Various refactoring

src/Dodge/Base.hs

@@ -22,21 +22,6 @@ import Data.Maybe
 --import qualified Data.IntSet as IS
 --import qualified Data.Set as S
 
-leftPad :: Int -> a -> [a] -> [a]
-leftPad i x xs = reverse $ take i $ reverse (take i xs) ++ repeat x
-
-rightPad :: Int -> a -> [a] -> [a]
-rightPad i x xs = take i $ xs ++ repeat x
-
-midPad :: Int -> a -> [a] -> [a] -> [a]
-midPad i x xs ys = xs ++ replicate j x ++ ys
-  where 
-    j = i - (length xs + length ys)
-
-midPadL :: Int -> a -> [a] -> [a] -> [a]
-midPadL i x xs ys = take j (xs ++ repeat x) ++ ys
-  where 
-    j = i - length ys
 
 {- | Implementation copied from 
  - https://hackage.haskell.org/package/utility-ht-0.0.16/docs/src/Data.List.HT.Private.html#takeUntil
@@ -428,10 +413,9 @@ nearestCrInFront p dir x w
 crInPolygon :: Creature -> [Point2] -> Bool
 crInPolygon cr = errorPointInPolygon 3 (_crPos cr)
 
---The following two functions should be unified
-{- | Transform coordinates from world position to normalised screen coordinates.  -}
-worldPosToScreen :: World -> Point2 -> Point2
-worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
+{- | Transform coordinates from world position to screen coordinates.  -}
+worldPosToScreenNorm :: World -> Point2 -> Point2
+worldPosToScreenNorm w = doWindowScale . doRotate . doZoom . doTranslate
   where
     doTranslate p       = p -.- _cameraCenter w
     doZoom p            = _cameraZoom w *.* p
@@ -439,7 +423,16 @@ worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
     doWindowScale (V2 x y) = V2
         ( x * 2 / getWindowX w)
         ( y * 2 / getWindowY w)
-{- | Transform coordinates from the map position to normalised screen
+{- | Transform world coordinates to scaled screen coordinates. 
+ - These have to be according to the size of the window to get actual screen positions.
+ - This allows for line thicknesses etc to correspond to pixel sizes.-}
+worldPosToScreen :: World -> Point2 -> Point2
+worldPosToScreen w = doRotate . doZoom . doTranslate
+  where
+    doTranslate p       = p -.- _cameraCenter w
+    doZoom p            = _cameraZoom w *.* p
+    doRotate p          = rotateV (negate $ _cameraRot w) p
+{- | Transform coordinates from the map position to screen
 coordinates.  -}
 cartePosToScreen :: World -> Point2 -> Point2
 cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate

src/Dodge/Creature.hs

@@ -149,7 +149,7 @@ startCr = defaultCreature
     , _crUpdate = stateUpdate yourControl
     , _crRad = 10
     , _crMass = 10
-    , _crHP = 1000000000
+    , _crHP = 1000
     , _crMaxHP = 1500
     , _crInv = startInventory 
     , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]

src/Dodge/Creature/Inanimate.hs

@@ -24,6 +24,7 @@ import Polyhedra
 
 import Control.Lens
 import qualified Control.Foldl as L
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
 
 defaultInanimate :: Creature
 defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
@@ -39,8 +40,10 @@ lamp h = defaultInanimate
 -- it is not clear that any of the attempts with Foldl help at all here
 lampPic :: Float -> Picture
 --{-# INLINE lampPic #-}
-lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3)
-     ++ (concatMap (preTriFold f) $ boxXYZnobase 5 5 (h-1))
+lampPic h = pictures 
+    [ setLayer 1 (setDepth h . color white $ circleSolid 3)
+    , concatMap (polyToTris . map f) $ boxXYZnobase 5 5 (h-1)
+    ]
   where
     f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] 0 polyNum
 

src/Dodge/Debug.hs

@@ -55,17 +55,17 @@ pjTimerF 0    i = projectiles %~ IM.delete i
 pjTimerF time i = projectiles . ix i . pjUpdate .~ (\_ -> pjTimerF (time - 1) i)
 
 drawDDA :: IM.IntMap IS.IntSet -> Picture
-drawDDA = setLayer 1 . color (withAlpha 0.5 green) . IM.foldlWithKey' f []
+drawDDA = setLayer 1 . color (withAlpha 0.5 green) . IM.foldlWithKey' f blank
   where
