bump

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