Working element buffer object

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)

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

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)]
+    , _itFloorPict = (,) emptySH $ setLayer 0 $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> SPic emptySH blank
+    , _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
+    , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color blue $ circleSolid 3
-    , _itEquipPict = \_ _ -> SPic emptySH blank
+    , _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)]
+    , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> SPic emptySH $ blank
+    , _itEquipPict = \_ _ -> (,) emptySH $ blank
     , _itID = Nothing
     , _itInvDisplay = _itName
     , _itInvColor = blue

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
+    , _itFloorPict = (,) emptySH $ setDepth 0.5 keyPic
-    , _itEquipPict = \_ _ -> SPic emptySH $ setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.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
+    , _itFloorPict = (,) emptySH $ setDepth 0.5 latchkeyPic
-    , _itEquipPict = \_ _ -> SPic emptySH $ setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic
+    , _itEquipPict = \_ _ -> (,) emptySH $ setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic
     , _itEffect = NoItEffect
     , _itHammer = HammerUp
     , _itID = Nothing

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
+    , _itFloorPict = (,) emptySH $ setLayer 0 . onLayer FlItLayer . color blue $ circleSolid 3
-    , _itEquipPict = pictureItem $ SPic emptySH $ color blue $ circleSolid 3
+    , _itEquipPict = pictureItem $ (,) emptySH $ color blue $ circleSolid 3
     , _itID = Nothing
     }
 

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)]
+    , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> SPic emptySH $ blank
+    , _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)]
+    , _itFloorPict = (,) 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)]
+    , _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)]
+    , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> SPic emptySH $ onLayer CrLayer 
+    , _itEquipPict = \_ _ -> (,) emptySH $ onLayer CrLayer 
         $ pictures [color yellow $ polygon $ rectNSEW 5 (-5) (-3) (-11) ]
     , _itEffect = NoItEffect
     , _itID = Nothing

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)]
+    , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> SPic emptySH $ blank
+    , _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)]
+    , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
-    , _itEquipPict = \_ _ -> SPic emptySH $ blank
+    , _itEquipPict = \_ _ -> (,) emptySH $ blank
     , _itEffect = autoRadarEffect
     , _itID = Nothing
     , _itAimingSpeed = 1

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

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
+    , _itFloorPict = (,) emptySH $ onLayer FlItLayer bezierGunPic
-    , _itEquipPict = pictureWeaponOnAim $ SPic emptySH bezierGunPic
+    , _itEquipPict = pictureWeaponOnAim $ (,) emptySH bezierGunPic
     , _itAttachment = NoItAttachment
     , _itScroll   = \_ _ -> removeItTarget
     , _itHammer = HammerUp

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

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 

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

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) 
+    (numShapeVs,nSils) <- pokeShape
-        $  VS.fromList
+        (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
-        $ (shEList $ worldShape w)
+        (shadVBOptr $ _lightingLineShadowShader pdata) 
---    -- poke foreground geometry for caps
+        (_eboPtr $ _shapeEBO pdata)
---    nCaps <- pokePoint3s (shadVBOptr $ _lightingCapShader pdata)
+        $ worldShape w
---        $ VS.fromList
---            (fmap _svPos (shVList $ worldShape w))
-    numShapeVs <- pokeShapeVs (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) 
-        $ VS.fromList $ shVList $ worldShape w
-    let nCaps = numShapeVs
     -- 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

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}

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

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

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

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 :: Ptr Float -> Ptr Float -> Ptr GLushort -> Shape -> IO (Int,Int)
-pokeShape vptr eptr sh = do
+pokeShape vptr eptr iptr = bifoldlM (pokeShapeVs' vptr iptr) (pokeShapeEs' eptr) (0,0)
-    nVs <- pokeShapeVs vptr (VS.fromList $ shVList sh)
-    nEs <- pokePoint3s eptr (VS.fromList $ shEList sh)
-    return (nVs,nEs)
 
