switch terminal handling library to vty

raycharles.cabal

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

shell.nix

@@ -4,8 +4,8 @@ let
 
   inherit (nixpkgs) pkgs;
 
-  f = { mkDerivation, ansi-terminal, base, deepseq, linear, matrix
+  f = { mkDerivation, base, deepseq, linear, matrix, monad-loops
-      , monad-loops, parallel, stdenv, suspend, terminal-size, vector
+      , 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
+          base deepseq linear matrix monad-loops parallel suspend vector vty
-          suspend terminal-size vector
         ];
         description = "A simple raytracer on the Console";
         license = stdenv.lib.licenses.bsd3;

src/Main.hs

@@ -13,9 +13,11 @@ import Control.Concurrent.Suspend.Lifted
 import Control.DeepSeq
 import Control.Parallel.Strategies
 
-import System.IO
+-- import System.IO
-import System.Console.ANSI as CA
+-- import System.Console.ANSI as CA
-import System.Console.Terminal.Size as TS
+-- 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
+  -- hSetBuffering stdin NoBuffering
-  hSetEcho stdin False
+  -- hSetEcho stdin False
-  hideCursor
+  -- hideCursor
-  state <- newMVar (State (V2 10 3) 0 False "")
+  cfg <- standardIOConfig
-  c <- newMVar Nothing
+  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
+    -- CA.clearScreen
-    _ <- takeMVar c
+    -- reserveDisplay (outputIface vty)
-    char <- getKey
+    -- _ <- takeMVar c
-    putMVar c char
+    -- char <- getKey
-    modifyMVar_ state (\s -> if (not (stop s))
+    -- putMVar c char
-      then
+    rev <- nextEventNonblocking vty
-        withMVar c (\mvchar -> handleInput mvchar s)
+    char <- case rev of
-      else
+      Just (EvKey (KChar c) []) -> do
-        return s)
+        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
+  -- hSetEcho stdin True
-  showCursor
+  -- showCursor
+  shutdown vty
 
-handleInput :: Maybe Char -> State -> IO State
+handleInput :: Char -> State -> IO State
-handleInput Nothing state = return state
+-- handleInput Nothing state = return state
-handleInput (Just char) state = do
+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
+        -- '\ESC' -> state
-          { stop = True }
+        --   { stop = True }
         _ -> state
   return nstate
 
 draw :: State -> IO (V.Vector (V.Vector Char))
-draw (State ppos prot _ _) = do
+draw (State ppos prot _ _ vty) = do
-  (Just (Window h w)) <- TS.size :: IO (Maybe (Window Int))
+  (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 :: IO (Maybe Char)
-getKey = do
+-- getKey = do
-  charMVar <- newEmptyMVar
+--   charMVar <- newEmptyMVar
-  tid <- forkIO (forkGetChar charMVar)
+--   tid <- forkIO (forkGetChar charMVar)
-  threadDelay (msdelay `div` 5)
+--   threadDelay (msdelay `div` 5)
-  empty <- isEmptyMVar charMVar
+--   empty <- isEmptyMVar charMVar
-  if (not empty)
+--   if (not empty)
-  then do
+--   then do
-    killThread tid
+--     killThread tid
-    Just <$> takeMVar charMVar
+--     Just <$> takeMVar charMVar
-  else do
+--   else do
-    killThread tid
+--     killThread tid
-    return Nothing
+--     return Nothing
-  where
+--   where
-    forkGetChar mvar = do
+--     forkGetChar mvar = do
-      cs <- (: []) <$> hGetChar stdin
+--       cs <- (: []) <$> hGetChar stdin
-      when (not (null cs)) $ do
+--       when (not (null cs)) $ do
-        _ <- putMVar mvar (head cs)
+--         _ <- putMVar mvar (head cs)
-        return ()
+--         return ()

src/Types.hs

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