packages feed

L-seed (empty) → 0.1

raw patch · 30 files changed

+1653/−0 lines, 30 filesdep +HDBCdep +HDBC-odbcdep +basesetup-changed

Dependencies added: HDBC, HDBC-odbc, base, cairo, containers, gtk, json, mtl, old-time, parsec, random

Files

+ L-seed.cabal view
@@ -0,0 +1,117 @@+Name:           L-seed+Version:        0.1+Cabal-Version:  >= 1.6+License:        BSD3+License-file:   LICENSE+Author:         Joachim Breitner <mail@joachim-breitner.de>+Maintainer:     Joachim Breitner <mail@joachim-breitner.de>+Synopsis:       Plant growing programming game+Description:+        The players of this game will write code (the „genome“) that describes+        how plants (the biological type, not the industrial) will grow. The+        plants will grow simultaneously on the screen (the „garden“), will+        compete for light and will multiply. The players can not change the+        code of a growing plant, but they do have the chance to update their+        code for the next generation -- when a plant drops a seed, it will run+        the newest code. All in all, the game aims to be slowly paced and+        relaxing, something to just watch for a while and something that does+        not need constant attention by the players.+        .+        This package contains the haskell programs, i.e. the game simulation+        with the visual display. It can be used to locally test the plants.+Homepage:       http://www.entropia.de/wiki/L-seed+Category:       Game+Build-Type:     Simple+Extra-source-files:+        examples/*.txt+        db.conf-example++Flag Database+  Description:+        Builds binaries that are required to interact with the SQL database.+        This is not needed when you just want to test the game locally.+  Default: False++Flag WebTools+  Description:+        Builds binaries that are required for the web interface.+        This is not needed when you just want to test the game locally.+  Default: False++Flag RendererCairo+  Description:+        This builds the cairo renderer. This will ususally be needed, unless+        you build the WebTools only.+  Default: True++Library+  Hs-Source-Dirs: src/+  Exposed-Modules:+        Lseed.Constants		+        Lseed.Data		+        Lseed.Data.Functions		+        Lseed.Geometry		+        Lseed.Geometry.Generator		+        Lseed.Grammar.Parse		+        Lseed.LSystem		+        Lseed.Logic		+        Lseed.Mainloop		+        Lseed.StipeInfo		+  Build-Depends:+        base    == 3.*,+        random,+        containers,+        old-time,+        mtl,+        parsec == 3.*++  if flag(RendererCairo)+    Exposed-Modules:+        Lseed.Renderer.Cairo		+    Build-Depends:+        cairo == 0.10.*,+        gtk == 0.10.*++  if flag(Database) +    Build-Depends:+        HDBC-odbc,+        HDBC+    Exposed-Modules:+        Lseed.DB++  if flag(WebTools) +    Build-Depends:+        json == 0.4.*++Executable runGarden+  Main-Is:        main.hs+  Hs-Source-Dirs: src/+  if ! flag(RendererCairo)+    Buildable:    False++Executable validate+  Main-Is:        validate.hs+  Hs-Source-Dirs: src/+  if ! flag(WebTools)+    Buildable:    False++Executable fastScorer+  Main-Is:        fastScorer.hs+  Hs-Source-Dirs: src/++Executable dbclient+  Main-Is:        dbclient.hs+  Hs-Source-Dirs: src/+  if ! flag(Database) || ! flag(RendererCairo)+    Buildable:    False++Executable dbscorer+  Main-Is:        dbscorer.hs+  Hs-Source-Dirs: src/+  if ! flag(Database)+    Buildable:    False++Source-repository head+  Type:     git+  Location: git://git.nomeata.de/L-seed.git+
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Joachim Breitner, 2009++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ db.conf-example view
@@ -0,0 +1,1 @@+Driver=MySQL;Server=svenhecht.is-a-geek.org;Database=lseed;Uid=lseedbackend;Pwd=XXX;Port=3306;
+ examples/christmasTree.txt view
@@ -0,0 +1,37 @@+RULE "Start"+WHEN Length <= 0+GROW BY 1+SET TAG = "Root1"++RULE "Story 1"+WHEN TAG = "Root1"+// No Percentage means 100%+BRANCH ANGLE = 70°, LENGTH = 2, Tag = ""+       ANGLE = -70°, LENGTH = 2, Tag = ""+       ANGLE = 0°, LENGTH = 1, TAG = "Root2"+SET TAG = ""++RULE "Story 2"+WHEN TAG = "Root2"+BRANCH AT 100% ANGLE = 70°, LENGTH = 1.5, Tag = ""+               ANGLE = -70°, LENGTH = 1.5, Tag = ""+               ANGLE = 0°, LENGTH = 1, TAG = "Root3"+SET TAG = ""++RULE "Story 3"+WHEN TAG = "Root3"+BRANCH AT 100% ANGLE = 70°, LENGTH = 1, Tag = ""+               ANGLE = -70°, LENGTH = 1, Tag = ""+               ANGLE = 0°, LENGTH = 1, TAG = "Root4"+SET TAG = ""++RULE "Story 4"+WHEN TAG = "Root4"+BRANCH AT 100% ANGLE = 70°, LENGTH = 0.5, Tag = ""+               ANGLE = -70°, LENGTH = 0.5, Tag = ""+               ANGLE = 0°, LENGTH = 0.5, Tag = "Tip"+SET TAG = ""++RULE "Star"+WHEN TAG = "Tip"+Blossom
+ examples/fiveFingered.txt view
@@ -0,0 +1,11 @@+RULE "Large enough"+WHEN length < 2+GROW TO 2++RULE Forking+WHEN length >= 2+BRANCH AT 100% ANGLE = -60°, LENGTH = 1+               ANGLE = -30°, LENGTH = 1+               ANGLE = 0°, LENGTH = 1+               ANGLE = 30°, LENGTH = 1+               ANGLE = 60°, LENGTH = 1
+ examples/grass.txt view
@@ -0,0 +1,7 @@+Rule "Some height is good"+WHEN length < 1+GROW TO 1++Rule "Be fertile"+WHEN length >= 1+BLOSSOM
+ examples/hopper.txt view
@@ -0,0 +1,22 @@+Rule "Start"+WHEN Length <= 0+BRANCH AT 100% ANGLE = 30°, LENGTH = 0.5+BRANCH AT 100% ANGLE = -30°, LENGTH = 0.5++RULE "Links"+WHEN Direction > 0 AND Direction < 140°+BRANCH AT 100% ANGLE = 30°, LENGTH = 0.5++RULE "Zurück"+WHEN Direction >= 140°+BRANCH AT 100% ANGLE = -120°, LENGTH = 0.5++RULE "Rechts"+WHEN Direction < 0 AND Direction > -140°+BRANCH AT 100% ANGLE = -30°, LENGTH = 0.5++RULE "Zurück"+WHEN Direction <= -140°+BRANCH AT 100% ANGLE = 120°, LENGTH = 0.5++
+ examples/leftOrRight.txt view
@@ -0,0 +1,15 @@+// Another quite trivial plant. It tends to grow right (at the middle of a branch),+// but sometimes goes left (at the end of a branch)++Rule "Growing"+Grow by 2+Weight 2++Rule "Right"+Branch At 50% Angle = 45°, Length = 1+Weight 1++Rule "Left"+Branch At 100% Angle = -45°, Length = 1+Weight 1+
+ examples/priorities.txt view
@@ -0,0 +1,23 @@+RULE "Start"+WHEN Length <= 0 AND TAG = ""+BRANCH AT 100%+ANGLE = -45°, LENGTH = 1, TAG = ""+ANGLE = 0°, LENGTH = 1, TAG = "Main"+ANGLE = 45°, LENGTH = 1, TAG = ""+SET TAG = "Done"+PRIORITY 10++RULE "Grow Fast"+WHEN TAG = "Main"+GROW BY 1+SET TAG = "MainBlossom"+PRIORITY 2++RULE "Blossom 1"+WHEN TAG = "MainBlossom"+BLOSSOM+SET TAG = "Main"++RULE "Blossom 2"+WHEN TAG = ""+BLOSSOM
+ examples/testDoubleStipe.txt view
@@ -0,0 +1,7 @@+RULE "start"+WHEN Length < 1+GROW TO 2++RULE "invalid"+WHEN Length > 1+BRANCH AT 500% ANGLE=0°, LENGTH=1
+ examples/tiltedGrass.txt view
@@ -0,0 +1,7 @@+Rule "Some height is good"+WHEN length < 1+BRANCH ANGLE = 40°, LENGTH = 1++Rule "Be fertile"+WHEN length >= 1+BLOSSOM
+ examples/trivial.txt view
@@ -0,0 +1,4 @@+// This is the trivial plant, which just grows and grows++RULE "Very simple Rule"+GROW BY 1
+ src/Lseed/Constants.hs view
@@ -0,0 +1,61 @@+-- |+-- This module contians the main nobs to control the game play.+--+-- All length data is relative to the screen width.+module Lseed.Constants where ++groundLevel :: Double+groundLevel = 0.03+budSize :: Double+budSize     = 0.01+stipeLength :: Double+stipeLength = 0.05+blossomSize :: Double+blossomSize = 0.03+stipeWidth :: Double+stipeWidth  = 0.01++-- | Light and growths interpolation frequency+ticksPerDay :: Integer+ticksPerDay = 9++-- | Plant length growth per Day and Light+--+-- 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++-- | Plants up to this size get an boost in growths+smallPlantBoostSize :: Double+smallPlantBoostSize = 0.5++-- | Minimum growths for plants of size less then smallPlantBoostSize+smallPlantBoostLength :: Double+smallPlantBoostLength = 0.2++-- | Cost (in light units) per (length for maintaining the plant)^2, to limit the growth of the plants+costPerLength :: Double+costPerLength = 0.0005++-- | Cost (in length growths equivalent) per seed to be grown+seedGrowthCost :: Double+seedGrowthCost = 1.0++-- | Branch translucency. Proportion of light that is let through by a plant+lightFalloff :: Double+lightFalloff = 0.4++-- | Length of one day, in seconds+dayLength :: Double+dayLength = 8.0++-- | ε+eps = 1e-9++-- | Minimum radial angular distance between two branches+minAngle :: Double+minAngle = pi/20++-- | Derived constants+tickLength = dayLength / fromIntegral ticksPerDay
+ src/Lseed/DB.hs view
@@ -0,0 +1,58 @@+module Lseed.DB +	( DBCode(..)+	, getCodeToRun+	, addFinishedSeasonResults+	) where++import Database.HDBC+import Database.HDBC.ODBC+import Data.Map((!))+import qualified Data.Map as M++import Lseed.Data+import Lseed.Data.Functions++data DBCode = DBCode+	{ dbcUserName :: String+	, dbcUserID :: Integer+	, dbcPlantName :: String+	, dbcPlantID :: Integer+	, dbcCode :: String+	}+	deriving (Show)++withLseedDB ::  (Connection -> IO t) -> IO t+withLseedDB what = do+	dn <- readFile "../db.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;"+	stmt <- prepare conn getCodeQuery+	execute stmt []+	result <- fetchAllRowsMap' stmt+	return $ flip map result $ \m -> +		DBCode (fromSql (m ! "username"))+		       (fromSql (m ! "userid"))+		       (fromSql (m ! "plantname"))+		       (fromSql (m ! "plantid"))+		       (fromSql (m ! "code"))++addFinishedSeasonResults garden = withLseedDB $ \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)" []+	stmt <- prepare conn "SELECT LAST_INSERT_ID()"+	execute stmt []+	id <- (head . head) `fmap` fetchAllRows' stmt+	stmt <- prepare conn "INSERT INTO seasonscore VALUES (NULL, ?, ?, ?)"+	executeMany stmt $ map (\(o,l)->+		[ toSql $ o+		, id+		, toSql $ l+		]) owernerscore+
+ src/Lseed/Data.hs view
@@ -0,0 +1,179 @@+-- | Data definitions for L-seed+module Lseed.Data where ++import Data.Foldable (Foldable, foldMap)+import Data.Traversable (Traversable, sequenceA)+import Control.Applicative ((<$>),(<*>),pure)+import Control.Arrow (second)+import Data.Monoid+import System.Time (ClockTime)++-- | User Tag+type UserTag = String++-- | Light angle+type Angle = Double++-- | A list of plants, together with their position in the garden, in the interval [0,1]+type Garden a = [ Planted a ]++-- | Named variants of a garden, for more expressive type signatures+type GrowingGarden = Garden GrowthState+type AnnotatedGarden = Garden StipeInfo++-- | A plant with metainformatoin+data Planted a = Planted+	{ plantPosition :: Double -- ^ Position in the garden, interval [0,1]+	, plantOwner    :: Integer -- ^ Id of the user that owns this plant+	, genome        :: GrammarFile -- ^ Lsystem in use+	, phenotype     :: Plant a -- ^ Actual current form of the plant+	}+	deriving (Show)++-- | Named variants of a Planted, for more expressive type signatures+type GrowingPlanted = Planted GrowthState+type AnnotatedPlanted = Planted StipeInfo++-- | A plant, which is+data Plant a +	-- | a stipe with a length (factor of stipeLength), an angle relative+	-- to the parent stipe and a list of plants sprouting at the end+	= Plant { pData :: a+		, pLength :: Double+		, pAngle :: Angle+		, pUserTag :: UserTag+		, pBranches :: [ Plant a ]+		}+	deriving (Show)++-- | A straight, untagged plant with length zero and no branches.+inititalPlant = Plant () 0 0 "" []++data StipeInfo = StipeInfo+	{ siLength    :: Double -- ^ a bit redundant, but what shells+	, siSubLength :: Double+	, siLight     :: Double+	, siSubLight  :: Double+	, siAngle     :: Angle+	, siDirection :: Angle+	, siGrowth    :: GrowthState+	, siOffset    :: Double -- ^ Sideways position, relative to Plant origin+	, siHeight    :: Double -- ^ Vertical distance from bottom+	}+	deriving (Show)++-- | A GrowingPlant can be growing in one of these three ways:+data GrowthState = NoGrowth+		 | EnlargingTo Double -- ^ value indicates the growth target +		 | GrowingSeed Double -- ^ value indicates the current state [0..1]+	deriving (Show)++-- | Named variants of a Plant, for more expressive type signatures+type GrowingPlant = Plant GrowthState+type AnnotatedPlant = Plant StipeInfo++-- | Representation of what is on screen+data ScreenContent = ScreenContent+	{ scGarden     :: AnnotatedGarden+	, scLightAngle :: Double+	, scTime       :: String+	}++-- | Main loop observers+data Observer = Observer {+	-- | Called once, 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 ()+	-- | 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 ()+	}+nullObserver = Observer (return ()) (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ())+++-- | A complete grammar file+type GrammarFile = [ GrammarRule ]++type Priority = Int+type Weight = Int++defaultPriority :: Priority+defaultPriority = 0++defaultWeight :: Weight+defaultWeight = 1++-- | A single Rule. For now, only single branches+--   can be matched, not whole subtree structures+data GrammarRule = GrammarRule+	{ grName :: String+	, grPriority :: Priority+	, grWeight :: Weight+	, grCondition :: Condition+	, grAction :: GrammarAction+	}+	deriving (Read,Show)++data Matchable+	= MatchLight+	| MatchSubLight+	| MatchLength+	| MatchSubLength+	| MatchDirection+	| MatchAngle+	deriving (Read,Show)++data Cmp+	= LE+	| Less+	| Equals+	| Greater+	| GE +	deriving (Read,Show)++data Condition+	= Always Bool -- constant conditions+	| Condition `And` Condition+	| Condition `Or` Condition+	| UserTagIs String+	| NumCond Matchable Cmp Double+	deriving (Read,Show)+	 +data GrammarAction+	= SetLength (Maybe UserTag) LengthDescr+	| AddBranches (Maybe UserTag) Double [(Angle, Double, Maybe UserTag)]+	| Blossom (Maybe UserTag)+	deriving (Read,Show)++data LengthDescr = Absolute Double+	         | Additional Double+                 | AdditionalRelative Double -- ^ in Percent+	deriving (Read,Show)+++-- Instances+instance Functor Plant where+	fmap f p = p { pData = f (pData p)+		     , pBranches = map (fmap f) (pBranches p)+		     }++instance Foldable Plant where+	foldMap f p = mconcat $ f (pData p) : map (foldMap f) (pBranches p)++instance Traversable Plant where+	sequenceA (Plant x len ang ut ps) =+		Plant <$> x <*> pure len <*> pure ang <*> pure ut <*>+			sequenceA (map sequenceA ps)++instance Functor Planted where+	fmap f planted = planted { phenotype = fmap f (phenotype planted) }++instance Foldable Planted where+	foldMap f planted = foldMap f (phenotype planted)++instance Traversable Planted where+	sequenceA planted = (\x -> planted { phenotype = x }) <$> sequenceA (phenotype planted)
+ src/Lseed/Data/Functions.hs view
@@ -0,0 +1,35 @@+module Lseed.Data.Functions where++import Lseed.Data+import Data.Monoid++-- | Puts the length of the current segment in the additional information field+plantPieceLengths :: Plant a -> Plant Double+plantPieceLengths (Plant _ len ang ut ps) =+	Plant len len ang ut (map plantPieceLengths ps)++plantLength :: Plant a -> Double+plantLength = plantTotalSum . plantPieceLengths++plantTotalSum :: Plant Double -> Double+plantTotalSum = getSum . pData . subPieceAccumulate . fmap Sum ++subPieceAccumulate :: Monoid m => Plant m -> Plant m+subPieceAccumulate p = go p+  where go (Plant x len ang ut ps) = let ps' = map go ps+                                         x' = x `mappend` (mconcat $ map pData ps')+                                     in  Plant x' len ang ut ps'++-- | Apply a function to each Planted in a Garden+mapGarden :: (Planted a -> Planted b) -> Garden a -> Garden b+mapGarden = map++-- | Apply a function to each Planted in a Garden, with an extra argument from a list+--   +--   You need to make sure that the list is long enough!+zipWithGarden :: (Planted a -> x -> Planted b) -> Garden a -> [x] -> Garden b+zipWithGarden = zipWith++-- | Apply a function to the Plant in a Planted+mapPlanted :: (Plant a -> Plant b) -> Planted a -> Planted b+mapPlanted f planted = planted { phenotype = f (phenotype planted) }
+ src/Lseed/Geometry.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}+module Lseed.Geometry where++import Lseed.Data+import Lseed.Data.Functions+import Lseed.Constants+import Lseed.Geometry.Generator+import Data.List+import Data.Maybe+import Data.Ord+import qualified Data.Map as M+import Control.Monad hiding (mapM,forM)+import Data.Traversable (mapM,forM)+import Prelude hiding (mapM)+import Control.Monad.ST+import Data.STRef+import Control.Applicative++type Point = (Double, Double)+type Line  = (Point, Point)++lineLength ((x1,y1),(x2,y2)) = sqrt ((x1-x2)^2 + (y1-y2)^2)++-- | from http://www.pdas.com/lineint.htm+crossPoint :: Line -> Line -> Maybe Point+crossPoint ((x1,y1),(x2,y2)) ((x3,y3),(x4,y4)) =+	let a1 = y2-y1+	    b1 = x1-x2+	    c1 = x2*y1 - x1*y2  -- { a1*x + b1*y + c1 = 0 is line 1 }+            a2 = y4-y3+            b2 = x3-x4+            c2 = x4*y3 - x3*y4  -- { a2*x + b2*y + c2 = 0 is line 2 }+	    denom = a1*b2 - a2*b1+	in if abs denom > eps+           then let x = (b1*c2 - b2*c1)/denom+		    y = (a2*c1 - a1*c2)/denom+		in if  x1 <= x && x <= x2 &&+		       y1 <= y && y <= y2 &&+		       x3 <= x && x <= x4 &&+		       y3 <= y && y <= y4+		   then Just (x,y)+                   else Nothing+           else Nothing+++plantedToLines :: Planted a -> [(Line, a)]+plantedToLines planted = runGeometryGenerator (plantPosition planted, 0) 0 $+		plantToGeometry (phenotype planted)++plantToGeometry :: Plant a -> GeometryGenerator a ()+plantToGeometry (Plant x len ang _ ps) = rotated ang $ do+		addLine x ((0,0),(0,len * stipeLength))+		translated (0,len * stipeLength) $ mapM_ plantToGeometry ps++-- | Lines are annotated with its plant, identified by the extra data+gardenToLines :: Garden a -> [(Line, a)]+gardenToLines = concatMap (\planted -> plantedToLines planted)++-- | Add lightning from a given angle+lightenLines :: Double -> [(Line, a)] -> [(Line, a, Double)]+lightenLines angle lines = let (lighted,_) = allKindsOfStuffWithAngle angle lines+                           in lighted++lightPolygons :: Double -> [(Line, a)] -> [(Point,Point,Point,Point,Double)]+lightPolygons angle lines = let (_,polygons) = allKindsOfStuffWithAngle angle lines+			    in polygons++allKindsOfStuffWithAngle :: forall a. Double -> [(Line, a)] ->+			    ( [(Line, a, Double)]+	                    , [(Point,Point,Point,Point,Double)] )+allKindsOfStuffWithAngle angle lines = (lighted, polygons)+  where projectLine :: Line -> (Double, Double)+        projectLine (p1, p2) = (projectPoint p1, projectPoint p2)+	projectTan :: Double+	projectTan = 1 / tan (pi-angle)+	projectPoint :: Point -> Double+	projectPoint (x,y) = x + y * projectTan+	+	-- False means Beginning of Line+	sweepPoints :: [(Double, Bool, (Line, a))]+	sweepPoints = sortBy (comparing (\(a,b,_)->(a,b))) $ concatMap (\l@((p1,p2),i) -> +			if abs (projectPoint p1 - projectPoint p2) < eps+			then []+			else if projectPoint p1 < projectPoint p2+			     then [(projectPoint p1,False,l), (projectPoint p2,True,l)]+			     else [(projectPoint p2,False,l), (projectPoint p1,True,l)]+		) lines++	-- Find all crossing points+	crossings :: [Double]+	crossings = case mapAccumL step [] sweepPoints of+			([],crosses) -> nub (sort (concat crosses))+			_            -> error "Lines left open after sweep"+	  where	-- accumulator is open lines, return is list of cross points+		step :: [Line] -> (Double, Bool, (Line, a)) -> ([Line], [Double])+		step [] (_, True, _)      = error $ "Line ends with no lines open"+		-- Beginning of a new line, mark it as open, and mark it as a cross-point+		step ol (x, False, (l,_)) = (l:ol, [x]) +		-- End of a line. Calculate crosses with all open line, and remove it from the+		-- list of open lines+		step ol (x, True, (l,_)) = +			let ol' = delete l ol+			    crosses = map projectPoint $ mapMaybe (crossPoint l) ol'+			in (ol', x:crosses)++	-- Cross points inverval+	intervals = zip crossings (tail crossings)++	unlighted = map (\(l,i) -> (l,i,0)) lines+	+	unprojectPoint x (p1@(x1,y1),p2@(x2,y2)) = +		let t = (x - projectPoint p1) /+			(projectPoint p2 - projectPoint p1)+		in (x1 + t * (x2-x1), y1 + t * (y2-y1))++	lineAtRay x l = let (x1',x2') = projectLine l+                      in abs (x1' - x2') > eps && -- avoid lines that parallel to the rays+		         (x1' <= x && x <= x2' || x2' <= x && x <= x1')++	aboveFirst x l1 l2 =+		let (_,y1) = unprojectPoint x l1+		    (_,y2) = unprojectPoint x l2+		in y2 `compare` y1++	lighted :: [(Line, a, Double)]+	lighted = foldl go unlighted intervals+	  where go llines (x1,x2) = curlines' ++ otherlines+		  where -- Calculation based on the ray at the mid point+			mid = (x1 + x2) / 2+			-- Light intensity+			width = abs ((x2 - x1) * sin angle)+			(curlines, otherlines) = partition (\(l,_,_) -> lineAtRay mid l)+							   llines+			sorted = sortBy (\(l1,_,_) (l2,_,_) -> aboveFirst mid l1 l2)+                                        curlines+			curlines' = snd $ mapAccumL shine width sorted+			shine intensity (l,i,amount) = (intensity * lightFalloff, +						       (l,i,amount + (1-lightFalloff) * intensity))++	polygons = concatMap go intervals+	  where go (x1,x2) = if null sorted then [nothingPoly] else lightedPolys+		  where mid = (x1 + x2) / 2+			curlines = filter (lineAtRay mid) (map fst lines)+			sorted = sortBy (aboveFirst mid) curlines+			ceiling = ((0,10),(1,10))+			floor = ((0,0),(1,0))+			nothingPoly = let p1 = unprojectPoint x1 ceiling+                                          p2 = unprojectPoint x1 floor+                                          p3 = unprojectPoint x2 floor+                                          p4 = unprojectPoint x2 ceiling+                                      in (p1,p2,p3,p4,1)+			firstPoly = let p1 = unprojectPoint x1 ceiling+                                        p2 = unprojectPoint x1 (head sorted)+                                        p3 = unprojectPoint x2 (head sorted)+                                        p4 = unprojectPoint x2 ceiling+                                    in (p1,p2,p3,p4)+			lastPoly =  let p1 = unprojectPoint x1 (last sorted)+                                        p2 = unprojectPoint x1 floor+                                        p3 = unprojectPoint x2 floor+                                        p4 = unprojectPoint x2 (last sorted)+                                    in (p1,p2,p3,p4)+			polys = zipWith (\l1 l2 ->+                                         let p1 = unprojectPoint x1 l1+                                             p2 = unprojectPoint x1 l2+                                             p3 = unprojectPoint x2 l2+                                             p4 = unprojectPoint x2 l1+					 in (p1,p2,p3,p4)) sorted (tail sorted)+			polys' = [firstPoly] ++ polys ++ [lastPoly]+			lightedPolys = snd $ mapAccumL shine 1 polys'+			shine intensity (p1,p2,p3,p4) = ( intensity * lightFalloff+							, (p1,p2,p3,p4,intensity))++-- | Annotates each piece of the garden with the amount of line it attacts+lightenGarden :: Angle -> Garden a -> Garden (a, Double)+lightenGarden angle = mapLine (lightenLines angle) 0 (+) +++-- | Helper to apply a function that works on lines to a garden+mapLine :: (forall b. [(Line, b)] -> [(Line, b, c)]) ->+           c -> (c -> c -> c) -> Garden a -> Garden (a,c)+mapLine process init combine garden = runST $ do+	gardenWithPointers <- mapM (mapM (\d -> (,) d <$> newSTRef init)) garden+	let linesWithPointers = gardenToLines gardenWithPointers+	let processedLines = process linesWithPointers+	-- Update values via the STRef+	forM_ processedLines $ \(_,(_,stRef),result) -> modifySTRef stRef (combine result)+	-- Undo the STRefs+	mapM (mapM (\(d,stRef) -> (,) d <$> readSTRef stRef)) gardenWithPointers+
+ src/Lseed/Geometry/Generator.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Helper module providing a monad that collects lines+module Lseed.Geometry.Generator+	( GeometryGenerator+	, translated+	, rotated+	, runGeometryGenerator+	, addLine+	)+	where++import Control.Monad.Reader+import Control.Monad.Writer++type Point = (Double, Double)+type Line  = (Point, Point)+++newtype GeometryGenerator x a = GeometryGenerator (ReaderT (Point, Double) (Writer [(Line, x)]) a)+ deriving (Monad)++transformed :: Point -> GeometryGenerator x Point+transformed (x,y) = GeometryGenerator $ do+	((bx,by),r) <- ask+	let (x', y') = (cos r * x + sin r *y, -sin r * x + cos r *y)+	return (bx + x', by + y')++translated :: Point -> GeometryGenerator x a -> GeometryGenerator x a+translated p (GeometryGenerator act) = do+	(x',y') <- transformed p+	GeometryGenerator $+		local (\(_,r) -> ((x',y'),r)) act++rotated :: Double -> GeometryGenerator x a -> GeometryGenerator x a+rotated r (GeometryGenerator act) = +	GeometryGenerator $ local (\(p,r') -> (p, r' - r)) act++addLine :: x -> Line -> GeometryGenerator x ()+addLine x (p1,p2) = do+	p1' <- transformed p1+	p2' <- transformed p2+	GeometryGenerator $ tell [((p1', p2'),x)]++	+runGeometryGenerator :: Point -> Double -> GeometryGenerator x () -> [(Line, x)]+runGeometryGenerator p r (GeometryGenerator gen) = +	execWriter (runReaderT gen (p,r))
+ src/Lseed/Grammar/Parse.hs view
@@ -0,0 +1,170 @@+module Lseed.Grammar.Parse ( parseGrammar ) where++import Text.Parsec+import qualified Text.Parsec.Token as P+import Text.Parsec.Language (javaStyle)+import Text.Parsec.Expr+import Control.Monad++import Lseed.Data++-- The lexer+lexer       = P.makeTokenParser $ javaStyle+	{ P.reservedNames = ["RULE", "WHEN", "SET", "Tag", "Light", "Branch", "At",+			     "Length", "Light", "Sublength", "Sublight", "Direction", "Angle",+			     "BY", "TO", "PRIORITY", "WEIGHT", "Blossom"]+	}++parens      = P.parens lexer+braces      = P.braces lexer+identifier  = P.identifier lexer+reserved    = P.reserved lexer+reservedOp  = P.reservedOp lexer+natural     = P.natural lexer+integer     = P.integer lexer+stringLiteral = P.stringLiteral lexer+naturalOrFloat = P.naturalOrFloat lexer+float	    = P.float lexer+comma	    = P.comma lexer+whiteSpace  = P.whiteSpace lexer++-- Expression++-- The parser++parseGrammar :: String -> String -> Either ParseError GrammarFile+parseGrammar = parse pFile++type Parser = Parsec String ()++pFile :: Parser GrammarFile+pFile = do+	whiteSpace +	gf <- many1 pRule+	eof+	return gf++pRule :: Parser GrammarRule+pRule = do+	reserved "RULE" +	name <- pString+	condition <- option (Always True) $ do+		reserved "WHEN"+		pCondition+	action <- pAction+	-- maybe (return ()) fail (actionIsInvalid action)+	priority <- option 1 $ do+		reserved "PRIORITY"+		fromIntegral `fmap` natural+	weight <- option 1 $ do+		reserved "WEIGHT"+		fromIntegral `fmap` natural+	return $ GrammarRule name priority weight condition action++pCondition :: Parser Condition+pCondition = buildExpressionParser table term+  where term = parens pCondition <|> pNumCond <|> pTagTest+	table = [[ Infix (do{ reserved "AND"; return And }) AssocLeft ]+	        ,[Infix (do{ reserved "OR";  return Or  }) AssocLeft ]+		]+pNumCond = do+	what <- pMatchable+	cmp <- pCmp+	value <- pFloat+	return (NumCond what cmp value)	++pTagTest = do+	reserved "TAG"+	reservedOp "="+	value <- pString+	return (UserTagIs value)++pAction :: Parser GrammarAction+pAction = pBranch <|> pGrow <|> pBlossom++pBranch :: Parser GrammarAction+pBranch = do+	reserved "BRANCH"+	fraction <- (do+		reserved "AT"+		fraction <- pFloat+		unless (0 <= fraction && fraction <= 100) $+			fail "Fork position has to be in between 0% and 100%."+		reservedOp "%"+		return fraction+		) <|> (return 100)+	branches <- many1 $ do+		reserved "ANGLE"+		reservedOp "="+		angle <- pFloat+		comma+		reserved "LENGTH"+		reservedOp "="+		length <- pFloat+		mTag <- optionMaybe $ do+			comma+			reserved "TAG"+			reservedOp "="+			pString+		return (angle, length, mTag)+	mTag <- pSetTag+	return (AddBranches mTag (fraction/100) branches)++pGrow :: Parser GrammarAction+pGrow = do+	reserved "GROW"+	desc <- by <|> to+	mTag <- pSetTag+	return (SetLength mTag desc)+  where by = do+		reserved "BY"+		value <- pFloat+		(reservedOp "%" >> return (AdditionalRelative value)) <|>+		                   return (Additional value)+	to = do+		reserved "TO"+		value <- pFloat+		return (Absolute value)++pBlossom :: Parser GrammarAction+pBlossom = do+	reserved "BLOSSOM"+	mTag <- pSetTag+	return (Blossom mTag)++pSetTag :: Parser (Maybe UserTag)+pSetTag = optionMaybe $ do+		reserved "SET"+		reserved "TAG"+		reservedOp "="+		pString++pMatchable =+	choice $ map (\(a,b) -> const b `fmap` reserved a) $+		[ ("LIGHT", MatchLight)+		, ("LENGTH", MatchLength)+		, ("SUBLENGTH", MatchSubLength)+		, ("SUBLIGHT", MatchSubLight)+		, ("ANGLE", MatchAngle)+		, ("DIRECTION", MatchDirection)+		]++pCmp = +	choice $ map (\(a,b) -> const b `fmap` reservedOp a) $+		[ ("<=", LE)+		, ("<",  Less)+		, ("=",  Equals)+		, (">",  Greater)+		, (">=", GE)+		]++pString = identifier <|> stringLiteral++pFloat = do value <- try (do +			i <- fromIntegral `fmap` integer+			notFollowedBy (char '.')+			return i+		     )  <|> float+	    (deg >> return (value / 180 * pi)) <|> return value++deg = reservedOp "\194\176"
+ src/Lseed/LSystem.hs view
@@ -0,0 +1,101 @@+module Lseed.LSystem where++import Lseed.Constants+import Lseed.Data+import Data.Maybe+import Data.Monoid+import System.Random+import Control.Arrow (second)+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+                                in  result+  where go :: Int -> AnnotatedPlant -> (Int, GrowingPlant)+ 	go maxPrio p@(Plant { pUserTag = oldUt+		            , pLength = oldSize+		            , pAngle = ang+		            , pBranches = ps+		            })+		= let choices = map applyRule $+			        filter (\r -> p `conformsTo` grCondition r) $+			        rules+		  in ( maximum (0 : subPrios ++ map fst choices)+		     , case filter (isValid . snd) $+		     	    map snd $+		            filter ((>= maxPrio) . fst) $+			    choices+		       of []       -> noAction+		          choices' -> chooseWeighted rgen choices'+		     )+	  where applyRule :: GrammarRule -> (Int, (Int, GrowingPlant))+	  	applyRule r = (grPriority r, (grWeight r, applyAction (grAction r)))+	  +	  	applyAction :: GrammarAction -> GrowingPlant+	  	applyAction (SetLength mut ld)+			= p { pData    = EnlargingTo (calcLengthDescr ld oldSize)+			    , pUserTag = fromMaybe oldUt mut+			    , pBranches = ps'+			    }+	  	applyAction (AddBranches mut pos branches) +			| 1-pos < eps -- Fork at the end+			= p { pData = NoGrowth+			    , pUserTag = ut+			    , pBranches = ps' ++ newForks}+			| otherwise -- Fork not at the end+			= Plant NoGrowth (oldSize * pos) ang ut $+			  [ Plant NoGrowth (oldSize * (1-pos)) 0 ut ps' ] +++			  newForks+		 where	ut = fromMaybe oldUt mut+			newForks = map (\(angle, newSize, ut) -> Plant (EnlargingTo newSize) 0 angle (fromMaybe oldUt ut) []) branches+		applyAction (Blossom mut) +			= p { pData = GrowingSeed 0+			    , pUserTag = fromMaybe oldUt mut+			    , pBranches = ps'+			    }+	+		noAction = p { pData = NoGrowth, pBranches = ps' }+		+		(subPrios, ps') = unzip $ map (go maxPrio) ps++	-- Some general checks to rule out unwanted rules+	isValid :: GrowingPlant -> Bool+	isValid (Plant newSize oldSize ang ut ps) = anglesOk+	  where angles = sort $ map pAngle ps+		-- Are all angles not too close to each other?+                anglesOk = all (> minAngle) (zipWith (flip (-)) angles (tail angles))++chooseWeighted _    []   = error "Can not choose from an empty list"+chooseWeighted rgen list = replicated !! (c-1)+  where replicated = concatMap (\(w,e) -> replicate w e) list+        (c,_) = randomR (1, length replicated) rgen++++conformsTo :: AnnotatedPlant -> Condition -> Bool+conformsTo (Plant {pData = si, pUserTag = ut}) = go+  where go (Always b)     = b+	go (c1 `And` c2)  = go c1 && go c2+	go (c1 `Or` c2)   = go c1 || go c2+	go (UserTagIs ut') = ut' == ut+	go (NumCond what how val) = doCompare how (getMatchable what) val+	+	getMatchable MatchLength    = siLength si+	getMatchable MatchSubLength = siSubLength si+	getMatchable MatchLight     = siLight si+	getMatchable MatchSubLight  = siSubLight si+	getMatchable MatchDirection = siDirection si+	getMatchable MatchAngle     = siAngle si++	doCompare LE = (<=)+	doCompare Less = (<)+	doCompare Equals = (==)+	doCompare Greater = (>)+	doCompare GE = (>=)++-- | Length reductions are silenty turned into no-ops+calcLengthDescr :: LengthDescr -> Double -> Double+calcLengthDescr (Absolute val) l  = max l val+calcLengthDescr (Additional val) l = max l (l + val)+calcLengthDescr (AdditionalRelative val) l = max l (l + l * (val/100))+
+ src/Lseed/Logic.hs view
@@ -0,0 +1,106 @@+-- | This module is mostly a general dump...+module Lseed.Logic where++import Lseed.Data+import Lseed.Data.Functions+import Lseed.Grammar.Parse+import Lseed.LSystem+import Lseed.Constants+import Lseed.Geometry+import Lseed.StipeInfo+import System.Time+import Text.Printf+import System.Random+import Data.List+import qualified Data.Foldable as F++timeSpanFraction :: Double -> ClockTime -> ClockTime -> Double+timeSpanFraction spanLenght (TOD sa pa) (TOD sb pb) = +	min 1 $ max 0 $+	(fromIntegral $ (sb - sa) * 1000000000000 + (pb-pa)) /+        (spanLenght * 1000000000000 )++formatTimeInfo :: Integer -> Double -> String+formatTimeInfo day frac = let minutes = floor (frac * 12 * 60) :: Integer+			      (hour, minute) = divMod minutes 60+                          in  printf "Day %d %2d:%02d" day (6+hour) minute++-- | Given the fraction of the time passed, returnes the angle of the sunlight+lightAngle :: Double -> Angle+lightAngle diff = pi/100 + diff * (98*pi/100)++-- | Calculates the length to be grown+remainingGrowth :: (a -> GrowthState) -> Planted a -> Double+remainingGrowth getGrowths planted = go (phenotype planted)+  where go p@(Plant { pLength = l1, pBranches = ps }) =+ 	   sum (map go ps) + case getGrowths (pData p) of+  		NoGrowth         -> 0+                EnlargingTo l2   -> l2 - l1+                GrowingSeed done -> (1-done) * seedGrowthCost ++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++-- | 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+  where rgens = unfoldr (Just . split) rgen+	aGarden = annotateGarden angle garden+	applyGenome' rgen planted =+		if   remainingGrowth siGrowth planted < eps+		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 = snd $ F.foldr go (rgen,[]) planted+	  where go si (rgen,newPlants) = 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)++-- | Applies an L-System to a Plant, putting the new length in the additional+--   information field+growPlanted :: GrowingPlanted -> Double -> (Double -> GrowingPlanted)+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+				  else 0+                     allowedGrowths = max lowerBound $+                                      (growthPerDayAndLight * lightAvailable) /+                                      (fromIntegral ticksPerDay) +		     growthThisTick = min remainingLength allowedGrowths+		     growthFraction = growthThisTick / remainingLength +		 in \tickDiff -> applyGrowth (tickDiff * growthFraction) planted+	    else const planted++-- | Applies Growth at given fraction, leaving the target length in place+applyGrowth :: Double -> GrowingPlanted -> GrowingPlanted+applyGrowth r = mapPlanted (applyGrowth' (\a b -> a * (1-r) + b * r))++applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant+applyGrowth' f = go+  where go (Plant NoGrowth l ang ut ps) = +  		Plant NoGrowth l ang ut (map go ps)+	go (Plant (EnlargingTo l2) l1 ang ut ps) =+		Plant (EnlargingTo l2) (f l1 l2) ang ut (map go ps)+	go (Plant (GrowingSeed done) l ang ut ps) =+		Plant (GrowingSeed (f (done*seedGrowthCost) seedGrowthCost)) l ang ut (map go ps)
+ src/Lseed/Mainloop.hs view
@@ -0,0 +1,51 @@+-- | This module contains a runner for a an Lseed garden. It can be passed an+-- observer that will receive the results.+module Lseed.Mainloop where++import Lseed.Data+import Lseed.Geometry+import Lseed.Data.Functions+import Lseed.Constants+import Lseed.Logic+import Lseed.StipeInfo+import System.Time+import System.Random+import Control.Concurrent+import Control.Monad++-- | Lets a garden grow for the given number of days, while keeping the+-- 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+	-> Integer -- ^ Maximum days to run+	-> Garden () -- ^ Initial garden state+	-> IO ()+lseedMainLoop rt obs maxDays garden = do+	obInit obs+	let nextDay (tick, garden) = +		let (day, tickOfDay) = tick `divMod` ticksPerDay in+		if day > maxDays then+			obFinished obs garden+		else do++		tickStart <- getClockTime+		rgen <- newStdGen+		let sampleAngle = lightAngle $ (fromIntegral tickOfDay + 0.5) /+                                                fromIntegral ticksPerDay+		let growingGarden = growGarden sampleAngle rgen garden++		obState obs tick garden+		when rt $ do+			obGrowingState obs $ \later -> +				let tickDiff = timeSpanFraction tickLength tickStart later+				    dayDiff = (fromIntegral tickOfDay + tickDiff) /+					      fromIntegral ticksPerDay+				    timeInfo = formatTimeInfo day dayDiff+				    visualizeAngle = lightAngle dayDiff+				    gardenNow = annotateGarden visualizeAngle $ +				                growingGarden tickDiff+				in ScreenContent gardenNow visualizeAngle timeInfo++			threadDelay (round (tickLength * 1000 * 1000))+		nextDay (succ tick, growingGarden 1)+	nextDay (0::Integer, mapGarden (fmap (const NoGrowth)) garden)
+ src/Lseed/Renderer/Cairo.hs view
@@ -0,0 +1,191 @@+module Lseed.Renderer.Cairo where++import Graphics.UI.Gtk hiding (fill)+import Graphics.Rendering.Cairo+import Control.Monad+import Control.Concurrent+import Data.IORef+import Data.Maybe+import Lseed.Data+import Lseed.Data.Functions+import Lseed.Constants+import Lseed.Geometry+import Text.Printf+import System.Time++cairoObserver :: IO Observer+cairoObserver = do+	initGUI++	-- global renderer state+	currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet"))++	-- widgets+	canvas <- drawingAreaNew++	window <- windowNew+	set window [windowDefaultWidth := 800, windowDefaultHeight := 600,+	      containerChild := canvas, containerBorderWidth := 0]+	widgetShowAll window++	-- Make gtk and haskell threading compatible+	timeoutAdd (yield >> return True) 50+	+	-- a thread for our GUI+	forkIO $ mainGUI++	-- The actual drawing function+	onExpose canvas$ \e -> do scGen <- readIORef currentGardenRef+				  ScreenContent garden angle timeInfo <-+						scGen `fmap` getClockTime +				  dwin <- widgetGetDrawWindow canvas+				  (w,h) <- drawableGetSize dwin+				  renderWithDrawable dwin $ do+					-- Set up coordinates+					translate 0 (fromIntegral h)+					scale 1 (-1)+					scale (fromIntegral w) (fromIntegral (w))+					translate 0 groundLevel+					setLineWidth stipeWidth++					render angle garden+					renderTimeInfo timeInfo+		                  return True++	timeoutAdd (widgetQueueDraw canvas >> return True) 20++	return $ nullObserver+		{ obGrowingState = \scGen -> do+			writeIORef currentGardenRef scGen+			widgetQueueDraw canvas+		, obFinished = \_ ->+			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))++	--mapM_ renderLightedLine (lightenLines angle (gardenToLines garden))+	--mapM_ renderLine (gardenToLines garden)+	--mapM_ renderLightedPlanted garden++	mapM_ renderPlanted garden++	renderInfo angle garden++renderPlanted :: AnnotatedPlanted -> Render ()+renderPlanted planted = preserve $ do+	translate (plantPosition planted) 0+	setSourceRGB 0 0.8 0+	setLineCap LineCapRound+	renderPlant (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)))+	moveTo 0 0+	lineTo 0 (len * stipeLength)+	setSourceRGB 0 0.8 0+	stroke+	translate 0 (len * stipeLength)+	mapM_ renderPlant ps+	case siGrowth si of+	  GrowingSeed done -> do+	  	setSourceRGB 1 1 0+	  	arc 0 0 (done * blossomSize/2) 0 (2*pi)+		fill+	  _ -> return ()+		+renderLightedPlanted :: AnnotatedPlanted -> Render ()+renderLightedPlanted planted = preserve $ do+	translate (plantPosition planted) 0+	renderLightedPlant (phenotype planted)++renderLightedPlant :: AnnotatedPlant -> Render ()	+renderLightedPlant (Plant si len ang ut ps) = preserve $ do+	rotate ang+	moveTo 0 0+	lineTo 0 (len * stipeLength)+	let normalized = siLight si / (len * stipeLength)+	when (normalized > 0) $ do+		--liftIO $ print normalized+		setLineWidth (2*stipeWidth)+		setSourceRGBA 1 1 0 normalized+		stroke+	translate 0 (len * stipeLength)+	mapM_ renderLightedPlant ps+		+{- Line based rendering deprecated++renderLine (l@((x1,y1),(x2,y2)), _) = do+	setSourceRGB 0 1 0 +	setLineWidth (0.5*stipeWidth)+	moveTo x1 y1+	lineTo x2 y2+	stroke+	+renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do+	moveTo x1 y1+	lineTo x2 y2+	let normalized = intensity / lineLength l+	when (normalized > 0) $ do+		setLineWidth (1.5*stipeWidth)+		setSourceRGBA 1 1 0 normalized+		strokePreserve+	setSourceRGB 0 1 0 +	setLineWidth (0.5*stipeWidth)+	stroke+-}+	+renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do+	when (intensity > 0) $ do+		moveTo x1 y1+		lineTo x2 y2+		lineTo x3 y3+		lineTo x4 y4+		closePath+		setSourceRGB 0 0 intensity+		fill++renderInfo angle garden = do+	forM_ garden $ \planted -> do+		let x = plantPosition planted+		let text1 = printf "Light: %.2f" $+				siSubLight . pData . phenotype $ planted+		let text2 = printf "Size: %.2f" $+				siSubLength . pData . phenotype $ planted+		preserve $ do+			scale 1 (-1)+			setSourceRGB 0 0 0+			setFontSize (groundLevel/2)+			moveTo x (0.9*groundLevel)+			showText text1+			moveTo x (0.5*groundLevel)+			showText text2++renderTimeInfo timeStr = do+	preserve $ do+		scale 1 (-1)+		setSourceRGB 0 0 0+		setFontSize (groundLevel/2)+		moveTo 0 (0.5*groundLevel)+		showText timeStr++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)+        fill++-- | Wrapper that calls 'save' and 'restore' before and after the argument+preserve :: Render () -> Render ()+preserve r = save >> r >> restore
+ src/Lseed/StipeInfo.hs view
@@ -0,0 +1,29 @@+module Lseed.StipeInfo where++import Lseed.Data+import Lseed.Constants+import Lseed.Data.Functions+import Lseed.Geometry++annotateGarden :: Angle -> GrowingGarden -> AnnotatedGarden+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+		{ siLength    = len+		, siSubLength = len + sum (map (siSubLength . pData) ps')+		, siLight     = light+		, siSubLight  = light + sum (map (siSubLight . pData) ps')+		, siAngle     = ang+		, siDirection = normAngle d'+		, siGrowth    = gs+		, siOffset    = o'+		, siHeight    = h'+		}) len ang ut ps'+	  where ps' = map (go d' o' h') ps+	  	d' = (d+ang)+		o' = o - len * stipeLength * sin d'+		h' = h + len * stipeLength * cos d'++normAngle a = a - fromIntegral (truncate ((a+pi) / (2*pi))) * 2*pi
+ src/dbclient.hs view
@@ -0,0 +1,19 @@+import Lseed.Data+import Lseed.Data.Functions+import Lseed.DB+import Lseed.Grammar.Parse+import Lseed.Mainloop+import Lseed.Renderer.Cairo+import Control.Applicative+import Control.Monad+import Text.Printf++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..]+	  where l = fromIntegral (length gs)++main = do+	garden <- getGarden+	obs <- cairoObserver+	lseedMainLoop True obs 1 garden
+ src/dbscorer.hs view
@@ -0,0 +1,32 @@+import Lseed.Data+import Lseed.Data.Functions+import Lseed.DB+import Lseed.Grammar.Parse+import Lseed.Mainloop+import Control.Applicative+import Control.Monad+import Text.Printf++getGarden = spread <$> map compileDBCode+		   <$> getCodeToRun+  where spread gs = zipWith (\(u,g) p -> Planted ((fromIntegral p + 0.5) / l) u 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)++scoringObs = 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+	}++main = do+	garden <- getGarden+	lseedMainLoop False scoringObs 10 garden
+ src/fastScorer.hs view
@@ -0,0 +1,45 @@+import Lseed.Data+import Lseed.Data.Functions+import Lseed.Grammar.Parse+import Lseed.Constants+import Lseed.Mainloop+import qualified Data.Map as M+import Control.Monad+import Debug.Trace+import System.Environment+import System.Time+import System.Random+import Text.Printf++parseFile filename = do+	content <- readFile filename+	let result = parseGrammar filename content+	return $ either (error.show) id result++readArgs doit = do+	args <- getArgs+	if null args+	  then	do+		putStrLn "L-Seed Demo application."+		putStrLn "Please pass L-Seed files on the command line."+	  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 l = fromIntegral (length gs)+	      ++scoringObs = 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))+		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+	}++main = readArgs $ \garden -> do+	lseedMainLoop False scoringObs 30 garden
+ src/main.hs view
@@ -0,0 +1,32 @@+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++parseFile filename = do+	content <- readFile filename+	let result = parseGrammar filename content+	return $ either (error.show) id result++readArgs doit = do+	args <- getArgs+	if null args+	  then	do+		putStrLn "L-Seed Demo application."+		putStrLn "Please pass L-Seed files on the command line."+	  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 l = fromIntegral (length gs)+		+main = readArgs $ \garden -> do+	obs <- cairoObserver+	lseedMainLoop True obs 200 garden
+ src/validate.hs view
@@ -0,0 +1,27 @@+{- + +Helper program: Expects a L-seed grammar on stdin and outputs its validity in JSON format:+$ echo "RULE is invalid" | ./validate +{"valid":false,"line":1,"column":9,"msg":"\nunexpected \"i\"\nexpecting \"WHEN\", \"BRANCH\" or \"GROW\""}+$ echo "RULE trivial GROW BY 1" | ./validate +{"valid":true}+-}++import Text.Parsec.Error+import Text.Parsec.Pos+import Lseed.Grammar.Parse+import Text.JSON++valid = encode $ makeObj [ ("valid", showJSON True) ]++invalid error = encode $ makeObj+	[ ("valid", showJSON False)+	, ("line",  showJSON . sourceLine .   errorPos $ error) +	, ("column",showJSON . sourceColumn . errorPos $ error) +	, ("msg",   showJSON .+	            showErrorMessages "or" "unknown parse error"+                                      "expecting" "unexpected" "end of input" .+                    errorMessages $ error)+	]++main = interact $ either invalid (const valid) . parseGrammar "stdin"