haskell-in-space-0.1: Asteroids/Geometry.hs

module Asteroids.Geometry(
   Figure(..),   -- data Figure = Rect Dimension Dimension
                 --             | Triangle Dimension Angle Dimension
                 --             | Polygon [Point]
                 --             | Circle Dimension
                 --             | Translate Point Figure
                 --             | Scale Double Figure
                 --             | Rotate Angle Figure
                 --           deriving (Eq, Ord, Show)
   draw,  --  :: Figure-> Graphic
   Shape, -- abstract
   shape, --     :: Figure -> Shape
   drawShape, -- :: Figure-> Graphic
   contains,  -- :: Shape-> Point-> Bool
   intersect, -- :: Shape-> Shape-> Bool
   polar, -- :: Double-> Angle-> Point
   smult, --  :: Double-> Point-> Point
   add,   --  :: Point-> Point-> Point
   len,   --  :: Point-> Double
   rot    --  :: Angle-> Point-> Point
) where

import Graphics.HGL.Units (Angle(), Point())
import Graphics.HGL.Draw.Picture (ellipse, polygon)
import Graphics.HGL.Draw.Monad (Graphic())
import Data.List (nub)

-- to make ghc happy -- delete for hugs
fromInt :: Num a=> Int-> a
fromInt n = fromInteger $ toInteger n

-- unchanged bits from previous version
type Dimension = Int
data Figure = Rect Dimension Dimension
            | Triangle Dimension Angle Dimension
            | Polygon [Point]
            | Circle Dimension
            | Translate Point Figure
            | Scale Double Figure
            | Rotate Angle Figure
           deriving (Eq, Ord, Show)

smult :: Double-> Point-> Point
smult f (x, y)
  | f == 1    = (x, y)
  | otherwise = (round (f* fromInt x),
                 round (f* fromInt y))
add :: Point-> Point-> Point
add (x1, y1) (x2, y2) = (x1+ x2, y1+ y2)

rot :: Angle-> Point-> Point
rot w (x, y)
  | w == 0    = (x, y)
  | otherwise = (round (x'* cos w+ y'* sin w),
                 round (-x' * sin w + y'* cos w)) where
                x' = fromInt x; y'= fromInt y


data Shape = Poly [Point]
           | Circ Point Double
           deriving (Eq, Show)

shape :: Figure-> Shape
shape = fig' ((0, 0), 1, 0) where
  fig' :: (Point, Double, Angle)-> Figure-> Shape
  fig' (m, r, phi) (Translate t f) =
    fig' (add m (smult r (rot phi t)), r, phi) f
  fig' (m, r, phi) (Scale s f) =
    fig' (m, r* s, phi) f
  fig' (m, r, phi) (Rotate w f) =
    fig' (m, r, phi+ w) f
  fig' c (Rect a b) =
    poly c [(x2, y2), (-x2, y2),
            (-x2, -y2), (x2, -y2)] where
      x2= a `div` 2; y2= b `div` 2
  fig' c (Triangle l1 a l2) =
    poly c [(0, 0), (0, l1), rot a (0, l2)]
  fig' c (Polygon pts) = poly c pts
  fig' (m, r, _) (Circle d) =
    Circ m (r*fromInt d)
  poly :: (Point, Double, Angle)-> [Point]-> Shape
  poly (m, p, w) = Poly. chckcls.
                      map (add m. smult p. rot w) where
    chckcls [] = []
    chckcls x  = if (head x) == (last x)
                    then x else x++ [head x]
drawShape :: Shape-> Graphic
drawShape (Poly pts) = polygon pts
drawShape (Circ (mx, my) r) =
    ellipse (mx-r', my- r') (mx+ r', my+ r') where
      r'= round r

draw :: Figure-> Graphic
draw = drawShape . shape

contains :: Shape-> Point-> Bool
contains (Poly pts)= inP pts
contains (Circ c r)= inC c r

inC :: Point-> Double-> Point-> Bool
inC (mx, my) r (px, py) = len (px- mx, py- my) <= r

len :: Point-> Double
len (x, y)= sqrt (fromInt (x^(2::Int)+ y^(2::Int)))

det :: Point-> (Point, Point)-> Int
det (cx,cy) ((ax,ay), (bx,by)) =
  signum ((by-ay)*(cx-bx)-(cy-by)*(bx-ax))

sides :: [Point]-> [(Point, Point)]
sides ps | length ps < 2 = []
         | otherwise     = (head ps, head (tail ps)):
                                       sides (tail ps)

inP :: [Point]-> Point-> Bool
inP ps c = (length. nub. map (det c). sides) ps == 1

intersect :: Shape-> Shape-> Bool
intersect (Poly p) (Circ c r)=
   inP p c || any (inC c r) p
intersect (Circ c r) (Poly p)=
   inP p c || any (inC c r) p
intersect (Poly p1) (Poly p2)=
   any (inP p1) p2 || any (inP p2) p1
intersect (Circ (mx1, my1) r1) (Circ (mx2, my2) r2)=
   len (mx2- mx1, my2- my1) <= r1+ r2

polar :: Double-> Angle-> Point
polar r phi = rot phi (round r, 0)