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

Working element buffer object

Browse Source
This commit is contained in:
justin
2021-09-20 12:36:35 +01:00
parent c605ac74ff
commit 5cbcbec101
22 changed files with 242 additions and 212 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Data/Preload/Render.hs
+1
View File
@@ -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
+10 -16
View File
@@ -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
+8 -8
View File
@@ -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
src/Dodge/Item.hs
+5 -5
View File
@@ -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
src/Dodge/Item/Consumable.hs
+3 -3
View File
@@ -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
}
src/Dodge/Item/Equipment.hs
+9 -9
View File
@@ -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
src/Dodge/Item/Weapon.hs
+44 -44
View File
@@ -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
src/Dodge/Item/Weapon/AutoGun.hs
+3 -3
View File
@@ -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
+3 -3
View File
@@ -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
src/Dodge/Item/Weapon/Grenade.hs
+2 -2
View File
@@ -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
+3 -3
View File
@@ -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
+2 -3
View File
@@ -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
+27 -16
View File
@@ -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
src/Preload/Render.hs
+16 -4
View File
@@ -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
+2 -2
View File
@@ -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
+8
View File
@@ -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
+9
View File
@@ -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
+22 -11
View File
@@ -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
src/Shape.hs
+24 -39
View File
@@ -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
src/Shape/Data.hs
+28 -21
View File
@@ -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
src/ShapePicture.hs
+6 -8
View File
@@ -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)
src/ShapePicture/Data.hs
+7 -12
View File
@@ -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