Cleanup creature picture
This commit is contained in:
@@ -5,56 +5,41 @@ module Dodge.Render.MenuScreen
|
||||
( menuScreen
|
||||
)
|
||||
where
|
||||
import Dodge.Data.Menu
|
||||
import Dodge.Data
|
||||
--import Dodge.Config.Update
|
||||
--import Dodge.Config.Data
|
||||
import Dodge.Base.Window
|
||||
import Picture
|
||||
import Geometry
|
||||
import Dodge.Menu
|
||||
--import Geometry.Data
|
||||
|
||||
menuScreen
|
||||
:: World
|
||||
-> [MenuLayer]
|
||||
-> ScreenLayer
|
||||
-> Picture
|
||||
menuScreen w mLays = case mLays of
|
||||
(LevelMenu x:_) -> optionsFromList w ("LEVEL"++show x) levelMenuOptions
|
||||
(PauseMenu : _) -> optionsFromList w "PAUSED" pauseMenuOptions
|
||||
(GameOverMenu : _) -> optionsFromList w "GAME OVER" pauseMenuOptions
|
||||
(OptionMenu : _) -> optionsFromList w "OPTIONS" optionsOptions
|
||||
(SoundOptionMenu : _) -> optionsFromList w "OPTIONS:VOLUME" soundMenuOptions
|
||||
(GraphicsOptionMenu : _) -> optionsFromList w "OPTIONS:GRAPHICS" graphicsMenuOptions
|
||||
(ControlList : _) -> pictures
|
||||
[color (withAlpha 0.5 black) $ polygon $ screenBox hw hh
|
||||
,tst (-100) 100 0.4 "CONTROLS"
|
||||
,controlsList
|
||||
]
|
||||
(WaitMessage s _ : _) -> optionsList hw hh s []
|
||||
(Terminal s : _) -> optionsList hw hh "SCANCODE INPUT" ['>':s ++ "_"]
|
||||
(TerminalMessage t xs : _) -> displayStringList hw hh $ map snd $ filter (( > t) . fst) xs
|
||||
_ -> blank
|
||||
where
|
||||
tst x y sc t = translate x y $ scale sc sc $ color white $ text t
|
||||
hh = halfHeight w
|
||||
hw = halfWidth w
|
||||
menuScreen w screen = case screen of
|
||||
OptionScreen {_scTitle = titf, _scOptions = mos}
|
||||
-> drawOptions w (titf w) mos
|
||||
(WaitScreen sf _) -> drawOptions w (sf w) []
|
||||
(InputScreen s) -> drawOptions w ('>':s) []
|
||||
(TerminalScreen t xs ) -> displayStringList w $ map snd $ filter (( > t) . fst) xs
|
||||
(DisplayScreen sd ) -> sd w
|
||||
|
||||
displayStringList :: Float -> Float -> [String] -> Picture
|
||||
displayStringList hw hh ss = pictures
|
||||
( polygon (rectNSEW hh (-hh) hw (-hw))
|
||||
displayStringList :: World -> [String] -> Picture
|
||||
displayStringList w ss = pictures
|
||||
( polygon (screenBox w)
|
||||
: zipWith f ys ss
|
||||
)
|
||||
where
|
||||
hw = halfWidth w
|
||||
ys = [0,22..]
|
||||
f y s = translate (10-hw) y . scale 0.15 0.15 $ text s
|
||||
|
||||
optionsFromList
|
||||
drawOptions
|
||||
:: World
|
||||
-> String -- ^ Title
|
||||
-> String -- ^ Title
|
||||
-> [MenuOption] -- ^ Options
|
||||
-> Picture
|
||||
optionsFromList w title ops = pictures $
|
||||
drawOptions w title ops = pictures $
|
||||
[darkenBackground
|
||||
,theTitle]
|
||||
++
|
||||
@@ -64,59 +49,17 @@ optionsFromList w title ops = pictures $
|
||||
notInvisible InvisibleToggle {} = False
|
||||
notInvisible _ = True
|
||||
placeString x y sc t = translate x y $ scale sc sc $ color white $ text t
|
||||
darkenBackground = color (withAlpha 0.5 black) $ polygon $ screenBox hw hh
|
||||
darkenBackground = color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
theTitle = placeString (-hw + 30) (hh - 50) 0.4 title
|
||||
hh = halfHeight w
|
||||
hw = halfWidth w
|
||||
|
||||
menuOptionToString :: World -> MenuOption -> String
|
||||
menuOptionToString w mo@(Toggle{})
|
||||
= (scodeToChar $ _moKey mo) : ':' : _moString mo w
|
||||
menuOptionToString w mo@(Toggle2{})
|
||||
= (scodeToChar $ _moKey1 mo) : '/' : (scodeToChar $ _moKey2 mo) : ':' : _moString mo w
|
||||
menuOptionToString _ _ = "undefined option string"
|
||||
|
||||
|
||||
optionsList
|
||||
:: Float -- ^ Half screen width
|
||||
-> Float -- ^ Half screen height
|
||||
-> String -- ^ Title
|
||||
-> [String] -- ^ Options
|
||||
-> Picture
|
||||
optionsList hw hh tit ops = pictures $
|
||||
[color (withAlpha 0.5 black) $ polygon $ screenBox hw hh
|
||||
,placeString (-hw + 30) (hh - 50) 0.4 tit]
|
||||
++
|
||||
zipWith (\ s vpos -> placeString (-hw + 50) vpos 0.2 s) ops [hh-100,hh-150 ..]
|
||||
menuOptionToString w mo = theKeys ++ _moString mo w
|
||||
where
|
||||
placeString x y sc t = translate x y $ scale sc sc $ color white $ text t
|
||||
|
||||
controlsList :: Picture
|
||||
controlsList = pictures $ concat $ zipWith butAndEff
|
||||
[("wasd", "movement")
|
||||
,("[rmb]", "aim")
|
||||
,("[rmb+lmb]", "shoot or use item")
|
||||
,("[wheelscroll]" , "select item" )
|
||||
,("[space]" , "pickup item" )
|
||||
,("m" , "display map" )
|
||||
,("f" , "drop item" )
|
||||
,("c[esc]" , "pause" )
|
||||
,("qe" , "rotate camera")
|
||||
]
|
||||
[60,30..]
|
||||
where
|
||||
butAndEff (btext,etext) y =
|
||||
[translate (-250) y $ scale 0.15 0.15 $ color white $ text btext
|
||||
,translate 0 y $ scale 0.15 0.15 $ color white $ text etext
|
||||
]
|
||||
|
||||
screenBox
|
||||
:: Float -- ^ Half screen width
|
||||
-> Float -- ^ Half screen height
|
||||
-> [Point2]
|
||||
screenBox halfW halfH = map toV2
|
||||
[ (halfW, halfH)
|
||||
, (-halfW, halfH)
|
||||
, (-halfW,-halfH)
|
||||
, ( halfW,-halfH)
|
||||
]
|
||||
|
||||
theKeys :: String
|
||||
theKeys = case mo of
|
||||
Toggle {_moKey = k} -> stc k : ":"
|
||||
Toggle2 {_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":"
|
||||
_ -> undefined
|
||||
stc = scodeToChar
|
||||
|
||||
+11
-14
@@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
--{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Render.Picture
|
||||
where
|
||||
import Dodge.Data
|
||||
@@ -8,29 +8,21 @@ import Dodge.Base.Zone
|
||||
import Dodge.Picture
|
||||
import Dodge.Picture.Layer
|
||||
import Dodge.Render.HUD
|
||||
--import Dodge.Render.List
|
||||
import Dodge.Render.MenuScreen
|
||||
--import Dodge.GameRoom
|
||||
--import Dodge.Debug
|
||||
import Geometry
|
||||
--import Geometry.Zone
|
||||
--import Geometry.Data
|
||||
import Picture
|
||||
import Polyhedra.Data
|
||||
|
||||
--import Dodge.Creature.YourControl
|
||||
|
||||
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 = pictures
|
||||
[pictures (_decorations w)
|
||||
,concatMapPic (dbArg _pjDraw) $ _projectiles w
|
||||
,concatMapPic (crDraw w) $ _creatures w
|
||||
,concatMapPic (crDraw w) . IM.filter crIsClose $ _creatures w
|
||||
,concatMapPic (dbArg _ptDraw) $ _particles w
|
||||
,testPic w
|
||||
,concatMapPic drawItem $ _floorItems w
|
||||
@@ -40,6 +32,10 @@ worldPictures w = pictures
|
||||
,concatMapPic btDraw $ _buttons w
|
||||
,concatMapPic drawWallFloor $ wallFloorsToDraw w
|
||||
]
|
||||
where
|
||||
crIsClose cr = dist (_crPos cr) camCen < winSize
|
||||
winSize = 30 + max (getWindowX w) (getWindowY w)
|
||||
camCen = _cameraCenter w
|
||||
|
||||
foregroundPics :: World -> [Polyhedra]
|
||||
foregroundPics = _foregroundDecorations
|
||||
@@ -50,7 +46,7 @@ fixedCoordPictures w = case _menuLayers w of
|
||||
[ hudDrawings w
|
||||
, customMouseCursor w
|
||||
]
|
||||
lays -> scaler . onLayer MenuDepth $ menuScreen w lays
|
||||
(lay:_) -> scaler . onLayer MenuDepth $ menuScreen w lay
|
||||
where
|
||||
scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w)
|
||||
|
||||
@@ -121,9 +117,10 @@ outsideScreenPolygon w = [tr,tl,bl,br]
|
||||
bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w))
|
||||
|
||||
wallShadowsToDraw :: World -> [Wall]
|
||||
wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
|
||||
. IM.elems
|
||||
$ wallsNearZones (zoneOfSight w) w
|
||||
wallShadowsToDraw w
|
||||
= filter (fromMaybe True . (^? blVisible))
|
||||
. IM.elems
|
||||
$ wallsNearZones (zoneOfSight w) w
|
||||
|
||||
-- cannot only test if walls are on screen, but also if they are on the cone
|
||||
-- towards the center of sight
|
||||
|
||||
Reference in New Issue
Block a user