Reworked Transform as a type class

src/CPUPlayer.hs

@@ -12,12 +12,11 @@ import GLDriver
 import Player
 
 
-data CPUPlayer = CPUPlayer Vector
+data CPUPlayer = CPUPlayer Rotation
                  deriving (Typeable, Show)
 
 instance Player CPUPlayer where
 --    playerUpdate (CPUPlayer angle) _ = return (CPUPlayer (if (angle+0.2) > 180 then angle-359.8 else angle+0.2), Just angle, True, Just (-angle), ((fromIntegral . round $ angle) == angle) && ((round $ angle) `mod` 2 == 0))
-    playerUpdate (CPUPlayer dir) _ = return (CPUPlayer dir', Just dir', True, Just mirrordir, False)
+    playerUpdate (CPUPlayer dir) _ = return (CPUPlayer dir', Just dir', True, Just $ negateV dir', False)
       where
-        dir' = (rotate (0.2*pi/180)) >< dir
+        dir' = (fromAngle (0.2*pi/180)) >< dir
-        mirrordir = Vector (vectorX dir') (-(vectorY dir'))

src/Collision.hs

@@ -20,7 +20,7 @@ bulletDiameter :: Coord
 bulletDiameter = 0.05
 
 collisionTankBorder :: Coord -> Coord -> Tank -> Tank
-collisionTankBorder lw lh tank = (translate dx dy) >< tank
+collisionTankBorder lw lh tank = V.Vector dx dy >< tank
   where
     corners = [ V.Vector (tankLength/2) (tankWidth/2)
               , V.Vector (-tankLength/2) (tankWidth/2)
@@ -28,8 +28,8 @@ collisionTankBorder lw lh tank = (translate dx dy) >< tank
               , V.Vector (tankLength/2) (-tankWidth/2)
               ]
     
-    rotp v = V.rotateV (tankDir tank) >< v
+    rotp v = tankDir tank >< v
-    transp v = V.translateV v >< tankPos tank
+    transp v = v >< tankPos tank
     
     points = map (transp . rotp) corners
     minx = minimum $ map V.vertexX points
