Initial commit

8 files changed, 464 insertions, 0 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..71356d4
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for scratchy
+
+## 0.1.0.0 -- 2025-12-15
+
+* Initial state of the project. Only includes the given files.
diff --git a/app/Example/CircleThatMoves.hs b/app/Example/CircleThatMoves.hs
new file mode 100644
index 0000000..9d9aa8b
--- /dev/null
+++ b/app/Example/CircleThatMoves.hs
@@ -0,0 +1,19 @@
+module Example.CircleThatMoves where
+
+import Graphics.Gloss.Interface.Pure.Game
+import Scratchy.Syntax
+
+circSprite :: SProg ()
+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 () )
+    $ Pure ())
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..d001db6
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import Scratchy as S
+
+main :: IO ()
+main = S.main
diff --git a/app/Scratchy.hs b/app/Scratchy.hs
new file mode 100644
index 0000000..cea910d
--- /dev/null
+++ b/app/Scratchy.hs
@@ -0,0 +1,76 @@
+module Scratchy where
+
+import Graphics.Gloss.Interface.Pure.Game
+
+import Scratchy.World
+import Scratchy.Syntax
+
+import Example.CircleThatMoves
+
+-- Main
+------------------------------------------------------------
+
+main :: IO ()
+main = play
+  (InWindow "Scratchy" (winW, winH) (100, 100))
+  white
+  120
+  (World
+    white
+    []
+    []
+    circSprite
+    []
+    []
+    []
+    []
+    [])
+  drawWorld
+  (\e -> fst . runGame (handleEvent e))
+  (\tick ->
+     fst . runGame ( runProg
+                     >> moveSprites tick
+                     >> handleKeyEvents
+                     >> tickTimers
+                     >> runProg
+                   ) )
+
+
+-- Rendering
+------------------------------------------------------------
+
+drawWorld :: World -> Picture
+drawWorld World{..} =
+  Pictures
+    ( backgroundFrom bg
+    : drawGrid
+    : map drawSprite sprites )
+
+backgroundFrom :: Color -> Picture
+backgroundFrom c =
+  let w' = fromIntegral gridW * cellSize
+      h' = fromIntegral gridH * cellSize
+  in Color c (rectangleSolid w' h')
+
+drawGrid :: Picture
+drawGrid =
+  let halfW = fromIntegral gridW * cellSize / 2
+      halfH = fromIntegral gridH * cellSize / 2
+      xs = [(-halfW), (-halfW + cellSize) .. halfW]
+      ys = [(-halfH), (-halfH + cellSize) .. halfH]
+      vlines = [ Line [ (x, -halfH), (x,  halfH) ] | x <- xs ]
+      hlines = [ Line [ (-halfW, y), ( halfW, y) ] | y <- ys ]
+  in Color (greyN 0.85) (Pictures (vlines ++ hlines))
+
+drawSprite :: Sprite -> Picture
+drawSprite Sprite{..} =
+  let (x, y) = toScreen pos
+  in Translate x y $ pic
+
+toScreen :: (Float, Float) -> (Float, Float)
+toScreen (gx, gy) =
+  let fx = gx - (fromIntegral gridW - 1) / 2
+      fy = gy - (fromIntegral gridH - 1) / 2
+  in (fx * cellSize, fy * cellSize)
+
+
diff --git a/app/Scratchy/.DS_Store b/app/Scratchy/.DS_Store
new file mode 100644
index 0000000..5008ddf
--- /dev/null
+++ b/app/Scratchy/.DS_Store
diff --git a/app/Scratchy/Syntax.hs b/app/Scratchy/Syntax.hs
new file mode 100644
index 0000000..c77e51a
--- /dev/null
+++ b/app/Scratchy/Syntax.hs
@@ -0,0 +1,87 @@
+module Scratchy.Syntax where
+
+import Graphics.Gloss.Interface.Pure.Game
+
+
+-- Types
+------------------------------------------------------------
+
+type Duration  = Int
+type Pos       = (Float, Float)
+type Cell      = (Int, Int)
+type SpritePtr = Int
+
+
+-- Constants
+------------------------------------------------------------
+
+cellsPerSec :: Float
+cellsPerSec = 5
+
+gridW, gridH :: Int
+gridW = 30
+gridH = 30 -- FIXME: move.
+
+inBounds :: (Int,Int) -> Bool
+inBounds (x,y) = x >= 0 && x < gridW && y >= 0 && y < gridH
+
+cellSize :: Float
+cellSize = 30
+
+winW, winH :: Int
+winW = round (fromIntegral gridW * cellSize)
+winH = round (fromIntegral gridH * cellSize)
+
+
+-- Direction
+------------------------------------------------------------
+
+data Dir = U | D | L | R deriving (Eq,Ord,Show)
+
+dirVec :: Dir -> (Int, Int)
+dirVec U = (0, 1)
+dirVec D = (0,-1)
+dirVec L = (-1,0)
+dirVec R = (1, 0)
+
+nextCell :: Dir -> (Int, Int) -> (Int, Int)
+nextCell d (cx,cy) =
+  let (dx,dy) = dirVec d
+  in (cx + dx, cy + dy)
+
+
+-- Syntax
+------------------------------------------------------------
+
+data InspectionResult
+  = HasBarrier | HasSprite | IsFree
+
+data SProg a
+  = Pure a
+
+  -- Event listening
+  | OnKeyEvent Key (SProg ()) (SProg a) -- Listener for a specific key
+  | OnTargetReached SpritePtr (Cell -> SProg ()) (SProg a) -- Listener for a specific sprite
+  | OnTargetUpdated SpritePtr (Cell -> Cell -> SProg ()) (SProg a) -- Listener for a specific sprite
+  | OnBarrierHit SpritePtr (Cell -> Cell -> SProg ()) (SProg a)
+
+  -- Sprite and grid actions
+  | NewSprite Cell Picture (SpritePtr -> SProg a)
+  | SetColor SpritePtr Color (SProg a)
+  | SetTarget SpritePtr Cell (SProg a)
+  | GetTarget SpritePtr (Cell -> SProg a)
+  | SetBackgroundColor Color (SProg a)
+  | InspectCell Cell (InspectionResult -> SProg a)
+
+  -- Timer
+  | After Duration (SProg ()) (SProg a)
+  deriving Functor
+
+
+-- Combining programs
+------------------------------------------------------------
+
+combine :: SProg () -> SProg () -> SProg ()
+combine = undefined -- Fill this in
+
+
diff --git a/app/Scratchy/World.hs b/app/Scratchy/World.hs
new file mode 100644
index 0000000..e727baf
--- /dev/null
+++ b/app/Scratchy/World.hs
@@ -0,0 +1,190 @@
+module Scratchy.World where
+
+import Data.List (partition)
+import Control.Monad
+import Graphics.Gloss.Interface.Pure.Game
+
+import Scratchy.Syntax
+
+
+-- Some useful helpers
+------------------------------------------------------------
+
+imapM :: Applicative m => (Int -> a -> m b) -> [a] -> m [b]
+imapM f = zipWithM f [0..]
+
+imapM_ :: Applicative m => (Int -> a -> m b) -> [a] -> m ()
+imapM_ f xs = () <$ zipWithM f [0..] xs
+
+setAt :: Int -> a -> [a] -> [a]
+setAt i x xs = zipWith (\j y -> if i == j then x else y) [0..] xs
+
+swap :: (a, b) -> (b, a)
+swap (x, y) = (y, x)
+
+
+-- Sprites
+------------------------------------------------------------
+
+data Sprite = Sprite
+  { pic  :: Picture
+  , pos  :: Pos
+  , tgt  :: Cell }
+  deriving (Show , Eq)
+
+
+-- World
+------------------------------------------------------------
+
+data World = World
+  { bg        :: Color
+  , sprites   :: ![Sprite]
+  , keysHeld  :: ![Key]
+  , prog      :: !(SProg ())        -- Current program
+  , keyHdlrs  :: ![(Key, SProg ())] -- Key pressed
+  , trHdlrs   :: ![( SpritePtr
+                   , Cell
+                     -> SProg () )] -- Target reached
+  , tuHdlrs   :: ![( SpritePtr
+                   , Cell
+                     -> Cell
+                     -> SProg () )] -- Target updated
+  , bhHdlrs   :: ![( SpritePtr
+                   , Cell
+                     -> Cell
+                     -> SProg () )] -- Barrier hit
+  , timers    :: ![(Duration, SProg ())] -- Timers
+  }
+
+
+-- Game
+------------------------------------------------------------
+
+newtype Game a = Game { runGame :: World -> (World, a) }
+  deriving Functor
+
+instance Applicative Game where
+  pure x = Game $ \w -> (w,x)
+  (<*>) = ap
+
+instance Monad Game where
+  Game f >>= k = Game $ \w ->
+    let (w', x) = f w in runGame (k x) w'
+
+
+-- Sprite movement ops
+------------------------------------------------------------
+
+moveSprites :: Float -> Game ()
+moveSprites dt = Game $ \w@World{..} ->
+  let (w', sprites') = flip runGame w $ imapM (moveSprite dt) sprites
+  in ( w' { sprites = sprites' }
+     , () )
+
+moveSprite :: Float -> SpritePtr -> Sprite -> Game Sprite
+moveSprite dt ptr m@Sprite{..} = Game $ \w@World{..} ->
+  let (tx,ty) = tgt
+      (px,py) = pos
+      dx = fromIntegral tx - px
+      dy = fromIntegral ty - py
+      dist = sqrt (dx*dx + dy*dy)
+      stepSize = cellsPerSec * dt
+  in if dist <= stepSize * dt
+     then ( w { prog
+                = prog `combine`
+                (case lookup ptr trHdlrs of
+                   Just f -> f tgt
+                   Nothing -> Pure ()) }
+          , m { pos = (fromIntegral tx, fromIntegral ty) } )
+     else ( w
+          , m { pos = ( px + (stepSize/dist)*dx
+                      , py + (stepSize/dist)*dy ) } )
+
+setSpriteTarget :: SpritePtr -> Cell -> Game ()
+setSpriteTarget ptr c = Game $ \w@World{..} -> 
+  let spr = sprites !! ptr in
+  if inBounds c
+  then ( w { sprites
+             = setAt ptr
+                 (spr { tgt = c })
+                 sprites
+           , prog
+             = prog `combine`
+               (case lookup ptr tuHdlrs of
+                  Just f -> f (tgt spr) c
+                  Nothing -> Pure ()) }
+       , () )
+  else ( w { prog
+             = prog `combine`
+               (case lookup ptr bhHdlrs of
+                  Just f -> f (tgt spr) c
+                  Nothing -> Pure ()) }
+       , () )
+
+spriteExistsAt :: Cell -> [Sprite] -> Maybe SpritePtr
+spriteExistsAt c = go . zip [0..]
+  where
+    go [] = Nothing
+    go ((p,s):sprs) =
+      let (p1, p2) = pos s
+          c'       = (round p1, round p2)
+      in if c == c' || c == tgt s then Just p else go sprs
+
+-- Input handling
+------------------------------------------------------------
+
+handleEvent :: Event -> Game ()
+handleEvent (EventKey c d _ _) = case d of
+  Down -> press c
+  Up   -> release c
+handleEvent _ = pure ()
+
+press :: Key -> Game ()
+press d = Game $ \w@World{..} ->
+  ( w { keysHeld = d : filter (/= d) keysHeld }
+  , () )
+
+release :: Key -> Game ()
+release d = Game $ \w@World{..} ->
+  ( w { keysHeld = filter (/= d) keysHeld }
+  , () )
+
+handleKeyEvents :: Game ()
+handleKeyEvents = Game $ \w@World{..} ->
+  ( fst
+    $ flip runGame w
+    $ mapM_ handleKey keysHeld
+  , () )
+
+handleKey :: Key -> Game ()
+handleKey k = Game $ \w@World{..} ->
+  ( w { prog
+        = prog `combine`
+          (case lookup k keyHdlrs of
+             Just m -> m
+             Nothing -> Pure ()) }
+  , () )
+
+
+-- Timers
+------------------------------------------------------------
+
+tickTimers :: Game ()
+tickTimers = Game $ \w@World{..} -> 
+  let ts = map (\(d,m) -> (d-1,m)) timers
+      (done,remaining) = partition (\(d,_) -> d <= 0) ts
+      p' = foldr (\(_,m) -> combine m) (Pure ()) done
+  in ( w { timers = remaining
+         , prog = prog `combine` p' }
+     , () )
+
+
+-- Running programs
+------------------------------------------------------------
+
+runProg :: Game ()
+runProg = Game $ \w -> (go (prog w) w { prog = Pure () } , ())
+  where
+    go :: SProg () -> World -> World
+    go = undefined -- Fill this in
+
diff --git a/scratchy.cabal b/scratchy.cabal
new file mode 100644
index 0000000..6b95628
--- /dev/null
+++ b/scratchy.cabal
@@ -0,0 +1,81 @@
+cabal-version:      3.0
+-- The cabal-version field refers to the version of the .cabal specification,
+-- and can be different from the cabal-install (the tool) version and the
+-- Cabal (the library) version you are using. As such, the Cabal (the library)
+-- version used must be equal or greater than the version stated in this field.
+-- Starting from the specification version 2.2, the cabal-version field must be
+-- the first thing in the cabal file.
+
+-- Initial package description 'scratchy' generated by
+-- 'cabal init'. For further documentation, see:
+--   http://haskell.org/cabal/users-guide/
+--
+-- The name of the package.
+name:               scratchy
+
+-- The package version.
+-- See the Haskell package versioning policy (PVP) for standards
+-- guiding when and how versions should be incremented.
+-- https://pvp.haskell.org
+-- PVP summary:     +-+------- breaking API changes
+--                  | | +----- non-breaking API additions
+--                  | | | +--- code changes with no API change
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- The license under which the package is released.
+license:            NONE
+
+-- The package author(s).
+author:             DM580 Participant
+
+-- An email address to which users can send suggestions, bug reports, and patches.
+maintainer:         your.email@sdu.dk
+
+-- A copyright notice.
+-- copyright:
+category:           Game
+build-type:         Simple
+
+-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.
+extra-doc-files:    CHANGELOG.md
+
+-- Extra source files to be distributed with the package, such as examples, or a tutorial module.
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+executable scratchy
+    -- Import common warning flags.
+    import:           warnings
+
+    -- .hs or .lhs file containing the Main module.
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    other-modules:    Scratchy
+                    , Scratchy.Syntax
+                    , Scratchy.World
+                    , Example.CircleThatMoves
+                        
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    default-extensions: RecordWildCards
+                      , DeriveFunctor
+    
+    -- Other library packages from which modules are imported.
+    build-depends:    base ^>=4.21.0.0, gloss
+
+    -- Directories containing source files.
+    hs-source-dirs:   app
+
+    -- Base language which the package is written in.
+    default-language: Haskell2010