L-seed 0.1 → 0.2

raw patch · 20 files changed

+535/−116 lines, 20 filesdep +random-shufflenew-component:exe:renderAsPNGPVP ok

version bump matches the API change (PVP)

Dependencies added: random-shuffle

API changes (from Hackage documentation)

Files

• L-seed.cabal +9/−2
• examples/hopper.txt +1/−1
• examples/segments.txt +4/−0
• src/Lseed/Constants.hs +6/−6
• src/Lseed/DB.hs +23/−8
• src/Lseed/Data.hs +35/−6
• src/Lseed/Data/Functions.hs +8/−0
• src/Lseed/Geometry.hs +30/−3
• src/Lseed/Grammar/Parse.hs +3/−2
• src/Lseed/LSystem.hs +7/−6
• src/Lseed/Logic.hs +23/−22
• src/Lseed/Mainloop.hs +19/−5
• src/Lseed/Renderer/Cairo.hs +210/−29
• src/Lseed/StipeInfo.hs +4/−3
• src/dbclient.hs +55/−6
• src/dbscorer.hs +27/−8
• src/fastScorer.hs +13/−6
• src/main.hs +12/−2
• src/renderAsPNG.hs +36/−0
• src/validate.hs +10/−1

@@ -1,5 +1,5 @@ Name:           L-seed-Version:        0.1+Version:        0.2 Cabal-Version:  >= 1.6 License:        BSD3 License-file:   LICENSE@@ -75,7 +75,8 @@   if flag(Database)      Build-Depends:         HDBC-odbc,-        HDBC+        HDBC,+        random-shuffle == 0.0.2     Exposed-Modules:         Lseed.DB @@ -85,6 +86,12 @@  Executable runGarden   Main-Is:        main.hs+  Hs-Source-Dirs: src/+  if ! flag(RendererCairo)+    Buildable:    False++Executable renderAsPNG+  Main-Is:        renderAsPNG.hs   Hs-Source-Dirs: src/   if ! flag(RendererCairo)     Buildable:    False

@@ -1,7 +1,7 @@ Rule "Start" WHEN Length <= 0 BRANCH AT 100% ANGLE = 30°, LENGTH = 0.5-BRANCH AT 100% ANGLE = -30°, LENGTH = 0.5+               ANGLE = -30°, LENGTH = 0.5  RULE "Links" WHEN Direction > 0 AND Direction < 140°

@@ -0,0 +1,4 @@+RULE Regel+WHEN TAG = ""+BRANCH ANGLE = 0°, LENGTH = 0.1+SET TAG = "done"

