justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Further strictifying

Browse Source
This commit is contained in:
justin
2021-07-30 00:23:02 +02:00
parent bd8ef3f416
commit 2d8b27746c
33 changed files with 228 additions and 211 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+14 -14
View File
@@ -404,8 +404,8 @@ nearestCrInTri p dir x w
where where
tri = tri =
[p [p
,p +.+ rotateV (dir-pi/4) (x,0) ,p +.+ rotateV (dir-pi/4) (V2 x 0)
,p +.+ rotateV (dir+pi/4) (x,0) ,p +.+ rotateV (dir+pi/4) (V2 x 0)
] ]
{- | Find 'Maybe' the closes creature in front of a point in a given direction for {- | Find 'Maybe' the closes creature in front of a point in a given direction for
a given distance. a given distance.
@@ -420,13 +420,15 @@ nearestCrInFront p dir x w
$ IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w $ IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
where where
rec = [p, pR, pR1, pL1, pL ] rec = [p, pR, pR1, pL1, pL ]
pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0) pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) (0))
pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0) pL = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) (0))
pR1 = pR +.+ rotateV dir (x/2,0) pR1 = pR +.+ rotateV dir (V2 (x/2) (0))
pL1 = pL +.+ rotateV dir (x/2,0) pL1 = pL +.+ rotateV dir (V2 (x/2) (0))
{- | Test whether a creature is in a polygon. -} {- | Test whether a creature is in a polygon. -}
crInPolygon :: Creature -> [Point2] -> Bool crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr = errorPointInPolygon 3 (_crPos cr) crInPolygon cr = errorPointInPolygon 3 (_crPos cr)
--The following two functions should be unified
{- | Transform coordinates from world position to normalised screen coordinates. -} {- | Transform coordinates from world position to normalised screen coordinates. -}
worldPosToScreen :: World -> Point2 -> Point2 worldPosToScreen :: World -> Point2 -> Point2
worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
@@ -434,10 +436,9 @@ worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
doTranslate p = p -.- _cameraCenter w doTranslate p = p -.- _cameraCenter w
doZoom p = _cameraZoom w *.* p doZoom p = _cameraZoom w *.* p
doRotate p = rotateV (negate $ _cameraRot w) p doRotate p = rotateV (negate $ _cameraRot w) p
doWindowScale (x,y) = doWindowScale (V2 x y) = V2
( x * 2 / getWindowX w ( x * 2 / getWindowX w)
, y * 2 / getWindowY w ( y * 2 / getWindowY w)
)
{- | Transform coordinates from the map position to normalised screen {- | Transform coordinates from the map position to normalised screen
coordinates. -} coordinates. -}
cartePosToScreen :: World -> Point2 -> Point2 cartePosToScreen :: World -> Point2 -> Point2
@@ -446,10 +447,9 @@ cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
doTranslate p = p -.- _carteCenter w doTranslate p = p -.- _carteCenter w
doZoom p = _carteZoom w *.* p doZoom p = _carteZoom w *.* p
doRotate p = rotateV (negate $ _carteRot w) p doRotate p = rotateV (negate $ _carteRot w) p
doWindowScale (x,y) = doWindowScale (V2 x y) = V2
( x * 2 / getWindowX w ( x * 2 / getWindowX w)
, y * 2 / getWindowY w ( y * 2 / getWindowY w)
)
{- | The mouse position in world coordinates. -} {- | The mouse position in world coordinates. -}
mouseWorldPos :: World -> Point2 mouseWorldPos :: World -> Point2
mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
src/Dodge/Base/Collide.hs
+3 -3
View File
@@ -141,14 +141,14 @@ pathToPointFireable i p w
canSeePointAll :: Int -> Point2 -> World -> Bool canSeePointAll :: Int -> Point2 -> World -> Bool
canSeePointAll i targPos w canSeePointAll i targPos w
= all (flip (canSeePoint i) w . (\p -> targPos +.+ radius *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] = all (flip (canSeePoint i) w . (\p -> targPos +.+ radius *.* p)) $ map toV2 [(1,0),(0,1),(-1,0),(0,-1)]
where where
cr = _creatures w IM.! i cr = _creatures w IM.! i
radius = _crRad cr radius = _crRad cr
canSeeAny :: Int -> Int -> World -> Bool canSeeAny :: Int -> Int -> World -> Bool
canSeeAny fromID toID w canSeeAny fromID toID w
= any (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] = any (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) $ map toV2 [(1,0),(0,1),(-1,0),(0,-1)]
where where
cr = _creatures w IM.! toID cr = _creatures w IM.! toID
cpos = _crPos cr cpos = _crPos cr
@@ -156,7 +156,7 @@ canSeeAny fromID toID w
canSeeAll :: Int -> Int -> World -> Bool canSeeAll :: Int -> Int -> World -> Bool
canSeeAll fromID toID w canSeeAll fromID toID w
= all (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] = all (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) $ map toV2 [(1,0),(0,1),(-1,0),(0,-1)]
where where
cr = _creatures w IM.! toID cr = _creatures w IM.! toID
cpos = _crPos cr cpos = _crPos cr
src/Dodge/Base/Window.hs
+4 -4
View File
@@ -12,10 +12,10 @@ screenPolygon w = [tr,tl,bl,br]
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
| otherwise = p | otherwise = p
scTran p = p +.+ _cameraCenter w scTran p = p +.+ _cameraCenter w
tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w) tr = scTran $ scRot $ scZoom (V2 ( halfWidth w) ( halfHeight w))
tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w) tl = scTran $ scRot $ scZoom (V2 (-halfWidth w) ( halfHeight w))
br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w) br = scTran $ scRot $ scZoom (V2 ( halfWidth w) (-halfHeight w))
bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w) bl = scTran $ scRot $ scZoom (V2 (-halfWidth w) (-halfHeight w))
halfWidth,halfHeight :: World -> Float halfWidth,halfHeight :: World -> Float
halfWidth w = getWindowX w / 2 halfWidth w = getWindowX w / 2
src/Dodge/Base/Zone.hs
+8 -8
View File
@@ -19,12 +19,12 @@ floorHun :: Float -> Int
floorHun x = floor $ x / zoneSize floorHun x = floor $ x / zoneSize
sizeZoneOfPoint :: Float -> Point2 -> (Int,Int) sizeZoneOfPoint :: Float -> Point2 -> (Int,Int)
sizeZoneOfPoint s (x,y) = (f x, f y) sizeZoneOfPoint s (V2 x y) = (f x, f y)
where where
f = floor . (/ s) f = floor . (/ s)
zoneOfPoint :: Point2 -> (Int,Int) zoneOfPoint :: Point2 -> (Int,Int)
zoneOfPoint (x,y) = (floorHun x, floorHun y) zoneOfPoint (V2 x y) = (floorHun x, floorHun y)
cloudZoneOfPoint :: Point2 -> (Int,Int) cloudZoneOfPoint :: Point2 -> (Int,Int)
cloudZoneOfPoint = sizeZoneOfPoint 20 cloudZoneOfPoint = sizeZoneOfPoint 20
@@ -33,19 +33,19 @@ crZoneOfPoint :: Point2 -> (Int,Int)
crZoneOfPoint = sizeZoneOfPoint 15 crZoneOfPoint = sizeZoneOfPoint 15
zoneNearPoint :: Point2 -> [(Int,Int)] zoneNearPoint :: Point2 -> [(Int,Int)]
zoneNearPoint (x',y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] zoneNearPoint (V2 x' y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where where
x = floorHun x' x = floorHun x'
y = floorHun y' y = floorHun y'
zoneAroundPoint :: Point2 -> [(Int,Int)] zoneAroundPoint :: Point2 -> [(Int,Int)]
zoneAroundPoint (x',y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]] zoneAroundPoint (V2 x' y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
where where
x = floorHun x' x = floorHun x'
y = floorHun y' y = floorHun y'
zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet
zoneAroundPoint' i (x',y') = IM.fromSet (const ys) xs zoneAroundPoint' i (V2 x' y') = IM.fromSet (const ys) xs
where where
x = floorHun x' x = floorHun x'
y = floorHun y' y = floorHun y'
@@ -65,10 +65,10 @@ bresx a b = digitalLine (x-1,y-1) (x'-1,y'-1)
(x',y') = zoneOfPoint b (x',y') = zoneOfPoint b
zoneOfLine :: Point2 -> Point2 -> [(Int,Int)] zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
zoneOfLine (aa,ab) (ba,bb) zoneOfLine (V2 aa ab) (V2 ba bb)
= nub = nub
. concatMap f . concatMap f
$ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb)) $ digitalLine (zoneOfPoint (V2 aa ab)) (zoneOfPoint (V2 ba bb))
where where
f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]] f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
@@ -154,7 +154,7 @@ wallsNearZones is w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
_ -> IM.empty _ -> IM.empty
ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a
ixZone z (x,y) = z IM.! floorHun x IM.! floorHun y ixZone z (V2 x y) = z IM.! floorHun x IM.! floorHun y
ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a] ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a]
ixNZ z p = lookLookups (zoneNearPoint p) z ixNZ z p = lookLookups (zoneNearPoint p) z
src/Dodge/Creature/Action/Movement.hs
+5 -5
View File
@@ -51,7 +51,7 @@ crMvForward
:: Float -- ^ Speed :: Float -- ^ Speed
-> Creature -> Creature
-> Creature -> Creature
crMvForward speed = crMvBy (speed,0) crMvForward speed = crMvBy (V2 speed 0)
advanceStepCounter advanceStepCounter
:: Float -- ^ Speed :: Float -- ^ Speed
@@ -70,7 +70,7 @@ creatureTurn a = crDir +~ a
creatureTurnTo :: Point2 -> Creature -> Creature creatureTurnTo :: Point2 -> Creature -> Creature
creatureTurnTo p cr creatureTurnTo p cr
| vToTarg == (0,0) = cr -- this should deal with the angleVV error | vToTarg == (V2 0 0) = cr -- this should deal with the angleVV error
| otherwise = cr & crDir .~ dirToTarget | otherwise = cr & crDir .~ dirToTarget
where where
vToTarg = p -.- _crPos cr vToTarg = p -.- _crPos cr
@@ -82,18 +82,18 @@ creatureTurnTowardDir
-> Creature -> Creature
-> Creature -> Creature
creatureTurnTowardDir a turnSpeed cr creatureTurnTowardDir a turnSpeed cr
| vToTarg == (0,0) = cr -- this should deal with the angleVV error | vToTarg == (V2 0 0) = cr -- this should deal with the angleVV error
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
= cr & crDir .~ dirToTarget = cr & crDir .~ dirToTarget
| isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
| otherwise = cr & crDir -~ turnSpeed | otherwise = cr & crDir -~ turnSpeed
where where
vToTarg = rotateV a (1,0) vToTarg = rotateV a (V2 1 0)
dirToTarget = argV vToTarg dirToTarget = argV vToTarg
creatureTurnToward :: Point2 -> Float -> Creature -> Creature creatureTurnToward :: Point2 -> Float -> Creature -> Creature
creatureTurnToward p turnSpeed cr creatureTurnToward p turnSpeed cr
| vToTarg == (0,0) = cr -- this should deal with the angleVV error | vToTarg == (V2 0 0) = cr -- this should deal with the angleVV error
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
= cr & crDir .~ dirToTarget = cr & crDir .~ dirToTarget
| isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
src/Dodge/Creature/Picture.hs
+6 -6
View File
@@ -33,7 +33,7 @@ basicCrPict col cr w
targetingPic ++ targetingPic ++
[ tr . setDepth 0 $ color yellow $ circleSolid 10 [ tr . setDepth 0 $ color yellow $ circleSolid 10
, tr . piercingMod $ bluntScale $ naked col cr , tr . piercingMod $ bluntScale $ naked col cr
, tr $ torso (light4 col) (0,-crad) (0,crad) , tr $ torso (light4 col) (V2 (0) (-crad)) (V2 0 crad)
, trFeet $ feet cr , trFeet $ feet cr
, tr $ arms col cr , tr $ arms col cr
, tr $ drawEquipment cr , tr $ drawEquipment cr
@@ -42,8 +42,8 @@ basicCrPict col cr w
crad = _crRad cr crad = _crRad cr
targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just) f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
tr = uncurry translate (_crPos cr) . rotate (_crDir cr) tr = uncurryV translate (_crPos cr) . rotate (_crDir cr)
trFeet = uncurry translate (_crPos cr) . rotate (_crMvDir cr) trFeet = uncurryV translate (_crPos cr) . rotate (_crMvDir cr)
cdir = _crDir cr cdir = _crDir cr
bluntDam :: Maybe Point2 bluntDam :: Maybe Point2
bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo) bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
@@ -104,7 +104,7 @@ arms col cr
torso :: Color -> Point2 -> Point2 -> Picture torso :: Color -> Point2 -> Point2 -> Picture
torso col x y = color col $ pictures torso col x y = color col $ pictures
[ poly3 [addZ 20 x, addZ 12 v, addZ 12 ((0,0) -.- v), addZ 20 y] [ poly3 [addZ 20 x, addZ 12 v, addZ 12 ((V2 0 0) -.- v), addZ 20 y]
, setDepth 12 . rotate a . scale 1 1 $ circleSolid $ magV v , setDepth 12 . rotate a . scale 1 1 $ circleSolid $ magV v
] ]
where where
@@ -171,8 +171,8 @@ drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
_ -> blank _ -> blank
circLine :: Float -> Picture circLine :: Float -> Picture
circLine x = line [(0,0),(x,0)] circLine x = line [(V2 0 0),(V2 x 0)]
picAtCrPos :: Picture -> Creature -> World -> Picture picAtCrPos :: Picture -> Creature -> World -> Picture
{-# INLINE picAtCrPos #-} {-# INLINE picAtCrPos #-}
picAtCrPos thePic cr _ = uncurry translate (_crPos cr) $ rotate (_crDir cr) thePic picAtCrPos thePic cr _ = uncurryV translate (_crPos cr) $ rotate (_crDir cr) thePic
src/Dodge/Creature/Volition.hs
+2 -2
View File
@@ -33,7 +33,7 @@ advanceShoot' tcid = lostest `DoActionWhile`
shootFirstMiss' :: Action shootFirstMiss' :: Action
shootFirstMiss' = shootFirstMiss' =
LeadTarget (30,50) `DoActionThen` LeadTarget (V2 30 50) `DoActionThen`
DoImpulses [UseItem] `DoActionThen` DoImpulses [UseItem] `DoActionThen`
(crCanShoot `DoActionWhile` DoActions [LeadTarget (0,0),DoImpulses [UseItem]]) (crCanShoot `DoActionWhile` DoActions [LeadTarget (V2 0 0),DoImpulses [UseItem]])
`DoActionThen` 20 `WaitThen` holsterWeapon `DoActionThen` 20 `WaitThen` holsterWeapon
src/Dodge/Data.hs
+2 -2
View File
@@ -67,7 +67,7 @@ data World = World
, _floorItems :: IM.IntMap FloorItem , _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [RenderType] , _floorTiles :: [RenderType]
, _randGen :: StdGen , _randGen :: StdGen
, _mousePos :: !(Float,Float) , _mousePos :: !Point2
, _testString :: String , _testString :: String
, _yourID :: !Int , _yourID :: !Int
, _worldEvents :: !(World -> World) , _worldEvents :: !(World -> World)
@@ -79,7 +79,7 @@ data World = World
, _foregroundDecorations :: [Polyhedra] , _foregroundDecorations :: [Polyhedra]
, _foregroundEdgeVerx :: [Point3] , _foregroundEdgeVerx :: [Point3]
, _corpses :: IM.IntMap (IM.IntMap [Corpse]) , _corpses :: IM.IntMap (IM.IntMap [Corpse])
, _clickMousePos :: (Float,Float) , _clickMousePos :: !Point2
, _pathGraph :: ~(Gr Point2 Float) , _pathGraph :: ~(Gr Point2 Float)
, _pathGraph' :: ~[(Point2,Point2)] , _pathGraph' :: ~[(Point2,Point2)]
, _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
src/Dodge/Debug.hs
+6 -6
View File
@@ -2,7 +2,7 @@ module Dodge.Debug where
import Dodge.Data import Dodge.Data
import Dodge.Picture import Dodge.Picture
import Dodge.Picture.Layer import Dodge.Picture.Layer
--import Geometry.Data import Geometry.Data
import Picture import Picture
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
@@ -13,8 +13,8 @@ drawCircleAtFor p t w = w & projectiles %~
IM.insert k Projectile IM.insert k Projectile
{ _pjPos = p { _pjPos = p
, _pjStartPos = p , _pjStartPos = p
, _pjVel = (0,0) , _pjVel = (V2 0 0)
, _pjDraw = \_ -> onLayer PtLayer $ uncurry translate p $ color white $ circleSolid 20 , _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
, _pjID = k , _pjID = k
, _pjUpdate = \_ -> pjTimerF t k , _pjUpdate = \_ -> pjTimerF t k
} }
@@ -25,8 +25,8 @@ drawCircleAtForCol p t col w = w & projectiles %~
IM.insert k Projectile IM.insert k Projectile
{ _pjPos = p { _pjPos = p
, _pjStartPos = p , _pjStartPos = p
, _pjVel = (0,0) , _pjVel = (V2 0 0)
, _pjDraw = \_ -> onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 20 , _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color col $ circleSolid 20
, _pjID = k , _pjID = k
, _pjUpdate = \_ -> pjTimerF t k , _pjUpdate = \_ -> pjTimerF t k
} }
@@ -37,7 +37,7 @@ drawLineForCol ps t col w = w & projectiles %~
IM.insert k Projectile IM.insert k Projectile
{ _pjPos = head ps { _pjPos = head ps
, _pjStartPos = head ps , _pjStartPos = head ps
, _pjVel = (0,0) , _pjVel = (V2 0 0)
, _pjDraw = \_ -> onLayer PtLayer $ color col $ lineOfThickness 5 ps , _pjDraw = \_ -> onLayer PtLayer $ color col $ lineOfThickness 5 ps
, _pjID = k , _pjID = k
, _pjUpdate = \_ -> pjTimerF t k , _pjUpdate = \_ -> pjTimerF t k
src/Dodge/Default/Shell.hs
+5 -4
View File
@@ -2,13 +2,14 @@ module Dodge.Default.Shell
where where
import Dodge.Data import Dodge.Data
import Picture import Picture
import Geometry.Data
defaultShell :: Projectile defaultShell :: Projectile
defaultShell = Shell defaultShell = Shell
{ _pjPos = (0,0) { _pjPos = (V2 0 0)
, _pjStartPos = (0,0) , _pjStartPos = (V2 0 0)
, _pjVel = (0,0) , _pjVel = (V2 0 0)
, _pjAcc = (0,0) , _pjAcc = (V2 0 0)
, _pjDir = 0 , _pjDir = 0
, _pjSpin = 0 , _pjSpin = 0
, _pjDraw = const blank , _pjDraw = const blank
src/Dodge/Default/World.hs
+9 -9
View File
@@ -8,7 +8,7 @@ import Dodge.Config.Data
import Dodge.Config.KeyConfig import Dodge.Config.KeyConfig
import Dodge.Item.Data import Dodge.Item.Data
--import Picture --import Picture
--import Geometry import Geometry.Data
--import Picture.Texture --import Picture.Texture
import System.Random import System.Random
@@ -20,10 +20,10 @@ defaultWorld :: World
defaultWorld = World defaultWorld = World
{ _keys = S.empty { _keys = S.empty
, _mouseButtons = S.empty , _mouseButtons = S.empty
, _cameraCenter = (0,0) , _cameraCenter = (V2 0 0)
, _cameraRot = 0 , _cameraRot = 0
, _cameraZoom = 1 , _cameraZoom = 1
, _cameraViewFrom = (0,0) , _cameraViewFrom = (V2 0 0)
, _creatures = IM.empty , _creatures = IM.empty
, _creaturesZone = IM.empty , _creaturesZone = IM.empty
, _creatureGroups = IM.empty , _creatureGroups = IM.empty
@@ -40,7 +40,7 @@ defaultWorld = World
, _floorItems = IM.empty , _floorItems = IM.empty
, _floorTiles = [] , _floorTiles = []
, _randGen = mkStdGen 2 , _randGen = mkStdGen 2
, _mousePos = (0,0) , _mousePos = (V2 0 0)
, _testString = [] , _testString = []
, _yourID = 0 , _yourID = 0
, _worldEvents = id , _worldEvents = id
@@ -54,13 +54,13 @@ defaultWorld = World
, _menuLayers = [LevelMenu 1] , _menuLayers = [LevelMenu 1]
, _worldState = M.empty , _worldState = M.empty
, _worldTriggers = S.empty , _worldTriggers = S.empty
, _clickMousePos = (0,0) , _clickMousePos = (V2 0 0)
, _pathGraph = Data.Graph.Inductive.Graph.empty , _pathGraph = Data.Graph.Inductive.Graph.empty
, _pathGraph' = [] , _pathGraph' = []
, _pathPoints = IM.empty , _pathPoints = IM.empty
, _pathInc = M.empty , _pathInc = M.empty
, _carteDisplay = False , _carteDisplay = False
, _carteCenter = (0,0) , _carteCenter = (V2 0 0)
, _carteZoom = 0.5 , _carteZoom = 0.5
, _carteRot = 0 , _carteRot = 0
, _lightSources = IM.empty , _lightSources = IM.empty
@@ -68,7 +68,7 @@ defaultWorld = World
, _closeActiveObjects = [] , _closeActiveObjects = []
, _seenLocations = IM.fromList , _seenLocations = IM.fromList
[(0, (_crPos . you, "CURRENT POSITION")) [(0, (_crPos . you, "CURRENT POSITION"))
,(1, (const (0,0) , "START POSITION")) ,(1, (const (V2 0 0) , "START POSITION"))
] ]
, _selLocation = 0 , _selLocation = 0
, _keyConfig = defaultKeyConfigSDL , _keyConfig = defaultKeyConfigSDL
@@ -89,10 +89,10 @@ defaultDebugFlags = DebugFlags
} }
youLight :: TempLightSource youLight :: TempLightSource
youLight = youLight =
TLS { _tlsPos = (0,0,0) TLS { _tlsPos = (V3 0 0 0)
,_tlsRad = 300 ,_tlsRad = 300
,_tlsIntensity = 0.1 ,_tlsIntensity = 0.1
,_tlsUpdate = \w _ -> (w, Just (youLight {_tlsPos = f $ _crPos (you w)})) ,_tlsUpdate = \w _ -> (w, Just (youLight {_tlsPos = f $ _crPos (you w)}))
} }
where where
f (x,y) = (x,y,0) f (V2 x y) = (V3 x y 0)
src/Dodge/Item/Weapon/Booster.hs
+1 -1
View File
@@ -97,7 +97,7 @@ drawBoostShockwave pj = setLayer 1 $ onLayer UPtLayer $ pictures $
theArc = maybeToList $ do theArc = maybeToList $ do
(hp,hv) <- safeHead pvs (hp,hv) <- safeHead pvs
r <- safeHead xs r <- safeHead xs
return $ color (snd $ last lpairs) $ uncurry translate hp return $ color (snd $ last lpairs) $ uncurryV translate hp
$ arc (argV hv - pi/2) (argV hv + pi/2) $ r * magV hv $ arc (argV hv - pi/2) (argV hv + pi/2) $ r * magV hv
cols = map (`withAlpha` white) [0,0.05..] cols = map (`withAlpha` white) [0,0.05..]
lpairs = zip (reverse lps) cols lpairs = zip (reverse lps) cols
src/Dodge/Item/Weapon/Grenade.hs
+4 -4
View File
@@ -37,7 +37,7 @@ moveGrenade time dir pID w = case hitWl of
where where
updatedWorld = updateV $ set (projectiles . ix pID . pjPos) finalPos updatedWorld = updateV $ set (projectiles . ix pID . pjPos) finalPos
$ set (projectiles .ix pID. pjDraw) $ set (projectiles .ix pID. pjDraw)
(\ _ -> onLayer PtLayer $ uncurry translate newPos (\ _ -> onLayer PtLayer $ uncurryV translate newPos
$ rotate dir $ grenadePic time) $ rotate dir $ grenadePic time)
$ set (projectiles .ix pID.pjUpdate) (\_ -> moveGrenade (time-1) dir pID) w $ set (projectiles .ix pID.pjUpdate) (\_ -> moveGrenade (time-1) dir pID) w
pj = _projectiles w IM.! pID pj = _projectiles w IM.! pID
@@ -71,7 +71,7 @@ throwGrenade explosion cr w = setWp $ removePict $ over projectiles addG w
{ _pjPos = p { _pjPos = p
, _pjStartPos = p , _pjStartPos = p
, _pjVel = v , _pjVel = v
, _pjDraw = \_ -> onLayer PtLayer $ uncurry translate p $ grenadePic 0 , _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ grenadePic 0
, _pjID = i , _pjID = i
, _pjUpdate = \_ -> moveGrenade fuseTime dir i , _pjUpdate = \_ -> moveGrenade fuseTime dir i
, _pjPayload = explosion , _pjPayload = explosion
@@ -84,8 +84,8 @@ throwGrenade explosion cr w = setWp $ removePict $ over projectiles addG w
v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w) v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w)
v | magV v' > 6 = 6 *.* normalizeV v' v | magV v' > 6 = 6 *.* normalizeV v'
| otherwise = v' | otherwise = v'
p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) p' = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr) (0))
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr-4) (0))
| otherwise = p' | otherwise = p'
dir = argV v dir = argV v
setWp :: World -> World setWp :: World -> World
src/Dodge/Layout.hs
+3 -3
View File
@@ -52,7 +52,7 @@ setupForegroundEdgeVerxs :: World -> World
setupForegroundEdgeVerxs w = w & foregroundEdgeVerx .~ polyhedrasToEdges (_foregroundDecorations w) setupForegroundEdgeVerxs w = w & foregroundEdgeVerx .~ polyhedrasToEdges (_foregroundDecorations w)
polyhedrasToEdges :: [Polyhedra] -> [Point3] polyhedrasToEdges :: [Polyhedra] -> [Point3]
polyhedrasToEdges = concatMap flat4 . concatMap polyToEdges polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
-- | connects a collection (tree) of rooms together -- | connects a collection (tree) of rooms together
generateFromTree :: State StdGen (Tree Room) -> World -> World generateFromTree :: State StdGen (Tree Room) -> World -> World
@@ -68,7 +68,7 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
plmnts = concatMap _rmPS $ flatten tr plmnts = concatMap _rmPS $ flatten tr
path = pairsToGraph dist pairGraph path = pairsToGraph dist pairGraph
pairGraph = makePath tr pairGraph = makePath tr
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] insertPoint pp@(_,(V2 x y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
pinc = M.fromList $ pairsToIncidence pairGraph pinc = M.fromList $ pairsToIncidence pairGraph
initializeStaticWalls :: World -> World initializeStaticWalls :: World -> World
@@ -160,7 +160,7 @@ shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
(_rmLinks t) (_rmLinks t)
ts ts
where where
f r = shiftRoomBy ( (0,0) -.- rotateV (pi-a) p , 0) $ shiftRoomBy ((0,0),pi-a) r f r = shiftRoomBy ( (V2 0 0) -.- rotateV (pi-a) p , 0) $ shiftRoomBy ((V2 0 0),pi-a) r
where where
(p,a) = last $ _rmLinks r (p,a) = last $ _rmLinks r
src/Dodge/LevelGen.hs
+5 -5
View File
@@ -94,13 +94,13 @@ placeSpot ps w = case _psType ps of
where where
(q:qs) = map (shiftPointBy (p,rot)) ps' (q:qs) = map (shiftPointBy (p,rot)) ps'
rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q]) rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
PutForeground poly -> w & foregroundDecorations %~ (map (uncurry translateXY p . rotateXY rot) poly ++) PutForeground poly -> w & foregroundDecorations %~ (map (uncurryV translateXY p . rotateXY rot) poly ++)
PutNothing -> w PutNothing -> w
PutID _ -> w PutID _ -> w
--_ -> w --_ -> w
where where
p@(px,py) = _psPos ps p@(V2 px py) = _psPos ps
p' = (px,py,0) p' = (V3 px py 0)
rot = _psRot ps rot = _psRot ps
-- TODO: remove this typeclass -- TODO: remove this typeclass
@@ -192,11 +192,11 @@ placeCr crF p rot = over creatures addCr
crs crs
placeLS :: LightSource -> Picture -> Point3 -> Float -> World -> World placeLS :: LightSource -> Picture -> Point3 -> Float -> World -> World
placeLS ls dec (x,y,z) rot w = over lightSources addLS $ over decorations addDec w placeLS ls dec (V3 x y z) rot w = over lightSources addLS $ over decorations addDec w
where where
addLS lss = IM.insert addLS lss = IM.insert
(IM.newKey lss) (IM.newKey lss)
(ls {_lsPos = (x,y,z),_lsDir = rot,_lsID = IM.newKey lss}) (ls {_lsPos = (V3 x y z),_lsDir = rot,_lsID = IM.newKey lss})
lss lss
addDec decs = IM.insert addDec decs = IM.insert
(IM.newKey decs) (IM.newKey decs)
src/Dodge/LevelGen/LineBlock.hs
+1 -1
View File
@@ -29,7 +29,7 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i
blockCenPs = snd $ evenOddSplit psOnLine blockCenPs = snd $ evenOddSplit psOnLine
numBlocks = length blockCenPs numBlocks = length blockCenPs
is = [0.. numBlocks - 1] is = [0.. numBlocks - 1]
cornerPoints = cornerPoints = map toV2
[(-halfBlockWidth,-depth) -- goes anticlockwise around the block [(-halfBlockWidth,-depth) -- goes anticlockwise around the block
,(-halfBlockWidth, depth) ,(-halfBlockWidth, depth)
,( halfBlockWidth, depth) ,( halfBlockWidth, depth)
src/Dodge/LevelGen/Pathing.hs
+1 -1
View File
@@ -24,5 +24,5 @@ removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
w w
where where
pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] insertPoint pp@(_,(V2 x y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
newGraph = pairsToGraph dist pg' newGraph = pairsToGraph dist pg'
src/Dodge/LevelGen/TriggerDoor.hs
+3 -2
View File
@@ -33,11 +33,12 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b)) (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
$ _pathGraph' w $ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] insertPoint pp@(_,(V2 x y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
eff w' = over pathGraph' (removedPairs ++) eff w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y) f (x,y) = (x,y,dist x y)
-- this has been repeated at least three times: TO BE UNIFIED, REFACTORED
addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
@@ -51,7 +52,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b)) (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
$ _pathGraph' w $ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] insertPoint pp@(_,(V2 x y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
openDoor w' = over pathGraph' (removedPairs ++) openDoor w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y) f (x,y) = (x,y,dist x y)
src/Dodge/Particle/Bullet/Spawn.hs
+1 -1
View File
@@ -39,7 +39,7 @@ aCurveBulAt
aCurveBulAt maycid col pos control targ hiteff width = Bul' aCurveBulAt maycid col pos control targ hiteff width = Bul'
{ _ptDraw = drawBul { _ptDraw = drawBul
, _ptUpdate' = \w -> mvGenBullet w . setVel , _ptUpdate' = \w -> mvGenBullet w . setVel
, _btVel' = (0,0) , _btVel' = (V2 0 0)
, _btColor' = col , _btColor' = col
, _btTrail' = [pos] , _btTrail' = [pos]
, _btPassThrough' = maycid , _btPassThrough' = maycid
src/Dodge/Path.hs
+4 -3
View File
@@ -20,6 +20,7 @@ import System.Random
worldGraph :: World -> Point2 -> HS.HashSet Point2 worldGraph :: World -> Point2 -> HS.HashSet Point2
worldGraph w p = HS.unions $ fmap (\q -> HS.fromList $ pointsAlong w p (p +.+ q)) worldGraph w p = HS.unions $ fmap (\q -> HS.fromList $ pointsAlong w p (p +.+ q))
$ map toV2
[(200,0),(-200,0),(0,200),(0,-200)] [(200,0),(-200,0),(0,200),(0,-200)]
pointsAlong :: World -> Point2 -> Point2 -> [Point2] pointsAlong :: World -> Point2 -> Point2 -> [Point2]
@@ -68,9 +69,9 @@ makeNode e = (HP.singleton (0,(0,[e])) , [])
tp1,tp2,tp3 :: Point2 tp1,tp2,tp3 :: Point2
tp1 = (0,1) tp1 = (V2 0 1)
tp2 = (0,20) tp2 = (V2 0 20)
tp3 = (30,40) tp3 = (V2 30 40)
f :: Point2 -> [Point2] f :: Point2 -> [Point2]
f = incidenceToFunction $ pairsToIncidence f = incidenceToFunction $ pairsToIncidence
src/Dodge/Render.hs
+7 -7
View File
@@ -46,7 +46,7 @@ doDrawing pdata w = do
let rot = _cameraRot w let rot = _cameraRot w
camzoom = _cameraZoom w camzoom = _cameraZoom w
trans = _cameraCenter w trans = _cameraCenter w
wins = (getWindowX w,getWindowY w) wins = (V2 (getWindowX w) (getWindowY w))
(wallPointsCol,windowPoints) = wallsAndWindows w (wallPointsCol,windowPoints) = wallsAndWindows w
lightPoints = lightsForGloom w lightPoints = lightsForGloom w
viewFroms = _cameraViewFrom w viewFroms = _cameraViewFrom w
@@ -63,7 +63,7 @@ doDrawing pdata w = do
(_foregroundEdgeVerx w) (_foregroundEdgeVerx w)
-- poke foreground geometry and floor -- poke foreground geometry and floor
let addC (xx,yy) = (xx,yy,0) let addC (V2 xx yy) = (V3 xx yy 0)
nsurfVs <- pokePoint3s (shadVBOptr $ _lightingSurfaceShader pdata) nsurfVs <- pokePoint3s (shadVBOptr $ _lightingSurfaceShader pdata)
$ polyToTris (map addC $ screenPolygon w) $ polyToTris (map addC $ screenPolygon w)
++ concatMap polyToGeoRender' (foregroundPics w) ++ concatMap polyToGeoRender' (foregroundPics w)
@@ -115,14 +115,14 @@ doDrawing pdata w = do
blend $= Disabled blend $= Disabled
drawShader (_bloomBlurShader pdata) 4 drawShader (_bloomBlurShader pdata) 4
replicateM_ 3 $ pingPongBetween (_fboFourth1 pdata) (_fboFourth2 pdata) (_bloomBlurShader pdata) replicateM_ 3 $ pingPongBetween (_fboFourth1 pdata) (_fboFourth2 pdata) (_bloomBlurShader pdata)
viewport $= (Position 0 0, Size (round $ fst wins) (round $ snd wins)) viewport $= (Position 0 0, Size (round $ fstV2 wins) (round $ sndV2 wins))
blend $= Enabled blend $= Enabled
bindFramebuffer Framebuffer $= fst (_fboLighting pdata) bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
viewport $= (Position 0 0 viewport $= (Position 0 0
,divideSize (w ^. config . shadow_resolution) $ Size (round $ fst wins) (round $ snd wins)) ,divideSize (w ^. config . shadow_resolution) $ Size (round $ fstV2 wins) (round $ sndV2 wins))
createLightMap pdata lightPoints nWalls nSils nsurfVs createLightMap pdata lightPoints nWalls nSils nsurfVs
viewport $= (Position 0 0, Size (round $ fst wins) (round $ snd wins)) viewport $= (Position 0 0, Size (round $ fstV2 wins) (round $ sndV2 wins))
colorMask $= Color4 Enabled Enabled Enabled Enabled colorMask $= Color4 Enabled Enabled Enabled Enabled
clearColor $= Color4 0 0 0 0 clearColor $= Color4 0 0 0 0
@@ -163,7 +163,7 @@ doDrawing pdata w = do
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
rds -> do rds -> do
let bindDrawDist :: (Point2,Point2,Point2,Float) -> IO () let bindDrawDist :: (Point2,Point2,Point2,Float) -> IO ()
bindDrawDist ((a,b),(c,d),(e,f),g) = do bindDrawDist ((V2 a b),(V2 c d),(V2 e f),g) = do
pokeArray (shadVBOptr $ _barrelShader pdata) pokeArray (shadVBOptr $ _barrelShader pdata)
[a,b,c,d,e,f,g] [a,b,c,d,e,f,g]
bindShaderBuffers [_barrelShader pdata] [1] bindShaderBuffers [_barrelShader pdata] [1]
@@ -176,7 +176,7 @@ doDrawing pdata w = do
zipWithM_ (>>) bindings $ map bindDrawDist rds zipWithM_ (>>) bindings $ map bindDrawDist rds
activeTexture $= TextureUnit 0 activeTexture $= TextureUnit 0
-- draw overlay -- draw overlay
bufferUBO $ isoMatrix 0 1 (0,0) (2,2) bufferUBO $ isoMatrix 0 1 (V2 0 0) (V2 2 2)
depthFunc $= Just Always depthFunc $= Just Always
depthMask $= Disabled depthMask $= Disabled
blend $= Enabled blend $= Enabled
src/Dodge/Render/HUD.hs
+28 -30
View File
@@ -51,12 +51,12 @@ drawInventory w = case _inventoryMode w of
cursorsZ :: World -> Int -> Item -> Picture cursorsZ :: World -> Int -> Item -> Picture
cursorsZ w ipos it = case it ^? wpAmmo . amParamSel of cursorsZ w ipos it = case it ^? wpAmmo . amParamSel of
Nothing -> winScale w $ zDraw sp (155- hw, hh - 77.5) Nothing -> winScale w $ zDraw sp (V2 (155- hw) ( hh - 77.5))
Just jpos -> winScale w $ zDraw sp (155 - hw, hh - (20 * fromIntegral jpos + 77.5)) Just jpos -> winScale w $ zDraw sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
where where
hh = halfHeight w hh = halfHeight w
hw = halfWidth w hw = halfWidth w
sp = (125 - hw, hh - (20 * fromIntegral ipos + 17.5)) sp = (V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5)))
topInvCursor :: Color -> Int -> World -> [Picture] topInvCursor :: Color -> Int -> World -> [Picture]
topInvCursor col iPos w topInvCursor col iPos w
@@ -84,7 +84,7 @@ mCurs it w = case it ^? wpAmmo . amParamSel of
y = 155 y = 155
zDraw :: Point2 -> Point2 -> Picture zDraw :: Point2 -> Point2 -> Picture
zDraw (x,y) (a,b) = line zDraw (V2 x y) (V2 a b) = line $ map toV2
[(x,y) [(x,y)
,(0.5 * (x+a), y) ,(0.5 * (x+a), y)
,(0.5 * (x+a), b) ,(0.5 * (x+a), b)
@@ -97,7 +97,7 @@ pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj
displayMidList :: World -> [String] -> String -> [Picture] displayMidList :: World -> [String] -> String -> [Picture]
displayMidList w strs s = displayMidList w strs s =
invHead w s invHead w s
++ renderListAt (150,-60) (map (,white) strs) w ++ renderListAt (V2 (150) (-60)) (map (,white) strs) w
invHead :: World -> String -> [Picture] invHead :: World -> String -> [Picture]
invHead w s = [winScale w . translate (-130) (halfHeight w - 40) invHead w s = [winScale w . translate (-130) (halfHeight w - 40)
@@ -105,10 +105,10 @@ invHead w s = [winScale w . translate (-130) (halfHeight w - 40)
] ]
displayListTopLeft :: [(String,Color)] -> World -> [Picture] displayListTopLeft :: [(String,Color)] -> World -> [Picture]
displayListTopLeft = renderListAt (0,0) displayListTopLeft = renderListAt (V2 0 0)
renderListAt :: Point2 -> [(String,Color)] -> World -> [Picture] renderListAt :: Point2 -> [(String,Color)] -> World -> [Picture]
renderListAt (tx,ty) scols w = renderListAt (V2 tx ty) scols w =
map (winScale w) $ zipWith map (winScale w) $ zipWith
(translate (tx + 15-halfWidth w)) (translate (tx + 15-halfWidth w))
( map (\x -> ty + halfHeight w - (20 * (fromIntegral x+1))) ([0..]::[Int]) ) ( map (\x -> ty + halfHeight w - (20 * (fromIntegral x+1))) ([0..]::[Int]) )
@@ -133,29 +133,29 @@ drawLocations wrld = displayListTopLeft locs wrld
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ wrld locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ wrld
locPoss = map (cartePosToScreen wrld . ($ wrld) . fst) . IM.elems . _seenLocations $ wrld locPoss = map (cartePosToScreen wrld . ($ wrld) . fst) . IM.elems . _seenLocations $ wrld
locTexts = map fst locs locTexts = map fst locs
bFunc (x,y) (z,w) = pictures bFunc (V2 x y) (V2 z w) = pictures
[ bline 0.2 0.050 0.010 [ bline 0.2 0.050 0.010
, bline 0.5 0.045 0.005 , bline 0.5 0.045 0.005
, bline 0.5 0.035 0.002 , bline 0.5 0.035 0.002
] --cheapo antialiasing ] --cheapo antialiasing
where where
bline alph lwidth rwidth bline alph lwidth rwidth
= bezierQuad (withAlpha 0.0 white) (withAlpha alph white) lwidth rwidth (x,y) (0,y) (z,w) = bezierQuad (withAlpha 0.0 white) (withAlpha alph white) lwidth rwidth (V2 x y) (V2 0 y) (V2 z w)
displayListCoords :: World -> [Point2] displayListCoords :: World -> [Point2]
displayListCoords w = map (g . f) [(1::Int)..] displayListCoords w = map (g . f) [(1::Int)..]
where where
f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) ) f i = (V2 ( 15 - halfWidth w ) ( halfHeight w - (20 * fromIntegral i)) )
g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w) g (V2 x y) = (V2 (2*x / getWindowX w) ( 2*y / getWindowY w))
displayListEndCoords :: World -> [String] -> [Point2] displayListEndCoords :: World -> [String] -> [Point2]
displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..] displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
where where
f :: Int -> Point2 f :: Int -> Point2
f i = ( 15 - halfWidth w , 2.5 + halfHeight w - (20 * fromIntegral i) ) f i = (V2 ( 15 - halfWidth w ) ( 2.5 + halfHeight w - (20 * fromIntegral i)) )
g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w) g (V2 x y) = (V2 (2*x / getWindowX w) ( 2*y / getWindowY w))
h :: String -> Point2 -> Point2 h :: String -> Point2 -> Point2
h s (x,y) = (x + 9 * fromIntegral (length s), y) h s (V2 x y) = (V2 (x + 9 * fromIntegral (length s)) ( y))
--bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture --bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
@@ -202,18 +202,16 @@ closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText
objPos obj = case obj of Left flit -> _flItPos flit objPos obj = case obj of Left flit -> _flItPos flit
Right bt -> _btPos bt Right bt -> _btPos bt
mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj)) mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
sc (x, y) = (x*2/getWindowX w, y*2/getWindowY w) sc (V2 x y) = (V2 (x*2/getWindowX w) ( y*2/getWindowY w))
maybeLine = do maybeLine = do
itScreenPos <- mayScreenPos itScreenPos <- mayScreenPos
theText <- fmap (snd . colAndText) mayObj theText <- fmap (snd . colAndText) mayObj
let textWidth = 9 * fromIntegral (length theText) let textWidth = 9 * fromIntegral (length theText)
let col = maybe white (_itInvColor . _flIt) mayIt let col = maybe white (_itInvColor . _flIt) mayIt
let p = (textWidth + xtran 0 + pushout - halfWidth w let p = V2 (textWidth + xtran 0 + pushout - halfWidth w)
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5 ( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
) let p' = V2 ( pushout - halfWidth w + 130)
let p' = ( pushout - halfWidth w + 130 ( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
)
return $ flip thickLineCol (1 / halfWidth w) return $ flip thickLineCol (1 / halfWidth w)
[(itScreenPos, withAlpha 0 col) [(itScreenPos, withAlpha 0 col)
,(sc p' , col) ,(sc p' , col)
@@ -240,10 +238,10 @@ openCursorAt
openCursorAt wth col xoff yoff yint w = winScale w openCursorAt wth col xoff yoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20) . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
$ lineCol $ lineCol
[(( wth,12.5) ,withAlpha 0 col) [((V2 wth 12.5) ,withAlpha 0 col)
,(( 0,12.5) ,col) ,((V2 0 12.5) ,col)
,(( 0,-7.5) ,col) ,((V2 ( 0) (-7.5)) ,col)
,(( wth,-7.5) ,withAlpha 0 col) ,((V2 ( wth) (-7.5)) ,withAlpha 0 col)
] ]
cursorAt cursorAt
:: Float -- ^ Width :: Float -- ^ Width
@@ -257,11 +255,11 @@ cursorAt wth col xoff yoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20) . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
. color col . color col
$ line $ line
[( wth,12.5) [(V2 wth 12.5)
,( 0,12.5) ,(V2 0 12.5)
,( 0,-7.5) ,(V2 ( 0) (-7.5))
,( wth,-7.5) ,(V2 ( wth) (-7.5))
,( wth,12.5) ,(V2 wth 12.5)
] ]
displayHP :: Int -> World -> Picture displayHP :: Int -> World -> Picture
src/Dodge/Render/Picture.hs
+16 -16
View File
@@ -50,9 +50,9 @@ fixedCoordPictures w = case _menuLayers w of
customMouseCursor :: World -> Picture customMouseCursor :: World -> Picture
customMouseCursor w = customMouseCursor w =
scale (2 /getWindowX w) (2/ getWindowY w) scale (2 /getWindowX w) (2/ getWindowY w)
. uncurry translate (_mousePos w) . uncurryV translate (_mousePos w)
. color white . color white
$ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ] $ pictures [ line [(V2 (-5) (0)),(V2 5 0)] , line [(V2 (0) (-5)),(V2 0 5)] ]
testPic :: World -> Picture testPic :: World -> Picture
testPic _ = blank testPic _ = blank
@@ -63,12 +63,12 @@ testPic _ = blank
crDraw :: World -> Creature -> Picture crDraw :: World -> Creature -> Picture
crDraw w c = _crPict c c w crDraw w c = _crPict c c w
ppDraw :: PressPlate -> Picture ppDraw :: PressPlate -> Picture
ppDraw c = uncurry translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
btDraw :: Button -> Picture btDraw :: Button -> Picture
btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c) btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_btPict c)
clDraw :: Cloud -> Picture clDraw :: Cloud -> Picture
clDraw c = uncurry translate (_clPos c) (_clPict c c) clDraw c = uncurryV translate (_clPos c) (_clPict c c)
wallFloorsToDraw :: World -> [Wall] wallFloorsToDraw :: World -> [Wall]
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
@@ -88,15 +88,15 @@ drawWallFloor wl = if _wlIsSeeThrough wl
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x) n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
errorNormalizeVDR :: Point2 -> Point2 errorNormalizeVDR :: Point2 -> Point2
errorNormalizeVDR (0,0) = error "problem with function: errorNormalizeVDR in DodgeRendering" errorNormalizeVDR (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
errorNormalizeVDR p = normalizeV p errorNormalizeVDR p = normalizeV p
printPoint :: Point2 -> Picture printPoint :: Point2 -> Picture
printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)] printPoint p = color white $ uncurryV translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
printRotPoint :: Float -> Point2 -> Picture printRotPoint :: Float -> Point2 -> Picture
printRotPoint r p = color white printRotPoint r p = color white
. uncurry translate p . uncurryV translate p
$ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)] $ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
outsideScreenPolygon :: World -> [Point2] outsideScreenPolygon :: World -> [Point2]
@@ -106,10 +106,10 @@ outsideScreenPolygon w = [tr,tl,bl,br]
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
| otherwise = error "Trying to set screen zoom to zero" | otherwise = error "Trying to set screen zoom to zero"
scTran p = p +.+ _cameraCenter w scTran p = p +.+ _cameraCenter w
tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w) tr = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) ( 3* halfHeight w)
tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w) tl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) ( 3* halfHeight w)
br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w)) br = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) (- (3* halfHeight w))
bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w)) bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w))
wallShadowsToDraw :: World -> [Wall] wallShadowsToDraw :: World -> [Wall]
wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible)) wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
@@ -163,10 +163,10 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] +
. makeLoopPairs $ screenPolygon w . makeLoopPairs $ screenPolygon w
rectangleSolid :: Float -> Float -> Picture rectangleSolid :: Float -> Float -> Picture
rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)] rectangleSolid x y = polygon $ map toV2 [(x,y),(x,-y),(-x,-y),(-x,y)]
drawItem :: FloorItem -> Picture drawItem :: FloorItem -> Picture
drawItem flit = uncurry translate (_flItPos flit) drawItem flit = uncurryV translate (_flItPos flit)
$ rotate (_flItRot flit) (_itFloorPict (_flIt flit)) $ rotate (_flItRot flit) (_itFloorPict (_flIt flit))
@@ -212,14 +212,14 @@ wallsAndWindows w
(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w (wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w
wallsToList :: [((Point2,Point2),Point4)] -> [Float] wallsToList :: [((Point2,Point2),Point4)] -> [Float]
wallsToList = concatMap (\(((a,b),(c,d)),(e,f,g,h)) -> [a,b,c,d,e,f,g,h]) wallsToList = concatMap (\(((V2 a b),(V2 c d)),(V4 e f g h)) -> [a,b,c,d,e,f,g,h])
pokeWalls :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int pokeWalls :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
pokeWalls ptr vals0 = go vals0 0 pokeWalls ptr vals0 = go vals0 0
where where
go [] n = return n go [] n = return n
go ( (((a,b),(c,d)),(e,f,g,h)):vals) n = do go ( (((V2 a b),(V2 c d)),(V4 e f g h)):vals) n = do
pokeElemOff ptr (off 0) a pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c pokeElemOff ptr (off 2) c
src/Dodge/Room/Corridor.hs
+19 -14
View File
@@ -3,21 +3,24 @@ module Dodge.Room.Corridor
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Default.Room import Dodge.Default.Room
import Geometry import Geometry
import Geometry.Data
import Tile import Tile
import Data.Bifunctor
{- | First exit due north, two other exits at angles next to this. {- | First exit due north, two other exits at angles next to this.
Entrance from south. -} Entrance from south. -}
corridor :: Room corridor :: Room
corridor = defaultRoom corridor = defaultRoom
{ _rmPolys = [poly] { _rmPolys = [poly]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (20,60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS = [] , _rmPS = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmFloor = [oTile poly 2] , _rmFloor = [oTile poly 2]
} }
where where
poly = rectNSWE 80 0 0 40 poly = rectNSWE 80 0 0 40
lnks = lnks = map (first toV2)
[((20,70) ,0) [((20,70) ,0)
,((20,70), pi/6) ,((20,70), pi/6)
,((20,70), negate $ pi/6) ,((20,70), negate $ pi/6)
@@ -32,12 +35,12 @@ corridorDebug = defaultRoom
--, [ (0,0), (0,20) , (20,10)] --, [ (0,0), (0,20) , (20,10)]
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (20,60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS = [] , _rmPS = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
} }
where where
lnks = lnks = map (first toV2)
[((20,70) ,0) [((20,70) ,0)
,((20,70), pi/6) ,((20,70), pi/6)
,((20,70), negate $ pi/6) ,((20,70), negate $ pi/6)
@@ -52,10 +55,10 @@ corridorN = defaultRoom
, _rmPS = [] , _rmPS = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
} }
where lnks = [((20,70) ,0) where lnks = [((V2 20 70) ,0)
,((20,10) ,pi) ,((V2 20 10) ,pi)
] ]
pth = doublePair ((20,70),(20,10)) pth = doublePair ((V2 20 70),(V2 20 10))
tEast :: Room tEast :: Room
tEast = defaultRoom tEast = defaultRoom
@@ -63,26 +66,28 @@ tEast = defaultRoom
,rectNSWE 80 40 (-40) 40 ,rectNSWE 80 40 (-40) 40
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPS = [] , _rmPS = []
, _rmBound = [ rectNSWE 70 10 0 40 ] , _rmBound = [ rectNSWE 70 10 0 40 ]
} }
where lnks = [(( 30,60),-pi/2) where
,((-30,60),pi/2) lnks = map (first toV2)
,((0,10),pi) [(( 30,60),-pi/2)
] ,((-30,60),pi/2)
,((0,10),pi)
]
tWest :: Room tWest :: Room
tWest = defaultRoom tWest = defaultRoom
{ _rmPolys = [rectNSWE 80 0 (-20) 20 { _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40 ,rectNSWE 80 40 (-40) 40
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60) . fst) lnks , _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPS = [] , _rmPS = []
, _rmBound = [ rectNSWE 70 10 0 40 ] , _rmBound = [ rectNSWE 70 10 0 40 ]
} }
where where
lnks = lnks = map (first toV2)
[((-30,60),pi/2) [((-30,60),pi/2)
,(( 30,60),-pi/2) ,(( 30,60),-pi/2)
,((0,10),pi) ,((0,10),pi)
src/Dodge/Room/Door.hs
+4 -4
View File
@@ -15,13 +15,13 @@ door :: Room
door = defaultRoom door = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40] { _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [((20,35),(20,5))] , _rmPath = [((V2 20 35),(V2 20 5))]
-- door extends into side walls (for shadows as rendered 12/03) -- door extends into side walls (for shadows as rendered 12/03)
, _rmPS = [sPS (0,20) 0 $ PutAutoDoor (0,0) (40,0)] , _rmPS = [sPS (V2 0 20) 0 $ PutAutoDoor (V2 0 0) (V2 40 0)]
, _rmBound = [] , _rmBound = []
} }
where lnks = [((20,35),0) where lnks = [((V2 20 35),0)
,((20, 5),pi) ,((V2 20 5),pi)
] ]
src/Dodge/Room/Foreground.hs
+11 -11
View File
@@ -20,9 +20,9 @@ highDiagonalMesh
-> Float -- ^ vertical distance between lines -> Float -- ^ vertical distance between lines
-> Picture -> Picture
highDiagonalMesh pa pb w d = setDepth (-0.2) $ pictures $ highDiagonalMesh pa pb w d = setDepth (-0.2) $ pictures $
map (flip thickLine 3 . flat2) (diagonalLinesRect pb pa w d (3*pi/4)) map (flip thickLine 3 . tflat2) (diagonalLinesRect pb pa w d (3*pi/4))
++ ++
map (flip thickLine 3 . flat2) (diagonalLinesRect pb pc (negate h) d (pi/4)) map (flip thickLine 3 . tflat2) (diagonalLinesRect pb pc (negate h) d (pi/4))
where where
pc = pb +.+ w *.* normalizeV (vNormal (pb -.- pa)) pc = pb +.+ w *.* normalizeV (vNormal (pb -.- pa))
h = dist pa pb h = dist pa pb
@@ -49,20 +49,20 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
yN = d * 0.5 *.* normalizeV (pa -.- pb) yN = d * 0.5 *.* normalizeV (pa -.- pb)
highPipe :: Float -> Point2 -> Point2 -> [Polyhedra] highPipe :: Float -> Point2 -> Point2 -> [Polyhedra]
highPipe h x@(xx,xy) y = highPipe h x@(V2 xx xy) y =
[ Polyhedron . map (map ( (,orange) . (+.+.+ (xx,xy,h)))) [ Polyhedron . map (map ( (,orange) . (+.+.+ (V3 xx xy h))))
$ boxABC (a,b,0) (a',b',0) (0,0,5) $ boxABC (V3 a b 0) (V3 a' b' 0) (V3 0 0 5)
] ]
where where
(a,b) = y -.- x (V2 a b) = y -.- x
(a',b') = 10 *.* normalizeV (vNormal (a,b)) (V2 a' b') = 10 *.* normalizeV (vNormal (V2 a b))
girderZ :: Float -> Point2 -> Point2 -> Picture girderZ :: Float -> Point2 -> Point2 -> Picture
girderZ w x y = setDepth 50 $ color red $ pictures $ girderZ w x y = setDepth 50 $ color red $ pictures $
[ thickLine [xt,yt] 3 [ thickLine [xt,yt] 3
, thickLine [xb,yb] 3 , thickLine [xb,yb] 3
] ]
++ map (flip thickLine 3 . flat2) ls ++ map (flip thickLine 3 . tflat2) ls
where where
n = w *.* normalizeV (vNormal $ y -.- x) n = w *.* normalizeV (vNormal $ y -.- x)
xb = x +.+ n xb = x +.+ n
@@ -78,8 +78,8 @@ girderV col w x y = setDepth 50 $ color col $ pictures $
[ thickLine [xt,yt] 3 [ thickLine [xt,yt] 3
, thickLine [xb,yb] 3 , thickLine [xb,yb] 3
] ]
++ map (flip thickLine 3 . flat2) as' ++ map (flip thickLine 3 . tflat2) as'
++ map (flip thickLine 3 . flat2) bs' ++ map (flip thickLine 3 . tflat2) bs'
where where
n = w *.* normalizeV (vNormal $ y -.- x) n = w *.* normalizeV (vNormal $ y -.- x)
xb = x +.+ n xb = x +.+ n
@@ -97,7 +97,7 @@ girder col w x y = pictures $
[ thickLine [xt,yt] 3 [ thickLine [xt,yt] 3
, thickLine [xb,yb] 3 , thickLine [xb,yb] 3
] ]
++ map (flip thickLine 3 . flat2) ls ++ map (flip thickLine 3 . tflat2) ls
) )
: map (\p -> verticalPipe 1.5 col p 0 (-0.1)) [xb,xt,yb,yt] : map (\p -> verticalPipe 1.5 col p 0 (-0.1)) [xb,xt,yb,yt]
where where
src/Dodge/Room/Link.hs
+2 -2
View File
@@ -59,8 +59,8 @@ This is intended to work when the external point is an outgoing link from anothe
shiftRoomToLink :: (Point2,Float) -> Room -> Room shiftRoomToLink :: (Point2,Float) -> Room -> Room
shiftRoomToLink l r shiftRoomToLink l r
= shiftRoomBy l = shiftRoomBy l
. shiftRoomBy ((0,0) -.- rotateV (pi-a) p , 0) . shiftRoomBy ((V2 0 0) -.- rotateV (pi-a) p , 0)
$ shiftRoomBy ((0,0) ,pi-a) $ shiftRoomBy ((V2 0 0) ,pi-a)
r r
where where
(p,a) = last $ _rmLinks r (p,a) = last $ _rmLinks r
src/Dodge/Update/Camera.hs
+8 -8
View File
@@ -43,7 +43,7 @@ moveCamera w = w & cameraCenter .~ idealPos
camCenter = ypos +.+ scope camCenter = ypos +.+ scope
isCam :: Bool isCam :: Bool
isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera
scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos scope = fromMaybe (V2 0 0) $ yourItem w ^? itAttachment . _Just . scopePos
sightFrom sightFrom
| isCam = camCenter | isCam = camCenter
| otherwise = ypos | otherwise = ypos
@@ -70,7 +70,7 @@ updateScopeZoom w
. itAttachment . _Just %~ updateScope . itAttachment . _Just %~ updateScope
where scppoint = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) where scppoint = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopeZoomChange . itAttachment . _Just . scopeZoomChange
updateScope (ItScope _ _ _ bl) = ItScope (0,0) 0 1 bl updateScope (ItScope _ _ _ bl) = ItScope (V2 0 0) 0 1 bl
updateScope otherAtt = otherAtt updateScope otherAtt = otherAtt
zoomSpeed :: Float zoomSpeed :: Float
@@ -158,18 +158,18 @@ farWallDist :: Point2 -> World -> Float
{-# INLINE farWallDist #-} {-# INLINE farWallDist #-}
farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (verticalMax+50) ) farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (verticalMax+50) )
where where
horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays horizontalMax = maximum $ map (h' (V2 1 0)) rRays ++ map (h' (V2 (-1) (0))) lRays
verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays verticalMax = maximum $ map (h' (V2 0 1)) tRays ++ map (h' (V2 (0) (-1))) bRays
--h p = fromMaybe p $ collidePointIndirect cpos p $ wallsAlongLine cpos p w --h p = fromMaybe p $ collidePointIndirect cpos p $ wallsAlongLine cpos p w
--h p = fromMaybe p . collidePointIndirect cpos p $ _walls w --h p = fromMaybe p . collidePointIndirect cpos p $ _walls w
wos = wallsOnScreen w wos = wallsOnScreen w
h p = fromMaybe p $ collidePointIndirect cpos p wos h p = fromMaybe p $ collidePointIndirect cpos p wos
h' x p = dotV (rotateV camRot x) (p -.- cpos) h' x p = dotV (rotateV camRot x) (p -.- cpos)
camRot = _cameraRot w camRot = _cameraRot w
rRays = rotF [( maxViewDistance,y) | y <- zs] rRays = rotF [(V2 ( maxViewDistance) (y)) | y <- zs]
lRays = rotF [(-maxViewDistance,y) | y <- zs] lRays = rotF [(V2 (-maxViewDistance) (y)) | y <- zs]
tRays = rotF [(y, maxViewDistance) | y <- zs] tRays = rotF [(V2 (y) ( maxViewDistance)) | y <- zs]
bRays = rotF [(y,-maxViewDistance) | y <- zs] bRays = rotF [(V2 (y) (-maxViewDistance)) | y <- zs]
rotF = map (h . (+.+) cpos . rotateV (_cameraRot w)) rotF = map (h . (+.+) cpos . rotateV (_cameraRot w))
zs = takeWhile (< maxViewDistance) [-maxViewDistance,negate $ 0.75*maxViewDistance..] zs = takeWhile (< maxViewDistance) [-maxViewDistance,negate $ 0.75*maxViewDistance..]
maxViewDistance = 800 maxViewDistance = 800
src/Dodge/WorldEvent/Cloud.hs
+2 -2
View File
@@ -3,7 +3,7 @@ module Dodge.WorldEvent.Cloud
import Dodge.Data import Dodge.Data
import Dodge.Base import Dodge.Base
--import Geometry import Geometry.Data
import Picture import Picture
--import qualified IntMapHelp as IM --import qualified IntMapHelp as IM
@@ -14,7 +14,7 @@ makeCloudAt rad t drawFunc p w = w & clouds %~ (theCloud :)
where where
theCloud = Cloud theCloud = Cloud
{ _clPos = p { _clPos = p
, _clVel = (0,0) , _clVel = (V2 0 0)
, _clPict = drawFunc , _clPict = drawFunc
, _clRad = rad , _clRad = rad
, _clTimer = t , _clTimer = t
src/Dodge/WorldEvent/Flash.hs
+3 -3
View File
@@ -70,7 +70,7 @@ lowLightPic len wdth col (a,b) w = case thingsHit a b w of
where where
(wa,wb) = _wlLine wall (wa,wb) = _wlLine wall
((p, E3x1 cr):_) ((p, E3x1 cr):_)
-> setCol . uncurry translate cp . rotate (-0.25 * pi + argV (p -.- cp)) -> setCol . uncurryV translate cp . rotate (-0.25 * pi + argV (p -.- cp))
$ thickArc 0 (pi/2) (_crRad cr) wdth $ thickArc 0 (pi/2) (_crRad cr) wdth
where where
cp = _crPos cr cp = _crPos cr
@@ -78,7 +78,7 @@ lowLightPic len wdth col (a,b) w = case thingsHit a b w of
where setCol = color col . setDepth (-0.5) . setLayer 2 where setCol = color col . setDepth (-0.5) . setLayer 2
flashFlareAt :: Color -> Float -> Point2 -> Particle flashFlareAt :: Color -> Float -> Point2 -> Particle
flashFlareAt col alphax (x,y) = Particle flashFlareAt col alphax (V2 x y) = Particle
{ _ptDraw = const $ setLayer 2 . setDepth (-0.9) . translate x y { _ptDraw = const $ setLayer 2 . setDepth (-0.9) . translate x y
$ circleSolidCol (withAlpha 0 col) (withAlpha alphax col) 30 $ circleSolidCol (withAlpha 0 col) (withAlpha alphax col) 30
, _ptUpdate' = ptTimer' 1 , _ptUpdate' = ptTimer' 1
@@ -105,7 +105,7 @@ muzzleFlashAt p = over particles (muzzleFlashPt p : )
. glareAt 2 10 5 (withAlpha 0.5 white) 20 30 p . glareAt 2 10 5 (withAlpha 0.5 white) 20 30 p
muzzleFlashPt :: Point2 -> Particle muzzleFlashPt :: Point2 -> Particle
muzzleFlashPt (x,y) = Particle muzzleFlashPt (V2 x y) = Particle
{ _ptDraw = const $ setDepth 0 { _ptDraw = const $ setDepth 0
. setLayer 2 . setLayer 2
. translate x y . translate x y
src/Dodge/WorldEvent/SpawnParticle.hs
+29 -29
View File
@@ -59,28 +59,28 @@ drawFlame rotd pt = thePic
ep = _btPos' pt ep = _btPos' pt
thePic = pictures thePic = pictures
[ glow [ glow
, aPic 3 prot2 18 (scaleChange + 1,2) red , aPic 3 prot2 18 (V2 (scaleChange + 1) (2)) red
, aPic 4 prot 19 (scaleChange + 0.5,1.5) orange , aPic 4 prot 19 (V2 (scaleChange + 0.5) (1.5)) orange
, aPic 5 prot3 20 (scaleChange,1) white , aPic 5 prot3 20 (V2 (scaleChange) (1)) white
] ]
aPic :: Int -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture aPic :: Int -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
aPic lay offset depth (scalex,scaley) col aPic lay offset depth (V2 scalex scaley) col
= setLayer lay = setLayer lay
. setDepth depth . setDepth depth
. uncurry translate (offset ep) . uncurryV translate (offset ep)
. rotate (pi * 0.5 + argV rotd) . rotate (pi * 0.5 + argV rotd)
. scale scalex scaley . scale scalex scaley
. color col . color col
$ circleSolid 5 $ circleSolid 5
glow = setLayer 1 $ setDepth 0.3 $ uncurry translate ep glow = setLayer 1 $ setDepth 0.3 $ uncurryV translate ep
$ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50 $ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50
time = _btTimer' pt time = _btTimer' pt
scaleChange scaleChange
| time < 80 = 3 | time < 80 = 3
| otherwise = 3 - (fromIntegral time - 80) * 0.2 | otherwise = 3 - (fromIntegral time - 80) * 0.2
prot p' = p' +.+ rotateV (fromIntegral time) (0,1) prot p' = p' +.+ rotateV (fromIntegral time) (V2 0 1)
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (0,1) prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (V2 0 1)
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2) prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (V2 0 2)
{- TODO: add generalised area damage particles/hiteffects. -} {- TODO: add generalised area damage particles/hiteffects. -}
moveFlame moveFlame
@@ -134,7 +134,7 @@ makeFlameletTimed
-> Int -- ^ Timer -> Int -- ^ Timer
-> World -> World
-> World -> World
makeFlameletTimed (x,y) z vel maycid size time w = w makeFlameletTimed (V2 x y) z vel maycid size time w = w
& randGen .~ g & randGen .~ g
& particles %~ (theFlamelet :) & particles %~ (theFlamelet :)
where where
@@ -143,7 +143,7 @@ makeFlameletTimed (x,y) z vel maycid size time w = w
, _ptUpdate' = moveFlamelet , _ptUpdate' = moveFlamelet
, _btVel' = vel , _btVel' = vel
, _btColor' = red , _btColor' = red
, _btPos' = (x,y) , _btPos' = (V2 x y)
, _btPassThrough' = maycid , _btPassThrough' = maycid
, _btWidth' = size , _btWidth' = size
, _btTimer' = time , _btTimer' = time
@@ -170,16 +170,16 @@ drawFlameletZ rot pt = pictures
size = _btWidth' pt size = _btWidth' pt
siz2 = size + 0.2 siz2 = size + 0.2
time = _btTimer' pt time = _btTimer' pt
glow = setDepth 19 $ uncurry translate ep glow = setDepth 19 $ uncurryV translate ep
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30 $ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
piu = setDepth (z + 20) piu = setDepth (z + 20)
. uncurry translate ep . uncurryV translate ep
. color (dark red) . color (dark red)
. rotate (negate (rot - 0.1 * fromIntegral time)) . rotate (negate (rot - 0.1 * fromIntegral time))
. scale s1 s1 . scale s1 s1
$ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2) $ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
pi2 = setDepth (z + 20) pi2 = setDepth (z + 20)
. uncurry translate ep . uncurryV translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red) orange (dark red)
) )
@@ -187,13 +187,13 @@ drawFlameletZ rot pt = pictures
. scale s2 s2 . scale s2 s2
$ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2) $ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
pic = setDepth (z + 20) pic = setDepth (z + 20)
. uncurry translate ep . uncurryV translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
white (dark red) white (dark red)
) )
. rotate (negate ( 0.1 * fromIntegral time + rot)) . rotate (negate ( 0.1 * fromIntegral time + rot))
. scale sc sc . scale sc sc
$ polygon [(-size,-size),(size,-size),(size,size),(-size,size)] $ polygon $ map toV2 [(-size,-size),(size,-size),(size,size),(-size,size)]
sc = (*) 2 $ log $ 1 + fromIntegral time / 20 sc = (*) 2 $ log $ 1 + fromIntegral time / 20
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40 s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
s2 = 0.5 * (sc + s1) s2 = 0.5 * (sc + s1)
@@ -210,17 +210,17 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
size = _btWidth' pt size = _btWidth' pt
siz2 = size + 0.2 siz2 = size + 0.2
time = _btTimer' pt time = _btTimer' pt
glow = setDepth 19 $ uncurry translate ep glow = setDepth 19 $ uncurryV translate ep
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30 $ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
piu = setDepth 20 piu = setDepth 20
. uncurry translate ep . uncurryV translate ep
. color (dark red) . color (dark red)
. rotate (negate (rot - 0.1 * fromIntegral time)) . rotate (negate (rot - 0.1 * fromIntegral time))
. scale s1 s1 . scale s1 s1
. polygon . polygon
$ rectNSWE siz2 (-siz2) (-siz2) siz2 $ rectNSWE siz2 (-siz2) (-siz2) siz2
pi2 = setDepth 20.2 pi2 = setDepth 20.2
. uncurry translate ep . uncurryV translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red) orange (dark red)
) )
@@ -229,13 +229,13 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
. polygon . polygon
$ rectNSWE siz2 (-siz2) (-siz2) siz2 $ rectNSWE siz2 (-siz2) (-siz2) siz2
pic = setDepth 20.4 pic = setDepth 20.4
. uncurry translate ep . uncurryV translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
white (dark red) white (dark red)
) )
. rotate (negate ( 0.1 * fromIntegral time + rot)) . rotate (negate ( 0.1 * fromIntegral time + rot))
. scale sc sc . scale sc sc
$ polygon [(-size,-size),(size,-size),(size,size),(-size,size)] $ polygon $ map toV2 [(-size,-size),(size,-size),(size,size),(-size,size)]
sc = (*) 2 $ log $ 1 + fromIntegral time / 20 sc = (*) 2 $ log $ 1 + fromIntegral time / 20
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40 s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
s2 = 0.5 * (sc + s1) s2 = 0.5 * (sc + s1)
@@ -392,7 +392,7 @@ crOrWallSensitive
-> World -> World
-> Either3 Creature Point2 Point2 -> Either3 Creature Point2 Point2
crOrWallSensitive p dir wlAttract w = crOrWallSensitive p dir wlAttract w =
fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
. listToMaybe . listToMaybe
. sortBy (compare `on` g) . sortBy (compare `on` g)
$ catMaybes [cr,wlp] $ catMaybes [cr,wlp]
@@ -405,7 +405,7 @@ crOrWallSensitive p dir wlAttract w =
( fmap fst ( fmap fst
. (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w) . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
. (+.+) p . (+.+) p
. (\d -> rotateV d (100,0)) . (\d -> rotateV d (V2 100 0))
. (+ dir) . (+ dir)
. (* wlAttract) . (* wlAttract)
) )
@@ -419,7 +419,7 @@ crOrWallSensitive p dir wlAttract w =
{- Finds whether a creature or wall is in front of a given point and direction. {- Finds whether a creature or wall is in front of a given point and direction.
Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'. -} Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'. -}
crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2 crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2
crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
$ listToMaybe $ sortBy (compare `on` g) $ listToMaybe $ sortBy (compare `on` g)
$ catMaybes [cr,wlp] $ catMaybes [cr,wlp]
where where
@@ -431,7 +431,7 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
( fmap fst ( fmap fst
. (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w) . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
. (+.+) p . (+.+) p
. (\d -> rotateV d (100,0)) . (\d -> rotateV d (V2 100 0))
. (+) dir . (+) dir
) )
[-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8] [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
@@ -451,7 +451,7 @@ createSpark time colid pos dir maycid w
spark = Bul' spark = Bul'
{ _ptDraw = drawBul { _ptDraw = drawBul
, _ptUpdate' = mvGenBullet , _ptUpdate' = mvGenBullet
, _btVel' = rotateV dir (5,0) , _btVel' = rotateV dir (V2 5 0)
, _btColor' = numColor colid , _btColor' = numColor colid
, _btTrail' = [pos] , _btTrail' = [pos]
, _btPassThrough' = maycid , _btPassThrough' = maycid
@@ -459,7 +459,7 @@ createSpark time colid pos dir maycid w
, _btTimer' = time , _btTimer' = time
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff , _btHitEffect' = destroyOnImpact sparkEff noEff noEff
} }
pos' = pos +.+ rotateV dir (5,0) pos' = pos +.+ rotateV dir (V2 5 0)
sparkEff bt p cr sparkEff bt p cr
= creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : ) = creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
where where
@@ -472,7 +472,7 @@ createSparkCol time col pos dir maycid w
spark = Bul' spark = Bul'
{ _ptDraw = drawBul { _ptDraw = drawBul
, _ptUpdate' = mvGenBullet , _ptUpdate' = mvGenBullet
, _btVel' = rotateV dir (5,0) , _btVel' = rotateV dir (V2 5 0)
, _btColor' = col , _btColor' = col
, _btTrail' = [pos] , _btTrail' = [pos]
, _btPassThrough' = maycid , _btPassThrough' = maycid
@@ -480,7 +480,7 @@ createSparkCol time col pos dir maycid w
, _btTimer' = time , _btTimer' = time
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff , _btHitEffect' = destroyOnImpact sparkEff noEff noEff
} }
pos' = pos +.+ rotateV dir (5,0) pos' = pos +.+ rotateV dir (V2 5 0)
sparkEff bt p cr sparkEff bt p cr
= creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : ) = creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
where where
src/Geometry.hs
+5 -1
View File
@@ -10,7 +10,7 @@ Line refers to a line defined by two points, and extends beyond the two points.
-} -}
module Geometry module Geometry
( module Geometry ( module Geometry
-- , module Geometry.Data , module Geometry.Data
, module Geometry.Intersect , module Geometry.Intersect
, module Geometry.Bezier , module Geometry.Bezier
, module Geometry.Vector , module Geometry.Vector
@@ -228,6 +228,10 @@ angleBetween v1 v2 = argV v1 - argV v2
-- | Return a list containing two copies of a pair. -- | Return a list containing two copies of a pair.
doublePair :: (a,a) -> [(a,a)] doublePair :: (a,a) -> [(a,a)]
doublePair (x,y) = [(x,y),(y,x)] doublePair (x,y) = [(x,y),(y,x)]
doubleV2 :: V2 a -> [V2 a]
doubleV2 (V2 x y) = [V2 x y,V2 y x]
-- | Test whether two polygons intersect by testing the intersection of each -- | Test whether two polygons intersect by testing the intersection of each
-- consecutive pair of points. -- consecutive pair of points.
polysIntersect :: [Point2] -> [Point2] -> Bool polysIntersect :: [Point2] -> [Point2] -> Bool
src/Geometry/Data.hs
+7
View File
@@ -9,6 +9,8 @@ module Geometry.Data
, toV3 , toV3
, toV4 , toV4
, uncurryV , uncurryV
, fstV2
, sndV2
) )
where where
import Linear.V2 import Linear.V2
@@ -24,3 +26,8 @@ toV4 (a,b,c,d) = V4 a b c d
uncurryV :: (a -> a -> b) -> V2 a -> b uncurryV :: (a -> a -> b) -> V2 a -> b
uncurryV f (V2 x y) = f x y uncurryV f (V2 x y) = f x y
fstV2 :: V2 a -> a
fstV2 (V2 x _) = x
sndV2 :: V2 a -> a
sndV2 (V2 _ x) = x