From 9e89dcebe7ab454a3cd368dc08bcc65cbc33c254 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 16 Mar 2023 21:56:34 +0000 Subject: [PATCH] Cleanup --- src/Dodge/Creature/Picture.hs | 46 +-- src/Dodge/Item/Draw/SPic.hs | 8 +- src/Dodge/Projectile/Draw.hs | 2 +- src/Dodge/Prop/Draw.hs | 10 +- src/Dodge/Room/Foreground.hs | 2 +- src/Shader/Poke.hs | 537 +++++++++++++++++++--------------- src/Shape.hs | 46 +-- 7 files changed, 351 insertions(+), 300 deletions(-) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index 408ad6e4f..8c0444534 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -44,7 +44,7 @@ basicCrShape cr where cskin = _crType cr crsize = 0.1 * _crRad cr - tr = uncurryV translateSHf (_crPos cr) + tr = uncurryV translateSHxy (_crPos cr) rotdir = rotateSH (_crDir cr) rotmdir = rotateSH (_crMvDir cr) @@ -53,18 +53,18 @@ feet :: Creature -> Shape feet cr = case cr ^? crStance . carriage of Just (Walking sa LeftForward) -> mconcat - [ translateSHf (f sa) off aFoot - , translateSHf (- f sa) (- off) aFoot + [ translateSHxy (f sa) off aFoot + , translateSHxy (- f sa) (- off) aFoot ] Just (Walking sa RightForward) -> mconcat - [ translateSHf (- f sa) off aFoot - , translateSHf (f sa) (- off) aFoot + [ translateSHxy (- f sa) off aFoot + , translateSHxy (f sa) (- off) aFoot ] _ -> mconcat - [ translateSHf 0 off aFoot - , translateSHf 0 (- off) aFoot + [ translateSHxy 0 off aFoot + , translateSHxy 0 (- off) aFoot ] where aFoot :: Shape @@ -78,18 +78,18 @@ deadFeet :: Creature -> Shape deadFeet cr = case cr ^? crStance . carriage of Just (Walking sa LeftForward) -> mconcat - [ translateSHf (f sa) off aFoot - , translateSHf (- f sa) (- off) aFoot + [ translateSHxy (f sa) off aFoot + , translateSHxy (- f sa) (- off) aFoot ] Just (Walking sa RightForward) -> mconcat - [ translateSHf (- f sa) off aFoot - , translateSHf (f sa) (- off) aFoot + [ translateSHxy (- f sa) off aFoot + , translateSHxy (f sa) (- off) aFoot ] _ -> mconcat - [ translateSHf 0 off aFoot - , translateSHf 0 (- off) aFoot + [ translateSHxy 0 off aFoot + , translateSHxy 0 (- off) aFoot ] where aFoot :: Shape @@ -122,9 +122,9 @@ deadRot cr = overPosSH (Q.rotateToZ d) scalp :: Creature -> Shape {-# INLINE scalp #-} scalp cr - | twists cr = translateSHf 0 5 . rotateSH (-1) $ translateSHf (negate 2.5) 0.25 fhead - | oneH cr = rotateSH 0.5 $ translateSHf 2.5 0 fhead - | otherwise = translateSHf 2.5 0 fhead + | twists cr = translateSHxy 0 5 . rotateSH (-1) $ translateSHxy (negate 2.5) 0.25 fhead + | oneH cr = rotateSH 0.5 $ translateSHxy 2.5 0 fhead + | otherwise = translateSHxy 2.5 0 fhead where fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 4 5 @@ -134,19 +134,19 @@ torso cr | oneH cr = rotateSH 0.5 $ mconcat - [ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder - , translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder + [ translateSHxy 0 3 . rotateSH (negate 0.2) $ aShoulder + , translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder ] | twists cr = - translateSHf 0 5 . rotateSH (-1) $ + translateSHxy 0 5 . rotateSH (-1) $ mconcat - [ rotateSH (negate 0.2) . translateSHf 2 3 . rotateSH (negate 0.4) $ aShoulder - , rotateSH (negate 0.2) . translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder + [ rotateSH (negate 0.2) . translateSHxy 2 3 . rotateSH (negate 0.4) $ aShoulder + , rotateSH (negate 0.2) . translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder ] | otherwise = mconcat - [ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder - , translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder + [ translateSHxy 0 3 . rotateSH (negate 0.2) $ aShoulder + , translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder ] where aShoulder = scaleSH (V3 10 10 1) baseShoulder diff --git a/src/Dodge/Item/Draw/SPic.hs b/src/Dodge/Item/Draw/SPic.hs index 6d24d27b7..4b57910d0 100644 --- a/src/Dodge/Item/Draw/SPic.hs +++ b/src/Dodge/Item/Draw/SPic.hs @@ -30,7 +30,7 @@ equipItemSPic et _ = case et of MAGSHIELD -> defSPic FLAMESHIELD -> defSPic FRONTARMOUR -> - ( emptySH + ( mempty , setDepth 20 $ pictures [ color yellow $ thickArc 0 (pi / 2) 10 5 @@ -191,8 +191,8 @@ heldItemSPic ht it = case ht of torchShape :: Shape torchShape = colorSH blue $ - translateSHf 0 1.5 side - <> translateSHf 0 (-1.5) side + translateSHxy 0 1.5 side + <> translateSHxy 0 (-1.5) side <> translateSHz 2.5 top <> translateSHz (-0.5) bot <> back @@ -397,7 +397,7 @@ baseSMGShape = colorSH green $ upperPrismPoly 3 $ rectXH 20 2 flamerPic :: Item -> SPic flamerPic it = ( colorSH yellow $ - translateSHf tx ty (upperPrismPoly tz $ polyCirc 3 r) + translateSHxy tx ty (upperPrismPoly tz $ polyCirc 3 r) <> upperPrismPoly 5 (rectNESW 2 18 (-2) 0) , color black $ translate3 (V3 tx ty (tz + 0.01)) $ circleSolid (r * am) ) diff --git a/src/Dodge/Projectile/Draw.hs b/src/Dodge/Projectile/Draw.hs index 298e7a8d2..c97431a3a 100644 --- a/src/Dodge/Projectile/Draw.hs +++ b/src/Dodge/Projectile/Draw.hs @@ -18,7 +18,7 @@ drawShell :: Proj -> SPic drawShell pj = noPic . translateSHz 18 - . uncurryV translateSHf (_prjPos pj) + . uncurryV translateSHxy (_prjPos pj) $ rotateSH (argV $ _prjAcc pj) shellShape shellShape :: Shape diff --git a/src/Dodge/Prop/Draw.hs b/src/Dodge/Prop/Draw.hs index ce15f28e6..35ecbcba9 100644 --- a/src/Dodge/Prop/Draw.hs +++ b/src/Dodge/Prop/Draw.hs @@ -43,7 +43,7 @@ propDrawToggle pd pr drawLampCover :: Float -> Prop -> SPic drawLampCover h pr = - ( translateSHz (h -2.5) . uncurryV translateSHf (_prPos pr) $ + ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $ rotateSH (_prRot pr) $ mconcat [ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3 @@ -57,7 +57,7 @@ drawLampCover h pr = drawVerticalLampCover :: Float -> Prop -> SPic drawVerticalLampCover h pr = - ( translateSHz h . uncurryV translateSHf (_prPos pr) $ + ( translateSHz h . uncurryV translateSHxy (_prPos pr) $ rotateSHx (_prRot pr) $ mconcat [ translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5 @@ -69,20 +69,20 @@ drawMovingShape :: Prop -> Shape -> SPic drawMovingShape pr = noPic . translateSHz (_prPosZ pr) - . uncurryV translateSHf (_prPos pr) + . uncurryV translateSHxy (_prPos pr) . overPosSH (Q.rotate (_prQuat pr)) drawMovingShapeCol :: Prop -> Shape -> SPic drawMovingShapeCol pr = noPic . translateSHz (_prPosZ pr) - . uncurryV translateSHf (_prPos pr) + . uncurryV translateSHxy (_prPos pr) . overPosSH (Q.rotate (_prQuat pr)) . colorSH (_prColor pr) drawDoubleLampCover :: Float -> Prop -> SPic drawDoubleLampCover h pr = - ( translateSHz (h -2.5) . uncurryV translateSHf (_prPos pr) $ + ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $ rotateSH (_prRot pr) $ mconcat [ upperPrismPoly 5 $ reverse $ rectNSWE 6 5 (-6) 6 diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 88abb77bb..673e1da1c 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -136,7 +136,7 @@ putShape sh = defaultForeground & fsPos .~ m & fsRad .~ radBounds bnds - & fsSPic .~ noPic (uncurryV translateSHf (- m) sh) + & fsSPic .~ noPic (uncurryV translateSHxy (- m) sh) where bnds = shapeBounds sh m = midBounds bnds diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 9627b6911..22df75949 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -1,67 +1,63 @@ -module Shader.Poke - ( pokeVerxs - , pokeLayVerxs - , pokeArrayOff - , pokeShape - , pokeWallsWindowsFloor - , memoTopPrismEdgeIndices - ) where -import Linear.V3 (cross) -import Geometry.Polygon -import Shader.Data -import Shader.Parameters -import Picture.Data -import Shape.Data -import Geometry.Data -import Control.Monad ---import ShapePicture +module Shader.Poke ( + pokeVerxs, + pokeLayVerxs, + pokeArrayOff, + pokeShape, + pokeWallsWindowsFloor, + memoTopPrismEdgeIndices, +) where -import Graphics.GL.Core45 -import Foreign +--import Control.Monad +import Control.Monad.Primitive import qualified Data.Vector as V +import qualified Data.Vector.Fusion.Stream.Monadic as VFSM +import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Unboxed as UV import qualified Data.Vector.Unboxed.Mutable as UMV -import qualified Data.Vector.Mutable as MV -import qualified Data.Vector.Fusion.Stream.Monadic as VFSM ---import Data.Vector.Fusion.Util -import Control.Monad.Primitive ---import qualified Control.Monad.Parallel as MP +import Foreign +import Geometry.Data +import Geometry.Polygon +import Graphics.GL.Core45 +import Linear.V3 (cross) +import Picture.Data +import Shader.Data +import Shader.Parameters +import Shape.Data -pokeVerxs - :: MV.MVector (PrimState IO) (FullShader,VBO) - -> UMV.MVector (PrimState IO) Int - -> Picture - -> IO () ---pokeVerxs vbos count = S.mapM_ (pokeVerx vbos count) . S.each +pokeVerxs :: + MV.MVector (PrimState IO) (FullShader, VBO) -> + UMV.MVector (PrimState IO) Int -> + Picture -> + IO () pokeVerxs vbos count = VFSM.mapM_ (pokeVerx vbos count) . VFSM.fromList -pokeVerx :: MV.MVector (PrimState IO) (FullShader,VBO) -> UMV.MVector (PrimState IO) Int -> Verx -> IO () -pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do +pokeVerx :: MV.MVector (PrimState IO) (FullShader, VBO) -> UMV.MVector (PrimState IO) Int -> Verx -> IO () +pokeVerx vbos offsets Verx{_vxPos = thePos, _vxCol = theCol, _vxExt = ext, _vxShadNum = theShadNum} = do typeOff <- UMV.unsafeRead offsets sn basePtr <- _vboPtr . snd <$> MV.unsafeRead vbos sn let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize) poke34 thePtr thePos theCol pokeArrayOff thePtr 7 ext - UMV.unsafeModify offsets (+1) sn + UMV.unsafeModify offsets (+ 1) sn where sn = _unShadNum theShadNum -pokeWallsWindowsFloor - :: Ptr Float - -> Ptr Float - -> Ptr Float - -> [ ( (Point2,Point2) , Point4 ) ] - -> [ ( (Point2,Point2) , Point4 ) ] - -> [ ( Point3 , Point3 ) ] - -> IO (Int,Int,Int) +pokeWallsWindowsFloor :: + Ptr Float -> + Ptr Float -> + Ptr Float -> + [((Point2, Point2), Point4)] -> + [((Point2, Point2), Point4)] -> + [(Point3, Point3)] -> + IO (Int, Int, Int) pokeWallsWindowsFloor wlptr wiptr flptr wls wis fls = do wlcounts1 <- VFSM.foldlM' (pokeW wlptr) 0 (VFSM.fromList wls) wlcounts2 <- VFSM.foldlM' (pokeW wiptr) 0 (VFSM.fromList wis) - flcounts <- VFSM.foldlM' (pokeF flptr) 0 (VFSM.fromList fls) - return (wlcounts1,wlcounts2,flcounts) + flcounts <- VFSM.foldlM' (pokeF flptr) 0 (VFSM.fromList fls) + return (wlcounts1, wlcounts2, flcounts) -pokeF :: Ptr Float -> Int -> (Point3,Point3) -> IO Int -pokeF ptr i' (V3 a b c,V3 d e f) = do +pokeF :: Ptr Float -> Int -> (Point3, Point3) -> IO Int +pokeF ptr i' (V3 a b c, V3 d e f) = do let i = i' * 6 pokeElemOff ptr (i + 0) a pokeElemOff ptr (i + 1) b @@ -71,8 +67,8 @@ pokeF ptr i' (V3 a b c,V3 d e f) = do pokeElemOff ptr (i + 5) f return $ i' + 1 -pokeW :: Ptr Float -> Int -> ((Point2,Point2),Point4) -> IO Int -pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do +pokeW :: Ptr Float -> Int -> ((Point2, Point2), Point4) -> IO Int +pokeW ptr i' ((V2 a b, V2 c d), V4 e f g h) = do let i = i' * 8 pokeElemOff ptr (i + 0) a pokeElemOff ptr (i + 1) b @@ -84,19 +80,22 @@ pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do pokeElemOff ptr (i + 7) h return $ i' + 1 -pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort - -> (Int,Int,Int) - -> [Surface] - -> IO (Int,Int,Int) +pokeShape :: + Ptr Float -> + Ptr GLushort -> + Ptr GLushort -> + (Int, Int, Int) -> + [Surface] -> + IO (Int, Int, Int) pokeShape ptr iptr ieptr is = VFSM.foldlM' (pokeShapeObj ptr iptr ieptr) is . VFSM.fromList -pokeShapeObj - :: Ptr Float - -> Ptr GLushort - -> Ptr GLushort - -> (Int,Int,Int) - -> Surface - -> IO (Int,Int,Int) +pokeShapeObj :: + Ptr Float -> + Ptr GLushort -> + Ptr GLushort -> + (Int, Int, Int) -> + Surface -> + IO (Int, Int, Int) {-# INLINE pokeShapeObj #-} pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of TopPrism size -> pokeTopPrism midp col size ptr iptr ieptr counts (VFSM.fromList shVerts) @@ -106,263 +105,334 @@ pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of where midp = centroidNum shVerts -pokeRoundedFaces :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort - -> (Int,Int,Int) - -> [Point3] - -> IO (Int,Int,Int) -pokeRoundedFaces col size ptr iptr ieptr (nv,nshapeindices,nei) (tc:bc:svs) = do +pokeRoundedFaces :: + Point4 -> + Int -> + Ptr Float -> + Ptr GLushort -> + Ptr GLushort -> + (Int, Int, Int) -> + [Point3] -> + IO (Int, Int, Int) +pokeRoundedFaces col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = do nv' <- pokeRoundedCurve col ptr tc bc svs nv - nsi' <- UV.foldM' (pokeIndex nv iptr) nshapeindices - --(memoTopPrismIndices V.! (size - 2)) - (memoTopPrismIndices V.! (size - 3)) - nei' <- UV.foldM' (pokeIndex nv ieptr) nei - $ memoTopPrismEdgeIndices V.! (size - 3) - return (nv',nsi',nei') + nsi' <- + UV.foldM' + (pokeIndex nv iptr) + nsi + (memoTopPrismIndices V.! (size - 3)) + nei' <- + UV.foldM' (pokeIndex nv ieptr) nei $ + memoTopPrismEdgeIndices V.! (size - 3) + return (nv', nsi', nei') pokeRoundedFaces _ _ _ _ _ _ _ = undefined -pokeCylinder :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort - -> (Int,Int,Int) - -> [Point3] - -> IO (Int,Int,Int) -pokeCylinder col size ptr iptr ieptr (nv,nshapeindices,nei) (tc:bc:svs) = do +pokeCylinder :: + Point4 -> + Int -> + Ptr Float -> + Ptr GLushort -> + Ptr GLushort -> + (Int, Int, Int) -> + [Point3] -> + IO (Int, Int, Int) +pokeCylinder col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = do nv' <- pokeRoundedCurve col ptr tc bc svs nv >>= pokeCylinderCaps col ptr tc bc svs - nsi' <- UV.foldM' (pokeIndex nv iptr) nshapeindices - (memoCylinderIndices V.! (size - 3)) - nei' <- UV.foldM' (pokeIndex nv ieptr) nei - $ memoTopPrismEdgeIndices V.! (size - 3) - return (nv',nsi',nei') + nsi' <- + UV.foldM' + (pokeIndex nv iptr) + nsi + (memoCylinderIndices V.! (size - 3)) + nei' <- + UV.foldM' (pokeIndex nv ieptr) nei $ + memoTopPrismEdgeIndices V.! (size - 3) + return (nv', nsi', nei') pokeCylinder _ _ _ _ _ _ _ = undefined pokeRoundedCurve :: Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] -> Int -> IO Int -pokeRoundedCurve col ptr tc bc svs nv = go True svs nv +pokeRoundedCurve col ptr tc bc = go True where + go True (x : xs) n = pokeJustV tc col ptr n x >>= go False xs + go False (x : xs) n = pokeJustV bc col ptr n x >>= go True xs go _ [] n = return n - go True (x:xs) n = pokeJustV tc col ptr n x >>= go False xs - go False (x:xs) n = pokeJustV bc col ptr n x >>= go True xs pokeCylinderCaps :: Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] -> Int -> IO Int -pokeCylinderCaps col ptr tc bc svs nv = go True svs nv +pokeCylinderCaps col ptr tc bc = go True where + go True (x : xs) n = pokeJustVInvNormal tc col ptr n x >>= go False xs + go False (x : xs) n = pokeJustVInvNormal bc col ptr n x >>= go True xs go _ [] n = return n - go True (x:xs) n = pokeJustVInvNormal tc col ptr n x >>= go False xs - go False (x:xs) n = pokeJustVInvNormal bc col ptr n x >>= go True xs -pokeBox :: Point4 -> Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort - -> (Int,Int,Int) - -> [Point3] - -> IO (Int,Int,Int) +pokeBox :: + Point4 -> + Int -> + Ptr Float -> + Ptr GLushort -> + Ptr GLushort -> + (Int, Int, Int) -> + [Point3] -> + IO (Int, Int, Int) {-# INLINE pokeBox #-} -pokeBox col size ptr iptr ieptr (nv,nshapeindices,nei) svs = do - nv' <- VFSM.foldM' (pokeBoxSurface col ptr svs) nv $ VFSM.fromList $ boxSurfaces size - nshapeindices' <- UV.foldM' (pokeIndex nv iptr) nshapeindices - (memoFlatIndices V.! (size -3)) - nei' <- UV.foldM' (pokeIndex nv ieptr) nei - $ memoBoxEdgeIndices V.! (size - 3) - return (nv', nshapeindices', nei') +pokeBox col size ptr iptr ieptr (nv, nsi, nei) svs = do + nv' <- VFSM.foldM' (pokeBoxSurface col ptr svsv) nv $ VFSM.fromList $ boxSurfaces size + nsi' <- + UV.foldM' + (pokeIndex nv iptr) + nsi + (memoFlatIndices V.! (size -3)) + nei' <- + UV.foldM' (pokeIndex nv ieptr) nei $ + memoBoxEdgeIndices V.! (size - 3) + return (nv', nsi', nei') + where + svsv = UV.fromList svs -- should probably use a vector of Point3 -pokeBoxSurface :: Point4 -> Ptr Float -> [Point3] -> Int -> [Int] -> IO Int -pokeBoxSurface col ptr vs n is = foldM - (pokeFlatV norm col ptr) - n - v +pokeBoxSurface :: Point4 -> Ptr Float -> UV.Vector Point3 -> Int -> [Int] -> IO Int +pokeBoxSurface col ptr vs n is = + UV.foldM' + (pokeFlatV norm col ptr) + n + v where - v = (V.backpermute (V.fromList vs) (V.fromList is)) - x = v V.! 0 - y = v V.! 1 - z = v V.! 2 - norm = negate $ cross (x-y) (z-y) + v = UV.backpermute vs (UV.fromList is) + x = v UV.! 0 + y = v UV.! 1 + z = v UV.! 2 + norm = negate $ cross (x - y) (z - y) +-- should probably memoize this boxSurfaces :: Int -> [[Int]] -boxSurfaces size = [0,2 .. size * 2 -1] - : [1,3 .. size * 2] - : map f [0,2 .. size * 2 - 1] +boxSurfaces size = + [0, 2 .. size * 2 -1] : + [1, 3 .. size * 2] : + map f [0, 2 .. size * 2 - 1] where - f x = map (`mod` (size *2)) [x, x+1, x+3, x+2] + f x = map (`mod` (size * 2)) [x, x + 1, x + 3, x + 2] boxSurfaces' :: Int -> [[Int]] -boxSurfaces' n = [0 .. n -1] - : reverse [n .. n * 2-1] - : map (map ((2*n)+)) [[4*i,4*i+1,4*i+2,4*i+3] | i <- [0..n-1]] +boxSurfaces' n = + [0 .. n -1] : + reverse [n .. n * 2 -1] : + [ map ((2 * n) +) [4 * i, 4 * i + 1, 4 * i + 2, 4 * i + 3] | i <- [0 .. n -1]] -pokeTopPrism :: Point3 -> Point4 -> Int -> Ptr Float -> Ptr GLushort - -> Ptr GLushort - -> (Int,Int,Int) - -> VFSM.Stream IO Point3 - -> IO (Int,Int,Int) +pokeTopPrism :: + Point3 -> + Point4 -> + Int -> + Ptr Float -> + Ptr GLushort -> + Ptr GLushort -> + (Int, Int, Int) -> + VFSM.Stream IO Point3 -> + IO (Int, Int, Int) {-# INLINE pokeTopPrism #-} -pokeTopPrism cp col size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do +pokeTopPrism cp col size ptr iptr ieptr (nv, nsi, nei) svs = do nv' <- VFSM.foldlM' (pokeJustV cp col ptr) nv svs - nshapeindices' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices - (memoTopPrismIndices V.! (size - 3)) - nedgeindices' <- UV.foldM' (pokeIndex nv ieptr) nedgeindices - (memoTopPrismEdgeIndices V.! (size - 3)) - return (nv', nshapeindices', nedgeindices') + nsi' <- + UV.foldM' + --(pokeTopPrismIndex nv iptr) + (pokeIndex nv iptr) + nsi + (memoTopPrismIndices V.! (size - 3)) + nei' <- + UV.foldM' + (pokeIndex nv ieptr) + nei + (memoTopPrismEdgeIndices V.! (size - 3)) + return (nv', nsi', nei') -pokeIndex - :: Int -- ^ base index - -> Ptr GLushort - -> Int -- ^ number poked - -> Int -- ^ index offset - -> IO Int +pokeIndex :: + -- | base index + Int -> + Ptr GLushort -> + -- | number poked + Int -> + -- | index offset + Int -> + IO Int {-# INLINE pokeIndex #-} -pokeIndex nv eiptr nedgeindices ioff = do - pokeElemOff eiptr nedgeindices (fromIntegral $ nv + ioff) - return $ nedgeindices + 1 +pokeIndex nv eiptr ni ioff = do + pokeElemOff eiptr ni (fromIntegral $ nv + ioff) + return $ ni + 1 -pokeTopPrismIndex :: Int -> Ptr GLushort - -> Int - -> Int - -> IO Int -{-# INLINE pokeTopPrismIndex #-} -pokeTopPrismIndex nv iptr nshapeindices ioff = do - pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff) - return $ nshapeindices + 1 +--pokeTopPrismIndex :: +-- Int -> +-- Ptr GLushort -> +-- Int -> +-- Int -> +-- IO Int +--{-# INLINE pokeTopPrismIndex #-} +--pokeTopPrismIndex nv iptr nshapeindices ioff = do +-- pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff) +-- return $ nshapeindices + 1 triangulate :: [Int] -> [Int] triangulate is = V.toList . V.backpermute (V.fromList is) . V.fromList $ triangulateIndices (length is) - + triangulateIndices :: Int -> [Int] -triangulateIndices i = concatMap f [0..i-3] +triangulateIndices i = concatMap f [0 .. i -3] where - f x | even x = [0,(x+1),(x+2)] - | otherwise = [0,(x+2),(x+1)] + f x + | even x = [0, x + 1, x + 2] + | otherwise = [0, x + 2, x + 1] memoFlatIndices :: V.Vector (UV.Vector Int) -memoFlatIndices = V.generate 10 - $ UV.fromList . concatMap triangulate . boxSurfaces' . (+3) +memoFlatIndices = + V.generate 10 $ + UV.fromList . concatMap triangulate . boxSurfaces' . (+ 3) memoTopPrismIndices :: V.Vector (UV.Vector Int) -memoTopPrismIndices = V.generate 10 - $ UV.fromList . topPrismIndices . (+ 3) +memoTopPrismIndices = + V.generate 10 $ + UV.fromList . topPrismIndices . (+ 3) memoCylinderIndices :: V.Vector (UV.Vector Int) -memoCylinderIndices = V.generate 10 - $ UV.fromList . cylinderIndices . (+ 3) +memoCylinderIndices = + V.generate 10 $ + UV.fromList . cylinderIndices . (+ 3) memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int) -memoTopPrismEdgeIndices = V.generate 10 - $ UV.fromList . topPrismEdgeIndices . (+3) +memoTopPrismEdgeIndices = + V.generate 10 $ + UV.fromList . topPrismEdgeIndices . (+ 3) -topPrismEdgeIndices - :: Int -- ^ the number of vertices on the top surface, ie. half the total - -> [Int] -topPrismEdgeIndices n = concatMap f [0..n-1] +topPrismEdgeIndices :: + -- | the number of vertices on the top surface, ie. half the total + Int -> + [Int] +topPrismEdgeIndices n = concatMap f [0 .. n -1] where f i = map g - [ 0 , 2 , 1 , 4 - , 0 , 1 ,-2 , 3 - , 1 , 3 ,-1 , 2 - ] + [ 0 , 2 , 1 , 4 + , 0 , 1 , -2 , 3 + , 1 , 3 , -1 , 2 + ] where - g j = (2 * i + j) `mod` (2*n) + g j = (2 * i + j) `mod` (2 * n) memoBoxEdgeIndices :: V.Vector (UV.Vector Int) -memoBoxEdgeIndices = V.generate 10 - $ UV.fromList . boxEdgeIndices . (+3) +memoBoxEdgeIndices = + V.generate 10 $ + UV.fromList . boxEdgeIndices . (+ 3) -boxEdgeIndices - :: Int -- ^ the number of vertices on the top surface, ie. half the total - -> [Int] -boxEdgeIndices n = concatMap f [0..n-1] +boxEdgeIndices :: + -- | the number of vertices on the top surface, ie. half the total + Int -> + [Int] +boxEdgeIndices n = concatMap f [0 .. n -1] where - f i = map g - [ 0 , 1 , n , 2 - , 0 , n ,-1 , n+1 - , n , n+1 ,n-1 , 1 - ] + f i = + map + g + [ 0 , 1 , n , 2 + , 0 , n , -1 , n + 1 + , n , n + 1 , n -1 , 1 + ] where - g j = (i + j) `mod` (2*n) + g j = (i + j) `mod` (2 * n) cylinderIndices :: Int -> [Int] -cylinderIndices n = cylinderRoundIndices n - ++ triangulate [2*n, 2*n+2 .. 4*n - 1] - ++ triangulate [2*n+1, 2*n+3 .. 4*n - 1] +cylinderIndices n = + cylinderRoundIndices n + ++ triangulate [2 * n, 2 * n + 2 .. 4 * n - 1] + ++ triangulate [2 * n + 1, 2 * n + 3 .. 4 * n - 1] cylinderRoundIndices :: Int -> [Int] -cylinderRoundIndices n = [2*n-2,2*n-1,1 - ,2*n-2,1,0] -- last side triangle (applies mod 2n) - ++ concatMap g [0..n-2] -- other triangles on sides +cylinderRoundIndices n = + [ 2 * n -2 , 2 * n -1 , 1 + , 2 * n -2 , 1 , 0 -- last side triangle (applies mod 2n) + ] + ++ concatMap g [0 .. n -2] -- other triangles on sides where - g x = [2*x,2*x+1,2*x+3 - ,2*x,2*x+3,2*x+2] + g x = + [ 2 * x , 2 * x + 1 , 2 * x + 3 + , 2 * x , 2 * x + 3 , 2 * x + 2 + ] topPrismIndices :: Int -> [Int] -topPrismIndices n = concatMap f [1..n-2] -- triangles on top face - ++ concatMap f' [1..n-2] -- triangles on bottom face - -- these should be checked - ++ [2*n-2,2*n-1,1 - ,2*n-2,1,0] -- last side triangle (applies mod 2n) - ++ concatMap g [0..n-2] -- other triangles on sides +topPrismIndices n = + concatMap f [1 .. n -2] -- triangles on top face + ++ concatMap f' [1 .. n -2] -- triangles on bottom face + -- these should be checked + ++ [ 2 * n -2 , 2 * n -1 , 1 + , 2 * n -2 , 1 , 0 -- last side triangle (applies mod 2n) + ] + ++ concatMap g [0 .. n -2] -- other triangles on sides where - f x = [0,2*x,2*x+2] - f' x = [1,2*x+3,2*x+1] - g x = [2*x,2*x+1,2*x+3 - ,2*x,2*x+3,2*x+2] + f x = [0, 2 * x, 2 * x + 2] + f' x = [1, 2 * x + 3, 2 * x + 1] + g x = + [ 2 * x , 2 * x + 1 , 2 * x + 3 + , 2 * x , 2 * x + 3 , 2 * x + 2 + ] -- consider changing the position to a vec4 -- and just doing two pokes rather than seven -- (especially if adding normal data) -pokeJustV - :: Point3 - -> Point4 - -> Ptr Float - -> Int - -> Point3 - -> IO Int +pokeJustV :: + Point3 -> + Point4 -> + Ptr Float -> + Int -> + Point3 -> + IO Int {-# INLINE pokeJustV #-} pokeJustV cp col ptr nv sh = do - zipWithM_ f [0..] [x,y,z,1,r,g,b,a,nx,ny,nz,1] + --zipWithM_ f [0 ..] [x, y, z, 1, r, g, b, a, nx, ny, nz, 1] + UV.imapM_ f $ UV.fromList [x, y, z, 1, r, g, b, a, nx, ny, nz, 1] return (nv + 1) where - f i = pokeElemOff ptr (nv*nShapeVerxComp + i) - V3 x y z = sh - V4 r g b a = col + f i = pokeElemOff ptr (nv * nShapeVerxComp + i) + V3 x y z = sh + V4 r g b a = col V3 nx ny nz = cp -pokeJustVInvNormal - :: Point3 - -> Point4 - -> Ptr Float - -> Int - -> Point3 - -> IO Int +pokeJustVInvNormal :: + Point3 -> + Point4 -> + Ptr Float -> + Int -> + Point3 -> + IO Int {-# INLINE pokeJustVInvNormal #-} pokeJustVInvNormal cp col ptr nv sh = do - zipWithM_ f [0..] [x,y,z,1,r,g,b,a,nx,ny,nz,1] + --zipWithM_ f [0 ..] [x, y, z, 1, r, g, b, a, nx, ny, nz, 1] + UV.imapM_ f $ UV.fromList [x, y, z, 1, r, g, b, a, nx, ny, nz, 1] return (nv + 1) where - f i = pokeElemOff ptr (nv*nShapeVerxComp + i) - V3 x y z = sh - V4 r g b a = col - V3 nx ny nz = (2*sh) - cp + f i = pokeElemOff ptr (nv * nShapeVerxComp + i) + V3 x y z = sh + V4 r g b a = col + V3 nx ny nz = (2 * sh) - cp -pokeFlatV :: Point3 - -> Point4 - -> Ptr Float - -> Int - -> Point3 - -> IO Int +pokeFlatV :: + Point3 -> + Point4 -> + Ptr Float -> + Int -> + Point3 -> + IO Int {-# INLINE pokeFlatV #-} pokeFlatV norm col ptr nv sh = do - zipWithM_ f [0..] [x,y,z,1,r,g,b,a,nx,ny,nz,1] + --zipWithM_ f [0 ..] [x, y, z, 1, r, g, b, a, nx, ny, nz, 1] + UV.imapM_ f $ UV.fromList [x, y, z, 1, r, g, b, a, nx, ny, nz, 1] return (nv + 1) where - f i = pokeElemOff ptr (nv*nShapeVerxComp + i) - V3 x y z = sh - V4 r g b a = col + f i = pokeElemOff ptr (nv * nShapeVerxComp + i) + V3 x y z = sh + V4 r g b a = col V3 nx ny nz = sh - norm -pokeLayVerxs - :: MV.MVector (PrimState IO) (FullShader ,VBO) - -> UMV.MVector (PrimState IO) Int - -> Picture - -> IO () ---pokeLayVerxs vbos counts = S.mapM_ (pokeLayVerx vbos counts) . S.each +pokeLayVerxs :: + MV.MVector (PrimState IO) (FullShader, VBO) -> + UMV.MVector (PrimState IO) Int -> + Picture -> + IO () pokeLayVerxs vbos counts = VFSM.mapM_ (pokeLayVerx vbos counts) . VFSM.fromList -pokeLayVerx :: MV.MVector (PrimState IO) (FullShader,VBO) -> UMV.MVector (PrimState IO) Int -> Verx -> IO () ---{-# INLINE pokeLayVerx #-} +pokeLayVerx :: MV.MVector (PrimState IO) (FullShader, VBO) -> UMV.MVector (PrimState IO) Int -> Verx -> IO () +{-# INLINE pokeLayVerx #-} pokeLayVerx vbos counts vx = do theOff <- UMV.unsafeRead counts vecPos basePtr <- _vboPtr . snd <$> MV.unsafeRead vbos sn @@ -389,7 +459,6 @@ pokeStride 4 = 10 pokeStride 5 = 7 pokeStride _ = undefined - poke34 :: Ptr Float -> Point3 -> Point4 -> IO () {-# INLINE poke34 #-} poke34 ptr (V3 a b c) (V4 d e f g) = do diff --git a/src/Shape.hs b/src/Shape.hs index 2d0a684a2..5290b60e2 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -2,14 +2,13 @@ module Shape ( module Shape.Data , translateSH - , emptySH , upperPrismPoly , upperPrismPolyHalf , prismPoly , polyCirc , upperBox , translateSHz - , translateSHf + , translateSHxy , rotateSH , rotateSHx , polyCircx @@ -24,18 +23,6 @@ import Geometry import Shape.Data import Color -singleShape :: Surface -> Shape -{-# INLINE singleShape #-} -singleShape = (:[]) - -shMap :: (Surface -> Surface) -> Shape -> Shape -{-# INLINE shMap #-} -shMap = map - -emptySH :: Shape -{-# INLINE emptySH #-} -emptySH = mempty - -- - approximate a circle by a polygon with n*2 points of radius x polyCirc :: Int -> Float -> [Point2] {-# INLINE polyCirc #-} @@ -54,19 +41,18 @@ prismPoly -> [Point3] -> Shape {-# INLINE prismPoly #-} -prismPoly upps downps = singleShape (Surface (TopPrism n) (f upps downps) black) +prismPoly upps downps = [Surface (TopPrism n) (f upps downps) white] where n = length upps f (a:as) (b:bs) = a:b:f as bs - f [] _ = [] - f _ [] = [] + f _ _ = [] upperPrismPoly :: Float -- ^ height, expected to be strictly positive -> [Point2] -> Shape {-# INLINE upperPrismPoly #-} -upperPrismPoly h ps = singleShape (Surface (TopPrism n) (f ps) black) +upperPrismPoly h ps = [Surface (TopPrism n) (f ps) white] where n = length ps g h' (V2 x y) = V3 x y h' @@ -78,7 +64,7 @@ upperBox -> [Point2] -> Shape {-# INLINE upperBox #-} -upperBox h ps = singleShape (Surface (FlatFaces n) (f ps) white) +upperBox h ps = [Surface (FlatFaces n) (f ps) white] where n = length ps g h' (V2 x y) = V3 x y h' @@ -90,7 +76,7 @@ upperCylinder -> [Point2] -> Shape {-# INLINE upperCylinder #-} -upperCylinder h ps = singleShape (Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) black) +upperCylinder h ps = [Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) white] where cc = centroid ps n = length ps @@ -103,7 +89,7 @@ upperRounded -> [Point2] -> Shape {-# INLINE upperRounded #-} -upperRounded h ps = singleShape (Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) black) +upperRounded h ps = [Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) white] where cc = centroid ps n = length ps @@ -116,7 +102,7 @@ upperPrismPolyHalf -> [Point2] -> Shape {-# INLINE upperPrismPolyHalf #-} -upperPrismPolyHalf h ps = singleShape (Surface (TopPrism n) (f upps downps) black) +upperPrismPolyHalf h ps = [Surface (TopPrism n) (f upps downps) white] where n = length ps upps = map f' ps @@ -132,15 +118,15 @@ colorSH = overColSH . const overColSH :: (Point4 -> Point4) -> Shape -> Shape {-# INLINE overColSH #-} -overColSH = shMap . overColObj +overColSH = map . overColObj translateSH :: Point3 -> Shape -> Shape {-# INLINE translateSH #-} translateSH !p = overPosSH (+.+.+ p) -translateSHf :: Float -> Float -> Shape -> Shape -{-# INLINE translateSHf #-} -translateSHf !x !y = translateSH (V3 x y 0) +translateSHxy :: Float -> Float -> Shape -> Shape +{-# INLINE translateSHxy #-} +translateSHxy !x !y = translateSH (V3 x y 0) translateSHz :: Float -> Shape -> Shape {-# INLINE translateSHz #-} @@ -152,11 +138,11 @@ rotateSH = overPosSH . rotate3 overPosSH :: (Point3 -> Point3) -> Shape -> Shape {-# INLINEABLE overPosSH #-} -overPosSH = shMap . overPosObj +overPosSH = map . overPosObj rotateSHx :: Float -> Shape -> Shape {-# INLINE rotateSHx #-} -rotateSHx a = overPosSH (rotate3x a) +rotateSHx = overPosSH . rotate3x scaleSH :: Point3 -> Shape -> Shape {-# INLINE scaleSH #-} @@ -166,10 +152,6 @@ overColObj :: (Point4 -> Point4) -> Surface -> Surface {-# INLINE overColObj #-} overColObj f (Surface st vs col) = Surface st vs (f col) ---overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj ---{-# INLINE overColObjM #-} ---overColObjM f (ShapeObj st vs) = ShapeObj st <$> mapM (svCol f) vs - overPosObj :: (Point3 -> Point3) -> Surface -> Surface {-# INLINE overPosObj #-} overPosObj f (Surface st vs col) = Surface st (map f vs) col