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:
jgk
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
tri =
[p
,p +.+ rotateV (dir-pi/4) (x,0)
,p +.+ rotateV (dir+pi/4) (x,0)
,p +.+ rotateV (dir-pi/4) (V2 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
a given distance.
@@ -420,13 +420,15 @@ nearestCrInFront p dir x w
$ IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
where
rec = [p, pR, pR1, pL1, pL ]
pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0)
pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0)
pR1 = pR +.+ rotateV dir (x/2,0)
pL1 = pL +.+ rotateV dir (x/2,0)
pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) (0))
pL = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) (0))
pR1 = pR +.+ rotateV dir (V2 (x/2) (0))
pL1 = pL +.+ rotateV dir (V2 (x/2) (0))
{- | Test whether a creature is in a polygon. -}
crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr = errorPointInPolygon 3 (_crPos cr)
--The following two functions should be unified
{- | Transform coordinates from world position to normalised screen coordinates. -}
worldPosToScreen :: World -> Point2 -> Point2
worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
@@ -434,10 +436,9 @@ worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
doTranslate p = p -.- _cameraCenter w
doZoom p = _cameraZoom w *.* p
doRotate p = rotateV (negate $ _cameraRot w) p
doWindowScale (x,y) =
( x * 2 / getWindowX w
, y * 2 / getWindowY w
)
doWindowScale (V2 x y) = V2
( x * 2 / getWindowX w)
( y * 2 / getWindowY w)
{- | Transform coordinates from the map position to normalised screen
coordinates. -}
cartePosToScreen :: World -> Point2 -> Point2
@@ -446,10 +447,9 @@ cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
doTranslate p = p -.- _carteCenter w
doZoom p = _carteZoom w *.* p
doRotate p = rotateV (negate $ _carteRot w) p
doWindowScale (x,y) =
( x * 2 / getWindowX w
, y * 2 / getWindowY w
)
doWindowScale (V2 x y) = V2
( x * 2 / getWindowX w)
( y * 2 / getWindowY w)
{- | The mouse position in world coordinates. -}
mouseWorldPos :: World -> Point2
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 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
cr = _creatures w IM.! i
radius = _crRad cr
canSeeAny :: Int -> Int -> World -> Bool
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
cr = _creatures w IM.! toID
cpos = _crPos cr
@@ -156,7 +156,7 @@ canSeeAny fromID toID w
canSeeAll :: Int -> Int -> World -> Bool
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
cr = _creatures w IM.! toID
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
| otherwise = p
scTran p = p +.+ _cameraCenter w
tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w)
tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w)
br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w)
bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w)
tr = scTran $ scRot $ scZoom (V2 ( halfWidth w) ( halfHeight w))
tl = scTran $ scRot $ scZoom (V2 (-halfWidth w) ( halfHeight w))
br = scTran $ scRot $ scZoom (V2 ( halfWidth w) (-halfHeight w))
bl = scTran $ scRot $ scZoom (V2 (-halfWidth w) (-halfHeight w))
halfWidth,halfHeight :: World -> Float
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
sizeZoneOfPoint :: Float -> Point2 -> (Int,Int)
sizeZoneOfPoint s (x,y) = (f x, f y)
sizeZoneOfPoint s (V2 x y) = (f x, f y)
where
f = floor . (/ s)
zoneOfPoint :: Point2 -> (Int,Int)
zoneOfPoint (x,y) = (floorHun x, floorHun y)
zoneOfPoint (V2 x y) = (floorHun x, floorHun y)
cloudZoneOfPoint :: Point2 -> (Int,Int)
cloudZoneOfPoint = sizeZoneOfPoint 20
@@ -33,19 +33,19 @@ crZoneOfPoint :: Point2 -> (Int,Int)
crZoneOfPoint = sizeZoneOfPoint 15
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
x = floorHun x'
y = floorHun y'
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
x = floorHun x'
y = floorHun y'
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
x = floorHun x'
y = floorHun y'
@@ -65,10 +65,10 @@ bresx a b = digitalLine (x-1,y-1) (x'-1,y'-1)
(x',y') = zoneOfPoint b
zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
zoneOfLine (aa,ab) (ba,bb)
zoneOfLine (V2 aa ab) (V2 ba bb)
= nub
. concatMap f
$ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
$ digitalLine (zoneOfPoint (V2 aa ab)) (zoneOfPoint (V2 ba bb))
where
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
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 z p = lookLookups (zoneNearPoint p) z
src/Dodge/Creature/Action/Movement.hs
+5 -5
View File
@@ -51,7 +51,7 @@ crMvForward
:: Float -- ^ Speed
-> Creature
-> Creature
crMvForward speed = crMvBy (speed,0)
crMvForward speed = crMvBy (V2 speed 0)
advanceStepCounter
:: Float -- ^ Speed
@@ -70,7 +70,7 @@ creatureTurn a = crDir +~ a
creatureTurnTo :: Point2 -> Creature -> Creature
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
where
vToTarg = p -.- _crPos cr
@@ -82,18 +82,18 @@ creatureTurnTowardDir
-> Creature
-> Creature
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
= cr & crDir .~ dirToTarget
| isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
| otherwise = cr & crDir -~ turnSpeed
where
vToTarg = rotateV a (1,0)
vToTarg = rotateV a (V2 1 0)
dirToTarget = argV vToTarg
creatureTurnToward :: Point2 -> Float -> Creature -> Creature
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
= cr & crDir .~ dirToTarget
| 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 ++
[ tr . setDepth 0 $ color yellow $ circleSolid 10
, 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
, tr $ arms col cr
, tr $ drawEquipment cr
@@ -42,8 +42,8 @@ basicCrPict col cr w
crad = _crRad cr
targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
tr = uncurry translate (_crPos cr) . rotate (_crDir cr)
trFeet = uncurry translate (_crPos cr) . rotate (_crMvDir cr)
tr = uncurryV translate (_crPos cr) . rotate (_crDir cr)
trFeet = uncurryV translate (_crPos cr) . rotate (_crMvDir cr)
cdir = _crDir cr
bluntDam :: Maybe Point2
bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
@@ -104,7 +104,7 @@ arms col cr
torso :: Color -> Point2 -> Point2 -> Picture
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
]
where
@@ -171,8 +171,8 @@ drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
_ -> blank
circLine :: Float -> Picture
circLine x = line [(0,0),(x,0)]
circLine x = line [(V2 0 0),(V2 x 0)]
picAtCrPos :: Picture -> Creature -> World -> Picture
{-# 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' =
LeadTarget (30,50) `DoActionThen`
LeadTarget (V2 30 50) `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
src/Dodge/Data.hs
+2 -2
View File
@@ -67,7 +67,7 @@ data World = World
, _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [RenderType]
, _randGen :: StdGen
, _mousePos :: !(Float,Float)
, _mousePos :: !Point2
, _testString :: String
, _yourID :: !Int
, _worldEvents :: !(World -> World)
@@ -79,7 +79,7 @@ data World = World
, _foregroundDecorations :: [Polyhedra]
, _foregroundEdgeVerx :: [Point3]
, _corpses :: IM.IntMap (IM.IntMap [Corpse])
, _clickMousePos :: (Float,Float)
, _clickMousePos :: !Point2
, _pathGraph :: ~(Gr Point2 Float)
, _pathGraph' :: ~[(Point2,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.Picture
import Dodge.Picture.Layer
--import Geometry.Data
import Geometry.Data
import Picture
import qualified IntMapHelp as IM
@@ -13,8 +13,8 @@ drawCircleAtFor p t w = w & projectiles %~
IM.insert k Projectile
{ _pjPos = p
, _pjStartPos = p
, _pjVel = (0,0)
, _pjDraw = \_ -> onLayer PtLayer $ uncurry translate p $ color white $ circleSolid 20
, _pjVel = (V2 0 0)
, _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
, _pjID = k
, _pjUpdate = \_ -> pjTimerF t k
}
@@ -25,8 +25,8 @@ drawCircleAtForCol p t col w = w & projectiles %~
IM.insert k Projectile
{ _pjPos = p
, _pjStartPos = p
, _pjVel = (0,0)
, _pjDraw = \_ -> onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 20
, _pjVel = (V2 0 0)
, _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color col $ circleSolid 20
, _pjID = k
, _pjUpdate = \_ -> pjTimerF t k
}
@@ -37,7 +37,7 @@ drawLineForCol ps t col w = w & projectiles %~
IM.insert k Projectile
{ _pjPos = head ps
, _pjStartPos = head ps
, _pjVel = (0,0)
, _pjVel = (V2 0 0)
, _pjDraw = \_ -> onLayer PtLayer $ color col $ lineOfThickness 5 ps
, _pjID = k
, _pjUpdate = \_ -> pjTimerF t k
src/Dodge/Default/Shell.hs
+5 -4
View File
@@ -2,13 +2,14 @@ module Dodge.Default.Shell
where
import Dodge.Data
import Picture
import Geometry.Data
defaultShell :: Projectile
defaultShell = Shell
{ _pjPos = (0,0)
, _pjStartPos = (0,0)
, _pjVel = (0,0)
, _pjAcc = (0,0)
{ _pjPos = (V2 0 0)
, _pjStartPos = (V2 0 0)
, _pjVel = (V2 0 0)
, _pjAcc = (V2 0 0)
, _pjDir = 0
, _pjSpin = 0
, _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.Item.Data
--import Picture
--import Geometry
import Geometry.Data
--import Picture.Texture
import System.Random
@@ -20,10 +20,10 @@ defaultWorld :: World
defaultWorld = World
{ _keys = S.empty
, _mouseButtons = S.empty
, _cameraCenter = (0,0)
, _cameraCenter = (V2 0 0)
, _cameraRot = 0
, _cameraZoom = 1
, _cameraViewFrom = (0,0)
, _cameraViewFrom = (V2 0 0)
, _creatures = IM.empty
, _creaturesZone = IM.empty
, _creatureGroups = IM.empty
@@ -40,7 +40,7 @@ defaultWorld = World
, _floorItems = IM.empty
, _floorTiles = []
, _randGen = mkStdGen 2
, _mousePos = (0,0)
, _mousePos = (V2 0 0)
, _testString = []
, _yourID = 0
, _worldEvents = id
@@ -54,13 +54,13 @@ defaultWorld = World
, _menuLayers = [LevelMenu 1]
, _worldState = M.empty
, _worldTriggers = S.empty
, _clickMousePos = (0,0)
, _clickMousePos = (V2 0 0)
, _pathGraph = Data.Graph.Inductive.Graph.empty
, _pathGraph' = []
, _pathPoints = IM.empty
, _pathInc = M.empty
, _carteDisplay = False
, _carteCenter = (0,0)
, _carteCenter = (V2 0 0)
, _carteZoom = 0.5
, _carteRot = 0
, _lightSources = IM.empty
@@ -68,7 +68,7 @@ defaultWorld = World
, _closeActiveObjects = []
, _seenLocations = IM.fromList
[(0, (_crPos . you, "CURRENT POSITION"))
,(1, (const (0,0) , "START POSITION"))
,(1, (const (V2 0 0) , "START POSITION"))
]
, _selLocation = 0
, _keyConfig = defaultKeyConfigSDL
@@ -89,10 +89,10 @@ defaultDebugFlags = DebugFlags
}
youLight :: TempLightSource
youLight =
TLS { _tlsPos = (0,0,0)
TLS { _tlsPos = (V3 0 0 0)
,_tlsRad = 300
,_tlsIntensity = 0.1
,_tlsUpdate = \w _ -> (w, Just (youLight {_tlsPos = f $ _crPos (you w)}))
}
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
(hp,hv) <- safeHead pvs
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
cols = map (`withAlpha` white) [0,0.05..]
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
updatedWorld = updateV $ set (projectiles . ix pID . pjPos) finalPos
$ set (projectiles .ix pID. pjDraw)
(\ _ -> onLayer PtLayer $ uncurry translate newPos
(\ _ -> onLayer PtLayer $ uncurryV translate newPos
$ rotate dir $ grenadePic time)
$ set (projectiles .ix pID.pjUpdate) (\_ -> moveGrenade (time-1) dir pID) w
pj = _projectiles w IM.! pID
@@ -71,7 +71,7 @@ throwGrenade explosion cr w = setWp $ removePict $ over projectiles addG w
{ _pjPos = p
, _pjStartPos = p
, _pjVel = v
, _pjDraw = \_ -> onLayer PtLayer $ uncurry translate p $ grenadePic 0
, _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ grenadePic 0
, _pjID = i
, _pjUpdate = \_ -> moveGrenade fuseTime dir i
, _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 | magV v' > 6 = 6 *.* normalizeV v'
| otherwise = v'
p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0)
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0)
p' = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr) (0))
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr-4) (0))
| otherwise = p'
dir = argV v
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)
polyhedrasToEdges :: [Polyhedra] -> [Point3]
polyhedrasToEdges = concatMap flat4 . concatMap polyToEdges
polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
-- | connects a collection (tree) of rooms together
generateFromTree :: State StdGen (Tree Room) -> World -> World
@@ -68,7 +68,7 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
plmnts = concatMap _rmPS $ flatten tr
path = pairsToGraph dist pairGraph
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
initializeStaticWalls :: World -> World
@@ -160,7 +160,7 @@ shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
(_rmLinks t)
ts
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
(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
(q:qs) = map (shiftPointBy (p,rot)) ps'
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
PutID _ -> w
--_ -> w
where
p@(px,py) = _psPos ps
p' = (px,py,0)
p@(V2 px py) = _psPos ps
p' = (V3 px py 0)
rot = _psRot ps
-- TODO: remove this typeclass
@@ -192,11 +192,11 @@ placeCr crF p rot = over creatures addCr
crs
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
addLS lss = IM.insert
(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
addDec decs = IM.insert
(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
numBlocks = length blockCenPs
is = [0.. numBlocks - 1]
cornerPoints =
cornerPoints = map toV2
[(-halfBlockWidth,-depth) -- goes anticlockwise around the block
,(-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
where
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'
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))
$ _pathGraph' w
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 ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
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 c btp btr a b w = over buttons (IM.insert bid bt)
$ 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))
$ _pathGraph' w
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 ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
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'
{ _ptDraw = drawBul
, _ptUpdate' = \w -> mvGenBullet w . setVel
, _btVel' = (0,0)
, _btVel' = (V2 0 0)
, _btColor' = col
, _btTrail' = [pos]
, _btPassThrough' = maycid
src/Dodge/Path.hs
+4 -3
View File
@@ -20,6 +20,7 @@ import System.Random
worldGraph :: World -> Point2 -> HS.HashSet Point2
worldGraph w p = HS.unions $ fmap (\q -> HS.fromList $ pointsAlong w p (p +.+ q))
$ map toV2
[(200,0),(-200,0),(0,200),(0,-200)]
pointsAlong :: World -> Point2 -> Point2 -> [Point2]
@@ -68,9 +69,9 @@ makeNode e = (HP.singleton (0,(0,[e])) , [])
tp1,tp2,tp3 :: Point2
tp1 = (0,1)
tp2 = (0,20)
tp3 = (30,40)
tp1 = (V2 0 1)
tp2 = (V2 0 20)
tp3 = (V2 30 40)
f :: Point2 -> [Point2]
f = incidenceToFunction $ pairsToIncidence
src/Dodge/Render.hs
+7 -7
View File
@@ -46,7 +46,7 @@ doDrawing pdata w = do
let rot = _cameraRot w
camzoom = _cameraZoom w
trans = _cameraCenter w
wins = (getWindowX w,getWindowY w)
wins = (V2 (getWindowX w) (getWindowY w))
(wallPointsCol,windowPoints) = wallsAndWindows w
lightPoints = lightsForGloom w
viewFroms = _cameraViewFrom w
@@ -63,7 +63,7 @@ doDrawing pdata w = do
(_foregroundEdgeVerx w)
-- 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)
$ polyToTris (map addC $ screenPolygon w)
++ concatMap polyToGeoRender' (foregroundPics w)
@@ -115,14 +115,14 @@ doDrawing pdata w = do
blend $= Disabled
drawShader (_bloomBlurShader pdata) 4
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
bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
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
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
clearColor $= Color4 0 0 0 0
@@ -163,7 +163,7 @@ doDrawing pdata w = do
drawShader (_fullscreenShader pdata) 4
rds -> do
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)
[a,b,c,d,e,f,g]
bindShaderBuffers [_barrelShader pdata] [1]
@@ -176,7 +176,7 @@ doDrawing pdata w = do
zipWithM_ (>>) bindings $ map bindDrawDist rds
activeTexture $= TextureUnit 0
-- draw overlay
bufferUBO $ isoMatrix 0 1 (0,0) (2,2)
bufferUBO $ isoMatrix 0 1 (V2 0 0) (V2 2 2)
depthFunc $= Just Always
depthMask $= Disabled
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 w ipos it = case it ^? wpAmmo . amParamSel of
Nothing -> winScale w $ zDraw sp (155- hw, hh - 77.5)
Just jpos -> winScale w $ zDraw sp (155 - hw, hh - (20 * fromIntegral jpos + 77.5))
Nothing -> winScale w $ zDraw sp (V2 (155- hw) ( hh - 77.5))
Just jpos -> winScale w $ zDraw sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
where
hh = halfHeight 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 col iPos w
@@ -84,7 +84,7 @@ mCurs it w = case it ^? wpAmmo . amParamSel of
y = 155
zDraw :: Point2 -> Point2 -> Picture
zDraw (x,y) (a,b) = line
zDraw (V2 x y) (V2 a b) = line $ map toV2
[(x,y)
,(0.5 * (x+a), y)
,(0.5 * (x+a), b)
@@ -97,7 +97,7 @@ pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj
displayMidList :: World -> [String] -> String -> [Picture]
displayMidList w strs s =
invHead w s
++ renderListAt (150,-60) (map (,white) strs) w
++ renderListAt (V2 (150) (-60)) (map (,white) strs) w
invHead :: World -> String -> [Picture]
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 = renderListAt (0,0)
displayListTopLeft = renderListAt (V2 0 0)
renderListAt :: Point2 -> [(String,Color)] -> World -> [Picture]
renderListAt (tx,ty) scols w =
renderListAt (V2 tx ty) scols w =
map (winScale w) $ zipWith
(translate (tx + 15-halfWidth w))
( 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
locPoss = map (cartePosToScreen wrld . ($ wrld) . fst) . IM.elems . _seenLocations $ wrld
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.5 0.045 0.005
, bline 0.5 0.035 0.002
] --cheapo antialiasing
where
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 w = map (g . f) [(1::Int)..]
where
f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) )
g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w)
f i = (V2 ( 15 - halfWidth w ) ( halfHeight w - (20 * fromIntegral i)) )
g (V2 x y) = (V2 (2*x / getWindowX w) ( 2*y / getWindowY w))
displayListEndCoords :: World -> [String] -> [Point2]
displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
where
f :: Int -> Point2
f i = ( 15 - halfWidth w , 2.5 + halfHeight w - (20 * fromIntegral i) )
g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w)
f i = (V2 ( 15 - halfWidth w ) ( 2.5 + halfHeight w - (20 * fromIntegral i)) )
g (V2 x y) = (V2 (2*x / getWindowX w) ( 2*y / getWindowY w))
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
@@ -202,18 +202,16 @@ closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText
objPos obj = case obj of Left flit -> _flItPos flit
Right bt -> _btPos bt
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
itScreenPos <- mayScreenPos
theText <- fmap (snd . colAndText) mayObj
let textWidth = 9 * fromIntegral (length theText)
let col = maybe white (_itInvColor . _flIt) mayIt
let p = (textWidth + xtran 0 + pushout - halfWidth w
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
)
let p' = ( pushout - halfWidth w + 130
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
)
let p = V2 (textWidth + xtran 0 + pushout - halfWidth w)
( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
let p' = V2 ( pushout - halfWidth w + 130)
( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
return $ flip thickLineCol (1 / halfWidth w)
[(itScreenPos, withAlpha 0 col)
,(sc p' , col)
@@ -240,10 +238,10 @@ openCursorAt
openCursorAt wth col xoff yoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
$ lineCol
[(( wth,12.5) ,withAlpha 0 col)
,(( 0,12.5) ,col)
,(( 0,-7.5) ,col)
,(( wth,-7.5) ,withAlpha 0 col)
[((V2 wth 12.5) ,withAlpha 0 col)
,((V2 0 12.5) ,col)
,((V2 ( 0) (-7.5)) ,col)
,((V2 ( wth) (-7.5)) ,withAlpha 0 col)
]
cursorAt
:: 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)
. color col
$ line
[( wth,12.5)
,( 0,12.5)
,( 0,-7.5)
,( wth,-7.5)
,( wth,12.5)
[(V2 wth 12.5)
,(V2 0 12.5)
,(V2 ( 0) (-7.5))
,(V2 ( wth) (-7.5))
,(V2 wth 12.5)
]
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 w =
scale (2 /getWindowX w) (2/ getWindowY w)
. uncurry translate (_mousePos w)
. uncurryV translate (_mousePos w)
. 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 _ = blank
@@ -63,12 +63,12 @@ testPic _ = blank
crDraw :: World -> Creature -> Picture
crDraw w c = _crPict c c w
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 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 c = uncurry translate (_clPos c) (_clPict c c)
clDraw c = uncurryV translate (_clPos c) (_clPict c c)
wallFloorsToDraw :: World -> [Wall]
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
@@ -88,15 +88,15 @@ drawWallFloor wl = if _wlIsSeeThrough wl
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
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
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 r p = color white
. uncurry translate p
. uncurryV translate p
$ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
outsideScreenPolygon :: World -> [Point2]
@@ -106,10 +106,10 @@ outsideScreenPolygon w = [tr,tl,bl,br]
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
| otherwise = error "Trying to set screen zoom to zero"
scTran p = p +.+ _cameraCenter w
tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w)
tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w)
br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w))
bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w))
tr = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) ( 3* halfHeight w)
tl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) ( 3* halfHeight w)
br = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) (- (3* halfHeight w))
bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w))
wallShadowsToDraw :: World -> [Wall]
wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
@@ -163,10 +163,10 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] +
. makeLoopPairs $ screenPolygon w
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 flit = uncurry translate (_flItPos flit)
drawItem flit = uncurryV translate (_flItPos flit)
$ rotate (_flItRot flit) (_itFloorPict (_flIt flit))
@@ -212,14 +212,14 @@ wallsAndWindows w
(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w
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 vals0 = go vals0 0
where
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 1) b
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.Default.Room
import Geometry
import Geometry.Data
import Tile
import Data.Bifunctor
{- | First exit due north, two other exits at angles next to this.
Entrance from south. -}
corridor :: Room
corridor = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (20,60) . fst) lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS = []
, _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmFloor = [oTile poly 2]
}
where
poly = rectNSWE 80 0 0 40
lnks =
lnks = map (first toV2)
[((20,70) ,0)
,((20,70), pi/6)
,((20,70), negate $ pi/6)
@@ -32,12 +35,12 @@ corridorDebug = defaultRoom
--, [ (0,0), (0,20) , (20,10)]
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (20,60) . fst) lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS = []
, _rmBound = [ rectNSWE 50 30 0 40 ]
}
where
lnks =
lnks = map (first toV2)
[((20,70) ,0)
,((20,70), pi/6)
,((20,70), negate $ pi/6)
@@ -52,10 +55,10 @@ corridorN = defaultRoom
, _rmPS = []
, _rmBound = [ rectNSWE 50 30 0 40 ]
}
where lnks = [((20,70) ,0)
,((20,10) ,pi)
where lnks = [((V2 20 70) ,0)
,((V2 20 10) ,pi)
]
pth = doublePair ((20,70),(20,10))
pth = doublePair ((V2 20 70),(V2 20 10))
tEast :: Room
tEast = defaultRoom
@@ -63,26 +66,28 @@ tEast = defaultRoom
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60) . fst) lnks
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPS = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
}
where lnks = [(( 30,60),-pi/2)
,((-30,60),pi/2)
,((0,10),pi)
]
where
lnks = map (first toV2)
[(( 30,60),-pi/2)
,((-30,60),pi/2)
,((0,10),pi)
]
tWest :: Room
tWest = defaultRoom
{ _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60) . fst) lnks
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPS = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
}
where
lnks =
lnks = map (first toV2)
[((-30,60),pi/2)
,(( 30,60),-pi/2)
,((0,10),pi)
src/Dodge/Room/Door.hs
+4 -4
View File
@@ -15,13 +15,13 @@ door :: Room
door = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _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)
, _rmPS = [sPS (0,20) 0 $ PutAutoDoor (0,0) (40,0)]
, _rmPS = [sPS (V2 0 20) 0 $ PutAutoDoor (V2 0 0) (V2 40 0)]
, _rmBound = []
}
where lnks = [((20,35),0)
,((20, 5),pi)
where lnks = [((V2 20 35),0)
,((V2 20 5),pi)
]
src/Dodge/Room/Foreground.hs
+11 -11
View File
@@ -20,9 +20,9 @@ highDiagonalMesh
-> Float -- ^ vertical distance between lines
-> Picture
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
pc = pb +.+ w *.* normalizeV (vNormal (pb -.- pa))
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)
highPipe :: Float -> Point2 -> Point2 -> [Polyhedra]
highPipe h x@(xx,xy) y =
[ Polyhedron . map (map ( (,orange) . (+.+.+ (xx,xy,h))))
$ boxABC (a,b,0) (a',b',0) (0,0,5)
highPipe h x@(V2 xx xy) y =
[ Polyhedron . map (map ( (,orange) . (+.+.+ (V3 xx xy h))))
$ boxABC (V3 a b 0) (V3 a' b' 0) (V3 0 0 5)
]
where
(a,b) = y -.- x
(a',b') = 10 *.* normalizeV (vNormal (a,b))
(V2 a b) = y -.- x
(V2 a' b') = 10 *.* normalizeV (vNormal (V2 a b))
girderZ :: Float -> Point2 -> Point2 -> Picture
girderZ w x y = setDepth 50 $ color red $ pictures $
[ thickLine [xt,yt] 3
, thickLine [xb,yb] 3
]
++ map (flip thickLine 3 . flat2) ls
++ map (flip thickLine 3 . tflat2) ls
where
n = w *.* normalizeV (vNormal $ y -.- x)
xb = x +.+ n
@@ -78,8 +78,8 @@ girderV col w x y = setDepth 50 $ color col $ pictures $
[ thickLine [xt,yt] 3
, thickLine [xb,yb] 3
]
++ map (flip thickLine 3 . flat2) as'
++ map (flip thickLine 3 . flat2) bs'
++ map (flip thickLine 3 . tflat2) as'
++ map (flip thickLine 3 . tflat2) bs'
where
n = w *.* normalizeV (vNormal $ y -.- x)
xb = x +.+ n
@@ -97,7 +97,7 @@ girder col w x y = pictures $
[ thickLine [xt,yt] 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]
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 l r
= shiftRoomBy l
. shiftRoomBy ((0,0) -.- rotateV (pi-a) p , 0)
$ shiftRoomBy ((0,0) ,pi-a)
. shiftRoomBy ((V2 0 0) -.- rotateV (pi-a) p , 0)
$ shiftRoomBy ((V2 0 0) ,pi-a)
r
where
(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
isCam :: Bool
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
| isCam = camCenter
| otherwise = ypos
@@ -70,7 +70,7 @@ updateScopeZoom w
. itAttachment . _Just %~ updateScope
where scppoint = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. 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
zoomSpeed :: Float
@@ -158,18 +158,18 @@ farWallDist :: Point2 -> World -> Float
{-# INLINE farWallDist #-}
farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (verticalMax+50) )
where
horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays
verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays
horizontalMax = maximum $ map (h' (V2 1 0)) rRays ++ map (h' (V2 (-1) (0))) lRays
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 $ _walls w
wos = wallsOnScreen w
h p = fromMaybe p $ collidePointIndirect cpos p wos
h' x p = dotV (rotateV camRot x) (p -.- cpos)
camRot = _cameraRot w
rRays = rotF [( maxViewDistance,y) | y <- zs]
lRays = rotF [(-maxViewDistance,y) | y <- zs]
tRays = rotF [(y, maxViewDistance) | y <- zs]
bRays = rotF [(y,-maxViewDistance) | y <- zs]
rRays = rotF [(V2 ( maxViewDistance) (y)) | y <- zs]
lRays = rotF [(V2 (-maxViewDistance) (y)) | y <- zs]
tRays = rotF [(V2 (y) ( maxViewDistance)) | y <- zs]
bRays = rotF [(V2 (y) (-maxViewDistance)) | y <- zs]
rotF = map (h . (+.+) cpos . rotateV (_cameraRot w))
zs = takeWhile (< maxViewDistance) [-maxViewDistance,negate $ 0.75*maxViewDistance..]
maxViewDistance = 800
src/Dodge/WorldEvent/Cloud.hs
+2 -2
View File
@@ -3,7 +3,7 @@ module Dodge.WorldEvent.Cloud
import Dodge.Data
import Dodge.Base
--import Geometry
import Geometry.Data
import Picture
--import qualified IntMapHelp as IM
@@ -14,7 +14,7 @@ makeCloudAt rad t drawFunc p w = w & clouds %~ (theCloud :)
where
theCloud = Cloud
{ _clPos = p
, _clVel = (0,0)
, _clVel = (V2 0 0)
, _clPict = drawFunc
, _clRad = rad
, _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
(wa,wb) = _wlLine wall
((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
where
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
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
$ circleSolidCol (withAlpha 0 col) (withAlpha alphax col) 30
, _ptUpdate' = ptTimer' 1
@@ -105,7 +105,7 @@ muzzleFlashAt p = over particles (muzzleFlashPt p : )
. glareAt 2 10 5 (withAlpha 0.5 white) 20 30 p
muzzleFlashPt :: Point2 -> Particle
muzzleFlashPt (x,y) = Particle
muzzleFlashPt (V2 x y) = Particle
{ _ptDraw = const $ setDepth 0
. setLayer 2
. translate x y
src/Dodge/WorldEvent/SpawnParticle.hs
+29 -29
View File
@@ -59,28 +59,28 @@ drawFlame rotd pt = thePic
ep = _btPos' pt
thePic = pictures
[ glow
, aPic 3 prot2 18 (scaleChange + 1,2) red
, aPic 4 prot 19 (scaleChange + 0.5,1.5) orange
, aPic 5 prot3 20 (scaleChange,1) white
, aPic 3 prot2 18 (V2 (scaleChange + 1) (2)) red
, aPic 4 prot 19 (V2 (scaleChange + 0.5) (1.5)) orange
, aPic 5 prot3 20 (V2 (scaleChange) (1)) white
]
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
. setDepth depth
. uncurry translate (offset ep)
. uncurryV translate (offset ep)
. rotate (pi * 0.5 + argV rotd)
. scale scalex scaley
. color col
$ 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
time = _btTimer' pt
scaleChange
| time < 80 = 3
| otherwise = 3 - (fromIntegral time - 80) * 0.2
prot p' = p' +.+ rotateV (fromIntegral time) (0,1)
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (0,1)
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2)
prot p' = p' +.+ rotateV (fromIntegral time) (V2 0 1)
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (V2 0 1)
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (V2 0 2)
{- TODO: add generalised area damage particles/hiteffects. -}
moveFlame
@@ -134,7 +134,7 @@ makeFlameletTimed
-> Int -- ^ Timer
-> 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
& particles %~ (theFlamelet :)
where
@@ -143,7 +143,7 @@ makeFlameletTimed (x,y) z vel maycid size time w = w
, _ptUpdate' = moveFlamelet
, _btVel' = vel
, _btColor' = red
, _btPos' = (x,y)
, _btPos' = (V2 x y)
, _btPassThrough' = maycid
, _btWidth' = size
, _btTimer' = time
@@ -170,16 +170,16 @@ drawFlameletZ rot pt = pictures
size = _btWidth' pt
siz2 = size + 0.2
time = _btTimer' pt
glow = setDepth 19 $ uncurry translate ep
glow = setDepth 19 $ uncurryV translate ep
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
piu = setDepth (z + 20)
. uncurry translate ep
. uncurryV translate ep
. color (dark red)
. rotate (negate (rot - 0.1 * fromIntegral time))
. scale s1 s1
$ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
pi2 = setDepth (z + 20)
. uncurry translate ep
. uncurryV translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red)
)
@@ -187,13 +187,13 @@ drawFlameletZ rot pt = pictures
. scale s2 s2
$ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
pic = setDepth (z + 20)
. uncurry translate ep
. uncurryV translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
white (dark red)
)
. rotate (negate ( 0.1 * fromIntegral time + rot))
. 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
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
s2 = 0.5 * (sc + s1)
@@ -210,17 +210,17 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
size = _btWidth' pt
siz2 = size + 0.2
time = _btTimer' pt
glow = setDepth 19 $ uncurry translate ep
glow = setDepth 19 $ uncurryV translate ep
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
piu = setDepth 20
. uncurry translate ep
. uncurryV translate ep
. color (dark red)
. rotate (negate (rot - 0.1 * fromIntegral time))
. scale s1 s1
. polygon
$ rectNSWE siz2 (-siz2) (-siz2) siz2
pi2 = setDepth 20.2
. uncurry translate ep
. uncurryV translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red)
)
@@ -229,13 +229,13 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
. polygon
$ rectNSWE siz2 (-siz2) (-siz2) siz2
pic = setDepth 20.4
. uncurry translate ep
. uncurryV translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
white (dark red)
)
. rotate (negate ( 0.1 * fromIntegral time + rot))
. 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
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
s2 = 0.5 * (sc + s1)
@@ -392,7 +392,7 @@ crOrWallSensitive
-> World
-> Either3 Creature Point2 Point2
crOrWallSensitive p dir wlAttract w =
fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
. listToMaybe
. sortBy (compare `on` g)
$ catMaybes [cr,wlp]
@@ -405,7 +405,7 @@ crOrWallSensitive p dir wlAttract w =
( fmap fst
. (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
. (+.+) p
. (\d -> rotateV d (100,0))
. (\d -> rotateV d (V2 100 0))
. (+ dir)
. (* 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.
Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'. -}
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)
$ catMaybes [cr,wlp]
where
@@ -431,7 +431,7 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
( fmap fst
. (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
. (+.+) p
. (\d -> rotateV d (100,0))
. (\d -> rotateV d (V2 100 0))
. (+) dir
)
[-(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'
{ _ptDraw = drawBul
, _ptUpdate' = mvGenBullet
, _btVel' = rotateV dir (5,0)
, _btVel' = rotateV dir (V2 5 0)
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
@@ -459,7 +459,7 @@ createSpark time colid pos dir maycid w
, _btTimer' = time
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff
}
pos' = pos +.+ rotateV dir (5,0)
pos' = pos +.+ rotateV dir (V2 5 0)
sparkEff bt p cr
= creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
where
@@ -472,7 +472,7 @@ createSparkCol time col pos dir maycid w
spark = Bul'
{ _ptDraw = drawBul
, _ptUpdate' = mvGenBullet
, _btVel' = rotateV dir (5,0)
, _btVel' = rotateV dir (V2 5 0)
, _btColor' = col
, _btTrail' = [pos]
, _btPassThrough' = maycid
@@ -480,7 +480,7 @@ createSparkCol time col pos dir maycid w
, _btTimer' = time
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff
}
pos' = pos +.+ rotateV dir (5,0)
pos' = pos +.+ rotateV dir (V2 5 0)
sparkEff bt p cr
= creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
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.Data
, module Geometry.Data
, module Geometry.Intersect
, module Geometry.Bezier
, module Geometry.Vector
@@ -228,6 +228,10 @@ angleBetween v1 v2 = argV v1 - argV v2
-- | Return a list containing two copies of a pair.
doublePair :: (a,a) -> [(a,a)]
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
-- consecutive pair of points.
polysIntersect :: [Point2] -> [Point2] -> Bool
src/Geometry/Data.hs
+7
View File
@@ -9,6 +9,8 @@ module Geometry.Data
, toV3
, toV4
, uncurryV
, fstV2
, sndV2
)
where
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 f (V2 x y) = f x y
fstV2 :: V2 a -> a
fstV2 (V2 x _) = x
sndV2 :: V2 a -> a
sndV2 (V2 _ x) = x