justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Put config/targeting pictures in sensible places, tweak main loop

Browse Source
This commit is contained in:
justin
2022-06-28 01:19:47 +01:00
parent 03b37c4e7b
commit f6d96ec92c
14 changed files with 148 additions and 154 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Picture.hs
+9 -74
View File
@@ -12,49 +12,25 @@ module Dodge.Creature.Picture
, basicCrCorpse
) where
import Dodge.Data
--import Dodge.Base
--import Dodge.Render.InfoBox
--import Dodge.Render.List
--import Dodge.Creature.AlertLevel.Data
--import Dodge.Picture.Layer
import Dodge.Clock
import Dodge.Creature.HandPos (translateToRightHand,translateToLeftHand)
import Dodge.Creature.Test
import Dodge.Damage
--import Dodge.Debug.Picture
import Picture
import Geometry
import Shape
import ShapePicture
import qualified Quaternion as Q
--import Geometry.Vector3D
import Control.Lens
import qualified Data.IntMap.Strict as IM
import qualified Data.Vector as V
basicCrPict :: Creature
-> Configuration
-> World
-> SPic
basicCrPict cr cfig w =
drawCrEquipment cr
<>
(basicCrShape cr
, pictures $
targetingPic ++
[ creatureDisplayText cfig w cr
--, tr . rotdir $ _spPicture $ drawEquipment cr
]
)
where
targetingPic = IM.elems $ IM.mapMaybe f $ _crInv cr
f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw)
basicCrPict :: Creature -> SPic
basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr , mempty)
drawCrEquipment :: Creature -> SPic
drawCrEquipment cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
shapeAtCrPos :: Shape -> Creature -> Configuration -> World -> SPic
shapeAtCrPos sh cr _ _ =
shapeAtCrPos :: Shape -> Creature -> SPic
shapeAtCrPos sh cr =
( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh
, mempty
)
@@ -77,47 +53,6 @@ basicCrShape cr
rotdir = rotateSH (_crDir cr)
rotmdir = rotateSH (_crMvDir cr)
creatureDisplayText :: Configuration -> World -> Creature -> Picture
creatureDisplayText cfig w cr
| not (debugOn Cr_awareness cfig) = []
| otherwise
= setLayer DebugLayer
. setDepth 20
. translate x y
. color white
. rotate (0.5 * pi)
-- . rotate (argV v - 0.5 * pi)
. scale theScale theScale
. stackText
$ clockCycle 25 (V.fromList
[ \cr' -> [crDisplayVigilance cr']
, \cr' -> [crDisplayAwareness cr']
]
) w cr
where
campos = _cameraViewFrom w
theScale = 0.15 / _cameraZoom w
cpos = _crPos cr
v = cpos -.- campos
(V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v
crDisplayAwareness :: Creature -> String
crDisplayAwareness cr
| isSuspicious = "?"
| isCognizant = "!"
| otherwise = "."
where
imAwarenesses = _cpAwareness (_crPerception cr)
isSuspicious = any f imAwarenesses && not (null imAwarenesses)
isCognizant = any g imAwarenesses && not (null imAwarenesses)
f (Suspicious _) = True
f _ = False
g (Cognizant _) = True
g _ = False
crDisplayVigilance :: Creature -> String
crDisplayVigilance = show . _cpVigilance . _crPerception
--damageMod :: Creature -> Picture -> Picture
--damageMod cr pic = piercingMod $ bluntScale pic
-- where
@@ -285,13 +220,13 @@ drawEquipment cr = foldMap f (_crInv cr)
circLine :: Float -> Picture
circLine x = line [V2 0 0,V2 x 0]
picAtCrPos :: Picture -> Creature -> Configuration -> World -> SPic
picAtCrPos :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
picAtCrPos thePic cr _ _ = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
picAtCrPos thePic cr = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
picAtCrPosNoRot :: Picture -> Creature -> Configuration -> World -> SPic
picAtCrPosNoRot :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
picAtCrPosNoRot thePic cr _ _ = (,) emptySH $ uncurryV translate (_crPos cr) thePic
picAtCrPosNoRot thePic cr = (,) emptySH $ uncurryV translate (_crPos cr) thePic
basicCrCorpse :: Creature -> Corpse -> SPic
basicCrCorpse cr cp = noPic . tr . scaleSH (V3 crsize crsize crsize) $ mconcat
src/Dodge/Creature/Picture/Awareness.hs
+45
View File
@@ -0,0 +1,45 @@
module Dodge.Creature.Picture.Awareness where
import Dodge.Data
import Dodge.Clock
import Picture
import Geometry
import qualified Data.Vector as V
creatureDisplayText :: World -> Creature -> Picture
creatureDisplayText w cr = setLayer DebugLayer
. setDepth 20
. translate x y
. color white
. rotate (0.5 * pi)
-- . rotate (argV v - 0.5 * pi)
. scale theScale theScale
. stackText
$ clockCycle 25 (V.fromList
[ \cr' -> [crDisplayVigilance cr']
, \cr' -> [crDisplayAwareness cr']
]
) w cr
where
campos = _cameraViewFrom w
theScale = 0.15 / _cameraZoom w
cpos = _crPos cr
v = cpos -.- campos
(V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v
crDisplayAwareness :: Creature -> String
crDisplayAwareness cr
| isSuspicious = "?"
| isCognizant = "!"
| otherwise = "."
where
imAwarenesses = _cpAwareness (_crPerception cr)
isSuspicious = any f imAwarenesses && not (null imAwarenesses)
isCognizant = any g imAwarenesses && not (null imAwarenesses)
f (Suspicious _) = True
f _ = False
g (Cognizant _) = True
g _ = False
crDisplayVigilance :: Creature -> String
crDisplayVigilance = show . _cpVigilance . _crPerception
src/Dodge/Data.hs
+2 -1
View File
@@ -346,7 +346,8 @@ data Creature = Creature
, _crMvDir :: Float
, _crTwist :: Float
, _crID :: Int
, _crPict :: Creature -> Configuration -> World -> SPic
--, _crPict :: Creature -> Configuration -> World -> SPic
, _crPict :: Creature -> SPic
, _crSkin :: CreatureSkin
, _crUpdate :: Creature -> World -> World
, _crRad :: Float
src/Dodge/Placement/Instance/Turret.hs
+1 -1
View File
@@ -75,7 +75,7 @@ updateTurret rotSpeed mc w
& crOldPos .~ mcpos
& crRad .~ 1
& crDir .~ mcdir
& crPict .~ (\cr _ _ -> drawCrEquipment cr)
& crPict .~ drawCrEquipment
& crUpdate .~ stateUpdate followThenClearImpulses
& crStance . posture .~ Aiming
& crApplyDamage .~ applyNoDamage
src/Dodge/Render.hs
+2 -7
View File
@@ -47,17 +47,15 @@ doDrawing pdata u = do
-- bind as much data into vbos as feasible at this point
-- count mutable vectors setup
layerCounts <- UMV.replicate (numLayers*6) 0
-- shapeCounts <- UMV.replicate 3 0
wlwiflCounts <- UMV.replicate 3 0
-- attempt to poke in parallel
let (ws,wp) = wallSPics <> worldSPic cfig w
(nShapeVs, nIndices, nSilIndices) <- MP.bindM3 (\ _ _ counts -> return counts)
( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) )
<- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts))
( pokeBindFoldableLayer shadV layerCounts wp)
( pokeWallsWindowsFloor
(shadVBOptr $ _wallTextureShader pdata)
(shadVBOptr $ _windowShader pdata)
(shadVBOptr $ _textureArrayShader pdata)
wlwiflCounts
wallPointsCol
windowPoints
(_floorTiles w)
@@ -68,9 +66,6 @@ doDrawing pdata u = do
(_eboPtr $ _silhouetteEBO pdata)
ws
)
nWalls <- UMV.read wlwiflCounts 0
nWins <- UMV.read wlwiflCounts 1
nFls <- UMV.read wlwiflCounts 2
-- bind wall points, silhouette data, surface geometry
uncurry bindShaderBuffers $ unzip
[ ( _wallTextureShader pdata, nWalls)
src/Dodge/Render/ShapePicture.hs
+24 -11
View File
@@ -1,6 +1,7 @@
module Dodge.Render.ShapePicture
( worldSPic
) where
import Dodge.Creature.Picture.Awareness
import Dodge.ShortShow
import Dodge.Config.Data
import Dodge.Render.InfoBox
@@ -25,6 +26,7 @@ import Sound.Data
import Geometry.ConvexPoly
--import Dodge.Base.Collide
--import Data.Foldable
import qualified Data.IntMap.Strict as IM -- Lazy?
import qualified Data.Map.Strict as M
import Control.Lens
@@ -33,22 +35,26 @@ import qualified Streaming.Prelude as S
-- TODO only filter out shapes outside the range of the furthest shown light source
worldSPic :: Configuration -> World -> SPic
worldSPic cfig w =
(mempty, extraPics cfig w)
--(mempty, extraPics cfig w)
worldSPic cfig w = (mempty, extraPics cfig w)
<> foldMap (dbArg _prDraw) (filtOn _prPos _props)
<> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
<> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
-- <> foldMap (\fs -> uncurryV translateSPf (_fsPos fs) . rotateSP (_fsDir fs) $ _fsSPic fs) (_shapes w)
<> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
<> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
<> foldMap (dbArg _crPict) (filtOn _crPos _creatures)
<> foldMap floorItemSPic (filtOn _flItPos _floorItems)
<> foldMap btSPic (filtOn _btPos _buttons)
<> foldMap mcSPic (filtOn _mcPos _machines)
<> anyTargeting cfig w
where
filtOn f g = IM.filter (pointIsClose . f) (g w)
pointIsClose = cullPoint cfig w
anyTargeting :: Configuration -> World -> SPic
anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr)
where
cr = you w
f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw)
shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x)
. rotateSP (fdir x)
@@ -80,14 +86,18 @@ extraPics cfig w = pictures (_decorations w)
<> cfigdraw Show_bound_box (const drawBoundingBox)
<> cfigdraw Show_wall_search_rays (const drawWallSearchRays)
<> cfigdraw Show_dda_test (const drawDDATest)
<> cfigdraw Show_far_wall_detect (const drawFarWallDetect)
<> cfigdraw Show_select (const drawWorldSelect)
<> cfigdraw Inspect_wall (const drawInspectWalls)
<> cfigdraw Show_far_wall_detect (const drawFarWallDetect)
<> cfigdraw Show_select (const drawWorldSelect)
<> cfigdraw Inspect_wall (const drawInspectWalls)
<> cfigdraw Cr_awareness (const drawCreatureDisplayTexts)
where
cfigdraw boption draw
| debugOn boption cfig = draw cfig w
| otherwise = mempty
drawCreatureDisplayTexts :: World -> Picture
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
drawInspectWalls :: World -> Picture
drawInspectWalls w = foldMap (drawInspectWall w)
$ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
@@ -113,9 +123,12 @@ drawWorldSelect w = setLayer DebugLayer . color cyan
(a,b) = _wSelect w
drawFarWallDetect :: World -> Picture
drawFarWallDetect w = setLayer DebugLayer . color yellow
. concatMap (\q -> line [p,q])
. map (\q -> fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w)
drawFarWallDetect w = setLayer DebugLayer
. color yellow
. concatMap (\q -> line
[ p
, fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w
] )
$ runIdentity $ S.toList_ $ streamViewpoints p w
where
p = _cameraViewFrom w
src/Dodge/Room/Foreground.hs
+4 -4
View File
@@ -5,7 +5,7 @@ import Picture
import Geometry
import Shape
import Quaternion
import Bound
--import Bound
--import Dodge.Data.ForegroundShape
import Dodge.Default.Foreground
@@ -13,8 +13,8 @@ import Data.List
import Data.Maybe
import Control.Lens
import ShapePicture
import Streaming
import qualified Streaming.Prelude as S
--import Streaming
--import qualified Streaming.Prelude as S
highDiagonalMesh
:: Point2
@@ -123,7 +123,7 @@ putShape :: Shape -> PSType
putShape sh = PutForeground $ defaultForeground
& fsPos .~ m
& fsRad .~ radBounds bnds
& fsSPic .~ noPic (uncurryV translateSHf (-m) $ sh)
& fsSPic .~ noPic (uncurryV translateSHf (-m) sh)
where
bnds = (0,0,0,0) -- shapeBounds sh
m = midBounds bnds
src/Geometry.hs
+1 -1
View File
@@ -65,7 +65,7 @@ errorClosestPointOnLine !i !x !y
| otherwise = closestPointOnLine x y
-- | Debug version of 'closestPointOnLineParam'
errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
errorClosestPointOnLineParam _ !x! y! z
errorClosestPointOnLineParam _ !x !y !z
| x == y = dist x z
| otherwise = closestPointOnLineParam x y z
src/Loop.hs
+7 -19
View File
@@ -18,18 +18,20 @@ import qualified Graphics.Rendering.OpenGL as GL
-- | Create a game loop with an SDL window.
setupLoop
:: Int -- ^ Target seconds per frame
-> (Int,Int) -- ^ The window size.
-> Maybe (Int,Int) -- ^ The window position.
-> T.Text -- ^ Window title
-> WindowConfig
-- -> (Int,Int) -- ^ The window size.
-- -> Maybe (Int,Int) -- ^ The window position.
-> (world -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop.
-> IO world -- ^ Initial simulation state.
-> (world -> IO world) -- ^ update, called once per frame. Allows for side effects such as rendering.
-> (world -> Event -> IO (Maybe world))
-- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
-> IO ()
setupLoop spf (xSize,ySize) winpos paramCleanup ioStartWorld sideEffects eventFn = do
setupLoop spf title winconfig paramCleanup ioStartWorld sideEffects eventFn = do
initializeAll
bracket
(createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize winpos))
(createWindow title winconfig)
destroyWindow
$ \window -> bracket
(glCreateContext window)
@@ -68,6 +70,7 @@ doLoop
doLoop spf window worldSideEffects eventFn updatedWorld
Nothing -> return ()
-- | Handle quit events in a manner to exit the loop. Other events handled as
-- determined by the custom function, although resize events also change the viewport.
applyEventIO :: (world -> Event -> IO (Maybe world)) -> Maybe world -> Event -> IO (Maybe world)
@@ -81,18 +84,3 @@ applyEventIO fn mw e = case eventPayload e of
mupdate = case mw of
Nothing -> return Nothing
Just w -> fn w e
-- | Create an OpenGL SDL window configuration with a given x and y size.
winConfig :: Int -> Int -> Maybe (Int, Int) -> WindowConfig
winConfig x y winpos = defaultWindow
{ windowGraphicsContext = OpenGLContext $ defaultOpenGL
{ glProfile = Core Normal 4 3
, glColorPrecision = V4 8 8 8 8
}
, windowPosition = theWinPos
, windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
, windowResizable =True
}
where
theWinPos = case winpos of
Just (px,py) -> Absolute (P (V2 (fromIntegral px) (fromIntegral py)))
Nothing -> Wherever
src/Shader/Poke.hs
+21 -25
View File
@@ -19,7 +19,7 @@ import qualified Data.Vector.Unboxed as UV
import qualified Data.Vector.Unboxed.Mutable as UMV
import qualified Data.Vector.Mutable as MV
import qualified Data.Vector.Fusion.Stream.Monadic as VS
import Data.Vector.Fusion.Util
--import Data.Vector.Fusion.Util
import Control.Monad.Primitive
--import qualified Control.Monad.Parallel as MP
@@ -45,19 +45,18 @@ pokeWallsWindowsFloor
:: Ptr Float
-> Ptr Float
-> Ptr Float
-> UMV.MVector (PrimState IO) Int
-> [ ( (Point2,Point2) , Point4 ) ]
-> [ ( (Point2,Point2) , Point4 ) ]
-> [ ( Point3 , Point3 ) ]
-> IO ()
pokeWallsWindowsFloor wlptr wiptr flptr counts wls wis fls = do
VS.mapM_ (pokeW wlptr counts 0) (VS.fromList wls)
VS.mapM_ (pokeW wiptr counts 1) (VS.fromList wis)
VS.mapM_ (pokeF flptr counts) (VS.fromList fls)
-> IO (Int,Int,Int)
pokeWallsWindowsFloor wlptr wiptr flptr wls wis fls = do
wlcounts1 <- VS.foldM (pokeW wlptr) 0 (VS.fromList wls)
wlcounts2 <- VS.foldM (pokeW wiptr) 0 (VS.fromList wis)
flcounts <- VS.foldM (pokeF flptr) 0 (VS.fromList fls)
return (wlcounts1,wlcounts2,flcounts)
pokeF :: Ptr Float -> UMV.MVector (PrimState IO) Int -> (Point3,Point3) -> IO ()
pokeF ptr counts (V3 a b c,V3 d e f) = do
i' <- UMV.unsafeRead counts 2
pokeF :: Ptr Float -> Int -> (Point3,Point3) -> IO Int
pokeF ptr i' (V3 a b c,V3 d e f) = do
let i = i' * 6
pokeElemOff ptr (i + 0) a
pokeElemOff ptr (i + 1) b
@@ -65,11 +64,10 @@ pokeF ptr counts (V3 a b c,V3 d e f) = do
pokeElemOff ptr (i + 3) d
pokeElemOff ptr (i + 4) e
pokeElemOff ptr (i + 5) f
UMV.unsafeModify counts (+1) 2
return $ i' + 1
pokeW :: Ptr Float -> UMV.MVector (PrimState IO) Int -> Int -> ((Point2,Point2),Point4) -> IO ()
pokeW ptr counts iv ((V2 a b,V2 c d),V4 e f g h) = do
i' <- UMV.unsafeRead counts iv
pokeW :: Ptr Float -> Int -> ((Point2,Point2),Point4) -> IO Int
pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do
let i = i' * 8
pokeElemOff ptr (i + 0) a
pokeElemOff ptr (i + 1) b
@@ -79,12 +77,9 @@ pokeW ptr counts iv ((V2 a b,V2 c d),V4 e f g h) = do
pokeElemOff ptr (i + 5) f
pokeElemOff ptr (i + 6) g
pokeElemOff ptr (i + 7) h
UMV.unsafeModify counts (+1) iv
return $ i' + 1
pokeShape
:: Ptr Float
-> Ptr GLushort
-> Ptr GLushort
pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort
-> [ShapeObj]
-> IO (Int,Int,Int)
pokeShape ptr iptr ieptr = VS.foldM (pokeShapeObj ptr iptr ieptr) (0,0,0) . VS.fromList
@@ -96,7 +91,7 @@ pokeShapeObj
-> (Int,Int,Int)
-> ShapeObj
-> IO (Int,Int,Int)
{-# INLINE pokeShapeObj #-}
--{-# INLINE pokeShapeObj #-}
pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of
TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts shVerts
@@ -105,7 +100,7 @@ pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort
-> (Int,Int,Int)
-> VS.Stream IO ShapeV
-> IO (Int,Int,Int)
{-# INLINE pokeTopPrism #-}
--{-# INLINE pokeTopPrism #-}
pokeTopPrism size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
nv' <- VS.foldM (pokeJustV ptr) nv svs
nshapeindices' <- UV.foldM (pokeTopPrismIndex nv iptr) nshapeindices
@@ -118,7 +113,7 @@ pokeTopPrismEdgeIndex :: Int -> Ptr GLushort
-> Int
-> Int
-> IO Int
{-# INLINE pokeTopPrismEdgeIndex #-}
--{-# INLINE pokeTopPrismEdgeIndex #-}
pokeTopPrismEdgeIndex nv eiptr nedgeindices ioff = do
pokeElemOff eiptr nedgeindices (fromIntegral $ nv + ioff)
return $ nedgeindices + 1
@@ -127,7 +122,7 @@ pokeTopPrismIndex :: Int -> Ptr GLushort
-> Int
-> Int
-> IO Int
{-# INLINE pokeTopPrismIndex #-}
--{-# INLINE pokeTopPrismIndex #-}
pokeTopPrismIndex nv iptr nshapeindices ioff = do
pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff)
return $ nshapeindices + 1
@@ -168,9 +163,9 @@ pokeJustV :: Ptr Float
-> Int
-> ShapeV
-> IO Int
{-# INLINE pokeJustV #-}
--{-# INLINE pokeJustV #-}
pokeJustV ptr nv sh = do
let off i = nv*7 + i
-- pokeArray (advancePtr ptr (off 0)) [a,b,c,d,e,f,g]
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c
@@ -180,6 +175,7 @@ pokeJustV ptr nv sh = do
pokeElemOff ptr (off 6) g
return (nv + 1)
where
off i = nv*7 + i
V3 a b c = _svPos sh
V4 d e f g = _svCol sh
src/Shape/Data.hs
+1 -1
View File
@@ -8,7 +8,7 @@ module Shape.Data
import Geometry.Data
import qualified Data.Vector.Fusion.Stream.Monadic as VS
import Data.Vector.Fusion.Util
--import Data.Vector.Fusion.Util
import Control.Lens
type Shape = [ShapeObj]