Move to stack src directory

1 files changed, 87 insertions, 0 deletions

diff --git a/src/ch2/Shape.hs b/src/ch2/Shape.hs
new file mode 100644
index 0000000..d1f9e2f
--- /dev/null
+++ b/src/ch2/Shape.hs
@@ -0,0 +1,87 @@
+module Shape
+        ( Shape
+        , area
+        , square
+        , circle
+        , polygon
+        )
+where
+
+data Shape = Rectangle Side Side
+           | Ellipse Radius Radius
+           | RtTriangle Side Side
+           | Polygon [Vertex]
+  deriving Show
+
+type Radius = Float
+type Side = Float
+type Vertex = (Float, Float)
+
+polygon :: [Vertex] -> Shape
+polygon vs = Polygon vs
+
+area :: Shape -> Float
+area (Rectangle  s1 s2 ) = s1 * s2
+area (RtTriangle s1 s2 ) = s1 * s2 / 2
+area (Ellipse    r1 r2 ) = pi * r1 * r2
+area (Polygon vs)
+  | length vs <= 2 = 0
+  | otherwise = polyArea (vs ++ [head vs])
+  where polyArea :: [Vertex] -> Float
+        polyArea (v1: v2: vs') = trapezoidArea v1 v2 + polyArea (v2:vs')
+        polyArea _ = 0
+
+trapezoidArea :: Vertex -> Vertex -> Float
+trapezoidArea v1 v2 =
+        let h      = fst v2 - fst v1
+            aplusb = snd v2 + snd v1
+        in  (aplusb / 2) * h
+
+triArea :: Vertex -> Vertex -> Vertex -> Float
+triArea v1 v2 v3 =
+        let a = distBetween v1 v2
+            b = distBetween v2 v3
+            c = distBetween v3 v1
+            s = 0.5 * (a + b + c)
+        in  sqrt (s * (s - a) * (s - b) * (s - c))
+
+distBetween :: Vertex -> Vertex -> Float
+distBetween (x1, y1) (x2, y2) = sqrt ((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
+
+circle :: Radius -> Shape
+circle r = Ellipse r r
+
+convex :: Shape -> Bool
+convex (Rectangle  a  b ) = True
+convex (RtTriangle a  b ) = True
+convex (Ellipse    r1 r2) = True
+convex (Polygon [_, _, _]) = True
+convex (Polygon (vfirst : vsecond : vthird : vs)) = False
+
+crossProduct :: Vertex -> Vertex -> Vertex -> Float
+crossProduct (x1, y1) (x2, y2) (x3, y3) = (x2 - x1) * (y3 - y2) - (y2 - y1) * (x3 - x2)
+
+square :: Side -> Shape
+square s = Rectangle s s
+
+rectangle :: Side -> Side -> Shape
+rectangle s1 s2 = Polygon [(x, y), (-x, y), (-x, -y), (x, -y)]
+    where
+        x = s1 / 2
+        y = s2 / 2
+
+regularPolygon :: Int -> Side -> Shape
+regularPolygon n s =
+        let
+                angleinc = (pi * 2) / fromIntegral n
+                radius   = (s * sin ((pi - angleinc) / 2)) / sin angleinc
+                regularVerts 0 _ = []
+                regularVerts n angle =
+                        (radius * cos angle, radius * sin angle) : regularVerts
+                                (n - 1)
+                                (angle + angleinc)
+        in
+                Polygon (regularVerts n 0)
+
+rtTriangle :: Side -> Side -> Shape
+rtTriangle s1 s2 = Polygon [(0, 0), (s1, 0), (0, s2)]