diff --git a/L-seed.cabal b/L-seed.cabal
new file mode 100644
--- /dev/null
+++ b/L-seed.cabal
@@ -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
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/db.conf-example b/db.conf-example
new file mode 100644
--- /dev/null
+++ b/db.conf-example
@@ -0,0 +1,1 @@
+Driver=MySQL;Server=svenhecht.is-a-geek.org;Database=lseed;Uid=lseedbackend;Pwd=XXX;Port=3306;
diff --git a/examples/christmasTree.txt b/examples/christmasTree.txt
new file mode 100644
--- /dev/null
+++ b/examples/christmasTree.txt
@@ -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
diff --git a/examples/fiveFingered.txt b/examples/fiveFingered.txt
new file mode 100644
--- /dev/null
+++ b/examples/fiveFingered.txt
@@ -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
diff --git a/examples/grass.txt b/examples/grass.txt
new file mode 100644
--- /dev/null
+++ b/examples/grass.txt
@@ -0,0 +1,7 @@
+Rule "Some height is good"
+WHEN length < 1
+GROW TO 1
+
+Rule "Be fertile"
+WHEN length >= 1
+BLOSSOM
diff --git a/examples/hopper.txt b/examples/hopper.txt
new file mode 100644
--- /dev/null
+++ b/examples/hopper.txt
@@ -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
+
+
diff --git a/examples/leftOrRight.txt b/examples/leftOrRight.txt
new file mode 100644
--- /dev/null
+++ b/examples/leftOrRight.txt
@@ -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
+
diff --git a/examples/priorities.txt b/examples/priorities.txt
new file mode 100644
--- /dev/null
+++ b/examples/priorities.txt
@@ -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
diff --git a/examples/testDoubleStipe.txt b/examples/testDoubleStipe.txt
new file mode 100644
--- /dev/null
+++ b/examples/testDoubleStipe.txt
@@ -0,0 +1,7 @@
+RULE "start"
+WHEN Length < 1
+GROW TO 2
+
+RULE "invalid"
+WHEN Length > 1
+BRANCH AT 500% ANGLE=0°, LENGTH=1
diff --git a/examples/tiltedGrass.txt b/examples/tiltedGrass.txt
new file mode 100644
--- /dev/null
+++ b/examples/tiltedGrass.txt
@@ -0,0 +1,7 @@
+Rule "Some height is good"
+WHEN length < 1
+BRANCH ANGLE = 40°, LENGTH = 1
+
+Rule "Be fertile"
+WHEN length >= 1
+BLOSSOM
diff --git a/examples/trivial.txt b/examples/trivial.txt
new file mode 100644
--- /dev/null
+++ b/examples/trivial.txt
@@ -0,0 +1,4 @@
+// This is the trivial plant, which just grows and grows
+
+RULE "Very simple Rule"
+GROW BY 1
diff --git a/src/Lseed/Constants.hs b/src/Lseed/Constants.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/Constants.hs
@@ -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
diff --git a/src/Lseed/DB.hs b/src/Lseed/DB.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/DB.hs
@@ -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
+
diff --git a/src/Lseed/Data.hs b/src/Lseed/Data.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/Data.hs
@@ -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)
diff --git a/src/Lseed/Data/Functions.hs b/src/Lseed/Data/Functions.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/Data/Functions.hs
@@ -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) }
diff --git a/src/Lseed/Geometry.hs b/src/Lseed/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/Geometry.hs
@@ -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
+
diff --git a/src/Lseed/Geometry/Generator.hs b/src/Lseed/Geometry/Generator.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/Geometry/Generator.hs
@@ -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))
diff --git a/src/Lseed/Grammar/Parse.hs b/src/Lseed/Grammar/Parse.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/Grammar/Parse.hs
@@ -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"
diff --git a/src/Lseed/LSystem.hs b/src/Lseed/LSystem.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/LSystem.hs
@@ -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))
+
diff --git a/src/Lseed/Logic.hs b/src/Lseed/Logic.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/Logic.hs
@@ -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)
diff --git a/src/Lseed/Mainloop.hs b/src/Lseed/Mainloop.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/Mainloop.hs
@@ -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)
diff --git a/src/Lseed/Renderer/Cairo.hs b/src/Lseed/Renderer/Cairo.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/Renderer/Cairo.hs
@@ -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
diff --git a/src/Lseed/StipeInfo.hs b/src/Lseed/StipeInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/Lseed/StipeInfo.hs
@@ -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
diff --git a/src/dbclient.hs b/src/dbclient.hs
new file mode 100644
--- /dev/null
+++ b/src/dbclient.hs
@@ -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
diff --git a/src/dbscorer.hs b/src/dbscorer.hs
new file mode 100644
--- /dev/null
+++ b/src/dbscorer.hs
@@ -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
diff --git a/src/fastScorer.hs b/src/fastScorer.hs
new file mode 100644
--- /dev/null
+++ b/src/fastScorer.hs
@@ -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
diff --git a/src/main.hs b/src/main.hs
new file mode 100644
--- /dev/null
+++ b/src/main.hs
@@ -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
diff --git a/src/validate.hs b/src/validate.hs
new file mode 100644
--- /dev/null
+++ b/src/validate.hs
@@ -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"