From 54406980ddc3a9395224e615f2d747ef724504d8 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 27 Oct 2018 02:57:07 +0200 Subject: [PATCH] another great speed optimization --- shell.nix | 6 +- src/Main.hs | 167 +++++++++++++++++++++++++++++++++++++--------------- src/Map.hs | 18 +++--- 3 files changed, 131 insertions(+), 60 deletions(-) diff --git a/shell.nix b/shell.nix index 3a88929..9847c45 100644 --- a/shell.nix +++ b/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; }; diff --git a/src/Main.hs b/src/Main.hs index a572fd6..eee93f3 100644 --- a/src/Main.hs +++ b/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 $ - V.foldl (\acc a -> acc V.++ V.singleton '\n' V.++ a) + let foutput = V.toList $ + 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,55 +92,128 @@ 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) - out = (V.generate (fromIntegral dh - 2) + 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) ((\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 + +drawPixel :: Double -> V2 Double -> (Int, Int) -> (Double, Double) -> Char +drawPixel prot ppos (w, h) (ddw, ddh) = + let rayLength = castRay2 + prot + ppos + (fromIntegral w, fromIntegral h) + (ddw, ddh) + in getPixel (fromMaybe 11 rayLength) + +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))) + in V.foldl (\acc a -> + if isNothing acc + then + if doesCollide (collPos a) + then Just a + 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 + half = vLen `div` 2 + minChunk = 10 + in if vLen > minChunk + then do + let v1 = V.unsafeSlice 0 half vec + v2 = V.unsafeSlice half (vLen - half) vec + void $ parVector v1 + void $ parVector v2 + return vec + else + evalChunk (vLen-1) >> + return vec where - drawPixel (w, h) (ddw, ddh) = - let rayLength = castRay (fromIntegral w) (fromIntegral h) ddw ddh - in getPixel (fromMaybe 11 rayLength) - castRay 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))) - in V.foldl (\acc a -> - if isNothing acc - then - if doesCollide (collPos a) - then Just a - else acc - else acc - ) Nothing iter - 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 - half = vLen `div` 2 - minChunk = 10 - in if vLen > minChunk - then do - let v1 = V.unsafeSlice 0 half vec - v2 = V.unsafeSlice half (vLen - half) vec - parVector v1 - parVector v2 - return vec - else - evalChunk (vLen-1) >> - return vec - where - evalChunk 0 = rpar (rdeepseq (vec V.! 0)) >> return vec - evalChunk i = rpar (rdeepseq (vec V.! i)) >> evalChunk (i-1) + evalChunk 0 = rpar (rdeepseq (vec V.! 0)) >> return vec + evalChunk i = rpar (rdeepseq (vec V.! i)) >> evalChunk (i-1) doesCollide :: V2 Double -> Bool doesCollide (V2 x y) = @@ -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 () diff --git a/src/Map.hs b/src/Map.hs index 18c6474..31d10c5 100644 --- a/src/Map.hs +++ b/src/Map.hs @@ -5,18 +5,18 @@ import Data.Matrix as M map :: Matrix Char map = fromLists [ ['#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#'] - , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#', '#', ' ', ' ', '#'] - , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#', '#', ' ', ' ', '#'] - , ['#', ' ', ' ', '#', '#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] - , ['#', ' ', ' ', '#', '#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] + , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] + , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] + , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] + , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] , ['#', ' ', ' ', ' ', ' ', ' ', '#', '#', '#', ' ', ' ', ' ', '#'] - , ['#', ' ', ' ', ' ', ' ', ' ', '#', '#', '#', ' ', ' ', '#', '#'] + , ['#', ' ', ' ', ' ', ' ', ' ', '#', '#', '#', ' ', ' ', ' ', '#'] , ['#', ' ', ' ', ' ', ' ', ' ', '#', '#', '#', ' ', ' ', ' ', '#'] , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] - , ['#', ' ', ' ', '#', '#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] - , ['#', ' ', ' ', '#', '#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] - , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#', '#', ' ', ' ', '#'] - , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#', '#', ' ', ' ', '#'] + , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] + , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] + , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] + , ['#', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', '#'] , ['#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#', '#'] ]