another great speed optimization

shell.nix

@@ -5,7 +5,7 @@ let
   inherit (nixpkgs) pkgs;
 
   f = { mkDerivation, ansi-terminal, base, deepseq, linear, matrix
-      , monad-loops, parallel, stdenv, suspend, terminal-size, timers
+      , monad-loops, parallel, stdenv, suspend, terminal-size, vector
       }:
       mkDerivation {
         pname = "raycharles";
@@ -15,10 +15,8 @@ let
         isExecutable = true;
         executableHaskellDepends = [
           ansi-terminal base deepseq linear matrix monad-loops parallel
-          suspend terminal-size timers
+          suspend terminal-size vector
         ];
-        enableLibraryProfiling = true;
-        enableExecutableProfiling = true;
         description = "A simple raytracer on the Console";
         license = stdenv.lib.licenses.bsd3;
       };

src/Main.hs

@@ -1,6 +1,6 @@
 module Main where
 
-import Linear
+import Linear as L
 
 import Data.Matrix as M
 import qualified Data.Vector as V
@@ -40,6 +40,7 @@ fov = pi / 2
 main :: IO ()
 main = do
   hSetBuffering stdin NoBuffering
+  hSetEcho stdin False
   hideCursor
   state <- newMVar (State (V2 10 3) 0 False "")
   c <- newMVar Nothing
