neocturne/htanks
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added Transformable class to simplify collision calculation

Browse source
This commit is contained in:
Matthias Schiffer 2011-06-24 21:50:32 +02:00
parent d7971385e8
commit 83f0606ea9
13 changed files with 258 additions and 144 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
htanks.cabal
View file

@ -6,14 +6,14 @@ category: Game
license: GPL-3
license-file: LICENSE
author: Matthias Schiffer
maintainer: matthias@gamezock.de
build-depends: base >= 4, syb, containers, mtl, time, X11, OpenGL, hwiid, obj-model, obj-model-opengl
maintainer: mschiffer@universe-factory.net
build-depends: base >= 4, syb, containers, mtl, time, X11, OpenGL, hwiid, obj-model, obj-model-opengl, fixed-point, vector-space, fixed-point-vector-space
build-type: Simple
data-files: tex/*.png model/*.obj
executable: HTanks
hs-source-dirs: src
main-is: HTanks.hs
other-modules: Collision, CPUPlayer, DefaultPlayer, HWiidPlayer, Game, GLDriver, GLX, Level, MainLoop, Paths_htanks, Player, Render, Simulation, Texture, Debris,
Tank, Model, Bindings.GLX, Bindings.GLPng
other-modules: Collision, CPUPlayer, DefaultPlayer, HWiidPlayer, Game, GLDriver, GLX, Level, MainLoop, Paths_htanks, Player, Render, Simulation, Texture, Transformable, Debris,
Tank, Model, Vector, Bindings.GLX, Bindings.GLPng
extra-libraries: glpng

11
src/CPUPlayer.hs
View file

@ -4,17 +4,20 @@ module CPUPlayer ( CPUPlayer(..)
) where
import Data.Fixed
import Data.Ratio ((%))
import Data.Typeable
import Transformable
import Vector
import GLDriver
import Player
data CPUPlayer = CPUPlayer Micro
data CPUPlayer = CPUPlayer Vector
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 angle) _ = return (CPUPlayer (if (angle+0.2) > 180 then angle-359.8 else angle+0.2), Just angle, True, Just (-angle), False)
playerUpdate (CPUPlayer dir) _ = return (CPUPlayer dir', Just dir', True, Just mirrordir, False)
where
dir' = (rotate (0.2*pi/180)) >< dir
mirrordir = Vector (vectorX dir') (-(vectorY dir'))

83
src/Collision.hs
View file

@ -5,68 +5,63 @@ module Collision ( collisionTankBorder
import Tank
import Game
import Transformable
import Data.Fixed
import Data.Ratio
import qualified Vector as V
import Data.VectorSpace
tankWidth :: Micro
tankWidth :: Coord
tankWidth = 0.4
tankLength :: Micro
tankLength :: Coord
tankLength = 0.95
bulletDiameter :: Micro
bulletDiameter :: Coord
bulletDiameter = 0.05
collisionTankBorder :: Micro -> Micro -> Tank -> Tank
collisionTankBorder lw lh tank = tank {tankX = newx, tankY = newy}
where
dir = (fromRational . toRational . tankDir $ tank)*pi/180
cosd = fromRational (round ((cos dir)*1000000)%1000000)
sind = fromRational (round ((sin dir)*1000000)%1000000)
collisionTankBorder :: Coord -> Coord -> Tank -> Tank
collisionTankBorder lw lh tank = (translate dx dy) >< tank
where
corners = [ V.Vector (tankLength/2) (tankWidth/2)
, V.Vector (-tankLength/2) (tankWidth/2)
, V.Vector (-tankLength/2) (-tankWidth/2)
, V.Vector (tankLength/2) (-tankWidth/2)
]
points = [ (tankLength/2, tankWidth/2)
, (-tankLength/2, tankWidth/2)
, (-tankLength/2, -tankWidth/2)
, (tankLength/2, -tankWidth/2)
]
rotp v = V.rotateV (tankDir tank) >< v
transp v = V.translateV v >< tankPos tank
rotp (x, y) = (cosd*x - sind*y, sind*x + cosd*y)
transp (x, y) = (x + tankX tank, y + tankY tank)
points = map (transp . rotp) corners
minx = minimum $ map V.vertexX points
maxx = maximum $ map V.vertexX points
miny = minimum $ map V.vertexY points
maxy = maximum $ map V.vertexY points
pointst = map (transp . rotp) points
minx = minimum $ map fst pointst
maxx = maximum $ map fst pointst
miny = minimum $ map snd pointst
maxy = maximum $ map snd pointst
dx = if minx < 0 then (-minx) else if maxx > lw then (-maxx+lw) else 0
dy = if miny < 0 then (-miny) else if maxy > lh then (-maxy+lh) else 0
newx = (tankX tank) + dx
newy = (tankY tank) + dy
dx = if minx < 0 then (-minx) else if maxx > lw then (-maxx+lw) else 0
dy = if miny < 0 then (-miny) else if maxy > lh then (-maxy+lh) else 0
collisionBulletBullet :: (Bullet, Bullet) -> (Bullet, Bullet) -> Bool
collisionBulletBullet (b1, b1') (b2, b2') = distancesq < (bulletDiameter^2)
where
distancesq = (bulletX b1' - bulletX b2')^2 + (bulletY b1' - bulletY b2')^2
where
distancesq = (bulletX b1' - bulletX b2')^2 + (bulletY b1' - bulletY b2')^2
collisionBulletTank :: (Bullet, Bullet) -> (Tank, Tank) -> Bool
collisionBulletTank (b, b') (tank, tank') = (not ((between bx minx maxx) && (between by miny maxy))) && ((between bx' minx maxx) && (between by' miny maxy))
where
between x a b = x >= a && x <= b
where
between x a b = x >= a && x <= b
dir t = (fromRational . toRational . tankDir $ t)*pi/180
cosd t = fromRational (round ((cos $ dir t)*1000000)%1000000)
sind t = fromRational (round ((sin $ dir t)*1000000)%1000000)
rotp t v = V.rotateV' (tankDir t) >< v
transp t v = V.diffV (tankPos t) v
rotp t (x, y) = ((cosd t)*x + (sind t)*y, -(sind t)*x + (cosd t)*y)
transp t (x, y) = (x - tankX t, y - tankY t)
V.Vector bx by = (rotp tank) . (transp tank) $ bulletPos b
V.Vector bx' by' = (rotp tank') . (transp tank') $ bulletPos b'
(bx, by) = (rotp tank) . (transp tank) $ (bulletX b, bulletY b)
(bx', by') = (rotp tank') . (transp tank') $ (bulletX b', bulletY b')
minx = -tankLength/2
maxx = tankLength/2
miny = -tankWidth/2
maxy = tankWidth/2
collisionTankTank :: ((Tank, Tank), (Tank, Tank)) -> ((Tank, Tank), (Tank, Tank))
collisionTankTank ((t1, t1'), (t2, t2')) = ((t1, t1'), (t2, t2'))
-- where
minx = -tankLength/2
maxx = tankLength/2
miny = -tankWidth/2
maxy = tankWidth/2

15
src/DefaultPlayer.hs
View file

@ -16,8 +16,9 @@ import Graphics.Rendering.OpenGL.GL.VertexSpec
import Tank
import GLDriver
import Player
import Vector
import Transformable (Coord)
import Data.VectorSpace
data DefaultPlayer = DefaultPlayer (S.Set Key) Float Float Bool
deriving (Typeable, Show)
@ -26,12 +27,12 @@ instance Player DefaultPlayer where
playerUpdate (DefaultPlayer keys aimx aimy shoot) tank =
let x = (if (S.member KeyLeft keys) then (-1) else 0) + (if (S.member KeyRight keys) then 1 else 0)
y = (if (S.member KeyDown keys) then (-1) else 0) + (if (S.member KeyUp keys) then 1 else 0)
ax = aimx - (fromRational . toRational . tankX $ tank)
ay = aimy - (fromRational . toRational . tankY $ tank)
ax = realToFrac $ aimx - (fromRational . toRational . tankX $ tank)
ay = realToFrac $ aimy - (fromRational . toRational . tankY $ tank)
move = (x /= 0 || y /= 0)
angle = if move then Just $ fromRational $ round ((atan2 y x)*1000000*180/pi)%1000000 else Nothing
aangle = if (ax /= 0 || ay /= 0) then Just $ fromRational $ round ((atan2 ay ax)*1000000*180/pi)%1000000 else Nothing
in return (DefaultPlayer keys aimx aimy False, angle, move, aangle, shoot)
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
in return (DefaultPlayer keys aimx aimy False, dir, move, adir, shoot)
handleEvent (DefaultPlayer keys aimx aimy shoot) ev
| Just (KeyPressEvent key) <- fromEvent ev = DefaultPlayer (S.insert key keys) aimx aimy shoot

26
src/Game.hs
View file

@ -1,26 +1,36 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Game ( Bullet(..)
, bulletX
, bulletY
, GameState(..)
) where
import Level
import Tank
import Control.Monad
import Control.Monad.State
import Data.Fixed
import Transformable
import Vector
data Bullet = Bullet
{ bulletX :: !Micro
, bulletY :: !Micro
, bulletDir :: !Micro
, bulletSpeed :: !Micro
{ bulletPos :: !Vertex
, bulletDir :: !Vector
, bulletSpeed :: !Coord
, bulletBouncesLeft :: !Int
, bulletTank :: !Int
} deriving (Eq, Show)
bulletX :: Bullet -> Coord
bulletX = vertexX . bulletPos
bulletY :: Bullet -> Coord
bulletY = vertexY . bulletPos
instance Transformable Bullet where
t >< b = b { bulletPos = pos, bulletDir = dir } where
pos = t >< bulletPos b
dir = t >< bulletDir b
data GameState = GameState
{ level :: !Level
, tanks :: ![Tank]

11
src/HTanks.hs
View file

@ -20,6 +20,7 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.Time
import Vector
main :: IO ()
main = do
@ -30,14 +31,14 @@ main = do
when (initialized gl) $ do
currentTime <- getCurrentTime
let gamestate = GameState {level = theLevel, tanks = [ Tank 7.0 4.0 0 0 1.5 270 False 3 1 5 1
, Tank 4.0 4.0 0 0 1.5 270 False 3 1 5 1
, Tank 10.0 4.0 0 0 1.5 270 False 3 1 5 1
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
], bullets = []}
mainstate = MainState {run = True, driver = SomeDriver gl, time = currentTime, players =
[ SomePlayer humanPlayer
, SomePlayer $ CPUPlayer (-90)
, SomePlayer $ CPUPlayer 90
, SomePlayer $ CPUPlayer $ Vector 0 (-1)
, SomePlayer $ CPUPlayer $ Vector 0 1
], textures = M.empty, models = M.empty, gameState = gamestate}
runMain mainstate $ do

12
src/HWiidPlayer.hs
View file

@ -20,6 +20,8 @@ import Graphics.Rendering.OpenGL.GL.VertexSpec
import Player
import Tank
import qualified Transformable as T
import qualified Vector as V
data HWiidPlayer = HWiidPlayer Wiimote WiimoteAccCal [(Float, Float)]
@ -51,15 +53,15 @@ instance Player HWiidPlayer where
then take irSkipSmooth newaims
else newaims
(aimx, aimy) = if null aims then (0, 0) else mulV (1/(fromIntegral $ length aims)) (foldr addV (0, 0) aims)
ax = aimx - (fromRational . toRational . tankX $ tank)
ay = aimy - (fromRational . toRational . tankY $ tank)
aangle = if (ax /= 0 || ay /= 0) then Just $ fromRational $ round ((atan2 ay ax)*1000000*180/pi)%1000000 else Nothing
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
move = (mx /= 0 || my /= 0)
angle = atan2 my mx
moveangle = if move then Just $ fromRational $ round ((angle - (sin $ 8*x)/8)*1000000*180/pi)%1000000 else Nothing
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
when foo $ print state
return (HWiidPlayer wiimote cal aims, moveangle, move, aangle, shoot)
return (HWiidPlayer wiimote cal aims, dir, move, aim, shoot)
renderPlayer (HWiidPlayer _ _ []) = return ()
renderPlayer (HWiidPlayer _ _ aims) = unsafePreservingMatrix $ do

5
src/Player.hs
View file

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

13
src/Render.hs
View file

@ -10,6 +10,7 @@ import Player
import Tank
import Texture
import Model
import qualified Vector as V
import Control.Monad.State
@ -148,11 +149,11 @@ render = do
forM_ tanklist $ \tank -> unsafePreservingMatrix $ do
let x = realToFrac . tankX $ tank
y = realToFrac . tankY $ tank
rotDir = realToFrac . tankDir $ tank
rotAim = realToFrac . tankAim $ tank
rotDir = realToFrac . V.toAngle . tankDir $ tank
rotAim = realToFrac . V.toAngle . tankAim $ tank
translate $ Vector3 x y (0 :: GLfloat)
rotate rotDir $ Vector3 0 0 (1 :: GLfloat)
rotate (rotDir*180/pi) $ Vector3 0 0 (1 :: GLfloat)
textureBinding Texture2D $= Just textureTank
@ -160,7 +161,7 @@ render = do
rotate 90 $ Vector3 1 0 (0 :: GLfloat)
drawObject modelTank 1
rotate (rotAim-rotDir) $ Vector3 0 0 (1 :: GLfloat)
rotate ((rotAim-rotDir)*180/pi) $ Vector3 0 0 (1 :: GLfloat)
textureBinding Texture2D $= Just textureCannon
@ -174,10 +175,10 @@ render = do
forM_ bulletlist $ \bullet -> unsafePreservingMatrix $ do
let x = realToFrac . bulletX $ bullet
y = realToFrac . bulletY $ bullet
rotDir = realToFrac . bulletDir $ bullet
rotDir = realToFrac . V.toAngle . bulletDir $ bullet
translate $ Vector3 x y (0.25 :: GLfloat)
rotate (rotDir-90) $ Vector3 0 0 (1 :: GLfloat)
rotate ((rotDir*180/pi)-90) $ Vector3 0 0 (1 :: GLfloat)
unsafePreservingMatrix $ do
drawObject modelBullet 0

82
src/Simulation.hs
View file

@ -7,31 +7,33 @@ import Level
import MainLoop
import Player
import Tank
import Transformable
import Vector
import Control.Monad.State
import Data.Fixed
import Data.List
import Data.Maybe
import Data.Ratio
import Data.VectorSpace
updateAngle :: Micro -> Tank -> Tank
updateAngle angle tank = tank {tankDir = newangle180}
updateAngle :: Vector -> Tank -> Tank
updateAngle dir tank = tank {tankDir = rotate newangle >< Vector 1 0}
where
oldangle = tankDir tank
oldangle = toAngle . tankDir $ tank
angle = toAngle dir
tspeed = (tankTurnspeed tank)/100
diff = angle - oldangle
diff360 = if (diff > 180)
then (diff-360)
else if (diff <= -180)
then (diff+360)
diff360 = if (diff > pi)
then (diff-2*pi)
else if (diff <= -pi)
then (diff+2*pi)
else diff
(diff180, angle180) = if (diff360 > 90)
then (diff360-180, oldangle+180)
else if (diff360 <= -90)
then (diff360+180, oldangle-180)
(diff180, angle180) = if (diff360 > pi/2)
then (diff360-180, oldangle+pi)
else if (diff360 <= -pi/2)
then (diff360+pi, oldangle-pi)
else (diff360, oldangle)
turn = if (diff180 > tspeed)
@ -42,20 +44,18 @@ updateAngle angle tank = tank {tankDir = newangle180}
newangle = angle180 + turn
newangle180 = if (newangle > 180)
then (newangle-360)
else if (newangle <= -180)
then (newangle+360)
else newangle
approx :: Vector -> Vector -> Bool
approx (Vector x1 y1) (Vector x2 y2) = x1 `approx'` x2 && y1 `approx'` y2
where
approx' a b = (abs (a-b)) < 0.000001
updateTank :: GameState -> Maybe Vector -> Bool -> Maybe Vector -> State Tank ()
updateTank game dir move aim = do
when (isJust dir) $
modify $ updateAngle $ fromJust dir
updateTank :: GameState -> Maybe Micro -> Bool -> Maybe Micro -> State Tank ()
updateTank game angle move aangle = do
when (isJust angle) $
modify $ updateAngle $ fromJust angle
when (isJust aangle) $
modify $ \tank -> tank {tankAim = fromJust aangle}
when (isJust aim) $
modify $ \tank -> tank {tankAim = fromJust aim}
when move $ do
tank <- get
@ -63,12 +63,8 @@ updateTank game angle move aangle = do
tspeed = tankSpeed tank
moved = tankMoving tank
when (isNothing angle || (isJust angle && (tdir == fromJust angle)) || moved) $ do
let anglej = (fromRational . toRational $ tdir)*pi/180
dx = tspeed * fromRational (round ((cos anglej)*1000)%100000)
dy = tspeed * fromRational (round ((sin anglej)*1000)%100000)
put tank {tankX = dx + tankX tank, tankY = dy + tankY tank, tankMoving = True}
when (isNothing dir || (isJust dir && (tdir `approx` fromJust dir) || moved)) $
put $ translateV (tdir ^* (tspeed/100)) >< tank {tankMoving = True}
when (not move) $ do
modify $ \tank -> tank {tankMoving = False}
@ -79,22 +75,17 @@ updateTank game angle move aangle = do
updateBullet :: GameState -> Bullet -> (Bullet, Bool)
updateBullet game bullet = (bullet {bulletX = newx, bulletY = newy, bulletDir = dir3, bulletBouncesLeft = bounces3}, bounces3 >= 0)
updateBullet game bullet = (bullet {bulletPos = Vertex x' y', bulletDir = Vector dx' dy', bulletBouncesLeft = bounces3}, bounces3 >= 0)
where
angle = (fromRational . toRational . bulletDir $ bullet)*pi/180
speed = bulletSpeed bullet
dx = speed * fromRational (round ((cos angle)*1000)%100000)
dy = speed * fromRational (round ((sin angle)*1000)%100000)
x = dx + bulletX bullet
y = dy + bulletY bullet
d@(Vector dx dy) = bulletDir bullet
Vertex x y = translateV (d ^* (speed/100)) >< bulletPos bullet
bounces = bulletBouncesLeft bullet
lw = fromIntegral . levelWidth . level $ game
lh = fromIntegral . levelHeight . level $ game
dir = bulletDir bullet
bounces = bulletBouncesLeft bullet
sg = if dir < 0 then -1 else 1
(newx, dir2, bounces2) = if x < 0 then (-x, sg*180 - dir, bounces-1) else if x > lw then (2*lw-x, sg*180 - dir, bounces-1) else (x, dir, bounces)
(newy, dir3, bounces3) = if y < 0 then (-y, -dir2, bounces2-1) else if y > lh then (2*lh-y, -dir2, bounces2-1) else (y, dir2, bounces2)
(x', dx', bounces2) = if x < 0 then (-x, -dx, bounces-1) else if x > lw then (2*lw-x, -dx, bounces-1) else (x, dx, bounces)
(y', dy', bounces3) = if y < 0 then (-y, -dy, bounces2-1) else if y > lh then (2*lh-y, -dy, bounces2-1) else (y, dy, bounces2)
gameStep :: [(Tank, Bool)] -> GameState -> GameState
gameStep tanksshoot state = state {tanks = thetanks, bullets = newbullets ++ (map snd . filter fst $ leftbullets2)}
@ -104,8 +95,7 @@ gameStep tanksshoot state = state {tanks = thetanks, bullets = newbullets ++ (ma
thetanks = map (\(tank, n) -> tank {tankBulletsLeft = (tankBulletsLeft tank) + (countLostTankBullets n leftbullets2)}) $ zip newtanks2 [0..]
newtanks = map (\(tank, shoot, _) -> if (shoot && (tankBulletsLeft tank) > 0) then tank {tankBulletsLeft = (tankBulletsLeft tank) - 1} else tank) $ ts
newbullets = map (\(tank, n) -> Bullet
{ bulletX = tankX tank
, bulletY = tankY tank
{ bulletPos = tankPos tank
, bulletDir = tankAim tank
, bulletSpeed = tankBulletSpeed tank
, bulletBouncesLeft = tankBulletBounces tank
@ -144,6 +134,6 @@ simulationStep = do
modify $ \state -> state {players = p, gameState = gameStep (zip t s) (gameState state)}
where
updateTank' game (player, tank) = do
(p, angle, move, aangle, shoot) <- playerUpdate player tank
let t = execState (updateTank game angle move aangle) tank
(p, dir, move, aim, shoot) <- playerUpdate player tank
let t = execState (updateTank game dir move aim) tank
return $ if (tankLife tank > 0) then (p, t, shoot) else (player, tank, False)

30
src/Tank.hs
View file

@ -1,18 +1,32 @@
module Tank ( Tank(..)
, tankX
, tankY
) where
import Data.Fixed
import Transformable
import Vector
data Tank = Tank
{ tankX :: !Micro
, tankY :: !Micro
, tankDir :: !Micro
, tankAim :: !Micro
, tankSpeed :: !Micro
, tankTurnspeed :: !Micro
{ tankPos :: !Vertex
, tankDir :: !Vector
, tankAim :: !Vector
, tankSpeed :: !Coord
, tankTurnspeed :: !Coord
, tankMoving :: !Bool
, tankBulletSpeed :: !Micro
, tankBulletSpeed :: !Coord
, tankBulletBounces :: !Int
, tankBulletsLeft :: !Int
, tankLife :: !Int
} deriving (Eq, Show)
tankX :: Tank -> Coord
tankX = vertexX . tankPos
tankY :: Tank -> Coord
tankY = vertexY . tankPos
instance Transformable Tank where
t >< tank = tank { tankPos = pos, tankDir = dir, tankAim = aim } where
pos = t >< tankPos tank
dir = t >< tankDir tank
aim = t >< tankAim tank

37
src/Transformable.hs Normal file
View file

@ -0,0 +1,37 @@
{-# LANGUAGE TypeOperators, TypeSynonymInstances #-}
module Transformable ( Coord
, Vector3
, Transform
, Transformable(..)
, translate
, rotate
, scale
) where
import Data.LinearMap
type Coord = Double
type Vector3 = (Coord, Coord, Coord)
type Transform = Vector3 :-* Vector3
class Transformable a where
(><) :: Transform -> a -> a
instance Transformable Transform where
t1 >< t2 = t1 *.* t2
instance Transformable Vector3 where
t >< v = t `lapply` v
translate :: Coord -> Coord -> Transform
translate dx dy = linear $ \(x, y, w) -> (x + w*dx, y + w*dy, w)
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
scale :: Coord -> Transform
scale s = linear $ \(x, y, w) -> (s*y, s*y, w)

59
src/Vector.hs Normal file
View file

@ -0,0 +1,59 @@
{-# LANGUAGE TypeFamilies #-}
module Vector ( Vertex(..)
, Vector(..)
, toAngle
, translateV
, translateV'
, rotateV
, rotateV'
, diffV
) where
import Transformable
import Data.AdditiveGroup
import Data.VectorSpace
import Data.LinearMap
data Vertex = Vertex { vertexX :: Coord, vertexY :: Coord } deriving (Show, Eq)
instance Transformable Vertex where
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'
where
(x', y', _) = t >< (x, y, 0) :: Vector3
instance AdditiveGroup Vector where
zeroV = Vector 0 0
Vector x1 y1 ^+^ Vector x2 y2 = Vector (x1+x2) (y1+y2)
negateV (Vector x y) = Vector (-x) (-y)
instance VectorSpace Vector where
type Scalar Vector = Coord
s *^ Vector x y = Vector (s*x) (s*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
translateV :: Vector -> Transform
translateV (Vector x y) = translate x y
translateV' :: Vector -> Transform
translateV' = translateV . negateV
rotateV :: Vector -> Transform
rotateV (Vector c s) = linear $ \(x, y, w) -> (c*x - s*y, s*x + c*y, w)
rotateV' :: Vector -> Transform
rotateV' (Vector c s) = rotateV $ Vector c (-s)
diffV :: Vertex -> Vertex -> Vector
diffV (Vertex x1 y1) (Vertex x2 y2) = Vector (x2-x1) (y2-y1)