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