diff options
| -rw-r--r-- | TextViewport.hs | 391 |
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) |