@@ -13,7 +13,7 @@ blossomSize :: Double blossomSize = 0.03 stipeWidth :: Double-stipeWidth  = 0.01+stipeWidth  = 0.005  -- | Light and growths interpolation frequency ticksPerDay :: Integer@@ -24,7 +24,7 @@ -- 1 means: Can grow one stipeLength during one day, when catching the sunlight -- with one branch of (projected) length screenwidth growthPerDayAndLight :: Double-growthPerDayAndLight = 15.0+growthPerDayAndLight = 40.0  -- | Plants up to this size get an boost in growths smallPlantBoostSize :: Double@@ -34,9 +34,9 @@ smallPlantBoostLength :: Double smallPlantBoostLength = 0.2 --- | Cost (in light units) per (length for maintaining the plant)^2, to limit the growth of the plants+-- | Cost (in light units) per (sum for all branches (length * distance), to limit the growth of the plants costPerLength :: Double-costPerLength = 0.0005+costPerLength = 0.0015  -- | Cost (in length growths equivalent) per seed to be grown seedGrowthCost :: Double@@ -44,11 +44,11 @@  -- | Branch translucency. Proportion of light that is let through by a plant lightFalloff :: Double-lightFalloff = 0.4+lightFalloff = 0.7  -- | Length of one day, in seconds dayLength :: Double-dayLength = 8.0+dayLength = 15  -- | ε eps = 1e-9

@@ -1,6 +1,7 @@ module Lseed.DB  	( DBCode(..) 	, getCodeToRun+	, getUpdatedCodeFromDB 	, addFinishedSeasonResults 	) where @@ -11,6 +12,7 @@  import Lseed.Data import Lseed.Data.Functions+import Data.Maybe  data DBCode = DBCode 	{ dbcUserName :: String@@ -21,17 +23,17 @@ 	} 	deriving (Show) -withLseedDB ::  (Connection -> IO t) -> IO t-withLseedDB what = do-	dn <- readFile "../db.conf"+withLseedDB :: FilePath -> (Connection -> IO t) -> IO t+withLseedDB conf what = do+	dn <- readFile conf 	conn <- connectODBC dn	 	res <- what conn 	disconnect conn 	return res -getCodeToRun ::  IO [DBCode]-getCodeToRun = withLseedDB $ \conn -> do-	let getCodeQuery = "SELECT plant.ID AS plantid, user.ID AS userid, code, plant.Name AS plantname, user.Name AS username from plant, user WHERE user.NextSeed = plant.ID;"+getCodeToRun :: FilePath -> IO [DBCode]+getCodeToRun conf = withLseedDB conf $ \conn -> do+	let getCodeQuery = "SELECT plant.ID AS plantid, user.ID AS userid, code, plant.Name AS plantname, user.Name AS username from plant, user WHERE plant.Valid AND user.NextSeed = plant.ID;" 	stmt <- prepare conn getCodeQuery 	execute stmt [] 	result <- fetchAllRowsMap' stmt@@ -42,10 +44,23 @@ 		       (fromSql (m ! "plantid")) 		       (fromSql (m ! "code")) -addFinishedSeasonResults garden = withLseedDB $ \conn -> do +getUpdatedCodeFromDB :: FilePath -> Integer -> IO (Maybe DBCode)+getUpdatedCodeFromDB conf userid = withLseedDB conf $ \conn -> do+	let query = "SELECT plant.ID AS plantid, user.ID AS userid, code, plant.Name AS plantname, user.Name AS username from plant, user WHERE plant.Valid AND user.NextSeed = plant.ID AND user.ID = ?;"+	stmt <- prepare conn query+	execute stmt [toSql userid]+	result <- fetchAllRowsMap' stmt+	return $ listToMaybe $ flip map result $ \m -> +		DBCode (fromSql (m ! "username"))+		       (fromSql (m ! "userid"))+		       (fromSql (m ! "plantname"))+		       (fromSql (m ! "plantid"))+		       (fromSql (m ! "code"))++addFinishedSeasonResults conf garden = withLseedDB conf $ \conn -> do  	let owernerscore = M.toList $ foldr go M.empty garden 		where go p = M.insertWith (+) (plantOwner p) (plantLength (phenotype p))-	run conn "INSERT INTO SEASON VALUES (NULL, False)" []+	run conn "INSERT INTO season VALUES (NULL, False)" [] 	stmt <- prepare conn "SELECT LAST_INSERT_ID()" 	execute stmt [] 	id <- (head . head) `fmap` fetchAllRows' stmt

@@ -7,6 +7,7 @@ import Control.Arrow (second) import Data.Monoid import System.Time (ClockTime)+import Data.Monoid  -- | User Tag type UserTag = String@@ -25,6 +26,7 @@ data Planted a = Planted 	{ plantPosition :: Double -- ^ Position in the garden, interval [0,1] 	, plantOwner    :: Integer -- ^ Id of the user that owns this plant+	, plantOwnerName:: String -- ^ Name of the owner of the plant 	, genome        :: GrammarFile -- ^ Lsystem in use 	, phenotype     :: Plant a -- ^ Actual current form of the plant 	}@@ -56,9 +58,10 @@ 	, siSubLight  :: Double 	, siAngle     :: Angle 	, siDirection :: Angle-	, siGrowth    :: GrowthState 	, siOffset    :: Double -- ^ Sideways position, relative to Plant origin 	, siHeight    :: Double -- ^ Vertical distance from bottom+	, siDistance  :: Double -- ^ Distance from root+	, siGrowth    :: GrowthState 	} 	deriving (Show) @@ -77,23 +80,37 @@ 	{ scGarden     :: AnnotatedGarden 	, scLightAngle :: Double 	, scTime       :: String+	, scMessage    :: Maybe String 	}  -- | Main loop observers data Observer = Observer {-	-- | Called once, before the main loop starts+	-- | Called once per season, before the main loop starts 	  obInit :: IO ()-	-- | Called once per tick, with the current tick number and the current-	-- state of the garden-	, obState :: Integer -> GrowingGarden -> IO ()+	-- | Called once per tick, with the current tick number corresponding+	-- light angle and the current state of the garden+	, obState :: Integer -> Angle -> GrowingGarden -> IO () 	-- | Also called once per tick, with a function that calculates the 	-- information that should be displayed given a point in time 	, obGrowingState :: (ClockTime -> ScreenContent) -> IO () 	-- | Called before the main loop quits, with the last state of the garden 	, obFinished :: GrowingGarden -> IO ()+	-- | Called once before program termination+	, obShutdown :: IO () 	}-nullObserver = Observer (return ()) (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ())+nullObserver = Observer (return ()) (\_ _ _ -> return ()) (\_ -> return ()) (\_ -> return ()) (return ()) +-- | Methods to get the initial garden and the updated code when a plant multiplies+data GardenSource = GardenSource {+	-- | Called at the beginning of a season, to aquire the garden+	  getGarden :: IO (Garden ())+	-- | Given a plant, returns the genome to be used for a seedling.+	, getUpdatedCode :: Planted () -> IO GrammarFile+	-- | Text to display on the screen+	, getScreenMessage :: IO (Maybe String)+	}+constGardenSource :: Garden () -> GardenSource+constGardenSource garden = GardenSource (return garden) (return . genome) (return Nothing)  -- | A complete grammar file type GrammarFile = [ GrammarRule ]@@ -125,6 +142,7 @@ 	| MatchSubLength 	| MatchDirection 	| MatchAngle+	| MatchDistance 	deriving (Read,Show)  data Cmp@@ -177,3 +195,14 @@  instance Traversable Planted where 	sequenceA planted = (\x -> planted { phenotype = x }) <$> sequenceA (phenotype planted)++instance Monoid Observer where+	mempty = nullObserver+	obs1 `mappend` obs2 = nullObserver {+		obInit = obInit obs1 >> obInit obs2,+		obState = \d g -> obState obs1 d g >> obState obs2 d g,+		obGrowingState = \f -> obGrowingState obs1 f >> obGrowingState obs2 f,+		obFinished = \g -> obFinished obs1 g >> obFinished obs2 g,+		obShutdown = obShutdown obs1 >> obShutdown obs2+		}+	

@@ -8,6 +8,14 @@ plantPieceLengths (Plant _ len ang ut ps) = 	Plant len len ang ut (map plantPieceLengths ps) +plantWeightedPieceLengths :: Double -> Plant a -> Plant Double+plantWeightedPieceLengths dist (Plant _ len ang ut ps) =+	Plant ((dist + 0.5*len) * len) len ang ut $+		map (plantWeightedPieceLengths (dist + len)) ps++weightedPlantLength :: Plant a -> Double+weightedPlantLength = plantTotalSum . plantWeightedPieceLengths 0+ plantLength :: Plant a -> Double plantLength = plantTotalSum . plantPieceLengths 

