From cc53496bab9ad2bbfc3fb2868cd10fa46f612e69 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Sun, 26 Jun 2011 20:55:51 +0200 Subject: Reworked Transform as a type class --- src/CPUPlayer.hs | 7 +++--- src/Collision.hs | 17 +++++++------ src/DefaultPlayer.hs | 4 +-- src/Game.hs | 5 ++-- src/HTanks.hs | 13 +++++----- src/HWiidPlayer.hs | 4 +-- src/Player.hs | 3 +-- src/Simulation.hs | 20 ++++++++------- src/Tank.hs | 7 +++--- src/Transformable.hs | 40 +++++++++++++++++------------- src/Vector.hs | 70 ++++++++++++++++++++++++++++++++++++++-------------- 11 files changed, 115 insertions(+), 75 deletions(-) diff --git a/src/CPUPlayer.hs b/src/CPUPlayer.hs index 55722bf..ced2220 100644 --- a/src/CPUPlayer.hs +++ b/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 - mirrordir = Vector (vectorX dir') (-(vectorY dir')) + dir' = (fromAngle (0.2*pi/180)) >< dir diff --git a/src/Collision.hs b/src/Collision.hs index 6ce2df7..19e6ef5 100644 --- a/src/Collision.hs +++ b/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 - transp v = V.translateV v >< tankPos tank + rotp v = tankDir tank >< v + 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 ((t1, t1'), (t2, t2')) = ((t1, t1'), (t2, t2')) --- where - \ No newline at end of file +collisionTankTank :: ((Tank, Tank), (Tank, Tank)) -> (Tank, Tank) +collisionTankTank ((t1, t1'), (t2, t2')) = (t1'', t2'') + where + t1'' = t1' + t2'' = t2' diff --git a/src/DefaultPlayer.hs b/src/DefaultPlayer.hs index 00dce95..4ac6bac 100644 --- a/src/DefaultPlayer.hs +++ b/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 - adir = if (ax /= 0 || ay /= 0) then Just (normalized $ Vector ax ay) else Nothing + dir = if move then Just (fromVector $ Vector x y) 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 diff --git a/src/Game.hs b/src/Game.hs index 16b04d8..c97b5de 100644 --- a/src/Game.hs +++ b/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 diff --git a/src/HTanks.hs b/src/HTanks.hs index 0974ffd..dd60903 100644 --- a/src/HTanks.hs +++ 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 - , Tank (Vertex 4.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) (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) zeroV zeroV 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 $ Vector 0 1 + , SomePlayer $ CPUPlayer $ fromAngle $ -pi/2 + , SomePlayer $ CPUPlayer $ fromAngle $ pi/2 ], textures = M.empty, models = M.empty, gameState = gamestate} runMain mainstate $ do diff --git a/src/HWiidPlayer.hs b/src/HWiidPlayer.hs index d98b9c9..9517394 100644 --- a/src/HWiidPlayer.hs +++ b/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) diff --git a/src/Player.hs b/src/Player.hs index 67d9f78..9239443 100644 --- a/src/Player.hs +++ b/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 diff --git a/src/Simulation.hs b/src/Simulation.hs index 3cf4fec..ca335f2 100644 --- a/src/Simulation.hs +++ b/src/Simulation.hs @@ -16,8 +16,8 @@ import Data.Maybe import Data.VectorSpace -updateAngle :: Vector -> Tank -> Tank -updateAngle dir tank = tank {tankDir = rotate newangle >< Vector 1 0} +updateAngle :: Rotation -> Tank -> Tank +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 (Vector x1 y1) (Vector x2 y2) = x1 `approx'` x2 && y1 `approx'` y2 +approx :: Rotation -> Rotation -> Bool +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 - Vertex x y = translateV (d ^* (speed/100)) >< bulletPos bullet + d@(Vector dx dy) = toVector $ bulletDir bullet + Vertex x y = (d ^* (speed/100)) >< bulletPos bullet bounces = bulletBouncesLeft bullet lw = fromIntegral . levelWidth . level $ game lh = fromIntegral . levelHeight . level $ game diff --git a/src/Tank.hs b/src/Tank.hs index f3230f2..a595618 100644 --- a/src/Tank.hs +++ b/src/Tank.hs @@ -3,13 +3,12 @@ module Tank ( Tank(..) , tankY ) where -import Transformable import Vector data Tank = Tank { tankPos :: !Vertex - , tankDir :: !Vector - , tankAim :: !Vector + , tankDir :: !Rotation + , 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 \ No newline at end of file diff --git a/src/Transformable.hs b/src/Transformable.hs index 2fd64fe..335b477 100644 --- a/src/Transformable.hs +++ b/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 - t1 >< t2 = t1 *.* t2 +class Transform a where + toMap :: a -> TransformMap + +class Transform a => ReversibleTransform a where + toMap' :: a -> TransformMap instance Transformable Vector3 where - t >< v = t `lapply` v + transform = lapply + +instance Transform TransformMap where + toMap = id + +instance Transformable TransformMap where + transform = (*.*) -translate :: Coord -> Coord -> Transform -translate dx dy = linear $ \(x, y, w) -> (x + w*dx, y + w*dy, w) +(><) :: (Transform t, Transformable a) => t -> a -> a +t >< a = transform (toMap t) a -rotate :: Coord -> Transform -rotate a = linear $ \(x, y, w) -> (c*x - s*y, s*x + c*y, w) where - c = cos a - s = sin 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) diff --git a/src/Vector.hs b/src/Vector.hs index 847be58..174afd3 100644 --- a/src/Vector.hs +++ b/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) + +instance ReversibleTransform Vector where + toMap' = toMap . negateV + +data Rotation = Rotation { rotC :: Coord, rotS :: Coord } deriving (Show, Eq) + +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 + +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 + -translateV :: Vector -> Transform -translateV (Vector x y) = translate x y +toAngle :: Rotation -> Coord +toAngle (Rotation c s) = atan2 s c -translateV' :: Vector -> Transform -translateV' = translateV . negateV +fromAngle :: Coord -> Rotation +fromAngle a = Rotation (cos a) (sin a) -rotateV :: Vector -> Transform -rotateV (Vector c s) = linear $ \(x, y, w) -> (c*x - s*y, s*x + c*y, w) +toVector :: Rotation -> Vector +toVector (Rotation c s) = Vector c s -rotateV' :: Vector -> Transform -rotateV' (Vector c s) = rotateV $ 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) -- cgit v1.2.3