more formatting

app/LStarMain.hs

@@ -21,14 +21,14 @@ semanticsForState _ _ [] = error ""
 semanticsForState MealyMachine{..} q [a] = fst (behaviour q a)
 semanticsForState m@MealyMachine{..} q (a : w) = semanticsForState m (snd (behaviour q a)) w
 
-
 main :: IO ()
 main = do
   [dotFile] <- getArgs
   print dotFile
   transitions <- mapMaybe (parseMaybe parseTransFull) . lines <$> readFile dotFile
 
-  let machine = convertToMealy transitions
+  let
+    machine = convertToMealy transitions
     alphabet = inputs machine
     tInit = initialState machine
     tOut s i = fst (behaviour machine s i)
@@ -37,7 +37,7 @@ main = do
     mq0 = semanticsForState machine (initialState machine)
     mq = countingMQ (\w -> when debugOutput (print w) >> return (mq0 w))
 
-  let loop table = do
+    loop table = do
       lift $ putStrLn "Making the table closed and consistent"
       (table2, b) <- makeClosedAndConsistentA mq table
       let (hInit, size, hTransMap, hOutMap) = createHypothesis table2

app/Main.hs

@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Avoid reverse" #-}
 module Main where
 
 import DotParser
@@ -10,21 +13,20 @@ import Preorder
 
 import Control.Monad (forM_)
 import Data.Bifunctor
-import Data.List (sort, sortOn, intercalate)
+import Data.List (intercalate, sort, sortOn)
 import Data.List.Ordered (nubSort)
 import Data.Map.Strict qualified as Map
-import Data.Maybe (mapMaybe)
+import Data.Maybe (isNothing, mapMaybe)
 import Data.Set qualified as Set
 import Data.Tuple (swap)
 import System.Environment
 import Text.Megaparsec
 
-
 converseRelation :: Ord b => Map.Map a b -> Map.Map b [a]
-converseRelation m = Map.fromListWith (++) . fmap (second pure . swap) . Map.assocs $ m
+converseRelation = Map.fromListWith (++) . fmap (second pure . swap) . Map.assocs
 
 myWriteFile :: FilePath -> String -> IO ()
-myWriteFile filename content = writeFile ("results/" ++ filename) content
+myWriteFile filename = writeFile ("results/" ++ filename)
 
 {-
   Hacked together, you can view the result with:
@@ -39,10 +41,7 @@ main = do
   -- Read dot file
   [dotFile] <- getArgs
   print dotFile
-  transitions <- mapMaybe (parseMaybe parseTransFull) . lines <$> readFile dotFile
+  machine <- convertToMealy . 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"
@@ -69,19 +68,23 @@ main = do
 
   -- 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"]
+  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, state2idx) = allProjections machine outs
     projections = zip outs $ fmap refineMealy projections0
 
   -- Print number of states of each projection
