bump

1 files changed, 330 insertions, 61 deletions

diff --git a/TextViewport.hs b/TextViewport.hs
index 3ca10a5..e3e1f97 100644
--- a/TextViewport.hs
+++ b/TextViewport.hs
@@ -17,14 +17,35 @@ module TextViewport
   , defaultViewport
   , scrollUp
   , scrollDown
-  , visibleLines
   , lookupPosition
+
+  , RenderState(..)
+  , mkRenderState
+  , updateRenderState
+
+  -- Viewport Instance ("simple" façade)
+  , ViewportInstance(..)
+  , mkViewportInstance
+  , visibleLines
+  , applyToInstance
+  , applyToInstanceRS
+  , scrollByI
+  , scrollUpI
+  , scrollDownI
+  , pageUpI
+  , pageDownI
+  , alignTopI
+  , alignBottomI
+  , modifyItemI
+  , lookupPositionI
+
   ) where
 
 import Data.List (minimumBy)
 import Data.Ord  (comparing)
 import Data.Text (Text)
 import Data.Vector (Vector)
+import qualified Data.DList as DL
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Text as T
 import qualified Data.Vector as V
@@ -117,6 +138,21 @@ data CachedRender = CachedRender
 
 newtype RenderCache = RenderCache { unRenderCache :: Seq (Maybe CachedRender) }
 
+--emptyCache :: RenderCache
+--emptyCache = RenderCache Seq.empty
+
+emptyCacheFor :: Buffer -> RenderCache
+emptyCacheFor (Buffer items) =
+  RenderCache (Seq.replicate (Seq.length items) Nothing)
+
+resizeCache :: Buffer -> RenderCache -> RenderCache
+resizeCache (Buffer items) (RenderCache cache) =
+  let n = Seq.length items
+      m = Seq.length cache
+  in RenderCache $
+       if m < n then cache <> Seq.replicate (n - m) Nothing
+       else Seq.take n cache
+
 --------------------------------------------------------------------------------
 -- Wrapping strategies
 --------------------------------------------------------------------------------
@@ -134,13 +170,14 @@ applyStrategy NoWrap width itemIx txt =
 
 applyStrategy FixedWidthWrap width itemIx txt =
   let rawLines = T.splitOn "\n" txt
