bump

1 files changed, 143 insertions, 41 deletions

diff --git a/TextViewport.hs b/TextViewport.hs
index 13c9762..ae68668 100644
--- a/TextViewport.hs
+++ b/TextViewport.hs
@@ -3,7 +3,7 @@
 module TextViewport
   ( Item(..)
   , Buffer(..)
-  , WrapMode(..)
+  , WrapStrategy(..)
   , RenderedLine(..)
   , RenderedBuffer
   , renderBuffer
@@ -18,14 +18,26 @@ module TextViewport
   , 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
 
 --------------------------------------------------------------------------------
 -- Logical model
 --------------------------------------------------------------------------------
 
-newtype Item = Item { unItem :: Text }
+data WrapStrategy
+  = NoWrap
+  | FixedWidthWrap
+  | HyphenateWrap H.Hyphenator
+
+data Item = Item
+  { itemText :: Text
+  , itemWrap :: WrapStrategy
+  }
+
 newtype Buffer = Buffer { unBuffer :: [Item] }
 
 modifyItem :: Int -> (Item -> Item) -> Buffer -> Buffer
@@ -36,45 +48,50 @@ modifyItem ix f (Buffer xs) =
 -- Rendering with provenance
 --------------------------------------------------------------------------------
 
-data WrapMode = NoWrap | Wrap
-  deriving (Eq, Show)
-
--- | A physical line with provenance.
 data RenderedLine = RenderedLine
   { rlText      :: !Text
   , rlItemIx    :: !Int
   , rlLineIx    :: !Int
   , rlCharStart :: !Int
-  } deriving (Eq, Show)
+  } deriving (Show)
 
--- | RenderedBuffer keeps per-item blocks so we can update only one item.
 type RenderedBuffer = [[RenderedLine]]
 
 flatten :: RenderedBuffer -> [RenderedLine]
 flatten = concat
 
-renderBuffer :: WrapMode -> Int -> Buffer -> RenderedBuffer
-renderBuffer mode w (Buffer items) =
-    zipWith (renderItem mode w) [0..] items
-
-renderItem :: WrapMode -> Int -> Int -> Item -> [RenderedLine]
-renderItem mode w itemIx (Item t) =
-    concat $ zipWith (renderLogicalLine mode w itemIx) [0..] (T.splitOn "\n" t)
-
-renderLogicalLine :: WrapMode -> Int -> Int -> Int -> Text -> [RenderedLine]
-renderLogicalLine mode w itemIx lineIx txt =
-    case mode of
-      NoWrap ->
-        [ RenderedLine (T.take w txt) itemIx lineIx 0 ]
-      Wrap ->
-        let chunks = chunk w txt
-        in zipWith mkChunk [0, w ..] chunks
+renderBuffer :: Int -> Buffer -> RenderedBuffer
+renderBuffer width (Buffer items) =
+    zipWith (renderItem width) [0..] items
+
+renderItem :: Int -> Int -> Item -> [RenderedLine]
+renderItem width itemIx (Item txt strategy) =
+    zipWith mkLine [0..] (applyStrategy strategy width txt)
   where
-    mkChunk off chunkTxt =
-      RenderedLine chunkTxt itemIx lineIx off
+    mkLine logicalIx (off, chunk) =
+      RenderedLine
+        { rlText      = chunk
+        , rlItemIx    = itemIx
+        , rlLineIx    = logicalIx
+        , rlCharStart = off
+        }
 
-chunk :: Int -> Text -> [Text]
-chunk w t
+--------------------------------------------------------------------------------
+-- 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
@@ -85,18 +102,103 @@ chunk w t
           in c : go r
 
 --------------------------------------------------------------------------------
+-- Hyphenation-aware wrapping
+--------------------------------------------------------------------------------
+
+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
+          baseLen = T.length baseTxt + T.length space
+
+          -- 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)
+        -- cubic badness like TeX, scaled down
+        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
-  :: WrapMode
-  -> Int
-  -> Int
-  -> Buffer
-  -> RenderedBuffer
-  -> RenderedBuffer
-updateRenderedItem mode w itemIx (Buffer items) rb =
-    let newBlock = renderItem mode w itemIx (items !! itemIx)
+updateRenderedItem :: Int -> Int -> Buffer -> RenderedBuffer -> RenderedBuffer
+updateRenderedItem width itemIx (Buffer items) rb =
+    let newBlock = renderItem width itemIx (items !! itemIx)
     in take itemIx rb ++ [newBlock] ++ drop (itemIx+1) rb
 
 --------------------------------------------------------------------------------
@@ -107,7 +209,7 @@ data Viewport = Viewport
   { vpWidth  :: !Int
   , vpHeight :: !Int
   , vpOffset :: !Int
-  } deriving (Eq, Show)
+  } deriving (Show)
 
 defaultViewport :: Int -> Int -> [RenderedLine] -> Viewport
 defaultViewport w h rendered =
@@ -135,11 +237,11 @@ visibleLines rendered vp =
 --------------------------------------------------------------------------------
 
 lookupPosition
-  :: Int              -- ^ x coordinate
-  -> Int              -- ^ y coordinate
+  :: Int
+  -> Int
   -> Viewport
   -> [RenderedLine]
-  -> Maybe (Int, Int) -- ^ (itemIx, charOffsetInLogicalLine)
+  -> Maybe (Int, Int)
 lookupPosition x y vp rendered = do
     let lineIx = vpOffset vp + y
     rl <- renderedAt lineIx rendered