From 650e58bdfa5ca9efab07a028dc03d6df9896c3c6 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 16 Aug 2021 20:56:49 +0200 Subject: [PATCH] Improve level generation speed --- src/Dodge/Creature/Inanimate.hs | 31 ++++-- src/Dodge/Creature/Picture.hs | 9 +- src/Dodge/Debug.hs | 14 +++ src/Dodge/Layout.hs | 2 +- src/Dodge/LevelGen/StaticWalls.hs | 29 +++--- src/Dodge/Render/Picture.hs | 14 +-- src/Geometry.hs | 11 +++ src/Geometry/Zone.hs | 159 ++++++++++++------------------ src/Picture.hs | 10 +- src/Picture/Data.hs | 6 ++ src/Polyhedra.hs | 16 +++ 11 files changed, 168 insertions(+), 133 deletions(-) diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index 5699bbf5d..7cb1c9f9e 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} {- Inanimate objects such as lamps, barrels, etc -} @@ -17,11 +17,13 @@ import Dodge.WorldEvent.Sound import Dodge.Creature.Update hiding (CRUpdate) import Picture import qualified IntMapHelp as IM -import Geometry.Data +import Geometry +--import Geometry.Data import Geometry.Vector3D import Polyhedra import Control.Lens +import qualified Control.Foldl as L defaultInanimate :: Creature defaultInanimate = defaultCreature & crActionPlan .~ Inanimate @@ -30,15 +32,30 @@ lamp :: Float -> Creature lamp h = defaultInanimate { _crUpdate = initialiseLamp h , _crHP = 100 - , _crPict = picAtCrPos (lampPic h) + , _crPict = picAtCrPosNoRot (lampPic h) , _crRad = 3 , _crMass = 3 } +-- it is not clear that any of the attempts with Foldl help at all here lampPic :: Float -> Picture -lampPic h = pictures - [ setLayer 0 $ pictures . map (helpPoly3D . map ((, blue) . (-.-.- V3 2.5 2.5 0))) $ boxXYZ 5 5 (h-1) - , setLayer 1 $ setDepth h $ color white $ circleSolid 3 - ] +--{-# INLINE lampPic #-} +lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3) + ++ (concatMap (preTriFold f) $ boxXYZnobase 5 5 (h-1)) + where + f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] 0 polyNum + +lTriFold :: a -> a -> L.Fold a [a] +lTriFold s x = L.Fold (f s) (x,[]) snd + where + f s' (x1,l) x2 = (x2,s':x1:x2:l) + +preTriFold :: (a -> b) -> [a] -> [b] +preTriFold f (s:x:xs) = L.fold (L.premap f $ lTriFold (f s) (f x)) xs +preTriFold _ _ = [] + +polyToTriFold :: [a] -> [a] +polyToTriFold (s:x:xs) = L.fold (lTriFold s x) xs +polyToTriFold _ = [] initialiseLamp :: Float -> CRUpdate initialiseLamp h w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp h i) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index d3e46f0f5..65231b479 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -5,6 +5,7 @@ module Dodge.Creature.Picture ( basicCrPict , circLine , picAtCrPos + , picAtCrPosNoRot ) where import Dodge.Data --import Dodge.Creature.Stance.Data @@ -174,5 +175,9 @@ circLine :: Float -> Picture circLine x = line [V2 0 0,V2 x 0] picAtCrPos :: Picture -> Creature -> World -> Picture -{-# INLINE picAtCrPos #-} -picAtCrPos thePic cr _ = uncurryV translate (_crPos cr) $ rotate (_crDir cr) thePic +--{-# INLINE picAtCrPos #-} +picAtCrPos thePic cr _ = tranRot (_crPos cr) (_crDir cr) thePic + +picAtCrPosNoRot :: Picture -> Creature -> World -> Picture +--{-# INLINE picAtCrPos #-} +picAtCrPosNoRot thePic cr _ = uncurryV translate (_crPos cr) thePic diff --git a/src/Dodge/Debug.hs b/src/Dodge/Debug.hs index 0d86674b5..10394ecd0 100644 --- a/src/Dodge/Debug.hs +++ b/src/Dodge/Debug.hs @@ -2,6 +2,9 @@ module Dodge.Debug where import Dodge.Data import Dodge.Picture import Dodge.Picture.Layer +import Dodge.Base.Zone +import Dodge.Base +import Geometry.Zone import Geometry.Data import Geometry import Picture @@ -58,3 +61,14 @@ drawDDA = setLayer 1 . color (withAlpha 0.5 green) . IM.foldlWithKey' f [] where x = 50 * fromIntegral x' ys = map ((50 *) . fromIntegral) $ IS.toList ys' + +debugWallZoningPic :: World -> Picture +debugWallZoningPic w = setLayer 1 $ zonesPic ++ wallsPic + where + wallsPic = setDepth 25 . color yellow . concatMap (drawTheWall . _wlLine) $ IM.elems theWalls + drawTheWall (a,b) = lineOfThickness 20 [a,b] + theWalls = wallsAlongLine sp ep w + zonesPic = setDepth 20 $ drawDDA zones + zones = ddaExt zoneSize sp ep + sp = _crPos $ you w + ep = mouseWorldPos w diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 7563d045e..57272e02c 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -95,7 +95,7 @@ updateWallZoning w = set wallsZone (foldl' (flip wallInZone) IM.empty (_walls w) where (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) wlid = _wlID wl - ips = map zoneOfPoint $ uncurry (divideLine (zoneSize)) (_wlLine wl) + ips = map zoneOfPoint $ uncurry (divideLine zoneSize) (_wlLine wl) makePath :: Tree Room -> [(Point2,Point2)] diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 22c66e976..33d646aa8 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -6,11 +6,12 @@ module Dodge.LevelGen.StaticWalls where import Dodge.Data import Geometry +import Geometry.ConvexPoly --import Geometry.Data import FoldableHelp --import Control.Lens -import Data.List +import Data.List.Extra import Data.Maybe import Data.Bifunctor -- | Describe a wall as two points. @@ -119,26 +120,24 @@ checkWallLeft (x,y) wls -- Be aware that we do not remove all colinear walls; this may still cause bugs cutPoly :: [Point2] -> [WallP] -> [WallP] cutPoly qs wls = - nub + nubOrd . removeInverseWalls . filter (not . wallIsZeroLength) . fuseWallsWith zs . addPolyWalls rs --- . removeWallsInPolygon ps --- . filter (not.wallIsZeroLength) --- . fuseWallsWith zs $ removeWallsInPolygon ps cwals where (zs,cwals) = cutWallsWithPoints ps wls ps = orderPolygon qs - rs = orderPolygon $ nub $ zs ++ qs + rs = orderPolygon $ nubOrd $ zs ++ qs -- | Given a value and a poly, pushes the poly points out from the center by the -- value amount. expandPolyBy :: Float -> [Point2] -> [Point2] expandPolyBy x ps = map f ps where - cp = 1/fromIntegral (length ps) *.* foldr (+.+) (V2 0 0) ps + --cp = 1/fromIntegral (length ps) *.* foldl' (+.+) (V2 0 0) ps + cp = centroid ps f p = p +.+ x *.* (p -.- cp) --f p = p +.+ x *.* normalizeV (p -.- cp) -- | Given a polygon expressed as a list of points and a collection of walls, @@ -146,10 +145,10 @@ expandPolyBy x ps = map f ps -- fst: points of the polygon's intersection with walls -- snd: the collection of walls after cutting by the polygon. cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] ) -cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) +cutWallsWithPoints (p:ps) ws = foldl' f ([],ws) (zip (p:ps) (ps++[p])) where - f (p1,p2) (as,ws') = - ( nub $ as ++ cutWallsPoints p1 p2 ws' + f (as,ws') (p1,p2) = + ( nubOrd $ as ++ cutWallsPoints p1 p2 ws' , concatMap (cutWall p1 p2) ws' ) cutWallsWithPoints _ _ = error "Trying to cut empty polygon" @@ -167,7 +166,7 @@ addPolyWalls :: [Point2] -- ^ Multiple walls described as a polygon. -> [WallP] -> [WallP] -addPolyWalls (q:qs) wls = foldr addPolyWall wls (zip (q:qs) (qs++[q])) +addPolyWalls (q:qs) wls = foldl' addPolyWall wls (zip (q:qs) (qs++[q])) addPolyWalls _ _ = error "Trying to add empty poly walls" -- | Add a new wall to a list of walls only if either -- 1. no wall already exists on the normal line from the new wall @@ -175,8 +174,8 @@ addPolyWalls _ _ = error "Trying to add empty poly walls" -- face away from the new wall. -- The normal line is the line from the center point of the new wall outwards -- along the clockwise normal of the new wall (currently 10000 units along) -addPolyWall :: WallP -> [WallP] -> [WallP] -addPolyWall (p1,p2) wls = +addPolyWall :: [WallP] -> WallP -> [WallP] +addPolyWall wls (p1,p2) = case maybeWs of Just ws -> if uncurry isLHS ws p3 then wls @@ -213,9 +212,9 @@ fuseWall ps (x,y) = ( rs , (x',y') ) -- | Given list of points and collection of walls, fuses the wall ends if -- they are close to the list of points or each other. fuseWallsWith :: [Point2] -> [WallP] -> [WallP] -fuseWallsWith zs ws = snd $ foldr fuseWalls (zs, []) ws +fuseWallsWith zs ws = snd $ foldl' fuseWalls (zs, []) ws where - fuseWalls w (ps, ws') = + fuseWalls (ps, ws') w = let (qs, w') = fuseWall ps w in (qs, w' : ws') -- | Test if fst p == snd p. diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index a97e5aea4..b6a87dad4 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -8,9 +8,9 @@ import Dodge.Picture import Dodge.Picture.Layer import Dodge.Render.HUD import Dodge.Render.MenuScreen -import Dodge.Debug +--import Dodge.Debug import Geometry -import Geometry.Zone +--import Geometry.Zone --import Geometry.Data import Picture import Polyhedra.Data @@ -58,15 +58,7 @@ customMouseCursor w = $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ] testPic :: World -> Picture -testPic w = setLayer 1 $ zonesPic ++ wallsPic - where - wallsPic = setDepth 25 . color yellow . concatMap (drawTheWall . _wlLine) $ IM.elems theWalls - drawTheWall (a,b) = lineOfThickness 20 [a,b] - theWalls = wallsAlongLine sp ep w - zonesPic = setDepth 20 $ drawDDA zones - zones = ddaExt zoneSize sp ep - sp = _crPos $ you w - ep = mouseWorldPos w +testPic _ = [] -- [ setDepth (-1) . translate 0 0.8 -- . scale 0.001 0.001 . text . show $ _crMvDir $ you w diff --git a/src/Geometry.hs b/src/Geometry.hs index a2e87a6cb..87714effa 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -199,6 +199,17 @@ polyToTris (a:as) = go a as go _ _ = [] polyToTris _ = [] +polyToTris' :: [s] -> [s] +{-# INLINE polyToTris' #-} +polyToTris' [] = [] +polyToTris' (a:as) = prependTwo a as + +prependTwo :: a -> [a] -> [a] +prependTwo _ [] = [] +prependTwo _ [_] = [] +prependTwo sep (x:y:xs) = sep : x : y : prependTwo sep (y:xs) + + -- | Return n equidistant points on a circle with a radius of 600. nRays :: Int -> [Point2] nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (V2 600 0) diff --git a/src/Geometry/Zone.hs b/src/Geometry/Zone.hs index 02ec4b978..c20623efb 100644 --- a/src/Geometry/Zone.hs +++ b/src/Geometry/Zone.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} module Geometry.Zone ( ddaExt ) @@ -19,62 +19,63 @@ import qualified Data.IntSet as IS -- g (r,x) y = (f r x y,y) --foldl2' _ s _ = s -sortArguments - :: Ord a - => (a -> a -> b) - -> a -> a -> b -sortArguments f x y - | x < y = f x y - | otherwise = f y x -sortArgumentsReverse - :: Ord a - => (a -> a -> [b]) - -> a -> a -> [b] -sortArgumentsReverse f x y - | x < y = f x y - | otherwise = reverse $ f y x +--sortArguments +-- :: Ord a +-- => (a -> a -> b) +-- -> a -> a -> b +--sortArguments f x y +-- | x < y = f x y +-- | otherwise = f y x +--sortArgumentsReverse +-- :: Ord a +-- => (a -> a -> [b]) +-- -> a -> a -> [b] +--sortArgumentsReverse f x y +-- | x < y = f x y +-- | otherwise = reverse $ f y x +-- +--intervalBounds +-- :: Float -- ^ interval threshold +-- -> Float -- ^ First endpoint +-- -> Float -- ^ Second endpoint +-- -> [Float] +--intervalBounds = sortArgumentsReverse . f +-- where +-- f r a b +-- | x > b = [a] +-- | otherwise = (a : [x,x+r..b]) +-- where +-- x = floorTo r a + r -intervalBounds - :: Float -- ^ interval threshold - -> Float -- ^ First endpoint - -> Float -- ^ Second endpoint - -> [Float] -intervalBounds = sortArgumentsReverse . f - where - f r a b - | x > b = [a] - | otherwise = (a : [x,x+r..b]) - where - x = floorTo r a + r +--floorTo :: Float -> Float -> Float +--floorTo r x = r * (fromIntegral ((floor $ x / r) :: Int)) -floorTo :: Float -> Float -> Float -floorTo r x = r * (fromIntegral ((floor $ x / r) :: Int)) - -ceilingTo :: Float -> Float -> Float -ceilingTo r x = r * (fromIntegral ((ceiling $ x / r) :: Int)) +--ceilingTo :: Float -> Float -> Float +--ceilingTo r x = r * (fromIntegral ((ceiling $ x / r) :: Int)) divTo :: Float -> Float -> Int {-# INLINE divTo #-} divTo s = floor . (/s) -flipV :: Point2 -> Point2 -{-# INLINE flipV #-} -flipV (V2 a b) = V2 b a +--flipV :: Point2 -> Point2 +--{-# INLINE flipV #-} +--flipV (V2 a b) = V2 b a -applyInverted - :: (Point2 -> Point2 -> [Point2]) - -> Point2 -> Point2 -> [Point2] -applyInverted f sp@(V2 sx sy) ep@(V2 ex ey) - | abs (sx-ex) > abs (sy-ey) = f sp ep - | otherwise = map flipV $ f (flipV sp) (flipV ep) +--applyInverted +-- :: (Point2 -> Point2 -> [Point2]) +-- -> Point2 -> Point2 -> [Point2] +--applyInverted f sp@(V2 sx sy) ep@(V2 ex ey) +-- | abs (sx-ex) > abs (sy-ey) = f sp ep +-- | otherwise = map flipV $ f (flipV sp) (flipV ep) sizeZoneOfPoint' :: Float -> Point2 -> V2 Int +{-# INLINE sizeZoneOfPoint' #-} sizeZoneOfPoint' s = fmap (divTo s) -increasingInterval :: Int -> Int -> [Int] -increasingInterval x y - | y > x = [x .. y] - | otherwise = [y .. x] +--increasingInterval :: Int -> Int -> [Int] +--increasingInterval x y +-- | y > x = [x .. y] +-- | otherwise = [y .. x] -- | Determines which horizontal and vertical lines on a grid are crossed by a -- line. For each adds the x-y index of the square to the right or above the @@ -91,41 +92,14 @@ ddaExt s sp@(V2 sx sy) ep@(V2 ex ey) in insertXY im (x,y) x1 = divTo s sx x2 = divTo s ex - x1y = fx' sp ep $ s * (fromIntegral x1) - x2y = fx' sp ep $ s * (fromIntegral x2) + x1y = fx' sp ep $ s * fromIntegral x1 + x2y = fx' sp ep $ s * fromIntegral x2 ydx = s * ydx' sp ep addys m = add2s m ypairs y1 = divTo s sy y2 = divTo s ey - y1x = fy' sp ep $ s * (fromIntegral y1) - y2x = fy' sp ep $ s * (fromIntegral y2) - xdy = s * xdy' sp ep - ypairs - | y1 <= y2 = zip (map (divTo s) [y1x,y1x+xdy..]) - [y1 .. y2] - | otherwise = zip (map (divTo s) [y2x,y2x+xdy..]) - [y2-1 .. y1-1] --- | Determines which horizontal and vertical lines on a grid are crossed by a --- line. For each adds the x-y index of the square to the right or above the --- crossed grid line. Also adds the index of the square containing the start --- point. -ddaExtExt :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet -ddaExtExt s sp@(V2 sx sy) ep@(V2 ex ey) - | x1 <= x2 = addys . IM.fromDistinctAscList $ zip [x1 .. x2] - $ map (IS.singleton . divTo s) [x1y,x1y+ydx..] - | otherwise = addys . IM.fromDistinctAscList $ zip [x2-1 .. x1-1] - $ map (IS.singleton . divTo s) [x2y,x2y+ydx..] - where - x1 = divTo s sx - x2 = divTo s ex - x1y = fx' sp ep $ s * (fromIntegral x1) - x2y = fx' sp ep $ s * (fromIntegral x2) - ydx = s * ydx' sp ep - addys m = add2s m ypairs - y1 = divTo s sy - y2 = divTo s ey - y1x = fy' sp ep $ s * (fromIntegral y1) - y2x = fy' sp ep $ s * (fromIntegral y2) + y1x = fy' sp ep $ s * fromIntegral y1 + y2x = fy' sp ep $ s * fromIntegral y2 xdy = s * xdy' sp ep ypairs | y1 <= y2 = zip (map (divTo s) [y1x,y1x+xdy..]) @@ -138,44 +112,39 @@ ydx' :: Point2 -> Point2 -> Float ydx' (V2 sx sy) (V2 ex ey) | sx == ex = 0 | otherwise = (ey - sy) / (ex - sx) -xInt' :: Float -> Point2 -> Point2 -> Float -xInt' s (V2 sx _) (V2 ex _) - | ex > sx = ceilingTo s sx - | otherwise = floorTo s sx fx' :: Point2 -> Point2 -> Float -> Float +{-# INLINE fx' #-} fx' sp@(V2 sx sy) ep@(V2 _ ey) x | sy == ey = sy | otherwise = sy + ydx' sp ep * (x - sx) xdy' :: Point2 -> Point2 -> Float +{-# INLINE xdy' #-} xdy' (V2 sx sy) (V2 ex ey) | sy == ey = 0 | otherwise = (ex - sx) / (ey - sy) -yInt' :: Float -> Point2 -> Point2 -> Float -yInt' s (V2 _ sy) (V2 _ ey) - | ey > sy = ceilingTo s sy - | otherwise = floorTo s sy fy' :: Point2 -> Point2 -> Float -> Float +{-# INLINE fy' #-} fy' sp@(V2 sx sy) ep@(V2 ex _) y | sx == ex = sx | otherwise = sx + xdy' sp ep * (y - sy) add2s :: IM.IntMap IS.IntSet -> [(Int,Int)] -> IM.IntMap IS.IntSet {-# INLINE add2s #-} -add2s imis = foldl' +add2s = foldl' (\m (k,x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m) - imis insertXY :: IM.IntMap IS.IntSet -> (Int,Int) -> IM.IntMap IS.IntSet +{-# INLINE insertXY #-} insertXY m (k,x) = IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m -addV2s :: IM.IntMap IS.IntSet -> [V2 Int] -> IM.IntMap IS.IntSet -{-# INLINE addV2s #-} -addV2s imis = foldl' - (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m) - imis +--addV2s :: IM.IntMap IS.IntSet -> [V2 Int] -> IM.IntMap IS.IntSet +--{-# INLINE addV2s #-} +--addV2s imis = foldl' +-- (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m) +-- imis -pairsToIntMapSet :: [V2 Int] -> IM.IntMap IS.IntSet -pairsToIntMapSet = foldl' - (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m) - IM.empty +--pairsToIntMapSet :: [V2 Int] -> IM.IntMap IS.IntSet +--pairsToIntMapSet = foldl' +-- (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m) +-- IM.empty diff --git a/src/Picture.hs b/src/Picture.hs index 7b398fe50..bc59ea78c 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -23,6 +23,7 @@ module Picture , lineCol , text , pictures + , tranRot , translate , rotate , scale @@ -161,7 +162,11 @@ translate3 !a !b (V3 x y z) = V3 (x+a) (y+b) z translate :: Float -> Float -> Picture -> Picture {-# INLINE translate #-} -translate !x !y = map $! overPos $! translate3 x y +translate x = map . overPos . translate3 x + +tranRot :: V2 Float -> Float -> Picture -> Picture +{-# INLINE tranRot #-} +tranRot (V2 x y) r = map $ overPos (translate3 x y . rotate3 r) setDepth :: Float -> Picture -> Picture {-# INLINE setDepth #-} @@ -190,7 +195,7 @@ scale x y = map $ overPos $ scale3 x y rotate :: Float -> Picture -> Picture {-# INLINE rotate #-} -rotate a = map $ overPos $ rotate3 a +rotate = map . overPos . rotate3 pictures :: [Picture] -> Picture {-# INLINE pictures #-} @@ -372,6 +377,7 @@ greyN :: Float -> Color {-# INLINE greyN #-} greyN x = toV4 (x,x,x,1) +-- Currently the lens version is much slower overPos :: (Point3 -> Point3) -> Verx -> Verx {-# INLINE overPos #-} --overPos = over vxPos diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 2f8f16b52..4612e23b4 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -13,6 +13,12 @@ data Verx = Verx } newtype ShadNum = ShadNum { _unShadNum :: Int } polyNum, polyzNum, bezNum, textNum, arcNum, ellNum :: ShadNum +{-# INLINE polyNum #-} +{-# INLINE polyzNum #-} +{-# INLINE bezNum #-} +{-# INLINE textNum #-} +{-# INLINE arcNum #-} +{-# INLINE ellNum #-} polyNum = ShadNum 0 polyzNum = ShadNum 1 bezNum = ShadNum 2 diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs index 5ee2ab0e2..a3c0e2b82 100644 --- a/src/Polyhedra.hs +++ b/src/Polyhedra.hs @@ -48,14 +48,29 @@ faceEdges xs = zipWith addNormal xs (tail xs ++ [head xs]) n = crossProd (b -.-.- a) (c -.-.- a) rhombus :: Point3 -> Point3 -> [Point3] +{-# INLINE rhombus #-} rhombus a b = [V3 0 0 0 ,a ,a +.+.+ b ,b ] +boxXYZnobase :: Float -> Float -> Float -> [[Point3]] +{-# INLINE boxXYZnobase #-} +boxXYZnobase x y z = + [ map (+.+.+ V3 0 0 z) $ reverse bottomFace + , frontFace + , map (+.+.+ V3 0 y 0) $ reverse frontFace + , sideFace + , map (+.+.+ V3 x 0 0) $ reverse sideFace + ] + where + bottomFace = rhombus (V3 0 y 0) (V3 x 0 0) + frontFace = rhombus (V3 x 0 0) (V3 0 0 z) + sideFace = rhombus (V3 0 0 z) (V3 0 y 0) boxXYZ :: Float -> Float -> Float -> [[Point3]] +{-# INLINE boxXYZ #-} boxXYZ x y z = [ bottomFace , map (+.+.+ V3 0 0 z) $ reverse bottomFace @@ -86,6 +101,7 @@ polyToPics :: Polyhedra -> [Picture] polyToPics = map helpPoly3D . _pyFaces helpPoly3D :: [(Point3, Point4)] -> [Verx] +--{-# INLINE helpPoly3D #-} helpPoly3D vs = map f $ polyToTris vs where f (pos,col) = Verx pos col [] 0 polyNum