-    f pic x' ys' = concatMap (\y -> polygon (rectNSEW (y+50) y (x+50) x)) ys ++ pic
+    f pic x' ys' = (concatMapPic (\y -> polygon (rectNSEW (y+50) y (x+50) x)) ys) `appendPic` pic
       where
         x = 50 * fromIntegral x'
         ys = map ((50 *) . fromIntegral) $ IS.toList ys'
 
 debugWallZoningPic :: World -> Picture
-debugWallZoningPic w = setLayer 1 $ zonesPic ++ wallsPic
+debugWallZoningPic w = setLayer 1 $ zonesPic `appendPic` wallsPic
   where
-    wallsPic = setDepth 25 . color yellow . concatMap (drawTheWall . _wlLine) $ IM.elems theWalls
+    wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls
     drawTheWall (a,b) = lineOfThickness 20 [a,b]
     theWalls = wallsAlongLine sp ep w
     zonesPic = setDepth 20 $ drawDDA zones

src/Dodge/Inventory.hs

@@ -1,10 +1,17 @@
 module Dodge.Inventory
+    ( checkInvSlotsYou
+    , rmSelectedInvItem
+    , addItem
+    , updateCloseObjects
+    , closeObjScrollDir
+    )
     where
 import Dodge.Data
 import Dodge.Base
 import Dodge.Base.Collide
 import Geometry
 import FoldableHelp
+import Padding
 
 --import Data.Maybe
 import Data.List
@@ -12,28 +19,31 @@ import qualified Data.IntMap.Strict as IM
 --import System.Random
 import Control.Lens
 
+-- | Finds first available slot where a new item may be placed in your inventory
 checkInvSlotsYou :: Item -> World -> Maybe Int
-checkInvSlotsYou it w = fst <$> find cond invListSelFirst
+checkInvSlotsYou it w = checkInvSlotsH it invListSelFirst
   where 
