module Math.ExpPairs.PrettyProcess
( prettify,
uglify,
PrettyProcess) where
import Data.List (minimumBy)
import Data.Ord (comparing)
import Data.Function.Memoize (memoize, deriveMemoizable)
import Text.PrettyPrint.Leijen
import Math.ExpPairs.ProcessMatrix
data PrettyProcess
= Simply [Process]
| Repeat PrettyProcess Int
| Sequence PrettyProcess PrettyProcess
deriving (Show)
data PrettyProcessWithWidth = PPWL { ppwlProcess :: PrettyProcess, ppwlWidth :: Int }
deriveMemoizable ''PrettyProcess
instance Pretty PrettyProcess where
pretty = \case
Simply xs -> hsep (map (text . show) xs)
Repeat _ 0 -> empty
Repeat xs 1 -> pretty xs
Repeat (Simply [A]) n -> text (show A) <> char '^' <> int n
Repeat xs n -> parens (pretty xs) <> char '^' <> int n
Sequence a b -> pretty a <+> pretty b
bracketWidth :: Int
bracketWidth = 4
subscriptWidth :: Int
subscriptWidth = 4
processWidth :: Process -> Int
processWidth A = 10
processWidth BA = 20
printedWidth :: PrettyProcess -> Int
printedWidth = \case
Simply xs -> sum (map processWidth xs)
Repeat _ 0 -> 0
Repeat xs 1 -> printedWidth xs
Repeat (Simply [A]) _ -> processWidth A + subscriptWidth
Repeat xs _ -> printedWidth xs + bracketWidth * 2 + subscriptWidth
Sequence a b -> printedWidth a + printedWidth b
annotateWithWidth :: PrettyProcess -> PrettyProcessWithWidth
annotateWithWidth p = PPWL p (printedWidth p)
divisors :: Int -> [Int]
divisors n = ds1 ++ reverse ds2 where
(ds1, ds2) = unzip [ (a, n `div` a) | a <- [1 .. sqrtint n], n `mod` a == 0 ]
sqrtint = round . sqrt . fromIntegral
asRepeat :: [Process] -> ([Process], Int)
asRepeat [] = ([], 0)
asRepeat xs = pair where
l = length xs
candidates = [ (take d xs, l `div` d) | d <- divisors l ]
pair = head $ filter (\(ys, n) -> concat (replicate n ys) == xs) candidates
prettify :: [Process] -> PrettyProcess
prettify = ppwlProcess . prettifyP
prettifyP :: [Process] -> PrettyProcessWithWidth
prettifyP = memoize prettify' where
prettify' :: [Process] -> PrettyProcessWithWidth
prettify' = \case
[] -> annotateWithWidth (Simply [])
[A] -> annotateWithWidth (Simply [A])
[BA] -> annotateWithWidth (Simply [BA])
xs -> minimumBy (comparing ppwlWidth) yss where
xs'' = case asRepeat xs of
(_, 1) -> annotateWithWidth (Simply xs)
(xs', n) -> annotateWithWidth (Repeat (prettify xs') n)
yss = xs'' : map f bcs
bcs = takeWhile (not . null . snd) $ iterate bcf ([head xs], tail xs)
bcf (_, []) = error "prettify': unexpected second argument of bcf"
bcf (zs, y:ys) = (zs++[y], ys)
f (bs, cs) = PPWL (Sequence bsP csP) (bsW + csW) where
PPWL bsP bsW = prettifyP bs
PPWL csP csW = prettifyP cs
uglify :: PrettyProcess -> [Process]
uglify = \case
Simply xs -> xs
Repeat xs n -> concat . replicate n . uglify $ xs
Sequence xs ys -> uglify xs ++ uglify ys