-      (allChunks, _) = foldl step ([], 0) rawLines
+      (dl, _) = foldl step (DL.empty, 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
+            offNext  = off0 + T.length line + 1
+            acc'     = acc `DL.append` DL.fromList (zip offsets chunks)
         in (acc', offNext)
+      allChunks = DL.toList dl
   in V.fromList
        [ RenderedLine { rlText = chunk, rlItemIx = itemIx, rlLineIx = lineIx, rlCharStart = off }
        | (lineIx, (off, chunk)) <- zip [0..] allChunks
@@ -153,24 +190,31 @@ applyStrategy (HyphenateWrap dict cache0) width itemIx txt =
       --   * all rendered (offset, chunk) pairs
       --   * updated hyphenation cache (unused for now)
       --   * running character offset across lines
-      (allChunks, _cache1, _) =
-        foldl wrapOneLine ([], cache0, 0) rawLines
+      (dl, _cache1, _) =
+        foldl wrapOneLine (DL.empty, cache0, 0) rawLines
+      allChunks = DL.toList dl
   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
+    --  :: ([(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)
+      let (chunks, cache1) = wrapWithHyphenationTeXLite dict width line cache
+          offsets          = scanOffsetsFrom off0 chunks
+          offNext          = off0 + T.length line + 1
+          acc'             = acc `DL.append` DL.fromList (zip offsets chunks)
+      in (acc', cache1, offNext)
+    --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]
@@ -202,21 +246,26 @@ scanOffsetsFrom start = go start
     go !_ []     = []
     go !o (t:ts) = o : go (o + T.length t) ts
 
-wrapWithHyphenationTeXLite :: H.Hyphenator -> Int -> Text -> [Text]
-wrapWithHyphenationTeXLite dict width txt =
-    go (T.words txt)
+wrapWithHyphenationTeXLite
+  :: H.Hyphenator
+  -> Int
+  -> Text
+  -> HM.HashMap Text [(Text, Text)]
+  -> ([Text], HM.HashMap Text [(Text, Text)])
+wrapWithHyphenationTeXLite dict width txt cache0 =
+    go cache0 (T.words txt)
   where
-    go [] = []
-    go ws =
-      case lineCandidates dict width ws of
-        [] ->
-          -- Hyphenation failed: fall back to fixed-width chunking
-          breakWordSafe width ws
-
-        cs ->
+    go cache [] = ([], cache)
+    go cache ws =
+      case lineCandidates dict width cache ws of
+        ([], cache1) ->
+          let chunks = breakWordSafe width ws
+          in (chunks, cache1)
+        (cs, cache1) ->
           let (line, rest, _) =
                 minimumBy (comparing (scoreCandidate width)) cs
-          in line : go rest
+              (more, cache2) = go cache1 rest
+          in (line : more, cache2)
 
 -- | Lossless fallback: treat remaining words as one long text and
 --   chunk it into width-sized pieces. Never truncates, never drops text.
@@ -233,40 +282,46 @@ breakWordSafe width ws =
 
 type Candidate = (Text, [Text], Bool)
 
-lineCandidates :: H.Hyphenator -> Int -> [Text] -> [Candidate]
-lineCandidates dict width = go [] []
+lineCandidates
+  :: H.Hyphenator
+  -> Int
+  -> HM.HashMap Text [(Text, Text)]
+  -> [Text]
+  -> ([(Text, [Text], Bool)], HM.HashMap Text [(Text, Text)])
+lineCandidates dict width cache0 ws0 =
+  go [] [] cache0 ws0
   where
-    go :: [Text] -> [Candidate] -> [Text] -> [Candidate]
-    go _    acc []         = acc
-    go line acc (w:ws) =
+    go _    acc cache [] = (acc, cache)
+    go line acc cache (w:ws) =
       let space   = if null line then "" else " "
           baseTxt = T.unwords line
-
-          -- whole word candidate (no hyphen)
           wholeTxt = baseTxt <> space <> w
           wholeLen = T.length wholeTxt
 
-          acc' =
+          acc1 =
             if wholeLen <= width && not (T.null wholeTxt)
               then (wholeTxt, ws, False) : acc
               else acc
 
-          -- hyphenation candidates for this word
-          hyphs = hyphenateWord dict w
+          (hyphs, cache1) =
+            case HM.lookup w cache of
+              Just hs -> (hs, cache)
+              Nothing ->
+                let hs = hyphenateWord dict w
+                in (hs, HM.insert w hs cache)
+
           hyphCands =
             [ (preTxt, suf : ws, True)
             | (pre, suf) <- hyphs
             , not (T.null pre)
             , let preTxt = baseTxt <> space <> pre <> "-"
-            , let preLen = T.length preTxt
-            , preLen <= width
+            , T.length preTxt <= width
             ]
 
-          acc'' = hyphCands ++ acc'
-
+          acc2 = hyphCands ++ acc1
       in if wholeLen <= width
-           then go (line ++ [w]) acc'' ws
-           else acc''
+           then go (line ++ [w]) acc2 cache1 ws
+           else (acc2, cache1)
 
 hyphenateWord :: H.Hyphenator -> Text -> [(Text, Text)]
 hyphenateWord dict word =
@@ -302,6 +357,133 @@ updateRenderedItem width itemIx (Buffer items) (RenderCache cache) rb =
     in (RenderCache newCache, newRB)
 
 --------------------------------------------------------------------------------
+-- Render state
+--------------------------------------------------------------------------------
+
+data RenderState = RenderState
+  { rsBuffer    :: Buffer             -- original items
+  , rsCache     :: RenderCache        -- per-item cached renders
+  , rsRendered  :: RenderedBuffer     -- fully wrapped + hyphenated lines
+  , rsWidth     :: Int                -- wrapping width
+  , rsLineCount :: Int                
+  }
+
+mkRenderState :: Int -> Buffer -> RenderState
+mkRenderState width buf =
+  let (cache1, rendered) = renderBuffer width buf (emptyCacheFor buf)
+  in RenderState
+       { rsBuffer    = buf
+       , rsCache     = cache1
+       , rsRendered  = rendered
+       , rsWidth     = width
+       , rsLineCount = length (flatten rendered)
+       }
+
+-- RenderState has to be rebuilt whenever the buffer or the width changes.
+updateRenderState :: Int -> Buffer -> RenderState -> RenderState
+updateRenderState width buf rs =
+  let (cache1, rendered) = renderBuffer width buf (rsCache rs)
+  in rs
+      { rsBuffer    = buf
+      , rsCache     = cache1
+      , rsRendered  = rendered
+      , rsWidth     = width
+      , rsLineCount = length (flatten rendered)
+      }
+
+modifyItemRS :: Int -> (Item -> Item) -> RenderState -> RenderState
+modifyItemRS ix f st =
+  let buf'    = modifyItem ix f (rsBuffer st)
+      cache'  = resizeCache buf' (rsCache st)
+      (cache1, rendered1) = renderBuffer (rsWidth st) buf' cache'
+  in st { rsBuffer    = buf'
+        , rsCache     = cache1
+        , rsRendered  = rendered1
+        , rsLineCount = length (flatten rendered1)
+        }
+
+insertItem :: Int -> Item -> RenderState -> RenderState
+insertItem i newItem st =
+  let Buffer items = rsBuffer st
+      items'       = Seq.insertAt i newItem items
+      buf'         = Buffer items'
+      cache'       = resizeCache buf' (rsCache st)
+      (cache1, rendered1) = renderBuffer (rsWidth st) buf' cache'
+  in st { rsBuffer = buf'
+        , rsCache = cache1
+        , rsRendered = rendered1
+        , rsLineCount = length (flatten rendered1)
+        }
+
+deleteItem :: Int -> RenderState -> RenderState
+deleteItem i st =
+  let Buffer items = rsBuffer st
+      items'       = Seq.deleteAt i items
+      buf'         = Buffer items'
+      cache'       = resizeCache buf' (rsCache st)
+      (cache1, rendered1) = renderBuffer (rsWidth st) buf' cache'
+  in st { rsBuffer = buf'
+        , rsCache = cache1
+        , rsRendered = rendered1
+        , rsLineCount = length (flatten rendered1)
+        }
+
+replaceItem :: Int -> Item -> RenderState -> RenderState
+replaceItem i newItem st =
+  let Buffer items = rsBuffer st
+      items'       = Seq.update i newItem items
+      buf'         = Buffer items'
+      cache'       = resizeCache buf' (rsCache st)
+      (cache1, rendered1) = renderBuffer (rsWidth st) buf' cache'
+  in st { rsBuffer = buf'
+        , rsCache = cache1
+        , rsRendered = rendered1
+        , rsLineCount = length (flatten rendered1)
+        }
+
+appendItem :: Item -> RenderState -> RenderState
+appendItem newItem st =
+  insertItem (Seq.length (let Buffer xs = rsBuffer st in xs)) newItem st
+
+clearBuffer :: RenderState -> RenderState
+clearBuffer st =
+  let buf' = Buffer Seq.empty
+      cache' = RenderCache Seq.empty
+  in st { rsBuffer = buf'
+        , rsCache = cache'
+        , rsRendered = Seq.empty
+        , rsLineCount = 0
+        }
+
+fromList :: Int -> [Item] -> RenderState
+fromList width xs =
+  let buf     = Buffer (Seq.fromList xs)
+      cache0  = RenderCache (Seq.replicate (length xs) Nothing)
+      (cache1, rendered) = renderBuffer width buf cache0
+  in RenderState
+       { rsBuffer    = buf
+       , rsCache     = cache1
+       , rsRendered  = rendered
+       , rsWidth     = width
+       , rsLineCount = length (flatten rendered)
+       }
+
+fromSeq :: Int -> Seq Item -> RenderState
+fromSeq width items =
+  let buf     = Buffer items
+      cache0  = RenderCache (Seq.replicate (Seq.length items) Nothing)
+      (cache1, rendered) = renderBuffer width buf cache0
+  in RenderState
+       { rsBuffer    = buf
+       , rsCache     = cache1
+       , rsRendered  = rendered
+       , rsWidth     = width
+       , rsLineCount = length (flatten rendered)
+       }
+
+
+
+--------------------------------------------------------------------------------
 -- Viewport
 --------------------------------------------------------------------------------
 
@@ -311,27 +493,54 @@ data Viewport = Viewport
   , vpOffset :: !Int
   } deriving (Show)
 
-defaultViewport :: Int -> Int -> RenderedBuffer -> Viewport
-defaultViewport w h rb =
-    let total = length (flatten rb)
-        off   = max 0 (total - h)
-    in Viewport w h off
+mkViewport :: Int -> Int -> Viewport
+mkViewport width height =
+  Viewport
+    { vpWidth  = width
+    , vpHeight = height
+    , vpOffset = 0
+    }
 
-scrollUp :: Int -> Viewport -> Viewport
-scrollUp k vp =
-    vp { vpOffset = max 0 (vpOffset vp - k) }
+defaultViewport :: Int -> Int -> RenderState -> Viewport
+defaultViewport width height rs =
+    alignBottom rs (mkViewport width height)
 
-scrollDown :: Int -> Int -> Viewport -> Viewport
-scrollDown totalLines n vp =
-    let newTop = min (totalLines - vpHeight vp) (vpOffset vp + n)
-    in vp { vpOffset = max 0 newTop }
+-- any function that sets vpOffset and can overshoot should use clampViewport
+clampViewport :: RenderState -> Viewport -> Viewport
+clampViewport rs vp =
+  let total  = rsLineCount rs
+      maxOff = max 0 (total - vpHeight vp)
+      off    = vpOffset vp
+  in vp { vpOffset = max 0 (min maxOff off) }
+
+scrollBy :: Int -> RenderState -> Viewport -> Viewport
+scrollBy delta rs vp =
+  clampViewport rs vp { vpOffset = vpOffset vp + delta }
+
+scrollUp :: Int -> RenderState -> Viewport -> Viewport
+scrollUp n = scrollBy (-n)
+
+scrollDown :: Int -> RenderState -> Viewport -> Viewport
+scrollDown n = scrollBy n
+
+pageUp :: RenderState -> Viewport -> Viewport
+pageUp rs vp =
+  scrollBy (-(vpHeight vp)) rs vp
+
+pageDown :: RenderState -> Viewport -> Viewport
+pageDown rs vp =
+  scrollBy (vpHeight vp) rs vp
+
+alignTop :: Viewport -> Viewport
+alignTop vp =
+  vp { vpOffset = 0 }
+
+alignBottom :: RenderState -> Viewport -> Viewport
+alignBottom rs vp =
+  let total = rsLineCount rs
+      off   = max 0 (total - vpHeight vp)
+  in vp { vpOffset = off }
 
-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
@@ -351,3 +560,63 @@ lookupPosition x y vp rb =
          let charIx = rlCharStart rl + x
          in Just (rlItemIx rl, charIx)
        [] -> Nothing
+
+--------------------------------------------------------------------------------
+-- Viewport Instance ("simple" façade)
+--------------------------------------------------------------------------------
+
+data ViewportInstance = ViewportInstance
+  { viRender :: RenderState
+  , viView   :: Viewport
+  }
+
+mkViewportInstance :: Int -> Int -> Buffer -> ViewportInstance
+mkViewportInstance width height buf =
+  let rs = mkRenderState width buf
+      vp = clampViewport rs (mkViewport width height)
+  in ViewportInstance rs vp
+
+
+visibleLines :: ViewportInstance -> [RenderedLine]
+visibleLines (ViewportInstance rs vp) =
+  take (vpHeight vp) . drop (vpOffset vp) . flatten $ rsRendered rs
+
+applyToInstance :: (Viewport -> Viewport) -> ViewportInstance -> ViewportInstance
+applyToInstance f (ViewportInstance rs vp) =
+    ViewportInstance rs (f vp)
+
+applyToInstanceRS :: (RenderState -> Viewport -> Viewport) -> ViewportInstance -> ViewportInstance
+applyToInstanceRS f (ViewportInstance rs vp) =
+    ViewportInstance rs (f rs vp)
+
+scrollByI :: Int -> ViewportInstance -> ViewportInstance
+scrollByI delta = applyToInstanceRS (scrollBy delta)
+
+scrollUpI :: Int -> ViewportInstance -> ViewportInstance
+scrollUpI delta = applyToInstanceRS (scrollUp delta)
+
+scrollDownI :: Int -> ViewportInstance -> ViewportInstance
+scrollDownI delta = applyToInstanceRS (scrollDown delta)
+
+pageUpI :: ViewportInstance -> ViewportInstance
+pageUpI = applyToInstanceRS pageUp
+
+pageDownI :: ViewportInstance -> ViewportInstance
+pageDownI = applyToInstanceRS pageDown
+
+alignTopI :: ViewportInstance -> ViewportInstance
+alignTopI = applyToInstance alignTop
+
+alignBottomI :: ViewportInstance -> ViewportInstance
+alignBottomI = applyToInstanceRS alignBottom
+
+modifyItemI :: Int -> (Item -> Item) -> ViewportInstance -> ViewportInstance
+modifyItemI ix f (ViewportInstance rs vp) =
+  let buf' = modifyItem ix f (rsBuffer rs)
+      rs'  = mkRenderState (rsWidth rs) buf'
+      vp'  = clampViewport rs' vp
+  in ViewportInstance rs' vp'
+
+lookupPositionI :: Int -> Int -> ViewportInstance -> Maybe (Int, Int)
+lookupPositionI x y (ViewportInstance rs vp) =
+    lookupPosition x y vp (rsRendered rs)