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

Allow tweaking z buffer when rendering polygon, improve explosion render

Browse Source
This commit is contained in:
jgk
2021-07-03 23:56:01 +02:00
parent 532f491327
commit 9df19a9e85
33 changed files with 339 additions and 82 deletions
Download Patch File Download Diff File Expand all files Collapse all files
shader/twoD/basicTweakZ.frag
+7
View File
@@ -0,0 +1,7 @@
#version 430 core
in vec4 vColor;
out vec4 fColor;
void main()
{
fColor = vColor;
}
shader/twoD/basicTweakZ.vert
+12
View File
@@ -0,0 +1,12 @@
#version 430 core
layout (location = 0) in vec4 position;
layout (location = 1) in vec4 color;
layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ;
out vec4 vColor;
void main()
{
vec4 posxy = theMat * vec4(position.xyz,1);
vec4 posz = theMat * vec4(position.xyw,1);
gl_Position = vec4(posxy.xy,posz.z,1);
vColor = color;
}
src/Dodge/Creature.hs
+1 -1
View File
@@ -171,7 +171,7 @@ startInventory = IM.fromList (zip [0..20]
,boosterGun
,remoteLauncher
,grenade
,spawnGun lamp
,spawnGun (lamp 20)
,lasGun
,flamer
,poisonSprayer
src/Dodge/Creature/Inanimate.hs
+14 -14
View File
@@ -26,29 +26,29 @@ import Control.Lens
defaultInanimate :: Creature
defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
lamp :: Creature
lamp = defaultInanimate
{ _crUpdate = initialiseLamp
lamp :: Float -> Creature
lamp h = defaultInanimate
{ _crUpdate = initialiseLamp h
, _crHP = 100
, _crPict = picAtCrPos lampPic
, _crPict = picAtCrPos (lampPic h)
, _crRad = 3
, _crMass = 3
}
lampPic :: Picture
lampPic = pictures
[ pictures . map (Poly3D 0 . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 99
, setDepth (100) $ color white $ circleSolid 3
lampPic :: Float -> Picture
lampPic h = pictures
[ pictures . map (Poly3D 0 . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 (h-1)
, setDepth h $ color white $ circleSolid 3
]
initialiseLamp :: CRUpdate
initialiseLamp w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp i)
initialiseLamp :: Float -> CRUpdate
initialiseLamp h w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp h i)
where
i = IM.newKey $ _lightSources $ f w -- to give different lights different keys
addLS = over lightSources (IM.insert i (lightAt (x,y,20) i))
addLS = over lightSources (IM.insert i (lightAt (x,y,h) i))
(x,y) = _crPos cr
updateLamp :: Int -> CRUpdate
updateLamp i = unrandUpdate handleLS internalUpdate
updateLamp :: Float -> Int -> CRUpdate
updateLamp h i = unrandUpdate handleLS internalUpdate
where
handleLS cr w
| _crHP cr < 0 = explosionFlashAt cPos
@@ -56,7 +56,7 @@ updateLamp i = unrandUpdate handleLS internalUpdate
| otherwise = w & lightSources . ix i . lsPos .~ f cPos
where
cPos = _crPos cr
f (x,y) = (x,y,120)
f (x,y) = (x,y,h)
internalUpdate cr
| _crHP cr < 0 = Nothing
| otherwise = Just $ doDamage cr
src/Dodge/Creature/Picture.hs
+13 -6
View File
@@ -16,6 +16,7 @@ import Dodge.Creature.Test
import Dodge.Item.Data
import Picture
import Geometry
import Geometry.Vector3D
import Control.Lens
import Data.List
@@ -29,12 +30,13 @@ basicCrPict col cr w = pictures $
targetingPic ++
[ tr . setDepth 0 $ color yellow $ circleSolid 10
, tr . piercingMod $ bluntScale $ naked col cr
, tr $ waist col
, tr $ torso (light4 col) (0,-crad) (0,crad)
, trFeet $ feet cr
, tr $ arms col cr
, tr $ drawEquipment cr
]
where
crad = _crRad cr
targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
tr = uncurry translate (_crPos cr) . rotate (_crDir cr)
@@ -55,9 +57,6 @@ basicCrPict col cr w = pictures $
_ -> id
pastDams = _crPastDamage $ _crState cr
waist :: Color -> Picture
waist col = setDepth 10 . color (light4 col) . scale 0.5 1 $ circleSolid 8
feet :: Creature -> Picture
feet cr = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> setL
@@ -99,7 +98,15 @@ arms col cr
f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
aimingTwist = crIsAiming' cr -- && crIt ^? itAimStance == Just TwoHandTwist
--crIt = _crInv cr IM.! _crInvSel cr
torso :: Color -> Point2 -> Point2 -> Picture
torso col x y = color col $ pictures
[ poly3 [addZ 20 x, addZ 12 v, addZ 12 ((0,0) -.- v), addZ 20 y]
, setDepth 12 . rotate a . scale 1 1 $ circleSolid $ magV v
]
where
v = 0.25 *.* (x -.- y)
a = argV v
naked :: Color -> Creature -> Picture
naked col cr
@@ -125,7 +132,7 @@ naked col cr
, shoulderH . translate 0 (negate 3) . rotate 0.2 . scale 0.5 1 $ color col' $ circleSolid $ _crRad cr
]
where
fhead = setDepth 30 $ circleSolid $ crad * 0.5
fhead = setDepth 22 $ circleSolid $ crad * 0.5
shoulderH = setDepth 20
twistA = negate 1
aimingOneHand = crIsAiming' cr && crIt ^? itAimStance == Just OneHand
src/Dodge/Creature/State.hs
+1
View File
@@ -93,6 +93,7 @@ movementSideEff cr w
Just (Boosting v)
-> makeFlameletTimed
(oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi))
20
(momentum +.+ 1 *.* rotateV randDir (vInverse v))
Nothing
1
src/Dodge/Data.hs
+12
View File
@@ -355,6 +355,18 @@ data Particle
, _btTimer' :: Int
, _btHitEffect' :: HitEffect
}
| PtZ
{ _ptDraw :: Particle -> Picture
, _ptUpdate' :: World -> Particle -> (World, Maybe Particle)
, _btVel' :: Point2
, _btColor' :: Color
, _btPos' :: Point2
, _btPassThrough' :: Maybe Int
, _btWidth' :: Float
, _btTimer' :: Int
, _btHitEffect' :: HitEffect
, _ptZ :: Float
}
| Pt'
{ _ptDraw :: Particle -> Picture
, _ptUpdate' :: World -> Particle -> (World, Maybe Particle)
src/Dodge/Event/Keyboard.hs
+1 -1
View File
@@ -105,6 +105,6 @@ dropLight w = placeLS ls dec pos 0 w
dec = onLayer PtLayer $ color white $ circleSolid 8
dropLight' :: World -> World
dropLight' w = placeCr lamp pos 0 w
dropLight' w = placeCr (lamp 30) pos 0 w
where
pos = _crPos(you w)
src/Dodge/Item/Draw.hs
+2 -2
View File
@@ -27,8 +27,8 @@ pictureWeaponOnAim p cr posInInv
= handD holsteredWep
| otherwise = blank
where
shoulderD = setDepth $ negate 0.005
handD = setDepth 0.01
shoulderD = setDepth 20.5
handD = setDepth 15
isSelected = _crInvSel cr == posInInv
drawnWep = uncurry translate (_crRad cr,0) p
twistWep = uncurry translate (0.5 * _crRad cr,0) p
src/Dodge/Item/Weapon.hs
+4 -4
View File
@@ -546,10 +546,10 @@ remoteShellPic
:: Int -- ^ Timer
-> Picture
remoteShellPic t
| rem (t+200) 20 < 9 = polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
| rem (t+200) 20 < 9 = setDepth 20 $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
| otherwise = pictures
[ onLayer UPtLayer $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
, setLayer 1 $ onLayer HPtLayer $ color col $ circleSolid 3
[ setDepth 20 $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
, setLayer 1 . setDepth 20.5 . color col $ circleSolid 3
]
where
col | t > (-99) = green
@@ -797,7 +797,7 @@ moveRemoteShell cid itid pj w
)
& soundFromPos (ShellSound i) newPos (fromIntegral smokeTrailSound) 1 250
& smokeGen
& makeFlameletTimed oldPos (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10
& makeFlameletTimed oldPos 20 (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10
| time > -200 = case thingHit of
Just _ -> doExplosion $ stopSoundFrom (ShellSound i) w
Nothing -> w
src/Dodge/Item/Weapon/Laser.hs
+3 -3
View File
@@ -3,7 +3,7 @@ module Dodge.Item.Weapon.Laser
where
import Dodge.Data
import Dodge.Picture
import Dodge.Picture.Layer
--import Dodge.Picture.Layer
import Dodge.Item.Attachment.Data
--import Dodge.Base
import Dodge.SoundLogic
@@ -56,7 +56,7 @@ moveLaser
-> (World, Maybe Particle)
moveLaser phaseV pos dir w pt
= ( set randGen g $ hitEffect w
, Just pt {_ptDraw = const $ onLayer PtLayer pic ,_ptUpdate' = ptTimer' 0 }
, Just pt {_ptDraw = const pic ,_ptUpdate' = ptTimer' 0 }
)
where
xp = pos +.+ 800 *.* unitVectorAtAngle dir
@@ -106,7 +106,7 @@ moveLaser phaseV pos dir w pt
Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (pos -.- p))
(reflectDir wl) Nothing
_ -> id
pic = pictures
pic = setDepth 20 $ pictures
[ fadeLine pos (head ps) 0.2 40 yellow
, setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (pos:ps)
, setLayer 1 $ color (withAlpha 0.5 yellow) $ vvThickLine (pos:ps)
src/Dodge/Item/Weapon/Launcher.hs
+2 -7
View File
@@ -98,7 +98,7 @@ doThrust pj w = w
& randGen .~ g
& projectiles . ix i . pjVel %~ (\v -> accel +.+ frict *.* v)
& soundFromPos (ShellSound i) newPos (fromIntegral smokeTrailSound) 1 250
& makeFlameletTimed (oldPos -.- vel) (vel +.+ rotateV (pi+sparkD) accel) Nothing 3 10
& makeFlameletTimed (oldPos -.- vel) 0 (vel +.+ rotateV (pi+sparkD) accel) Nothing 3 10
& smokeGen
where
accel = _pjAcc pj
@@ -172,16 +172,11 @@ reduceSpinBy :: Float -> Projectile -> World -> World
reduceSpinBy x pj = projectiles . ix (_pjID pj) . pjSpin *~ x
shellPic :: Projectile -> Picture
shellPic pj
| t > 40 = onLayerL [levLayer CrLayer - 2]
$ uncurry translate pos $ rotate (argV accel) basePic
| otherwise = onLayer PtLayer $ uncurry translate pos $ rotate (argV accel) basePic
shellPic pj = setDepth 20 . uncurry translate pos $ rotate (argV accel) basePic
where
basePic = color black $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
accel = _pjAcc pj
pos = _pjPos pj
t = _pjTimer pj
pjEffTimeRange
:: (Int,Int)
src/Dodge/LightSources.hs
+1 -1
View File
@@ -14,7 +14,7 @@ lightAt (x,y,z) i =
LS {_lsID = i
,_lsPos = (x,y,z)
,_lsDir = 0
,_lsRad = 500
,_lsRad = 700
,_lsIntensity = 0.75
}
basicLS :: PSType
src/Dodge/Particle/Bullet/Draw.hs
+1 -1
View File
@@ -5,6 +5,6 @@ import Dodge.Data
import Picture
drawBul :: Particle -> Picture
drawBul pt = setLayer 1 . color thecolor $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt)
drawBul pt = setLayer 1 . setDepth 20 . color thecolor $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt)
where
thecolor = _btColor' pt
src/Dodge/Particle/Bullet/HitEffect.hs
+2 -2
View File
@@ -118,7 +118,7 @@ bulIncCr' bt p cr w
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
v = evalState (randInCirc 1) $ _randGen w
incFlamelets = over worldEvents $ (.) (makeFlameletTimed p v Nothing 3 20)
incFlamelets = over worldEvents $ (.) (makeFlameletTimed p 20 v Nothing 3 20)
{- | Creates a shockwave when hitting a creature. -}
bulConCr' :: Particle -> Point2 -> Creature -> World -> World
bulConCr' bt p cr w
@@ -172,7 +172,7 @@ bulIncWall' bt p wl w = damageBlocksBy 5 wl $ incFlamelets w
pOut = p +.+ safeNormalizeV (sp -.- p)
wallV = uncurry (-.-) (_wlLine wl)
reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt)
incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut reflectVel Nothing 3 20)
incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut 20 reflectVel Nothing 3 20)
{- | Create a shockwave on wall-}
bulConWall'
:: Particle
src/Dodge/Particle/Bullet/Spawn.hs
+1 -1
View File
@@ -11,7 +11,7 @@ import Control.Lens
aGenBulAt
:: Maybe Int -- ^ Pass-through creature id
-> Point2 -- ^ Start position
-> Point2 -- ^ Velocity
-> Point2 -- ^ Velocity
-> HitEffect
-> Float -- ^ Bullet width
-> Particle
src/Dodge/Picture.hs
+1 -1
View File
@@ -43,7 +43,7 @@ wedgeOfThickness t x y
n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
verticalPipe :: Float -> Color -> Point2 -> Float -> Float -> Picture
verticalPipe w col (xx,xy) za zb = pictures $ map (poly3D . f) ps
verticalPipe w col (xx,xy) za zb = pictures $ map (poly3Col . f) ps
where
x = (xx,xy,0)
xs = map (\(a,b) -> x +.+.+ (a,b,za)) [(w,0),(0,w),(-w,0),(0,-w)]
src/Dodge/RandomHelp.hs
+21
View File
@@ -3,6 +3,7 @@ Helpers for random generation.
-}
module Dodge.RandomHelp where
import Geometry
import Geometry.Vector3D
import Geometry.Data
import System.Random
@@ -68,6 +69,26 @@ randInCirc maxRad = do rad <- state $ randomR (0,maxRad)
ang <- state $ randomR (0,2*pi)
return $ rad *.* unitVectorAtAngle ang
randOnUnitSphere :: RandomGen g => State g Point3
randOnUnitSphere = do
z <- state $ randomR (negate 1,1)
longitude <- state $ randomR (0, 2*pi)
let (x,y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
return (x,y,z)
randOnHemisphere :: RandomGen g => State g Point3
randOnHemisphere = do
z <- state $ randomR (0,1)
longitude <- state $ randomR (0, 2*pi)
let (x,y) = sqrt (1 - z^(2::Int)) *.* unitVectorAtAngle longitude
return (x,y,z)
randInHemisphere :: RandomGen g => State g Point3
randInHemisphere = do
p <- randOnHemisphere
r <- state $ randomR (0,1)
return $ r *.*.* p
randInRect :: RandomGen g => Float -> Float -> State g Point2
randInRect w h = do x <- state $ randomR (0,w)
y <- state $ randomR (0,h)
src/Dodge/Render.hs
+6 -1
View File
@@ -64,7 +64,7 @@ doDrawing pdata w = do
depthFunc $= Just Less
let scPol = screenPolygon w
-- draw the lightmap. Probably changes the bound framebufferObject
createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints viewFroms
createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints
(foregroundPics w) scPol
clear [DepthBuffer]
@@ -95,6 +95,11 @@ doDrawing pdata w = do
blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
depthFunc $= Just Lequal
_ <- renderFoldable pdata $ picToLTree (Just 1) pic
depthMask $= Disabled
_ <- renderFoldable pdata $ picToLTree (Just 3) pic
_ <- renderFoldable pdata $ picToLTree (Just 4) pic
_ <- renderFoldable pdata $ picToLTree (Just 5) pic
depthMask $= Enabled
-- reset blend so that light map applies again
-- allows us to be certain these elements are drawn on top of those before,
-- in case we want transparency effects
src/Dodge/Room/Placement.hs
+1 -1
View File
@@ -13,7 +13,7 @@ import Data.List
import Control.Lens
putLamp :: PSType
putLamp = PutCrit lamp
putLamp = PutCrit (lamp 90)
singleBlock :: Point2 -> [Placement]
singleBlock a =
src/Dodge/WorldEvent/Cloud.hs
+1 -1
View File
@@ -26,7 +26,7 @@ makeCloudAt rad t drawFunc p w = w & clouds %~ IM.insert i theCloud
drawCloudWith :: Float -> Float -> Color -> Cloud -> Picture
drawCloudWith radMult fadet col cl
= setLayer 2
. setDepth (-0.02)
. setDepth 25
$ circleSolidCol (withAlpha 0 col) (withAlpha a col) (radMult * _clRad cl)
where
a = min 1 $ fromIntegral (_clTimer cl) / fadet
src/Dodge/WorldEvent/Explosion.hs
+6 -3
View File
@@ -12,6 +12,7 @@ import Dodge.SoundLogic
import Dodge.SoundLogic.Synonyms
import Dodge.WorldEvent.Shockwave
import Geometry
import Geometry.Vector3D
import Picture
import Control.Monad.State
@@ -71,14 +72,16 @@ makeExplosionAt p w
$ makeShockwaveAt [] p 50 10 1 white w
where
fVs = replicateM 75 (randInCirc 1) & evalState $ _randGen w
fPs' = replicateM 75 (randInCirc 15) & evalState $ _randGen w
fPs'' = replicateM 75 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w
(fPs',zs) = let (a,b,c) = unzip3 fPs''
in (zip a b, c)
fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) fPs'
inversePushOut v = (15 - magV v) * 0.01 *.* v
fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
sizes = randomRs (2,6) $ _randGen w
times = randomRs (20,25) $ _randGen w
mF q v size time = makeFlameletTimed q v Nothing size time
newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
mF q z v size time = makeFlameletTimed q z v Nothing size time
newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times
addFlames w' = foldr ($) w' newFs
pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q $ wallsNearPoint q w
src/Dodge/WorldEvent/Shockwave.hs
+1 -1
View File
@@ -49,7 +49,7 @@ Shockwave picture.
drawShockwave :: Particle -> Picture
drawShockwave pt = pic
where
pic = onLayer PtLayer $ uncurry translate p
pic = setDepth 20 . uncurry translate p
$ color (_btColor' pt) $ thickCircle rad thickness
p = _btPos' pt
r = _btRad' pt
src/Dodge/WorldEvent/SpawnParticle.hs
+65 -15
View File
@@ -20,6 +20,7 @@ import Dodge.RandomHelp
--import Dodge.Debug
import Picture
import Geometry
--import Geometry.Data
import qualified IntMapHelp as IM
import Control.Lens
@@ -56,9 +57,9 @@ drawFlame rotd pt = thePic
ep = _btPos' pt
thePic = pictures
[ glow
, aPic prot2 0.002998 (scaleChange + 1,2) red
, aPic prot 0.002996 (scaleChange + 0.5,1.5) orange
, aPic prot3 0.002994 (scaleChange,1) white
, aPic prot2 18 (scaleChange + 1,2) red
, aPic prot 19 (scaleChange + 0.5,1.5) orange
, aPic prot3 20 (scaleChange,1) white
]
aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
aPic offset depth (scalex,scaley) col
@@ -121,31 +122,80 @@ moveFlame rotd w pt
+.+ (0.2 *.* vel)
smokeCol = fst $ randomR (0.2,0.5) (_randGen w)
smokeGen = makeFlamerSmokeAt smokeCol ep
makeFlameletTimed
:: Point2 -- ^ Position
-> Float -- ^ z position
-> Point2 -- ^ Velocity
-> Maybe Int -- ^ Creature id
-> Float -- ^ Size
-> Int -- ^ Timer
-> World
-> World
makeFlameletTimed pos vel maycid size time w = w
makeFlameletTimed (x,y) z vel maycid size time w = w
& randGen .~ g
& particles %~ (theFlamelet :)
where
theFlamelet = Pt'
{ _ptDraw = drawFlamelet rot
theFlamelet = PtZ
{ _ptDraw = drawFlameletZ rot
, _ptUpdate' = moveFlamelet
, _btVel' = vel
, _btColor' = red
, _btPos' = pos
, _btPos' = (x,y)
, _btPassThrough' = maycid
, _btWidth' = size
, _btTimer' = time
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
, _ptZ = z
}
(rot ,g) = randomR (0,3) $ _randGen w
drawFlameletZ
:: Float -- ^ Rotation
-> Particle
-> Picture
drawFlameletZ rot pt = pictures
[ setLayer 5 pic
, setLayer 4 pi2
, setLayer 3 piu
, setLayer 1 glow
]
where
z = _ptZ pt
sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
size = _btWidth' pt
siz2 = size + 0.2
time = _btTimer' pt
glow = setDepth 19 $ uncurry translate ep
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
piu = setDepth (z + 20)
. uncurry translate ep
. color (dark red)
. rotate (negate (rot - 0.1 * fromIntegral time))
. scale s1 s1
$ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
pi2 = setDepth (z + 20)
. uncurry translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red)
)
. rotate (negate (rot + 0.2 * fromIntegral time))
. scale s2 s2
$ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
pic = setDepth (z + 20)
. uncurry translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
white (dark red)
)
. rotate (negate ( 0.1 * fromIntegral time + rot))
. scale sc sc
$ polygon [(-size,-size),(size,-size),(size,size),(-size,size)]
sc = (*) 2 $ log $ 1 + fromIntegral time / 20
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
s2 = 0.5 * (sc + s1)
drawFlamelet
:: Float -- ^ Rotation
-> Particle
@@ -158,16 +208,16 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
size = _btWidth' pt
siz2 = size + 0.2
time = _btTimer' pt
glow = setDepth 0.336 $ uncurry translate ep
glow = setDepth 19 $ uncurry translate ep
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
piu = setDepth 0.334
piu = setDepth 20
. uncurry translate ep
. color (dark red)
. rotate (negate (rot - 0.1 * fromIntegral time))
. scale s1 s1
. polygon
$ rectNSWE siz2 (-siz2) (-siz2) siz2
pi2 = setDepth 0.332
pi2 = setDepth 20.2
. uncurry translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red)
@@ -176,7 +226,7 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
. scale s2 s2
. polygon
$ rectNSWE siz2 (-siz2) (-siz2) siz2
pic = setDepth 0.33
pic = setDepth 20.4
. uncurry translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
white (dark red)
@@ -251,10 +301,10 @@ drawTeslaArc pt = pic
where
ps' = _ptPoints pt
pic = setLayer 1 $ pictures
[ onLayer PtLayer $ color (_ptColor pt) $ line ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
[ setDepth 20.5 $ color (_ptColor pt) $ line ps'
, setDepth 20 $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
, setDepth 20 $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
, setDepth 20 $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
]
-- todo: fix electrical damage location
moveTeslaArc
src/Geometry/Vector.hs
+2 -4
View File
@@ -115,12 +115,10 @@ Identical to detV. -}
crossV :: Point2 -> Point2 -> Float
crossV (ax,ay) (bx,by) = ax*by - ay*bx
{- | TO CHECK Orthographic projection of one vector onto another. -}
projV
:: Point2
-> Point2
-> Point2
projV :: Point2 -> Point2 -> Point2
projV fromv onv
| den == 0 = error "tried projecting onto zero vector"
| otherwise = (fromv `dotV` onv) / den *.* onv
where
den = onv `dotV` onv
src/Geometry/Vector3D.hs
+32
View File
@@ -4,6 +4,8 @@ module Geometry.Vector3D
import Geometry.Vector
import Geometry.Data
import Data.List
infixl 6 +.+.+, -.-.-
infixl 7 *.*.*
@@ -56,3 +58,33 @@ magV3 (x,y,z) = sqrt $ x^i + y^i + z^i
normalizeV3 :: Point3 -> Point3
normalizeV3 (0,0,0) = (0,0,0)
normalizeV3 p = (1 / magV3 p) *.*.* p
addZ :: Float -> Point2 -> Point3
addZ z (x,y) = (x,y,z)
orderAround3
:: Point3 -- ^ Vector to order around
-> [Point3]
-> [Point3]
orderAround3 v ps = sortOn (argV . prj) ps
where
xdir = crossProd v (head ps)
ydir = crossProd v xdir
prj p = (dotV3 xdir p, dotV3 ydir p)
vCen3 :: [Point3] -> Point3
vCen3 ps = (1 / fromIntegral (length ps)) *.*.* foldr (+.+.+) (0,0,0) ps
dotV3
:: Point3
-> Point3
-> Float
dotV3 (x,y,z) (a,b,c) = x*a + y*b + z*c
projV3
:: Point3
-> Point3
-> Point3
projV3 = undefined
src/Picture.hs
+15 -4
View File
@@ -1,8 +1,11 @@
{-# LANGUAGE TupleSections #-}
module Picture
( module Picture.Data
, polygon
, polygonZ
, polygonCol
, poly3D
, poly3
, poly3Col
, bezierQuad
, arc
, arcSolid
@@ -63,13 +66,21 @@ polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon = Polygon 0
polygonZ :: [Point2] -> Float -> Picture
{-# INLINE polygonZ #-}
polygonZ = PolygonZ 0
polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = PolygonCol 0
poly3D :: [(Point3,RGBA)] -> Picture
{-# INLINE poly3D #-}
poly3D = Poly3D 0
poly3 :: [Point3] -> Picture
{-# INLINE poly3 #-}
poly3 = poly3Col . map (, black)
poly3Col :: [(Point3,RGBA)] -> Picture
{-# INLINE poly3Col #-}
poly3Col = Poly3D 0
-- note that much of work computing the width of the bezier curve is done here
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
src/Picture/Data.hs
+7 -5
View File
@@ -14,11 +14,12 @@ import Geometry.Data
--import Control.Monad
data RenderType
= RenderPoly [(Point3,Point4)]
| RenderBezQ [(Point3,Point4,Point4)]
| RenderText [(Point3,Point4,Point2)]
| RenderArc [(Point3,Point4,Point3)]
| RenderLine [(Point3,Point4)]
= RenderPoly [(Point3,Point4)]
| RenderPolyZ [(Point3,Point4,Float)]
| RenderBezQ [(Point3,Point4,Point4)]
| RenderText [(Point3,Point4,Point2)]
| RenderArc [(Point3,Point4,Point3)]
| RenderLine [(Point3,Point4)]
| RenderEllipse [(Point3,Point4)]
| Render3 [Point3]
| RenderConst
@@ -79,6 +80,7 @@ data Picture
= Blank
| Text Int String
| Polygon Int [Point2]
| PolygonZ Int [Point2] Float
| BezierQuad Int [(Point2,RGBA,Point2,Point2)]
| PolygonCol Int [(Point2,RGBA)]
| Poly3D Int [(Point3,RGBA)]
src/Picture/Tree.hs
+4
View File
@@ -21,6 +21,8 @@ picToLTree
{-# INLINE picToLTree #-}
picToLTree mx (Polygon i ps)
= filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
picToLTree mx (PolygonZ i ps z)
= filtB mx i $ LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
picToLTree mx (PolygonCol i vs)
= filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
where
@@ -85,6 +87,7 @@ overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
overPos f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs
overPos _ _ = undefined
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
@@ -95,6 +98,7 @@ overCol f (RenderEllipse vs) = RenderEllipse $ map (second f) vs
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (a,f b,c)) vs
overCol _ _ = undefined
stringToList :: String -> [(Point3,Point4,Point2)]
src/Polyhedra/Data.hs
+12
View File
@@ -5,6 +5,8 @@ module Polyhedra.Data
import Geometry.Data
import Control.Lens
import qualified Data.Map as M
--import qualified Data.IntSet as IS
-- | Polyhedra are represented as a list of faces.
-- Each face is a list of points (and colours) that are assumed to lie on a plane, and be
-- ordered to form an anticlockwise convex polygon within that plane.
@@ -12,4 +14,14 @@ data Polyhedra = Polyhedron
{ _pyFaces :: [[(Point3,Point4)]]
}
-- | Describe a polygon as a map from vertex indices to a positiong and list of faces.
-- The list of faces is assumed to be ordered in clockwise direction around the vertex.
-- The vertices of the faces are assumed to start with a point adjacent to the
-- key vertex and to be listed anticlockwise around the center of the face.
-- The key vertex is not included in the list.
data VF a = VF
{ _vertices :: M.Map a (Point3, [[a]])
}
makeLenses ''Polyhedra
makeLenses ''VF
src/Polyhedra/Geodesic.hs
+79
View File
@@ -0,0 +1,79 @@
{-# LANGUAGE TupleSections #-}
module Polyhedra.Geodesic
where
import Geometry.Data
import Geometry.Vector3D
import Polyhedra.Data
import Data.List
import qualified Data.Map as M
icosahedronPoints :: [Point3]
icosahedronPoints = concat
[ [(0,one,gr),(one, gr, 0),(gr, 0, one)]
| one <- [-1,1]
, gr <- [negate (1 + sqrt 5)/2, (1 + sqrt 5)/2 ]
]
icosohedronFaces :: [[Point3]]
icosohedronFaces = map orderFace $
rectEdgeFaces ++ map (map rotTrip) rectEdgeFaces ++ map (map (rotTrip . rotTrip)) rectEdgeFaces
++ addSym negFst (addSym negSnd $ addSym negThd rectCornFace)
where
rectEdgeFaces = addSym negThd $ addSym negFst rectEdgeFace
rectEdgeFace = [[ (gr,1,0) , (gr,negate 1,0) , (1,0,gr) ]]
rectCornFace = [[ (gr,1,0) , (0,gr,1) , (1,0,gr) ]]
addSym f faces = map (map f) faces ++ faces
negFst (x,y,z) = (negate x,y,z)
negSnd (x,y,z) = (x,negate y,z)
negThd (x,y,z) = (x,y,negate z)
rotTrip (x,y,z) = (z,x,y)
gr = (1 + sqrt 5) / 2 :: Float
orderFace ps = undefined orderAround3 ps
-- | Assuming that this works, note that it relies heavily on the ordering of
-- faces adjacent to a vertex (clockwise around the vertex)
-- and vertices on faces (anticlockwise around center of face).
truncate :: Ord a => VF a -> VF (a,a)
truncate vf = VF
{ _vertices = M.fromList . concatMap f $ M.toList vmap
}
where
vmap = _vertices vf
f (i, (pos, faces)) = map (g i pos faces) faces
g i pos faces (j:_) =
((i,j)
, (0.5 *.*.* (pos +.+.+ fst (vmap M.! j))
,truncFaces i j faces
)
)
g _ _ _ _ = undefined
truncFaces :: Eq a => a -> a -> [[a]] -> [[(a,a)]]
truncFaces v n vss =
[ reverse $ map ((v,) . head) (f1:fs)
, g (n:f0) ++ [(n,v)]
, (n,v) : g (f1 ++ [v])
]
where
(f0:f1:fs) = rotateTo ((== n) . head) vss
g (x:y:xs) = [(x,y),(y,x)] ++ g (y:xs)
g _ = []
rotateTo :: (a -> Bool) -> [a] -> [a]
rotateTo p xs = ys ++ zs
where
(zs,ys) = break p xs
facesToVF :: Ord a => [[a]] -> M.Map a [[a]]
facesToVF faces = foldr f M.empty vs
where
vs = nub $ concat faces
f v = M.insert v (g v)
g v = map (tail . rotateTo (== v)) $ filter (elem v) faces
--triPyramid :: VF
--triPyramid = VF
--dual :: VF a -> VF [a]
--dual vf =
src/Preload/Render.hs
+8 -1
View File
@@ -45,6 +45,7 @@ preloadRender = do
bezierQuadShader <- makeShader "twoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip pokeBezQStrat
cslist <- makeShader "twoD/character" [vert,frag] [3,4,2] ETriangles pokeCharStrat
>>= addTexture "data/texture/charMap.png"
basicTweakZShad <- makeShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles pokeTriTweakZ
-- texture shaders, no textures attached
fsShad <- makeShader "texture/simple" [vert,frag] [2,2] ETriangleStrip $ const cornerList
-- note we directly poke the shader vertex data here
@@ -75,7 +76,8 @@ preloadRender = do
clearColor $= Color4 0 0 0 1
return $ RenderData
{ _pictureShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
{ _pictureShaders =
[bslist,lslist,cslist,aslist,eslist,bezierQuadShader,basicTweakZShad]
, _lightingSurfaceShader = lightingSurfaceShad
, _lightingLineShadowShader = lightingLineShadowShad
, _lightingOccludeShader = wsShad
@@ -160,6 +162,11 @@ pokeBezQStrat (RenderBezQ vs) = fmap (\((x,y,z),(r,g,b,a),(s,t,u,v)) -> [x,y,z,r
vs
pokeBezQStrat _ = []
pokeTriTweakZ :: RenderType -> [[Float]]
pokeTriTweakZ (RenderPolyZ vs) = fmap (\(p,co,z) -> flat3 p ++ [z] ++ flat4 co) vs
pokeTriTweakZ _ = []
{-# INLINE pokeTriStrat #-}
pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeLineStrat,pokeEllStrat :: RenderType -> [[Float]]
pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> flat3 p ++ flat4 co) vs
src/Render.hs
+1 -2
View File
@@ -55,11 +55,10 @@ createLightMap
-> Int -- Resolution division
-> [(Point2,Point2)] -- Wall pairs
-> [(Point3,Float,Float)] -- Lights
-> (Float,Float) -- View from position
-> [Polyhedra] -- foreground geometry
-> [Point2]
-> IO ()
createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) fpics scPol = do
createLightMap pdata resDiv wallPoints lightPoints fpics scPol = do
-- get viewport size so we can reset it later
(vppos,vpsize) <- get viewport
-- set the viewport size to that of the render buffer