```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 ```