> module Shape where

> type Coord  = Double
> type Length = Double
> type Angle  = Double

> type Vertex = (Coord, Coord)

> type BinOp t = t -> t -> t

> vertOp :: BinOp Double -> BinOp Vertex
> vertOp op (x1,y1) (x2,y2) = (x1 `op` x2, y1 `op` y2)

> (^-^) = vertOp (-)
> (^+^) = vertOp (+)

> skal :: Double -> Vertex -> Vertex
> skal s (x,y) = (s * x, s * y)

> scaleVertex v s v1 = skal s (v1 ^-^ v) ^+^ v

> class HasVert p where
>   bbox           :: p -> Maybe (Vertex,Vertex)
>   vertMap        :: (Vertex -> Vertex) -> p -> p
>   move           :: Vertex             -> p -> p
>   scale          :: Vertex -> Double   -> p -> p

>   move v = vertMap (v ^+^)
>   scale v s = vertMap (scaleVertex v s)

> data Shape = Squat Vertex -- invisible!
>            | Rectangle Vertex Vertex
>            | Polygon [Vertex]            -- filled
>            | PolygonOL [Vertex]          -- outline only
>            | Polyline [Vertex]
>            | Ellipse Vertex Vertex
>            | ShearEllipse Vertex Vertex Vertex
>            | Text Vertex String

> instance HasVert Shape where
>   vertMap f (Squat p)       = Squat (f p)
>   vertMap f (Rectangle p q) = Rectangle (f p) (f q)
>   vertMap f (Polygon vs)    = Polygon $ map f vs
>   vertMap f (PolygonOL vs)  = PolygonOL $ map f vs
>   vertMap f (Polyline vs)   = Polyline $ map f vs
>   vertMap f (Ellipse p q)   = Ellipse (f p) (f q)
>   vertMap f (ShearEllipse p q r) = ShearEllipse (f p) (f q) (f r)
>   vertMap f (Text p s) = Text (f p) s

>   bbox (Squat p) = Just (p,p)
>   bbox (Text p s) = Just (p,p)
>   bbox (Rectangle p q) = Just (p,q)
>   bbox (Polygon vs)    = Just $ vertList_bb vs
>   bbox (PolygonOL vs)  = Just $ vertList_bb vs
>   bbox (Polyline vs)   = Just $ vertList_bb vs
>   bbox (Ellipse p q)   = Just (p,q)
>   bbox (ShearEllipse p1 p2 p3) = let p4 = p3 ^+^ (p2 ^-^ p1)
>                                  in Just $ vertList_bb [p1,p2,p4,p3]

> vertList_bb vs = let
>   (xs,ys) = unzip vs
>   xl = minimum xs
>   xr = maximum xs
>   yl = minimum ys
>   yu = maximum ys
>  in ((xl,yl), (xr,yu))