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

Turn Shape into a stream

Browse Source
This commit is contained in:
justin
2022-06-27 18:31:25 +01:00
parent 673e9b11fc
commit c7e720248d
11 changed files with 42 additions and 32 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/HandPos.hs
+1 -1
View File
@@ -43,7 +43,7 @@ translatePointToRightHand' cr
f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
translateToRightHand :: Creature -> SPic -> SPic
translateToRightHand cr = translateToRightHand' cr . mirrorSPxz
translateToRightHand cr = translateToRightHand' cr -- . mirrorSPxz
translateToRightHand' :: Creature -> SPic -> SPic
translateToRightHand' cr
src/Dodge/Item/Equipment/Shape.hs
+1 -1
View File
@@ -23,7 +23,7 @@ equipPosition epos cr sh = case epos of
OnLeftWrist -> translateToLeftHand cr sh
OnRightWrist -> translateToRightHand cr sh
OnLegs -> translateToLeftLeg cr sh <>
translateToRightLeg cr (mirrorSPxz sh)
translateToRightLeg cr sh --(mirrorSPxz sh)
OnHead -> translateToHead cr sh
OnChest -> translateToChest cr sh
_ -> sh
src/Dodge/Item/Weapon/BatteryGuns.hs
+1 -1
View File
@@ -99,7 +99,7 @@ teslaGun = defaultBatteryGun
teslaGunPic :: Item -> SPic
teslaGunPic _ = noPic $ colorSH blue $
upperPrismPoly 5 (rectNESW xb 8 xa 0)
++ upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0)
<> upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0)
where
xa = 1
xb = 9
src/Dodge/Item/Weapon/BulletGun/Cane.hs
+3 -1
View File
@@ -31,6 +31,7 @@ import Shape
import Sound.Data
import LensHelp
import qualified Data.Vector.Fusion.Stream.Monadic as VS
--import qualified Data.Map.Strict as M
--import qualified Data.Sequence as Seq
--import Control.Lens
@@ -302,7 +303,8 @@ miniGunXPict i spin _ =
)
where
aBarrel = translateSH (V3 15 2 2) baseCaneShape
barrels = concatMap (\an -> aBarrel & rotateSHx (2*pi * fromIntegral an / fromIntegral i)) [1..i]
barrels = VS.concatMap (\an -> aBarrel & rotateSHx (2*pi * fromIntegral an / fromIntegral i))
$ VS.fromList [1..i]
a = fromIntegral spin / 100
--x = fromIntegral am / 10
-- clip y z = translateSH (V3 0 (-1) z) (rotateSHx (negate $ pi/4)
src/Dodge/Item/Weapon/Shatter.hs
+1 -1
View File
@@ -41,7 +41,7 @@ shatterGun = defaultWeapon
shatterGunSPic :: Item -> SPic
shatterGunSPic _ = noPic $ colorSH blue $
upperPrismPoly 5 (rectNESW xb 8 xa 0)
++ upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0)
<> upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0)
where
xa = 1
xb = 9
src/Dodge/Item/Weapon/SprayGuns.hs
+1 -1
View File
@@ -56,7 +56,7 @@ flamerPic :: Item -> SPic
flamerPic it =
( colorSH yellow $
translateSHf 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)
)
where
src/Dodge/Room/Foreground.hs
+3 -3
View File
@@ -5,7 +5,7 @@ import Picture
import Geometry
import Shape
import Quaternion
import Bound
--import Bound
--import Dodge.Data.ForegroundShape
import Dodge.Default.Foreground
@@ -13,8 +13,8 @@ import Data.List
import Data.Maybe
import Control.Lens
import ShapePicture
import Streaming
import qualified Streaming.Prelude as S
--import Streaming
--import qualified Streaming.Prelude as S
highDiagonalMesh
:: Point2
src/Shader/Poke.hs
+2 -3
View File
@@ -19,7 +19,6 @@ 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 VS
import Data.Vector.Fusion.Util
import Control.Monad.Primitive
--import qualified Control.Monad.Parallel as MP
@@ -85,9 +84,9 @@ pokeShape
:: Ptr Float
-> Ptr GLushort
-> Ptr GLushort
-> [ShapeObj]
-> VS.Stream IO ShapeObj
-> IO (Int,Int,Int)
pokeShape ptr iptr ieptr = VS.foldM (pokeShapeObj ptr iptr ieptr) (0,0,0) . VS.fromList
pokeShape ptr iptr ieptr = VS.foldM (pokeShapeObj ptr iptr ieptr) (0,0,0)
pokeShapeObj
:: Ptr Float
src/Shape.hs
+5 -5
View File
@@ -25,7 +25,7 @@ import qualified Data.Vector.Fusion.Stream.Monadic as VS
emptySH :: Shape
{-# INLINE emptySH #-}
emptySH = mempty
emptySH = VS.empty
-- - approximate a circle by a polygon with n*2 points of radius x
polyCirc :: Int -> Float -> [Point2]
@@ -45,7 +45,7 @@ prismPoly
-> [Point3]
-> Shape
{-# INLINE prismPoly #-}
prismPoly upps downps = [ShapeObj (TopPrism n) (VS.fromList $ f upps downps)]
prismPoly upps downps = VS.singleton $ ShapeObj (TopPrism n) (VS.fromList $ f upps downps)
where
n = length upps
f (a:as) (b:bs) = g a:g b:f as bs
@@ -58,7 +58,7 @@ upperPrismPoly
-> [Point2]
-> Shape
{-# INLINE upperPrismPoly #-}
upperPrismPoly h ps = [ShapeObj (TopPrism n) (VS.fromList $ f ps)]
upperPrismPoly h ps = VS.singleton $ ShapeObj (TopPrism n) (VS.fromList $ f ps)
where
n = length ps
g h' (V2 x y) = pairToSV (V3 x y h', black)
@@ -70,7 +70,7 @@ upperPrismPolyHalf
-> [Point2]
-> Shape
{-# INLINE upperPrismPolyHalf #-}
upperPrismPolyHalf h ps = [ShapeObj (TopPrism n) (VS.fromList $ f upps downps)]
upperPrismPolyHalf h ps = VS.singleton $ ShapeObj (TopPrism n) (VS.fromList $ f upps downps)
where
n = length ps
upps = map f' ps
@@ -94,7 +94,7 @@ overColSH = fmap . overColObj
overPosSHI :: (Point3 -> Point3) -> Shape -> Shape
{-# INLINE overPosSHI #-}
overPosSHI = fmap . overPosObj
overPosSHI = VS.map . overPosObj
translateSH :: Point3 -> Shape -> Shape
{-# INLINE translateSH #-}
src/Shape/Data.hs
+7 -2
View File
@@ -3,14 +3,19 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
module Shape.Data
where
import Geometry.Data
import qualified Data.Vector.Fusion.Stream.Monadic as VS
import Data.Vector.Fusion.Util
import Control.Lens
type Shape = [ShapeObj]
type Shape = VS.Stream IO ShapeObj
instance Semigroup (VS.Stream IO ShapeObj) where
(<>) = (VS.++)
instance Monoid (VS.Stream IO ShapeObj) where
mempty = VS.empty
--_shVertices :: Shape -> [ShapeV]
--{-# INLINE _shVertices #-}
src/ShapePicture.hs
+17 -13
View File
@@ -1,3 +1,5 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module ShapePicture
( emptyBlank
@@ -10,23 +12,25 @@ module ShapePicture
, noShape
, _spShape
, _spPicture
, mirrorSPyz
, mirrorSPxz
-- , mirrorSPyz
-- , mirrorSPxz
) where
import Shape
import Picture
import Geometry
import qualified Data.Vector.Fusion.Stream.Monadic as VS
import Data.Bifunctor
--import Control.Lens
type SPic = (Shape, Picture)
type SPic = (Shape, Picture)
-- should all this be inlined/inlinable?
noPic :: Shape -> SPic
noPic = (,mempty)
noShape :: Picture -> SPic
noShape = (mempty,)
noShape = (VS.empty,)
_spShape :: SPic -> Shape
_spShape = fst
@@ -48,12 +52,12 @@ translateSP v = bimap (translateSH v) (translate3 v)
rotateSP :: Float -> SPic -> SPic
rotateSP a = bimap (rotateSH a) (rotate a)
mirrorSPxz :: SPic -> SPic
mirrorSPxz = bimap (reverse . overPosSH flipy) mirrorxz
where
flipy (V3 x y z) = V3 x (negate y) z
mirrorSPyz :: SPic -> SPic
mirrorSPyz = bimap (reverse . overPosSH flipx) mirroryz
where
flipx (V3 x y z) = V3 (negate x) y z
--mirrorSPxz :: SPic -> SPic
--mirrorSPxz = bimap (reverse . overPosSH flipy) mirrorxz
-- where
-- flipy (V3 x y z) = V3 x (negate y) z
--
--mirrorSPyz :: SPic -> SPic
--mirrorSPyz = bimap (reverse . overPosSH flipx) mirroryz
-- where
-- flipx (V3 x y z) = V3 (negate x) y z