switch terminal handling library to vty

This commit is contained in:
nek0 2020-04-25 14:59:22 +02:00
parent 8103104941
commit 824ca45298
4 changed files with 72 additions and 51 deletions

View file

@ -23,13 +23,14 @@ executable raycharles
build-depends: base >=4.11 && <5
, linear
, matrix
, ansi-terminal
-- , ansi-terminal
-- , terminal-size
, suspend
, monad-loops
, terminal-size
, deepseq
, parallel
, vector
, vty
hs-source-dirs: src
ghc-options: -Wall -threaded
default-language: Haskell2010

View file

@ -4,8 +4,8 @@ let
inherit (nixpkgs) pkgs;
f = { mkDerivation, ansi-terminal, base, deepseq, linear, matrix
, monad-loops, parallel, stdenv, suspend, terminal-size, vector
f = { mkDerivation, base, deepseq, linear, matrix, monad-loops
, parallel, stdenv, suspend, vector, vty
}:
mkDerivation {
pname = "raycharles";
@ -14,8 +14,7 @@ let
isLibrary = false;
isExecutable = true;
executableHaskellDepends = [
ansi-terminal base deepseq linear matrix monad-loops parallel
suspend terminal-size vector
base deepseq linear matrix monad-loops parallel suspend vector vty
];
description = "A simple raytracer on the Console";
license = stdenv.lib.licenses.bsd3;

View file

@ -13,9 +13,11 @@ 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 System.IO
-- import System.Console.ANSI as CA
-- import System.Console.Terminal.Size as TS
import Graphics.Vty
-- import Debug.Trace as T
@ -42,21 +44,37 @@ vfov = pi / 2
main :: IO ()
main = do
hSetBuffering stdin NoBuffering
hSetEcho stdin False
hideCursor
state <- newMVar (State (V2 10 3) 0 False "")
c <- newMVar Nothing
-- 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
_ <- takeMVar c
char <- getKey
putMVar c char
modifyMVar_ state (\s -> if (not (stop s))
then
withMVar c (\mvchar -> handleInput mvchar s)
else
return s)
-- 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 $
@ -69,12 +87,13 @@ main = do
deepseq foutput (putStr foutput)
)
-- threadDelay msdelay
hSetEcho stdin True
showCursor
-- hSetEcho stdin True
-- showCursor
shutdown vty
handleInput :: Maybe Char -> State -> IO State
handleInput Nothing state = return state
handleInput (Just char) state = do
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
@ -87,14 +106,14 @@ handleInput (Just char) state = do
{ rot = rot state + rotStep }
'a' -> state
{ rot = rot state - rotStep }
'\ESC' -> state
{ stop = True }
-- '\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))
draw (State ppos prot _ _ vty) = do
(w, h) <- displayBounds (outputIface vty)
let dims@(dw, dh) = (w, (h - 4))
out = (V.generate (fromIntegral dh)
((\mh ->
@ -234,22 +253,22 @@ rotVec (V2 x y) rad = V2 nx ny
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 ()
-- 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 ()

View file

@ -1,10 +1,12 @@
module Types where
import Linear
import Graphics.Vty (Vty)
data State = State
{ pos :: V2 Double
, rot :: Double
, stop :: Bool
, output :: String
, vty :: Vty
}