From 25d47a3550e3696099465c510bd69399d885ea1d Mon Sep 17 00:00:00 2001 From: Joshua Moerman Date: Thu, 23 Jun 2016 11:16:47 +0200 Subject: [PATCH] Refactors the IO monad out. Made functions pure again. --- src/Main.hs | 119 ++++++++++++++++++---------------------- src/NLStar.hs | 109 +++++++++++++++--------------------- src/ObservationTable.hs | 2 +- 3 files changed, 99 insertions(+), 131 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 6fe2bdc..77fdd53 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} import Examples @@ -11,6 +9,7 @@ import NLStar import NLambda import Data.List (inits, tails) +import Debug.Trace import Prelude hiding (and, curry, filter, lookup, map, not, sum, uncurry) @@ -54,42 +53,35 @@ inconsistency = inconsistencyBartek -- This function will (recursively) make the table complete and consistent. -- This is in the IO monad purely because I want some debugging information. -- (Same holds for many other functions here) -makeCompleteConsistent :: LearnableAlphabet i => Teacher i -> State i -> IO (State i) -makeCompleteConsistent teacher state@State{..} = do +makeCompleteConsistent :: LearnableAlphabet i => Teacher i -> State i -> State i +makeCompleteConsistent teacher state@State{..} = -- inc is the set of rows witnessing incompleteness, that is the sequences -- 's1 a' which do not have their equivalents of the form 's2'. - let inc = incompleteness state + let inc = incompleteness state in ite (isNotEmpty inc) - (do - -- If that set is non-empty, we should add new rows - putStrLn "Incomplete!" + ( -- If that set is non-empty, we should add new rows + trace "Incomplete! Adding rows:" $ -- These will be the new rows, ... - let ds = inc - putStr " -> Adding rows: " - print ds - let state2 = addRows teacher ds state + let ds = inc in + traceShow ds $ + let state2 = addRows teacher ds state in makeCompleteConsistent teacher state2 ) - (do - -- inc2 is the set of inconsistencies. - let inc2 = inconsistency state + ( -- inc2 is the set of inconsistencies. + let inc2 = inconsistency state in ite (isNotEmpty inc2) - (do - -- If that set is non-empty, we should add new columns - putStr "Inconsistent! : " - print inc2 + ( -- If that set is non-empty, we should add new columns + trace "Inconsistent! Adding columns:" $ -- The extensions are in the second component - let de = sum $ map (\((s1,s2,a),es) -> map (a:) es) inc2 - putStr " -> Adding columns: " - print de - let state2 = addColumns teacher de state + let de = sum $ map (\((s1,s2,a),es) -> map (a:) es) inc2 in + traceShow de $ + let state2 = addColumns teacher de state in 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. - putStrLn " => Complete + Consistent :D!" - return state + trace " => Complete + Consistent :D!" $ + state ) ) @@ -106,48 +98,46 @@ constructHypothesis State{..} = automaton q a d i f toform s = forAll id . map fromBool $ s -- 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 teacher state@State{..} ces = do - putStr "Using ce: " - print ces - let ds = sum . map (fromList . inits) $ ces - putStr " -> Adding rows: " - print ds - let state2 = addRows teacher ds state - return state2 +useCounterExampleAngluin :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> State i +useCounterExampleAngluin teacher state@State{..} ces = + trace "Using ce:" $ + traceShow ces $ + let ds = sum . map (fromList . inits) $ ces in + trace " -> Adding rows:" $ + traceShow ds $ + addRows teacher ds state -- 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 teacher state@State{..} ces = do - putStr "Using ce: " - print ces - let de = sum . map (fromList . tails) $ ces - putStr " -> Adding columns: " - print de - let state2 = addColumns teacher de state - return state2 +useCounterExampleRS :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> State i +useCounterExampleRS teacher state@State{..} ces = + trace "Using ce:" $ + traceShow ces $ + let de = sum . map (fromList . tails) $ ces in + trace " -> Adding columns:" $ + traceShow de $ + addColumns teacher de state -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 -- The main loop, which results in an automaton. Will stop if the hypothesis -- exactly accepts the language we are learning. -loop :: LearnableAlphabet i => Teacher i -> State i -> IO (Automaton (BRow i) i) -loop teacher s = do - putStrLn "##################" - putStrLn "1. Making it complete and consistent" - s <- makeCompleteConsistent teacher s - putStrLn "2. Constructing hypothesis" - let h = constructHypothesis s - print h - putStr "3. Equivalent? " - let eq = equivalent teacher h - print eq +loop :: LearnableAlphabet i => Teacher i -> State i -> Automaton (BRow i) i +loop teacher s = + trace "##################" $ + trace "1. Making it complete and consistent" $ + let s2 = makeCompleteConsistent teacher s in + trace "2. Constructing hypothesis" $ + let h = constructHypothesis s2 in + traceShow h $ + trace "3. Equivalent? " $ + let eq = equivalent teacher h in + traceShow eq $ case eq of - Nothing -> return h + Nothing -> h Just ce -> do - s <- useCounterExample teacher s ce - loop teacher s + let s3 = useCounterExample teacher s2 ce + loop teacher s3 constructEmptyState :: LearnableAlphabet i => Teacher i -> State i constructEmptyState teacher = @@ -158,14 +148,13 @@ constructEmptyState teacher = let t = fillTable teacher (ss `union` ssa) ee in State{..} -learn :: LearnableAlphabet i => Teacher i -> IO (Automaton (BRow i) i) -learn teacher = do - let s = constructEmptyState teacher - loop teacher s +learn :: LearnableAlphabet i => Teacher i -> Automaton (BRow i) i +learn teacher = loop teacher s + where s = constructEmptyState teacher -- Initializes the table and runs the algorithm. main :: IO () main = do - h <- learn exampleTeacher + let h = learn (teacherWithTarget (Examples.fifoExample 3)) putStrLn "Finished! Final hypothesis =" print h diff --git a/src/NLStar.hs b/src/NLStar.hs index b9adb3e..880874b 100644 --- a/src/NLStar.hs +++ b/src/NLStar.hs @@ -8,6 +8,7 @@ import Teacher import NLambda +import Debug.Trace import Data.List (inits, tails) import Prelude hiding (and, curry, filter, lookup, map, not, sum) @@ -51,58 +52,38 @@ inconsistencyNonDet State{..} = 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 --- 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 is in the IO monad purely because I want some debugging information. -- (Same holds for many other functions here) -makeCompleteConsistentNonDet :: LearnableAlphabet i => Teacher i -> State i -> IO (State i) -makeCompleteConsistentNonDet teacher state@State{..} = do +makeCompleteConsistentNonDet :: LearnableAlphabet i => Teacher i -> State i -> State i +makeCompleteConsistentNonDet teacher state@State{..} = -- inc is the set of rows witnessing incompleteness, that is the sequences -- 's1 a' which do not have their equivalents of the form 's2'. - putStrLn "New round" - let inc = incompletenessNonDet state + let inc = incompletenessNonDet state in ite (isNotEmpty inc) - (do - -- If that set is non-empty, we should add new rows - putStrLn "Incomplete!" + ( -- If that set is non-empty, we should add new rows + trace "Incomplete! Adding rows:" $ -- These will be the new rows, ... - let ds = inc - putStr " -> Adding rows: " - print ds - let state2 = addRows teacher ds state + let ds = inc in + traceShow ds $ + let state2 = addRows teacher ds state in makeCompleteConsistentNonDet teacher state2 ) - (do - -- inc2 is the set of inconsistencies. - let inc2 = inconsistencyNonDet state + ( -- inc2 is the set of inconsistencies. + let inc2 = inconsistencyNonDet state in ite (isNotEmpty inc2) - (do - -- If that set is non-empty, we should add new columns - putStr "Inconsistent! : " - print inc2 + ( -- If that set is non-empty, we should add new columns + trace "Inconsistent! Adding columns:" $ -- The extensions are in the second component - let de = sum $ map (\((s1,s2,a),es) -> map (a:) es) inc2 - putStr " -> Adding columns: " - print de - let state2 = addColumns teacher de state + let de = sum $ map (\((s1,s2,a),es) -> map (a:) es) inc2 in + traceShow de $ + let state2 = addColumns teacher de state in 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. - putStrLn " => Complete + Consistent :D!" - return state + trace " => Complete + Consistent :D!" $ + state ) ) @@ -126,34 +107,33 @@ constructHypothesisNonDet State{..} = automaton q a d i f toform s = forAll id . map fromBool $ s -- 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 teacher state@State{..} ces = do - putStr "Using ce: " - print ces - let de = sum . map (fromList . tails) $ ces - putStr " -> Adding columns: " - print de - let state2 = addColumns teacher de state - return state2 +useCounterExampleNonDet :: LearnableAlphabet i => Teacher i -> State i -> Set [i] -> State i +useCounterExampleNonDet teacher state@State{..} ces = + trace "Using ce:" $ + traceShow ces $ + let de = sum . map (fromList . tails) $ ces in + trace " -> Adding columns:" $ + traceShow de $ + addColumns teacher de state -- The main loop, which results in an automaton. Will stop if the hypothesis -- exactly accepts the language we are learning. -loopNonDet :: LearnableAlphabet i => Teacher i -> State i -> IO (Automaton (BRow i) i) -loopNonDet teacher s = do - putStrLn "##################" - putStrLn "1. Making it complete and consistent" - s <- makeCompleteConsistentNonDet teacher s - putStrLn "2. Constructing hypothesis" - let h = constructHypothesisNonDet s - print h - putStr "3. Equivalent? " - let eq = equivalent teacher h - print eq +loopNonDet :: LearnableAlphabet i => Teacher i -> State i -> Automaton (BRow i) i +loopNonDet teacher s = + trace "##################" $ + trace "1. Making it complete and consistent" $ + let s2 = makeCompleteConsistentNonDet teacher s in + trace "2. Constructing hypothesis" $ + let h = constructHypothesisNonDet s2 in + traceShow h $ + trace "3. Equivalent? " $ + let eq = equivalent teacher h in + traceShow eq $ case eq of - Nothing -> return h + Nothing -> h Just ce -> do - s <- useCounterExampleNonDet teacher s ce - loopNonDet teacher s + let s3 = useCounterExampleNonDet teacher s2 ce + loopNonDet teacher s3 constructEmptyStateNonDet :: LearnableAlphabet i => Teacher i -> State i constructEmptyStateNonDet teacher = @@ -164,7 +144,6 @@ constructEmptyStateNonDet teacher = let t = fillTable teacher (ss `union` ssa) ee in State{..} -learnNonDet :: LearnableAlphabet i => Teacher i -> IO (Automaton (BRow i) i) -learnNonDet teacher = do - let s = constructEmptyStateNonDet teacher - loopNonDet teacher s +learnNonDet :: LearnableAlphabet i => Teacher i -> Automaton (BRow i) i +learnNonDet teacher = loopNonDet teacher s + where s = constructEmptyStateNonDet teacher diff --git a/src/ObservationTable.hs b/src/ObservationTable.hs index 1b940fb..24b4560 100644 --- a/src/ObservationTable.hs +++ b/src/ObservationTable.hs @@ -44,7 +44,7 @@ type BRow i = Row i Bool -- second is columns. Although the teacher provides us formulas instead of -- booleans, we can partition the answers to obtain actual booleans. 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 base = pairsWith (\s e -> (s, e, membership teacher (s++e))) sssa ee map2 f (a, b) = (f a, f b)