@@ -50,7 +50,7 @@ collisionBulletTank (b, b') (tank, tank') = (not ((between bx minx maxx) && (bet
   where
     between x a b = x >= a && x <= b
           
-    rotp t v = V.rotateV' (tankDir t) >< v
+    rotp t v = tankDir t >:< v
     transp t v = V.diffV (tankPos t) v
       
     V.Vector bx by = (rotp tank) . (transp tank) $ bulletPos b
@@ -61,7 +61,8 @@ collisionBulletTank (b, b') (tank, tank') = (not ((between bx minx maxx) && (bet
     miny = -(tankWidth+bulletDiameter)/2
     maxy = (tankWidth+bulletDiameter)/2
 
-collisionTankTank :: ((Tank, Tank), (Tank, Tank)) -> ((Tank, Tank), (Tank, Tank))
+collisionTankTank :: ((Tank, Tank), (Tank, Tank)) -> (Tank, Tank)
-collisionTankTank ((t1, t1'), (t2, t2')) = ((t1, t1'), (t2, t2'))
+collisionTankTank ((t1, t1'), (t2, t2')) = (t1'', t2'')
---  where
+  where
-    
+    t1'' = t1'
+    t2'' = t2'

src/DefaultPlayer.hs

@@ -30,8 +30,8 @@ instance Player DefaultPlayer where
             ax = realToFrac $ aimx - (fromRational . toRational . tankX $ tank)
             ay = realToFrac $ aimy - (fromRational . toRational . tankY $ tank)
             move = (x /= 0 || y /= 0)
-            dir = if move then Just (normalized $ Vector x y) else Nothing
+            dir = if move then Just (fromVector $ Vector x y) else Nothing
-            adir = if (ax /= 0 || ay /= 0) then Just (normalized $ Vector ax ay) else Nothing
+            adir = if (ax /= 0 || ay /= 0) then Just (fromVector $ Vector ax ay) else Nothing
         in return (DefaultPlayer keys aimx aimy False, dir, move, adir, shoot)
     
     handleEvent (DefaultPlayer keys aimx aimy shoot) ev

src/Game.hs

@@ -8,13 +8,12 @@ module Game ( Bullet(..)
 
 import Level
 import Tank
-import Transformable
 import Vector
 
 
 data Bullet = Bullet
     { bulletPos    :: !Vertex
-    , bulletDir    :: !Vector
+    , bulletDir    :: !Rotation
     , bulletSpeed  :: !Coord
     , bulletBouncesLeft :: !Int
     , bulletTank   :: !Int
@@ -27,7 +26,7 @@ bulletY :: Bullet -> Coord
 bulletY = vertexY . bulletPos
 
 instance Transformable Bullet where
-  t >< b = b { bulletPos = pos, bulletDir = dir } where
+  transform t b = b { bulletPos = pos, bulletDir = dir } where
     pos = t >< bulletPos b
     dir = t >< bulletDir b
 

src/HTanks.hs

@@ -10,6 +10,8 @@ import DefaultPlayer
 import HWiidPlayer
 import Simulation
 import Tank
+import Vector
+
 
 import GLDriver
 import GLX
@@ -20,7 +22,6 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Time
 
-import Vector
 
 main :: IO ()
 main = do
@@ -31,14 +32,14 @@ main = do
   
   when (initialized gl) $ do
          currentTime <- getCurrentTime
-         let gamestate = GameState {level = theLevel, tanks = [ Tank (Vertex 7.0 4.0) (Vector 1 0) (Vector 1 0) 1.5 (270*pi/180) False 3 1 5 1
+         let gamestate = GameState {level = theLevel, tanks = [ Tank (Vertex 7.0 4.0) zeroV zeroV 1.5 (270*pi/180) False 3 1 5 1
-                                                              , Tank (Vertex 4.0 4.0) (Vector 1 0) (Vector 1 0) 1.5 (270*pi/180) False 3 1 5 1
+                                                              , Tank (Vertex 4.0 4.0) zeroV zeroV 1.5 (270*pi/180) False 3 1 5 1
-                                                              , Tank (Vertex 10.0 4.0) (Vector 1 0) (Vector 1 0) 1.5 (270*pi/180) False 3 1 5 1
+                                                              , Tank (Vertex 10.0 4.0) zeroV zeroV 1.5 (270*pi/180) False 3 1 5 1
                                                               ], bullets = []}
              mainstate = MainState {run = True, driver = SomeDriver gl, time = currentTime, players =
                                           [ SomePlayer humanPlayer
-                                          , SomePlayer $ CPUPlayer $ Vector 0 (-1)
+                                          , SomePlayer $ CPUPlayer $ fromAngle $ -pi/2
-                                          , SomePlayer $ CPUPlayer $ Vector 0 1
+                                          , SomePlayer $ CPUPlayer $ fromAngle $ pi/2
                                           ], textures = M.empty, models = M.empty, gameState = gamestate}
              
          runMain mainstate $ do

src/HWiidPlayer.hs

@@ -55,11 +55,11 @@ instance Player HWiidPlayer where
                                     (aimx, aimy) = if null aims then (0, 0) else mulV (1/(fromIntegral $ length aims)) (foldr addV (0, 0) aims)
                                     ax = realToFrac $ aimx - (fromRational . toRational . tankX $ tank)
                                     ay = realToFrac $ aimy - (fromRational . toRational . tankY $ tank)
-                                    aim = if (ax /= 0 || ay /= 0) then Just $ V.Vector ax ay else Nothing
+                                    aim = if (ax /= 0 || ay /= 0) then Just . V.fromVector $ V.Vector ax ay else Nothing
                                                  
                                     move = (mx /= 0 || my /= 0)
                                     angle = atan2 my mx
-                                    dir = if move then Just $ T.rotate (fromRational $ round ((angle - (sin $ 8*x)/8)*1000000*180/pi)%1000000) T.>< V.Vector 1 0 else Nothing
+                                    dir = if move then Just $ V.fromAngle (fromRational $ round ((angle - (sin $ 8*x)/8)*1000000)%1000000) else Nothing
                                 when foo $ print state
                                 return (HWiidPlayer wiimote cal aims, dir, move, aim, shoot)
     

src/Player.hs

@@ -4,7 +4,6 @@ module Player ( Player(..)
               , SomePlayer(..)
               ) where
 
-import Transformable
 import Vector
 import Data.Typeable
 
@@ -13,7 +12,7 @@ import GLDriver (SomeEvent)
 
 
 class Player a where
-    playerUpdate :: a -> Tank -> IO (a, Maybe Vector, Bool, Maybe Vector, Bool)
+    playerUpdate :: a -> Tank -> IO (a, Maybe Rotation, Bool, Maybe Rotation, Bool)
     
     handleEvent :: a -> SomeEvent -> a
     handleEvent player _ = player

src/Simulation.hs

@@ -16,8 +16,8 @@ import Data.Maybe
 import Data.VectorSpace
 
 
-updateAngle :: Vector -> Tank -> Tank
+updateAngle :: Rotation -> Tank -> Tank
-updateAngle dir tank = tank {tankDir = rotate newangle >< Vector 1 0}
+updateAngle dir tank = tank { tankDir = fromAngle newangle }
     where
       oldangle = toAngle . tankDir $ tank
       angle = toAngle dir
@@ -44,12 +44,14 @@ updateAngle dir tank = tank {tankDir = rotate newangle >< Vector 1 0}
   
       newangle = angle180 + turn
 
-approx :: Vector -> Vector -> Bool
+approx :: Rotation -> Rotation -> Bool
-approx (Vector x1 y1) (Vector x2 y2) = x1 `approx'` x2 && y1 `approx'` y2
+approx r1 r2 = c1 `approx'` c2 && s1 `approx'` s2
   where
     approx' a b = (abs (a-b)) < 0.000001
+    Vector c1 s1 = toVector r1
+    Vector c2 s2 = toVector r2
 
-updateTank :: GameState -> Maybe Vector -> Bool -> Maybe Vector -> State Tank ()
+updateTank :: GameState -> Maybe Rotation -> Bool -> Maybe Rotation -> State Tank ()
 updateTank game dir move aim = do
   when (isJust dir) $
        modify $ updateAngle $ fromJust dir
@@ -64,7 +66,7 @@ updateTank game dir move aim = do
         moved = tankMoving tank
     
     when (isNothing dir || (isJust dir && (tdir `approx` fromJust dir) || moved)) $
-             put $ translateV (tdir ^* (tspeed/100)) >< tank {tankMoving = True}
+             put $ ((toVector tdir) ^* (tspeed/100)) >< tank {tankMoving = True}
   
   when (not move) $ do
                    modify $ \tank -> tank {tankMoving = False}
@@ -75,11 +77,11 @@ updateTank game dir move aim = do
 
 
 updateBullet :: GameState -> Bullet -> (Bullet, Bool)
-updateBullet game bullet = (bullet {bulletPos = Vertex x' y', bulletDir = Vector dx' dy', bulletBouncesLeft = bounces3}, bounces3 >= 0)
+updateBullet game bullet = (bullet {bulletPos = Vertex x' y', bulletDir = fromVector $ Vector dx' dy', bulletBouncesLeft = bounces3}, bounces3 >= 0)
     where
       speed = bulletSpeed bullet
-      d@(Vector dx dy) = bulletDir bullet
+      d@(Vector dx dy) = toVector $ bulletDir bullet
-      Vertex x y = translateV (d ^* (speed/100)) >< bulletPos bullet
+      Vertex x y = (d ^* (speed/100)) >< bulletPos bullet
       bounces = bulletBouncesLeft bullet
       lw = fromIntegral . levelWidth . level $ game
       lh = fromIntegral . levelHeight . level $ game

src/Tank.hs

@@ -3,13 +3,12 @@ module Tank ( Tank(..)
             , tankY
             ) where
 
-import Transformable
 import Vector
 
 data Tank = Tank
           { tankPos           :: !Vertex
-          , tankDir           :: !Vector
+          , tankDir           :: !Rotation
-          , tankAim           :: !Vector
+          , tankAim           :: !Rotation
           , tankSpeed         :: !Coord
           , tankTurnspeed     :: !Coord
           , tankMoving        :: !Bool
@@ -26,7 +25,7 @@ tankY :: Tank -> Coord
 tankY = vertexY . tankPos
 
 instance Transformable Tank where
-  t >< tank = tank { tankPos = pos, tankDir = dir, tankAim = aim } where
+  transform t tank = tank { tankPos = pos , tankDir = dir, tankAim = aim } where
     pos = t >< tankPos tank
     dir = t >< tankDir tank
     aim = t >< tankAim tank

src/Transformable.hs

@@ -2,11 +2,12 @@
 
 module Transformable ( Coord
                      , Vector3
-                     , Transform
+                     , TransformMap
+                     , Transform(..)
+                     , ReversibleTransform(..)
                      , Transformable(..)
-                     , translate
+                     , (><)
-                     , rotate
+                     , (>:<)
-                     , scale
                      ) where
 
 import Data.LinearMap
@@ -14,24 +15,29 @@ import Data.LinearMap
 type Coord = Double
 
 type Vector3 = (Coord, Coord, Coord)
-type Transform = Vector3 :-* Vector3
+type TransformMap = Vector3 :-* Vector3
 
 class Transformable a where
-  (><) :: Transform -> a -> a
+  transform :: TransformMap -> a -> a
 
-instance Transformable Transform where
+class Transform a where
-  t1 >< t2 = t1 *.* t2
+  toMap :: a -> TransformMap
+
+class Transform a => ReversibleTransform a where
+  toMap' :: a -> TransformMap
 
 instance Transformable Vector3 where
-  t >< v = t `lapply` v
+  transform = lapply
 
-translate :: Coord -> Coord -> Transform
+instance Transform TransformMap where
-translate dx dy = linear $ \(x, y, w) -> (x + w*dx, y + w*dy, w)
+  toMap = id
 
-rotate :: Coord -> Transform
+instance Transformable TransformMap where
-rotate a = linear $ \(x, y, w) -> (c*x - s*y, s*x + c*y, w) where
+  transform = (*.*)
-  c = cos a
+
-  s = sin a
+(><) :: (Transform t, Transformable a) => t -> a -> a
+t >< a = transform (toMap t) a
+
+(>:<) :: (ReversibleTransform t, Transformable a) => t -> a -> a
+t >:< a = transform (toMap' t) a
 
-scale :: Coord -> Transform
-scale s = linear $ \(x, y, w) -> (s*y, s*y, w)

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
+              , fromAngle
-              , translateV'
+              , toVector
-              , rotateV
+              , fromVector
-              , rotateV'
               , 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
+instance Transform Vector where
-toAngle (Vector x y) = atan2 y x
+  toMap (Vector dx dy) = linear $ \(x, y, w) -> (x+w*dx, y+w*dy, w)
 
-translateV :: Vector -> Transform
+instance ReversibleTransform Vector where
-translateV (Vector x y) = translate x y
+  toMap' = toMap . negateV
 
-translateV' :: Vector -> Transform
+data Rotation = Rotation { rotC :: Coord, rotS :: Coord } deriving (Show, Eq)
-translateV' = translateV . negateV
 
-rotateV :: Vector -> Transform
+instance Transformable Rotation where
-rotateV (Vector c s) = linear $ \(x, y, w) -> (c*x - s*y, s*x + c*y, w)
+  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
+instance AdditiveGroup Rotation where
-rotateV' (Vector c s) = rotateV $ Vector c (-s)
+  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)