Homework/KarelSemantics.hs

module KarelSemantics where

import Prelude hiding (Either(..))
import Data.Function (fix)

import KarelSyntax
import KarelState


-- | Valuation function for Test.
test :: Test -> World -> Robot -> Bool
test (Not t) w r = not $ test t w r
test (Facing c) w (_, c', _) = c == c'
test (Clear d) w (p, c, _) = isClear (neighbor (cardTurn d c) p) w
test Beeper w (p, _, _) = hasBeeper p w
test Empty w (_, _, i) = i == 0

-- | Valuation function for Stmt.
stmt :: Stmt -> Defs -> World -> Robot -> Result
stmt Shutdown   _ _ r = Done r
stmt PickBeeper _ w r = let p = getPos r
                        in if hasBeeper p w
                              then OK (decBeeper p w) (incBag r)
                              else Error ("No beeper to pick at: " ++ show p)
stmt Move _ w (p, c, i) =
    case w np of
        Just n -> OK w (np, c, i)
        Nothing -> Error ("Blocked at: " ++ show np)
    where np = neighbor c p
stmt PutBeeper _ w (p, c, i) = case i of
    0 -> Error ("No beeper to put.")
    n -> OK (incBeeper p w) (p, c, n - 1)
stmt (Turn d) _ w (p, c, i) = OK w (p, cardTurn d c, i)
stmt (Call m) e w r = case lookup m e of
    Just x -> stmt x e w r
    Nothing -> Error ("Undefined macro: " ++ m)
stmt (Iterate n s) e w r = several (take n $ cycle [s]) e w r
stmt (If c t el) e w r =
    if test c w r
    then stmt t e w r
    else stmt el e w r
stmt (While t es) e w r =
    if test t w r
    then onOK (\w' r' -> stmt (While t es) e w' r') (stmt es e w r)
    else OK w r
stmt (Block es) e w r = several es e w r

several :: [Stmt] -> Defs -> World -> Robot -> Result
several xs d w r = foldl (\rs s -> onOK (\w' r' -> stmt s d w' r') rs) (OK w r) xs
    
-- | Run a Karel program.
prog :: Prog -> World -> Robot -> Result
prog (m,s) w r = stmt s m w r