diff options
Diffstat (limited to '')
| -rw-r--r-- | CHANGELOG.md | 3 | ||||
| -rw-r--r-- | app/Example/CircleThatMoves.hs | 39 | ||||
| -rw-r--r-- | app/Scratchy/Syntax.hs | 42 | ||||
| -rw-r--r-- | app/Scratchy/World.hs | 75 | ||||
| -rwxr-xr-x | app/Snakey/TwoSnakes.hs | 116 | ||||
| -rw-r--r-- | scratchy.cabal | 1 |
6 files changed, 146 insertions, 130 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 0f0c77b..e4c931c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,8 @@ # Revision history for scratchy +## 1.1.0.1 -- 2025-12-29 +* Changed code style to match Haskell style. + ## 1.1.0.0 -- 2025-12-27 * The solution for stopping the blinking effect was not to centralize collision detection, but to add a timeout diff --git a/app/Example/CircleThatMoves.hs b/app/Example/CircleThatMoves.hs index d173a3d..077ee1e 100644 --- a/app/Example/CircleThatMoves.hs +++ b/app/Example/CircleThatMoves.hs @@ -8,20 +8,25 @@ circSprite = NewSprite (15,15) (Color green $ circleSolid (cellSize * 0.6)) (\s -> - OnKeyEvent (Char 'w') - ( OnTargetReached s - (\cl -> SetTarget s (nextCell U cl) (Pure ())) - $ Pure () ) - $ OnKeyEvent (Char 's') - ( OnTargetReached s - (\cl -> SetTarget s (nextCell D cl) (Pure ())) - $ Pure () ) - $ OnKeyEvent (Char 'a') - ( OnTargetReached s - (\cl -> SetTarget s (nextCell L cl) (Pure ())) - $ Pure () ) - $ OnKeyEvent (Char 'd') - ( OnTargetReached s - (\cl -> SetTarget s (nextCell R cl) (Pure ())) - $ Pure () ) - $ Pure ()) + OnKeyEvent (Char 'w') + ( OnTargetReached s + (\cl -> SetTarget s (nextCell U cl) (Pure ())) $ + Pure () + ) $ + OnKeyEvent (Char 's') + ( OnTargetReached s + (\cl -> SetTarget s (nextCell D cl) (Pure ())) $ + Pure () + ) $ + OnKeyEvent (Char 'a') + ( OnTargetReached s + (\cl -> SetTarget s (nextCell L cl) (Pure ())) $ + Pure () + ) $ + OnKeyEvent (Char 'd') + ( OnTargetReached s + (\cl -> SetTarget s (nextCell R cl) (Pure ())) $ + Pure () + ) $ + Pure () + ) diff --git a/app/Scratchy/Syntax.hs b/app/Scratchy/Syntax.hs index 128ea01..277cebd 100644 --- a/app/Scratchy/Syntax.hs +++ b/app/Scratchy/Syntax.hs @@ -88,64 +88,64 @@ combine (Pure ()) p2 = p2 combine p1 (Pure ()) = p1 combine (OnKeyEvent k1 handler1 cont1) p2 = - OnKeyEvent k1 handler1 (combine cont1 p2) + OnKeyEvent k1 handler1 (combine cont1 p2) combine p1 (OnKeyEvent k2 handler2 cont2) = - OnKeyEvent k2 handler2 (combine p1 cont2) + OnKeyEvent k2 handler2 (combine p1 cont2) combine (OnTargetReached sp1 h1 c1) p2 = - OnTargetReached sp1 h1 (combine c1 p2) + OnTargetReached sp1 h1 (combine c1 p2) combine p1 (OnTargetReached sp2 h2 c2) = - OnTargetReached sp2 h2 (combine p1 c2) + OnTargetReached sp2 h2 (combine p1 c2) combine (OnTargetUpdated sp1 h1 c1) p2 = - OnTargetUpdated sp1 h1 (combine c1 p2) + OnTargetUpdated sp1 h1 (combine c1 p2) combine p1 (OnTargetUpdated sp2 h2 c2) = - OnTargetUpdated sp2 h2 (combine p1 c2) + OnTargetUpdated sp2 h2 (combine p1 c2) combine (OnBarrierHit sp1 h1 c1) p2 = - OnBarrierHit sp1 h1 (combine c1 p2) + OnBarrierHit sp1 h1 (combine c1 p2) combine p1 (OnBarrierHit sp2 h2 c2) = - OnBarrierHit sp2 h2 (combine p1 c2) + OnBarrierHit sp2 h2 (combine p1 c2) combine (After dur1 handler1 cont1) p2 = - After dur1 handler1 (combine cont1 p2) + After dur1 handler1 (combine cont1 p2) combine p1 (After dur2 handler2 cont2) = - After dur2 handler2 (combine p1 cont2) + After dur2 handler2 (combine p1 cont2) combine (NewSprite cell pic k1) p2 = - NewSprite cell pic (\sp -> combine (k1 sp) p2) + NewSprite cell pic (\sp -> combine (k1 sp) p2) combine p1 (NewSprite cell pic k2) = - NewSprite cell pic (combine p1 . k2) + NewSprite cell pic (combine p1 . k2) combine (SetColor sp c cont1) p2 = - SetColor sp c (combine cont1 p2) + SetColor sp c (combine cont1 p2) combine p1 (SetColor sp c cont2) = - SetColor sp c (combine p1 cont2) + SetColor sp c (combine p1 cont2) combine (SetTarget sp cell cont1) p2 = - SetTarget sp cell (combine cont1 p2) + SetTarget sp cell (combine cont1 p2) combine p1 (SetTarget sp cell cont2) = - SetTarget sp cell (combine p1 cont2) + SetTarget sp cell (combine p1 cont2) combine (GetTarget sp k1) p2 = - GetTarget sp (\cell -> combine (k1 cell) p2) + GetTarget sp (\cell -> combine (k1 cell) p2) combine p1 (GetTarget sp k2) = - GetTarget sp (combine p1 . k2) + GetTarget sp (combine p1 . k2) combine (SetBackgroundColor c cont1) p2 = - SetBackgroundColor c (combine cont1 p2) + SetBackgroundColor c (combine cont1 p2) combine p1 (SetBackgroundColor c cont2) = - SetBackgroundColor c (combine p1 cont2) + SetBackgroundColor c (combine p1 cont2) combine (InspectCell cell k1) p2 = - InspectCell cell (\result -> combine (k1 result) p2) + InspectCell cell (\result -> combine (k1 result) p2) diff --git a/app/Scratchy/World.hs b/app/Scratchy/World.hs index 89d45e5..c128682 100644 --- a/app/Scratchy/World.hs +++ b/app/Scratchy/World.hs @@ -186,52 +186,51 @@ tickTimers = Game $ \w@World{..} -> runProg :: Game () runProg = Game $ \w -> (go (prog w) w { prog = Pure () } , ()) - where - go :: SProg () -> World -> World - go (Pure ()) w = w + where + go :: SProg () -> World -> World + go (Pure ()) w = w - go (OnKeyEvent k handler cont) w = - go cont (w { keyHdlrs = (k, handler) : keyHdlrs 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 (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 (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 (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 (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 (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 (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 (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 (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 (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 }) + go (After dur handler cont) w = + go cont (w { timers = (dur, handler) : timers w }) diff --git a/app/Snakey/TwoSnakes.hs b/app/Snakey/TwoSnakes.hs index 2f02a99..cb7d291 100755 --- a/app/Snakey/TwoSnakes.hs +++ b/app/Snakey/TwoSnakes.hs @@ -4,67 +4,75 @@ import Scratchy.Syntax -- Helper functions moveSnake :: SpritePtr -> [SpritePtr] -> Dir -> SProg () -moveSnake h tailSeg dir = - OnTargetReached h (\pos -> - let newPos = nextCell dir pos in - InspectCell newPos (\case - HasSprite -> - SetBackgroundColor black $ - After 1 (SetBackgroundColor white $ Pure ()) $ - Pure () - HasBarrier -> - SetBackgroundColor red $ - After 1 (SetBackgroundColor white $ Pure ()) $ - Pure () - IsFree -> - SetTarget h newPos $ - moveTail pos tailSeg $ - Pure () - ) - ) $ Pure () +moveSnake h t d = + OnTargetReached h (\pos -> + let newPos = nextCell d pos in + InspectCell newPos (\case + HasSprite -> + SetBackgroundColor black $ + After 1 (SetBackgroundColor white $ Pure ()) $ + Pure () + HasBarrier -> + SetBackgroundColor red $ + After 1 (SetBackgroundColor white $ Pure ()) $ + Pure () + IsFree -> + SetTarget h newPos $ + moveTail pos t $ + Pure () + ) + ) $ + Pure () -moveTail :: (Int, Int) -> [SpritePtr] -> SProg () -> SProg () +moveTail :: Cell -> [SpritePtr] -> SProg () -> SProg () moveTail _ [] cont = cont moveTail prevPos (t:ts) cont = - GetTarget t (\curPos -> - SetTarget t prevPos $ - moveTail curPos ts cont - ) + GetTarget t (\curPos -> + SetTarget t prevPos $ + moveTail curPos ts cont + ) twoSnakes :: SProg () twoSnakes = - -- Green snake - NewSprite (5, 5) (Color green $ circleSolid (cellSize * 0.6)) $ \greenH -> - NewSprite (4, 5) (Color green $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \greenT1 -> - NewSprite (3, 5) (Color green $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \greenT2 -> - NewSprite (2, 5) (Color green $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \greenT3 -> - NewSprite (1, 5) (Color green $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \greenT4 -> - NewSprite (0, 5) (Color green $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \greenT5 -> - NewSprite (0, 4) (Color green $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \greenT6 -> - NewSprite (0, 3) (Color green $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \greenT7 -> - let greenTail = [greenT1,greenT2,greenT3,greenT4,greenT5,greenT6,greenT7] in + let headRadius = cellSize * 0.6 + tailSize = cellSize * 0.9 + in - -- Blue snake - NewSprite (15, 15) (Color blue $ circleSolid (cellSize * 0.6)) $ \blueH -> - NewSprite (16, 15) (Color blue $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \blueT1 -> - NewSprite (17, 15) (Color blue $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \blueT2 -> - NewSprite (18, 15) (Color blue $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \blueT3 -> - NewSprite (19, 15) (Color blue $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \blueT4 -> - NewSprite (19, 16) (Color blue $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \blueT5 -> - NewSprite (19, 17) (Color blue $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \blueT6 -> - NewSprite (19, 18) (Color blue $ rectangleSolid (cellSize * 0.9) (cellSize * 0.9)) $ \blueT7 -> - let blueTail = [blueT1,blueT2,blueT3,blueT4,blueT5,blueT6,blueT7] in + -- Green snake + NewSprite (5, 5) (Color green $ circleSolid headRadius) $ \gHead -> + NewSprite (4, 5) (Color green $ rectangleSolid tailSize tailSize) $ \gt1 -> + NewSprite (3, 5) (Color green $ rectangleSolid tailSize tailSize) $ \gt2 -> + NewSprite (2, 5) (Color green $ rectangleSolid tailSize tailSize) $ \gt3 -> + NewSprite (1, 5) (Color green $ rectangleSolid tailSize tailSize) $ \gt4 -> + NewSprite (0, 5) (Color green $ rectangleSolid tailSize tailSize) $ \gt5 -> + NewSprite (0, 4) (Color green $ rectangleSolid tailSize tailSize) $ \gt6 -> + NewSprite (0, 3) (Color green $ rectangleSolid tailSize tailSize) $ \gt7 -> - -- Green snake movement - OnKeyEvent (Char 'w') (moveSnake greenH greenTail U) $ - OnKeyEvent (Char 's') (moveSnake greenH greenTail D) $ - OnKeyEvent (Char 'a') (moveSnake greenH greenTail L) $ - OnKeyEvent (Char 'd') (moveSnake greenH greenTail R) $ + -- Blue snake + NewSprite (15, 15) (Color blue $ circleSolid headRadius) $ \bHead -> + NewSprite (16, 15) (Color blue $ rectangleSolid tailSize tailSize) $ \bt1 -> + NewSprite (17, 15) (Color blue $ rectangleSolid tailSize tailSize) $ \bt2 -> + NewSprite (18, 15) (Color blue $ rectangleSolid tailSize tailSize) $ \bt3 -> + NewSprite (19, 15) (Color blue $ rectangleSolid tailSize tailSize) $ \bt4 -> + NewSprite (19, 16) (Color blue $ rectangleSolid tailSize tailSize) $ \bt5 -> + NewSprite (19, 17) (Color blue $ rectangleSolid tailSize tailSize) $ \bt6 -> + NewSprite (19, 18) (Color blue $ rectangleSolid tailSize tailSize) $ \bt7 -> - -- Blue snake movement - OnKeyEvent (Char 'i') (moveSnake blueH blueTail U) $ - OnKeyEvent (Char 'k') (moveSnake blueH blueTail D) $ - OnKeyEvent (Char 'j') (moveSnake blueH blueTail L) $ - OnKeyEvent (Char 'l') (moveSnake blueH blueTail R) $ + -- List of tail sprites + let bTail = [bt1, bt2, bt3, bt4, bt5, bt6, bt7] + gTail = [gt1, gt2, gt3, gt4, gt5, gt6, gt7] + in - Pure () + -- Green snake movement + OnKeyEvent (Char 'w') (moveSnake gHead gTail U) $ + OnKeyEvent (Char 's') (moveSnake gHead gTail D) $ + OnKeyEvent (Char 'a') (moveSnake gHead gTail L) $ + OnKeyEvent (Char 'd') (moveSnake gHead gTail R) $ + + -- Blue snake movement + OnKeyEvent (Char 'i') (moveSnake bHead bTail U) $ + OnKeyEvent (Char 'k') (moveSnake bHead bTail D) $ + OnKeyEvent (Char 'j') (moveSnake bHead bTail L) $ + OnKeyEvent (Char 'l') (moveSnake bHead bTail R) $ + + Pure () diff --git a/scratchy.cabal b/scratchy.cabal index 83bb824..44a981a 100644 --- a/scratchy.cabal +++ b/scratchy.cabal @@ -29,6 +29,7 @@ version: 1.1.0.0 -- description: -- The license under which the package is released. +version: 1.1.0.1 license: NONE -- The package author(s). |