Improve mouse menu controls, tweak charmap

src/Dodge/Base/Window.hs

@@ -54,3 +54,5 @@ screenBox w = rectNSWE hh (- hh) (- hw) hw
   where
     hw = halfWidth w
     hh = halfHeight w
+
+

src/Dodge/Data/SelectionList.hs

@@ -20,10 +20,11 @@ data SelectionList = SelectionList
     , _slWidth :: SelectionWidth
     , _slLength :: Int
     , _slSizeRestriction :: SelectionSizeRestriction
-    , _slSpecialItem :: SpecialSelectionItem
+--    , _slSpecialItem :: SpecialSelectionItem
     }
 
 data SelectionItemIndex = ListedSelectionItem Int
+    | DummySelectionItem
     | ScrollUpSelectionItem
     | ScrollDownSelectionItem
     | SpecialSelectionItem

src/Dodge/Data/Universe.hs

@@ -5,6 +5,7 @@
 
 module Dodge.Data.Universe (
     module Dodge.Data.Universe,
+    module Dodge.Data.SelectionList,
     module Dodge.Data.Config,
     module Dodge.Data.World,
     module Data.Preload,

src/Dodge/Menu/Option.hs

@@ -1,7 +1,7 @@
 module Dodge.Menu.Option
     where
 --import Dodge.ScodeToChar
-import Data.Maybe
+--import Data.Maybe
 import Dodge.WindowLayout
 import Padding
 import Picture.Base
@@ -18,11 +18,13 @@ slTitleOptionsEff title ops defstr eff u =
         , _scOptions = ops
         , _scMaybeOption = fmap (Toggle eff . const . MODString) defstr
         , _scOptionFlag = NormalOptions
-        , _scSelectionList = makeOptionsSelectionList (Just 0) u ops defstr
+        , _scSelectionList = makeOptionsSelectionList (Just 0) u ops
         }
 
-makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> Maybe String -> SelectionList
+--makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> Maybe String -> SelectionList
-makeOptionsSelectionList mselpos u mos defstr = SelectionList
+--makeOptionsSelectionList mselpos u mos defstr = SelectionList
+makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> SelectionList
+makeOptionsSelectionList mselpos u mos = SelectionList
     { _slPosX = 50
     , _slPosY = 50
     , _slOffset = 0
@@ -36,16 +38,16 @@ makeOptionsSelectionList mselpos u mos defstr = SelectionList
     , _slLength = length $ optionsToSelections u mos
     , _slSizeRestriction = SelectionSizeRestriction (availableMenuLines cfig) overflowit overflowit
         (SSRFromScreenBottom 5)
-    , _slSpecialItem = fromMaybe NoSpecialSelectionItem $ do
+--    , _slSpecialItem = fromMaybe NoSpecialSelectionItem $ do
-        str <- defstr
+--        str <- defstr
-        return $ BottomSelectionItem SelectionItem 
+--        return $ BottomSelectionItem SelectionItem 
-            { _siPictures = [color white $ text str]
+--            { _siPictures = [color white $ text str]
-            , _siHeight = 1
+--            , _siHeight = 1
-            , _siIsSelectable = True
+--            , _siIsSelectable = True
-            , _siWidth = length str
+--            , _siWidth = length str
-            , _siColor = white
+--            , _siColor = white
-            , _siOffX = 0
+--            , _siOffX = 0
-            }
+--            }
     }
   where
     cfig = u ^. uvConfig

src/Dodge/Render/HUD.hs

@@ -43,7 +43,6 @@ drawInGameHUD :: SubInventory -> Universe -> Picture
 drawInGameHUD subinv uv =
     pictures
         [ winScale cfig . dShadCol white $ displayHP 0 cfig w
-        , listPicturesAt (halfWidth cfig) 0 cfig $ map text (_uvTestString uv uv)
         , inventoryDisplay subinv cfig w
         ]
   where
@@ -64,7 +63,6 @@ defaultSelectionList = SelectionList
     , _slWidth = FixedSelectionWidth 15
     , _slLength = 0
     , _slSizeRestriction = NoSelectionSizeRestriction
-    , _slSpecialItem = NoSpecialSelectionItem
     }
 
 subInvSelectionList :: SelectionList
