raycharles/src/Main.hs

180 lines
4.7 KiB
Haskell
Raw Normal View History

2018-10-25 15:21:51 +00:00
module Main where
2018-10-25 21:31:21 +00:00
import Linear
import Data.Matrix as M
2018-10-26 02:18:06 +00:00
import qualified Data.Vector as V
2018-10-25 21:31:21 +00:00
import Data.Maybe
import Control.Monad
import Control.Monad.Loops
import Control.Concurrent
import Control.Concurrent.Suspend.Lifted
import Control.DeepSeq
2018-10-26 01:05:32 +00:00
import Control.Parallel.Strategies
2018-10-25 21:31:21 +00:00
import System.IO
import System.Console.ANSI as CA
import System.Console.Terminal.Size as TS
2018-10-26 00:03:44 +00:00
-- import Debug.Trace as T
2018-10-25 21:31:21 +00:00
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
fov :: Double
fov = pi / 2
2018-10-25 15:21:51 +00:00
main :: IO ()
2018-10-25 21:31:21 +00:00
main = do
hSetBuffering stdin NoBuffering
hideCursor
state <- newMVar (State (V2 10 3) 0 False "")
2018-10-26 00:03:44 +00:00
c <- newMVar Nothing
2018-10-25 21:31:21 +00:00
whileM_ (not <$> stop <$> readMVar state) $ do
CA.clearScreen
2018-10-26 01:05:32 +00:00
_ <- takeMVar c
2018-10-26 00:03:44 +00:00
char <- getKey
2018-10-25 21:31:21 +00:00
putMVar c char
modifyMVar_ state (\s -> if (not (stop s))
then
2018-10-26 01:05:32 +00:00
withMVar c (\mvchar -> handleInput mvchar s)
2018-10-25 21:31:21 +00:00
else
return s)
outputs <- withMVar state draw
withMVar state (\s -> when (not (stop s)) $ do
2018-10-26 02:18:06 +00:00
let foutput = V.toList $ V.tail $
V.foldl (\acc a -> acc V.++ V.singleton '\n' V.++ a)
V.empty
( outputs
V.++ V.singleton (V.fromList $ show char)
V.++ V.singleton (V.fromList $ show (pos s) ++ " " ++ show (rot s))
)
2018-10-26 01:05:32 +00:00
deepseq foutput (putStr foutput)
2018-10-26 00:03:44 +00:00
)
-- threadDelay msdelay
2018-10-25 21:31:21 +00:00
showCursor
handleInput :: Maybe Char -> State -> IO State
handleInput Nothing state = return state
handleInput (Just 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
2018-10-26 02:18:06 +00:00
draw :: State -> IO (V.Vector (V.Vector Char))
2018-10-26 01:05:32 +00:00
draw (State ppos prot _ _) = do
(Just (Window h w)) <- TS.size :: IO (Maybe (Window Int))
2018-10-26 00:03:44 +00:00
let dims@(dw, dh) = (min 160 w, min 60 h) -- if w >= h then (w, w `div` 2) else (w, h)
2018-10-26 02:18:06 +00:00
out = (V.generate (fromIntegral dh - 2)
((\mh ->
V.map
(\mw -> drawPixel dims (mw, mh))
(V.generate (fromIntegral dw) fromIntegral)
) . fromIntegral)
) `using` parVector
2018-10-26 01:05:32 +00:00
return out
2018-10-25 21:31:21 +00:00
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 =
2018-10-26 02:18:06 +00:00
let iter = V.generate (1000) ((/ 100) . fromIntegral) :: V.Vector Double
2018-10-26 01:05:32 +00:00
collPos a = (ppos + (V2 0 (a * cos (- fov / 2 + ddh * fov / h))
`rotVec` (prot - fov / 2 + ddw * fov / w)))
2018-10-26 02:18:06 +00:00
in V.foldl (\acc a ->
2018-10-25 21:31:21 +00:00
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 = ' '
2018-10-26 02:18:06 +00:00
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)
2018-10-25 21:31:21 +00:00
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
2018-10-26 02:18:06 +00:00
{-# INLINE doesCollide #-}
2018-10-25 21:31:21 +00:00
2018-10-26 02:18:06 +00:00
rotVec :: V2 Double -> Double -> V2 Double
2018-10-25 21:31:21 +00:00
rotVec (V2 x y) rad = V2 nx ny
where
nx = x * cos rad + y * sin rad
ny = x * sin rad - y * cos rad
2018-10-26 02:18:06 +00:00
{-# INLINE rotVec #-}
2018-10-26 00:03:44 +00:00
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
hSetEcho stdin False
cs <- (: []) <$> hGetChar stdin
hSetEcho stdin True
when (not (null cs)) $ do
_ <- putMVar mvar (head cs)
return ()