{- | Glue between the notation image renderer and the brick UI, using Kitty
graphics protocol direct placement.

Each track that shows notation reserves a fixed-height region ('notationRegionWidget')
of blank cells. brick lays it out and reports its on-screen extent; in the event
handler 'syncNotationGraphics' looks that extent up, renders the notation image,
moves the cursor there, and blits the image scaled to the region (Kitty draws it
over the blank cells). Re-emitting with a stable image/placement id replaces the
placement rather than stacking.

Gated on the detected protocol being 'Kitty' with Bravura loaded; otherwise the
caller falls back to the Unicode text staff.
-}
module Termtab.UI.NotationGraphics (
    syncNotationGraphics,
    notationRegionWidget,
    graphicsNotationActive,
    notationRows,
) where

import Brick
import Brick.Main (lookupExtent)
import Brick.Types (locationColumnL, locationRowL)
import Control.Monad (forM_, when)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BC
import Data.Map.Strict qualified as Map
import Lens.Micro ((^.))
import System.IO (hFlush, stdout)

import Termtab.Graphics.Detect (GraphicsProtocol (..))
import Termtab.Graphics.Font (GlyphFont)
import Termtab.Graphics.Kitty (deleteImage, encodeDirect)
import Termtab.Graphics.Notation (defaultLayout, renderNotationImage, totalColumns)
import Termtab.Types
import Termtab.UI.Types
import Termtab.UI.Widgets.Tablature (findVisibleRange)

-- | Height of the notation strip, in terminal cells.
notationRows :: Int
notationRows :: Int
notationRows = Int
7

{- | Kitty image id for a track's notation (distinct per track, nonzero).
Nonzero matters because Kitty reserves id 0 as \"no explicit id\"; @i +
1@ is the simplest mapping that avoids it.
-}
trackImageId :: TrackIndex -> Int
trackImageId :: TrackIndex -> Int
trackImageId (TrackIndex Int
i) = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

{- | True when the graphics notation path is available: the terminal speaks the
Kitty protocol and Bravura loaded.
-}
graphicsNotationActive :: AppState -> Bool
graphicsNotationActive :: AppState -> Bool
graphicsNotationActive AppState
st =
    AppState -> GraphicsProtocol
asProtocol AppState
st GraphicsProtocol -> GraphicsProtocol -> Bool
forall a. Eq a => a -> a -> Bool
== GraphicsProtocol
Kitty Bool -> Bool -> Bool
&& Bool -> (GlyphFont -> Bool) -> Maybe GlyphFont -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> GlyphFont -> Bool
forall a b. a -> b -> a
const Bool
True) (AppState -> Maybe GlyphFont
asGlyphFont AppState
st)

{- | The reserved region a track's notation image is blitted over: blank cells
whose extent we report so the transmit step can find its screen position.
-}
notationRegionWidget :: TrackIndex -> Widget ResourceName
notationRegionWidget :: TrackIndex -> Widget ResourceName
notationRegionWidget TrackIndex
tIdx =
    ResourceName -> Widget ResourceName -> Widget ResourceName
forall n. Ord n => n -> Widget n -> Widget n
reportExtent (TrackIndex -> ResourceName
NotationRegion TrackIndex
tIdx) (Int -> Widget ResourceName -> Widget ResourceName
forall n. Int -> Widget n -> Widget n
vLimit Int
notationRows (Char -> Widget ResourceName
forall n. Char -> Widget n
fill Char
' '))

{- | For every track, blit its notation image if it shows notation and its
content/position changed since last time, or clear a stale image if it stopped
showing notation. A no-op when graphics are unavailable.
-}
syncNotationGraphics :: EventM ResourceName AppState ()
syncNotationGraphics :: EventM ResourceName AppState ()
syncNotationGraphics = do
    st <- EventM ResourceName AppState AppState
forall s (m :: * -> *). MonadState s m => m s
get
    case (asProtocol st, asGlyphFont st) of
        (GraphicsProtocol
Kitty, Just GlyphFont
font) ->
            [(Int, Track)]
-> ((Int, Track) -> EventM ResourceName AppState ())
-> EventM ResourceName AppState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Track] -> [(Int, Track)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Song -> [Track]
songTracks (AppState -> Song
asSong AppState
st))) (((Int, Track) -> EventM ResourceName AppState ())
 -> EventM ResourceName AppState ())
-> ((Int, Track) -> EventM ResourceName AppState ())
-> EventM ResourceName AppState ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, Track
track) -> do
                let tIdx :: TrackIndex