-    cond (_,NoItem) = True
-    cond (_,it'   ) = itNotFull it' && _itName it == _itName it'
     youCr = you w
     youSel = _crInvSel youCr
     invList = _crInv youCr
     invListSelFirst = (youSel , invList IM.! youSel) : IM.toList invList
 
-checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int
-checkInvSlots it its = fmap fst $ find cond $ IM.toList its
+checkInvSlotsH :: Item -> [(Int,Item)] -> Maybe Int
+checkInvSlotsH it = fmap fst . find cond
   where 
     cond (_,NoItem) = True
     cond (_,it'   ) = itNotFull it' && _itName it == _itName it'
 
+---- | Finds first available slot where a new item may be placed in the inventory
+--checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int
+--checkInvSlots it = checkInvSlotsH it . IM.toList
+
 addItem :: Item -> Item -> Item
 addItem it NoItem = it
 addItem _ it'     = it' & itAmount +~ 1
 
-numInventorySlots :: Int 
-numInventorySlots = 9
+--numInventorySlots :: Int 
+--numInventorySlots = 9
 
 itNotFull :: Item -> Bool
 itNotFull it = _itMaxStack it > _itAmount it
@@ -52,19 +62,6 @@ rmSelectedInvItem
     -> World 
     -> World
 rmSelectedInvItem cid w = rmInvItem cid (_crInvSel (_creatures w IM.! cid)) w
--- for now, left are floor items, right are buttons
-closestActiveObject :: World -> Maybe (Either FloorItem Button)
-closestActiveObject w = safeMinimumOn (dist ypos . pos) actObjs
-  where 
-    ypos = _crPos $ you w
-    actObjs = filter (\obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w) 
-                  $ map Left (IM.elems $ _floorItems w) ++ activeButtons -- map Right (IM.elems $ _buttons w)
-    pos (Right x) = _btPos x
-    pos (Left x)  = _flItPos x
-    activeButtons = map Right
-                      . filter ( (/=) BtNoLabel . _btState) 
-                      . IM.elems 
-                      $ _buttons w
 
 updateCloseObjects :: World -> World
 updateCloseObjects w = w & closeActiveObjects .~ unionBy eTest oldCloseFiltered currentClose
@@ -87,15 +84,7 @@ updateCloseObjects w = w & closeActiveObjects .~ unionBy eTest oldCloseFiltered
 
 closeObjScrollDir :: Float -> World -> World
 closeObjScrollDir x 
-    | x > 0 = closeObjScrollUp
-    | x < 0 = closeObjScrollDown
+    | x > 0 = over closeActiveObjects rotU
+    | x < 0 = over closeActiveObjects rotD
     | otherwise = id
 
-closeObjScrollUp :: World -> World
-closeObjScrollUp = over closeActiveObjects rotU
-    where rotU [] = []
-          rotU (x:xs) = xs ++ [x]
-closeObjScrollDown :: World -> World
-closeObjScrollDown = over closeActiveObjects rotD
-    where rotD [] = []
-          rotD xs = last xs : init xs

src/Dodge/Item/Weapon/InventoryDisplay.hs

@@ -4,8 +4,9 @@ Display of weapon strings in the inventory.
 module Dodge.Item.Weapon.InventoryDisplay
     where
 import Dodge.Data
-import Dodge.Base
+--import Dodge.Base
 import Dodge.Item.Attachment.Data
+import Padding
 
 import Data.Sequence
 import Control.Lens

src/Dodge/Item/Weapon/Launcher.hs

@@ -19,6 +19,7 @@ import Dodge.RandomHelp
 import Geometry
 import Picture
 import qualified IntMapHelp as IM
+import Padding
 
 import Data.Maybe
 import Control.Lens

src/Dodge/LevelGen/DoorPane.hs

@@ -0,0 +1,66 @@
+module Dodge.LevelGen.DoorPane
+    ( linearPane
+    , mkDoubleDoor
+    ) where
+import Dodge.Data
+import Dodge.LevelGen.MoveDoor
+import Picture
+import qualified DoubleStack as DS
+import Geometry.Vector
+
+-- | A door pane that moves linearly between open and closed positions using a
+-- boolean trigger.
+linearPane 
+    :: Color 
+    -> Bool             -- ^ Pathable flag
+    -> (World -> Bool)  -- ^ Opening condition
+    -> Int              -- ^ Wall id
+    -> (Point2,Point2)  -- ^ Closed position
+    -> (Point2,Point2)  -- ^ Open position
+    -> Wall
+linearPane c isPathable cond n closedPos openPos = Door
+    { _wlLine = closedPos
+    , _wlID = n
+    , _doorMech = dm
+    , _wlColor = c
+    , _wlSeen = False
+    , _wlIsSeeThrough = False
+    , _doorPathable = isPathable
+    , _drPositions = DS.singleton closedPos
+    }
+  where 
+    dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond 
+    openDoor = moveDoorToward openPos
+    closeDoor = moveDoorToward closedPos
+
+mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
+mkDoubleDoor c isPathable cond pl pr is 
+    = addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond)
+    is
+    (leftDoor ++ rightDoor)
+    (map shiftLeft leftDoor ++ map shiftRight rightDoor)
+  where 
+    leftDoor = 
+        [ (pld +.+ perp,hwd)
+        , (hwd,         hwu)
+        , (hwu,         plu +.+ perp)
+        , (plu +.+ perp,pld +.+ perp)
+        ]
+    rightDoor =
+        [ (pru -.- perp,hwu)
+        , (hwu,         hwd)
+        , (hwd,         prd -.- perp)
+        , (prd -.- perp,pru -.- perp)
+        ]
+    shiftRight = h (+.+ (0.5 *.* (pr -.- pl)))
+    shiftLeft  = h (+.+ (0.5 *.* (pl -.- pr)))
+    h func (x,y) = (func x,func y)
+    norm = 9 *.* normalizeV ( vNormal (pr -.- pl))
+    hw = 0.5 *.* (pl +.+ pr)
+    perp = 5 *.* normalizeV (pl -.- pr)
+    plu = pl +.+ norm
+    pld = pl -.- norm
+    pru = pr +.+ norm
+    prd = pr -.- norm
+    hwu = hw +.+ norm
+    hwd = hw -.- norm

src/Dodge/Render/Connectors.hs

@@ -0,0 +1,32 @@
+module Dodge.Render.Connectors
+    ( zConnect
+    , bConnect
+    , lConnect
+    ) where
+import Picture
+import Geometry
+
+zConnect :: Point2 -> Point2 -> Picture
+zConnect (V2 x y) (V2 a b) = line $ map toV2
+    [(x,y)
+    ,(0.5 * (x+a), y)
+    ,(0.5 * (x+a), b)
+    ,(a, b)
+    ]
+
+bConnect :: Point2 -> Point2 -> Picture
+bConnect (V2 x y) (V2 z w) = pictures 
+    [ bline 0.2 0.050 0.010
+    , bline 0.5 0.045 0.005
+    , bline 0.5 0.035 0.002
+    ] --cheapo antialiasing
+  where
+    bline alph lwidth rwidth
+        = bezierQuad (withAlpha 0.0 white) (withAlpha alph white) lwidth rwidth (V2 x y) (V2 0 y) (V2 z w)
+
+lConnect :: Point2 -> Point2 -> Picture
+lConnect sp@(V2 _ y) ep@(V2 x _) = line 
+    [ sp
+    , V2 x y
+    , ep
+    ]

src/Dodge/Render/HUD.hs

@@ -1,12 +1,16 @@
 {-# LANGUAGE TupleSections #-}
 module Dodge.Render.HUD
+    ( hudDrawings
+    )
     where
 import Dodge.Data
 import Dodge.Base
 import Dodge.Base.Window
 import Dodge.Inventory
+import Dodge.Render.Connectors
 import Picture
 import Geometry
+import Padding
 
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
@@ -14,33 +18,39 @@ import qualified Data.Set as S
 import Control.Lens
 import SDL (MouseButton (..))
 
-winScale :: World -> Picture -> Picture
-winScale w = scale (2 / getWindowX w) (2 / getWindowY w)
-
 hudDrawings :: World -> Picture
-hudDrawings w =
-    (winScale w . dShadCol white $ displayHP 0 w)
-    ++ (winScale w . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w))
-    ++ selectionText
+hudDrawings w = pictures
+    [ winScale w . dShadCol white $ displayHP 0 w
+    , winScale w . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w)
+    , selectionText
+    ]
   where
     selectionText = 
         if _carteDisplay w
