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

Add explicit layer datatype

Browse Source
This commit is contained in:
justin
2022-04-10 10:48:17 +01:00
parent edd82fb3ac
commit 77c3f83d20
27 changed files with 75 additions and 70 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Lamp.hs
+2 -2
View File
@@ -37,11 +37,11 @@ lamp h = defaultInanimate
}
lampCrPic :: Float -> Picture
lampCrPic h = pictures
[ setLayer 1 (setDepth h . color white $ circleSolid 3)
[ setLayer BloomLayer (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 [] (LayNum 0) polyNum
f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum
initialiseLamp :: Float -> Creature -> World -> World
initialiseLamp = initialiseColorLamp 0.75
src/Dodge/Creature/Picture.hs
+3 -3
View File
@@ -13,7 +13,7 @@ module Dodge.Creature.Picture
import Dodge.Data
--import Dodge.Base
import Dodge.Creature.Test
import Dodge.Render.InfoBox
--import Dodge.Render.InfoBox
import Dodge.Render.List
--import Dodge.Creature.AlertLevel.Data
--import Dodge.Picture.Layer
@@ -87,7 +87,7 @@ crDisplayInfo cfig w cr = (_crPos cr,
crOnScreen = pointOnScreen cfig w $ _crPos cr
creatureDisplayText :: Configuration -> World -> Creature -> Picture
creatureDisplayText cfig w cr = setLayer 4 . setDepth 50
creatureDisplayText cfig w cr = setLayer FixedCoordLayer . setDepth 50
$ color white $ renderListAt 0 0 cfig $ zip ["TEST","ME"] $ repeat white
-- $ renderInfoListAt 0 0 cfig w
-- $ crDisplayInfo cfig w cr
@@ -96,7 +96,7 @@ creatureDisplayText' :: Configuration -> World -> Creature -> Picture
creatureDisplayText' cfig w cr
| not (_debug_cr_status cfig) = []
| otherwise
= setLayer 4
= setLayer TopLayer
. setDepth 50
. translate x y
. color white
src/Dodge/Debug.hs
+2 -2
View File
@@ -45,7 +45,7 @@ pjTimerF 0 i = props %~ IM.delete i
pjTimerF time i = props . ix i . pjUpdate .~ (\_ -> pjTimerF (time - 1) i)
drawDDA :: IM.IntMap IS.IntSet -> Picture
drawDDA = setLayer 1 . color (withAlpha 0.5 green) . IM.foldlWithKey' f blank
drawDDA = setLayer BloomLayer . color (withAlpha 0.5 green) . IM.foldlWithKey' f blank
where
f pic x' ys' = concatMapPic (\y -> polygon (rectNSEW (y+50) y (x+50) x)) ys `appendPic` pic
where
@@ -53,7 +53,7 @@ drawDDA = setLayer 1 . color (withAlpha 0.5 green) . IM.foldlWithKey' f blank
ys = map ((50 *) . fromIntegral) $ IS.toList ys'
debugWallZoningPic :: World -> Picture
debugWallZoningPic w = setLayer 1 $ zonesPic `appendPic` wallsPic
debugWallZoningPic w = setLayer BloomLayer $ zonesPic `appendPic` wallsPic
where
wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls
drawTheWall (a,b) = thickLine 20 [a,b]
src/Dodge/Debug/LinkDecoration.hs
+2 -2
View File
@@ -25,11 +25,11 @@ roomLinkDecorations :: Room -> Picture
roomLinkDecorations rm = pictures . map (linkDecoration . lnkPosDir) $ _rmLinks rm
linkDecoration :: (Point2,Float) -> Picture
linkDecoration (p,a) = setLayer 1 . setDepth 50 . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)]
linkDecoration (p,a) = setLayer TopLayer . setDepth 50 . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)]
roomPolyDecorations :: Room -> Picture
roomPolyDecorations rm = pictures . map polyWireFrame $ _rmPolys rm
polyWireFrame :: [Point2] -> Picture
polyWireFrame (x:xs) = setLayer 1 . setDepth 50 . color green $ line $ (x:xs) ++ [x]
polyWireFrame (x:xs) = setLayer TopLayer . setDepth 50 . color green $ line $ (x:xs) ++ [x]
polyWireFrame _ = undefined
src/Dodge/Default.hs
+2 -3
View File
@@ -8,7 +8,6 @@ module Dodge.Default where
import Dodge.Default.Weapon
import Dodge.Data
import Dodge.SoundLogic
import Dodge.Picture.Layer
import Dodge.Wall.Delete
import Dodge.Creature.Damage
import Geometry
@@ -44,7 +43,7 @@ defaultCreature = Creature
, _crInvEquipped = mempty
, _crLeftInvSel = Nothing
, _crState = defaultState
, _crCorpse = setLayer 0 $ setDepth 5 $ color (greyN 0.5) $ circleSolid 10
, _crCorpse = setLayer BottomLayer $ setDepth 5 $ color (greyN 0.5) $ circleSolid 10
, _crApplyDamage = defaultApplyDamage
, _crStance = Stance
{_carriage=Walking 0 WasLeftForward
@@ -264,7 +263,7 @@ defaultLS = LS
, _lsPict = defLSPic
}
defLSPic :: LightSource -> Picture
defLSPic ls = setLayer 1 . translate3 (_lsPos $ _lsParam ls) . color col $ circleSolid 4
defLSPic ls = setLayer BloomNoZWrite . translate3 (_lsPos $ _lsParam ls) . color col $ circleSolid 4
where
col = V4 r g b 2
V3 r g b = _lsCol $ _lsParam ls
src/Dodge/Item/Equipment.hs
-1
View File
@@ -4,7 +4,6 @@ import Dodge.Item.Draw
import Dodge.Item.Weapon.InventoryDisplay
import Dodge.Default
import Dodge.Default.Wall
import Dodge.Picture.Layer
import Dodge.Creature.Test
import Dodge.Wall
import Dodge.Magnet
src/Dodge/Item/Weapon/BatteryGuns.hs
+5 -5
View File
@@ -309,7 +309,7 @@ lasGunPic it =
upperPrismPoly 4 (rectNESW 3 30 1 0)
<> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0)
<> upperPrismPoly 1 (rectNESW 3 30 (-3) 0)
, setLayer 1 . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0
, setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0
)
where
amFrac = fractionLoadedAmmo it
@@ -386,7 +386,7 @@ tractorGunPic it =
upperPrismPoly 4 (rectNESW 3 30 1 0)
<> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0)
<> upperPrismPoly 1 (rectNESW 3 30 (-3) 0)
, setLayer 1 . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0
, setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0
)
where
amFrac = fractionLoadedAmmo it
@@ -508,7 +508,7 @@ shootDualLaser it cr w = w'
dam = _lasDamage $ _itParams it
drawBeam :: Beam -> Picture
drawBeam bm = setLayer 1 $ pictures
drawBeam bm = setLayer BloomNoZWrite $ pictures
[ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 20 ps
, setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 ps
]
@@ -591,7 +591,7 @@ mvLaser phasev pos dir w pt
xp = pos +.+ 800 *.* unitVectorAtAngle dir
(thHit, ps) = reflectLaserAlong phasev [] pos xp w
col = _ptColor pt
pic = setLayer 1 $ pictures
pic = setLayer BloomNoZWrite $ pictures
[ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 20 (pos:ps)
, setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 (pos:ps)
]
@@ -661,7 +661,7 @@ tractorPullPos q p1 p = p -.- m *.* (0.3/ x' *.* q +.+ g y *.* p4)
p3 = p1 +.+ p4
tractorSPic :: Prop -> SPic
tractorSPic pj = (,) mempty $ setLayer 1 $ setDepth 20 $ color (withAlpha 0.5 col) $ polygon
tractorSPic pj = (,) mempty $ setLayer BloomNoZWrite $ setDepth 20 $ color (withAlpha 0.5 col) $ polygon
[ spos -- not sure if this is anticlockwise...
, spos +.+ size *.* (d +.+ n)
, xpos +.+ size *.* n
src/Dodge/Item/Weapon/Booster.hs
+1 -2
View File
@@ -7,7 +7,6 @@ import Dodge.Zone
import Dodge.Default.Weapon
import Geometry
import qualified IntMapHelp as IM
import Dodge.Picture.Layer
import Picture
import ShapePicture
--import Shape
@@ -81,7 +80,7 @@ updateLinearShockwave pj w
t = _pjTimer pj
drawBoostShockwave :: Prop -> SPic
drawBoostShockwave pj = (,) mempty $ setLayer 1 $ setDepth 20 $ pictures $
drawBoostShockwave pj = (,) mempty $ setLayer BloomLayer $ setDepth 20 $ pictures $
theArc ++
[ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0,0.05..]
, lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0,0.05..]
src/Dodge/Item/Weapon/Decoration.hs
+1 -1
View File
@@ -15,7 +15,7 @@ makeLaserScope
-> Float -- ^ Fraction of red/green
-> Particle
makeLaserScope p ep relFrac = Particle
{_ptDraw = const $ setLayer 1 $ setDepth 20 $ pictures
{_ptDraw = const $ setLayer BloomLayer $ setDepth 20 $ pictures
[lineAlphaThick 0.5 0.5
,lineAlphaThick 0.2 1.5
,lineAlphaThick 0.1 2
src/Dodge/Item/Weapon/ExtraEffect.hs
+3 -3
View File
@@ -75,7 +75,7 @@ targetCursor = defaultTargeting
targetSimpleDraw :: Int -> Item -> Creature -> World -> Picture
targetSimpleDraw _ it _ w = fromMaybe mempty $ do
mwp <- it ^? itTargeting . tgPos . _Just
return $ setLayer 4 $ color red $ setDepth 50 $ uncurryV translate mwp
return $ setLayer TopLayer $ color red $ setDepth 50 $ uncurryV translate mwp
$ rotate (_cameraRot w)
$ pictures
[line [V2 x x, V2 (-x) (-x)]
@@ -87,7 +87,7 @@ targetSimpleDraw _ it _ w = fromMaybe mempty $ do
targetRBCreatureDraw :: Int -> Item -> Creature -> World -> Picture
targetRBCreatureDraw _ it _ w = fromMaybe mempty $ do
mwp <- it ^? itTargeting . tgPos . _Just
return $ setLayer 5 $ color thecolor $ setDepth 50 $ uncurryV translate mwp
return $ setLayer TopLayer $ color thecolor $ setDepth 50 $ uncurryV translate mwp
$ rotate (_cameraRot w)
$ pictures
[line [V2 x x, V2 (-x) (-x)]
@@ -146,7 +146,7 @@ targetLaserUpdate it cr w t
sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr)
ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos w -.- sp)
addLaserPic = instantParticles .:~ Particle
{ _ptDraw = const $ setLayer 1 $ pictures
{ _ptDraw = const $ setLayer BloomNoZWrite $ pictures
[ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 5 (sp:ps)
, setDepth 19.5 . color (brightX 5 1 col) $ thickLine 1 (sp:ps)
]
src/Dodge/Item/Weapon/Launcher.hs
+1 -1
View File
@@ -231,7 +231,7 @@ shellShape = colorSH black $ upperPrismPoly 4 $ map toV2 [(-6,4),(-6,-4),(6,-4),
remoteShellShape :: Color -> SPic
remoteShellShape col = (shellShape
, setLayer 1 . setDepth 4.5 . color col $ circleSolid 3
, setLayer BloomNoZWrite . setDepth 4.5 . color col $ circleSolid 3
)
drawRemoteShell :: Prop -> SPic
src/Dodge/Item/Weapon/SonicGuns.hs
+1 -1
View File
@@ -78,7 +78,7 @@ sonicWave pos dir cpos = ShockLine
makePointDir p = (p, argV $ p -.- cpos)
drawSonicWave :: Particle -> Picture
drawSonicWave pt = foldMap (color (_ptColor pt) . setLayer 1 . setDepth 20
drawSonicWave pt = foldMap (color (_ptColor pt) . setLayer BloomNoZWrite . setDepth 20
. lineThick 20
. map fst)
$ _ptPointDirs pt
src/Dodge/Item/Weapon/UseEffect.hs
+2 -2
View File
@@ -31,7 +31,7 @@ mvBlip p col maxt t w pt =
, Just $ pt & ptUpdate .~ mvBlip p col maxt (t-1)
& ptDraw .~ ( const
. setDepth (-0.5)
. setLayer 1
. setLayer BloomLayer
. uncurryV translate p
. color (withAlpha (fromIntegral t / fromIntegral maxt) col)
$ circleSolid 2 )
@@ -50,7 +50,7 @@ mvSonar x p w pt = (w, Just $ pt {_ptDraw = const pic
}
)
where
pic = setDepth (-0.5) . setLayer 1 $ pictures crBlips
pic = setDepth (-0.5) . setLayer BloomLayer $ pictures crBlips
crBlips = mapMaybe crBlip $ IM.elems $ _creatures w
crBlip cr | dist cpos p < r + crad && dist cpos p > r - (crad + 100)
= Just $ colHelper (0.5 * (1 - (r - dist cpos p) /100))
src/Dodge/Particle/Bullet/Draw.hs
+1 -1
View File
@@ -5,7 +5,7 @@ import Dodge.Data
import Picture
drawBul :: Particle -> Picture
drawBul pt = setLayer 1
drawBul pt = setLayer BloomNoZWrite
. setDepth 20
. color (_ptColor pt)
$ thickLine (_ptWidth pt) (take 3 $ _ptTrail pt)
src/Dodge/Particle/TeslaArc.hs
+1 -1
View File
@@ -31,7 +31,7 @@ aTeslaArcAt col thearc = LinearParticle
}
drawTeslaArc :: Particle -> Picture
drawTeslaArc pt = setLayer 1 $ pictures
drawTeslaArc pt = setLayer BloomNoZWrite $ pictures
[ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ thickLine 3 ps
, setDepth 20 $ color (V4 0 0 0 0.5) $ thickLine 10 ps
]
src/Dodge/Picture/Layer.hs
-1
View File
@@ -6,7 +6,6 @@ module Dodge.Picture.Layer
-- , levLayer
-- , Layer (..)
) where
import Dodge.Picture.Layer.Data
import Picture
{- | Uses a layer to set the depth. -}
--onLayer :: Layer -> Picture -> Picture
src/Dodge/Picture/SizeInvariant.hs
+4 -4
View File
@@ -14,7 +14,7 @@ fixedSizePicAt
-> World
-> Picture
fixedSizePicAt pic p w
= setLayer 4
= setLayer TopLayer
. setDepth 50
. translate x y
. scale theScale theScale
@@ -34,7 +34,7 @@ fixedSizePicClamp
-> World
-> Picture
fixedSizePicClamp xbord ybord pic p cfig w
= setLayer 4
= setLayer TopLayer
-- . setDepth 50
. translate x y
. scale theScale theScale
@@ -59,8 +59,8 @@ fixedSizePicClampArrow
-> World
-> Picture
fixedSizePicClampArrow xbord ybord pic p cfig w = pictures
[ setLayer 4 . translate x y . scale theScale theScale $ pic
, setLayer 4 . color white . setDepth 20 $ arrowPic
[ setLayer TopLayer . translate x y . scale theScale theScale $ pic
, setLayer TopLayer . color white . setDepth 20 $ arrowPic
]
where
winps = screenPolygon cfig w
src/Dodge/Render.hs
+2 -1
View File
@@ -17,6 +17,7 @@ import Shader.Data
import MatrixHelper
import Shader.ExtraPrimitive
import Shader.Parameters
import Picture.Data
import Foreign
import Control.Lens
@@ -45,7 +46,7 @@ doDrawing pdata u = do
lwShad = _lightingWallShadShader pdata
-- bind as much data into vbos as feasible at this point
-- count mutable vectors setup
layerCounts <- UMV.replicate (6*6) 0
layerCounts <- UMV.replicate (numLayers*6) 0
shapeCounts <- UMV.replicate 3 (0 :: Int)
wlwiflCounts <- UMV.replicate 3 (0 :: Int)
-- attempt to poke in parallel
src/Dodge/Render/ShapePicture.hs
+3 -3
View File
@@ -106,7 +106,7 @@ drawPathing cfig w
viewBoundaries :: Configuration -> World -> Picture
viewBoundaries cfig w
| _debug_view_boundaries cfig
= setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs)
= setLayer TopLayer $ color green (concatMap (polygonWire . _grBound) grs)
<> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
| otherwise = []
where
@@ -116,9 +116,9 @@ viewBoundaries cfig w
viewClipBounds :: Configuration -> World -> Picture
viewClipBounds cfig w
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries
= setLayer 5 $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
= setLayer TopLayer $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
= setLayer 5 $ f (_roomClipping w)
= setLayer TopLayer $ f (_roomClipping w)
| otherwise = []
where
f (x:xs) = g x xs <> f xs
src/Dodge/WorldEvent/Cloud.hs
+1 -1
View File
@@ -46,7 +46,7 @@ smokeCloudAt
smokeCloudAt col = makeCloudAt (drawCloudWith (4/3) 800 col)
drawCloudWith :: Float -> Float -> Color -> Cloud -> Picture
drawCloudWith radMult fadet col cl = setLayer 2
drawCloudWith radMult fadet col cl = setLayer MidLayer
. setDepth 25
$ circleSolidCol (withAlpha 0 col) (withAlpha a col) (radMult * _clRad cl)
where
src/Dodge/WorldEvent/Flash.hs
+2 -2
View File
@@ -28,7 +28,7 @@ muzFlareAt :: Color -> Point3 -> Float -> World -> World
muzFlareAt col tranv dir w = w & instantParticles .:~ theFlare
where
theFlare = Particle
{ _ptDraw = const $ setLayer 1 . translate3 tranv $ theShape
{ _ptDraw = const $ setLayer BloomNoZWrite . translate3 tranv $ theShape
, _ptUpdate = ptSimpleTime 2
}
theShape = rotate dir . color col $ polygon
@@ -40,7 +40,7 @@ muzFlareAt col tranv dir w = w & instantParticles .:~ theFlare
flareCircleAt :: Color -> Float -> Point3 -> World -> World
flareCircleAt col alphax tranv = instantParticles .:~ Particle
{ _ptDraw = const . setLayer 1 . translate3 tranv
{ _ptDraw = const . setLayer BloomNoZWrite . translate3 tranv
$ circleSolidCol (withAlpha 0 0) (withAlpha alphax col) 50
, _ptUpdate = ptSimpleTime 1
}
src/Dodge/WorldEvent/Shockwave.hs
+2 -3
View File
@@ -8,7 +8,6 @@ import Dodge.Data
import Dodge.Wall.Damage
import Dodge.Base
import Dodge.Zone
import Dodge.Picture.Layer
import Geometry
import Picture
import LensHelp
@@ -38,7 +37,7 @@ makeShockwaveAt is p rad dam push col = instantParticles .:~ Shockwave
{- Shockwave picture. -}
drawShockwave :: Particle -> Picture
drawShockwave pt = setDepth 20
. setLayer 1
. setLayer BloomLayer
. uncurryV translate (_ptPos pt)
. color (_ptColor pt)
$ thickCircle rad thickness
@@ -115,7 +114,7 @@ moveInverseShockwave w pt
drawInverseShockwave :: Particle -> Picture
drawInverseShockwave pt
= setLayer 1 $ setDepth 20 $ uncurryV translate p
= setLayer BloomLayer $ setDepth 20 $ uncurryV translate p
$ color cyan $ thickCircle rad thickness
where
p = _ptPos pt
src/Dodge/WorldEvent/SpawnParticle.hs
+10 -10
View File
@@ -51,13 +51,13 @@ drawFlame
-> Picture
drawFlame rotd pt = pictures
[ glow
, aPic 3 prot2 25 (V2 (scaleChange + 1) 2 ) $ V4 2 (-1) (-1) 0.5
, aPic 3 prot 22 (V2 (scaleChange + 0.5) 1 ) $ V4 1 0.5 0 2
, aPic 1 prot3 20 (V2 scaleChange 0.5) $ V4 1 1 1 1
, aPic BloomNoZWrite prot2 25 (V2 (scaleChange + 1) 2 ) $ V4 2 (-1) (-1) 0.5
, aPic BloomNoZWrite prot 22 (V2 (scaleChange + 0.5) 1 ) $ V4 1 0.5 0 2
, aPic BloomLayer prot3 20 (V2 scaleChange 0.5) $ V4 1 1 1 1
]
where
ep = _ptPos pt
aPic :: Int -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
aPic :: Layer -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
aPic lay offset depth (V2 scalex scaley) col
= setLayer lay
. setDepth depth
@@ -66,7 +66,7 @@ drawFlame rotd pt = pictures
. scale scalex scaley
. color col
$ circleSolid 5
glow = setLayer 1 $ setDepth 0.3 $ uncurryV translate ep
glow = setLayer BloomNoZWrite $ setDepth 0.3 $ uncurryV translate ep
$ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50
time = _ptTimer pt
scaleChange
@@ -202,7 +202,7 @@ makeFlamelet (V2 x y) z vel maycid size time w = w
drawStaticBall
:: Particle
-> Picture
drawStaticBall pt = setLayer 1
drawStaticBall pt = setLayer BloomNoZWrite
. setDepth (_ptZ pt + 20)
. uncurryV translate (_ptPos pt)
$ circleSolidCol (_ptColor pt) (withAlpha 0.5 white) (_ptWidth pt+5)
@@ -212,9 +212,9 @@ drawFlameletZ
-> Particle
-> Picture
drawFlameletZ rot pt = pictures
[ setLayer 1 pic
, setLayer 3 piu
, setLayer 3 pi2
[ setLayer BloomLayer pic
, setLayer BloomNoZWrite piu
, setLayer BloomNoZWrite pi2
]
where
z = _ptZ pt
@@ -292,7 +292,7 @@ makeGasCloud pos vel w = w
theCloud = Cloud
{ _clPos = addZ 20 pos
, _clVel = addZ 0 vel
, _clPict = \_ -> setLayer 2 . setDepth 30 $ color (withAlpha 0.05 col)
, _clPict = \_ -> setLayer MidLayer . setDepth 30 $ color (withAlpha 0.05 col)
$ circleSolid 20
, _clRad = 10
, _clAlt = 25
src/Picture.hs
+10 -10
View File
@@ -57,19 +57,19 @@ polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon = map f . polyToTris
where
f (V2 x y) = Verx (V3 x y 0) black [] (LayNum 0) polyNum
f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum
polygonZ :: [Point2] -> Float -> Picture
{-# INLINE polygonZ #-}
polygonZ ps z = map (f . zeroZ) $ polyToTris ps
where
f pos = Verx pos black [z] (LayNum 0) polyzNum
f pos = Verx pos black [z] BottomLayer polyzNum
polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = polyToTris . map f
where
f (V2 x y,col) = Verx (V3 x y 0) col [] (LayNum 0) polyNum
f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum
poly3 :: [Point3] -> Picture
{-# INLINE poly3 #-}
@@ -79,7 +79,7 @@ poly3Col :: [(Point3,RGBA)] -> Picture
{-# INLINE poly3Col #-}
poly3Col = map f . polyToTris
where
f (pos,col) = Verx pos col [] (LayNum 0) polyNum
f (pos,col) = Verx pos col [] BottomLayer polyNum
-- note that much of work computing the width of the bezier curve is done here
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
@@ -118,7 +118,7 @@ bezierQuad cola colc ra rc a b c
bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
bzhelp = map f
where
f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] (LayNum 0) bezNum
f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] BottomLayer bezNum
-- given a one and two zeros of a linear function over x and y,
-- determine the function
@@ -166,11 +166,11 @@ addDepth :: Float -> Picture -> Picture
addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d))
-- TODO change the Int here to a dedicated type
setLayer :: Int -> Picture -> Picture
setLayer :: Layer -> Picture -> Picture
{-# INLINE setLayer #-}
setLayer i = map f
where
f v = v {_vxLayer = LayNum i}
f v = v {_vxLayer = i}
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
@@ -215,7 +215,7 @@ circleSolidCol colC colE r = map f
,(V3 r (-r) 0, black)
]
where
f (pos,col) = Verx pos col [] (LayNum 0) ellNum
f (pos,col) = Verx pos col [] BottomLayer ellNum
circle :: Float -> Picture
{-# INLINE circle #-}
@@ -233,7 +233,7 @@ text :: String -> Picture
{-# INLINE text #-}
text = map f . stringToList
where
f (pos,col,V2 a b) = Verx pos col [a,b] (LayNum 0) textNum
f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum
line :: [Point2] -> Picture
{-# INLINE line #-}
@@ -326,7 +326,7 @@ thickArcHelp startA endA rad wdth = map f
(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0)
--(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * 2) 0)
(V2 xc yc) = rotateV endA (V2 rad 0)
f (pos,col,V3 a b c) = Verx pos col [a,b,c] (LayNum 0) arcNum
f (pos,col,V3 a b c) = Verx pos col [a,b,c] BottomLayer arcNum
-- Currently the lens version is much slower
src/Picture/Data.hs
+11 -2
View File
@@ -10,10 +10,10 @@ data Verx = Verx
{ _vxPos :: !Point3
, _vxCol :: !Point4
, _vxExt :: [Float]
, _vxLayer :: !LayNum
, _vxLayer :: !Layer
, _vxShadNum :: !ShadNum
}
newtype LayNum = LayNum { _unLayNum :: Int }
--newtype LayNum = LayNum { _unLayNum :: Int }
data Layer
= BottomLayer
@@ -23,6 +23,15 @@ data Layer
| TopLayer
| FixedCoordLayer
layerNum :: Layer -> Int
layerNum lay = case lay of
BottomLayer -> 0
MidLayer -> 1
BloomLayer -> 2
BloomNoZWrite -> 3
TopLayer -> 4
FixedCoordLayer -> 5
numLayers :: Int
numLayers = 6
--TODO use synonyms for layer numbers
src/Polyhedra.hs
+1 -1
View File
@@ -121,7 +121,7 @@ polyToPics = map helpPoly3D . _pyFaces
helpPoly3D :: [(Point3, Point4)] -> Picture
helpPoly3D = map f . polyToTris
where
f (pos,col) = Verx pos col [] (LayNum 0) polyNum
f (pos,col) = Verx pos col [] BottomLayer polyNum
polysToPic :: [Polyhedra] -> Picture
polysToPic = pictures . concatMap polyToPics
src/Shader/Poke.hs
+2 -2
View File
@@ -196,8 +196,8 @@ pokeLayVerx vbos counts vx = do
UMV.unsafeModify counts (+ 1) vecPos
where
sn = _unShadNum (_vxShadNum vx)
vecPos = theLayer * 6 + sn
theLayer = _unLayNum $ _vxLayer vx
vecPos = theLayer * numLayers + sn
theLayer = layerNum $ _vxLayer vx
thePos = _vxPos vx
theCol = _vxCol vx
layOff = theLayer * numSubElements