Reworked Transform as a type class
This commit is contained in:
parent
8f1fd98cd6
commit
cc53496bab
11 changed files with 115 additions and 75 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
collisionTankTank :: ((Tank, Tank), (Tank, Tank)) -> (Tank, Tank)
|
||||
collisionTankTank ((t1, t1'), (t2, t2')) = (t1'', t2'')
|
||||
where
|
||||
t1'' = t1'
|
||||
t2'' = t2'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
translate :: Coord -> Coord -> Transform
|
||||
translate dx dy = linear $ \(x, y, w) -> (x + w*dx, y + w*dy, w)
|
||||
instance Transform TransformMap where
|
||||
toMap = id
|
||||
|
||||
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
|
||||
instance Transformable TransformMap where
|
||||
transform = (*.*)
|
||||
|
||||
(><) :: (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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Reference in a new issue