217 lines
7.7 KiB
Haskell
217 lines
7.7 KiB
Haskell
module Dodge.Render.List where
|
|
|
|
--import Picture.Text
|
|
import Dodge.Inventory
|
|
import qualified Data.IntMap.Strict as IM
|
|
--import Data.Foldable
|
|
import Dodge.SelectionList
|
|
import Data.Maybe
|
|
import Dodge.Base.WinScale
|
|
import Dodge.Base.Window
|
|
import Dodge.Data.CardinalPoint
|
|
import Dodge.Data.Config
|
|
import Dodge.Data.SelectionList
|
|
import Geometry
|
|
import ListHelp
|
|
import Picture
|
|
import LensHelp
|
|
|
|
drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
|
|
drawSelectionList ldps cfig sl =
|
|
listPicturesAtScaleOff
|
|
(_ldpVerticalGap ldps)
|
|
(_ldpScale ldps)
|
|
(_ldpPosX ldps)
|
|
(_ldpPosY ldps)
|
|
cfig
|
|
0 --(_slOffset sl)
|
|
(makeSelectionListPictures sl)
|
|
<> drawSelectionCursor ldps cfig sl
|
|
|
|
makeSelectionListPictures :: SelectionList a -> [Picture]
|
|
makeSelectionListPictures sl = concatMap f $ getShownItems sl
|
|
where
|
|
f si = map (color (_siColor si) . text) $ _siPictures si
|
|
--f si = map (textGrad (_siColor si) (withAlpha 0 (_siColor si))) $ _siPictures si
|
|
|
|
drawCursorAt :: ListDisplayParams -> Configuration -> Maybe Int -> [SelectionItem a] -> Picture
|
|
drawCursorAt ldps cfig mi lis = fromMaybe mempty $ do
|
|
i <- mi
|
|
selit <- lis !? i
|
|
f <- case _ldpCursorType ldps of
|
|
BorderCursor cps -> Just $ listCursorChooseBorderScale (_ldpVerticalGap ldps) (_ldpScale ldps) cps
|
|
NoCursor -> Nothing
|
|
let j = sum . map _siHeight $ take i lis
|
|
col = _siColor selit
|
|
return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j 0 col wdth (_siHeight selit)
|
|
where
|
|
wdth = case _ldpWidth ldps of
|
|
FixedSelectionWidth x -> x
|
|
_ -> 1
|
|
|
|
drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
|
|
drawSelectionCursor ldps cfig sl = drawCursorAt ldps cfig (f $ sl ^. slSelPos) (getShownItems sl)
|
|
where
|
|
-- the following is quite hacky
|
|
f = case sl ^. slRegex of
|
|
_ | sl ^. slRegexInput -> const (Just 0)
|
|
"" | not (sl ^. slRegexInput) -> id
|
|
_ -> fmap (+1)
|
|
|
|
-- given a list of pictures that are each the size of a "text" call, displays them as
|
|
-- a list on the screen
|
|
listPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
|
|
listPicturesAt tx ty cfig = listPicturesAtScaleOff 10 1 tx ty cfig 0
|
|
|
|
listPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture
|
|
listPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i ..]
|
|
|
|
listPicturesAtScaleOff :: Float -> Float -> Float -> Float -> Configuration -> Int -> [Picture] -> Picture
|
|
listPicturesAtScaleOff ygap s tx ty cfig i = mconcat . zipWith (listTextPictureAtScale ygap s tx ty cfig) [i ..]
|
|
|
|
stackPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
|
|
stackPicturesAt tx ty cfig = stackPicturesAtOff tx ty cfig 0
|
|
|
|
stackPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture
|
|
stackPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i, i -1 ..]
|
|
|
|
selSecDrawCursor :: Int -> [CardinalPoint] -> Configuration -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Picture
|
|
selSecDrawCursor xsize borders cfig ldp sss i j = fromMaybe mempty $ do
|
|
yint <- selSecSelPos i j sss
|
|
xint <- sss ^? sssSections . ix i . ssIndent
|
|
si <- sss ^? sssSections . ix i . ssItems . ix j
|
|
return $ listCursorDisplayParams ldp borders cfig yint xint (_siColor si) xsize (length $ _siPictures si)
|
|
|
|
listCursorDisplayParams ::
|
|
ListDisplayParams ->
|
|
[CardinalPoint] ->
|
|
Configuration ->
|
|
Int ->
|
|
Int ->
|
|
Color ->
|
|
Int ->
|
|
Int ->
|
|
Picture
|
|
listCursorDisplayParams ldp borders =
|
|
listCursorChooseBorderScale ygap s borders xoff yoff
|
|
where
|
|
ygap = _ldpVerticalGap ldp
|
|
s = _ldpScale ldp
|
|
xoff = _ldpPosX ldp
|
|
yoff = _ldpPosY ldp
|
|
|
|
-- displays a cursor that should match up to list text pictures
|
|
-- the width of a character appears to be 9(?!)
|
|
-- this is probably because it is 8 pixels plus one for the border
|
|
listCursorChooseBorderScale ::
|
|
Float ->
|
|
Float ->
|
|
[CardinalPoint] ->
|
|
Float ->
|
|
Float ->
|
|
Configuration ->
|
|
Int ->
|
|
Int ->
|
|
Color ->
|
|
Int ->
|
|
Int ->
|
|
Picture
|
|
listCursorChooseBorderScale ygap s borders xoff yoff cfig yint xint col cursxsize cursysize =
|
|
winScale cfig
|
|
. translate
|
|
(15 + (9 * s * (fromIntegral xint - 1)) + xoff - halfWidth cfig)
|
|
(halfHeight cfig + s * 12.5 - (yoff + (s * 10 + ygap) * (fromIntegral yint + 1)))
|
|
. color col
|
|
$ chooseCursorBorders (s * wth) (s * hgt) borders
|
|
where
|
|
x = 9
|
|
wth = x * fromIntegral cursxsize + 9
|
|
hgt = 20 * fromIntegral cursysize -- TODO this should be changed!
|
|
|
|
-- displays a cursor that should match up to list text pictures
|
|
-- the width of a character appears to be 9(?!)
|
|
-- this is probably because it is 8 pixels plus one for the border
|
|
listCursorChooseBorder ::
|
|
[CardinalPoint] -> Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture
|
|
listCursorChooseBorder = listCursorChooseBorderScale 10 1
|
|
|
|
-- note we cannot simply scale lines because they are drawn as solid rectangles
|
|
chooseCursorBorders :: Float -> Float -> [CardinalPoint] -> Picture
|
|
chooseCursorBorders wth hgt = foldMap (line . toLine)
|
|
where
|
|
top = 0
|
|
bot = - hgt
|
|
lef = 0
|
|
toLine North = [V2 lef top, V2 wth top]
|
|
toLine East = [V2 wth top, V2 wth bot]
|
|
toLine South = [V2 wth bot, V2 lef bot]
|
|
toLine West = [V2 lef bot, V2 lef top]
|
|
|
|
listCursorNS :: Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture
|
|
listCursorNS = listCursorChooseBorder [North, South]
|
|
|
|
listCursorNES :: Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture
|
|
listCursorNES = listCursorChooseBorder [North, South, East]
|
|
|
|
listCursorNESW :: Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture
|
|
listCursorNESW = listCursorChooseBorder [North, South, East, West]
|
|
|
|
listCursorNSW :: Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture
|
|
listCursorNSW = listCursorChooseBorder [North, South, West]
|
|
|
|
fillScreenText :: Configuration -> String -> Picture
|
|
fillScreenText cfig str =
|
|
winScale cfig
|
|
. scale wscale hscale
|
|
. centerText
|
|
$ str
|
|
where
|
|
wscale = hw * 0.02 / fromIntegral (length str)
|
|
hscale = hh * 0.01
|
|
hw = halfWidth cfig
|
|
hh = halfHeight cfig
|
|
|
|
fillWidthText :: Configuration -> String -> Picture
|
|
fillWidthText cfig str =
|
|
winScale cfig
|
|
. scale thescale thescale
|
|
. centerText
|
|
$ str
|
|
where
|
|
thescale = hw * 0.02 / fromIntegral (length str)
|
|
hw = halfWidth cfig
|
|
|
|
listTextPictureAt :: Float -> Float -> Configuration -> Int -> Picture -> Picture
|
|
listTextPictureAt xoff yoff cfig yint =
|
|
winScale cfig
|
|
. translate (xoff + 15 - hw) (negate yoff + hh - (20 * (fromIntegral yint + 1)))
|
|
. scale 0.1 0.1
|
|
where
|
|
hw = halfWidth cfig
|
|
hh = halfHeight cfig
|
|
|
|
listTextPictureAtScale :: Float -> Float -> Float -> Float -> Configuration -> Int -> Picture -> Picture
|
|
listTextPictureAtScale ygap s xoff yoff cfig yint =
|
|
winScale cfig
|
|
. translate (xoff + 15 - hw) (negate yoff + hh - ((s * 10 + ygap) * (fromIntegral yint + 1)))
|
|
. scale (s * 0.1) (s * 0.1)
|
|
where
|
|
hw = halfWidth cfig
|
|
hh = halfHeight cfig
|
|
|
|
renderListAt :: Float -> Float -> Configuration -> [(String, Color)] -> Picture
|
|
renderListAt tx ty cfig = listPicturesAt tx ty cfig . map (\(str, col) -> color col $ text str)
|
|
|
|
-- concatMapPic (winScale cfig) . zipWith (listPairAt tx ty cfig) [0..]
|
|
|
|
--TODO put the following functions in an appropriate place
|
|
|
|
-- | Colour picture and add black drop shadow.
|
|
dShadCol :: Color -> Picture -> Picture
|
|
{-# INLINE dShadCol #-}
|
|
dShadCol c p =
|
|
pictures
|
|
[ color black $ translate 1.2 (-1.2) p
|
|
, color c p
|
|
]
|