-        then concat $ drawLocations w
+        then drawLocations w
         else drawInventory w
 
+winScale :: World -> Picture -> Picture
+{-# INLINE winScale #-}
+winScale w = scale (2 / getWindowX w) (2 / getWindowY w)
+
 drawInventory :: World -> Picture
-drawInventory w = case _inventoryMode w of
-    TopInventory -> closeObjectTexts w
-        ++ topInvCursor col iPos w
-        ++ concat (displayInv 0 w)
-    TweakInventory -> 
-        concat (mCurs it w)
-        ++ cursorAt 120 col 5 0 iPos w
-        ++ cursorsZ w iPos it
-        ++ concat (displayInv 0 w )
-        ++ concat (displayMidList w (ammoTweakStrings it) "TWEAK")
-    CombineInventory -> concat (displayInv 0 w) ++ invHead w "COMBINE"
-    InspectInventory -> concat (displayInv 0 w) ++ invHead w "INSPECT"
+drawInventory w = displayInv 0 w `appendPic` subInventoryDisplay w 
+
+subInventoryDisplay :: World -> Picture
+subInventoryDisplay w = case _inventoryMode w of
+    TopInventory -> pictures
+        [ closeObjectTexts w
+        , topInvCursor col iPos w
+        ]
+    TweakInventory -> pictures
+        [ mCurs it w
+        , cursorAt 120 col 5 0 iPos w
+        , cursorsZ w iPos it
+        , displayMidList w (ammoTweakStrings it) "TWEAK"
+        ]
+    CombineInventory -> invHead w "COMBINE"
+    InspectInventory -> invHead w "INSPECT"
   where 
     itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
     iPos = _crInvSel $ _creatures w IM.! _yourID w
@@ -49,9 +59,10 @@ drawInventory w = case _inventoryMode w of
 
 cursorsZ :: World -> Int -> Item -> Picture
 cursorsZ w ipos it = case it ^? wpAmmo . amParamSel of
-    Nothing -> winScale w $ zDraw sp (V2 (155- hw) ( hh - 77.5))
-    Just jpos -> winScale w $ zDraw sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
+    Nothing   -> f $ zConnect sp (V2 (155- hw) ( hh - 77.5))
+    Just jpos -> f $ zConnect sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
   where
+    f = winScale w . color white
     hh = halfHeight w
     hw = halfWidth w
     sp = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
@@ -60,59 +71,45 @@ topInvCursor :: Color -> Int -> World -> Picture
 topInvCursor col iPos w 
     | ButtonRight `S.member` _mouseButtons w = 
         cursorAt 100 col 5 0 iPos w
-        ++ openCursorAt 20 col 105 0 iPos w
-    | otherwise = openCursorAt 120 col 5 0 iPos w
+        `appendPic` openCursorAt 20 col 105 0 iPos w
+    | otherwise = mainListCursor col iPos w
 
 ammoTweakStrings :: Item -> [String]
 ammoTweakStrings it = case it ^? wpAmmo . amPjParams of
     Just l -> map pjTweakString l
     _ -> ["NOT TWEAKABLE"]
 
-mCurs :: Item -> World -> [Picture]
+mCurs :: Item -> World -> Picture
 mCurs it w = case it ^? wpAmmo . amParamSel of
     Nothing -> []
     Just i 
         | ButtonRight `S.member` _mouseButtons w -> 
+            pictures 
             [cursorAt x white y 60 i w
             ,openCursorAt 20 white (x+y) 60 i w
             ]
-        | otherwise -> [openCursorAt 140 white 155 60 i w]
+        | otherwise -> openCursorAt 140 white 155 60 i w
   where
     x = 117.5
     y = 155
 
-zDraw :: Point2 -> Point2 -> Picture
-zDraw (V2 x y) (V2 a b) = line $ map toV2
-    [(x,y)
-    ,(0.5 * (x+a), y)
-    ,(0.5 * (x+a), b)
-    ,(a, b)
-    ]
-
 pjTweakString :: PjParam -> String
 pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj
 
-displayMidList :: World -> [String] -> String -> [Picture]
+displayMidList :: World -> [String] -> String -> Picture
 displayMidList w strs s =
-    [invHead w s]
-    ++ renderListAt (V2 150 (-60)) (map (,white) strs) w
+    invHead w s
+    `appendPic` renderListAt 150 (-60) (map (,white) strs) w
 
 invHead :: World -> String -> Picture
 invHead w s = winScale w . translate (-130) (halfHeight w - 40) . dShadCol white . scale 0.4 0.4 $ text s
-    
 
-displayListTopLeft :: [(String,Color)] -> World -> [Picture]
-displayListTopLeft = renderListAt (V2 0 0) 
+renderListAt :: Float -> Float -> [(String,Color)] -> World -> Picture
+renderListAt tx ty scols w =
+    concatMapPic (winScale w) $ zipWith (listItemAt tx ty w) [0..] scols
 
-renderListAt :: Point2 -> [(String,Color)] -> World -> [Picture]
-renderListAt (V2 tx ty) scols w =
-    map (winScale w) $ zipWith 
-        (translate (tx + 15-halfWidth w))
-        ( map (\x -> ty + halfHeight w - (20 * (fromIntegral x+1)))    ([0..]::[Int]) )
-        ( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols )
-
-displayInv :: Int -> World -> [Picture]
-displayInv n w = displayListTopLeft scols w
+displayInv :: Int -> World -> Picture
+displayInv n w = renderListAt 0 0 scols w
   where 
     scols = map itemStringCol . IM.elems . _crInv $ _creatures w IM.! n
 
@@ -120,30 +117,17 @@ itemStringCol :: Item -> (String,Color)
 itemStringCol NoItem    = ("----", greyN 0.5)
 itemStringCol itm       = (_itInvDisplay itm itm, _itInvColor itm)
 
-drawLocations :: World -> [Picture]
-drawLocations wrld = displayListTopLeft locs wrld
-    ++ zipWith bFunc (displayListEndCoords wrld locTexts) locPoss
+drawLocations :: World -> Picture
+drawLocations wrld = pictures $ 
+    renderListAt 0 0 locs wrld
+    : zipWith bConnect (displayListEndCoords wrld locTexts) locPoss
     ++ mapOverlay wrld
-    ++ [drawListCursor white iPos wrld]
+    ++ [mainListCursor white iPos wrld]
   where
     iPos = _selLocation wrld
     locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ wrld
     locPoss = map (cartePosToScreen wrld . ($ wrld) . fst) . IM.elems . _seenLocations $ wrld
     locTexts = map fst locs
-    bFunc (V2 x y) (V2 z w) = pictures 
-        [ bline 0.2 0.050 0.010
-        , bline 0.5 0.045 0.005
-        , bline 0.5 0.035 0.002
-        ] --cheapo antialiasing
-      where
-        bline alph lwidth rwidth
-            = bezierQuad (withAlpha 0.0 white) (withAlpha alph white) lwidth rwidth (V2 x y) (V2 0 y) (V2 z w)
-
-displayListCoords :: World -> [Point2]
-displayListCoords w = map (g . f) [(1::Int)..]
-  where 
-    f i = V2 ( 15 - halfWidth w ) ( halfHeight w - (20 * fromIntegral i))
-    g (V2 x y) = V2 (2*x / getWindowX w) ( 2*y / getWindowY w)
 
 displayListEndCoords :: World -> [String] -> [Point2]
 displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
@@ -154,7 +138,6 @@ displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
     h :: String -> Point2 -> Point2
     h s (V2 x y) = V2 (x + 9 * fromIntegral (length s)) y
 
---bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
 
 mapOverlay :: World -> [Picture]
 mapOverlay w = (color (withAlpha 0.5 black) . polygon $ rectNSEW 1 (-1) (-1) 1) : 
@@ -172,18 +155,13 @@ mapWall w wl =
     c = _wlColor wl
 {- | Pictures of popup text for items close to your position.-}
 closeObjectTexts :: World -> Picture
-closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText $ _closeActiveObjects w)
-    ++ maybeToList maybeLine
-  where 
-    colAndText (Left x)  = (_itInvColor $ _flIt x, _itName $ _flIt x)
-    colAndText (Right x) = (white, _btText x)
-    renderList i (c,t) = winScale w
-        . tran
-        . translate (xtran i) (negate (20 * fromIntegral i))
-        . scale 0.1 0.1 
-        . color c 
-        $ text t
-    tran = translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral invPos +1))
+closeObjectTexts w = pictures $ 
+    renderListAt pushout (negate 20 * fromIntegral invPos)
+        (map colAndText $ _closeActiveObjects w) w
+    : maybeToList maybeLine
+  where
+    colAndText (Left x)  = ( _itName $ _flIt x, _itInvColor $ _flIt x)
+    colAndText (Right x) = (_btText x,yellow)
     youSel = _crInvSel $ you w
     freeSlot = mayIt >>= \it -> checkInvSlotsYou (_flIt it) w
     invPos = fromMaybe youSel freeSlot