-  forM_ projections (\(o, partition) -> do
+  forM_
+    projections
+    ( \(o, partition) -> do
         putStr $ o <> " -> "
         printPartition partition
     )
 
   -- First we check for equivalent partitions, so that we skip redundant work.
-  let preord p1 p2 = toPreorder (comparePartitions p1 p2)
+  let
+    preord p1 p2 = toPreorder (comparePartitions p1 p2)
     (equiv, uniqPartitions) = equivalenceClasses preord projections
 
   putStrLn ""
@@ -90,19 +93,24 @@ main = do
 
   putStrLn ""
   putStrLn "Equivalences"
-  forM_ (Map.assocs equiv) (\(o2, o1) -> do
+  forM_
-    putStrLn $ "  " <> (show o2) <> " == " <> (show o1)
+    (Map.assocs equiv)
+    ( \(o2, o1) -> do
+        putStrLn $ "  " <> show o2 <> " == " <> show o1
     )
 
   -- Then we compare each pair of partitions. We only keep the finest
   -- partitions, since the coarse ones don't provide value to us.
-  let (topMods, downSets) = maximalElements preord uniqPartitions
+  let
+    (topMods, downSets) = maximalElements preord uniqPartitions
     foo (a, b) = (numBlocks b, a)
 
   putStrLn ""
   putStrLn "Top modules"
-  forM_ (reverse . sort . fmap foo $ topMods) (\(b, o) -> do
+  forM_
-    putStrLn $ "  " <> (show o) <> " has size " <> (show b)
+    (reverse . sort . fmap foo $ topMods)
+    ( \(b, o) -> do
+        putStrLn $ "  " <> show o <> " has size " <> show b
     )
 
   -- Then we try to combine paritions, so that we don't end up with
@@ -114,35 +122,37 @@ main = do
   projmap <- heuristicMerger topMods strategy
 
   -- Now we are going to output the components we found.
-  let equivInv = converseRelation equiv
+  let
+    equivInv = converseRelation equiv
     projmapN = zip projmap [1 :: Int ..]
-
+    action ((os, p), componentIdx) = do
-  forM_ projmapN (\((os, p), i) -> do
+      let
-    let name = intercalate "x" os
+        name = intercalate "x" os
         osWithRel = concat $ os : [Map.findWithDefault [] o downSets | o <- os]
         osWithRelAndEquiv = concat $ osWithRel : [Map.findWithDefault [] o equivInv | o <- osWithRel]
         componentOutputs = Set.fromList osWithRelAndEquiv
-        proj = projectToComponent (flip Set.member componentOutputs) machine
+        proj = projectToComponent (`Set.member` componentOutputs) machine
         -- Sanity check: compute partition again
         partition = refineMealy . mealyMachineToEncoding $ proj
 
-    putStrLn $ ""
+      putStrLn ""
       putStrLn $ "Component " <> show os
       putStrLn $ "Correct? " <> show (comparePartitions p partition)
       putStrLn $ "Size = " <> show (numBlocks p)
 
-    (do
+      do
-      let filename = "partition_" <> show i <> ".dot"
+        let
+          filename = "partition_" <> show componentIdx <> ".dot"
           idx2State = Map.map head . converseRelation $ state2idx
           stateBlocks = fmap (fmap (idx2State Map.!)) . Partition.toBlocks $ partition
-          content = unlines . fmap (intercalate " ") $ stateBlocks
+          content = unlines . fmap unwords $ stateBlocks
 
         putStrLn $ "Output (partition) in file " <> filename
         myWriteFile filename content
-      )
 
-    (do
+      do
-      let MealyMachine{..} = proj
+        let
+          MealyMachine{..} = proj
           -- We enumerate all transitions in the full automaton
           transitions = [(s, i, o, t) | s <- states, i <- inputs, let (o, t) = behaviour s i]
           -- This is the quotient map, from state to block
@@ -155,18 +165,18 @@ main = do
           initialFirst = sortOn (\(s, _, _, _) -> s /= initialBlock) transitionsBlocks
 
           -- Convert to a file
-          filename1 = "component_" <> show i <> ".dot"
+          filename1 = "component_" <> show componentIdx <> ".dot"
           content1 = toString . mealyToDot name $ initialFirst
 
           -- So far so good, `initialFirst` could serve as our output
           -- But we do one more optimisation on the machine
           -- We remove inputs, on which the machine does nothing
           deadInputs0 = Map.fromListWith (++) . fmap (\(s, i, o, t) -> (i, [(s, o, t)])) $ initialFirst
-          deadInputs = Map.keysSet . Map.filter (all (\(s,o,t) -> s == t && o == Nothing)) $ deadInputs0
+          deadInputs = Map.keysSet . Map.filter (all (\(s, o, t) -> s == t && isNothing o)) $ deadInputs0
           result = filter (\(_, i, _, _) -> i `Set.notMember` deadInputs) initialFirst
 
           -- Convert to a file
-          filename2 = "component_reduced_" <> show i <> ".dot"
+          filename2 = "component_reduced_" <> show componentIdx <> ".dot"
           content2 = toString . mealyToDot name $ result
 
         putStrLn $ "Output (reduced machine) in file " <> filename1
@@ -176,7 +186,5 @@ main = do
 
         putStrLn $ "Output (reduced machine) in file " <> filename2
         myWriteFile filename2 content2
-      )
-    )
 
-  return ()
+  mapM_ action projmapN

app/RandomGen.hs

@@ -1,5 +1,6 @@
-{-# language PartialTypeSignatures #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+
 module Main where
 
 import SplittingTree
@@ -21,7 +22,7 @@ genTransitions size inputs outputs = do
     randomOutput = (outputs !!) <$> liftRand (uniformR (0, numOutputs - 1))
     randomTarget = (states !!) <$> liftRand (uniformR (0, size - 1))
     randomTransition s i = (\o t -> (s, i, o, t)) <$> randomOutput <*> randomTarget
-  t <- sequence $ (\s i -> randomTransition s i) <$> states <*> inputs
+  t <- sequence $ randomTransition <$> states <*> inputs
   return (states, t)
 
 -- numC <= 8
@@ -34,10 +35,13 @@ genComposition size numC inputs = do
   allTransitions <- traverse (\c -> genTransitions size inputs (outputSets !! c)) components
 
   let
-    productState = fmap (Map.fromList . zip components) (sequence (fmap fst allTransitions))
+    productState = fmap (Map.fromList . zip components) (mapM fst allTransitions)
     allStates = (,) <$> components <*> productState
-    compMap = Map.fromList $ zip components (fmap (Map.fromList . fmap (\(s, i, o, t) -> ((s, i), (o, t)))) . fmap snd $ allTransitions)
+    compMap = Map.fromList $ zip components ((Map.fromList . fmap (\(s, i, o, t) -> ((s, i), (o, t)))) . snd <$> allTransitions)
-    norm c = if c <= 0 then c + numC else if c > numC then c - numC else c
+    norm c
+      | c <= 0 = c + numC
+      | c > numC = c - numC
+      | otherwise = c
     transition (c, cs) 'L' = (norm (c - 1), cs)
     transition (c, cs) 'R' = (norm (c + 1), cs)
     transition (c, cs) x = (c, Map.adjust (\s -> snd (compMap Map.! c Map.! (s, x))) c cs)
@@ -75,7 +79,7 @@ main = do
     states = Map.elems reachableMap
     init = reachableMap Map.! init0
     trans s i = reachableMap Map.! trans0 (inverseMap Map.! s) i
-    outpf s i = outpf0 (inverseMap Map.! s) i
+    outpf s = outpf0 (inverseMap Map.! s)
 
   -- minimize
   let

other/decompose_fsm_optimise.py

@@ -335,9 +335,7 @@ class Encoder:
 
     # Even omzetten in een makkelijkere data structuur
     m = self.solver.get_model()
-    model = {}
+    model = {abs(l): l > 0 for l in m}
-    for l in m:
-      model[abs(l)] = l > 0
 
     if self.args.verbose:
       for rid in self.rids:

src/Bisimulation.hs

@@ -4,7 +4,6 @@ import Data.List (find)
 import Data.Map.Strict qualified as Map
 import Data.Sequence qualified as Seq
 
-
 -- Dit is niet de echte union-find datastructuur (niet erg efficient),
 -- maar wel simpel en beter dan niks.
 newtype UnionFind x = MkUnionFind {unUnionFind :: Map.Map x x}
@@ -15,10 +14,9 @@ empty = MkUnionFind Map.empty
 
 -- Omdat we een pure interface hebben, doen we hier geen path-compression.
 equivalent :: Ord x => x -> x -> UnionFind x -> Bool
-equivalent x y (MkUnionFind m) = root x == root y where
+equivalent x y (MkUnionFind m) = root x == root y
-  root z = case Map.lookup z m of
+ where
-    Nothing -> z
+  root z = maybe z root (Map.lookup z m)
-    Just w -> root w
 
 -- Hier kunnen we wel path-compression doen. We zouden ook nog een rank
 -- optimalisatie kunnen (moeten?) doen. Maar dan moeten we meer onthouden.
@@ -34,8 +32,6 @@ equate x y (MkUnionFind m1) =
     Nothing -> (z, m)
     Just w -> Map.insert z r <$> rootCP w m r
 
-
-
 -- Bisimulatie in 1 machine
 bisimulation :: (Eq o, Ord s) => [i] -> (s -> i -> o) -> (s -> i -> s) -> s -> s -> Maybe [i]
 bisimulation alphabet output transition x y = go (Seq.singleton ([], x, y)) empty

src/DotParser.hs

@@ -49,15 +49,17 @@ parseTransFull :: Parser Trans
 parseTransFull = space *> parseTrans <* eof
 
 convertToMealy :: [Trans] -> MealyMachine String String String
-convertToMealy l = MealyMachine
+convertToMealy l =
+  MealyMachine
     { states = states
     , inputs = ins
     , outputs = outs
-  , behaviour = \s i -> base Map.! (s, i)
+    , behaviour = curry (base Map.!)
     , initialState = (\(a, _, _, _) -> a) . head $ l
-  -- ^ Assumption: first transition in the file belongs to the initial state
     }
  where
+  -- \^ Assumption: first transition in the file belongs to the initial state
+
   froms = OrdList.nubSort . fmap (\(a, _, _, _) -> a) $ l
   tos = OrdList.nubSort . fmap (\(_, a, _, _) -> a) $ l
   ins = OrdList.nubSort . fmap (\(_, _, i, _) -> i) $ l

src/LStar.hs

@@ -73,7 +73,7 @@ inconsistencies table@LStarState{..} = defects
     equivalentPairs = [(r1, r2) | r1 <- Set.toList rowIndices, r2 <- Set.toList rowIndices, r1 < r2, row table r1 == row table r2]
     defects = [(a, s) | (r1, r2) <- equivalentPairs, a <- alphabet, let d = differenceOfRows r1 r2 a, s <- Map.keys d]
     differenceOfRows r1 r2 a = differenceOfMaps (row table (r1 `snoc` a)) (row table (r2 `snoc` a))
-    differenceOfMaps m1 m2 = MapMerge.merge MapMerge.dropMissing MapMerge.dropMissing (MapMerge.zipWithMaybeMatched (\_ x y -> if x == y then Nothing else Just ())) m1 m2
+    differenceOfMaps = MapMerge.merge MapMerge.dropMissing MapMerge.dropMissing (MapMerge.zipWithMaybeMatched (\_ x y -> if x == y then Nothing else Just ()))
 
 -- Preconditie: tabel is gesloten en consistent
 -- TODO: misschien checken of de automaat uniek is? De constructie van
@@ -83,7 +83,7 @@ createHypothesis :: (Ord i, Ord o) => LStarState i o -> (Int, Int, Map.Map (Int,
 createHypothesis table@LStarState{..} = (initialState, Map.size row2IntMap, transitions, outputs)
   where
     rowIndicesLs = Set.toList rowIndices
-    upperRows = map (row table) $ rowIndicesLs
+    upperRows = map (row table) rowIndicesLs
     row2IntMap = Map.fromList $ zip upperRows [0..]
     row2Int = (Map.!) row2IntMap . row table
     transitions = Map.fromList [((row2Int r, a), row2Int (r `snoc` a)) | r <- rowIndicesLs, a <- alphabet]
@@ -97,7 +97,7 @@ createHypothesis table@LStarState{..} = (initialState, Map.size row2IntMap, tran
 -- Een lege tabel heeft altijd een "epsilon-rij" en voor elk symbool een kolom.
 -- (Omdat het Mealy machines zijn.)
 initialiseA :: (Applicative f, Ord i) => [i] -> MQ f i o -> f (LStarState i o)
-initialiseA alphabet mq = initialiseWithA alphabet [mempty] (map pure alphabet) mq
+initialiseA alphabet = initialiseWithA alphabet [mempty] (map pure alphabet)
 
 -- We kunnen ook een tabel maken met voorgedefinieerde rijen en kolommen.
 initialiseWithA :: (Applicative f, Ord i) => [i] -> [Word i] -> [Word i] -> MQ f i o -> f (LStarState i o)
@@ -106,7 +106,7 @@ initialiseWithA alphabet rowIdcs colIdcs mq = (\content -> LStarState{..}) <$> c
     rowIndices = Set.fromList rowIdcs
     colIndices = Set.fromList colIdcs
     queries = [p <> m <> s | p <- rowIdcs, m <- []:fmap pure alphabet, s <- colIdcs]
-    contentA = Map.traverseWithKey (\w _ -> mq w) . Map.fromList . zip queries $ repeat ()
+    contentA = Map.traverseWithKey (\ w _ -> mq w) . Map.fromList . map (, ()) $ queries
 
 -- preconditie: newRowIndices is disjunct van de huidige rowIndices en de
 -- vereniging is prefix-gesloten. (Wordt niet gechecked.)
@@ -116,7 +116,7 @@ addRowsA newRowIndices mq table@LStarState{..} = (\newContent -> table
   , rowIndices = rowIndices <> Set.fromList newRowIndices }) <$> contentA
   where
     queries = [w | p <- newRowIndices, m <- []:fmap pure alphabet, s <- Set.toList colIndices, let w = p <> m <> s, w `Map.notMember` content]
-    contentA = Map.traverseWithKey (\w _ -> mq w) . Map.fromList . zip queries $ repeat ()
+    contentA = Map.traverseWithKey (\ w _ -> mq w) . Map.fromList . map (, ()) $ queries
 
 -- preconditie: zie addRows (?)
 addColumnsA :: (Applicative f, Ord i) => [Word i] -> MQ f i o -> LStarState i o -> f (LStarState i o)
@@ -125,7 +125,7 @@ addColumnsA newColIndices mq table@LStarState{..} = (\newContent -> table
   , colIndices = colIndices <> Set.fromList newColIndices }) <$> contentA
   where
     queries = [w | p <- Set.toList rowIndices, m <- []:fmap pure alphabet, s <- newColIndices, let w = p <> m <> s, w `Map.notMember` content]
-    contentA = Map.traverseWithKey (\w _ -> mq w) . Map.fromList . zip queries $ repeat ()
+    contentA = Map.traverseWithKey (\ w _ -> mq w) . Map.fromList . map (, ()) $ queries
 
 
 ------------------

src/Mealy.hs

@@ -15,8 +15,9 @@ transitionFunction :: MealyMachine s i o -> s -> i -> s
 transitionFunction MealyMachine{..} s i = snd (behaviour s i)
 
 exampleMM :: MealyMachine String Char String
-exampleMM =
+exampleMM = MealyMachine{..}
-  let states = ["q0", "q1", "q2", "q3"]
+ where
+  states = ["q0", "q1", "q2", "q3"]
   inputs = ['a', 'b']
   outputs = ["een", "twee", "drie", "vier"]
   behaviour "q0" 'a' = ("een", "q1")
@@ -29,4 +30,3 @@ exampleMM =
   behaviour "q3" 'b' = ("twee", "q1")
   behaviour _ _ = error "undefined behaviour of exampleMM"
   initialState = "q0"
-   in MealyMachine{..}

src/MealyRefine.hs

@@ -5,8 +5,8 @@ import Partition (Partition)
 
 import Control.Monad.ST (runST)
 import Copar.Algorithm (refine)
-import Copar.Functors.Polynomial (Polynomial, PolyF1(..))
+import Copar.Functors.Polynomial (PolyF1 (..), Polynomial)
-import Copar.RefinementInterface (Label, F1)
+import Copar.RefinementInterface (F1, Label)
 import Data.Bool (bool)
 import Data.CoalgebraEncoding (Encoding (..))
 import Data.List.Ordered (nubSort)
@@ -16,7 +16,8 @@ import Data.Vector qualified
 import Data.Vector.Unboxed qualified
 
 project :: Ord u => (o -> u) -> MealyMachine s i o -> MealyMachine s i u
-project f MealyMachine{..} = MealyMachine
+project f MealyMachine{..} =
+  MealyMachine
     { outputs = nubSort $ fmap f outputs -- inefficient
     , behaviour = \s i -> case behaviour s i of
         (out, s2) -> (f out, s2)
@@ -28,7 +29,8 @@ projectToBit o = project (o ==)
 
 projectToComponent :: Ord o => (o -> Bool) -> MealyMachine s i o -> MealyMachine s i (Maybe o)
 projectToComponent oPred = project oMaybe
-  where oMaybe o
+ where
+  oMaybe o
     | oPred o = Just o
     | otherwise = Nothing
 
@@ -49,15 +51,21 @@ allProjections MealyMachine{..} outs = (fmap mkEncoding outs, state2idx)
   edgesLabel = Data.Vector.generate (numStates * numInputs) (snd . stateInputIndex)
   edgesTo = Data.Vector.Unboxed.generate (numStates * numInputs) ((state2idx Map.!) . snd . (\(s, i) -> behaviour (idx2state Map.! s) (idx2input Map.! i)) . stateInputIndex)
   bool2Int = bool 0 1
-    structure o = Data.Vector.generate numStates
+  structure o =
-      (\s -> PolyF1
+    Data.Vector.generate
+      numStates
+      ( \s ->
+          PolyF1
             { polyF1Summand = 0 -- There is only one summand
             , polyF1Variables = numInputs -- This many transitions per state
-        , polyF1Constants = Data.Vector.Unboxed.generate numInputs
+            , polyF1Constants =
-          (\i -> bool2Int . (o==) . fst $ (behaviour (idx2state Map.! s) (idx2input Map.! i)))
+                Data.Vector.Unboxed.generate
+                  numInputs
+                  (\i -> bool2Int . (o ==) . fst $ behaviour (idx2state Map.! s) (idx2input Map.! i))
             }
       )
-    mkEncoding o = Encoding
+  mkEncoding o =
+    Encoding
       { eStructure = structure o
       , eInitState = Nothing -- not needed
       , eEdgesFrom = edgesFrom
@@ -76,12 +84,17 @@ mealyMachineToEncoding MealyMachine{..} =
       idx2state = Map.fromList $ zip [0 ..] states
       idx2input = Map.fromList $ zip [0 ..] inputs
       out2idx = Map.fromList $ zip outputs [0 ..]
-      eStructure = Data.Vector.generate numStates
+      eStructure =
-        (\s -> PolyF1
+        Data.Vector.generate
+          numStates
+          ( \s ->
+              PolyF1
                 { polyF1Summand = 0 -- There is only one summand
                 , polyF1Variables = numInputs -- This many transitions per state
-          , polyF1Constants = Data.Vector.Unboxed.generate numInputs
+                , polyF1Constants =
-            (\i -> out2idx Map.! (fst (behaviour (idx2state Map.! s) (idx2input Map.! i))))
+                    Data.Vector.Unboxed.generate
+                      numInputs
+                      (\i -> out2idx Map.! fst (behaviour (idx2state Map.! s) (idx2input Map.! i)))
                 }
           )
       eInitState = Nothing

src/Merger.hs

@@ -29,7 +29,8 @@ heuristicMerger components strategy = do
   return $ Map.assocs projmap
  where
   score ps p3 = numBlocks p3 - sum (fmap numBlocks ps)
-    combine ops = let os = fmap fst ops
+  combine ops =
+    let os = fmap fst ops
         ps = fmap snd ops
         p3 = foldr1 commonRefinement ps
      in ((os, p3), score ps p3)

src/Partition.hs

@@ -1,14 +1,14 @@
-module Partition
+module Partition (
-  ( module Partition
+  module Partition,
-  , module Data.Partition
+  module Data.Partition,
 ) where
 
 import Preorder
 
-import Control.Monad.Trans.State.Strict (runState, get, put)
+import Control.Monad.Trans.State.Strict (get, put, runState)
 import Data.Coerce (coerce)
 import Data.Map.Strict qualified as Map
-import Data.Partition (Partition(..), numStates, blockOfState, toBlocks)
+import Data.Partition (Partition (..), blockOfState, numStates, toBlocks)
 import Data.Partition.Common (Block (..))
 import Data.Vector qualified as V
 
@@ -62,7 +62,8 @@ toPreorder Incomparable = IC'
 comparePartitions :: Partition -> Partition -> Comparison
 comparePartitions p1 p2
   | p1 == p2 = Equivalent
-  | otherwise = let glb = commonRefinement p1 p2
+  | otherwise =
+      let glb = commonRefinement p1 p2
           n1 = numBlocks p1
           n2 = numBlocks p2
           n3 = numBlocks glb

src/Preorder.hs

@@ -1,14 +1,14 @@
-{-# language PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms #-}
+
 module Preorder where
 
-{- |
+-- \|
-This modules includes some algorithms to deal with preorders. For our use-case
+-- This modules includes some algorithms to deal with preorders. For our use-case
-it could be done efficiently with a single function. But this makes it a bit
+-- it could be done efficiently with a single function. But this makes it a bit
-unwieldy. So I have separated it into two functions:
+-- unwieldy. So I have separated it into two functions:
-1. One function takes a preorder and computes the equivalence classes.
+-- 1. One function takes a preorder and computes the equivalence classes.
-2. The second function takes the order into account (now only on the
+-- 2. The second function takes the order into account (now only on the
-   representatives of the first function) and returns the "top" elements.
+--    representatives of the first function) and returns the "top" elements.
--}
 
 import Control.Monad.Trans.Writer.Lazy (runWriter, tell)
 import Data.Bifunctor
@@ -19,10 +19,15 @@ import Data.Set qualified as Set
 type PartialOrdering = Maybe Ordering
 
 pattern EQ', LT', GT', IC' :: PartialOrdering
-pattern EQ' = Just EQ -- ^ Equivalent (or equal)
+pattern EQ' = Just EQ
-pattern LT' = Just LT -- ^ Strictly less than
+-- \^ Equivalent (or equal)
-pattern GT' = Just GT -- ^ Strictly greater than
+pattern LT' = Just LT
-pattern IC' = Nothing -- ^ Incomparable
+-- \^ Strictly less than
+pattern GT' = Just GT
+-- \^ Strictly greater than
+pattern IC' = Nothing
+
+-- \^ Incomparable
 
 -- | A preorder should satisfy reflexivity and transitivity. It is not assumed
 -- to be anti-symmetric.

src/SplittingTree.hs

@@ -1,13 +1,14 @@
-{-# language PartialTypeSignatures #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 
 module SplittingTree where
 
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.State
-import Data.Map.Strict qualified as Map
 import Data.Coerce (coerce)
+import Data.Foldable (traverse_)
 import Data.List (sortOn)
+import Data.Map.Strict qualified as Map
 
 newtype Block = Block Int
   deriving (Eq, Ord, Read, Show, Enum)
@@ -63,7 +64,8 @@ data PRState s i o = PRState
   deriving (Show)
 
 updatePartition :: (Monad m, Ord s) => s -> Block -> StateT (PRState s i o) m ()
-updatePartition s b = modify foo where
+updatePartition s b = modify foo
+ where
   foo prs = prs{partition = coerce (Map.insert s b) (partition prs)}
 
 updateSize :: Monad m => Block -> Int -> StateT (PRState s i o) m Int
@@ -78,9 +80,11 @@ genNextBlockId = do
   return idx
 
 updateParent :: Monad m => Either Block InnerNode -> InnerNode -> o -> StateT (PRState s i o) m ()
-updateParent (Left block) target output = modify foo where
+updateParent (Left block) target output = modify foo
+ where
   foo prs = prs{splittingTree = (splittingTree prs){blockParent = Map.insert block (target, output) (blockParent (splittingTree prs))}}
-updateParent (Right node) target output = modify foo where
+updateParent (Right node) target output = modify foo
+ where
   foo prs = prs{splittingTree = (splittingTree prs){innerParent = Map.insert node (target, output) (innerParent (splittingTree prs))}}
 
 updateLabel :: Monad m => InnerNode -> [i] -> StateT (PRState s i o) m ()
@@ -111,10 +115,10 @@ refineWithSplitter action rev Splitter{..} = do
     tempChildsMaps = Map.map (Map.fromListWith (++)) . Map.fromListWith (++) $ tempChildsList
 
     -- Now we need to check the 3-way split:
-    -- * Some blocks have no states which occured, these don't appear.
+    -- \* Some blocks have no states which occured, these don't appear.
-    -- * Some blocks have all states move to a single subblock, this is not a
+    -- \* Some blocks have all states move to a single subblock, this is not a
     --   proper split and should be removed.
-    -- * Some blocks have different outputs (a proper split) or states which
+    -- \* Some blocks have different outputs (a proper split) or states which
     --   moved and states which didn't.
     properSplit b os
       | Map.null os = error "Should not happen"
@@ -130,7 +134,7 @@ refineWithSplitter action rev Splitter{..} = do
       -- Create a new sub-block
       nBIdx <- genNextBlockId
       -- Set all states to that id
-      mapM_ (\s -> updatePartition s nBIdx) ls
+      mapM_ (`updatePartition` nBIdx) ls
       -- And update the tree
       updateParent (Left nBIdx) nNIdx o
       n <- updateSize nBIdx (length ls)
@@ -163,17 +167,20 @@ refineWithSplitter action rev Splitter{..} = do
       -- sure it's worth the effort, so we only do it when we can remove a
       -- subblock.
       if missingSize == 0
-      then let ls = Map.toList sizesAndSubblocks
+        then
+          let ls = Map.toList sizesAndSubblocks
               -- TODO: sort(On) is unnecessarily expensive, we only need to
               -- know the biggest...
               ((o1, _) : smallerBlocks) = sortOn (\(_, (n, _)) -> -n) ls
-           in
+           in return
-           return Splitter
+                Splitter
                   { split = Map.fromList (fmap (\(o, (_, lss)) -> (o, lss)) smallerBlocks)
                   , leftOut = o1
                   , witness = newWitness
                   }
-      else return Splitter
+        else
+          return
+            Splitter
               { split = Map.map snd sizesAndSubblocks
               , leftOut = leftOut
               , witness = newWitness
@@ -200,7 +207,7 @@ refineWithOutput action out = do
       -- Create a new sub-block
       nBIdx <- genNextBlockId
       -- Set all states to that id
-        mapM_ (\s -> updatePartition s nBIdx) ss
+      mapM_ (`updatePartition` nBIdx) ss
       -- And update the tree
       updateParent (Left nBIdx) nNIdx o
       _ <- updateSize nBIdx (length ss)
@@ -213,7 +220,7 @@ refineWithOutput action out = do
 
       -- For the remaining blocks, we update the partition
       nNIdx <- genNextNodeId
-      _ <- traverse (\(o, ss) -> updateStates nNIdx o ss) smaller
+      traverse_ (uncurry (updateStates nNIdx)) smaller
 
       -- If we are doing the very first split, the nNIdx node does not have a
       -- parent. So we don't have to do updates. Now nNIdx will be the root.
@@ -228,7 +235,8 @@ refineWithOutput action out = do
       _ <- updateSize b (length biggest)
 
       -- Return the splitter, not that we already skipped the larger part.
-      return Splitter
+      return
+        Splitter
           { split = Map.fromList smaller
           , leftOut = o1
           , witness = witness
@@ -237,10 +245,12 @@ refineWithOutput action out = do
   Map.elems <$> Map.traverseWithKey updateBlock tempChildsMaps2
 
 initialPRState :: Ord s => [s] -> PRState s i o
-initialPRState ls = PRState
+initialPRState ls =
+  PRState
     { partition = Partition . Map.fromList $ [(s, Block 0) | s <- ls]
     , nextBlockId = Block 1
-  , splittingTree = SplittingTree
+    , splittingTree =
+        SplittingTree
           { label = Map.empty
           , innerParent = Map.empty
           , blockParent = Map.empty
@@ -249,13 +259,13 @@ initialPRState ls = PRState
     , nextNodeId = Node 0
     }
 
-refineWithAllOutputs :: (Monad m, Ord o, Ord s) => [(i, (s -> o))] -> StateT (PRState s i o) m [Splitter s i o]
+refineWithAllOutputs :: (Monad m, Ord o, Ord s) => [(i, s -> o)] -> StateT (PRState s i o) m [Splitter s i o]
 refineWithAllOutputs ls = concat <$> traverse (uncurry refineWithOutput) ls
 
-refineWithSplitterAllInputs :: (Monad m, Ord o, Ord s) => [(i, (s -> [s]))] -> Splitter s i o -> StateT (PRState s i o) m [Splitter s i o]
+refineWithSplitterAllInputs :: (Monad m, Ord o, Ord s) => [(i, s -> [s])] -> Splitter s i o -> StateT (PRState s i o) m [Splitter s i o]
 refineWithSplitterAllInputs ls splitter = concat <$> traverse (\(i, rev) -> refineWithSplitter i rev splitter) ls
 
-refine :: (Monad m, Ord o, Ord s) => ([i] -> m ()) -> [(i, (s -> o))] -> [(i, (s -> [s]))] -> StateT (PRState s i o) m ()
+refine :: (Monad m, Ord o, Ord s) => ([i] -> m ()) -> [(i, s -> o)] -> [(i, s -> [s])] -> StateT (PRState s i o) m ()
 refine ping outputs transitionsReverse = do
   initialQueue <- refineWithAllOutputs outputs
 

src/StateIdentifiers.hs

@@ -1,14 +1,14 @@
 module StateIdentifiers where
 
 import SplittingTree
-import Trie qualified as Trie
+import Trie qualified
 
 import Data.Map.Strict qualified as Map
 
 stateIdentifierFor :: (Ord i, Ord s) => s -> Partition s -> SplittingTree s i o -> Trie.Trie i
-stateIdentifierFor state Partition{..} SplittingTree{..} = go firstNode where
+stateIdentifierFor state Partition{..} SplittingTree{..} = go firstNode
+ where
   firstNode = fst <$> blockParent Map.!? (getPartition Map.! state)
   getParent n = fst <$> innerParent Map.!? n
   go Nothing = Trie.empty
   go (Just n) = Trie.insert (label Map.! n) (go (getParent n))
-