summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--app/Scratchy/Syntax.hs66
-rw-r--r--app/Scratchy/World.hs53
2 files changed, 115 insertions, 4 deletions
diff --git a/app/Scratchy/Syntax.hs b/app/Scratchy/Syntax.hs
index c77e51a..128ea01 100644
--- a/app/Scratchy/Syntax.hs
+++ b/app/Scratchy/Syntax.hs
@@ -82,6 +82,70 @@ data SProg a
------------------------------------------------------------
combine :: SProg () -> SProg () -> SProg ()
-combine = undefined -- Fill this in
+-- Base cases
+combine (Pure ()) p2 = p2
+combine p1 (Pure ()) = p1
+combine (OnKeyEvent k1 handler1 cont1) p2 =
+ OnKeyEvent k1 handler1 (combine cont1 p2)
+
+combine p1 (OnKeyEvent k2 handler2 cont2) =
+ OnKeyEvent k2 handler2 (combine p1 cont2)
+
+combine (OnTargetReached sp1 h1 c1) p2 =
+ OnTargetReached sp1 h1 (combine c1 p2)
+
+combine p1 (OnTargetReached sp2 h2 c2) =
+ OnTargetReached sp2 h2 (combine p1 c2)
+
+combine (OnTargetUpdated sp1 h1 c1) p2 =
+ OnTargetUpdated sp1 h1 (combine c1 p2)
+
+combine p1 (OnTargetUpdated sp2 h2 c2) =
+ OnTargetUpdated sp2 h2 (combine p1 c2)
+
+combine (OnBarrierHit sp1 h1 c1) p2 =
+ OnBarrierHit sp1 h1 (combine c1 p2)
+
+combine p1 (OnBarrierHit sp2 h2 c2) =
+ OnBarrierHit sp2 h2 (combine p1 c2)
+
+combine (After dur1 handler1 cont1) p2 =
+ After dur1 handler1 (combine cont1 p2)
+
+combine p1 (After dur2 handler2 cont2) =
+ After dur2 handler2 (combine p1 cont2)
+
+combine (NewSprite cell pic k1) p2 =
+ NewSprite cell pic (\sp -> combine (k1 sp) p2)
+
+combine p1 (NewSprite cell pic k2) =
+ NewSprite cell pic (combine p1 . k2)
+
+combine (SetColor sp c cont1) p2 =
+ SetColor sp c (combine cont1 p2)
+
+combine p1 (SetColor sp c cont2) =
+ SetColor sp c (combine p1 cont2)
+
+combine (SetTarget sp cell cont1) p2 =
+ SetTarget sp cell (combine cont1 p2)
+
+combine p1 (SetTarget sp cell cont2) =
+ SetTarget sp cell (combine p1 cont2)
+
+combine (GetTarget sp k1) p2 =
+ GetTarget sp (\cell -> combine (k1 cell) p2)
+
+combine p1 (GetTarget sp k2) =
+ GetTarget sp (combine p1 . k2)
+
+combine (SetBackgroundColor c cont1) p2 =
+ SetBackgroundColor c (combine cont1 p2)
+
+combine p1 (SetBackgroundColor c cont2) =
+ SetBackgroundColor c (combine p1 cont2)
+
+combine (InspectCell cell k1) p2 =
+ InspectCell cell (\result -> combine (k1 result) p2)
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 })