diff --git a/package.yaml b/package.yaml index a6e1f8b9c..70cebdf9b 100644 --- a/package.yaml +++ b/package.yaml @@ -46,7 +46,6 @@ dependencies: - aeson - directory - QuickCheck -- utility-ht library: source-dirs: src diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 780ad12e1..e8c128874 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -735,7 +735,7 @@ nearestCrInFront p dir x w {- | Test whether a creature is in a polygon. -} crInPolygon :: Creature -> [Point2] -> Bool -crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs +crInPolygon cr = errorPointInPolygon 3 (_crPos cr) {- | Transform coordinates from world position to normalised screen coordinates. -} diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index d940d7af3..9f61e1a4f 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -67,13 +67,15 @@ explosiveBarrel :: Creature explosiveBarrel = defaultInanimate { _crUpdate = updateExpBarrel , _crHP = 400 - , _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10 - , color red $ circleSolid 8 - ] - , _crState = defaultState {_goals = [[Wait]] - ,_faction = ChaseCritters - ,_crSpState = Barrel [] - } + , _crPict = \ _ -> onLayer CrLayer $ pictures + [ color red $ circleSolid 8 + , color orange $ circleSolid 10 + ] + , _crState = defaultState + {_goals = [[Wait]] + ,_faction = ChaseCritters + ,_crSpState = Barrel [] + } , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] ,_crApplyDamage = \_ c -> (id, c) } diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 53c1588b4..ce4483e79 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -46,18 +46,20 @@ stateUpdate u w (f,g) cr = $ crOrCorpse =<< maybeCr ) where - crOrCorpse cr | cr ^. crHP > 0 = Just cr - | otherwise = Nothing - deathEff | cr ^.crHP > 0 = id - | otherwise = stopSoundFrom (CrWeaponSound (_crID cr)) - . over decorations addCorpse - . dropByState cr + crOrCorpse cr + | cr ^. crHP > 0 = Just cr + | otherwise = Nothing + deathEff + | cr ^.crHP > 0 = id + | otherwise = stopSoundFrom (CrWeaponSound (_crID cr)) + . over decorations addCorpse + . dropByState cr crBeforeDeath = colCrWall w $ cr addCorpse = insertNewKey $ uncurry translate (_crOldPos cr) $ rotate (_crDir cr) (_crCorpse cr) --- | Drop items accoring to the creature state. +-- | Drop items according to the creature state. dropByState :: Creature -> World -> World dropByState cr w = foldr (copyItemToFloor cr) w is where @@ -81,11 +83,12 @@ crFriction cr vel = (0,0) doDamage :: Creature -> Creature doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (+ hpLost) damagedCr - where dams = _crDamage $ _crState cr - startHP = _crHP cr - damagedCr = snd $ (_crApplyDamage cr) dams cr - afterHP = _crHP damagedCr - hpLost = startHP - afterHP -- note this can be negative + where + dams = _crDamage $ _crState cr + startHP = _crHP cr + damagedCr = snd $ (_crApplyDamage cr) dams cr + afterHP = _crHP damagedCr + hpLost = startHP - afterHP -- note this can be negative sumDamage :: Creature -> DamageType -> Int -> Int sumDamage cr dm x = x + _dmAmount dm diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index 0dbc239c2..0993ef015 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/src/Dodge/Creature/YourControl.hs @@ -16,8 +16,6 @@ import qualified Data.Set as S import qualified Data.IntMap.Strict as IM import System.Random - - yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) yourControl w (f,g) cr = ( (updateUsingInput . f, g) , Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 11f2c71d3..ecb27f7ec 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -26,10 +26,12 @@ import Dodge.Data.DamageType import Dodge.Config.Data import Dodge.Config.KeyConfig import Dodge.Item.Attachment.Data +import Dodge.World.Trigger.Data import Preload.Data import Picture.Data import Geometry.Data import Sound.Data +import qualified DoubleStack as DS import Control.Lens import Control.Monad.State @@ -162,10 +164,6 @@ data WorldState | CrNumAlive Int deriving (Eq,Ord) -data WorldTrigger - = ResetLevel Int - deriving (Eq,Ord) - data Button = Button { _btPict :: Picture , _btPos :: Point2 @@ -434,12 +432,14 @@ data Wall , _wlIsSeeThrough :: Bool } | Door - { _wlLine :: [Point2] , _wlID :: Int + { _wlLine :: [Point2] + , _wlID :: Int , _doorMech :: World -> World , _wlColor :: Color , _wlSeen :: Bool , _wlIsSeeThrough :: Bool , _doorPathable :: Bool + , _drPositions :: DS.DS [Point2] } | Block { _wlLine :: [Point2] diff --git a/src/Dodge/Data.hs.orig b/src/Dodge/Data.hs.orig index a2c9eba19..49031a2b6 100644 --- a/src/Dodge/Data.hs.orig +++ b/src/Dodge/Data.hs.orig @@ -616,7 +616,7 @@ data PSType = PutCrit Creature | PutAutoDoor Point2 Point2 | PutBlock [Int] Color [Point2] | PutLineBlock Wall Float Float Point2 Point2 - | PutTriggerDoor Color (World -> Bool) Point2 Point2 + | PutDoubleDoor Color (World -> Bool) Point2 Point2 | PutBtDoor Color Point2 Float Point2 Point2 | PutSwitchDoor Color Point2 Float Point2 Point2 | RandPS (State StdGen PSType) diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 1be71c9b5..e78afdb64 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -16,6 +16,7 @@ import Dodge.Config.Data import Dodge.Config.KeyConfig import Geometry import Picture +import qualified DoubleStack as DS import Control.Lens import System.Random @@ -44,6 +45,7 @@ defaultAutoDoor = Door , _wlSeen = False , _wlIsSeeThrough = False , _doorPathable = True + , _drPositions = DS.singleton [(0,0),(50,0)] } {- Non-pathable door. @@ -56,6 +58,7 @@ defaultDoor = Door , _wlSeen = False , _wlIsSeeThrough = False , _doorPathable = False + , _drPositions = DS.singleton [(0,0),(50,0)] } defaultCreature :: Creature defaultCreature = Creature diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 7b3d31b0d..76e767185 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -12,6 +12,7 @@ import Dodge.Room.Link import Dodge.Room.Door import Dodge.Room.Branch import Dodge.Room.Boss +import Dodge.Room.Airlock import Dodge.Base import Dodge.Layout import Dodge.Layout.Tree.Polymorphic @@ -40,29 +41,34 @@ roomTreex = do let struct = treeFromPost [[SpecificRoom $ fmap (pure . Right) testRoom]] [EndRoom] let t' = padCorridors struct t = treeFromTrunk - [[StartRoom] - ,[DoorAno] - ,[SpecificRoom $ fmap (pure . Right) $ randomiseAllLinks =<< centerVaultRoom 1 200 200 50] - ,[SpecificRoom blockedCorridor] - ,[OrAno [[DoorAno] - ,[Corridor] - ,[DoorNumAno 0,AirlockAno]] - ] - ,[FirstWeapon] - ,[Corridor] - ,[SpecificRoom $ fmap (pure . Right) testRoom] - ,[Corridor] - ,[OrAno [[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers] - ,[BossAno $ addArmour launcherCrit & crHP +~ 800 - & crState . crDropsOnDeath .~ DropSpecific [0] ] - ] - ] - ,[Corridor] - ,[SpecificRoom $ fmap (pure . Right) armouredCorridor] - ,[Corridor] - ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] - ] - t' + [[StartRoom] + ,[Corridor] + ,[SpecificRoom $ (pure . pure . Right) $ airlockCrystal 20] + ,[Corridor] + ,[DoorAno] + ,[SpecificRoom $ fmap (pure . Right) + $ randomiseLinksBy shuffleTail =<< centerVaultRoom 1 200 200 50] + ,[SpecificRoom blockedCorridor] + ,[OrAno [[DoorAno] + ,[Corridor] + ,[DoorNumAno 0,AirlockAno]] + ] + ,[FirstWeapon] + ,[Corridor] + ,[SpecificRoom $ fmap (pure . Right) testRoom] + ,[Corridor] + ,[OrAno + [[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers] + ,[BossAno $ addArmour launcherCrit & crHP +~ 800 + & crState . crDropsOnDeath .~ DropSpecific [0] ] + ] + ] + ,[Corridor] + ,[SpecificRoom $ fmap (pure . Right) armouredCorridor] + ,[Corridor] + ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] + ] + t' fmap (shiftExpandTree . expandTreeBy id) $ mapM annoToRoomTree t levx :: RandomGen g => State g [Room] diff --git a/src/Dodge/Layout/Tree/Annotate.hs b/src/Dodge/Layout/Tree/Annotate.hs index 9a665c3c6..f74f7dbac 100644 --- a/src/Dodge/Layout/Tree/Annotate.hs +++ b/src/Dodge/Layout/Tree/Annotate.hs @@ -15,6 +15,7 @@ import Dodge.Room.Boss import Dodge.Room.Treasure import Dodge.Room.Link import Dodge.Room.Data +import Dodge.Room.Airlock import Dodge.Room import Dodge.Room.Teleport @@ -71,7 +72,7 @@ annoToRoomTree [OrAno as] = do annoToRoomTree a annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor annoToRoomTree [DoorAno] = roomThenCorridor door -annoToRoomTree [DoorNumAno i,AirlockAno] = roomThenCorridor (airlock i) +annoToRoomTree [DoorNumAno i,AirlockAno] = airlock i >>= roomThenCorridor annoToRoomTree [FirstWeapon] = do branchWP <- branchRectWith weaponRoom blockedC <- longBlockedCorridor diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 451d62774..3665e95a8 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -61,10 +61,16 @@ placeSpot ps w = case ps of -> placePressPlate pp p rot w PS {_psType = RandPS rgen} -> placeSpot (set psType evaluatedType ps) (set randGen g w) - where (evaluatedType, g) = runState rgen (_randGen w) + where + (evaluatedType, g) = runState rgen (_randGen w) - PS {_psPos = p, _psRot = rot, _psType = PutTriggerDoor col f a b} - -> addTriggerDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w + PS {_psPos = p, _psRot = rot, _psType = PutDoor col f pss} + -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w + where + mapBoth fn (x,y) = (fn x, fn y) + + PS {_psPos = p, _psRot = rot, _psType = PutDoubleDoor col f a b} + -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b} -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs index 4d694c546..edb7cd76b 100644 --- a/src/Dodge/LevelGen/AutoDoor.hs +++ b/src/Dodge/LevelGen/AutoDoor.hs @@ -10,6 +10,7 @@ import Dodge.SoundLogic import Dodge.Creature.Property import Geometry import Picture +import qualified DoubleStack as DS import Data.List import Data.Maybe @@ -85,6 +86,7 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door , _wlSeen = False , _wlIsSeeThrough = False , _doorPathable = True + , _drPositions = DS.singleton closedPos } where a = closedPos !! 0 diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 3233fc87a..1c618234d 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -17,7 +17,8 @@ data PSType = PutCrit Creature | PutAutoDoor Point2 Point2 | PutBlock [Int] Color [Point2] | PutLineBlock Wall Float Float Point2 Point2 - | PutTriggerDoor Color (World -> Bool) Point2 Point2 + | PutDoubleDoor Color (World -> Bool) Point2 Point2 + | PutDoor Color (World -> Bool) [(Point2,Point2)] | PutBtDoor Color Point2 Float Point2 Point2 | PutSwitchDoor Color Point2 Float Point2 Point2 | RandPS (State StdGen PSType) diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index ee1812886..362834c28 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -6,17 +6,15 @@ import Dodge.Base import Dodge.SoundLogic import Dodge.LevelGen.Switch import Dodge.LevelGen.Pathing - import Picture import Geometry +import qualified DoubleStack as DS import Data.List import Data.Maybe import qualified Data.IntMap.Strict as IM - import Control.Lens import Control.DeepSeq (deepseq) - import Data.Graph.Inductive hiding ((&)) import Data.Graph.Inductive.NodeMap @@ -26,7 +24,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt) $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) $ set pathGraph newGraph $ set pathGraph' newGraphPairs - $ addTriggerDoor c cond a b w + $ putDoubleDoor c cond a b w where bid = newKey $ _buttons w cond w = BtNoLabel == _btState (_buttons w IM.! bid) @@ -44,7 +42,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) $ set pathGraph newGraph $ set pathGraph' newGraphPairs - $ addTriggerDoor c cond a b w + $ putDoubleDoor c cond a b w where bid = newKey $ _buttons w cond w = BtOn == _btState (_buttons w IM.! bid) @@ -59,17 +57,48 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) closeDoor w' = over pathGraph' (\\ removedPairs) . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w' -addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World -addTriggerDoor c cond a b = over walls (triggerDoor c cond a b) -triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall -triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is - where - i = newKey wls - is = [i..] +putDoor + :: Color + -> (World -> Bool) + -> [(Point2,Point2)] -- ^ Door positions, closed to open. + -- Bumped out up and down by 9, not widened + -> World + -> World +putDoor c cond pss = over walls triggerDoor + where + triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is + where + is = [newKey wls..] -mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall] -mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond) +putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World +putDoubleDoor c cond a b = over walls triggerDoubleDoor + where + triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoubleDoor c cond a b is + where + is = [newKey wls..] + +mkTriggerDoor + :: Color + -> (World -> Bool) -- ^ Opening condition + -> [(Point2,Point2)] -- ^ List of wall position pairs, closed to open + -> [Int] -- ^ Wall ids + -> [Wall] +mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $ + transpose $ map toPanePoints ppairs + +toPanePoints :: (Point2,Point2) -> [[Point2]] +toPanePoints (x,y) = + [ [y +.+ perp, y -.- perp] + , [y -.- perp, x -.- perp] + , [x -.- perp, x +.+ perp] + , [x +.+ perp, y +.+ perp] + ] + where + perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y)) + +mkTriggerDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall] +mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear c cond) xs (leftDoor ++ rightDoor) (map shiftLeft leftDoor ++ map shiftRight rightDoor) @@ -106,8 +135,14 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond) where wp = _wlLine (_walls w IM.! head xs) !! 1 -triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall -triggerDoorPane c cond n closedPos openPos = Door +triggerDoorPaneLinear + :: Color + -> (World -> Bool) -- ^ Opening condition + -> Int -- ^ Wall id + -> [Point2] -- ^ Closed position + -> [Point2] -- ^ Open position + -> Wall +triggerDoorPaneLinear c cond n closedPos openPos = Door { _wlLine = closedPos , _wlID = n , _doorMech = dm @@ -115,6 +150,7 @@ triggerDoorPane c cond n closedPos openPos = Door , _wlSeen = False , _wlIsSeeThrough = False , _doorPathable = False + , _drPositions = DS.singleton closedPos } where a = closedPos !! 0 @@ -135,3 +171,40 @@ triggerDoorPane c cond n closedPos openPos = Door = over wallsZone $ adjustIMZone openDoor x y n changeZonedWall' (!x,!y) = over wallsZone $ adjustIMZone closeDoor x y n + +{- | +Zoning might be an issue here. +It is necessary in the current version, but I am not sure of its behaviour. -} +triggerDoorPane + :: Color + -> (World -> Bool) -- ^ Opening condition + -> Int -- ^ Wall id + -> [[Point2]] -- ^ List of positions: closed to open + -> Wall +triggerDoorPane c cond n poss = Door + { _wlLine = head poss + , _wlID = n + , _doorMech = dm + , _wlColor = c + , _wlSeen = False + , _wlIsSeeThrough = False + , _doorPathable = False + , _drPositions = DS.fromListL poss + } + where + dm w | cond w = flip (foldr changeZonedWall) allZoneps + $ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a') + | otherwise = flip (foldr changeZonedWall') allZoneps + $ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a) + openDoor = updatePos . (drPositions %~ DS.pushL) + closeDoor = updatePos . (drPositions %~ DS.pushR) + updatePos :: Wall -> Wall + updatePos d = d & wlLine %~ maybe id const (DS.head <$> (d ^? drPositions)) + changeZonedWall (!x,!y) + = over wallsZone $ adjustIMZone openDoor x y n + changeZonedWall' (!x,!y) + = over wallsZone $ adjustIMZone closeDoor x y n + allZoneps = nub $ concatMap zoneps poss + zoneps [a,b] + | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b] + | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b diff --git a/src/Dodge/RandomHelp.hs b/src/Dodge/RandomHelp.hs index 3ed817d52..34c2a68a7 100644 --- a/src/Dodge/RandomHelp.hs +++ b/src/Dodge/RandomHelp.hs @@ -41,7 +41,7 @@ takeN :: RandomGen g => Int -> [a] -> State g [a] takeN 0 xs = return [] takeN i xs = fmap fst $ takeNMore i ([],xs) --- to randomly shuffle a list +-- | Randomly shuffle a list. shuffle :: RandomGen g => [a] -> State g [a] shuffle xs = do let l = length xs @@ -51,6 +51,10 @@ shuffle xs = do let (_,zs) = mapAccumR f xs rands return zs +-- | Randomly shuffle the tail of a list, not safe. +shuffleTail :: RandomGen g => [a] -> State g [a] +shuffleTail (x:xs) = (x :) <$> shuffle xs + randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a] randomSelectionFromList p = filterM $ const $ randProb p diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 2556ceb22..3b20bdb48 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -51,53 +51,43 @@ doDrawing pdata w = do viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w pic = worldPictures w wallPoints = map fst wallPointsCol - -- set the coordinate uniforms ready for drawing elements with using world coordinates setCommonUniforms pdata rot zoom trans wins depthFunc $= Just Less pmat <- (newMatrix RowMajor $ perspectiveMatrix rot zoom trans wins viewFroms) :: IO (GLmatrix GLfloat) - -- draw the lightmap. Probably changes the bound framebufferObject createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints viewFroms pmat - -- draw the background. Assumes that depth testing is not enabled or that -- the depth buffer is ready to be drawn on blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) renderBackground pdata rot zoom trans wins - -- draw the walls depthFunc $= Just Less if w ^. config . wall_textured then renderTextureWalls pdata wallPointsCol pmat else renderBlankWalls pdata wallPointsCol pmat - -- I believe a more apt name would be setCeilingDepth: stops drawing of objects -- at points that are behind the extension of walls to the screen edge setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat - -- draw the first layer of pictures -- these will probably all be opaque renderFoldable pdata $ picToLTree (Just 0) pic - -- reset blend so that light map doesn't apply -- useful for drawing vivid projectiles blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One)) depthFunc $= Just Lequal renderFoldable pdata $ picToLTree (Just 1) pic - -- reset blend so that light map applies again -- allows us to be certain these elements are drawn on top of those before, -- in case we want transparency effects blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) renderFoldable pdata $ picToLTree (Just 2) pic depthMask $= Disabled - -- render transparent walls -- the ordering between these and transparent clouds perhaps presents a challenge renderBlankWalls pdata windowPoints pmat depthMask $= Enabled - -- draw the fbo to the screen -- allows for post-processing -- first, bind the screen fbo @@ -108,20 +98,23 @@ doDrawing pdata w = do textureBinding Texture2D $= Just (snd $ _fbo2 pdata) -- textureFilter Texture2D $= ((Linear',Just Linear') , Linear') -- generateMipmap' Texture2D - bindShaderBuffers [_fullscreenShader pdata] [4] - drawShader (_fullscreenShader pdata) 4 + if _crHP (you w) > 0 + then do + bindShaderBuffers [_fullscreenShader pdata] [4] + drawShader (_fullscreenShader pdata) 4 + else do + bindShaderBuffers [_grayscaleShader pdata] [4] + drawShader (_grayscaleShader pdata) 4 blend $= Enabled - -- reset the coordinate uniforms for pictures that are drawn wrt to window -- coordinates resetShaderUniforms (map extractProgAndUnis $ _pictureShaders pdata) - blendFunc $= (SrcAlpha,OneMinusSrcAlpha) renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w) eTicks <- SDL.ticks return (eTicks - sTicks) ----------------------- +-------------------------------------------------------------------------------- renderBlankWalls :: RenderData diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 28442cf64..43c0cb136 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -27,6 +27,7 @@ import Dodge.Room.Corridor import Dodge.Room.Link import Dodge.Room.Branch import Dodge.Room.Door +import Dodge.Room.Airlock import Geometry import Picture @@ -47,53 +48,6 @@ import Data.Graph.Inductive.NodeMap import qualified Data.Map as M import qualified Data.IntMap.Strict as IM -airlockOneWay :: Int -> Room -airlockOneWay n = Room - { _rmPolys = [rectNSWE 90 0 0 40] - , _rmLinks = lnks - , _rmPath = [] - , _rmPS = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (0,40) - ,PS (0,75) 0 $ PutTriggerDoor col (cond) (0,0) (0,40) - ,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState - (M.insert (DoorNumOpen n) True)) - ] - --, _rmBound = rectNSWE 90 30 (-30) 30 - , _rmBound = rectNSWE 75 15 0 40 - } - where lnks = [((0,85),0) - ,((0, 5),pi) - ] - cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) - col = dim $ dim $ bright red - -airlock - :: Int -- ^ Door id - -> Room -airlock n = Room - { _rmPolys = - [ rectNSWE 100 0 0 40 - , rectNSWE 65 35 (-40) 20 - ] - , _rmLinks = lnks - , _rmPath = [((20,85),(20,45)) - ,((20,45),(20, 5)) - ] - , _rmPS = - [PS (0,20) 0 $ PutTriggerDoor col (not . cond) (1,0) (39,0) - ,PS (0,80) 0 $ PutTriggerDoor col (cond) (1,0) (39,0) - ,PS (35,50) (pi/2) $ PutButton $ makeSwitch col - (over worldState (M.insert (DoorNumOpen n) True)) - (over worldState (M.insert (DoorNumOpen n) False)) - ,PS (-25, 50) 0 putLamp - ] - , _rmBound = rectNSWE 75 15 0 40 - } - where - lnks = [((20,85),0) - ,((20, 5),pi) - ] - cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) - col = dim $ dim $ bright red roomC :: Float -> Float -> Room roomC x y = Room @@ -633,4 +587,5 @@ spawnerRoom = do ] let f ((lx,_),_) = lx < x/2-5 roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2) - return $ treeFromTrunk [Left (airlock 0)] roomWithSpawner + aRoom <- airlock 0 + return $ treeFromTrunk [Left aRoom] roomWithSpawner diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs new file mode 100644 index 000000000..00e299509 --- /dev/null +++ b/src/Dodge/Room/Airlock.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE TupleSections #-} +{- +Rooms that contain two doors and a switch alternating both. -} +module Dodge.Room.Airlock + where +import Dodge.Room.Data +import Dodge.Room.Placement +import Dodge.Data +import Dodge.LevelGen.Data +import Dodge.LevelGen.Switch +import Dodge.RandomHelp +import Geometry +import Picture + +import qualified Data.Map as M +import System.Random +import Control.Monad.State +import Control.Lens + +airlockOneWay :: Int -> Room +airlockOneWay n = Room + { _rmPolys = [rectNSWE 90 0 0 40] + , _rmLinks = lnks + , _rmPath = [] + , _rmPS = [PS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40) + ,PS (0,75) 0 $ PutDoubleDoor col (cond) (0,0) (0,40) + ,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState + (M.insert (DoorNumOpen n) True)) + ] + --, _rmBound = rectNSWE 90 30 (-30) 30 + , _rmBound = rectNSWE 75 15 0 40 + } + where lnks = [((0,85),0) + ,((0, 5),pi) + ] + cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) + col = dim $ dim $ bright red + +{- | +A passage with a switch that opens forward access while closing backwards access. -} +airlock + :: RandomGen g + => Int -- ^ Door id + -> State g Room +airlock n = takeOne [airlock0 n,airlock90 n,airlockCrystal n] + +{- | +Straight airlock -} +airlock0 + :: Int -- ^ Door id + -> Room +airlock0 n = Room + { _rmPolys = + [ rectNSWE 100 0 0 40 + , rectNSWE 65 35 (-40) 20 + ] + , _rmLinks = lnks + , _rmPath = [((20,95),(20,45)) + ,((20,45),(20, 5)) + ] + , _rmPS = + [PS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0) + ,PS (0,80) 0 $ PutDoubleDoor col (cond) (1,0) (39,0) + ,PS (35,50) (pi/2) $ PutButton $ makeSwitch col + (over worldState (M.insert (DoorNumOpen n) True)) + (over worldState (M.insert (DoorNumOpen n) False)) + ,PS (-25, 50) 0 putLamp + ] + , _rmBound = rectNSWE 75 15 0 40 + } + where + lnks = [((20,95),0) + ,((20, 5),pi) + ] + cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) + col = dim $ dim $ bright red + +airlock90 + :: Int -- ^ Door id + -> Room +airlock90 n = Room + { _rmPolys = + [ rectNSWE 100 10 10 100 + , rectNSWE 20 0 20 60 + , rectNSWE 20 60 20 0 + , [ (10,100) + , (100,150) + , (150,100) + , (100,10) + ] + ] + , _rmLinks = + [((0,40),pi/2) + ,((40, 0),pi) + ] + , _rmPath = + [((0,40),(40,0)) + ,((40,0),(0,40)) + ] + , _rmPS = + [PS (5,5) 0 $ PutDoor col (not . cond) pss + ,PS (120,120) (3* pi/4) $ PutButton $ makeSwitch col + (over worldState (M.insert (DoorNumOpen n) True)) + (over worldState (M.insert (DoorNumOpen n) False)) + ,PS (60, 60) 0 putLamp + ] + , _rmBound = + [ (10,10) + , (10,100) + , (100,150) + , (150,100) + , (100,10) + ] + } + where + cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) + col = dim $ dim $ bright red + pss = ((0,0) ,) <$> arcStepwise 3 (negate $ pi/2) (0,0) (0,55) + +airlockCrystal + :: Int -- ^ Door id + -> Room +airlockCrystal n = Room + { _rmPolys = + [ rectNSWE 140 0 0 40 + , orderPolygon + [(39,20) + ,(150,60) + ,(150,80) + ,(39,120) + ] + ] + , _rmLinks = + [((20,130),0) + ,((20, 0),pi) + ] + , _rmPath = + [ + ] + , _rmPS = + [PS (0,0) 0 $ PutDoor col (not . cond) pss + ,PS (145,70) (pi/2) $ PutButton $ makeSwitch col + (over worldState (M.insert (DoorNumOpen n) True)) + (over worldState (M.insert (DoorNumOpen n) False)) + ,crystalLine (0,70) (40,70) + ,PS (20, 40) 0 putLamp + ,PS (20, 100) 0 putLamp + ] + , _rmBound = + [ ] + } + where + cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) + col = dim $ dim $ bright red + pss :: [(Point2,Point2)] + pss = reverse $ fmap ( (\x -> ((50,x),(50,x+50)) ) . fromIntegral) + [20,22..70] diff --git a/src/Dodge/Room/Door.hs b/src/Dodge/Room/Door.hs index 00cbc2755..6fb7d57e5 100644 --- a/src/Dodge/Room/Door.hs +++ b/src/Dodge/Room/Door.hs @@ -22,3 +22,5 @@ door = Room where lnks = [((20,35),0) ,((20, 5),pi) ] + + diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index 7748a22a7..712a29bc3 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -30,6 +30,15 @@ randomiseAllLinks r = do newLinks <- shuffle $ _rmLinks r return $ r {_rmLinks = newLinks} +randomiseLinksBy + :: RandomGen g + => ( [(Point2,Float)] -> State g [(Point2,Float)] ) + -> Room + -> State g Room +randomiseLinksBy f r = do + newLinks <- f $ _rmLinks r + return $ r {_rmLinks = newLinks} + filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room filterLinks cond r = do newLinks <- shuffle $ filter cond $ init $ _rmLinks r diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 5b2ee71b1..adbee9460 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -260,6 +260,10 @@ centerVaultRoom n w h d = do ,PS (w-5,5-h) 0 putLamp ,PS (5-w,h-5) 0 putLamp ,PS (5-w,5-h) 0 putLamp + ,PS (0,h-5) 0 $ PutCrit explosiveBarrel + ,PS (5,h-5) 0 $ PutCrit explosiveBarrel + ,PS (0,h) 0 $ PutCrit explosiveBarrel + ,PS (-4,h-5) 0 $ PutCrit explosiveBarrel ,PS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll) ] ++ concat (zipWith (\i r -> map (shiftPSBy ((0,0),r)) $ theDoor i) @@ -269,7 +273,7 @@ centerVaultRoom n w h d = do where col = dim $ dim $ bright red theDoor i = - [ PS (0,d-10) 0 $ PutTriggerDoor col (cond i) (-19,0) (19,0) + [ PS (0,d-10) 0 $ PutDoubleDoor col (cond i) (-19,0) (19,0) , PS (35,d+4) 0 $ PutButton $ makeSwitch col (over worldState (M.insert (DoorNumOpen i) True)) (over worldState (M.insert (DoorNumOpen i) False)) diff --git a/src/Dodge/Room/Teleport.hs b/src/Dodge/Room/Teleport.hs index 224cfdafe..3898683dd 100644 --- a/src/Dodge/Room/Teleport.hs +++ b/src/Dodge/Room/Teleport.hs @@ -4,6 +4,7 @@ Specification of rooms that teleport (between levels). module Dodge.Room.Teleport where import Dodge.Data +import Dodge.World.Trigger.Data import Dodge.Base import Dodge.Room.Data import Dodge.Room.Procedural diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 67edb7ffd..539ee50f9 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -7,6 +7,7 @@ module Dodge.Update ) where import Dodge.Data import Dodge.Data.Menu +import Dodge.World.Trigger.Data import Dodge.Config.Data import Dodge.Data.Menu import Dodge.Base @@ -35,35 +36,38 @@ pushSideEffects :: World -> World pushSideEffects w = w & sideEffects .~ [] & doneSideEffects .~ _sideEffects w - -{- | The update step. -If '_menuLayers' is not empty, or the saving screen, this is the identity. -In such menus, the only way to change the world is using event handling. - -} +{- | + The update step. +For most menus the only way to change the world is using event handling. -} update' :: World -> World update' w = case _menuLayers w of (WaitMessage _ : ls) -> w & menuLayers .~ ls - (_ : _) -> w - [] -> let w1 = updateParticles - . updateProjectiles - . updateLightSources - . zoneClouds - . updateClouds - . updateCreatures - . updateBlocks -- . zoning - . updateSeenWalls - . updateSoundQueue - $ updateCloseObjects w - in checkEndGame - . updateTriggers - . ppEvents - . updateCamera - . colCrsWalls - . simpleCrSprings - . zoneCreatures - . updateWalls - . set worldEvents id - $ _worldEvents w1 w1 + (GameOverMenu : _) -> updateParticles + . updateProjectiles + . updateLightSources + $ updateClouds + w + (_ : _) -> w + [] -> checkEndGame + . updateTriggers + . ppEvents + . updateCamera + . colCrsWalls + . simpleCrSprings + . zoneCreatures + . updateWalls + . set worldEvents id + . doubleArgumentFor _worldEvents + . updateParticles + . updateProjectiles + . updateLightSources + . zoneClouds + . updateClouds + . updateCreatures + . updateBlocks + . updateSeenWalls + . updateSoundQueue + $ updateCloseObjects w where zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w)) creatureInZone cr = insertIMInZone x y cid cr @@ -73,17 +77,18 @@ update' w = case _menuLayers w of cloudInZone cr = insertIMInZone x y cid cr where (x,y) = zoneOfPoint $ _clPos cr cid = _clID cr + doubleArgumentFor f x = f x x updateTriggers :: World -> World updateTriggers w - | ResetLevel 1 `S.member` _worldTriggers w - = generateFromList levx - $ initialWorld - & randGen .~ _randGen w - & config .~ _config w - & menuLayers .~ [] - & creatures . ix 0 . crPos .~ (0,0) + | ResetLevel 1 `S.member` _worldTriggers w = generateFromList levx $ initialWorld + & randGen .~ _randGen w + & config .~ _config w + & menuLayers .~ [] + & creatures . ix 0 .~ cr | otherwise = w + where + cr = _creatures w IM.! 0 & crPos .~ (0,0) updateSoundQueue = set soundQueue [] . set sounds M.empty @@ -93,10 +98,8 @@ updateLightSources w = set tempLightSources (catMaybes tlss) w' (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w - {- -Apply internal particle updates, delete 'Nothing's. - -} +Apply internal particle updates, delete 'Nothing's. -} updateParticles :: World -> World updateParticles w = set particles (catMaybes ps) w' where @@ -105,12 +108,11 @@ updateParticles w = set particles (catMaybes ps) w' updateCreatures :: World -> World updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w where - ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) - $ _creatures w + ((f,newG),crs) = + IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w {- | -Apply door mechanisms. - -} +Apply door mechanisms. -} updateWalls :: World -> World updateWalls w = IM.foldr (maybe id id . (^? doorMech)) w (_walls w) @@ -127,69 +129,75 @@ updateSeenWalls w = foldr markSeen w wallsToUpdate setTestStringIO :: IO World -> IO World setTestStringIO = fmap (\ w -> set testString (show $ s w) w) - where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos) + where + s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos) checkEndGame :: World -> World -checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]} - | otherwise = w +checkEndGame w + | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]} + | otherwise = w updateClouds :: World -> World updateClouds w = IM.foldr' updateCloud w $ _clouds w updateCloud :: Cloud -> World -> World -updateCloud c w | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c) - | otherwise = moveCloud c w +updateCloud c w + | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c) + | otherwise = moveCloud c w moveCloud :: Cloud -> World -> World moveCloud c w = _clEffect c c . theUpdate $ w - where newVel = 0.95 *.* springVels - springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w) - oldPos = _clPos c - newPos = oldPos +.+ newVel - hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w - finalPos = fromMaybe newPos (fmap fst hitWl) - finalVel = fromMaybe newVel (fmap snd hitWl) - theUpdate w' = w' & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1) - & clouds . ix (_clID c) . clVel .~ finalVel - & clouds . ix (_clID c) . clPos .~ finalPos + where + newVel = 0.95 *.* springVels + springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w) + oldPos = _clPos c + newPos = oldPos +.+ newVel + hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w + finalPos = fromMaybe newPos (fmap fst hitWl) + finalVel = fromMaybe newVel (fmap snd hitWl) + theUpdate w' = w' + & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1) + & clouds . ix (_clID c) . clVel .~ finalVel + & clouds . ix (_clID c) . clPos .~ finalPos clClSpringVel :: Cloud -> World -> Cloud -> Point2 -> Point2 clClSpringVel a w b v | ida == idb = v | dist pa pb < radDist = v +.+ 0.1 *.* (safeNormalizeV (pa -.- pb)) | otherwise = v - where ida = _clID a - idb = _clID b - pa = _clPos a - pb = _clPos b - radDist = (_clRad a + _clRad b) / 2 + where + ida = _clID a + idb = _clID b + pa = _clPos a + pb = _clPos b + radDist = (_clRad a + _clRad b) / 2 simpleCrSprings :: World -> World simpleCrSprings w = IM.foldr' crSpring w $ _creatures w crSpring :: Creature -> World -> World crSpring c w = IM.foldr' (crCrSpring c) w $ cs - where cs = creaturesNearPoint (_crPos c) w + where + cs = creaturesNearPoint (_crPos c) w crCrSpring :: Creature -> Creature -> World -> World crCrSpring c1 c2 w - | id1 == id2 = w - | vec == (0,0) = w - | diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1) - $ over (creatures . ix id2 . crPos) (-.- overlap2) w - | otherwise = w - where id1 = _crID c1 - id2 = _crID c2 - vec = _crPos c1 -.- _crPos c2 - diff = magV $ vec - comRad = _crRad c1 + _crRad c2 - overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec - overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec - massT = _crMass c1 + _crMass c2 - + | id1 == id2 = w + | vec == (0,0) = w + | diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1) + $ over (creatures . ix id2 . crPos) (-.- overlap2) w + | otherwise = w + where + id1 = _crID c1 + id2 = _crID c2 + vec = _crPos c1 -.- _crPos c2 + diff = magV $ vec + comRad = _crRad c1 + _crRad c2 + overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec + overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec + massT = _crMass c1 + _crMass c2 {- -Finds the IDs of visible walls from a point to another point. --} +Finds the IDs of visible walls from a point to another point. -} visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int] visibleWalls p1 p2 ws = map fst @@ -201,8 +209,10 @@ visibleWalls p1 p2 ws $ IM.toList ws where f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl)) - takeUntil h xs = let (ys,zs) = span h xs - in ys ++ tf zs - where tf (x:_) = [x] - tf _ = [] + takeUntil h xs = + let (ys,zs) = span h xs + in ys ++ tf zs + where + tf (x:_) = [x] + tf _ = [] diff --git a/src/Dodge/World.hs b/src/Dodge/World.hs new file mode 100644 index 000000000..6a8e5a4f0 --- /dev/null +++ b/src/Dodge/World.hs @@ -0,0 +1,6 @@ +{- | +Placeholder... not sure of its purpose, but might deal with pure world change functions. +The world datatype itself is very intertwined with the creature, weapon, etc datatypes. + -} +module Dodge.World + where diff --git a/src/Dodge/World/Trigger/Data.hs b/src/Dodge/World/Trigger/Data.hs new file mode 100644 index 000000000..48ecc7358 --- /dev/null +++ b/src/Dodge/World/Trigger/Data.hs @@ -0,0 +1,12 @@ +{- | +World triggers are intended to help me handle global events, +such as new levels, game overs, etc, that disrupt the typical flow of the game. +They should probably be used sparingly. + -} +module Dodge.World.Trigger.Data + where + +data WorldTrigger + = ResetLevel Int + | GameOver + deriving (Eq,Ord) diff --git a/src/DoubleStack.hs b/src/DoubleStack.hs new file mode 100644 index 000000000..870fac635 --- /dev/null +++ b/src/DoubleStack.hs @@ -0,0 +1,33 @@ +module DoubleStack + where + +newtype DS a = DS (a,[a],[a]) + deriving (Eq, Ord, Read, Show) + +{- | +Unsafe. -} +fromListL :: [a] -> DS a +fromListL (x:xs) = DS (x,xs,[]) + +singleton :: a -> DS a +singleton x = DS (x,[],[]) + +head (DS (x,_,_)) = x +left (DS (_,l,_)) = l +right (DS (_,_,r)) = r + +pushL :: DS a -> DS a +pushL (DS (x,xs,(y:ys))) = DS (y,(x:xs),ys) +pushL ds = ds + +pushR :: DS a -> DS a +pushR (DS (y,(x:xs),ys)) = DS (x,xs,(y:ys)) +pushR ds = ds + +cycleL :: DS a -> Maybe (DS a) +cycleL (DS (x,xs,(y:ys))) = Just $ DS (y,(x:xs),ys) +cycleL _ = Nothing + +cycleR :: DS a -> Maybe (DS a) +cycleR (DS (y,(x:xs),ys)) = Just $ DS (x,xs,(y:ys)) +cycleR _ = Nothing diff --git a/src/Geometry.hs b/src/Geometry.hs index cd6d758db..0ba975022 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -461,6 +461,29 @@ divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad where n = ceiling $ rad * 2 * pi / x +arcStepwise + :: Float -- ^ Maximum distance between points + -> Float -- ^ Angle to travel + -> Point2 -- ^ Center + -> Point2 -- ^ Start vector from center + -> [Point2] +arcStepwise ssize a c v + | a < 0 = reverse $ arcStepwisePositive ssize (negate a) c (rotateV a v) + | otherwise = arcStepwisePositive ssize a c v + +arcStepwisePositive + :: Float -- ^ Maximum distance between points + -> Float -- ^ Angle to travel, assumed to be positive + -> Point2 -- ^ Center + -> Point2 -- ^ Start vector from center + -> [Point2] +arcStepwisePositive ssize a cen v = ((cen +.+) . (\rot -> rotateV rot v) ) <$> rots + where + rots :: [Float] + rots = map ((a*) . (/ fromIntegral n ) . fromIntegral) [0 .. n] + n :: Int + n = ceiling (a * magV v / ssize) + --nPointsOnCirc :: Int -> Float -> [Point2] --nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)