Small optimisations

src/Dodge/Base.hs

@@ -18,6 +18,7 @@ import Geometry
 --import Picture
 import qualified IntMapHelp as IM
 
+import Data.Foldable
 import Control.Lens
 --import Control.Monad.State
 --import Data.List
@@ -88,7 +89,19 @@ wallsOnCirc p r = IM.filter f
     f wl = uncurry circOnSeg (_wlLine wl) p r
 
 wallsOnScreen :: World -> IM.IntMap Wall
-wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
+wallsOnScreen w -- = wallsNearZones (zoneOfScreen w) w
+    = foldl' (flip $ IM.union . \i -> innerFold (f i (_wallsZone w))) IM.empty xs
+  where 
+    innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
+
+    f i m = case IM.lookup i m of 
+        Just val -> val
+        _        -> IM.empty
+    (x,y) = zoneOfPoint $ _cameraCenter w
+    n = ceiling (wh / (_cameraZoom w * zoneSize))
+    wh = max (getWindowX w) (getWindowY w)
+    xs = [x - n .. x + n]
+    ys = [y - n .. y + n]
 
 allWalls :: World -> IM.IntMap Wall
 allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w

src/Dodge/Render.hs

@@ -78,7 +78,8 @@ doDrawing pdata w = do
     if w ^. config . wall_textured
         then renderTextureWalls pdata nWalls
         else renderBlankWalls pdata nWalls
-    _ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
+    --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
+    _ <- renderFoldable pdata $ picToLTree (Just 0) (polysToPic $ foregroundPics w)
     _ <- renderFoldable pdata $ picToLTree (Just 0) pic
     _ <- renderShader (_textureArrayShader pdata) (_floorTiles w)
 

src/Geometry.hs

@@ -251,7 +251,10 @@ anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
 -- split a list into triples, forms triangles from a polygon
 polyToTris :: [s] -> [s]
 {-# INLINE polyToTris #-}
-polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (b:c:as) (c:as))
+polyToTris (a:as) = f a as
+  where
+    f x (y:z:ys) = x : y : z : f x (z:ys)
+    f _ _ = []
 polyToTris _ = []
 
 -- | Return n equidistant points on a circle with a radius of 600.

src/Picture/Data.hs

@@ -49,13 +49,14 @@ instance Foldable FTree where
 {- Tree with values at and only at the leaves. -}
 data LTree a
     = LBranches [LTree a]
-    | LLeaf a
+    | LLeaf !a
 instance Foldable LTree where
     foldMap g (LBranches ts) = mconcat $ map (foldMap g) ts
     foldMap g (LLeaf a) = g a
     {-# INLINE foldMap #-}
     foldr _ x (LBranches []) = x
-    foldr g x (LBranches (t:ts)) = foldr g (foldr g x (LBranches ts)) t
+    foldr g x (LBranches (t:ts)) = foldr g (foldr g x t) (LBranches ts)
+    --foldr g x (LBranches (t:ts)) = foldr g (foldr g x (LBranches ts)) t
     foldr g x (LLeaf y) = g y x
     {-# INLINE foldr #-}
     foldl' _ x (LBranches []) = x

src/Picture/Tree.hs

@@ -21,7 +21,7 @@ picToLTree
     :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
     -> Picture
     -> LTree RenderType
-{-# INLINE picToLTree #-}
+--{-# INLINE picToLTree #-}
 picToLTree _ (Polygon ps)
     = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
 picToLTree _ (PolygonZ ps z)
@@ -162,7 +162,7 @@ white = (1,1,1,1)
 black = (0,0,0,1)
 
 overPos :: (Point3 -> Point3) -> RenderType -> RenderType
-{-# INLINE overPos #-}
+--{-# INLINE overPos #-}
 overPos f (RenderPoly vs) = RenderPoly $ map (first f) vs
 overPos f (RenderLine vs) = RenderLine $ map (first f) vs
 overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
@@ -173,7 +173,7 @@ overPos f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs
 overPos _ _ = undefined
 
 overCol :: (Point4 -> Point4) -> RenderType -> RenderType
-{-# INLINE overCol #-}
+--{-# INLINE overCol #-}
 overCol f (RenderPoly vs)     = RenderPoly    $ map (second f) vs
 overCol f (RenderLine vs)     = RenderLine    $ map (second f) vs
 overCol f (RenderEllipse vs)  = RenderEllipse $ map (second f) vs
@@ -183,31 +183,28 @@ overCol f (RenderArc vs)      = RenderArc     $ map (\(a,b,c) -> (a,f b,c)) vs
 overCol f (RenderPolyZ vs)    = RenderPolyZ   $ map (\(a,b,c) -> (a,f b,c)) vs
 overCol _ _ = undefined
 
+-- no premature optimisation, consider changing to use texture arrays
 stringToList :: String -> [(Point3,Point4,Point2)]
 {-# INLINE stringToList #-}
-stringToList s = concat $ zipWith (map . f)
-    [0,0.9*dimText..]
-    $ map charToTuple s
+--stringToList s = concat $ zipWith charToTuple [0,0.9*dimText ..] s
+stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
   where
-    f y (a,b,c) = (translate3 y 0 a,b,c)
-    --where dimText = 100
-dimText :: Float
-dimText = 100
+    dimText = 100
 
-charToTuple :: Char -> [(Point3,Point4,Point2)]
+charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
 {-# INLINE charToTuple #-}
-charToTuple c = 
-    [((-50,-100,0),    white,(offset,1))
-    ,((-50,100,0),     white,(offset,0))
-    ,(( 50,100,0),   white,(offset+1,0))
-    ,((-50,-100,0),    white,(offset,1))
-    ,(( 50,-100,0),  white,(offset+1,1))
-    ,(( 50,100,0),   white,(offset+1,0))
+charToTuple x c = 
+    [((x-50,-100,0),    white,(offset,1))
+    ,((x-50,100,0),     white,(offset,0))
+    ,((x+50,100,0),   white,(offset+1,0))
+    ,((x-50,-100,0),    white,(offset,1))
+    ,((x+50,-100,0),  white,(offset+1,1))
+    ,((x+50,100,0),   white,(offset+1,0))
     ]
   where 
     offset = fromIntegral (fromEnum c) - 32
 
-{- Translate a 3D vector in the x and y directions. -}
-translate3 :: Float -> Float -> Point3 -> Point3
-{-# INLINE translate3 #-}
-translate3 a b (x,y,z) = (x+a,y+b,z)
+--{- Translate a 3D vector in the x and y directions. -}
+--translate3 :: Float -> Float -> Point3 -> Point3
+--{-# INLINE translate3 #-}
+--translate3 a b (x,y,z) = (x+a,y+b,z)