@@ -81,7 +79,6 @@ subInvSelectionList = SelectionList
     , _slWidth = FixedSelectionWidth 15
     , _slLength = 0
     , _slSizeRestriction = NoSelectionSizeRestriction
-    , _slSpecialItem = NoSpecialSelectionItem
     }
 
 inventorySelectionList :: World -> [SelectionItem]

src/Dodge/Render/List.hs

@@ -23,7 +23,7 @@ drawSelectionList cfig sl =
         (_slPosX sl)
         (_slPosY sl)
         cfig
-        (_slOffset sl)
+        0 --(_slOffset sl)
         (makeSelectionListPictures sl)
         <> drawSelectionCursor cfig sl
 

src/Dodge/Render/MenuScreen.hs

@@ -1,7 +1,6 @@
 {- The menu picture.  -}
 module Dodge.Render.MenuScreen (
-    menuScreen,
+    drawMenuScreen,
-    menuScreen',
 ) where
 
 --import LensHelp
@@ -15,8 +14,8 @@ import Dodge.Data.Universe
 import Padding
 import Picture
 
-menuScreen' :: Configuration -> ScreenLayer -> Picture
+drawMenuScreen :: Configuration -> ScreenLayer -> Picture
-menuScreen' cfig screen = case screen of
+drawMenuScreen cfig screen = case screen of
     OptionScreen{_scTitle = titf, _scSelectionList = selpos} ->
         drawOptions cfig titf selpos "Use keys to navigate the menu"
     --    (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
@@ -24,12 +23,12 @@ menuScreen' cfig screen = case screen of
     --    (DisplayScreen sd) -> sd w
     (ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs
 
-menuScreen :: Configuration -> ScreenLayer -> Picture
+--menuScreen :: Configuration -> ScreenLayer -> Picture
-menuScreen cfig screen = case screen of
+--menuScreen cfig screen = case screen of
-    OptionScreen{_scTitle = titf, _scSelectionList = selpos} ->
+--    OptionScreen{_scTitle = titf, _scSelectionList = selpos} ->
-        drawOptions cfig titf selpos "Use keys to navigate the menu"
+--        drawOptions cfig titf selpos "Use keys to navigate the menu"
-    (InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help
+--    (InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help
-    (ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs
+--    (ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs
 
 --displayStringList :: World -> [String] -> Picture
 --displayStringList w ss = pictures
@@ -72,8 +71,8 @@ drawInputMenu ::
     Picture
 drawInputMenu cfig title footer =
     pictures 
-        [ --darkenBackground cfig
+        [ darkenBackground cfig
-         drawTitle cfig title
+        , drawTitle cfig title
         , drawFooterText cfig red footer
         ]
 
@@ -88,14 +87,14 @@ drawOptions ::
     Picture
 drawOptions cfig title sl footer =
     pictures 
-        [ --darkenBackground cfig
+        [ darkenBackground cfig
-         drawTitle cfig title
+        , drawTitle cfig title
         , drawFooterText cfig red footer
         , drawSelectionList cfig sl
         ]
 
 darkenBackground :: Configuration -> Picture
-darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
+darkenBackground cfig = winScale cfig . color (withAlpha 0.5 black) . polygon . reverse . screenBox $ cfig
 
 drawTitle :: Configuration -> String -> Picture
 drawTitle cfig = winScale cfig . translate (30 - hw) (hh-50) . scale 0.4 0.4 . text

src/Dodge/Render/Picture.hs

@@ -13,14 +13,18 @@ import Geometry
 import Picture
 
 fixedCoordPictures :: Universe -> Picture
-fixedCoordPictures u =
+fixedCoordPictures u = drawMenuOrHUD cfig u 
-    drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld . input) <> case u ^. uvScreenLayers of
+    <> drawConcurrentMessage u 
-        [] -> drawHUD u
+    <> customMouseCursor cfig (u ^. uvWorld . input)
-        (lay : _) -> setDepth (-1) (menuScreen' cfig lay)
+    <> listPicturesAt (halfWidth cfig) 0 cfig (map text (_uvTestString u u))
---            <> (setDepth (-1) . winScale cfig $ menuScreen cfig lay)
   where
     cfig = _uvConfig u
 
+drawMenuOrHUD :: Configuration -> Universe -> Picture
+drawMenuOrHUD cfig u = case u ^. uvScreenLayers of
+    [] -> drawHUD u
+    (lay : _) -> drawMenuScreen cfig lay
+
 drawConcurrentMessage :: Universe -> Picture
 drawConcurrentMessage u =
     stackPicturesAt

src/Dodge/SelectionList.hs

@@ -1,16 +1,19 @@
 module Dodge.SelectionList where
 
+--import Color
 import Dodge.Data.SelectionList
 import LensHelp
 
 setShownSelectionItems :: SelectionList -> SelectionList
 setShownSelectionItems sl = case sl ^? slSizeRestriction of
-    Just (SelectionSizeRestriction maxlines topit botit _)
+    Just (SelectionSizeRestriction maxlines _ botit _)
         | length allitems <= maxlines -> sl & slShownItems .~ allitems
-        | otherwise -> if offset > 0
+--        | offset > length allitems + 3 - maxlines -> sl
-            then sl & slShownItems .~ ((topit,ScrollUpSelectionItem) : take (maxlines - 2) (drop offset allitems))
+        | otherwise ->
-            else sl & slShownItems .~ (take (maxlines - 2) allitems ++ [(botit,ScrollDownSelectionItem)])
+            sl & slShownItems .~ take (maxlines - 2) (drop offset allitems) -- ++ repeat dummyitem))
+                ++ [(botit,ScrollDownSelectionItem)]
     _ -> sl & slShownItems .~ allitems
   where
+--    dummyitem = (SelectionItem [] 1 False 0 white 0, DummySelectionItem)
     offset = sl ^. slOffset
     allitems = zipWith (\x y -> (x,ListedSelectionItem y)) (sl ^. slItems) [0..]

src/Dodge/TestString.hs

@@ -8,5 +8,8 @@ import qualified Data.Map.Strict as M
 
 testStringInit :: Universe -> [String]
 testStringInit u =
-    [  shortShow $ u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
+    [ show $ u ^? uvScreenLayers . _head . scSelectionList . slOffset
-    ] ++ map show (M.toList (u ^. uvWorld . input . pressedKeys))
+    ]
+    ++ [  shortShow $ u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
+    ] 
+     ++ map show (M.toList (u ^. uvWorld . input . pressedKeys))

src/Dodge/Update.hs

@@ -92,15 +92,21 @@ gotoTerminal w = case _uvScreenLayers w of
     (InputScreen{} : _) -> w
     _ -> w & uvScreenLayers .:~ InputScreen T.empty "Enter command"
 
-mouseClickOptionsList :: [MenuOption] -> SelectionList -> Maybe MenuOption -> Universe -> Universe
+mouseClickOptionsList :: [MenuOption] -> SelectionList -> Universe -> Universe
-mouseClickOptionsList mos sl mop u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
+mouseClickOptionsList mos sl u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
     Just False -> fromMaybe u $ do
         i <- sl ^. slSelPos
         si <- sl ^? slShownItems . ix i . _2
         return $ maybe u ($ u) $ case si of
             ListedSelectionItem j -> mos ^? ix j . moEff
-            ScrollUpSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset %~ (min 0 . subtract 10)
+            ScrollUpSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset %~ (max 0 . subtract 5)
-            ScrollDownSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset +~ 10
+            ScrollDownSelectionItem -> do
+                maxlines <- sl ^? slSizeRestriction . maxSelectionLines
+                alllines <- sl ^? slLength
+                Just $ uvScreenLayers . _head . scSelectionList . slOffset %~ 
+                    (\x -> if x + maxlines - 2 >= alllines then 0 else x + maxlines - 2)
+            DummySelectionItem -> Just id
+            SpecialSelectionItem -> Just id
     _ -> u
 
 mouseOverSelectionList :: SelectionList -> Universe -> Universe
@@ -146,7 +152,7 @@ optionScreenUpdate :: [MenuOption] -> Maybe MenuOption -> OptionScreenFlag
     -> Universe -> Universe
 optionScreenUpdate mos mop _ sl u = 
      optionScreenDefEff mop
-    . mouseClickOptionsList mos sl mop
+    . mouseClickOptionsList mos sl
     . mouseOverSelectionList sl
     . menuWheelEvents
     . over (uvScreenLayers . _head . scSelectionList) (setSelectionListRestriction cfig)