1
Fork 0
mirror of https://github.com/Jaxan/ons-hs.git synced 2025-04-27 14:47:45 +02:00

Optimised minimisation to work on leaves separately

This commit is contained in:
Joshua Moerman 2019-01-18 15:12:03 +01:00
parent 1d72d3cddb
commit 7a8591f002
4 changed files with 41 additions and 21 deletions

View file

@ -2,7 +2,7 @@
module Main where
import OrbitList
import OrbitList hiding (head)
import Support (Rat)
import Prelude (Show, Ord, Eq, Int, IO, print, otherwise, (.), ($), (!!), (+), (-), Bool, head, tail)

View file

@ -17,7 +17,7 @@ import qualified EquivariantSet as Set
import Data.Foldable (fold)
import qualified GHC.Generics as GHC
import Prelude as P hiding (map, product, words, filter)
import Prelude as P hiding (map, product, words, filter, foldr)
-- Version A: works on equivalence relations
@ -50,7 +50,7 @@ minimiseA Automaton{..} alph = Automaton
-- Version B: works on quotient maps
minimiseB :: _ => Automaton q a -> OrbitList a -> Automaton _ a
minimiseB Automaton{..} alph = Automaton
{ states = stInf
{ states = map fst stInf
, initialState = phiInf ! initialState
, acceptance = Map.fromList . fmap (\(s, b) -> (phiInf ! s, b)) . Map.toList $ acceptance
, transition = Map.fromList . fmap (\((s, a), t) -> ((phiInf ! s, a), phiInf ! t)) . Map.toList $ transition
@ -59,25 +59,25 @@ minimiseB Automaton{..} alph = Automaton
-- Are all successors of s0 t0 related?
nextAreEquiv phi s0 t0 = OrbitList.null
. filter (\(s2, t2) -> s2 /= t2 && phi ! s2 /= phi ! t2)
$ productWith (\(s, t) a -> (transition ! (s, a), transition ! (t, a))) (singleOrbit (s0, t0)) alph
$ productWith (\a (s, t) -> (transition ! (s, a), transition ! (t, a))) alph (singleOrbit (s0, t0))
-- Are s0 t0 equivalent with current information?
equiv phi s0 t0 = s0 == t0 || (phi ! s0 == phi ! t0 && nextAreEquiv phi s0 t0)
-- Given a quotientmap, refine it
go phi st = let (phi2, st2) = quotientf (equiv phi) states
in if size st == size st2
addMid p a (f, b, k) = (p <> f, b <> a, k)
-- Given a quotientmap, refine it, per "leaf"
go phi st = let (phi2, st2, _) = foldr (\(_, clas) (phix, acc, k) -> addMid phix acc . quotientf k (equiv phi) . Set.toOrbitList $ clas) (mempty, empty, 0) st
in if size st == size st2 -- fixpoint
then (phi, st)
else go phi2 st2
-- Start with acceptance as quotient map
(phi0, st0) = quotientf (\a b -> a == b || acceptance ! a == acceptance ! b) states
(phi0, st0, _) = quotientf 0 (\a b -> a == b || acceptance ! a == acceptance ! b) states
-- Compute fixpoint
(phiInf, stInf) = go phi0 st0
main :: IO ()
main = do
-- putStrLn . toStr . toList . map (\x -> (x, True)) $ words 2
-- putStrLn . toStr $ (fifoAut 3)
putStrLn . toStr $ (minimiseB (fifoAut 2) fifoAlph)
-- putStrLn . toStr $ (doubleWordAut 4)
putStrLn . toStr $ (minimiseB (doubleWordAut 4) rationals)
-- All example automata follow below
@ -94,6 +94,12 @@ data DoubleWord = Store [Rat] | Check [Rat] | Accept | Reject
deriving (Eq, Ord, GHC.Generic)
deriving Nominal via Generic DoubleWord
instance ToStr DoubleWord where
toStr (Store w) = "S " ++ toStr w
toStr (Check w) = "C " ++ toStr w
toStr Accept = "A"
toStr Reject = "R"
doubleWordAut 0 = Automaton {..} where
states = fromList [Accept, Reject]
initialState = Accept
@ -106,8 +112,8 @@ doubleWordAut n = Automaton {..} where
trans Accept _ = Reject
trans Reject _ = Reject
trans (Store l) a
| length l < n = Store (a:l)
| otherwise = Check (reverse (a:l))
| length l + 1 < n = Store (a:l)
| otherwise = Check (reverse (a:l))
trans (Check (a:as)) b
| a == b = if (P.null as) then Accept else Check as
| otherwise = Reject

View file

@ -9,26 +9,28 @@ import qualified EquivariantMap as Map
import EquivariantSet (EquivariantSet(..))
import qualified EquivariantSet as Set
import Prelude (Bool, Int, Ord, (.), (<>), (+), ($), snd, fmap, uncurry)
import Prelude (Bool, Int, Ord, (.), (<>), (+), ($), fst, snd, fmap, uncurry)
type QuotientType = (Int, Support)
type QuotientMap a = EquivariantMap a QuotientType
-- Computes a quotient map given an equivalence relation
quotient :: (Nominal a, Ord (Orbit a)) => EquivariantSet (a, a) -> OrbitList a -> (QuotientMap a, OrbitList QuotientType)
quotient equiv = quotientf (\a b -> (a, b) `Set.member` equiv)
quotient equiv = post . quotientf 0 (\a b -> (a, b) `Set.member` equiv)
where post (a, b, _) = (a, map fst b)
-- f should be equivariant and an equivalence relation
quotientf :: (Nominal a, Ord (Orbit a)) => (a -> a -> Bool) -> OrbitList a -> (QuotientMap a, OrbitList QuotientType)
quotientf f ls = go 0 Map.empty empty (toList ls)
quotientf :: (Nominal a, Ord (Orbit a)) => Int -> (a -> a -> Bool) -> OrbitList a -> (QuotientMap a, OrbitList (QuotientType, EquivariantSet a), Int)
quotientf k f ls = go k Map.empty empty (toList ls)
where
go _ phi acc [] = (phi, acc)
go n phi acc [] = (phi, acc, n)
go n phi acc (a:as) =
let y0 = filter (uncurry f) (product (singleOrbit a) (fromList as))
y1 = filter (uncurry f) (product (singleOrbit a) (singleOrbit a))
y2 = map (\(a1, a2) -> (a2, (n, support a1 `intersect` support a2))) (y1 <> y0)
m0 = Map.fromListWith (\(n1, s1) (n2, s2) -> (n1, s1 `intersect` s2)) . toList $ y2
l0 = take 1 . fromList . fmap snd $ Map.toList m0
clas = Map.keysSet m0
l0 = head . fromList . fmap snd $ Map.toList m0
in if a `Set.member` (Map.keysSet phi)
then go n phi acc as
else go (n+1) (phi <> m0) (acc <> l0) as
else go (n+1) (phi <> m0) ((l0, clas) `cons` acc) as

View file

@ -41,6 +41,9 @@ elem x = L.elem (toOrbit x) . unOrbitList
size :: forall a. Nominal a => OrbitList a -> [Int]
size = LO.sortOn negate . fmap (index (Proxy :: Proxy a)) . unOrbitList
-- May fail when empty
head :: Nominal a => OrbitList a -> a
head (OrbitList l) = getElementE (L.head l)
-- Construction
@ -53,6 +56,9 @@ singleOrbit a = OrbitList [toOrbit a]
rationals :: OrbitList Rat
rationals = singleOrbit (Rat 0)
cons :: Nominal a => a -> OrbitList a -> OrbitList a
cons a (OrbitList l) = OrbitList (toOrbit a : l)
repeatRationals :: Int -> OrbitList [Rat]
repeatRationals 0 = singleOrbit []
repeatRationals n = productWith (:) rationals (repeatRationals (n-1))
@ -75,7 +81,13 @@ take :: Int -> OrbitList a -> OrbitList a
take n = OrbitList . L.take n . unOrbitList
-- TODO: drop, span, takeWhile, ...
-- TODO: folds
-- TODO: Think about preconditions and postconditions of folds
foldr :: Nominal a => (a -> b -> b) -> b -> OrbitList a -> b
foldr f b = L.foldr (f . getElementE) b . unOrbitList
foldl :: Nominal a => (b -> a -> b) -> b -> OrbitList a -> b
foldl f b = L.foldl (\acc -> f acc . getElementE) b . unOrbitList
-- Combinations