@@ -9,6 +9,7 @@ import Data.Maybe import Data.Ord import qualified Data.Map as M+import qualified Data.Foldable as F import Control.Monad hiding (mapM,forM) import Data.Traversable (mapM,forM) import Prelude hiding (mapM)@@ -128,7 +129,7 @@ 		  where -- Calculation based on the ray at the mid point 			mid = (x1 + x2) / 2 			-- Light intensity-			width = abs ((x2 - x1) * sin angle)+			width = abs ((x2 - x1) * sin angle) * lightIntensity 			(curlines, otherlines) = partition (\(l,_,_) -> lineAtRay mid l) 							   llines 			sorted = sortBy (\(l1,_,_) (l2,_,_) -> aboveFirst mid l1 l2)@@ -137,6 +138,8 @@ 			shine intensity (l,i,amount) = (intensity * lightFalloff,  						       (l,i,amount + (1-lightFalloff) * intensity)) +	lightIntensity = sin angle+ 	polygons = concatMap go intervals 	  where go (x1,x2) = if null sorted then [nothingPoly] else lightedPolys 		  where mid = (x1 + x2) / 2@@ -148,7 +151,7 @@                                           p2 = unprojectPoint x1 floor                                           p3 = unprojectPoint x2 floor                                           p4 = unprojectPoint x2 ceiling-                                      in (p1,p2,p3,p4,1)+                                      in (p1,p2,p3,p4, lightIntensity) 			firstPoly = let p1 = unprojectPoint x1 ceiling                                         p2 = unprojectPoint x1 (head sorted)                                         p3 = unprojectPoint x2 (head sorted)@@ -166,7 +169,7 @@                                              p4 = unprojectPoint x2 l1 					 in (p1,p2,p3,p4)) sorted (tail sorted) 			polys' = [firstPoly] ++ polys ++ [lastPoly]-			lightedPolys = snd $ mapAccumL shine 1 polys'+			lightedPolys = snd $ mapAccumL shine lightIntensity polys' 			shine intensity (p1,p2,p3,p4) = ( intensity * lightFalloff 							, (p1,p2,p3,p4,intensity)) @@ -187,3 +190,27 @@ 	-- Undo the STRefs 	mapM (mapM (\(d,stRef) -> (,) d <$> readSTRef stRef)) gardenWithPointers +-- | Slightly shifts angles +windy s = mapGarden (mapPlanted (go 0))+  where go d p = let a' = pAngle p + +			  windFactor * offset * pLength p * cos (d + pAngle p)+                     d' = (d+a')+		 in p { pAngle = a'+		      , pData = (pData p) { siDirection = d' }+		      , pBranches = map (go d') (pBranches p)+		      }+        offset = sin (windChangeFrequency * s)+	windFactor = 0.015+	windChangeFrequency = 1++-- | For a Garden, calculates the maximum size to the left, to the right, and+-- maximum height+gardenOffset :: AnnotatedGarden -> (Double, Double, Double)+gardenOffset = pad . F.foldr max3 (0.5,0.5,0) . map (F.foldr max3 (0.5,0.5,0) . go )+  where go planted = fmap (\si -> ( siOffset si + plantPosition planted+                                  , siOffset si + plantPosition planted +				  , siHeight si+				  )+			   ) planted+        max3 (a,b,c) (a',b',c') = (min a a', max b b', max c c')+	pad (a,b,c) = (a-0.02,b+0.02,c+0.02)

@@ -11,7 +11,7 @@ -- The lexer lexer       = P.makeTokenParser $ javaStyle 	{ P.reservedNames = ["RULE", "WHEN", "SET", "Tag", "Light", "Branch", "At",-			     "Length", "Light", "Sublength", "Sublight", "Direction", "Angle",+			     "Length", "Light", "Sublength", "Sublight", "Direction", "Angle", "Distance", 			     "BY", "TO", "PRIORITY", "WEIGHT", "Blossom"] 	} @@ -147,6 +147,7 @@ 		, ("SUBLIGHT", MatchSubLight) 		, ("ANGLE", MatchAngle) 		, ("DIRECTION", MatchDirection)+		, ("DISTANCE", MatchDistance) 		]  pCmp = @@ -167,4 +168,4 @@ 		     )  <|> float 	    (deg >> return (value / 180 * pi)) <|> return value -deg = reservedOp "\194\176"+deg = reservedOp "\194\176" <|> reservedOp "\176"

