cis194

07-laziness.hs

import Control.Monad (replicateM)
import System.Random
import Test.QuickCheck

-- Exercise 1

fib :: Integer -> Integer
fib 0 = 1
fib 1 = 1
fib n = fib (n-1) + fib (n-2)

fibs1 :: [Integer]
fibs1 = map fib [0..]

fibs2 :: [Integer]
fibs2 = 1 : 1 : zipWith (+) fibs2 (tail fibs2)

-- Exercise 2

data Stream a = Cons a (Stream a)

streamToList :: Stream a -> [a]
streamToList (Cons x xs) = x : streamToList xs

instance Show a => Show (Stream a) where
    show s = init (show (take 20 (streamToList s))) ++ "…"

streamRepeat :: a -> Stream a
streamRepeat x = Cons x (streamRepeat x)

streamMap :: (a -> b) -> Stream a -> Stream b
streamMap f (Cons x xs) = Cons (f x) (streamMap f xs)

streamIterate :: (a -> a) -> a -> Stream a
streamIterate f x = Cons x (streamIterate f (f x))

streamInterleave :: Stream a -> Stream a -> Stream a
streamInterleave (Cons x xs) ys = Cons x (streamInterleave ys xs)

nats :: Stream Integer
nats = streamIterate (+1) 0

ruler :: Stream Integer
ruler = streamInterleave (streamRepeat 0) (streamMap (+1) ruler)

-- Exercise 3

data Supply s a = S (Stream s -> (a, Stream s))

get :: Supply s s
get = S (\(Cons x xs) -> (x, xs))

pureSupply :: a -> Supply s a
pureSupply x = S (\xs -> (x, xs))

