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
app/Main.hs → appDodge/Main.hs
View File
appDodge/Main.hs.orig
+101
View File
@@ -0,0 +1,101 @@
module Main where
import Loop
import Shader
import LoadConfig
import Dodge.Default
import Dodge.Data
import Dodge.Initialisation
import Dodge.Rooms
import Dodge.Layout
import Dodge.Update
import Dodge.Event
import Dodge.Render
import Dodge.Menu
import Dodge.Floor
import Dodge.LoadConfig
import Dodge.LoadSound
import Picture
import Picture.Render
import Picture.Preload
import Sound
import Preload
import Sound.Data
import Music
import Control.Concurrent
import Control.Lens
import Foreign (Word32)
import Control.Monad (when,void)
import System.Random
<<<<<<< HEAD
import qualified Data.Map as M
import qualified Data.IntMap as IM
=======
import System.Random
import qualified Data.Map as M
import Graphics.Rendering.OpenGL hiding (color, rotate, scale,
translate)
>>>>>>> testing
import qualified SDL
import qualified SDL.Mixer as Mix
doPreload' :: IO (PreloadData a)
doPreload' = do
lChunks <- loadSounds
lMusic <- loadMusic
let sData = SoundData {_loadedChunks = lChunks, _playingSounds = M.empty}
mData = MusicData {_loadedMusic = lMusic}
Mix.playMusic Mix.Forever (lMusic IM.! 0)
rData <- preloadRender
return $ PreloadData
{ _renderData = rData
, _soundData = sData
, _musicData = mData
, _frameTimer = 0
}
main :: IO ()
main = do
(sizex,sizey) <- loadConfig
keyConfig <- loadKeyConfig
setupLoop
(sizex,sizey)
(SDL.cursorVisible $= False >> doPreload' >>= resizeSpareFBO sizex sizey)
(\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x)
(fmap (setWindowSize sizex sizey keyConfig) firstWorld)
( \preData w -> do
startTicks <- SDL.ticks
void $ doDrawing (_renderData preData) w
playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)
endTicks <- SDL.ticks
let lastFrameTicks = _frameTimer preData
when (_debugMode w) $ void $ renderFoldable
(_renderData preData)
(picToLTree Nothing . setLayer 1 . setDepth (-1)
. translate (-0.5) (-0.8) . scale 0.0005 0.0005
. text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
)
return $ preData & soundData . playingSounds .~ newPlayingSounds
& frameTimer .~ endTicks
)
(flip $ menuEvents handleEvent)
(Just . update)
Mix.closeAudio
checkForGlErrors :: IO ()
checkForGlErrors = do
errs <- errors
when (length errs > 0) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs)
setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World
setWindowSize x y z w = w & windowX .~ fromIntegral x
& windowY .~ fromIntegral y
& keyConfig .~ z
package.yaml
+19 -1
View File
@@ -50,6 +50,7 @@ dependencies:
- extra
- primitive
- streaming
- repa
library:
source-dirs: src
@@ -60,7 +61,7 @@ executables:
# loop-exe:
dodge:
main: Main.hs
source-dirs: app
source-dirs: appDodge
ghc-options:
- -threaded
- -O2
@@ -77,6 +78,23 @@ executables:
# - -hiedir=.hie
dependencies:
- loop
hetris:
main: Hetris.hs
source-dirs: appHetris
ghc-options:
- -threaded
- -O2
- -rtsopts
- -with-rtsopts=-N
- -flate-dmd-anal
- -fno-liberate-case
- -fno-state-hack
- -funfolding-use-threshold1000
- -funfolding-keeness-factor1000
- -fllvm
- -optlo-O3
dependencies:
- loop
tests:
loop-test:
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
+25 -25
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 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
, 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)
, blockLine (V2 (negate w) w ) (V2 0 w)
]
, [ 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 (20) (2*w-40)) pi PutNothing
, 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
+1 -2
View File
@@ -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
@@ -34,6 +34,10 @@ module Shader.Data
, psArc
, psEll
, vert
, geom
, frag
-- TODO make lenses for VBO object
-- , textureObject
) where
@@ -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
stack.yaml
+1
View File
@@ -36,6 +36,7 @@ packages:
#
extra-deps:
- SDL-0.6.7.0@sha256:9d6ba75c0cab575ec38468c8277803983e985f9622437aeca6a53e6a7337a7d5,2045
- repa-3.4.1.4@sha256:5a99bde69fe96a18d70aae23f47c8f719b1134558dca3ee5a7c15423b68a132e,3323
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a