Create a proper mainloop with an observer parameter
authorJoachim Breitner <mail@joachim-breitner.de>
Sun, 24 May 2009 18:33:14 +0000 (20:33 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Sun, 24 May 2009 18:42:13 +0000 (20:42 +0200)
src/Lseed/Data.hs
src/Lseed/Logic.hs
src/Lseed/Mainloop.hs [new file with mode: 0644]
src/Lseed/Renderer/Cairo.hs
src/dbclient.hs
src/main.hs

index a0568e5..809ce23 100644 (file)
@@ -6,6 +6,7 @@ import Data.Traversable (Traversable, sequenceA)
 import Control.Applicative ((<$>),(<*>),pure)
 import Control.Arrow (second)
 import Data.Monoid
+import System.Time (ClockTime)
 
 -- | A list of plants, together with their position in the garden, in the interval [0,1]
 type Garden a = [ Planted a ]
@@ -71,6 +72,15 @@ data ScreenContent = ScreenContent
 -- | Light angle
 type Angle = Double
 
+-- | Main loop observers
+data Observer = Observer
+       { obInit :: IO ()
+       , obState :: Integer -> GrowingGarden -> IO ()
+       , obGrowingState :: (ClockTime -> ScreenContent) -> IO ()
+       , obFinished :: GrowingGarden -> IO ()
+       }
+nullObserver = Observer (return ()) (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ())
+
 -- Instances
 instance Functor Plant where
        fmap f (Stipe x len ps) = Stipe (f x) len (map (second (fmap f)) ps)
index 9a17ff8..432b6d1 100644 (file)
@@ -1,7 +1,6 @@
 -- | This module is mostly a general dump...
 module Lseed.Logic where
 
-import Lseed.Renderer.Cairo
 import Lseed.Data
 import Lseed.Data.Functions
 import Lseed.Grammar
@@ -15,7 +14,6 @@ import System.Time
 import Text.Printf
 import System.Random
 import Data.List
-import Control.Concurrent
 
 timeSpanFraction :: Double -> ClockTime -> ClockTime -> Double
 timeSpanFraction spanLenght (TOD sa pa) (TOD sb pb) = 
@@ -76,7 +74,7 @@ growPlanted planted light =
 finishGrowth :: GrowingPlant -> Plant ()
 finishGrowth = fmap (const ()) . applyGrowth' (flip const)
 
--- | Applies Growth at given fraction, leaving the target lenght in place
+-- | 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))
 
@@ -84,28 +82,3 @@ applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant
 applyGrowth' f = go
   where go (Stipe Nothing l ps)    = Stipe Nothing l (mapSprouts go ps)
        go (Stipe (Just l2) l1 ps) = Stipe (Just l2) (f l1 l2) (mapSprouts go ps)
-
-runGarden :: Garden a -> IO ()
-runGarden garden = do
-       renderGarden <- initRenderer
-       let nextDay (tick, garden) = do
-               let (day, tickOfDay) = tick `divMod` ticksPerDay
-
-               tickStart <- getClockTime
-               rgen <- newStdGen
-               let sampleAngle = lightAngle $ (fromIntegral tickOfDay + 0.5) /
-                                                fromIntegral ticksPerDay
-               let growingGarden = growGarden sampleAngle rgen garden
-
-               renderGarden $ \later -> 
-                       let tickDiff = timeSpanFraction tickLength tickStart later
-                           dayDiff = (fromIntegral tickOfDay + tickDiff) /
-                                      fromIntegral ticksPerDay
-                            timeInfo = formatTimeInfo day dayDiff
-                           visualizeAngle = lightAngle dayDiff
-                           gardenNow = mapGarden (fmap (const ())) $ growingGarden tickDiff
-                       in ScreenContent gardenNow visualizeAngle timeInfo
-
-               threadDelay (round (tickLength * 1000 * 1000))
-               nextDay (succ tick, growingGarden 1)
-       nextDay (0::Integer, mapGarden (fmap (const Nothing)) garden)
diff --git a/src/Lseed/Mainloop.hs b/src/Lseed/Mainloop.hs
new file mode 100644 (file)
index 0000000..713a3fb
--- /dev/null
@@ -0,0 +1,50 @@
+-- | 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 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 = mapGarden (fmap (const ())) $
+                                               growingGarden tickDiff
+                               in ScreenContent gardenNow visualizeAngle timeInfo
+
+                       threadDelay (round (tickLength * 1000 * 1000))
+               nextDay (succ tick, growingGarden 1)
+       nextDay (0::Integer, mapGarden (fmap (const Nothing)) garden)
index 1d038a0..da1e3f8 100644 (file)
@@ -13,8 +13,8 @@ import Lseed.Geometry
 import Text.Printf
 import System.Time
 
-initRenderer :: IO ((ClockTime -> ScreenContent) -> IO ())
-initRenderer = do
+cairoObserver :: IO Observer
+cairoObserver = do
        initGUI
 
        -- global renderer state
@@ -54,9 +54,13 @@ initRenderer = do
 
        timeoutAdd (widgetQueueDraw canvas >> return True) 20
 
-       return $ \scGen -> do
-               writeIORef currentGardenRef scGen
-               widgetQueueDraw canvas
+       return $ nullObserver
+               { obGrowingState = \scGen -> do
+                       writeIORef currentGardenRef scGen
+                       widgetQueueDraw canvas
+               , obFinished = \_ ->
+                       mainQuit
+               }
 
 render :: Double -> Garden a -> Render ()
 render angle garden = do
index bd99c72..4b90593 100644 (file)
@@ -3,6 +3,7 @@ import Lseed.DB
 import Lseed.Grammar.Compile
 import Lseed.Grammar.Parse
 import Lseed.Logic
+import Lseed.Renderer.Cairo
 import Control.Applicative
 
 getGarden = spread <$> map (either (error.show) compileGrammarFile . parseGrammar "" . dbcCode)
@@ -12,4 +13,5 @@ getGarden = spread <$> map (either (error.show) compileGrammarFile . parseGramma
 
 main = do
        garden <- getGarden
-       runGarden garden
+       obs <- cairoObserver
+       lseedMainLoop obs 1 garden
index c35245d..104e5de 100644 (file)
@@ -3,12 +3,13 @@ import Lseed.Data.Functions
 import Lseed.Grammar.Compile
 import Lseed.Grammar.Parse
 import Lseed.Constants
-import Lseed.Logic
+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
@@ -28,4 +29,6 @@ readArgs doit = do
          where l = fromIntegral (length gs)
              
                
-main = readArgs runGarden
+main = readArgs $ \garden -> do
+       obs <- cairoObserver
+       lseedMainLoop True obs 1 garden