module Text.Layout.Table.Justify
( justifyTextsAsGrid
, justifyWordListsAsGrid
, columnsAsGrid
, fillSameLength
, justifyText
, justify
, dimorphicSummands
, dimorphicSummandsBy
) where
import Control.Arrow
import Data.List
justifyTextsAsGrid :: [(Int, String)] -> [[String]]
justifyTextsAsGrid = justifyWordListsAsGrid . fmap (second words)
justifyWordListsAsGrid :: [(Int, [String])] -> [[String]]
justifyWordListsAsGrid = columnsAsGrid . fmap (uncurry justify)
columnsAsGrid :: [[[a]]] -> [[[a]]]
columnsAsGrid = transpose . fillSameLength []
fillSameLength :: a -> [[a]] -> [[a]]
fillSameLength x l = fmap (fillTo $ maximum $ 0 : fmap length l) l
where
fillTo i l = take i $ l ++ repeat x
justifyText :: Int -> String -> [String]
justifyText w = justify w . words
justify :: Int -> [String] -> [String]
justify width = mapInit pad (\(_, _, line) -> unwords line) . gather 0 0 []
where
pad (len, wCount, line) = unwords $ if len < width
then zipWith (++) line $ dimorphicSpaces (width len) (pred wCount) ++ [""]
else line
gather lineLen wCount line ws = case ws of
[] | null line -> []
| otherwise -> [(lineLen, wCount, reverse line)]
w : ws' ->
let wLen = length w
newLineLen = lineLen + 1 + wLen
reinit = gather wLen 1 [w] ws'
in if | null line -> reinit
| newLineLen <= width -> gather newLineLen (succ wCount) (w : line) ws'
| otherwise -> (lineLen, wCount, reverse line) : reinit
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
dimorphicSpaces :: Int -> Int -> [String]
dimorphicSpaces = dimorphicSummandsBy $ flip replicate ' '
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