LookAtパターン・改改

LookAt.hs

{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances, GADTs, FlexibleContexts #-}
import Control.Monad.State
import Control.Lens
import Control.Monad.Operational.TH (makeSingletons)
import Control.Monad.Operational.Mini
import Data.Functor.Product

data Pattern p q x where
  Hook :: Either (State p ()) (State q ()) -> Pattern p q ()
  Self :: Pattern p q p
  Env :: Pattern p q q

makeSingletons ''Pattern

type LookAt p q = Program (Pattern p q)

runLookAt :: p -> q -> LookAt p q a -> Product (State p) (State q) a
runLookAt p q = interpret (step p q) where
  step :: p -> q -> Pattern p q a -> Product (State p) (State q) a
  step _ _ (Hook (Left f)) = Pair f (return ())
  step _ _ (Hook (Right f)) = Pair (return ()) f
  step p _ Self = Pair (return p) (return p)
  step _ q Env = Pair (return q) (return q)

data Chara = Chara { _posC :: (Int, Int) } deriving (Eq, Show)
data Bullet = Bullet { _posB :: (Int, Int) } deriving (Eq, Show)
data Field = Field {
  _player :: Chara,
  _bullets :: [Bullet]
  } deriving (Eq, Show)
f = Field (Chara (0,100)) [Bullet (100,200), Bullet (20,300)]

makeLenses ''Chara
makeLenses ''Bullet
makeLenses ''Field

updateChara :: LookAt Chara Field ()
updateChara = do
  p <- self
  hook $ Left $ do
    let (x,y) = p^.posC
    posC .= (x+100, y-100)

bulletA :: LookAt Bullet Field ()
bulletA = do
  b <- self
  f <- env
  hook $ Left $ do
    (x,y) <- (^.posB) `fmap` get
    posB .= (x,length (f^.bullets))
  hook $ Right $ do
    bullets %= (b:)

runBullets :: State Field ()
runBullets = do
  bs <- use bullets
  f <- use id
  let pairs = map (\b -> runLookAt b f bulletA) bs
  bullets .= (map (\(b,f) -> execState f b) $ zip bs $ map (\(Pair f _) -> f) pairs)
  modify $ execState $ mapM (\(Pair _ g) -> g) pairs

{-
-- p is connected to (/ stands on) q under relationship r with environment m
class Connected m p q where
  hook :: m p () -> m q ()
  self :: m q p

newtype State' a b = State' (State a b)
unState' :: State' a b -> State a b
unState' (State' m) = m

instance Connected State' Chara Field where
  hook (State' m) = State' $ player %= execState m
  self = State' $ use player
-}