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

Move main to allow for new executables

Browse Source
This commit is contained in:
jgk
2021-08-11 17:54:48 +02:00
parent b74bb45a4c
commit 4bbe5d0cf1
64 changed files with 521 additions and 345 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+4 -4
View File
@@ -420,10 +420,10 @@ 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)) (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))
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)
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)) $ map toV2 [(1,0),(0,1),(-1,0),(0,-1)]
= all (flip (canSeePoint i) w . (\p -> targPos +.+ radius *.* p) . 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)) $ map toV2 [(1,0),(0,1),(-1,0),(0,-1)]
= any (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p) . 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)) $ map toV2 [(1,0),(0,1),(-1,0),(0,-1)]
= all (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p) . toV2) [(1,0),(0,1),(-1,0),(0,-1)]
where
cr = _creatures w IM.! toID
cpos = _crPos cr
src/Dodge/Creature.hs
+2 -2
View File
@@ -140,8 +140,8 @@ addArmour = over crInv insarmour
ID 0. -}
startCr :: Creature
startCr = defaultCreature
{ _crPos = (V2 0 0)
, _crOldPos = (V2 0 0)
{ _crPos = V2 0 0
, _crOldPos = V2 0 0
, _crDir = pi/2
, _crMvDir = pi/2
, _crID = 0
src/Dodge/Creature/Action.hs
+2 -2
View File
@@ -68,8 +68,8 @@ blinkAction cr w = soundOnce teleSound
where
distR = 120
distortionBulge =
[(p3,p3 +.+ (V2 distR 0), p3 +.+ (V2 0 distR),0.1)
,(cpos,cpos +.+ (V2 distR 0), cpos +.+ (V2 0 distR),1.9)
[(p3,p3 +.+ V2 distR 0, p3 +.+ V2 0 distR,0.1)
,(cpos,cpos +.+ V2 distR 0, cpos +.+ V2 0 distR,1.9)
]
cid = _crID cr
p1 = mouseWorldPos w
src/Dodge/Creature/Action/Movement.hs
+3 -3
View File
@@ -70,7 +70,7 @@ creatureTurn a = crDir +~ a
creatureTurnTo :: Point2 -> Creature -> Creature
creatureTurnTo p cr
| vToTarg == (V2 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,7 +82,7 @@ creatureTurnTowardDir
-> Creature
-> Creature
creatureTurnTowardDir a turnSpeed cr
| vToTarg == (V2 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
@@ -93,7 +93,7 @@ creatureTurnTowardDir a turnSpeed cr
creatureTurnToward :: Point2 -> Float -> Creature -> Creature
creatureTurnToward p turnSpeed cr
| vToTarg == (V2 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/Inanimate.hs
+2 -2
View File
@@ -36,7 +36,7 @@ lamp h = defaultInanimate
}
lampPic :: Float -> Picture
lampPic h = pictures
[ setLayer 0 $ pictures . map (helpPoly3D . map ((, blue) . (-.-.- (V3 2.5 2.5 0)))) $ boxXYZ 5 5 (h-1)
[ setLayer 0 $ pictures . map (helpPoly3D . map ((, blue) . (-.-.- V3 2.5 2.5 0))) $ boxXYZ 5 5 (h-1)
, setLayer 1 $ setDepth h $ color white $ circleSolid 3
]
@@ -56,7 +56,7 @@ updateLamp h i = unrandUpdate handleLS internalUpdate
| otherwise = w & lightSources . ix i . lsPos .~ f cPos
where
cPos = _crPos cr
f (V2 x y) = (V3 x y h)
f (V2 x y) = V3 x y h
internalUpdate cr
| _crHP cr < 0 = Nothing
| otherwise = Just $ doDamage cr
src/Dodge/Creature/Picture.hs
+3 -3
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) (V2 (0) (-crad)) (V2 0 crad)
, tr $ torso (light4 col) (V2 0 (-crad)) (V2 0 crad)
, trFeet $ feet cr
, tr $ arms col cr
, tr $ drawEquipment cr
@@ -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 ((V2 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,7 +171,7 @@ drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
_ -> blank
circLine :: Float -> Picture
circLine x = line [(V2 0 0),(V2 x 0)]
circLine x = line [V2 0 0,V2 x 0]
picAtCrPos :: Picture -> Creature -> World -> Picture
{-# INLINE picAtCrPos #-}
src/Dodge/Creature/PistolCrit.hs
+2 -2
View File
@@ -93,7 +93,7 @@ chooseMovement' cr w = takeOneWeighted [chargeProb,retreatProb,strafeProb,strafe
`DoActionThen`
3
`DoReplicate`
ImpulsesList (replicate 9 [Move (V2 (0) (-3))] ++ [[Move (V2 (0) (-3)),UseItem]])
ImpulsesList (replicate 9 [Move (V2 0 (-3))] ++ [[Move (V2 0 (-3)),UseItem]])
yposl = ypos -.- 100 *.* vNormal (normalizeV $ ypos -.- cpos)
yposr = ypos +.+ 100 *.* vNormal (normalizeV $ ypos -.- cpos)
@@ -103,7 +103,7 @@ retreatActions tcr cr =
`DoImpulsesAlongside`
3
`DoReplicate`
ImpulsesList (replicate 9 [Move (V2 (-3) (0))] ++ [[UseItem]])
ImpulsesList (replicate 9 [Move (V2 (-3) 0)] ++ [[UseItem]])
where
cpos = _crPos cr
tpos = _crPos tcr
src/Dodge/Creature/SentinelAI.hs
+4 -4
View File
@@ -39,7 +39,7 @@ sentinelAI = sentinelExtraWatchUpdate
DoImpulses [ChangeStrategy WatchAndWait]
, AimAtCloseSlow
{ _targetID = tcid
, _targetSeenAt = (V2 0 0) -- hack
, _targetSeenAt = V2 0 0 -- hack
, _aimSpeed = 0.2
, _slowAimSpeed = 0.01
, _slowAimAngle = pi/8
@@ -72,7 +72,7 @@ sentinelFireType f = performActionsR
drawwp = DoActionIfElse NoAction crIsAiming (DoActionThen drawWeapon (WaitThen 50 NoAction))
aiming = AimAtCloseSlow
{ _targetID = 0
, _targetSeenAt = (V2 0 0) -- hack
, _targetSeenAt = V2 0 0 -- hack
, _aimSpeed = 0.2
, _slowAimSpeed = 0.01
, _slowAimAngle = pi/8
@@ -104,7 +104,7 @@ shootAtAdvance tcid =
DoImpulses [ChangeStrategy WatchAndWait]
, AimAtCloseSlow
{ _targetID = tcid
, _targetSeenAt = (V2 0 0) -- hack
, _targetSeenAt = V2 0 0 -- hack
, _aimSpeed = 0.2
, _slowAimSpeed = 0.01
, _slowAimAngle = pi/8
@@ -125,7 +125,7 @@ shootAtWhileContinueTime tcid _ _ = StrategyActions (ShootAt tcid)
DoImpulses [ChangeStrategy WatchAndWait]
, AimAtCloseSlow
{ _targetID = tcid
, _targetSeenAt = (V2 0 0) -- hack
, _targetSeenAt = V2 0 0 -- hack
, _aimSpeed = 0.2
, _slowAimSpeed = 0.01
, _slowAimAngle = pi/8
src/Dodge/Creature/State.hs
+1 -1
View File
@@ -78,7 +78,7 @@ Given a creature and a velocity, applies friction to that creature and evaluates
velocity to carry across frames.
-}
crFriction :: Creature -> Point2 -> Point2
crFriction _ _ = (V2 0 0)
crFriction _ _ = V2 0 0
doDamage :: Creature -> Creature
doDamage cr = set (crState . crDamage) []
src/Dodge/Creature/YourControl.hs
+7 -7
View File
@@ -37,7 +37,7 @@ wasdWithAiming w speed i cr
| otherwise = theTurn $ theMovement cr
where
theMovement
| movDir == (V2 0 0) = id
| movDir == V2 0 0 = id
| otherwise = crMvAbsolute (speed *.* movAbs) . set crMvDir dir
theTurn cr' = creatureTurnTowardDir (_crMvDir cr') 0.2 cr'
movDir = wasdDir w
@@ -53,11 +53,11 @@ wasdWithAiming w speed i cr
wasdM :: World -> SDL.Scancode -> Point2
wasdM w scancode
| scancode == moveUpKey (_keyConfig w) = ( V2 (0) ( 1))
| scancode == moveDownKey (_keyConfig w) = (V2 ( 0) (-1))
| scancode == moveRightKey (_keyConfig w) = (V2 ( 1) ( 0))
| scancode == moveLeftKey (_keyConfig w) = (V2 (-1) ( 0))
wasdM _ _ = (V2 0 0)
| scancode == moveUpKey (_keyConfig w) = V2 0 1
| scancode == moveDownKey (_keyConfig w) = V2 0 (-1)
| scancode == moveRightKey (_keyConfig w) = V2 1 0
| scancode == moveLeftKey (_keyConfig w) = V2 (-1) 0
wasdM _ _ = V2 0 0
wasdDir :: World -> Point2
wasdDir w = foldr ((+.+) . wasdM w) (V2 0 0) $ _keys w
@@ -65,7 +65,7 @@ wasdDir w = foldr ((+.+) . wasdM w) (V2 0 0) $ _keys w
wasdComp :: S.Set SDL.Scancode -> World -> (Point2,Maybe Float)
wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (V2 0 0) ks
where
f (V2 0 0) = ((V2 0 0), Nothing)
f (V2 0 0) = (V2 0 0, Nothing)
f p = (errorNormalizeV 46 p, Just $ argV p)
{- | Set posture according to mouse presses. -}
src/Dodge/Data.hs
+1 -1
View File
@@ -503,7 +503,7 @@ data ForceField = FF
, _ffDeflect :: Maybe (StdGen -> Point2 -> ForceField -> (Point2,StdGen))
, _ffState :: FFState
}
data FFState = FFDestroyable { _ffsHP :: Int }
newtype FFState = FFDestroyable { _ffsHP :: Int }
data ActionPlan
= Inanimate
src/Dodge/Debug.hs
+3 -3
View File
@@ -13,7 +13,7 @@ drawCircleAtFor p t w = w & projectiles %~
IM.insert k Projectile
{ _pjPos = p
, _pjStartPos = p
, _pjVel = (V2 0 0)
, _pjVel = V2 0 0
, _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
, _pjID = k
, _pjUpdate = \_ -> pjTimerF t k
@@ -25,7 +25,7 @@ drawCircleAtForCol p t col w = w & projectiles %~
IM.insert k Projectile
{ _pjPos = p
, _pjStartPos = p
, _pjVel = (V2 0 0)
, _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 = (V2 0 0)
, _pjVel = V2 0 0
, _pjDraw = \_ -> onLayer PtLayer $ color col $ lineOfThickness 5 ps
, _pjID = k
, _pjUpdate = \_ -> pjTimerF t k
src/Dodge/Default.hs
+9 -9
View File
@@ -22,9 +22,9 @@ import Data.List
defaultCreature :: Creature
defaultCreature = Creature
{ _crPos = (V2 0 0)
, _crOldPos = (V2 0 0)
, _crVel = (V2 0 0)
{ _crPos = V2 0 0
, _crOldPos = V2 0 0
, _crVel = V2 0 0
, _crDir = 0
, _crMvDir = 0
, _crID = 1
@@ -127,7 +127,7 @@ applyIndividualDamage (PushDam amount pback) cr
applyIndividualDamage dt cr
= ( id , over crHP (\hp -> hp - _dmAmount dt) cr )
defaultFlIt :: FloorItem
defaultFlIt = FlIt {_flItRot=0,_flIt = defaultIt, _flItPos = (V2 0 0), _flItID = 0}
defaultFlIt = FlIt {_flItRot=0,_flIt = defaultIt, _flItPos = V2 0 0, _flItID = 0}
defaultIt :: Item
defaultIt = Consumable
{ _itIdentity = Medkit25
@@ -147,7 +147,7 @@ defaultIt = Consumable
defaultButton :: Button
defaultButton = Button
{ _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (V2 0 0)
, _btPos = V2 0 0
, _btRot = 0
, _btEvent = \b w ->
set (buttons . ix (_btID b) . btPict) (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10))
@@ -159,9 +159,9 @@ defaultButton = Button
}
defaultPT :: Projectile
defaultPT = Projectile
{ _pjPos = (V2 0 0)
, _pjStartPos = (V2 0 0)
, _pjVel = (V2 0 0)
{ _pjPos = V2 0 0
, _pjStartPos = V2 0 0
, _pjVel = V2 0 0
, _pjDraw = const blank
, _pjID = 0
, _pjUpdate = const id
@@ -169,7 +169,7 @@ defaultPT = Projectile
defaultPP :: PressPlate
defaultPP = PressPlate
{ _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright blue) $ circleSolid 5
, _ppPos = (V2 0 0)
, _ppPos = V2 0 0
, _ppRot = 0
, _ppEvent = const id
, _ppID = -1
src/Dodge/Default/Shell.hs
+4 -4
View File
@@ -6,10 +6,10 @@ import Geometry.Data
defaultShell :: Projectile
defaultShell = Shell
{ _pjPos = (V2 0 0)
, _pjStartPos = (V2 0 0)
, _pjVel = (V2 0 0)
, _pjAcc = (V2 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/Wall.hs
+6 -6
View File
@@ -7,7 +7,7 @@ import Geometry.Data
{- Indestructible wall. -}
defaultWall :: Wall
defaultWall = Wall
{ _wlLine = ((V2 0 0),(V2 50 0))
{ _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0
, _wlColor = greyN 0.6
, _wlSeen = False
@@ -16,7 +16,7 @@ defaultWall = Wall
{- Indestructible see-through wall. -}
defaultCrystalWall :: Wall
defaultCrystalWall = Wall
{ _wlLine = ((V2 0 0),(V2 50 0))
{ _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0
, _wlColor = withAlpha 0.5 aquamarine
, _wlSeen = False
@@ -26,26 +26,26 @@ defaultCrystalWall = Wall
Pathable. -}
defaultAutoDoor :: Wall
defaultAutoDoor = Door
{ _wlLine = ((V2 0 0),(V2 50 0))
{ _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = True
, _drPositions = DS.singleton ((V2 0 0),(V2 50 0))
, _drPositions = DS.singleton (V2 0 0,V2 50 0)
}
{-
Non-pathable door.
-}
defaultDoor :: Wall
defaultDoor = Door
{ _wlLine = ((V2 0 0),(V2 50 0))
{ _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
, _drPositions = DS.singleton ((V2 0 0),(V2 50 0))
, _drPositions = DS.singleton (V2 0 0,V2 50 0)
}
src/Dodge/Default/World.hs
+7 -7
View File
@@ -20,10 +20,10 @@ defaultWorld :: World
defaultWorld = World
{ _keys = S.empty
, _mouseButtons = S.empty
, _cameraCenter = (V2 0 0)
, _cameraCenter = V2 0 0
, _cameraRot = 0
, _cameraZoom = 1
, _cameraViewFrom = (V2 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 = (V2 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 = (V2 0 0)
, _clickMousePos = V2 0 0
, _pathGraph = Data.Graph.Inductive.Graph.empty
, _pathGraph' = []
, _pathPoints = IM.empty
, _pathInc = M.empty
, _carteDisplay = False
, _carteCenter = (V2 0 0)
, _carteCenter = V2 0 0
, _carteZoom = 0.5
, _carteRot = 0
, _lightSources = IM.empty
@@ -89,10 +89,10 @@ defaultDebugFlags = DebugFlags
}
youLight :: TempLightSource
youLight =
TLS { _tlsPos = (V3 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 (V2 x y) = (V3 x y 0)
f (V2 x y) = V3 x y 0
src/Dodge/Event/Keyboard.hs
+1 -1
View File
@@ -100,7 +100,7 @@ dropLight :: World -> World
dropLight w = placeLS ls dec pos 0 w
where --(rot, g) = randomR (-pi,pi) $ _randGen w
(V2 x y) = _crPos (you w)
pos = (V3 x y 0)
pos = V3 x y 0
ls = lightAt pos 0
dec = onLayer PtLayer $ color white $ circleSolid 8
src/Dodge/Initialisation.hs
+4 -3
View File
@@ -27,7 +27,7 @@ firstWorld = do
initialWorld :: World
initialWorld = defaultWorld
{ _keys = S.empty
, _cameraCenter = (V2 0 0)
, _cameraCenter = V2 0 0
, _cameraRot = 0
, _cameraZoom = 10
, _creatures = IM.fromList [(0,startCr)]
@@ -36,10 +36,11 @@ initialWorld = defaultWorld
, _forceFields = IM.empty
, _floorItems = IM.empty
, _randGen = mkStdGen 2
, _mousePos = (V2 0 0)
, _mousePos = V2 0 0
, _testString = []
, _yourID = 0
, _worldEvents = soundOncePos foamSprayFadeOutSound (V2 0 0) . foldr ((.) . makeStartCloudAt) id [(V2 x y) | x <- [-5,-3..5] , y <- [-5,-3..5]]
, _worldEvents = soundOncePos foamSprayFadeOutSound (V2 0 0) . foldr ((.) . makeStartCloudAt) id
[V2 x y | x <- [-5,-3..5] , y <- [-5,-3..5]]
, _pressPlates = IM.empty
, _buttons = IM.empty
, _soundQueue = []
src/Dodge/Item/Weapon.hs
+5 -5
View File
@@ -610,7 +610,7 @@ retireRemoteRocket itid t pjid w = setScope w
retireRemoteBomb :: Int -> Int -> Int -> World -> World
retireRemoteBomb itid 0 pjid w = w
& pointToItem (_itemPositions w IM.! itid) %~
( (itAttachment . _Just . scopePos .~ (V2 0 0))
( (itAttachment . _Just . scopePos .~ V2 0 0)
. (itZoom .~ defaultItZoom)
. (itUse .~ (\_ -> hammerCheck throwRemoteBomb))
)
@@ -754,7 +754,7 @@ fireRemoteLauncher cr w = setLocation
i = IM.newKey $ _projectiles w
cid = _crID cr
dir = _crDir cr
pos = _crPos cr +.+ rotateV dir (V2 (_crRad cr + 1) (0))
pos = _crPos cr +.+ rotateV dir (V2 (_crRad cr + 1) 0)
remRocket = IM.insert i $ Shell
{ _pjPos = pos
, _pjStartPos = pos
@@ -762,7 +762,7 @@ fireRemoteLauncher cr w = setLocation
, _pjDraw = remoteShellPic'
, _pjID = i
, _pjUpdate = \pj -> decTimMvVel pj . setRemoteScope itid pj . moveRemoteShell cid itid pj
, _pjAcc = (V2 0 0)
, _pjAcc = V2 0 0
, _pjDir = dir
, _pjSpin = 0
, _pjPayload = makeExplosionAt
@@ -864,8 +864,8 @@ throwRemoteBomb cr w = setLocation
removePict = set (creatures . ix cid . crInv . ix j . itEquipPict) $ \ _ _ -> blank
resetFire = set (creatures . ix cid . crInv . ix j . itUse)
$ \_ -> hammerCheck $ explodeRemoteBomb itid i
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))
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'
maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just
setLocation :: World -> World
src/Dodge/Item/Weapon/Bezier.hs
+1 -1
View File
@@ -59,7 +59,7 @@ shootBezier targetp cr w = w & particles %~ (theBullet :)
controlp = mouseWorldPos w
cid = _crID cr
dir = _crDir cr
startp = _crPos cr +.+ rotateV dir (V2 (_crRad cr + 1) (0))
startp = _crPos cr +.+ rotateV dir (V2 (_crRad cr + 1) 0)
(randPos,randPos') = flip evalState (_randGen w) $ do
a <- randInCirc 10
b <- randInCirc 20
src/Dodge/Item/Weapon/Bullet.hs
+2 -2
View File
@@ -10,12 +10,12 @@ basicBullet = BulletAmmo
{ _amString = "BULLET"
, _amBulEff = destroyOnImpact bulHitCr bulHitWall' bulHitFF'
, _amBulWth = 2
, _amBulVel = (V2 30 0)
, _amBulVel = V2 30 0
}
hvBullet :: Ammo
hvBullet = BulletAmmo
{ _amString = "HVBULLET"
, _amBulEff = penWalls hvBulHitCr hvBulHitWall' bulHitFF'
, _amBulWth = 6
, _amBulVel = (V2 80 0)
, _amBulVel = V2 80 0
}
src/Dodge/Item/Weapon/ExtraEffect.hs
+2 -2
View File
@@ -127,8 +127,8 @@ targetRBMousePos w = (f, \_ _ _ w' -> cursorPic w')
cursorPic w' = setLayer 1 $ onLayer InvLayer $ uncurryV translate mwp
$ rotate (_cameraRot w')
$ pictures
[line [( V2 (x) (x)), (V2 (-x) (-x))]
,line [(V2 (-x) (x)), (V2 ( x) (-x))]
[line [V2 x x, V2 (-x) (-x)]
,line [V2 (-x) x, V2 x (-x)]
]
where
x = 5 / _cameraZoom w'
src/Dodge/Item/Weapon/Grenade.hs
+2 -2
View File
@@ -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) (V2 (_crRad cr) (0))
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (V2 (_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/Item/Weapon/TriggerType.hs
+4 -4
View File
@@ -128,7 +128,7 @@ withRecoil
withRecoil recoilAmount eff cr = eff cr . over (creatures . ix cid) pushback
where
cid = _crID cr
pushback = over crPos (+.+ rotateV (_crDir cr) (V2 ((-recoilAmount) / _crMass cr ) (0)))
pushback = over crPos (+.+ rotateV (_crDir cr) (V2 ((-recoilAmount) / _crMass cr ) 0))
{- | Pushes a creature sideways by a random amount.
Applied before the underlying effect. -}
withSidePush
@@ -140,7 +140,7 @@ withSidePush
withSidePush maxSide eff cr w = eff cr . over (creatures . ix cid) push $ w
where
cid = _crID cr
push = over crPos (+.+ rotateV (_crDir cr) (V2 (0) (pushAmount / _crMass cr)))
push = over crPos (+.+ rotateV (_crDir cr) (V2 0 (pushAmount / _crMass cr)))
(pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
-- consider unifying the pushes using a direction vector
{- | Pushes a creature sideways by a random amount.
@@ -154,7 +154,7 @@ withSidePushAfter
withSidePushAfter maxSide eff cr w = over (creatures . ix cid) push . eff cr $ w
where
cid = _crID cr
push = over crPos (+.+ rotateV (_crDir cr) (V2 (0) (pushAmount / _crMass cr)))
push = over crPos (+.+ rotateV (_crDir cr) (V2 0 (pushAmount / _crMass cr)))
(pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
{- | Applies a world effect and sound effect after an ammo check. -}
shootWithSound
@@ -462,7 +462,7 @@ numVelWthHitEff num vel wth eff cr = over particles (newbuls ++)
d = _crDir cr
poss = map (+.+ pos) $ take num offsets
maxOffset = fromIntegral num * 2.5 - 2.5
offsets = map (\y -> rotateV d (V2 0 y)) [-maxOffset,5-maxOffset..]
offsets = map (rotateV d . V2 0) [-maxOffset,5-maxOffset..]
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle d
{- | Uses '_wpSpread' as a parameter for the current offset angle. -}
randWalkAngle
src/Dodge/Layout.hs
+2 -2
View File
@@ -68,7 +68,7 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
plmnts = concatMap _rmPS $ flatten tr
path = pairsToGraph dist pairGraph
pairGraph = makePath tr
insertPoint pp@(_,(V2 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 ( (V2 0 0) -.- rotateV (pi-a) p , 0) $ shiftRoomBy ((V2 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
+2 -2
View File
@@ -100,7 +100,7 @@ placeSpot ps w = case _psType ps of
--_ -> w
where
p@(V2 px py) = _psPos ps
p' = (V3 px py 0)
p' = V3 px py 0
rot = _psRot ps
-- TODO: remove this typeclass
@@ -196,7 +196,7 @@ placeLS ls dec (V3 x y z) rot w = over lightSources addLS $ over decorations add
where
addLS lss = IM.insert
(IM.newKey lss)
(ls {_lsPos = (V3 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/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@(_,(V2 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/StaticWalls.hs
+1 -1
View File
@@ -233,7 +233,7 @@ findWallsInPolygon ps = filter cond
cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
brokenWalls :: [(Point2,Point2)]
brokenWalls = map (first toV2 . second toV2)
brokenWalls = map (bimap toV2 toV2)
[((330.12192,3032.2456),(190.52365,2995.8352)),((190.52365,2995.8352),(203.94716,2945.9377)),((214.33855,2907.311),(230.12193,2859.0405)),((230.12193,2859.0405),(366.7245,2895.643)),((366.7245,2895.643),(330.12192,3032.2456)),((366.7245,2895.643),(230.12193,2859.0405)),((230.12193,2859.0405),(266.7245,2722.438)),((266.7245,2722.438),(403.32703,2759.0405)),((403.32703,2759.0405),(503.32703,2932.2456)),((466.72446,3068.8481),(330.12192,3032.2456)),((330.12192,3032.2456),(366.7245,2895.643)),((503.32703,2932.2456),(466.72446,3068.8481)),((203.94716,2945.9377),(145.99155,2930.4084)),((156.38292,2891.7817),(214.33855,2907.311)),((107.47222,2920.979),(34.06077,2901.2295)),((34.06077,2901.2295),(52.571453,2832.4224)),((70.17772,2796.55),(174.45558,2824.6025)),((174.45558,2824.6025),(156.38292,2891.7817)),((100.76944,2955.4202),(107.47222,2920.979)),((145.99155,2930.4084),(140.79587,2949.722)),((52.571453,2832.4224),(35.882084,2827.9504)),((31.745949,2785.4312),(70.17772,2796.55)),((88.14497,3002.5354),(100.76944,2955.4202)),((140.79587,2949.722),(120.21855,3027.0303)),((35.882084,2827.9504),(-22.07344,2812.4214)),((-31.039248,2768.608),(31.745949,2785.4312)),((-261.32483,3408.5737),(-303.9881,3451.237)),((-303.9881,3451.237),(-332.27234,3422.9526)),((-332.27234,3422.9526),(-289.84595,3380.5264)),((-261.56174,3352.242),(88.14497,3002.5354)),((120.21855,3027.0303),(-233.27742,3380.5264)),((-289.84595,3380.5264),(-332.2724,3338.0999)),((-332.2724,3338.0999),(-303.9881,3309.8157)),((-303.9881,3309.8157),(-261.56174,3352.242)),((-22.07344,2812.4214),(-89.68823,2794.304)),((-79.335526,2755.667),(-31.039248,2768.608)),((-210.16953,3456.4133),(-261.32483,3408.5737)),((-233.27742,3380.5264),(-194.64026,3419.1633)),((-128.32533,2783.9514),(-200.79468,3054.4106)),((-200.79468,3054.4106),(-780.35016,2899.1191)),((-780.35016,2899.1191),(-625.05865,2319.5635)),((-625.05865,2319.5635),(-45.503174,2474.855)),((-45.503174,2474.855),(-117.97253,2745.3142)),((-89.68823,2794.304),(-128.32533,2783.9514)),((-117.97253,2745.3142),(-79.335526,2755.667)),((-178.49438,3590.2566),(-241.50847,3573.372)),((-241.50847,3573.372),(-210.16953,3456.4133)),((-194.64026,3419.1633),(-136.80266,3434.6611)),((-98.165634,3445.014),(-139.85736,3600.6094)),((-92.98925,3425.6953),(-98.165634,3445.014)),((-136.80266,3434.6611),(-127.74397,3400.8535)),((-187.553,3624.064),(-178.49438,3590.2566)),((-139.85736,3600.6094),(-148.91603,3634.4167)),((-127.74397,3400.8535),(-111.20285,3339.121)),((-78.55679,3371.8325),(-92.98925,3425.6953)),((-349.5008,4383.0093),(-388.13782,4372.6563)),((-388.13782,4372.6563),(-485.18823,3653.0168)),((-485.18823,3653.0168),(-477.42368,3624.039)),((-477.42368,3624.039),(-206.96445,3696.5085)),((-168.32744,3706.861),(102.131805,3779.3306)),((102.131805,3779.3306),(94.36725,3808.308)),((94.36725,3808.308),(-349.5008,4383.0093)),((-206.96445,3696.5085),(-187.553,3624.064)),((-148.91603,3634.4167),(-168.32744,3706.861)),((299.35522,3346.2668),(97.2383,3547.9797)),((97.2383,3547.9797),(-78.55679,3371.8325)),((-111.20285,3339.121),(116.74672,3110.6904)),((116.74672,3110.6904),(320.08704,3314.438)),((352.084,3395.578),(299.35522,3346.2668)),((320.08704,3314.438),(367.6133,3358.328)),((495.06226,3666.979),(293.8115,3613.054)),((293.8115,3613.054),(352.084,3395.578)),((367.6133,3358.328),(563.6875,3410.866)),((563.6875,3410.866),(495.06226,3666.979))]
--intersectingBrokenWalls :: [(Point2,Point2)]
src/Dodge/LevelGen/Switch.hs
+2 -2
View File
@@ -15,7 +15,7 @@ makeButton
-> Button
makeButton c eff = Button
{ _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (V2 0 0)
, _btPos = V2 0 0
, _btRot = 0
, _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
-- . set (buttons . ix (_btID b) . btPict)
@@ -39,7 +39,7 @@ makeSwitch
-> Button
makeSwitch c effOn effOff = Button
{ _btPict = offPict
, _btPos = (V2 0 0)
, _btPos = V2 0 0
, _btRot = 0
, _btEvent = flipSwitch
, _btID = 0
src/Dodge/LevelGen/TriggerDoor.hs
+2 -2
View File
@@ -33,7 +33,7 @@ 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@(_,(V2 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)
@@ -52,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@(_,(V2 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/LightSources.hs
+5 -5
View File
@@ -12,7 +12,7 @@ import Geometry.Data
lightAt :: Point3 -> Int -> LightSource
lightAt (V3 x y z) i =
LS {_lsID = i
,_lsPos = (V3 x y z)
,_lsPos = V3 x y z
,_lsDir = 0
,_lsRad = 700
,_lsIntensity = 0.75
@@ -25,13 +25,13 @@ basicLS = PutLS ls dec
tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
tLightFade 0 rmax intensityF (V2 x y) = TLS
{ _tlsPos = (V3 x y 0)
{ _tlsPos = V3 x y 0
, _tlsRad = rmax
, _tlsIntensity = intensityF 0
, _tlsUpdate = \w _ -> (w, Nothing)
}
tLightFade i rmax intensityF p@(V2 x y) = TLS
{ _tlsPos = (V3 x y 0)
{ _tlsPos = V3 x y 0
, _tlsRad = rmax
, _tlsIntensity = intensityF i
, _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p)
@@ -44,13 +44,13 @@ tLightRad
-> Point2
-> TempLightSource
tLightRad 0 rmax _ (V2 x y) = TLS
{ _tlsPos = (V3 x y 0)
{ _tlsPos = V3 x y 0
, _tlsRad = rmax
, _tlsIntensity = 0.5
, _tlsUpdate = \w _ -> (w, Nothing)
}
tLightRad i rmax rmin p@(V2 x y) = TLS
{ _tlsPos = (V3 x y 0)
{ _tlsPos = V3 x y 0
, _tlsRad = rmax
, _tlsIntensity = 0.5
, _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p)
src/Dodge/Lock/Data.hs
+2 -2
View File
@@ -5,11 +5,11 @@ module Dodge.Lock.Data
import Dodge.Data
import Control.Lens
data Lock = Lock
newtype Lock = Lock
{ _lkUnlocker :: Unlocker
}
data Unlocker
newtype Unlocker
= ItemUnlocker Item
makeLenses ''Lock
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' = (V2 0 0)
, _btVel' = V2 0 0
, _btColor' = col
, _btTrail' = [pos]
, _btPassThrough' = maycid
src/Dodge/Path.hs
+5 -6
View File
@@ -19,9 +19,8 @@ import Control.Monad.State
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)]
worldGraph w p = HS.unions $ (\q -> HS.fromList $ pointsAlong w p (p +.+ q)) . toV2
<$> [(200,0),(-200,0),(0,200),(0,-200)]
pointsAlong :: World -> Point2 -> Point2 -> [Point2]
pointsAlong w p q = divideLineFixed 50 p p'
@@ -69,9 +68,9 @@ makeNode e = (HP.singleton (0,(0,[e])) , [])
tp1,tp2,tp3 :: Point2
tp1 = (V2 0 1)
tp2 = (V2 0 20)
tp3 = (V2 30 40)
tp1 = V2 0 1
tp2 = V2 0 20
tp3 = V2 30 40
f :: Point2 -> [Point2]
f = incidenceToFunction $ pairsToIncidence
src/Dodge/Picture.hs
+3 -3
View File
@@ -45,12 +45,12 @@ wedgeOfThickness t x y
verticalPipe :: Float -> Color -> Point2 -> Float -> Float -> Picture
verticalPipe w col (V2 xx xy) za zb = pictures $ map (poly3Col . f) ps
where
x = (V3 xx xy 0)
xs = map (\(V2 a b) -> x +.+.+ (V3 a b za)) (map toV2 [(w,0),(0,w),(-w,0),(0,-w)])
x = V3 xx xy 0
xs = map ((\(V2 a b) -> x +.+.+ V3 a b za) . toV2) [(w,0),(0,w),(-w,0),(0,-w)]
ps = zip xs (tail xs ++ [head xs])
f (a,b) = map f' [a,b,g b,g a]
g :: Point3 -> Point3
g (V3 a b _) = (V3 a b zb)
g (V3 a b _) = V3 a b zb
f' a = (a,col)
expandLine :: Point3 -> Point3 -> Point3 -> [Point3]
src/Dodge/Render.hs
+2 -2
View File
@@ -55,7 +55,7 @@ doDrawing pdata w = do
nSils <- pokePoint3s (shadVBOptr $ _lightingLineShadowShader pdata)
(_foregroundEdgeVerx w)
-- poke foreground geometry and floor
let addC (V2 xx yy) = (V3 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)
@@ -155,7 +155,7 @@ doDrawing pdata w = do
drawShader (_fullscreenShader pdata) 4
rds -> do
let bindDrawDist :: (Point2,Point2,Point2,Float) -> IO ()
bindDrawDist ((V2 a b),(V2 c d),(V2 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]
src/Dodge/Render/HUD.hs
+19 -18
View File
@@ -56,7 +56,7 @@ cursorsZ w ipos it = case it ^? wpAmmo . amParamSel of
where
hh = halfHeight w
hw = halfWidth w
sp = (V2 (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
@@ -97,7 +97,7 @@ pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj
displayMidList :: World -> [String] -> String -> [Picture]
displayMidList w strs s =
invHead w s
++ renderListAt (V2 (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)
@@ -145,17 +145,17 @@ drawLocations wrld = displayListTopLeft locs wrld
displayListCoords :: World -> [Point2]
displayListCoords w = map (g . f) [(1::Int)..]
where
f i = (V2 ( 15 - halfWidth w ) ( halfHeight w - (20 * fromIntegral i)) )
g (V2 x y) = (V2 (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 = (V2 ( 15 - halfWidth w ) ( 2.5 + halfHeight w - (20 * fromIntegral i)) )
g (V2 x y) = (V2 (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 (V2 x y) = (V2 (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,7 +202,7 @@ 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 (V2 x y) = (V2 (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
@@ -212,11 +212,12 @@ closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText
( 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)
return $ thickLineCol
[(itScreenPos, withAlpha 0 col)
,(sc p' , col)
,(sc p , col)
]
(1 / halfWidth w)
{- | Colour picture and add black drop shadow. -}
dShadCol :: Color -> Picture -> Picture
dShadCol c p = pictures
@@ -238,10 +239,10 @@ openCursorAt
openCursorAt wth col xoff yoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
$ lineCol
[((V2 wth 12.5) ,withAlpha 0 col)
,((V2 0 12.5) ,col)
,((V2 ( 0) (-7.5)) ,col)
,((V2 ( 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
@@ -255,11 +256,11 @@ cursorAt wth col xoff yoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
. color col
$ line
[(V2 wth 12.5)
,(V2 0 12.5)
,(V2 ( 0) (-7.5))
,(V2 ( wth) (-7.5))
,(V2 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
+4 -4
View File
@@ -22,10 +22,10 @@ import qualified Data.IntMap.Lazy as IM
worldPictures :: World -> Picture
worldPictures w = concat $
(IM.elems $ _decorations w) ++
IM.elems (_decorations w) ++
(map (dbArg _pjDraw) . IM.elems $ _projectiles w) ++
(map (crDraw w) . IM.elems $ _creatures w) ++
(map (dbArg _ptDraw) $ _particles w) ++
map (dbArg _ptDraw) (_particles w) ++
[ testPic w
, concatMap drawItem . IM.elems $ _floorItems w
, concatMap (crDraw w) . IM.elems $ _creatures w
@@ -53,7 +53,7 @@ customMouseCursor w =
scale (2 /getWindowX w) (2/ getWindowY w)
. uncurryV translate (_mousePos w)
. color white
$ pictures [ line [(V2 (-5) (0)),(V2 5 0)] , line [(V2 (0) (-5)),(V2 0 5)] ]
$ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]
testPic :: World -> Picture
testPic _ = blank
@@ -213,7 +213,7 @@ wallsAndWindows w
(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w
wallsToList :: [((Point2,Point2),Point4)] -> [Float]
wallsToList = concatMap (\(((V2 a b),(V2 c d)),(V4 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])
lightsForGloom :: World -> [(Point3,Float,Float)]
src/Dodge/Room.hs
+52 -52
View File
@@ -51,7 +51,7 @@ roomC x y = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [windowLine (V2 (x/2) (0)) (V2 (x/2) (y-60))
, _rmPS = [windowLine (V2 (x/2) 0) (V2 (x/2) (y-60))
]
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
}
@@ -65,8 +65,8 @@ roomC x y = defaultRoom
roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = defaultRoom
{ _rmPolys = [ps]
, _rmLinks = [(p,0),((V2 0 0),pi)]
, _rmPath = [((V2 0 0),p)]
, _rmLinks = [(p,0),(V2 0 0,pi)]
, _rmPath = [(V2 0 0,p)]
, _rmPS = []
, _rmBound = []
}
@@ -90,14 +90,14 @@ glassSwitchBack = do
wllen <- state $ randomR (60,wth/2-40)
let hf = hgt/5
let plmnts =
[windowLine (V2 (wth-60 ) ( hf)) (V2 (wllen) (hf) )
,windowLine (V2 (wth-wllen) (2*hf)) (V2 (60 ) (2*hf))
,windowLine (V2 (wth-60 ) (3*hf)) (V2 (wllen) (3*hf))
,windowLine (V2 (wth-wllen) (4*hf)) (V2 (60 ) (4*hf))
,blockLine (V2 ( 0) (1*hf)) (V2 (wllen) (1*hf))
,blockLine (V2 (wth-wllen) (2*hf)) (V2 ( wth) (2*hf))
,blockLine (V2 ( 0) (3*hf)) (V2 (wllen) (3*hf))
,blockLine (V2 (wth-wllen) (4*hf)) (V2 ( wth) (4*hf))
[windowLine (V2 (wth-60 ) hf ) (V2 wllen hf )
,windowLine (V2 (wth-wllen) (2*hf)) (V2 60 (2*hf))
,windowLine (V2 (wth-60 ) (3*hf)) (V2 wllen (3*hf))
,windowLine (V2 (wth-wllen) (4*hf)) (V2 60 (4*hf))
,blockLine (V2 0 (1*hf)) (V2 wllen (1*hf))
,blockLine (V2 (wth-wllen) (2*hf)) (V2 wth (2*hf))
,blockLine (V2 0 (3*hf)) (V2 wllen (3*hf))
,blockLine (V2 (wth-wllen) (4*hf)) (V2 wth (4*hf))
, sPS (V2 (wth/2) (hgt/2)) 0 putLamp
]
return $ set rmPS plmnts $ roomRect wth hgt 2 6
@@ -135,19 +135,19 @@ miniRoom1 = do
,50+4*hf,30+5*hf
]
crx <- state $ randomR (wllen,wth-(wllen+40))
let plmnts = [windowLine (V2 (wth-60) ( 40+hf)) (V2 (wllen) (40+hf))
,windowLine (V2 (wth-wllen) (40+2*hf)) (V2 (60) (40+2*hf))
,windowLine (V2 (wth-60) ( 40+3*hf)) (V2 (wllen) (40+3*hf))
,windowLine (V2 (wth-wllen) (40+4*hf)) (V2 (60) (40+4*hf))
let plmnts = [windowLine (V2 (wth-60) ( 40+hf)) (V2 wllen (40+hf))
,windowLine (V2 (wth-wllen) (40+2*hf)) (V2 60 (40+2*hf))
,windowLine (V2 (wth-60) ( 40+3*hf)) (V2 wllen (40+3*hf))
,windowLine (V2 (wth-wllen) (40+4*hf)) (V2 60 (40+4*hf))
,sPS (V2 crx cry) 0 $ PutCrit miniGunCrit
,sPS (V2 (wth-20) (hgt/2+40)) 0 randC1
,sPS (V2 (wth/2) (hgt/2)) 0 putLamp
,blockLine (V2 ( 0) ( 40+1*hf)) (V2 (wllen) (40+1*hf))
,blockLine (V2 (wth-wllen) ( 40+2*hf)) (V2 ( wth) (40+2*hf))
,blockLine (V2 ( 0) ( 40+3*hf)) (V2 (wllen) (40+3*hf))
,blockLine (V2 (wth-wllen) ( 40+4*hf)) (V2 ( wth) (40+4*hf))
,blockLine (V2 0 ( 40+1*hf)) (V2 wllen (40+1*hf))
,blockLine (V2 (wth-wllen) ( 40+2*hf)) (V2 wth (40+2*hf))
,blockLine (V2 0 ( 40+3*hf)) (V2 wllen (40+3*hf))
,blockLine (V2 (wth-wllen) ( 40+4*hf)) (V2 wth (40+4*hf))
]
return $ set rmPS plmnts $ shiftRoomBy ((V2 0 40),0) $ roomRect wth hgt 2 4
return $ set rmPS plmnts $ shiftRoomBy (V2 0 40,0) $ roomRect wth hgt 2 4
miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
miniTree2 = miniRoom1
@@ -159,7 +159,7 @@ miniRoom3 :: RandomGen g => State g (Tree (Either Room Room))
miniRoom3 = do
w <- state $ randomR (300,400)
h <- state $ randomR (300,400)
let cp = (V2 (0) (h/2+40))
let cp = V2 0 (h/2+40)
let b = PutBlock [5,20,20] (greyN 0.5) $ map toV2 [(-10,-60)
,( 10,-60)
,( 10,-80)
@@ -263,11 +263,11 @@ weaponEmptyRoom = do
let plmnts =
[sPS (V2 (w/2) (h-40)) 0 $ RandPS randFirstWeapon
,sPS (V2 20 20) (pi/2) randC1
,sPS (V2 (w-20) (20)) (pi/2) randC1
,sPS (V2 (w-20) 20) (pi/2) randC1
,sPS (V2 (w/2) (h/2)) 0 putLamp
]
(fmap connectRoom . randomiseOutLinks) =<<
changeLinkTo ((\p -> dist p (V2 (w/2) (0)) < 10) . fst) (set rmPS plmnts $ roomRect w h 2 2)
changeLinkTo ((\p -> dist p (V2 (w/2) 0) < 10) . fst) (set rmPS plmnts $ roomRect w h 2 2)
weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room))
weaponUnderCrits = do
@@ -291,8 +291,8 @@ weaponUnderCrits = do
weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room))
weaponBehindPillar = do
cpos <- takeOne $ [(V2 x y) | x <- [20,220], y <- [20,220]] ++ [(V2 120 160),(V2 120 200)]
let d p = argV $ (V2 120 80) -.- p
cpos <- takeOne $ [V2 x y | x <- [20,220], y <- [20,220]] ++ [V2 120 160,V2 120 200]
let d p = argV $ V2 120 80 -.- p
let plmnts1 =
[sPS (V2 120 160) 0 $ RandPS randFirstWeapon
,sPS cpos (d cpos) randC1
@@ -306,11 +306,11 @@ weaponBehindPillar = do
weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
weaponBetweenPillars = do
wpPos <- takeOne [(V2 x y) | x <- [20,120,220], y <- [20,120,220]]
(ps,_) <- takeNMore 2 ([], [(V2 x y) | x <- [20,220], y <- [20,120,220]])
wpPos <- takeOne [V2 x y | x <- [20,120,220], y <- [20,120,220]]
(ps,_) <- takeNMore 2 ([], [V2 x y | x <- [20,220], y <- [20,120,220]])
let crPos1 = ps !! 0
crPos2 = ps !! 1
d p = argV $ (V2 120 120) -.- p
d p = argV $ V2 120 120 -.- p
plmnts =
[sPS wpPos 0 $ RandPS randFirstWeapon
,sPS crPos1 (d crPos1) randC1
@@ -327,7 +327,7 @@ weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do
root <- takeOne [tEast, tWest]
connectingRoom <- takeOne
[tEast & rmPS .~ [sPS (V2 (-40) (60)) 0 putLamp]
[tEast & rmPS .~ [sPS (V2 (-40) 60) 0 putLamp]
,tWest & rmPS .~ [sPS (V2 40 60) 0 putLamp]
]
i1 <- state $ randomR (2,5)
@@ -336,7 +336,7 @@ weaponLongCorridor = do
let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor)
return $ Node (Left root) [branch1,branch2]
where
putCrs = over rmPS (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) (40)) (-pi/2) randC1 ])
putCrs = over rmPS (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
putWp = set rmPS [sPS (V2 20 40) 0 $ RandPS randFirstWeapon ,sPS (V2 20 60) 0 putLamp ]
critInDeadEnd :: Room
@@ -348,11 +348,11 @@ deadEndRoom = defaultRoom
]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [sPS (V2 (0) (-10)) 0 putLamp]
, _rmPS = [sPS (V2 0 (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30]
}
where
lnks = [((V2 0 30) ,0) ]
lnks = [(V2 0 30 ,0) ]
{- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: RandomGen g => State g (Tree (Either Room Room))
weaponRoom = join $ takeOne
@@ -367,7 +367,7 @@ roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
roomCCrits = do
ps <- replicateM 20 $ randInCirc 9
let plmnts = map (\p -> sPS p 0 randC1)
$ zipWith (+.+) [(V2 x y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
$ zipWith (+.+) [V2 x y | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
lamps = [sPS (V2 50 100) 0 putLamp , sPS (V2 175 100) 0 putLamp]
return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200
@@ -387,14 +387,14 @@ longRoom = do
[rectNSWE 95 70 0 25
,rectNSWE 95 70 50 75
]
brls <- fmap (map (\p -> sPS (p +.+ (V2 10 200)) 0 $ PutCrit explosiveBarrel) )
brls <- fmap (map (\p -> sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel) )
$ replicateM 5 $ randInRect (w-20) 900
let rm = roomRect w (h+70) 1 1 & rmPolys %~ ([rectNSWE h (h-165) (-45) (w+45)] ++)
changeLinkTo cond $ rm & rmPS .~ ws ++ brls ++ wsDefense ++
[sPS (V2 12.5 (h-25)) 0 $ PutCrit longCrit
,sPS (V2 37.5 (h-25)) 0 $ PutCrit longCrit
,sPS (V2 62.5 (h-25)) 0 $ PutCrit longCrit
,sPS (V2 25 ( 20)) 0 putLamp
,sPS (V2 25 20 ) 0 putLamp
,sPS (V2 25 (h-10)) 0 putLamp
]
@@ -423,12 +423,12 @@ shootersRoom1 = do
y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
x4 <- state $ randomR (60,w-60)
y4 <- state $ randomR (40,180)
p <- takeOne [(V2 (x1) (y1-10)),(V2 (x2) (y2-10)),(V2 (x3) (y3-10))]
p <- takeOne [V2 x1 (y1-10),V2 x2 (y2-10),V2 x3 (y3-10)]
let bln x y = putBlockN (x+25) (x-25) (y+10) y
let blv x y = putBlockV (x+25) (x-25) (y+10) y
let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [sPS p (-pi/2) $ PutCrit autoCrit
,sPS (V2 (w/2) (200)) 0 putLamp
,sPS (V2 (w/2) 200) 0 putLamp
]
return $ set rmPS plmnts $ roomRectAutoLinks w 600
@@ -446,10 +446,10 @@ shootersRoom = do
let bln x y = putBlockN (x+25) (x-25) (y+10) y
let blv x y = putBlockV (x+25) (x-25) (y+10) y
let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [sPS (V2 (x1) (y1-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 (x2) (y2-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 (x3) (y3-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 (w/2) (200)) 0 putLamp
++ [sPS (V2 x1 (y1-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 x2 (y2-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 x3 (y3-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 (w/2) 200 ) 0 putLamp
]
return $ set rmPS plmnts $ roomRectAutoLinks w 600
@@ -479,11 +479,11 @@ pistolerRoom = do
,sPS (ps !! 1) ab $ PutCrit pistolCrit
,sPS (ps !! 2) ac $ PutCrit pistolCrit
,sPS (V2 (w/2) (h-50)) 0 putLamp
,sPS (V2 (w/2) (50) ) 0 putLamp
,sPS (V2 (w/2) 50 ) 0 putLamp
,sPS (V2 (w-5) (h-5) ) 0 putLamp
,sPS (V2 ( 5) (h-5) ) 0 putLamp
,sPS (V2 (w-5) (5) ) 0 putLamp
,sPS (V2 ( 5) (5) ) 0 putLamp
,sPS (V2 5 (h-5) ) 0 putLamp
,sPS (V2 (w-5) 5 ) 0 putLamp
,sPS (V2 5 5 ) 0 putLamp
,sPS (V2 (w/2) (h/2) ) 0 putLamp
]
++
@@ -493,11 +493,11 @@ pistolerRoom = do
shootingRange :: RandomGen g => State g (Tree (Either Room Room))
shootingRange = do
rm1 <- shootersRoom1 >>= changeLinkTo (\((V2 _ y),_) -> y < 40)
>>= filterLinks (\((V2 _ y),r) -> y > 200 && r /= 0)
rm2 <- shootersRoom >>= changeLinkTo (\((V2 x y),_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\((V2 _ y),r) -> y > 200 && r /= 0)
rm3 <- shootersRoom >>= changeLinkTo (\((V2 x y),_) -> y < 10 && x > 20 && x < 180)
rm1 <- shootersRoom1 >>= changeLinkTo (\(V2 _ y,_) -> y < 40)
>>= filterLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
rm2 <- shootersRoom >>= changeLinkTo (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
rm3 <- shootersRoom >>= changeLinkTo (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\(_,r) -> r == 0)
return $ treeFromPost [Left rm1
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (V2 0 20)
@@ -512,13 +512,13 @@ spawnerRoom = do
y <- state $ randomR (300,400)
wl <- takeOne [sPS (V2 0 0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10))
defaultCrystalWall
,windowLine (V2 (x/2) (0)) (V2 (x/2) (y-60))
,windowLine (V2 (x/2) 0) (V2 (x/2) (y-60))
]
let plmnts = [sPS (V2 (x/4) ( y/4)) (pi/2) $ PutCrit spawnerCrit
,wl
,sPS (V2 (x/2) ( y-10)) 0 putLamp
]
let f ((V2 lx _),_) = lx < x/2-5
let f (V2 lx _,_) = lx < x/2-5
roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2)
aRoom <- airlock 0
return $ treeFromTrunk [Left aRoom] roomWithSpawner
src/Dodge/Room/Airlock.hs
+15 -15
View File
@@ -31,8 +31,8 @@ airlockOneWay n = defaultRoom
--, _rmBound = rectNSWE 90 30 (-30) 30
, _rmBound = [rectNSWE 75 15 0 40]
}
where lnks = [((V2 0 85),0)
,((V2 0 5),pi)
where lnks = [(V2 0 85,0)
,(V2 0 5,pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
@@ -56,8 +56,8 @@ airlock0 n = defaultRoom
, rectNSWE 65 35 (-40) 20
]
, _rmLinks = lnks
, _rmPath = [((V2 20 95),(V2 20 45))
,((V2 20 45),(V2 20 5))
, _rmPath = [(V2 20 95,V2 20 45)
,(V2 20 45,V2 20 5)
]
, _rmPS =
[sPS (V2 0 20) 0 $ PutDoubleDoor col (not . cond) (V2 1 0) (V2 39 0)
@@ -65,13 +65,13 @@ airlock0 n = defaultRoom
,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,sPS (V2 (-25) ( 50)) 0 putLamp
,sPS (V2 (-25) 50) 0 putLamp
]
, _rmBound = [rectNSWE 75 15 0 40]
}
where
lnks = [((V2 20 95),0)
,((V2 20 5),pi)
lnks = [(V2 20 95,0)
,(V2 20 5,pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
@@ -91,12 +91,12 @@ airlock90 n = defaultRoom
]
]
, _rmLinks =
[((V2 0 40),pi/2)
,((V2 40 0),pi)
[(V2 0 40,pi/2)
,(V2 40 0,pi)
]
, _rmPath =
[((V2 0 40),(V2 40 0))
,((V2 40 0),(V2 0 40))
[(V2 0 40,V2 40 0)
,(V2 40 0,V2 0 40)
]
, _rmPS =
[sPS (V2 5 5) 0 $ PutDoor col (not . cond) pss
@@ -116,7 +116,7 @@ airlock90 n = defaultRoom
where
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
pss = ((V2 0 0) ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55)
pss = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55)
airlockCrystal
:: Int -- ^ Door id
@@ -132,8 +132,8 @@ airlockCrystal n = defaultRoom
]
]
, _rmLinks =
[((V2 20 130),0)
,((V2 20 0),pi)
[(V2 20 130,0)
,(V2 20 0 ,pi)
]
, _rmPath =
[
@@ -154,5 +154,5 @@ airlockCrystal n = defaultRoom
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
pss :: [(Point2,Point2)]
pss = reverse $ fmap ( (\x -> ((V2 50 x),(V2 (50) (x+50))) ) . fromIntegral)
pss = reverse $ fmap ( (\x -> (V2 50 x,V2 50 (x+50)) ) . fromIntegral)
[20::Int,22..70]
src/Dodge/Room/Boss.hs
+27 -27
View File
@@ -29,21 +29,21 @@ roomGlassOctogon x = defaultRoom
,rectNSWE 0 (-(x + 40)) (-20) 20
]
, _rmLinks =
[((V2 0 x),0)
,((V2 (0) (-(x+40))),pi)
[(V2 0 x,0)
,(V2 0 (-(x+40)),pi)
]
, _rmPath = [((V2 (0) (x)),(V2 (0) (-(x+40))))
,((V2 (0) (-(x+40))),(V2 (0) (x)))]
, _rmPath = [(V2 0 x,V2 0 (-(x+40)))
,(V2 0 (-(x+40)),V2 0 x)]
, _rmPS =
[sPS (V2 fx fx) 0 putLamp
,sPS (V2 (-fx) (fx)) 0 putLamp
,sPS (V2 (fx) (-fx)) 0 putLamp
,sPS (V2 (-fx) fx) 0 putLamp
,sPS (V2 fx (-fx)) 0 putLamp
,sPS (V2 (-fx) (-fx)) 0 putLamp
,crystalLine (V2 (-x) (x/2)) (V2 (negate (x/2)) ( x))
,crystalLine (V2 (x) (x/2)) (V2 (x/2) ( x))
,crystalLine (V2 (x/2) (-x)) (V2 (x) (negate (x/2)))
,crystalLine (V2 (-x) (x/2)) (V2 (negate (x/2)) x)
,crystalLine (V2 x (x/2)) (V2 (x/2) x)
,crystalLine (V2 (x/2) (-x)) (V2 x (negate (x/2)))
,crystalLine (V2 (negate $ x/2) (-x)) (V2 (-x) (negate (x/2)))
,blockLine (V2 (-40) (40-x)) (V2 (40) (40-x))
,blockLine (V2 (-40) (40-x)) (V2 40 (40-x))
]
, _rmBound = [rectNSWE x (-x) (-x) x]
}
@@ -55,7 +55,7 @@ bossRoom cr = randomMediumRoom <&> rmPS %~ ( sPS (V2 0 100) (negate $ pi/2) (Put
armouredChasers :: RandomGen g => State g (Tree Room)
armouredChasers = do
ps <- takeN 5 [(V2 x y) | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
ps <- takeN 5 [V2 x y | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
as <- replicateM 5 . state $ randomR (0,2*pi)
let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs
treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPS %~ (++ theCrits))
@@ -80,21 +80,21 @@ roomCross x y = defaultRoom
,rectNSWE (-x) x y (-y)
]
, _rmLinks =
[((V2 (x) (y-20)),negate $ pi/2)
,((V2 (x) (20-y)),negate $ pi/2)
,((V2 (20-y) (x)),0)
,((V2 (y-20) (x)),0)
,((V2 (-x) (y-20)),pi/2)
,((V2 (-x) (20-y)),pi/2)
,((V2 (20-y) (-x)),pi)
,((V2 (y-20) (-x)),pi)
[(V2 x (y-20),negate $ pi/2)
,(V2 x (20-y),negate $ pi/2)
,(V2 (20-y) x ,0)
,(V2 (y-20) x ,0)
,(V2 (-x) (y-20),pi/2)
,(V2 (-x) (20-y),pi/2)
,(V2 (20-y) (-x),pi)
,(V2 (y-20) (-x),pi)
]
, _rmPath = []
, _rmPS =
[sPS (V2 ( x) ( 0)) 0 putLamp
,sPS (-V2 (x) ( 0)) 0 putLamp
,sPS (V2 ( 0) ( x)) 0 putLamp
,sPS (V2 ( 0) (-x)) 0 putLamp
[sPS (V2 x 0) 0 putLamp
,sPS (-V2 x 0) 0 putLamp
,sPS (V2 0 x) 0 putLamp
,sPS (V2 0 (-x)) 0 putLamp
]
, _rmBound =
[rectNSWE y (-y) (-x) x
@@ -115,12 +115,12 @@ roomShuriken x y =
] ]
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [((V2 (x-1) (y-20)),negate $ pi/2)]
, _rmLinks = [(V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = []
, _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((V2 0 0), r) corner) [0,pi/2,pi,3*pi/2]
in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
{- | TODO: pathing
Precondition: first float is less than the second by at least 40. -}
roomTwistCross
@@ -139,9 +139,9 @@ roomTwistCross x y z =
]
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [((V2 (z) (y-20)), pi/2)]
, _rmLinks = [(V2 z (y-20), pi/2)]
, _rmPath = []
, _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((V2 0 0), r) corner) [0,pi/2,pi,3*pi/2]
in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
src/Dodge/Room/Corridor.hs
+3 -3
View File
@@ -55,10 +55,10 @@ corridorN = defaultRoom
, _rmPS = []
, _rmBound = [ rectNSWE 50 30 0 40 ]
}
where lnks = [((V2 20 70) ,0)
,((V2 20 10) ,pi)
where lnks = [(V2 20 70 ,0)
,(V2 20 10 ,pi)
]
pth = doublePair ((V2 20 70),(V2 20 10))
pth = doublePair (V2 20 70,V2 20 10)
tEast :: Room
tEast = defaultRoom
src/Dodge/Room/Door.hs
+3 -3
View File
@@ -15,13 +15,13 @@ door :: Room
door = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = lnks
, _rmPath = [((V2 20 35),(V2 20 5))]
, _rmPath = [(V2 20 35,V2 20 5)]
-- door extends into side walls (for shadows as rendered 12/03)
, _rmPS = [sPS (V2 0 20) 0 $ PutAutoDoor (V2 0 0) (V2 40 0)]
, _rmBound = []
}
where lnks = [((V2 20 35),0)
,((V2 20 5),pi)
where lnks = [(V2 20 35,0)
,(V2 20 5,pi)
]
src/Dodge/Room/Foreground.hs
+1 -1
View File
@@ -50,7 +50,7 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
highPipe :: Float -> Point2 -> Point2 -> [Polyhedra]
highPipe h x@(V2 xx xy) y =
[ Polyhedron . map (map ( (,orange) . (+.+.+ (V3 xx xy h))))
[ Polyhedron . map (map ( (,orange) . (+.+.+ V3 xx xy h)))
$ boxABC (V3 a b 0) (V3 a' b' 0) (V3 0 0 5)
]
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 ((V2 0 0) -.- rotateV (pi-a) p , 0)
$ shiftRoomBy ((V2 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/Room/LongDoor.hs
+15 -15
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections #-}
--{-# LANGUAGE TupleSections #-}
{- | Rooms containing long doors, probably with a big reveal behind them.
-}
module Dodge.Room.LongDoor
@@ -33,18 +33,18 @@ twinSlowDoorRoom
twinSlowDoorRoom drID w h x = defaultRoom
{ _rmPolys = ps
, _rmLinks =
[ ((V2 (w) (h/2)) , negate $ pi/2)
, ((V2 (-w) (h/2)) , pi/2)
, ((V2 (0) (-h)), pi)
[ (V2 w (h/2) , negate $ pi/2)
, (V2 (-w) (h/2) , pi/2)
, (V2 0 (-h), pi)
]
, _rmPath = []
, _rmPS =
[ sPS (V2 (0) (h/2)) 0 putLamp
, sPS (V2 (25) (5)) 0 putLamp
, sPS (V2 (negate 25) (5)) 0 putLamp
[ sPS (V2 0 (h/2)) 0 putLamp
, sPS (V2 25 5) 0 putLamp
, sPS (V2 (negate 25) 5) 0 putLamp
, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drL
, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drR
, sPS (V2 (0) (h-5)) pi $ PutButton $ makeButton col
, sPS (V2 0 (h-5)) pi $ PutButton $ makeButton col
(over worldState (M.insert (DoorNumOpen drID) True))
]
, _rmBound = ps
@@ -54,9 +54,9 @@ twinSlowDoorRoom drID w h x = defaultRoom
[rectNSWE h (-2) (-w) w
,rectNSWE 20 (-h) (negate x) x
]
drL = fmap ((\h' -> ((V2 (x) (-h')),(V2 (x) (h-h')))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
drL = fmap ((\h' -> (V2 x (-h'),V2 x (h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
[0..nDrp]
drR = fmap ((\h' -> ((V2 (-x) (-h')),(V2 (-x) (h-h')))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
drR = fmap ((\h' -> (V2 (-x) (-h'),V2 (-x) (h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
[0..nDrp]
nDrp = ceiling h :: Int
cond w' = or $ M.lookup (DoorNumOpen drID) (_worldState w')
@@ -67,8 +67,8 @@ twinSlowDoorChasers
=> Int -- ^ Door id
-> State g Room
twinSlowDoorChasers drid = do
let lps = (V2 (-65)) <$> [20,40 .. 180]
rps = (V2 65) <$> [20,40 .. 180]
let lps = V2 (-65) <$> [20,40 .. 180]
rps = V2 65 <$> [20,40 .. 180]
ps <- takeN 4 $ lps ++ rps
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
return $ twinSlowDoorRoom drid 80 200 40 & rmPS %~ (plmnts ++)
@@ -79,8 +79,8 @@ slowDoorRoom = do
y <- state $ randomR (400,800)
h <- state $ randomR (200,min (y-100) 500)
(butPos,butRot) <- takeOne
[( (V2 (x/2-50) (5)),0)
,( (V2 (x/2+50) (5)),0)
[( V2 (x/2-50) 5,0)
,( V2 (x/2+50) 5,0)
]
let n = 25
xs <- replicateM n $ state $ randomR (10,x-10)
@@ -90,7 +90,7 @@ slowDoorRoom = do
xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- replicateM 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> sPS p r randC1) ps rs
lsources = [sPS (V2 (x/2) (30)) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
lsources = [sPS (V2 (x/2) 30) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
pillarsa = []
pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
src/Dodge/Room/NoNeedWeapon.hs
+1 -1
View File
@@ -33,7 +33,7 @@ centerVaultExplosiveExit drID = do
[sPS (V2 0 175) 0 $ PutCrit explosiveBarrel
,sPS (V2 5 195) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 200) 0 $ PutCrit explosiveBarrel
,sPS (V2 (-4) (195)) 0 $ PutCrit explosiveBarrel
,sPS (V2 (-4) 195) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
]
r <- centerVaultRoom drID 200 200 50 <&> rmPS %~ (extraPS ++)
src/Dodge/Room/Placement.hs
+6 -6
View File
@@ -28,7 +28,7 @@ Width 9, also extends out from each point by 9.
-}
blockLine :: Point2 -> Point2 -> Placement
blockLine a b = SinglePlacement $ PS
{ _psPos = (V2 0 0)
{ _psPos = V2 0 0
, _psRot = 0
, _psType = PutLineBlock baseBlockPane 9 9 a b
}
@@ -39,7 +39,7 @@ Width 8, also extends out from each point by 8.
-}
windowLine :: Point2 -> Point2 -> Placement
windowLine a b = SinglePlacement $ PS
{ _psPos = (V2 0 0)
{ _psPos = V2 0 0
, _psRot = 0
, _psType = PutLineBlock baseWindowPane 8 8 a b
}
@@ -50,7 +50,7 @@ Width 7, also extends out from each point by 7.
-}
crystalLine :: Point2 -> Point2 -> Placement
crystalLine a b = SinglePlacement $ PS
{ _psPos = (V2 0 0)
{ _psPos = V2 0 0
, _psRot = 0
, _psType = PutWall ps defaultCrystalWall
}
@@ -68,7 +68,7 @@ Depth 15, does not extend wider than points.
-}
wallLine :: Point2 -> Point2 -> Placement
wallLine a b = SinglePlacement $ PS
{ _psPos = (V2 0 0)
{ _psPos = V2 0 0
, _psRot = 0
, _psType = PutWall ps defaultWall
}
@@ -87,7 +87,7 @@ windowLineType = PutLineBlock baseWindowPane 8 8
baseBlockPane :: Wall
baseBlockPane = Block
{ _wlLine = ((V2 0 0),(V2 50 0))
{ _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0
, _wlColor = greyN 0.5
, _wlSeen = False
@@ -100,7 +100,7 @@ baseBlockPane = Block
}
baseWindowPane :: Wall
baseWindowPane = Block
{ _wlLine = ((V2 0 0),(V2 50 0))
{ _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0
, _wlColor = withAlpha 0.2 cyan
, _wlSeen = False
src/Dodge/Room/Procedural.hs
+29 -29
View File
@@ -50,9 +50,9 @@ roomRect x y xn yn = defaultRoom
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = [Tile
{ _tilePoly = rectNSWE y 0 0 x
, _tileCenter = (V2 0 0)
, _tileX = (V2 50 0)
, _tileY = (V2 0 50)
, _tileCenter = V2 0 0
, _tileX = V2 50 0
, _tileY = V2 0 50
, _tileZ = 16
} ]
}
@@ -79,7 +79,7 @@ makeGrid x nx y ny
$ gridPoints x nx y ny
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
gridPoints x nx y ny = [(V2 a b) | a <- take nx $ scanl (+) 0 $ repeat x
gridPoints x nx y ny = [V2 a b | a <- take nx $ scanl (+) 0 $ repeat x
, b <- take ny $ scanl (+) 0 $ repeat y
]
@@ -124,9 +124,9 @@ fourthWall :: RandomGen g => Float -> State g Room
fourthWall w = do
b <- takeOne
[ [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 (0) (40)) 0 putLamp
, sPS (V2 0 40) 0 putLamp
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) (w))
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) w)
]
, [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 40) 0 putLamp
@@ -136,16 +136,16 @@ fourthWall w = do
, [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 20) 0 putLamp
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (0) (w/2))
, blockLine (V2 (-29) (w)) (V2 (0) (w/2))
, blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
, blockLine (V2 (-29) w) (V2 0 (w/2))
]
]
pure $ defaultRoom
{ _rmPolys = [ map toV2 [(0,0),(w,w),(-w,w)] ]
, _rmLinks = [((V2 0 w), 0)]
, _rmPath = [((V2 0 w),(V2 0 0)),((V2 0 0),(V2 0 w))]
, _rmLinks = [(V2 0 w, 0)]
, _rmPath = [(V2 0 w,V2 0 0),(V2 0 0,V2 0 w)]
, _rmPS = b
, _rmBound = [[(V2 0 0),(V2 w w),(V2 (-w) (w))]]
, _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]]
}
--fourthCorner :: Float -> Room
--fourthCorner w = Room
@@ -162,36 +162,36 @@ fourthWall w = do
fourthCornerWall :: RandomGen g => Float -> State g Room
fourthCornerWall w = do
b <- takeOne
[ [ sPS (V2 (10-w) (w)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp
[ [ sPS (V2 (10-w) w) 0 putLamp
, sPS (V2 (w-10) w) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 (0) (2*w-20)) pi PutNothing
, sPS (V2 0 (2*w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
]
, [ sPS (V2 (0) (3*w/2)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp
, sPS (V2 (10-w) (w-20)) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 (0) (2*w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate w) (w)) (V2 0 w)
, [ sPS (V2 0 (3*w/2)) 0 putLamp
, sPS (V2 (w-10) w) 0 putLamp
, sPS (V2 (10-w) (w-20) ) 0 putLamp
, sPS (V2 0 10 ) 0 putLamp
, sPS (V2 0 (2*w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate w) w ) (V2 0 w)
]
, [ sPS (V2 (10-w) (w)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 (20) (2*w-40)) pi PutNothing
, [ sPS (V2 (10-w) w ) 0 putLamp
, sPS (V2 (w-10) w ) 0 putLamp
, sPS (V2 0 10 ) 0 putLamp
, sPS (V2 20 (2*w-40)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 0 w) (V2 (0) (w*2))
, blockLine (V2 0 w) (V2 0 (w*2))
]
]
pure $ defaultRoom
{ _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
, _rmLinks =
[((V2 (w/2) (3*w/2)), negate $ pi/4)
,((V2 (negate $ w/2) (3*w/2)), pi/4)
[(V2 (w/2) (3*w/2), negate $ pi/4)
,(V2 (negate $ w/2) (3*w/2), pi/4)
]
, _rmPath = [((V2 0 w),(V2 0 0)),((V2 0 0),(V2 0 w))]
, _rmPath = [(V2 0 w,V2 0 0),(V2 0 0,V2 0 w)]
, _rmPS = b
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
}
src/Dodge/Update.hs
+2 -2
View File
@@ -110,7 +110,7 @@ updateTriggers w
& creatures . ix 0 .~ cr
| otherwise = w
where
cr = _creatures w IM.! 0 & crPos .~ (V2 0 0)
cr = _creatures w IM.! 0 & crPos .~ V2 0 0
updateSoundQueue :: World -> World
updateSoundQueue = set soundQueue [] . set sounds M.empty
@@ -201,7 +201,7 @@ crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
crCrSpring :: Creature -> Creature -> World -> World
crCrSpring c1 c2 w
| id1 == id2 = w
| vec == (V2 0 0) = w
| vec == V2 0 0 = w
| diff >= comRad = w
| otherwise = over (creatures . ix id1 . crPos) (+.+ overlap1)
$ over (creatures . ix id2 . crPos) (-.- overlap2) w
src/Dodge/WorldEvent/SpawnParticle.hs
+1 -1
View File
@@ -61,7 +61,7 @@ drawFlame rotd pt = thePic
[ glow
, 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 5 prot3 20 (V2 scaleChange 1 ) white
]
aPic :: Int -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
aPic lay offset depth (V2 scalex scaley) col
src/Loop.hs
+61
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
{- |
Module : Loop
Description : Simple game loop
@@ -6,15 +7,18 @@ This module sets up an SDL window which may be updated using a simple game loop.
-}
module Loop
( setupLoop
, setupMiniLoop
) where
import qualified Data.Text as T
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Maybe
import System.Mem
--import Foreign.C
import SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Fusion.Stream.Monadic as VS
--import Control.Lens ((.~),(&),(+~))
-- | Create a game loop with an SDL window.
setupLoop
@@ -99,3 +103,60 @@ winConfig x y = defaultWindow
, windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
, windowResizable =True
}
setupMiniLoop
:: (Int,Int) -- ^ The window size.
-> IO world -- ^ Initial simulation state.
-> (world -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop.
-> (world -> Event -> MaybeT IO world)
-- ^ Event handling
-> (world -> MaybeT IO world)
-- ^ Simulation update
-> IO ()
setupMiniLoop (xsize,ysize) initWorld cleanup eventUpdate simUpdate = do
bracket
(createWindow (T.pack "Mini Loop") (winConfig xsize ysize))
destroyWindow
$ \window -> bracket
(glCreateContext window)
(\con -> GL.finish >> glDeleteContext con)
$ \_ -> bracket
initWorld
cleanup
(doMiniLoop window eventUpdate simUpdate)
doMiniLoop
:: Window
-> (world -> Event -> MaybeT IO world)
-> (world -> MaybeT IO world)
-> world
-> IO ()
doMiniLoop window eventUpdate simUpdate startWorld = do
startTicks <- ticks
glSwapWindow window
mayWorld <- runMaybeT $ foldEventsT (plungeMaybe eventUpdate) startWorld >>= simUpdate
case mayWorld of
Just w -> do
performGC
endTicks <- ticks -- it might be better to use System.Clock (monotonic)
let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
threadDelay (theDelay * 1000 )
doMiniLoop window eventUpdate simUpdate w
Nothing -> return ()
plungeMaybe :: (a -> b -> MaybeT IO a) -> Maybe a -> b -> IO (Maybe a)
plungeMaybe f a b = runMaybeT $ MaybeT (pure a) >>= flip f b
foldEventsT :: (Maybe world -> Event -> IO (Maybe world)) -> world -> MaybeT IO world
foldEventsT f w = MaybeT $ foldEvents f w
foldEvents :: (Maybe world -> Event -> IO (Maybe world)) -> world -> IO (Maybe world)
foldEvents f w = VS.foldlM' f (Just w) streamEvents
streamEvents :: VS.Stream IO Event
streamEvents = VS.unfoldrM pollEventSeed ()
pollEventSeed :: () -> IO (Maybe (Event,()))
pollEventSeed _ = fmap (fmap (,())) pollEvent
src/Picture.hs
+26 -26
View File
@@ -157,7 +157,7 @@ color c = map $ overCol (const c)
translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 !a !b !(V3 x y z) = V3 (x+a) (y+b) z
translate3 !a !b (V3 x y z) = V3 (x+a) (y+b) z
translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
@@ -181,7 +181,7 @@ setLayer i = map f
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (V3 x y z) = (V3 (x*a) (y*b) (z))
scale3 a b (V3 x y z) = V3 (x*a) (y*b) z
scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
@@ -198,7 +198,7 @@ pictures = concat
makeArc :: Float -> Point2 -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (V2 a b) = map (`rotateV` (V2 0 rad)) angles
makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles
where
angles = [a,a+step.. b]
step = pi * 0.2
@@ -210,9 +210,9 @@ circleSolid = circleSolidCol white white
circleSolidCol :: Color -> Color -> Float -> Picture
{-# INLINE circleSolidCol #-}
circleSolidCol colC colE r = map f
[( (V3 (-r) ( r) (0)), colC)
,( (V3 (-r) (-r) (0)), colE)
,( (V3 ( r) (-r) (0)), black)
[(V3 (-r) r 0, colC)
,(V3 (-r) (-r) 0, colE)
,(V3 r (-r) 0, black)
]
where
f (pos,col) = Verx pos col [] 0 ellNum
@@ -270,7 +270,7 @@ arcSolid
-> Float -- ^ Radius
-> Picture
{-# INLINE arcSolid #-}
arcSolid startA endA rad = polygon $ (V2 0 0) : makeArc rad (V2 startA endA)
arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA)
arc
:: Float -- ^ Start angle
@@ -295,22 +295,22 @@ thickArc startA endA rad wdth
thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
{-# INLINE thickArcHelp #-}
thickArcHelp startA endA rad wdth = map f
[( (V3 0 0 0),black,(V3 0 0 wdth))
,((V3 xa ya 0),black,(V3 1 0 wdth))
,((V3 xb yb 0),black,(V3 1 1 wdth))
,( (V3 0 0 0),black,(V3 0 0 wdth))
,((V3 xb yb 0),black,(V3 1 1 wdth))
,((V3 xc yc 0),black,(V3 0 1 wdth))
[ (V3 0 0 0,black,V3 0 0 wdth)
,(V3 xa ya 0,black,V3 1 0 wdth)
,(V3 xb yb 0,black,V3 1 1 wdth)
, (V3 0 0 0,black,V3 0 0 wdth)
,(V3 xb yb 0,black,V3 1 1 wdth)
,(V3 xc yc 0,black,V3 0 1 wdth)
]
where
(V2 xa ya) = rotateV startA (V2 rad 0)
(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) (0))
(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0)
(V2 xc yc) = rotateV endA (V2 rad 0)
f (pos,col,V3 a b c) = Verx pos col [a,b,c] 0 arcNum
withAlpha :: Float -> RGBA -> RGBA
{-# INLINE withAlpha #-}
withAlpha a (V4 x y z a') = (V4 x y z (a*a'))
withAlpha a (V4 x y z a') = V4 x y z (a*a')
red,green,blue,yellow,cyan,magenta,rose
,violet,azure,aquamarine,chartreuse,orange,white,black::Color
@@ -350,23 +350,23 @@ mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
normrata = rata / fullrat
normratb = ratb / fullrat
f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int)
in (V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2))
in V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2)
light :: Color -> Color
{-# INLINE light #-}
light (V4 r g b a) = (V4 (r+0.2) (g+0.2) (b+0.2) (a))
light (V4 r g b a) = V4 (r+0.2) (g+0.2) (b+0.2) a
dark :: Color -> Color
{-# INLINE dark #-}
dark (V4 r g b a) = (V4 (r-0.2) (g-0.2) (b-0.2) (a))
dark (V4 r g b a) = V4 (r-0.2) (g-0.2) (b-0.2) a
dim :: Color -> Color
{-# INLINE dim #-}
dim (V4 r g b a) = (V4 (r/1.2) (g/1.2) (b/1.2) (a))
dim (V4 r g b a) = V4 (r/1.2) (g/1.2) (b/1.2) a
bright :: Color -> Color
{-# INLINE bright #-}
bright (V4 r g b a) = (V4 (r*1.2) (g*1.2) (b*1.2) (a))
bright (V4 r g b a) = V4 (r*1.2) (g*1.2) (b*1.2) a
greyN :: Float -> Color
{-# INLINE greyN #-}
@@ -392,12 +392,12 @@ stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
{-# INLINE charToTuple #-}
charToTuple x c =
[((V3 (x-50) (-100) (0)), white,(V2 offset 1))
,((V3 (x-50) (100) (0)), white,(V2 offset 0))
,((V3 (x+50) (100) (0)), white,(V2 (offset+1) 0))
,((V3 (x-50) (-100) (0)), white,(V2 offset 1))
,((V3 (x+50) (-100) (0)), white,(V2 (offset+1) 1))
,((V3 (x+50) (100) (0)), white,(V2 (offset+1) 0))
[(V3 (x-50) (-100) 0, white,V2 offset 1)
,(V3 (x-50) 100 0, white,V2 offset 0)
,(V3 (x+50) 100 0, white,V2 (offset+1) 0)
,(V3 (x-50) (-100) 0, white,V2 offset 1)
,(V3 (x+50) (-100) 0, white,V2 (offset+1) 1)
,(V3 (x+50) 100 0, white,V2 (offset+1) 0)
]
where
offset = fromIntegral (fromEnum c) - 32
src/Polyhedra.hs
+5 -5
View File
@@ -15,7 +15,7 @@ import Control.Lens
translateXY :: Float -> Float -> Polyhedra -> Polyhedra
translateXY x y = pyFaces %~ map (map $ first tran)
where
tran (V3 a b c) = (V3 (a+x) (b+y) (c))
tran (V3 a b c) = V3 (a+x) (b+y) c
rotateXY :: Float -> Polyhedra -> Polyhedra
rotateXY a = over pyFaces $ map $ map $ first $ rotate3 a
@@ -49,7 +49,7 @@ faceEdges xs = zipWith addNormal xs (tail xs ++ [head xs])
rhombus :: Point3 -> Point3 -> [Point3]
rhombus a b =
[(V3 0 0 0)
[V3 0 0 0
,a
,a +.+.+ b
,b
@@ -58,11 +58,11 @@ rhombus a b =
boxXYZ :: Float -> Float -> Float -> [[Point3]]
boxXYZ x y z =
[ bottomFace
, map (+.+.+ (V3 0 0 z)) $ reverse bottomFace
, map (+.+.+ V3 0 0 z) $ reverse bottomFace
, frontFace
, map (+.+.+ (V3 0 y 0)) $ reverse frontFace
, map (+.+.+ V3 0 y 0) $ reverse frontFace
, sideFace
, map (+.+.+ (V3 x 0 0)) $ reverse sideFace
, map (+.+.+ V3 x 0 0) $ reverse sideFace
]
where
bottomFace = rhombus (V3 0 y 0) (V3 x 0 0)
src/Preload/Render.hs
-4
View File
@@ -217,7 +217,3 @@ cleanUpRenderPreload pd = do
freeShaderPointers $ _lightingOccludeShader pd
freeShaderPointers $ _fullscreenShader pd
vert, geom, frag :: ShaderType
vert = VertexShader
geom = GeometryShader
frag = FragmentShader
src/Render.hs
+2 -2
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections #-}
--{-# LANGUAGE TupleSections #-}
module Render
where
import Shader
@@ -59,7 +59,7 @@ createLightMap pdata lightPoints nWalls nSils nsurfVs = do
blendFunc $= (Zero, OneMinusSrcAlpha)
stencilTest $= Enabled
depthFunc $= Just Lequal
forM_ lightPoints $ \((V3 x y z),r,lum) -> do
forM_ lightPoints $ \(V3 x y z,r,lum) -> do
-- stencil out shadows
colorMask $= Color4 Disabled Disabled Disabled Disabled
clear [StencilBuffer]
src/Shader/Compile.hs
+2 -3
View File
@@ -47,7 +47,7 @@ makeShaderUsingShaderVAO
makeShaderUsingShaderVAO s shaderlist pm fs = do
prog <- makeSourcedShader s shaderlist
return $ fs
{_shaderProgram = prog
{ _shaderProgram = prog
, _shaderDrawPrimitive = pm
, _shaderTexture = Nothing
, _shaderCustomUnis = []
@@ -60,8 +60,7 @@ makeShader
:: String -- ^ First part of the name of the shader
-> [ShaderType] -- ^ Filetype extensions
-> [Int] -- ^ The input vertex sizes
-> EPrimitiveMode
-> IO FullShader
-> EPrimitiveMode -> IO FullShader
makeShader s shaderlist sizes pm = do
prog <- makeSourcedShader s shaderlist
vaob <- setupVAO sizes
src/Shader/Data.hs
+10 -11
View File
@@ -33,6 +33,10 @@ module Shader.Data
, psText
, psArc
, psEll
, vert
, geom
, frag
-- TODO make lenses for VBO object
-- , textureObject
@@ -138,8 +142,6 @@ instance Traversable PicShads where
, _psArc = x4
, _psEll = x5
} = PicShads <$> f x0 <*> f x1 <*> f x2 <*> f x3 <*> f x4 <*> f x5
{- | Datatype containing the necessary information for a single shader. -}
data FullShader = FullShader
{ _shaderProgram :: Program
@@ -151,15 +153,6 @@ data FullShader = FullShader
{- | Datatype containing the reference to a texture object. -}
newtype ShaderTexture = ShaderTexture
{ _textureObject :: TextureObject }
--data PicVerxs = PicVerxs
-- { _pvPoly :: (Point3,Point4)
-- , _pvPolyz :: (Point3,Point4,Float)
-- , _pvBez :: (Point3,Point4,Point4)
-- , _pvText :: (Point3,Point4,Point2)
-- , _pvArc :: (Point3,Point3,Point3)
-- , _pvEll :: (Point3,Point4)
-- }
data EPrimitiveMode
= EPoints
| ELines
@@ -174,6 +167,12 @@ data EPrimitiveMode
| EPolygon
| EPatches
-- | Short synonyms for shader types
vert, geom, frag :: ShaderType
vert = VertexShader
geom = GeometryShader
frag = FragmentShader
makeLenses ''VAO
makeLenses ''FullShader
makeLenses ''VShader
src/Shader/Poke.hs
+2 -2
View File
@@ -45,7 +45,7 @@ vToPicShad mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
pokeVerx :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO ()
--{-# INLINE pokeVerx #-}
pokeVerx vbos offsets !Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
typeOff <- MV.unsafeRead offsets sn
let thePtr = plusPtr (_vboPtr $ vboFromType vbos sn) (typeOff * pokeStride sn * floatSize)
poke34 thePtr thePos theCol
@@ -73,7 +73,7 @@ pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
pokePoint33s ptr vals0 = go vals0 0
where
go [] n = return n
go ( !(V3 a b c,V3 d e f):vals) !n = do
go ( (V3 a b c,V3 d e f):vals) !n = do
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c