@@ -191,39 +169,40 @@ closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText
     mayIt = mayObj >>= maybeLeft
     maybeLeft (Left x) = Just x
     maybeLeft _  = Nothing
-    pushout = 140
-    xtran :: Int -> Float
-    xtran 0 = case mayIt of Nothing -> 25
-                            _       -> -25
-    xtran _ = 0
-    objPos obj = case obj of Left flit -> _flItPos flit
-                             Right bt  -> _btPos bt
-    mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
-    sc (V2 x  y) = V2 (x*2/getWindowX w) ( y*2/getWindowY w)
+    pushout = 120
+    objPos obj = case obj of 
+        Left flit -> _flItPos flit
+        Right bt  -> _btPos bt
+    mayScreenPos = fmap (worldPosToScreen w . objPos) mayObj
     maybeLine = do 
           itScreenPos <- mayScreenPos
-          theText <- fmap (snd . colAndText) mayObj
+          (theText,col) <- fmap colAndText mayObj
           let textWidth = 9 * fromIntegral (length theText)
-          let col = maybe white (_itInvColor . _flIt) mayIt
-          let p = V2 (textWidth + xtran 0 + pushout - halfWidth w)
-                    ( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
-          let p' = V2 ( pushout - halfWidth w + 130)
-                   ( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
-          return $ thickLineCol  
-                      [(itScreenPos, withAlpha 0 col)
-                      ,(sc p'      , col)
-                      ,(sc p       , col)
-                      ]
-                      (1 / halfWidth w)
+          let p = V2 (textWidth + 15 + pushout - halfWidth w)
+                     ( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
+          return . winScale w . color col $ lConnect p itScreenPos
 {- | Colour picture and add black drop shadow. -}
 dShadCol :: Color -> Picture -> Picture
 dShadCol c p = pictures
-    [ color black $ uncurry translate (1.2,-1.2) p
+    [ color black $ translate 1.2 (-1.2) p
     , color c p
     ]
 
-drawListCursor :: Color -> Int -> World -> Picture
-drawListCursor c = openCursorAt 120 c 5 0
+mainListCursor :: Color -> Int -> World -> Picture
+mainListCursor c = openCursorAt 120 c 5 0
+
+listItemAt
+    :: Float    -- ^ x offset
+    -> Float    -- ^ y offset
+    -> World 
+    -> Int      -- ^ y offset (discrete)
+    -> (String,Color)   -- ^ The text item
+    -> Picture
+listItemAt xoff yoff w yint (s,col) 
+    = translate (xoff + 15 - halfWidth w) (yoff + halfHeight w - (20 * (fromIntegral yint+1)))
+    . scale 0.1 0.1
+    . dShadCol col
+    $ text s
 
 openCursorAt 
     :: Float    -- ^ Width
@@ -261,6 +240,10 @@ cursorAt wth col xoff yoff yint w = winScale w
         ]
 
 displayHP :: Int -> World -> Picture
-displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $
-                    scale 0.2 0.2 $ text $ reverse $ take 5 $ (++ repeat ' ') $ reverse $ show
-                    $ _crHP $ _creatures w IM.! n
+displayHP n w = translate (halfWidth w-80) (halfHeight w-20) 
+    . scale 0.2 0.2 
+    . text
+    . leftPad 5 ' ' 
+    . show
+    . _crHP 
+    $ _creatures w IM.! n

src/Dodge/Render/Picture.hs

@@ -21,22 +21,23 @@ import Control.Lens
 import Data.Maybe
 import Data.List (partition)
 import qualified Data.IntMap.Lazy as IM
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
 
 worldPictures :: World -> Picture
-worldPictures w = concat $
-    IM.elems (_decorations w) ++
-    (map (dbArg _pjDraw)  . IM.elems $ _projectiles w) ++
-    (map (crDraw w) . IM.elems $ _creatures w) ++
-    map (dbArg _ptDraw) (_particles w) ++
-    [ testPic w
-    , concatMap drawItem . IM.elems $ _floorItems w
-    , concatMap (crDraw w) . IM.elems $ _creatures w
-    , concatMap clDraw   . reverse $ _clouds w
-    , concatMap ppDraw   . IM.elems $ _pressPlates w
-    , concatMap btDraw (IM.elems (_buttons w))
-    , concatMap (dbArg _ptDraw) $ _particles w
-    , concatMap drawWallFloor (wallFloorsToDraw w)
+worldPictures w = pictures
+    [pictures (_decorations w)
+    ,concatMapPic (dbArg _pjDraw)  $ _projectiles w
+    ,concatMapPic (crDraw w) $ _creatures w
+    ,concatMapPic (dbArg _ptDraw) $ _particles w
+    ,testPic w
+    ,concatMapPic drawItem $ _floorItems w
+    ,concatMapPic (crDraw w) $ _creatures w
+    ,concatMapPic clDraw $ _clouds w      
+    ,concatMapPic ppDraw $ _pressPlates w
+    ,concatMapPic btDraw $ _buttons w
+    ,concatMapPic drawWallFloor $ wallFloorsToDraw w
     ]
+    
 foregroundPics :: World -> [Polyhedra]
 foregroundPics = _foregroundDecorations
 
@@ -58,7 +59,7 @@ customMouseCursor w =
     $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]
 
 testPic :: World -> Picture
-testPic _ = []
+testPic _ = blank
     
 --    [ setDepth (-1) . translate 0 0.8
 --        . scale 0.001 0.001 . text . show $ _crMvDir $ you w

src/Geometry.hs

@@ -191,12 +191,18 @@ doublePair (x,y) = [(x,y),(y,x)]
 doubleV2 :: V2 a -> [V2 a]
 doubleV2 (V2 x y) = [V2 x y,V2 y x]
 -- split a list into triples, forms triangles from a polygon
-polyToTris :: [s] -> [s]
-{-# INLINE polyToTris #-}
-polyToTris (a:as) = go a as
+polyToTris'' :: [s] -> [s]
+polyToTris'' (a:as) = go a as
   where
     go !x (y:z:ys) = x : y : z : go x (z:ys)
     go _ _ = []
+polyToTris'' _ = []
+
+polyToTris :: [s] -> [s]
+{-# INLINABLE polyToTris #-}
+polyToTris (x:xs) = foldr (f x) [] $ zip xs $ tail xs
+  where
+    f a (b,c) ls = a:b:c:ls
 polyToTris _ = []
 
 polyToTris' :: [s] -> [s]

src/Padding.hs

@@ -0,0 +1,33 @@
+{-| Basic padding and "justification" of lists.
+ -}
+module Padding
+    where
+leftPad :: Int -> a -> [a] -> [a]
+{-# INLINE leftPad #-}
+leftPad i x xs = reverse $ take i $ reverse (take i xs) ++ repeat x
+
+rightPad :: Int -> a -> [a] -> [a]
+{-# INLINE rightPad #-}
+rightPad i x xs = take i $ xs ++ repeat x
+
+midPad :: Int -> a -> [a] -> [a] -> [a]
+{-# INLINE midPad #-}
+midPad i x xs ys = xs ++ replicate j x ++ ys
+  where 
+    j = i - (length xs + length ys)
+
+midPadL :: Int -> a -> [a] -> [a] -> [a]
+{-# INLINE midPadL #-}
+midPadL i x xs ys = take j (xs ++ repeat x) ++ ys
+  where 
+    j = i - length ys
+
+rotU :: [a] -> [a]
+{-# INLINE rotU #-}
+rotU [] = []
+rotU (x:xs) = xs ++ [x]
+
+rotD :: [a] -> [a]
+{-# INLINE rotD #-}
+rotD [] = []
+rotD xs = last xs : init xs

src/Picture.hs

@@ -23,6 +23,8 @@ module Picture
     , lineCol
     , text
     , pictures
+    , concatMapPic
+    , appendPic
     , tranRot
     , translate
     , rotate
@@ -65,6 +67,8 @@ import Picture.Data
 --import qualified Data.DList as DL
 --import Graphics.Rendering.OpenGL (lineWidth, ($=))
 --import Control.Lens
+--import Data.Foldable
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
 
 blank :: Picture
 {-# INLINE blank #-}
@@ -197,8 +201,16 @@ rotate :: Float -> Picture -> Picture
 {-# INLINE rotate #-}
 rotate = map . overPos . rotate3
 
-pictures :: [Picture] -> Picture
-{-# INLINE pictures #-}
+concatMapPic :: Foldable t => (a -> Picture) -> t a -> Picture
+{-# INLINE concatMapPic #-}
+concatMapPic = concatMap
+
+appendPic :: Picture -> Picture -> Picture
+{-# INLINE appendPic #-}
+appendPic = (++)
+
+pictures :: Foldable t => t Picture -> Picture
+{-# INLINABLE pictures #-}
 pictures = concat
 
 makeArc :: Float -> Point2 -> [Point2]
@@ -297,9 +309,9 @@ thickArc startA endA rad wdth
     r = rad + 0.5 * wdth
     w = 1 - wdth / r
 
-thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
+thickArcHelp :: Float -> Float -> Float -> Float -> Picture
 {-# INLINE thickArcHelp #-}
-thickArcHelp startA endA rad wdth = map f 
+thickArcHelp startA endA rad wdth = map f
     [  (V3 0 0 0,black,V3 0 0 wdth)
     ,(V3 xa ya 0,black,V3 1 0 wdth)
     ,(V3 xb yb 0,black,V3 1 1 wdth)

src/Picture/Data.hs

@@ -3,6 +3,7 @@ module Picture.Data
     where
 import Geometry.Data
 
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
 import Control.Lens
 data Verx = Verx
     { _vxPos    :: !Point3

src/Polyhedra.hs

@@ -11,6 +11,7 @@ import Data.Maybe
 import Data.List
 import Data.Bifunctor
 import Control.Lens
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
 
 translateXY :: Float -> Float -> Polyhedra -> Polyhedra
 translateXY x y = pyFaces %~ map (map $ first tran)
@@ -100,7 +101,7 @@ boxABC a b c =
 polyToPics :: Polyhedra -> [Picture]
 polyToPics = map helpPoly3D . _pyFaces
 
-helpPoly3D :: [(Point3, Point4)] -> [Verx]
+helpPoly3D :: [(Point3, Point4)] -> Picture
 --{-# INLINE helpPoly3D #-}
 helpPoly3D vs = map f $ polyToTris vs
   where

src/Render.hs

@@ -131,7 +131,7 @@ drawTextureOnFramebuffer fs fbo to = do
 
 renderFoldable
     :: MV.MVector (PrimState IO) FullShader
-    -> [Verx]
+    -> Picture
     -> IO ()
 renderFoldable shadV struct = do
     counts <- UMV.replicate 6 0
@@ -140,7 +140,7 @@ renderFoldable shadV struct = do
 
 renderFoldableTimed
     :: MV.MVector (PrimState IO) FullShader
-    -> [Verx]
+    -> Picture
     -> IO Word32
 renderFoldableTimed shadV struct = do
     pokeStartTicks <- SDL.ticks

src/Shader/Poke.hs

@@ -22,7 +22,7 @@ import Control.Monad.Primitive
 pokeVerxs 
     :: MV.MVector (PrimState IO) FullShader
     -> UMV.MVector (PrimState IO) Int 
-    -> [Verx] 
+    -> Picture 
     -> IO ()
 pokeVerxs vbos count vxs = VS.mapM_ (pokeVerx vbos count) $ VS.fromList vxs
 
@@ -40,7 +40,7 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the
 pokeLayVerxs 
     :: MV.MVector (PrimState IO) FullShader 
     -> UMV.MVector (PrimState IO) Int
-    -> [Verx] 
+    -> Picture 
     -> IO ()
 pokeLayVerxs vbos counts vxs = VS.mapM_ (pokeLayVerx vbos counts) $ VS.fromList vxs