Tui

.gitmodules

@@ -4,3 +4,6 @@
 [submodule "PortMidi"]
 	path = PortMidi
 	url = git@github.com:yosukeueda33/PortMidi-haskell.git
+[submodule "vty-windows"]
+	path = vty-windows
+	url = https://github.com/chhackett/vty-windows.git

README.md

@@ -92,6 +92,17 @@ If you built from the souce, execute this command in the cloned dir.
 make run
 ```
 
+If you get this output,
+```bash
+Setup of the rendering thread failed: Unable to make GL context current
+Falling back to rendering in the main thread. The content may not be updated while resizing the window.
+```
+this may fix the problem.
+```bash
+__GLX_VENDOR_LIBRARY_NAME=mesa LIBGL_ALWAYS_SOFTWARE=1 ./chordMapper-x86_64.AppImage
+__GLX_VENDOR_LIBRARY_NAME=mesa LIBGL_ALWAYS_SOFTWARE=1 make run
+```
+
 This is the UI of the chordMapper. Sorry, it's still awful.
 Select input and output device that you want to use. 
 And then, click `Play/Stop` button.

package.yaml

@@ -28,17 +28,21 @@ dependencies:
 - PortMidi
 - deepseq
 - HCodecs
-- unix
 - stm
 - time
 - containers
-- monomer
 - text
 - text-show
 - lens
 - dhall
 - filepath
 - directory
+- brick
+- microlens
+- microlens-th
+- microlens-mtl
+- vty
+- vector
 
 ghc-options:
 - -Wall

src/Mapper.hs

@@ -45,7 +45,7 @@ import Chord (Chord(..)
              , getVoicingBetweenOn, getEnvelopeDifference
              , degreeToChord7thOnePassingTension
              , addNoMin2ndTension)
-import Ui
+import Tui
 import Types
 import ArgParse
 import Rec
@@ -120,7 +120,7 @@ mapperMain = do
   checkFilePath "font" fontPath
 
   -- Load config.
-  config <- Dhall.input Dhall.auto $ T.pack cfgPath :: IO FullConfig
+  config <- Dhall.inputFile Dhall.auto cfgPath :: IO FullConfig
   print config
 
   -- Initialize buffers.
@@ -135,7 +135,7 @@ mapperMain = do
              in bimap f f <$> getAllDevices :: IO ([(InputDeviceID, String)], [(OutputDeviceID, String)])
   -- UI thread.
   let needOutSubDev = isMinilab3 config
-  (uiInput, uiUpdator) <- createUiThread devices needOutSubDev $ T.pack fontPath
+  (uiInput, uiUpdator) <- createTuiThread devices needOutSubDev
   initializeMidi
   -- Wait and execute UI input.
   let
@@ -148,12 +148,12 @@ mapperMain = do
           --Start Midi threads.
           _ <- forkIO $ mainLoop loopExitSig loopExitDoneSig
                         uiUpdator config inDev outDev mbOutSubDev
-          putStrLn "Loop Started."
+          -- putStrLn "Loop Started."
           loop -- Keep listening.
         UiStop -> do
           putMVar loopExitSig ()
           takeMVar loopExitDoneSig
-          putStrLn "Loop Stop Done."
+          -- putStrLn "Loop Stop Done."
           putMVar loopExitDoneSig ()
           loop -- Keep listening.
         UiExit -> do
@@ -181,14 +181,14 @@ mainLoop exitSig exitDoneSig uiUpdator config inDev outDev mbOutSubDev = do
     tChordStep <- newTVarIO 0
     preStopSig <- newTVarIO False
     stopSig <- newTVarIO False
-    putStrLn "Clearing MIDI Devices..."
+    -- putStrLn "Clearing MIDI Devices..."
     wait 0.5
     (getRecData, recorder, getMsgToStop, recStart, recPlayResume, recPlayStop)
       <- createRecPlay tChordMap (fromIntegral $ recStepNum config)
     let
       qnSec = oneQnSec config
       op = do
-        putStrLn "Initializing MIDI Devices..."
+        -- putStrLn "Initializing MIDI Devices..."
         _ <- forkIO $ clockLoop qnSec tChordMapSet tChordMap
                         genBuf preStopSig tChordStep uiUpdator
                         (fromIntegral $ clockOffset config)
@@ -208,19 +208,19 @@ mainLoop exitSig exitDoneSig uiUpdator config inDev outDev mbOutSubDev = do
                         tPushingKeys tChordMap stopSig -- poll input and add to buffer
         _ <- forkIO $ controlReceiver stopSig tControl -- For Special Input
                         [ ( NextChordMapSet
-                          ,  putStrLn "Chord map change registered!"
-                              >> changeChordMapSet
+                          ,  -- putStrLn "Chord map change registered!"
+                              changeChordMapSet
                                   tChordMapSet tChordMapSetIndex
                                   (chordMapSetList config))
                         , ( RecStart
-                          ,  putStrLn "Rec Start!"
-                             >> recStart)
+                          ,  -- putStrLn "Rec Start!"
+                             recStart)
                         , ( RecPlayResume
-                          ,  putStrLn "Rec Play Resume!"
-                             >> recPlayResume)
+                          ,  -- putStrLn "Rec Play Resume!"
+                             recPlayResume)
                         , ( RecPlayStop
-                          ,  putStrLn "Rec Play Stop!"
-                               >> recPlayStop
+                          ,  -- putStrLn "Rec Play Stop!"
+                               recPlayStop
                                >> atomically
                                     ( readTVar tChordStep
                                       >>= getMsgToStop
@@ -244,21 +244,21 @@ mainLoop exitSig exitDoneSig uiUpdator config inDev outDev mbOutSubDev = do
               return (length vals)
           mergedSendOut ellapsed = sum <$> mapM ($ ellapsed) [sendOut, sendSubOut]
         _ <- forkIO (midiOutRec 0.0 mergedSendOut stopSig) -- take from buffer and output
-        putStrLn "MIDI I/O services started."
+        -- putStrLn "MIDI I/O services started."
         detectExitLoop stopSig -- should only exit this via handleCtrlC
       closeOp = do
         atomically $ writeTVar preStopSig True -- signal the other threads to stop
-        putStrLn "Stopping clock signal" -- not clear why Ctrl+C is needed again
+        -- putStrLn "Stopping clock signal" -- not clear why Ctrl+C is needed again
         wait 1.0
         atomically $ writeTVar stopSig True -- signal the other threads to stop
-        putStrLn "Stopping MIDI devices" -- not clear why Ctrl+C is needed again
+        -- putStrLn "Stopping MIDI devices" -- not clear why Ctrl+C is needed again
         wait 2.0 -- give the other threads time to stop before closing down MIDI!
-        putStrLn "before terminating..."
+        -- putStrLn "before terminating..."
         wait 0.5 -- give MIDI time to close down
         putMVar exitDoneSig ()
     _ <- forkIO op
     takeMVar exitSig
-    putStrLn "Got exit"
+    -- putStrLn "Got exit"
     closeOp
 
 -- Invoke tasks by special inputs like tapping pads.
@@ -370,7 +370,7 @@ clockLoop qnSec tChordMapSet tChordMap genBuf preStopSig tChordStep uiUpdator
     _ <- execStateT loop 0
     sendStop
     uiUpdator (Just "", Just 0, Just 0)
-    putStrLn "closed clock"
+    -- putStrLn "closed clock"
 
 type ChordMap = (Int, String, ChordKeyMap)
 
@@ -510,8 +510,8 @@ specialInput tControl cfgs msg =
         isSameNoteOn _ _ = False
       in
         when (isSameNoteOn cfgMsg msg) $ do
-          putStrLn "got special input."
-          print msg
+          -- putStrLn "got special input."
+          -- print msg
           atomically . writeTVar tControl $ Just control
 
   in mapM_ f cfgs
@@ -631,4 +631,4 @@ sendMidiOut dev ms = outputMidi dev >> mapM_ (deliverMidiEvent dev . (0,) . snd)
 type Seconds = Double
 -- Wait specified seconds.
 wait :: Seconds -> IO () 
-wait s = threadDelay $ round $ s * 1000000
+wait s = threadDelay $ round $ s * 1000000

src/Tui.hs

@@ -0,0 +1,197 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Tui where
+
+import Data.Bool (bool)
+import Data.Maybe (fromJust)
+import Control.Concurrent
+import Control.Concurrent.STM
+import qualified Data.List as L
+import qualified Data.Vector as Vec
+import Lens.Micro ((^.))
+import Lens.Micro.TH (makeLenses)
+import Lens.Micro.Mtl
+import Control.Monad (void)
+import Control.Monad.Trans (liftIO)
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Monoid ((<>))
+#endif
+import qualified Graphics.Vty as V
+
+import qualified Brick.Types as T
+import Brick.AttrMap
+import Brick.Util
+import Brick.Types (Widget, ViewportType(Vertical))
+import qualified Brick.Main as M
+import qualified Brick.Widgets.Edit as E
+import qualified Brick.Widgets.Center as C
+import qualified Brick.Widgets.Border as B
+import Brick.Widgets.Core
+import qualified Brick.Widgets.List as WL
+import Euterpea.IO.MIDI.MidiIO
+    ( OutputDeviceID, InputDeviceID, unsafeInputID, unsafeOutputID )
+import Brick.BChan (BChan, newBChan, writeBChan)
+
+data UiInput
+  = UiStart InputDeviceID OutputDeviceID
+      (Maybe OutputDeviceID) -- For like, lights on keyboard like MiniLab3 touch pads.
+  | UiStop
+  | UiExit
+
+data CustomEvent = ChangeChordInfo String Int Int
+
+type UiUpdator = (Maybe String, Maybe Int, Maybe Int) -> IO ()
+type DeviceLists = ([(InputDeviceID, String)], [(OutputDeviceID, String)])
+
+data Name = InputList | OutputList | SpecialList | StartStopButton
+          deriving (Eq, Ord, Show)
+
+data St = St { _chordName :: String 
+             , _clockProgress :: Int
+             , _chordSetProgress :: Int
+             , _selectListIndex :: Int
+             , _inputList :: WL.List Name String
+             , _outputList :: WL.List Name String
+             , _specialList :: WL.List Name String
+             , _playing :: Bool
+             }
+
+makeLenses ''St
+
+drawUi :: St -> [Widget Name]
+drawUi st = L.singleton
+          $ hBox [
+                      colHigh 0 (str "Select Input:") <=>
+                        WL.renderList renderFunc True (st^.inputList)
+                   ,  colHigh 1 (str "Select Output:") <=>
+                        WL.renderList renderFunc True (st^.outputList)
+                   ,  colHigh 2 (str "Select Special output:") <=>
+                        WL.renderList renderFunc True (st^.specialList)
+                   ] <=>
+            strWrap ( "Chord             : " ++ st^.chordName ) <=>
+            strWrap ( "Chord set progress: "
+              ++ concat (replicate (st^.chordSetProgress) "o")) <=>
+            strWrap ( "Chord progress    : "
+              ++ concat (replicate (st^.clockProgress `div` 6) "o")) <=>
+            (withAttr (attrName "info")
+              . strWrap $ "Left/Right: Select device type."
+                          ++ "  Up/Down: Select device."
+                          ++ "  Space: Start/Stop playing.")
+  where
+    colHigh i = if i == st^.selectListIndex then withAttr (attrName "colHighlight") else id
+    renderFunc sel e = rowHigh $ strWrap e
+      where rowHigh = if sel then withAttr (attrName "rowHighlight") else id
+
+appEvent :: (Int -> Int -> Int -> IO ())
+         -> IO () -> T.BrickEvent Name CustomEvent -> T.EventM Name St ()
+appEvent _ _ (T.AppEvent (ChangeChordInfo name clockI setI))
+                                          =  chordName %= const name
+                                          >> clockProgress %= const clockI
+                                          >> chordSetProgress %= const setI
+appEvent start stop (T.VtyEvent e) = case e of
+  (V.EvKey V.KLeft []) -> selectListIndex %= (\i -> max 0 (i - 1))
+  (V.EvKey V.KRight []) -> selectListIndex %= (\i -> min 2 (i + 1))
+  (V.EvKey (V.KChar ' ') []) ->
+    use playing >>= bool
+                      (do
+                        inId <- use $ inputList . WL.listSelectedL
+                        outId <- use $ outputList . WL.listSelectedL
+                        spId <- use $ specialList . WL.listSelectedL
+                        liftIO $ start (fromJust inId)
+                                       (fromJust outId)
+                                       (fromJust spId)
+                        playing %= const True)
+                      (liftIO stop >> playing %= const False)
+  (V.EvKey V.KEsc []) -> do
+                           vty <- M.getVtyHandle
+                           liftIO $ V.setMode (V.outputIface vty) V.Mouse False
+                           liftIO $ putStr "\ESC[0m\ESC[2J\ESC[H"
+                           M.halt
+  ev -> do
+                      nowCol <- use selectListIndex
+                      let targetList = case nowCol of
+                                         0 -> inputList
+                                         1 -> outputList
+                                         2 -> specialList
+                                         _ -> inputList
+                      T.zoom targetList $ WL.handleListEvent ev
+appEvent _ _ _ =  return ()
+
+aMap :: AttrMap
+aMap = attrMap V.defAttr
+    [ (attrName "colHighlight",   V.white `on` V.cyan)
+    , (attrName "rowHighlight",   V.white `on` V.blue)
+    , (attrName "info",           V.white `on` V.magenta)
+    ]
+
+app :: (Int -> Int -> Int -> IO ()) -> IO () -> M.App St CustomEvent Name
+app start stop =
+    M.App { M.appDraw = drawUi
+          , M.appChooseCursor = M.showFirstCursor
+          , M.appStartEvent = do
+              vty <- M.getVtyHandle
+              liftIO $ V.setMode (V.outputIface vty) V.Mouse True
+          , M.appHandleEvent = appEvent start stop
+          , M.appAttrMap = const aMap
+          }
+
+tuiMain :: DeviceLists
+        -> (Int -> Int -> Int -> IO ()) -> IO () -> IO ()
+        -> BChan CustomEvent
+        -> IO()
+tuiMain devices start stop exit varsChan = do
+  let
+    inputs = Vec.fromList . map (\(id, name) -> show id ++ ": " ++ name) $ fst devices 
+    outputs = Vec.fromList . map (\(id, name) -> show id ++ ": "++ name) $ snd devices 
+    specials = outputs
+  _ <- M.customMainWithDefaultVty (Just varsChan) (app start stop)
+        $ St { _chordName = ""
+             , _clockProgress = 0
+             , _chordSetProgress = 0
+             , _selectListIndex = 0
+             , _inputList = WL.list InputList inputs 5
+             , _outputList = WL.list OutputList outputs 5
+             , _specialList = WL.list SpecialList specials 5
+             , _playing = False
+             }
+  exit
+
+readVars :: BChan CustomEvent -> TVar String -> TVar Int -> TVar Int -> IO ()
+readVars varsChan tChordName tClockProgress tChordSetProgress = go 
+  where
+    go = do
+      threadDelay 100000
+      writeBChan varsChan =<< ChangeChordInfo <$> readTVarIO tChordName
+                                              <*> readTVarIO tClockProgress
+                                              <*> readTVarIO tChordSetProgress
+      go
+
+
+createTuiThread :: DeviceLists -> Bool -> IO (IO UiInput, UiUpdator)
+createTuiThread devices needOutSubDev = do 
+  mUiInput <- newEmptyMVar
+  tChordName <- newTVarIO ""
+  tClockProgress <- newTVarIO 0
+  tChordSetProgress <- newTVarIO 0
+  varsChan <- newBChan 10
+  void . forkIO $ readVars varsChan tChordName tClockProgress tChordSetProgress
+  _ <- forkIO $ tuiMain devices
+                  (\inIx outIx spIx -> 
+                    let
+                      inId = fst $ fst devices !! inIx
+                      outId = fst $ snd devices !! outIx
+                      mSpId = Just . fst $ snd devices !! spIx
+                    in putMVar mUiInput $ UiStart inId outId mSpId)
+                  (putMVar mUiInput UiStop)
+                  (putMVar mUiInput UiExit)
+                  varsChan
+  let
+    uiInput = takeMVar mUiInput
+    updateTVar tx = maybe (return ()) (atomically . writeTVar tx)
+    updator (mbChordName, mbClockProgress, mbChordSetProgress)
+      =  updateTVar tChordName mbChordName
+      >> updateTVar tClockProgress mbClockProgress
+      >> updateTVar tChordSetProgress mbChordSetProgress
+
+  return (uiInput, updator)