raycharles/src/Main.hs

280 lines
7.4 KiB
Haskell

module Main where
import Linear as L
import Data.Matrix as M hiding ((<->))
import qualified Data.Vector as V
import Data.Maybe
import Control.Monad
import Control.Monad.Loops
import Control.Concurrent
import Control.Concurrent.Suspend.Lifted
import Control.DeepSeq
import Control.Parallel.Strategies
-- import System.IO
-- import System.Console.ANSI as CA
-- import System.Console.Terminal.Size as TS
import Graphics.Vty
-- import Debug.Trace as T
import qualified Map
import Types
delay :: Delay
delay = msDelay (fromIntegral msdelay)
msdelay :: Int
msdelay = 100
step :: V2 Double
step = V2 0 0.5
rotStep :: Double
rotStep = 0.174533
hfov :: Double
hfov = pi / 1.5
vfov :: Double
vfov = pi / 2
main :: IO ()
main = do
-- hSetBuffering stdin NoBuffering
-- hSetEcho stdin False
-- hideCursor
cfg <- standardIOConfig
vty <- mkVty cfg
hideCursor (outputIface vty)
state <- newMVar (State (V2 10 3) 0 False "" vty)
-- c <- newMVar Nothing
whileM_ (not <$> stop <$> readMVar state) $ do
-- CA.clearScreen
-- reserveDisplay (outputIface vty)
-- _ <- takeMVar c
-- char <- getKey
-- putMVar c char
rev <- nextEventNonblocking vty
char <- case rev of
Just (EvKey (KChar c) []) -> do
modifyMVar_ state (\s -> if (not (stop s))
then do
handleInput c s
else
return s)
return (Just c)
Just (EvKey (KEsc) []) -> do
modifyMVar_ state (\s ->
return s
{ stop = True
}
)
return Nothing
_ -> return Nothing
outputs <- withMVar state draw
image <- withMVar state (\s -> do
let foutput =
V.foldl (\acc a -> acc <-> a)
emptyImage
( outputs
-- V.++ V.singleton (V.fromList $ show char)
-- V.++ V.singleton (V.fromList $ show (pos s) ++ " " ++ show (rot s))
V.++ V.singleton (emptyImage)
V.++ V.singleton (emptyImage)
V.++ V.singleton (emptyImage)
)
pure foutput
)
let picture = picForImage image
update vty picture
-- threadDelay msdelay
-- hSetEcho stdin True
-- showCursor
shutdown vty
handleInput :: Char -> State -> IO State
-- handleInput Nothing state = return state
handleInput char state = do
let npos delta = if not (doesCollide (pos state + delta))
then pos state + delta
else pos state
nstate = case char of
'w' -> state
{ pos = npos (step `rotVec` rot state) }
's' -> state
{ pos = npos (- step `rotVec` rot state) }
'd' -> state
{ rot = rot state + rotStep }
'a' -> state
{ rot = rot state - rotStep }
-- '\ESC' -> state
-- { stop = True }
_ -> state
return nstate
draw :: State -> IO (V.Vector Image)
draw (State ppos prot _ _ vty) = do
(w, h) <- displayBounds (outputIface vty)
let dims@(dw, dh) = (w, h - 4)
out = V.generate (fromIntegral dh)
((\mh -> string defAttr $ V.toList $
V.map
(\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 (- vfov / 2 + ddh * vfov / h))
`rotVec` (prot - hfov / 2 + ddw * hfov / 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 + (- hfov / 2 + ddw * hfov / 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 (- vfov / 2 + ddh * vfov / 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
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) =
let tile = safeGet (floor x) (floor y) Map.map
in case tile of
Nothing -> True
Just '#' -> True
_ -> False
{-# INLINE doesCollide #-}
rotVec :: V2 Double -> Double -> V2 Double
rotVec (V2 x y) rad = V2 nx ny
where
nx = x * cos rad + y * sin rad
ny = x * sin rad - y * cos rad
{-# INLINE rotVec #-}
-- getKey :: IO (Maybe Char)
-- getKey = do
-- charMVar <- newEmptyMVar
-- tid <- forkIO (forkGetChar charMVar)
-- threadDelay (msdelay `div` 5)
-- empty <- isEmptyMVar charMVar
-- if (not empty)
-- then do
-- killThread tid
-- Just <$> takeMVar charMVar
-- else do
-- killThread tid
-- return Nothing
-- where
-- forkGetChar mvar = do
-- cs <- (: []) <$> hGetChar stdin
-- when (not (null cs)) $ do
-- _ <- putMVar mvar (head cs)
-- return ()