From 5cbcbec1014d69f480612c55ad82f663bf461066 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 20 Sep 2021 12:36:35 +0100 Subject: [PATCH] Working element buffer object --- src/Data/Preload/Render.hs | 1 + src/Dodge/Creature/Picture.hs | 26 ++++----- src/Dodge/Default.hs | 16 +++--- src/Dodge/Item.hs | 10 ++-- src/Dodge/Item/Consumable.hs | 6 +-- src/Dodge/Item/Equipment.hs | 18 +++---- src/Dodge/Item/Weapon.hs | 88 +++++++++++++++---------------- src/Dodge/Item/Weapon/AutoGun.hs | 6 +-- src/Dodge/Item/Weapon/Bezier.hs | 6 +-- src/Dodge/Item/Weapon/Grenade.hs | 4 +- src/Dodge/Item/Weapon/Launcher.hs | 6 +-- src/Dodge/Layout.hs | 5 +- src/Dodge/Render.hs | 43 +++++++++------ src/Preload/Render.hs | 20 +++++-- src/Shader/Compile.hs | 4 +- src/Shader/Data.hs | 8 +++ src/Shader/Parameters.hs | 9 ++++ src/Shader/Poke.hs | 33 ++++++++---- src/Shape.hs | 63 +++++++++------------- src/Shape/Data.hs | 49 +++++++++-------- src/ShapePicture.hs | 14 +++-- src/ShapePicture/Data.hs | 19 +++---- 22 files changed, 242 insertions(+), 212 deletions(-) diff --git a/src/Data/Preload/Render.hs b/src/Data/Preload/Render.hs index 94ac14958..f27bff2a0 100644 --- a/src/Data/Preload/Render.hs +++ b/src/Data/Preload/Render.hs @@ -29,6 +29,7 @@ data RenderData = RenderData , _barrelShader :: FullShader , _grayscaleShader :: FullShader , _shapeShader :: FullShader + , _shapeEBO :: EBO , _pictureShaders :: MV.MVector (PrimState IO) FullShader , _fbo2 :: (FramebufferObject, TextureObject) , _fbo3 :: (FramebufferObject, TextureObject) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index 75089e95e..9532ab16e 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -34,7 +34,7 @@ basicCrPict -> Creature -> World -> SPic -basicCrPict col cr w = SPic (basicCrShape col cr) $ pictures $ +basicCrPict col cr w = (,) (basicCrShape col cr) $ pictures $ targetingPic ++ [ creatureDisplayText w cr , tr . rotdir $ _spPicture $ drawEquipment cr @@ -125,6 +125,7 @@ damageModSH :: Creature -> Shape -> Shape damageModSH _ = id feet :: Creature -> Shape +{-# INLINE feet #-} feet cr = case cr ^? crStance . carriage of Just (Walking sa LeftForward) -> mconcat [ translateSHf ( f sa) off aFoot @@ -146,6 +147,7 @@ feet cr = case cr ^? crStance . carriage of f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen arms :: Creature -> Shape +{-# INLINE arms #-} arms cr | oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand | twists cr = shoulderSH . translateSHf 0 (0.5* crad) . rotateSH (-1) $ mconcat @@ -165,6 +167,7 @@ arms cr f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen scalp :: Creature -> Shape +{-# INLINE scalp #-} scalp cr | twists cr = translateSHf 0 (0.5*crad) . rotateSH (-1) $ translateSHf (negate 0.25 * crad) 0.25 fhead | oneH cr = rotateSH 0.5 $ translateSHf (0.25 * crad) 0 fhead @@ -184,6 +187,7 @@ twists cr = crIsAiming' cr && crIt ^? itAimStance == Just TwoHandTwist crIt = _crInv cr IM.! _crInvSel cr torso :: Creature -> Shape +{-# INLINE torso #-} torso cr | oneH cr = rotateSH 0.5 $ mconcat [ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder @@ -203,27 +207,16 @@ torso cr crad = _crRad cr baseShoulder :: Shape +{-# INLINE baseShoulder #-} baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 1 - - upperBody :: Color -> Creature -> Shape +{-# INLINE upperBody #-} upperBody col cr = colorSH (light4 col) $ mconcat [ arms cr , shoulderSH $ torso cr ] ---naked :: Color -> Creature -> Picture ---naked _ cr --- | strikeMelee = shoulderH . color white $ circleSolid $ _crRad cr --- | pdam > 200 = shoulderH . color red $ circleSolid $ _crRad cr --- | pdam > 99 = shoulderH . color white $ circleSolid $ _crRad cr --- | otherwise = [] --- where --- strikeMelee = _crMeleeCooldown cr > 5 --- pdam = sum $ concatMap (map _dmAmount) pastDams --- pastDams = _crPastDamage $ _crState cr - shoulderSH :: Shape -> Shape shoulderSH = translateSHz 20 waistSH :: Shape -> Shape @@ -244,6 +237,7 @@ light4 = light . light . light . light drawEquipment :: Creature -> SPic +{-# INLINE drawEquipment #-} drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr) where f (i,it) = case it ^? itEquipPict of @@ -255,8 +249,8 @@ circLine x = line [V2 0 0,V2 x 0] picAtCrPos :: Picture -> Creature -> World -> SPic --{-# INLINE picAtCrPos #-} -picAtCrPos thePic cr _ = SPic emptySH $ tranRot (_crPos cr) (_crDir cr) thePic +picAtCrPos thePic cr _ = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic picAtCrPosNoRot :: Picture -> Creature -> World -> SPic --{-# INLINE picAtCrPos #-} -picAtCrPosNoRot thePic cr _ = SPic emptySH $ uncurryV translate (_crPos cr) thePic +picAtCrPosNoRot thePic cr _ = (,) emptySH $ uncurryV translate (_crPos cr) thePic diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 4c67dd597..4b6f5f32e 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -19,7 +19,7 @@ import Dodge.SoundLogic.LoadSound import Dodge.Picture.Layer import Geometry import Picture -import ShapePicture +--import ShapePicture import Shape import Control.Lens @@ -36,7 +36,7 @@ defaultCreature = Creature , _crOldDir = 0 , _crMvDir = 0 , _crID = 1 - , _crPict = \_ _ -> SPic (flatCirc 10) blank + , _crPict = \_ _ -> (,) (flatCirc 10) blank , _crUpdate = \cr _ -> (Endo id , Just cr) , _crRad = 10 , _crMass = 10 @@ -130,8 +130,8 @@ defaultEquipment = Equipment , _itName = "genericEquipment" , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ setLayer 0 $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \_ _ -> SPic emptySH blank + , _itFloorPict = (,) emptySH $ setLayer 0 $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \_ _ -> (,) emptySH blank , _itEffect = NoItEffect , _itHammer = HammerUp , _itID = Nothing @@ -152,8 +152,8 @@ defaultConsumable = Consumable , _itMaxStack = 9 , _itAmount = 1 , _cnEffect = \_ _ -> Nothing - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color blue $ circleSolid 3 - , _itEquipPict = \_ _ -> SPic emptySH blank + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color blue $ circleSolid 3 + , _itEquipPict = \_ _ -> (,) emptySH blank , _itID = Nothing , _itInvColor = blue , _itInvDisplay = \it -> _itName it ++ " x" ++ show (_itAmount it) @@ -199,8 +199,8 @@ defaultIt = Consumable , _itMaxStack = 3 , _itAmount = 2 , _cnEffect = const return - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \_ _ -> SPic emptySH $ blank + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \_ _ -> (,) emptySH $ blank , _itID = Nothing , _itInvDisplay = _itName , _itInvColor = blue diff --git a/src/Dodge/Item.hs b/src/Dodge/Item.hs index 5a15cc6b9..c53a2d61e 100644 --- a/src/Dodge/Item.hs +++ b/src/Dodge/Item.hs @@ -7,7 +7,7 @@ import Dodge.Default import Dodge.Picture import Picture import Geometry.Data -import ShapePicture +--import ShapePicture import Shape keyToken :: Int -> Item @@ -16,8 +16,8 @@ keyToken n = defaultEquipment , _itName = "KEYTOKEN "++show n , _itMaxStack = 5 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ setDepth 0.5 keyPic - , _itEquipPict = \_ _ -> SPic emptySH $ setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic + , _itFloorPict = (,) emptySH $ setDepth 0.5 keyPic + , _itEquipPict = \_ _ -> (,) emptySH $ setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic , _itEffect = NoItEffect , _itHammer = HammerUp , _itID = Nothing @@ -40,8 +40,8 @@ latchkey n = defaultEquipment , _itName = "KEY "++show n , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ setDepth 0.5 latchkeyPic - , _itEquipPict = \_ _ -> SPic emptySH $ setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic + , _itFloorPict = (,) emptySH $ setDepth 0.5 latchkeyPic + , _itEquipPict = \_ _ -> (,) emptySH $ setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic , _itEffect = NoItEffect , _itHammer = HammerUp , _itID = Nothing diff --git a/src/Dodge/Item/Consumable.hs b/src/Dodge/Item/Consumable.hs index 4bfe69c6d..077d39ebb 100644 --- a/src/Dodge/Item/Consumable.hs +++ b/src/Dodge/Item/Consumable.hs @@ -8,7 +8,7 @@ import Dodge.Default import Dodge.SoundLogic import Dodge.SoundLogic.LoadSound import Shape -import ShapePicture +--import ShapePicture import Dodge.Item.Draw import Picture @@ -22,8 +22,8 @@ medkit i = defaultConsumable , _itMaxStack = 9 , _itAmount = 1 , _cnEffect = heal i - , _itFloorPict = SPic emptySH $ setLayer 0 . onLayer FlItLayer . color blue $ circleSolid 3 - , _itEquipPict = pictureItem $ SPic emptySH $ color blue $ circleSolid 3 + , _itFloorPict = (,) emptySH $ setLayer 0 . onLayer FlItLayer . color blue $ circleSolid 3 + , _itEquipPict = pictureItem $ (,) emptySH $ color blue $ circleSolid 3 , _itID = Nothing } diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs index e59a0bab8..035ef630a 100644 --- a/src/Dodge/Item/Equipment.hs +++ b/src/Dodge/Item/Equipment.hs @@ -6,7 +6,7 @@ import Dodge.Default import Dodge.Picture.Layer import Picture import Geometry -import ShapePicture +--import ShapePicture import Shape magShield :: Item @@ -15,8 +15,8 @@ magShield = defaultEquipment , _itName = "MAGSHIELD" , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \_ _ -> SPic emptySH $ blank + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \_ _ -> (,) emptySH $ blank , _itID = Nothing } flameShield :: Item @@ -25,8 +25,8 @@ flameShield = defaultEquipment , _itName = "FLAMESHIELD" , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \cr _ -> SPic emptySH $ onLayer CrLayer $ pictures [color cyan $ circle (_crRad cr+2)] + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \cr _ -> (,) emptySH $ onLayer CrLayer $ pictures [color cyan $ circle (_crRad cr+2)] , _itID = Nothing } {- | Slows you down, blocks forward projectiles. -} @@ -36,11 +36,11 @@ frontArmour = defaultEquipment , _itName = "FARMOUR" , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ translate 0 (-5) $ pictures + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ translate 0 (-5) $ pictures [color (greyN 0.1) $ thickArc 0 (pi/2) 10 5 ,color (greyN 0.1) $ thickArc (3*pi/2) (2*pi) 10 5 ] - , _itEquipPict = \_ _ -> SPic emptySH $ onLayer CrLayer $ pictures + , _itEquipPict = \_ _ -> (,) emptySH $ onLayer CrLayer $ pictures [color (greyN 0.1) $ thickArc 0 (pi/2) 10 5 ,color (greyN 0.1) $ thickArc (3*pi/2) (2*pi) 10 5 ] @@ -54,8 +54,8 @@ jetPack = defaultEquipment , _itName = "JETPACK" , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \_ _ -> SPic emptySH $ onLayer CrLayer + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \_ _ -> (,) emptySH $ onLayer CrLayer $ pictures [color yellow $ polygon $ rectNSEW 5 (-5) (-3) (-11) ] , _itEffect = NoItEffect , _itID = Nothing diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 91ef48f39..1091fd2a0 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -77,13 +77,13 @@ pistol = defaultGun , _wpSpread = 0.02 , _wpRange = 20 , _itHammer = HammerUp - , _itFloorPict = SPic emptySH $ onLayer FlItLayer pistolPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer pistolPic , _itAmount = 1 , _itMaxStack = 1 , _itAimingSpeed = 1 , _itAimingRange = 0 , _itZoom = defaultItZoom - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH pistolPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH pistolPic , _itAttachment = NoItAttachment , _itID = Nothing , _itEffect = wpRecock @@ -121,13 +121,13 @@ rezGun = defaultGun [] , _wpSpread = 0.001 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color chartreuse $ pictures + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color chartreuse $ pictures [polygon $ rectNESW 7 3 1 (-3) ,polygon $ rectNESW (-1) 3 (-7) (-3) ] , _itAimingSpeed = 0.4 , _itAimingRange = 0 - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH $ color chartreuse $ pictures + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH $ color chartreuse $ pictures [polygon $ rectNESW 7 3 1 (-3) ,polygon $ rectNESW (-1) 3 (-7) (-3) ] @@ -152,11 +152,11 @@ teslaGun = defaultGun ] , _wpSpread = 0.001 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer teslaGunPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer teslaGunPic , _itAimingSpeed = 0.4 , _itZoom = defaultItZoom , _itAimingRange = 0 - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH teslaGunPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH teslaGunPic } teslaGunPic :: Picture teslaGunPic = color blue $ pictures @@ -187,10 +187,10 @@ lasGun = defaultAutoGun ] , _wpSpread = 0.001 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer lasGunPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer lasGunPic , _itAimingSpeed = 0.4 , _itAimingRange = 1 - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH lasGunPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH lasGunPic , _itAttachment = ItCharMode $ Seq.fromList "/VZ" , _itScroll = scrollCharMode , _itInvDisplay = basicWeaponDisplay @@ -210,7 +210,7 @@ forceFieldGun = defaultGun , _itUse = undefined , _wpSpread = 0.02 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-4,-4),(-4,4),(4,4),(4,0),(0,0),(0,-4)] + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-4,-4),(-4,4),(4,4),(4,0),(0,0),(0,-4)] , _itAimingSpeed = 0.4 , _itAimingRange = 0.5 } @@ -249,10 +249,10 @@ tractorGun = defaultAutoGun ] , _wpSpread = 0.00001 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ] + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ] , _itAimingSpeed = 0.4 , _itAimingRange = 0.5 - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ] + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ] } @@ -278,10 +278,10 @@ remoteLauncher = defaultGun ] , _wpSpread = 0.02 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) , _itAimingSpeed = 0.2 , _itAimingRange = 0.5 - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) , _itAttachment = ItScope (V2 0 0) 0 1 True } hvAutoGun :: Item @@ -303,10 +303,10 @@ hvAutoGun = defaultAutoGun , withMuzFlareI ] , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer hvAutoGunPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer hvAutoGunPic , _itAimingSpeed = 0.2 , _itAimingRange = 1 - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH hvAutoGunPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH hvAutoGunPic , _wpAmmo = hvBullet } hvAutoGunPic :: Picture @@ -334,11 +334,11 @@ ltAutoGun = defaultAutoGun ] , _wpSpread = 0.5 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer ltAutoGunPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer ltAutoGunPic , _itAimingSpeed = 1 , _itAimingRange = 0 , _itZoom = defaultItZoom - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH ltAutoGunPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH ltAutoGunPic , _itAimStance = OneHand , _wpAmmo = ltBullet } @@ -393,10 +393,10 @@ miniGun = defaultAutoGun , withSmoke 1 black 20 200 5 ] , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer miniGunPict + , _itFloorPict = (,) emptySH $ onLayer FlItLayer miniGunPict , _itAimingSpeed = 0.4 , _itAimingRange = 1 - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH miniGunPict + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH miniGunPict , _wpAmmo = basicBullet } where @@ -440,10 +440,10 @@ spreadGun = defaultGun ] , _wpSpread = spreadGunSpread , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer spreadGunPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer spreadGunPic , _itAimingSpeed = 1 , _itAimingRange = 0 - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH spreadGunPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH spreadGunPic , _wpAmmo = basicBullet , _wpNumBarrels = 50 } @@ -472,12 +472,12 @@ multGun = defaultGun ] , _wpSpread = spreadGunSpread , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer multGunPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer multGunPic , _itAimingSpeed = 0.4 , _itAimingRange = 1 , _itZoom = defaultItZoom , _itAimZoom = defaultItZoom {_itZoomFac = 1.5} - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH multGunPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH multGunPic , _itAimStance = TwoHandTwist , _wpAmmo = basicBullet , _wpNumBarrels = 5 @@ -517,12 +517,12 @@ longGun = defaultGun , withMuzFlareI ] , _wpRange = 200 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer longGunPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer longGunPic , _itAimingSpeed = 0.2 , _itAimingRange = 1 , _itZoom = defaultItZoom , _itAimZoom = defaultItZoom {_itZoomMax = 0.5, _itZoomMin = 0.5} - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH longGunPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH longGunPic , _itScroll = zoomLongGun , _itAttachment = ItScope (V2 0 0) 0 1 False , _itEffect = itemLaserScopeEffect @@ -561,11 +561,11 @@ poisonSprayer = defaultAutoGun , spreadNumI ] , _wpRange = 8 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color yellow $ polygon $ rectNESW 4 4 (-4) (-4) + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color yellow $ polygon $ rectNESW 4 4 (-4) (-4) , _itAimingSpeed = 0.2 , _itAimingRange = 0 , _itZoom = defaultItZoom - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH $ color yellow $ polygon $ rectNESW 4 4 (-4) (-4) + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH $ color yellow $ polygon $ rectNESW 4 4 (-4) (-4) , _wpSpread = 0.1 , _wpNumBarrels = 3 } @@ -588,12 +588,12 @@ flamer = defaultAutoGun ] , _wpSpread = 0 , _wpRange = 8 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer flamerPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer flamerPic , _itAimingSpeed = 0.5 , _itAimingRange = 0 , _itZoom = defaultItZoom , _itAimZoom = defaultItZoom {_itZoomMax = 5, _itZoomMin = 1.5} - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH flamerPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH flamerPic , _itAttachment = NoItAttachment } flamerPic :: Picture @@ -619,7 +619,7 @@ blinkGun = defaultGun , _itLeftClickUse = Just $ hammerCheckL $ shootL aSelfL , _wpSpread = 0.05 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ polygon $ map toV2[(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)] + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2[(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)] , _itAimingSpeed = 1 , _itAimingRange = 0 } @@ -637,7 +637,7 @@ boosterGun = defaultGun , _itLeftClickUse = Just $ boostSelfL 10 , _wpSpread = 0.05 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)] + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)] , _itAimingSpeed = 1 , _itAimingRange = 0 , _itEffect = resetAttachmentID @@ -810,7 +810,7 @@ grenade = Throwable , _itIdentity = Grenade , _itMaxStack = 8 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] , _twMaxRange = 150 , _twAccuracy = 30 , _itUse = \_ -> throwGrenade makeExplosionAt @@ -863,7 +863,7 @@ remoteBomb = defaultThrowable , _itIdentity = RemoteBomb , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] , _twMaxRange = 150 , _twAccuracy = 30 , _itUse = const throwRemoteBomb @@ -871,7 +871,7 @@ remoteBomb = defaultThrowable [ hammerCheckI ] , _itAttachment = ItScope (V2 0 0) 0 1 True - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH remoteBombUnarmedPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH remoteBombUnarmedPic } fireRemoteLauncher :: Creature -> World -> World @@ -1020,7 +1020,7 @@ explodeRemoteBomb itid pjid cr w cid = _crID cr resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTEBOMB" resetPict = set (creatures . ix cid . crInv . ix j . itEquipPict ) - (pictureWeaponOnAim $ SPic emptySH remoteBombUnarmedPic) + (pictureWeaponOnAim $ (,) emptySH remoteBombUnarmedPic) -- resetScope = creatures . ix cid . crInv . ix j . itScope . _Just . scopePos .~ (0,0) j = _crInvSel $ _creatures w IM.! cid remoteBombPic @@ -1042,7 +1042,7 @@ pipe = Craftable , _itName = "PIPE" , _itMaxStack = 3 , _itAmount = 3 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] , _itEquipPict = \_ _ -> emptyBlank , _itID = Nothing , _itInvDisplay = _itName @@ -1068,13 +1068,13 @@ radar = defaultGun , _wpSpread = autogunSpread , _wpRange = 20 , _itHammer = HammerUp - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) , _itAmount = 1 , _itMaxStack = 1 , _itAimingRange = 1 , _itZoom = defaultItZoom { _itZoomMax = 1} , _itAimZoom = defaultItZoom { _itZoomMax = 1} - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) } {- | Sends out pulses that display creatures. -} @@ -1094,13 +1094,13 @@ sonar = defaultGun ] , _wpRange = 20 , _itHammer = HammerUp - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) , _itAmount = 1 , _itMaxStack = 1 , _itAimingRange = 1 , _itZoom = defaultItZoom {_itZoomMax = 1} , _itAimZoom = defaultItZoom {_itZoomMax = 1} - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) } {- | Automatically sends out pulses that display creatures. -} @@ -1110,8 +1110,8 @@ autoSonar = defaultEquipment , _itName = "AUTOSONAR" , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \_ _ -> SPic emptySH $ blank + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \_ _ -> (,) emptySH $ blank , _itEffect = autoSonarEffect , _itID = Nothing , _itAimingSpeed = 1 @@ -1127,8 +1127,8 @@ autoRadar = defaultEquipment , _itName = "AUTORADAR" , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \_ _ -> SPic emptySH $ blank + , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \_ _ -> (,) emptySH $ blank , _itEffect = autoRadarEffect , _itID = Nothing , _itAimingSpeed = 1 diff --git a/src/Dodge/Item/Weapon/AutoGun.hs b/src/Dodge/Item/Weapon/AutoGun.hs index e741d20ac..590f99fb7 100644 --- a/src/Dodge/Item/Weapon/AutoGun.hs +++ b/src/Dodge/Item/Weapon/AutoGun.hs @@ -16,7 +16,7 @@ import Dodge.Item.Weapon.TriggerType import Dodge.SoundLogic.LoadSound import Picture import Geometry -import ShapePicture +--import ShapePicture import Shape import qualified Data.Sequence as Seq @@ -51,12 +51,12 @@ autoGun = defaultAutoGun , _wpSpread = autogunSpread , _wpRange = 20 , _itHammer = HammerUp - , _itFloorPict = SPic emptySH $ onLayer FlItLayer autoGunPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer autoGunPic , _itAimingSpeed = 0.4 , _itAimingRange = 1 , _itZoom = defaultItZoom , _itAimZoom = defaultItZoom {_itZoomFac = 1.5} - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH autoGunPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH autoGunPic , _itEffect = wpRecock , _itAttachment = ItCharMode $ Seq.fromList "MS" , _itScroll = scrollCharMode diff --git a/src/Dodge/Item/Weapon/Bezier.hs b/src/Dodge/Item/Weapon/Bezier.hs index e22794296..f1447915e 100644 --- a/src/Dodge/Item/Weapon/Bezier.hs +++ b/src/Dodge/Item/Weapon/Bezier.hs @@ -18,7 +18,7 @@ import Dodge.Picture.Layer import Dodge.SoundLogic.LoadSound import Picture import Geometry -import ShapePicture +--import ShapePicture import Shape --import System.Random @@ -37,8 +37,8 @@ bezierGun = defaultGun . withRecoilI 40 . torqueBefore 0.05 ] - , _itFloorPict = SPic emptySH $ onLayer FlItLayer bezierGunPic - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH bezierGunPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer bezierGunPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH bezierGunPic , _itAttachment = NoItAttachment , _itScroll = \_ _ -> removeItTarget , _itHammer = HammerUp diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs index cdce8f6a3..cfa39a92d 100644 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ b/src/Dodge/Item/Weapon/Grenade.hs @@ -52,7 +52,7 @@ moveGrenade time dir pID w = case hitWl of grenadePic :: Int -> SPic -grenadePic x = SPic emptySH $ pictures +grenadePic x = (,) emptySH $ pictures [ color (dark $ dark green) $ circleSolid 5 , color green $ arc (degToRad $ (179 * fromIntegral x / 50) - 180 ) (degToRad $ 180 - (179 * fromIntegral x / 50) ) @@ -79,7 +79,7 @@ throwGrenade explosion cr w = setWp $ removePict $ over projectiles addG w , _pjPayload = explosion } j = _crInvSel cr - removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> SPic emptySH blank + removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> (,) emptySH blank i = newProjectileKey w --(_, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w) --(_, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index 18efadc1a..c22cdb89a 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -22,7 +22,7 @@ import Geometry.Vector3D import Picture import qualified IntMapHelp as IM import Padding -import ShapePicture +--import ShapePicture import Shape import Data.Maybe @@ -50,10 +50,10 @@ launcher = defaultGun ] , _wpSpread = 0.02 , _wpRange = 20 - , _itFloorPict = SPic emptySH $ onLayer FlItLayer launcherPic + , _itFloorPict = (,) emptySH $ onLayer FlItLayer launcherPic , _itAimingSpeed = 0.2 , _itAimingRange = 0.5 - , _itEquipPict = pictureWeaponOnAim $ SPic emptySH launcherPic + , _itEquipPict = pictureWeaponOnAim $ (,) emptySH launcherPic , _itHammer = NoHammer , _itEffect = NoItEffect , _wpAmmo = defaultShellAmmo diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index cdf941a6e..3e606fd62 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -79,11 +79,10 @@ setupWorldBounds w = w setupForegroundEdgeVerxs :: World -> World setupForegroundEdgeVerxs w = w & foregroundEdgeVerx .~ polyhedrasToEdges (_foregroundDecorations w) - & foregroundShape .~ Shape vs es + & foregroundShape .~ (vs,es) where - vs = shVfromList $ concatMap (polyToTris . map toShape) $ concatMap _pyFaces $ _foregroundDecorations w + vs = shVfromList $ map pairToSV $ concatMap polyToTris $ concatMap _pyFaces $ _foregroundDecorations w es = shEfromList $ polyhedrasToEdges (_foregroundDecorations w) - toShape (p3,p4) = ShapeV p3 p4 polyhedrasToEdges :: [Polyhedra] -> [Point3] polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 1f11c5d9b..808c1c8ac 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -20,7 +20,8 @@ import Shader.Data import MatrixHelper --import Polyhedra.Data import Polyhedra -import Shape.Data +import Shader.ExtraPrimitive +import Shader.Parameters import Foreign --import Control.Applicative @@ -38,7 +39,7 @@ import Control.Monad import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate) import qualified SDL import qualified Data.Vector.Unboxed.Mutable as UMV -import qualified Data.Vector.Fusion.Stream.Monadic as VS +import Graphics.GL.Core43 doDrawing :: RenderData -> World -> IO Word32 doDrawing pdata w = do @@ -56,21 +57,15 @@ doDrawing pdata w = do -- bind as much data into vbos as feasible at this point -- poke wall points and colors nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol - nSils <- pokePoint3s (shadVBOptr $ _lightingLineShadowShader pdata) - $ VS.fromList - $ (shEList $ worldShape w) --- -- poke foreground geometry for caps --- nCaps <- pokePoint3s (shadVBOptr $ _lightingCapShader pdata) --- $ VS.fromList --- (fmap _svPos (shVList $ worldShape w)) - numShapeVs <- pokeShapeVs (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) - $ VS.fromList $ shVList $ worldShape w - let nCaps = numShapeVs + (numShapeVs,nSils) <- pokeShape + (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) + (shadVBOptr $ _lightingLineShadowShader pdata) + (_eboPtr $ _shapeEBO pdata) + $ worldShape w -- bind wall points, silhouette data, surface geometry uncurry bindShaderBuffers $ unzip [ ( _wallTextureShader pdata, nWalls) , (_lightingLineShadowShader pdata, nSils) --- , (_lightingCapShader pdata, nCaps) , (_shapeShader pdata, numShapeVs) ] -- set the coordinate uniform ready for drawing elements using world coordinates @@ -95,7 +90,22 @@ doDrawing pdata w = do pokeBindFoldableLayer shadV layerCounts $ worldPictures w renderLayer 0 shadV layerCounts - drawShader (_shapeShader pdata) numShapeVs +-- drawShader (_shapeShader pdata) numShapeVs + let fs = _shapeShader pdata + currentProgram $= Just (_shadProg fs) + bindVertexArrayObject $= Just (_vao $ _shadVAO fs) + bindBuffer ElementArrayBuffer $= Just (_ebo $ _shapeEBO pdata) + bufferSubData + ElementArrayBuffer + WriteToBuffer + 0 + (fromIntegral $ glushortSize * numShapeVs) + (_eboPtr $ _shapeEBO pdata) + glDrawElements + (marshalEPrimitiveMode $ _shadPrim fs) + (fromIntegral numShapeVs) + (GL_UNSIGNED_SHORT) + nullPtr --draw floor onto base buffer nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w) @@ -103,7 +113,8 @@ doDrawing pdata w = do drawShader (_textureArrayShader pdata) nTextArrayVs --draw lightmap for base buffer bindFramebuffer Framebuffer $= fst (_fboLighting pdata) - createLightMap pdata lightPoints nWalls nSils nCaps (snd $ snd $ _fboBase pdata) + --createLightMap pdata lightPoints nWalls nSils numShapeVs (snd $ snd $ _fboBase pdata) + createLightMap pdata lightPoints nWalls 0 0 (snd $ snd $ _fboBase pdata) colorMask $= Color4 Enabled Enabled Enabled Enabled clearColor $= Color4 0 0 0 0 --apply lightmap to base buffer @@ -157,7 +168,7 @@ doDrawing pdata w = do depthMask $= Disabled blend $= Enabled bindFramebuffer Framebuffer $= fst (_fboLighting pdata) - createLightMap pdata lightPoints nWalls nSils nCaps (snd $ snd $ _fboCloud pdata) + createLightMap pdata lightPoints nWalls nSils numShapeVs (snd $ snd $ _fboCloud pdata) colorMask $= Color4 Enabled Enabled Enabled Enabled clearColor $= Color4 0 0 0 0 --apply lightmap to cloud buffer diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 3bd3c43f5..b228314b6 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -29,7 +29,7 @@ preloadRender = do -- set up uniform buffer object theUBO <- genObjectName bindBuffer UniformBuffer $= Just theUBO - bufferData UniformBuffer $= (64, nullPtr, DynamicDraw) + bufferData UniformBuffer $= (64, nullPtr, StreamDraw) bindBufferBase IndexedUniformBuffer 0 $= Just theUBO -- setup wall points VBO, VAOs and shaders wpVBOname <- genObjectName @@ -38,7 +38,7 @@ preloadRender = do bufferData ArrayBuffer $= (fromIntegral $ floatSize * numDrawableWalls * 8 , nullPtr - , DynamicDraw + , StreamDraw ) let wpVBO = VBO {_vbo = wpVBOname, _vboPtr = wpVBOptr, _vboAttribSizes = [4,4], _vboStride = 8} wpVAOname <- genObjectName @@ -58,7 +58,7 @@ preloadRender = do bufferData ArrayBuffer $= (fromIntegral $ floatSize * numDrawableWalls * 8 , nullPtr - , DynamicDraw + , StreamDraw ) let winVBO = VBO {_vbo = winVBOname, _vboPtr = winVBOptr, _vboAttribSizes = [4,4], _vboStride = 8} winColVAOname <- genObjectName @@ -67,13 +67,23 @@ preloadRender = do setupVertexAttribPointer 1 4 8 4 let winColVAO = VAO {_vao = winColVAOname, _vaoVBO = winVBO} -- setup shape geometry/cap VBO and two VAOs + -- TODO when making shaders that use these VAOs, don't mallocate ptr space + shEBOname <- genObjectName + shEBOptr <- mallocArray numDrawableElements + bindBuffer ElementArrayBuffer $= Just shEBOname + bufferData ElementArrayBuffer $= + ( fromIntegral $ glushortSize * numDrawableElements + , nullPtr + , StreamDraw + ) + let shEBO = EBO {_ebo = shEBOname, _eboPtr = shEBOptr} shVBOname <- genObjectName shVBOptr <- mallocArray (7 * numDrawableElements) bindBuffer ArrayBuffer $= Just shVBOname bufferData ArrayBuffer $= ( fromIntegral $ floatSize * numDrawableElements * 7 , nullPtr - , DynamicDraw + , StreamDraw ) let shVBO = VBO {_vbo = shVBOname, _vboPtr = shVBOptr, _vboAttribSizes = [4,4], _vboStride = 8} shPosColVAOname <- genObjectName @@ -81,6 +91,7 @@ preloadRender = do bindBuffer ArrayBuffer $= Just shVBOname setupVertexAttribPointer 0 3 7 0 setupVertexAttribPointer 1 4 7 3 + bindBuffer ElementArrayBuffer $= Just shEBOname shPosVAOname <- genObjectName bindVertexArrayObject $= Just shPosVAOname bindBuffer ArrayBuffer $= Just shVBOname @@ -169,6 +180,7 @@ preloadRender = do return $ RenderData { _pictureShaders = shadV , _shapeShader = bslista {_shadVAO = shPosColVAO } + , _shapeEBO = shEBO , _lightingCapShader = lightingCapShad { _shadVAO = shPosVAO } , _lightingLineShadowShader = lightingLineShadowShad , _lightingOccludeShader = wsShad {_shadVAO = wpVAO} diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index 12ae6a30d..912fcfae3 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -148,7 +148,7 @@ setupVBO sizes = do bufferData ArrayBuffer $= (fromIntegral $ floatSize * numDrawableElements * strd , nullPtr - , DynamicDraw + , StreamDraw ) return $ VBO { _vbo = vboName @@ -171,7 +171,7 @@ setupVBOSized sizes ndraw = do bufferData ArrayBuffer $= (fromIntegral $ floatSize * ndraw * strd , nullPtr - , DynamicDraw + , StreamDraw ) return $ VBO { _vbo = vboName diff --git a/src/Shader/Data.hs b/src/Shader/Data.hs index e8ae70219..789cb2565 100644 --- a/src/Shader/Data.hs +++ b/src/Shader/Data.hs @@ -4,6 +4,7 @@ module Shader.Data ( VAO (..) , VBO (..) + , EBO (..) , FullShader (..) , ShaderTexture (..) , EPrimitiveMode (..) @@ -19,6 +20,8 @@ module Shader.Data , vboPtr , vboAttribSizes , vboStride + , ebo + , eboPtr -- | Synonyms , vert , geom @@ -51,6 +54,10 @@ data VBO = VBO , _vboAttribSizes :: [Int] -- ^ It is not clear to me if this is necessary to store or not , _vboStride :: Int } +data EBO = EBO + { _ebo :: BufferObject + , _eboPtr :: Ptr GLushort + } {- | Datatype containing the reference to a texture object. -} newtype ShaderTexture = ShaderTexture { _textureObject :: TextureObject } @@ -75,3 +82,4 @@ frag = FragmentShader makeLenses ''VAO makeLenses ''VBO makeLenses ''FullShader +makeLenses ''EBO diff --git a/src/Shader/Parameters.hs b/src/Shader/Parameters.hs index 34ca78033..1c8cae878 100644 --- a/src/Shader/Parameters.hs +++ b/src/Shader/Parameters.hs @@ -2,6 +2,7 @@ module Shader.Parameters ( floatSize , numDrawableElements , numSubElements + , glushortSize ) where import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Foreign @@ -10,6 +11,14 @@ floatSize :: Int floatSize = sizeOf (0.5 :: GLfloat) {-# INLINE floatSize #-} +--intSize :: Int +--intSize = sizeOf (1 :: GLuint) +--{-# INLINE intSize #-} + +glushortSize :: Int +glushortSize = sizeOf (0 :: GLushort) +{-# INLINE glushortSize #-} + numDrawableElements :: Int {-# INLINE numDrawableElements #-} numDrawableElements = 60000 diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index f5a57e2a6..6993562da 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -7,7 +7,6 @@ module Shader.Poke , pokePoint33s , poke224s , pokeShape - , pokeShapeVs , pokePoint3s ) where import Shader.Data @@ -16,11 +15,13 @@ import Picture.Data import Shape.Data import Geometry.Data +import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate) import Foreign import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Fusion.Stream.Monadic as VS import Control.Monad.Primitive +import Data.Bifoldable --import qualified Data.DList as DL pokeVerxs @@ -41,17 +42,25 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the where sn = _unShadNum theShadNum -pokeShape :: Ptr Float -> Ptr Float -> Shape -> IO (Int,Int) -pokeShape vptr eptr sh = do - nVs <- pokeShapeVs vptr (VS.fromList $ shVList sh) - nEs <- pokePoint3s eptr (VS.fromList $ shEList sh) - return (nVs,nEs) +pokeShape :: Ptr Float -> Ptr Float -> Ptr GLushort -> Shape -> IO (Int,Int) +pokeShape vptr eptr iptr = bifoldlM (pokeShapeVs' vptr iptr) (pokeShapeEs' eptr) (0,0) -pokeShapeVs :: Ptr Float -> VS.Stream IO ShapeV -> IO Int -pokeShapeVs ptr = VS.foldlM' (pokeShapeV ptr) 0 +pokeShapeVs' :: Ptr Float -> Ptr GLushort -> (Int,Int) -> [ShapeV] -> IO (Int, Int) +pokeShapeVs' ptr iptr count = VS.foldlM' (pokeShapeV' ptr iptr) count . VS.fromList -pokeShapeV :: Ptr Float -> Int -> ShapeV -> IO Int -pokeShapeV ptr n sh = do +pokeShapeEs' :: Ptr Float -> (Int,Int) -> [Point3] -> IO (Int, Int) +pokeShapeEs' ptr count = VS.foldlM' (pokeShapeE' ptr) count . VS.fromList + + +pokeShapeE' :: Ptr Float -> (Int,Int) -> Point3 -> IO (Int,Int) +pokeShapeE' ptr (nv,n) (V3 a b c) = do + pokeElemOff ptr (n * 3) a + pokeElemOff ptr (n * 3 + 1) b + pokeElemOff ptr (n * 3 + 2) c + return $ (nv,n + 1) + +pokeShapeV' :: Ptr Float -> Ptr GLushort -> (Int,Int) -> ShapeV -> IO (Int,Int) +pokeShapeV' ptr iptr (n,ne) sh = do pokeElemOff ptr (off 0) a pokeElemOff ptr (off 1) b pokeElemOff ptr (off 2) c @@ -59,12 +68,14 @@ pokeShapeV ptr n sh = do pokeElemOff ptr (off 4) e pokeElemOff ptr (off 5) f pokeElemOff ptr (off 6) g - return (n+1) + pokeElemOff iptr n (fromIntegral n) + return (n+1,ne) where off i = n*7 + i V3 a b c = _svPos sh V4 d e f g = _svCol sh + pokePoint3s :: Ptr Float -> VS.Stream IO Point3 -> IO Int pokePoint3s ptr = VS.foldlM' (pokePoint3 ptr) 0 diff --git a/src/Shape.hs b/src/Shape.hs index 04b27e4a7..665b71cbe 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -20,12 +20,11 @@ import Geometry.ConvexPoly import Shape.Data import Color ---import qualified Data.Vector.Fusion.Stream.Monadic as VS ---import qualified Data.DList as DL +import Data.Bifunctor emptySH :: Shape {-# INLINE emptySH #-} -emptySH = Shape mempty mempty +emptySH = mempty flatCirc :: Float -> Shape {-# INLINE flatCirc #-} @@ -40,16 +39,16 @@ upperPrismPoly -> [Point2] -> Shape {-# INLINE upperPrismPoly #-} -upperPrismPoly h ps = Shape - { _shVertices = topFace <> sideFaces - , _shEdges = topEdges <> bottomEdges <> sideEdges - } +upperPrismPoly h ps = + ( topFace <> sideFaces + , topEdges <> bottomEdges <> sideEdges + ) where topFace = shVfromList $ polyToTris $ map f' ps - f' (V2 x y) = ShapeV {_svPos = V3 x y h, _svCol = black } + f' (V2 x y) = pairToSV (V3 x y h, black) sideFaces = shVfromList $ map addCol $ concat $ zipWith (\a b -> polyToTris (extendSide a b)) ps (tail ps ++ [head ps]) - addCol x = ShapeV {_svPos = x, _svCol = black} + addCol x = pairToSV ( x, black) extendSide (V2 x y) (V2 x' y') = [V3 x y 0, V3 x' y' 0, V3 x' y' h, V3 x y h] topEdges = shEfromList $ concat $ zipWith makeTopEdge ps (tail ps ++ [head ps]) makeTopEdge (V2 x y) (V2 x' y') = [V3 x y h,V3 x' y' h,V3 x y 0,V3 xcen ycen h] @@ -64,18 +63,18 @@ prismPoly -> [Point2] -> Shape {-# INLINE prismPoly #-} -prismPoly h ps = Shape - { _shVertices = topFace <> bottomFace <> sideFaces - , _shEdges = topEdges <> bottomEdges <> sideEdges - } +prismPoly h ps = + ( topFace <> bottomFace <> sideFaces + , topEdges <> bottomEdges <> sideEdges + ) where topFace = shVfromList $ polyToTris $ map f' ps - f' (V2 x y) = ShapeV {_svPos = V3 x y h, _svCol = black } - f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black } + f' (V2 x y) = pairToSV ( V3 x y h, black ) + f (V2 x y) = pairToSV ( V3 x y 0, black ) bottomFace = shVfromList $ polyToTris $ map f $ reverse ps sideFaces = shVfromList $ map addCol $ concat $ zipWith (\a b -> polyToTris (extendSide a b)) ps (tail ps ++ [head ps]) - addCol x = ShapeV {_svPos = x, _svCol = black} + addCol x = pairToSV ( x, black) extendSide (V2 x y) (V2 x' y') = [V3 x y 0, V3 x' y' 0, V3 x' y' h, V3 x y h] topEdges = shEfromList $ concat $ zipWith makeTopEdge ps (tail ps ++ [head ps]) makeTopEdge (V2 x y) (V2 x' y') = [V3 x y h,V3 x' y' h,V3 x y 0,V3 xcen ycen h] @@ -86,12 +85,12 @@ prismPoly h ps = Shape makeSideEdge (V2 xl yl) (V2 x y) (V2 xr yr) = [V3 x y 0, V3 x y h, V3 xr yr 0, V3 xl yl h] flatPoly :: [Point2] -> Shape -flatPoly ps = Shape - { _shVertices = shVfromList $ polyToTris $ map f ps - , _shEdges = shEfromList $ concat $ zipWith g ps (tail ps ++ [head ps]) - } +flatPoly ps = + ( shVfromList $ polyToTris $ map f ps + , shEfromList $ concat $ zipWith g ps (tail ps ++ [head ps]) + ) where - f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black } + f (V2 x y) = pairToSV ( V3 x y 0, black ) g (V2 x y) (V2 a b) = [ V3 x y 0 , V3 a b 0 @@ -100,8 +99,6 @@ flatPoly ps = Shape ] where n = addZ 0 $ vNormal (V2 (a-x) (b-y)) --- where - --n = colorSH :: Color -> Shape -> Shape {-# INLINE colorSH #-} @@ -109,17 +106,11 @@ colorSH col = overCol $ const col overCol :: (Point4 -> Point4) -> Shape -> Shape {-# INLINE overCol #-} -overCol f Shape{_shVertices=vs,_shEdges=es} = Shape - {_shVertices = fmap (overColVertex f) vs - ,_shEdges = es - } +overCol f = first (fmap $ overColVertex f) overPos :: (Point3 -> Point3) -> Shape -> Shape {-# INLINE overPos #-} -overPos f Shape{_shVertices=vs,_shEdges=es} = Shape - {_shVertices = fmap (overPosVertex f) vs - ,_shEdges = fmap f es - } +overPos f = bimap (fmap $ overPosVertex f) (fmap f) translateSH :: Point3 -> Shape -> Shape {-# INLINE translateSH #-} @@ -143,14 +134,8 @@ scaleSH !(V3 a b c) = overPos (\(V3 x y z) -> V3 (x*a) (y*b) (z*c)) overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV {-# INLINE overColVertex #-} -overColVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV - {_svPos = pos - ,_svCol = f col - } +overColVertex f (ShapeV a b) = ShapeV a (f b) overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV {-# INLINE overPosVertex #-} -overPosVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV - {_svPos = f pos - ,_svCol = col - } +overPosVertex f (ShapeV a b) = ShapeV (f a) b diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index a8ad0e836..d05de5beb 100644 --- a/src/Shape/Data.hs +++ b/src/Shape/Data.hs @@ -1,40 +1,47 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} module Shape.Data where import Geometry.Data -import Control.Lens ---import qualified Data.Vector.Fusion.Stream.Monadic as VS -import qualified Data.DList as DL +--import qualified Data.DList as DL ---import Data.Monoid -data Shape = Shape - { _shVertices :: DL.DList ShapeV - , _shEdges :: DL.DList Point3 - } -instance Semigroup Shape where - (<>) (Shape sv1 se1) (Shape sv2 se2) = Shape (sv1 <> sv2) (se1 <> se2) - --(<>) (Shape sv1 se1) (Shape sv2 se2) = Shape (sv1 VS.++ sv2) (se1 VS.++ se2) -instance Monoid Shape where - mempty = Shape mempty mempty +type Shape = ([ShapeV], [Point3]) +_shVertices :: Shape -> [ShapeV] +{-# INLINE _shVertices #-} +_shVertices = fst +_shEdges :: Shape -> [Point3] +{-# INLINE _shEdges #-} +_shEdges = snd shVList :: Shape -> [ShapeV] {-# INLINE shVList #-} -shVList = DL.toList . _shVertices +shVList = _shVertices +--shVList = DL.toList . _shVertices shEList :: Shape -> [Point3] {-# INLINE shEList #-} -shEList = DL.toList . _shEdges +shEList = _shEdges +--shEList = DL.toList . _shEdges {-# INLINE shVfromList #-} -shVfromList = DL.fromList +shVfromList = id +--shVfromList = DL.fromList {-# INLINE shEfromList #-} -shEfromList = DL.fromList +shEfromList = id +--shEfromList = DL.fromList -- edges are given by four consecutive points data ShapeV = ShapeV - { _svPos :: Point3 - , _svCol :: Point4 + {_svPos :: Point3 + ,_svCol :: Point4 } -makeLenses ''ShapeV -makeLenses ''Shape +pairToSV :: (Point3,Point4) -> ShapeV +{-# INLINE pairToSV #-} +pairToSV = uncurry ShapeV + +--_svPos :: ShapeV -> Point3 +--_svPos = fst +--_svCol :: ShapeV -> Point4 +--_svCol = snd diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index 308706980..a954bad7c 100644 --- a/src/ShapePicture.hs +++ b/src/ShapePicture.hs @@ -8,19 +8,17 @@ import ShapePicture.Data import Picture import Geometry +import Data.Bifunctor + emptyBlank :: SPic -emptyBlank = SPic emptySH blank +emptyBlank = (emptySH,blank) translateSPf :: Float -> Float -> SPic -> SPic -translateSPf x y (SPic sh pic) = SPic - (translateSH (V3 x y 0) sh) - (translate x y pic) +translateSPf x y = bimap (translateSH (V3 x y 0)) (translate x y) -- TODO make this uniform: currently the shape translates and the picture is set to a constant translateSPz :: Float -> SPic -> SPic -translateSPz z (SPic sh pic) = SPic - (translateSH (V3 0 0 z) sh) - (setDepth z pic) +translateSPz z = bimap (translateSH (V3 0 0 z)) (setDepth z) rotateSP :: Float -> SPic -> SPic -rotateSP a (SPic sh pic) = SPic (rotateSH a sh) (rotate a pic) +rotateSP a = bimap (rotateSH a) (rotate a) diff --git a/src/ShapePicture/Data.hs b/src/ShapePicture/Data.hs index 9c9c0267d..3e28bac84 100644 --- a/src/ShapePicture/Data.hs +++ b/src/ShapePicture/Data.hs @@ -1,19 +1,14 @@ {-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} +--{-# LANGUAGE TemplateHaskell #-} module ShapePicture.Data where import Shape import Picture -import Control.Lens -data SPic = SPic - { _spShape :: Shape - , _spPicture :: Picture - } +--import Control.Lens -instance Semigroup SPic where - (<>) (SPic a b) (SPic x y) = SPic (a <> x) (b <>y) +type SPic = (Shape, Picture) -instance Monoid SPic where - mempty = SPic emptySH blank - -makeLenses ''SPic +_spShape :: SPic -> Shape +_spShape = fst +_spPicture :: SPic -> Picture +_spPicture = snd