module Data.DFA.KISS2
(
read
, writeToFile
) where
import Prelude hiding ( lex, read )
import Control.Monad ( when )
import Data.List ( foldl' )
import Foreign.C
import qualified Data.Map as Map
import Data.DFA ( DFA, State )
import qualified Data.DFA as DFA
cToNum :: (Num i, Integral e) => e -> i
cToNum = fromIntegral . toInteger
q0 :: State
q0 = 0
read :: Bool -> String -> IO DFA
read debug ls =
do let s = foldl' lex_states (Map.empty, initial_state) (lines ls)
dfa <- DFA.initialize debug q0
_ <- mapM_ (lex_trans dfa s) (lines ls)
return dfa
where
initial_state = error "KISS2.read: no initial state."
state_name st out = st ++ "_" ++ out
lex_inputs is = sum [ 2 ^ x | (i, x) <- zip is [(0::Int) .. ], i == '1' ]
lex_out out = out == "1"
lex_states s@(sm, _) l = case l of
'0':_ -> lex_states_trans s l
'1':_ -> lex_states_trans s l
'.':'r':rest -> case words rest of
[st] -> (sm, st)
_ -> error $ "readKISS2: malformed reset line: '" ++ l ++ "'"
_ -> s
lex_states_trans s = lex_states_trans2 s . words
lex_states_trans2 (sm, is) [_inputs, _from, to, out] =
let t = state_name to out
sm' = case t `Map.lookup` sm of
Nothing -> Map.insert t (cToNum (Map.size sm + 1)) sm
Just {} -> sm
in sm' `seq` is `seq` (sm', is)
lex_states_trans2 _s l = error $ "readKISS2: failed to lex: '" ++ unwords l ++ "'"
lex_trans dfa s l = case l of
'0':_ -> lex_trans1 dfa s l
'1':_ -> lex_trans1 dfa s l
_ -> return ()
lex_trans1 dfa s = lex_trans2 dfa s . words
lex_trans2 dfa (sm, is) [inputs, from, to, out] =
do let sym = lex_inputs inputs
Just t = state_name to out `Map.lookup` sm
when (from == is) $ DFA.addTransition dfa (q0, sym, t)
when (lex_out out) $ DFA.setFinal dfa t
let add_trans o =
case state_name from o `Map.lookup` sm of
Nothing -> return ()
Just f -> DFA.addTransition dfa (f, sym, t)
add_trans "0"
add_trans "1"
lex_trans2 _dfa _sm l = error $ "readKISS2: failed to lex: '" ++ unwords l ++ "'"
writeToFile :: DFA -> FilePath -> IO ()
writeToFile dfa fname =
throwErrnoPathIfMinus1_ "KISS2.writetoFile" fname $
withCString fname (writeKISS2ToFile' dfa)
foreign import ccall unsafe "dfa.h DFA_writeKISS2ToFile"
writeKISS2ToFile' :: DFA -> CString -> IO CInt