@@ -9,10 +9,10 @@ import Data.List  applyLSystem :: RandomGen g => g -> GrammarFile -> AnnotatedPlant -> GrowingPlant-applyLSystem rgen rules plant = let (maxPrio, result) = go maxPrio plant -- great use of lazyness here+applyLSystem rgen rules plant = let (maxPrio, result) = go rgen maxPrio plant -- great use of lazyness here                                 in  result-  where go :: Int -> AnnotatedPlant -> (Int, GrowingPlant)- 	go maxPrio p@(Plant { pUserTag = oldUt+  where go :: RandomGen g => g -> Int -> AnnotatedPlant -> (Int, GrowingPlant)+ 	go rgen maxPrio p@(Plant { pUserTag = oldUt 		            , pLength = oldSize 		            , pAngle = ang 		            , pBranches = ps@@ -26,7 +26,7 @@ 		            filter ((>= maxPrio) . fst) $ 			    choices 		       of []       -> noAction-		          choices' -> chooseWeighted rgen choices'+		          choices' -> chooseWeighted rgen' choices' 		     ) 	  where applyRule :: GrammarRule -> (Int, (Int, GrowingPlant)) 	  	applyRule r = (grPriority r, (grWeight r, applyAction (grAction r)))@@ -55,8 +55,8 @@ 			    } 	 		noAction = p { pData = NoGrowth, pBranches = ps' }-		-		(subPrios, ps') = unzip $ map (go maxPrio) ps+		(rgen':rgens) = unfoldr (Just . split) rgen+		(subPrios, ps') = unzip $ zipWith (\r -> go r maxPrio) rgens ps  	-- Some general checks to rule out unwanted rules 	isValid :: GrowingPlant -> Bool@@ -86,6 +86,7 @@ 	getMatchable MatchSubLight  = siSubLight si 	getMatchable MatchDirection = siDirection si 	getMatchable MatchAngle     = siAngle si+	getMatchable MatchDistance  = siDistance si  	doCompare LE = (<=) 	doCompare Less = (<)

@@ -38,40 +38,38 @@                 EnlargingTo l2   -> l2 - l1                 GrowingSeed done -> (1-done) * seedGrowthCost  +-- | For a GrowingGarden, calculates the current amount of light and then+-- advance the growth. This ought to be called after applyGenome growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)-growGarden angle rgen garden = sequence $ zipWith growPlanted garden' lightings-  where lightings = map (plantTotalSum . fmap snd . phenotype) $ lightenGarden angle garden'-	garden' = applyGenome angle rgen garden+growGarden angle rgen garden = sequence $ zipWith growPlanted garden totalLight+  where totalLight = map (plantTotalSum . fmap snd . phenotype) $ lightenGarden angle garden  -- | For all Growing plants that are done, find out the next step--- This involves creating new plants if some are done-applyGenome :: (RandomGen g) => Angle -> g -> GrowingGarden -> GrowingGarden -applyGenome angle rgen garden = concat $ zipWith applyGenome' rgens aGarden+-- If new plants are to be created, these are returned via their position, next+-- to their parent plant.+applyGenome :: (RandomGen g) => Angle -> g -> GrowingGarden -> [(GrowingPlanted,[Double])]+applyGenome angle rgen garden = zipWith applyGenome' rgens aGarden   where rgens = unfoldr (Just . split) rgen 	aGarden = annotateGarden angle garden 	applyGenome' rgen planted = 		if   remainingGrowth siGrowth planted < eps-		then planted { phenotype = applyLSystem rgen+		then ( planted { phenotype = applyLSystem rgen 							(genome planted) 							(phenotype planted) 		     -- here, we throw away the last eps of growth. Is that a problem?-			     } :-		     collectSeeds rgen planted-	 	else [fmap siGrowth planted]-	collectSeeds :: (RandomGen g) => g -> AnnotatedPlanted -> GrowingGarden+			     }+		     , collectSeeds rgen planted)+	 	else (fmap siGrowth planted,[])+	collectSeeds :: (RandomGen g) => g -> AnnotatedPlanted -> [Double] 	collectSeeds rgen planted = snd $ F.foldr go (rgen,[]) planted-	  where go si (rgen,newPlants) = case siGrowth si of+	  where go si (rgen,seedPoss) = case siGrowth si of 	  		GrowingSeed _ -> 				let spread = ( - siHeight si + siOffset si 				             ,   siHeight si + siOffset si 					     ) 				    (posDelta,rgen') = randomR spread rgen-				    p = Planted (plantPosition planted + posDelta)-			                          (plantOwner planted)-						  (genome planted)-						  (fmap (const NoGrowth) inititalPlant)-				in (rgen, p:newPlants)-			_ -> (rgen,newPlants)+				in (rgen', posDelta:seedPoss)+			_ -> (rgen,seedPoss)  -- | Applies an L-System to a Plant, putting the new length in the additional --   information field@@ -79,10 +77,10 @@ growPlanted planted light =  	let remainingLength = remainingGrowth id planted 	in  if remainingLength > eps-            then let sizeOfPlant = plantLength (phenotype planted)-                     lightAvailable = light - costPerLength * sizeOfPlant^2-		     lowerBound = if sizeOfPlant < smallPlantBoostSize-		                  then smallPlantBoostLength+            then let sizeOfPlant = weightedPlantLength (phenotype planted)+                     lightAvailable = light - costPerLength * sizeOfPlant+		     lowerBound = if sizeOfPlant < smallPlantBoostSize && not (doesBlossom (phenotype planted))+		                  then (1 - sizeOfPlant / smallPlantBoostSize) * smallPlantBoostLength 				  else 0                      allowedGrowths = max lowerBound $                                       (growthPerDayAndLight * lightAvailable) /@@ -91,6 +89,9 @@ 		     growthFraction = growthThisTick / remainingLength  		 in \tickDiff -> applyGrowth (tickDiff * growthFraction) planted 	    else const planted++doesBlossom (Plant { pData = (GrowingSeed _) }) = True+doesBlossom (Plant { pBranches = ps }) = any doesBlossom ps  -- | Applies Growth at given fraction, leaving the target length in place applyGrowth :: Double -> GrowingPlanted -> GrowingPlanted

@@ -17,10 +17,11 @@ -- observer informed about any changes. lseedMainLoop :: Bool -- ^ Run in real time, e.g. call 'threadDelay' 	-> Observer -- ^ Who to notify about the state of the game+	-> GardenSource -- ^ Where do get the plant code from 	-> Integer -- ^ Maximum days to run-	-> Garden () -- ^ Initial garden state 	-> IO ()-lseedMainLoop rt obs maxDays garden = do+lseedMainLoop rt obs gardenSource maxDays = do+	garden <- getGarden gardenSource 	obInit obs 	let nextDay (tick, garden) =  		let (day, tickOfDay) = tick `divMod` ticksPerDay in@@ -32,10 +33,23 @@ 		rgen <- newStdGen 		let sampleAngle = lightAngle $ (fromIntegral tickOfDay + 0.5) /                                                 fromIntegral ticksPerDay-		let growingGarden = growGarden sampleAngle rgen garden+		let newGardenWithSeeds = applyGenome sampleAngle rgen garden+		rgen <- newStdGen+		newGarden <- fmap concat $ forM newGardenWithSeeds $+			\(parent,seedPoss) -> fmap (parent:) $ forM seedPoss $ \seedPos -> do+				genome <- getUpdatedCode gardenSource (fmap (const ()) parent)+				return $ Planted (plantPosition parent + seedPos)+				                 (plantOwner parent)+				                 (plantOwnerName parent)+				         	 genome+				         	 (fmap (const NoGrowth) inititalPlant) -		obState obs tick garden+		let growingGarden = growGarden sampleAngle rgen newGarden+++		obState obs tick sampleAngle garden 		when rt $ do+			text <- getScreenMessage gardenSource  			obGrowingState obs $ \later ->  				let tickDiff = timeSpanFraction tickLength tickStart later 				    dayDiff = (fromIntegral tickOfDay + tickDiff) /@@ -44,7 +58,7 @@ 				    visualizeAngle = lightAngle dayDiff 				    gardenNow = annotateGarden visualizeAngle $  				                growingGarden tickDiff-				in ScreenContent gardenNow visualizeAngle timeInfo+				in ScreenContent gardenNow visualizeAngle timeInfo text  			threadDelay (round (tickLength * 1000 * 1000)) 		nextDay (succ tick, growingGarden 1)

@@ -10,15 +10,76 @@ import Lseed.Data.Functions import Lseed.Constants import Lseed.Geometry+import Lseed.StipeInfo import Text.Printf import System.Time+import qualified Data.Map as M+import Data.List+import Data.Ord+import System.Time +colors :: [ (Double, Double, Double) ]+colors = cycle $ [ (r,g,b) | r <- [0.0,0.4], b <- [0.0, 0.4], g <- [1.0,0.6,0.8]]++pngDailyObserver :: FilePath -> Observer+pngDailyObserver filename = nullObserver {+	obGrowingState = \scGen -> do+		ScreenContent garden angle timeInfo mbMessage <-+			scGen `fmap` getClockTime +		let (w,h) = (800,600)+		let h' = fromIntegral h / fromIntegral w++		let (xLeft,xRight,xHeight) = gardenOffset garden+		    scaleY = h'*(1-groundLevel)/xHeight+		    scaleX = 1/(max 1 xRight - min 0 xLeft)+		    scaleXY = minimum [1, scaleX, scaleY]+		    shiftX = min 0 xLeft ++		withImageSurface FormatRGB24 w h $ \sur -> do+			renderWith sur $ do+				-- Set up coordinates+				translate 0 (fromIntegral h)+				scale 1 (-1)+				scale (fromIntegral w) (fromIntegral w)+				translate 0 groundLevel+				setLineWidth stipeWidth++				preserve $ do+					scale scaleXY scaleXY+					translate (-shiftX) 0+					render angle garden++				maybe (return ()) (renderMessage angle h') mbMessage+				renderTimeInfo timeInfo+				renderStats h' garden+			surfaceWriteToPNG sur filename+	}++pngObserver :: IO Observer+pngObserver = return $ nullObserver {+	obFinished = \garden -> do+		let (w,h) = (400,400)+		withImageSurface FormatRGB24 w h $ \sur -> do+			renderWith sur $ do+				-- Set up coordinates+				translate 0 (fromIntegral h)+				scale 1 (-1)+				scale (fromIntegral w) (fromIntegral w)+				translate (-0.5) 0+				scale 2 2+				translate 0 groundLevel+				setLineWidth stipeWidth++				render (pi/3) (annotateGarden (pi/3) garden)+			surfaceWriteToPNG sur "/dev/fd/1"+	}+ cairoObserver :: IO Observer cairoObserver = do 	initGUI  	-- global renderer state-	currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet"))+	currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet" Nothing))  	-- widgets 	canvas <- drawingAreaNew@@ -36,20 +97,33 @@  	-- The actual drawing function 	onExpose canvas$ \e -> do scGen <- readIORef currentGardenRef-				  ScreenContent garden angle timeInfo <-+				  ScreenContent garden angle timeInfo mbMessage <- 						scGen `fmap` getClockTime +				  s <- clockTimeToDouble `fmap` getClockTime 				  dwin <- widgetGetDrawWindow canvas 				  (w,h) <- drawableGetSize dwin+				  let h' = fromIntegral h / fromIntegral w++				  let (xLeft,xRight,xHeight) = gardenOffset garden+				      scaleY = h'*(1-groundLevel)/xHeight+				      scaleX = 1/(max 1 xRight - min 0 xLeft)+				      scaleXY = minimum [1, scaleX, scaleY]+				      shiftX = min 0 xLeft + 				  renderWithDrawable dwin $ do 					-- Set up coordinates 					translate 0 (fromIntegral h) 					scale 1 (-1)-					scale (fromIntegral w) (fromIntegral (w))+					scale (fromIntegral w) (fromIntegral w) 					translate 0 groundLevel-					setLineWidth stipeWidth -					render angle garden+					preserve $ do+						scale scaleXY scaleXY+						translate (-shiftX) 0+						render angle (windy s garden)+					maybe (return ()) (renderMessage angle h') mbMessage 					renderTimeInfo timeInfo+					renderStats h' garden 		                  return True  	timeoutAdd (widgetQueueDraw canvas >> return True) 20@@ -58,16 +132,15 @@ 		{ obGrowingState = \scGen -> do 			writeIORef currentGardenRef scGen 			widgetQueueDraw canvas-		, obFinished = \_ ->-			mainQuit+		, obShutdown = mainQuit 		}  render :: Double -> AnnotatedGarden -> Render () render angle garden = do 	-- TODO the following can be optimized to run allKindsOfStuffWithAngle only once. 	-- by running it here. This needs modification to lightenGarden and mapLine-	renderGround-	mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))+	renderSky angle+	--mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))  	--mapM_ renderLightedLine (lightenLines angle (gardenToLines garden)) 	--mapM_ renderLine (gardenToLines garden)@@ -75,25 +148,68 @@  	mapM_ renderPlanted garden -	renderInfo angle garden+	renderGround +	--renderInfo garden+ renderPlanted :: AnnotatedPlanted -> Render () renderPlanted planted = preserve $ do 	translate (plantPosition planted) 0-	setSourceRGB 0 0.8 0 	setLineCap LineCapRound-	renderPlant (phenotype planted)+	let c = colors !! fromIntegral (plantOwner planted)+	renderPlant (Just (renderFlag (take 10 (plantOwnerName planted))))+	            c (phenotype planted) -renderPlant :: AnnotatedPlant -> Render ()	-renderPlant (Plant si len ang ut ps) = preserve $ do-	rotate ang-	setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt (siSubLength si)))+renderFlag :: String -> Render ()+renderFlag text = preserve $ do+	scale 1 (-1)+	setFontSize (groundLevel/2)+	ext <- textExtents text++	preserve $ do+		translate (stipeWidth) (groundLevel/2)+		rectangle 0+			  (textExtentsYbearing ext + groundLevel/2)+			  (textExtentsXadvance ext)+			  (-textExtentsYbearing ext - groundLevel/2 - groundLevel/2)+		setSourceRGB 1 1 1+		fill++		setSourceRGB 0 0 0+		showText text++	setLineWidth (groundLevel/10)+	setSourceRGB 0 0 0 	moveTo 0 0-	lineTo 0 (len * stipeLength)-	setSourceRGB 0 0.8 0+	lineTo (stipeWidth + textExtentsXadvance ext) 0 	stroke+++-- | Renders a plant, or part of a plant, with a given colour. If the Render+-- argument is given, it is drawn at the end of the plant, if there are no+-- branches, or passed to exactly one branch.+renderPlant :: (Maybe (Render ())) -> (Double,Double,Double) -> AnnotatedPlant -> Render ()	+renderPlant leaveR color@(r,g,b) (Plant si len ang ut ps) = preserve $ do+	rotate ang+	withLinearPattern 0 0 0 (len * stipeLength) $ \pat -> do+		let darkenByBegin = 1/(1 + (siSubLength si)/15)+		let darkenByEnd = 1/(1 + (siSubLength si - siLength si)/15)+		patternAddColorStopRGB pat 0+			(darkenByBegin*r) (darkenByBegin*g) (darkenByBegin*b) +		patternAddColorStopRGB pat 1+			(darkenByEnd*r) (darkenByEnd*g) (darkenByEnd*b) +		setSource pat+		--setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt (siSubLength si)))+		setLineWidth stipeWidth+		moveTo 0 0+		lineTo 0 (len * stipeLength)+		stroke 	translate 0 (len * stipeLength)-	mapM_ renderPlant ps+	if null ps+	 then fromMaybe (return ()) leaveR+	 else sequence_ $ zipWith (\r p -> renderPlant r color p)+	                         (leaveR : repeat Nothing)+				 ps 	case siGrowth si of 	  GrowingSeed done -> do 	  	setSourceRGB 1 1 0@@ -152,11 +268,14 @@ 		setSourceRGB 0 0 intensity 		fill -renderInfo angle garden = do+renderInfo garden = do 	forM_ garden $ \planted -> do 		let x = plantPosition planted+		{- 		let text1 = printf "Light: %.2f" $ 				siSubLight . pData . phenotype $ planted+		-}+		let text1 = plantOwnerName planted 		let text2 = printf "Size: %.2f" $ 				siSubLength . pData . phenotype $ planted 		preserve $ do@@ -164,28 +283,90 @@ 			setSourceRGB 0 0 0 			setFontSize (groundLevel/2) 			moveTo x (0.9*groundLevel)-			showText text1-			moveTo x (0.5*groundLevel) 			showText text2+			moveTo x (0.5*groundLevel)+			showText text1 -renderTimeInfo timeStr = do-	preserve $ do+renderTimeInfo timeStr = preserve $ do 		scale 1 (-1) 		setSourceRGB 0 0 0 		setFontSize (groundLevel/2) 		moveTo 0 (0.5*groundLevel) 		showText timeStr +renderMessage angle h text = preserve $ do+		scale 1 (-1)+		setSourceRGB 0 0 0+		translate (0.5) (2.5*groundLevel - h) +		setFontSize (groundLevel)++		let bullet = " * "+		ext <- textExtents (text ++ bullet)++		rectangle (-0.25)+			  (textExtentsYbearing ext + groundLevel)+			  (0.5)+			  (-textExtentsYbearing ext - groundLevel - groundLevel)+		setSourceRGB 1 1 1+		fillPreserve+		clip++		let textWidth = textExtentsXbearing ext + textExtentsXadvance ext+		    textCount = ceiling $ 0.5/textWidth+		    scroll = 3 * (angle + pi/2)/(2*pi)+		    scroll' = scroll - fromIntegral (floor scroll)+		    scrollDist = fromIntegral textCount * textWidth+		translate (-0.25 - scroll' * scrollDist) 0++		setSourceRGB 0 0 0+		showText $ intercalate bullet $ replicate (2*textCount) text++renderStats h garden = do+	let owernerscore = foldr (\p -> M.insertWith (+) (plantOwnerName p) (plantLength (phenotype p))) M.empty garden++	setFontSize (groundLevel/2)+	let texts = map (\(n,s) -> printf "%s: %.1f" (take 20 n) s) $+			reverse $+			sortBy (comparing snd) $+		        (M.toList owernerscore)+	unless (null texts) $ preserve $ do+		scale 1 (-1)+		translate 0 (1.5*groundLevel - h) +		+		textE <- mapM (\t -> (,) t `fmap` textExtents t) texts++		let totalHeight = groundLevel/4 + fromIntegral (length texts) * (1.0*groundLevel/2)+		let totalWidth = maximum $ map (\x -> textExtentsXadvance (snd x)) textE++		rectangle 0+			  (-1.0*groundLevel/2)+			  totalWidth+			  (totalHeight)+		setSourceRGB 1 1 1+		fill++		forM_ texts $ \text -> do+			setSourceRGB 0 0 0+			moveTo 0 0+			showText text+			translate 0 (1.0*groundLevel/2)++++renderSky :: Angle -> Render ()+renderSky angle = do+	-- Clear Background+	setSourceRGB  0 0 (sin angle)+	paint+ renderGround :: Render () renderGround = do-	-- Clear Background-	rectangle 0 0 1 100-	setSourceRGB  0 0 1-	fill 	setSourceRGB (140/255) (80/255) (21/255)-	rectangle 0 0 1 (-groundLevel)+	rectangle (-1) 0 3 (-(1+groundLevel))         fill  -- | Wrapper that calls 'save' and 'restore' before and after the argument preserve :: Render () -> Render () preserve r = save >> r >> restore++clockTimeToDouble (TOD s p) = fromIntegral s + fromIntegral p/(1000*1000*1000*1000)

