From 9bdb9a227fc4f66dea3af8e78f2d3eb9e8736da0 Mon Sep 17 00:00:00 2001 From: jgk Date: Tue, 17 Aug 2021 19:08:18 +0200 Subject: [PATCH] Various refactoring --- src/Dodge/Base.hs | 33 ++-- src/Dodge/Creature.hs | 2 +- src/Dodge/Creature/Inanimate.hs | 7 +- src/Dodge/Debug.hs | 8 +- src/Dodge/Inventory.hs | 49 +++--- src/Dodge/Item/Weapon/InventoryDisplay.hs | 3 +- src/Dodge/Item/Weapon/Launcher.hs | 1 + src/Dodge/LevelGen/DoorPane.hs | 66 ++++++++ src/Dodge/Render/Connectors.hs | 32 ++++ src/Dodge/Render/HUD.hs | 197 ++++++++++------------ src/Dodge/Render/Picture.hs | 29 ++-- src/Geometry.hs | 12 +- src/Padding.hs | 33 ++++ src/Picture.hs | 20 ++- src/Picture/Data.hs | 1 + src/Polyhedra.hs | 3 +- src/Render.hs | 4 +- src/Shader/Poke.hs | 4 +- 18 files changed, 313 insertions(+), 191 deletions(-) create mode 100644 src/Dodge/LevelGen/DoorPane.hs create mode 100644 src/Dodge/Render/Connectors.hs create mode 100644 src/Padding.hs diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 7c14de6b9..2eff4a81b 100644 --- a/src/Dodge/Base.hs +++ b/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 diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 9f604b1ec..116178fff 100644 --- a/src/Dodge/Creature.hs +++ b/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] diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index 7cb1c9f9e..a3978b356 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/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 diff --git a/src/Dodge/Debug.hs b/src/Dodge/Debug.hs index 10394ecd0..3764b819e 100644 --- a/src/Dodge/Debug.hs +++ b/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 diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index d63cd8147..036cbc491 100644 --- a/src/Dodge/Inventory.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon/InventoryDisplay.hs b/src/Dodge/Item/Weapon/InventoryDisplay.hs index ca4141937..acdfeb934 100644 --- a/src/Dodge/Item/Weapon/InventoryDisplay.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index ccd1fcef9..814d3aa27 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/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 diff --git a/src/Dodge/LevelGen/DoorPane.hs b/src/Dodge/LevelGen/DoorPane.hs new file mode 100644 index 000000000..4f28db45a --- /dev/null +++ b/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 diff --git a/src/Dodge/Render/Connectors.hs b/src/Dodge/Render/Connectors.hs new file mode 100644 index 000000000..02896e1b1 --- /dev/null +++ b/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 + ] diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index f90dc1a6a..a630191cf 100644 --- a/src/Dodge/Render/HUD.hs +++ b/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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index b6a87dad4..24aee294d 100644 --- a/src/Dodge/Render/Picture.hs +++ b/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 diff --git a/src/Geometry.hs b/src/Geometry.hs index 87714effa..fe89928f7 100644 --- a/src/Geometry.hs +++ b/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] diff --git a/src/Padding.hs b/src/Padding.hs new file mode 100644 index 000000000..84018ea2f --- /dev/null +++ b/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 diff --git a/src/Picture.hs b/src/Picture.hs index af353c31b..84b034af1 100644 --- a/src/Picture.hs +++ b/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) diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 4612e23b4..9c78ecd82 100644 --- a/src/Picture/Data.hs +++ b/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 diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs index a3c0e2b82..4f60a82f4 100644 --- a/src/Polyhedra.hs +++ b/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 diff --git a/src/Render.hs b/src/Render.hs index ff20521f8..7a6a1cbc6 100644 --- a/src/Render.hs +++ b/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 diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 103839e81..642aecdfe 100644 --- a/src/Shader/Poke.hs +++ b/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