278 lines
7.4 KiB
Haskell
278 lines
7.4 KiB
Haskell
module Main where
|
|
|
|
import Linear as L
|
|
|
|
import Data.Matrix as M
|
|
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
|
|
withMVar state (\s -> when (not (stop s)) $ do
|
|
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)
|
|
-- V.++ V.singleton (V.fromList $ show (pos s) ++ " " ++ show (rot s))
|
|
V.++ V.singleton (V.empty)
|
|
V.++ V.singleton (V.empty)
|
|
V.++ V.singleton (V.empty)
|
|
)
|
|
deepseq foutput (putStr foutput)
|
|
)
|
|
-- 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 (V.Vector Char))
|
|
draw (State ppos prot _ _ vty) = do
|
|
(w, h) <- displayBounds (outputIface vty)
|
|
let dims@(dw, dh) = (w, (h - 4))
|
|
out = (V.generate (fromIntegral dh)
|
|
((\mh ->
|
|
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 ()
|