@@ -55,8 +56,8 @@ main = do
         return s)
     outputs <- withMVar state draw
     withMVar state (\s -> when (not (stop s)) $ do
-      let foutput = V.toList $ V.tail $
+      let foutput = V.toList $
-            V.foldl (\acc a -> acc V.++ V.singleton '\n' V.++ a)
+            V.foldl (\acc a -> acc V.++ a V.++ V.singleton '\n')
               V.empty
               ( outputs
               V.++ V.singleton (V.fromList $ show char)
@@ -65,6 +66,7 @@ main = do
       deepseq foutput (putStr foutput)
       )
     -- threadDelay msdelay
+  hSetEcho stdin True
   showCursor
 
 handleInput :: Maybe Char -> State -> IO State
@@ -90,20 +92,32 @@ handleInput (Just char) state = do
 draw :: State -> IO (V.Vector (V.Vector Char))
 draw (State ppos prot _ _) = do
   (Just (Window h w)) <- TS.size :: IO (Maybe (Window Int))
-  let dims@(dw, dh) = (min 160 w, min 60 h) -- if w >= h then (w, w `div` 2) else (w, h)
+  let dims@(dw, dh) = (min 160 w, min 60 (h - 4)) -- if w >= h then (w, w `div` 2) else (w, h)
-      out = (V.generate (fromIntegral dh - 2)
+      out = (V.generate (fromIntegral dh)
         ((\mh ->
           V.map
-          (\mw -> drawPixel dims (mw, mh))
+          (\mw -> drawPixel prot ppos dims (mw, mh))
           (V.generate (fromIntegral dw) fromIntegral)
           ) . fromIntegral)
         ) `using` parVector
   return out
-  where
+
-    drawPixel (w, h) (ddw, ddh) =
+drawPixel :: Double -> V2 Double -> (Int, Int) -> (Double, Double) -> Char
-      let rayLength = castRay (fromIntegral w) (fromIntegral h) ddw ddh
+drawPixel prot ppos (w, h) (ddw, ddh) =
+  let rayLength = castRay2
+        prot
+        ppos
+        (fromIntegral w, fromIntegral h)
+        (ddw, ddh)
   in getPixel (fromMaybe 11 rayLength)
-    castRay w h ddw ddh =
+
+castRay
+  :: Double
+  -> V2 Double
+  -> (Double, Double)
+  -> (Double, Double)
+  -> Maybe Double
+castRay prot ppos (w, h) (ddw, ddh) =
   let iter = V.generate (1000) ((/ 100) . fromIntegral) :: V.Vector Double
       collPos a = (ppos + (V2 0 (a * cos (- fov / 2 + ddh * fov / h))
         `rotVec` (prot - fov / 2 + ddw * fov / w)))
@@ -115,12 +129,73 @@ draw (State ppos prot _ _) = do
         else acc
       else acc
     ) Nothing iter
+{-# INLINE castRay #-}
+
+castRay2
+  :: Double
+  -> V2 Double
+  -> (Double, Double)
+  -> (Double, Double)
+  -> Maybe Double
+castRay2 prot ppos@(V2 ux uy) (w, h) (ddw, ddh) =
+  let v@(V2 vx vy) = V2 0 1 `rotVec` (prot + (- fov / 2 + ddw * fov / w))
+      stepx = signum vx
+      stepy = signum vy
+      tmaxx = (((fromIntegral :: Int -> Double) . floor) ux + stepx - ux) / vx
+      tmaxy = (((fromIntegral :: Int -> Double) . floor) uy + stepy - uy) / vy
+      tdeltax = stepx / vx
+      tdeltay = stepy / vy
+      tiles = (ux, uy) : buildTileList (tmaxx, tmaxy) (tdeltax, tdeltay) (stepx, stepy) (ux, uy) ppos
+  in fmap (/ cos (- fov / 2 + ddh * fov / h)) (getRayColl ppos v tiles)
+{-# INLINE castRay2 #-}
+
+getRayColl
+  :: V2 Double
+  -> V2 Double
+  -> [(Double, Double)]
+  -> Maybe Double
+getRayColl _ _ []     = Nothing
+getRayColl _ _ (_:[]) = Nothing
+getRayColl ppos@(V2 ux uy) v@(V2 vx vy) ((ptix, _):tile@(tix, tiy):ts) =
+  case safeGet (floor tix) (floor tiy) Map.map of
+    Just '#' ->
+      let t = if (floor ptix :: Int) == (floor tix :: Int)
+            then (((fromIntegral :: Int -> Double) . floor) tiy - uy) / vy
+            else (((fromIntegral :: Int -> Double) . floor) tix - ux) / vx -- floor tix = ux + t * vx
+          vec = (* t) <$> v
+      in Just (sqrt $ vec `L.dot` vec)
+    _ -> getRayColl ppos v (tile:ts)
+{-# INLINE getRayColl #-}
+
+buildTileList
+  :: (Double, Double)
+  -> (Double, Double)
+  -> (Double, Double)
+  -> (Double, Double)
+  -> V2 Double
+  -> [(Double, Double)]
+buildTileList (tmaxx, tmaxy) delta@(tdeltax, tdeltay) rstep@(stepx, stepy) (x, y) ppos =
+  if distance ppos (V2 x y) <= 9
+  then if tmaxx < tmaxy
+    then
+      let ntmaxx = tmaxx + tdeltax
+          nx     = x + stepx
+      in (nx, y) : buildTileList (ntmaxx, tmaxy) delta rstep (nx, y) ppos
+    else
+      let ntmaxy = tmaxy + tdeltay
+          ny     = y + stepy
+      in (x, ny) : buildTileList (tmaxx, ntmaxy) delta rstep (x, ny) ppos
+  else []
+{-# INLINE buildTileList #-}
+
+getPixel :: Double -> Char
 getPixel l
   | l <= 3    = '█'
   | l <= 4.5  = '▓'
   | l <= 6    = '▒'
   | l <= 9    = '░'
   | otherwise = ' '
+
 parVector :: NFData a => Strategy (V.Vector a)
 parVector vec =
   let vLen = V.length vec
@@ -130,8 +205,8 @@ draw (State ppos prot _ _) = do
       then do
         let v1 = V.unsafeSlice 0 half vec
             v2 = V.unsafeSlice half (vLen - half) vec
-            parVector v1
+        void $ parVector v1
-            parVector v2
+        void $ parVector v2
         return vec
       else
         evalChunk (vLen-1) >>
@@ -171,9 +246,7 @@ getKey = do
     return Nothing
   where
     forkGetChar mvar = do
-      hSetEcho stdin False
       cs <- (: []) <$> hGetChar stdin
-      hSetEcho stdin True
       when (not (null cs)) $ do
         _ <- putMVar mvar (head cs)
         return ()

src/Map.hs

@@ -5,18 +5,18 @@ import Data.Matrix as M
 map :: Matrix Char
 map = fromLists
   [ ['#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#']
-  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#', '#', ' ', ' ', '#']
+  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
-  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#', '#', ' ', ' ', '#']
+  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
-  , ['#', ' ', ' ', '#', '#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
+  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
-  , ['#', ' ', ' ', '#', '#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
+  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
   , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
   , ['#', ' ', ' ', ' ', ' ', ' ', '#', '#', '#', ' ', ' ', ' ', '#']
-  , ['#', ' ', ' ', ' ', ' ', ' ', '#', '#', '#', ' ', ' ', '#', '#']
+  , ['#', ' ', ' ', ' ', ' ', ' ', '#', '#', '#', ' ', ' ', ' ', '#']
   , ['#', ' ', ' ', ' ', ' ', ' ', '#', '#', '#', ' ', ' ', ' ', '#']
   , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
-  , ['#', ' ', ' ', '#', '#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
+  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
-  , ['#', ' ', ' ', '#', '#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
+  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
-  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#', '#', ' ', ' ', '#']
+  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
-  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#', '#', ' ', ' ', '#']
+  , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#']
   , ['#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#']
   ]