joshua/nominal-lstar
1
Fork 0
mirror of https://github.com/Jaxan/nominal-lstar.git synced 2025-04-27 14:47:45 +02:00
Code Issues Releases Activity

Refactors the IO monad out. Made functions pure again.

Browse source
This commit is contained in:
Joshua Moerman 2016-06-23 11:16:47 +02:00
parent f5f88a2ef7
commit 25d47a3550
3 changed files with 99 additions and 131 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

119
src/Main.hs
View file

@ -1,5 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
import Examples import Examples
@ -11,6 +9,7 @@ import NLStar
import NLambda import NLambda
import Data.List (inits, tails) import Data.List (inits, tails)
import Debug.Trace
import Prelude hiding (and, curry, filter, lookup, map, not, import Prelude hiding (and, curry, filter, lookup, map, not,
sum, uncurry) sum, uncurry)
@ -54,42 +53,35 @@ inconsistency = inconsistencyBartek
-- This function will (recursively) make the table complete and consistent. -- This function will (recursively) make the table complete and consistent.
-- This is in the IO monad purely because I want some debugging information. -- This is in the IO monad purely because I want some debugging information.
-- (Same holds for many other functions here) -- (Same holds for many other functions here)
makeCompleteConsistent :: LearnableAlphabet i => Teacher i -> State i -> IO (State i) makeCompleteConsistent :: LearnableAlphabet i => Teacher i -> State i -> State i
makeCompleteConsistent teacher state@State{..} = do makeCompleteConsistent teacher state@State{..} =
-- inc is the set of rows witnessing incompleteness, that is the sequences -- inc is the set of rows witnessing incompleteness, that is the sequences
-- 's1 a' which do not have their equivalents of the form 's2'. -- 's1 a' which do not have their equivalents of the form 's2'.
let inc = incompleteness state let inc = incompleteness state in
ite (isNotEmpty inc) ite (isNotEmpty inc)
(do ( -- If that set is non-empty, we should add new rows
-- If that set is non-empty, we should add new rows trace "Incomplete! Adding rows:" $
putStrLn "Incomplete!"
-- These will be the new rows, ... -- These will be the new rows, ...
let ds = inc let ds = inc in
putStr " -> Adding rows: " traceShow ds $
print ds let state2 = addRows teacher ds state in
let state2 = addRows teacher ds state
makeCompleteConsistent teacher state2 makeCompleteConsistent teacher state2
) )
(do ( -- inc2 is the set of inconsistencies.
-- inc2 is the set of inconsistencies. let inc2 = inconsistency state in
let inc2 = inconsistency state
ite (isNotEmpty inc2) ite (isNotEmpty inc2)
(do ( -- If that set is non-empty, we should add new columns
-- If that set is non-empty, we should add new columns trace "Inconsistent! Adding columns:" $
putStr "Inconsistent! : "
print inc2
-- The extensions are in the second component -- The extensions are in the second component
let de = sum $ map (\((s1,s2,a),es) -> map (a:) es) inc2 let de = sum $ map (\((s1,s2,a),es) -> map (a:) es) inc2 in
putStr " -> Adding columns: " traceShow de $
print de let state2 = addColumns teacher de state in
let state2 = addColumns teacher de state
makeCompleteConsistent teacher state2 makeCompleteConsistent teacher state2
) )
(do ( -- If both sets are empty, the table is complete and
-- If both sets are empty, the table is complete and
-- consistent, so we are done. -- consistent, so we are done.
putStrLn " => Complete + Consistent :D!" trace " => Complete + Consistent :D!" $
return state state
) )
) )
@ -106,48 +98,46 @@ constructHypothesis State{..} = automaton q a d i f
toform s = forAll id . map fromBool $ s toform s = forAll id . map fromBool $ s
-- Extends the table with all prefixes of a set of counter examples. -- Extends the table with all prefixes of a set of counter examples.
useCounterExampleAngluin :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> IO (State i) useCounterExampleAngluin :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> State i
useCounterExampleAngluin teacher state@State{..} ces = do useCounterExampleAngluin teacher state@State{..} ces =
putStr "Using ce: " trace "Using ce:" $
print ces traceShow ces $
let ds = sum . map (fromList . inits) $ ces let ds = sum . map (fromList . inits) $ ces in
putStr " -> Adding rows: " trace " -> Adding rows:" $
print ds traceShow ds $
let state2 = addRows teacher ds state addRows teacher ds state
return state2
-- I am not quite sure whether this variant is due to Rivest & Schapire or Maler & Pnueli. -- I am not quite sure whether this variant is due to Rivest & Schapire or Maler & Pnueli.
useCounterExampleRS :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> IO (State i) useCounterExampleRS :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> State i
useCounterExampleRS teacher state@State{..} ces = do useCounterExampleRS teacher state@State{..} ces =
putStr "Using ce: " trace "Using ce:" $
print ces traceShow ces $
let de = sum . map (fromList . tails) $ ces let de = sum . map (fromList . tails) $ ces in
putStr " -> Adding columns: " trace " -> Adding columns:" $
print de traceShow de $
let state2 = addColumns teacher de state addColumns teacher de state
return state2
useCounterExample :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> IO (State i) useCounterExample :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> State i
useCounterExample = useCounterExampleRS useCounterExample = useCounterExampleRS
-- The main loop, which results in an automaton. Will stop if the hypothesis -- The main loop, which results in an automaton. Will stop if the hypothesis
-- exactly accepts the language we are learning. -- exactly accepts the language we are learning.
loop :: LearnableAlphabet i => Teacher i -> State i -> IO (Automaton (BRow i) i) loop :: LearnableAlphabet i => Teacher i -> State i -> Automaton (BRow i) i
loop teacher s = do loop teacher s =
putStrLn "##################" trace "##################" $
putStrLn "1. Making it complete and consistent" trace "1. Making it complete and consistent" $
s <- makeCompleteConsistent teacher s let s2 = makeCompleteConsistent teacher s in
putStrLn "2. Constructing hypothesis" trace "2. Constructing hypothesis" $
let h = constructHypothesis s let h = constructHypothesis s2 in
print h traceShow h $
putStr "3. Equivalent? " trace "3. Equivalent? " $
let eq = equivalent teacher h let eq = equivalent teacher h in
print eq traceShow eq $
case eq of case eq of
Nothing -> return h Nothing -> h
Just ce -> do Just ce -> do
s <- useCounterExample teacher s ce let s3 = useCounterExample teacher s2 ce
loop teacher s loop teacher s3
constructEmptyState :: LearnableAlphabet i => Teacher i -> State i constructEmptyState :: LearnableAlphabet i => Teacher i -> State i
constructEmptyState teacher = constructEmptyState teacher =
@ -158,14 +148,13 @@ constructEmptyState teacher =
let t = fillTable teacher (ss `union` ssa) ee in let t = fillTable teacher (ss `union` ssa) ee in
State{..} State{..}
learn :: LearnableAlphabet i => Teacher i -> IO (Automaton (BRow i) i) learn :: LearnableAlphabet i => Teacher i -> Automaton (BRow i) i
learn teacher = do learn teacher = loop teacher s
let s = constructEmptyState teacher where s = constructEmptyState teacher
loop teacher s
-- Initializes the table and runs the algorithm. -- Initializes the table and runs the algorithm.
main :: IO () main :: IO ()
main = do main = do
h <- learn exampleTeacher let h = learn (teacherWithTarget (Examples.fifoExample 3))
putStrLn "Finished! Final hypothesis =" putStrLn "Finished! Final hypothesis ="
print h print h