mapSupply :: (a -> b) -> Supply s a -> Supply s b
mapSupply f (S t) = S go
  where go xs = let (a, xs') = t xs
                in  (f a, xs')

mapSupply2 :: (a -> b -> c) -> Supply s a -> Supply s b -> Supply s c
mapSupply2 f (S t1) (S t2) = S go
  where go xs = let (a, xs')  = t1 xs
                    (b, xs'') = t2 xs'
                in  (f a b, xs'')

bindSupply :: Supply s a -> (a -> Supply s b) -> Supply s b
bindSupply (S t1) k = S go
  where go xs = let (a, xs')  = t1 xs
                    (S t2)    = k a
                    (b, xs'') = t2 xs'
                in  (b, xs'')

runSupply :: Stream s -> Supply s a -> a
runSupply s (S t) = fst (t s)

instance Functor (Supply s) where
    fmap = mapSupply

instance Applicative (Supply s) where
    pure = pureSupply
    (<*>) = mapSupply2 id

instance Monad (Supply s) where
    return = pureSupply
    (>>=) = bindSupply


data Tree a = Node (Tree a) (Tree a) | Leaf a deriving (Show, Eq)

labelTree :: Tree a -> Tree Integer
labelTree t = runSupply nats (go t)
  where
    go :: Tree a -> Supply s (Tree s)
    go (Node t1 t2) = Node <$> go t1 <*> go t2
    go (Leaf _) = Leaf <$> get

instance Arbitrary a => Arbitrary (Tree a) where
  arbitrary = genTree

genTree :: Arbitrary a => Gen (Tree a)
genTree = sized $ \size -> do
  frequency
    [ (100, do x<-arbitrary; return $ Leaf x)
    , (size, do l <- arbitrary; r <- arbitrary; return $ Node l r)
    ]

size :: Tree a -> Integer
size (Leaf _) = 1
size (Node l r) = (size l) + (size r)

toList :: Tree a -> [a]
toList (Leaf x) = [x]
toList (Node l r) = (toList l) ++ (toList r)

prop_lengthOfListShouldEqualTreeSize :: Tree Integer -> Bool
prop_lengthOfListShouldEqualTreeSize t = (size t) == (toInteger $ length $ toList t)

prop_labelTreeDoesNotChangeSizeOfTree :: Tree Integer -> Bool
prop_labelTreeDoesNotChangeSizeOfTree t = (size t) == (size $ labelTree t)

prop_labelTree :: Tree Int -> Bool
prop_labelTree t = ([0..((size t) - 1)] :: [Integer]) == (toList $ labelTree t)

prop_labelTreeIdempotent :: Tree Integer -> Bool
prop_labelTreeIdempotent t = once == twice
  where once = labelTree t
        twice = labelTree once

main = do
  quickCheck prop_lengthOfListShouldEqualTreeSize
  quickCheck prop_labelTreeDoesNotChangeSizeOfTree
  quickCheck prop_labelTree
  quickCheck prop_labelTreeIdempotent

8_1.hs

module Main where

data ComplicatedA a b
  = Con1 a b
  | Con2 [Maybe (a -> b)]

instance Functor (ComplicatedA a) where
  fmap f (Con1 x y ) = Con1 x (f y)
  fmap f (Con2 inner) = Con2 $ (fmap.fmap.fmap) f inner

data ComplicatedB f g a b
  = Con3 (f a)
  | Con4 (g b)
  | Con5 (g (g [b]))

instance Functor g => Functor (ComplicatedB f g a) where
  fmap f (Con3 x) = Con3 x
  fmap f (Con4 gb) = Con4 $ fmap f gb
  fmap f (Con5 gglb) = Con5 $ (fmap.fmap.fmap) f gglb

main :: IO ()
main = print "kutyus"

8_2.hs

module Main where

func0 :: Monad f => (a -> a) -> f a -> f a
func0 f xs = do
    x <- xs
    return (f (f x))

func0' :: Functor f => (a -> a) -> f a -> f a
func0' f xs = (f . f) <$> xs

func1 :: Monad f => f a -> f (a,a)
func1 xs = xs >>= (\x -> return (x,x))

func1' :: Functor f => f a -> f (a,a)
func1' = fmap $ \x -> (x,x)

func2 :: Monad f => f a -> f (a,a)
func2 xs = xs >>= (\x -> xs >>= \y -> return (x,y))

func2' :: Applicative f => f a -> f (a,a)
func2' xs = (,) <$> xs <*> xs

func3 :: Monad f => f a -> f (a,a)
func3 xs = xs >>= (\x -> xs >>= \y -> return (x,x))

func3' :: Applicative f => f a -> f (a,a)
func3' xs = (\x _ -> (x,x)) <$> xs <*> xs

func4 :: Monad f => f a -> f a -> f (a,a)
func4 xs ys = xs >>= (\x -> ys >>= \y -> return (x,y))

func4' :: Applicative f => f a -> f a -> f (a,a)
func4' xs ys = (,) <$> xs <*> ys

func5 :: Monad f => f Integer -> f Integer -> f Integer
func5 xs ys = do
    x <- xs
    let x' = x + 1
    y <- (+1) <$> ys
    return (x' + y)

func5' :: Applicative f => f Integer -> f Integer -> f Integer
func5' xs ys = let xs' = (+1) <$> xs
                   ys' = (+1) <$> ys
               in (+) <$> xs' <*> ys'

func6 :: Monad f => f Integer -> f (Integer,Integer)
func6 xs = do
    x <- xs
    return $ if x > 0 then (x, 0)
                      else (0, x)

func6' :: Functor f => f Integer -> f (Integer,Integer)
func6' xs = f <$> xs
    where f x = if x > 0 then (x, 0)
                         else (0, x)


func7 :: Monad f => f Integer -> f (Integer,Integer)
func7 xs = do
    x <- xs
    if x > 0 then return (x, 0)
             else return (0, x)

func7' :: Functor f => f Integer -> f (Integer,Integer)
func7' = func6'

func8 :: Monad f => f Integer -> Integer -> f Integer
func8 xs x = pure (+) <*> xs <*> pure x

func8' :: Functor f => f Integer -> Integer -> f Integer
func8' xs x = (+x) <$> xs

func9 :: Monad f => f Integer -> f Integer -> f Integer -> f Integer
func9 xs ys zs = xs >>= \x -> if even x then ys else zs

func9' :: Monad f => f Integer -> f Integer -> f Integer -> f Integer
func9' xs ys zs = do
  x <- xs
  if even x then ys else zs

func10 :: Monad f => f Integer -> f Integer
func10 xs = do
    x <- xs >>= (\x -> return (x * x))
    return (x + 10)

func10' :: Functor f => f Integer -> f Integer
func10' xs = (+10).(\x -> (x * x)) <$> xs

xs = [1..3]
ys = [4..6]
zs = [-3..3]

main :: IO ()
main = do
  print $ (func1 xs) == (func1' xs)
  print $ (func2 xs) == (func2' xs)
  print $ (func3 xs) == (func3' xs)
  print $ (func4 xs ys) == (func4' xs ys)
  print $ (func5 xs ys) == (func5' xs ys)
  print $ (func6 zs) == (func6' zs)
  print $ (func7 zs) == (func7' zs)
  print $ (func8 zs 10) == (func8' zs 10)
  print $ (func9 zs xs ys) == (func9' zs xs ys)
  print $ (func10 xs) == (func10' xs)

8_3.hs

module Main where

newtype Parser a = P {runParser :: String -> (Maybe a, String)}

parse :: Parser a -> String -> Maybe a
parse p text = let (result, restOfTheText) = runParser p text
               in if null restOfTheText then result else Nothing

noParser :: Parser a
noParser = P $ \text -> (Nothing, text)

pureParser :: a -> Parser a
pureParser x = P $ \text -> (Just x, text)

instance Functor Parser where
  fmap f (P g) = P $ \text -> let (result, restOfText) = g text
                               in (f <$> result, restOfText)

instance Applicative Parser where
  (P f) <*> (P g) = P $ \text -> let (maybeF, restOfText) = f text
                                     (maybeParam, restOfText') = g restOfText
                                  in (maybeF <*> maybeParam, restOfText')
  pure = pureParser

instance Monad Parser where
  return = pure
  ma >>= k = P $ \text -> let (maybeResult, restOfText) = runParser ma text
                              maybeMb = k <$> maybeResult
                           in case maybeMb of
                                Nothing -> (Nothing, restOfText)
                                Just mb -> runParser mb restOfText

anyChar :: Parser Char
anyChar = P go
  where go [] = (Nothing, [])
        go (x:xs) = (Just x, xs)


char :: Char -> Parser ()
char c = do
  x <- anyChar
  if x==c then return () else noParser

anyCharBut :: Char -> Parser Char
anyCharBut c = do
  x <- anyChar
  if x==c then noParser else return x

input = "alma"
input2 = "alma\nkorte\nbarack"

orElse :: Parser a -> Parser a -> Parser a
orElse l r = P $ \t -> case runParser l t of
                         all@(Just _, _) -> all
                         (Nothing, _) -> runParser r t

many :: Parser a -> Parser [a]
many p = ((:) <$> p <*> (many p)) `orElse` return []

sepBy :: Parser a -> Parser () -> Parser [a]
sepBy p1 p2 = (:) <$> p1 <*> (many (p2 *> p1)) `orElse` return []

main :: IO ()
main = do
  --print $ parse anyChar ""
  --print $ parse anyChar "a"
  --print $ parse anyChar "alma"

  --print $ parse (char 'a') ""
  --print $ parse (char 'a') "a"
  --print $ parse (char 'a') "alma"
  --print $ parse (char 'a') "c"

  --print $ parse (anyCharBut 'a') ""
  --print $ parse (anyCharBut 'a') "a"
  --print $ parse (anyCharBut 'a') "blma"
  --print $ parse (anyCharBut 'a') "c"

  --let p = pureParser 'a'
  --print $ parse (noParser `orElse` p) input == parse p input
  --print $ parse (pureParser 'x' `orElse` p) input == parse (pureParser 'x') input
  --print $ parse (anyChar `orElse` pureParser 'a') "" == Just 'a'
  --print $ parse (anyChar `orElse` pureParser 'a') ['c'] == Just 'c'
  --print $ parse (anyChar `orElse` pureParser 'a') "alma" == Nothing

  --print $ parse (many anyChar) input == Just input
  --print $ parse (many noParser) "" == (Just [] :: Maybe String)
  --print $ parse (many noParser) input == (Nothing :: Maybe String)

  print $ parse (many (anyCharBut '\n') `sepBy` char '\n') input == Just (lines input)

Stream.hs

module Stream where

data Stream a = Cons a (Stream a)

instance Functor Stream where
  fmap f (Cons x xs) = Cons (f x) (fmap f xs)

instance Show a => Show (Stream a) where
  show s = show $ take 20 $ streamToList s

streamToList :: Stream a -> [a]
streamToList (Cons a rest) = a:streamToList rest

streamRepeat :: a -> Stream a
streamRepeat x = Cons x (streamRepeat x)

streamCompare :: Eq a => [a] -> Stream a -> Bool
streamCompare pattern stream = pattern == take (length pattern) (streamToList stream)

streamIterate :: (a->a) -> a -> Stream a
streamIterate f start = Cons start (streamIterate f (f start))

streamInterleave :: Stream a -> Stream a -> Stream a
streamInterleave (Cons x xs) (Cons y ys) = Cons x (Cons y (streamInterleave xs ys))

Supply.hs

module Supply where

import Stream

data Supply s a = S (Stream s -> (a, Stream s))

instance Functor (Supply s) where
  fmap f (S g) = S $ \xs -> let (x, stream) = (g xs)
                             in (f x, stream)

instance Applicative (Supply s) where
  pure = pureSupply
  (<*>) = mapSupply2 id

instance Monad (Supply s) where
  return = pure
  (S f) >>= b = S $ \stream -> let (a, stream') = f stream
                                   S g          = b a
                                in g stream'

runSupply :: Stream s -> Supply s a -> a
runSupply stream (S f) = fst $ f stream

get :: Supply s s
get = S $ \(Cons x xs) -> (x, xs)

pureSupply :: a -> Supply s a
pureSupply x = S $ \xs -> (x, xs)

mapSupply2 :: (a->b->c) -> Supply s a -> Supply s b -> Supply s c
mapSupply2 f (S g) (S h) = S $ \stream -> let (a, stream') = g stream
                                              (b, stream'') = h stream'
                                          in (f a b, stream'')

week5.hs

module Main where

import Data.Char
import Data.List
import qualified Data.Set hiding (foldr)
import Data.Foldable

halveEvens :: [Int] -> [Int]
halveEvens = (map (`div` 2)) . (filter even)
--From a list of integers, remove any odd entry and halve every even entry.

ex_halveEvens =
  [ halveEvens [] == []
  , halveEvens [1,2,3,4,5] == [1,2]
  , halveEvens [6,6,6,3,3,3,2,2,2] == [3,3,3,1,1,1]
  ]

safeString :: String -> String
safeString = map replacer
  where replacer :: Char -> Char
        replacer c | isControl c = '_' | not $ isAscii c = '_' | otherwise = c
--In a string, replace every character that is a control character or not an ASCII character by an underscore. Use the Data.Char module.

ex_safeString =
  [ safeString [] == []
  , safeString "Hello World!" == "Hello World!"
  , safeString "That’s your line:\n" == "That_s your line:_"
  , safeString "🙋.o(“Me Me Me”)" == "_.o(_Me Me Me_)"
  ]

holes :: [a] -> [[a]]
holes xs = splitter <$> indexes
  where indexes = [0..(length xs) - 1]
        splitter i = let (start, end) = splitAt i xs in start ++ (safeTail end)
        safeTail s | null s = s | otherwise = tail s

--Given a list, return the a list of lists that contains every list that is obtained by the original list by removing one element, in order. (The examples might be more helpful).

ex_holes =
  [ holes "" == []
  , holes "Hello" == ["ello", "Hllo", "Helo", "Helo", "Hell"]
  ]

longestText :: (Traversable t, Show a) => t a -> a
longestText = maximumBy longestShow
  where longestShow l r = compare (showLen l) (showLen r)
        showLen s = length $ show s

--Given a non-empty list, find the entry for which show results the longest text shown. If there are ties, prefer the last one.

ex_longestText =
  [ longestText [True,False] == False
  , longestText [2,4,16,32] == (32::Int)
  , longestText (words "Hello World") == "World"
  , longestText (words "Olá mundo") ==  "Olá"
  ]

adjacents :: [a] -> [(a,a)]
adjacents xs = snd $ foldr topairs (Nothing, []) xs
  where topairs a (Nothing, acc) = (Just a, acc)
        topairs a (Just prev, acc) = (Just a, (a, prev):acc)


--Pair each element with the next one in the list.

ex_adjacents =
  [ adjacents "" == []
  , adjacents [True] == []
  , adjacents "Hello" == [('H','e'),('e','l'),('l','l'),('l','o')]
  ]

commas :: [String] -> String
commas = fold . intersperse ", "

--Add commas between strings.

ex_commas =
  [ commas [] == ""
  , commas ["Hello"] == "Hello"
  , commas ["Hello", "World"] == "Hello, World"
  , commas ["Hello", "", "World"] == "Hello, , World"
  , commas ["Hello", "new", "World"] == "Hello, new, World"
  ]

type Coefficients = [Integer]
addPolynomials :: [Coefficients] -> Coefficients
addPolynomials = foldr add []
  where add :: Coefficients -> Coefficients -> Coefficients
        add diff acc = let properAcc = if null acc
                                       then replicate (length diff) 0
                                       else acc
                       in zipWith (+) diff properAcc


--Given coefficients to polynomial equations as lists of the same length, output the coefficients for the sum of these equations.
--You may assume that at least one polynomial is given.

ex_addPolynomials =
  [ addPolynomials [[]] == []
  , addPolynomials [[0, 1], [1, 1]] == [1, 2]
  , addPolynomials [[0, 1, 5], [7, 0, 0], [-2, -1, 5]] == [5, 0, 10]
  ]

sumNumbers :: String -> Integer
sumNumbers str = sum numbers
  where numbers = read <$> numbersAsString
        numbersAsString = snd $ foldr filterNums ("", []) str
        filterNums c (current, parsed)
          | isDigit c = (c:current, parsed)
          | null current = (current, parsed)
          | otherwise = ("", current:parsed)

--Output the sum of all natural numbers contained in the given string. A natural number in this sense is any maximal subsequence of digits, i.e. one that is neither preceded nor followed by an integer. (The examples should provide more clarification.)

ex_sumNumbers =
  [ sumNumbers "" == 0
  , sumNumbers "Hello world!" == 0
  , sumNumbers "a1bc222d3f44" == 270
  , sumNumbers "words0are1234separated12by3integers45678" == 46927
  , sumNumbers "000a." == 0
  , sumNumbers "0.00a." == 0
  ]

testResults :: [(String, [Bool])]
testResults = [ ("halveEvens", ex_halveEvens)
              , ("safeString", ex_safeString)
              , ("holes", ex_holes)
              , ("longestText", ex_longestText)
              , ("adjacents", ex_adjacents)
              , ("commas", ex_commas)
              , ("addPolynomials", ex_addPolynomials)
              , ("sumNumbers", ex_sumNumbers)
              ]

formatTests :: [(String, [Bool])] -> [String]
formatTests = map report
  where report (name, results) = name ++ " " ++ (if and results then "ok" else "failed")


str = unlines [
  "first line",
  "second line",
  "",
  "third line"]

wordCount :: String -> [String]
wordCount str = reports
  where reports =
          [ "number of lines: " ++ (strLength $ lined)
          , "number of empty lines: " ++ (strLength $ (filter null lined))
          , "number of words: " ++ (strLength worded)
          , "number of unique words: " ++ (strLength $ wordset)
          , "length of longest line: " ++ (strLength $ longestText lined)
          ]
        lined = lines str
        strLength :: Foldable t => t a -> String
        strLength = show . length
        worded = foldMap words lined
        wordset = Data.Set.fromList worded


main :: IO ()
main = do
  --mapM_ putStrLn $ formatTests testResults
  mapM_ putStrLn $ wordCount str

week6.hs

{-# LANGUAGE OverloadedStrings #-}

import System.IO
import Data.Foldable
import Data.Monoid

type Picture = Integer -> Integer -> Maybe Char

blank :: Picture
blank _ _ = Nothing

main :: IO ()
main = exercise4

translated :: Integer -> Integer -> Picture -> Picture
translated dx dy p = \x y -> p (x - dx) (y + dy)

(&) :: Picture -> Picture -> Picture
l & r = \x y -> let pics = Last <$> (($ y).($ x) <$> [l, r])
                in getLast $ fold pics

data Event = KeyPress String deriving (Show, Eq)

scaled :: Int -> Int -> Picture -> Picture
scaled _ _ p = p

circle :: Double -> Picture
circle _ = charPicture 'O'

-- Lists

data List a = Empty | Entry a (List a) deriving Eq

infixr `Entry`

mapList :: (a -> b) -> List a -> List b
mapList _ Empty = Empty
mapList f (Entry c cs) = Entry (f c) (mapList f cs)

combine :: List Picture -> Picture
combine Empty = blank
combine (Entry p ps) = p & combine ps

allList :: List Bool -> Bool
allList Empty = True
allList (Entry b bs) = b && allList bs


elemList :: Eq a => a -> List a -> Bool
elemList _ Empty = False
elemList x (Entry y ys) | x == y = True
                        | otherwise = elemList x ys

appendList :: List a -> List a -> List a
appendList Empty ys = ys
appendList (Entry x xs) ys = Entry x (xs `appendList` ys)

listLength :: List a -> Integer
listLength Empty = 0
listLength (Entry _ xs) = 1 + listLength xs

nth :: List a -> Integer -> a
nth Empty _ = error "list too short"
nth (Entry x _) 1 = x
nth (Entry _ xs) n = nth xs (n-1)

filterList :: (a -> Bool) -> List a -> List a
filterList _ Empty = Empty
filterList p (Entry x xs) | p x       = Entry x (filterList p xs)
                          | otherwise =          filterList p xs

-- Graph Search


isGraphClosed :: Eq a => a -> (a -> List a) -> (a -> Bool) -> Bool
isGraphClosed initial adjacent isOk = go Empty (Entry initial Empty)
  where
    go _    Empty = True
    go seen (Entry c todo) | c `elemList` seen = go seen todo
    go _    (Entry c _)    | not (isOk c)      = False
    go seen (Entry c todo) = go (Entry c seen) (adjacent c `appendList` todo)


-- Coordinates

data Coord = C Integer Integer

data Direction = R | U | L | D deriving Eq

eqCoord :: Coord -> Coord -> Bool
eqCoord (C x1 y1) (C x2 y2) = x1 == x2 && y1 == y2

instance Eq Coord where
  C x1 y1 == C x2 y2 = x1 == x2 && y1 == y2

adjacentCoord :: Direction -> Coord -> Coord
adjacentCoord R (C x y) = C (x+1) y
adjacentCoord U (C x y) = C  x   (y+1)
adjacentCoord L (C x y) = C (x-1) y
adjacentCoord D (C x y) = C  x   (y-1)

moveFromTo :: Eq a => a -> a -> a -> a
moveFromTo c1 c2 c | c1 == c   = c2
                   | otherwise = c


-- The maze

data Tile = Wall | Ground | Storage | Box | Blank deriving Eq

data Maze = Maze Coord (Coord -> Tile)

noBoxMaze :: (Coord -> Tile) -> Coord -> Tile
noBoxMaze maze c = case maze c of
  Box -> Ground
  t   -> t

mazeWithBoxes :: (Coord -> Tile) -> List Coord -> Coord -> Tile
mazeWithBoxes maze Empty c' = noBoxMaze maze c'
mazeWithBoxes maze (Entry c cs) c'
  | eqCoord c c' = Box
  | otherwise  = mazeWithBoxes maze cs c'

isOnStorage :: (Coord -> Tile) -> Coord -> Bool
isOnStorage maze c = case maze c of Storage -> True
                                    _       -> False
                               
gameWon :: (Coord -> Tile) ->  List Coord -> Bool
gameWon maze cs = allList (mapList (isOnStorage maze) cs)


-- The state

data State = State Coord Direction (List Coord) Integer deriving Eq


initialBoxes :: (Coord -> Tile) -> List Coord
initialBoxes maze = go (-10) (-10)
  where
    go 11 11 = Empty
    go x  11 = go (x+1) (-10)
    go x  y  = case maze (C x y) of
      Box -> Entry (C x y) (go x (y+1))
      _   ->                go x (y+1)

loadMaze :: Integer -> State
loadMaze n = State c R (initialBoxes maze) n
  where (Maze c maze) = nth mazes n

initialState :: State
initialState = loadMaze 1

nthMaze :: Integer -> (Coord -> Tile)
nthMaze n = case nth mazes n of Maze _ maze -> maze

-- Event handling

tryGoTo :: State -> Direction -> State
tryGoTo (State from _ bx i) d
  = case currentMaze to of
    Box -> case currentMaze beyond of
      Ground -> movedState
      Storage -> movedState
      _ -> didn'tMove
    Ground -> movedState
    Storage -> movedState
    _ -> didn'tMove
  where to          = adjacentCoord d from
        beyond      = adjacentCoord d to
        maze        = nthMaze i
        currentMaze = mazeWithBoxes maze bx 
        movedState  = State to d movedBx i
        movedBx     = mapList (moveFromTo to beyond) bx
        didn'tMove  = State from d bx i
  
handleEvent :: Event -> State -> State
handleEvent (KeyPress key) (State _ _ bx i)
    | gameWon (nthMaze i)  bx 
    , i < listLength mazes
    , key == " "     = loadMaze (i+1)
handleEvent _ (State c d bx i)
    | gameWon (nthMaze i) bx 
                     = State c d bx i
handleEvent (KeyPress key) s
    | key == "l" = tryGoTo s R
    | key == "k" = tryGoTo s U
    | key == "h" = tryGoTo s L
    | key == "j" = tryGoTo s D
handleEvent _ s  = s

-- Drawing

wall, ground, storage, box :: Picture
wall =    charPicture '#'
ground =  charPicture ' '
storage = charPicture 'U'
box =     charPicture '@'

drawTile :: Tile -> Picture
drawTile Wall    = wall
drawTile Ground  = ground
drawTile Storage = storage
drawTile Box     = box
drawTile Blank   = blank

pictureOfMaze :: (Coord -> Tile) -> Picture
pictureOfMaze maze  = draw21times (\r -> draw21times (\c -> drawTileAt maze (C r c)))

draw21times :: (Integer -> Picture) -> Picture
draw21times something = go (-10)
  where
    go :: Integer -> Picture
    go 11 = blank
    go n  = something n & go (n+1)

drawTileAt :: (Coord -> Tile) ->  Coord -> Picture
drawTileAt maze c = atCoord c (drawTile (noBoxMaze maze c))


atCoord :: Coord -> Picture -> Picture
atCoord (C x y) pic = translated (fromIntegral x) (fromIntegral y) pic

charPicture :: Char -> Picture
charPicture c = \x y -> if x == 0 && y == 0
                        then Just c
                        else Nothing

player :: Direction -> Picture
player R = charPicture '>'
player L = charPicture '<'
player U = charPicture '^'
player D = charPicture 'v'

pictureOfBoxes :: List Coord -> Picture
pictureOfBoxes cs = combine (mapList (\c -> atCoord c (drawTile Box)) cs)

drawState :: State -> Picture
drawState (State c d boxes i)
  = pictureOfMaze (nthMaze i)
  & pictureOfBoxes boxes
  & atCoord c (player d)

-- The complete interaction

sokoban :: Interaction State
sokoban = Interaction initialState handleEvent drawState

-- The general interaction type

data Interaction world = Interaction
        world
        (Event -> world -> world)
        (world -> Picture)

runInteraction :: Interaction s -> IO ()
runInteraction (Interaction state0 handle draw) = do
  hSetBuffering stdin NoBuffering
  hSetBuffering stdout NoBuffering
  loop state0
    where loop state = do
            k <- getChar
            let newState = handle (KeyPress [k]) state
            putStr $ stringWorld $ (draw newState)
            loop newState
          stringWorld :: Picture -> String
          stringWorld f = [if x == 11 then '\n' else (translatePicture f) x y | y <- [-10..10], x <- [-10..11]]
          translatePicture :: Picture -> Integer -> Integer -> Char
          translatePicture f = \x y -> case f x y of
                                        Nothing -> ' '
                                        Just c  -> c

-- Resetable interactions

resetable :: Interaction s -> Interaction s
resetable (Interaction state0 handle draw)
  = Interaction state0 handle' draw
  where handle' (KeyPress key) _ | key == "Esc" = state0
        handle' e s = handle e s

data WithUndo a = WithUndo a (List a)

withUndo :: Eq a => Interaction a -> Interaction (WithUndo a)
withUndo (Interaction state0 handle draw)
  = Interaction state0' handle' draw'
  where
    state0' = WithUndo state0 Empty
    handle' (KeyPress key) (WithUndo s stack) | key == "U"
      = case stack of Entry s' stack' -> WithUndo s' stack'
                      Empty           -> WithUndo s Empty
    handle' e              (WithUndo s stack)
       | s' == s = WithUndo s stack
       | otherwise = WithUndo s' (Entry s stack)
      where s' = handle e s

    draw' (WithUndo s _) = draw s


-- The main function

exercise4 :: IO ()
exercise4 = runInteraction (resetable (withUndo sokoban))


mazes :: List Maze
mazes =
  Entry (Maze (C 1 1)       maze9) $
  Entry (Maze (C 0 0)       maze8) $
  Entry (Maze (C (-3) 3)    maze7) $
  Entry (Maze (C (-2) 4)    maze6) $
  Entry (Maze (C 0 1)       maze5) $
  Entry (Maze (C 1 (-3))    maze4) $
  Entry (Maze (C (-4) 3)    maze3) $
  Entry (Maze (C 0 1)       maze1) $
  Empty
  
extraMazes :: List Maze
extraMazes =
  Entry (Maze (C 1 (-3))    maze4') $
  Entry (Maze (C 1 (-3))    maze4'') $
  Entry (Maze (C 1 1)       maze9') $
  mazes

maze1 :: Coord -> Tile
maze1 (C x y)
  | abs x > 4  || abs y > 4  = Blank
  | abs x == 4 || abs y == 4 = Wall
  | x ==  2 && y <= 0        = Wall
  | x ==  3 && y <= 0        = Storage
  | x >= -2 && y == 0        = Box
  | otherwise                = Ground

maze3 :: Coord -> Tile
maze3 (C (-5) (-5)) = Wall
maze3 (C (-5) (-4)) = Wall
maze3 (C (-5) (-3)) = Wall
maze3 (C (-5) (-2)) = Wall
maze3 (C (-5) (-1)) = Wall
maze3 (C (-5)   0 ) = Wall
maze3 (C (-5)   1 ) = Wall
maze3 (C (-5)   2 ) = Wall
maze3 (C (-5)   3 ) = Wall
maze3 (C (-5)   4 ) = Wall

maze3 (C (-4) (-5)) = Wall
maze3 (C (-4) (-4)) = Ground
maze3 (C (-4) (-3)) = Ground
maze3 (C (-4) (-2)) = Ground
maze3 (C (-4) (-1)) = Ground
maze3 (C (-4)   0 ) = Ground
maze3 (C (-4)   1 ) = Ground
maze3 (C (-4)   2 ) = Ground
maze3 (C (-4)   3 ) = Ground
maze3 (C (-4)   4 ) = Wall

maze3 (C (-3) (-5)) = Wall
maze3 (C (-3) (-4)) = Ground
maze3 (C (-3) (-3)) = Wall
maze3 (C (-3) (-2)) = Wall
maze3 (C (-3) (-1)) = Wall
maze3 (C (-3)   0 ) = Wall
maze3 (C (-3)   1 ) = Ground
maze3 (C (-3)   2 ) = Wall
maze3 (C (-3)   3 ) = Ground
maze3 (C (-3)   4 ) = Wall
maze3 (C (-3)   5 ) = Wall

maze3 (C (-2) (-5)) = Wall
maze3 (C (-2) (-4)) = Box
maze3 (C (-2) (-3)) = Ground
maze3 (C (-2) (-2)) = Ground
maze3 (C (-2) (-1)) = Ground
maze3 (C (-2)   0 ) = Wall
maze3 (C (-2)   1 ) = Ground
maze3 (C (-2)   2 ) = Box
maze3 (C (-2)   3 ) = Box
maze3 (C (-2)   4 ) = Ground
maze3 (C (-2)   5 ) = Wall

maze3 (C (-1) (-6)) = Wall
maze3 (C (-1) (-5)) = Wall
maze3 (C (-1) (-4)) = Ground
maze3 (C (-1) (-3)) = Ground
maze3 (C (-1) (-2)) = Ground
maze3 (C (-1) (-1)) = Ground
maze3 (C (-1)   0 ) = Wall
maze3 (C (-1)   1 ) = Ground
maze3 (C (-1)   2 ) = Ground
maze3 (C (-1)   3 ) = Box
maze3 (C (-1)   4 ) = Ground
maze3 (C (-1)   5 ) = Wall
maze3 (C (-1)   6 ) = Wall

maze3 (C   0  (-6)) = Wall
maze3 (C   0  (-5)) = Ground
maze3 (C   0  (-4)) = Ground
maze3 (C   0  (-3)) = Ground
maze3 (C   0  (-2)) = Ground
maze3 (C   0  (-1)) = Ground
maze3 (C   0    0 ) = Wall
maze3 (C   0    1 ) = Wall
maze3 (C   0    2 ) = Wall
maze3 (C   0    3 ) = Wall
maze3 (C   0    4 ) = Ground
maze3 (C   0    5 ) = Ground
maze3 (C   0    6 ) = Wall

maze3 (C   1  (-6)) = Wall
maze3 (C   1  (-5)) = Ground
maze3 (C   1  (-4)) = Ground
maze3 (C   1  (-3)) = Ground
maze3 (C   1  (-2)) = Ground
maze3 (C   1  (-1)) = Ground
maze3 (C   1    0 ) = Wall
maze3 (C   1    1 ) = Storage
maze3 (C   1    2 ) = Storage
maze3 (C   1    3 ) = Storage
maze3 (C   1    4 ) = Ground
maze3 (C   1    5 ) = Ground
maze3 (C   1    6 ) = Wall

maze3 (C   2  (-6)) = Wall
maze3 (C   2  (-5)) = Wall
maze3 (C   2  (-4)) = Ground
maze3 (C   2  (-3)) = Ground
maze3 (C   2  (-2)) = Ground
maze3 (C   2  (-1)) = Ground
maze3 (C   2    0 ) = Wall
maze3 (C   2    1 ) = Wall
maze3 (C   2    2 ) = Wall
maze3 (C   2    3 ) = Wall
maze3 (C   2    4 ) = Wall
maze3 (C   2    5 ) = Wall
maze3 (C   2    6 ) = Wall

maze3 (C   3  (-5)) = Wall
maze3 (C   3  (-4)) = Ground
maze3 (C   3  (-3)) = Ground
maze3 (C   3  (-2)) = Storage
maze3 (C   3  (-1)) = Ground
maze3 (C   3    0 ) = Wall

maze3 (C   4  (-5)) = Wall
maze3 (C   4  (-4)) = Wall
maze3 (C   4  (-3)) = Wall
maze3 (C   4  (-2)) = Wall
maze3 (C   4  (-1)) = Wall
maze3 (C   4    0 ) = Wall

maze3 _ = Blank

maze4 :: Coord -> Tile
maze4 (C x y)
  | abs x > 4  || abs y > 4      = Blank
  | abs x == 4 || abs y == 4     = Wall
  | x ==  2 && y <   0           = Wall
  | x >= -1 && y ==  1 && x <= 2 = Wall
  | x == -3 && y ==  1           = Wall
  | x ==  0 && y ==  3           = Wall
  | x ==  0 && y ==  0           = Wall
  | x ==  3 && y == -3           = Storage
  | x ==  1 && y ==  2           = Storage
  | x == -3 && y ==  2           = Storage
  | x ==  1 && y == -1           = Storage
  | x == -2 && y ==  1           = Box
  | x ==  2 && y ==  2           = Box
  | x <=  1 && y == -2 && x >= 0 = Box
  | otherwise                    = Ground

maze5 :: Coord -> Tile 
maze5 (C x y)
  | abs x >  4 || abs y >  4           = Blank
  | abs x == 4 || abs y == 4           = Wall
  | x ==     1 && y <      0           = Wall
  | x ==    -3 && y ==    -2           = Wall
  | x <=     1 && x >     -2 && y == 0 = Wall
  | x >     -3 && x <      3 && y == 2 = Wall
  | x ==     3 && y >      1           = Storage
  | y ==    -2 && x <      0           = Box
  | y ==    -2 && x ==     2           = Box
  | y ==    0  && x ==     3           = Box
  | y == -1    && x > 1      && x < 4  = Storage
  | otherwise                          = Ground

maze6 :: Coord -> Tile 
maze6 (C x y)
  | abs x > 3  || abs y > 5                 = Blank
  | abs x == 3 || (abs y == 5 && abs x < 4) = Wall
  | x == 0 && abs y < 4                     = Storage
  | x == -1 && (y == 0 || abs y == 2)       = Box
  | x == 1 && (abs y == 1 || abs y == 3)    = Box
  | x == (-2) &&  y == 1                    = Wall
  | otherwise                               = Ground

maze7 :: Coord -> Tile
maze7 (C x y)
  | abs x > 4  || abs y > 4   = Blank
  | abs x == 4 || abs y == 4  = Wall
  | not (x == 2)  && y == 2   = Wall
  | not (x == -2)  && y == -1 = Wall
  | x ==  3 && y == -3        = Storage
  | x == 2 && y == 2          = Box
  | otherwise                 = Ground
  
maze8 :: Coord -> Tile
maze8 (C x y)
  | abs x > 10 || abs y > 10    = Blank
  | x == 0 && y == 0            = Ground
  | abs x == 9 && abs y == 9    = Wall
  | abs x == 10 || abs y == 10  = Wall
  | x == y                      = Storage
  | abs x == abs y              = Box
  | x < 0 && x > (-9) && y == 0 = Box
  | x > 0 && x < 9 && y == 0    = Storage
  | otherwise                   = Ground

maze9 :: Coord -> Tile 
maze9 (C x y)
  | abs x > 4  || abs y > 4                  = Blank
  | abs x == 4 || abs y == 4 || x == -3      = Wall
  | x == -2 && (y == 3 || y == 0)            = Wall
  | x == -1 &&  y == -1                      = Wall
  | x == -0 &&  y == 1                       = Wall
  | x ==  3 &&  y == 0                       = Wall
  | x <   0 && (y == 2 || y == -3)           = Storage
  | x == -1 &&  y == 1                       = Storage
  | x ==  0 && (y == 2 || y == 0 || y == -1) = Box
  | x ==  1 &&  y == -2                      = Box
  | x ==  2 &&  y == -3                      = Box
  | otherwise                                = Ground

maze4'' :: Coord -> Tile
maze4'' (C 1 (-3)) = Box
maze4'' c = maze4 c

maze4' :: Coord -> Tile
maze4' (C 0 1) = Blank
maze4' c = maze4 c

maze9' :: Coord -> Tile
maze9' (C 3 0) = Box
maze9' (C 4 0) = Box
maze9'  c      = maze9 c

week7.hs

module Main where

import Stream
import Supply
import Control.Monad

fib :: [Int]
fib = 1:1:next fib
  where next (x:t@(y:ys)) = (x+y):(next t)

fib2 :: [Int]
fib2 = 1:1:(zipWith (+) fib2 (tail fib2))

exercise :: String -> IO () -> IO ()
exercise title action = header >> action
  where header :: IO ()
        header = putStrLn "" >> putStrLn title >> putStrLn separatorLine
        separatorLine :: String
        separatorLine = replicate (length title) '*'

nats :: Stream Integer
nats = streamIterate (+1) 0

ruler :: Stream Integer
ruler = streamInterleave zeros (streamInterleave ones (streamInterleave twos threefour))
  where zeros = streamRepeat 0
        ones = streamRepeat 1
        twos = streamRepeat 2
        threefour = streamInterleave (streamRepeat 3) (streamRepeat 4)

data Tree a = Node (Tree a) (Tree a) | Leaf a deriving (Show, Eq)

labelTree :: Tree a -> Tree Integer
labelTree t = runSupply nats (go t)
  where go :: Tree a -> Supply Integer (Tree Integer)
        go (Node l r) = Node <$> go l <*> go r
        go (Leaf _) = get >>= return . Leaf

main :: IO ()
main = do
  exercise "fibs" $ do
    print $ take 15 $ fib
    print $ take 15 $ fib2

  exercise "stream" $ do
    print $ "ap" == (take 2 $ streamToList (Cons 'a' (Cons 'p' (streamRepeat '.'))))
    print $ streamCompare "aaaa" (streamRepeat 'a')
    print $ streamCompare "aaaa" (const 'a' <$> (streamRepeat '.'))
    print $ streamCompare [1,2,4] (streamIterate (*2) 1)
    print $ streamCompare [0,1,0,1] (streamInterleave (streamRepeat 0) (streamRepeat 1))
    print $ streamCompare [0..10] nats
    print $ streamCompare [0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4] ruler

  exercise "supply" $ do
    print $ 0 == runSupply nats get
    print $ 10 == runSupply nats (pureSupply 10)
    print $ "10" == runSupply nats (show <$> pureSupply 10)
    print $ 30 == runSupply nats (mapSupply2 (+) (pureSupply 10) (pureSupply 20))
    print $ 200 == runSupply nats ((*) <$> (pureSupply 10) <*> (pureSupply 20))
    print $ 2 == runSupply nats (get >> get >> get >>= pureSupply)
    let x = runSupply nats $ do
              get
              get
              x <- get
              pureSupply x
    print $ 2 == x

  exercise "tree" $ do
    let leaf = Leaf ()
    let tree = Node (Node (Node leaf leaf) leaf) (Node leaf leaf)
    let labeledTree = Node (Node (Node (Leaf 0) (Leaf 1)) (Leaf 2)) (Node (Leaf 3) (Leaf 4))
    print $ (labelTree tree) == labeledTree