path: root/TextViewport.hs

{-# LANGUAGE OverloadedStrings #-}

module TextViewport
  ( Item(..)
  , Buffer(..)
  , WrapStrategy(..)
  , RenderedLine(..)
  , RenderedBuffer
  , renderBuffer
  , flatten
  , modifyItem
  , updateRenderedItem
  , Viewport(..)
  , defaultViewport
  , scrollUp
  , scrollDown
  , visibleLines
  , lookupPosition
  ) where

import Data.List (minimumBy)
import Data.Ord  (comparing)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Text.Hyphenation as H

import qualified Data.Sequence as Seq
import           Data.Sequence (Seq)
import qualified Data.Foldable as F

--------------------------------------------------------------------------------
-- Logical model
--------------------------------------------------------------------------------

data WrapStrategy
  = NoWrap
  | FixedWidthWrap
  | HyphenateWrap H.Hyphenator

data Item = Item
  { itemText :: Text
  , itemWrap :: WrapStrategy
  }

newtype Buffer = Buffer { unBuffer :: Seq Item }

modifyItem :: Int -> (Item -> Item) -> Buffer -> Buffer
modifyItem ix f (Buffer xs) =
    Buffer (Seq.adjust' f ix xs)

--------------------------------------------------------------------------------
-- Rendering with provenance
--------------------------------------------------------------------------------

data RenderedLine = RenderedLine
  { rlText      :: !Text
  , rlItemIx    :: !Int
  , rlLineIx    :: !Int
  , rlCharStart :: !Int
  } deriving (Show)

type RenderedBuffer = Seq [RenderedLine]

flatten :: RenderedBuffer -> [RenderedLine]
flatten = concat . F.toList

renderBuffer :: Int -> Buffer -> RenderedBuffer
renderBuffer width (Buffer items) =
    let itemsList = F.toList items
        blocks    = zipWith (renderItem width) [0..] itemsList
    in Seq.fromList blocks

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
        }

--------------------------------------------------------------------------------
-- Wrapping strategies
--------------------------------------------------------------------------------

applyStrategy :: WrapStrategy -> Int -> Text -> [(Int, Text)]
applyStrategy NoWrap w t =
    [(0, T.take w t)]

applyStrategy FixedWidthWrap w t =
    zip [0,w..] (chunkFixed w t)

applyStrategy (HyphenateWrap dict) w t =
    hyphenateWrapped dict w t

chunkFixed :: Int -> Text -> [Text]
chunkFixed w t
  | T.null t  = [""]
  | otherwise = go t
  where
    go s
      | T.null s  = []
      | otherwise =
          let (c, r) = T.splitAt w s
          in c : go r

--------------------------------------------------------------------------------
-- Hyphenation-aware wrapping (TeX-lite)
--------------------------------------------------------------------------------

hyphenateWrapped :: H.Hyphenator -> Int -> Text -> [(Int, Text)]
hyphenateWrapped dict w txt =
    let chunks  = wrapWithHyphenationTeXLite dict w txt
        offsets = scanOffsets chunks
    in zip offsets chunks

scanOffsets :: [Text] -> [Int]
scanOffsets []     = []
scanOffsets (x:xs) = 0 : go (T.length x) xs
  where
    go _   []     = []
    go acc (y:ys) = acc : go (acc + T.length y) ys

wrapWithHyphenationTeXLite :: H.Hyphenator -> Int -> Text -> [Text]
wrapWithHyphenationTeXLite dict width txt =
    go (T.words txt)
  where
    go [] = []
    go ws =
      case lineCandidates dict width ws of
        [] -> [T.unwords ws]  -- fallback: everything on one line
        cs ->
          let (line, rest, _) =
                minimumBy (comparing (scoreCandidate width)) cs
          in line : go rest

type Candidate = (Text, [Text], Bool)

lineCandidates :: H.Hyphenator -> Int -> [Text] -> [Candidate]
lineCandidates dict width = go [] []
  where
    go :: [Text] -> [Candidate] -> [Text] -> [Candidate]
    go _    acc []         = acc
    go line acc (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' =
            if wholeLen <= width && not (T.null wholeTxt)
              then (wholeTxt, ws, False) : acc
              else acc

          -- hyphenation candidates for this word
          hyphs = hyphenateWord dict w
          hyphCands =
            [ let preTxt = baseTxt <> space <> pre <> "-"
                  preLen = T.length preTxt
              in (preTxt, suf : ws, True)
            | (pre, suf) <- hyphs
            , not (T.null pre)
            , let preTxt = baseTxt <> space <> pre <> "-"
            , let preLen = T.length preTxt
            , preLen <= width
            ]

          acc'' = hyphCands ++ acc'

      in if wholeLen <= width
           then go (line ++ [w]) acc'' ws
           else acc''

hyphenateWord :: H.Hyphenator -> Text -> [(Text, Text)]
hyphenateWord dict word =
    let parts = H.hyphenate dict (T.unpack word)
    in [ ( T.pack (concat (take i parts))
         , T.pack (concat (drop i parts))
         )
       | i <- [1 .. length parts - 1]
       ]

scoreCandidate :: Int -> Candidate -> Int
scoreCandidate width (line, _, endsWithHyphen) =
    let len      = T.length line
        remSpace = max 0 (width - len)
        badness  = remSpace * remSpace * remSpace
        hyphenPenalty =
          if endsWithHyphen then 50 else 0
        shortPenalty =
          if len < width `div` 2 then 200 else 0
    in badness + hyphenPenalty + shortPenalty

--------------------------------------------------------------------------------
-- Incremental re-rendering
--------------------------------------------------------------------------------

updateRenderedItem :: Int -> Int -> Buffer -> RenderedBuffer -> RenderedBuffer
updateRenderedItem width itemIx (Buffer items) rb =
    let item    = Seq.index items itemIx
        newBlock = renderItem width itemIx item
    in Seq.update itemIx newBlock rb

--------------------------------------------------------------------------------
-- Viewport
--------------------------------------------------------------------------------

data Viewport = Viewport
  { vpWidth  :: !Int
  , vpHeight :: !Int
  , vpOffset :: !Int
  } deriving (Show)

defaultViewport :: Int -> Int -> [RenderedLine] -> Viewport
defaultViewport w h rendered =
    let total = length rendered
        off   = max 0 (total - h)
    in Viewport w h off

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 }

visibleLines :: [RenderedLine] -> Viewport -> [RenderedLine]
visibleLines rendered vp =
    take (vpHeight vp) . drop (vpOffset vp) $ rendered

--------------------------------------------------------------------------------
-- Coordinate lookup
--------------------------------------------------------------------------------

lookupPosition
  :: Int
  -> Int
  -> Viewport
  -> [RenderedLine]
  -> 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)