Add options page scrolling

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
 

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 

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

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

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)]

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 [] 

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

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
     ]
 

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

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

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 

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