Reworked Transform as a type class

src/Vector.hs

@@ -1,12 +1,20 @@
 {-# LANGUAGE TypeFamilies #-}
 
-module Vector ( Vertex(..)
+module Vector ( Coord
+              , Transformable(..)
+              , Transform(..)
+              , ReversibleTransform(..)
+              , Vertex(..)
               , Vector(..)
+              , Rotation
+              , zeroV
+              , (^+^)
+              , negateV
+              , (><)
               , toAngle
-              , translateV
-              , translateV'
-              , rotateV
-              , rotateV'
+              , fromAngle
+              , toVector
+              , fromVector
               , diffV
               ) where
 
@@ -18,13 +26,14 @@ import Data.LinearMap
 
 data Vertex = Vertex { vertexX :: Coord, vertexY :: Coord } deriving (Show, Eq)
 instance Transformable Vertex where
-  t >< (Vertex x y) = Vertex x' y'
+  transform t (Vertex x y) = Vertex x' y'
     where
       (x', y', _) = t >< (x, y, 1) :: Vector3
 
 data Vector = Vector { vectorX :: Coord, vectorY :: Coord } deriving (Show, Eq)
+
 instance Transformable Vector where
-  t >< (Vector x y) = Vector x' y'
+  transform t (Vector x y) = Vector x' y'
     where
       (x', y', _) = t >< (x, y, 0) :: Vector3
 
@@ -35,25 +44,50 @@ instance AdditiveGroup Vector where
 
 instance VectorSpace Vector where
   type Scalar Vector = Coord
-  s *^ Vector x y = Vector (s*x) (s*y)
+  r *^ Vector x y = Vector (r*x) (r*y)
 
 instance InnerSpace Vector where
   Vector x1 y1 <.> Vector x2 y2 = x1*x2 + y1*y2
 
-toAngle :: Vector -> Coord
-toAngle (Vector x y) = atan2 y x
+instance Transform Vector where
+  toMap (Vector dx dy) = linear $ \(x, y, w) -> (x+w*dx, y+w*dy, w)
 
-translateV :: Vector -> Transform
-translateV (Vector x y) = translate x y
+instance ReversibleTransform Vector where
+  toMap' = toMap . negateV
 
-translateV' :: Vector -> Transform
-translateV' = translateV . negateV
+data Rotation = Rotation { rotC :: Coord, rotS :: Coord } deriving (Show, Eq)
 
-rotateV :: Vector -> Transform
-rotateV (Vector c s) = linear $ \(x, y, w) -> (c*x - s*y, s*x + c*y, w)
+instance Transformable Rotation where
+  transform t (Rotation c s) = Rotation (c'/l) (s'/l)
+    where
+      (c', s', _) = t >< (c, s, 0) :: Vector3
+      l = sqrt $ c'^2 + s'^2
 
-rotateV' :: Vector -> Transform
-rotateV' (Vector c s) = rotateV $ Vector c (-s)
+instance AdditiveGroup Rotation where
+  zeroV = Rotation 1 0
+  Rotation c1 s1 ^+^ Rotation c2 s2 = Rotation (c1*c2 - s1*s2) (s1*c2 + c1*s2)
+  negateV (Rotation c s) = Rotation (-c) s
+
+instance Transform Rotation where
+  toMap (Rotation c s) = linear $ \(x, y, w) -> (c*x - s*y, s*x + c*y, w)
+
+instance ReversibleTransform Rotation where
+  toMap' = toMap . negateV
+
+
+toAngle :: Rotation -> Coord
+toAngle (Rotation c s) = atan2 s c
+
+fromAngle :: Coord -> Rotation
+fromAngle a = Rotation (cos a) (sin a)
+
+toVector :: Rotation -> Vector
+toVector (Rotation c s) = Vector c s
+
+fromVector :: Vector -> Rotation
+fromVector v = Rotation x y
+  where
+    Vector x y = normalized v
 
 diffV :: Vertex -> Vertex -> Vector
 diffV (Vertex x1 y1) (Vertex x2 y2) = Vector (x2-x1) (y2-y1)