PrettyProcess.hs

{-|
Module      : Math.ExpPairs.PrettyProcess
Copyright   : (c) Andrew Lelechenko, 2015-2020
License     : GPL-3
Maintainer  : andrew.lelechenko@gmail.com

Transforms sequences of 'Process' into most compact (by the means of typesetting) representation using brackets and powers.
E. g., AAAABABABA -> A^4(BA)^3.
-}
{-# LANGUAGE LambdaCase      #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Math.ExpPairs.PrettyProcess
  ( prettify,
    uglify,
    PrettyProcess) where

import Data.List                (minimumBy, inits, tails)
import Data.Monoid              (mempty)
import Data.Ord                 (comparing)
import Data.Text.Prettyprint.Doc

import qualified Data.Map as M
import qualified Data.Set as S

import Math.ExpPairs.ProcessMatrix

-- | Compact representation of the sequence of 'Process',
-- using brackets and powers.
data PrettyProcess
  = Simply [Process]
  | Repeat PrettyProcess Int
  | Sequence PrettyProcess PrettyProcess
  deriving (Show)

data PrettyProcessWithWidth = PPWL { ppwlProcess :: PrettyProcess, ppwlWidth :: Int }

instance Pretty PrettyProcess where
  pretty = \case
    Simply xs    -> hsep (map (pretty . show) xs)
    Repeat _  0  -> mempty
    Repeat xs 1  -> pretty xs
    Repeat (Simply [A]) n -> pretty (show A) <> pretty "^" <> pretty n
    Repeat xs n  -> parens (pretty xs) <> pretty "^" <> pretty n
    Sequence a b -> pretty a <+> pretty b

-- | Width of the bracket symbol.
bracketWidth :: Int
bracketWidth = 4

-- | Width of the subscript-sized digit (e. g., power).
subscriptWidth :: Int
subscriptWidth = 4

-- | Width of the process symbols.
processWidth :: Process -> Int
processWidth  A = 10
processWidth BA = 20

-- | Compute the width of the 'PrettyProcess'
-- according to 'bracketWidth', 'subscriptWidth' and 'printedWidth''.
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

-- | Convert 'PrettyProcess' to 'PrettyProcessWithWidth'.
annotateWithWidth :: PrettyProcess -> PrettyProcessWithWidth
annotateWithWidth p = PPWL p (printedWidth p)

-- | List divisors.
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

-- | Try to represent list as a replication of list.
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

-- | Find the most compact representation of the sequence of processes.
prettify :: [Process] -> PrettyProcess
prettify = ppwlProcess . prettifyP

-- | Find the most compact representation of the sequence of processes, keeping track of widthess.
prettifyP :: [Process] -> PrettyProcessWithWidth
prettifyP ps = (M.!) cache ps
  where
    keys = S.fromList $ concatMap inits (tails ps)
    cache = M.fromSet alg keys

    alg :: [Process] -> PrettyProcessWithWidth
    alg = \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 (ppwlProcess $ (M.!) cache xs') n)

        yss = xs'' : map f bcs

        bcs = takeWhile (not . null . snd) $ iterate bcf ([head xs], tail xs)

        bcf (_, [])    = error "prettifyP: 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 = (M.!) cache  bs
          PPWL csP csW = (M.!) cache  cs

-- | Unfold back 'PrettyProcess' into the sequence of 'Process'.
uglify :: PrettyProcess -> [Process]
uglify = \case
  Simply xs      -> xs
  Repeat xs n    -> concat . replicate n . uglify $ xs
  Sequence xs ys -> uglify xs ++ uglify ys