+{-# LANGUAGE DeriveFunctor #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Symantic.Plaintext.Writer2 where
+
+import Control.Applicative (Alternative (..), Applicative (..))
+import Data.Bool
+import Data.Char (Char)
+import Data.Eq (Eq (..))
+import Data.Function (($), (.))
+import Data.Functor (Functor (..), (<$>))
+import Data.List qualified as List
+import Data.Maybe (Maybe (..), fromMaybe)
+import Data.Monoid (Monoid (..))
+import Data.Ord (Ord (..))
+import Data.Semigroup (Semigroup (..))
+import Data.String (IsString (..), String)
+import Data.Traversable (Traversable (traverse))
+import GHC.Natural (
+ minusNatural,
+ minusNaturalMaybe,
+ quotRemNatural,
+ )
+import Numeric.Natural (Natural)
+import Text.Show (
+ Show (..),
+ showParen,
+ showString,
+ )
+import Prelude (
+ Num (..),
+ error,
+ fromIntegral,
+ undefined,
+ )
+
+--import qualified Data.Text.Lazy.Builder as TLB
+--import qualified Data.Text.Lazy.Builder as TLB
+
+import Control.Monad (Monad ((>>=)))
+import Data.Functor.Identity (Identity (..))
+import Data.Text.Internal.Fusion.Types (RS (RS3))
+import Data.Tuple (fst, snd, swap)
+import Debug.Trace (trace, traceShow)
+import GHC.IO.Exception (IOErrorType (SystemError))
+import GHC.List (sum)
+import GHC.Real (Integral (div))
+import Symantic.Plaintext.Classes ()
+import Symantic.Plaintext.Output
+
+data Measured o = Measured
+ { measuredHorizontal :: Natural
+ , measuredVertical :: Natural
+ , unMeasured :: o
+ }
+instance Dimensionable (Measured o) where
+ width = measuredHorizontal
+ height = measuredVertical
+
+-- renderRect :: Outputable o => Measured (Rect o) -> [o]
+-- renderRect Measured{..} = case unMeasured of
+-- RectEmpty -> []
+-- RectChunk o -> [o]
+-- Rects{..} -> case rectDirection of
+-- DirectionHorizontal -> []
+
+resize :: Measured [o] -> [o]
+resize Measured{..} = undefined
+
+-- | Doc: https://personal.cis.strath.ac.uk/conor.mcbride/so-pigworker.pdf#section.4.9
+data PaddedList a = (:-)
+ { padded :: [a]
+ , padder :: a
+ }
+ deriving (Show, Eq)
+
+infixr 5 :-
+
+instance Functor PaddedList where
+ fmap = (<*>) . pure
+instance Applicative PaddedList where
+ pure = ([] :-)
+ as :- ap <*> bs :- bp = go as bs :- ap bp
+ where
+ go [] xs = ap <$> xs
+ go fs [] = ($ bp) <$> fs
+ go (f : fs) (x : xs) = f x : go fs xs
+
+-- >>> "om":-' ' <*> "mane":-' '
+
+-- >>> "om":-' ' <*> "mane":-' '
+-- Couldn't match type ‘Char’ with ‘Char -> b’
+-- Expected type: PaddedList (Char -> b)
+-- Actual type: PaddedList Char
+
+-- >>> deggar ' ' ["om", "mane", "padme", "hum12345"]
+-- (:-) {padded = ["omph","maau"," ndm"," em1"," e2"," 3"," 4"," 5"], padder = " "}
+deggar pad = traverse (:- pad)
+
+lines0 = ["om", "mane", "padme", "hum12345"]
+columns0 = [["om"], ["mane", "padme"], ["hum", "12345"]]
+measureList :: Lengthable a => [a] -> (Natural, [(Natural, a)])
+measureList =
+ List.mapAccumL (\acc s -> let len = length s in (max len acc, (len, s))) 0
+measureVert :: Lengthable a => [a] -> (Natural, [(Natural, a)])
+measureVert ss = (fromIntegral $ List.length ss, (1,) <$> ss)
+
+-- >>> padList (\n -> List.replicate (fromIntegral n) ' ') (measureList lines0)
+-- ["om ","mane ","padme ","hum12345"]
+-- >>> (measureVert lines0)
+-- (4,[(1,"om"),(1,"mane"),(1,"padme"),(1,"hum12345")])
+padList :: Semigroup o => (Natural -> o) -> (Natural, [(Natural, o)]) -> [o]
+padList pad (inpLen, inp) =
+ fmap
+ ( \(itemLen, item) -> case inpLen `minusNaturalMaybe` itemLen of
+ Nothing -> item
+ Just padLen -> item <> pad padLen
+ )
+ inp
+
+whites :: Integral a => a -> [Char]
+whites n = List.replicate (fromIntegral n) ' '
+withLength :: Lengthable a => [a] -> (Natural, [a])
+withLength x = (sum $ length <$> x, x)
+
+text0 :: [Chunk (Line [Chunk (Word String)])]
+text0 = convert @String "123 45\n67 89\n 10 11 12"
+
+{- |
+ >>> justi JustifyCenter text0
+ [Item (Line [Spaces 1,Item (Word "123"),Spaces 1,Item (Word "45"),Spaces 1]),Item (Line [Spaces 1,Item (Word "67"),Spaces 1,Item (Word "89"),Spaces 2]),Item (Line [Spaces 0,Item (Word "10"),Spaces 1,Item (Word "11"),Spaces 1,Item (Word "12"),Spaces 0])]
+-}
+
+-- >>> justi JustifyStart text0
+-- [Item (Line [Item (Word "123"),Spaces 1,Item (Word "45"),Spaces 2]),Item (Line [Item (Word "67"),Spaces 1,Item (Word "89"),Spaces 3]),Item (Line [Item (Word "10"),Spaces 1,Item (Word "11"),Spaces 1,Item (Word "12"),Spaces 0])]
+
+-- >>> justi JustifyEnd text0
+-- [Item (Line [Spaces 2,Item (Word "123"),Spaces 1,Item (Word "45")]),Item (Line [Spaces 3,Item (Word "67"),Spaces 1,Item (Word "89")]),Item (Line [Spaces 0,Item (Word "10"),Spaces 1,Item (Word "11"),Spaces 1,Item (Word "12")])]
+
+-- >>> justi JustifySpaceBetween text0
+-- [Item (Line [Item (Word "123"),Spaces 2,Item (Word "45")]),Item (Line [Item (Word "67"),Spaces 2,Item (Word "89")]),Item (Line [Item (Word "10"),Spaces 1,Item (Word "11"),Spaces 1,Item (Word "12")])]
+{-
+justi ::
+ Semigroup o =>
+ Lengthable o =>
+ Justify ->
+ [Chunk [Chunk o]] ->
+ [Chunk [Chunk o]]
+justi jus ls =
+ (<$> ls) $
+ \lineChunk ->
+ (<$> lineChunk) $ \li -> (<$> li) $ \l ->
+ justifyChunks jus minWitdh (length l, l)
+ where
+ --(maxCols, maxWidths, rows) = List.foldr go (0, List.repeat 0, []) ls
+ minWitdh :: Natural
+ minWitdh =
+ List.foldl'
+ ( \acc -> \case
+ ChunkInvisible{} -> acc
+ ChunkItem o -> length o
+ ChunkSpaces{} -> acc
+ )
+ 0
+ ls
+-}
+-- formatChunks ::
+-- forall o.
+-- Semigroup o =>
+-- Justify ->
+-- Justify ->
+-- {-vertLimit-} Natural ->
+-- {-horizLimit-} Natural ->
+-- [Chunk [Measured (Chunk o)]] ->
+-- {-lines-} Measured [Chunk {-words-} (Measured [Chunk o])]
+-- formatChunks vertJus horizJus vertLimit horizLimit vertChunks =
+-- justifyChunks
+-- DirectionHorizontal
+-- vertJus
+-- vertLimit
+-- $ fmap (\(v,cs) -> Measured 0 v cs)
+-- $ List.mapAccumL
+-- ( \vertDim vertChunk ->
+-- case vertChunk of
+-- ChunkInvisible o -> (vertDim, ChunkInvisible o)
+-- ChunkSpaces s -> (vertDim + s, ChunkSpaces s)
+-- ChunkItem vertItem ->
+-- ( vertDim + horizHeight
+-- , ChunkItem $
+-- --Measured horizLimit horizHeight
+-- justifyChunks
+-- DirectionVertical
+-- horizJus
+-- horizLimit
+-- vertItem
+-- )
+-- where
+-- horizHeight = maxOn' measuredHeight vertItem
+-- )
+-- 0
+-- vertChunks
+
+{- | A strict version of 'sum', using a custom valuation function.
+
+ > sumOn' read ["1", "2", "3"] == 6
+-}
+sumOn' :: Num b => (a -> b) -> [a] -> b
+sumOn' f = List.foldl' (\acc x -> acc + f x) 0
+
+maxOn' :: (a -> Natural) -> [a] -> Natural
+maxOn' f = List.foldl' (\acc x -> acc `max` f x) 0
+
+{- | A version of 'maximum' where the comparison is done on some extracted value.
+ Raises an error if the list is empty. Only calls the function once per element.
+
+ > maximumOn id [] == undefined
+ > maximumOn length ["test","extra","a"] == "extra"
+-}
+maximumOn :: Ord b => (a -> b) -> [a] -> a
+maximumOn f [] = error "Data.List.Extra.maximumOn: empty list"
+maximumOn f (x : xs) = g x (f x) xs
+ where
+ g v mv [] = v
+ g v mv (x : xs)
+ | mx > mv = g x mx xs
+ | otherwise = g v mv xs
+ where
+ mx = f x
+
+{-
+>>> text0
+[Item (Line [Item (Word "123"),Spaces 1,Item (Word "45")]),Item (Line [Item (Word "67")]),Item (Line [Item (Word "89"),Spaces 1,Item (Word "10")])]
+
+>>> length text0
+3
+
+>>> justifyChunks JustifyCenter 30 (length text0, text0)
+[Spaces 13,Item (Line [Item (Word "123"),Spaces 1,Item (Word "45")]),Item (Line [Item (Word "67")]),Item (Line [Item (Word "89"),Spaces 1,Item (Word "10")]),Spaces 14]
+
+>>> justifyChunks JustifySpaceBetween 30 (length text0, text0)
+[Item (Line [Item (Word "123"),Spaces 1,Item (Word "45")]),Item (Line [Item (Word "67")]),Item (Line [Item (Word "89"),Spaces 1,Item (Word "10")])]
+-}
+justifyChunks ::
+ Semigroup o =>
+ Direction ->
+ Justify ->
+ Natural ->
+ [Measured (Chunk o)] ->
+ Measured [Chunk o]
+justifyChunks dir jus limitDim measuredChunks =
+ let chunksDim = List.sum (mea <$> measuredChunks)
+ chunks = unMeasured <$> measuredChunks
+ mea = case dir of
+ DirectionHorizontal -> measuredVertical
+ DirectionVertical -> measuredHorizontal
+ in Measured
+ { measuredHorizontal = 0
+ , measuredVertical = 0
+ , unMeasured = case limitDim `minusNaturalMaybe` chunksDim of
+ Nothing -> chunks
+ Just padLen ->
+ case jus of
+ JustifyStart -> chunks <> [ChunkSpaces padLen]
+ JustifyEnd -> [ChunkSpaces padLen] <> chunks
+ JustifyCenter -> [ChunkSpaces halfPadLen] <> chunks <> [ChunkSpaces (padLen - halfPadLen)]
+ where
+ -- NOTE: may be 0
+ halfPadLen = padLen `div` 2
+ JustifySpaceBetween ->
+ if itemsCount > 0
+ then spaceBetweenItems chunks padLens
+ else chunks <> [ChunkSpaces padLen]
+ where
+ itemsCount = countItems chunks
+ padLens = justifyPadding padLen itemsCount
+ spaceBetweenItems :: [Chunk o] -> [Natural] -> [Chunk o]
+ spaceBetweenItems (x : xs) pads@(p : ps) =
+ case x of
+ ChunkSpaces _w -> ChunkSpaces (p + 1) : spaceBetweenItems xs ps
+ _ -> x : spaceBetweenItems xs pads
+ spaceBetweenItems (w : ws) [] = w : spaceBetweenItems ws []
+ spaceBetweenItems [] _os = mempty
+ }
+
+instance IsString (Rect String) where
+ fromString s =
+ Rects
+ { rectDirection = DirectionHorizontal
+ , rectJustify = JustifyStart
+ , rectWrap = False
+ , rectAxis = rectOfWords . wordsNoEmpty <$> lines s
+ }
+ where
+ rectOfWords :: [Word String] -> Rect String
+ rectOfWords ws =
+ Rects
+ { rectDirection = DirectionHorizontal
+ , rectJustify = JustifyStart
+ , rectWrap = False
+ , rectAxis = (\(Word x) -> Rect (fromIntegral (List.length x), [x])) <$> ws
+ }
+
+rect0 :: Rect String
+rect0 =
+ Rects
+ { rectDirection = DirectionHorizontal
+ , rectJustify = JustifyStart
+ , rectWrap = False
+ , rectAxis = ["abc"]
+ }
+rect1 :: Rect String
+rect1 =
+ Rects
+ { rectDirection = DirectionHorizontal
+ , rectJustify = JustifyStart
+ , rectWrap = True
+ , rectAxis = ["abc", "abcd", "abc"]
+ }
+rect2 :: Rect [Char]
+rect2 =
+ Rects
+ { rectDirection = DirectionVertical
+ , rectJustify = JustifyStart
+ , rectWrap = False
+ , rectAxis =
+ [ Rects
+ { rectDirection = DirectionHorizontal
+ , rectJustify = JustifyStart
+ , rectWrap = True
+ , rectAxis = ["123", "4567", "890"]
+ }
+ , Rects
+ { rectDirection = DirectionHorizontal
+ , rectJustify = JustifyStart
+ , rectWrap = True
+ , rectAxis = ["abc", "defg", "hij"]
+ }
+ ]
+ }
+
+{- | @(measureRect limitH limitV rect)@ return the given @(rect)@
+with minimal 'rectMeasure's, trying to fit the given limits when 'rectWrap' is 'True'.
+
+>>> measureRect Nothing Nothing rectH3V1
+Rect {rectContent = "abc"}
+
+>>> measureRect Nothing Nothing rect1
+Rects {rectMeasure = (10,1), rectDirection = DirectionHorizontal, rectJustify = JustifyStart, rectWrap = False, rectAxis = [Rect {rectContent = "abc"},Rect {rectContent = "abcd"},Rect {rectContent = "abc"}]}
+
+>>> measureRect (Just 4) Nothing rect1{rectWrap=True}
+Rects {rectMeasure = (4,3), rectDirection = DirectionHorizontal, rectJustify = JustifyStart, rectWrap = True, rectAxis = [Rect {rectContent = "abc"},Rect {rectContent = "abcd"},Rect {rectContent = "abc"}]}
+
+>>> measureRect (Just 2) Nothing rect1{rectWrap=True, rectDirection = DirectionVertical}
+Rects {rectMeasure = (7,2), rectDirection = DirectionVertical, rectJustify = JustifyStart, rectWrap = True, rectAxis = [Rect {rectContent = "abc"},Rect {rectContent = "abcd"},Rect {rectContent = "abc"}]}
+-}
+
+{- |
+
+>>> renderRect Nothing Nothing rect0
+((3,1),[["abc"]])
+
+>>> renderRect Nothing Nothing rect1
+((10,1),[["abc","abcd","abc"]])
+
+>>> renderRect Nothing Nothing rect2
+((10,2),[["123","4567","890","abc","defg","hij"]])
+
+>>> renderRect (Just 4) Nothing rect2
+((4,6),[["123"," ","abc"," "],["4567","defg"],["890"," ","hij"," "]])
+-}
+renderRect ::
+ forall o.
+ Semigroup o =>
+ Show o =>
+ Dimensionable o =>
+ Padable o =>
+ Maybe Natural ->
+ Maybe Natural ->
+ Rect o ->
+ ((Natural, Natural), [[o]])
+renderRect limitH limitV is =
+ traceShow ("renderRect" :: String, limitH, limitV, is, "res" :: String, res) res
+ where
+ res =
+ case is of
+ Rect (n, ws) -> ((n, 1), [ws])
+ Rects{..} ->
+ let (_finalH, _finalV, maximalH, maximalV, renderedRects) =
+ List.foldl'
+ ( \(currH, currV, maxH, maxV, rectHV) rect ->
+ let (dim, rectRendered) =
+ renderRect
+ (limitH `minusOrZero` currH)
+ (limitV `minusOrZero` currV)
+ rect
+ newDim@(rectH, rectV) =
+ case rectDirection of
+ DirectionHorizontal -> dim
+ DirectionVertical -> swap dim
+ newH = currH + (if currH == 0 || rectDirection == DirectionVertical then 0 else 1) + rectH
+ in case limitH of
+ Just limH
+ -- Limit overflow, and wrapping
+ | limH < newH && rectWrap ->
+ traceShow ("overflow" :: String, limH, newH) $
+ (rectH, maxV, maxH `max` rectH, maxV + rectV, newRectHV)
+ where
+ -- Word goes into a new line
+ newRectHV = [(newDim, rectRendered)] : rectHV
+ -- No limit, or no overflow, or no wrapping
+ _ -> (newH, currV, maxH + rectH, maxV `max` rectV, newRectHV)
+ where
+ -- Word goes into the same line
+ newRectHV = case rectHV of
+ [] -> [[(newDim, rectRendered)]]
+ r : rs -> ((newDim, rectRendered) : r) : rs
+ )
+ (0, 0, 0, 0, [])
+ rectAxis
+ in ( case rectDirection of
+ DirectionHorizontal -> (maximalH, maximalV)
+ DirectionVertical -> (maximalV, maximalH)
+ , concatHV maximalH maximalV (List.reverse $ List.reverse <$> renderedRects)
+ -- (traceShow ("renderedRects" :: String, renderedRects) $ List.reverse renderedRects)
+ )
+ -- concatRender :: [[o]] -> [[o]] -> [[o]]
+ -- concatRender = List.zipWith (<>)
+ -- Should probably change a wrapped H rect into a V rect containing H rects
+ -- Now reads rectAxis from the left to right, top to bottom
+ -- and make each line reach at least maximalH
+ -- case rectJustify of
+ -- JustifyStart ->
+ -- ((\line -> line <> replicate (maximalH - List.length line) ' ') <$> lines)
+ -- <> replicate (maximalV - List.length lines) (replicate maximalH ' ')
+
+ minusOrZero :: Maybe Natural -> Natural -> Maybe Natural
+ minusOrZero Nothing _m = Nothing
+ minusOrZero (Just n) m = minusNaturalMaybe n m <|> Just 0
+
+{-
+@
+
+>>> concatH 10 2 [((3,1), [["123"]])]
+[["123"," "],[" "," "]]
+
+>>> concatH 10 2 [((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]
+[["123","4567"," "],["ab "," "," "]]
+
+>>> concatH 4 3 [((4,3),[["abc"," "],["defg"],["hij"," "]])]
+[["abc"," "],["defg"],["hij"," "]]
+
+>>> concatH 8 3 [((4,3),[["123"," "],["4567"],["890"," "]]), ((4,3),[["abc"," "],["defg"],["hij"," "]])]
+[["123"," ","abc"," "],["4567","defg"],["890"," ","hij"," "]]
+
+@
+-}
+concatH :: Padable o => Show o => Natural -> Natural -> [((Natural, Natural), [[o]])] -> [[o]]
+concatH maxH maxV rs =
+ traceShow
+ ("concatH" :: String, maxH, maxV, rs, "res" :: String, res)
+ res
+ where
+ (res, rsH) =
+ List.foldr
+ ( \((rH, rV), r) (acc, accH) ->
+ let rPlusVPad = case maxV `minusNaturalMaybe` rV of
+ Nothing -> error "concatH: given maxV is lower than the actual maximal V length"
+ Just dV -> r <> List.replicate (fromIntegral dV) [padding rH]
+ in (List.zipWith (<>) rPlusVPad acc, accH + rH)
+ )
+ (List.replicate (fromIntegral maxV) [padding dH | dH /= 0], 0)
+ rs
+ dH =
+ fromMaybe (error "concatH: given maxH is lower than the actual maximal H length ") $
+ maxH `minusNaturalMaybe` rsH
+
+{-
+concatH maxH maxV [] = List.replicate (fromIntegral maxV) [padding maxH | maxH /= 0]
+concatH maxH maxV (((rH, rV), r) : rs) = case maxH `minusNaturalMaybe` rH of
+ Nothing -> error "concatH: given maxH is lower than the actual maximal H length "
+ Just dH -> List.zipWith (<>) rPlusVPad (concatH dH maxV rs)
+ where
+ rPlusVPad = case maxV `minusNaturalMaybe` rV of
+ Nothing -> error "concatH: given maxV is lower than the actual maximal V length"
+ Just dV -> r <> List.replicate (fromIntegral dV) [padding rH]
+-}
+{-
+@
+
+>>> concatV 10 2 [((3,1), [["123"]])]
+[["123"," "],[" "]]
+
+>>> concatV 4 3 [((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]
+[["123"," "],["ab "," "],["4567"]]
+
+>>> concatV 4 3 [((4,3),[["abc"," "],["defg"],["hij"," "]])]
+[["abc"," "],["defg"],["hij"," "]]
+
+>>> concatV 4 6 [((4,3),[["123"," "],["4567"],["890"," "]]), ((4,3),[["abc"," "],["defg"],["hij"," "]])]
+[["123"," "],["4567"],["890"," "],["abc"," "],["defg"],["hij"," "]]
+
+@
+-}
+concatV :: Padable o => Show o => Natural -> Natural -> [((Natural, Natural), [[o]])] -> [[o]]
+concatV maxH maxV [] = List.replicate (fromIntegral maxV) [padding maxH | maxH /= 0]
+concatV maxH maxV (((rH, rV), r) : rs) = case maxV `minusNaturalMaybe` rV of
+ Nothing -> error "concatV: given maxH is lower than actual maximal H length"
+ Just dV -> rPlusHPad <> concatV maxH dV rs
+ where
+ rPlusHPad = case maxH `minusNaturalMaybe` rH of
+ Nothing -> error "concatV: given maxV is lower than actual maximal V length"
+ Just dH
+ | dH == 0 -> r
+ | otherwise -> List.zipWith (<>) r $ List.replicate (fromIntegral rV) [padding dH]
+
+{- |
+@
+>>> concatHV 10 2 [[((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]]
+[["123","4567"," "],["ab "," "," "]]
+
+>>> concatHV 10 3 [[((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]]
+[["123","4567"," "],["ab "," "," "],[" "]]
+
+>>> concatHV 4 6 [ [((4,3),[["123"," "],["4567"],["890"," "]])], [((4,3),[["abc"," "],["defg"],["hij"," "]])] ]
+[["123"," "],["4567"],["890"," "],["abc"," "],["defg"],["hij"," "]]
+-}
+concatHV :: Padable o => Show o => Natural -> Natural -> [[((Natural, Natural), [[o]])]] -> [[o]]
+concatHV maxH maxV rs = concatV maxH maxV $ f <$> rs
+ where
+ f r = ((maxH, rV), concatH maxH rV r)
+ where
+ rV = List.maximum $ snd . fst <$> r
+
+{-
+@
+>>> concatV 10 2 [[((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]]
+[["123","4567"," "],["ab "," "," "]]
+
+>>> concatV 10 3 [[((3,2), [["123"], ["ab "]]), ((4,1), [["4567"]])]]
+[["123","4567"," "],["ab "," "," "],[" "]]
+
+>>> concatV3 4 6 [ [((4,3),[["123"," "],["4567"],["890"," "]])], [((4,3),[["abc"," "],["defg"],["hij"," "]])] ]
+[["123"," "],["4567"],["890"," "],["abc"," "],["defg"],["hij"," "]]
+concatV :: Padable o => Show o => Natural -> Natural -> [[((Natural, Natural), [[o]])]] -> [[o]]
+concatV maxH maxV rs =
+ traceShow
+ ("concatV" :: String, maxH, maxV, rs, "res" :: String, res)
+ res
+ where
+ (res, rsV) =
+ List.foldr
+ ( \r (acc, accV) ->
+ let rV = List.maximum $ snd . fst <$> r
+ in (concatH maxH rV r <> acc, accV + rV)
+ )
+ (List.replicate (fromIntegral $ maxV - rsV) [padding maxH], 0)
+ rs
+-}
+
+{-
+concatV maxH maxV []
+ | maxV == 0 = []
+ | otherwise = List.replicate (fromIntegral maxV) [padding maxH]
+concatV maxH maxV (r : rs) =
+ List.zipWith (<>) (concatH maxH rV r) (concatV maxH (maxV - rV) rs)
+ where
+ rV = List.maximum $ snd . fst <$> r
+-}
+-- where
+-- paddedR = case maxH `minusNaturalMaybe` rH of
+-- Nothing -> r
+-- Just p -> r <> List.replicate (fromIntegral p) [padding rH]
+
+{- | @('zipWithLongest xPadLen yPadLen xs ys')@ zips together the lists @(xs)@ and @(ys)@
+ padding the @(xs)@ (resp. @(ys)@) elements with a 'padding' of @(xPadLen)@ (resp. @(yPadLen)@)
+ when it is shorter than the corresponding one in @(ys)@ (resp. @(xs)@).
+
+>>> zipWithLongest []
+-}
+zipWithLongest :: Padable o => Natural -> Natural -> [[o]] -> [[o]] -> [[o]]
+zipWithLongest _ _ [] [] = []
+zipWithLongest xP yP (x0 : xs) (y0 : ys) = x0 <> y0 : zipWithLongest xP yP xs ys
+zipWithLongest _xP yP [] ys
+ | yP <= 0 = ys
+ | otherwise = List.map (padding yP :) ys
+zipWithLongest xP _yP xs []
+ | xP <= 0 = xs
+ | otherwise = List.map (<> [padding xP]) xs
+
+class Padable o where
+ padding :: Natural -> o
+instance Padable String where
+ padding n = List.replicate (fromIntegral n) ' '
+
+{-
+>>> renderRect $ measureRect (Just 2) Nothing rect1{rectWrap=True, rectDirection = DirectionVertical}
+["abc","abcd","abc"]
+renderRect :: Dimensionable o => Rect (Natural, Natural) o -> [o]
+renderRect = \case
+ Rect{..} -> [rectContent]
+ Rects{rectMeasure = (measureH, measureV), ..} ->
+ List.concat $ renderRect <$> rectAxis
+-}
+
+-- fitRect :: Rect o -> Measured (Rect o)
+-- fitRect r = case r of
+-- Rect m -> m{unMeasured r}
+-- Rects{..} ->
+-- let rectsCount = fromIntegral $ max 0 $ List.length rectAxis - 1 in
+-- case rectDirection of
+-- DirectionHorizontal ->
+-- Rects
+-- {
+-- rectAxis =
+-- List.mapAccumL
+-- (\r acc ->
+-- let m = fitRect r in
+-- case measuredHeight acc `compare` measuredHeight m of
+-- LT -> undefined -- acc must be justified upto m
+-- EQ -> acc{measureWidth = measuredWidth acc + measuredWidth m}
+-- GT -> undefined -- m must be justified upto acc
+-- ) rectAxis
+-- }
+-- renderRect :: Maybe Natural -> Maybe Natural -> Rect o -> [[o]]
+-- renderRect horizLimit vertLimit = \case
+-- Rect (Measured w h c) -> [[c]]
+-- Rects{..} ->
+-- renderRect rectAxis
+
+-- * Type 'Rect'
+data Rect o
+ = Rect
+ { rectContent :: (Natural, [o])
+ }
+ | Rects
+ { rectDirection :: Direction
+ , rectJustify :: Justify
+ , rectWrap :: Bool
+ , rectAxis :: [Rect o]
+ }
+ deriving (Show)
+
+{-
+instance Dimensionable o => Dimensionable (Rect (Natural, Natural) o) where
+ width = \case
+ Rect{..} -> width rectContent
+ Rects{rectMeasure = (h, _)} -> h
+ height = \case
+ Rect{..} -> height rectContent
+ Rects{rectMeasure = (_, v)} -> v
+-}
+instance Dimensionable String where
+ width s = fromIntegral $ List.maximum $ List.length <$> splitOnChar (== '\n') s
+ height s = fromIntegral $ List.length $ splitOnChar (== '\n') s
+
+data Adjustment o
+ = AdjustmentVariable Natural
+ | AdjustmentFixed o
+
+-- ** Type 'Chunk'
+data Chunk o
+ = ChunkItem !o
+ | -- | Whites preserved to be interleaved
+ -- correctly with 'ChunkInvisible'.
+ ChunkSpaces !Natural
+ | -- | Ignored by the justification but kept in place.
+ -- Used to put ANSI sequences.
+ ChunkInvisible !o
+ deriving (Functor)
+
+runChunk :: Outputable o => Chunk o -> o
+runChunk = \case
+ ChunkInvisible o -> o
+ ChunkItem o -> o
+ ChunkSpaces s -> repeatedChar s ' '
+
+instance Show o => Show (Chunk o) where
+ showsPrec p x =
+ showParen (p > 10) $
+ case x of
+ ChunkInvisible o -> showString "Ignored" . showsPrec 11 o
+ ChunkItem o -> showString "Item " . showsPrec 11 o
+ ChunkSpaces w -> showString "Spaces " . showsPrec 11 w
+
+-- instance Lengthable o => Lengthable (Chunk (Line o)) where
+-- length = \case
+-- ChunkInvisible{} -> 0
+-- ChunkItem o
+-- | isEmpty o -> 0
+-- | otherwise -> 1
+-- ChunkSpaces w -> w
+-- isEmpty = \case
+-- ChunkInvisible{} -> True
+-- ChunkItem o -> isEmpty o
+-- ChunkSpaces w -> w == 0
+-- instance Lengthable o => Lengthable (Chunk (Word o)) where
+-- length = \case
+-- ChunkInvisible{} -> 0
+-- ChunkItem o -> length o
+-- ChunkSpaces w -> w
+-- isEmpty = \case
+-- ChunkInvisible{} -> True
+-- ChunkItem o -> isEmpty o
+-- ChunkSpaces w -> w == 0
+-- instance Lengthable (Chunk o) => Lengthable [Chunk o] where
+-- length = List.foldl' (\acc out -> acc + length out) 0
+-- isEmpty = List.all isEmpty
+
+{- | @('wordsCount' ps)@ returns the number of words in @(ps)@
+ clearly separated by spaces.
+-}
+countItems :: [Chunk o] -> Natural
+countItems = go False 0
+ where
+ go isAdjacentItem acc = \case
+ [] -> acc
+ ChunkInvisible{} : xs -> go isAdjacentItem acc xs
+ ChunkSpaces w : xs
+ | w == 0 -> go isAdjacentItem acc xs
+ | otherwise -> go False acc xs
+ ChunkItem{} : xs ->
+ if isAdjacentItem
+ then go isAdjacentItem acc xs
+ else go True (acc + 1) xs
+
+{- | @('justifyPadding' a b)@ returns the padding lengths
+to reach @(a)@ in @(b)@ pads,
+using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
+where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
+
+A simple implementation of 'justifyPadding' could be:
+@
+'justifyPadding' a b =
+ 'join' ('List.replicate' m [q,q'+'1])
+ <> ('List.replicate' (r'-'m) (q'+'1)
+ <> ('List.replicate' ((b'-'r)'-'m) q
+ where
+ (q,r) = a`divMod`b
+ m = 'min' (b-r) r
+@
+
+>>> justifyPadding 30 7
+[4,5,4,5,4,4,4]
+-}
+justifyPadding :: Natural -> Natural -> [Natural]
+justifyPadding a b = go r (b - r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
+ where
+ (q, r) = a `quotRemNatural` b
+ go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r
+ go rr 0 = List.replicate (fromIntegral rr) (q + 1) -- when min (b-r) r == r
+ go rr bmr = q : (q + 1) : go (rr `minusNatural` 1) (bmr `minusNatural` 1)
+
+takeExactly :: o -> Natural -> [o] -> [o]
+takeExactly pad len inp =
+ if len <= 0
+ then inp
+ else case inp of
+ [] -> List.replicate (fromIntegral len) pad
+ o : next -> o : takeExactly pad (len - 1) next
+
+-- https://codepen.io/enxaneta/full/adLPwv/
+-- https://github.com/jordwalke/flex/blob/master/src/lib/Layout.re
+data Direction
+ = DirectionHorizontal
+ | DirectionVertical
+ deriving (Eq, Show)
+data Justify
+ = JustifyStart
+ | JustifyEnd
+ | JustifyCenter
+ | JustifyStretch
+ | JustifySpaceBetween
+ | JustifySpaceAround
+ deriving (Show)
+
+{-
+type ItemAlignSelf = Maybe Align
+
+data Container o = Container
+ { containerDirection :: Direction
+ , containerWrap :: Bool
+ , containerAlignItems :: Align
+ , containerJustifyContent :: Align
+ , containerAlignContent :: Align
+ , containerItems :: [Item o]
+ }
+data Item o = Item
+ { itemAlignSelf :: Maybe Align
+ , itemFlexGrow :: Natural
+ , itemFlexShrink :: Natural
+ , itemFlexOrder :: Natural
+ , itemContent :: o
+ }
+
+2. Determine the available main and cross space for the flex items.
+3. Determine the flex base size and hypothetical main size of each item:
+4. Determine the main size of the flex container using the rules of the formatting context in which it participates.
+5. Collect flex items into flex lines
+6. Resolve the flexible lengths of all the flex items to find their used main size.
+7. Determine the hypothetical cross size of each item by performing layout with the used main size and the available space, treating auto as fit-content.
+8. Calculate the cross size of each flex line.
+9. Handle 'align-content: stretch'.
+10. Collapse visibility:collapse items.
+11. Determine the used cross size of each flex item.
+12. Distribute any remaining free space.
+13. Resolve cross-axis auto margins.
+14. Align all flex items along the cross-axis per align-self, if neither of the item’s cross-axis margins are auto.
+15. Determine the flex container’s used cross size
+16. Align all flex lines per align-content.
+
+Resolving Flexible Lengths
+1. Determine the used flex factor.
+2. Size inflexible items.
+3. Calculate initial free space.
+4. Loop:
+ 4.1 Check for flexible items.
+ 4.2 Calculate the remaining free space as for initial free space, above.
+ 4.3 Distribute free space proportional to the flex factors.
+ 4.4 Fix min/max violations.
+ 4.5 Freeze over-flexed items.
+
+-}
+
+-- * Type 'Writer'
+
+-- -- | Church encoded for performance concerns.
+-- -- Kinda like 'ParsecT' in @megaparsec@ but a little bit different
+-- -- due to the use of 'WriterFit' for implementing 'breakingSpace' correctly
+-- -- when in the left hand side of ('<.>').
+-- -- Prepending is done using continuation, like in a difference list.
+-- newtype Writer (o :: Type) a = Writer
+-- { unWriter ::
+-- a ->
+-- {-curr-} WriterInh o ->
+-- {-curr-} WriterState o ->
+-- {-ok-} (({-prepend-} (o -> o {-new-}), WriterState o) -> WriterFit o) ->
+-- WriterFit o
+-- -- NOTE: equivalent to:
+-- -- ReaderT WriterInh (StateT (WriterState o) (Cont (WriterFit o))) (o->o)
+-- }
+--
+-- runWriter :: Monoid o => Writer o a -> a -> o
+-- runWriter x a =
+-- unWriter
+-- x
+-- a
+-- defWriterInh
+-- defWriterState
+-- {-k-} ( \(px, _sx) fits _overflow ->
+-- -- NOTE: if px fits, then appending mempty fits
+-- fits (px mempty)
+-- )
+-- {-fits-} id
+-- {-overflow-} id
+
+-- ** Type 'WriterFit'
+
+{-
+-- | Double continuation to qualify the returned document
+-- as fitting or overflowing the given 'plainInh_width'.
+-- It's like @('Bool',o)@ in a normal style
+-- (a non continuation-passing-style).
+type WriterFit o =
+ {-fits-} (o -> o) ->
+ {-overflow-} (o -> o) ->
+ o
+
+-- ** Type 'WriterInh'
+data WriterInh o = WriterInh
+ { plainInh_width :: !(Maybe Column)
+ , plainInh_justify :: !Bool
+ , plainInh_indent :: !Indent
+ , plainInh_indenting :: !(Writer o ())
+ , plainInh_sgr :: ![SGR]
+ }
+
+defWriterInh :: Monoid o => WriterInh o
+defWriterInh =
+ WriterInh
+ { plainInh_width = Nothing
+ , plainInh_justify = False
+ , plainInh_indent = 0
+ , plainInh_indenting = empty
+ , plainInh_sgr = []
+ }
+
+-- ** Type 'WriterState'
+data WriterState o = WriterState
+ { plainState_buffer :: ![WriterChunk o]
+ , -- | The 'Column' from which the 'plainState_buffer'
+ -- must be written.
+ plainState_bufferStart :: !Column
+ , -- | The 'Width' of the 'plainState_buffer' so far.
+ plainState_bufferWidth :: !Width
+ , -- | The amount of 'Indent' added by 'breakspace'
+ -- that can be reached by breaking the 'space'
+ -- into a 'newlineJustifyingWriter'.
+ plainState_breakIndent :: !Indent
+ }
+ deriving (Show)
+
+defWriterState :: WriterState o
+defWriterState =
+ WriterState
+ { plainState_buffer = mempty
+ , plainState_bufferStart = 0
+ , plainState_bufferWidth = 0
+ , plainState_breakIndent = 0
+ }
+
+-- ** Type 'WriterChunk'
+data WriterChunk o
+ = -- | Ignored by the justification but kept in place.
+ -- Used for instance to put ANSI sequences.
+ WriterChunk_Ignored !o
+ | WriterChunk_Word !(Word o)
+ | -- | 'spaces' preserved to be interleaved
+ -- correctly with 'WriterChunk_Ignored'.
+ WriterChunk_Spaces !Width
+instance Show o => Show (WriterChunk o) where
+ showsPrec p x =
+ showParen (p > 10) $
+ case x of
+ WriterChunk_Ignored o ->
+ showString "Z "
+ . showsPrec 11 o
+ WriterChunk_Word (Word o) ->
+ showString "W "
+ . showsPrec 11 o
+ WriterChunk_Spaces s ->
+ showString "S "
+ . showsPrec 11 s
+instance Lengthable o => Lengthable (WriterChunk o) where
+ length = \case
+ WriterChunk_Ignored{} -> 0
+ WriterChunk_Word o -> length o
+ WriterChunk_Spaces s -> s
+ isEmpty = \case
+ WriterChunk_Ignored{} -> True
+ WriterChunk_Word o -> isEmpty o
+ WriterChunk_Spaces s -> s == 0
+
+--instance From [SGR] o => From [SGR] (WriterChunk o) where
+-- from sgr = WriterChunk_Ignored (from sgr)
+
+instance Emptyable (Writer o) where
+ empty = Writer $ \_a _inh st k -> k (id, st)
+
+-}
+
+-- >>> wordsNoEmpty (Line (" a b c "::String))
+-- [Word {unWord = "a"},Word {unWord = "b"},Word {unWord = "c"}]
+instance Convertible String o => Convertible String [Chunk (Line [Chunk (Word o)])] where
+ convert =
+ ( ChunkItem . Line
+ . List.intersperse (ChunkSpaces 1)
+ . (ChunkItem . convert <$>)
+ . wordsNoEmpty
+ <$>
+ )
+ . lines
sourcephile / git / haskell / symantic-plaintext.git / commitdiff