# 07.31.07

Posted in Uncategorized at 9:56 pm by admin

One way to do this is to handle each constructor for a `Region` (and a `Shape` for those cases) and reflect those in the x-axis, i.e.

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 (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

And similarly (negating the x-coordinate) for `flipY`. Note that the order of points must change in `HalfPlane`, and should also be reversed in flipping a `Polygon` if we had the clockwise ordering constraint. Another way to solve this exercise is to use the `Scale` constructor on a `Region`:

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

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

Permalink

# 07.29.07

Posted in Uncategorized at 11:55 pm by admin

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 |

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

Permalink

Posted in Uncategorized at 11:52 pm by admin

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

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

Permalink

Posted in Uncategorized at 11:49 pm by admin

The simplest way to allow vertices in clockwise or anticlockwise order is to define `isRightOf` analogously to `isLeftOf`, and combine them with a boolean expression.

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 |

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

Permalink

Posted in Uncategorized at 11:42 pm by admin

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

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

Permalink

Posted in Uncategorized at 11:38 pm by admin

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

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)

The definitions dealing with other kinds of `Shape` need not be changed.

Permalink

Posted in Uncategorized at 11:24 pm by admin

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 |

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

This is technically correct, but the problem here lies with the inability to lazy evaluate `Intersect` in a matter similar to `take`. I’m not sure this could easily be made to work: we would need to define `Intersect` differently and probably also impose an ordering constraint on `Region` composition. Even then, I think we still have an ordering problem with the positive-and-negative-infinite list evaluation, whereby a bounded `Region` and an infinite `Region` (e.g. a semi-infinite halfplane) would be incompatible (although I could be wrong about this depending on how Haskell’s lazy evaluation works exactly).

Permalink

# 07.28.07

Posted in Uncategorized at 9:59 pm by admin

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

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)

Permalink

Posted in Uncategorized at 9:56 pm by admin

It’s not clear what the action of `zip` should be on trees with data only at the leaves: if the two trees are mismatched, what should the zipped tree look like? So it is easier to define `zipWith` on an `InternalTree`, and of course to define `zip` in terms of `zipWith`.

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 |

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

Permalink

Posted in Uncategorized at 9:48 pm by admin

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

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

`repeatTree` is apparently magic: the base case constructor (`ILeaf`) is not specified. But the `takeTree` and `takeTreeWhile` functions work with `repeatTree` as expected.

(Technical error 14 applies to this exercise.)

Permalink

« Previous entries Next Page » Next Page »