From c7e720248dcf9b4c02bbf5faf3344d6b8271a1eb Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 27 Jun 2022 18:31:25 +0100 Subject: [PATCH] Turn Shape into a stream --- src/Dodge/Creature/HandPos.hs | 2 +- src/Dodge/Item/Equipment/Shape.hs | 2 +- src/Dodge/Item/Weapon/BatteryGuns.hs | 2 +- src/Dodge/Item/Weapon/BulletGun/Cane.hs | 4 +++- src/Dodge/Item/Weapon/Shatter.hs | 2 +- src/Dodge/Item/Weapon/SprayGuns.hs | 2 +- src/Dodge/Room/Foreground.hs | 6 ++--- src/Shader/Poke.hs | 5 ++--- src/Shape.hs | 10 ++++----- src/Shape/Data.hs | 9 ++++++-- src/ShapePicture.hs | 30 ++++++++++++++----------- 11 files changed, 42 insertions(+), 32 deletions(-) diff --git a/src/Dodge/Creature/HandPos.hs b/src/Dodge/Creature/HandPos.hs index 7497664dd..419731b2c 100644 --- a/src/Dodge/Creature/HandPos.hs +++ b/src/Dodge/Creature/HandPos.hs @@ -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 diff --git a/src/Dodge/Item/Equipment/Shape.hs b/src/Dodge/Item/Equipment/Shape.hs index 0c6267a20..8a29ff214 100644 --- a/src/Dodge/Item/Equipment/Shape.hs +++ b/src/Dodge/Item/Equipment/Shape.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index 37e83dab1..7db131418 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/BulletGun/Cane.hs b/src/Dodge/Item/Weapon/BulletGun/Cane.hs index 495b552f6..54c8d2f51 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Cane.hs +++ b/src/Dodge/Item/Weapon/BulletGun/Cane.hs @@ -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) diff --git a/src/Dodge/Item/Weapon/Shatter.hs b/src/Dodge/Item/Weapon/Shatter.hs index 8a64b8e32..6d424b74d 100644 --- a/src/Dodge/Item/Weapon/Shatter.hs +++ b/src/Dodge/Item/Weapon/Shatter.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/SprayGuns.hs b/src/Dodge/Item/Weapon/SprayGuns.hs index 7b70fe3f2..16f7cfa65 100644 --- a/src/Dodge/Item/Weapon/SprayGuns.hs +++ b/src/Dodge/Item/Weapon/SprayGuns.hs @@ -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 diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 6db8339d3..ac60d5358 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -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 diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index a04d76a07..827ef172d 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -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 diff --git a/src/Shape.hs b/src/Shape.hs index c453b21ce..b540410fa 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -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 #-} diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index 01389eb50..0b6772284 100644 --- a/src/Shape/Data.hs +++ b/src/Shape/Data.hs @@ -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 #-} diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index 925aa6971..5cd93a640 100644 --- a/src/ShapePicture.hs +++ b/src/ShapePicture.hs @@ -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