tIdx = Int -> TrackIndex
TrackIndex Int
i
                if DisplayMode -> Bool
showsNotation (AppState -> TrackIndex -> Track -> DisplayMode
trackDisplayMode AppState
st TrackIndex
tIdx Track
track)
                    then do
                        mExt <- ResourceName
-> EventM ResourceName AppState (Maybe (Extent ResourceName))
forall n s. Eq n => n -> EventM n s (Maybe (Extent n))
lookupExtent (TrackIndex -> ResourceName
NotationRegion TrackIndex
tIdx)
                        forM_ mExt $ emitTrack st font tIdx track
                    else TrackIndex -> EventM ResourceName AppState ()
clearTrackImage TrackIndex
tIdx
        (GraphicsProtocol, Maybe GlyphFont)
_ -> () -> EventM ResourceName AppState ()
forall a. a -> EventM ResourceName AppState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{- | Render one track's notation and blit it over its reserved extent — but only
if its signature changed, so in-place navigation doesn't re-blit (and flicker).
-}
emitTrack ::
    AppState ->
    GlyphFont ->
    TrackIndex ->
    Track ->
    Extent ResourceName ->
    EventM ResourceName AppState ()
emitTrack :: AppState
-> GlyphFont
-> TrackIndex
-> Track
-> Extent ResourceName
-> EventM ResourceName AppState ()
emitTrack AppState
st GlyphFont
font TrackIndex
tIdx Track
track Extent ResourceName
ext = do
    let ul :: Location
ul = Extent ResourceName -> Location
forall n. Extent n -> Location
extentUpperLeft Extent ResourceName
ext
        col :: Int
col = Location
ul Location -> Getting Int Location Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Location Int
forall a. TerminalLocation a => Lens' a Int
Lens' Location Int
locationColumnL
        row :: Int
row = Location
ul Location -> Getting Int Location Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Location Int
forall a. TerminalLocation a => Lens' a Int
Lens' Location Int
locationRowL
        (Int
w, Int
_h) = Extent ResourceName -> (Int, Int)
forall n. Extent n -> (Int, Int)
extentSize Extent ResourceName
ext
        zoom :: Int
zoom = AppState -> Int
asZoom AppState
st
        MeasureIndex Int
cursorM = AppState -> MeasureIndex
asCurrentMeasure AppState
st
        -- Match the tab: it reserves one label column, then the measures.
        contentWidth :: Int
contentWidth = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        visible :: [(MeasureIndex, [Beat], Measure)]
visible = Track
-> [Measure]
-> Int
-> Int
-> Int
-> [(MeasureIndex, [Beat], Measure)]
findVisibleRange Track
track (Song -> [Measure]
songMeasures (AppState -> Song
asSong AppState
st)) Int
zoom Int
contentWidth Int
cursorM
        -- Blit only as many cells wide as the content, so one layout column maps
        -- to one terminal cell and the notation lines up with the tab below.
        cols :: Int
cols = NotationLayout -> Int -> [(MeasureIndex, [Beat], Measure)] -> Int
totalColumns NotationLayout
defaultLayout Int
zoom [(MeasureIndex, [Beat], Measure)]
visible
        sig :: String
sig = Int -> Int -> Int -> [(MeasureIndex, [Beat], Measure)] -> String
notationSignature Int
col Int
row Int
cols [(MeasureIndex, [Beat], Measure)]
visible
        imgId :: Int
imgId = TrackIndex -> Int
trackImageId TrackIndex
tIdx
    prev <- (AppState -> Maybe String)
-> EventM ResourceName AppState (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TrackIndex -> Map TrackIndex String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackIndex
tIdx (Map TrackIndex String -> Maybe String)
-> (AppState -> Map TrackIndex String) -> AppState -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppState -> Map TrackIndex String
asNotationSigs)
    when (prev /= Just sig) $ do
        img <-
            liftIO $
                renderNotationImage font defaultLayout (asInkColor st) zoom (trackInstrument track) visible
        -- Delete the previous image, move the cursor to the region's top-left
        -- (1-based), then blit scaled to cols×notationRows cells. Delete + place
        -- go out in one write so the terminal never repaints between them.
        let move = String -> ByteString
BC.pack (String
"\ESC[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
";" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"H")
            payload = Int -> ByteString
deleteImage Int
imgId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
move ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Int -> Image PixelRGBA8 -> ByteString
encodeDirect Int
imgId Int
cols Int
notationRows Image PixelRGBA8
img
        liftIO $ do
            BS.hPut stdout payload
            hFlush stdout
        modify $ \AppState
