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