Cleanup
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -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)
|
||||
)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+303
-234
@@ -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
|
||||
|
||||
+14
-32
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user