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:
justin
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.Update
import Dodge.KeyEvents import Dodge.KeyEvents
import Dodge.Rendering import Dodge.Rendering
import Dodge.Menu
import Picture import Picture
import Picture.Render import Picture.Render
@@ -50,8 +51,8 @@ main = do
(initializeWorld $ generateFromTree lev1 $ initWorld) (initializeWorld $ generateFromTree lev1 $ initWorld)
(-- \((bs:fs:ts:_),tes) w -> --do render setparams w egFade (-- \((bs:fs:ts:_),tes) w -> --do render setparams w egFade
\preData 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 (_cameraZoom w) (_windowX w,_windowY w) (draw blank w)
renderPicture' preData (draw blank w) --renderPicture' preData (_windowX w,_windowY w) (Circle 5)
-- renderPicture' preData -- renderPicture' preData
-- (pictures [scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)] -- (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)] -- ,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) (\w -> Just $ update w)
Mix.closeAudio Mix.closeAudio
package.yaml
+1
View File
@@ -41,6 +41,7 @@ dependencies:
- dlist - dlist
- deepseq - deepseq
- transformers - transformers
- foldl
library: library:
source-dirs: src source-dirs: src
src/Dodge/Base.hs
+13 -1
View File
@@ -422,6 +422,18 @@ lineOfThickness t = pictures . f
f _ = [] f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b)) 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 :: Float -> Point2 -> Point2 -> Picture
wedgeOfThickness t x y wedgeOfThickness t x y
| x == y = blank | x == y = blank
@@ -701,7 +713,7 @@ onLayer l = setDepth (fromIntegral (levLayer l) / 100)
--onLayer l p = [(p, [levLayer l])] --onLayer l p = [(p, [levLayer l])]
onLayerL :: [Int] -> Picture -> Picture 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 :: Layer -> Int
levLayer BgLayer = 20 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 (SubPathTo p i _:_) -> dGoals $ sizeColEnemy r blue
(Search i:_) -> dGoals $ sizeColEnemy r black (Search i:_) -> dGoals $ sizeColEnemy r black
_ -> dGoals $ sizeColEnemy r magenta _ -> 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) _ -> sizeColEnemy r (light $ dim green)
startCr :: Creature startCr :: Creature
@@ -395,5 +395,4 @@ basicCrPict col cr = pictures [ onLayer CrLayer naked , drawEquipment cr]
-- | crDam > _crHP cr && odd (crDam - _crHP cr) -- | crDam > _crHP cr && odd (crDam - _crHP cr)
-- = [color white $ circleSolid $ _crRad cr] -- = [color white $ circleSolid $ _crRad cr]
| otherwise = pictures [color col $ circleSolid $ _crRad cr, circLine $ _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 pdam = _crPastDamage $ _crState cr
src/Dodge/Data.hs
+1
View File
@@ -242,6 +242,7 @@ data MenuState
| PauseMenu | PauseMenu
| GameOverMenu | GameOverMenu
| InGame | InGame
deriving (Eq,Ord)
data Sound = Sound { _soundTime :: Int data Sound = Sound { _soundTime :: Int
, _soundFadeTime :: 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}) (ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss})
lss lss
addDec decs = IM.insert (newKey decs) addDec decs = IM.insert (newKey decs)
(uncurry translate p $ rotate (radToDeg rot) dec) (uncurry translate p $ rotate (0 - rot) dec)
decs 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 = case _mapDisplay w of
(True, z) -> (blank (True, z) -> (blank
,pictures [color white $ circleSolid 3 ,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) $ uncurry translate ((0,0) -.- _cameraCenter w)
$ pictures $ mapMaybe mapWall $ IM.elems $ _walls w] $ pictures $ mapMaybe mapWall $ IM.elems $ _walls w]
) )
@@ -68,7 +68,7 @@ draw'' b w-- | (Char 'm') `S.member` _keys w
x2 = (x''+1) x2 = (x''+1)
y1 = (y''-1) y1 = (y''-1)
y2 = (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) . uncurry translate ((0,0) -.- _cameraPos w)
zoom = _cameraZoom w zoom = _cameraZoom w
pathsTest = map drawPair $ _pathGraph' w pathsTest = map drawPair $ _pathGraph' w
@@ -100,7 +100,7 @@ collectDrawings w = pictures
] ]
-- <> [onLayer GloomLayer $ theLighting w] -- <> [onLayer GloomLayer $ theLighting w]
where where
screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) ) screenShift = scale zoom zoom . rotate (0 - (_cameraRot w) )
. uncurry translate ((0,0) -.- _cameraPos w) . uncurry translate ((0,0) -.- _cameraPos w)
zoom = _cameraZoom w zoom = _cameraZoom w
decPicts = IM.elems $ _decorations w decPicts = IM.elems $ _decorations w
@@ -127,12 +127,13 @@ collectDrawings w = pictures
menuScreen = case _menuState w of menuScreen = case _menuState w of
InGame -> blank InGame -> blank
LevelMenu x -> LevelMenu x ->
pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 ("LEVEL "++show x) tst (-100) 100 0.4 ("LEVEL "++show x)
,controlsList ,controlsList
] ]
PauseMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w PauseMenu -> pictures
,tst (-100) 100 0.4 "PAUSED" [--color (withAlpha 0.5 black) $ polygon $ screenBox w
tst (-100) 100 0.4 "PAUSED"
,tst (-100) 50 0.2 "n - new level" ,tst (-100) 50 0.2 "n - new level"
,tst (-100) 0 0.2 "r - restart" ,tst (-100) 0 0.2 "r - restart"
, controlsList , controlsList
@@ -157,11 +158,11 @@ hudDrawings w = (onLayer InvLayer)
where itCol = fromMaybe (greyN 0.5) . (^? itInvColor) where itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
crDraw :: Creature -> Drawing 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 :: 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 :: 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 :: Cloud -> Drawing
clDraw c = uncurry translate (_clPos c) $ (_clPict c c) 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 (halfHeight w - (25* (fromIntegral iPos)) - 20
) )
-- $ rectangleWire 200 25 -- $ rectangleWire 200 25
$ color white
$ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)] $ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)]
where iPos = _crInvSel $ _creatures w IM.! _yourID w 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' pb p' = p' -.- orth p'
pao p' = pa p' +.+ l *.* safeNormalizeV (pa p' -.- _cameraCenter w) pao p' = pa p' +.+ l *.* safeNormalizeV (pa p' -.- _cameraCenter w)
pbo p' = pb p' +.+ l *.* safeNormalizeV (pb 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') a p' = pi - argV (orth p')
trap p' = polygon [pa p', pb p', pbo p', pao p'] trap p' = polygon [pa p', pb p', pbo p', pao p']
f p' = [semiCirc p', trap 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) pao' p' = pa' p' +.+ l *.* safeNormalizeV (pa' p' -.- _cameraCenter w)
pbo' p' = pb' p' +.+ l *.* safeNormalizeV (pb' 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'] 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 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 :: Float -> Point2 -> Picture
printRotPoint r p = color white $ uncurry translate p $ pictures [circle 3 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 :: World -> [Point2]
outsideScreenPolygon w = [tr,tl,bl,br] outsideScreenPolygon w = [tr,tl,bl,br]
@@ -390,42 +392,42 @@ drawButText :: World -> Button -> Picture
drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100 drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100
&& hasLOS (_btPos bt) (_crPos (you w)) w && hasLOS (_btPos bt) (_crPos (you w)) w
&& _btState bt /= BtNoLabel && _btState bt /= BtNoLabel
= t $ rotate (radToDeg (-_cameraRot w)) = t $ rotate (_cameraRot w)
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)] $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, 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 ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
$ scale 0.1 0.1 $ text $ _btText bt $ scale 0.1 0.1 $ text $ _btText bt
] ]
| otherwise = blank | 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 zoom = _cameraZoom w
scLine = dShadCol white . line . fmap (sqrt zoom *.*) scLine = dShadCol white . line . fmap (sqrt zoom *.*)
drawPPText :: World -> PressPlate -> Picture drawPPText :: World -> PressPlate -> Picture
drawPPText w pp | magV (_crPos (you w) -.- _ppPos pp) < 100 drawPPText w pp | magV (_crPos (you w) -.- _ppPos pp) < 100
&& hasLOS (_ppPos pp) (_crPos (you w)) w && 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)] $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, 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 ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
$ scale 0.1 0.1 $ text $ _ppText pp $ scale 0.1 0.1 $ text $ _ppText pp
] ]
| otherwise = blank | 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 zoom = _cameraZoom w
scLine = dShadCol white . line . fmap (sqrt zoom *.*) scLine = dShadCol white . line . fmap (sqrt zoom *.*)
drawItemName :: World -> FloorItem -> Picture drawItemName :: World -> FloorItem -> Picture
drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100 drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100
&& hasLOS (_flItPos flIt) (_crPos (you w)) w && 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)] $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, 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 ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
$ scale 0.1 0.1 $ text $ nameOfItem $ scale 0.1 0.1 $ text $ nameOfItem
] ]
| otherwise = blank | 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 nameOfItem = case flIt of FlIt {} -> _itName $ _flIt flIt
FlAm {_flAm = PistolBullet} -> "Bullets" FlAm {_flAm = PistolBullet} -> "Bullets"
FlAm {_flAm = LiquidFuel} -> "Liquid Fuel" 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 :: World -> ForceField -> [Picture]
drawFFShadow w ff drawFFShadow w ff
| youOnFF = [] | youOnFF = []
| otherwise = map (rotate (radToDeg (- _cameraRot w)) . pane) | otherwise = map (rotate ( _cameraRot w) . pane)
[0,0.05..0.25] [0,0.05..0.25]
where p = rotateV (-_cameraRot w) $ ypShift where p = rotateV (-_cameraRot w) $ ypShift
x = rotateV (-_cameraRot w) x' x = rotateV (-_cameraRot w) x'
src/Dodge/Update.hs
+7 -4
View File
@@ -22,7 +22,10 @@ import Control.Lens
-- }}} -- }}}
update :: World -> World update :: World -> World
update w = let w1 = updateParticles' $ updateParticles update w
| _menuState w /= InGame = w
| otherwise =
let w1 = updateParticles' $ updateParticles
$ updateLightSources $ updateLightSources
$ zoneClouds $ zoneClouds
$ updateClouds $ updateClouds
@@ -31,16 +34,16 @@ update w = let w1 = updateParticles' $ updateParticles
$ updateBlocks -- $ zoning $ updateBlocks -- $ zoning
$ updateSeenWalls $ updateSeenWalls
w w
w2 = -- updateWeaponCounters $ w2 = -- updateWeaponCounters $
simpleCrSprings simpleCrSprings
$ zoneCreatures $ wallEvents $ zoneCreatures $ wallEvents
$ set worldEvents id $ _worldEvents w1 $ set worldEvents id $ _worldEvents w1
w1 w1
w3 = updateCamera w3 = updateCamera
$ updateAfterParticles' $ updateAfterParticles'
$ colCrsWalls $ colCrsWalls
w2 w2
in checkEndGame $ ppEvents w3 in checkEndGame $ ppEvents w3
where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
-- w -- w
-- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize -- 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 ,longGun,flamer,blinkGun,forceFieldGun :: Item
pistol = Weapon pistol = Weapon
{ _itName = "pistol" { _itName = "PISTOL"
, _itIdentity = Pistol , _itIdentity = Pistol
, _wpMaxAmmo = 15 , _wpMaxAmmo = 15
, _wpLoadedAmmo = 15 , _wpLoadedAmmo = 15
@@ -101,7 +101,7 @@ autoEffectGun name eff = autoGun
} }
autoGun = defaultGun autoGun = defaultGun
{ _itName = "autoGun .........." { _itName = "AUTOGUN AUTO"
, _itIdentity = AutoGun , _itIdentity = AutoGun
, _wpMaxAmmo = 30 , _wpMaxAmmo = 30
, _wpLoadedAmmo = 30 , _wpLoadedAmmo = 30
@@ -142,12 +142,12 @@ incMode :: Int -> World -> World
incMode _ w incMode _ w
= case newMode of = case newMode of
0 -> w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode .~ 0 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 . itHammer .~ NoHammer
& creatures . ix 0 . crInv . ix itRef . itEffect .~ NoItEffect & creatures . ix 0 . crInv . ix itRef . itEffect .~ NoItEffect
& creatures . ix 0 . crInv . ix itRef . wpFire .~ autoFireMode & creatures . ix 0 . crInv . ix itRef . wpFire .~ autoFireMode
1 -> w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode .~ 1 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 . itHammer .~ HammerUp
& creatures . ix 0 . crInv . ix itRef . itEffect .~ wpRecock & creatures . ix 0 . crInv . ix itRef . itEffect .~ wpRecock
& creatures . ix 0 . crInv . ix itRef . wpFire .~ singleFireMode & creatures . ix 0 . crInv . ix itRef . wpFire .~ singleFireMode
@@ -157,17 +157,17 @@ incMode _ w
f x = mod (x+1) 2 f x = mod (x+1) 2
decMode :: Int -> World -> World decMode :: Int -> World -> World
decMode _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode %~ f 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 where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel
oldMode = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode oldMode = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode
newMode = fromMaybe 1 $ fmap f oldMode newMode = fromMaybe 1 $ fmap f oldMode
f x = mod (x-1) 2 f x = mod (x-1) 2
g 1 = " ." g 1 = " SINGLE"
g 2 = " ..." g 2 = " BURST"
g 0 = " .........." g 0 = " AUTO"
rezGun = defaultGun rezGun = defaultGun
{ _itName = "reanimator" { _itName = "REANIMATOR"
, _wpMaxAmmo = 50 , _wpMaxAmmo = 50
, _wpLoadedAmmo = 50 , _wpLoadedAmmo = 50
, _wpAmmoType = Battery , _wpAmmoType = Battery
@@ -191,7 +191,7 @@ rezGun = defaultGun
] ]
} }
teslaGun = autoGun teslaGun = autoGun
{ _itName = "teslaGun" { _itName = "TESLAGUN"
, _itIdentity = TeslaGun , _itIdentity = TeslaGun
, _wpMaxAmmo = 200 , _wpMaxAmmo = 200
, _wpLoadedAmmo = 200 , _wpLoadedAmmo = 200
@@ -217,7 +217,7 @@ teslaGun = autoGun
] ]
} }
lasGun = autoGun lasGun = autoGun
{ _itName = "lasGun ////" { _itName = "LASGUN ////"
, _itIdentity = LasGun , _itIdentity = LasGun
, _wpMaxAmmo = 200 , _wpMaxAmmo = 200
, _wpLoadedAmmo = 200 , _wpLoadedAmmo = 200
@@ -241,7 +241,7 @@ lasGun = autoGun
} }
incPhaseV :: Int -> World -> World incPhaseV :: Int -> World -> World
incPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV %~ f 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 where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel
oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV
newPhaseV = fromMaybe 1 $ fmap f oldPhaseV newPhaseV = fromMaybe 1 $ fmap f oldPhaseV
@@ -257,7 +257,7 @@ incPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just .
g 5 = " \\\\//" g 5 = " \\\\//"
decPhaseV :: Int -> World -> World decPhaseV :: Int -> World -> World
decPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV %~ f 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 where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel
oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV
newPhaseV = fromMaybe 1 $ fmap f oldPhaseV newPhaseV = fromMaybe 1 $ fmap f oldPhaseV
@@ -272,7 +272,7 @@ decPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just .
g 2 = " \\///" g 2 = " \\///"
g 5 = " \\\\//" g 5 = " \\\\//"
forceFieldGun = defaultGun forceFieldGun = defaultGun
{ _itName = "forceField" { _itName = "FORCEFIELD"
, _itIdentity = ForceFieldGun , _itIdentity = ForceFieldGun
, _wpMaxAmmo = 100 , _wpMaxAmmo = 100
, _wpLoadedAmmo = 100 , _wpLoadedAmmo = 100
@@ -311,7 +311,7 @@ forceFieldGun = defaultGun
-- , _itAimingRange = 0.5 -- , _itAimingRange = 0.5
-- } -- }
tractorGun = autoGun tractorGun = autoGun
{ _itName = "tractorGun" { _itName = "TRACTORGUN"
, _itIdentity = TractorGun , _itIdentity = TractorGun
, _wpMaxAmmo = 10000 , _wpMaxAmmo = 10000
, _wpLoadedAmmo = 10000 , _wpLoadedAmmo = 10000
@@ -331,7 +331,7 @@ tractorGun = autoGun
, _itEquipPict = drawWeapon $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ] , _itEquipPict = drawWeapon $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ]
} }
launcher = defaultGun launcher = defaultGun
{ _itName = "launcher" { _itName = "lAUNCHER"
, _itIdentity = Launcher , _itIdentity = Launcher
, _wpMaxAmmo = 30 , _wpMaxAmmo = 30
, _wpLoadedAmmo = 30 , _wpLoadedAmmo = 30
@@ -353,7 +353,7 @@ launcher = defaultGun
, _itEffect = NoItEffect , _itEffect = NoItEffect
} }
remoteLauncher = defaultGun remoteLauncher = defaultGun
{ _itName = "remoteLauncher" { _itName = "REMOTELAUNCHER"
, _itIdentity = RemoteLauncher , _itIdentity = RemoteLauncher
, _wpMaxAmmo = 1 , _wpMaxAmmo = 1
, _wpLoadedAmmo = 1 , _wpLoadedAmmo = 1
@@ -374,7 +374,7 @@ remoteLauncher = defaultGun
, _itAttachment = Just $ ItScope (0,0) 0 1 True , _itAttachment = Just $ ItScope (0,0) 0 1 True
} }
hvAutoGun = autoGun hvAutoGun = autoGun
{ _itName = "hvMachineGun" { _itName = "HVMACHINEGUN"
, _itIdentity = HvAutoGun , _itIdentity = HvAutoGun
, _wpMaxAmmo = 100 , _wpMaxAmmo = 100
, _wpLoadedAmmo = 100 , _wpLoadedAmmo = 100
@@ -401,7 +401,7 @@ hvAutoGun = autoGun
hvBulHitCr' hvBulHitWall' bulHitFF' hvBulHitCr' hvBulHitWall' bulHitFF'
ltAutoGun = autoGun ltAutoGun = autoGun
{ _itName = "autoPistol" { _itName = "AUTOPISTOL"
, _itIdentity = LtAutoGun , _itIdentity = LtAutoGun
, _wpMaxAmmo = 25 , _wpMaxAmmo = 25
, _wpLoadedAmmo = 25 , _wpLoadedAmmo = 25
@@ -426,7 +426,7 @@ ltAutoGun = autoGun
] ]
} }
miniGun = autoGun miniGun = autoGun
{ _itName = "miniGun" { _itName = "MINIGUN"
, _itIdentity = MiniGun , _itIdentity = MiniGun
, _wpMaxAmmo = 150 , _wpMaxAmmo = 150
, _wpLoadedAmmo = 150 , _wpLoadedAmmo = 150
@@ -447,7 +447,7 @@ miniGun = autoGun
, _itEquipPict = drawWeapon $ color red $ polygon $ rectNESW 9 5 (-9) (-5) , _itEquipPict = drawWeapon $ color red $ polygon $ rectNESW 9 5 (-9) (-5)
} }
spreadGun = defaultGun spreadGun = defaultGun
{ _itName = "spreadgun" { _itName = "SPREADGUN"
, _itIdentity = SpreadGun , _itIdentity = SpreadGun
, _wpMaxAmmo = 5 , _wpMaxAmmo = 5
, _wpLoadedAmmo = 5 , _wpLoadedAmmo = 5
@@ -491,7 +491,7 @@ spreadGun = defaultGun
-- , _itAimingRange = 0.5 -- , _itAimingRange = 0.5
-- } -- }
multGun = defaultGun multGun = defaultGun
{ _itName = "multGun" { _itName = "MULTGUN"
, _itIdentity = MultGun , _itIdentity = MultGun
, _wpMaxAmmo = 2 , _wpMaxAmmo = 2
, _wpLoadedAmmo = 2 , _wpLoadedAmmo = 2
@@ -522,7 +522,7 @@ multGun = defaultGun
, polygon [(-1.5,12),(-2,12),(-2,-12),(-1.5,-12)] , polygon [(-1.5,12),(-2,12),(-2,-12),(-1.5,-12)]
] ]
longGun = defaultGun longGun = defaultGun
{ _itName = "elephantGun" { _itName = "ELEPHANTGUN"
, _itIdentity = LongGun , _itIdentity = LongGun
, _wpMaxAmmo = 1 , _wpMaxAmmo = 1
, _wpLoadedAmmo = 1 , _wpLoadedAmmo = 1
@@ -563,7 +563,7 @@ startZoomOutLongGun _ w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatu
poisonSprayer = autoGun poisonSprayer = autoGun
{ _itName = "poisonSprayer" { _itName = "POISONSPRAYER"
, _itIdentity = PoisonSprayer , _itIdentity = PoisonSprayer
, _wpMaxAmmo = 500 , _wpMaxAmmo = 500
, _wpLoadedAmmo = 500 , _wpLoadedAmmo = 500
@@ -585,7 +585,7 @@ poisonSprayer = autoGun
} }
flamer = autoGun flamer = autoGun
{ _itName = "flamethrower" { _itName = "FLAMETHROWER"
, _itIdentity = Flamethrower , _itIdentity = Flamethrower
, _wpMaxAmmo = 250 , _wpMaxAmmo = 250
, _wpLoadedAmmo = 250 , _wpLoadedAmmo = 250
@@ -609,7 +609,7 @@ flamer = autoGun
, _itAttachment = Nothing , _itAttachment = Nothing
} }
blinkGun = defaultGun blinkGun = defaultGun
{ _itName = "blinker" { _itName = "BLINKER"
, _itIdentity = Blinker , _itIdentity = Blinker
, _wpMaxAmmo = 100 , _wpMaxAmmo = 100
, _wpLoadedAmmo = 100 , _wpLoadedAmmo = 100
@@ -804,11 +804,11 @@ moveShell time i cid rot accel w
(moveShell (time-1) i cid rot (rotateV rot accel)) (moveShell (time-1) i cid rot (rotateV rot accel))
$ over (particles . ix i . ptVel) (\v -> accel +.+ frict *.* v) $ over (particles . ix i . ptVel) (\v -> accel +.+ frict *.* v)
$ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250 $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250
$ smokeGen
$ makeFlameletTimed oldPos $ makeFlameletTimed oldPos
(0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20 (0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20
$ makeFlameletTimed (0.5 *.* (newPos +.+ oldPos)) $ makeFlameletTimed (0.5 *.* (newPos +.+ oldPos))
(0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20 (0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20
$ smokeGen
w w
| time > -200 = case thingHit of | time > -200 = case thingHit of
Just p -> shellExplosionAt oldPos Just p -> shellExplosionAt oldPos
@@ -829,9 +829,9 @@ moveShell time i cid rot accel w
(frict,g) = randomR (0.6,0.9) $ _randGen w (frict,g) = randomR (0.6,0.9) $ _randGen w
(sparkD,_) = randomR (-0.5,0.5) $ _randGen w (sparkD,_) = randomR (-0.5,0.5) $ _randGen w
dir = argV $ vel 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] 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 hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w
hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w
thingHit = hitCr <|> hitWl thingHit = hitCr <|> hitWl
@@ -1018,24 +1018,24 @@ moveFlame rotd w pt =
damcr cr p = over (creatures . ix (_crID cr) . crState . crDamage) damcr cr p = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ Flaming (div time 10) sp p ep) ((:) $ Flaming (div time 10) sp p ep)
hiteff = _btHitEffect' pt pt 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') 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 $ scale scaleChange 1
-- $ color white -- $ color white
-- $ circleSolid 5 -- $ circleSolid 5
$ pictures [color white $ circleSolid 4 $ pictures $ reverse [color white $ circleSolid 4
,color (withAlpha 0.5 white) $ circleSolid 5 ,color (withAlpha 0.5 white) $ circleSolid 5
] ]
-- $ rotate (radToDeg (fromIntegral time * 10)) -- $ rotate (radToDeg (fromIntegral time * 10))
-- $ polygon [(-5,-2),(5,-2),(5,2),(-5,2)] -- $ polygon [(-5,-2),(5,-2),(5,2),(-5,2)]
pi2 p' = onLayerL [levLayer UPtLayer,4] $ uncurry translate (prot p') pi2 p' = onLayerL [levLayer UPtLayer,4] $ uncurry translate (prot p')
-- $ rotate ( (fromIntegral time * 5)) -- $ rotate ( (fromIntegral time * 5))
$ rotate (90 + (negate $ radToDeg $ argV rotd)) $ rotate (pi * 0.5 + argV rotd)
-- $ color (mixColors 0.5 0.5 orange white) -- $ color (mixColors 0.5 0.5 orange white)
-- $ polygon [(-6,-6),(6,-6),(6,6),(-6,6)] -- $ polygon [(-6,-6),(6,-6),(6,6),(-6,6)]
$ scale (scaleChange + 0.5) 1.5 $ 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 (withAlpha 0.5 orange) $ circleSolid 5
] ]
-- $ color orange -- $ color orange
@@ -1044,10 +1044,10 @@ moveFlame rotd w pt =
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time * 1) (0,1) prot2 p' = p' +.+ rotateV (negate $ fromIntegral time * 1) (0,1)
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2) prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2)
piu p' = onLayerL [levLayer UPtLayer,2] $ uncurry translate (prot2 p') 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))) -- $ rotate ((fromIntegral time * (-10)))
$ scale (scaleChange + 1) 2 $ 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 (withAlpha 0.5 red) $ circleSolid 5
] ]
-- $ color (dark red) -- $ color (dark red)
@@ -1697,7 +1697,7 @@ grenadeLauncher = pistol
grenade,remoteBomb :: Item grenade,remoteBomb :: Item
grenade = Throwable grenade = Throwable
{ _itName = "grenade " ++ show fuseTime { _itName = "GRENADE " ++ show fuseTime
, _itIdentity = Grenade , _itIdentity = Grenade
, _itMaxStack = 8 , _itMaxStack = 8
, _itAmount = 1 , _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 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 . itScrollDown .~ increaseFuse newTime
& creatures . ix 0 . crInv . ix itRef . twFire .~ throwGrenade 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 . itAttachment .~ Just (ItFuse newTime)
& creatures . ix 0 . crInv . ix itRef . itZoom & creatures . ix 0 . crInv . ix itRef . itZoom
.~ (basicItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm}) .~ (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 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 . itScrollDown .~ increaseFuse newTime
& creatures . ix 0 . crInv . ix itRef . twFire .~ throwGrenade 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 . itAttachment .~ Just (ItFuse newTime)
& creatures . ix 0 . crInv . ix itRef . itZoom & creatures . ix 0 . crInv . ix itRef . itZoom
.~ (basicItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm}) .~ (basicItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm})
@@ -1746,7 +1746,7 @@ decreaseFuse fuse i w = w & creatures . ix 0 . crInv . ix itRef . itScrollUp .~
defaultThrowable = grenade defaultThrowable = grenade
remoteBomb = defaultThrowable remoteBomb = defaultThrowable
{ _itName = "remoteBomb" { _itName = "REMOTEBOMB"
, _itIdentity = RemoteBomb , _itIdentity = RemoteBomb
, _itMaxStack = 1 , _itMaxStack = 1
, _itAmount = 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' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0)
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0)
| otherwise = p' | otherwise = p'
dir = negate $ radToDeg $ argV $ v dir = argV v
setWp :: World -> World setWp :: World -> World
setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20 setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20
--maybewpid = w ^? creatures . ix n . crInv . ix j . itID . _Just --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 ) ((179 * fromIntegral x / 50) - 180 )
(180 - (179 * fromIntegral x / 50) ) (180 - (179 * fromIntegral x / 50) )
5 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 $ 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 newitid = newKey $ _itemPositions w
maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just
resetFire = set (creatures . ix cid . crInv . ix j . wpFire) $ explodeRemoteRocket itid i 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 :: World -> World
setLocation w' = case maybeitid of setLocation w' = case maybeitid of
Nothing -> w' & creatures . ix cid . crInv . ix j . itID .~ Just newitid 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 (sparkD,_) = randomR (-0.5,0.5) $ _randGen w
dir = argV $ vel dir = argV $ vel
pic = onLayer PtLayer $ uncurry translate newPos pic = onLayer PtLayer $ uncurry translate newPos
$ rotate (-radToDeg (argV accel)) $ remoteShellPic time $ rotate (argV accel) $ remoteShellPic time
piclow = onLayerL [levLayer CrLayer - 2] piclow = onLayerL [levLayer CrLayer - 2]
$ uncurry translate newPos $ rotate (-radToDeg (argV accel)) $ uncurry translate newPos $ rotate (argV accel)
$ remoteShellPic time $ remoteShellPic time
hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w
hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos 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:[]) (s1:s2:s3:_) = map (\s -> fromIntegral s * 0.1 - 1) (t3:t2:t1:[])
-- ((r1:r2:r3:_),_) = runState ((sequence . repeat . randInCirc) 10) $ _randGen w -- ((r1:r2:r3:_),_) = runState ((sequence . repeat . randInCirc) 10) $ _randGen w
-- v1 = fst $ runState (randInCirc 0.5) $ _randGen w -- v1 = fst $ runState (randInCirc 0.5) $ _randGen w
smokeGen = makeSmokeAt'' v1 s1 t1 (newPos +.+ r1) smokeGen = makeSmokeAt'' v2 s2 t2 (newPos +.+ r2)
. makeSmokeAt'' v2 s2 t2 (newPos +.+ r2) . makeSmokeAt'' v1 s1 t1 (newPos +.+ r1)
-- . makeSmokeAt'' v3 s3 t3 (newPos +.+ r3) -- . makeSmokeAt'' v3 s3 t3 (newPos +.+ r3)
doExplosion = explodeRemoteRocket itid i cid doExplosion = explodeRemoteRocket itid i cid
setScope w' = case _itemPositions w' IM.! itid of setScope w' = case _itemPositions w' IM.! itid of
@@ -1943,7 +1944,7 @@ explodeRemoteRocket itid ptid n w
-- $ resetScope -- $ resetScope
$ makeExplosionAt (_ptPos (_particles w IM.! ptid)) w $ makeExplosionAt (_ptPos (_particles w IM.! ptid)) w
-- $ makeShrapnelBombAt (_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) -- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0)
itPoint = pointToItem $ _itemPositions w IM.! itid itPoint = pointToItem $ _itemPositions w IM.! itid
@@ -1968,7 +1969,7 @@ throwRemoteBomb n w = setLocation $ removePict $ resetFire
v | magV v' > 6 = 6 *.* normalizeV v' v | magV v' > 6 = 6 *.* normalizeV v'
-- zoom = 1 / _cameraZoom w -- zoom = 1 / _cameraZoom w
j = _crInvSel $ _creatures w IM.! n 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 removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank
resetFire = set (creatures . ix n . crInv . ix j . twFire) $ explodeRemoteBomb itid i resetFire = set (creatures . ix n . crInv . ix j . twFire) $ explodeRemoteBomb itid i
cr = _creatures w IM.! n cr = _creatures w IM.! n
@@ -1995,19 +1996,19 @@ explodeRemoteBomb itid ptid n w
-- $ resetScope -- $ resetScope
$ makeExplosionAt (_ptPos (_particles w IM.! ptid)) w $ makeExplosionAt (_ptPos (_particles w IM.! ptid)) w
-- $ makeShrapnelBombAt (_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 ) resetPict = set (creatures . ix n . crInv . ix j . itEquipPict )
(drawWeapon $ remoteBombUnarmedPic) (drawWeapon $ remoteBombUnarmedPic)
-- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0) -- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0)
j = _crInvSel $ _creatures w IM.! n j = _crInvSel $ _creatures w IM.! n
remoteBombPic :: Int -> Picture remoteBombPic :: Int -> Picture
remoteBombPic x = pictures [ color (dark $ dark orange) $ circleSolid 5 remoteBombPic x = pictures [ color (dark $ dark orange) $ circleSolid 5
, rotate (fromIntegral x * 10 + 45) $ color red $ arc 0 90 5 , rotate (0 - degToRad (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 (withAlpha 0.05 red)
$ arcSolid 0 90 50 $ 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 $ 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 $ arcSolid 0 20 20
] ]
remoteBombUnarmedPic :: Picture remoteBombUnarmedPic :: Picture
@@ -2027,7 +2028,7 @@ drawWeapon p cr posInInv
medkit :: Int -> Item medkit :: Int -> Item
medkit i = basicConsumable medkit i = basicConsumable
{ _itIdentity = Medkit25 { _itIdentity = Medkit25
, _itName = "medkit" ++ show i , _itName = "MEDKIT" ++ show i
, _itMaxStack = 9 , _itMaxStack = 9
, _itAmount = 1 , _itAmount = 1
, _cnEffect = heal i , _cnEffect = heal i
@@ -2328,7 +2329,7 @@ autogunSpread = 0.07
medkit25,pipe,magShield :: Item medkit25,pipe,magShield :: Item
medkit25 = basicConsumable medkit25 = basicConsumable
{ _itIdentity = Medkit25 { _itIdentity = Medkit25
, _itName = "medkit25" , _itName = "MEDKIT25"
, _itMaxStack = 3 , _itMaxStack = 3
, _itAmount = 2 , _itAmount = 2
, _cnEffect = heal25 , _cnEffect = heal25
@@ -2337,7 +2338,7 @@ medkit25 = basicConsumable
} }
pipe = Craftable pipe = Craftable
{ _itIdentity = Generic { _itIdentity = Generic
, _itName = "pipe" , _itName = "PIPE"
, _itMaxStack = 3 , _itMaxStack = 3
, _itAmount = 3 , _itAmount = 3
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2348,7 +2349,7 @@ pipe = Craftable
} }
magShield = basicEquipment magShield = basicEquipment
{ _itIdentity = MagShield { _itIdentity = MagShield
, _itName = "magshield" , _itName = "MAGSHIELD"
, _itMaxStack = 1 , _itMaxStack = 1
, _itAmount = 1 , _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2357,7 +2358,7 @@ magShield = basicEquipment
} }
flameShield = basicEquipment flameShield = basicEquipment
{ _itIdentity = FlameShield { _itIdentity = FlameShield
, _itName = "flameShield" , _itName = "FLAMESHIELD"
, _itMaxStack = 1 , _itMaxStack = 1
, _itAmount = 1 , _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2368,7 +2369,7 @@ flameShield = basicEquipment
} }
frontArmour = basicEquipment frontArmour = basicEquipment
{ _itIdentity = FrontArmour { _itIdentity = FrontArmour
, _itName = "frontArmour" , _itName = "FRONTARMOUR"
, _itMaxStack = 1 , _itMaxStack = 1
, _itAmount = 1 , _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ translate 0 (-5) $ pictures [color (greyN 0.1) $ thickArc 0 90 10 5 , _itFloorPict = onLayer FlItLayer $ translate 0 (-5) $ pictures [color (greyN 0.1) $ thickArc 0 90 10 5
@@ -2384,7 +2385,7 @@ frontArmour = basicEquipment
} }
jetPack = basicEquipment jetPack = basicEquipment
{ _itIdentity = JetPack { _itIdentity = JetPack
, _itName = "JetPack" , _itName = "JETPACK"
, _itMaxStack = 1 , _itMaxStack = 1
, _itAmount = 1 , _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2399,11 +2400,11 @@ jetPack = basicEquipment
latchkey :: Int -> Item latchkey :: Int -> Item
latchkey n = basicEquipment latchkey n = basicEquipment
{ _itIdentity = Generic { _itIdentity = Generic
, _itName = "key "++show n , _itName = "KEY "++show n
, _itMaxStack = 1 , _itMaxStack = 1
, _itAmount = 1 , _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ latchkeyPic , _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 , _itEffect = NoItEffect
, _itHammer = HammerUp , _itHammer = HammerUp
, _itID = Nothing , _itID = Nothing
@@ -2549,7 +2550,7 @@ shakeCr cID amount w =
radar = defaultGun radar = defaultGun
{ _itName = "radar" { _itName = "RADAR"
, _itIdentity = Generic , _itIdentity = Generic
, _wpMaxAmmo = 100 , _wpMaxAmmo = 100
, _wpLoadedAmmo = 100 , _wpLoadedAmmo = 100
@@ -2571,7 +2572,7 @@ radar = defaultGun
} }
sonar = defaultGun sonar = defaultGun
{ _itName = "sonar" { _itName = "SONAR"
, _itIdentity = Generic , _itIdentity = Generic
, _wpMaxAmmo = 100 , _wpMaxAmmo = 100
, _wpLoadedAmmo = 100 , _wpLoadedAmmo = 100
@@ -2678,7 +2679,7 @@ mvRadar x p w pt = (putBlips w, Just $ pt {_ptPict' = pic
autoSonar = basicEquipment autoSonar = basicEquipment
{ _itIdentity = Generic { _itIdentity = Generic
, _itName = "autoSonar" , _itName = "AUTOSONAR"
, _itMaxStack = 1 , _itMaxStack = 1
, _itAmount = 1 , _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
@@ -2691,7 +2692,7 @@ autoSonar = basicEquipment
} }
autoRadar = basicEquipment autoRadar = basicEquipment
{ _itIdentity = Generic { _itIdentity = Generic
, _itName = "autoRadar" , _itName = "AUTORADAR"
, _itMaxStack = 1 , _itMaxStack = 1
, _itAmount = 1 , _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] , _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 where l x = uncurry translate x
$ rotate (90 - (radToDeg $ argV (p -.- x))) $ rotate (pi*0.5 + argV (p -.- x))
$ color (withAlpha alphay col) $ color (withAlpha alphay col)
$ thickArc 0 180 (_crRad cr) wdth $ 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 cp = _crPos cr
cid = _crID cr cid = _crID cr
upp cid' w' = case w' ^? creatures . ix cid . crPos of upp cid' w' = case w' ^? creatures . ix cid . crPos of
@@ -597,38 +596,37 @@ mvGenBullet' w bt
t = _btTimer' bt t = _btTimer' bt
bulLine :: Color -> Float -> [Point2] -> Drawing 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 = onLayer HPtLayer $ pictures
[color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b] [polygonCol $ zip (wedgeGeom width b a) $ [white,withAlpha 0 white,withAlpha 0 white]
,color white $ wedgeOfThickness width a b ,polygonCol $ zip (lineGeom (width+1.5) a b) $ [col,col,withAlpha 0 col,withAlpha 0 col]
-- ,color white $ lineOfThickness width [a,b]
-- ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b]
-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
] ]
-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b) bulLine col width (a:b:c:[]) -- (a:b:[])
-- a3 = (0.3 *.* a) +.+ (0.7 *.* b)
bulLine col width (a:b:c:_)
= onLayer HPtLayer $ pictures = onLayer HPtLayer $ pictures
[color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c] [polygonCol $ zip (wedgeGeom width b a) $ repeat white
,color white $ wedgeOfThickness width a c ,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
-- ,color white $ lineOfThickness width [a,b] ,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
-- ,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]
] ]
-- where a2 = b bulLine col width (a:b:_:c:[]) -- (a:b:[])
-- a3 = (0.5 *.* b) +.+ (0.5 *.* c) = onLayer HPtLayer $ pictures
-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b) [polygonCol $ zip (wedgeGeom width b a) $ repeat white
-- a3 = (0.3 *.* a) +.+ (0.7 *.* b) ,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
--bulLine col width (a:b:c:d:_) ,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 -- = onLayer HPtLayer $ pictures
-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1) [a,c] -- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c]
-- ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b] -- ,color white $ wedgeOfThickness width a c
-- ,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)
thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World
-> [(Point2, (Either3 Creature Wall ForceField))] -> [(Point2, (Either3 Creature Wall ForceField))]
@@ -735,11 +733,11 @@ moveFlamelet levelInt rot w pt =
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
white (dark red) white (dark red)
) )
$ rotate (radToDeg ( 0.1 * fromIntegral time + rot)) $ rotate (0 - ( 0.1 * fromIntegral time + rot))
$ scale sc sc $ scale sc sc
$ polygon [(-size,-size),(size,-size),(size,size),(-size,size)] $ polygon [(-size,-size),(size,-size),(size,size),(-size,size)]
piu = onLayerL [levelInt,1] $ uncurry translate ep 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 $ scale s1 s1
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
glow = onLayerL [levelInt,0] $ uncurry translate ep 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) $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red) orange (dark red)
) )
$ rotate (radToDeg $ rot + 0.2 * fromIntegral time) $ rotate (0 - (rot + 0.2 * fromIntegral time))
$ scale s2 s2 $ scale s2 s2
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
@@ -822,7 +820,8 @@ moveSmoke' scal p time i
makeSmokeAt'' :: Point2 -> Float -> Int -> Point2 -> World -> World makeSmokeAt'' :: Point2 -> Float -> Int -> Point2 -> World -> World
makeSmokeAt'' vel scal time p w = over particles' ((:) smokeP) w makeSmokeAt'' vel scal time p w = over particles' ((:) smokeP) w
where smokeP = Particle' 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 , _ptUpdate' = moveSmoke'' scal time p vel
} }
@@ -836,15 +835,18 @@ moveSmoke'' scal time p vel w pt
}) })
| otherwise = (w, Nothing) | otherwise = (w, Nothing)
where pNew = p +.+ vel where pNew = p +.+ vel
pic = onLayerL [levLayer PtLayer - 1] pic = onLayerL [levLayer PtLayer]
--pic = onLayerL [levLayer PtLayer - 1]
$ uncurry translate pNew $ uncurry translate pNew
$ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
pi1 = pictures pi1 = pictures $ reverse
[(onLayerL [levLayer PtLayer] [(onLayerL [levLayer PtLayer]
$ uncurry translate pNew $ uncurry translate pNew
$ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5)) $ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5))
$ circleSolid $ 21 * scal) $ circleSolid $ 21 * scal)
, (onLayerL [levLayer BgLayer+1] ,
--(onLayerL [levLayer BgLayer+1]
(onLayerL [levLayer PtLayer]
$ uncurry translate pNew $ uncurry translate pNew
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
$ circleSolid $ 21 * scal) $ 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 (\_ -> bracket customInit initCleanup $ \setup -> do -- setup <- customInit
-- swapInterval $= ImmediateUpdates -- swapInterval $= ImmediateUpdates
GL.blend $= GL.Enabled GL.blend $= GL.Enabled
GL.depthMask $= GL.Enabled
GL.blendEquation $= GL.FuncAdd GL.blendEquation $= GL.FuncAdd
GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha) 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 doLoop setup window startWorld
sideEffects eventFn worldFn sideEffects eventFn worldFn
) )
src/Picture.hs
+18 -104
View File
@@ -3,6 +3,7 @@
module Picture module Picture
( module Picture.Data ( module Picture.Data
, polygon , polygon
, polygonCol
, arc , arc
, arcSolid , arcSolid
, thickArc , thickArc
@@ -14,7 +15,6 @@ module Picture
, pictures , pictures
, translate , translate
, rotate , rotate
, rotateRad
, scale , scale
, color , color
, withAlpha , withAlpha
@@ -71,6 +71,10 @@ polygon :: [Point2] -> Picture
{-# INLINE polygon #-} {-# INLINE polygon #-}
polygon = Polygon polygon = Polygon
polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = PolygonCol
--polygon :: [Point2] -> Picture --polygon :: [Point2] -> Picture
--{-# INLINE polygon #-} --{-# INLINE polygon #-}
--polygon (a:b:c:ps) = NLeaf $ emptyScene --polygon (a:b:c:ps) = NLeaf $ emptyScene
@@ -81,40 +85,18 @@ polygon = Polygon
-- tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs -- tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
--polygon _ = blank --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 color :: RGBA -> Picture -> Picture
{-# INLINE color #-} {-# INLINE color #-}
color c pic = Color c pic 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 translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-} {-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z) 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 translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-} {-# INLINE translate #-}
translate x y pic = Translate x y pic 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 setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-} {-# INLINE setDepth #-}
setDepth d pic = SetDepth d pic setDepth d pic = SetDepth d pic
@@ -123,11 +105,6 @@ scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-} {-# INLINE scale3 #-}
scale3 a b (x,y,z) = (x*a,y*b,z) 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 scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-} {-# INLINE scale #-}
scale x y pic = Scale x y pic scale x y pic = Scale x y pic
@@ -137,28 +114,11 @@ rotate3 :: Float -> Point3 -> Point3
rotate3 a (x,y,z) = (x',y',z) rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y) where (x',y') = rotateV a (x,y)
rotate' :: Float -> Scene -> Scene rotate = Rotate
{-# 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)
{-# INLINE rotate #-} {-# INLINE rotate #-}
rotateRad a = Rotate a --rotateRad a = Rotate a
{-# INLINE rotateRad #-} --{-# INLINE rotateRad #-}
pictures :: [Picture] -> Picture pictures :: [Picture] -> Picture
{-# INLINE pictures #-} {-# INLINE pictures #-}
@@ -171,72 +131,32 @@ makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
where as = [a,a+step.. b] where as = [a,a+step.. b]
step = pi * 0.2 step = pi * 0.2
--circleSolidD :: Float -> Float -> Picture
--circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
circleSolid :: Float -> Picture circleSolid :: Float -> Picture
{-# INLINE circleSolid #-} {-# INLINE circleSolid #-}
circleSolid rad = polygon $ makeArc rad (0,2*pi) --circleSolid rad = polygon $ makeArc rad (0,2*pi)
circleSolid = Circle
circle :: Float -> Picture circle :: Float -> Picture
{-# INLINE circle #-} {-# INLINE circle #-}
circle rad = line $ makeArc rad (0,2*pi) 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 text :: String -> Picture
{-# INLINE text #-} {-# INLINE text #-}
text = 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 line :: [Point2] -> Picture
{-# INLINE line #-} {-# INLINE line #-}
line ps = thickLine ps 1 line = Line
thickLine :: [Point2] -> Float -> Picture thickLine :: [Point2] -> Float -> Picture
{-# INLINE thickLine #-} {-# 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 thickCircle :: Float -> Float -> Picture
{-# INLINE thickCircle #-} {-# 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 :: Float -> Color
greyN x = (x,x,x,1) 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 RGBA = (Float,Float,Float,Float)
type Color = (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 data FTree a
= FBranch (a -> a) (FTree a) = FBranch (a -> a) (FTree a)
| FBranches [FTree a] | FBranches [FTree a]
@@ -43,33 +25,6 @@ instance Foldable FTree where
foldMap g (FLeaf x) = g x foldMap g (FLeaf x) = g x
{-# INLINE foldMap #-} {-# 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] flat2 (x,y) = [x,y]
flat3 (x,y,z) = [x,y,z] flat3 (x,y,z) = [x,y,z]
flat4 (x,y,z,w) = [x,y,z,w] flat4 (x,y,z,w) = [x,y,z,w]
@@ -80,49 +35,25 @@ flat4 (x,y,z,w) = [x,y,z,w]
data RenderType data RenderType
= RenderPoly [(Point3,Point4)] = RenderPoly [(Point3,Point4)]
| RenderText [(Point3,Point4,Point2)] | RenderText [(Point3,Point4,Point2)]
| RenderCirc (Point3,Point4,Float)
| RenderArc (Point3,Point4,Point4)
| RenderLine [(Point3,Point4)]
| RenderBlank | RenderBlank
data Picture data Picture
= Blank = Blank
| Text String | Text String
| Polygon [Point2] | Polygon [Point2]
| PolygonCol [(Point2,RGBA)]
| Circle Float
| Scale Float Float Picture | Scale Float Float Picture
| Translate Float Float Picture | Translate Float Float Picture
| Rotate Float Picture | Rotate Float Picture
| SetDepth Float Picture | SetDepth Float Picture
| Color RGBA Picture | Color RGBA Picture
| Pictures [Picture] | Pictures [Picture]
| Line [Point2]
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
blank :: Picture blank :: Picture
{-# INLINE blank #-} {-# INLINE blank #-}
blank = 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 qualified Data.Vector.Storable as V
import Control.Lens import Control.Lens
import Control.Monad
import Foreign import Foreign
@@ -20,19 +21,55 @@ data PreloadData = PreloadData
-- , _textures :: [Image PixelRGBA8] -- , _textures :: [Image PixelRGBA8]
, _basicShader :: Program , _basicShader :: Program
, _textShader :: Program , _textShader :: Program
, _circShader :: Program
, _arcShader :: Program
, _lineShader :: Program
, _fadeCircleShader :: Program , _fadeCircleShader :: Program
, _basicVAO :: VertexArrayObject , _basicVAO :: VertexArrayObject
, _textVAO :: VertexArrayObject , _textVAO :: VertexArrayObject
, _circVAO :: VertexArrayObject
, _arcVAO :: VertexArrayObject
, _posVBO :: BufferObject , _posVBO :: BufferObject
, _colVBO :: BufferObject , _colVBO :: BufferObject
, _texVBO :: BufferObject , _texVBO :: BufferObject
, _ptrPosVBO :: Ptr Float , _ptrPosVBO :: Ptr Float
, _ptrColVBO :: 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 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 :: IO [Image PixelRGBA8]
loadTextures = do loadTextures = do
@@ -53,8 +90,16 @@ doPreload' = do
-- compile shader programs -- compile shader programs
bs <- makeBasicShader bs <- makeBasicShader
ts <- makeTextureShader ts <- makeTextureShader
cs <- makeCircleShader
as <- makeArcShader
fcs <- makeFadeShader 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 --setup vbos
--need to be bound before assigning the vertex attribute pointers --need to be bound before assigning the vertex attribute pointers
posVBO <- genObjectName posVBO <- genObjectName
@@ -76,81 +121,75 @@ doPreload' = do
generateMipmap' Texture2D generateMipmap' Texture2D
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest) textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
let vertexSize = sizeOf (0.5 :: GLfloat)
firstIndex = 0
-- setup VAOs: basic vao -- setup VAOs: basic vao
basicVAO <- genObjectName basicVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4)]
bindVertexArrayObject $= Just basicVAO textVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,2)]
circVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,1)]
-- let posAttrib = AttribLocation 0 arcVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,3)]
-- 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
-- allocate memory for vertex attributes -- allocate memory for vertex attributes
-- for triangles
ptrPosVBO <- mallocArray (3*3*20000) ptrPosVBO <- mallocArray (3*3*20000)
ptrColVBO <- mallocArray (3*4*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 return $ PreloadData
{ _charMap = convertRGBA8 cmap { _charMap = convertRGBA8 cmap
, _basicShader = bs , _basicShader = bs
, _textShader = ts , _textShader = ts
, _circShader = cs
, _arcShader = as
, _fadeCircleShader = fcs , _fadeCircleShader = fcs
, _basicVAO = basicVAO , _basicVAO = basicVAO
, _textVAO = textVAO , _textVAO = textVAO
, _circVAO = circVAO
, _arcVAO = arcVAO
, _posVBO = posVBO , _posVBO = posVBO
, _colVBO = colVBO , _colVBO = colVBO
, _texVBO = texVBO , _texVBO = texVBO
, _ptrPosVBO = ptrPosVBO , _ptrPosVBO = ptrPosVBO
, _ptrColVBO = ptrColVBO , _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 :: PreloadData -> IO ()
cleanUpPreload pd = do cleanUpPreload pd = do
free (_ptrPosVBO pd) free (_ptrPosVBO pd)
free (_ptrColVBO 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
import Control.Monad.Trans.State import Control.Monad.Trans.State
import qualified Control.Foldl as F
import Data.Bifunctor import Data.Bifunctor
import Picture import Picture
@@ -18,7 +20,7 @@ import Foreign
import Codec.Picture 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 qualified Graphics.Rendering.OpenGL as GL
import Data.Foldable import Data.Foldable
@@ -36,27 +38,11 @@ toVec2 (x,y) = Vector2 x y
toVec3 (x,y,z) = Vector3 x y z toVec3 (x,y,z) = Vector3 x y z
toVec4 (x,y,z,w) = Vector4 x y z w 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] polyToTris :: [s] -> [s]
{-# INLINE polyToTris #-} {-# INLINE polyToTris #-}
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as)) polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
polyToTris _ = [] 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) tripFirst :: (a -> a') -> (a,b,c) -> (a',b,c)
{-# INLINE tripFirst #-} {-# INLINE tripFirst #-}
tripFirst f (x,y,z) = (f x,y,z) 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) tripSecond f (x,y,z) = (x,f y,z)
scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2) scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
{-# INLINE scaleT #-}
scaleT x (a,b,(o,s)) = (a,b,(o,s*x)) 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,translateRen :: Float -> Float -> RenderType -> RenderType
scaleRen x y (RenderPoly xs) = RenderPoly $ map (first $ scale3 x y) xs {-# INLINE scaleRen #-}
scaleRen x y (RenderText xs) = RenderText $ map (tripFirst (scale3 x y ) . scaleT x) xs scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs
--scaleRen x y (RenderText xs) = RenderText $ map (\(a,b,c) -> (a,b, (0,0.2))) xs scaleRen x y (RenderCirc (a,b,c)) = overPos (scale3 x y) $ RenderCirc (a,b,c)
scaleRen x y rt = rt scaleRen x y rt = overPos (scale3 x y) rt
translateRen x y (RenderPoly xs) = RenderPoly $ map (first $ translate3 x y) xs {-# INLINE translateRen #-}
translateRen x y (RenderText xs) = RenderText $ map (tripFirst $ translate3 x y) xs translateRen x y = overPos $ translate3 x y
--translateRen x y (RenderText xs) = RenderText $ map (tripFirst $ const (0.2,0.2,0)) xs
translateRen x y rt = rt
rotateRen,setDepthRen :: Float -> RenderType -> RenderType rotateRen,setDepthRen :: Float -> RenderType -> RenderType
rotateRen a (RenderPoly xs) = RenderPoly $ map (first $ rotate3 a) xs {-# INLINE rotateRen #-}
rotateRen a (RenderText xs) = RenderText $ map (tripFirst $ rotate3 a) xs rotateRen a = overPos $ rotate3 a
rotateRen a rt = rt {-# INLINE setDepthRen #-}
setDepthRen a (RenderPoly xs) = RenderPoly $ map (first $ (\(x,y,_) -> (x,y,a))) xs setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
setDepthRen a (RenderText xs) = RenderText $ map (tripFirst $ (\(x,y,_) -> (x,y,a))) xs {-# INLINE colorRen #-}
setDepthRen a rt = rt
colorRen :: RGBA -> RenderType -> RenderType colorRen :: RGBA -> RenderType -> RenderType
colorRen c (RenderPoly xs) = RenderPoly $ map (second $ const c) xs colorRen c = overCol $ const c
colorRen c (RenderText xs) = RenderText $ map (tripSecond $ const c) xs
colorRen c rt = rt
stringToList :: String -> [(Point3,Point4,Point2)] 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..] [0,0.9*dimText..]
$ map charToTuple s $ map charToTuple s
where dimText = 100 where dimText = 100
charToTuple :: Char -> (Point3,Point4,Point2) charToTuple :: Char -> (Point3,Point4,Point2)
{-# INLINE charToTuple #-}
charToTuple c = ((0,0,0),white,(offset,100)) charToTuple c = ((0,0,0),white,(offset,100))
where offset = fromIntegral (fromEnum c) - 32 where offset = fromIntegral (fromEnum c) - 32
picToFTree :: Picture -> FTree RenderType picToFTree :: Picture -> FTree RenderType
{-# INLINE picToFTree #-} {-# INLINE picToFTree #-}
picToFTree (Polygon ps) = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black 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 Blank = FLeaf $ RenderBlank
picToFTree (Text s) = FLeaf $ RenderText $ stringToList s picToFTree (Text s) = FLeaf $ RenderText $ stringToList s
picToFTree (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree pic 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 (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree pic
picToFTree (Color c pic) = FBranch (colorRen c) $ picToFTree pic picToFTree (Color c pic) = FBranch (colorRen c) $ picToFTree pic
picToFTree (Pictures pics) = FBranches $ map picToFTree pics 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 doubleLine :: [Point2] -> [Point2]
pokeTexts = go 0 doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
where go n pa pb pc t = foldM (pokeText pa pb pc) n t 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 :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
pokeText pa pb pc n (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs 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 pokeElemOff pb (4*n+3) a
return (n+1) 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 translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-} {-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z) 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) rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y) where (x',y') = rotateV a (x,y)
renderPicture' :: PreloadData -> Picture -> IO () renderPicture' :: PreloadData -> Float -> (Float,Float) -> Picture -> IO ()
renderPicture' pdata pic = do renderPicture' pdata zoom (winx,winy) pic = do
let firstIndex = 0 let firstIndex = 0
fSize = sizeOf (0::Float) 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) currentProgram $= Just (_basicShader pdata)
numVert <- pokePic (_ptrPosVBO pdata) (_ptrColVBO pdata) $ picToFTree pic
bindVertexArrayObject $= Just (_basicVAO pdata) bindVertexArrayObject $= Just (_basicVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO 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) bindBuffer ArrayBuffer $= Just (_colVBO pdata)
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 4, _ptrColVBO pdata, StreamDraw) bufferData ArrayBuffer $= (fromIntegral $ fSize * nTriVs * 4, _ptrColVBO pdata, StreamDraw)
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVert) 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) currentProgram $= Just (_textShader pdata)
numVert' <- pokeTexts (_ptrPosVBO pdata) (_ptrColVBO pdata) (_ptrTexVBO pdata) $ picToFTree pic
bindVertexArrayObject $= Just (_textVAO pdata) bindVertexArrayObject $= Just (_textVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO 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) 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) 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') 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 bufferOffset :: Integral a => a -> Ptr b
src/Shaders.hs
+24
View File
@@ -6,6 +6,8 @@ module Shaders
,makeTextureShader ,makeTextureShader
,makeBasicShader ,makeBasicShader
,makeFadeShader ,makeFadeShader
,makeCircleShader
,makeArcShader
) )
where where
import Graphics.Rendering.OpenGL import Graphics.Rendering.OpenGL
@@ -34,6 +36,28 @@ setupBasicShader = do
shaderProgram <- makeBasicShader shaderProgram <- makeBasicShader
currentProgram $= (Just shaderProgram) 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 :: IO Program
makeFadeShader = do makeFadeShader = do
vsSource <- BS.readFile "shader/fadeCircle.vert" vsSource <- BS.readFile "shader/fadeCircle.vert"