Lens-based sprite

sprite.hs

{-# LANGUAGE MultiWayIf, ExistentialQuantification, OverloadedStrings #-}
import FreeGame
import qualified Data.IntMap as IM
import Control.Lens

import Control.Monad.State
import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import qualified Data.Traversable as T

main = runGameDefault $ flip evalStateT (IM.empty, 0) $ do
    zoom _1 $ do
        at 0 ?= (mobile
            & position .~ V2 240 240
            & appearance .~ color "47F" (circle 32)
            & shape .~ (<32^2) . quadrance)
        at 1 ?= (mobile
            & position .~ V2 80 380
            & appearance .~ color "DD3" (circle 24)
            & shape .~ (<24^2) . quadrance)
        at 2 ?= (mobile
            & position .~ V2 400 370
            & appearance .~ color "E21" (circle 48)
            & shape .~ (<48^2) . quadrance)
    forever $ do
        whenM (keyDown KeySpace) $ _2 %= (`mod`3) . succ
        i <- use _2
        zoom _1 $ do
            get >>= lift . lift . T.mapM step >>= put
            Just p <- preuse (ix i . position)
            translate p $ color black $ polygonOutline [V2 50 0, V2 0 (-50), V2 (-50) 0, V2 0 50]
            whenM (keyPress KeyLeft) $ ix i . position += V2 (-2) 0
            whenM (keyPress KeyRight) $ ix i . position += V2 2 0
            whenM (keyPress KeyUp) $ ix i . position += V2 0 (-2)
            whenM (keyPress KeyDown) $ ix i . position += V2 0 2
        tick

mobile :: Sprite
mobile = flip Karakuri ((V2 0 0, const False, return ()), Nothing)
    $ \(a@(pos, sh, m), s) -> Crank a (\b -> (b, s)) $ translate pos $ do
        m
        btn <- mouseButtonL
        p <- mousePosition
        return $ if | Just ofs <- s, btn -> ((pos + p - ofs, sh, m), s)
                    | btn, sh p -> (a, Just p)
                    | otherwise -> (a, Nothing)

data Crank m a b t = Crank a (b -> t) (m t)

mapCrank :: (a -> a') -> Crank m a b t -> Crank m a' b t
mapCrank f (Crank a bt m) = Crank (f a) bt m
{-# INLINE mapCrank #-}

-- | Karakuri means automaton in Japanese.
data Karakuri m b a = forall s. Karakuri (s -> Crank m a b s) !s

step :: Monad m => Karakuri m b a -> m (Karakuri m b a)
step (Karakuri f s) = let Crank _ _ m = f s in Karakuri f `liftM` m
{-# INLINE step #-}

pass :: Karakuri m b a -> b -> Karakuri m b a
pass (Karakuri f s) b = let Crank _ bs _ = f s in Karakuri f (bs b)
{-# INLINE pass #-}

look :: Karakuri m b a -> a
look (Karakuri f s) = let Crank a _ _ = f s in a
{-# INLINE look #-}

instance Functor (Karakuri m b) where
    fmap f (Karakuri g s) = Karakuri (mapCrank f . g) s
    {-# INLINE fmap #-}

instance Monad m => Applicative (Karakuri m b) where
    pure a = Karakuri (const $ Crank a (const ()) (return ())) ()
    Karakuri c s0 <*> Karakuri d t0 = Karakuri go (s0, t0) where
        go (s, t) = let Crank f bs m = c s
                        Crank a bt n = d t
                    in Crank (f a) ((,) <$> bs <*> bt) (liftM2 (,) m n)
        {-# INLINE go #-}

type Contraption m a = Karakuri m a a

type Sprite = Contraption Frame (Vec2, Vec2 -> Bool, Frame ())

surface :: Lens' (Contraption m a) a
surface = lens look pass

position :: Lens' Sprite Vec2
position = surface . _1

shape :: Lens' Sprite (Vec2 -> Bool)
shape = surface . _2

appearance :: Lens' Sprite (Frame ())
appearance = surface . _3