The Haskell School of Expression: Exercises

flipX :: Region -> Region
flipX (Translate (a,b) r) = Translate (a,-b) (flipX r)
flipX (Scale (a,b) r) = Scale (a,-b) (flipX r)
flipX (Complement r) = Complement (flipX r)
flipX (r1 `Union` r2) = (flipX r1) `Union` (flipX r2)
flipX (r1 `Intersect` r2) = (flipX r1) `Intersect` (flipX r2)
flipX (HalfPlane (x1,y1) (x2,y2)) = HalfPlane (x2,-y2) (x1,-y1)
flipX Empty = Empty
flipX (Shape s) = Shape (flipXShape s)
    where flipXShape (RtTriangle a b) = RtTriangle a (-b)
          flipXShape (Polygon vs) = Polygon (map ((x,y) -> (x,-y)) vs)
          flipXShape s = s

flipX :: Region -> Region
flipX r = Scale (1, -1) r
 
flipY :: Region -> Region
flipY r = Scale (-1, 1) r

polygon :: [Coordinate] -> Region
polygon [] = Empty
polygon [x] = Empty
polygon (x:xs) = halfPlanes x (xs ++ [x])
    where halfPlanes x1 (x2:xs) = HalfPlane x1 x2 `Intersect` halfPlanes x2 xs
          halfPlanes xlast [] = Complement Empty

data Region = ...
            | HalfPlane Coordinate Coordinate
            ...
 
(HalfPlane p1 p2) `containsR` p = p `isLeftOf` (p1,p2)

isLeftOf :: Coordinate -> Ray -> Bool
(px,py) `isLeftOf` ((ax,ay), (bx,by))
    = let (s,t) = (px-ax, py-ay)
          (u,v) = (px-bx, py-by)
      in s * v >= t * u
 
isRightOf :: Coordinate -> Ray -> Bool
(px,py) `isRightOf` ((ax,ay), (bx,by))
    = let (s,t) = (px-ax, py-ay)
          (u,v) = (px-bx, py-by)
      in s * v <= t * u
 
(Polygon pts) `containsS` p
    = let leftOfList = map isLeftOfp (zip pts (tail pts ++ [head pts]))
          isLeftOfp p' = isLeftOf p p'
          rightOfList = map isRightOfp (zip pts (tail pts ++ [head pts]))
          isRightOfp p' = isRightOf p p'
      in and leftOfList || and rightOfList

r1 `difference` r2 = r1 `Intersect` (Complement r2)
 
annulus :: Radius -> Radius -> Region
annulus rinner router = Shape (circle router) `difference` Shape (circle rinner)

area (Rectangle a b) = abs(a * b)
area (RtTriangle a b) = abs(a * b) / 2
area (Ellipse r1 r2) = pi * abs(r1 * r2)
 
perimeter (Rectangle s1 s2) = 2 * (abs s1 + abs s2)
perimeter (RtTriangle s1 s2) = abs s1 + abs s2 + sqrt(s1^2 + s2^2)
perimeter (Ellipse r1 r2)
    | abs r1 > abs r2 = ellipsePerim (abs r1) (abs r2)
    | otherwise = ellipsePerim (abs r2) (abs r1)
    where ellipsePerim r1 r2 = let e = sqrt (r1^2 - r2^2) / r1
                                   aux s i = nextEl e s i
                                   s = scanl aux (0.25 * e^2) [2..]
                                   test x = x > epsilon
                                   sSum = sum (takeWhile test s)
                               in 2 * r1 * pi * (1 - sSum)

oneCircle = Shape (Ellipse 1 1)
manyCircles' = [Translate (x,y) oneCircle | x <- centers, y <- centers]
    where centers = [0, 2 ..] ++ [-2, -4 ..]
manyCirclesRegion = foldl Union Empty manyCircles'
rectRegion = Translate (4,0) (Shape (Rectangle 10 2))
fiveCircles' = rectRegion `Intersect` manyCirclesRegion

data Expr = C Float
          | V String
          | Expr :+ Expr
          | Expr :- Expr
          | Expr :* Expr
          | Expr :/ Expr
          | Let String Expr Expr
            deriving Show
 
evaluate :: Expr -> [(String, Float)] -> Float
evaluate (C x) _ = x
evaluate (V x) vars = lookup x vars
    where lookup i [] = error "Unbound variable"
          lookup i ((a,b):vars) = if i == a then b else lookup i vars
evaluate (e1 :+ e2) vars = (evaluate e1 vars) + (evaluate e2 vars)
evaluate (e1 :- e2) vars = (evaluate e1 vars) - (evaluate e2 vars)
evaluate (e1 :* e2) vars = (evaluate e1 vars) * (evaluate e2 vars)
evaluate (e1 :/ e2) vars = (evaluate e1 vars) / (evaluate e2 vars)
evaluate (Let s e1 e2) vars = let es = evaluate e1 vars 
                              in evaluate e2 ((s, es):vars)

zipWithInternalTree :: (a -> b -> c) -> InternalTree a
                    -> InternalTree b -> InternalTree c
zipWithInternalTree f ILeaf _ = ILeaf
zipWithInternalTree f _ ILeaf = ILeaf
zipWithInternalTree f (IBranch a x y) (IBranch b i j)
    = IBranch (f a b) x' y'
      where x' = (zipWithInternalTree f x i)
            y' = (zipWithInternalTree f y j)
 
zipInternalTree :: InternalTree a -> InternalTree b -> InternalTree (a,b)
zipInternalTree x y = zipWithInternalTree (,) x y

foldrTree :: (a -> b -> b) -> b -> InternalTree a -> b
foldrTree f z ILeaf = z
foldrTree f z (IBranch a x y) = foldrTree f (f a (foldrTree f z y)) x
 
foldlTree :: (a -> b -> a) -> a -> InternalTree b -> a
foldlTree f z ILeaf = z
foldlTree f z (IBranch a x y) = foldlTree f (f (foldlTree f z x) a) y
 
repeatTree :: a -> InternalTree a
repeatTree a = t
    where t = (IBranch a (t) (t))