s -> AppState
s{asNotationSigs = Map.insert tIdx sig (asNotationSigs s)}

{- | Remove a track's on-screen image if one was placed (e.g. it switched to a
mode without notation).
-}
clearTrackImage :: TrackIndex -> EventM ResourceName AppState ()
clearTrackImage :: TrackIndex -> EventM ResourceName AppState ()
clearTrackImage TrackIndex
tIdx = do
    placed <- (AppState -> Bool) -> EventM ResourceName AppState Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TrackIndex -> Map TrackIndex String -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member TrackIndex
tIdx (Map TrackIndex String -> Bool)
-> (AppState -> Map TrackIndex String) -> AppState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppState -> Map TrackIndex String
asNotationSigs)
    when placed $ do
        liftIO $ do
            BS.hPut stdout (deleteImage (trackImageId tIdx))
            hFlush stdout
        modify $ \AppState
s -> AppState
s{asNotationSigs = Map.delete tIdx (asNotationSigs s)}

{- | Cheap key of everything that determines the blitted image + its placement:
position, width, and the visible beats (durations, rests, pitches).
-}
notationSignature :: Int -> Int -> Int -> [(MeasureIndex, [Beat], Measure)] -> String
notationSignature :: Int -> Int -> Int -> [(MeasureIndex, [Beat], Measure)] -> String
notationSignature Int
col Int
row Int
cols [(MeasureIndex, [Beat], Measure)]
visible =
    (Int, Int, Int, [(Int, [(String, Bool, [Int])])]) -> String
forall a. Show a => a -> String
show (Int
col, Int
row, Int
cols, ((MeasureIndex, [Beat], Measure) -> (Int, [(String, Bool, [Int])]))
-> [(MeasureIndex, [Beat], Measure)]
-> [(Int, [(String, Bool, [Int])])]
forall a b. (a -> b) -> [a] -> [b]
map (MeasureIndex, [Beat], Measure) -> (Int, [(String, Bool, [Int])])
forall {c}.
(MeasureIndex, [Beat], c) -> (Int, [(String, Bool, [Int])])
summariseMeasure [(MeasureIndex, [Beat], Measure)]
visible)
  where
    summariseMeasure :: (MeasureIndex, [Beat], c) -> (Int, [(String, Bool, [Int])])
summariseMeasure (MeasureIndex Int
mi, [Beat]
beats, c
_) = (Int
mi, (Beat -> (String, Bool, [Int]))
-> [Beat] -> [(String, Bool, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map Beat -> (String, Bool, [Int])
summariseBeat [Beat]
beats)
    summariseBeat :: Beat -> (String, Bool, [Int])
summariseBeat Beat
b =
        (Duration -> String
forall a. Show a => a -> String
show (Beat -> Duration
beatDuration Beat
b), Beat -> Bool
beatIsRest Beat
b, [Int
p | Note
note <- Beat -> [Note]
beatNotes Beat
b, let Pitch Int
p = Note -> Pitch
notePitch Note
note])

-- Display-mode helpers (mirroring Termtab.UI.Widgets.TrackPanel) -------------

{- | The effective 'DisplayMode' for deciding whether to blit graphics,
duplicating "Termtab.UI.Widgets.TrackPanel"'s own effective-mode logic
(forcing 'Standard' tracks to 'NotationOnly') since this module needs the
same answer but doesn't import that widget module.
-}
trackDisplayMode :: AppState -> TrackIndex -> Track -> DisplayMode
trackDisplayMode :: AppState -> TrackIndex -> Track -> DisplayMode
trackDisplayMode AppState
st TrackIndex
tIdx Track
track =
    case Track -> Instrument
trackInstrument Track
track of
        Standard MidiProgram
_ -> DisplayMode
NotationOnly
        Instrument
_ -> DisplayMode
-> TrackIndex -> Map TrackIndex DisplayMode -> DisplayMode
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault DisplayMode
TabOnly TrackIndex
tIdx (AppState -> Map TrackIndex DisplayMode
asDisplayModes AppState
st)

-- | Does this 'DisplayMode' include the notation staff at all?
showsNotation :: DisplayMode -> Bool
showsNotation :: DisplayMode -> Bool
showsNotation DisplayMode
TabOnly = Bool
False
showsNotation DisplayMode
NotationOnly = Bool
True
showsNotation DisplayMode
TabAndNotation = Bool
True