109
src/NLStar.hs
View file

@ -8,6 +8,7 @@ import Teacher
import NLambda import NLambda
import Debug.Trace
import Data.List (inits, tails) import Data.List (inits, tails)
import Prelude hiding (and, curry, filter, lookup, map, not, import Prelude hiding (and, curry, filter, lookup, map, not,
sum) sum)
@ -51,58 +52,38 @@ inconsistencyNonDet State{..} =
candidate0 s1 s2 = s1 `neq` s2 /\ rowP t s1 `eq` rowP t s2 candidate0 s1 s2 = s1 `neq` s2 /\ rowP t s1 `eq` rowP t s2
candidate1 s1 s2 a = rowPa t s1 a `neq` rowPa t s2 a candidate1 s1 s2 a = rowPa t s1 a `neq` rowPa t s2 a
-- This can be written for all monads. Unfortunately (a,) is also a monad and
-- this gives rise to overlapping instances, so I only do it for IO here.
-- Note that it is not really well defined, but it kinda works.
instance (Conditional a) => Conditional (IO a) where
cond f a b = case solve f of
Just True -> a
Just False -> b
Nothing -> fail "### Unresolved branch ###"
-- NOTE: another implementation would be to evaluate both a and b
-- and apply ite to their results. This however would runs both side
-- effects of a and b.
-- This function will (recursively) make the table complete and consistent. -- This function will (recursively) make the table complete and consistent.
-- This is in the IO monad purely because I want some debugging information. -- This is in the IO monad purely because I want some debugging information.
-- (Same holds for many other functions here) -- (Same holds for many other functions here)
makeCompleteConsistentNonDet :: LearnableAlphabet i => Teacher i -> State i -> IO (State i) makeCompleteConsistentNonDet :: LearnableAlphabet i => Teacher i -> State i -> State i
makeCompleteConsistentNonDet teacher state@State{..} = do makeCompleteConsistentNonDet teacher state@State{..} =
-- inc is the set of rows witnessing incompleteness, that is the sequences -- inc is the set of rows witnessing incompleteness, that is the sequences
-- 's1 a' which do not have their equivalents of the form 's2'. -- 's1 a' which do not have their equivalents of the form 's2'.
putStrLn "New round" let inc = incompletenessNonDet state in
let inc = incompletenessNonDet state
ite (isNotEmpty inc) ite (isNotEmpty inc)
(do ( -- If that set is non-empty, we should add new rows
-- If that set is non-empty, we should add new rows trace "Incomplete! Adding rows:" $
putStrLn "Incomplete!"
-- These will be the new rows, ... -- These will be the new rows, ...
let ds = inc let ds = inc in
putStr " -> Adding rows: " traceShow ds $
print ds let state2 = addRows teacher ds state in
let state2 = addRows teacher ds state
makeCompleteConsistentNonDet teacher state2 makeCompleteConsistentNonDet teacher state2
) )
(do ( -- inc2 is the set of inconsistencies.
-- inc2 is the set of inconsistencies. let inc2 = inconsistencyNonDet state in
let inc2 = inconsistencyNonDet state
ite (isNotEmpty inc2) ite (isNotEmpty inc2)
(do ( -- If that set is non-empty, we should add new columns
-- If that set is non-empty, we should add new columns trace "Inconsistent! Adding columns:" $
putStr "Inconsistent! : "
print inc2
-- The extensions are in the second component -- The extensions are in the second component
let de = sum $ map (\((s1,s2,a),es) -> map (a:) es) inc2 let de = sum $ map (\((s1,s2,a),es) -> map (a:) es) inc2 in
putStr " -> Adding columns: " traceShow de $
print de let state2 = addColumns teacher de state in
let state2 = addColumns teacher de state
makeCompleteConsistentNonDet teacher state2 makeCompleteConsistentNonDet teacher state2
) )
(do ( -- If both sets are empty, the table is complete and
-- If both sets are empty, the table is complete and
-- consistent, so we are done. -- consistent, so we are done.
putStrLn " => Complete + Consistent :D!" trace " => Complete + Consistent :D!" $
return state state
) )
) )
@ -126,34 +107,33 @@ constructHypothesisNonDet State{..} = automaton q a d i f
toform s = forAll id . map fromBool $ s toform s = forAll id . map fromBool $ s
-- I am not quite sure whether this variant is due to Rivest & Schapire or Maler & Pnueli. -- I am not quite sure whether this variant is due to Rivest & Schapire or Maler & Pnueli.
useCounterExampleNonDet :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> IO (State i) useCounterExampleNonDet :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> State i
useCounterExampleNonDet teacher state@State{..} ces = do useCounterExampleNonDet teacher state@State{..} ces =
putStr "Using ce: " trace "Using ce:" $
print ces traceShow ces $
let de = sum . map (fromList . tails) $ ces let de = sum . map (fromList . tails) $ ces in
putStr " -> Adding columns: " trace " -> Adding columns:" $
print de traceShow de $
let state2 = addColumns teacher de state addColumns teacher de state
return state2
-- The main loop, which results in an automaton. Will stop if the hypothesis -- The main loop, which results in an automaton. Will stop if the hypothesis
-- exactly accepts the language we are learning. -- exactly accepts the language we are learning.
loopNonDet :: LearnableAlphabet i => Teacher i -> State i -> IO (Automaton (BRow i) i) loopNonDet :: LearnableAlphabet i => Teacher i -> State i -> Automaton (BRow i) i
loopNonDet teacher s = do loopNonDet teacher s =
putStrLn "##################" trace "##################" $
putStrLn "1. Making it complete and consistent" trace "1. Making it complete and consistent" $
s <- makeCompleteConsistentNonDet teacher s let s2 = makeCompleteConsistentNonDet teacher s in
putStrLn "2. Constructing hypothesis" trace "2. Constructing hypothesis" $
let h = constructHypothesisNonDet s let h = constructHypothesisNonDet s2 in
print h traceShow h $
putStr "3. Equivalent? " trace "3. Equivalent? " $
let eq = equivalent teacher h let eq = equivalent teacher h in
print eq traceShow eq $
case eq of case eq of
Nothing -> return h Nothing -> h
Just ce -> do Just ce -> do
s <- useCounterExampleNonDet teacher s ce let s3 = useCounterExampleNonDet teacher s2 ce
loopNonDet teacher s loopNonDet teacher s3
constructEmptyStateNonDet :: LearnableAlphabet i => Teacher i -> State i constructEmptyStateNonDet :: LearnableAlphabet i => Teacher i -> State i
constructEmptyStateNonDet teacher = constructEmptyStateNonDet teacher =
@ -164,7 +144,6 @@ constructEmptyStateNonDet teacher =
let t = fillTable teacher (ss `union` ssa) ee in let t = fillTable teacher (ss `union` ssa) ee in
State{..} State{..}
learnNonDet :: LearnableAlphabet i => Teacher i -> IO (Automaton (BRow i) i) learnNonDet :: LearnableAlphabet i => Teacher i -> Automaton (BRow i) i
learnNonDet teacher = do learnNonDet teacher = loopNonDet teacher s
let s = constructEmptyStateNonDet teacher where s = constructEmptyStateNonDet teacher
loopNonDet teacher s

2
src/ObservationTable.hs
View file

@ -44,7 +44,7 @@ type BRow i = Row i Bool
-- second is columns. Although the teacher provides us formulas instead of -- second is columns. Although the teacher provides us formulas instead of
-- booleans, we can partition the answers to obtain actual booleans. -- booleans, we can partition the answers to obtain actual booleans.
fillTable :: LearnableAlphabet i => Teacher i -> Set [i] -> Set [i] -> BTable i fillTable :: LearnableAlphabet i => Teacher i -> Set [i] -> Set [i] -> BTable i
fillTable teacher sssa ee = force . Prelude.uncurry union . map2 (map slv) . map2 simplify . partition (\(_, _, f) -> f) $ base fillTable teacher sssa ee = Prelude.uncurry union . map2 (map slv) . map2 simplify . partition (\(_, _, f) -> f) $ base
where where
base = pairsWith (\s e -> (s, e, membership teacher (s++e))) sssa ee base = pairsWith (\s e -> (s, e, membership teacher (s++e))) sssa ee
map2 f (a, b) = (f a, f b) map2 f (a, b) = (f a, f b)