Add homework 6 solutions

Did it on paper first!

HW1.fedorind.hs

@@ -10,7 +10,7 @@ data Tree
 
 -- | An example binary tree, which will be used in tests.
 t1 :: Tree
-t1 = Node 1 (Node 2 (Node 3 (Leaf 4) (Leaf 5))
+t1 = Node 1 (Node 2 (Node 3 (Leaf 4) (Lea 5))
                     (Leaf 6))
             (Node 7 (Leaf 8) (Leaf 9))
 
@@ -62,7 +62,7 @@ treeFold f a (Node i l r) = f i $ treeFold f (treeFold f a r) l
 --   1
 --
 leftmost :: Tree -> Int
-leftmost = treeFoldr1 const
+leftmost = treeFoldr1 (\a _ -> a)
 
 -- | The integer at the right-most node of a binary tree.
 --
@@ -79,7 +79,7 @@ leftmost = treeFoldr1 const
 --   9
 --
 rightmost :: Tree -> Int
-rightmost = treeFoldl1 const
+rightmost = treeFoldl1 (\a _ -> a)
 
 -- | Get the maximum integer from a binary tree.
 --

HW2.fedorind.hs

@@ -73,7 +73,7 @@ mapTree = fmap
 valueAt :: Path -> Tree a -> Maybe a
 valueAt _ End = Nothing
 valueAt [] (Node a _ _) = Just a
-valueAt (x:xs) (Node a l r) = valueAt xs $ if x == L then l else r
+valueAt (x:xs) (Node _ l r) = valueAt xs $ if x == L then l else r
 
 -- | Find a path to a node that contains the given value.
 --
@@ -92,12 +92,12 @@ valueAt (x:xs) (Node a l r) = valueAt xs $ if x == L then l else r
 --   >>> pathTo 10 ex
 --   Nothing
 --
+
 pathTo :: Eq a => a -> Tree a -> Maybe Path
-pathTo v End = Nothing
+pathTo _ End = Nothing
 pathTo v (Node a l r) = orElse currentNode $ orElse (pathHelper v l L) $ pathHelper v r R
     where
         currentNode = if a == v then Just [] else Nothing
-        pathHelper v tree dir = (pathTo v tree) >>= (Just . (dir:))
-        orElse m1 m2 = case m1 of
-            Just _ -> m1
-            Nothing -> m2
+        pathHelper _ tree dir = fmap (dir:) (pathTo v tree)
+        orElse m1 m2 = if isJust m1 then m1 else m2
+        isJust mx = mx /= Nothing

HW3.fedorind.hs

@@ -0,0 +1,102 @@
+-- Author: Danila Fedorin
+import Data.List
+
+-- Definitions
+type Var = String
+type Macro = String
+
+data PenMode = Up | Down
+
+data Expr = Variable Var
+          | Number Int
+          | Sum Expr Expr
+
+data Cmd = Pen PenMode
+         | Move Expr Expr
+         | Define Macro [Var] Prog
+         | Call Macro [Expr]
+
+type Prog = [Cmd]
+
+-- HW Code
+-- define line(x1, y1, x2, y2) {
+--     pen up; move (x1, y1);
+--     pen down; move(x2, y2);
+-- }
+lineMacro = Define "line" [ "x1", "y1", "x2", "y2" ]
+    [ Pen Up
+    , Move (Variable "x1") (Variable "y1")
+    , Pen Down
+    , Move (Variable "x2") (Variable "y2")
+    ]
+
+-- define nix(x, y, w, h) {
+--     call line(x, y, x + w, y + h);
+--     call line(x + w, y, x, y + h);
+-- }
+nixMacro = Define "nix" [ "x", "y", "w", "h" ]
+    [ Call "line"
+        [ Variable "x"
+        , Variable "y"
+        , Sum (Variable "x") (Variable "w")
+        , Sum (Variable "y") (Variable "h")
+        ]
+    , Call "line"
+        [ Sum (Variable "x") (Variable "w")
+        , Variable "y"
+        , Variable "x"
+        , Sum (Variable "y") (Variable "h")
+        ]
+    ]
+
+steps :: Int -> Prog
+steps n = base ++ stepList
+    where
+        base = [ Pen Up, Move (Number 0) (Number 0), Pen Down ]
+        stepList = [1..n] >>= (\i -> [ Move (Number (i -1)) (Number i), Move (Number i) (Number i) ])
+
+prettyPrintExpr :: Expr -> String
+prettyPrintExpr (Variable v) = v
+prettyPrintExpr (Number i) = show i
+prettyPrintExpr (Sum l r) = prettyPrintExpr l ++ "+" ++ prettyPrintExpr r
+
+prettyPrintPenMode :: PenMode -> String
+prettyPrintPenMode Up = "up"
+prettyPrintPenMode Down = "down"
+
+prettyPrintCmd :: Cmd -> [String]
+prettyPrintCmd (Pen m) = [ "pen " ++ prettyPrintPenMode m ++ ";" ]
+prettyPrintCmd (Move l r) = [ "move(" ++ prettyPrintExpr l ++ ", " ++ prettyPrintExpr r ++ ");" ]
+prettyPrintCmd (Define m vs cmds) = ("define " ++ m ++ "(" ++ intercalate ", " vs ++ ") {") : map ("    " ++) (cmds >>= prettyPrintCmd) ++ [ "}" ]
+prettyPrintCmd (Call n xs) = [ "call " ++ n ++ "(" ++ intercalate ", " (map prettyPrintExpr xs) ++ ");" ]
+
+pretty :: Prog -> String
+pretty prog = intercalate "\n" $ (prog >>= prettyPrintCmd) ++ [ "" ]
+
+macros :: Prog -> [Macro]
+macros xs = xs >>= macrosC
+    where
+        macrosC (Define n vs cs) = n:(cs >>= macrosC)
+        macrosC _ = []
+
+sortWith :: Ord b => (a -> b) -> [a] -> [a]
+sortWith f = sortBy (\l r -> compare (f l) (f r))
+
+optE :: Expr -> Expr
+optE expr = mergeAll $ sortWith exprOrdinal $ listTerms expr
+    where
+        listTerms (Sum l r) = listTerms l ++ listTerms r
+        listTerms e = [ e ]
+        exprOrdinal (Number _) = 2
+        exprOrdinal _ = 1
+        mergeTwo (Number i1) (Number i2) = Number (i1 + i2)
+        mergeTwo l r = Sum l r
+        mergeAll [x] = x
+        mergeAll xs = foldr1 mergeTwo xs
+
+optP :: Prog -> Prog
+optP = map optC
+    where
+        optC (Move e1 e2) = Move (optE e1) (optE e2)
+        optC (Call n exs) = Call n (map optE exs)
+        optC c = c

HW4.fedorind.hs

@@ -0,0 +1,183 @@
+-- Authors: Danila Fedorin, Ryan Alder, Matthew Sessions
+-- ONIDs: fedorind, alderr, sessionm
+module HW3 where
+
+import MiniMiniLogo
+import Render
+import System.Random
+import Data.Maybe
+import System.IO.Unsafe
+
+--
+-- * Semantics of MiniMiniLogo
+--
+
+-- NOTE:
+--  * MiniMiniLogo.hs defines the abstract syntax of MiniMiniLogo and some
+--    functions for generating MiniMiniLogo programs. It contains the type
+--    definitions for Mode, Cmd, and Prog.
+--  * Render.hs contains code for rendering the output of a MiniMiniLogo
+--    program in HTML5. It contains the types definitions for Point and Line.
+
+-- | A type to represent the current state of the pen.
+type State = (Mode,Point)
+
+-- | The initial state of the pen.
+start :: State
+start = (Up,(0,0))
+
+-- | A function that renders the image to HTML. Only works after you have
+--   implemented `prog`. Applying `draw` to a MiniMiniLogo program will
+--   produce an HTML file named MiniMiniLogo.html, which you can load in
+--   your browswer to view the rendered image.
+draw :: Prog -> IO ()
+draw p = let (_,ls) = prog p start in toHTML ls
+
+
+-- Semantic domains:
+--   * Cmd:  State -> (State, Maybe Line)
+--   * Prog: State -> (State, [Line])
+
+
+-- | Semantic function for Cmd.
+--   
+--   >>> cmd (Pen Down) (Up,(2,3))
+--   ((Down,(2,3)),Nothing)
+--
+--   >>> cmd (Pen Up) (Down,(2,3))
+--   ((Up,(2,3)),Nothing)
+--
+--   >>> cmd (Move 4 5) (Up,(2,3))
+--   ((Up,(4,5)),Nothing)
+--
+--   >>> cmd (Move 4 5) (Down,(2,3))
+--   ((Down,(4,5)),Just ((2,3),(4,5)))
+--
+cmd :: Cmd -> State -> (State, Maybe Line)
+cmd (Move l r) s = case fst s of
+    Up -> ((fst s, (l, r)), Nothing)
+    Down -> ((fst s, (l, r)), Just (snd s, (l, r)))
+cmd (Pen m) s    = ((m, snd s), Nothing)
+
+-- | Semantic function for Prog.
+--
+--   >>> prog (nix 10 10 5 7) start
+--   ((Down,(15,10)),[((10,10),(15,17)),((10,17),(15,10))])
+--
+--   >>> prog (steps 2 0 0) start
+--   ((Down,(2,2)),[((0,0),(0,1)),((0,1),(1,1)),((1,1),(1,2)),((1,2),(2,2))])
+prog :: Prog -> State -> (State, [Line])
+prog cs is = (fs, catMaybes ls)
+    where
+        step (s, xs) c = let (ns, ml) = cmd c s in (ns, xs ++ [ml])
+        (fs, ls) = foldl step (is, []) cs
+
+
+type Cell = (Bool, Bool, Bool, Bool, Bool)
+type Coord = (Int, Int)
+type Maze = [(Coord, Cell)]
+data Wall = WTop | WBottom | WLeft | WRight
+
+visited :: Cell -> Bool
+visited (b, _, _, _, _) = b
+
+neighbors :: Maze -> Coord -> [Coord]
+neighbors m (x, y) = [ c | c <- map fst m,
+                           abs (x - fst c) + abs (y - snd c) == 1,
+                           maybe False (not . visited) (lookup c m) ]
+
+pickNeighbor :: Maze -> StdGen -> Coord -> (Maybe Coord, StdGen)
+pickNeighbor m sg c = 
+    case ns of
+        [] -> (Nothing, sg)
+        _ -> (Just (ns !! v), g)
+    where
+        (v, g) = randomR (0, length ns - 1) sg
+        ns = neighbors m c
+
+breakCellWall :: Wall -> Cell -> Cell
+breakCellWall WTop (b1, b2, b3, b4, b5) = (b1, False, b3, b4, b5)
+breakCellWall WBottom (b1, b2, b3, b4, b5) = (b1, b2, False, b4, b5)
+breakCellWall WLeft (b1, b2, b3, b4, b5) = (b1, b2, b3, False, b5)
+breakCellWall WRight (b1, b2, b3, b4, b5) = (b1, b2, b3, b4, False)
+
+getWall :: Coord -> Coord -> Wall
+getWall (x, y) (x2, y2) = case (x - x2, y - y2) of
+    (0, 1)  -> WBottom
+    (0, -1) -> WTop
+    (1, 0)  -> WLeft
+    (-1, 0) -> WRight
+
+update :: Eq a => (b -> b) -> a -> [(a, b)] -> [(a, b)]
+update f a = map changeFunc
+    where
+        changeFunc (a', b) = if a == a' then (a', f b) else (a', b)
+
+breakWall :: Wall -> Coord -> Maze -> Maze
+breakWall w = update (breakCellWall w)
+
+visit :: Coord -> Maze -> Maze
+visit = update (\(b1, b2, b3, b4, b5) -> (True, b2, b3, b4, b5))
+
+generate :: Coord -> StdGen -> Maze -> (Maze, StdGen)
+generate c s m = maybe (nm, s) fixpointMove mc
+    where
+        nm = visit c m
+        (mc, g) = pickNeighbor nm s c
+        fixpointMove c2 = let (nm', g') = moveCell c2 in generate c g' nm'
+        moveCell c2 = generate c2 g $
+                         breakWall (getWall c c2) c $
+                         breakWall (getWall c2 c) c2 nm
+
+emptyMaze :: Int -> Int -> Maze 
+emptyMaze w h = [ ((x, y), (False, True, True, True, True)) | x <- [0..w - 1], y <- [0..h - 1] ]
+
+transform :: (Int -> Int) -> (Int -> Int) -> Coord -> Coord
+transform fx fy (x, y) = (fx x, fy y)
+
+offset :: Coord -> Coord -> Coord
+offset (ox, oy) = transform (+ox) (+oy)
+
+line :: Coord -> Coord -> Prog
+line (x1, y1) (x2, y2) = [ Pen Up, Move x1 y1, Pen Down, Move x2 y2 ]
+
+spotToLogo :: (Coord, Cell) -> Prog
+spotToLogo (c, (_, top, bottom, left, right)) = lineMovements
+    where
+        ls =
+            [ (offset (0, 1) c, offset (1, 1) c, top)
+            , (c, offset (1, 0) c, bottom)
+            , (c, offset (0, 1) c, left)
+            , (offset (1, 0) c, offset(1, 1) c, right)
+            ]
+        lineMovements = ls >>= (\(c1, c2, b) -> if b then line c1 c2 else [])
+
+mazeToLogo :: Maze -> Prog
+mazeToLogo m = m >>= spotToLogo
+
+drawFlower :: Int -> Coord -> Prog
+drawFlower n (xi, yi) = [ Pen Up, Move xi yi, Pen Down, Move xi (yi + n * 2) ] ++ linesFromCenter (xi, yi + n * 2)
+    where
+        pointsAround xs ys = [ (xs + x, ys + y) | x <- [-n..n], y <- [-n..n], abs x + abs y == n ]
+        linesFromCenter c@(x, y) = pointsAround x y >>= line c
+--
+-- * Extra credit
+--
+
+generateMaze :: Int -> Int -> Maze
+generateMaze w h = m
+    where
+        mi = emptyMaze w h
+        r = mkStdGen 5
+        (m, _) = generate (0, 0) r mi
+
+-- | This should be a MiniMiniLogo program that draws an amazing picture.
+--   Add as many helper functions as you want.
+amazing :: Prog
+amazing =
+    drawFlower 3 (5, 20) ++ 
+    drawFlower 3 (12, 20) ++ 
+    drawFlower 4 (27, 20) ++ 
+    drawFlower 6 (40, 20) ++
+    drawFlower 5 (65, 20) ++
+    (mazeToLogo $ generateMaze 80 20)

KarelExamples.hs

@@ -0,0 +1,103 @@
+-- | This module defines some example worlds and programs for testing
+--   your Karel interpreter.
+module KarelExamples where
+
+import Prelude hiding (Either(..))
+import KarelSyntax
+import KarelState
+
+
+--
+-- * Trivial worlds
+--
+
+-- | A world that is all walls.
+wallWorld :: World
+wallWorld = const Nothing
+
+-- | A world that is completely empty of walls and beepers.
+emptyWorld :: World
+emptyWorld = const (Just 0)
+
+-- | A robot that starts at the origin, facing north, with the
+--   given number of beepers.
+originBot :: Int -> Robot
+originBot b = ((0,0),North,b)
+
+
+--
+-- * Demo world
+--
+
+-- | A 10x5 room with some beepers in a line, illustrated below.
+--
+--       XXXXXXXXXXXX
+--       X          X
+--       X          X
+--       X          X
+--       X @  2 3 4 X
+--       X          X
+--       XXXXXXXXXXXX
+-- 
+--   The @ symbol is coordinate (1,1).
+--   Clear spaces are from (0,0) to (9,4).
+--   There are beepers at the following locations:
+--    * 2 beepers at (4,1)
+--    * 3 beepers at (6,1)
+--    * 4 beepers at (8,1)
+-- 
+demoWorld :: World
+demoWorld (4,1) = Just 2
+demoWorld (6,1) = Just 3
+demoWorld (8,1) = Just 4
+demoWorld (x,y) | x >= 0 && x < 10 &&
+                  y >= 0 && y < 5      = Just 0
+                | otherwise            = Nothing
+
+-- | An initial robot state for the demo world. The robot starts at
+--   (1,1), facing East, with 1 beeper in its bag.
+demoBot :: Robot
+demoBot = ((1,1),East,1)
+
+
+--
+-- * Program generators
+--
+
+-- | Generate a program that does the following n times:
+--     1. moves in a straight line until it finds a beeper
+--     2. picks it up
+--     3. returns to its original position and facing.
+fetcher :: Int -> Prog
+fetcher n = ([("fetch",fetch)], main)
+  where
+    fetch = Block
+      [ While (Not Beeper)   -- do until we find a beeper:
+          (If (Clear Front)    -- can we move forward?
+              Move             -- if yes, then do it
+              Shutdown)        -- if not, shut down
+      , PickBeeper ]
+    main = Block
+      [ Iterate n $ Block  -- repeat n times:
+         [ PutBeeper         -- put a beeper down to mark our place
+         , Move              -- move forward one space
+         , Call "fetch"      -- go get a new beeper
+         , Turn Back         -- turn around
+         , Move              -- move forward one space
+         , Call "fetch"      -- go back to where we started
+         , Turn Back ]       -- turn back to our initial facing
+      , Shutdown ]
+
+-- | Generates a statement that moves the robot in a rectangle of
+--   the given dimensions.
+rectangle :: Int -> Int -> Stmt
+rectangle w h = Block
+  [ While (Not (Facing North)) (Turn Right)
+  , Iterate h Move
+  , Turn Right
+  , Iterate w Move
+  , Turn Right
+  , Iterate h Move
+  , Turn Right
+  , Iterate w Move
+  , Turn Right ]

KarelSemantics.hs

@@ -0,0 +1,53 @@
+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

KarelState.hs

@@ -0,0 +1,167 @@
+-- | This module defines the state of a running Karel program.
+module KarelState where
+
+import Prelude hiding (Either(..))
+import KarelSyntax
+
+
+--
+-- * Positions and directions
+--
+
+-- | A cartesian coordinate, representing a position in the world.
+type Pos = (Int,Int)
+
+-- | Get the position next to the given position, offset by one square
+--   in the indicated *cardinal* direction.
+neighbor :: Card -> Pos -> Pos
+neighbor North (x,y) = (x,y+1)
+neighbor South (x,y) = (x,y-1)
+neighbor East  (x,y) = (x+1,y)
+neighbor West  (x,y) = (x-1,y)
+
+-- | Get a cardinal direction relative to the current one.
+cardTurn :: Dir -> Card -> Card
+cardTurn Front c     = c
+cardTurn Back  North = South
+cardTurn Back  South = North
+cardTurn Back  East  = West
+cardTurn Back  West  = East
+cardTurn Left  North = West
+cardTurn Left  South = East
+cardTurn Left  East  = North
+cardTurn Left  West  = South
+cardTurn Right North = East
+cardTurn Right South = West
+cardTurn Right East  = South
+cardTurn Right West  = North
+
+
+--
+-- * World state
+--
+
+-- | The state of the world is represented by a function that returns
+--   for each position:
+--    * Nothing, if the position is a wall
+--    * Just k, if the position is clear and has k beepers
+--   You can assume k is always >= 0.
+type World = Pos -> Maybe Int
+
+-- | Is the given position clear?
+isClear :: Pos -> World -> Bool
+isClear p w = w p /= Nothing
+
+-- | Is there a beeper at the given position?
+hasBeeper :: Pos -> World -> Bool
+hasBeeper p w = maybe False (>0) (w p)
+
+-- | Increment the number of beepers at the given position.
+incBeeper :: Pos -> World -> World
+incBeeper p w = \q -> if p == q 
+                         then case w q of
+                                Nothing -> Just 1
+                                Just i  -> Just (i+1)
+                         else w q
+
+-- | Decrement the number of beepers at the given position. Note that this
+--   function can yield a world with negative beepers, so you should make
+--   sure to only decrement the beepers at a position after first checking
+--   to make sure there is at least one beeper there (using `hasBeeper`).
+decBeeper :: Pos -> World -> World
+decBeeper p w = \q -> if p == q then fmap (subtract 1) (w q) else w q
+
+
+--
+-- * Robot state
+--
+
+-- | The state of the robot is represented by a triple containing:
+--    * the current position
+--    * the current facing (cardinal direction)
+--    * the number of beepers in the beeper bag
+type Robot = (Pos,Card,Int)
+
+
+-- ** Robot position
+
+-- | The robot's position.
+getPos :: Robot -> Pos
+getPos (p,_,_) = p
+
+-- | Get a position relative to the robot's current facing and position.
+relativePos :: Dir -> Robot -> Pos
+relativePos d (p,c,_) = neighbor (cardTurn d c) p
+
+-- | Set the robot's position.
+setPos :: Pos -> Robot -> Robot
+setPos p (_,c,b) = (p,c,b)
+
+-- | Update the robot's position using an update function.
+updatePos :: (Pos -> Pos) -> Robot -> Robot
+updatePos f (p,c,b) = (f p,c,b)
+
+
+-- ** Robot facing
+
+-- | The robot's facing (cardinal direction).
+getFacing :: Robot -> Card
+getFacing (_,c,_) = c
+
+-- | Set the robot's facing.
+setFacing :: Card -> Robot -> Robot
+setFacing c (p,_,b) = (p,c,b)
+
+-- | Update the robot's facing using an update function.
+updateFacing :: (Card -> Card) -> Robot -> Robot
+updateFacing f (p,c,b) = (p,f c,b)
+
+
+-- ** Beeper bag
+
+-- | The number of beepers in the beeper bag.
+getBag :: Robot -> Int
+getBag (_,_,b) = b
+
+-- | Is the beeper bag empty?
+isEmpty :: Robot -> Bool
+isEmpty (_,_,b) = b <= 0
+
+-- | Increment the number of beepers in the bag.
+incBag :: Robot -> Robot
+incBag (p,c,b) = (p,c,b+1)
+
+-- | Decrement the number of beepers in the bag.
+decBag :: Robot -> Robot
+decBag (p,c,b) = (p,c,b-1)
+
+
+--
+-- * Statement results
+--
+
+-- | The result of executing a statement.
+-- 
+--     * OK: The statement executed successfully, so return the updated state
+--       of the world and the robot. OK to execute the next statement.
+--
+--     * Done: Produced only by the Shutdown statement. This returns the final
+--       state of the robot. No further statements should be executed.
+--
+--     * Error: An error occurred. Includes a string for reporting error messages.
+--       No further statements should be executed.
+--
+data Result = OK    World Robot
+            | Done  Robot
+            | Error String
+
+instance Show Result where
+  show (OK _ r)  = "OK: " ++ show r
+  show (Done r)  = "Done: " ++ show r
+  show (Error s) = "Error: " ++ s
+
+-- | Applies a function to the result if its an OK, otherwise returns
+--   the result unchanged.
+onOK :: (World -> Robot -> Result) -> Result -> Result
+onOK f (OK w r) = f w r
+onOK _ result   = result

KarelSyntax.hs

@@ -0,0 +1,40 @@
+-- | This module defines the syntax of the Karel language.
+module KarelSyntax where
+
+
+-- | A Karel program is a list of macro definitions and a statement to
+--   use as the body of the "main" function.
+type Prog = (Defs,Stmt)
+
+-- | A macro name.
+type Macro = String
+
+-- | A list of macro definitions.
+type Defs = [(Macro,Stmt)]
+
+-- | Cardinal directions.
+data Card = North | South | East  | West  deriving (Eq,Show)
+
+-- | Directions relative to the current facing.
+data Dir  = Front | Back  | Right | Left  deriving (Eq,Show)
+
+-- | Environment queries.
+data Test = Not    Test   -- boolean negation
+          | Facing Card   -- am I facing the given cardinal direction?
+          | Clear  Dir    -- can I move in the given relative direction?
+          | Beeper        -- is there a beeper here?
+          | Empty         -- is my beeper bag empty?
+  deriving (Eq,Show)
+
+-- | Statements.
+data Stmt = Shutdown                 -- end the program
+          | Move                     -- move forward
+          | PickBeeper               -- take a beeper
+          | PutBeeper                -- leave a beeper
+          | Turn    Dir              -- rotate in place
+          | Call    Macro            -- invoke a macro
+          | Iterate Int  Stmt        -- fixed repetition loop
+          | If      Test Stmt Stmt   -- conditional branch
+          | While   Test Stmt        -- conditional loop
+          | Block   [Stmt]           -- statement block
+  deriving (Eq,Show)

KarelTests.hs

@@ -0,0 +1,122 @@
+-- | A module that contains several doctests for testing your interpreter.
+--   Note that if you want the tests to pass, you'll need to reverse engineer
+--   the error messages.
+--
+--   If you add your own tests, make sure to do that in the HW5 file, since you
+--   will not submit this file.
+module KarelTests where
+
+import Prelude hiding (Either(..))
+
+import KarelSyntax
+import KarelState
+import KarelSemantics
+import KarelExamples
+
+
+-- | Basic tests for move, turn, pick, and put.
+--
+--   >>> prog ([],Move) emptyWorld (originBot 0)
+--   OK: ((0,1),North,0)
+--
+--   >>> prog ([],Block [Turn Right,Move]) emptyWorld (originBot 0)
+--   OK: ((1,0),East,0)
+--
+--   >>> prog ([],Block [PutBeeper,PutBeeper]) emptyWorld (originBot 5)
+--   OK: ((0,0),North,3)
+--
+--   >>> prog ([],Block [PutBeeper,PickBeeper]) emptyWorld (originBot 5)
+--   OK: ((0,0),North,5)
+--   
+--   >>> prog ([],Block [PutBeeper,Move,Turn Back,Move,PickBeeper]) emptyWorld (originBot 5)
+--   OK: ((0,0),South,5)
+--
+--   >>> prog ([],Move) wallWorld (originBot 0)
+--   Error: Blocked at: (0,1)
+--
+--   >>> prog ([],Block [PutBeeper,PutBeeper]) emptyWorld (originBot 1)
+--   Error: No beeper to put.
+--
+--   >>> prog ([],PickBeeper) emptyWorld (originBot 5)
+--   Error: No beeper to pick at: (0,0)
+--
+--   >>> prog ([],Block [PutBeeper,Move,PickBeeper]) emptyWorld (originBot 5)
+--   Error: No beeper to pick at: (0,1)
+
+
+-- | Conditional tests.
+--
+--   >>> prog ([],If Beeper (Turn Left) (Turn Right)) emptyWorld (originBot 0)
+--   OK: ((0,0),East,0)
+--   
+--   >>> prog ([],If (Not Beeper) (Turn Left) (Turn Right)) emptyWorld (originBot 0)
+--   OK: ((0,0),West,0)
+--   
+--   >>> prog ([],Block [PutBeeper,If Beeper (Turn Left) (Turn Right)]) emptyWorld (originBot 3)
+--   OK: ((0,0),West,2)
+--
+--   >>> prog ([],Block [PutBeeper,PickBeeper,If Beeper (Turn Left) (Turn Right)]) emptyWorld (originBot 3)
+--   OK: ((0,0),East,3)
+--
+--   >>> prog ([],If (Facing North) (Turn Left) (Turn Right)) emptyWorld (originBot 0)
+--   OK: ((0,0),West,0)
+--
+--   >>> prog ([],If (Facing South) (Turn Left) (Turn Right)) emptyWorld (originBot 0)
+--   OK: ((0,0),East,0)
+--
+--   >>> prog ([],If (Not Empty) PutBeeper Move) emptyWorld (originBot 3)
+--   OK: ((0,0),North,2)
+--
+--   >>> prog ([],If (Not Empty) PutBeeper Move) emptyWorld (originBot 0)
+--   OK: ((0,1),North,0)
+--
+--   >>> prog ([],If (Clear Front) Move Shutdown) emptyWorld (originBot 0)
+--   OK: ((0,1),North,0)
+--
+--   >>> prog ([],If (Clear Front) Move Shutdown) wallWorld (originBot 0)
+--   Done: ((0,0),North,0)
+
+
+-- | Test macros.
+--   
+--   >>> prog ([("A",Turn Right),("B",Turn Left)],Call "A") emptyWorld (originBot 0)
+--   OK: ((0,0),East,0)
+--
+--   >>> prog ([("A",Turn Right),("B",Turn Left)],Call "B") emptyWorld (originBot 0)
+--   OK: ((0,0),West,0)
+--
+--   >>> prog ([("A",Turn Right),("B",Turn Left)],Call "C") emptyWorld (originBot 0)
+--   Error: Undefined macro: C
+
+
+-- | Test looping constructs.
+--
+--   >>> prog ([],Iterate 8 Move) demoWorld demoBot
+--   OK: ((9,1),East,1)
+--
+--   >>> prog ([],Iterate 9 Move) demoWorld demoBot
+--   Error: Blocked at: (10,1)
+--
+--   >>> prog ([],While (Clear Front) Move) demoWorld demoBot
+--   OK: ((9,1),East,1)
+--
+--   >>> prog ([],Block [Iterate 7 Move, While Beeper PickBeeper]) demoWorld demoBot
+--   OK: ((8,1),East,5)
+
+
+-- | Larger tests.
+--
+--   >>> prog (fetcher 4) demoWorld demoBot
+--   Done: ((1,1),East,5)
+--
+--   >>> prog (fetcher 9) demoWorld demoBot
+--   Done: ((1,1),East,10)
+-- 
+--   >>> prog (fetcher 10) demoWorld demoBot
+--   Done: ((9,1),East,9)
+--
+--   >>> prog ([],rectangle 8 3) demoWorld demoBot
+--   OK: ((1,1),North,1)
+--
+--   >>> prog ([],rectangle 3 8) demoWorld demoBot
+--   Error: Blocked at: (1,5)

MiniMiniLogo.hs

@@ -0,0 +1,63 @@
+-- | This module defines the syntax of MiniMiniLogo. It also provides
+--   functions to generate programs that draw some basic shapes.
+--
+--   NOTE: You should not change the definitions in this file!
+--
+module MiniMiniLogo where
+
+--
+-- * Syntax
+--
+
+-- | A program is a sequence of commands.
+type Prog = [Cmd]
+
+-- | The mode of the pen.
+data Mode = Down | Up
+  deriving (Eq,Show)
+
+-- | Abstract syntax of commands.
+data Cmd = Pen Mode
+         | Move Int Int
+  deriving (Eq,Show)
+
+-- | Generate a MiniMiniLogo program that draws a 2x2 box starting from the
+--   specified point. Conceptually, this program looks like the following, but
+--   the additions are carried out in Haskell rather than in MiniMiniLogo.
+-- 
+--     pen up; move (x,y);
+--     pen down; move (x+2,y); move (x+2,y+2);
+--               move (x,y+2); move (x,y);
+--
+--   >>> box 7 3
+--   [Pen Up,Move 7 3,Pen Down,Move 9 3,Move 9 5,Move 7 5,Move 7 3]
+--
+box :: Int -> Int -> Prog
+box x y = [Pen Up, Move x y, Pen Down,
+           Move (x+2) y, Move (x+2) (y+2), Move x (y+2), Move x y]
+
+-- | Generate an 'X' from (x,y) to (x+w,y+h).
+--
+--   >>> nix 10 10 5 7
+--   [Pen Up,Move 10 10,Pen Down,Move 15 17,Pen Up,Move 10 17,Pen Down,Move 15 10]
+--
+nix :: Int -> Int -> Int -> Int -> Prog
+nix x y w h = [Pen Up, Move x y, Pen Down, Move (x+w) (y+h),
+               Pen Up, Move x (y+h), Pen Down, Move (x+w) y]
+
+-- | Generate a MiniMiniLogo program that draws n steps starting from
+--   point (x,y).
+--
+--   >>> steps 3 2 4
+--   [Pen Up,Move 2 4,Pen Down,Move 2 5,Move 3 5,Move 3 6,Move 4 6,Move 4 7,Move 5 7]
+-- 
+steps :: Int -> Int -> Int -> Prog
+steps n x y = [Pen Up, Move x y, Pen Down] ++ step n
+  where 
+    step 0 = []
+    step n = step (n-1) ++ [Move (x+n-1) (y+n), Move (x+n) (y+n)]
+
+-- | Draw an example picture. The expected output is given on the HW4
+--   description page.
+demo :: Prog
+demo = box 7 3 ++ nix 6 6 4 3 ++ steps 3 2 4

Render.hs

@@ -0,0 +1,82 @@
+-- | A module for rendering lines as an HTML5 file containing an SVG image.
+--   This can be used to visualize the denotational semantics of a MiniLogo
+--   program.
+--
+--   NOTE: You should not change the definitions in this file!
+--
+module Render (Point,Line,toHTML,toGridHTML) where
+
+import Data.List (intercalate)
+
+
+-- | A point is a cartesian pair (x,y).
+type Point = (Int,Int)
+
+-- | A line is defined by its endpoints.
+type Line = (Point,Point)
+
+-- | Output a list of lines as an HTML5 file containing an SVG image.
+toHTML :: [Line] -> IO ()
+toHTML ls = writeFile "MiniMiniLogo.html" (header ++ content ls ++ footer)
+
+-- | Alternate version of 'toHTML' that adds a grid to the background.
+toGridHTML :: [Line] -> IO ()
+toGridHTML ls = writeFile "MiniMiniLogo.html" (header ++ grid ++ content ls ++ footer)
+
+--
+-- Private definitions. All definitions below this point will not be visible
+-- from within a module that imports this module.
+--
+
+scale, margin, width, height :: Int
+scale  = 10
+margin = 10
+width  = 800
+height = 400
+
+gridStep = 5
+maxX = width `div` scale
+maxY = height `div` scale
+
+gridStyle = "fill:none;stroke:lightgrey;stroke-width:1"
+drawStyle = "fill:none;stroke:red;stroke-width:2"
+
+title  = "<head><title>MiniLogo Semantics Viewer</title></head>"
+view   = "<svg width='100%' viewBox='0 0 "
+         ++ show (width + 2*margin) ++ " "
+         ++ show (height + 2*margin) ++ "'>"
+border = "<rect x='" ++ show (margin-3) ++
+             "' y='" ++ show (margin-3) ++
+         "' width='" ++ show (width +6) ++
+        "' height='" ++ show (height+5) ++
+         "' style='fill:none;stroke:black;stroke-width:2'/>"
+
+header = unlines ["<!DOCTYPE html>", "<html>", title, "<body>", view, border]
+footer = unlines ["</svg>","</body>","</html>"]
+
+grid = unlines (map (poly gridStyle) lines)
+  where lines = [ [(x,0), (x,maxY)] | x <- [0,gridStep..maxX] ]
+             ++ [ [(0,y), (maxX,y)] | y <- [0,gridStep..maxY] ]
+
+content :: [Line] -> String
+content = unlines . map (poly drawStyle) . chunk
+
+-- | A canvas-adjusted point as a string.
+point :: Point -> String
+point (x,y) = show xp ++ "," ++ show yp
+  where xp = x*scale + margin
+        yp = height - y*scale + margin
+
+-- | Chunk a bunch of lines into sequences of connected points.
+chunk :: [Line] -> [[Point]]
+chunk []         = []
+chunk [(p,q)]    = [[p,q]]
+chunk ((p,q):ls) | q == head ps = (p:ps) : pss
+                 | otherwise    = [p,q] : ps : pss
+  where (ps:pss) = chunk ls
+
+-- | Draw a sequence of connected points.
+poly :: String -> [Point] -> String
+poly style ps = "<polyline points='"
+             ++ intercalate " " (map point ps)
+             ++ "' style='" ++ style ++ "'/>"

fedorind.pl

@@ -0,0 +1,119 @@
+% Here are a bunch of facts describing the Simpson's family tree.
+% Don't change them!
+
+female(mona).
+female(jackie).
+female(marge).
+female(patty).
+female(selma).
+female(lisa).
+female(maggie).
+female(ling).
+
+male(abe).
+male(clancy).
+male(herb).
+male(homer).
+male(bart).
+
+married_(abe,mona).
+married_(clancy,jackie).
+married_(homer,marge).
+
+married(X,Y) :- married_(X,Y).
+married(X,Y) :- married_(Y,X).
+
+parent(abe,herb).
+parent(abe,homer).
+parent(mona,homer).
+
+parent(clancy,marge).
+parent(jackie,marge).
+parent(clancy,patty).
+parent(jackie,patty).
+parent(clancy,selma).
+parent(jackie,selma).
+
+parent(homer,bart).
+parent(marge,bart).
+parent(homer,lisa).
+parent(marge,lisa).
+parent(homer,maggie).
+parent(marge,maggie).
+
+parent(selma,ling).
+
+
+
+%%
+% Part 1. Family relations
+%%
+
+% 1. Define a predicate `child/2` that inverts the parent relationship.
+child(X, Y) :- parent(Y, X).
+
+% 2. Define two predicates `isMother/1` and `isFather/1`.
+isMother(X) :- female(X), parent(X, _).
+isFather(X) :- male(X), parent(X, _).
+
+% 3. Define a predicate `grandparent/2`.
+grandparent(X, Y) :- parent(X, Z), parent(Z, Y).
+
+% 4. Define a predicate `sibling/2`. Siblings share at least one parent.
+sibling(X, Y) :- parent(Z, X), parent(Z, Y), X \= Y.
+
+% 5. Define two predicates `brother/2` and `sister/2`.
+brother(X, Y) :- sibling(X, Y), male(X).
+sister(X, Y) :- sibling(X, Y), female(X).
+
+% 6. Define a predicate `siblingInLaw/2`. A sibling-in-law is either married to
+%    a sibling or the sibling of a spouse.
+siblingInLaw(X, Y) :- married(X, SB), sibling(SB, Y) ; married(Y, SP), sibling(X, SP).
+
+% 7. Define two predicates `aunt/2` and `uncle/2`. Your definitions of these
+%    predicates should include aunts and uncles by marriage.
+aunt(X, Y) :- child(Y, P), (siblingInLaw(X, P) ; sibling(X, P)), female(X).
+uncle(X, Y) :- child(Y, P), (siblingInLaw(X, P) ; sibling(X, P)), male(X).
+
+% 8. Define the predicate `cousin/2`.
+cousin(X, Y) :- parent(P1, X), parent(P2, Y), siblingInLaw(P1, P2).
+
+% 9. Define the predicate `ancestor/2`.
+ancestor(X, Y) :- parent(X, Y) ; parent(P, Y), ancestor(X, P).
+
+% Extra credit: Define the predicate `related/2`.
+% TODO
+related(X, X, _).
+related(X, Y, V) :- not(member(Y, V)),
+    (child(Y, S), related(X, S, [Y|V]) ;
+     parent(Y, C), related(X, C, [Y|V]) ;
+     married(Y, S), related(X, S, [Y|V])).
+related(X, Y) :- related(X, Y, []), X \= Y.
+
+%%
+% Part 2. Language implementation (see course web page)
+%%
+cmd(X) :- number(X).
+cmd(X) :- string(X).
+cmd(X) :- bool(X).
+cmd(add).
+cmd(lte).
+cmd(if(X, Y)).
+
+prog([X|T]) :- cmd(X), prog(T).
+prog([]).
+
+if(X, Y) :- prog(X), prog(Y).
+
+bool(f).
+bool(t).
+
+cmd(X, OS, [X|OS]) :- prog(OS), (number(X) ; string(X) ; bool(X)).
+cmd(add, [X, Y | OS], [SUM| OS]) :- number(X), number(Y), is(SUM, X + Y).
+cmd(lte, [X, Y | OS], [t | OS]) :- number(X), number(Y), X =< Y.
+cmd(lte, [X, Y | OS], [f | OS]) :- number(X), number(Y), X > Y.
+cmd(if(P1, _), [t | OS], FS) :- prog(P1, OS, FS).
+cmd(if(_, P2), [f | OS], FS) :- prog(P2, OS, FS).
+
+prog([], S, S).
+prog([C|OP], S, FS) :- cmd(C), prog(OP), cmd(C, S, TS), prog(OP, TS, FS).