David Tran’s blog

{-

    Program : make_change.hs
    Author  : David Tran
    Date    : 2008-10-25

    On the SOE exercise 5.9 (http://davidtran.doublegifts.com/blog/?p=37)
    I said that I will find a solution for it. Here it is.
    The make change question could be considered as partitions of integers
    problem. (http://davidtran.doublegifts.com/blog/?p=152)
    The amount money is the interger to be partition.
    The coins are the generating functions; only select functions matchs coins' value.

    Examples:
    makeChange 99 [5, 1]         ==> [19,4]
    makeChange 18 [10, 9, 3, 1]  ==> [0,2,0,0]

-}
import Data.List
import Data.Maybe

type Constant = (Int, Int)       -- "Constant" at "Position"
type Coefficient = [ Constant ]  -- "Sum" of Constant
type Exponent = Int
type Term = (Coefficient, Exponent)
type Polynomial = [ Term ]       -- "Sum" of Term

term :: Int -> Int -> Polynomial
term max n = ([],0) : [ ([(n,i)], n * i) | i <- [1.. max `div` n ] ]

mult :: Int -> Polynomial -> Polynomial -> Polynomial
mult max p1 p2 = [ (c1++c2, e1+e2) | (c1,e1) <- p1, (c2,e2) <- p2, e1+e2 <= max ]

makeChange :: Int -> [Int] -> [Int]
makeChange n cs = to_solution $ min_change $ only_coeff $ filter_terms $ generate_terms 
  where
  generate_terms = foldr1 (mult n) (map (term n) cs)
  filter_terms   = filter (\(c, e) -> e == n)
  only_coeff     = map (\(c, e) -> c)
  min_change     = minimumBy (\x y -> compare (countCoin x) (countCoin y))
  countCoin      = foldr (\(c,t) sum -> sum + t) 0
  to_solution xs = map (\c -> fromMaybe 0 (lookup c xs)) cs
  

class Area a where
  area :: a -> Float

class Perimeter p where
  perimeter :: p -> Float

class Draw d where
  draw :: d -> IO ()

data Rectangle = Rectangle Float Float

instance Area Rectangle where
  area (Rectangle w h) = w * h

instance Perimeter Rectangle where
  perimeter (Rectangle w h) = 2 * (w + h)

-- instance Draw Rectangle where ...

data Circle = Circle Float

instance Area Circle where
  area (Circle radius) = pi * radius * radius

instance Perimeter Circle where
  perimeter (Circle radius) = 2 * pi * radius

-- instance Draw Circle where ...


-- ... etc

quicksort :: Ord a => [a] -> [a]
quicksort [] = []

{-
quicksort (x:xs) = quicksort [n | n <- xs, n < x]   ++ 
                   [x]                              ++ 
                   quicksort [n | n <- xs, n >= x]
-}

quicksort (x:xs) = quicksort lesser ++ x : quicksort greater
  where
  part l g [] = (l, g)
  part l g (n:ns) = if n < x then part (n:l) g ns else part l (n:g) ns
  (lesser, greater) = part [] [] xs


-- qsort (x:xs) = qsort (filter (< x) xs) ++ [x] ++ qsort (filter (>= x) xs)


-- import Data.List
-- qsort (x:xs) = qsort less ++ [x] ++ qsort more
--   where (less, more) = partition (<x) xs


-- http://en.wikipedia.org/wiki/Quicksort
-- http://www.haskell.org/haskellwiki/Introduction 
-- http://en.literateprograms.org/Quicksort_(Haskell)

data Color = Red | Orange | Yellow | Green | Blue | Indigo | Violet
  deriving Show
--  deriving (Eq, Enum, Ord, Show)

-- Consult Prelude.hs to know about the Minimal complete definition for each class.


instance Eq Color where   -- Minimal complete definition: (==) or (/=)
  Red == Red        = True
  Orange == Orange  = True
  Yellow == Yellow  = True
  Green == Green    = True
  Blue == Blue      = True
  Indigo == Indigo  = True
  Violet == Violet  = True
  _ == _            = False


instance Ord Color where   -- Minimal complete definition: (<=) or compare
  Red    < Orange   = True
  Red    < Yellow   = True
  Red    < Green    = True
  Red    < Blue     = True
  Red    < Indigo   = True
  Red    < Violet   = True
  Orange < Yellow   = True
  Orange < Green    = True
  Orange < Blue     = True
  Orange < Indigo   = True
  Orange < Violet   = True
  Yellow < Green    = True
  Yellow < Blue     = True
  Yellow < Indigo   = True
  Yellow < Violet   = True
  Green  < Blue     = True
  Green  < Indigo   = True
  Green  < Violet   = True
  Blue   < Indigo   = True
  Blue   < Violet   = True
  Indigo < Violet   = True
  _      < _        = False

  a <= b = (a < b) || (a == b)


instance Enum Color where   -- Minimal complete definition: toEnum, fromEnum
  fromEnum Red    = 0
  fromEnum Orange = 1
  fromEnum Yellow = 2
  fromEnum Green  = 3
  fromEnum Blue   = 4
  fromEnum Indigo = 5
  fromEnum Violet = 6

  toEnum 0 = Red
  toEnum 1 = Orange
  toEnum 2 = Yellow
  toEnum 3 = Green
  toEnum 4 = Blue
  toEnum 5 = Indigo
  toEnum 6 = Violet

{-  
  Redefine the two methods below to make sure 
  something like [Red ..], [Indigo, Green ..] just works
  as we deriving (Enum).
-}

  enumFrom x = map toEnum [ fromEnum x .. 6]

  enumFromThen x y =
    let x' = fromEnum x
        y' = fromEnum y
        z' = if (x' > y')
             then 0
             else if (x' < y')
                  then 6
                  else x'
    in  map toEnum [x', y' .. z']

class Eq a where
  (==), (/=) :: a -> a -> Bool
  x /= y   = not (x == y)
  x == y   = not (x /= y)

data Tree a = Leaf a | Branch (Tree a) (Tree a)

instance Eq a => Eq (Tree a) where
  Leaf a == Leaf b               = a == b
  Branch l1 r1 == Branch l2 r2   = l1 == l2 && r1 == r2
  _ == _                         = False

(A) Prove that the instance of Tree in the class Eq satisfies the laws of its class.

Law #1:  (x/=y) = not (x==y)
Since we do not redefine the operator (/=), it takes its default method, which defined just like the law to prove.

Law #2:  (x==y) && (y==z)  ====>  (x==z)
(x == y):
 Leaf xa == Leaf ya            = xa == ya
 Branch xl xr == Branch yl yr  = xl == yl && xr == yr
 _ == _                        = False

(y == z):
 Leaf ya == Leaf za            = ya == za
 Branch yl yr == Branch zl zr  = yl == zl && yr == zr
 _ == _                        = False

so (x == z):
  Leaf xa == Leaf za ====>  (xa == ya) && (ya == za) ====> (xa == za) ====> True
  Branch xl xr == Branch zl zr  ====> xl == yl && xr == yr && yl == zl && yr == zr
                                ====> xl == zl && xr == zr
                                ====> True
  _ == _  = False =====> True

(B) Also prove that the modified instance of Tree in
    the class Ord satisfies the laws of its class.

Skip ... (maybe come back later to do it)

(^!) :: Integer -> Integer -> Integer
x ^! n | n < 0     = error "negative exponent"
       | otherwise = f x n
  where
  f x n | n == 0    = 1
        | even n    = even_f x n
        | otherwise = x * even_f x (n-1)
    where
    even_f x n = f (x * x) (n `quot` 2)

A function f is strict if  f ⊥ = ⊥

(1)
reverse :: [a] -> [a] is strict
reverse ⊥ = ⊥

  Easy to test, just try:
  reverse (head []) ==> error

(2)
simple :: Integer -> Integer -> Integer
simple x y z = x * (y + z)
simple is strict on all arguments.
simple ⊥ y z = simple x ⊥ z = simple x y ⊥ = ⊥
( because (*) and (+) are strict )

  simple (head [] :: Integer) 2 3 ==> error
  simple 1 (head [] :: Integer) 3 ==> error
  simple 1 2 (head [] :: Integer) ==> error

(3)
map :: (a -> b) -> [a] -> [b]
map is strict only on second argument.

  map id (head []) ==> error
  map (head []) [] ==> []

(4)
tail :: [a] -> [a]
tail is a strict function.
tail ⊥ = ⊥

  tail (head []) ==> error

(5)
area :: Shape -> Float
Base on the definition of area function (page#29),
area is a strict function.
area ⊥ = ⊥

(6)
regionToGRegion :: Region -> G.Region  -- page#119
regionToGRegion r = regToGReg (0,0) (1,1) r
and
regToGReg :: Vector -> Vector -> Region -> G.Region
and
base on the definition of regToGReg page#120
if region is ⊥ the result will be ⊥.
pattern matching will fail for ⊥ case.

  regionToGRegion ⊥ = ⊥

(7)
(&&) :: Bool -> Bool -> Bool
False && x   = False  -- Prelude's definition
True  && x   = x

Base on its definition, (&&) is strict only on first argument.
  ⊥ && x = ⊥
  False    && ⊥ = False

(8)
(True &&) :: Bool -> Bool
is a strict function.
  (True &&) ⊥ = ⊥

(9)
(False &&) :: Bool -> Bool
is not a strict function.
  (False &&) ⊥ = False

(10)
ifFun :: Bool -> a -> a -> a
ifFun pred cons alt = if pred then cons else alt
ifFun is strict function on all arguments.

  ifFun (head [] :: Bool) 1 2 ==> error
  ifFun True (head []) 2 ==> error
  ifFun False 1 (head []) ==> error

Just prove one, maybe later back to prove others.

Prove: For all finite nonnegative m and n such that n >= m:
drop m . take n = take (n - m) . drop m

(a) base step: m = 0
(drop 0 . take n) xs = drop 0 (take n xs) = take n xs
(take (n-0) . drop 0) xs = take n (drop 0 xs) = take n xs
==> Proven.

(b) induction hypothesis: Assume that (drop m . take n) xs = (take (n-m) . drop m) xs

(drop (m+1) . take n) xs
= drop (m+1) (take n xs)
= drop (1+m) (take n xs) -- commutative of (+)
= (drop 1 . drop m) (take n xs)) -- property of drop m . drop n = drop (m+n)
= drop 1 ( drop m (take n xs))
= drop 1 ((drop m . take n) xs)
= drop 1 ((take (n-m) . drop m) xs) -- induction hypothesis assumption
= drop 1 (take (n-m) (drop m xs))
= (drop 1 . take (n-m)) (drop m xs)
= (take (n-m-1) . drop 1) (drop m xs) -- property of take m . drop n = drop n . take (m+n)
= take (n-(m+1)) (drop 1 (drop m xs))
= take (n-(m+1)) ((drop 1 . drop m) xs)
= take (n-(m+1)) (drop(1+m) xs) -- property of drop m . drop n = drop (m+n)
= (take (n-(m+1)) . drop (m+1)) xs -- commutative of (+)
==> Proven.

Prove: putCharList cs = map putChar cs

Recall: (Page#58)
putCharList :: String -> [IO()]
putCharList [] = []
putCharList (c:cs) = putChar c : putCharList cs

(a) base step
putCharList [] = []
map putChar [] = []
==> Proven.

(b) induction hypothesis: we assume that putCharList xs = map putChar xs
putCharList (x:xs) = putChar x : putCharList xs
map putChar (x:xs) = putChar x : map putChar xs
Because induction hypothesis, we have putCharList(x:xs) = map putChar (x:xs)
==> Proven.

-----------------------------------------------------------------------------

Prove: listProd xs = fold (*) 1 xs

Recall: (Page#66)
listProd :: [Float] -> [Float]
listProd [] = 1
listProd (x:xs) = x * listProd xs

fold op init [] = init
fold op init (x:xs) = x `op` fold op init xs

(a) base step
listProd [] = 1
fold (*) 1 [] = 1
==> Proven.

(b) induction hypothesis: we assume that listProd ns = fold (*) 1 ns
listProd (n:ns) = n * listProd ns
fold (*) 1 (n:ns) = n * fold (*) 1 ns
Because induction hypothesis, we have listProd (n:ns) = fold (*) 1 (n:ns)
==> Proven.