path: root/app/Scratchy/World.hs

module Scratchy.World where

import Data.List (partition)
import Control.Monad
import Graphics.Gloss.Interface.Pure.Game

import Scratchy.Syntax

import Data.Bifunctor (bimap)


-- 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 (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 })