Llayland’s Food, Oracle, and Haskell

April 11, 2012

Trying to learn FRP 4 (stepped macros)

Filed under: Haskell — Tags: , , — llayland @ 2:15 am

The game in the last post worked, but the macros jumped to their target instead of following each step.  If we upgrade to Reactive-Banana 0.5, we can use the spill function to get an event that fires with the values of an array in sequence.

Thanks to Heinrich Apfelmus for clarifying that this usage is valid.

The rules of the game:

The user starts at the point (1,0)
Moving onto a point on the x=y line loses
moving onto the point (6,4) wins
The commands UP,DOWN,LEFT,RIGHT move the user
The command DEF <name> <string>…  defines macros
The command UNDEF String removes a macro
macros may refer to other macros

I moved the relevant FRP parts to the begining, but I still need the imports first

> import Reactive.Banana
> import Control.Monad
> import Data.Monoid
> import qualified Data.Map as Map
> import Prelude hiding (Left,Right)
> import Data.IORef   — I wish I could get rid of this

> networkDescription :: (IORef GameCondition) -> NetworkDescription t (Event t String) -> NetworkDescription t ()
> networkDescription condRef lineEnd = do
>    lineE <- lineEnd

The filterJust function fits nicely with our parse functions to create events that only fire on a successful parse

>    let defE = filterJust $ parseDef . words <$> lineE
>        undefE = filterJust $ parseUndef . words <$> lineE

The current dictionary is just the accumulation of the updates from the successful parses

>        dictB = accumB initialDict $ defE `union` undefE

We need both a behavior for the players position and an event that fires when we update the behavior.
A combinator for this is easy to build on top of the mapAccum combinator.

>        accumEB :: a -> Event t (a->a) -> (Event t a, Behavior t a)
>        accumEB seed e = mapAccum seed (fmap (\f -> pairAp f) e)
>           where pairAp f a = (f a, f a)

Here is the updated functionality to step through the macros.
We need to fire an event containing the list of steps in response to an entered line event.
Then, we spill that event to fire a sequence of events each containing a step.

>        stepsE = getMove <$> dictB <@> lineE
>        stepsEs = spill stepsE

We can determine the position with the sequence just like we did with the old aggregated event

>        (positionE, positionB) = accumEB (Sum 1, Sum 0) $ fmap mappend stepsEs

now we can fire events when the player reaches a position

>        loseE = filterE (uncurry (==)) positionE
>        winE = filterE (== (Sum 6, Sum 4)) positionE
>        quitE = filterE (== “quit”) lineE

Last, we react to some of the events.

>        exitWith retval = reactimate . fmap (const $ writeIORef condRef retval)
>
>    reactimate $ fmap print positionE
>    exitWith Lost loseE
>    exitWith Won winE
>    exitWith Quit quitE

Once again this was very easy. Here is a sample output to verify the change:

*Main> main
def n Up
(Sum {getSum = 1},Sum {getSum = 0})
def e Right
(Sum {getSum = 1},Sum {getSum = 0})
def wl e e e e e n n n n n n n n
(Sum {getSum = 1},Sum {getSum = 0})
wl
(Sum {getSum = 2},Sum {getSum = 0})
(Sum {getSum = 3},Sum {getSum = 0})
(Sum {getSum = 4},Sum {getSum = 0})
(Sum {getSum = 5},Sum {getSum = 0})
(Sum {getSum = 6},Sum {getSum = 0})
(Sum {getSum = 6},Sum {getSum = 1})
(Sum {getSum = 6},Sum {getSum = 2})
(Sum {getSum = 6},Sum {getSum = 3})
(Sum {getSum = 6},Sum {getSum = 4})
(Sum {getSum = 6},Sum {getSum = 5})
(Sum {getSum = 6},Sum {getSum = 6})
(Sum {getSum = 6},Sum {getSum = 7})
(Sum {getSum = 6},Sum {getSum = 8})
You Won

Notice that output continued after I won. I’ll fix that in the next post.

I’m not sure why I did not get a lost message when I hit (6,6); lazyness?

> eventLoop condRef fire = loop
>    where
>    loop = do
>       s <- getLine
>       fire s
>       cond <- readIORef condRef
>       when (cond == Playing) loop

> main = do
>   gameCondRef <- newIORef Playing
>   (addHandler,fire) <- newAddHandler
>   compile (networkDescription gameCondRef $ fromAddHandler addHandler ) >>= actuate
>   eventLoop gameCondRef fire
>   cond <- readIORef gameCondRef
>   putStrLn $ “You ” ++ show cond

Lets pull some types out of that desciption

> type XY = (Sum Int,Sum Int)

> data GameCondition = Won | Lost | Quit | Playing
>    deriving (Show, Eq)

> data Direction = Up | Down | Left | Right | Stay
>    deriving (Show, Enum)

> data Macro = Macro Direction
>            | Refs [String]
>    deriving Show

> type Dict = Map.Map String Macro

and the obvious functions

> xy :: Direction -> XY
> xy Up = (Sum 0,Sum 1); xy Down = (Sum 0,Sum (-1)); xy Left = (Sum (-1),Sum 0); xy Right = (Sum 1,Sum 0); xy Stay = (Sum 0, Sum 0)

> gameCond :: XY -> GameCondition
> gameCond p@(x,y) | x == y     = Lost
>                  | p == (Sum 6,Sum 4) = Won
>                  | otherwise  = Playing

> getMove :: Dict -> String -> [XY]
> getMove d k = case Map.lookup k d of
>                 Nothing -> [xy Stay]
>                 Just (Macro m) -> [xy m]
>                 Just (Refs rs) -> concatMap (getMove d) $ rs

> parseDef :: [String] -> Maybe (Dict -> Dict)
> parseDef (“def”:name:rs) = Just $ Map.insert name (Refs rs)
> parseDef _ = Nothing

> parseUndef :: [String] -> Maybe (Dict -> Dict)
> parseUndef [“undef”,name] = Just $ Map.delete name
> parseUndef _ = Nothing

We’ll need to start with a dictionary containing the basic movement commands

> initialDict = Map.fromList . map namer $ [Up .. Right]
>   where namer x = (show x, Macro x)

Leave a Comment »

No comments yet.

RSS feed for comments on this post. TrackBack URI

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Create a free website or blog at WordPress.com.

%d bloggers like this: