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:
justin
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 - extra
- primitive - primitive
- streaming - streaming
- repa
library: library:
source-dirs: src source-dirs: src
@@ -60,7 +61,7 @@ executables:
# loop-exe: # loop-exe:
dodge: dodge:
main: Main.hs main: Main.hs
source-dirs: app source-dirs: appDodge
ghc-options: ghc-options:
- -threaded - -threaded
- -O2 - -O2
@@ -77,6 +78,23 @@ executables:
# - -hiedir=.hie # - -hiedir=.hie
dependencies: dependencies:
- loop - 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: tests:
loop-test: 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 $ IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
where where
rec = [p, pR, pR1, pL1, pL ] rec = [p, pR, pR1, pL1, pL ]
pR = p +.+ rotateV (dir - pi*(3/8)) (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)) pL = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) 0)
pR1 = pR +.+ rotateV dir (V2 (x/2) (0)) pR1 = pR +.+ rotateV dir (V2 (x/2) 0)
pL1 = pL +.+ rotateV dir (V2 (x/2) (0)) pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
{- | Test whether a creature is in a polygon. -} {- | Test whether a creature is in a polygon. -}
crInPolygon :: Creature -> [Point2] -> Bool crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr = errorPointInPolygon 3 (_crPos cr) crInPolygon cr = errorPointInPolygon 3 (_crPos cr)
src/Dodge/Base/Collide.hs
+3 -3
View File
@@ -141,14 +141,14 @@ pathToPointFireable i p w
canSeePointAll :: Int -> Point2 -> World -> Bool canSeePointAll :: Int -> Point2 -> World -> Bool
canSeePointAll i targPos w canSeePointAll i targPos w
= all (flip (canSeePoint i) w . (\p -> targPos +.+ radius *.* p)) $ 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 where
cr = _creatures w IM.! i cr = _creatures w IM.! i
radius = _crRad cr radius = _crRad cr
canSeeAny :: Int -> Int -> World -> Bool canSeeAny :: Int -> Int -> World -> Bool
canSeeAny fromID toID w canSeeAny fromID toID w
= any (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) $ 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 where
cr = _creatures w IM.! toID cr = _creatures w IM.! toID
cpos = _crPos cr cpos = _crPos cr
@@ -156,7 +156,7 @@ canSeeAny fromID toID w
canSeeAll :: Int -> Int -> World -> Bool canSeeAll :: Int -> Int -> World -> Bool
canSeeAll fromID toID w canSeeAll fromID toID w
= all (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) $ 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 where
cr = _creatures w IM.! toID cr = _creatures w IM.! toID
cpos = _crPos cr cpos = _crPos cr
src/Dodge/Creature.hs
+2 -2
View File
@@ -140,8 +140,8 @@ addArmour = over crInv insarmour
ID 0. -} ID 0. -}
startCr :: Creature startCr :: Creature
startCr = defaultCreature startCr = defaultCreature
{ _crPos = (V2 0 0) { _crPos = V2 0 0
, _crOldPos = (V2 0 0) , _crOldPos = V2 0 0
, _crDir = pi/2 , _crDir = pi/2
, _crMvDir = pi/2 , _crMvDir = pi/2
, _crID = 0 , _crID = 0
src/Dodge/Creature/Action.hs
+2 -2
View File
@@ -68,8 +68,8 @@ blinkAction cr w = soundOnce teleSound
where where
distR = 120 distR = 120
distortionBulge = distortionBulge =
[(p3,p3 +.+ (V2 distR 0), p3 +.+ (V2 0 distR),0.1) [(p3,p3 +.+ V2 distR 0, p3 +.+ V2 0 distR,0.1)
,(cpos,cpos +.+ (V2 distR 0), cpos +.+ (V2 0 distR),1.9) ,(cpos,cpos +.+ V2 distR 0, cpos +.+ V2 0 distR,1.9)
] ]
cid = _crID cr cid = _crID cr
p1 = mouseWorldPos w 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 :: Point2 -> Creature -> Creature
creatureTurnTo p cr 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 | otherwise = cr & crDir .~ dirToTarget
where where
vToTarg = p -.- _crPos cr vToTarg = p -.- _crPos cr
@@ -82,7 +82,7 @@ creatureTurnTowardDir
-> Creature -> Creature
-> Creature -> Creature
creatureTurnTowardDir a turnSpeed cr 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 | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
= cr & crDir .~ dirToTarget = cr & crDir .~ dirToTarget
| isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
@@ -93,7 +93,7 @@ creatureTurnTowardDir a turnSpeed cr
creatureTurnToward :: Point2 -> Float -> Creature -> Creature creatureTurnToward :: Point2 -> Float -> Creature -> Creature
creatureTurnToward p turnSpeed cr 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 | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
= cr & crDir .~ dirToTarget = cr & crDir .~ dirToTarget
| isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
src/Dodge/Creature/Inanimate.hs
+2 -2
View File
@@ -36,7 +36,7 @@ lamp h = defaultInanimate
} }
lampPic :: Float -> Picture lampPic :: Float -> Picture
lampPic h = pictures 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 , 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 | otherwise = w & lightSources . ix i . lsPos .~ f cPos
where where
cPos = _crPos cr cPos = _crPos cr
f (V2 x y) = (V3 x y h) f (V2 x y) = V3 x y h
internalUpdate cr internalUpdate cr
| _crHP cr < 0 = Nothing | _crHP cr < 0 = Nothing
| otherwise = Just $ doDamage cr | otherwise = Just $ doDamage cr
src/Dodge/Creature/Picture.hs
+3 -3
View File
@@ -33,7 +33,7 @@ basicCrPict col cr w
targetingPic ++ targetingPic ++
[ tr . setDepth 0 $ color yellow $ circleSolid 10 [ tr . setDepth 0 $ color yellow $ circleSolid 10
, tr . piercingMod $ bluntScale $ naked col cr , tr . piercingMod $ bluntScale $ naked col cr
, tr $ torso (light4 col) (V2 (0) (-crad)) (V2 0 crad) , tr $ torso (light4 col) (V2 0 (-crad)) (V2 0 crad)
, trFeet $ feet cr , trFeet $ feet cr
, tr $ arms col cr , tr $ arms col cr
, tr $ drawEquipment cr , tr $ drawEquipment cr
@@ -104,7 +104,7 @@ arms col cr
torso :: Color -> Point2 -> Point2 -> Picture torso :: Color -> Point2 -> Point2 -> Picture
torso col x y = color col $ pictures torso col x y = color col $ pictures
[ poly3 [addZ 20 x, addZ 12 v, addZ 12 ((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 , setDepth 12 . rotate a . scale 1 1 $ circleSolid $ magV v
] ]
where where
@@ -171,7 +171,7 @@ drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
_ -> blank _ -> blank
circLine :: Float -> Picture 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 picAtCrPos :: Picture -> Creature -> World -> Picture
{-# INLINE picAtCrPos #-} {-# INLINE picAtCrPos #-}
src/Dodge/Creature/PistolCrit.hs
+2 -2
View File
@@ -93,7 +93,7 @@ chooseMovement' cr w = takeOneWeighted [chargeProb,retreatProb,strafeProb,strafe
`DoActionThen` `DoActionThen`
3 3
`DoReplicate` `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) yposl = ypos -.- 100 *.* vNormal (normalizeV $ ypos -.- cpos)
yposr = ypos +.+ 100 *.* vNormal (normalizeV $ ypos -.- cpos) yposr = ypos +.+ 100 *.* vNormal (normalizeV $ ypos -.- cpos)
@@ -103,7 +103,7 @@ retreatActions tcr cr =
`DoImpulsesAlongside` `DoImpulsesAlongside`
3 3
`DoReplicate` `DoReplicate`
ImpulsesList (replicate 9 [Move (V2 (-3) (0))] ++ [[UseItem]]) ImpulsesList (replicate 9 [Move (V2 (-3) 0)] ++ [[UseItem]])
where where
cpos = _crPos cr cpos = _crPos cr
tpos = _crPos tcr tpos = _crPos tcr
src/Dodge/Creature/SentinelAI.hs
+4 -4
View File
@@ -39,7 +39,7 @@ sentinelAI = sentinelExtraWatchUpdate
DoImpulses [ChangeStrategy WatchAndWait] DoImpulses [ChangeStrategy WatchAndWait]
, AimAtCloseSlow , AimAtCloseSlow
{ _targetID = tcid { _targetID = tcid
, _targetSeenAt = (V2 0 0) -- hack , _targetSeenAt = V2 0 0 -- hack
, _aimSpeed = 0.2 , _aimSpeed = 0.2
, _slowAimSpeed = 0.01 , _slowAimSpeed = 0.01
, _slowAimAngle = pi/8 , _slowAimAngle = pi/8
@@ -72,7 +72,7 @@ sentinelFireType f = performActionsR
drawwp = DoActionIfElse NoAction crIsAiming (DoActionThen drawWeapon (WaitThen 50 NoAction)) drawwp = DoActionIfElse NoAction crIsAiming (DoActionThen drawWeapon (WaitThen 50 NoAction))
aiming = AimAtCloseSlow aiming = AimAtCloseSlow
{ _targetID = 0 { _targetID = 0
, _targetSeenAt = (V2 0 0) -- hack , _targetSeenAt = V2 0 0 -- hack
, _aimSpeed = 0.2 , _aimSpeed = 0.2
, _slowAimSpeed = 0.01 , _slowAimSpeed = 0.01
, _slowAimAngle = pi/8 , _slowAimAngle = pi/8
@@ -104,7 +104,7 @@ shootAtAdvance tcid =
DoImpulses [ChangeStrategy WatchAndWait] DoImpulses [ChangeStrategy WatchAndWait]
, AimAtCloseSlow , AimAtCloseSlow
{ _targetID = tcid { _targetID = tcid
, _targetSeenAt = (V2 0 0) -- hack , _targetSeenAt = V2 0 0 -- hack
, _aimSpeed = 0.2 , _aimSpeed = 0.2
, _slowAimSpeed = 0.01 , _slowAimSpeed = 0.01
, _slowAimAngle = pi/8 , _slowAimAngle = pi/8
@@ -125,7 +125,7 @@ shootAtWhileContinueTime tcid _ _ = StrategyActions (ShootAt tcid)
DoImpulses [ChangeStrategy WatchAndWait] DoImpulses [ChangeStrategy WatchAndWait]
, AimAtCloseSlow , AimAtCloseSlow
{ _targetID = tcid { _targetID = tcid
, _targetSeenAt = (V2 0 0) -- hack , _targetSeenAt = V2 0 0 -- hack
, _aimSpeed = 0.2 , _aimSpeed = 0.2
, _slowAimSpeed = 0.01 , _slowAimSpeed = 0.01
, _slowAimAngle = pi/8 , _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. velocity to carry across frames.
-} -}
crFriction :: Creature -> Point2 -> Point2 crFriction :: Creature -> Point2 -> Point2
crFriction _ _ = (V2 0 0) crFriction _ _ = V2 0 0
doDamage :: Creature -> Creature doDamage :: Creature -> Creature
doDamage cr = set (crState . crDamage) [] 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 | otherwise = theTurn $ theMovement cr
where where
theMovement theMovement
| movDir == (V2 0 0) = id | movDir == V2 0 0 = id
| otherwise = crMvAbsolute (speed *.* movAbs) . set crMvDir dir | otherwise = crMvAbsolute (speed *.* movAbs) . set crMvDir dir
theTurn cr' = creatureTurnTowardDir (_crMvDir cr') 0.2 cr' theTurn cr' = creatureTurnTowardDir (_crMvDir cr') 0.2 cr'
movDir = wasdDir w movDir = wasdDir w
@@ -53,11 +53,11 @@ wasdWithAiming w speed i cr
wasdM :: World -> SDL.Scancode -> Point2 wasdM :: World -> SDL.Scancode -> Point2
wasdM w scancode wasdM w scancode
| scancode == moveUpKey (_keyConfig w) = ( V2 (0) ( 1)) | scancode == moveUpKey (_keyConfig w) = V2 0 1
| scancode == moveDownKey (_keyConfig w) = (V2 ( 0) (-1)) | scancode == moveDownKey (_keyConfig w) = V2 0 (-1)
| scancode == moveRightKey (_keyConfig w) = (V2 ( 1) ( 0)) | scancode == moveRightKey (_keyConfig w) = V2 1 0
| scancode == moveLeftKey (_keyConfig w) = (V2 (-1) ( 0)) | scancode == moveLeftKey (_keyConfig w) = V2 (-1) 0
wasdM _ _ = (V2 0 0) wasdM _ _ = V2 0 0
wasdDir :: World -> Point2 wasdDir :: World -> Point2
wasdDir w = foldr ((+.+) . wasdM w) (V2 0 0) $ _keys w 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 :: S.Set SDL.Scancode -> World -> (Point2,Maybe Float)
wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (V2 0 0) ks wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (V2 0 0) ks
where 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) f p = (errorNormalizeV 46 p, Just $ argV p)
{- | Set posture according to mouse presses. -} {- | 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)) , _ffDeflect :: Maybe (StdGen -> Point2 -> ForceField -> (Point2,StdGen))
, _ffState :: FFState , _ffState :: FFState
} }
data FFState = FFDestroyable { _ffsHP :: Int } newtype FFState = FFDestroyable { _ffsHP :: Int }
data ActionPlan data ActionPlan
= Inanimate = Inanimate
src/Dodge/Debug.hs
+3 -3
View File
@@ -13,7 +13,7 @@ drawCircleAtFor p t w = w & projectiles %~
IM.insert k Projectile IM.insert k Projectile
{ _pjPos = p { _pjPos = p
, _pjStartPos = p , _pjStartPos = p
, _pjVel = (V2 0 0) , _pjVel = V2 0 0
, _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20 , _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
, _pjID = k , _pjID = k
, _pjUpdate = \_ -> pjTimerF t k , _pjUpdate = \_ -> pjTimerF t k
@@ -25,7 +25,7 @@ drawCircleAtForCol p t col w = w & projectiles %~
IM.insert k Projectile IM.insert k Projectile
{ _pjPos = p { _pjPos = p
, _pjStartPos = p , _pjStartPos = p
, _pjVel = (V2 0 0) , _pjVel = V2 0 0
, _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color col $ circleSolid 20 , _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color col $ circleSolid 20
, _pjID = k , _pjID = k
, _pjUpdate = \_ -> pjTimerF t k , _pjUpdate = \_ -> pjTimerF t k
@@ -37,7 +37,7 @@ drawLineForCol ps t col w = w & projectiles %~
IM.insert k Projectile IM.insert k Projectile
{ _pjPos = head ps { _pjPos = head ps
, _pjStartPos = head ps , _pjStartPos = head ps
, _pjVel = (V2 0 0) , _pjVel = V2 0 0
, _pjDraw = \_ -> onLayer PtLayer $ color col $ lineOfThickness 5 ps , _pjDraw = \_ -> onLayer PtLayer $ color col $ lineOfThickness 5 ps
, _pjID = k , _pjID = k
, _pjUpdate = \_ -> pjTimerF t k , _pjUpdate = \_ -> pjTimerF t k
src/Dodge/Default.hs
+9 -9
View File
@@ -22,9 +22,9 @@ import Data.List
defaultCreature :: Creature defaultCreature :: Creature
defaultCreature = Creature defaultCreature = Creature
{ _crPos = (V2 0 0) { _crPos = V2 0 0
, _crOldPos = (V2 0 0) , _crOldPos = V2 0 0
, _crVel = (V2 0 0) , _crVel = V2 0 0
, _crDir = 0 , _crDir = 0
, _crMvDir = 0 , _crMvDir = 0
, _crID = 1 , _crID = 1
@@ -127,7 +127,7 @@ applyIndividualDamage (PushDam amount pback) cr
applyIndividualDamage dt cr applyIndividualDamage dt cr
= ( id , over crHP (\hp -> hp - _dmAmount dt) cr ) = ( id , over crHP (\hp -> hp - _dmAmount dt) cr )
defaultFlIt :: FloorItem 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 :: Item
defaultIt = Consumable defaultIt = Consumable
{ _itIdentity = Medkit25 { _itIdentity = Medkit25
@@ -147,7 +147,7 @@ defaultIt = Consumable
defaultButton :: Button defaultButton :: Button
defaultButton = Button defaultButton = Button
{ _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10) { _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (V2 0 0) , _btPos = V2 0 0
, _btRot = 0 , _btRot = 0
, _btEvent = \b w -> , _btEvent = \b w ->
set (buttons . ix (_btID b) . btPict) (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10)) 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
defaultPT = Projectile defaultPT = Projectile
{ _pjPos = (V2 0 0) { _pjPos = V2 0 0
, _pjStartPos = (V2 0 0) , _pjStartPos = V2 0 0
, _pjVel = (V2 0 0) , _pjVel = V2 0 0
, _pjDraw = const blank , _pjDraw = const blank
, _pjID = 0 , _pjID = 0
, _pjUpdate = const id , _pjUpdate = const id
@@ -169,7 +169,7 @@ defaultPT = Projectile
defaultPP :: PressPlate defaultPP :: PressPlate
defaultPP = PressPlate defaultPP = PressPlate
{ _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright blue) $ circleSolid 5 { _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright blue) $ circleSolid 5
, _ppPos = (V2 0 0) , _ppPos = V2 0 0
, _ppRot = 0 , _ppRot = 0
, _ppEvent = const id , _ppEvent = const id
, _ppID = -1 , _ppID = -1
src/Dodge/Default/Shell.hs
+4 -4
View File
@@ -6,10 +6,10 @@ import Geometry.Data
defaultShell :: Projectile defaultShell :: Projectile
defaultShell = Shell defaultShell = Shell
{ _pjPos = (V2 0 0) { _pjPos = V2 0 0
, _pjStartPos = (V2 0 0) , _pjStartPos = V2 0 0
, _pjVel = (V2 0 0) , _pjVel = V2 0 0
, _pjAcc = (V2 0 0) , _pjAcc = V2 0 0
, _pjDir = 0 , _pjDir = 0
, _pjSpin = 0 , _pjSpin = 0
, _pjDraw = const blank , _pjDraw = const blank
src/Dodge/Default/Wall.hs
+6 -6
View File
@@ -7,7 +7,7 @@ import Geometry.Data
{- Indestructible wall. -} {- Indestructible wall. -}
defaultWall :: Wall defaultWall :: Wall
defaultWall = Wall defaultWall = Wall
{ _wlLine = ((V2 0 0),(V2 50 0)) { _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0 , _wlID = 0
, _wlColor = greyN 0.6 , _wlColor = greyN 0.6
, _wlSeen = False , _wlSeen = False
@@ -16,7 +16,7 @@ defaultWall = Wall
{- Indestructible see-through wall. -} {- Indestructible see-through wall. -}
defaultCrystalWall :: Wall defaultCrystalWall :: Wall
defaultCrystalWall = Wall defaultCrystalWall = Wall
{ _wlLine = ((V2 0 0),(V2 50 0)) { _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0 , _wlID = 0
, _wlColor = withAlpha 0.5 aquamarine , _wlColor = withAlpha 0.5 aquamarine
, _wlSeen = False , _wlSeen = False
@@ -26,26 +26,26 @@ defaultCrystalWall = Wall
Pathable. -} Pathable. -}
defaultAutoDoor :: Wall defaultAutoDoor :: Wall
defaultAutoDoor = Door defaultAutoDoor = Door
{ _wlLine = ((V2 0 0),(V2 50 0)) { _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0 , _wlID = 0
, _doorMech = id , _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow , _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False , _wlSeen = False
, _wlIsSeeThrough = False , _wlIsSeeThrough = False
, _doorPathable = True , _doorPathable = True
, _drPositions = DS.singleton ((V2 0 0),(V2 50 0)) , _drPositions = DS.singleton (V2 0 0,V2 50 0)
} }
{- {-
Non-pathable door. Non-pathable door.
-} -}
defaultDoor :: Wall defaultDoor :: Wall
defaultDoor = Door defaultDoor = Door
{ _wlLine = ((V2 0 0),(V2 50 0)) { _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0 , _wlID = 0
, _doorMech = id , _doorMech = id
, _wlColor = light $ dim $ dim $ dim yellow , _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False , _wlSeen = False
, _wlIsSeeThrough = False , _wlIsSeeThrough = False
, _doorPathable = 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 defaultWorld = World
{ _keys = S.empty { _keys = S.empty
, _mouseButtons = S.empty , _mouseButtons = S.empty
, _cameraCenter = (V2 0 0) , _cameraCenter = V2 0 0
, _cameraRot = 0 , _cameraRot = 0
, _cameraZoom = 1 , _cameraZoom = 1
, _cameraViewFrom = (V2 0 0) , _cameraViewFrom = V2 0 0
, _creatures = IM.empty , _creatures = IM.empty
, _creaturesZone = IM.empty , _creaturesZone = IM.empty
, _creatureGroups = IM.empty , _creatureGroups = IM.empty
@@ -40,7 +40,7 @@ defaultWorld = World
, _floorItems = IM.empty , _floorItems = IM.empty
, _floorTiles = [] , _floorTiles = []
, _randGen = mkStdGen 2 , _randGen = mkStdGen 2
, _mousePos = (V2 0 0) , _mousePos = V2 0 0
, _testString = [] , _testString = []
, _yourID = 0 , _yourID = 0
, _worldEvents = id , _worldEvents = id
@@ -54,13 +54,13 @@ defaultWorld = World
, _menuLayers = [LevelMenu 1] , _menuLayers = [LevelMenu 1]
, _worldState = M.empty , _worldState = M.empty
, _worldTriggers = S.empty , _worldTriggers = S.empty
, _clickMousePos = (V2 0 0) , _clickMousePos = V2 0 0
, _pathGraph = Data.Graph.Inductive.Graph.empty , _pathGraph = Data.Graph.Inductive.Graph.empty
, _pathGraph' = [] , _pathGraph' = []
, _pathPoints = IM.empty , _pathPoints = IM.empty
, _pathInc = M.empty , _pathInc = M.empty
, _carteDisplay = False , _carteDisplay = False
, _carteCenter = (V2 0 0) , _carteCenter = V2 0 0
, _carteZoom = 0.5 , _carteZoom = 0.5
, _carteRot = 0 , _carteRot = 0
, _lightSources = IM.empty , _lightSources = IM.empty
@@ -89,10 +89,10 @@ defaultDebugFlags = DebugFlags
} }
youLight :: TempLightSource youLight :: TempLightSource
youLight = youLight =
TLS { _tlsPos = (V3 0 0 0) TLS { _tlsPos = V3 0 0 0
,_tlsRad = 300 ,_tlsRad = 300
,_tlsIntensity = 0.1 ,_tlsIntensity = 0.1
,_tlsUpdate = \w _ -> (w, Just (youLight {_tlsPos = f $ _crPos (you w)})) ,_tlsUpdate = \w _ -> (w, Just (youLight {_tlsPos = f $ _crPos (you w)}))
} }
where where
f (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 dropLight w = placeLS ls dec pos 0 w
where --(rot, g) = randomR (-pi,pi) $ _randGen w where --(rot, g) = randomR (-pi,pi) $ _randGen w
(V2 x y) = _crPos (you w) (V2 x y) = _crPos (you w)
pos = (V3 x y 0) pos = V3 x y 0
ls = lightAt pos 0 ls = lightAt pos 0
dec = onLayer PtLayer $ color white $ circleSolid 8 dec = onLayer PtLayer $ color white $ circleSolid 8
src/Dodge/Initialisation.hs
+4 -3
View File
@@ -27,7 +27,7 @@ firstWorld = do
initialWorld :: World initialWorld :: World
initialWorld = defaultWorld initialWorld = defaultWorld
{ _keys = S.empty { _keys = S.empty
, _cameraCenter = (V2 0 0) , _cameraCenter = V2 0 0
, _cameraRot = 0 , _cameraRot = 0
, _cameraZoom = 10 , _cameraZoom = 10
, _creatures = IM.fromList [(0,startCr)] , _creatures = IM.fromList [(0,startCr)]
@@ -36,10 +36,11 @@ initialWorld = defaultWorld
, _forceFields = IM.empty , _forceFields = IM.empty
, _floorItems = IM.empty , _floorItems = IM.empty
, _randGen = mkStdGen 2 , _randGen = mkStdGen 2
, _mousePos = (V2 0 0) , _mousePos = V2 0 0
, _testString = [] , _testString = []
, _yourID = 0 , _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 , _pressPlates = IM.empty
, _buttons = IM.empty , _buttons = IM.empty
, _soundQueue = [] , _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 :: Int -> Int -> Int -> World -> World
retireRemoteBomb itid 0 pjid w = w retireRemoteBomb itid 0 pjid w = w
& pointToItem (_itemPositions w IM.! itid) %~ & pointToItem (_itemPositions w IM.! itid) %~
( (itAttachment . _Just . scopePos .~ (V2 0 0)) ( (itAttachment . _Just . scopePos .~ V2 0 0)
. (itZoom .~ defaultItZoom) . (itZoom .~ defaultItZoom)
. (itUse .~ (\_ -> hammerCheck throwRemoteBomb)) . (itUse .~ (\_ -> hammerCheck throwRemoteBomb))
) )
@@ -754,7 +754,7 @@ fireRemoteLauncher cr w = setLocation
i = IM.newKey $ _projectiles w i = IM.newKey $ _projectiles w
cid = _crID cr cid = _crID cr
dir = _crDir 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 remRocket = IM.insert i $ Shell
{ _pjPos = pos { _pjPos = pos
, _pjStartPos = pos , _pjStartPos = pos
@@ -762,7 +762,7 @@ fireRemoteLauncher cr w = setLocation
, _pjDraw = remoteShellPic' , _pjDraw = remoteShellPic'
, _pjID = i , _pjID = i
, _pjUpdate = \pj -> decTimMvVel pj . setRemoteScope itid pj . moveRemoteShell cid itid pj , _pjUpdate = \pj -> decTimMvVel pj . setRemoteScope itid pj . moveRemoteShell cid itid pj
, _pjAcc = (V2 0 0) , _pjAcc = V2 0 0
, _pjDir = dir , _pjDir = dir
, _pjSpin = 0 , _pjSpin = 0
, _pjPayload = makeExplosionAt , _pjPayload = makeExplosionAt
@@ -864,8 +864,8 @@ throwRemoteBomb cr w = setLocation
removePict = set (creatures . ix cid . crInv . ix j . itEquipPict) $ \ _ _ -> blank removePict = set (creatures . ix cid . crInv . ix j . itEquipPict) $ \ _ _ -> blank
resetFire = set (creatures . ix cid . crInv . ix j . itUse) resetFire = set (creatures . ix cid . crInv . ix j . itUse)
$ \_ -> hammerCheck $ explodeRemoteBomb itid i $ \_ -> hammerCheck $ explodeRemoteBomb itid i
p' = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr) (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)) p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr-4) 0)
| otherwise = p' | otherwise = p'
maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just
setLocation :: World -> World 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 controlp = mouseWorldPos w
cid = _crID cr cid = _crID cr
dir = _crDir 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 (randPos,randPos') = flip evalState (_randGen w) $ do
a <- randInCirc 10 a <- randInCirc 10
b <- randInCirc 20 b <- randInCirc 20
src/Dodge/Item/Weapon/Bullet.hs
+2 -2
View File
@@ -10,12 +10,12 @@ basicBullet = BulletAmmo
{ _amString = "BULLET" { _amString = "BULLET"
, _amBulEff = destroyOnImpact bulHitCr bulHitWall' bulHitFF' , _amBulEff = destroyOnImpact bulHitCr bulHitWall' bulHitFF'
, _amBulWth = 2 , _amBulWth = 2
, _amBulVel = (V2 30 0) , _amBulVel = V2 30 0
} }
hvBullet :: Ammo hvBullet :: Ammo
hvBullet = BulletAmmo hvBullet = BulletAmmo
{ _amString = "HVBULLET" { _amString = "HVBULLET"
, _amBulEff = penWalls hvBulHitCr hvBulHitWall' bulHitFF' , _amBulEff = penWalls hvBulHitCr hvBulHitWall' bulHitFF'
, _amBulWth = 6 , _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 cursorPic w' = setLayer 1 $ onLayer InvLayer $ uncurryV translate mwp
$ rotate (_cameraRot w') $ rotate (_cameraRot w')
$ pictures $ 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 where
x = 5 / _cameraZoom w' 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' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w)
v | magV v' > 6 = 6 *.* normalizeV v' v | magV v' > 6 = 6 *.* normalizeV v'
| otherwise = v' | otherwise = v'
p' = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr) (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)) p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr-4) 0)
| otherwise = p' | otherwise = p'
dir = argV v dir = argV v
setWp :: World -> World setWp :: World -> World
src/Dodge/Item/Weapon/TriggerType.hs
+4 -4
View File
@@ -128,7 +128,7 @@ withRecoil
withRecoil recoilAmount eff cr = eff cr . over (creatures . ix cid) pushback withRecoil recoilAmount eff cr = eff cr . over (creatures . ix cid) pushback
where where
cid = _crID cr 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. {- | Pushes a creature sideways by a random amount.
Applied before the underlying effect. -} Applied before the underlying effect. -}
withSidePush withSidePush
@@ -140,7 +140,7 @@ withSidePush
withSidePush maxSide eff cr w = eff cr . over (creatures . ix cid) push $ w withSidePush maxSide eff cr w = eff cr . over (creatures . ix cid) push $ w
where where
cid = _crID cr 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 (pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
-- consider unifying the pushes using a direction vector -- consider unifying the pushes using a direction vector
{- | Pushes a creature sideways by a random amount. {- | 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 withSidePushAfter maxSide eff cr w = over (creatures . ix cid) push . eff cr $ w
where where
cid = _crID cr 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 (pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
{- | Applies a world effect and sound effect after an ammo check. -} {- | Applies a world effect and sound effect after an ammo check. -}
shootWithSound shootWithSound
@@ -462,7 +462,7 @@ numVelWthHitEff num vel wth eff cr = over particles (newbuls ++)
d = _crDir cr d = _crDir cr
poss = map (+.+ pos) $ take num offsets poss = map (+.+ pos) $ take num offsets
maxOffset = fromIntegral num * 2.5 - 2.5 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 pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle d
{- | Uses '_wpSpread' as a parameter for the current offset angle. -} {- | Uses '_wpSpread' as a parameter for the current offset angle. -}
randWalkAngle randWalkAngle
src/Dodge/Layout.hs
+2 -2
View File
@@ -68,7 +68,7 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
plmnts = concatMap _rmPS $ flatten tr plmnts = concatMap _rmPS $ flatten tr
path = pairsToGraph dist pairGraph path = pairsToGraph dist pairGraph
pairGraph = makePath tr pairGraph = makePath tr
insertPoint pp@(_,(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 pinc = M.fromList $ pairsToIncidence pairGraph
initializeStaticWalls :: World -> World initializeStaticWalls :: World -> World
@@ -160,7 +160,7 @@ shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
(_rmLinks t) (_rmLinks t)
ts ts
where where
f r = shiftRoomBy ( (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 where
(p,a) = last $ _rmLinks r (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 --_ -> w
where where
p@(V2 px py) = _psPos ps p@(V2 px py) = _psPos ps
p' = (V3 px py 0) p' = V3 px py 0
rot = _psRot ps rot = _psRot ps
-- TODO: remove this typeclass -- TODO: remove this typeclass
@@ -196,7 +196,7 @@ placeLS ls dec (V3 x y z) rot w = over lightSources addLS $ over decorations add
where where
addLS lss = IM.insert addLS lss = IM.insert
(IM.newKey lss) (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 lss
addDec decs = IM.insert addDec decs = IM.insert
(IM.newKey decs) (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 w
where where
pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w 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' 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 cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
brokenWalls :: [(Point2,Point2)] 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))] [((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)] --intersectingBrokenWalls :: [(Point2,Point2)]
src/Dodge/LevelGen/Switch.hs
+2 -2
View File
@@ -15,7 +15,7 @@ makeButton
-> Button -> Button
makeButton c eff = Button makeButton c eff = Button
{ _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10) { _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (V2 0 0) , _btPos = V2 0 0
, _btRot = 0 , _btRot = 0
, _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b)) , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
-- . set (buttons . ix (_btID b) . btPict) -- . set (buttons . ix (_btID b) . btPict)
@@ -39,7 +39,7 @@ makeSwitch
-> Button -> Button
makeSwitch c effOn effOff = Button makeSwitch c effOn effOff = Button
{ _btPict = offPict { _btPict = offPict
, _btPos = (V2 0 0) , _btPos = V2 0 0
, _btRot = 0 , _btRot = 0
, _btEvent = flipSwitch , _btEvent = flipSwitch
, _btID = 0 , _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)) (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
$ _pathGraph' w $ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs 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 ++) eff w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y) f (x,y) = (x,y,dist x y)
@@ -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)) (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
$ _pathGraph' w $ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs 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 ++) openDoor w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y) f (x,y) = (x,y,dist x y)
src/Dodge/LightSources.hs
+5 -5
View File
@@ -12,7 +12,7 @@ import Geometry.Data
lightAt :: Point3 -> Int -> LightSource lightAt :: Point3 -> Int -> LightSource
lightAt (V3 x y z) i = lightAt (V3 x y z) i =
LS {_lsID = i LS {_lsID = i
,_lsPos = (V3 x y z) ,_lsPos = V3 x y z
,_lsDir = 0 ,_lsDir = 0
,_lsRad = 700 ,_lsRad = 700
,_lsIntensity = 0.75 ,_lsIntensity = 0.75
@@ -25,13 +25,13 @@ basicLS = PutLS ls dec
tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
tLightFade 0 rmax intensityF (V2 x y) = TLS tLightFade 0 rmax intensityF (V2 x y) = TLS
{ _tlsPos = (V3 x y 0) { _tlsPos = V3 x y 0
, _tlsRad = rmax , _tlsRad = rmax
, _tlsIntensity = intensityF 0 , _tlsIntensity = intensityF 0
, _tlsUpdate = \w _ -> (w, Nothing) , _tlsUpdate = \w _ -> (w, Nothing)
} }
tLightFade i rmax intensityF p@(V2 x y) = TLS tLightFade i rmax intensityF p@(V2 x y) = TLS
{ _tlsPos = (V3 x y 0) { _tlsPos = V3 x y 0
, _tlsRad = rmax , _tlsRad = rmax
, _tlsIntensity = intensityF i , _tlsIntensity = intensityF i
, _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p) , _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p)
@@ -44,13 +44,13 @@ tLightRad
-> Point2 -> Point2
-> TempLightSource -> TempLightSource
tLightRad 0 rmax _ (V2 x y) = TLS tLightRad 0 rmax _ (V2 x y) = TLS
{ _tlsPos = (V3 x y 0) { _tlsPos = V3 x y 0
, _tlsRad = rmax , _tlsRad = rmax
, _tlsIntensity = 0.5 , _tlsIntensity = 0.5
, _tlsUpdate = \w _ -> (w, Nothing) , _tlsUpdate = \w _ -> (w, Nothing)
} }
tLightRad i rmax rmin p@(V2 x y) = TLS tLightRad i rmax rmin p@(V2 x y) = TLS
{ _tlsPos = (V3 x y 0) { _tlsPos = V3 x y 0
, _tlsRad = rmax , _tlsRad = rmax
, _tlsIntensity = 0.5 , _tlsIntensity = 0.5
, _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p) , _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 Dodge.Data
import Control.Lens import Control.Lens
data Lock = Lock newtype Lock = Lock
{ _lkUnlocker :: Unlocker { _lkUnlocker :: Unlocker
} }
data Unlocker newtype Unlocker
= ItemUnlocker Item = ItemUnlocker Item
makeLenses ''Lock 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' aCurveBulAt maycid col pos control targ hiteff width = Bul'
{ _ptDraw = drawBul { _ptDraw = drawBul
, _ptUpdate' = \w -> mvGenBullet w . setVel , _ptUpdate' = \w -> mvGenBullet w . setVel
, _btVel' = (V2 0 0) , _btVel' = V2 0 0
, _btColor' = col , _btColor' = col
, _btTrail' = [pos] , _btTrail' = [pos]
, _btPassThrough' = maycid , _btPassThrough' = maycid
src/Dodge/Path.hs
+5 -6
View File
@@ -19,9 +19,8 @@ import Control.Monad.State
import System.Random import System.Random
worldGraph :: World -> Point2 -> HS.HashSet Point2 worldGraph :: World -> Point2 -> HS.HashSet Point2
worldGraph w p = HS.unions $ fmap (\q -> HS.fromList $ pointsAlong w p (p +.+ q)) worldGraph w p = HS.unions $ (\q -> HS.fromList $ pointsAlong w p (p +.+ q)) . toV2
$ map toV2 <$> [(200,0),(-200,0),(0,200),(0,-200)]
[(200,0),(-200,0),(0,200),(0,-200)]
pointsAlong :: World -> Point2 -> Point2 -> [Point2] pointsAlong :: World -> Point2 -> Point2 -> [Point2]
pointsAlong w p q = divideLineFixed 50 p p' pointsAlong w p q = divideLineFixed 50 p p'
@@ -69,9 +68,9 @@ makeNode e = (HP.singleton (0,(0,[e])) , [])
tp1,tp2,tp3 :: Point2 tp1,tp2,tp3 :: Point2
tp1 = (V2 0 1) tp1 = V2 0 1
tp2 = (V2 0 20) tp2 = V2 0 20
tp3 = (V2 30 40) tp3 = V2 30 40
f :: Point2 -> [Point2] f :: Point2 -> [Point2]
f = incidenceToFunction $ pairsToIncidence 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 :: Float -> Color -> Point2 -> Float -> Float -> Picture
verticalPipe w col (V2 xx xy) za zb = pictures $ map (poly3Col . f) ps verticalPipe w col (V2 xx xy) za zb = pictures $ map (poly3Col . f) ps
where where
x = (V3 xx xy 0) 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)]) 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]) ps = zip xs (tail xs ++ [head xs])
f (a,b) = map f' [a,b,g b,g a] f (a,b) = map f' [a,b,g b,g a]
g :: Point3 -> Point3 g :: Point3 -> Point3
g (V3 a b _) = (V3 a b zb) g (V3 a b _) = V3 a b zb
f' a = (a,col) f' a = (a,col)
expandLine :: Point3 -> Point3 -> Point3 -> [Point3] 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) nSils <- pokePoint3s (shadVBOptr $ _lightingLineShadowShader pdata)
(_foregroundEdgeVerx w) (_foregroundEdgeVerx w)
-- poke foreground geometry and floor -- 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) nsurfVs <- pokePoint3s (shadVBOptr $ _lightingSurfaceShader pdata)
$ polyToTris (map addC $ screenPolygon w) $ polyToTris (map addC $ screenPolygon w)
++ concatMap polyToGeoRender (foregroundPics w) ++ concatMap polyToGeoRender (foregroundPics w)
@@ -155,7 +155,7 @@ doDrawing pdata w = do
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
rds -> do rds -> do
let bindDrawDist :: (Point2,Point2,Point2,Float) -> IO () let bindDrawDist :: (Point2,Point2,Point2,Float) -> IO ()
bindDrawDist ((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) pokeArray (shadVBOptr $ _barrelShader pdata)
[a,b,c,d,e,f,g] [a,b,c,d,e,f,g]
bindShaderBuffers [_barrelShader pdata] [1] bindShaderBuffers [_barrelShader pdata] [1]
src/Dodge/Render/HUD.hs
+19 -18
View File
@@ -56,7 +56,7 @@ cursorsZ w ipos it = case it ^? wpAmmo . amParamSel of
where where
hh = halfHeight w hh = halfHeight w
hw = halfWidth 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 :: Color -> Int -> World -> [Picture]
topInvCursor col iPos w topInvCursor col iPos w
@@ -97,7 +97,7 @@ pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj
displayMidList :: World -> [String] -> String -> [Picture] displayMidList :: World -> [String] -> String -> [Picture]
displayMidList w strs s = displayMidList w strs s =
invHead w s invHead w s
++ renderListAt (V2 (150) (-60)) (map (,white) strs) w ++ renderListAt (V2 150 (-60)) (map (,white) strs) w
invHead :: World -> String -> [Picture] invHead :: World -> String -> [Picture]
invHead w s = [winScale w . translate (-130) (halfHeight w - 40) invHead w s = [winScale w . translate (-130) (halfHeight w - 40)
@@ -145,17 +145,17 @@ drawLocations wrld = displayListTopLeft locs wrld
displayListCoords :: World -> [Point2] displayListCoords :: World -> [Point2]
displayListCoords w = map (g . f) [(1::Int)..] displayListCoords w = map (g . f) [(1::Int)..]
where where
f i = (V2 ( 15 - halfWidth w ) ( halfHeight w - (20 * fromIntegral i)) ) f i = V2 ( 15 - halfWidth w ) ( halfHeight w - (20 * fromIntegral i))
g (V2 x y) = (V2 (2*x / getWindowX w) ( 2*y / getWindowY w)) g (V2 x y) = V2 (2*x / getWindowX w) ( 2*y / getWindowY w)
displayListEndCoords :: World -> [String] -> [Point2] displayListEndCoords :: World -> [String] -> [Point2]
displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..] displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
where where
f :: Int -> Point2 f :: Int -> Point2
f i = (V2 ( 15 - halfWidth w ) ( 2.5 + halfHeight w - (20 * fromIntegral i)) ) 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)) g (V2 x y) = V2 (2*x / getWindowX w) ( 2*y / getWindowY w)
h :: String -> Point2 -> Point2 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 --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 objPos obj = case obj of Left flit -> _flItPos flit
Right bt -> _btPos bt Right bt -> _btPos bt
mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj)) mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
sc (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 maybeLine = do
itScreenPos <- mayScreenPos itScreenPos <- mayScreenPos
theText <- fmap (snd . colAndText) mayObj 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) ( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
let p' = V2 ( pushout - halfWidth w + 130) let p' = V2 ( pushout - halfWidth w + 130)
( halfHeight w - 20* (fromIntegral invPos +1) + 2.5) ( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
return $ flip thickLineCol (1 / halfWidth w) return $ thickLineCol
[(itScreenPos, withAlpha 0 col) [(itScreenPos, withAlpha 0 col)
,(sc p' , col) ,(sc p' , col)
,(sc p , col) ,(sc p , col)
] ]
(1 / halfWidth w)
{- | Colour picture and add black drop shadow. -} {- | Colour picture and add black drop shadow. -}
dShadCol :: Color -> Picture -> Picture dShadCol :: Color -> Picture -> Picture
dShadCol c p = pictures dShadCol c p = pictures
@@ -238,10 +239,10 @@ openCursorAt
openCursorAt wth col xoff yoff yint w = winScale w openCursorAt wth col xoff yoff yint w = winScale w
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20) . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
$ lineCol $ lineCol
[((V2 wth 12.5) ,withAlpha 0 col) [(V2 wth 12.5 ,withAlpha 0 col)
,((V2 0 12.5) ,col) ,(V2 0 12.5 ,col)
,((V2 ( 0) (-7.5)) ,col) ,(V2 0 (-7.5),col)
,((V2 ( wth) (-7.5)) ,withAlpha 0 col) ,(V2 wth (-7.5),withAlpha 0 col)
] ]
cursorAt cursorAt
:: Float -- ^ Width :: 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) . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
. color col . color col
$ line $ line
[(V2 wth 12.5) [V2 wth 12.5
,(V2 0 12.5) ,V2 0 12.5
,(V2 ( 0) (-7.5)) ,V2 0 (-7.5)
,(V2 ( wth) (-7.5)) ,V2 wth (-7.5)
,(V2 wth 12.5) ,V2 wth 12.5
] ]
displayHP :: Int -> World -> Picture 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 :: World -> Picture
worldPictures w = concat $ worldPictures w = concat $
(IM.elems $ _decorations w) ++ IM.elems (_decorations w) ++
(map (dbArg _pjDraw) . IM.elems $ _projectiles w) ++ (map (dbArg _pjDraw) . IM.elems $ _projectiles w) ++
(map (crDraw w) . IM.elems $ _creatures w) ++ (map (crDraw w) . IM.elems $ _creatures w) ++
(map (dbArg _ptDraw) $ _particles w) ++ map (dbArg _ptDraw) (_particles w) ++
[ testPic w [ testPic w
, concatMap drawItem . IM.elems $ _floorItems w , concatMap drawItem . IM.elems $ _floorItems w
, concatMap (crDraw w) . IM.elems $ _creatures w , concatMap (crDraw w) . IM.elems $ _creatures w
@@ -53,7 +53,7 @@ customMouseCursor w =
scale (2 /getWindowX w) (2/ getWindowY w) scale (2 /getWindowX w) (2/ getWindowY w)
. uncurryV translate (_mousePos w) . uncurryV translate (_mousePos w)
. color white . 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 :: World -> Picture
testPic _ = blank testPic _ = blank
@@ -213,7 +213,7 @@ wallsAndWindows w
(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w (wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w
wallsToList :: [((Point2,Point2),Point4)] -> [Float] wallsToList :: [((Point2,Point2),Point4)] -> [Float]
wallsToList = concatMap (\(((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)] 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] { _rmPolys = [rectNSWE y 0 0 x]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [] , _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)] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
} }
@@ -65,8 +65,8 @@ roomC x y = defaultRoom
roomPadCut :: [Point2] -> Point2 -> Room roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = defaultRoom roomPadCut ps p = defaultRoom
{ _rmPolys = [ps] { _rmPolys = [ps]
, _rmLinks = [(p,0),((V2 0 0),pi)] , _rmLinks = [(p,0),(V2 0 0,pi)]
, _rmPath = [((V2 0 0),p)] , _rmPath = [(V2 0 0,p)]
, _rmPS = [] , _rmPS = []
, _rmBound = [] , _rmBound = []
} }
@@ -90,14 +90,14 @@ glassSwitchBack = do
wllen <- state $ randomR (60,wth/2-40) wllen <- state $ randomR (60,wth/2-40)
let hf = hgt/5 let hf = hgt/5
let plmnts = let plmnts =
[windowLine (V2 (wth-60 ) ( hf)) (V2 (wllen) (hf) ) [windowLine (V2 (wth-60 ) hf ) (V2 wllen hf )
,windowLine (V2 (wth-wllen) (2*hf)) (V2 (60 ) (2*hf)) ,windowLine (V2 (wth-wllen) (2*hf)) (V2 60 (2*hf))
,windowLine (V2 (wth-60 ) (3*hf)) (V2 (wllen) (3*hf)) ,windowLine (V2 (wth-60 ) (3*hf)) (V2 wllen (3*hf))
,windowLine (V2 (wth-wllen) (4*hf)) (V2 (60 ) (4*hf)) ,windowLine (V2 (wth-wllen) (4*hf)) (V2 60 (4*hf))
,blockLine (V2 ( 0) (1*hf)) (V2 (wllen) (1*hf)) ,blockLine (V2 0 (1*hf)) (V2 wllen (1*hf))
,blockLine (V2 (wth-wllen) (2*hf)) (V2 ( wth) (2*hf)) ,blockLine (V2 (wth-wllen) (2*hf)) (V2 wth (2*hf))
,blockLine (V2 ( 0) (3*hf)) (V2 (wllen) (3*hf)) ,blockLine (V2 0 (3*hf)) (V2 wllen (3*hf))
,blockLine (V2 (wth-wllen) (4*hf)) (V2 ( wth) (4*hf)) ,blockLine (V2 (wth-wllen) (4*hf)) (V2 wth (4*hf))
, sPS (V2 (wth/2) (hgt/2)) 0 putLamp , sPS (V2 (wth/2) (hgt/2)) 0 putLamp
] ]
return $ set rmPS plmnts $ roomRect wth hgt 2 6 return $ set rmPS plmnts $ roomRect wth hgt 2 6
@@ -135,19 +135,19 @@ miniRoom1 = do
,50+4*hf,30+5*hf ,50+4*hf,30+5*hf
] ]
crx <- state $ randomR (wllen,wth-(wllen+40)) crx <- state $ randomR (wllen,wth-(wllen+40))
let plmnts = [windowLine (V2 (wth-60) ( 40+hf)) (V2 (wllen) (40+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-wllen) (40+2*hf)) (V2 60 (40+2*hf))
,windowLine (V2 (wth-60) ( 40+3*hf)) (V2 (wllen) (40+3*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)) ,windowLine (V2 (wth-wllen) (40+4*hf)) (V2 60 (40+4*hf))
,sPS (V2 crx cry) 0 $ PutCrit miniGunCrit ,sPS (V2 crx cry) 0 $ PutCrit miniGunCrit
,sPS (V2 (wth-20) (hgt/2+40)) 0 randC1 ,sPS (V2 (wth-20) (hgt/2+40)) 0 randC1
,sPS (V2 (wth/2) (hgt/2)) 0 putLamp ,sPS (V2 (wth/2) (hgt/2)) 0 putLamp
,blockLine (V2 ( 0) ( 40+1*hf)) (V2 (wllen) (40+1*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 (wth-wllen) ( 40+2*hf)) (V2 wth (40+2*hf))
,blockLine (V2 ( 0) ( 40+3*hf)) (V2 (wllen) (40+3*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 (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 :: RandomGen g => State g (Tree (Either Room Room))
miniTree2 = miniRoom1 miniTree2 = miniRoom1
@@ -159,7 +159,7 @@ miniRoom3 :: RandomGen g => State g (Tree (Either Room Room))
miniRoom3 = do miniRoom3 = do
w <- state $ randomR (300,400) w <- state $ randomR (300,400)
h <- 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) let b = PutBlock [5,20,20] (greyN 0.5) $ map toV2 [(-10,-60)
,( 10,-60) ,( 10,-60)
,( 10,-80) ,( 10,-80)
@@ -263,11 +263,11 @@ weaponEmptyRoom = do
let plmnts = let plmnts =
[sPS (V2 (w/2) (h-40)) 0 $ RandPS randFirstWeapon [sPS (V2 (w/2) (h-40)) 0 $ RandPS randFirstWeapon
,sPS (V2 20 20) (pi/2) randC1 ,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 ,sPS (V2 (w/2) (h/2)) 0 putLamp
] ]
(fmap connectRoom . randomiseOutLinks) =<< (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 :: RandomGen g => State g (Tree (Either Room Room))
weaponUnderCrits = do weaponUnderCrits = do
@@ -291,8 +291,8 @@ weaponUnderCrits = do
weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room)) weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room))
weaponBehindPillar = do weaponBehindPillar = do
cpos <- takeOne $ [(V2 x y) | x <- [20,220], y <- [20,220]] ++ [(V2 120 160),(V2 120 200)] 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 d p = argV $ V2 120 80 -.- p
let plmnts1 = let plmnts1 =
[sPS (V2 120 160) 0 $ RandPS randFirstWeapon [sPS (V2 120 160) 0 $ RandPS randFirstWeapon
,sPS cpos (d cpos) randC1 ,sPS cpos (d cpos) randC1
@@ -306,11 +306,11 @@ weaponBehindPillar = do
weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room)) weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
weaponBetweenPillars = do weaponBetweenPillars = do
wpPos <- takeOne [(V2 x y) | x <- [20,120,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]]) (ps,_) <- takeNMore 2 ([], [V2 x y | x <- [20,220], y <- [20,120,220]])
let crPos1 = ps !! 0 let crPos1 = ps !! 0
crPos2 = ps !! 1 crPos2 = ps !! 1
d p = argV $ (V2 120 120) -.- p d p = argV $ V2 120 120 -.- p
plmnts = plmnts =
[sPS wpPos 0 $ RandPS randFirstWeapon [sPS wpPos 0 $ RandPS randFirstWeapon
,sPS crPos1 (d crPos1) randC1 ,sPS crPos1 (d crPos1) randC1
@@ -327,7 +327,7 @@ weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do weaponLongCorridor = do
root <- takeOne [tEast, tWest] root <- takeOne [tEast, tWest]
connectingRoom <- takeOne 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] ,tWest & rmPS .~ [sPS (V2 40 60) 0 putLamp]
] ]
i1 <- state $ randomR (2,5) i1 <- state $ randomR (2,5)
@@ -336,7 +336,7 @@ weaponLongCorridor = do
let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor) let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor)
return $ Node (Left root) [branch1,branch2] return $ Node (Left root) [branch1,branch2]
where 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 ] putWp = set rmPS [sPS (V2 20 40) 0 $ RandPS randFirstWeapon ,sPS (V2 20 60) 0 putLamp ]
critInDeadEnd :: Room critInDeadEnd :: Room
@@ -348,11 +348,11 @@ deadEndRoom = defaultRoom
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [] , _rmPath = []
, _rmPS = [sPS (V2 (0) (-10)) 0 putLamp] , _rmPS = [sPS (V2 0 (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30] , _rmBound = [rectNSWE 20 (-20) (-30) 30]
} }
where where
lnks = [((V2 0 30) ,0) ] lnks = [(V2 0 30 ,0) ]
{- A random Either tree with a weapon and melee monster challenge. -} {- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: RandomGen g => State g (Tree (Either Room Room)) weaponRoom :: RandomGen g => State g (Tree (Either Room Room))
weaponRoom = join $ takeOne weaponRoom = join $ takeOne
@@ -367,7 +367,7 @@ roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
roomCCrits = do roomCCrits = do
ps <- replicateM 20 $ randInCirc 9 ps <- replicateM 20 $ randInCirc 9
let plmnts = map (\p -> sPS p 0 randC1) 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] lamps = [sPS (V2 50 100) 0 putLamp , sPS (V2 175 100) 0 putLamp]
return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200 return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200
@@ -387,14 +387,14 @@ longRoom = do
[rectNSWE 95 70 0 25 [rectNSWE 95 70 0 25
,rectNSWE 95 70 50 75 ,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 $ replicateM 5 $ randInRect (w-20) 900
let rm = roomRect w (h+70) 1 1 & rmPolys %~ ([rectNSWE h (h-165) (-45) (w+45)] ++) let rm = roomRect w (h+70) 1 1 & rmPolys %~ ([rectNSWE h (h-165) (-45) (w+45)] ++)
changeLinkTo cond $ rm & rmPS .~ ws ++ brls ++ wsDefense ++ changeLinkTo cond $ rm & rmPS .~ ws ++ brls ++ wsDefense ++
[sPS (V2 12.5 (h-25)) 0 $ PutCrit longCrit [sPS (V2 12.5 (h-25)) 0 $ PutCrit longCrit
,sPS (V2 37.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 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 ,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) y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
x4 <- state $ randomR (60,w-60) x4 <- state $ randomR (60,w-60)
y4 <- state $ randomR (40,180) 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 bln x y = putBlockN (x+25) (x-25) (y+10) y
let blv x y = putBlockV (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 let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [sPS p (-pi/2) $ PutCrit autoCrit ++ [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 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 bln x y = putBlockN (x+25) (x-25) (y+10) y
let blv x y = putBlockV (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 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 x1 (y1-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 (x2) (y2-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 x3 (y3-10)) (-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 return $ set rmPS plmnts $ roomRectAutoLinks w 600
@@ -479,11 +479,11 @@ pistolerRoom = do
,sPS (ps !! 1) ab $ PutCrit pistolCrit ,sPS (ps !! 1) ab $ PutCrit pistolCrit
,sPS (ps !! 2) ac $ PutCrit pistolCrit ,sPS (ps !! 2) ac $ PutCrit pistolCrit
,sPS (V2 (w/2) (h-50)) 0 putLamp ,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 (w-5) (h-5) ) 0 putLamp
,sPS (V2 ( 5) (h-5) ) 0 putLamp ,sPS (V2 5 (h-5) ) 0 putLamp
,sPS (V2 (w-5) (5) ) 0 putLamp ,sPS (V2 (w-5) 5 ) 0 putLamp
,sPS (V2 ( 5) (5) ) 0 putLamp ,sPS (V2 5 5 ) 0 putLamp
,sPS (V2 (w/2) (h/2) ) 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 :: RandomGen g => State g (Tree (Either Room Room))
shootingRange = do shootingRange = do
rm1 <- shootersRoom1 >>= changeLinkTo (\((V2 _ y),_) -> y < 40) rm1 <- shootersRoom1 >>= changeLinkTo (\(V2 _ y,_) -> y < 40)
>>= filterLinks (\((V2 _ y),r) -> y > 200 && r /= 0) >>= filterLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
rm2 <- shootersRoom >>= changeLinkTo (\((V2 x y),_) -> y < 10 && x > 20 && x < 180) rm2 <- shootersRoom >>= changeLinkTo (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\((V2 _ y),r) -> y > 200 && r /= 0) >>= filterLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
rm3 <- shootersRoom >>= changeLinkTo (\((V2 x y),_) -> y < 10 && x > 20 && x < 180) rm3 <- shootersRoom >>= changeLinkTo (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\(_,r) -> r == 0) >>= filterLinks (\(_,r) -> r == 0)
return $ treeFromPost [Left rm1 return $ treeFromPost [Left rm1
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (V2 0 20) ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (V2 0 20)
@@ -512,13 +512,13 @@ spawnerRoom = do
y <- state $ randomR (300,400) y <- state $ randomR (300,400)
wl <- takeOne [sPS (V2 0 0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10)) wl <- takeOne [sPS (V2 0 0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10))
defaultCrystalWall 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 let plmnts = [sPS (V2 (x/4) ( y/4)) (pi/2) $ PutCrit spawnerCrit
,wl ,wl
,sPS (V2 (x/2) ( y-10)) 0 putLamp ,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) roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2)
aRoom <- airlock 0 aRoom <- airlock 0
return $ treeFromTrunk [Left aRoom] roomWithSpawner 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 90 30 (-30) 30
, _rmBound = [rectNSWE 75 15 0 40] , _rmBound = [rectNSWE 75 15 0 40]
} }
where lnks = [((V2 0 85),0) where lnks = [(V2 0 85,0)
,((V2 0 5),pi) ,(V2 0 5,pi)
] ]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red col = dim $ dim $ bright red
@@ -56,8 +56,8 @@ airlock0 n = defaultRoom
, rectNSWE 65 35 (-40) 20 , rectNSWE 65 35 (-40) 20
] ]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [((V2 20 95),(V2 20 45)) , _rmPath = [(V2 20 95,V2 20 45)
,((V2 20 45),(V2 20 5)) ,(V2 20 45,V2 20 5)
] ]
, _rmPS = , _rmPS =
[sPS (V2 0 20) 0 $ PutDoubleDoor col (not . cond) (V2 1 0) (V2 39 0) [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 ,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True)) (over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False)) (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] , _rmBound = [rectNSWE 75 15 0 40]
} }
where where
lnks = [((V2 20 95),0) lnks = [(V2 20 95,0)
,((V2 20 5),pi) ,(V2 20 5,pi)
] ]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red col = dim $ dim $ bright red
@@ -91,12 +91,12 @@ airlock90 n = defaultRoom
] ]
] ]
, _rmLinks = , _rmLinks =
[((V2 0 40),pi/2) [(V2 0 40,pi/2)
,((V2 40 0),pi) ,(V2 40 0,pi)
] ]
, _rmPath = , _rmPath =
[((V2 0 40),(V2 40 0)) [(V2 0 40,V2 40 0)
,((V2 40 0),(V2 0 40)) ,(V2 40 0,V2 0 40)
] ]
, _rmPS = , _rmPS =
[sPS (V2 5 5) 0 $ PutDoor col (not . cond) pss [sPS (V2 5 5) 0 $ PutDoor col (not . cond) pss
@@ -116,7 +116,7 @@ airlock90 n = defaultRoom
where where
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red 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 airlockCrystal
:: Int -- ^ Door id :: Int -- ^ Door id
@@ -132,8 +132,8 @@ airlockCrystal n = defaultRoom
] ]
] ]
, _rmLinks = , _rmLinks =
[((V2 20 130),0) [(V2 20 130,0)
,((V2 20 0),pi) ,(V2 20 0 ,pi)
] ]
, _rmPath = , _rmPath =
[ [
@@ -154,5 +154,5 @@ airlockCrystal n = defaultRoom
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red col = dim $ dim $ bright red
pss :: [(Point2,Point2)] 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] [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 ,rectNSWE 0 (-(x + 40)) (-20) 20
] ]
, _rmLinks = , _rmLinks =
[((V2 0 x),0) [(V2 0 x,0)
,((V2 (0) (-(x+40))),pi) ,(V2 0 (-(x+40)),pi)
] ]
, _rmPath = [((V2 (0) (x)),(V2 (0) (-(x+40)))) , _rmPath = [(V2 0 x,V2 0 (-(x+40)))
,((V2 (0) (-(x+40))),(V2 (0) (x)))] ,(V2 0 (-(x+40)),V2 0 x)]
, _rmPS = , _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
,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 (negate (x/2)) x)
,crystalLine (V2 (x) (x/2)) (V2 (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/2) (-x)) (V2 x (negate (x/2)))
,crystalLine (V2 (negate $ 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] , _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 :: RandomGen g => State g (Tree Room)
armouredChasers = do 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) as <- replicateM 5 . state $ randomR (0,2*pi)
let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs
treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPS %~ (++ theCrits)) treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPS %~ (++ theCrits))
@@ -80,21 +80,21 @@ roomCross x y = defaultRoom
,rectNSWE (-x) x y (-y) ,rectNSWE (-x) x y (-y)
] ]
, _rmLinks = , _rmLinks =
[((V2 (x) (y-20)),negate $ pi/2) [(V2 x (y-20),negate $ pi/2)
,((V2 (x) (20-y)),negate $ pi/2) ,(V2 x (20-y),negate $ pi/2)
,((V2 (20-y) (x)),0) ,(V2 (20-y) x ,0)
,((V2 (y-20) (x)),0) ,(V2 (y-20) x ,0)
,((V2 (-x) (y-20)),pi/2) ,(V2 (-x) (y-20),pi/2)
,((V2 (-x) (20-y)),pi/2) ,(V2 (-x) (20-y),pi/2)
,((V2 (20-y) (-x)),pi) ,(V2 (20-y) (-x),pi)
,((V2 (y-20) (-x)),pi) ,(V2 (y-20) (-x),pi)
] ]
, _rmPath = [] , _rmPath = []
, _rmPS = , _rmPS =
[sPS (V2 ( x) ( 0)) 0 putLamp [sPS (V2 x 0) 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
,sPS (V2 ( 0) (-x)) 0 putLamp ,sPS (V2 0 (-x)) 0 putLamp
] ]
, _rmBound = , _rmBound =
[rectNSWE y (-y) (-x) x [rectNSWE y (-y) (-x) x
@@ -115,12 +115,12 @@ roomShuriken x y =
] ] ] ]
corner = defaultRoom corner = defaultRoom
{ _rmPolys = ps { _rmPolys = ps
, _rmLinks = [((V2 (x-1) (y-20)),negate $ pi/2)] , _rmLinks = [(V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = [] , _rmPath = []
, _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp] , _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp]
, _rmBound = ps , _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 {- | TODO: pathing
Precondition: first float is less than the second by at least 40. -} Precondition: first float is less than the second by at least 40. -}
roomTwistCross roomTwistCross
@@ -139,9 +139,9 @@ roomTwistCross x y z =
] ]
corner = defaultRoom corner = defaultRoom
{ _rmPolys = ps { _rmPolys = ps
, _rmLinks = [((V2 (z) (y-20)), pi/2)] , _rmLinks = [(V2 z (y-20), pi/2)]
, _rmPath = [] , _rmPath = []
, _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp] , _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp]
, _rmBound = ps , _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 = [] , _rmPS = []
, _rmBound = [ rectNSWE 50 30 0 40 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
} }
where lnks = [((V2 20 70) ,0) where lnks = [(V2 20 70 ,0)
,((V2 20 10) ,pi) ,(V2 20 10 ,pi)
] ]
pth = doublePair ((V2 20 70),(V2 20 10)) pth = doublePair (V2 20 70,V2 20 10)
tEast :: Room tEast :: Room
tEast = defaultRoom tEast = defaultRoom
src/Dodge/Room/Door.hs
+3 -3
View File
@@ -15,13 +15,13 @@ door :: Room
door = defaultRoom door = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40] { _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [((V2 20 35),(V2 20 5))] , _rmPath = [(V2 20 35,V2 20 5)]
-- door extends into side walls (for shadows as rendered 12/03) -- door extends into side walls (for shadows as rendered 12/03)
, _rmPS = [sPS (V2 0 20) 0 $ PutAutoDoor (V2 0 0) (V2 40 0)] , _rmPS = [sPS (V2 0 20) 0 $ PutAutoDoor (V2 0 0) (V2 40 0)]
, _rmBound = [] , _rmBound = []
} }
where lnks = [((V2 20 35),0) where lnks = [(V2 20 35,0)
,((V2 20 5),pi) ,(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 :: Float -> Point2 -> Point2 -> [Polyhedra]
highPipe h x@(V2 xx xy) y = 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) $ boxABC (V3 a b 0) (V3 a' b' 0) (V3 0 0 5)
] ]
where where
src/Dodge/Room/Link.hs
+2 -2
View File
@@ -59,8 +59,8 @@ This is intended to work when the external point is an outgoing link from anothe
shiftRoomToLink :: (Point2,Float) -> Room -> Room shiftRoomToLink :: (Point2,Float) -> Room -> Room
shiftRoomToLink l r shiftRoomToLink l r
= shiftRoomBy l = shiftRoomBy l
. shiftRoomBy ((V2 0 0) -.- rotateV (pi-a) p , 0) . shiftRoomBy (V2 0 0 -.- rotateV (pi-a) p , 0)
$ shiftRoomBy ((V2 0 0) ,pi-a) $ shiftRoomBy (V2 0 0 ,pi-a)
r r
where where
(p,a) = last $ _rmLinks r (p,a) = last $ _rmLinks r
src/Dodge/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. {- | Rooms containing long doors, probably with a big reveal behind them.
-} -}
module Dodge.Room.LongDoor module Dodge.Room.LongDoor
@@ -33,18 +33,18 @@ twinSlowDoorRoom
twinSlowDoorRoom drID w h x = defaultRoom twinSlowDoorRoom drID w h x = defaultRoom
{ _rmPolys = ps { _rmPolys = ps
, _rmLinks = , _rmLinks =
[ ((V2 (w) (h/2)) , negate $ pi/2) [ (V2 w (h/2) , negate $ pi/2)
, ((V2 (-w) (h/2)) , pi/2) , (V2 (-w) (h/2) , pi/2)
, ((V2 (0) (-h)), pi) , (V2 0 (-h), pi)
] ]
, _rmPath = [] , _rmPath = []
, _rmPS = , _rmPS =
[ sPS (V2 (0) (h/2)) 0 putLamp [ sPS (V2 0 (h/2)) 0 putLamp
, sPS (V2 (25) (5)) 0 putLamp , sPS (V2 25 5) 0 putLamp
, sPS (V2 (negate 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) drL
, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drR , 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)) (over worldState (M.insert (DoorNumOpen drID) True))
] ]
, _rmBound = ps , _rmBound = ps
@@ -54,9 +54,9 @@ twinSlowDoorRoom drID w h x = defaultRoom
[rectNSWE h (-2) (-w) w [rectNSWE h (-2) (-w) w
,rectNSWE 20 (-h) (negate x) x ,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] [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] [0..nDrp]
nDrp = ceiling h :: Int nDrp = ceiling h :: Int
cond w' = or $ M.lookup (DoorNumOpen drID) (_worldState w') cond w' = or $ M.lookup (DoorNumOpen drID) (_worldState w')
@@ -67,8 +67,8 @@ twinSlowDoorChasers
=> Int -- ^ Door id => Int -- ^ Door id
-> State g Room -> State g Room
twinSlowDoorChasers drid = do twinSlowDoorChasers drid = do
let lps = (V2 (-65)) <$> [20,40 .. 180] let lps = V2 (-65) <$> [20,40 .. 180]
rps = (V2 65) <$> [20,40 .. 180] rps = V2 65 <$> [20,40 .. 180]
ps <- takeN 4 $ lps ++ rps ps <- takeN 4 $ lps ++ rps
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
return $ twinSlowDoorRoom drid 80 200 40 & rmPS %~ (plmnts ++) return $ twinSlowDoorRoom drid 80 200 40 & rmPS %~ (plmnts ++)
@@ -79,8 +79,8 @@ slowDoorRoom = do
y <- state $ randomR (400,800) y <- state $ randomR (400,800)
h <- state $ randomR (200,min (y-100) 500) h <- state $ randomR (200,min (y-100) 500)
(butPos,butRot) <- takeOne (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 let n = 25
xs <- replicateM n $ state $ randomR (10,x-10) xs <- replicateM n $ state $ randomR (10,x-10)
@@ -90,7 +90,7 @@ slowDoorRoom = do
xs' <- replicateM 5 $ state $ randomR (10,x-10) xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- replicateM 5 $ state $ randomR (h+20,y) ys' <- replicateM 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> sPS p r randC1) ps rs 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' barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
pillarsa = [] pillarsa = []
pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20) 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 0 175) 0 $ PutCrit explosiveBarrel
,sPS (V2 5 195) 0 $ PutCrit explosiveBarrel ,sPS (V2 5 195) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 200) 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) ,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
] ]
r <- centerVaultRoom drID 200 200 50 <&> rmPS %~ (extraPS ++) 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 :: Point2 -> Point2 -> Placement
blockLine a b = SinglePlacement $ PS blockLine a b = SinglePlacement $ PS
{ _psPos = (V2 0 0) { _psPos = V2 0 0
, _psRot = 0 , _psRot = 0
, _psType = PutLineBlock baseBlockPane 9 9 a b , _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 :: Point2 -> Point2 -> Placement
windowLine a b = SinglePlacement $ PS windowLine a b = SinglePlacement $ PS
{ _psPos = (V2 0 0) { _psPos = V2 0 0
, _psRot = 0 , _psRot = 0
, _psType = PutLineBlock baseWindowPane 8 8 a b , _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 :: Point2 -> Point2 -> Placement
crystalLine a b = SinglePlacement $ PS crystalLine a b = SinglePlacement $ PS
{ _psPos = (V2 0 0) { _psPos = V2 0 0
, _psRot = 0 , _psRot = 0
, _psType = PutWall ps defaultCrystalWall , _psType = PutWall ps defaultCrystalWall
} }
@@ -68,7 +68,7 @@ Depth 15, does not extend wider than points.
-} -}
wallLine :: Point2 -> Point2 -> Placement wallLine :: Point2 -> Point2 -> Placement
wallLine a b = SinglePlacement $ PS wallLine a b = SinglePlacement $ PS
{ _psPos = (V2 0 0) { _psPos = V2 0 0
, _psRot = 0 , _psRot = 0
, _psType = PutWall ps defaultWall , _psType = PutWall ps defaultWall
} }
@@ -87,7 +87,7 @@ windowLineType = PutLineBlock baseWindowPane 8 8
baseBlockPane :: Wall baseBlockPane :: Wall
baseBlockPane = Block baseBlockPane = Block
{ _wlLine = ((V2 0 0),(V2 50 0)) { _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0 , _wlID = 0
, _wlColor = greyN 0.5 , _wlColor = greyN 0.5
, _wlSeen = False , _wlSeen = False
@@ -100,7 +100,7 @@ baseBlockPane = Block
} }
baseWindowPane :: Wall baseWindowPane :: Wall
baseWindowPane = Block baseWindowPane = Block
{ _wlLine = ((V2 0 0),(V2 50 0)) { _wlLine = (V2 0 0,V2 50 0)
, _wlID = 0 , _wlID = 0
, _wlColor = withAlpha 0.2 cyan , _wlColor = withAlpha 0.2 cyan
, _wlSeen = False , _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)] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = [Tile , _rmFloor = [Tile
{ _tilePoly = rectNSWE y 0 0 x { _tilePoly = rectNSWE y 0 0 x
, _tileCenter = (V2 0 0) , _tileCenter = V2 0 0
, _tileX = (V2 50 0) , _tileX = V2 50 0
, _tileY = (V2 0 50) , _tileY = V2 0 50
, _tileZ = 16 , _tileZ = 16
} ] } ]
} }
@@ -79,7 +79,7 @@ makeGrid x nx y ny
$ gridPoints x nx y ny $ gridPoints x nx y ny
gridPoints :: Float -> Int -> Float -> Int -> [Point2] 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 , b <- take ny $ scanl (+) 0 $ repeat y
] ]
@@ -124,9 +124,9 @@ fourthWall :: RandomGen g => Float -> State g Room
fourthWall w = do fourthWall w = do
b <- takeOne b <- takeOne
[ [ sPS (V2 (20-w) (w-40)) 0 putLamp [ [ 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 , 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 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 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 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 20) 0 putLamp , sPS (V2 0 20) 0 putLamp
, sPS (V2 (w-20) (w-20)) pi PutNothing , sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (0) (w/2)) , blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
, blockLine (V2 (-29) (w)) (V2 (0) (w/2)) , blockLine (V2 (-29) w) (V2 0 (w/2))
] ]
] ]
pure $ defaultRoom pure $ defaultRoom
{ _rmPolys = [ map toV2 [(0,0),(w,w),(-w,w)] ] { _rmPolys = [ map toV2 [(0,0),(w,w),(-w,w)] ]
, _rmLinks = [((V2 0 w), 0)] , _rmLinks = [(V2 0 w, 0)]
, _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 , _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 :: Float -> Room
--fourthCorner w = Room --fourthCorner w = Room
@@ -162,36 +162,36 @@ fourthWall w = do
fourthCornerWall :: RandomGen g => Float -> State g Room fourthCornerWall :: RandomGen g => Float -> State g Room
fourthCornerWall w = do fourthCornerWall w = do
b <- takeOne b <- takeOne
[ [ sPS (V2 (10-w) (w)) 0 putLamp [ [ sPS (V2 (10-w) w) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp , sPS (V2 (w-10) w) 0 putLamp
, sPS (V2 0 10) 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 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate $ 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 0 (3*w/2)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp , sPS (V2 (w-10) w) 0 putLamp
, sPS (V2 (10-w) (w-20) ) 0 putLamp , sPS (V2 (10-w) (w-20) ) 0 putLamp
, sPS (V2 0 10 ) 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 (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 (10-w) w ) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp , sPS (V2 (w-10) w ) 0 putLamp
, sPS (V2 0 10 ) 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 (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 pure $ defaultRoom
{ _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ] { _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
, _rmLinks = , _rmLinks =
[((V2 (w/2) (3*w/2)), negate $ pi/4) [(V2 (w/2) (3*w/2), negate $ pi/4)
,((V2 (negate $ w/2) (3*w/2)), 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 , _rmPS = b
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]] , _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 & creatures . ix 0 .~ cr
| otherwise = w | otherwise = w
where where
cr = _creatures w IM.! 0 & crPos .~ (V2 0 0) cr = _creatures w IM.! 0 & crPos .~ V2 0 0
updateSoundQueue :: World -> World updateSoundQueue :: World -> World
updateSoundQueue = set soundQueue [] . set sounds M.empty 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 :: Creature -> Creature -> World -> World
crCrSpring c1 c2 w crCrSpring c1 c2 w
| id1 == id2 = w | id1 == id2 = w
| vec == (V2 0 0) = w | vec == V2 0 0 = w
| diff >= comRad = w | diff >= comRad = w
| otherwise = over (creatures . ix id1 . crPos) (+.+ overlap1) | otherwise = over (creatures . ix id1 . crPos) (+.+ overlap1)
$ over (creatures . ix id2 . crPos) (-.- overlap2) w $ 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 [ glow
, aPic 3 prot2 18 (V2 (scaleChange + 1) 2 ) red , aPic 3 prot2 18 (V2 (scaleChange + 1) 2 ) red
, aPic 4 prot 19 (V2 (scaleChange + 0.5) 1.5) orange , 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 :: Int -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
aPic lay offset depth (V2 scalex scaley) col aPic lay offset depth (V2 scalex scaley) col
src/Loop.hs
+61
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
{- | {- |
Module : Loop Module : Loop
Description : Simple game 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 module Loop
( setupLoop ( setupLoop
, setupMiniLoop
) where ) where
import qualified Data.Text as T import qualified Data.Text as T
import Control.Concurrent import Control.Concurrent
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Trans.Maybe
import System.Mem import System.Mem
--import Foreign.C --import Foreign.C
import SDL import SDL
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Fusion.Stream.Monadic as VS
--import Control.Lens ((.~),(&),(+~)) --import Control.Lens ((.~),(&),(+~))
-- | Create a game loop with an SDL window. -- | Create a game loop with an SDL window.
setupLoop setupLoop
@@ -99,3 +103,60 @@ winConfig x y = defaultWindow
, windowInitialSize = V2 (fromIntegral x) (fromIntegral y) , windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
, windowResizable =True , 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 translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-} {-# 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 translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-} {-# INLINE translate #-}
@@ -181,7 +181,7 @@ setLayer i = map f
scale3 :: Float -> Float -> Point3 -> Point3 scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-} {-# 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 scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-} {-# INLINE scale #-}
@@ -198,7 +198,7 @@ pictures = concat
makeArc :: Float -> Point2 -> [Point2] makeArc :: Float -> Point2 -> [Point2]
{-# INLINE makeArc #-} {-# 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 where
angles = [a,a+step.. b] angles = [a,a+step.. b]
step = pi * 0.2 step = pi * 0.2
@@ -210,9 +210,9 @@ circleSolid = circleSolidCol white white
circleSolidCol :: Color -> Color -> Float -> Picture circleSolidCol :: Color -> Color -> Float -> Picture
{-# INLINE circleSolidCol #-} {-# INLINE circleSolidCol #-}
circleSolidCol colC colE r = map f circleSolidCol colC colE r = map f
[( (V3 (-r) ( r) (0)), colC) [(V3 (-r) r 0, colC)
,( (V3 (-r) (-r) (0)), colE) ,(V3 (-r) (-r) 0, colE)
,( (V3 ( r) (-r) (0)), black) ,(V3 r (-r) 0, black)
] ]
where where
f (pos,col) = Verx pos col [] 0 ellNum f (pos,col) = Verx pos col [] 0 ellNum
@@ -270,7 +270,7 @@ arcSolid
-> Float -- ^ Radius -> Float -- ^ Radius
-> Picture -> Picture
{-# INLINE arcSolid #-} {-# 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 arc
:: Float -- ^ Start angle :: Float -- ^ Start angle
@@ -295,22 +295,22 @@ thickArc startA endA rad wdth
thickArcHelp :: Float -> Float -> Float -> Float -> [Verx] thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
{-# INLINE thickArcHelp #-} {-# INLINE thickArcHelp #-}
thickArcHelp startA endA rad wdth = map f thickArcHelp startA endA rad wdth = map f
[( (V3 0 0 0),black,(V3 0 0 wdth)) [ (V3 0 0 0,black,V3 0 0 wdth)
,((V3 xa ya 0),black,(V3 1 0 wdth)) ,(V3 xa ya 0,black,V3 1 0 wdth)
,((V3 xb yb 0),black,(V3 1 1 wdth)) ,(V3 xb yb 0,black,V3 1 1 wdth)
,( (V3 0 0 0),black,(V3 0 0 wdth)) , (V3 0 0 0,black,V3 0 0 wdth)
,((V3 xb yb 0),black,(V3 1 1 wdth)) ,(V3 xb yb 0,black,V3 1 1 wdth)
,((V3 xc yc 0),black,(V3 0 1 wdth)) ,(V3 xc yc 0,black,V3 0 1 wdth)
] ]
where where
(V2 xa ya) = rotateV startA (V2 rad 0) (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) (V2 xc yc) = rotateV endA (V2 rad 0)
f (pos,col,V3 a b c) = Verx pos col [a,b,c] 0 arcNum f (pos,col,V3 a b c) = Verx pos col [a,b,c] 0 arcNum
withAlpha :: Float -> RGBA -> RGBA withAlpha :: Float -> RGBA -> RGBA
{-# INLINE withAlpha #-} {-# 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 red,green,blue,yellow,cyan,magenta,rose
,violet,azure,aquamarine,chartreuse,orange,white,black::Color ,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 normrata = rata / fullrat
normratb = ratb / fullrat normratb = ratb / fullrat
f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int) 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 light :: Color -> Color
{-# INLINE light #-} {-# 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 dark :: Color -> Color
{-# INLINE dark #-} {-# 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 dim :: Color -> Color
{-# INLINE dim #-} {-# 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 bright :: Color -> Color
{-# INLINE bright #-} {-# 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 greyN :: Float -> Color
{-# INLINE greyN #-} {-# INLINE greyN #-}
@@ -392,12 +392,12 @@ stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)] charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
{-# INLINE charToTuple #-} {-# INLINE charToTuple #-}
charToTuple x c = charToTuple x c =
[((V3 (x-50) (-100) (0)), white,(V2 offset 1)) [(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 0)
,((V3 (x+50) (100) (0)), white,(V2 (offset+1) 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)
,((V3 (x+50) (-100) (0)), white,(V2 (offset+1) 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) 0)
] ]
where where
offset = fromIntegral (fromEnum c) - 32 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 :: Float -> Float -> Polyhedra -> Polyhedra
translateXY x y = pyFaces %~ map (map $ first tran) translateXY x y = pyFaces %~ map (map $ first tran)
where 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 :: Float -> Polyhedra -> Polyhedra
rotateXY a = over pyFaces $ map $ map $ first $ rotate3 a 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 :: Point3 -> Point3 -> [Point3]
rhombus a b = rhombus a b =
[(V3 0 0 0) [V3 0 0 0
,a ,a
,a +.+.+ b ,a +.+.+ b
,b ,b
@@ -58,11 +58,11 @@ rhombus a b =
boxXYZ :: Float -> Float -> Float -> [[Point3]] boxXYZ :: Float -> Float -> Float -> [[Point3]]
boxXYZ x y z = boxXYZ x y z =
[ bottomFace [ bottomFace
, map (+.+.+ (V3 0 0 z)) $ reverse bottomFace , map (+.+.+ V3 0 0 z) $ reverse bottomFace
, frontFace , frontFace
, map (+.+.+ (V3 0 y 0)) $ reverse frontFace , map (+.+.+ V3 0 y 0) $ reverse frontFace
, sideFace , sideFace
, map (+.+.+ (V3 x 0 0)) $ reverse sideFace , map (+.+.+ V3 x 0 0) $ reverse sideFace
] ]
where where
bottomFace = rhombus (V3 0 y 0) (V3 x 0 0) 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 $ _lightingOccludeShader pd
freeShaderPointers $ _fullscreenShader 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 module Render
where where
import Shader import Shader
@@ -59,7 +59,7 @@ createLightMap pdata lightPoints nWalls nSils nsurfVs = do
blendFunc $= (Zero, OneMinusSrcAlpha) blendFunc $= (Zero, OneMinusSrcAlpha)
stencilTest $= Enabled stencilTest $= Enabled
depthFunc $= Just Lequal depthFunc $= Just Lequal
forM_ lightPoints $ \((V3 x y z),r,lum) -> do forM_ lightPoints $ \(V3 x y z,r,lum) -> do
-- stencil out shadows -- stencil out shadows
colorMask $= Color4 Disabled Disabled Disabled Disabled colorMask $= Color4 Disabled Disabled Disabled Disabled
clear [StencilBuffer] clear [StencilBuffer]
src/Shader/Compile.hs
+1 -2
View File
@@ -60,8 +60,7 @@ makeShader
:: String -- ^ First part of the name of the shader :: String -- ^ First part of the name of the shader
-> [ShaderType] -- ^ Filetype extensions -> [ShaderType] -- ^ Filetype extensions
-> [Int] -- ^ The input vertex sizes -> [Int] -- ^ The input vertex sizes
-> EPrimitiveMode -> EPrimitiveMode -> IO FullShader
-> IO FullShader
makeShader s shaderlist sizes pm = do makeShader s shaderlist sizes pm = do
prog <- makeSourcedShader s shaderlist prog <- makeSourcedShader s shaderlist
vaob <- setupVAO sizes vaob <- setupVAO sizes
src/Shader/Data.hs
+10 -11
View File
@@ -34,6 +34,10 @@ module Shader.Data
, psArc , psArc
, psEll , psEll
, vert
, geom
, frag
-- TODO make lenses for VBO object -- TODO make lenses for VBO object
-- , textureObject -- , textureObject
) where ) where
@@ -138,8 +142,6 @@ instance Traversable PicShads where
, _psArc = x4 , _psArc = x4
, _psEll = x5 , _psEll = x5
} = PicShads <$> f x0 <*> f x1 <*> f x2 <*> f x3 <*> f x4 <*> f x5 } = PicShads <$> f x0 <*> f x1 <*> f x2 <*> f x3 <*> f x4 <*> f x5
{- | Datatype containing the necessary information for a single shader. -} {- | Datatype containing the necessary information for a single shader. -}
data FullShader = FullShader data FullShader = FullShader
{ _shaderProgram :: Program { _shaderProgram :: Program
@@ -151,15 +153,6 @@ data FullShader = FullShader
{- | Datatype containing the reference to a texture object. -} {- | Datatype containing the reference to a texture object. -}
newtype ShaderTexture = ShaderTexture newtype ShaderTexture = ShaderTexture
{ _textureObject :: TextureObject } { _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 data EPrimitiveMode
= EPoints = EPoints
| ELines | ELines
@@ -174,6 +167,12 @@ data EPrimitiveMode
| EPolygon | EPolygon
| EPatches | EPatches
-- | Short synonyms for shader types
vert, geom, frag :: ShaderType
vert = VertexShader
geom = GeometryShader
frag = FragmentShader
makeLenses ''VAO makeLenses ''VAO
makeLenses ''FullShader makeLenses ''FullShader
makeLenses ''VShader 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 () pokeVerx :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO ()
--{-# INLINE pokeVerx #-} --{-# 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 typeOff <- MV.unsafeRead offsets sn
let thePtr = plusPtr (_vboPtr $ vboFromType vbos sn) (typeOff * pokeStride sn * floatSize) let thePtr = plusPtr (_vboPtr $ vboFromType vbos sn) (typeOff * pokeStride sn * floatSize)
poke34 thePtr thePos theCol poke34 thePtr thePos theCol
@@ -73,7 +73,7 @@ pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
pokePoint33s ptr vals0 = go vals0 0 pokePoint33s ptr vals0 = go vals0 0
where where
go [] n = return n 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 0) a
pokeElemOff ptr (off 1) b pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c pokeElemOff ptr (off 2) c
stack.yaml
+1
View File
@@ -36,6 +36,7 @@ packages:
# #
extra-deps: extra-deps:
- SDL-0.6.7.0@sha256:9d6ba75c0cab575ec38468c8277803983e985f9622437aeca6a53e6a7337a7d5,2045 - SDL-0.6.7.0@sha256:9d6ba75c0cab575ec38468c8277803983e985f9622437aeca6a53e6a7337a7d5,2045
- repa-3.4.1.4@sha256:5a99bde69fe96a18d70aae23f47c8f719b1134558dca3ee5a7c15423b68a132e,3323
# - acme-missiles-0.3 # - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git # - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a