module Slides6 where
import Prelude hiding (print)
import Maybe (fromMaybe)
-- import Slides4 (qsortBy)
-- import IOExts(trace)

data Weekday = Mon | Tue | Wed | Thu | Fri | Sat | Sun

isWeekend :: Weekday -> Bool
isWeekend Sat = True
isWeekend Sun = True
isWeekend _   = False    

data Date  = Date Day Month Year    
type Day   = Int
data Month = Jan | Feb | Mar | Apr | May | Jun 
           | Jul | Aug | Sep | Oct | Nov | Dec
type Year  = Int

today     = Date 29 Nov 2004
bloomsday = Date 16 Jun 1904
fstday    = Date 1 Jan 1

day  :: Date-> Day
year :: Date-> Year
day  (Date d m y) = d
year (Date d m y) = y

type Point = (Double, Double)
data Shape = Circ Point Int 
           | Rect Point Point
           | Poly [Point]

           deriving (Show)

corners :: Shape-> Int
corners (Circ _ _)       = 0
corners (Rect _ _)       = 4
corners (Poly ps)        = length ps 

move :: Shape-> Point-> Shape
move (Circ m d) p   = Circ (add p m) d
move (Rect c1 c2) p = Rect (add p c1) (add p c2)
move (Poly ps) p    = Poly (map (add p) ps) 

add :: Point-> Point-> Point
add (x, y) (u, v) = (x+ u, y+ v)

area :: Shape-> Double
area (Circ _ d) = pi* (fromIntegral d)
area (Rect (x1, y1) (x2, y2)) = 
      abs ((x2- x1)* (y2- y1))       

area (Poly ps) | length ps < 3  = 0
area (Poly (p1:p2:p3:ps)) = 
           triArea p1 p2 p3 + 
           area (Poly (p1:p3:ps))

triArea :: Point-> Point-> Point-> Double
triArea p1 p2 p3 = 
  let s= 0.5*(a+ b+ c) 
      a= dist p1 p2
      b= dist p2 p3
      c= dist p3 p1
  in  sqrt (s*(s- a)*(s- b)*(s- c))

dist :: Point-> Point-> Double
dist (x1, y1) (x2, y2) = sqrt((x1-x2)^2+ (y2- y1)^2)

data Expr = Lit Int 
          | Var String
          | Add Expr Expr
          | Mult Expr Expr

          deriving (Eq,Read,Show)    

eval :: (String-> Int)-> Expr-> Int
eval f (Lit n) = n
eval f (Var x) = f x 
eval f (Add e1 e2)  = eval f e1+ eval f e2
eval f (Mult e1 e2) = eval f e1* eval f e2

print :: Expr-> String 
print (Lit n) = show n
print (Var x) = x
print (Add e1 e2)  = "("++ print e1++ "+"++ print e2++ ")"
print (Mult e1 e2) = "("++ print e1++ "*"++ print e2++ ")"

foldE :: (Int-> a)-> (String-> a)
         -> (a-> a-> a)-> (a-> a-> a)-> Expr-> a
foldE b v a m (Lit n)     = b n
foldE b v a m (Var x)     = v x
foldE b v a m (Add e1 e2) = a (foldE b v a m e1)
                              (foldE b v a m e2)
foldE b v a m (Mult e1 e2) = m (foldE b v a m e1)
                               (foldE b v a m e2)

eval' :: (String-> Int)-> Expr-> Int
print':: Expr-> String    

eval' f  = foldE id f (+) (*)
print'   = 
  foldE show id 
        (\s1 s2-> "("++ s1++ "+"++ s2++ ")")
        (\s1 s2-> "("++ s1++ "*"++ s2++ ")")

data Pair a = Pair a a    

              deriving (Show, Read)    

twist :: Pair a-> Pair a
twist (Pair a b) = Pair b a

mapP :: (a-> b)-> Pair a-> Pair b
mapP f (Pair a b)= Pair (f a) (f b)

data List a = Mt | Cons a (List a)  

              deriving (Eq, Show)

fold :: (a-> b-> b)-> b-> List a-> b
fold f e Mt          = e
fold f e (Cons a as) = f a (fold f e as)

map' f    = fold (Cons . f) Mt
length'   = fold ((+).(const 1)) 0 
filter' p = fold (\x-> if p x then Cons x else id) Mt 

find :: (a-> Bool)-> [a]-> Maybe a
find p []     = Nothing
find p (x:xs) = if p x then Just x 
                else find p xs

maybe :: b -> (a -> b) -> Maybe a -> b
maybe d f Nothing  = d
maybe d f (Just x) = f x

data Tree a = Null  
            | Node (Tree a) a (Tree a)  

               deriving (Eq, Read, Show)

data Tree' a b = Null' 
               | Leaf' b 
               | Node' (Tree' a b) a (Tree' a b)

  deriving (Eq, Read, Show)

member :: Eq a=> Tree a-> a-> Bool
member Null _ = False
member (Node l a r) b =
  a == b || (member l b) || (member r b)

foldT :: (a-> b-> b-> b)-> b-> Tree a-> b    
foldT f e Null = e
foldT f e (Node l a r) = f a (foldT f e l) (foldT f e r)

member' :: Eq a=> Tree a-> a-> Bool

member' t x = 
   foldT (\e b1 b2-> e == x || b1 || b2) False t

preorder  :: Tree a-> [a]
inorder   :: Tree a-> [a]
postorder :: Tree a-> [a]
preorder   = foldT (\x t1 t2-> [x]++ t1++ t2) []
inorder    = foldT (\x t1 t2-> t1++ [x]++ t2) []
postorder  = foldT (\x t1 t2-> t1++ t2++ [x]) []

preorder' Null          = []
preorder' (Node l a r)  = [a] ++preorder' l ++preorder' r

test1 = Node (Node Null 4 (Node Null 5 Null)) 7
             (Node (Node (Node Null 8 Null) 9 Null) 11 (Node Null 12 Null))

insert :: Ord a=> Tree a-> a-> Tree a
insert Null a = Node Null a Null
insert (Node l a r) b
  | b < a  = Node (insert l b) a r
  | b == a = Node l a r
  | b > a  = Node l a (insert r b) 

delete :: Ord a=> Tree a-> a-> Tree a
delete Null _ = Null
delete (Node l y r) x
  | x < y  = Node (delete l x) y r
  | x == y = join l r
  | x > y  = Node l y (delete r x)

join ::  Tree a-> Tree a-> Tree a
join xt Null = xt
join xt yt   = Node xt u nu where
  (u, nu) = splitTree yt
  splitTree :: Tree a-> (a, Tree a)
  splitTree (Node Null a t) = (a, t)
  splitTree (Node lt a rt) =
    (u, Node nu a rt) where
       (u, nu) = splitTree lt

t = Node (Node (Node Null 1 Null)
                5
               (Node Null 7 Null))
         9
         (Node (Node Null 10 Null)
               13
               (Node Null 29 Null))

instance Eq Shape where

 Circ p1 i1 == Circ p2 i2 = p1 == p2 && i1 == i2
 Rect p1 q1 == Rect p2 q2 = p1 == p2 && q1 == q2
 Poly ps    == Poly qs    = ps == qs
 _          == _          = False