raycharles/src/Main.hs

module Main where

import Linear

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 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

fov :: Double
fov = pi / 2

main :: IO ()
main = do
  hSetBuffering stdin NoBuffering
  hideCursor
  state <- newMVar (State (V2 10 3) 0 False "")
  c <- newMVar Nothing
  whileM_ (not <$> stop <$> readMVar state) $ do
    CA.clearScreen
    _ <- takeMVar c
    char <- getKey
    putMVar c char
    modifyMVar_ state (\s -> if (not (stop s))
      then
        withMVar c (\mvchar -> handleInput mvchar s)
      else
        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)
              V.empty
              ( outputs
              V.++ V.singleton (V.fromList $ show char)
              V.++ V.singleton (V.fromList $ show (pos s) ++ " " ++ show (rot s))
              )
      deepseq foutput (putStr foutput)
      )
    -- threadDelay msdelay
  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

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)
        ((\mh ->
          V.map
          (\mw -> drawPixel dims (mw, mh))
          (V.generate (fromIntegral dw) fromIntegral)
          ) . fromIntegral)
        ) `using` parVector
  return out
  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)

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
      hSetEcho stdin False
      cs <- (: []) <$> hGetChar stdin
      hSetEcho stdin True
      when (not (null cs)) $ do
        _ <- putMVar mvar (head cs)
        return ()