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

Refactor vao preload

Browse Source
This commit is contained in:
jgk
2021-02-19 12:41:46 +01:00
parent f4db9bf9a1
commit f6efe98181
16 changed files with 441 additions and 485 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+4 -3
View File
@@ -15,6 +15,7 @@ import Dodge.LoadSound
import Dodge.Update
import Dodge.KeyEvents
import Dodge.Rendering
import Dodge.Menu
import Picture
import Picture.Render
@@ -50,8 +51,8 @@ main = do
(initializeWorld $ generateFromTree lev1 $ initWorld)
(-- \((bs:fs:ts:_),tes) w -> --do render setparams w egFade
\preData w -> --do render setparams w egFade
--renderPicture' preData (polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)])
renderPicture' preData (draw blank w)
renderPicture' preData (_cameraZoom w) (_windowX w,_windowY w) (draw blank w)
--renderPicture' preData (_windowX w,_windowY w) (Circle 5)
-- renderPicture' preData
-- (pictures [scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]
-- ,scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]
@@ -59,6 +60,6 @@ main = do
-- ]
-- )
)
handleEvent
(flip $ menuEvents $ flip handleEvent)
(\w -> Just $ update w)
Mix.closeAudio
package.yaml
+1
View File
@@ -41,6 +41,7 @@ dependencies:
- dlist
- deepseq
- transformers
- foldl
library:
source-dirs: src
src/Dodge/Base.hs
+13 -1
View File
@@ -422,6 +422,18 @@ lineOfThickness t = pictures . f
f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
lineGeom :: Float -> Point2 -> Point2 -> [Point2]
lineGeom t x y
| x == y = []
| otherwise = [x +.+ n x y, x -.- n x y, y +.+ n x y, y -.- n x y]
where n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
wedgeGeom :: Float -> Point2 -> Point2 -> [Point2]
wedgeGeom t x y
| x == y = []
| otherwise = [x +.+ n x y, x -.- n x y, y]
where n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
wedgeOfThickness t x y
| x == y = blank
@@ -701,7 +713,7 @@ onLayer l = setDepth (fromIntegral (levLayer l) / 100)
--onLayer l p = [(p, [levLayer l])]
onLayerL :: [Int] -> Picture -> Picture
onLayerL is = setDepth (sum $ zipWith (/) (map fromIntegral is) $ map (\x->100**x) [1..])
onLayerL is = setDepth ((sum $ zipWith (/) (map fromIntegral is) $ map (\x->100**x) [1..]))
levLayer :: Layer -> Int
levLayer BgLayer = 20
src/Dodge/Critters.hs
+1 -2
View File
@@ -342,7 +342,7 @@ goalPict cr = let r = _crRad cr in case _crState cr of
(SubPathTo p i _:_) -> dGoals $ sizeColEnemy r blue
(Search i:_) -> dGoals $ sizeColEnemy r black
_ -> dGoals $ sizeColEnemy r magenta
where dGoals p = pictures [p, rotate (radToDeg (_crDir cr)) $ scale 0.1 0.1 $ color white $ text $ show gls]
where dGoals p = pictures [p, rotate (0 - _crDir cr) $ scale 0.1 0.1 $ color white $ text $ show gls]
_ -> sizeColEnemy r (light $ dim green)
startCr :: Creature
@@ -395,5 +395,4 @@ basicCrPict col cr = pictures [ onLayer CrLayer naked , drawEquipment cr]
-- | crDam > _crHP cr && odd (crDam - _crHP cr)
-- = [color white $ circleSolid $ _crRad cr]
| otherwise = pictures [color col $ circleSolid $ _crRad cr, circLine $ _crRad cr]
-- , rotate (radToDeg $ _crDir cr) $ scale 0.2 0.2 $ color white $ text $ show $ _crPos cr
pdam = _crPastDamage $ _crState cr
src/Dodge/Data.hs
+1
View File
@@ -242,6 +242,7 @@ data MenuState
| PauseMenu
| GameOverMenu
| InGame
deriving (Eq,Ord)
data Sound = Sound { _soundTime :: Int
, _soundFadeTime :: Int
src/Dodge/LevelGen.hs
+1 -1
View File
@@ -750,7 +750,7 @@ placeLS ls dec p rot w = over lightSources addLS
(ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss})
lss
addDec decs = IM.insert (newKey decs)
(uncurry translate p $ rotate (radToDeg rot) dec)
(uncurry translate p $ rotate (0 - rot) dec)
decs
src/Dodge/Rendering.hs
+22 -20
View File
@@ -51,7 +51,7 @@ draw'' b w-- | (Char 'm') `S.member` _keys w
= case _mapDisplay w of
(True, z) -> (blank
,pictures [color white $ circleSolid 3
,scale z z $ rotate (radToDeg (_cameraRot w))
,scale z z $ rotate (0 - (_cameraRot w))
$ uncurry translate ((0,0) -.- _cameraCenter w)
$ pictures $ mapMaybe mapWall $ IM.elems $ _walls w]
)
@@ -68,7 +68,7 @@ draw'' b w-- | (Char 'm') `S.member` _keys w
x2 = (x''+1)
y1 = (y''-1)
y2 = (y''+1)
screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
screenShift = scale zoom zoom . rotate (0 - (_cameraRot w) )
. uncurry translate ((0,0) -.- _cameraPos w)
zoom = _cameraZoom w
pathsTest = map drawPair $ _pathGraph' w
@@ -100,7 +100,7 @@ collectDrawings w = pictures
]
-- <> [onLayer GloomLayer $ theLighting w]
where
screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
screenShift = scale zoom zoom . rotate (0 - (_cameraRot w) )
. uncurry translate ((0,0) -.- _cameraPos w)
zoom = _cameraZoom w
decPicts = IM.elems $ _decorations w
@@ -127,12 +127,13 @@ collectDrawings w = pictures
menuScreen = case _menuState w of
InGame -> blank
LevelMenu x ->
pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 ("LEVEL "++show x)
pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w
tst (-100) 100 0.4 ("LEVEL "++show x)
,controlsList
]
PauseMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 "PAUSED"
PauseMenu -> pictures
[--color (withAlpha 0.5 black) $ polygon $ screenBox w
tst (-100) 100 0.4 "PAUSED"
,tst (-100) 50 0.2 "n - new level"
,tst (-100) 0 0.2 "r - restart"
, controlsList
@@ -157,11 +158,11 @@ hudDrawings w = (onLayer InvLayer)
where itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
crDraw :: Creature -> Drawing
crDraw c = uncurry translate (_crPos c) $ rotateRad (_crDir c) (_crPict c c)
crDraw c = uncurry translate (_crPos c) $ rotate (_crDir c) (_crPict c c)
ppDraw :: PressPlate -> Drawing
ppDraw c = uncurry translate (_ppPos c) $ rotateRad (_ppRot c) (_ppPict c)
ppDraw c = uncurry translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
btDraw :: Button -> Drawing
btDraw c = uncurry translate (_btPos c) $ rotateRad (_btRot c) (_btPict c)
btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c)
clDraw :: Cloud -> Drawing
clDraw c = uncurry translate (_clPos c) $ (_clPict c c)
@@ -171,6 +172,7 @@ drawCursor w = translate (105-halfWidth w)
(halfHeight w - (25* (fromIntegral iPos)) - 20
)
-- $ rectangleWire 200 25
$ color white
$ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)]
where iPos = _crInvSel $ _creatures w IM.! _yourID w
@@ -242,7 +244,7 @@ drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps,
pb p' = p' -.- orth p'
pao p' = pa p' +.+ l *.* safeNormalizeV (pa p' -.- _cameraCenter w)
pbo p' = pb p' +.+ l *.* safeNormalizeV (pb p' -.- _cameraCenter w)
semiCirc p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r
semiCirc p' = uncurry translate p' $ rotate (0 - (a p')) $ arcSolid 0 180 r
a p' = pi - argV (orth p')
trap p' = polygon [pa p', pb p', pbo p', pao p']
f p' = [semiCirc p', trap p']
@@ -256,7 +258,7 @@ drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps,
pao' p' = pa' p' +.+ l *.* safeNormalizeV (pa' p' -.- _cameraCenter w)
pbo' p' = pb' p' +.+ l *.* safeNormalizeV (pb' p' -.- _cameraCenter w)
trap' p' = line [pa' p', pb' p', pbo' p', pao' p',pa' p']
semiCirc' p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r'
semiCirc' p' = uncurry translate p' $ rotate (0 - (a p')) $ arcSolid 0 180 r'
drawWall :: Wall -> Drawing
@@ -283,7 +285,7 @@ printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.0
printRotPoint :: Float -> Point2 -> Picture
printRotPoint r p = color white $ uncurry translate p $ pictures [circle 3
, rotate r $ scale 0.1 0.1 $ text (show p)]
, rotate (0 - r) $ scale 0.1 0.1 $ text (show p)]
outsideScreenPolygon :: World -> [Point2]
outsideScreenPolygon w = [tr,tl,bl,br]
@@ -390,42 +392,42 @@ drawButText :: World -> Button -> Picture
drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100
&& hasLOS (_btPos bt) (_crPos (you w)) w
&& _btState bt /= BtNoLabel
= t $ rotate (radToDeg (-_cameraRot w))
= t $ rotate (_cameraRot w)
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
$ scale 0.1 0.1 $ text $ _btText bt
]
| otherwise = blank
where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w))
where t = rotate (0 - (_cameraRot w)) . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w))
zoom = _cameraZoom w
scLine = dShadCol white . line . fmap (sqrt zoom *.*)
drawPPText :: World -> PressPlate -> Picture
drawPPText w pp | magV (_crPos (you w) -.- _ppPos pp) < 100
&& hasLOS (_ppPos pp) (_crPos (you w)) w
= t $ rotate (radToDeg (-_cameraRot w))
= t $ rotate (_cameraRot w)
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
$ scale 0.1 0.1 $ text $ _ppText pp
]
| otherwise = blank
where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_ppPos pp -.- _cameraPos w))
where t = rotate (0 - (_cameraRot w)) . uncurry translate (zoom *.* (_ppPos pp -.- _cameraPos w))
zoom = _cameraZoom w
scLine = dShadCol white . line . fmap (sqrt zoom *.*)
drawItemName :: World -> FloorItem -> Picture
drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100
&& hasLOS (_flItPos flIt) (_crPos (you w)) w
= t $ rotate (radToDeg (-_cameraRot w))
= t $ rotate (_cameraRot w)
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
$ scale 0.1 0.1 $ text $ nameOfItem
]
| otherwise = blank
where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w))
where t = rotate (0 - (_cameraRot w)) . uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w))
nameOfItem = case flIt of FlIt {} -> _itName $ _flIt flIt
FlAm {_flAm = PistolBullet} -> "Bullets"
FlAm {_flAm = LiquidFuel} -> "Liquid Fuel"
@@ -472,7 +474,7 @@ drawFF (FF {_ffLine = l, _ffColor = col}) = pictures [color white $ line l, colo
drawFFShadow :: World -> ForceField -> [Picture]
drawFFShadow w ff
| youOnFF = []
| otherwise = map (rotate (radToDeg (- _cameraRot w)) . pane)
| otherwise = map (rotate ( _cameraRot w) . pane)
[0,0.05..0.25]
where p = rotateV (-_cameraRot w) $ ypShift
x = rotateV (-_cameraRot w) x'
src/Dodge/Update.hs
+7 -4
View File
@@ -22,7 +22,10 @@ import Control.Lens
-- }}}
update :: World -> World
update w = let w1 = updateParticles' $ updateParticles
update w
| _menuState w /= InGame = w
| otherwise =
let w1 = updateParticles' $ updateParticles
$ updateLightSources
$ zoneClouds
$ updateClouds
@@ -31,16 +34,16 @@ update w = let w1 = updateParticles' $ updateParticles
$ updateBlocks -- $ zoning
$ updateSeenWalls
w
w2 = -- updateWeaponCounters $
w2 = -- updateWeaponCounters $
simpleCrSprings
$ zoneCreatures $ wallEvents
$ set worldEvents id $ _worldEvents w1
w1
w3 = updateCamera
w3 = updateCamera
$ updateAfterParticles'
$ colCrsWalls
w2
in checkEndGame $ ppEvents w3
in checkEndGame $ ppEvents w3
where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
-- w
-- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
src/Dodge/Weapons.hs
+68 -67
View File
@@ -45,7 +45,7 @@ pistol,lasGun,tractorGun,launcher,autoGun
,longGun,flamer,blinkGun,forceFieldGun :: Item
pistol = Weapon
{ _itName = "pistol"
{ _itName = "PISTOL"
, _itIdentity = Pistol
, _wpMaxAmmo = 15
, _wpLoadedAmmo = 15
@@ -101,7 +101,7 @@ autoEffectGun name eff = autoGun
}
autoGun = defaultGun
{ _itName = "autoGun .........."
{ _itName = "AUTOGUN AUTO"
, _itIdentity = AutoGun
, _wpMaxAmmo = 30
, _wpLoadedAmmo = 30
@@ -142,12 +142,12 @@ incMode :: Int -> World -> World
incMode _ w
= case newMode of
0 -> w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode .~ 0
& creatures . ix 0 . crInv . ix itRef . itName .~ "autoGun .........."
& creatures . ix 0 . crInv . ix itRef . itName .~ "AUTOGUN AUTO"
& creatures . ix 0 . crInv . ix itRef . itHammer .~ NoHammer
& creatures . ix 0 . crInv . ix itRef . itEffect .~ NoItEffect
& creatures . ix 0 . crInv . ix itRef . wpFire .~ autoFireMode
1 -> w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode .~ 1
& creatures . ix 0 . crInv . ix itRef . itName .~ "autoGun ."
& creatures . ix 0 . crInv . ix itRef . itName .~ "AUTOGUN SINGLE"
& creatures . ix 0 . crInv . ix itRef . itHammer .~ HammerUp
& creatures . ix 0 . crInv . ix itRef . itEffect .~ wpRecock
& creatures . ix 0 . crInv . ix itRef . wpFire .~ singleFireMode
@@ -157,17 +157,17 @@ incMode _ w
f x = mod (x+1) 2
decMode :: Int -> World -> World
decMode _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode %~ f
& creatures . ix 0 . crInv . ix itRef . itName .~ "autoGun" ++ g newMode
& creatures . ix 0 . crInv . ix itRef . itName .~ "AUTOGUN" ++ g newMode
where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel
oldMode = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode
newMode = fromMaybe 1 $ fmap f oldMode
f x = mod (x-1) 2
g 1 = " ."
g 2 = " ..."
g 0 = " .........."
g 1 = " SINGLE"
g 2 = " BURST"
g 0 = " AUTO"
rezGun = defaultGun
{ _itName = "reanimator"
{ _itName = "REANIMATOR"
, _wpMaxAmmo = 50
, _wpLoadedAmmo = 50
, _wpAmmoType = Battery
@@ -191,7 +191,7 @@ rezGun = defaultGun
]
}
teslaGun = autoGun
{ _itName = "teslaGun"
{ _itName = "TESLAGUN"
, _itIdentity = TeslaGun
, _wpMaxAmmo = 200
, _wpLoadedAmmo = 200
@@ -217,7 +217,7 @@ teslaGun = autoGun
]
}
lasGun = autoGun
{ _itName = "lasGun ////"
{ _itName = "LASGUN ////"
, _itIdentity = LasGun
, _wpMaxAmmo = 200
, _wpLoadedAmmo = 200
@@ -241,7 +241,7 @@ lasGun = autoGun
}
incPhaseV :: Int -> World -> World
incPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV %~ f
& creatures . ix 0 . crInv . ix itRef . itName .~ "lasGun" ++ g newPhaseV
& creatures . ix 0 . crInv . ix itRef . itName .~ "LASGUN" ++ g newPhaseV
where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel
oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV
newPhaseV = fromMaybe 1 $ fmap f oldPhaseV
@@ -257,7 +257,7 @@ incPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just .
g 5 = " \\\\//"
decPhaseV :: Int -> World -> World
decPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV %~ f
& creatures . ix 0 . crInv . ix itRef . itName .~ "lasGun" ++ g newPhaseV
& creatures . ix 0 . crInv . ix itRef . itName .~ "LASGUN" ++ g newPhaseV
where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel
oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV
newPhaseV = fromMaybe 1 $ fmap f oldPhaseV
@@ -272,7 +272,7 @@ decPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just .
g 2 = " \\///"
g 5 = " \\\\//"
forceFieldGun = defaultGun
{ _itName = "forceField"
{ _itName = "FORCEFIELD"
, _itIdentity = ForceFieldGun
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
@@ -311,7 +311,7 @@ forceFieldGun = defaultGun
-- , _itAimingRange = 0.5
-- }
tractorGun = autoGun
{ _itName = "tractorGun"
{ _itName = "TRACTORGUN"
, _itIdentity = TractorGun
, _wpMaxAmmo = 10000
, _wpLoadedAmmo = 10000
@@ -331,7 +331,7 @@ tractorGun = autoGun
, _itEquipPict = drawWeapon $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ]
}
launcher = defaultGun
{ _itName = "launcher"
{ _itName = "lAUNCHER"
, _itIdentity = Launcher
, _wpMaxAmmo = 30
, _wpLoadedAmmo = 30
@@ -353,7 +353,7 @@ launcher = defaultGun
, _itEffect = NoItEffect
}
remoteLauncher = defaultGun
{ _itName = "remoteLauncher"
{ _itName = "REMOTELAUNCHER"
, _itIdentity = RemoteLauncher
, _wpMaxAmmo = 1
, _wpLoadedAmmo = 1
@@ -374,7 +374,7 @@ remoteLauncher = defaultGun
, _itAttachment = Just $ ItScope (0,0) 0 1 True
}
hvAutoGun = autoGun
{ _itName = "hvMachineGun"
{ _itName = "HVMACHINEGUN"
, _itIdentity = HvAutoGun
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
@@ -401,7 +401,7 @@ hvAutoGun = autoGun
hvBulHitCr' hvBulHitWall' bulHitFF'
ltAutoGun = autoGun
{ _itName = "autoPistol"
{ _itName = "AUTOPISTOL"
, _itIdentity = LtAutoGun
, _wpMaxAmmo = 25
, _wpLoadedAmmo = 25
@@ -426,7 +426,7 @@ ltAutoGun = autoGun
]
}
miniGun = autoGun
{ _itName = "miniGun"
{ _itName = "MINIGUN"
, _itIdentity = MiniGun
, _wpMaxAmmo = 150
, _wpLoadedAmmo = 150
@@ -447,7 +447,7 @@ miniGun = autoGun
, _itEquipPict = drawWeapon $ color red $ polygon $ rectNESW 9 5 (-9) (-5)
}
spreadGun = defaultGun
{ _itName = "spreadgun"
{ _itName = "SPREADGUN"
, _itIdentity = SpreadGun
, _wpMaxAmmo = 5
, _wpLoadedAmmo = 5
@@ -491,7 +491,7 @@ spreadGun = defaultGun
-- , _itAimingRange = 0.5
-- }
multGun = defaultGun
{ _itName = "multGun"
{ _itName = "MULTGUN"
, _itIdentity = MultGun
, _wpMaxAmmo = 2
, _wpLoadedAmmo = 2
@@ -522,7 +522,7 @@ multGun = defaultGun
, polygon [(-1.5,12),(-2,12),(-2,-12),(-1.5,-12)]
]
longGun = defaultGun
{ _itName = "elephantGun"
{ _itName = "ELEPHANTGUN"
, _itIdentity = LongGun
, _wpMaxAmmo = 1
, _wpLoadedAmmo = 1
@@ -563,7 +563,7 @@ startZoomOutLongGun _ w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatu
poisonSprayer = autoGun
{ _itName = "poisonSprayer"
{ _itName = "POISONSPRAYER"
, _itIdentity = PoisonSprayer
, _wpMaxAmmo = 500
, _wpLoadedAmmo = 500
@@ -585,7 +585,7 @@ poisonSprayer = autoGun
}
flamer = autoGun
{ _itName = "flamethrower"
{ _itName = "FLAMETHROWER"
, _itIdentity = Flamethrower
, _wpMaxAmmo = 250
, _wpLoadedAmmo = 250
@@ -609,7 +609,7 @@ flamer = autoGun
, _itAttachment = Nothing
}
blinkGun = defaultGun
{ _itName = "blinker"
{ _itName = "BLINKER"
, _itIdentity = Blinker
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
@@ -804,11 +804,11 @@ moveShell time i cid rot accel w
(moveShell (time-1) i cid rot (rotateV rot accel))
$ over (particles . ix i . ptVel) (\v -> accel +.+ frict *.* v)
$ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250
$ smokeGen
$ makeFlameletTimed oldPos
(0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20
$ makeFlameletTimed (0.5 *.* (newPos +.+ oldPos))
(0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20
$ smokeGen
w
| time > -200 = case thingHit of
Just p -> shellExplosionAt oldPos
@@ -829,9 +829,9 @@ moveShell time i cid rot accel w
(frict,g) = randomR (0.6,0.9) $ _randGen w
(sparkD,_) = randomR (-0.5,0.5) $ _randGen w
dir = argV $ vel
pic = onLayer PtLayer $ uncurry translate newPos $ rotate (-radToDeg (argV accel)) shellPic
pic = onLayer PtLayer $ uncurry translate newPos $ rotate (argV accel) shellPic
piclow = onLayerL [levLayer CrLayer - 2]
$ uncurry translate newPos $ rotate (-radToDeg (argV accel)) shellPic
$ uncurry translate newPos $ rotate (argV accel) shellPic
hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w
hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w
thingHit = hitCr <|> hitWl
@@ -1018,24 +1018,24 @@ moveFlame rotd w pt =
damcr cr p = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ Flaming (div time 10) sp p ep)
hiteff = _btHitEffect' pt pt
thepic p' = pictures [ pic p' , piu p' , pi2 p' , glow p' ]
thepic p' = pictures $ reverse [ pic p' , piu p' , pi2 p' , glow p' ]
pic p' = onLayerL [levLayer UPtLayer,6] $ uncurry translate (prot3 p')
$ rotate (90 + (negate $ radToDeg $ argV rotd))
$ rotate (pi * 0.5 + argV rotd)
$ scale scaleChange 1
-- $ color white
-- $ circleSolid 5
$ pictures [color white $ circleSolid 4
$ pictures $ reverse [color white $ circleSolid 4
,color (withAlpha 0.5 white) $ circleSolid 5
]
-- $ rotate (radToDeg (fromIntegral time * 10))
-- $ polygon [(-5,-2),(5,-2),(5,2),(-5,2)]
pi2 p' = onLayerL [levLayer UPtLayer,4] $ uncurry translate (prot p')
-- $ rotate ( (fromIntegral time * 5))
$ rotate (90 + (negate $ radToDeg $ argV rotd))
$ rotate (pi * 0.5 + argV rotd)
-- $ color (mixColors 0.5 0.5 orange white)
-- $ polygon [(-6,-6),(6,-6),(6,6),(-6,6)]
$ scale (scaleChange + 0.5) 1.5
$ pictures [color orange $ circleSolid 4.5
$ pictures $ reverse [color orange $ circleSolid 4.5
,color (withAlpha 0.5 orange) $ circleSolid 5
]
-- $ color orange
@@ -1044,10 +1044,10 @@ moveFlame rotd w pt =
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time * 1) (0,1)
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2)
piu p' = onLayerL [levLayer UPtLayer,2] $ uncurry translate (prot2 p')
$ rotate (90 + (negate $ radToDeg $ argV rotd))
$ rotate (pi*0.5 + argV rotd)
-- $ rotate ((fromIntegral time * (-10)))
$ scale (scaleChange + 1) 2
$ pictures [color red $ circleSolid 4.5
$ pictures $ reverse [color red $ circleSolid 4.5
,color (withAlpha 0.5 red) $ circleSolid 5
]
-- $ color (dark red)
@@ -1697,7 +1697,7 @@ grenadeLauncher = pistol
grenade,remoteBomb :: Item
grenade = Throwable
{ _itName = "grenade " ++ show fuseTime
{ _itName = "GRENADE " ++ show fuseTime
, _itIdentity = Grenade
, _itMaxStack = 8
, _itAmount = 1
@@ -1724,7 +1724,7 @@ increaseFuse :: Int -> Int -> World -> World
increaseFuse fuse i w = w & creatures . ix 0 . crInv . ix itRef . itScrollUp .~ decreaseFuse newTime
& creatures . ix 0 . crInv . ix itRef . itScrollDown .~ increaseFuse newTime
& creatures . ix 0 . crInv . ix itRef . twFire .~ throwGrenade newTime
& creatures . ix 0 . crInv . ix itRef . itName .~ "grenade " ++ show newTime
& creatures . ix 0 . crInv . ix itRef . itName .~ "GRENADE " ++ show newTime
& creatures . ix 0 . crInv . ix itRef . itAttachment .~ Just (ItFuse newTime)
& creatures . ix 0 . crInv . ix itRef . itZoom
.~ (basicItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm})
@@ -1736,7 +1736,7 @@ decreaseFuse :: Int -> Int -> World -> World
decreaseFuse fuse i w = w & creatures . ix 0 . crInv . ix itRef . itScrollUp .~ decreaseFuse newTime
& creatures . ix 0 . crInv . ix itRef . itScrollDown .~ increaseFuse newTime
& creatures . ix 0 . crInv . ix itRef . twFire .~ throwGrenade newTime
& creatures . ix 0 . crInv . ix itRef . itName .~ "grenade " ++ show newTime
& creatures . ix 0 . crInv . ix itRef . itName .~ "GRENADE " ++ show newTime
& creatures . ix 0 . crInv . ix itRef . itAttachment .~ Just (ItFuse newTime)
& creatures . ix 0 . crInv . ix itRef . itZoom
.~ (basicItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm})
@@ -1746,7 +1746,7 @@ decreaseFuse fuse i w = w & creatures . ix 0 . crInv . ix itRef . itScrollUp .~
defaultThrowable = grenade
remoteBomb = defaultThrowable
{ _itName = "remoteBomb"
{ _itName = "REMOTEBOMB"
, _itIdentity = RemoteBomb
, _itMaxStack = 1
, _itAmount = 1
@@ -1783,7 +1783,7 @@ throwGrenade fuseTime n w = setWp $ removePict $ over particles addG $ set randG
p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0)
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0)
| otherwise = p'
dir = negate $ radToDeg $ argV $ v
dir = argV v
setWp :: World -> World
setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20
--maybewpid = w ^? creatures . ix n . crInv . ix j . itID . _Just
@@ -1814,7 +1814,7 @@ grenadePic x = pictures [ color (dark $ dark green) $ circleSolid 5
((179 * fromIntegral x / 50) - 180 )
(180 - (179 * fromIntegral x / 50) )
5
, translate (-2) 2 $ rotate 90
, translate (-2) 2 $ rotate (pi*0.5)
$ scale 0.05 0.05 $ color green $ text $ show $ 1 + quot x 20
]
@@ -1838,7 +1838,7 @@ fireRemoteLauncher cid w = setLocation $ resetFire $ resetName
newitid = newKey $ _itemPositions w
maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just
resetFire = set (creatures . ix cid . crInv . ix j . wpFire) $ explodeRemoteRocket itid i
resetName = set (creatures . ix cid . crInv . ix j . itName) "remoteRocket"
resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTEROCKET"
setLocation :: World -> World
setLocation w' = case maybeitid of
Nothing -> w' & creatures . ix cid . crInv . ix j . itID .~ Just newitid
@@ -1910,9 +1910,9 @@ moveRemoteShell time i cid itid dir w
(sparkD,_) = randomR (-0.5,0.5) $ _randGen w
dir = argV $ vel
pic = onLayer PtLayer $ uncurry translate newPos
$ rotate (-radToDeg (argV accel)) $ remoteShellPic time
$ rotate (argV accel) $ remoteShellPic time
piclow = onLayerL [levLayer CrLayer - 2]
$ uncurry translate newPos $ rotate (-radToDeg (argV accel))
$ uncurry translate newPos $ rotate (argV accel)
$ remoteShellPic time
hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w
hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w
@@ -1924,8 +1924,9 @@ moveRemoteShell time i cid itid dir w
(s1:s2:s3:_) = map (\s -> fromIntegral s * 0.1 - 1) (t3:t2:t1:[])
-- ((r1:r2:r3:_),_) = runState ((sequence . repeat . randInCirc) 10) $ _randGen w
-- v1 = fst $ runState (randInCirc 0.5) $ _randGen w
smokeGen = makeSmokeAt'' v1 s1 t1 (newPos +.+ r1)
. makeSmokeAt'' v2 s2 t2 (newPos +.+ r2)
smokeGen = makeSmokeAt'' v2 s2 t2 (newPos +.+ r2)
. makeSmokeAt'' v1 s1 t1 (newPos +.+ r1)
-- . makeSmokeAt'' v3 s3 t3 (newPos +.+ r3)
doExplosion = explodeRemoteRocket itid i cid
setScope w' = case _itemPositions w' IM.! itid of
@@ -1943,7 +1944,7 @@ explodeRemoteRocket itid ptid n w
-- $ resetScope
$ makeExplosionAt (_ptPos (_particles w IM.! ptid)) w
-- $ makeShrapnelBombAt (_ptPos (_particles w IM.! ptid)) w
where resetName = set (itPoint . itName) "remoteLauncher"
where resetName = set (itPoint . itName) "REMOTELAUNCHER"
-- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0)
itPoint = pointToItem $ _itemPositions w IM.! itid
@@ -1968,7 +1969,7 @@ throwRemoteBomb n w = setLocation $ removePict $ resetFire
v | magV v' > 6 = 6 *.* normalizeV v'
-- zoom = 1 / _cameraZoom w
j = _crInvSel $ _creatures w IM.! n
resetName = set (creatures . ix n . crInv . ix j . itName) "remote"
resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTE"
removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank
resetFire = set (creatures . ix n . crInv . ix j . twFire) $ explodeRemoteBomb itid i
cr = _creatures w IM.! n
@@ -1995,19 +1996,19 @@ explodeRemoteBomb itid ptid n w
-- $ resetScope
$ makeExplosionAt (_ptPos (_particles w IM.! ptid)) w
-- $ makeShrapnelBombAt (_ptPos (_particles w IM.! ptid)) w
where resetName = set (creatures . ix n . crInv . ix j . itName) "remoteBomb"
where resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTEBOMB"
resetPict = set (creatures . ix n . crInv . ix j . itEquipPict )
(drawWeapon $ remoteBombUnarmedPic)
-- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0)
j = _crInvSel $ _creatures w IM.! n
remoteBombPic :: Int -> Picture
remoteBombPic x = pictures [ color (dark $ dark orange) $ circleSolid 5
, rotate (fromIntegral x * 10 + 45) $ color red $ arc 0 90 5
, rotate (fromIntegral x * 10 + 45) $ color (withAlpha 0.05 red)
, rotate (0 - degToRad (fromIntegral x * 10 + 45)) $ color red $ arc 0 90 5
, rotate (0 - degToRad (fromIntegral x * 10 + 45)) $ color (withAlpha 0.05 red)
$ arcSolid 0 90 50
, rotate (fromIntegral x * 10 + 20) $ color (withAlpha 0.05 red)
, rotate (0 - degToRad (fromIntegral x * 10 + 20)) $ color (withAlpha 0.05 red)
$ arcSolid 0 40 40
, rotate (fromIntegral x * 10 + 10) $ color (withAlpha 0.05 red)
, rotate (0 - degToRad (fromIntegral x * 10 + 10)) $ color (withAlpha 0.05 red)
$ arcSolid 0 20 20
]
remoteBombUnarmedPic :: Picture
@@ -2027,7 +2028,7 @@ drawWeapon p cr posInInv
medkit :: Int -> Item
medkit i = basicConsumable
{ _itIdentity = Medkit25
, _itName = "medkit" ++ show i
, _itName = "MEDKIT" ++ show i
, _itMaxStack = 9
, _itAmount = 1
, _cnEffect = heal i
@@ -2328,7 +2329,7 @@ autogunSpread = 0.07
medkit25,pipe,magShield :: Item
medkit25 = basicConsumable
{ _itIdentity = Medkit25
, _itName = "medkit25"
, _itName = "MEDKIT25"
, _itMaxStack = 3
, _itAmount = 2
, _cnEffect = heal25
@@ -2337,7 +2338,7 @@ medkit25 = basicConsumable
}
pipe = Craftable
{ _itIdentity = Generic
, _itName = "pipe"
, _itName = "PIPE"
, _itMaxStack = 3
, _itAmount = 3
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2348,7 +2349,7 @@ pipe = Craftable
}
magShield = basicEquipment
{ _itIdentity = MagShield
, _itName = "magshield"
, _itName = "MAGSHIELD"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2357,7 +2358,7 @@ magShield = basicEquipment
}
flameShield = basicEquipment
{ _itIdentity = FlameShield
, _itName = "flameShield"
, _itName = "FLAMESHIELD"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2368,7 +2369,7 @@ flameShield = basicEquipment
}
frontArmour = basicEquipment
{ _itIdentity = FrontArmour
, _itName = "frontArmour"
, _itName = "FRONTARMOUR"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ translate 0 (-5) $ pictures [color (greyN 0.1) $ thickArc 0 90 10 5
@@ -2384,7 +2385,7 @@ frontArmour = basicEquipment
}
jetPack = basicEquipment
{ _itIdentity = JetPack
, _itName = "JetPack"
, _itName = "JETPACK"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2399,11 +2400,11 @@ jetPack = basicEquipment
latchkey :: Int -> Item
latchkey n = basicEquipment
{ _itIdentity = Generic
, _itName = "key "++show n
, _itName = "KEY "++show n
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ latchkeyPic
, _itEquipPict = \cr _ -> onLayer PtLayer $ translate (-5) (-5) $ rotate 50 latchkeyPic
, _itEquipPict = \cr _ -> onLayer PtLayer $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic
, _itEffect = NoItEffect
, _itHammer = HammerUp
, _itID = Nothing
@@ -2549,7 +2550,7 @@ shakeCr cID amount w =
radar = defaultGun
{ _itName = "radar"
{ _itName = "RADAR"
, _itIdentity = Generic
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
@@ -2571,7 +2572,7 @@ radar = defaultGun
}
sonar = defaultGun
{ _itName = "sonar"
{ _itName = "SONAR"
, _itIdentity = Generic
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
@@ -2678,7 +2679,7 @@ mvRadar x p w pt = (putBlips w, Just $ pt {_ptPict' = pic
autoSonar = basicEquipment
{ _itIdentity = Generic
, _itName = "autoSonar"
, _itName = "AUTOSONAR"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2691,7 +2692,7 @@ autoSonar = basicEquipment
}
autoRadar = basicEquipment
{ _itIdentity = Generic
, _itName = "autoRadar"
, _itName = "AUTORADAR"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
src/Dodge/WorldActions.hs
+38 -36
View File
@@ -482,10 +482,9 @@ crGlareWidth wdth col alphay p cr =
)
}
where l x = uncurry translate x
$ rotate (90 - (radToDeg $ argV (p -.- x)))
$ rotate (pi*0.5 + argV (p -.- x))
$ color (withAlpha alphay col)
$ thickArc 0 180 (_crRad cr) wdth
-- where l = rotate (radToDeg $ argV (cp -.- p)) $ uncurry translate cp $ color (withAlpha 0.5 white) $ thickArc 0 25 (_crRad cr) 5
cp = _crPos cr
cid = _crID cr
upp cid' w' = case w' ^? creatures . ix cid . crPos of
@@ -597,38 +596,37 @@ mvGenBullet' w bt
t = _btTimer' bt
bulLine :: Color -> Float -> [Point2] -> Drawing
bulLine col width (a:b:[])
bulLine _ _ [] = blank
bulLine _ _ (x:[]) = blank
bulLine col width (a:b:[]) -- (a:b:[])
= onLayer HPtLayer $ pictures
[color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b]
,color white $ wedgeOfThickness width a b
-- ,color white $ lineOfThickness width [a,b]
-- ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b]
-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
[polygonCol $ zip (wedgeGeom width b a) $ [white,withAlpha 0 white,withAlpha 0 white]
,polygonCol $ zip (lineGeom (width+1.5) a b) $ [col,col,withAlpha 0 col,withAlpha 0 col]
]
-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b)
-- a3 = (0.3 *.* a) +.+ (0.7 *.* b)
bulLine col width (a:b:c:_)
bulLine col width (a:b:c:[]) -- (a:b:[])
= onLayer HPtLayer $ pictures
[color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c]
,color white $ wedgeOfThickness width a c
-- ,color white $ lineOfThickness width [a,b]
-- ,color (withAlpha 0.3 white) $ lineOfThickness (width-1) [a3,c]
-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
-- ,color white $ lineOfThickness width [a,a2]
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
]
-- where a2 = b
-- a3 = (0.5 *.* b) +.+ (0.5 *.* c)
-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b)
-- a3 = (0.3 *.* a) +.+ (0.7 *.* b)
--bulLine col width (a:b:c:d:_)
bulLine col width (a:b:_:c:[]) -- (a:b:[])
= onLayer HPtLayer $ pictures
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
]
bulLine col width (a:b:_:_:c:_) -- (a:b:[])
= onLayer HPtLayer $ pictures
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
]
-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b]
-- ,color white $ wedgeOfThickness width a b
--bulLine col width (a:b:c:_)
-- = onLayer HPtLayer $ pictures
-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1) [a,c]
-- ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b]
-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
-- ,color white $ lineOfThickness width [a,a2]
-- ]
-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b)
-- a3 = (0.3 *.* a) +.+ (0.7 *.* b)
-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c]
-- ,color white $ wedgeOfThickness width a c
thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World
-> [(Point2, (Either3 Creature Wall ForceField))]
@@ -735,11 +733,11 @@ moveFlamelet levelInt rot w pt =
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
white (dark red)
)
$ rotate (radToDeg ( 0.1 * fromIntegral time + rot))
$ rotate (0 - ( 0.1 * fromIntegral time + rot))
$ scale sc sc
$ polygon [(-size,-size),(size,-size),(size,size),(-size,size)]
piu = onLayerL [levelInt,1] $ uncurry translate ep
$ color (dark red) $ rotate (radToDeg (rot - 0.1 * fromIntegral time))
$ color (dark red) $ rotate (0 - (rot - 0.1 * fromIntegral time))
$ scale s1 s1
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
glow = onLayerL [levelInt,0] $ uncurry translate ep
@@ -753,7 +751,7 @@ moveFlamelet levelInt rot w pt =
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red)
)
$ rotate (radToDeg $ rot + 0.2 * fromIntegral time)
$ rotate (0 - (rot + 0.2 * fromIntegral time))
$ scale s2 s2
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
@@ -822,7 +820,8 @@ moveSmoke' scal p time i
makeSmokeAt'' :: Point2 -> Float -> Int -> Point2 -> World -> World
makeSmokeAt'' vel scal time p w = over particles' ((:) smokeP) w
where smokeP = Particle'
{ _ptPict' = onLayerL [levLayer PtLayer - 1] $ uncurry translate p $ color black $ circleSolid 1
--{ _ptPict' = onLayerL [levLayer PtLayer - 1] $ uncurry translate p $ color black $ circleSolid 1
{ _ptPict' = onLayerL [levLayer PtLayer ] $ uncurry translate p $ color black $ circleSolid 1
, _ptUpdate' = moveSmoke'' scal time p vel
}
@@ -836,15 +835,18 @@ moveSmoke'' scal time p vel w pt
})
| otherwise = (w, Nothing)
where pNew = p +.+ vel
pic = onLayerL [levLayer PtLayer - 1]
pic = onLayerL [levLayer PtLayer]
--pic = onLayerL [levLayer PtLayer - 1]
$ uncurry translate pNew
$ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
pi1 = pictures
pi1 = pictures $ reverse
[(onLayerL [levLayer PtLayer]
$ uncurry translate pNew
$ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5))
$ circleSolid $ 21 * scal)
, (onLayerL [levLayer BgLayer+1]
,
--(onLayerL [levLayer BgLayer+1]
(onLayerL [levLayer PtLayer]
$ uncurry translate pNew
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
$ circleSolid $ 21 * scal)
src/Loop.hs
+3 -1
View File
@@ -41,9 +41,11 @@ setupLoop wName xSize ySize
(\_ -> bracket customInit initCleanup $ \setup -> do -- setup <- customInit
-- swapInterval $= ImmediateUpdates
GL.blend $= GL.Enabled
GL.depthMask $= GL.Enabled
GL.blendEquation $= GL.FuncAdd
GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha)
GL.clearColor $= GL.Color4 0 0.5 0 0
GL.clearColor $= GL.Color4 0 0.5 0 1
GL.clearDepth $= (200)
doLoop setup window startWorld
sideEffects eventFn worldFn
)
src/Picture.hs
+18 -104
View File
@@ -3,6 +3,7 @@
module Picture
( module Picture.Data
, polygon
, polygonCol
, arc
, arcSolid
, thickArc
@@ -14,7 +15,6 @@ module Picture
, pictures
, translate
, rotate
, rotateRad
, scale
, color
, withAlpha
@@ -71,6 +71,10 @@ polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon = Polygon
polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = PolygonCol
--polygon :: [Point2] -> Picture
--{-# INLINE polygon #-}
--polygon (a:b:c:ps) = NLeaf $ emptyScene
@@ -81,40 +85,18 @@ polygon = Polygon
-- tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
--polygon _ = blank
color' :: RGBA -> Scene -> Scene
{-# INLINE color' #-}
color' c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
pic {_scColTri = mapVC (const c) colTri
,_scColChar = mapVC (const c) colChar
}
color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color c pic = Color c pic
overPos :: (Point3 -> Point3) -> Scene -> Scene
{-# INLINE overPos #-}
overPos f pic@(Scene {_scPosTri = posTri,_scPosChar= posChar}) =
pic {_scPosTri = mapVC f posTri
,_scPosChar = mapVC f posChar
}
translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z)
translate' :: Float -> Float -> Scene -> Scene
{-# INLINE translate' #-}
--translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
translate' x y = overPos $ translate3 x y
translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
translate x y pic = Translate x y pic
setDepth' :: Float -> Scene -> Scene
{-# INLINE setDepth' #-}
setDepth' d = overPos $ \(x,y,z) -> (x,y,d)
setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-}
setDepth d pic = SetDepth d pic
@@ -123,11 +105,6 @@ scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (x,y,z) = (x*a,y*b,z)
scale' :: Float -> Float -> Scene -> Scene
{-# INLINE scale' #-}
--scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
scale' x y pic = overPos (scale3 x y) $ over scTexChar (fmap (second (*x))) pic
scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
scale x y pic = Scale x y pic
@@ -137,28 +114,11 @@ rotate3 :: Float -> Point3 -> Point3
rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y)
rotate' :: Float -> Scene -> Scene
{-# INLINE rotate' #-}
rotate' a = overPos $ rotate3 $ 0 - degToRad a
--rotate :: Float -> Picture -> Picture
--{-# INLINE rotate #-}
--rotate a pic = NBranch (rotate' a) pic
--
---- -- this rotation uses radians, and is anticlockwise
--rotateRad' :: Float -> Scene -> Scene
--{-# INLINE rotateRad' #-}
--rotateRad' a = overPos $ rotate3 a
--
--rotateRad :: Float -> Picture -> Picture
--{-# INLINE rotateRad #-}
--rotateRad a pic = NBranch (rotateRad' a) pic
rotate a = rotateRad (0 - degToRad a)
rotate = Rotate
{-# INLINE rotate #-}
rotateRad a = Rotate a
{-# INLINE rotateRad #-}
--rotateRad a = Rotate a
--{-# INLINE rotateRad #-}
pictures :: [Picture] -> Picture
{-# INLINE pictures #-}
@@ -171,72 +131,32 @@ makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
where as = [a,a+step.. b]
step = pi * 0.2
--circleSolidD :: Float -> Float -> Picture
--circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
circleSolid :: Float -> Picture
{-# INLINE circleSolid #-}
circleSolid rad = polygon $ makeArc rad (0,2*pi)
--circleSolid rad = polygon $ makeArc rad (0,2*pi)
circleSolid = Circle
circle :: Float -> Picture
{-# INLINE circle #-}
circle rad = line $ makeArc rad (0,2*pi)
--text :: String -> Picture
--text s = zipWith (\x -> overVs $ first $ translate3 x 0)
-- [0,0.25..]
-- $ map charToShape s
text :: String -> Picture
{-# INLINE text #-}
text = Text
----text :: String -> Picture
----{-# INLINE text #-}
----text s = pictures $ zipWith (\x -> translate x (0-dimText))
---- [0,0.9*dimText..]
---- (map charToScene s)
----
----charToScene :: Char -> Picture
----charToScene c = NLeaf $ Scene
---- {_scPosTri = mempty
---- ,_scColTri = mempty
---- ,_scPosChar = toVC [(0.0,0.0,0)]
---- ,_scColChar = toVC [white]
---- ,_scTexChar = toVC [(offset,100)]
---- }
---- where x = 1/128
---- s = offset * x
---- offset = fromIntegral (fromEnum c) - 32
--charToScene :: Char -> Picture
--charToScene c = Scene
-- {_scPosTri = mempty
-- ,_scColTri = mempty
-- ,_scPosChar = toVC [(0.0 ,0.0 ,0)
-- ,(dimText,0.0 ,0)
-- ,(dimText,dimText*2,0)
-- ,(0.0 ,0.0 ,0)
-- ,(dimText,dimText*2,0)
-- ,(0.0 ,dimText*2,0)
-- ]
-- ,_scColChar = toVC $ take 6 $ repeat white
-- ,_scTexChar = toVC $ [(s,1) ,(e,1) ,(e,0) ,(s,1) ,(e,0) ,(s,0)]
-- }
-- where x = 1/128
-- s = offset * x
-- e = s + x
-- offset = fromIntegral (fromEnum c) - 32
dimText = 100
line :: [Point2] -> Picture
{-# INLINE line #-}
line ps = thickLine ps 1
line = Line
thickLine :: [Point2] -> Float -> Picture
{-# INLINE thickLine #-}
thickLine ps x = blank
thickLine ps t = pictures $ f ps
where f (x:y:ys)
| x == y = f (x:ys)
| otherwise
= polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
thickCircle :: Float -> Float -> Picture
{-# INLINE thickCircle #-}
@@ -296,9 +216,3 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
greyN :: Float -> Color
greyN x = (x,x,x,1)
--zeroZ :: Point2 -> Point3
--{-# INLINE zeroZ #-}
--zeroZ (x,y) = (x,y,0)
src/Picture/Data.hs
+6 -75
View File
@@ -14,24 +14,6 @@ import Control.Lens
type RGBA = (Float,Float,Float,Float)
type Color = (Float,Float,Float,Float)
--type VerticesContainer a = Se.Seq a
--toVC = Se.fromList
--fromVC :: VerticesContainer a -> [a]
--fromVC = F.toList
--type VerticesContainer a = DL.DList a
--toVC = DL.fromList
--fromVC = DL.toList
type VerticesContainer a = [a]
toVC = id
fromVC = id
{-# INLINE toVC #-}
{-# INLINE fromVC #-}
{-# INLINE mapVC #-}
mapVC :: (a -> b) -> VerticesContainer a -> VerticesContainer b
mapVC = fmap
data FTree a
= FBranch (a -> a) (FTree a)
| FBranches [FTree a]
@@ -43,33 +25,6 @@ instance Foldable FTree where
foldMap g (FLeaf x) = g x
{-# INLINE foldMap #-}
--reduceShapeTree :: (Shape -> Shape) -> ShapeTree -> [Shape]
--reduceShapeTree
-- (TransformShape f xs) = map (f . reduceShapeTree) xs
--reduceShapeTree
-- (Leaf s) = [s]
-- data ShapeTree
-- = TransformShape (Shape -> Shape) [ShapeTree]
-- | Leaf Shape
--
-- data Shape
-- = Shape
-- { _shPos :: VerticesContainer Point3
-- , _shCol :: VerticesContainer RGBA
-- }
-- | TextShape
-- { _shPos :: VerticesContainer Point3
-- , _shCol :: VerticesContainer RGBA
-- , _shTex :: VerticesContainer Point2
-- }
--
--combineShapes :: Shape -> Shape -> Shape
--combineShapes sa sb = Shape
-- { _shPos = _shPos sa <> _shPos sb
-- , _shCol = _shCol sa <> _shCol sb
-- }
flat2 (x,y) = [x,y]
flat3 (x,y,z) = [x,y,z]
flat4 (x,y,z,w) = [x,y,z,w]
@@ -80,49 +35,25 @@ flat4 (x,y,z,w) = [x,y,z,w]
data RenderType
= RenderPoly [(Point3,Point4)]
| RenderText [(Point3,Point4,Point2)]
| RenderCirc (Point3,Point4,Float)
| RenderArc (Point3,Point4,Point4)
| RenderLine [(Point3,Point4)]
| RenderBlank
data Picture
= Blank
| Text String
| Polygon [Point2]
| PolygonCol [(Point2,RGBA)]
| Circle Float
| Scale Float Float Picture
| Translate Float Float Picture
| Rotate Float Picture
| SetDepth Float Picture
| Color RGBA Picture
| Pictures [Picture]
data Scene = Scene
{ _scPosTri :: VerticesContainer Point3
, _scColTri :: VerticesContainer RGBA
, _scPosChar :: VerticesContainer Point3
, _scColChar :: VerticesContainer RGBA
, _scTexChar :: VerticesContainer Point2
}
emptyScene :: Scene
{-# INLINE emptyScene #-}
emptyScene = Scene mempty mempty mempty mempty mempty
| Line [Point2]
blank :: Picture
{-# INLINE blank #-}
blank = Blank
combineScenes :: Scene -> Scene -> Scene
{-# INLINE combineScenes #-}
combineScenes sa sb = Scene
{ _scPosTri = _scPosTri sa <> _scPosTri sb
, _scColTri = _scColTri sa <> _scColTri sb
, _scPosChar = _scPosChar sa <> _scPosChar sb
, _scColChar = _scColChar sa <> _scColChar sb
, _scTexChar = _scTexChar sa <> _scTexChar sb
}
instance Semigroup Scene where
(<>) = combineScenes
instance Monoid Scene where
mempty = emptyScene
--mappend = combineScenes
makeLenses ''Scene
src/Picture/Preload.hs
+94 -55
View File
@@ -10,6 +10,7 @@ import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Storable as V
import Control.Lens
import Control.Monad
import Foreign
@@ -20,19 +21,55 @@ data PreloadData = PreloadData
-- , _textures :: [Image PixelRGBA8]
, _basicShader :: Program
, _textShader :: Program
, _circShader :: Program
, _arcShader :: Program
, _lineShader :: Program
, _fadeCircleShader :: Program
, _basicVAO :: VertexArrayObject
, _textVAO :: VertexArrayObject
, _circVAO :: VertexArrayObject
, _arcVAO :: VertexArrayObject
, _posVBO :: BufferObject
, _colVBO :: BufferObject
, _texVBO :: BufferObject
, _ptrPosVBO :: Ptr Float
, _ptrColVBO :: Ptr Float
, _ptrTexVBO :: Ptr Float
, _ptrCharPos :: Ptr Float
, _ptrCharCol :: Ptr Float
, _ptrCharTex :: Ptr Float
, _ptrCircPos :: Ptr Float
, _ptrCircCol :: Ptr Float
, _ptrCircSca :: Ptr Float
, _ptrArcPos :: Ptr Float
, _ptrArcCol :: Ptr Float
, _ptrArcSca :: Ptr Float
, _ptrLinePos :: Ptr Float
, _ptrLineCol :: Ptr Float
, _uniWinSize :: UniformLocation
, _csZoomUni :: UniformLocation
, _asWinUni :: UniformLocation
, _asZoomUni :: UniformLocation
}
makeLenses ''PreloadData
floatSize = sizeOf (0.5 :: GLfloat)
setupVAO :: [(BufferObject,GLuint,Int)] -> IO VertexArrayObject
setupVAO ps = do
theVAO <- genObjectName
bindVertexArrayObject $= Just theVAO
forM_ ps $ \(vbo,aloc,i) -> do
bindBuffer ArrayBuffer $= Just vbo
vertexAttribPointer (AttribLocation aloc) $=
( ToFloat
, VertexArrayDescriptor (fromIntegral i)
Float
(fromIntegral $ floatSize * i)
(bufferOffset 0)
)
vertexAttribArray (AttribLocation aloc) $= Enabled
return theVAO
loadTextures :: IO [Image PixelRGBA8]
loadTextures = do
@@ -53,8 +90,16 @@ doPreload' = do
-- compile shader programs
bs <- makeBasicShader
ts <- makeTextureShader
cs <- makeCircleShader
as <- makeArcShader
fcs <- makeFadeShader
winSizeUni <- GL.uniformLocation cs "winSize"
zoomUni <- GL.uniformLocation cs "zoom"
asWinSizeUniLoc <- GL.uniformLocation as "winSize"
asZoomUniLoc <- GL.uniformLocation as "zoom"
-- get uniform locations
--setup vbos
--need to be bound before assigning the vertex attribute pointers
posVBO <- genObjectName
@@ -76,81 +121,75 @@ doPreload' = do
generateMipmap' Texture2D
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
let vertexSize = sizeOf (0.5 :: GLfloat)
firstIndex = 0
-- setup VAOs: basic vao
basicVAO <- genObjectName
bindVertexArrayObject $= Just basicVAO
-- let posAttrib = AttribLocation 0
-- colAttrib = AttribLocation 1
bindBuffer ArrayBuffer $= Just posVBO
vertexAttribPointer (AttribLocation 0) $=
( ToFloat
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3)
(bufferOffset (firstIndex * vertexSize))
)
vertexAttribArray (AttribLocation 0) $= Enabled
bindBuffer ArrayBuffer $= Just colVBO
vertexAttribPointer (AttribLocation 1) $=
( ToFloat
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4)
(bufferOffset (firstIndex * vertexSize) )
)
vertexAttribArray (AttribLocation 1) $= Enabled
-- setup second vao
textVAO <- genObjectName
bindVertexArrayObject $= Just textVAO
bindBuffer ArrayBuffer $= Just posVBO
vertexAttribPointer (AttribLocation 0) $=
( ToFloat
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3)
(bufferOffset (firstIndex * vertexSize))
)
vertexAttribArray (AttribLocation 0) $= Enabled
bindBuffer ArrayBuffer $= Just colVBO
vertexAttribPointer (AttribLocation 1) $=
( ToFloat
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4)
(bufferOffset (firstIndex * vertexSize) )
)
vertexAttribArray (AttribLocation 1) $= Enabled
bindBuffer ArrayBuffer $= Just texVBO
vertexAttribPointer (AttribLocation 2) $=
( ToFloat
, VertexArrayDescriptor 2 Float (fromIntegral $ vertexSize * 2)
(bufferOffset (firstIndex * vertexSize) )
)
vertexAttribArray (AttribLocation 2) $= Enabled
basicVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4)]
textVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,2)]
circVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,1)]
arcVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,3)]
-- allocate memory for vertex attributes
-- for triangles
ptrPosVBO <- mallocArray (3*3*20000)
ptrColVBO <- mallocArray (3*4*20000)
ptrTexVBO <- mallocArray (3*2*20000)
-- for characters
ptrCharPos <- mallocArray (3*20000)
ptrCharCol <- mallocArray (4*20000)
ptrCharTex <- mallocArray (2*20000)
-- for circles
ptrCircPos <- mallocArray (3*20000)
ptrCircCol <- mallocArray (4*20000)
ptrCircSca <- mallocArray (2*20000)
-- for lines
ptrLinePos <- mallocArray (3*20000)
ptrLineCol <- mallocArray (4*20000)
-- for arcs
ptrArcPos <- mallocArray (3*20000)
ptrArcCol <- mallocArray (4*20000)
ptrArcSca <- mallocArray (3*20000)
return $ PreloadData
{ _charMap = convertRGBA8 cmap
, _basicShader = bs
, _textShader = ts
, _circShader = cs
, _arcShader = as
, _fadeCircleShader = fcs
, _basicVAO = basicVAO
, _textVAO = textVAO
, _circVAO = circVAO
, _arcVAO = arcVAO
, _posVBO = posVBO
, _colVBO = colVBO
, _texVBO = texVBO
, _ptrPosVBO = ptrPosVBO
, _ptrColVBO = ptrColVBO
, _ptrTexVBO = ptrTexVBO
, _ptrCharPos = ptrCharPos
, _ptrCharCol = ptrCharCol
, _ptrCharTex = ptrCharTex
, _ptrCircPos = ptrCircPos
, _ptrCircCol = ptrCircCol
, _ptrCircSca = ptrCircSca
, _ptrArcPos = ptrArcPos
, _ptrArcCol = ptrArcCol
, _ptrArcSca = ptrArcSca
, _ptrLinePos = ptrLinePos
, _ptrLineCol = ptrLineCol
, _uniWinSize = winSizeUni
, _csZoomUni = zoomUni
, _asWinUni = asWinSizeUniLoc
, _asZoomUni = asZoomUniLoc
}
cleanUpPreload :: PreloadData -> IO ()
cleanUpPreload pd = do
free (_ptrPosVBO pd)
free (_ptrColVBO pd)
free (_ptrTexVBO pd)
free (_ptrCharPos pd)
free (_ptrCharCol pd)
free (_ptrCharTex pd)
free (_ptrCircPos pd)
free (_ptrCircCol pd)
free (_ptrCircSca pd)
free (_ptrArcPos pd)
free (_ptrArcCol pd)
free (_ptrArcSca pd)
src/Picture/Render.hs
+140 -116
View File
@@ -6,6 +6,8 @@ import Control.Lens
import Control.Monad
import Control.Monad.Trans.State
import qualified Control.Foldl as F
import Data.Bifunctor
import Picture
@@ -18,7 +20,7 @@ import Foreign
import Codec.Picture
import Graphics.Rendering.OpenGL hiding (get,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
import Graphics.Rendering.OpenGL hiding (Line,get,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
import qualified Graphics.Rendering.OpenGL as GL
import Data.Foldable
@@ -36,27 +38,11 @@ toVec2 (x,y) = Vector2 x y
toVec3 (x,y,z) = Vector3 x y z
toVec4 (x,y,z,w) = Vector4 x y z w
mapFlat :: (NFData b) => (a -> VerticesContainer b) -> VerticesContainer a -> [b]
mapFlat f = fromVC . foldMap f
polyToTris :: [s] -> [s]
{-# INLINE polyToTris #-}
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
polyToTris _ = []
data Tx a = Tx [Tx a] | Lx a
deriving instance Foldable Tx
stateBump :: [Int] -> () -> State Int [Int]
stateBump xs _ = do
s <- get
modify (+1)
return (s:xs)
redT :: Foldable t => t () -> [Int]
redT x = evalState (foldM stateBump [] x) 0
tripFirst :: (a -> a') -> (a,b,c) -> (a',b,c)
{-# INLINE tripFirst #-}
tripFirst f (x,y,z) = (f x,y,z)
@@ -66,42 +52,57 @@ tripSecond :: (b -> b') -> (a,b,c) -> (a,b',c)
tripSecond f (x,y,z) = (x,f y,z)
scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
{-# INLINE scaleT #-}
scaleT x (a,b,(o,s)) = (a,b,(o,s*x))
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
overPos _ RenderBlank = RenderBlank
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
overCol _ RenderBlank = RenderBlank
scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
scaleRen x y (RenderPoly xs) = RenderPoly $ map (first $ scale3 x y) xs
scaleRen x y (RenderText xs) = RenderText $ map (tripFirst (scale3 x y ) . scaleT x) xs
--scaleRen x y (RenderText xs) = RenderText $ map (\(a,b,c) -> (a,b, (0,0.2))) xs
scaleRen x y rt = rt
translateRen x y (RenderPoly xs) = RenderPoly $ map (first $ translate3 x y) xs
translateRen x y (RenderText xs) = RenderText $ map (tripFirst $ translate3 x y) xs
--translateRen x y (RenderText xs) = RenderText $ map (tripFirst $ const (0.2,0.2,0)) xs
translateRen x y rt = rt
{-# INLINE scaleRen #-}
scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs
scaleRen x y (RenderCirc (a,b,c)) = overPos (scale3 x y) $ RenderCirc (a,b,c)
scaleRen x y rt = overPos (scale3 x y) rt
{-# INLINE translateRen #-}
translateRen x y = overPos $ translate3 x y
rotateRen,setDepthRen :: Float -> RenderType -> RenderType
rotateRen a (RenderPoly xs) = RenderPoly $ map (first $ rotate3 a) xs
rotateRen a (RenderText xs) = RenderText $ map (tripFirst $ rotate3 a) xs
rotateRen a rt = rt
setDepthRen a (RenderPoly xs) = RenderPoly $ map (first $ (\(x,y,_) -> (x,y,a))) xs
setDepthRen a (RenderText xs) = RenderText $ map (tripFirst $ (\(x,y,_) -> (x,y,a))) xs
setDepthRen a rt = rt
{-# INLINE rotateRen #-}
rotateRen a = overPos $ rotate3 a
{-# INLINE setDepthRen #-}
setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
{-# INLINE colorRen #-}
colorRen :: RGBA -> RenderType -> RenderType
colorRen c (RenderPoly xs) = RenderPoly $ map (second $ const c) xs
colorRen c (RenderText xs) = RenderText $ map (tripSecond $ const c) xs
colorRen c rt = rt
colorRen c = overCol $ const c
stringToList :: String -> [(Point3,Point4,Point2)]
stringToList s = zipWith (\x (a,b,c) -> (translate3 x (0-dimText) a,b,c))
{-# INLINE stringToList #-}
stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
[0,0.9*dimText..]
$ map charToTuple s
where dimText = 100
charToTuple :: Char -> (Point3,Point4,Point2)
{-# INLINE charToTuple #-}
charToTuple c = ((0,0,0),white,(offset,100))
where offset = fromIntegral (fromEnum c) - 32
picToFTree :: Picture -> FTree RenderType
{-# INLINE picToFTree #-}
picToFTree (Polygon ps) = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
picToFTree (PolygonCol vs) = let (ps,cs) = unzip vs
in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToFTree (Circle r) = FLeaf $ RenderCirc $ ((0.5,0,0),red,r)
picToFTree Blank = FLeaf $ RenderBlank
picToFTree (Text s) = FLeaf $ RenderText $ stringToList s
picToFTree (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree pic
@@ -110,10 +111,75 @@ picToFTree (Rotate a pic) = FBranch (rotateRen a) $ picToFTree pic
picToFTree (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree pic
picToFTree (Color c pic) = FBranch (colorRen c) $ picToFTree pic
picToFTree (Pictures pics) = FBranches $ map picToFTree pics
picToFTree (Line ps) = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat black
pokeTexts :: Ptr Float -> Ptr Float -> Ptr Float -> FTree RenderType -> IO Int
pokeTexts = go 0
where go n pa pb pc t = foldM (pokeText pa pb pc) n t
doubleLine :: [Point2] -> [Point2]
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
doubleLine _ = []
pokeFold :: (Ptr Float, Ptr Float) -> F.FoldM IO RenderType Int
pokeFold (pa,pb) = F.FoldM
(pokePoly pa pb)
(return 0)
return
pokeTextFold :: (Ptr Float, Ptr Float,Ptr Float) -> F.FoldM IO RenderType Int
pokeTextFold (pa,pb,pc) = F.FoldM
(pokeText pa pb pc)
(return 0)
return
pokeCircFold :: (Ptr Float, Ptr Float,Ptr Float) -> F.FoldM IO RenderType Int
pokeCircFold (pa,pb,pc) = F.FoldM
(pokeCirc pa pb pc)
(return 0)
return
theFold :: (Ptr Float,Ptr Float)
-> (Ptr Float,Ptr Float,Ptr Float)
-> (Ptr Float,Ptr Float,Ptr Float)
-> (Ptr Float,Ptr Float)
-> F.FoldM IO RenderType (Int,Int,Int,Int)
theFold pas pbs pcs pds = (,,,) <$> pokeFold pas <*> pokeTextFold pbs <*> pokeCircFold pcs
<*> pokeLineFold pds
pokeLineFold :: (Ptr Float, Ptr Float) -> F.FoldM IO RenderType Int
pokeLineFold (pa,pb) = F.FoldM
(pokeLine pa pb)
(return 0)
return
pokeLine :: Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
pokeLine pa pb n (RenderLine vs) = foldM (pokeLineVert pa pb) n vs
pokeLine _ _ n _ = return n
pokeLineVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
pokeLineVert pa pb n ((x,y,z),(r,g,b,a))
| n > 20000 * 2 = return n
| otherwise = do
pokeElemOff pa (3*n+0) x
pokeElemOff pa (3*n+1) y
pokeElemOff pa (3*n+2) z
pokeElemOff pb (4*n+0) r
pokeElemOff pb (4*n+1) g
pokeElemOff pb (4*n+2) b
pokeElemOff pb (4*n+3) a
return (n+1)
pokeCirc :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
pokeCirc pa pb pc n (RenderCirc vs) = pokeCircVert pa pb pc n vs
pokeCirc _ _ _ n _ = return n
pokeCircVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Float) -> IO Int
pokeCircVert pa pb pc n ((x,y,z),(r,g,b,a),s)
| n > 20000 * 2 = return n
| otherwise = do
pokeElemOff pa (3*n+0) x
pokeElemOff pa (3*n+1) y
pokeElemOff pa (3*n+2) z
pokeElemOff pb (4*n+0) r
pokeElemOff pb (4*n+1) g
pokeElemOff pb (4*n+2) b
pokeElemOff pb (4*n+3) a
pokeElemOff pc n s
return (n+1)
pokeText :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
pokeText pa pb pc n (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
@@ -155,33 +221,6 @@ pokeVert pa pb n ((x,y,z),(r,g,b,a))
pokeElemOff pb (4*n+3) a
return (n+1)
reducePicture :: Picture -> (DL.DList Float,DL.DList Float)
{-# INLINE reducePicture #-}
reducePicture = reducePicture' black id
where
reducePicture' :: RGBA -> (Point3 -> Point3) -> Picture -> (DL.DList Float,DL.DList Float)
reducePicture' col tran Blank = (DL.empty,DL.empty)
reducePicture' col tran (Text _) = (DL.empty,DL.empty)
reducePicture' col tran (Polygon ps)
= ( DL.fromList $ concatMap (flat3 . tran . zeroZ) (polyToTris ps)
, DL.fromList $ concatMap (flat4 . const col) (polyToTris ps)
)
reducePicture' col tran (Scale x y pic)
= reducePicture' col (tran . scale3 x y) pic
reducePicture' col tran (Translate x y pic)
= reducePicture' col (tran . translate3 x y) pic
reducePicture' col tran (Rotate a pic)
= reducePicture' col (tran . rotate3 a) pic
reducePicture' col tran (SetDepth a pic)
= reducePicture' col (tran . \(x,y,z) -> (x,y,a)) pic
reducePicture' col tran (Color c pic)
= reducePicture' c tran pic
reducePicture' col tran (Pictures pics)
= foldr com (DL.empty,DL.empty) $ map (reducePicture' col tran) pics
where com (xs,ys) (xs',ys') = (xs <> xs', ys <> ys')
translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z)
@@ -193,72 +232,57 @@ rotate3 :: Float -> Point3 -> Point3
rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y)
renderPicture' :: PreloadData -> Picture -> IO ()
renderPicture' pdata pic = do
renderPicture' :: PreloadData -> Float -> (Float,Float) -> Picture -> IO ()
renderPicture' pdata zoom (winx,winy) pic = do
let firstIndex = 0
fSize = sizeOf (0::Float)
(nTriVs,numVert',numCircVs,nLineVs)
<- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
(_ptrCharPos pdata, _ptrCharCol pdata, _ptrCharTex pdata)
(_ptrCircPos pdata, _ptrCircCol pdata, _ptrCircSca pdata)
(_ptrLinePos pdata, _ptrLineCol pdata)
) $ picToFTree pic
depthFunc $= Just Less
-- draw triangles
currentProgram $= Just (_basicShader pdata)
numVert <- pokePic (_ptrPosVBO pdata) (_ptrColVBO pdata) $ picToFTree pic
bindVertexArrayObject $= Just (_basicVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 3, _ptrPosVBO pdata, StreamDraw)
bufferData ArrayBuffer $= (fromIntegral $ fSize * nTriVs * 3, _ptrPosVBO pdata, StreamDraw)
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 4, _ptrColVBO pdata, StreamDraw)
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVert)
bufferData ArrayBuffer $= (fromIntegral $ fSize * nTriVs * 4, _ptrColVBO pdata, StreamDraw)
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ nTriVs)
-- draw lines, don't need to change the program or vaos, just need to bind the
-- vbos and draw
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * nLineVs * 3, _ptrLinePos pdata, StreamDraw)
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * nLineVs * 4, _ptrLineCol pdata, StreamDraw)
drawArrays Lines (fromIntegral firstIndex) (fromIntegral $ nLineVs)
-- draw circles
currentProgram $= Just (_circShader pdata)
uniform (_uniWinSize pdata) $= Vector2 winx winy
uniform (_csZoomUni pdata) $= zoom
bindVertexArrayObject $= Just (_circVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *3, _ptrCircPos pdata, StreamDraw)
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *4, _ptrCircCol pdata, StreamDraw)
bindBuffer ArrayBuffer $= Just (_texVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *1, _ptrCircSca pdata, StreamDraw)
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numCircVs)
currentProgram $= Just (_textShader pdata)
numVert' <- pokeTexts (_ptrPosVBO pdata) (_ptrColVBO pdata) (_ptrTexVBO pdata) $ picToFTree pic
bindVertexArrayObject $= Just (_textVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *3, _ptrPosVBO pdata, StreamDraw)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *3, _ptrCharPos pdata, StreamDraw)
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *4, _ptrColVBO pdata, StreamDraw)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *4, _ptrCharCol pdata, StreamDraw)
bindBuffer ArrayBuffer $= Just (_texVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *2, _ptrTexVBO pdata, StreamDraw)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *2, _ptrCharTex pdata, StreamDraw)
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVert')
renderPicture :: PreloadData -> Picture -> IO ()
renderPicture pdata pic = do
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_basicVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
let firstIndex = 0
let (vs,cs) = reducePicture pic
vertices :: [Float]
vertices = DL.toList vs
numVertices = length vertices
vertexSize = sizeOf (head vertices)
pokeArray (_ptrPosVBO pdata) vertices
bufferData ArrayBuffer $= (fromIntegral (length vertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
-- marshallVs vertices $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
let colVs = DL.toList cs
pokeArray (_ptrColVBO pdata) colVs
bufferData ArrayBuffer $= (fromIntegral (length colVs * vertexSize), _ptrColVBO pdata, StreamDraw)
-- marshallVs colVs $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices)
---- currentProgram $= Just (_textShader pdata)
---- bindVertexArrayObject $= Just (_textVAO pdata)
---- bindBuffer ArrayBuffer $= Just (_posVBO pdata)
---- let vertices' = concatMap flat3 posChar
---- numVertices' = length posChar
---- vertexSize' = sizeOf $ head vertices'
---- pokeArray (_ptrPosVBO pdata) vertices'
---- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
---- --withArray vertices' $ \ptr -> do
---- -- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
---- bindBuffer ArrayBuffer $= Just (_colVBO pdata)
---- pokeArray (_ptrColVBO pdata) $ concatMap flat4 colChar
---- bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
---- bindBuffer ArrayBuffer $= Just (_texVBO pdata)
---- pokeArray (_ptrTexVBO pdata) $ concatMap flat2 texChar
---- bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
---- drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVertices')
bufferOffset :: Integral a => a -> Ptr b
src/Shaders.hs
+24
View File
@@ -6,6 +6,8 @@ module Shaders
,makeTextureShader
,makeBasicShader
,makeFadeShader
,makeCircleShader
,makeArcShader
)
where
import Graphics.Rendering.OpenGL
@@ -34,6 +36,28 @@ setupBasicShader = do
shaderProgram <- makeBasicShader
currentProgram $= (Just shaderProgram)
makeCircleShader :: IO Program
makeCircleShader = do
vsSource <- BS.readFile "shader/circle.vert"
gsSource <- BS.readFile "shader/circle.geom"
fsSource <- BS.readFile "shader/circle.frag"
makeShaderProgram [(VertexShader, vsSource )
,(GeometryShader, gsSource )
,(FragmentShader, fsSource )
]
makeArcShader :: IO Program
makeArcShader = do
vsSource <- BS.readFile "shader/arc.vert"
gsSource <- BS.readFile "shader/arc.geom"
fsSource <- BS.readFile "shader/arc.frag"
makeShaderProgram [(VertexShader, vsSource )
,(GeometryShader, gsSource )
,(FragmentShader, fsSource )
]
makeFadeShader :: IO Program
makeFadeShader = do
vsSource <- BS.readFile "shader/fadeCircle.vert"