-pokeShapeVs :: Ptr Float -> VS.Stream IO ShapeV -> IO Int
+pokeShapeVs' :: Ptr Float -> Ptr GLushort -> (Int,Int) -> [ShapeV] -> IO (Int, Int)
-pokeShapeVs ptr = VS.foldlM' (pokeShapeV ptr) 0
+pokeShapeVs' ptr iptr count = VS.foldlM' (pokeShapeV' ptr iptr) count . VS.fromList
 
-pokeShapeV :: Ptr Float -> Int -> ShapeV -> IO Int
+pokeShapeEs' :: Ptr Float -> (Int,Int) -> [Point3] -> IO (Int, Int)
-pokeShapeV ptr n sh = do
+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
 

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 Data.Bifunctor
---import qualified Data.DList as DL
 
 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
+upperPrismPoly h ps =
-    { _shVertices = topFace <> sideFaces
+    ( topFace <> sideFaces
-    , _shEdges = topEdges <> bottomEdges <> sideEdges
+    , 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
+prismPoly h ps =
-    { _shVertices = topFace <> bottomFace <> sideFaces
+    ( topFace <> bottomFace <> sideFaces
-    , _shEdges = topEdges <> bottomEdges <> sideEdges
+    , 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 )
-    f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = 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
+flatPoly ps =
-    { _shVertices = shVfromList $ polyToTris $ map f ps
+    ( shVfromList $ polyToTris $ map f ps
-    , _shEdges = shEfromList $ concat $ zipWith g ps (tail ps ++ [head 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 
+overCol f = first (fmap $ overColVertex f)
-    {_shVertices = fmap (overColVertex f) vs
-    ,_shEdges    = es
-    }
 
 overPos :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINE overPos #-}
-overPos f Shape{_shVertices=vs,_shEdges=es} = Shape 
+overPos f = bimap (fmap $ overPosVertex f) (fmap f)
-    {_shVertices = fmap (overPosVertex f) vs
-    ,_shEdges    = fmap f es
-    }
 
 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
+overColVertex f (ShapeV a b) = ShapeV a (f b)
-    {_svPos = pos
-    ,_svCol = f col
-    }
 
 overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
 {-# INLINE overPosVertex #-}
-overPosVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
+overPosVertex f (ShapeV a b) = ShapeV (f a) b
-    {_svPos = f pos
-    ,_svCol = col
-    }

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.DList as DL
---import qualified Data.Vector.Fusion.Stream.Monadic as VS
-import qualified Data.DList as DL
 
---import Data.Monoid
+type Shape = ([ShapeV], [Point3])
-data Shape = Shape
+_shVertices :: Shape -> [ShapeV]
-    { _shVertices :: DL.DList ShapeV
+{-# INLINE _shVertices #-}
-    , _shEdges    :: DL.DList Point3
+_shVertices = fst
-    }
+_shEdges :: Shape -> [Point3]
-instance Semigroup Shape where
+{-# INLINE _shEdges #-}
-    (<>) (Shape sv1 se1) (Shape sv2 se2) = Shape (sv1 <> sv2) (se1 <> se2)
+_shEdges = snd
-    --(<>) (Shape sv1 se1) (Shape sv2 se2) = Shape (sv1 VS.++ sv2) (se1 VS.++ se2)
-instance Monoid Shape where
-    mempty = Shape mempty mempty
 
 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
     }
-makeLenses ''ShapeV
+pairToSV :: (Point3,Point4) -> ShapeV
-makeLenses ''Shape
+{-# INLINE pairToSV #-}
+pairToSV = uncurry ShapeV
+
+--_svPos :: ShapeV -> Point3
+--_svPos = fst
+--_svCol :: ShapeV -> Point4
+--_svCol = snd

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
+translateSPf x y = bimap (translateSH (V3 x y 0)) (translate x y)
-    (translateSH (V3 x y 0) sh)
-    (translate x y pic)
 
 -- 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
+translateSPz z  = bimap (translateSH (V3 0 0 z)) (setDepth z)
-    (translateSH (V3 0 0 z) sh)
-    (setDepth z pic)
 
 rotateSP :: Float -> SPic -> SPic
-rotateSP a (SPic sh pic) = SPic (rotateSH a sh) (rotate a pic)
+rotateSP a = bimap (rotateSH a) (rotate a)

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
+--import Control.Lens
-data SPic = SPic 
-    { _spShape :: Shape 
-    , _spPicture :: Picture
-    }
 
-instance Semigroup SPic where
+type SPic =  (Shape, Picture)
-    (<>) (SPic a b) (SPic x y) = SPic (a <> x) (b <>y)
 
-instance Monoid SPic where
+_spShape :: SPic -> Shape
-    mempty = SPic emptySH blank
+_spShape = fst
-
+_spPicture :: SPic -> Picture
-makeLenses ''SPic
+_spPicture = snd