From aa9fc62a29c865452f3e5437c4166854583bba97 Mon Sep 17 00:00:00 2001 From: Mikkel Thestrup Date: Tue, 16 Dec 2025 14:10:27 +0100 Subject: Initial commit --- app/Example/CircleThatMoves.hs | 19 +++++ app/Main.hs | 6 ++ app/Scratchy.hs | 76 +++++++++++++++++ app/Scratchy/.DS_Store | Bin 0 -> 6148 bytes app/Scratchy/Syntax.hs | 87 +++++++++++++++++++ app/Scratchy/World.hs | 190 +++++++++++++++++++++++++++++++++++++++++ 6 files changed, 378 insertions(+) create mode 100644 app/Example/CircleThatMoves.hs create mode 100644 app/Main.hs create mode 100644 app/Scratchy.hs create mode 100644 app/Scratchy/.DS_Store create mode 100644 app/Scratchy/Syntax.hs create mode 100644 app/Scratchy/World.hs (limited to 'app') 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 Binary files /dev/null and b/app/Scratchy/.DS_Store differ 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 + -- cgit v1.2.3-70-g09d2