From 17a71cca80ffcec080d8c126dcf35580bb7426b0 Mon Sep 17 00:00:00 2001 From: Joshua Moerman Date: Sat, 10 Dec 2016 23:24:41 +0100 Subject: [PATCH] Minimization of automata --- .gitignore | 4 ++ Mini.cabal | 67 ++++++++++++++++++++++++++++++ Mini.hs | 118 +++++++++++++++++++++++++++++++++++++++++++++++++++++ Setup.hs | 2 + 4 files changed, 191 insertions(+) create mode 100644 .gitignore create mode 100644 Mini.cabal create mode 100644 Mini.hs create mode 100644 Setup.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3ddc074 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +dist +.cabal-sandbox +cabal.sandbox.config + diff --git a/Mini.cabal b/Mini.cabal new file mode 100644 index 0000000..8c3dcdd --- /dev/null +++ b/Mini.cabal @@ -0,0 +1,67 @@ +-- Initial Mini.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: Mini + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- The license under which the package is released. +-- license: + +-- The file containing the license text. +-- license-file: LICENSE + +-- The package author(s). +author: Joshua Moerman + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: lakseru@gmail.com + +-- A copyright notice. +-- copyright: + +-- category: + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +executable Mini + -- .hs or .lhs file containing the Main module. + main-is: Mini.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.7 && <4.8, data-fix + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + diff --git a/Mini.hs b/Mini.hs new file mode 100644 index 0000000..bbe8f6d --- /dev/null +++ b/Mini.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE LambdaCase #-} + +import Data.Fix +import Data.List +import Data.Maybe + + +-- Lib +type Coalgebra f x = x -> f x + +behaviour :: (Functor f) => Coalgebra f x -> x -> Fix f +behaviour = ana -- = (~> Fix) = Fix (fmap (behaviour phi) (phi x)) + +data MooreF i o x = MooreF o (i -> x) +type Moore i o x = Coalgebra (MooreF i o) x + +getO :: MooreF i o x -> o +getO (MooreF o _) = o + +apply :: MooreF i o x -> i -> x +apply (MooreF _ f) = f + +instance Functor (MooreF i o) where + fmap f (MooreF o phi) = MooreF o (f . phi) + + +type DFA i x = Moore i Bool x +type Language i = Fix (MooreF i Bool) +type Word i = [i] + +singleton :: (Eq i) => DFA i (Maybe (Word i)) +singleton Nothing = MooreF False (const Nothing) +singleton (Just []) = MooreF True (const Nothing) +singleton (Just (y:ys)) = MooreF False (\i -> if i == y then Just ys else Nothing) + +isMember :: Word i -> Language i -> Bool +isMember [] l = getO . unFix $ l +isMember (x:xs) l = isMember xs $ apply (unFix l) x + +test :: x -> [Word i] -> DFA i x -> ([Word i], [Word i]) +test s ws m = partition (\w -> isMember w (behaviour m s)) ws + +enumerate :: [x] -> [[x]] -> [[x]] +enumerate xs [] = [] +enumerate xs (a:as) = map (:a) xs ++ enumerate xs as + +enumerateAll :: [x] -> [[x]] +enumerateAll xs = concat $ iterate (enumerate xs) [[]] + +type Color = Int +type NewColor = Int + +algebra :: [i] -> (o -> Int) -> [Color] -> MooreF i o Color -> NewColor +algebra is mp cs (MooreF o phi) = (mp o) * totalWidth + foldl (\acc d -> width * acc + d) 0 digits + where + width = length is + totalWidth = length cs ^ width + digits = map phi is + +allColours :: [x] -> (x -> Int) -> [Int] +allColours xs p = map head . group . sort . map p $ xs + +-- maps [x1 ... xn] to [0 ... n] +-- Can be implemented a lot better ;D +reduce :: [Int] -> (Int -> Int) +reduce xs x = fromJust $ lookup x indexed + where + sorted = map head . group $ sort xs + indexed = zip sorted [0..] + + +base :: [x] -> [i] -> (o -> Int) -> Moore i o x -> (x -> Int) +base _ _ _ _ = \x -> 0 + +step :: [x] -> [i] -> (o -> Int) -> Moore i o x -> (x -> Int) -> (x -> Int) +step states inputs outputs machine p = reducedP + where + colors = allColours states p + newP = algebra inputs outputs colors . fmap p . machine + reducedP = reduce (allColours states newP) . newP + +-- minimize :: [x] -> [i] -> (o -> Int) -> Moore i o x -> (x -> Int) +minimize' states inputs outputs machine = stabilize $ iterate s b + where + b = base states inputs outputs machine + s = step states inputs outputs machine + size p = length (allColours states p) + conv l = zip l (tail l) + stabilize = snd . last . takeWhile (\(a, b) -> size a < size b) . conv + +-- Example +data States = A | B | C | D | E | F +data Input = Zero | One + deriving Show + +machine :: DFA Input States +machine A = MooreF False (\case Zero -> B; One -> C) +machine B = MooreF False (\case Zero -> A; One -> D) +machine C = MooreF True (\case Zero -> E; One -> F) +machine D = MooreF True (\case Zero -> E; One -> F) +machine E = MooreF True (\case Zero -> E; One -> F) +machine F = MooreF False (\case Zero -> F; One -> F) + +states = [A, B, C, D, E, F] +inputs = [Zero, One] +outputs = (\o -> if o then 1 else 0) + +b = base states inputs outputs machine +s = step states inputs outputs machine + +main :: IO () +main = print . limit 10 . onBoth evaluate . limit 200000 $ test startingState tests machine + where + startingState = A + tests = enumerateAll [Zero, One] + onBoth f (a, b) = (f a, f b) + limit n = onBoth (take n) + evaluate xs = seq (sum (map length xs)) xs diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain