another great speed optimization

This commit is contained in:
nek0 2018-10-27 02:57:07 +02:00
parent 5c0346e3fb
commit 54406980dd
3 changed files with 131 additions and 60 deletions

View file

@ -5,7 +5,7 @@ let
inherit (nixpkgs) pkgs; inherit (nixpkgs) pkgs;
f = { mkDerivation, ansi-terminal, base, deepseq, linear, matrix 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 { mkDerivation {
pname = "raycharles"; pname = "raycharles";
@ -15,10 +15,8 @@ let
isExecutable = true; isExecutable = true;
executableHaskellDepends = [ executableHaskellDepends = [
ansi-terminal base deepseq linear matrix monad-loops parallel 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"; description = "A simple raytracer on the Console";
license = stdenv.lib.licenses.bsd3; license = stdenv.lib.licenses.bsd3;
}; };

View file

@ -1,6 +1,6 @@
module Main where module Main where
import Linear import Linear as L
import Data.Matrix as M import Data.Matrix as M
import qualified Data.Vector as V import qualified Data.Vector as V
@ -40,6 +40,7 @@ fov = pi / 2
main :: IO () main :: IO ()
main = do main = do
hSetBuffering stdin NoBuffering hSetBuffering stdin NoBuffering
hSetEcho stdin False
hideCursor hideCursor
state <- newMVar (State (V2 10 3) 0 False "") state <- newMVar (State (V2 10 3) 0 False "")
c <- newMVar Nothing c <- newMVar Nothing
@ -55,8 +56,8 @@ main = do
return s) return s)
outputs <- withMVar state draw outputs <- withMVar state draw
withMVar state (\s -> when (not (stop s)) $ do 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 V.empty
( outputs ( outputs
V.++ V.singleton (V.fromList $ show char) V.++ V.singleton (V.fromList $ show char)
@ -65,6 +66,7 @@ main = do
deepseq foutput (putStr foutput) deepseq foutput (putStr foutput)
) )
-- threadDelay msdelay -- threadDelay msdelay
hSetEcho stdin True
showCursor showCursor
handleInput :: Maybe Char -> State -> IO State 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 -> IO (V.Vector (V.Vector Char))
draw (State ppos prot _ _) = do draw (State ppos prot _ _) = do
(Just (Window h w)) <- TS.size :: IO (Maybe (Window Int)) (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 -> ((\mh ->
V.map V.map
(\mw -> drawPixel dims (mw, mh)) (\mw -> drawPixel prot ppos dims (mw, mh))
(V.generate (fromIntegral dw) fromIntegral) (V.generate (fromIntegral dw) fromIntegral)
) . fromIntegral) ) . fromIntegral)
) `using` parVector ) `using` parVector
return out 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 where
drawPixel (w, h) (ddw, ddh) = evalChunk 0 = rpar (rdeepseq (vec V.! 0)) >> return vec
let rayLength = castRay (fromIntegral w) (fromIntegral h) ddw ddh evalChunk i = rpar (rdeepseq (vec V.! i)) >> evalChunk (i-1)
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)
doesCollide :: V2 Double -> Bool doesCollide :: V2 Double -> Bool
doesCollide (V2 x y) = doesCollide (V2 x y) =
@ -171,9 +246,7 @@ getKey = do
return Nothing return Nothing
where where
forkGetChar mvar = do forkGetChar mvar = do
hSetEcho stdin False
cs <- (: []) <$> hGetChar stdin cs <- (: []) <$> hGetChar stdin
hSetEcho stdin True
when (not (null cs)) $ do when (not (null cs)) $ do
_ <- putMVar mvar (head cs) _ <- putMVar mvar (head cs)
return () return ()

View file

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