Improve level generation speed

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
+--{-# INLINE lampPic #-}
-    [ setLayer 0 $ pictures . map (helpPoly3D . map ((, blue) . (-.-.- V3 2.5 2.5 0))) $ boxXYZ 5 5 (h-1)
+lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3)
-    , 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)

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 #-}
+--{-# INLINE picAtCrPos #-}
-picAtCrPos thePic cr _ = uncurryV translate (_crPos cr) $ rotate (_crDir cr) thePic
+picAtCrPos thePic cr _ = tranRot (_crPos cr) (_crDir cr) thePic
+
+picAtCrPosNoRot :: Picture -> Creature -> World -> Picture
+--{-# INLINE picAtCrPos #-}
+picAtCrPosNoRot thePic cr _ = uncurryV translate (_crPos cr) thePic

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

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)]

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') = 
+    f (as,ws') (p1,p2) = 
-        ( nub $ as ++ cutWallsPoints p1 p2 ws'
+        ( 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 :: [WallP] -> WallP -> [WallP]
-addPolyWall (p1,p2) wls =
+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.

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
+testPic _ = []
-  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
     
 --    [ setDepth (-1) . translate 0 0.8
 --        . scale 0.001 0.001 . text . show $ _crMvDir $ you w

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)

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 
+--sortArguments 
-    :: Ord a 
+--    :: Ord a 
-    => (a -> a -> b)
+--    => (a -> a -> b)
-    -> a -> a -> b
+--    -> a -> a -> b
-sortArguments f x y
+--sortArguments f x y
-    | x < y = f x y
+--    | x < y = f x y
-    | otherwise = f y x
+--    | otherwise = f y x
-sortArgumentsReverse
+--sortArgumentsReverse
-    :: Ord a 
+--    :: Ord a 
-    => (a -> a -> [b])
+--    => (a -> a -> [b])
-    -> a -> a -> [b]
+--    -> a -> a -> [b]
-sortArgumentsReverse f x y
+--sortArgumentsReverse f x y
-    | x < y = f x y
+--    | x < y = f x y
-    | otherwise = reverse $ f y x
+--    | 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
+--floorTo :: Float -> Float -> Float
-    :: Float    -- ^ interval threshold
+--floorTo r x = r * (fromIntegral ((floor $ x / r) :: Int))
-    -> 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
+--ceilingTo :: Float -> Float -> Float
-floorTo r x = r * (fromIntegral ((floor $ x / r) :: Int))
+--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
+--flipV :: Point2 -> Point2
-{-# INLINE flipV #-}
+--{-# INLINE flipV #-}
-flipV (V2 a b) = V2 b a
+--flipV (V2 a b) = V2 b a
 
-applyInverted 
+--applyInverted 
-    :: (Point2 -> Point2 -> [Point2])
+--    :: (Point2 -> Point2 -> [Point2])
-    -> Point2 -> Point2 -> [Point2]
+--    -> Point2 -> Point2 -> [Point2]
-applyInverted f sp@(V2 sx sy) ep@(V2 ex ey)
+--applyInverted f sp@(V2 sx sy) ep@(V2 ex ey)
-    | abs (sx-ex) > abs (sy-ey) = f sp ep
+--    | abs (sx-ex) > abs (sy-ey) = f sp ep
-    | otherwise = map flipV $ f (flipV sp) (flipV 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 :: Int -> Int -> [Int]
-increasingInterval x y
+--increasingInterval x y
-    | y > x = [x .. y]
+--    | y > x = [x .. y]
-    | otherwise = [y .. x]
+--    | 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)
+    x1y = fx' sp ep $ s * fromIntegral x1
-    x2y = fx' sp ep $ s * (fromIntegral x2)
+    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)
+    y1x = fy' sp ep $ s * fromIntegral y1
-    y2x = fy' sp ep $ s * (fromIntegral y2)
+    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)
     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
+--addV2s :: IM.IntMap IS.IntSet -> [V2 Int] -> IM.IntMap IS.IntSet
-{-# INLINE addV2s #-}
+--{-# INLINE addV2s #-}
-addV2s imis = foldl' 
+--addV2s imis = foldl' 
-    (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
+--    (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
-    imis
+--    imis
 
-pairsToIntMapSet :: [V2 Int] -> IM.IntMap IS.IntSet
+--pairsToIntMapSet :: [V2 Int] -> IM.IntMap IS.IntSet
-pairsToIntMapSet = foldl' 
+--pairsToIntMapSet = foldl' 
-    (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
+--    (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
-    IM.empty
+--    IM.empty

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

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

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