{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
module Text.Layout.Table.Justify
(
justify
, justifyText
, fitWords
, concatPadLine
, dimorphicSummands
, dimorphicSummandsBy
, mixedDimorphicSummandsBy
) where
import Text.Layout.Table.Primitives.Basic
justifyText :: Int -> String -> [String]
justifyText w = justify w . words
justify :: Int -> [String] -> [String]
justify width = mapInit (concatPadLine width) (unwords . lineWords) . fitWords width
data Line
= Line
{ lineLength :: Int
, lineWordCount :: Int
, lineWords :: [String]
} deriving Show
concatPadLine
:: Int
-> Line
-> String
concatPadLine width Line {..} = case lineWords of
[word] -> word
_ -> unwords $ if lineLength < width
then let fillAmount = width - lineLength
gapCount = pred lineWordCount
spaceSeps = mixedDimorphicSpaces fillAmount gapCount ++ [""]
in zipWith (++) lineWords spaceSeps
else lineWords
fitWords
:: Int
-> [String]
-> [Line]
fitWords width =
finishFitState . foldr fitStep (FitState 0 0 [] [])
where
fitStep word s@FitState {..} =
let wLen = length word
newLineLen = fitStateLineLen + 1 + wLen
reinit f = FitState wLen 1 [word] $ f fitStateLines
in if | null fitStateWords -> reinit id
| newLineLen <= width -> FitState newLineLen (succ fitStateWordCount) (word : fitStateWords) fitStateLines
| otherwise -> reinit (finishLine s :)
data FitState
= FitState
{ fitStateLineLen :: Int
, fitStateWordCount :: Int
, fitStateWords :: [String]
, fitStateLines :: [Line]
}
finishLine :: FitState -> Line
finishLine FitState {..} = Line fitStateLineLen fitStateWordCount $ reverse fitStateWords
finishFitState :: FitState -> [Line]
finishFitState s@FitState {..} = finishLines fitStateLines
where
finishLines = case fitStateWordCount of
0 -> id
_ -> (finishLine s :)
mapInit :: (a -> b) -> (a -> b) -> [a] -> [b]
mapInit _ _ [] = []
mapInit f g (x : xs) = go x xs
where
go y [] = [g y]
go y (y' : ys) = f y : go y' ys
mixedDimorphicSpaces :: Int -> Int -> [String]
mixedDimorphicSpaces = mixedDimorphicSummandsBy spaces
dimorphicSummands :: Int -> Int -> [Int]
dimorphicSummands = dimorphicSummandsBy id
dimorphicSummandsBy :: (Int -> a) -> Int -> Int -> [a]
dimorphicSummandsBy _ _ 0 = []
dimorphicSummandsBy f n splits = replicate r largeS ++ replicate (splits - r) smallS
where
(q, r) = n `divMod` splits
largeS = f $ succ q
smallS = f q
mixedDimorphicSummandsBy :: (Int -> a) -> Int -> Int -> [a]
mixedDimorphicSummandsBy f n splits = go r (splits - r)
where
go 0 s = replicate s smallS
go l 0 = replicate l largeS
go l s = largeS : smallS : go (pred l) (pred s)
(q, r) = n `divMod` splits
largeS = f $ succ q
smallS = f q