diff options
| -rw-r--r-- | TextViewport.hs | 243 |
1 files changed, 168 insertions, 75 deletions
diff --git a/TextViewport.hs b/TextViewport.hs index b97936e..3ca10a5 100644 --- a/TextViewport.hs +++ b/TextViewport.hs @@ -5,6 +5,9 @@ module TextViewport , Buffer(..) , WrapStrategy(..) , RenderedLine(..) + , RenderedItem(..) + , CachedRender(..) + , RenderCache(..) , RenderedBuffer , renderBuffer , flatten @@ -21,7 +24,10 @@ module TextViewport import Data.List (minimumBy) import Data.Ord (comparing) import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.HashMap.Strict as HM import qualified Data.Text as T +import qualified Data.Vector as V import qualified Text.Hyphenation as H import qualified Data.Sequence as Seq @@ -35,7 +41,10 @@ import qualified Data.Foldable as F data WrapStrategy = NoWrap | FixedWidthWrap - | HyphenateWrap H.Hyphenator + | HyphenateWrap + { hwDict :: H.Hyphenator + , hwCache :: HM.HashMap Text [(Text, Text)] + } data Item = Item { itemText :: Text @@ -59,75 +68,139 @@ data RenderedLine = RenderedLine , rlCharStart :: !Int } deriving (Show) -type RenderedBuffer = Seq [RenderedLine] +type RenderedBuffer = Seq RenderedItem -flatten :: RenderedBuffer -> [RenderedLine] -flatten = concat . F.toList +data RenderedItem = RenderedItem + { riLines :: !(Vector RenderedLine) + } -renderBuffer :: Int -> Buffer -> RenderedBuffer -renderBuffer width (Buffer items) = - let itemsList = F.toList items - blocks = zipWith (renderItem width) [0..] itemsList - in Seq.fromList blocks +flatten :: RenderedBuffer -> [RenderedLine] +flatten = concatMap (F.toList . riLines) . F.toList + +renderBuffer :: Int -> Buffer -> RenderCache -> (RenderCache, RenderedBuffer) +renderBuffer width (Buffer items) (RenderCache cache) = + let n = Seq.length items + go i (cAcc, rAcc) + | i >= n = (RenderCache cAcc, rAcc) + | otherwise = + let item = Seq.index items i + mOld = Seq.index cache i + newEntry = renderItem width i item mOld + cAcc' = Seq.update i (Just newEntry) cAcc + rAcc' = rAcc Seq.|> crRendered newEntry + in go (i + 1) (cAcc', rAcc') + in go 0 (cache, Seq.empty) + +renderItem :: Int -> Int -> Item -> Maybe CachedRender -> CachedRender +renderItem width itemIx (Item txt strategy) mOld = + case mOld of + Just old + | crWidth old == width + , crText old == txt + -> old + _ -> + let linesV = applyStrategy strategy width itemIx txt + rendered = RenderedItem linesV + in CachedRender + { crWidth = width + , crStrategy = strategy + , crText = txt + , crRendered = rendered + } + +data CachedRender = CachedRender + { crWidth :: !Int + , crStrategy :: !WrapStrategy + , crText :: !Text + , crRendered :: !RenderedItem + } -renderItem :: Int -> Int -> Item -> [RenderedLine] -renderItem width itemIx (Item txt strategy) = - zipWith mkLine [0..] (applyStrategy strategy width txt) - where - mkLine logicalIx (off, chunk) = - RenderedLine - { rlText = chunk - , rlItemIx = itemIx - , rlLineIx = logicalIx - , rlCharStart = off - } +newtype RenderCache = RenderCache { unRenderCache :: Seq (Maybe CachedRender) } -------------------------------------------------------------------------------- -- Wrapping strategies -------------------------------------------------------------------------------- -applyStrategy :: WrapStrategy -> Int -> Text -> [(Int, Text)] -applyStrategy NoWrap _ t = - let ls = T.splitOn "\n" t - in zip (scanOffsets ls) ls +applyStrategy :: WrapStrategy -> Int -> Int -> Text -> Vector RenderedLine -applyStrategy FixedWidthWrap w t = - concatMap chunkOne (T.splitOn "\n" t) - where - chunkOne line = - let chunks = chunkFixed w line - offs = scanOffsets chunks - in zip offs chunks +applyStrategy NoWrap width itemIx txt = + let rawLines = T.splitOn "\n" txt + chunks = map (T.take width) rawLines -- crop + offsets = scanOffsetsWithNewlines chunks + in V.fromList + [ RenderedLine { rlText = chunk, rlItemIx = itemIx, rlLineIx = lineIx, rlCharStart = off } + | (lineIx, (off, chunk)) <- zip [0..] (zip offsets chunks) + ] + +applyStrategy FixedWidthWrap width itemIx txt = + let rawLines = T.splitOn "\n" txt + (allChunks, _) = foldl step ([], 0) rawLines + step (acc, off0) line = + let chunks = chunkFixed width line + offsets = scanOffsetsFrom off0 chunks + offNext = off0 + T.length line + 1 -- +1 for newline + acc' = acc ++ zip offsets chunks + in (acc', offNext) + in V.fromList + [ RenderedLine { rlText = chunk, rlItemIx = itemIx, rlLineIx = lineIx, rlCharStart = off } + | (lineIx, (off, chunk)) <- zip [0..] allChunks + ] -applyStrategy (HyphenateWrap dict) w t = - concatMap wrapOne (T.splitOn "\n" t) +applyStrategy (HyphenateWrap dict cache0) width itemIx txt = + let rawLines = T.splitOn "\n" txt + + -- fold over each physical line, accumulating: + -- * all rendered (offset, chunk) pairs + -- * updated hyphenation cache (unused for now) + -- * running character offset across lines + (allChunks, _cache1, _) = + foldl wrapOneLine ([], cache0, 0) rawLines + in V.fromList + [ RenderedLine { rlText = chunk, rlItemIx = itemIx, rlLineIx = lineIx, rlCharStart = off } + | (lineIx, (off, chunk)) <- zip [0..] allChunks + ] + where + -- Wrap a single physical line using TeX‑lite hyphenation + wrapOneLine + :: ([(Int, Text)], HM.HashMap Text [(Text, Text)], Int) + -> Text + -> ([(Int, Text)], HM.HashMap Text [(Text, Text)], Int) + wrapOneLine (acc, cache, off0) line = + let chunks = wrapWithHyphenationTeXLite dict width line + offsets = scanOffsetsFrom off0 chunks + offNext = off0 + T.length line + 1 -- +1 for newline + acc' = acc ++ zip offsets chunks + in (acc', cache, offNext) + +-- | Compute running character offsets for a list of chunks. +scanOffsetsWithNewlines :: [Text] -> [Int] +scanOffsetsWithNewlines = go 0 where - wrapOne line = - let chunks = wrapWithHyphenationTeXLite dict w line - offsets = scanOffsets chunks - in zip offsets chunks + go !_ [] = [] + go !o (l:ls) = + let off = o + o' = o + T.length l + 1 -- +1 for newline + in off : go o' ls +-- | Chunk a single line into fixed-width pieces. chunkFixed :: Int -> Text -> [Text] chunkFixed w t + | w <= 0 = [] | T.null t = [""] - | otherwise = go t - where - go s - | T.null s = [] - | otherwise = - let (c, r) = T.splitAt w s - in c : go r + | otherwise = + let (h, rest) = T.splitAt w t + in h : if T.null rest then [] else chunkFixed w rest -------------------------------------------------------------------------------- -- Hyphenation-aware wrapping (TeX-lite) -------------------------------------------------------------------------------- -scanOffsets :: [Text] -> [Int] -scanOffsets [] = [] -scanOffsets (x:xs) = 0 : go (T.length x) xs +-- Compute offsets starting from a base offset +scanOffsetsFrom :: Int -> [Text] -> [Int] +scanOffsetsFrom start = go start where - go _ [] = [] - go acc (y:ys) = acc : go (acc + T.length y) ys + go !_ [] = [] + go !o (t:ts) = o : go (o + T.length t) ts wrapWithHyphenationTeXLite :: H.Hyphenator -> Int -> Text -> [Text] wrapWithHyphenationTeXLite dict width txt = @@ -136,12 +209,28 @@ wrapWithHyphenationTeXLite dict width txt = go [] = [] go ws = case lineCandidates dict width ws of - [] -> [T.unwords ws] -- fallback: everything on one line + [] -> + -- Hyphenation failed: fall back to fixed-width chunking + breakWordSafe width ws + cs -> let (line, rest, _) = minimumBy (comparing (scoreCandidate width)) cs in line : go rest +-- | Lossless fallback: treat remaining words as one long text and +-- chunk it into width-sized pieces. Never truncates, never drops text. +breakWordSafe :: Int -> [Text] -> [Text] +breakWordSafe width ws = + chunk (T.unwords ws) + where + chunk t + | T.null t = [] + | T.length t <= width = [t] + | otherwise = + let (c, r) = T.splitAt width t + in c : chunk r + type Candidate = (Text, [Text], Bool) lineCandidates :: H.Hyphenator -> Int -> [Text] -> [Candidate] @@ -203,11 +292,14 @@ scoreCandidate width (line, _, endsWithHyphen) = -- Incremental re-rendering -------------------------------------------------------------------------------- -updateRenderedItem :: Int -> Int -> Buffer -> RenderedBuffer -> RenderedBuffer -updateRenderedItem width itemIx (Buffer items) rb = +updateRenderedItem :: Int -> Int -> Buffer -> RenderCache -> Seq RenderedItem -> (RenderCache, Seq RenderedItem) +updateRenderedItem width itemIx (Buffer items) (RenderCache cache) rb = let item = Seq.index items itemIx - newBlock = renderItem width itemIx item - in Seq.update itemIx newBlock rb + mOld = Seq.index cache itemIx + newEntry = renderItem width itemIx item mOld + newCache = Seq.update itemIx (Just newEntry) cache + newRB = Seq.update itemIx (crRendered newEntry) rb + in (RenderCache newCache, newRB) -------------------------------------------------------------------------------- -- Viewport @@ -219,9 +311,9 @@ data Viewport = Viewport , vpOffset :: !Int } deriving (Show) -defaultViewport :: Int -> Int -> [RenderedLine] -> Viewport -defaultViewport w h rendered = - let total = length rendered +defaultViewport :: Int -> Int -> RenderedBuffer -> Viewport +defaultViewport w h rb = + let total = length (flatten rb) off = max 0 (total - h) in Viewport w h off @@ -229,16 +321,17 @@ scrollUp :: Int -> Viewport -> Viewport scrollUp k vp = vp { vpOffset = max 0 (vpOffset vp - k) } -scrollDown :: Int -> [RenderedLine] -> Viewport -> Viewport -scrollDown k rendered vp = - let total = length rendered - maxOff = max 0 (total - vpHeight vp) - newOff = min maxOff (vpOffset vp + k) - in vp { vpOffset = newOff } +scrollDown :: Int -> Int -> Viewport -> Viewport +scrollDown totalLines n vp = + let newTop = min (totalLines - vpHeight vp) (vpOffset vp + n) + in vp { vpOffset = max 0 newTop } -visibleLines :: [RenderedLine] -> Viewport -> [RenderedLine] -visibleLines rendered vp = - take (vpHeight vp) . drop (vpOffset vp) $ rendered +visibleLines :: RenderedBuffer -> Viewport -> [RenderedLine] +visibleLines rb vp = + let allLines = flatten rb + start = vpOffset vp + end = start + vpHeight vp + in take (vpHeight vp) . drop start $ allLines -------------------------------------------------------------------------------- -- Coordinate lookup @@ -248,13 +341,13 @@ lookupPosition :: Int -> Int -> Viewport - -> [RenderedLine] + -> RenderedBuffer -> Maybe (Int, Int) -lookupPosition x y vp rendered = do - let lineIx = vpOffset vp + y - rl <- renderedAt lineIx rendered - pure (rlItemIx rl, rlCharStart rl + x) - where - renderedAt ix rs - | ix < 0 || ix >= length rs = Nothing - | otherwise = Just (rs !! ix) +lookupPosition x y vp rb = + let allLines = flatten rb + idx = vpOffset vp + y + in case drop idx allLines of + (rl:_) -> + let charIx = rlCharStart rl + x + in Just (rlItemIx rl, charIx) + [] -> Nothing |