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 »