@@ -9,8 +9,8 @@ annotateGarden angle  = map (mapPlanted annotatePlant) . lightenGarden angle  annotatePlant :: Plant (GrowthState, Double) -> AnnotatedPlant-annotatePlant = go 0 0 0-  where go d o h (Plant (gs, light) len ang ut ps) = Plant (StipeInfo+annotatePlant = go 0 0 0 0+  where go d o h dist (Plant (gs, light) len ang ut ps) = Plant (StipeInfo 		{ siLength    = len 		, siSubLength = len + sum (map (siSubLength . pData) ps') 		, siLight     = light@@ -20,8 +20,9 @@ 		, siGrowth    = gs 		, siOffset    = o' 		, siHeight    = h'+		, siDistance  = dist 		}) len ang ut ps'-	  where ps' = map (go d' o' h') ps+	  where ps' = map (go d' o' h' (dist+len)) ps 	  	d' = (d+ang) 		o' = o - len * stipeLength * sin d' 		h' = h + len * stipeLength * cos d'

@@ -7,13 +7,62 @@ import Control.Applicative import Control.Monad import Text.Printf+import System.Environment+import Data.Monoid+import Data.Maybe+import System.Random+import System.Random.Shuffle (shuffle') -getGarden = spread <$> map (either (error.show) id . parseGrammar "" . dbcCode)-		   <$> getCodeToRun-  where spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g inititalPlant) gs [0..]+randomize l = shuffle' l (length l) <$> newStdGen++getDBGarden conf = do+	dbc <- getCodeToRun conf+	gs <- randomize $ mapMaybe compileDBCode dbc+	return $ spread gs+  where spread gs = zipWith (\(u,n,g) p ->+ 		 Planted ((fromIntegral p + 0.5) / l)+			 u+			 n+			 g+			 inititalPlant+		) gs [0..] 	  where l = fromIntegral (length gs) +compileDBCode dbc =+	case  parseGrammar "" (dbcCode dbc) of+		Left err          -> Nothing+		Right grammarFile -> Just (dbcUserID dbc, dbcUserName dbc, grammarFile)++dbc2genome = either (const Nothing) Just . parseGrammar "" . dbcCode++getDBUpdate conf planted = fromMaybe (genome planted) <$>+		maybe Nothing dbc2genome <$>+		getUpdatedCodeFromDB conf (plantOwner planted)++scoringObs conf = nullObserver {+	obFinished = \garden -> do+		forM_ garden $ \planted -> do+			printf "Plant from %d at %.4f: Total size %.4f\n"+				(plantOwner planted)+				(plantPosition planted)+				(plantLength (phenotype planted))+		addFinishedSeasonResults conf garden+	}++nothingNull "" = Nothing+nothingNull s  = Just s+ main = do-	garden <- getGarden-	obs <- cairoObserver-	lseedMainLoop True obs 1 garden+	args <- getArgs+	case args of+	  [conf, pngfile, textfile] -> do+		obs <- cairoObserver+		let obs' = obs `mappend` scoringObs conf `mappend` pngDailyObserver pngfile+		let gs = GardenSource (getDBGarden conf)+				      (getDBUpdate conf)+                                      (nothingNull <$> readFile textfile) +		lseedMainLoop True obs' gs 40+		obShutdown obs'+	  _ -> do+		putStrLn "L-Seed DB client application."+		putStrLn "Please pass DB configuration file, a PNG file to write, and a text file with messages on the command line."

@@ -6,27 +6,46 @@ import Control.Applicative import Control.Monad import Text.Printf+import System.Environment -getGarden = spread <$> map compileDBCode-		   <$> getCodeToRun-  where spread gs = zipWith (\(u,g) p -> Planted ((fromIntegral p + 0.5) / l) u g inititalPlant) gs [0..]+getDBGarden conf = spread <$> map compileDBCode <$> getCodeToRun conf+  where spread gs = zipWith (\(u,n,g) p ->+ 		 Planted ((fromIntegral p + 0.5) / l)+			 u+			 n+			 g+			 inititalPlant+		) gs [0..] 	  where l = fromIntegral (length gs)  compileDBCode dbc = 	case  parseGrammar "" (dbcCode dbc) of 		Left err          -> error (show err)-		Right grammarFile -> (dbcUserID dbc, grammarFile)+		Right grammarFile -> (dbcUserID dbc, dbcUserName dbc, grammarFile) -scoringObs = nullObserver {+dbc2genome = either (error.show) id . parseGrammar "" . dbcCode++getDBUpdate conf planted = maybe (genome planted) dbc2genome <$>+                      getUpdatedCodeFromDB conf (plantOwner planted)++scoringObs conf = nullObserver { 	obFinished = \garden -> do 		forM_ garden $ \planted -> do 			printf "Plant from %d at %.4f: Total size %.4f\n" 				(plantOwner planted) 				(plantPosition planted) 				(plantLength (phenotype planted))-		addFinishedSeasonResults garden+		addFinishedSeasonResults conf garden 	}  main = do-	garden <- getGarden-	lseedMainLoop False scoringObs 10 garden+	args <- getArgs+	case args of+	  [conf] -> do+		lseedMainLoop False+			      (scoringObs conf)+			      (GardenSource (getDBGarden conf) (getDBUpdate conf) (return Nothing))+			      30+	  _ -> do+		putStrLn "L-Seed DB client application."+		putStrLn "Please pass DB configuration file on the command line."

@@ -25,21 +25,28 @@ 	  else	do 		genomes <- mapM parseFile args 		doit (spread genomes)-  where	spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g inititalPlant) gs [0..]+  where	spread gs = zipWith (\g p ->+  		Planted ((fromIntegral p + 0.5) / l)+		        p+			(show p)+			g+			inititalPlant+		) gs [0..] 	  where l = fromIntegral (length gs) 	        scoringObs = nullObserver { 	obFinished = \garden -> do 		forM_ garden $ \planted -> do-			printf "Plant from %d at %.4f: Total size %.4f\n"+			printf "Plant from %s (%d) at %.4f: Total size %.4f\n"+				(plantOwnerName planted) 				(plantOwner planted) 				(plantPosition planted) 				(plantLength (phenotype planted))-		let owernerscore = foldr (\p -> M.insertWith (+) (plantOwner p) (plantLength (phenotype p))) M.empty garden-		forM_ (M.toList owernerscore) $ \(o,s) -> -			printf "Sum for %d: %.4f\n" o s+		let owernerscore = foldr (\p -> M.insertWith (+) (plantOwner p, plantOwnerName p)(plantLength (phenotype p))) M.empty garden+		forM_ (M.toList owernerscore) $ \((o,n),s) -> +			printf "Sum for %s (%d): %.4f\n" n o s 	}  main = readArgs $ \garden -> do-	lseedMainLoop False scoringObs 30 garden+	lseedMainLoop False scoringObs (constGardenSource garden) 30

@@ -24,9 +24,19 @@ 	  else	do 		genomes <- mapM parseFile args 		doit (spread genomes)-  where	spread gs = zipWith (\g p -> Planted ((fromIntegral p + 0.5) / l) p g inititalPlant) gs [0..]+  where	spread gs = zipWith (\g p ->+  		Planted ((fromIntegral p + 0.5) / l)+		        p+			("Player " ++ (show p))+			g+			inititalPlant+		) gs [0..] 	  where l = fromIntegral (length gs) 		 main = readArgs $ \garden -> do 	obs <- cairoObserver-	lseedMainLoop True obs 200 garden+	lseedMainLoop True+	              obs+		      ((constGardenSource garden) { getScreenMessage = (return (Just "bla blubb"))})+		      30+	obShutdown obs

@@ -0,0 +1,36 @@+import Lseed.Data+import Lseed.Data.Functions+import Lseed.Grammar.Parse+import Lseed.Constants+import Lseed.Mainloop+import Control.Monad+import Debug.Trace+import System.Environment+import System.Time+import System.Random+import Lseed.Renderer.Cairo+import Data.Maybe+import Graphics.Rendering.Cairo++main = do+	args <- getArgs+	let name = fromMaybe "Some Plant" $ listToMaybe args++	file <- getContents+	case parseGrammar name file of+	 Left _ -> do +		let (w,h) = (300,300)+                withImageSurface FormatRGB24 w h $ \sur -> do+                        renderWith sur $ do+				setSourceRGB 1 1 1+				paint++                                translate 0 (0.5* fromIntegral h)+				setFontSize (0.1* fromIntegral h)+				setSourceRGB 0 0 0+				showText "Syntax Error"+                        surfaceWriteToPNG sur "/dev/fd/1"+	 Right genome -> do+		let garden = [Planted 0.5 0 name genome inititalPlant]+		obs <- pngObserver+		lseedMainLoop False obs (constGardenSource garden) 10

@@ -11,6 +11,7 @@ import Text.Parsec.Pos import Lseed.Grammar.Parse import Text.JSON+import System.Exit  valid = encode $ makeObj [ ("valid", showJSON True) ] @@ -24,4 +25,12 @@                     errorMessages $ error) 	] -main = interact $ either invalid (const valid) . parseGrammar "stdin"+main = do+	file <- getContents+	case (parseGrammar "stdin" file) of+		Left err -> do+			putStr (invalid err)+			exitWith (ExitFailure 1)+		Right _ -> do+			putStr valid+			exitWith ExitSuccess