mealy-decompose/app/Main.hs

module Main where

import DotParser
import Mealy
import MealyRefine
import Partition

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State.Strict
import Control.Monad (forM_, when, forever)
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe)
-- import Data.Semigroup (Arg(..))
-- import Data.Set qualified as Set
-- import Data.List.Ordered (nubSort)
import Data.List (minimumBy)
import Data.Function (on)
import System.Environment
import Text.Megaparsec

{-
  Hacked together, you can view the result with:

    tred relation.dot | dot -Tpng -G"rankdir=BT" > relation.png

  tred is the graphviz tool to remove transitive edges. And the rankdir
  attribute flips the graph upside down.
-}
main :: IO ()
main = do
  -- Read dot file
  [dotFile] <- getArgs
  print dotFile
  transitions <- mapMaybe (parseMaybe parseTransFull) . lines <$> readFile dotFile

  -- convert to mealy
  let machine = convertToMealy transitions

  -- print some basic info
  putStrLn $ (show . length $ states machine) <> " states, " <> (show . length $ inputs machine) <> " inputs and " <> (show . length $ outputs machine) <> " outputs"
  putStrLn "Small sample:"
  print . take 4 . states $ machine
  print . take 4 . inputs $ machine
  print . take 4 . outputs $ machine

  -- DEBUG OUTPUT
  -- forM_ (states machine) (\s -> do
  --   print s
  --   forM_ (inputs machine) (\i -> do
  --     putStr "  "
  --     let (o, t) = behaviour machine s i
  --     putStrLn $ "--" <> (show i) <> "/" <> (show o) <> "->" <> (show t)
  --     )
  --   )

  let printPartition p = putStrLn $ "number of states = " <> show (numBlocks p)

  -- Minimise input, so we know the actual number of states
  printPartition (refineMealy (mealyMachineToEncoding machine))
  putStrLn ""

  -- Then compute each projection
  -- I did some manual preprocessing, these are the only interesting bits
  let outs = ["10", "10-O9", "2.2", "3.0", "3.1", "3.10", "3.12", "3.13", "3.14", "3.16", "3.17", "3.18", "3.19", "3.2", "3.20", "3.21", "3.3", "3.4", "3.6", "3.7", "3.8", "3.9", "5.0", "5.1", "5.12", "5.13", "5.17", "5.2", "5.21", "5.23", "5.6", "5.7", "5.8", "5.9", "quiescence"]
      -- outs = outputs machine
      projections0 = allProjections machine outs
      projections = zip outs $ fmap refineMealy projections0

  -- Print number of states of each projection
  forM_ projections (\(o, partition) -> do
    putStr $ o <> " -> "
    printPartition partition
    )

  let totalSize = sum (fmap (numBlocks . snd) projections)

  putStrLn $ "total size = " <> show totalSize

  let score p1 p2 p3 = numBlocks p3 - numBlocks p2 - numBlocks p1
      combine (o1, p1) (o2, p2) = let p3 = commonRefinement p1 p2 in ((o1, o2, p3), score p1 p2 p3)
      allCombs projs = [combine op1 op2 | op1 <- projs, op2 <- projs, fst op1 < fst op2]
      minComb projs = minimumBy (compare `on` snd) (allCombs projs)

  _ <- flip execStateT (Map.fromList projections, totalSize) $ forever (do
    (projmap, currentSize) <- get
    liftIO . print . fmap numBlocks . Map.elems $ projmap
    let ((o1, o2, p3), gain) = minComb (Map.assocs projmap)
        o3 = o1 <> "x" <> o2
        newSize = currentSize + gain
        newProjmap = Map.insert o3 p3 . Map.delete o2 . Map.delete o1 $ projmap
    liftIO $ putStrLn (show o3 <> " -> " <> show newSize)
    put (newProjmap, newSize)
    )

  print "done"


  {-

  -- Check refinement relations for all pairs
  -- This is a bit messy, it skips machines which are equivalent
  -- to earlier checked machines, so we thread some state through this
  -- computation. (And I also want some IO for debugging purposes.)
  (equiv, rel) <- flip execStateT (Map.empty, []) $ do
    forM_ projections (\(o1, b1) -> do
      (repr, _) <- get
      if o1 `Map.member` repr
        then do
          liftIO . putStrLn $ "skip " <> (show o1) <> " |-> " <> (show (repr Map.! o1))
        else do
          liftIO $ print o1
          forM_ projections (\(o2, b2) -> do
            (repr0, _) <- get
            when (o1 < o2 && o2 `Map.notMember` repr0) $ do
              case (isRefinementOf b1 b2, isRefinementOf b2 b1) of
                (True, True) -> do
                  (repr, ls) <- get
                  put (Map.insert o2 o1 repr, ls)
                (True, False) -> do
                  (repr, ls) <- get
                  put (repr, (o1, o2):ls)
                (False, True) -> do
                  (repr, ls) <- get
                  put (repr, (o2, o1):ls)
                (False, False) -> return ()

              -- liftIO $ putStr " vs. "
              -- liftIO $ print o2
            )
      )

  putStrLn ""
  putStrLn "Equivalences"
  forM_ (Map.assocs equiv) (\(o2, o1) -> do
    putStrLn $ "  " <> (show o2) <> " == " <> (show o1)
    )

  let cleanRel = [(Map.findWithDefault o1 o1 equiv, Map.findWithDefault o2 o2 equiv) | (o1, o2) <- rel]
  putStrLn ""
  putStrLn "Relation (smaller points to bigger)"
  forM_ (nubSort cleanRel) (\(o1, o2) -> do
    putStrLn $ "  " <> (show o2) <> " -> " <> (show o1)
    )

  return ()

  -}