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

Cleanup

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