summaryrefslogtreecommitdiff
path: root/app/Scratchy/World.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--app/Scratchy/World.hs53
1 files changed, 50 insertions, 3 deletions
diff --git a/app/Scratchy/World.hs b/app/Scratchy/World.hs
index e727baf..89d45e5 100644
--- a/app/Scratchy/World.hs
+++ b/app/Scratchy/World.hs
@@ -6,6 +6,8 @@ import Graphics.Gloss.Interface.Pure.Game
import Scratchy.Syntax
+import Data.Bifunctor (bimap)
+
-- Some useful helpers
------------------------------------------------------------
@@ -184,7 +186,52 @@ tickTimers = Game $ \w@World{..} ->
runProg :: Game ()
runProg = Game $ \w -> (go (prog w) w { prog = Pure () } , ())
- where
- go :: SProg () -> World -> World
- go = undefined -- Fill this in
+ where
+ go :: SProg () -> World -> World
+ go (Pure ()) w = w
+
+ go (OnKeyEvent k handler cont) w =
+ go cont (w { keyHdlrs = (k, handler) : keyHdlrs w })
+
+ go (OnTargetReached ptr handler cont) w =
+ go cont (w { trHdlrs = (ptr, handler) : trHdlrs w })
+
+ go (OnTargetUpdated ptr handler cont) w =
+ go cont (w { tuHdlrs = (ptr, handler) : tuHdlrs w })
+
+ go (OnBarrierHit ptr handler cont) w =
+ go cont (w { bhHdlrs = (ptr, handler) : bhHdlrs w })
+
+ go (NewSprite cell pic k) w =
+ let ptr = length (sprites w)
+ sprite = Sprite pic (bimap fromIntegral fromIntegral cell) cell
+ in go (k ptr) (w { sprites = sprites w ++ [sprite] })
+
+ go (SetColor ptr c cont) w =
+ go cont (w { sprites = setAt ptr (spr { pic = pic' })
+ (sprites w) })
+ where
+ spr = sprites w !! ptr
+ pic' = Graphics.Gloss.Interface.Pure.Game.color c (pic spr)
+
+ go (SetTarget ptr cell cont) w =
+ let w' = fst $ runGame (setSpriteTarget ptr cell) w
+ in go cont w'
+
+ go (GetTarget ptr k) w =
+ let targetCell = tgt (sprites w !! ptr)
+ in go (k targetCell) w
+
+ go (SetBackgroundColor c cont) w =
+ go cont (w { bg = c })
+
+ go (InspectCell cell k) w =
+ case spriteExistsAt cell (sprites w) of
+ Just _ -> go (k HasSprite) w
+ Nothing ->
+ if inBounds cell
+ then go (k IsFree) w
+ else go (k HasBarrier) w
+ go (After dur handler cont) w =
+ go cont (w { timers = (dur, handler) : timers w })