diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index d85cae2ff..d8cbcf9c2 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -48,6 +48,7 @@ import FoldableHelp import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens +import Control.Monad import qualified FoldlHelp as L import Data.Monoid import Streaming @@ -149,19 +150,17 @@ orderStreamOn f = S.each . runIdentity . L.purely S.fold_ L.map . S.map g where g x = (f x,x) -visibleWallWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity () -visibleWallWalls sp ep = - join - . fmap (S.take 1) - . S.span (not . wlIsOpaque . snd) +visibleWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity () +visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap + ( S.span (not . wlIsOpaque . snd) . orderStreamOn (dist sp . fst) . S.mapMaybe f - . wallsAlongLineStream sp ep + . wallsAlongLineStream sp ep ) where f wl = uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl) allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity () -allVisibleWalls w = concats $ S.subst (flip (visibleWallWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20) +allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20) where vPos = _cameraViewFrom w diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 6269470f3..fffda028d 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -126,7 +126,7 @@ data World = World , _floorItems :: IM.IntMap FloorItem , _floorTiles :: [(Point3,Point3)] , _randGen :: StdGen - , _testString :: World -> [String] + , _testString :: Configuration -> World -> [String] , _debugPicture :: Picture , _modifications :: IM.IntMap Modification , _yourID :: Int @@ -254,6 +254,7 @@ data ScreenLayer , _scOptions :: [MenuOption] , _scDefaultEff :: Universe -> IO (Maybe Universe) , _scOptionFlag :: OptionScreenFlag + , _scOptionsOffset :: Int } | ColumnsScreen { _scTitle :: Universe -> String diff --git a/src/Dodge/Debug.hs b/src/Dodge/Debug.hs index 20e60d8ec..b9c4c5b3f 100644 --- a/src/Dodge/Debug.hs +++ b/src/Dodge/Debug.hs @@ -9,6 +9,7 @@ import Picture import qualified IntMapHelp as IM import qualified Data.IntSet as IS +import qualified Streaming.Prelude as S import Control.Lens drawCircleAtFor :: Point2 -> Int -> World -> World @@ -55,9 +56,10 @@ drawDDA = setLayer BloomLayer . color (withAlpha 0.5 green) . IM.foldlWithKey' f debugWallZoningPic :: World -> Picture debugWallZoningPic w = setLayer BloomLayer $ zonesPic `appendPic` wallsPic where - wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls + --wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls + wallsPic = setDepth 25 . color yellow . runIdentity . S.foldMap_ (drawTheWall . _wlLine) + $ wallsAlongLineStream sp ep w drawTheWall (a,b) = thickLine 20 [a,b] - theWalls = wallsAlongLine sp ep w zonesPic = setDepth 20 $ drawDDA zones zones = ddaExt zoneSize sp ep sp = _crPos $ you w diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index eaada9b1b..b8d40bb1c 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -56,7 +56,7 @@ defaultWorld = World , _floorTiles = [] , _randGen = mkStdGen 2 , _mousePos = V2 0 0 - , _testString = const [] + , _testString = const . const [] , _debugPicture = mempty , _yourID = 0 , _worldEvents = id diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index c77f18d75..fe0b72164 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -5,6 +5,7 @@ import Dodge.Data import Dodge.Debug.Terminal --import Dodge.Menu import Dodge.Menu.PushPop +import Dodge.WindowLayout import Data.Maybe --import Control.Monad @@ -15,8 +16,8 @@ import qualified Data.Text as T handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe) handlePressedKeyInMenu mState scode = case mState of - OptionScreen { _scOptions = mos, _scDefaultEff = defeff} - -> optionListToEffects defeff scode mos + OptionScreen { _scOptions = mos, _scDefaultEff = defeff, _scOptionsOffset = offset} + -> optionListToEffects defeff scode offset mos DisplayScreen {} -> popScreen ColumnsScreen {} -> popScreen WaitScreen {} -> return . Just @@ -35,12 +36,20 @@ handlePressedKeyInMenu mState scode = case mState of optionListToEffects :: (Universe -> IO (Maybe Universe)) -> Scancode + -> Int -> [MenuOption] -> Universe -> IO (Maybe Universe) -optionListToEffects defaulteff sc - = fromMaybe defaulteff - . lookup sc - . concatMap menuOptionToEffects +optionListToEffects defaulteff sc offset mops u = case sc of + ScancodeSpace -> return . Just + . (menuLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines))) + $ u + _ -> (fromMaybe defaulteff + . lookup sc + . concatMap menuOptionToEffects $ mops) u + where + f x | x > length mops = 0 + | otherwise = x + mlines = availableMenuLines $ _config u menuOptionToEffects :: MenuOption -> [(Scancode,Universe -> IO (Maybe Universe))] menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)] diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index ff8ae9b3b..0d6d19a3f 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -40,6 +40,7 @@ initialWorld = defaultWorld -- , _menuLayers = [TerminalScreen 300 rezText'] } -testStringInit :: World -> [String] +testStringInit :: Configuration -> World -> [String] +testStringInit cfig _ = [show $ _windowY cfig] --testStringInit = map (show . _drStatus) . IM.elems . _doors -testStringInit = const [] +--testStringInit = const . const [] diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index eea37811b..479fb1a4a 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -30,6 +30,7 @@ slTitleOptionsEff title ops eff = OptionScreen , _scOptions = ops , _scDefaultEff = eff , _scOptionFlag = NormalOptions + , _scOptionsOffset = 0 } pauseMenu :: ScreenLayer pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause) @@ -158,6 +159,7 @@ gameOverMenu = OptionScreen , _scOptions = pauseMenuOptions , _scDefaultEff = return . Just , _scOptionFlag = GameOverOptions + , _scOptionsOffset = 0 } -- | hacky - no longer used diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index e06f73b0c..8c5be4ba2 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -40,7 +40,7 @@ hudDrawings cfig w = case _hudElement $ _hud w of drawInGameHUD :: Configuration -> World -> Picture drawInGameHUD cfig w = pictures [ winScale cfig . dShadCol white $ displayHP 0 cfig w - , listPicturesAt (halfWidth cfig) 0 cfig $ map text (_testString w w) + , listPicturesAt (halfWidth cfig) 0 cfig $ map text (_testString w cfig w) , inventoryDisplay cfig w ] diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 200db4276..bd93d5b19 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -3,19 +3,21 @@ module Dodge.Render.MenuScreen ( menuScreen ) where import Dodge.Data +import Dodge.WindowLayout import Dodge.Base.Window import Picture import Dodge.Menu import Padding +import Geometry import qualified Data.Text as T menuScreen :: Universe -> ScreenLayer -> Picture menuScreen w screen = case screen of - OptionScreen {_scTitle = titf, _scOptions = mos} - -> drawOptions w (titf w) mos "Use keys to navigate the menu" - (WaitScreen sf _) -> drawOptions w (sf w) [] "" - (InputScreen inputstr help) -> drawOptions w ('>':T.unpack inputstr) [] help + OptionScreen {_scTitle = titf, _scOptions = mos, _scOptionsOffset = off} + -> drawOptions w (titf w) mos off "Use keys to navigate the menu" + (WaitScreen sf _) -> drawOptions w (sf w) [] 0 "" + (InputScreen inputstr help) -> drawOptions w ('>':T.unpack inputstr) [] 0 help (DisplayScreen sd ) -> sd w (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_config w) (titf w) pairs @@ -48,19 +50,29 @@ drawOptions :: Universe -> String -- ^ Title -> [MenuOption] -- ^ Options + -> Int -- ^ Options offset -> String -- ^ Help Text -> Picture -drawOptions u title ops footer = pictures $ +drawOptions u title ops off footer = pictures $ [ darkenBackground cfig , drawTitle cfig title , drawFooterText cfig red footer ] ++ zipWith (\s vpos -> placeString (-hw + 50) vpos 0.2 s) - (map (menuOptionToString u maxOptionLength) ops') + (ops'') [hh-100,hh-150 ..] +-- ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] | +-- y <- map (+75) [0,50..hh*2]] +-- ] where maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops') - ops' = filter notInvisible ops + ops' = case availableMenuLines cfig of + x | x < length ops -> take (availableMenuLines cfig) (drop off visibleops) + _ -> visibleops + ops'' = case availableMenuLines cfig of + x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ ["SPACE: MORE OPTIONS"] + _ -> map (menuOptionToString u maxOptionLength) ops' + visibleops = filter notInvisible ops notInvisible InvisibleToggle {} = False notInvisible _ = True hh = halfHeight cfig diff --git a/src/Dodge/WindowLayout.hs b/src/Dodge/WindowLayout.hs new file mode 100644 index 000000000..317ea19da --- /dev/null +++ b/src/Dodge/WindowLayout.hs @@ -0,0 +1,5 @@ +module Dodge.WindowLayout where +import Dodge.Config.Data + +availableMenuLines :: Configuration -> Int +availableMenuLines = floor . (/50) . subtract 125 . _windowY diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 38d589e61..1ff356c7a 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -2,7 +2,7 @@ module Dodge.Zone ( crZoneOfPoint , zoneOfLineIntMap , wallsNearPoint - , wallsAlongLine +-- , wallsAlongLine , wallsAlongLineStream , zoneSize , zoneOfPoint @@ -165,28 +165,22 @@ cloudsNearPoint p w = f (IM.lookup x (_znObjects $ _cloudsZone w) >>= IM.lookup -- assumes _wallsZone is correct level generation -- there is certainly a problem somewhere here: it may be in the zoning, or -- within this function -wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall ---{-# INLINE wallsAlongLine #-} -wallsAlongLine a b w = - IM.foldlWithKey' g IM.empty kps - where - g m x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _wallsZone w) s)) m - kps = zoneOfLineIntMap a b - f i m = case IM.lookup i m of - Just val -> val - _ -> IM.empty +--wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall +----{-# INLINE wallsAlongLine #-} +--wallsAlongLine a b w = +-- IM.foldlWithKey' g IM.empty kps +-- where +-- g m x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _wallsZone w) s)) m +-- kps = zoneOfLineIntMap a b +-- f i m = case IM.lookup i m of +-- Just val -> val +-- _ -> IM.empty wallsAlongLineStream :: Monad m => Point2 -> Point2 -> World -> Stream (Of Wall) m () wallsAlongLineStream sp ep w = S.concat $ S.mapMaybe f $ zoneOfLineStream sp ep where f (i,j) = w ^? wallsZone . znObjects . ix i . ix j ---wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall -----{-# INLINE wallsAlongLine #-} ---wallsAlongLine a b w = _walls w --- where --- kps = zoneOfLineIntMap a b - wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall wallsAlongCirc p r w = IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y) <- zoneOfCircle p r] where diff --git a/src/Geometry/Zone.hs b/src/Geometry/Zone.hs index b99a47f62..278affd4c 100644 --- a/src/Geometry/Zone.hs +++ b/src/Geometry/Zone.hs @@ -4,6 +4,7 @@ module Geometry.Zone , ddaExt' , ddaSq , ddaSqStream + , ddaStream ) where import Geometry.Data @@ -127,6 +128,10 @@ ddaExt' s sp@(V2 sx sy) ep@(V2 ex ey) [y1 .. y2] | otherwise = zip (map (divTo s) [y2x,y2x+xdy..]) [y2-1 .. y1-1] +ddaStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity () +ddaStream s sp _ -- @(V2 sx sy) ep@(V2 ex ey) + = S.yield $ sizeZoneOfPoint' s sp + -- | Determines which horizontal and vertical lines on a grid are crossed by a -- line. For each adds the x-y index of the square to the right or above the -- crossed grid line. Also adds the index of the square containing the start