CIS 194 Notes and Homework

Hw1

toDigits :: Integer -> [Integer]
toDigits n 
  | n <= 0    = []
  | otherwise = toDigits (n `div` 10) ++ [n `mod` 10]

toDigitsRev :: Integer -> [Integer]
toDigitsRev n
  | n <= 0    = []
  | otherwise = n `mod` 10 : toDigitsRev (n `div` 10)

type Peg = String
type Move = (Peg, Peg)
hanoi :: Integer -> Peg -> Peg -> Peg -> [Move]
hanoi n a b c
  | n <= 0    = []
  | otherwise = (hanoi (n - 1) a c b) ++ [(a, b)] ++ (hanoi (n - 1) c b a)

Hw2

module LogAnalysis where

import Log

parseMessage :: String -> LogMessage
parseMessage strMsg = 
    case words strMsg of
        ("I":ts:msg) -> LogMessage Info (read ts) (unwords msg)
        ("W":ts:msg) -> LogMessage Warning (read ts) (unwords msg)
        ("E":n:ts:msg) -> LogMessage (Error (read n)) (read ts) (unwords msg)
        _ -> Unknown strMsg

parse :: String -> [LogMessage]
parse input =
    case lines input of
        [] -> []
        (x:xs) -> parseMessage x : parse (unlines xs)

cmpMsg :: LogMessage -> LogMessage -> Integer
cmpMsg (LogMessage _ ts1 _) (LogMessage _ ts2 _) = if ts1 < ts2 then -1 else if ts1 > ts2 then 1 else 0
cmpMsg (Unknown _) _ = -1

insert :: LogMessage -> MessageTree -> MessageTree
insert (Unknown _) tree = tree
insert logMsg tree =
    case tree of
        Leaf -> Node Leaf logMsg Leaf
        Node left currMsg right ->
            if cmpMsg logMsg currMsg < 0
            then Node (insert logMsg left) currMsg right
            else Node left currMsg (insert logMsg right)

build :: [LogMessage] -> MessageTree
build msgs = foldr insert Leaf msgs

inOrder :: MessageTree -> [LogMessage]
inOrder Leaf = []
inOrder (Node left logMsg right) =
    inOrder left ++ [logMsg] ++ inOrder right

isError :: LogMessage -> Bool
isError (LogMessage (Error level) _ _) = level >= 50
isError _ = False

getMessage :: LogMessage -> String
getMessage (LogMessage _ _ msg) = msg

whatWentWrong :: [LogMessage] -> [String]
whatWentWrong msgs = 
    let sortedMsgs = inOrder (build msgs)
        errors = filter isError sortedMsgs
    in map getMessage errors

Hw3

skips :: [a] -> [[a]]
skips [] = []
skips xs =
    let skipsn xs n = [xs !! (k * n - 1) | k <- [1..length xs `div` n]]
    in [skipsn xs n | n <- [1..length xs]]

-- Example usage:
-- skips "ABCD" == ["ABCD", "AC", "AD", "A", "B", "C", "D"]
skipsTest :: IO ()
skipsTest = do
    print (skips "ABCD")

localMaxima :: [Integer] -> [Integer]
localMaxima [] = []
localMaxima [x] = []
localMaxima [x, y] = []
localMaxima xs@(x:y:z:r) =
    if y > x && y > z
        then y : localMaxima (y:z:r)
        else localMaxima (y:z:r)

localMaximaTest :: IO ()
localMaximaTest = do
    print (localMaxima [2, 9, 5, 6, 1])

sort :: Ord a => [a] -> [a]
sort [] = []
sort (x:xs) = 
    let smallerSorted = sort [a | a <- xs, a <= x]
        biggerSorted = sort [a | a <- xs, a > x]
    in smallerSorted ++ [x] ++ biggerSorted

histogram :: [Integer] -> String
histogram [] = "=========\n0123456789\n"
histogram xs = 
    let sortedXs = sort xs 
        counts = map (\n -> length (filter (== n) sortedXs)) [0..9]
        height = maximum counts
        rows = [ [if count >= h then '*' else ' ' | count <- counts] | h <- [height, height - 1 .. 1] ]
        rowStrings = map (concat . map (:[])) rows
    in unlines (rowStrings ++ ["=========", "0123456789"])

histogramTest :: IO ()
histogramTest = do
    let xs = [1, 1, 1, 5]
    putStrLn (histogram xs)

main :: IO ()
main = do
    skipsTest
    localMaximaTest
    histogramTest

Hw4

fun1 :: [Integer] -> Integer
fun1 [] = 1
fun1 xs = product . map (\x -> (x - 2)) . filter even $ xs

fun2 :: Integer -> Integer
fun2 1 = 0
-- use `iterate` and `takeWhile`
fun2 n = sum $ filter even $ takeWhile (>1) $ iterate collatz n
    where
        collatz x = if even x then x `div` 2 else 3 * x + 1

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

foldTree :: [a] -> Tree a
-- generate a balanced binary tree from a list
foldTree xs = foldr insert Leaf xs
  where
    insert x Leaf = Node 0 Leaf x Leaf
    insert x (Node h l v r)
      | height l <= height r = Node (h + 1) (insert x l) v r
      | otherwise            = Node (h + 1) l v (insert x r)

    height Leaf = 0
    height (Node h _ _ _) = h

