Browse Source

Minimization of automata

master
Joshua Moerman 7 years ago
commit
17a71cca80
  1. 4
      .gitignore
  2. 67
      Mini.cabal
  3. 118
      Mini.hs
  4. 2
      Setup.hs

4
.gitignore

@ -0,0 +1,4 @@
dist
.cabal-sandbox
cabal.sandbox.config

67
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

118
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

2
Setup.hs

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain