diff --git a/data/texture/charMap.png b/data/texture/charMap.png index 7f0d0b119..7700bf053 100644 Binary files a/data/texture/charMap.png and b/data/texture/charMap.png differ diff --git a/src/Dodge/Base/Window.hs b/src/Dodge/Base/Window.hs index bb9172c1c..c90c3f098 100644 --- a/src/Dodge/Base/Window.hs +++ b/src/Dodge/Base/Window.hs @@ -54,3 +54,5 @@ screenBox w = rectNSWE hh (- hh) (- hw) hw where hw = halfWidth w hh = halfHeight w + + diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs index 54984fd81..06a8aba87 100644 --- a/src/Dodge/Data/SelectionList.hs +++ b/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 diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index d4b9e8613..82cbee83d 100644 --- a/src/Dodge/Data/Universe.hs +++ b/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, diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs index 6a7f9a2a7..c789dbd8b 100644 --- a/src/Dodge/Menu/Option.hs +++ b/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 mselpos u mos defstr = SelectionList +--makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> Maybe String -> 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 - str <- defstr - return $ BottomSelectionItem SelectionItem - { _siPictures = [color white $ text str] - , _siHeight = 1 - , _siIsSelectable = True - , _siWidth = length str - , _siColor = white - , _siOffX = 0 - } +-- , _slSpecialItem = fromMaybe NoSpecialSelectionItem $ do +-- str <- defstr +-- return $ BottomSelectionItem SelectionItem +-- { _siPictures = [color white $ text str] +-- , _siHeight = 1 +-- , _siIsSelectable = True +-- , _siWidth = length str +-- , _siColor = white +-- , _siOffX = 0 +-- } } where cfig = u ^. uvConfig diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index a132bc7ad..9ad108aee 100644 --- a/src/Dodge/Render/HUD.hs +++ b/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] diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 3243d01c6..01933267b 100644 --- a/src/Dodge/Render/List.hs +++ b/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 diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index f106bd7e9..021c7fd38 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -1,7 +1,6 @@ {- The menu picture. -} module Dodge.Render.MenuScreen ( - menuScreen, - menuScreen', + drawMenuScreen, ) where --import LensHelp @@ -15,8 +14,8 @@ import Dodge.Data.Universe import Padding import Picture -menuScreen' :: Configuration -> ScreenLayer -> Picture -menuScreen' cfig screen = case screen of +drawMenuScreen :: Configuration -> ScreenLayer -> Picture +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 cfig screen = case screen of - OptionScreen{_scTitle = titf, _scSelectionList = selpos} -> - drawOptions cfig titf selpos "Use keys to navigate the menu" - (InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help - (ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs +--menuScreen :: Configuration -> ScreenLayer -> Picture +--menuScreen cfig screen = case screen of +-- OptionScreen{_scTitle = titf, _scSelectionList = selpos} -> +-- drawOptions cfig titf selpos "Use keys to navigate the menu" +-- (InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help +-- (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 - drawTitle cfig title + [ darkenBackground cfig + , drawTitle cfig title , drawFooterText cfig red footer ] @@ -88,14 +87,14 @@ drawOptions :: Picture drawOptions cfig title sl footer = pictures - [ --darkenBackground cfig - drawTitle cfig title + [ darkenBackground cfig + , 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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index ccaf0d7f3..2a51f033d 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -13,14 +13,18 @@ import Geometry import Picture fixedCoordPictures :: Universe -> Picture -fixedCoordPictures u = - drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld . input) <> case u ^. uvScreenLayers of - [] -> drawHUD u - (lay : _) -> setDepth (-1) (menuScreen' cfig lay) --- <> (setDepth (-1) . winScale cfig $ menuScreen cfig lay) +fixedCoordPictures u = drawMenuOrHUD cfig u + <> drawConcurrentMessage u + <> customMouseCursor cfig (u ^. uvWorld . input) + <> listPicturesAt (halfWidth cfig) 0 cfig (map text (_uvTestString u u)) 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 diff --git a/src/Dodge/SelectionList.hs b/src/Dodge/SelectionList.hs index b5f85f39d..32ecc6779 100644 --- a/src/Dodge/SelectionList.hs +++ b/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 - then sl & slShownItems .~ ((topit,ScrollUpSelectionItem) : take (maxlines - 2) (drop offset allitems)) - else sl & slShownItems .~ (take (maxlines - 2) allitems ++ [(botit,ScrollDownSelectionItem)]) +-- | offset > length allitems + 3 - maxlines -> sl + | otherwise -> + 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..] diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index 6865c1ab7..3b740dc25 100644 --- a/src/Dodge/TestString.hs +++ b/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 - ] ++ map show (M.toList (u ^. uvWorld . input . pressedKeys)) + [ show $ u ^? uvScreenLayers . _head . scSelectionList . slOffset + ] + ++ [ shortShow $ u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crPos + ] + ++ map show (M.toList (u ^. uvWorld . input . pressedKeys)) diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 0e2237531..6d11062c9 100644 --- a/src/Dodge/Update.hs +++ b/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 mos sl mop u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of +mouseClickOptionsList :: [MenuOption] -> SelectionList -> Universe -> Universe +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) - ScrollDownSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset +~ 10 + ScrollUpSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset %~ (max 0 . subtract 5) + 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)