xor :: [Bool] -> Bool
xor [] = False
xor xs = foldr' (\x acc -> if x then not acc else acc) False xs

map' :: (a -> b) -> [a] -> [b]
map' _ [] = []
map' f xs = foldr (\x acc -> f x : acc) [] xs

sieveSundaram :: Integer -> [Integer]
sieveSundaram n =
    let m = (n + 1)
        numbers = [i + j + 2 * i * j | i <- [1..m], j <- [1..m], i + j + 2 * i * j <= 2 * n + 2]
        nonPrimes = foldr (\x acc -> x : acc) [] numbers
    in [x | x <- [1..2 * n + 2], x `notElem` nonPrimes]

Hw5

{-# LANGUAGE FlexibleInstances #-}

import ExprT

-- exercise 1
eval :: ExprT -> Integer
eval (Lit n) = n
eval (Add e1 e2) = eval e1 + eval e2
eval (Mul e1 e2) = eval e1 * eval e2

-- exercise 2
evalStr :: String -> Maybe Integer
evalStr s = 
    case parseExp s of
        Just expr -> Just (eval expr)
        Nothing   -> Nothing

-- exercise 3
class Expr a where
    lit :: Integer -> a
    add :: a -> a -> a
    mul :: a -> a -> a

instance Expr ExprT where
    lit n = Lit n
    add e1 e2 = Add e1 e2
    mul e1 e2 = Mul e1 e2

-- exercise 4
instance Expr Integer where
    lit n = n
    add e1 e2 = e1 + e2
    mul e1 e2 = e1 * e2

instance Expr Bool where
    lit n = n > 0
    add e1 e2 = e1 || e2
    mul e1 e2 = e1 && e2

newtype MinMax = MinMax Integer deriving (Show, Eq)
newtype Mod7 = Mod7 Integer deriving (Show, Eq)

instance Expr MinMax where
    lit n = MinMax n
    add (MinMax e1) (MinMax e2) = MinMax (max e1 e2)
    mul (MinMax e1) (MinMax e2) = MinMax (min e1 e2)

instance Expr Mod7 where
    lit n = Mod7 (n `mod` 7)
    add (Mod7 e1) (Mod7 e2) = Mod7 ((e1 + e2) `mod` 7)
    mul (Mod7 e1) (Mod7 e2) = Mod7 ((e1 * e2) `mod` 7)

testExp :: Expr a => a
testExp = parseExp lit add mul "(3 * -4) + 5"

testInteger = testExp :: Maybe Integer
testBool = testExp :: Maybe Bool
testMinMax = testExp :: Maybe MinMax
testMod7 = testExp :: Maybe Mod7

-- Exercise 5
compile :: ExprT -> Program

instance Expr Program where
    lit n = [PushI n]
    add e1 e2 = e1 ++ e2 ++ [Add]
    mul e1 e2 = e1 ++ e2 ++ [Mul]

compile = parseExp lit add mul

Hw6

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

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

-- exercise 2
-- O(n) time complexity
fibs2 :: [Integer]
fibs2 = fibs2' 0 1
  where
    fibs2' a b = a : fibs2' b (a + b)

-- exercise 3
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 xs =
    let show20 n (Cons y ys) =
        if n >= 20 then "..."
        else show y ++ ", " ++ show20 (n + 1) ys
    in show20 0 xs

-- exercise 4
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)

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

-- exercise 5

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

ruler :: Stream Integer
ruler = streamMap largestPowerOfTwo nats
  where
    largestPowerOfTwo x = if even x then largestPowerOfTwo (x `div` 2) else x

Hw7

import Sized
import Data.Monoid

data JoinList m a = Empty | Single a | Append m (JoinList m a) (JoinList m a)
                    deriving (Eq, Show)

tag :: Monoid m => JoinList m a -> m
tag Empty = mempty
tag (Single a) = mempty
tag (Append m l r) = m

(+++) :: Monoid m => JoinList m a -> JoinList m a -> JoinList m a
Empty +++ jl = jl
jl +++ Empty = jl
jl1 +++ jl2 = Append (tag jl1 <> tag jl2) jl1 jl2

indexJ :: (Sized b, Monoid b) => Int -> JoinList b a -> Maybe a
indexJ _ Empty = Nothing
indexJ _ (Single a) = Just a
indexJ n (Append m l r)
  | n < 0 || n >= getSize (size m) = Nothing
  | n < getSize (size l) = indexJ n l
  | otherwise = indexJ (n - getSize (size l)) r

dropJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a
dropJ _ Empty = Empty
dropJ n jl@(Single _) 
  | n <= 0 = jl
  | otherwise = Empty
dropJ n (Append m l r)
  | n <= 0 = Append m l r
  | n < getSize (size l) = Append m (dropJ n l) r
  | otherwise = dropJ (n - getSize (size l)) r

takeJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a
takeJ _ Empty = Empty
takeJ n jl@(Single _)
  | n <= 0 = Empty
  | otherwise = jl
takeJ n (Append m l r)
  | n <= 0 = Empty
  | n < getSize (size l) = Append (tag l) (takeJ n l) Empty
  | otherwise = Append m l (takeJ (n - getSize (size l)) r)