From a50a9c0d8d9b3bf1edc9c7ff6b7b253a2ce7404d Mon Sep 17 00:00:00 2001
From: Henning Basold <henning@basold.eu>
Date: Sat, 14 Jun 2014 16:22:19 +0200
Subject: [PATCH 001/104] fgl implements Show for Patricia trees from 5.5.0.0
 on

---
 interpreter/LAMA.cabal                       |  2 +-
 interpreter/Main.hs                          |  1 -
 language/LAMA.cabal                          |  5 ++---
 language/lib/Data/Graph/Inductive/GenShow.hs | 14 --------------
 language/lib/Lang/LAMA/Dependencies.hs       |  2 --
 scade2lama/Scade2Lama.cabal                  |  2 +-
 scade2lama/lib/TransformAutomata.hs          |  3 +--
 7 files changed, 5 insertions(+), 24 deletions(-)
 delete mode 100644 language/lib/Data/Graph/Inductive/GenShow.hs

diff --git a/interpreter/LAMA.cabal b/interpreter/LAMA.cabal
index 566ed20..1b05040 100644
--- a/interpreter/LAMA.cabal
+++ b/interpreter/LAMA.cabal
@@ -8,7 +8,7 @@ Description:
 Executable test-lama
   default-language: Haskell2010
   build-depends: base, containers, mtl, bytestring, natural-numbers,
-    transformers, pretty, array, HUnit, language-lama
+    transformers, pretty, array, HUnit, language-lama, fgl >= 5.5.0.0
   hs-source-dirs: test lib
   GHC-Options: -Wall
   other-modules:
diff --git a/interpreter/Main.hs b/interpreter/Main.hs
index 7408bce..0c0e41b 100644
--- a/interpreter/Main.hs
+++ b/interpreter/Main.hs
@@ -18,7 +18,6 @@ import Data.Foldable (forM_, foldlM, foldl)
 import Lang.LAMA.Identifier
 import qualified Data.Map as Map
 import Data.Map (Map)
-import Data.Graph.Inductive.GenShow ()
 import Control.Monad (void, when, MonadPlus(..))
 import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class
diff --git a/language/LAMA.cabal b/language/LAMA.cabal
index 9691d39..01e6704 100644
--- a/language/LAMA.cabal
+++ b/language/LAMA.cabal
@@ -5,15 +5,14 @@ Cabal-Version:  >= 1.10
 Description:
   Parser, type checker and dependency analysis for LAMA
 
-Library 
+Library
   default-language: Haskell2010
   Build-Depends: base, containers, mtl, bytestring, natural-numbers,
-    transformers, pretty, array, fgl, text, filepath, placeholders,
+    transformers, pretty, array, fgl >= 5.5.0.0, text, filepath, placeholders,
     prelude-extras
   Hs-Source-Dirs: . lib
   GHC-Options: -Wall -O2
   exposed-modules:
-    Data.Graph.Inductive.GenShow
     Data.Bits.Size
     Lang.LAMA.Identifier
     Lang.LAMA.Types
diff --git a/language/lib/Data/Graph/Inductive/GenShow.hs b/language/lib/Data/Graph/Inductive/GenShow.hs
deleted file mode 100644
index 7c6a971..0000000
--- a/language/lib/Data/Graph/Inductive/GenShow.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Data.Graph.Inductive.GenShow where
-
-import Data.Graph.Inductive.Graph
-import Data.Graph.Inductive.PatriciaTree
-import qualified Data.Graph.Inductive.Tree as GTree
-
-instance forall a b. (Show a, Show b) => Show (Gr a b) where
-  show g =
-    let n = labNodes g
-        e = labEdges g
-        g' = mkGraph n e :: GTree.Gr a b
-    in show g'
diff --git a/language/lib/Lang/LAMA/Dependencies.hs b/language/lib/Lang/LAMA/Dependencies.hs
index 1f4b768..7c1230d 100644
--- a/language/lib/Lang/LAMA/Dependencies.hs
+++ b/language/lib/Lang/LAMA/Dependencies.hs
@@ -36,8 +36,6 @@ import Lang.LAMA.Identifier
 import Lang.LAMA.Types
 import Lang.LAMA.Typing.TypedStructure
 
-import Data.Graph.Inductive.GenShow ()
-
 -- fromSet :: Ord k => (k -> a) -> Set k -> Map k a
 -- fromSet f = Map.fromList . map (id &&& f) . Set.toList
 
diff --git a/scade2lama/Scade2Lama.cabal b/scade2lama/Scade2Lama.cabal
index 2ee03c1..985cb57 100644
--- a/scade2lama/Scade2Lama.cabal
+++ b/scade2lama/Scade2Lama.cabal
@@ -9,7 +9,7 @@ Executable scade2lama
   default-language: Haskell2010
   Build-Depends: base, containers, language-scade, language-lama,
     transformers, placeholders, mtl, bytestring, split, pretty,
-    natural-numbers, syb, fgl
+    natural-numbers, syb, fgl >= 5.5.0.0
   Hs-Source-Dirs: . lib
   GHC-Options: -Wall
   other-modules:
diff --git a/scade2lama/lib/TransformAutomata.hs b/scade2lama/lib/TransformAutomata.hs
index 0fcaa2e..6078e26 100644
--- a/scade2lama/lib/TransformAutomata.hs
+++ b/scade2lama/lib/TransformAutomata.hs
@@ -9,7 +9,6 @@ import Development.Placeholders
 
 import Data.Graph.Inductive.Graph as Gr
 import Data.Graph.Inductive.PatriciaTree
-import Data.Graph.Inductive.GenShow ()
 import qualified Data.Map as Map
 import Data.Map (Map, (!))
 import qualified Data.Set as Set
@@ -558,4 +557,4 @@ mkAutomaton gr defaultExprs =
           S.ActionEmission [] -> L.Edge hName tName cond
           S.ActionEmission _ -> $notImplemented
           S.ActionDef (S.DataDef [] [] []) -> L.Edge hName tName cond
-          S.ActionDef _ -> $notImplemented
\ No newline at end of file
+          S.ActionDef _ -> $notImplemented

From f82c02314cefc17d2a03d193f45327647e22a473 Mon Sep 17 00:00:00 2001
From: Henning Basold <henning@basold.eu>
Date: Sat, 14 Jun 2014 20:09:58 +0200
Subject: [PATCH 002/104] Give strategy the opportunity to return hints (aka
 counterexamples)

This comes in handy, if the user wants to analyse why an induction
cannot prove or disprove a property
---
 lamaSMT/Main.hs                      | 11 ++++++---
 lamaSMT/lib/Strategies/BMC.hs        | 35 +++++++++++++++++++++-------
 lamaSMT/lib/Strategies/KInduction.hs | 17 ++++++++++----
 lamaSMT/lib/Strategy.hs              | 19 +++++++++++----
 4 files changed, 61 insertions(+), 21 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index 65d4e4e..741c219 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -204,11 +204,16 @@ runCheck progOpts = chooseSolver progOpts . checkError
                       -- ++ solverBase
   -- withPipe solverCmd []
 
-checkModel :: Ident i => Options -> Program i -> Maybe (Natural, Model i) -> IO ()
-checkModel _ _ Nothing = putStrLn "42"
-checkModel opts prog (Just (lastIndex, m)) =
+checkModel :: Ident i =>
+           Options
+           -> Program i
+           -> (StrategyResult i)
+           -> IO ()
+checkModel _ _ Success = putStrLn "42"
+checkModel opts prog (Failure lastIndex m) =
   do putStrLn ":-("
      when (optDumpModel opts) (putStrLn . render $ prettyModel m)
      case optScenarioFile opts of
        Nothing -> return ()
        Just f -> writeFile f $ render $ scadeScenario prog (optTopNodePath opts) lastIndex m
+checkModel opts prog (Unknown what hints) = return ()
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index fb2c724..43c2d1c 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -43,9 +43,12 @@ assumeTrace defs iDef =
   assertDefs iDef (flowDef defs) >>
   assertPrecond iDef (precondition defs)
 
-bmcStep :: MonadSMT m
-             => (Map Natural StreamPos -> SMT (Model i))
-             -> ProgDefs -> Map Natural StreamPos -> StreamPos -> m (Maybe (Model i))
+bmcStep :: MonadSMT m =>
+        (Map Natural StreamPos -> SMT (Model i))
+        -> ProgDefs
+        -> Map Natural StreamPos
+        -> StreamPos
+        -> m (Maybe (Model i))
 bmcStep getModel defs pastIndices iDef =
   do assumeTrace defs iDef
      let invs = invariantDef defs
@@ -53,14 +56,20 @@ bmcStep getModel defs pastIndices iDef =
        $ checkInvariant iDef invs >>=
        checkGetModel getModel pastIndices
 
-check' :: SMTAnnotation Natural -> BMC -> (Map Natural StreamPos -> SMT (Model i))
-          -> ProgDefs -> Map Natural StreamPos -> Natural -> StreamPos -> SMTErr (Maybe (Natural, Model i))
+check' :: SMTAnnotation Natural
+       -> BMC
+       -> (Map Natural StreamPos -> SMT (Model i))
+       -> ProgDefs
+       -> Map Natural StreamPos
+       -> Natural
+       -> StreamPos
+       -> SMTErr (StrategyResult i)
 check' natAnn s getModel defs pastIndices i iDef =
   do liftIO $ when (bmcPrintProgress s) (putStrLn $ "Depth " ++ show i)
      r <- bmcStep getModel defs pastIndices iDef
      case r of
        Nothing -> next (check' natAnn s getModel defs) natAnn s pastIndices i iDef
-       Just m -> return $ Just (i, m)
+       Just m -> return $ Failure i m
 
 assertDefs :: MonadSMT m => SMTExpr Natural -> [Definition] -> m ()
 assertDefs i = mapM_ (assertDef i)
@@ -81,9 +90,17 @@ checkGetModel :: MonadSMT m
 checkGetModel getModel indices r = liftSMT $
   if r then return Nothing else fmap Just $ getModel indices
 
-next :: (Map Natural StreamPos -> Natural -> SMTExpr Natural -> SMTErr (Maybe (Natural, Model i)))
+next :: (Map Natural StreamPos
+             -> Natural
+             -> SMTExpr Natural
+             -> SMTErr (StrategyResult i)
+        )
         -> SMTAnnotation Natural
-        -> BMC -> Map Natural StreamPos -> Natural -> SMTExpr Natural -> SMTErr (Maybe (Natural, Model i))
+        -> BMC
+        -> Map Natural StreamPos
+        -> Natural
+        -> SMTExpr Natural
+        -> SMTErr (StrategyResult i)
 next checkCont natAnn s pastIndices i iDef =
   do let i' = succ i
      iDef' <- liftSMT . defConst$ succ' natAnn iDef
@@ -93,4 +110,4 @@ next checkCont natAnn s pastIndices i iDef =
        Just l ->
          if i' < l
          then checkCont pastIndices' i' iDef'
-         else return Nothing
+         else return Success
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index a3d0faa..a9e41b7 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -60,22 +60,29 @@ data InductState = InductState
 type KInductM = StateT InductState SMTErr
 
 check' :: SMTAnnotation Natural
-          -> KInduct -> (Map Natural StreamPos -> SMT (Model i))
-          -> ProgDefs -> KInductM (Maybe (Natural, Model i))
+       -> KInduct
+       -> (Map Natural StreamPos -> SMT (Model i))
+       -> ProgDefs
+       -> KInductM i (StrategyResult i)
 check' natAnn s getModel defs =
   do InductState{..} <- get
      liftIO $ when (printProgress s) (putStrLn $ "Depth " ++ show kVal)
      rBMC <- bmcStep getModel defs pastKs kDef
      case rBMC of
-       Just m -> return $ Just (kVal, m)
+       Just m -> return $ Failure kVal m
        Nothing ->
          do n1 <- liftSMT . defConst $ succ' natAnn nDef
             modify $ \indSt -> indSt { nDef = n1 }
             assertPrecond nDef $ invariantDef defs
             r <- checkStep defs n1
-            if r then return Nothing else next (check' natAnn s getModel defs) natAnn s
+            if r
+               then return Success
+               else next (check' natAnn s getModel defs) natAnn s
 
-next :: KInductM (Maybe (Natural, Model i)) -> SMTAnnotation Natural -> KInduct -> KInductM (Maybe (Natural, Model i))
+next :: KInductM i (StrategyResult i)
+     -> SMTAnnotation Natural
+     -> KInduct
+     -> KInductM i (StrategyResult i)
 next checkCont natAnn s =
   do indState@InductState {..} <- get
      let k' = succ kVal
diff --git a/lamaSMT/lib/Strategy.hs b/lamaSMT/lib/Strategy.hs
index 1946cc7..8f421a3 100644
--- a/lamaSMT/lib/Strategy.hs
+++ b/lamaSMT/lib/Strategy.hs
@@ -16,6 +16,12 @@ import TransformEnv
 import Model
 
 type SMTErr = ErrorT String SMT
+data Hint i = Hint { hintDescr :: String, hintModel :: Model i }
+type Hints i = [Hint i]
+data StrategyResult i =
+     Success
+     | Failure Natural (Model i)
+     | Unknown String (Hints i)
 
 data Strategy = forall s. StrategyClass s => Strategy s
 
@@ -25,10 +31,15 @@ class StrategyClass s where
   check :: SMTAnnotation Natural
            -> s
            -> (Map Natural StreamPos -> SMT (Model i))
-           -> ProgDefs -> SMTErr (Maybe (Natural, Model i))
-
-checkWithModel :: SMTAnnotation Natural -> Strategy -> ProgDefs -> VarEnv i -> SMTErr (Maybe (Natural, Model i))
+           -> ProgDefs
+           -> SMTErr (StrategyResult i)
+
+checkWithModel :: SMTAnnotation Natural
+               -> Strategy
+               -> ProgDefs
+               -> VarEnv i
+               -> SMTErr (StrategyResult i)
 checkWithModel natAnn (Strategy s) d env = check natAnn s (getModel env) d
 
 readOptions' :: String -> Strategy -> Strategy
-readOptions' o (Strategy s) = Strategy $ readOption o s
\ No newline at end of file
+readOptions' o (Strategy s) = Strategy $ readOption o s

From 4d977b1602da0285d6c1e9e8435aae8664913663 Mon Sep 17 00:00:00 2001
From: Henning Basold <henning@basold.eu>
Date: Sun, 22 Jun 2014 19:45:52 +0200
Subject: [PATCH 003/104] Generate hints if k-induction fails within given
 depth

This required the change of the interface of Strategy to allow
returning 3-valued results that may include hints.
---
 lamaSMT/Main.hs                      |  26 +++-
 lamaSMT/lib/Model.hs                 |  26 +++-
 lamaSMT/lib/Strategies/BMC.hs        |   8 +-
 lamaSMT/lib/Strategies/KInduction.hs | 220 +++++++++++++++++++++++----
 lamaSMT/lib/TransformEnv.hs          |   3 +-
 5 files changed, 241 insertions(+), 42 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index 741c219..3840f8b 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -5,7 +5,7 @@ module Main (main) where
 
 import qualified Data.ByteString.Lazy.Char8 as BL
 
-import Text.PrettyPrint (render)
+import Text.PrettyPrint (Doc, render, vcat, text, ($$))
 import Data.List.Split (splitOn)
 import Data.List (intercalate)
 import Data.Natural
@@ -212,8 +212,28 @@ checkModel :: Ident i =>
 checkModel _ _ Success = putStrLn "42"
 checkModel opts prog (Failure lastIndex m) =
   do putStrLn ":-("
+     putStrLn $ "Found counterexample at depth " ++ show lastIndex
      when (optDumpModel opts) (putStrLn . render $ prettyModel m)
      case optScenarioFile opts of
        Nothing -> return ()
-       Just f -> writeFile f $ render $ scadeScenario prog (optTopNodePath opts) lastIndex m
-checkModel opts prog (Unknown what hints) = return ()
+       Just f -> writeFile f $ render $ scadeScenario prog (optTopNodePath opts) m
+checkModel opts prog (Unknown what hints) =
+  do putStrLn ":-("
+     putStrLn what
+     when (optDumpModel opts)
+          (putStrLn . render . prettyHints $ hints)
+     case optScenarioFile opts of
+       Nothing -> return ()
+       Just f ->
+         mapM_ (\h ->
+                 writeFile (f ++ "_" ++ hintDescr h)
+                 . render
+                 $ scadeScenario prog (optTopNodePath opts) (hintModel h))
+               hints
+
+prettyHints :: Ident i => Hints i -> Doc
+prettyHints = vcat . map prettyHint
+  where
+    prettyHint h
+      = text ("Hint for " ++ (hintDescr h))
+        $$ prettyModel (hintModel h)
diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index f9b88b5..0787d31 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -99,16 +99,38 @@ getStreamValue s
   = ask >>=
     liftSMT . mapM (\i -> getValue $ s `app` i)
 
-scadeScenario :: Ident i => Program i -> [String] -> Natural -> Model i -> Doc
-scadeScenario p varPath lastIndex m =
+scadeScenario :: Ident i =>
+              Program i -> [String] -> Model i -> Doc
+scadeScenario p varPath m =
   let progInputNames = map varIdent . declsInput $ progDecls p
       progInputs = (Map.fromList $ zip progInputNames (repeat ()))
+      lastIndex = case fmap fst . Map.minView . modelVars $ m of
+        Nothing -> 0
+        Just s -> getLastIndex s
       inputTraces = Map.toList $ (modelVars m) `Map.intersection` progInputs
       path = case varPath of
         [] -> mempty
         _ -> (hcat $ punctuate (text "::") $ map text varPath) <> text ("/")
   in scenario inputTraces path lastIndex 0
   where
+    -- | Retrieves the last defined index of a given stream
+    getLastIndex :: ValueStream -> Natural
+    getLastIndex (BoolVStream s) = highestIndex s
+    getLastIndex (IntVStream s)  = highestIndex s
+    getLastIndex (RealVStream s) = highestIndex s
+    getLastIndex (EnumVStream s) = highestIndex s
+     -- abuses that products are non-empty
+    getLastIndex (ProdVStream a) = getLastIndex (a ! 0)
+
+    -- | Usese that streams are given by maps and so we can use findMax to
+    -- get the highest defined index.
+    highestIndex :: ValueStreamT t -> Natural
+    highestIndex s
+      | Map.null s = 0
+      | otherwise  = fst $ Map.findMax s
+
+    -- | Creates a Doc for all indices i..n from inp, setting the variables
+    -- under path.
     scenario inp path n i
       | i <= n =
         let setOp = text "SSM::set"
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index 43c2d1c..e468975 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -84,9 +84,11 @@ assertPrecond = assertDefinition id
 checkInvariant :: MonadSMT m => SMTExpr Natural -> Definition -> m Bool
 checkInvariant i p = liftSMT $ assertDefinition not' i p >> liftM not checkSat
 
-checkGetModel :: MonadSMT m
-                 => (Map Natural StreamPos -> SMT (Model i)) -> Map Natural StreamPos
-                 -> Bool -> m (Maybe (Model i))
+checkGetModel :: MonadSMT m =>
+              (Map Natural StreamPos -> SMT (Model i))
+              -> Map Natural StreamPos
+              -> Bool
+              -> m (Maybe (Model i))
 checkGetModel getModel indices r = liftSMT $
   if r then return Nothing else fmap Just $ getModel indices
 
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index a9e41b7..11da3b9 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -9,9 +9,10 @@ import qualified Data.Map as Map
 import Data.Map (Map)
 
 import Control.Monad.State (MonadState(..), StateT, evalStateT, modify)
+import Control.Monad.Writer (MonadWriter(..), WriterT, runWriterT)
 import Control.Monad.IO.Class
 import Control.Monad (when)
-import Control.Monad.Error (throwError)
+import Control.Arrow ((&&&))
 
 import Language.SMTLib2
 
@@ -22,51 +23,76 @@ import Model (Model)
 import Strategies.BMC
 import Internal.Monads
 
+data GenerateHints =
+     NoHints
+     | LastInductionStep
+     | AllInductionSteps
 data KInduct = KInduct
                { depth :: Maybe Natural
-               , printProgress :: Bool }
+               , printProgress :: Bool
+               , generateHints :: GenerateHints }
 
 instance StrategyClass KInduct where
-  defaultStrategyOpts = KInduct Nothing False
+  defaultStrategyOpts = KInduct Nothing False NoHints
 
-  readOption (stripPrefix "depth=" -> Just d) s =
+  readOption (stripPrefix "depth=" -> Just d) indOpts =
     case d of
-      "inf" -> s { depth = Nothing }
-      _ -> s { depth = Just $ read d }
-  readOption "progress" s =
-    s { printProgress = True }
+      "inf" -> indOpts { depth = Nothing }
+      _     -> indOpts { depth = Just $ read d }
+  readOption "progress" indOpts =
+    indOpts { printProgress = True }
+  readOption (stripPrefix "hints" -> Just r) indOpts =
+    case (stripPrefix "=" r) of
+         Nothing    -> indOpts { generateHints = LastInductionStep }
+         Just which -> case which of
+              "all"  -> indOpts { generateHints = AllInductionSteps }
+              "last" -> indOpts { generateHints = LastInductionStep }
+              _      -> error $ "Invalid hint option: " ++ which
   readOption o _ = error $ "Invalid k-induction option: " ++ o
 
-  check natAnn s getModel defs =
+  check natAnn indOpts getModel defs =
     let baseK = 0
     in do baseKDef <- liftSMT . defConst $ constantAnn baseK natAnn
           baseNDef <- liftSMT $ varAnn natAnn
           assumeTrace defs baseNDef
-          let s0 = InductState baseK baseKDef baseNDef (Map.singleton baseK baseKDef)
-          (flip evalStateT s0) $ check' natAnn s getModel defs
+          let s0 = InductState baseK baseKDef
+                               baseNDef (Map.singleton baseK baseKDef)
+          (r, hints) <- runWriterT
+                $ (flip evalStateT s0)
+                $ check' natAnn indOpts getModel defs
+          case r of
+               Unknown what h -> return $ Unknown what (h ++ hints)
+               _ -> return r
 
-checkStep :: MonadSMT m => ProgDefs -> StreamPos -> m Bool
+-- | Checks the induction step and returns true if the invariant could be
+-- proven
+checkStep :: ProgDefs -> StreamPos -> SMT Bool
 checkStep defs iDef =
   do assumeTrace defs iDef
      let invs = invariantDef defs
-     liftSMT . stack $ checkInvariant iDef invs
+     checkInvariant iDef invs
 
 -- | Holds current depth k and definitions of last k and n
 data InductState = InductState
                    { kVal :: Natural
-                   , kDef :: StreamPos -- ^ SMT expression for k
-                   , nDef :: StreamPos -- ^ SMT expression for n
+                   , kDef :: StreamPos -- ^ Induction depth k (in solver)
+                   , nDef :: StreamPos -- ^ Induction variable n (in solver)
                    , pastKs :: Map Natural StreamPos }
-type KInductM = StateT InductState SMTErr
+type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 
+-- | Checks the program against its invariant. If the invariant
+-- does not hold in the base case, then a model is returned.
+-- If the base case is fine, but the induction step is not, we
+-- call next, which increases k. Finally, if also the induction
+-- step can be proven, Nothing is returned.
 check' :: SMTAnnotation Natural
        -> KInduct
        -> (Map Natural StreamPos -> SMT (Model i))
        -> ProgDefs
        -> KInductM i (StrategyResult i)
-check' natAnn s getModel defs =
+check' natAnn indOpts getModel defs =
   do InductState{..} <- get
-     liftIO $ when (printProgress s) (putStrLn $ "Depth " ++ show kVal)
+     liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
      rBMC <- bmcStep getModel defs pastKs kDef
      case rBMC of
        Just m -> return $ Failure kVal m
@@ -74,24 +100,152 @@ check' natAnn s getModel defs =
          do n1 <- liftSMT . defConst $ succ' natAnn nDef
             modify $ \indSt -> indSt { nDef = n1 }
             assertPrecond nDef $ invariantDef defs
-            r <- checkStep defs n1
-            if r
+            (indSuccess, hints) <- liftSMT . stack $
+              do r <- checkStep defs n1
+                 h <- retrieveHints (getModel pastKs) indOpts kVal r
+                 return (r, h)
+            tell hints
+            let k' = succ kVal
+            if indSuccess
                then return Success
-               else next (check' natAnn s getModel defs) natAnn s
+               else case depth indOpts of
+                    Nothing -> cont k'
+                    Just l  ->
+                      if k' > l
+                      then return $ Unknown ("Cancelled induction. Found no"
+                                              ++" proof within given depth")
+                                    []
+                      else cont k'
+  where
+    cont k' =
+      do indState@InductState{..} <- get
+         kDef' <- liftSMT . defConst $ succ' natAnn kDef
+         let pastKs' = Map.insert k' kDef' pastKs
+         put $ indState { kVal = k', kDef = kDef', pastKs = pastKs' }
+         check' natAnn indOpts getModel defs
 
-next :: KInductM i (StrategyResult i)
+--     r <- checkInvariant iDef invs >>=
+--          checkGetModel getModel pastIndices
+{-
+        do getOpt
+             m <- getModel
+             tell m
+             return False
+-}
+
+-- | If requested, gets a model for the induction step
+retrieveHints :: SMT (Model i)
+              -> KInduct
+              -> Natural
+              -> Bool
+              -> SMT [(Hint i)]
+retrieveHints getModel indOpts k success =
+  case (generateHints  &&& depth) indOpts of
+       (NoHints          , _      ) -> return []
+       (LastInductionStep, Nothing) -> return []
+       (LastInductionStep, Just l ) ->
+         if not success && succ k > l
+         then getModel >>= \m -> return [Hint (show k) m]
+         else return []
+       (AllInductionSteps, _      ) ->
+         getModel >>= \m -> return [Hint (show k) m]
+
+-- | Checks whether the induction step could be proven. If not, then it can
+-- return Nothing, to indicate that the next induction depth should be tried.
+-- If the induction depth attained its bound, we stop with a StrategyResult.
+-- In case of failure, the current model might be recorded/returned as hint.
+-- If the step could be proven, Success is returned.
+-- checkStepResult :: SMTAnnotation Natural
+--      -> KInduct
+--      -> Natural
+--      -> Maybe (Hint i)
+--      -> Bool
+--      -> SMT (Maybe (StrategyResult i))
+-- checkStepResult = undefined
+{-
+
+-- | Checks whether the induction step could be proven. If not, then it can
+-- return Nothing, to indicate that the next induction depth should be tried.
+-- If the induction depth attained its bound, we stop with a StrategyResult.
+-- In case of failure, the current model might be recorded/returned as hint.
+-- If the step could be proven, Success is returned.
+checkStepResult :: (Map Natural StreamPos -> SMT (Model i))
+     -> SMTAnnotation Natural
+     -> KInduct
+     -> Natural
+     -> Bool
+     -> KInductM i (Maybe (StrategyResult i))
+checkStepResult getModel natAnn indOpts k' result =
+  if result
+  then return $ Just Success
+  else
+       case (generateHints    &&& depth) indOpts of
+            (NoHints          , Nothing) -> return Nothing
+            (NoHints          , Just l)  -> checkCont l k' (return [])
+            (LastInductionStep, Nothing) -> return Nothing
+            (LastInductionStep, Just l)  ->
+              checkCont l k' (retrieveModel
+                                >>= \m -> return [Hint (show kVal) m])
+            (AllInductionSteps, Nothing) ->
+              do m <- retrieveModel
+                 tell [Hint (show kVal) m]
+                 return Nothing
+            (AllInductionSteps, Just l)  ->
+              do m <- retrieveModel
+                 tell $ [Hint (show kVal) m]
+                 checkCont l k' (return [Hint (show kVal) m])
+  where
+    checkCont l k' m =
+      if k' < l
+      then return Nothing
+      else m >>= \r ->
+           return $ Just $ Unknown
+                    "Cancelled induction. Found no proof within given depth"
+                    r
+    retrieveModel =
+      do InductState{..} <- get
+         liftSMT $ getModel pastKs
+-}
+{-
+getModelAndContinue
+     :: (Map Natural StreamPos -> SMT (Model i))
+     -> KInductM i (StrategyResult i)
      -> SMTAnnotation Natural
      -> KInduct
      -> KInductM i (StrategyResult i)
-next checkCont natAnn s =
-  do indState@InductState {..} <- get
+getModelAndContinue getModel inductCont natAnn indOpts =
+  do InductState {..} <- get
      let k' = succ kVal
-     kDef' <- liftSMT . defConst $ succ' natAnn kDef
-     let pastKs' = Map.insert k' kDef' pastKs
-     put $ indState { kVal = k', kDef = kDef', pastKs = pastKs' }
-     case depth s of
-       Nothing -> checkCont
-       Just l ->
-         if k' < l
-         then checkCont
-         else throwError $ "Cancelled induction. Found no proof within given depth"
+     case (generateHints    &&& depth) indOpts of
+          (NoHints          , Nothing) -> cont k'
+          (NoHints          , Just l)  -> checkCont l k' (return [])
+          (LastInductionStep, Nothing) -> cont k'
+          (LastInductionStep, Just l)  ->
+            checkCont l k' (retrieveModel >>= \m -> return [Hint (show kVal) m])
+          (AllInductionSteps, Nothing) ->
+            do m <- retrieveModel
+               tell [Hint (show kVal) m]
+               cont k'
+          (AllInductionSteps, Just l)  ->
+            do m <- retrieveModel
+               tell $ [Hint (show kVal) m]
+               checkCont l k' (return [Hint (show kVal) m])
+  where
+    cont k' =
+      do indState@InductState {..} <- get
+         kDef' <- liftSMT . defConst $ succ' natAnn kDef
+         let pastKs' = Map.insert k' kDef' pastKs
+         put $ indState { kVal = k', kDef = kDef', pastKs = pastKs' }
+         inductCont
+    checkCont l k' m =
+      if k' < l
+      then cont k'
+      else m >>= \r ->
+           return $ Unknown
+                    "Cancelled induction. Found no proof within given depth"
+                    r
+--    retrieveModel :: (MonadSMT m, MonadState InductState) => m (Model i)
+    retrieveModel =
+      do InductState{..} <- get
+         liftSMT $ getModel pastKs
+-}
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 61388f0..72688a6 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -32,8 +32,9 @@ data NodeEnv i = NodeEnv
 
 data VarEnv i = VarEnv
                 { nodes :: Map i (NodeEnv i)
-                  -- | Maps names of variables to a SMT expression for using that variable
                 , vars :: Map i (TypedStream i)
+                  -- ^ Maps names of variables to a SMT expression for using
+                  -- that variable
                 }
 
 data Env i = Env

From 08ba8329e89db8003a51c47ac4d3421a12e9c707 Mon Sep 17 00:00:00 2001
From: Henning Basold <henning@basold.eu>
Date: Sun, 22 Jun 2014 19:48:13 +0200
Subject: [PATCH 004/104] Improve code layout

---
 lamaSMT/lib/Model.hs | 15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)

diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index 0787d31..6a3534b 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -61,15 +61,18 @@ prettyNodeModel m = braces . nest 2 $
 
 prettyStream :: ValueStream -> Doc
 prettyStream (BoolVStream s) = prettyStreamVals s
-prettyStream (IntVStream s) = prettyStreamVals s
+prettyStream (IntVStream s)  = prettyStreamVals s
 prettyStream (RealVStream s) = prettyStreamVals s
 prettyStream (EnumVStream s) = prettyStreamVals s
-prettyStream (ProdVStream s) = parens . hcat . punctuate comma . fmap prettyStream $ Arr.elems s
+prettyStream (ProdVStream s)
+             = parens . hcat . punctuate comma . fmap prettyStream $ Arr.elems s
 
 prettyStreamVals :: Show t => ValueStreamT t -> Doc
-prettyStreamVals = cat . punctuate (char ',')
-               . map (\(n, v) -> (integer $ toInteger n) <+> text "->" <+> text (show v))
-               . Map.toList
+prettyStreamVals
+        = cat . punctuate (char ',')
+          . map (\(n, v) ->
+                (integer $ toInteger n) <+> text "->" <+> text (show v))
+          . Map.toList
 
 getModel :: VarEnv i -> Map Natural StreamPos -> SMT (Model i)
 getModel env = runReaderT (getModel' env)
@@ -89,7 +92,7 @@ getVarsModel = mapM getVarModel
 
 getVarModel :: TypedStream i -> ModelM ValueStream
 getVarModel (BoolStream   s) = BoolVStream <$> getStreamValue s
-getVarModel (IntStream    s) = IntVStream <$> getStreamValue s
+getVarModel (IntStream    s) = IntVStream  <$> getStreamValue s
 getVarModel (RealStream   s) = RealVStream <$> getStreamValue s
 getVarModel (EnumStream _ s) = EnumVStream <$> getStreamValue s
 getVarModel (ProdStream   s) = ProdVStream <$> mapM getVarModel s

From 4846537fb3f8ae4a22ec6e6e2e9bd2b9e8949b8e Mon Sep 17 00:00:00 2001
From: Henning Basold <henning@basold.eu>
Date: Sun, 22 Jun 2014 19:48:56 +0200
Subject: [PATCH 005/104] Use hints feature in examples

---
 example/runBase.sh | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/example/runBase.sh b/example/runBase.sh
index a5d2f33..282aea2 100755
--- a/example/runBase.sh
+++ b/example/runBase.sh
@@ -10,7 +10,7 @@ if [ -z "$4" ]; then
 else
   d="$4";
 fi
-strategy="-s $3 -o depth=$d -o progress"
+strategy="-s $3 -o depth=$d -o progress -o hints"
 
 timefmt="%U user\n%S system\n%E elapsed\n%P CPU\n%Xkb text + %Dkb data -> %Kkb total + %Mkb max\n%I inputs + %O outputs\n%F major + %R minor pagefaults\n%W swaps"
 

From c7cdb289f4f669e180170e0439c43a0e5b6919dc Mon Sep 17 00:00:00 2001
From: Henning Basold <henning@basold.eu>
Date: Sun, 22 Jun 2014 19:50:59 +0200
Subject: [PATCH 006/104] Instance of MonadSMT for WriterT

---
 lamaSMT/lib/Internal/Monads.hs | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/lamaSMT/lib/Internal/Monads.hs b/lamaSMT/lib/Internal/Monads.hs
index 79837fb..16917aa 100644
--- a/lamaSMT/lib/Internal/Monads.hs
+++ b/lamaSMT/lib/Internal/Monads.hs
@@ -6,6 +6,7 @@ import Control.Monad.Error
 import Control.Monad.State.Lazy as Lazy
 import Control.Monad.State.Strict as Strict
 import Control.Monad.Reader
+import Control.Monad.Writer
 
 -- | Lift an SMT action into an arbitrary monad (like liftIO).
 class Monad m => MonadSMT m where
@@ -25,3 +26,6 @@ instance MonadSMT m => MonadSMT (Strict.StateT s m) where
 
 instance MonadSMT m => MonadSMT (ReaderT r m) where
   liftSMT = lift . liftSMT
+
+instance (Monoid w, MonadSMT m) => MonadSMT (WriterT w m) where
+  liftSMT = lift . liftSMT

From ecd520f0758f2b84a154cd3f43f8089ba1388c9d Mon Sep 17 00:00:00 2001
From: Henning Basold <henning@basold.eu>
Date: Sun, 22 Jun 2014 19:53:53 +0200
Subject: [PATCH 007/104] Removed dead (commented) code

---
 lamaSMT/lib/Strategies/KInduction.hs | 109 ---------------------------
 1 file changed, 109 deletions(-)

diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index 11da3b9..7377ba4 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -124,15 +124,6 @@ check' natAnn indOpts getModel defs =
          put $ indState { kVal = k', kDef = kDef', pastKs = pastKs' }
          check' natAnn indOpts getModel defs
 
---     r <- checkInvariant iDef invs >>=
---          checkGetModel getModel pastIndices
-{-
-        do getOpt
-             m <- getModel
-             tell m
-             return False
--}
-
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)
               -> KInduct
@@ -149,103 +140,3 @@ retrieveHints getModel indOpts k success =
          else return []
        (AllInductionSteps, _      ) ->
          getModel >>= \m -> return [Hint (show k) m]
-
--- | Checks whether the induction step could be proven. If not, then it can
--- return Nothing, to indicate that the next induction depth should be tried.
--- If the induction depth attained its bound, we stop with a StrategyResult.
--- In case of failure, the current model might be recorded/returned as hint.
--- If the step could be proven, Success is returned.
--- checkStepResult :: SMTAnnotation Natural
---      -> KInduct
---      -> Natural
---      -> Maybe (Hint i)
---      -> Bool
---      -> SMT (Maybe (StrategyResult i))
--- checkStepResult = undefined
-{-
-
--- | Checks whether the induction step could be proven. If not, then it can
--- return Nothing, to indicate that the next induction depth should be tried.
--- If the induction depth attained its bound, we stop with a StrategyResult.
--- In case of failure, the current model might be recorded/returned as hint.
--- If the step could be proven, Success is returned.
-checkStepResult :: (Map Natural StreamPos -> SMT (Model i))
-     -> SMTAnnotation Natural
-     -> KInduct
-     -> Natural
-     -> Bool
-     -> KInductM i (Maybe (StrategyResult i))
-checkStepResult getModel natAnn indOpts k' result =
-  if result
-  then return $ Just Success
-  else
-       case (generateHints    &&& depth) indOpts of
-            (NoHints          , Nothing) -> return Nothing
-            (NoHints          , Just l)  -> checkCont l k' (return [])
-            (LastInductionStep, Nothing) -> return Nothing
-            (LastInductionStep, Just l)  ->
-              checkCont l k' (retrieveModel
-                                >>= \m -> return [Hint (show kVal) m])
-            (AllInductionSteps, Nothing) ->
-              do m <- retrieveModel
-                 tell [Hint (show kVal) m]
-                 return Nothing
-            (AllInductionSteps, Just l)  ->
-              do m <- retrieveModel
-                 tell $ [Hint (show kVal) m]
-                 checkCont l k' (return [Hint (show kVal) m])
-  where
-    checkCont l k' m =
-      if k' < l
-      then return Nothing
-      else m >>= \r ->
-           return $ Just $ Unknown
-                    "Cancelled induction. Found no proof within given depth"
-                    r
-    retrieveModel =
-      do InductState{..} <- get
-         liftSMT $ getModel pastKs
--}
-{-
-getModelAndContinue
-     :: (Map Natural StreamPos -> SMT (Model i))
-     -> KInductM i (StrategyResult i)
-     -> SMTAnnotation Natural
-     -> KInduct
-     -> KInductM i (StrategyResult i)
-getModelAndContinue getModel inductCont natAnn indOpts =
-  do InductState {..} <- get
-     let k' = succ kVal
-     case (generateHints    &&& depth) indOpts of
-          (NoHints          , Nothing) -> cont k'
-          (NoHints          , Just l)  -> checkCont l k' (return [])
-          (LastInductionStep, Nothing) -> cont k'
-          (LastInductionStep, Just l)  ->
-            checkCont l k' (retrieveModel >>= \m -> return [Hint (show kVal) m])
-          (AllInductionSteps, Nothing) ->
-            do m <- retrieveModel
-               tell [Hint (show kVal) m]
-               cont k'
-          (AllInductionSteps, Just l)  ->
-            do m <- retrieveModel
-               tell $ [Hint (show kVal) m]
-               checkCont l k' (return [Hint (show kVal) m])
-  where
-    cont k' =
-      do indState@InductState {..} <- get
-         kDef' <- liftSMT . defConst $ succ' natAnn kDef
-         let pastKs' = Map.insert k' kDef' pastKs
-         put $ indState { kVal = k', kDef = kDef', pastKs = pastKs' }
-         inductCont
-    checkCont l k' m =
-      if k' < l
-      then cont k'
-      else m >>= \r ->
-           return $ Unknown
-                    "Cancelled induction. Found no proof within given depth"
-                    r
---    retrieveModel :: (MonadSMT m, MonadState InductState) => m (Model i)
-    retrieveModel =
-      do InductState{..} <- get
-         liftSMT $ getModel pastKs
--}

From 363fbd324204db2ce77a64bf70211e2b396984b0 Mon Sep 17 00:00:00 2001
From: Henning Basold <henning@basold.eu>
Date: Mon, 13 Oct 2014 20:54:38 +0200
Subject: [PATCH 008/104] Readme about installation etc.

---
 README.md | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 53 insertions(+)
 create mode 100644 README.md

diff --git a/README.md b/README.md
new file mode 100644
index 0000000..f8b5aee
--- /dev/null
+++ b/README.md
@@ -0,0 +1,53 @@
+Project structure
+================
+
+The project consists of four parts:
+ * language
+ * interpreter
+ * scade2lama
+ * lamaSMT
+The first contains the parser, type checker and dependency checker for the LAMA
+language.
+There is an interpreter for LAMA in the directory of the same name, so that one
+can run simulations.
+Next, we have the translator from SCADE to LAMA, to be found in "scade2lama".
+Last but not least, in lamaSMT the actual verfication of LAMA programs using SMT
+is implemented.
+
+Installation and Dependencies
+==============
+
+It is recommended to use cabal for installation.
+The "language" project does not require any special libraries, only alex and
+happy need to be installed.
+So after that, a simple "cabal install" in the "language" directory should
+suffice.
+All other subprojects require "language" to be installed.
+The installation of the interpreter is optional, usually it is not required.
+The "scade2lama" subproject requires the library "language-scade" to be
+installed, which is not on hackage.
+It can be found at https://github.com/hguenther/language-scade.
+Finally, the "lamaSMT" project requires additionally smtlib2 to be installed.
+This is located at https://github.com/hguenther/smtlib2.
+The last known version to work with this project is
+https://github.com/hguenther/smtlib2/tree/58ad9aa7e1c0ef2ba460667d03461e023c0a8a76,
+though it can be that more recent version work as well.
+
+Running
+========
+
+After installation, one might actually want to use the project.
+It is recommended to add the cabal binary directory (e.g., ~/.cabal/bin) to the
+PATH, to be able to easily run the installed programs (this might even be
+necessary during the installation, to run alex and happy).
+
+Having done this, the interpreter can be run with the command "lamai", the SCADE
+translator with "scade2lama" and the verification tool with "lamasmt".
+The latter requires z3 (https://z3.codeplex.com/) to installed and available in
+the PATH.
+
+Development
+===========
+
+The project development follows the guidelines for git projects at
+http://nvie.com/posts/a-successful-git-branching-model/.

From ee91d6d2ca02125a70ac0b1ad1f55f42af701dab Mon Sep 17 00:00:00 2001
From: Henning Basold <henning@basold.eu>
Date: Sun, 19 Apr 2015 23:01:55 +0200
Subject: [PATCH 009/104] Example of a proof by coinduction

This is just an exploration of how we _could_ implement
proofs without having to use functions Nat -> A that
represent streams.
---
 example/Switch-coinduction.smt | 156 +++++++++++++++++++++++++++++++++
 1 file changed, 156 insertions(+)
 create mode 100644 example/Switch-coinduction.smt

diff --git a/example/Switch-coinduction.smt b/example/Switch-coinduction.smt
new file mode 100644
index 0000000..31a3a2f
--- /dev/null
+++ b/example/Switch-coinduction.smt
@@ -0,0 +1,156 @@
+;; Implementation of Switch.lm by hand for exploration
+;; Proves the 3 given properties using (0-)coinduction.
+;; There are slight variants (commented) of those
+;; properties which are incorrect. Those give the
+;; expected counterexamples.
+
+;; node Switch
+(define-fun Switch_s_def ((on Bool) (off Bool) (s_1 Bool) (s Bool)) Bool
+  (= s
+     (ite s_1 (not off) on)))
+(define-fun Switch_s_1_def ((s Bool) (s_1_next Bool)) Bool
+  (= s_1_next
+     s ))
+(define-fun Switch_so_def ((so Bool) (s Bool)) Bool
+  (= so
+     s))
+
+;; Global flow
+(define-fun Switch_on_def ((Switch_on Bool) (on Bool)) Bool
+  (= Switch_on
+     on))
+(define-fun Switch_off_def ((Switch_off Bool) (off Bool)) Bool
+  (= Switch_off
+     off))
+(define-fun s_def ((Switch_so Bool) (s Bool)) Bool
+  (= s
+     Switch_so))
+(define-fun s_1_def ((s_1_next Bool) (s Bool)) Bool
+  (= s_1_next
+     s))
+
+;; properties
+(define-fun prop1 ((off Bool) (on Bool) (s Bool)) Bool
+;  (=> on s))
+  (=> (and on (not off)) s))
+(define-fun prop2 ((off Bool) (on Bool) (s Bool)) Bool
+;  (=> off (not s)))
+  (=> (and off (not on)) (not s)))
+(define-fun prop3 ((off Bool) (on Bool) (s Bool) (s_1 Bool)) Bool
+  (=> (and (not off) (not on)) (= s s_1)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Prove that initial state fulfils property
+
+(push)
+
+;; declarations
+(declare-fun Switch_on_0 () Bool)
+(declare-fun Switch_off_0 () Bool)
+(declare-fun Switch_so_0 () Bool)
+(declare-fun Switch_s_0 () Bool)
+(declare-fun Switch_s_1_0 () Bool)
+
+(declare-fun on_0 () Bool)
+(declare-fun off_0 () Bool)
+(declare-fun s_0 () Bool)
+(declare-fun s_1_0 () Bool)
+
+(declare-fun Switch_s_1_1 () Bool)
+(declare-fun s_1_1 () Bool)
+
+;; initialisation
+(assert (= Switch_s_1_0 false))
+(assert (= s_1_0 false))
+
+(assert (Switch_on_def Switch_on_0 on_0))
+(assert (Switch_off_def Switch_off_0 off_0))
+
+(assert (Switch_so_def Switch_so_0 Switch_s_0))
+(assert (Switch_s_def Switch_on_0 Switch_off_0 Switch_s_1_0 Switch_s_0))
+(assert (Switch_s_1_def Switch_s_0 Switch_s_1_1))
+
+(assert (s_def s_0 Switch_so_0))
+(assert (s_1_def s_1_1 s_0))
+
+;(assert (not (prop1 off_0 on_0 s_0)))
+(assert (not (prop2 off_0 on_0 s_0)))
+;(assert (not (prop3 off_0 on_0 s_0 s_1_0)))
+
+(check-sat)
+(get-model)
+(pop)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Prove that property is an invariant
+
+;; declarations
+(declare-fun Switch_on () Bool)
+(declare-fun Switch_off () Bool)
+(declare-fun Switch_so () Bool)
+(declare-fun Switch_s () Bool)
+(declare-fun Switch_s_1 () Bool)
+
+(declare-fun on () Bool)
+(declare-fun off () Bool)
+(declare-fun s () Bool)
+(declare-fun s_1 () Bool)
+
+(declare-fun Switch_s_1_n1 () Bool)
+(declare-fun s_1_n1 () Bool)
+
+(declare-fun Switch_on_n1 () Bool)
+(declare-fun Switch_off_n1 () Bool)
+(declare-fun Switch_so_n1 () Bool)
+(declare-fun Switch_s_n1 () Bool)
+
+(declare-fun on_n1 () Bool)
+(declare-fun off_n1 () Bool)
+(declare-fun s_n1 () Bool)
+
+(declare-fun Switch_s_1_n2 () Bool)
+(declare-fun s_1_n2 () Bool)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Assume that we start in a state in which the invariant holds
+
+;(assert (prop1 off on s))
+(assert (prop2 off on s))
+;(assert (prop3 off on s s_1))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Set up variables in starting state
+
+(assert (Switch_on_def Switch_on on))
+(assert (Switch_off_def Switch_off off))
+
+(assert (Switch_so_def Switch_so Switch_s))
+(assert (Switch_s_def Switch_on Switch_off Switch_s_1 Switch_s))
+(assert (Switch_s_1_def Switch_s Switch_s_1_n1))
+
+(assert (s_def s Switch_so))
+(assert (s_1_def s_1_n1 s))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Make transition
+
+(assert (Switch_on_def Switch_on_n1 on_n1))
+(assert (Switch_off_def Switch_off_n1 off_n1))
+
+(assert (Switch_so_def Switch_so_n1 Switch_s_n1))
+(assert (Switch_s_def Switch_on_n1 Switch_off_n1 Switch_s_1_n1 Switch_s_n1))
+(assert (Switch_s_1_def Switch_s_n1 Switch_s_1_n2))
+
+(assert (s_def s_n1 Switch_so_n1))
+(assert (s_1_def s_1_n2 s_n1))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Try to prove that property holds after transition
+(push)
+;(assert (not (prop1 off_n1 on_n1 s_n1)))
+(assert (not (prop2 off_n1 on_n1 s_n1)))
+;(assert (not (prop3 off_n1 on_n1 s_n1 s_1_n1)))
+
+(check-sat)
+(get-model)
+(pop)
\ No newline at end of file

From dc4e02616248e9131524d21a6bbdc86121af6285 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 7 Jul 2015 16:45:47 +0200
Subject: [PATCH 010/104] Rudementary functionality, variables not streams any
 more

---
 lamaSMT/Main.hs             |  7 +++--
 lamaSMT/lib/Model.hs        | 19 +++++++------
 lamaSMT/lib/Transform.hs    | 55 +++++++++++++++++++------------------
 lamaSMT/lib/TransformEnv.hs | 10 +++----
 4 files changed, 47 insertions(+), 44 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index 3840f8b..47eb06c 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -169,9 +169,10 @@ run opts@Options{..} file inp = do
   liftIO $ when optDumpLama (print p)
   model <- runCheck opts
     ( (liftSMT $ mapM_ setOption optSMTOpts) >>
-      lamaSMT optNatImpl optEnumImpl p >>=
-      (uncurry $ checkWithModel optNatImpl optStrategy) )
-  liftIO $ checkModel opts p model
+      lamaSMT optNatImpl optEnumImpl p) {- >>=
+      (uncurry $ checkWithModel optNatImpl optStrategy) ) -}
+  --liftIO $ checkModel opts p model
+  liftIO $ putStr "Test"
 
 checkErrors :: Either Error a -> MaybeT IO a
 checkErrors r = case r of
diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index 6a3534b..c78dfb1 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -87,20 +87,21 @@ getNodeModel :: NodeEnv i -> ModelM (NodeModel i)
 getNodeModel (NodeEnv i o e) =
   NodeModel <$> mapM getVarModel i <*> mapM getVarModel o <*> getModel' e
 
-getVarsModel :: Map i (TypedStream i) -> ModelM (Map i ValueStream)
+getVarsModel :: Map i (TypedExpr i) -> ModelM (Map i ValueStream)
 getVarsModel = mapM getVarModel
 
-getVarModel :: TypedStream i -> ModelM ValueStream
-getVarModel (BoolStream   s) = BoolVStream <$> getStreamValue s
-getVarModel (IntStream    s) = IntVStream  <$> getStreamValue s
-getVarModel (RealStream   s) = RealVStream <$> getStreamValue s
-getVarModel (EnumStream _ s) = EnumVStream <$> getStreamValue s
-getVarModel (ProdStream   s) = ProdVStream <$> mapM getVarModel s
+--TODO
+getVarModel :: TypedExpr i -> ModelM ValueStream
+getVarModel (BoolExpr s) = BoolVStream <$> getStreamValue s
+getVarModel (IntExpr  s) = IntVStream  <$> getStreamValue s
+getVarModel (RealExpr s) = RealVStream <$> getStreamValue s
+getVarModel (EnumExpr s) = EnumVStream <$> getStreamValue s
+getVarModel (ProdExpr s) = ProdVStream <$> mapM getVarModel s
 
-getStreamValue :: SMTValue t => Stream t -> ModelM (ValueStreamT t)
+getStreamValue :: SMTValue t => SMTExpr t -> ModelM (ValueStreamT t)
 getStreamValue s
   = ask >>=
-    liftSMT . mapM (\i -> getValue $ s `app` i)
+    liftSMT . mapM (\i -> getValue $ s)
 
 scadeScenario :: Ident i =>
               Program i -> [String] -> Model i -> Doc
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index a083b8f..3f41a28 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -84,11 +84,11 @@ declProgram p =
      putConstants (progConstantDefinitions p)
      declareEnums (progEnumDefinitions p)
      (declDefs, _) <- declareDecls Nothing Set.empty (progDecls p)
-     flowDefs <- declareFlow Nothing (progFlow p)
-     assertInits (progInitial p)
-     precondDef <- declarePrecond Nothing (progAssertion p)
-     invarDef <- declareInvariant Nothing (progInvariant p)
-     return $ ProgDefs (declDefs ++ flowDefs) precondDef invarDef
+     --flowDefs <- declareFlow Nothing (progFlow p)
+     --assertInits (progInitial p)
+     --precondDef <- declarePrecond Nothing (progAssertion p)
+     --invarDef <- declareInvariant Nothing (progInvariant p)
+     return $ ProgDefs (declDefs{- ++ flowDefs-}) (head declDefs) (head declDefs)-- precondDef invarDef
 
 -- | Declares common types etc.
 -- At the moment just Natural is defined.
@@ -125,42 +125,42 @@ declareDecls activeCond excludeNodes d =
   do let (excluded, toDeclare)
            = Map.partitionWithKey (\n _ -> n `Set.member` excludeNodes)
              $ declsNode d
-     defs <- mapM (uncurry $ declareNode activeCond) $ Map.toList toDeclare
+     --defs <- mapM (uncurry $ declareNode activeCond) $ Map.toList toDeclare
      inp <- declareVars $ declsInput d
      locs <- declareVars $ declsLocal d
      states <- declareVars $ declsState d
      modifyVars $ mappend (inp `mappend` locs `mappend` states)
-     return (concat defs, excluded)
+     return ({-concat defs-}[], excluded)
 
-declareVars :: Ident i => [Variable i] -> DeclM i (Map i (TypedStream i))
+declareVars :: Ident i => [Variable i] -> DeclM i (Map i (TypedExpr i))
 declareVars = fmap (Map.fromList) . declareVarList
 
-declareVarList :: Ident i => [Variable i] -> DeclM i ([(i, TypedStream i)])
+declareVarList :: Ident i => [Variable i] -> DeclM i ([(i, TypedExpr i)])
 declareVarList = mapM declareVar
 
-declareVar :: Ident i => Variable i -> DeclM i ((i, TypedStream i))
+declareVar :: Ident i => Variable i -> DeclM i ((i, TypedExpr i))
 declareVar (Variable x t) =
-  do natAnn <- gets natImpl
-     (x,) <$> typedVar (identString x) natAnn t
+  --do natAnn <- gets natImpl
+     (x,) <$> typedVar (identString x) t
   where
     typedVar :: Ident i =>
                 String
-                -> SMTAnnotation Natural
+                -- -> SMTAnnotation Natural
                 -> Type i
-                -> DeclM i (TypedStream i)
-    typedVar v ann (GroundType BoolT)
-      = liftSMT $ fmap BoolStream $ funAnnNamed v ann unit
-    typedVar v ann (GroundType IntT)
-      = liftSMT $ fmap IntStream $ funAnnNamed v ann unit
-    typedVar v ann (GroundType RealT)
-      = liftSMT $ fmap RealStream $ funAnnNamed v ann unit
-    typedVar v ann (GroundType _) = $notImplemented
-    typedVar v ann (EnumType et)
+                -> DeclM i (TypedExpr i)
+    typedVar v (GroundType BoolT)
+      = liftSMT $ fmap BoolExpr $ varNamed v
+    typedVar v (GroundType IntT)
+      = liftSMT $ fmap IntExpr $ varNamed v
+    typedVar v (GroundType RealT)
+      = liftSMT $ fmap RealExpr $ varNamed v
+    typedVar v (GroundType _) = $notImplemented
+    typedVar v (EnumType et)
       = do etAnn <- lookupEnumAnn et
-           liftSMT $ fmap (EnumStream etAnn) $ funAnnNamed v ann etAnn
-    typedVar v ann (ProdType ts) =
-      do vs <- mapM (typedVar (v ++ "_comp") ann) ts
-         return (ProdStream $ listArray (0, (length vs) - 1) vs)
+           liftSMT $ fmap EnumExpr $ varNamedAnn v etAnn
+    typedVar v (ProdType ts) =
+      do vs <- mapM (typedVar (v ++ "_comp")) ts
+         return (ProdExpr $ listArray (0, (length vs) - 1) vs)
 {-
 -- | Declares a stream of type Enum, including possible extra constraints on it.
 enumVar :: MonadSMT m
@@ -184,7 +184,7 @@ enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
 -- (using getNodesInLocations). Then all nodes _except_ those found before are
 -- declared. The other nodes are deferred to be declared in the corresponding
 -- location (see declareAutomaton and declareLocations).
-declareNode :: Ident i =>
+{-declareNode :: Ident i =>
                Maybe (Stream Bool) -> i -> Node i -> DeclM i [Definition]
 declareNode active nName nDecl =
   do (interface, defs) <- localVarEnv (const emptyVarEnv) $
@@ -785,3 +785,4 @@ applyOp Mul     e1 e2 = liftArithL mult [e1, e2]
 applyOp RealDiv e1 e2 = liftReal2 divide e1 e2
 applyOp IntDiv  e1 e2 = liftInt2 div' e1 e2
 applyOp Mod     e1 e2 = liftInt2 mod' e1 e2
+-}
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 72688a6..a266121 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -25,14 +25,14 @@ import LamaSMTTypes
 import Internal.Monads
 
 data NodeEnv i = NodeEnv
-                 { nodeEnvIn :: [TypedStream i]
-                 , nodeEnvOut :: [TypedStream i]
+                 { nodeEnvIn :: [TypedExpr i]
+                 , nodeEnvOut :: [TypedExpr i]
                  , nodeEnvVars :: VarEnv i
                  }
 
 data VarEnv i = VarEnv
                 { nodes :: Map i (NodeEnv i)
-                , vars :: Map i (TypedStream i)
+                , vars :: Map i (TypedExpr i)
                   -- ^ Maps names of variables to a SMT expression for using
                   -- that variable
                 }
@@ -74,7 +74,7 @@ modifyVarEnv f = modify $ \env -> env { varEnv = f $ varEnv env }
 modifyNodes :: (Map i (NodeEnv i) -> Map i (NodeEnv i)) -> DeclM i ()
 modifyNodes f = modifyVarEnv $ (\env -> env { nodes = f $ nodes env })
 
-modifyVars :: (Map i (TypedStream i) -> Map i (TypedStream i)) -> DeclM i ()
+modifyVars :: (Map i (TypedExpr i) -> Map i (TypedExpr i)) -> DeclM i ()
 modifyVars f = modifyVarEnv $ (\env -> env { vars = f $ vars env })
 
 lookupErr :: (MonadError e m, Ord k) => e -> k -> Map k v -> m v
@@ -82,7 +82,7 @@ lookupErr err k m = case Map.lookup k m of
   Nothing -> throwError err
   Just v -> return v
 
-lookupVar :: (MonadState (Env i) m, MonadError String m, Ident i) => i -> m (TypedStream i)
+lookupVar :: (MonadState (Env i) m, MonadError String m, Ident i) => i -> m (TypedExpr i)
 lookupVar x = gets (vars . varEnv) >>= lookupErr ("Unknown variable " ++ identPretty x) x
 
 lookupNode :: Ident i => i -> DeclM i (NodeEnv i)

From 98eb00163faceff2f0aee3746d93586e78ea28a1 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Fri, 28 Aug 2015 18:07:53 +0200
Subject: [PATCH 011/104] Implemented initialisation assertion

---
 lamaSMT/lib/Transform.hs | 14 +++++++++++---
 1 file changed, 11 insertions(+), 3 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 3f41a28..179626b 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -85,7 +85,7 @@ declProgram p =
      declareEnums (progEnumDefinitions p)
      (declDefs, _) <- declareDecls Nothing Set.empty (progDecls p)
      --flowDefs <- declareFlow Nothing (progFlow p)
-     --assertInits (progInitial p)
+     assertInits (progInitial p)
      --precondDef <- declarePrecond Nothing (progAssertion p)
      --invarDef <- declareInvariant Nothing (progInvariant p)
      return $ ProgDefs (declDefs{- ++ flowDefs-}) (head declDefs) (head declDefs)-- precondDef invarDef
@@ -655,6 +655,7 @@ mkTransitionEq activeCond locationEnumTy locationEnumConstrs act sel es =
                     -> Expr i
      locConsExpr locNames t loc
        = mkTyped (AtExpr $ AtomEnum ((Map.!) locNames loc)) t
+-}
 
 assertInits :: Ident i => StateInit i -> DeclM i ()
 assertInits = mapM_ assertInit . Map.toList
@@ -664,9 +665,10 @@ assertInit (x, e) =
   do natAnn <- gets natImpl
      x' <- lookupVar x
      e' <- trConstExpr e
-     let def = liftRel (.==.) (x' `appStream` (zero' natAnn)) e'
+     let def = liftRel (.==.) x' e'
      liftSMT $ liftAssert def
 
+{-
 -- | Creates a definition for a precondition p. If an activation condition c
 -- is given, the resulting condition is (=> c p).
 declarePrecond :: Ident i => Maybe (Stream Bool) -> Expr i -> DeclM i Definition
@@ -683,6 +685,7 @@ declarePrecond activeCond e =
 declareInvariant :: Ident i =>
                     Maybe (Stream Bool) -> Expr i -> DeclM i Definition
 declareInvariant = declarePrecond
+-}
 
 trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr i)
 trConstExpr (untyped -> Const c)
@@ -694,6 +697,7 @@ trConstExpr (untyped -> ConstProd (Prod cs)) =
 
 type TransM i = ReaderT (StreamPos, Env i) (Either String)
 
+{-
 doAppStream :: TypedStream i -> TransM i (TypedExpr i)
 doAppStream s = askStreamPos >>= return . appStream s
 
@@ -702,8 +706,9 @@ runTransM :: TransM i a -> Env i -> StreamPos -> a
 runTransM m e n = case runReaderT m (n, e) of
   Left err -> error err
   Right r -> r
+-}
 
-lookupVar' :: Ident i => i -> TransM i (TypedStream i)
+lookupVar' :: Ident i => i -> TransM i (TypedExpr i)
 lookupVar' x =
   do vs <- asks $ vars . varEnv . snd
      case Map.lookup x vs of
@@ -716,6 +721,7 @@ lookupEnumConsAnn' t
   = asks (enumConsAnn . snd)
     >>= lookupErr ("Unknown enum constructor " ++ identPretty t) t
 
+{-
 askStreamPos :: TransM i StreamPos
 askStreamPos = asks fst
 
@@ -761,6 +767,7 @@ trEnumMatch x pats =
       trEnumCons e >>= \y ->
       return $ liftRel (.==.) c (EnumExpr y)
     trEnumHead _ BottomPattern = return . BoolExpr $ constant True
+-}
 
 trEnumConsAnn :: Ident i =>
                  EnumConstr i -> SMTAnnotation SMTEnum -> SMTExpr SMTEnum
@@ -769,6 +776,7 @@ trEnumConsAnn x = constantAnn (SMTEnum . fromString $ identString x)
 trEnumCons :: Ident i => EnumConstr i -> TransM i (SMTExpr SMTEnum)
 trEnumCons x = lookupEnumConsAnn' x >>= return . trEnumConsAnn x
 
+{-
 applyOp :: BinOp -> TypedExpr i -> TypedExpr i -> TypedExpr i
 applyOp Or      e1 e2 = liftBoolL or'  [e1, e2]
 applyOp And     e1 e2 = liftBoolL and' [e1, e2]

From 3f4d597cdbd54b72d8e0be7f9e4b5a397d4eb7dd Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 1 Sep 2015 17:48:13 +0200
Subject: [PATCH 012/104] Invariant and precondition implemented, but with only
 one boolean argument

---
 lamaSMT/lib/Definition.hs   | 14 +++++------
 lamaSMT/lib/LamaSMTTypes.hs | 39 ++++++++++++++++++++++++++++++-
 lamaSMT/lib/Transform.hs    | 46 +++++++++++++++++--------------------
 lamaSMT/lib/TransformEnv.hs | 25 ++++++++++++++++++++
 4 files changed, 91 insertions(+), 33 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 873ecf4..04f8403 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -8,22 +8,22 @@ import LamaSMTTypes
 import Internal.Monads
 
 data Definition =
-  SingleDef (Stream Bool)
+  SingleDef (SMTFunction (SMTExpr Bool) Bool)
   | ProdDef (Array Int Definition)
---  deriving Show
+  deriving Show
 
-ensureDefinition :: TypedStream i -> Definition
-ensureDefinition (BoolStream s) = SingleDef s
-ensureDefinition (ProdStream ps) = ProdDef $ fmap ensureDefinition ps
+ensureDefinition :: TypedFunc i -> Definition
+ensureDefinition (BoolFunc s) = SingleDef s
+ensureDefinition (ProdFunc ps) = ProdDef $ fmap ensureDefinition ps
 ensureDefinition _
-  = error $ "ensureDefinition: not a boolean stream" -- : " ++ show s
+  = error $ "ensureDefinition: not a boolean function" -- : " ++ show s
 
 assertDefinition :: MonadSMT m =>
                     (SMTExpr Bool -> SMTExpr Bool)
                     -> StreamPos
                     -> Definition
                     -> m ()
-assertDefinition f i (SingleDef s) = liftSMT $ assert (f $ s `app` i)
+assertDefinition f i (SingleDef s) = do return ()--liftSMT $ assert (f $ s `app` i)
 assertDefinition f i (ProdDef ps) = mapM_ (assertDefinition f i) $ Arr.elems ps
 
 data ProgDefs = ProgDefs
diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index 599fb1d..6f0ccdf 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -29,6 +29,43 @@ unProd' :: TypedExpr i -> Array Int (TypedExpr i)
 unProd' (ProdExpr e) = e
 unProd' e = error $ "Cannot unProd: " ++ show e
 
+data TypedFunc i
+  = BoolFunc (SMTFunction (SMTExpr Bool) Bool)
+  | IntFunc (SMTFunction (SMTExpr Bool) Integer)
+  | RealFunc (SMTFunction (SMTExpr Bool) Rational)
+  | EnumFunc EnumAnn (SMTFunction (SMTExpr Bool) SMTEnum)
+  | ProdFunc (Array Int (TypedFunc i))
+  deriving Show
+
+mkProdFunc :: [TypedFunc i] -> TypedFunc i
+mkProdFunc [] = error "Cannot create empty product stream"
+mkProdFunc [s] = s
+mkProdFunc sts = ProdFunc . uncurry listArray $ ((0,) . pred . length &&& id) sts
+
+appFunc :: TypedFunc i -> SMTExpr Bool -> TypedExpr i
+appFunc (BoolFunc f) arg = BoolExpr $ f `app` arg
+appFunc (IntFunc f) arg = IntExpr $ f `app` arg
+appFunc (RealFunc f) arg = RealExpr $ f `app` arg
+appFunc (EnumFunc _ f) arg = EnumExpr $ f `app` arg
+appFunc (ProdFunc f) arg = ProdExpr $ fmap (`appFunc` arg) f
+
+{-instance (SMTExpr i) => Args (TypedExpr i) where
+  type ArgAnnotation (TypedExpr i) = SMTAnnotation i
+  foldExprs f = f
+  foldsExprs f = f
+  extractArgAnnotation (BoolExpr expr) = extractAnnotation expr
+  toArgs _ (x:xs) = do
+    r <- entype gcast x
+    return (r,xs)
+  toArgs _ [] = Nothing
+  fromArgs x = [UntypedExpr x]
+  getSorts (_::SMTExpr a) ann = [getSort (undefined::a) ann]
+  getArgAnnotation u (s:rest) = (annotationFromSort (getUndef u) s,rest)
+  getArgAnnotation _ [] = error "smtlib2: To few sorts provided."
+  showsArgs = showExpr-}
+
+------------------------------
+
 type StreamPos = SMTExpr Natural
 type Stream t = SMTFunction StreamPos t
 data TypedStream i
@@ -37,7 +74,7 @@ data TypedStream i
   | RealStream (Stream Rational)
   | EnumStream EnumAnn (Stream SMTEnum)
   | ProdStream (Array Int (TypedStream i))
---  deriving Show
+  deriving Show
 
 mkProdStream :: [TypedStream i] -> TypedStream i
 mkProdStream [] = error "Cannot create empty product stream"
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 179626b..b503f13 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -15,6 +15,8 @@
 
 module Transform where
 
+import Debug.Trace
+
 import Development.Placeholders
 
 import Lang.LAMA.Identifier
@@ -86,9 +88,9 @@ declProgram p =
      (declDefs, _) <- declareDecls Nothing Set.empty (progDecls p)
      --flowDefs <- declareFlow Nothing (progFlow p)
      assertInits (progInitial p)
-     --precondDef <- declarePrecond Nothing (progAssertion p)
-     --invarDef <- declareInvariant Nothing (progInvariant p)
-     return $ ProgDefs (declDefs{- ++ flowDefs-}) (head declDefs) (head declDefs)-- precondDef invarDef
+     precondDef <- declarePrecond Nothing (progAssertion p)
+     invarDef <- declareInvariant Nothing (progInvariant p)
+     return $ ProgDefs (declDefs{- ++ flowDefs-}) precondDef invarDef
 
 -- | Declares common types etc.
 -- At the moment just Natural is defined.
@@ -668,24 +670,22 @@ assertInit (x, e) =
      let def = liftRel (.==.) x' e'
      liftSMT $ liftAssert def
 
-{-
 -- | Creates a definition for a precondition p. If an activation condition c
 -- is given, the resulting condition is (=> c p).
-declarePrecond :: Ident i => Maybe (Stream Bool) -> Expr i -> DeclM i Definition
+declarePrecond :: Ident i => Maybe (SMTFunction (SMTExpr Bool) Bool) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
   do env <- get
      d <- case activeCond of
-       Nothing -> defStream boolT $ \t -> runTransM (trExpr e) env t
-       Just c -> defStream boolT $
-                 \t -> (flip (flip runTransM env) t)
-                       (trExpr e >>= \e' ->
-                         return $ liftBool2 (.=>.) (BoolExpr $ c `app` t) e')
-     return $ ensureDefinition d
+       Nothing -> defFunc boolT $ \a -> runTransM (trExpr e) env a
+       Just c -> defFunc boolT $
+                 \a -> (flip (flip runTransM env) a)
+		       (trExpr e >>= \e' ->
+                         return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
+     return $ trace ("Precond " ++ show d) $ ensureDefinition d
 
 declareInvariant :: Ident i =>
-                    Maybe (Stream Bool) -> Expr i -> DeclM i Definition
+                    Maybe (SMTFunction (SMTExpr Bool) Bool) -> Expr i -> DeclM i Definition
 declareInvariant = declarePrecond
--}
 
 trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr i)
 trConstExpr (untyped -> Const c)
@@ -695,18 +695,18 @@ trConstExpr (untyped -> ConstEnum x)
 trConstExpr (untyped -> ConstProd (Prod cs)) =
   ProdExpr . listArray (0, length cs - 1) <$> mapM trConstExpr cs
 
-type TransM i = ReaderT (StreamPos, Env i) (Either String)
+type TransM i = ReaderT (SMTExpr Bool, Env i) (Either String)
 
 {-
 doAppStream :: TypedStream i -> TransM i (TypedExpr i)
 doAppStream s = askStreamPos >>= return . appStream s
+-}
 
 -- beware: uses error
-runTransM :: TransM i a -> Env i -> StreamPos -> a
-runTransM m e n = case runReaderT m (n, e) of
+runTransM :: TransM i a -> Env i -> SMTExpr Bool -> a
+runTransM m e a = case runReaderT m (a, e) of
   Left err -> error err
   Right r -> r
--}
 
 lookupVar' :: Ident i => i -> TransM i (TypedExpr i)
 lookupVar' x =
@@ -724,6 +724,7 @@ lookupEnumConsAnn' t
 {-
 askStreamPos :: TransM i StreamPos
 askStreamPos = asks fst
+-}
 
 -- we do no further type checks since this
 -- has been done beforehand.
@@ -732,8 +733,7 @@ trExpr expr = case untyped expr of
   AtExpr (AtomConst c) -> return $ trConstant c
   AtExpr (AtomVar x)   ->
     do s <- lookupVar' x
-       n <- askStreamPos
-       return $ s `appStream` n
+       return s
   AtExpr (AtomEnum x)  -> EnumExpr <$> trEnumCons x
   LogNot e             -> lift1Bool not' <$> trExpr e
   Expr2 op e1 e2       -> applyOp op <$> trExpr e1 <*> trExpr e2
@@ -741,9 +741,8 @@ trExpr expr = case untyped expr of
   ProdCons (Prod es)   -> (ProdExpr . listArray (0, (length es) - 1))
                           <$> mapM trExpr es
   Project x i          ->
-    do (ProdStream s) <- lookupVar' x
-       n <- askStreamPos
-       return $ (s ! fromEnum i) `appStream` n
+    do (ProdExpr s) <- lookupVar' x
+       return $ (s ! fromEnum i)
   Match e pats         -> trExpr e >>= flip trPattern pats
 
 trPattern :: Ident i => TypedExpr i -> [Pattern i] -> TransM i (TypedExpr i)
@@ -767,7 +766,6 @@ trEnumMatch x pats =
       trEnumCons e >>= \y ->
       return $ liftRel (.==.) c (EnumExpr y)
     trEnumHead _ BottomPattern = return . BoolExpr $ constant True
--}
 
 trEnumConsAnn :: Ident i =>
                  EnumConstr i -> SMTAnnotation SMTEnum -> SMTExpr SMTEnum
@@ -776,7 +774,6 @@ trEnumConsAnn x = constantAnn (SMTEnum . fromString $ identString x)
 trEnumCons :: Ident i => EnumConstr i -> TransM i (SMTExpr SMTEnum)
 trEnumCons x = lookupEnumConsAnn' x >>= return . trEnumConsAnn x
 
-{-
 applyOp :: BinOp -> TypedExpr i -> TypedExpr i -> TypedExpr i
 applyOp Or      e1 e2 = liftBoolL or'  [e1, e2]
 applyOp And     e1 e2 = liftBoolL and' [e1, e2]
@@ -793,4 +790,3 @@ applyOp Mul     e1 e2 = liftArithL mult [e1, e2]
 applyOp RealDiv e1 e2 = liftReal2 divide e1 e2
 applyOp IntDiv  e1 e2 = liftInt2 div' e1 e2
 applyOp Mod     e1 e2 = liftInt2 mod' e1 e2
--}
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index a266121..6c6d636 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -144,6 +144,31 @@ defStream ty sf = gets natImpl >>= \natAnn -> defStream' natAnn ty sf
          return . ProdStream $ listArray (0,u) x
       where defParts (ty2, i) = defStream' natAnn ty2 ((! i) . unProd' . f)
 
+-- | Defines a function instead of streams
+defFunc :: Ident i =>
+             Type i -> (SMTExpr Bool -> TypedExpr i) -> DeclM i (TypedFunc i)
+defFunc (GroundType BoolT) f = liftSMT . fmap BoolFunc $
+                                defFun (unBool' . f)
+defFunc (GroundType IntT) f = liftSMT . fmap IntFunc $
+                                defFun (unInt . f)
+defFunc (GroundType RealT) f = liftSMT . fmap RealFunc $
+                               defFun (unReal . f)
+defFunc (GroundType _) f = $notImplemented
+defFunc (EnumType alias) f = do ann <- lookupEnumAnn alias
+                                liftSMT $ fmap (EnumFunc ann) $
+                                 defFun (unEnum . f)
+-- We have to pull the product out of a stream.
+-- If we are given a function f : FuncPos -> (Ix -> TE) = TypedExpr as above,
+-- we would like to have as result something like:
+-- g : Ix -> (FuncPos -> TE)
+-- g(i)(t) = defFunc(λt'.f(t')(i))(t)
+-- Here i is the index into the product and t,t' are time variables.
+defFunc (ProdType ts) f =
+  do let u = length ts - 1
+     x <- mapM defParts $ zip ts [0..u]
+     return . ProdFunc $ listArray (0,u) x
+  where defParts (ty2, i) = defFunc ty2 ((! i) . unProd' . f)
+
 -- stream :: Ident i => Type i -> DeclM i (Stream t)
 
 trConstant :: Ident i => Constant i -> TypedExpr i

From beba56224f33d2770c283dc14d986a1effc22c84 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 3 Sep 2015 18:47:53 +0200
Subject: [PATCH 013/104] Argument is now a list of boolean expressions

---
 lamaSMT/lib/Definition.hs   |  2 +-
 lamaSMT/lib/LamaSMTTypes.hs | 10 +++++-----
 lamaSMT/lib/Transform.hs    |  8 ++++----
 lamaSMT/lib/TransformEnv.hs |  3 ++-
 lamaSMT/lib/Unit.hs         | 30 ++++++++++++++++++++++++++++++
 5 files changed, 42 insertions(+), 11 deletions(-)
 create mode 100644 lamaSMT/lib/Unit.hs

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 04f8403..3aaafa7 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -8,7 +8,7 @@ import LamaSMTTypes
 import Internal.Monads
 
 data Definition =
-  SingleDef (SMTFunction (SMTExpr Bool) Bool)
+  SingleDef (SMTFunction [SMTExpr Bool] Bool)
   | ProdDef (Array Int Definition)
   deriving Show
 
diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index 6f0ccdf..a36d6e5 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -30,10 +30,10 @@ unProd' (ProdExpr e) = e
 unProd' e = error $ "Cannot unProd: " ++ show e
 
 data TypedFunc i
-  = BoolFunc (SMTFunction (SMTExpr Bool) Bool)
-  | IntFunc (SMTFunction (SMTExpr Bool) Integer)
-  | RealFunc (SMTFunction (SMTExpr Bool) Rational)
-  | EnumFunc EnumAnn (SMTFunction (SMTExpr Bool) SMTEnum)
+  = BoolFunc (SMTFunction [SMTExpr Bool] Bool)
+  | IntFunc (SMTFunction [SMTExpr Bool] Integer)
+  | RealFunc (SMTFunction [SMTExpr Bool] Rational)
+  | EnumFunc EnumAnn (SMTFunction [SMTExpr Bool] SMTEnum)
   | ProdFunc (Array Int (TypedFunc i))
   deriving Show
 
@@ -42,7 +42,7 @@ mkProdFunc [] = error "Cannot create empty product stream"
 mkProdFunc [s] = s
 mkProdFunc sts = ProdFunc . uncurry listArray $ ((0,) . pred . length &&& id) sts
 
-appFunc :: TypedFunc i -> SMTExpr Bool -> TypedExpr i
+appFunc :: TypedFunc i -> [SMTExpr Bool] -> TypedExpr i
 appFunc (BoolFunc f) arg = BoolExpr $ f `app` arg
 appFunc (IntFunc f) arg = IntExpr $ f `app` arg
 appFunc (RealFunc f) arg = RealExpr $ f `app` arg
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index b503f13..c640247 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -672,7 +672,7 @@ assertInit (x, e) =
 
 -- | Creates a definition for a precondition p. If an activation condition c
 -- is given, the resulting condition is (=> c p).
-declarePrecond :: Ident i => Maybe (SMTFunction (SMTExpr Bool) Bool) -> Expr i -> DeclM i Definition
+declarePrecond :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
   do env <- get
      d <- case activeCond of
@@ -684,7 +684,7 @@ declarePrecond activeCond e =
      return $ trace ("Precond " ++ show d) $ ensureDefinition d
 
 declareInvariant :: Ident i =>
-                    Maybe (SMTFunction (SMTExpr Bool) Bool) -> Expr i -> DeclM i Definition
+                    Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
 declareInvariant = declarePrecond
 
 trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr i)
@@ -695,7 +695,7 @@ trConstExpr (untyped -> ConstEnum x)
 trConstExpr (untyped -> ConstProd (Prod cs)) =
   ProdExpr . listArray (0, length cs - 1) <$> mapM trConstExpr cs
 
-type TransM i = ReaderT (SMTExpr Bool, Env i) (Either String)
+type TransM i = ReaderT ([SMTExpr Bool], Env i) (Either String)
 
 {-
 doAppStream :: TypedStream i -> TransM i (TypedExpr i)
@@ -703,7 +703,7 @@ doAppStream s = askStreamPos >>= return . appStream s
 -}
 
 -- beware: uses error
-runTransM :: TransM i a -> Env i -> SMTExpr Bool -> a
+runTransM :: TransM i a -> Env i -> [SMTExpr Bool] -> a
 runTransM m e a = case runReaderT m (a, e) of
   Left err -> error err
   Right r -> r
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 6c6d636..954a857 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -19,6 +19,7 @@ import Data.Traversable
 import Control.Monad.State (StateT(..), MonadState(..), modify, gets)
 import Control.Monad.Error (ErrorT(..), MonadError(..))
 
+import Unit
 import SMTEnum
 import NatInstance
 import LamaSMTTypes
@@ -146,7 +147,7 @@ defStream ty sf = gets natImpl >>= \natAnn -> defStream' natAnn ty sf
 
 -- | Defines a function instead of streams
 defFunc :: Ident i =>
-             Type i -> (SMTExpr Bool -> TypedExpr i) -> DeclM i (TypedFunc i)
+             Type i -> ([SMTExpr Bool] -> TypedExpr i) -> DeclM i (TypedFunc i)
 defFunc (GroundType BoolT) f = liftSMT . fmap BoolFunc $
                                 defFun (unBool' . f)
 defFunc (GroundType IntT) f = liftSMT . fmap IntFunc $
diff --git a/lamaSMT/lib/Unit.hs b/lamaSMT/lib/Unit.hs
new file mode 100644
index 0000000..e731f44
--- /dev/null
+++ b/lamaSMT/lib/Unit.hs
@@ -0,0 +1,30 @@
+module Unit where
+
+import Data.Unit
+
+{-
+class Unit t where
+    -- | Constructs a unit type
+    unit :: t
+
+instance Unit () where
+    unit = ()
+
+instance (Unit a,Unit b) => Unit (a,b) where
+    unit = (unit,unit)
+
+instance (Unit a,Unit b,Unit c) => Unit (a,b,c) where
+    unit = (unit,unit,unit)
+
+instance (Unit a,Unit b,Unit c,Unit d) => Unit (a,b,c,d) where
+    unit = (unit,unit,unit,unit)
+
+instance (Unit a,Unit b,Unit c,Unit d,Unit e) => Unit (a,b,c,d,e) where
+    unit = (unit,unit,unit,unit,unit)
+
+instance (Unit a,Unit b,Unit c,Unit d,Unit e,Unit f) => Unit (a,b,c,d,e,f) where
+    unit = (unit,unit,unit,unit,unit,unit)
+-}
+
+instance (Unit a) => Unit ([a]) where
+    unit = ([unit])

From 42c2ccc58fecd86c114da72ac6342f2413a71e89 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 10 Sep 2015 03:42:36 +0200
Subject: [PATCH 014/104] Arguments now connected to function body

Functions for preconditions and invariant
now have the correct argument count and the
arguments are used in correctly in the function
body.
---
 lamaSMT/lib/Transform.hs    | 35 +++++++++++++++++++++++++----------
 lamaSMT/lib/TransformEnv.hs | 27 ++++++++++++++-------------
 2 files changed, 39 insertions(+), 23 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index c640247..e490731 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -31,7 +31,7 @@ import Data.Array as Arr
 import Data.Natural
 import NatInstance
 import qualified Data.Set as Set
-import Data.Set (Set)
+import Data.Set (Set, union, unions)
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Prelude hiding (mapM)
@@ -42,7 +42,7 @@ import Data.Monoid
 import Control.Monad.Trans.Class
 import Control.Monad.State (StateT(..), MonadState(..), gets)
 import Control.Monad.Error (ErrorT(..), MonadError(..))
-import Control.Monad.Reader (ReaderT(..), asks)
+import Control.Monad.Reader (ReaderT(..), ask, asks)
 import Control.Applicative (Applicative(..), (<$>))
 import Control.Arrow ((&&&), second)
 
@@ -676,9 +676,9 @@ declarePrecond :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -
 declarePrecond activeCond e =
   do env <- get
      d <- case activeCond of
-       Nothing -> defFunc boolT $ \a -> runTransM (trExpr e) env a
-       Just c -> defFunc boolT $
-                 \a -> (flip (flip runTransM env) a)
+       Nothing -> defFunc (Set.size $ getArgSet e) boolT $ \a -> runTransM (trExpr e) env (zip (Set.toList $ getArgSet e) a)
+       Just c -> defFunc (Set.size $ getArgSet e) boolT $
+                 \a -> (flip (flip runTransM env) (zip (Set.toList $ getArgSet e) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
      return $ trace ("Precond " ++ show d) $ ensureDefinition d
@@ -695,7 +695,7 @@ trConstExpr (untyped -> ConstEnum x)
 trConstExpr (untyped -> ConstProd (Prod cs)) =
   ProdExpr . listArray (0, length cs - 1) <$> mapM trConstExpr cs
 
-type TransM i = ReaderT ([SMTExpr Bool], Env i) (Either String)
+type TransM i = ReaderT ([(i, SMTExpr Bool)], Env i) (Either String)
 
 {-
 doAppStream :: TypedStream i -> TransM i (TypedExpr i)
@@ -703,7 +703,7 @@ doAppStream s = askStreamPos >>= return . appStream s
 -}
 
 -- beware: uses error
-runTransM :: TransM i a -> Env i -> [SMTExpr Bool] -> a
+runTransM :: TransM i a -> Env i -> [(i, SMTExpr Bool)] -> a
 runTransM m e a = case runReaderT m (a, e) of
   Left err -> error err
   Right r -> r
@@ -726,14 +726,29 @@ askStreamPos :: TransM i StreamPos
 askStreamPos = asks fst
 -}
 
+getArgSet :: Ident i => Expr i -> Set i
+getArgSet expr = case untyped expr of
+  AtExpr (AtomConst c) -> Set.empty
+  AtExpr (AtomVar x)   -> Set.singleton x
+  AtExpr (AtomEnum x)  -> Set.empty
+  LogNot e             -> getArgSet e
+  Expr2 op e1 e2       -> Set.union (getArgSet e1) (getArgSet e2)
+  Ite c e1 e2          -> Set.unions [getArgSet c, getArgSet e1, getArgSet e2]
+  ProdCons (Prod es)   -> foldr (union . getArgSet) Set.empty es
+  Project x i          -> Set.empty
+  Match e pats         -> getArgSet e
+
+
 -- we do no further type checks since this
 -- has been done beforehand.
 trExpr :: Ident i => Expr i -> TransM i (TypedExpr i)
 trExpr expr = case untyped expr of
   AtExpr (AtomConst c) -> return $ trConstant c
-  AtExpr (AtomVar x)   ->
-    do s <- lookupVar' x
-       return s
+  AtExpr (AtomVar x)   -> do
+                            s <- ask
+                            case lookup x (fst s) of
+                              Nothing -> throwError $ "No argument binding for " ++ identPretty x
+                              Just n -> return $ BoolExpr n
   AtExpr (AtomEnum x)  -> EnumExpr <$> trEnumCons x
   LogNot e             -> lift1Bool not' <$> trExpr e
   Expr2 op e1 e2       -> applyOp op <$> trExpr e1 <*> trExpr e2
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 954a857..4418436 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -15,6 +15,7 @@ import qualified Data.Map as Map
 import Data.Map (Map)
 import Prelude hiding (mapM)
 import Data.Traversable
+import Data.List (replicate)
 
 import Control.Monad.State (StateT(..), MonadState(..), modify, gets)
 import Control.Monad.Error (ErrorT(..), MonadError(..))
@@ -147,28 +148,28 @@ defStream ty sf = gets natImpl >>= \natAnn -> defStream' natAnn ty sf
 
 -- | Defines a function instead of streams
 defFunc :: Ident i =>
-             Type i -> ([SMTExpr Bool] -> TypedExpr i) -> DeclM i (TypedFunc i)
-defFunc (GroundType BoolT) f = liftSMT . fmap BoolFunc $
-                                defFun (unBool' . f)
-defFunc (GroundType IntT) f = liftSMT . fmap IntFunc $
-                                defFun (unInt . f)
-defFunc (GroundType RealT) f = liftSMT . fmap RealFunc $
-                               defFun (unReal . f)
-defFunc (GroundType _) f = $notImplemented
-defFunc (EnumType alias) f = do ann <- lookupEnumAnn alias
-                                liftSMT $ fmap (EnumFunc ann) $
-                                 defFun (unEnum . f)
+             Int -> Type i -> ([SMTExpr Bool] -> TypedExpr i) -> DeclM i (TypedFunc i)
+defFunc i (GroundType BoolT) f = liftSMT . fmap BoolFunc $
+                                defFunAnn (replicate i ()) (unBool' . f)
+defFunc i (GroundType IntT) f = liftSMT . fmap IntFunc $
+                                defFunAnn (replicate i ()) (unInt . f)
+defFunc i (GroundType RealT) f = liftSMT . fmap RealFunc $
+                               defFunAnn (replicate i ()) (unReal . f)
+defFunc i (GroundType _) f = $notImplemented
+defFunc i (EnumType alias) f = do ann <- lookupEnumAnn alias
+                                  liftSMT $ fmap (EnumFunc ann) $
+                                   defFunAnn (replicate i ()) (unEnum . f)
 -- We have to pull the product out of a stream.
 -- If we are given a function f : FuncPos -> (Ix -> TE) = TypedExpr as above,
 -- we would like to have as result something like:
 -- g : Ix -> (FuncPos -> TE)
 -- g(i)(t) = defFunc(λt'.f(t')(i))(t)
 -- Here i is the index into the product and t,t' are time variables.
-defFunc (ProdType ts) f =
+defFunc i (ProdType ts) f =
   do let u = length ts - 1
      x <- mapM defParts $ zip ts [0..u]
      return . ProdFunc $ listArray (0,u) x
-  where defParts (ty2, i) = defFunc ty2 ((! i) . unProd' . f)
+  where defParts (ty2, i) = defFunc i ty2 ((! i) . unProd' . f)
 
 -- stream :: Ident i => Type i -> DeclM i (Stream t)
 

From 603474eb8fee37e4dfdb621d2534acfabd1e5b36 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 15 Sep 2015 00:28:05 +0200
Subject: [PATCH 015/104] FlowDefs working if no nodes and activeCond used

---
 lamaSMT/lib/Transform.hs | 91 +++++++++++++++++++++-------------------
 1 file changed, 47 insertions(+), 44 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index e490731..1c4bf63 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -52,17 +52,17 @@ import Definition
 import TransformEnv
 import Internal.Monads
 
--- | Gets an "undefined" value for a given type of stream.
--- The stream itself is not further analysed.
+-- | Gets an "undefined" value for a given type of expression.
+-- The expression itself is not further analysed.
 -- FIXME: Make behaviour configurable, i.e. bottom can be some
 -- default value or a left open stream
 -- (atm it does the former).
-getBottom :: TypedStream i -> TypedExpr i
-getBottom (BoolStream _)     = BoolExpr $ constant False
-getBottom (IntStream _)      = IntExpr  $ constant 0xdeadbeef
-getBottom (RealStream _)     = RealExpr . constant $ fromInteger 0xdeadbeef
-getBottom (EnumStream ann _) = EnumExpr $ constantAnn (enumBottom ann) ann
-getBottom (ProdStream strs)  = ProdExpr $ fmap getBottom strs
+getBottom :: TypedExpr i -> TypedExpr i
+getBottom (BoolExpr _)     = BoolExpr $ constant False
+getBottom (IntExpr _)      = IntExpr  $ constant 0xdeadbeef
+getBottom (RealExpr _)     = RealExpr . constant $ fromInteger 0xdeadbeef
+getBottom (EnumExpr e) = EnumExpr e --evtl. TODO
+getBottom (ProdExpr strs)  = ProdExpr $ fmap getBottom strs
 
 -- | Transforms a LAMA program into a set of formulas which is
 -- directly declared and a set of defining functions. Those functions
@@ -86,7 +86,7 @@ declProgram p =
      putConstants (progConstantDefinitions p)
      declareEnums (progEnumDefinitions p)
      (declDefs, _) <- declareDecls Nothing Set.empty (progDecls p)
-     --flowDefs <- declareFlow Nothing (progFlow p)
+     flowDefs <- declareFlow Nothing (progFlow p)
      assertInits (progInitial p)
      precondDef <- declarePrecond Nothing (progAssertion p)
      invarDef <- declareInvariant Nothing (progInvariant p)
@@ -225,42 +225,43 @@ getNodesInLocations = mconcat . map getUsedLoc . automLocations
     getUsedLoc (Location _ flow) = mconcat . map getUsed $ flowDefinitions flow
     getUsed (NodeUsage _ n _) = Set.singleton n
     getUsed _ = Set.empty
+-}
 
 -- | Creates definitions for instant definitions. In case of a node usage this
 -- may produce multiple definitions. If 
 declareInstantDef :: Ident i =>
-                     Maybe (Stream Bool)
+                     Maybe (SMTExpr Bool)
                      -> InstantDefinition i
                      -> DeclM i [Definition]
-declareInstantDef activeCond inst@(InstantExpr x _) =
+declareInstantDef activeCond inst@(InstantExpr x e) =
   do (res, []) <- trInstant (error "no activation condition") inst
-     xStream <- lookupVar x
+     xVar <- lookupVar x
      def <- declareConditionalAssign
-            activeCond id (const $ getBottom xStream) xStream res
+            activeCond (getBottom xVar) xVar (getArgSet e) res
      return [def]
-declareInstantDef activeCond inst@(NodeUsage x _ _) =
+{-declareInstantDef activeCond inst@(NodeUsage x _ _) =
   do (outp, inpDefs) <- trInstant activeCond inst
-     xStream         <- lookupVar x
+     xVar         <- lookupVar x
      outpDef         <- declareConditionalAssign
-                        activeCond id (const $ getBottom xStream) xStream outp
+                        activeCond id (getBottom xVar) xVar (getArgSet x) outp
      return $ inpDefs ++ [outpDef]
+-}
 
 -- | Translates an instant definition into a function which can be
 -- used to further refine this instant (e.g. wrap it into an ite).
 -- This may also return definitions of the parameters of a node.
 -- The activation condition is only used for the inputs of a node.
-trInstant :: Ident i => Maybe (Stream Bool) -> InstantDefinition i ->
-             DeclM i (Env i -> StreamPos -> TypedExpr i, [Definition])
+trInstant :: Ident i => Maybe (SMTExpr Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i, [Definition])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
-trInstant inpActive (NodeUsage _ n es) =
+{-trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
      let esTr = map (runTransM . trExpr) es
-         y    = mkProdStream (nodeEnvOut nEnv)
+         y    = mkProdFunc (nodeEnvOut nEnv)
      inpDefs  <- mapM (\(x, e) ->
                         declareConditionalAssign
                         inpActive id (const $ getBottom x) x e)
                  $ zip (nodeEnvIn nEnv) esTr
-     return (const $ appStream y, inpDefs)
+     return (const $ appFunc y, inpDefs)
 
 -- | Creates a declaration for a state transition.
 -- If an activation condition c is given, the declaration boils down to
@@ -277,6 +278,7 @@ declareTransition activeCond (StateTransition x e) =
          xApp    = appStream xStream
          e'      = runTransM $ trExpr e
      declareConditionalAssign activeCond succAnn xApp xStream e'
+-}
 
 -- | Creates a declaration for an assignment. Depending on the
 -- activation condition the given expression or a default expression
@@ -284,51 +286,52 @@ declareTransition activeCond (StateTransition x e) =
 -- stream of /x/ which will be defined, can be specified by modPos
 -- (see declareDef).
 declareConditionalAssign :: Ident i =>
-                            Maybe (Stream Bool)
-                            -> (StreamPos -> StreamPos)
-                            -> (StreamPos -> TypedExpr i)
-                            -> TypedStream i
-                            -> (Env i -> StreamPos -> TypedExpr i)
+                            Maybe (SMTExpr Bool)
+                            -> TypedExpr i
+                            -> TypedExpr i
+                            -> Set i
+                            -> (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i)
                             -> DeclM i Definition
-declareConditionalAssign activeCond modPos defaultStream x ef =
+declareConditionalAssign activeCond defaultExpr x al ef =
   case activeCond of
-    Nothing -> declareDef modPos x ef
+    Nothing -> declareDef x al ef
     Just c  ->
-      declareDef modPos x (\env t ->
-                            mkConditionalStream t c (ef env) defaultStream)
+      declareDef x al ef
+      --declareDef modPos x (mkConditionalExpr c e defaultExpr)
   where
     -- | Takes a condition and the corresponding branches which may depend
     -- on the current time and builds an expression which takes the corresponding
     -- branch depending on the condition (if c then s_1(n) else s_2(n)).
-    mkConditionalStream n c s1 s2 =
-      let c' = BoolExpr $ c `app` n
-      in liftIte c' (s1 n) (s2 n)
+    mkConditionalExpr c s1 s2 =
+      let c' = BoolExpr $ c
+      in liftIte c' s1 s2
 
 -- | Creates a definition for a given variable. Whereby a function to
 -- manipulate the stream position at which it is defined is used (normally
 -- id or succ' to define instances or state transitions).
 -- The second argument /x/ is the stream to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
-declareDef :: Ident i => (StreamPos -> StreamPos) -> TypedStream i ->
-              (Env i -> StreamPos -> TypedExpr i) -> DeclM i Definition
-declareDef f x ef =
+declareDef :: Ident i => TypedExpr i -> Set i ->
+              (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i) -> DeclM i Definition
+declareDef x as ef =
   do env         <- get
-     let defType = streamDefType x
-     d           <- defStream defType
-                    $ \t -> liftRel (.==.) (x `appStream` (f t)) (ef env t)
+     let defType = varDefType x
+     d           <- defFunc (1 + Set.size as) defType
+                    $ \a -> liftRel (.==.) (BoolExpr $ head a) $ ef env $ zip (Set.toList as) (tail a)
      return $ ensureDefinition d
   where
-    streamDefType (ProdStream ts) = ProdType . fmap streamDefType $ Arr.elems ts
-    streamDefType _               = boolT
+    varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
+    varDefType _               = boolT
 
-declareFlow :: Ident i => Maybe (Stream Bool) -> Flow i -> DeclM i [Definition]
+declareFlow :: Ident i => Maybe (SMTExpr Bool) -> Flow i -> DeclM i [Definition]
 declareFlow activeCond f =
   do defDefs        <- fmap concat
                        . mapM (declareInstantDef activeCond)
                        $ flowDefinitions f
-     transitionDefs <- mapM (declareTransition activeCond) $ flowTransitions f
-     return $ defDefs ++ transitionDefs
+     --transitionDefs <- mapM (declareTransition activeCond) $ flowTransitions f
+     return $ defDefs-- ++ transitionDefs
 
+{-
 -- | Declares an automaton by
 -- * defining an enum for the locations
 -- * defining two variables which hold the active location (see mkStateVars)

From 1dd00313f92373fc5781a551831439f65a03a87b Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 15 Sep 2015 02:14:28 +0200
Subject: [PATCH 016/104] Activation condition has to be a function not an
 expression

---
 lamaSMT/lib/Transform.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 1c4bf63..562abe2 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -119,7 +119,7 @@ declareEnum (t, EnumDef cs) =
         liftSMT (declareType (undefined :: SMTEnum) ann) >> return (t, ann)
 
 declareDecls :: Ident i =>
-                Maybe (Stream Bool)
+                Maybe (SMTFunction [SMTExpr Bool] Bool)
                 -> Set i
                 -> Declarations i
                 -> DeclM i ([Definition], Map i (Node i))
@@ -230,7 +230,7 @@ getNodesInLocations = mconcat . map getUsedLoc . automLocations
 -- | Creates definitions for instant definitions. In case of a node usage this
 -- may produce multiple definitions. If 
 declareInstantDef :: Ident i =>
-                     Maybe (SMTExpr Bool)
+                     Maybe (SMTFunction [SMTExpr Bool] Bool)
                      -> InstantDefinition i
                      -> DeclM i [Definition]
 declareInstantDef activeCond inst@(InstantExpr x e) =
@@ -251,7 +251,7 @@ declareInstantDef activeCond inst@(InstantExpr x e) =
 -- used to further refine this instant (e.g. wrap it into an ite).
 -- This may also return definitions of the parameters of a node.
 -- The activation condition is only used for the inputs of a node.
-trInstant :: Ident i => Maybe (SMTExpr Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i, [Definition])
+trInstant :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i, [Definition])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
 {-trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
@@ -286,7 +286,7 @@ declareTransition activeCond (StateTransition x e) =
 -- stream of /x/ which will be defined, can be specified by modPos
 -- (see declareDef).
 declareConditionalAssign :: Ident i =>
-                            Maybe (SMTExpr Bool)
+                            Maybe (SMTFunction [SMTExpr Bool] Bool)
                             -> TypedExpr i
                             -> TypedExpr i
                             -> Set i
@@ -323,7 +323,7 @@ declareDef x as ef =
     varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
     varDefType _               = boolT
 
-declareFlow :: Ident i => Maybe (SMTExpr Bool) -> Flow i -> DeclM i [Definition]
+declareFlow :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Flow i -> DeclM i [Definition]
 declareFlow activeCond f =
   do defDefs        <- fmap concat
                        . mapM (declareInstantDef activeCond)

From f8f4e9134a028a6f38af380ab5423b6dbc52950c Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 15 Sep 2015 04:47:56 +0200
Subject: [PATCH 017/104] nodeEnvOut is now a Map, nodeEnvIn still a list

---
 lamaSMT/lib/Model.hs        |  6 +++---
 lamaSMT/lib/Transform.hs    | 19 +++++++++----------
 lamaSMT/lib/TransformEnv.hs |  2 +-
 3 files changed, 13 insertions(+), 14 deletions(-)

diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index c78dfb1..bb2a6d1 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -40,7 +40,7 @@ data Model i = Model
 
 data NodeModel i = NodeModel
                    { nodeModelIn :: [ValueStream]
-                   , nodeModelOut :: [ValueStream]
+                   , nodeModelOut :: Map i ValueStream
                    , nodeModelVars :: Model i
                    } deriving Show
 
@@ -56,7 +56,7 @@ prettyNodes = vcat . map (\(x, n) -> (ptext $ identString x) <+> prettyNodeModel
 prettyNodeModel :: Ident i => NodeModel i -> Doc
 prettyNodeModel m = braces . nest 2 $
   text "Inputs:" $+$ nest 2 (vcat . map prettyStream $ nodeModelIn m) $+$
-  text "Outputs:" $+$ nest 2 (vcat . map prettyStream $ nodeModelOut m) $+$
+  text "Outputs:" $+$ nest 2 (vcat . map prettyStream $ Map.elems $ nodeModelOut m) $+$
   prettyModel (nodeModelVars m)
 
 prettyStream :: ValueStream -> Doc
@@ -85,7 +85,7 @@ getModel' env =
 
 getNodeModel :: NodeEnv i -> ModelM (NodeModel i)
 getNodeModel (NodeEnv i o e) =
-  NodeModel <$> mapM getVarModel i <*> mapM getVarModel o <*> getModel' e
+  NodeModel <$> mapM getVarModel i <*> getVarsModel o <*> getModel' e
 
 getVarsModel :: Map i (TypedExpr i) -> ModelM (Map i ValueStream)
 getVarsModel = mapM getVarModel
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 562abe2..168bd9f 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -186,8 +186,8 @@ enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
 -- (using getNodesInLocations). Then all nodes _except_ those found before are
 -- declared. The other nodes are deferred to be declared in the corresponding
 -- location (see declareAutomaton and declareLocations).
-{-declareNode :: Ident i =>
-               Maybe (Stream Bool) -> i -> Node i -> DeclM i [Definition]
+declareNode :: Ident i =>
+               Maybe (SMTFunction [SMTExpr Bool] Bool) -> i -> Node i -> DeclM i [Definition]
 declareNode active nName nDecl =
   do (interface, defs) <- localVarEnv (const emptyVarEnv) $
                           declareNode' active nDecl
@@ -195,7 +195,7 @@ declareNode active nName nDecl =
      return defs
   where
     declareNode' :: Ident i =>
-                    Maybe (Stream Bool) -> Node i
+                    Maybe (SMTFunction [SMTExpr Bool] Bool) -> Node i
                     -> DeclM i (NodeEnv i, [Definition])
     declareNode' activeCond n =
       do let automNodes =
@@ -204,18 +204,18 @@ declareNode active nName nDecl =
            declareDecls activeCond automNodes $ nodeDecls n
          outDecls <- declareVarList $ nodeOutputs n
          ins <- mapM (lookupVar . varIdent) . declsInput $ nodeDecls n
-         let outs = map snd outDecls
+         let outs = Map.fromList outDecls
          modifyVars $ Map.union (Map.fromList outDecls)
          flowDefs <- declareFlow activeCond $ nodeFlow n
-         automDefs <-
-           fmap concat .
-           mapM (declareAutomaton activeCond undeclaredNodes) .
-           Map.toList $ nodeAutomata n
+         --automDefs <-
+         --  fmap concat .
+         --  mapM (declareAutomaton activeCond undeclaredNodes) .
+         --  Map.toList $ nodeAutomata n
          assertInits $ nodeInitial n
          precondDef <- declarePrecond activeCond $ nodeAssertion n
          varDefs <- gets varEnv
          return (NodeEnv ins outs varDefs,
-                 declDefs ++ flowDefs ++ automDefs ++ [precondDef])
+                 declDefs ++ flowDefs ++ {-automDefs ++ -}[precondDef])
 
 -- | Extracts all nodes which are used inside some location.
 getNodesInLocations :: Ident i => Automaton i -> Set i
@@ -225,7 +225,6 @@ getNodesInLocations = mconcat . map getUsedLoc . automLocations
     getUsedLoc (Location _ flow) = mconcat . map getUsed $ flowDefinitions flow
     getUsed (NodeUsage _ n _) = Set.singleton n
     getUsed _ = Set.empty
--}
 
 -- | Creates definitions for instant definitions. In case of a node usage this
 -- may produce multiple definitions. If 
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 4418436..c01f831 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -28,7 +28,7 @@ import Internal.Monads
 
 data NodeEnv i = NodeEnv
                  { nodeEnvIn :: [TypedExpr i]
-                 , nodeEnvOut :: [TypedExpr i]
+                 , nodeEnvOut :: Map i (TypedExpr i)
                  , nodeEnvVars :: VarEnv i
                  }
 

From 35d1a0a4a9cfda20cae09eec7c77c847f60c70b2 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 16 Sep 2015 00:40:18 +0200
Subject: [PATCH 018/104] FlowDefs now with node usage, but nodes without
 automatons

---
 lamaSMT/lib/LamaSMTTypes.hs |  8 ++++----
 lamaSMT/lib/Transform.hs    | 37 ++++++++++++++++++++++++-------------
 2 files changed, 28 insertions(+), 17 deletions(-)

diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index a36d6e5..18e85b4 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -37,10 +37,10 @@ data TypedFunc i
   | ProdFunc (Array Int (TypedFunc i))
   deriving Show
 
-mkProdFunc :: [TypedFunc i] -> TypedFunc i
-mkProdFunc [] = error "Cannot create empty product stream"
-mkProdFunc [s] = s
-mkProdFunc sts = ProdFunc . uncurry listArray $ ((0,) . pred . length &&& id) sts
+mkProdExpr :: [TypedExpr i] -> TypedExpr i
+mkProdExpr [] = error "Cannot create empty product expression"
+mkProdExpr [s] = s
+mkProdExpr sts = ProdExpr . uncurry listArray $ ((0,) . pred . length &&& id) sts
 
 appFunc :: TypedFunc i -> [SMTExpr Bool] -> TypedExpr i
 appFunc (BoolFunc f) arg = BoolExpr $ f `app` arg
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 168bd9f..26a6733 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -127,7 +127,7 @@ declareDecls activeCond excludeNodes d =
   do let (excluded, toDeclare)
            = Map.partitionWithKey (\n _ -> n `Set.member` excludeNodes)
              $ declsNode d
-     --defs <- mapM (uncurry $ declareNode activeCond) $ Map.toList toDeclare
+     defs <- mapM (uncurry $ declareNode activeCond) $ Map.toList toDeclare
      inp <- declareVars $ declsInput d
      locs <- declareVars $ declsLocal d
      states <- declareVars $ declsState d
@@ -215,7 +215,7 @@ declareNode active nName nDecl =
          precondDef <- declarePrecond activeCond $ nodeAssertion n
          varDefs <- gets varEnv
          return (NodeEnv ins outs varDefs,
-                 declDefs ++ flowDefs ++ {-automDefs ++ -}[precondDef])
+                 declDefs ++ flowDefs ++{- automDefs ++-} [precondDef])
 
 -- | Extracts all nodes which are used inside some location.
 getNodesInLocations :: Ident i => Automaton i -> Set i
@@ -238,13 +238,13 @@ declareInstantDef activeCond inst@(InstantExpr x e) =
      def <- declareConditionalAssign
             activeCond (getBottom xVar) xVar (getArgSet e) res
      return [def]
-{-declareInstantDef activeCond inst@(NodeUsage x _ _) =
+declareInstantDef activeCond inst@(NodeUsage x n _) =
   do (outp, inpDefs) <- trInstant activeCond inst
-     xVar         <- lookupVar x
+     xVar            <- lookupVar x
+     nEnv            <- lookupNode n
      outpDef         <- declareConditionalAssign
-                        activeCond id (getBottom xVar) xVar (getArgSet x) outp
+                        activeCond (getBottom xVar) xVar (Map.keysSet $ nodeEnvOut nEnv) outp
      return $ inpDefs ++ [outpDef]
--}
 
 -- | Translates an instant definition into a function which can be
 -- used to further refine this instant (e.g. wrap it into an ite).
@@ -252,16 +252,27 @@ declareInstantDef activeCond inst@(InstantExpr x e) =
 -- The activation condition is only used for the inputs of a node.
 trInstant :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i, [Definition])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
-{-trInstant inpActive (NodeUsage _ n es) =
+trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
      let esTr = map (runTransM . trExpr) es
-         y    = mkProdFunc (nodeEnvOut nEnv)
-     inpDefs  <- mapM (\(x, e) ->
+         y    = runTransM $ trOutput $ nodeEnvOut nEnv
+     inpDefs  <- mapM (\(x, eTr, e) ->
                         declareConditionalAssign
-                        inpActive id (const $ getBottom x) x e)
-                 $ zip (nodeEnvIn nEnv) esTr
-     return (const $ appFunc y, inpDefs)
+                        inpActive (getBottom x) x (getArgSet e) eTr)
+                 $ zip3 (nodeEnvIn nEnv) esTr es
+     return (y, inpDefs)
+
+trOutput :: Ident i => Map i (TypedExpr i) -> TransM i (TypedExpr i)
+trOutput map = do
+                 s <- ask
+                 outList <- mapM (trOutput' s) (Map.toList map)
+                 return $ mkProdExpr outList
+               where
+                 trOutput' s (i, te) = case lookup i (fst s) of
+                                       Nothing -> throwError $ "No argument binding for " ++ identPretty i
+                                       Just n -> return $ BoolExpr n
 
+{-
 -- | Creates a declaration for a state transition.
 -- If an activation condition c is given, the declaration boils down to
 -- x' = (ite c e x) where e is the defining expression. Otherwise it is just
@@ -683,7 +694,7 @@ declarePrecond activeCond e =
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ getArgSet e) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
-     return $ trace ("Precond " ++ show d) $ ensureDefinition d
+     return $ ensureDefinition d
 
 declareInvariant :: Ident i =>
                     Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition

From 630104b19db3b3deb7340d8e782ff66e556665a6 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 16 Sep 2015 00:59:50 +0200
Subject: [PATCH 019/104] FlowTrans also activated on a very simple way

---
 lamaSMT/lib/Transform.hs | 17 ++++++-----------
 1 file changed, 6 insertions(+), 11 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 26a6733..f84cccd 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -272,23 +272,18 @@ trOutput map = do
                                        Nothing -> throwError $ "No argument binding for " ++ identPretty i
                                        Just n -> return $ BoolExpr n
 
-{-
 -- | Creates a declaration for a state transition.
 -- If an activation condition c is given, the declaration boils down to
 -- x' = (ite c e x) where e is the defining expression. Otherwise it is just
 -- x' = e.
 declareTransition :: Ident i =>
-                     Maybe (Stream Bool)
+                     Maybe (SMTFunction [SMTExpr Bool] Bool)
                      -> StateTransition i
                      -> DeclM i Definition
 declareTransition activeCond (StateTransition x e) =
-  do xStream     <- lookupVar x
-     natAnn      <- gets natImpl
-     let succAnn = succ' natAnn
-         xApp    = appStream xStream
-         e'      = runTransM $ trExpr e
-     declareConditionalAssign activeCond succAnn xApp xStream e'
--}
+  do xVar     <- lookupVar x
+     let e'      = runTransM $ trExpr e
+     declareConditionalAssign activeCond (getBottom xVar) xVar (getArgSet e) e'
 
 -- | Creates a declaration for an assignment. Depending on the
 -- activation condition the given expression or a default expression
@@ -338,8 +333,8 @@ declareFlow activeCond f =
   do defDefs        <- fmap concat
                        . mapM (declareInstantDef activeCond)
                        $ flowDefinitions f
-     --transitionDefs <- mapM (declareTransition activeCond) $ flowTransitions f
-     return $ defDefs-- ++ transitionDefs
+     transitionDefs <- mapM (declareTransition activeCond) $ flowTransitions f
+     return $ defDefs ++ transitionDefs
 
 {-
 -- | Declares an automaton by

From fb292d6dce502375f1f83a1892c24d5366e4dac5 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 16 Sep 2015 03:45:49 +0200
Subject: [PATCH 020/104] First try on using Idents in Definitions to get
 TypedExpr from VarEnv

---
 lamaSMT/Main.hs                      |  4 +--
 lamaSMT/lib/Definition.hs            | 45 +++++++++++++++---------
 lamaSMT/lib/Strategies/BMC.hs        | 52 +++++++++++++++-------------
 lamaSMT/lib/Strategies/Factory.hs    |  4 +--
 lamaSMT/lib/Strategies/KInduction.hs |  3 +-
 lamaSMT/lib/Strategy.hs              | 15 ++++----
 lamaSMT/lib/Transform.hs             | 34 +++++++++---------
 lamaSMT/lib/TransformEnv.hs          |  2 ++
 8 files changed, 91 insertions(+), 68 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index 47eb06c..a56b6ee 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -169,8 +169,8 @@ run opts@Options{..} file inp = do
   liftIO $ when optDumpLama (print p)
   model <- runCheck opts
     ( (liftSMT $ mapM_ setOption optSMTOpts) >>
-      lamaSMT optNatImpl optEnumImpl p) {- >>=
-      (uncurry $ checkWithModel optNatImpl optStrategy) ) -}
+      lamaSMT optNatImpl optEnumImpl p >>=
+      (uncurry $ checkWithModel optNatImpl optStrategy) )
   --liftIO $ checkModel opts p model
   liftIO $ putStr "Test"
 
diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 3aaafa7..8445dd6 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -1,33 +1,46 @@
 module Definition where
 
 import Data.Array as Arr
+import qualified Data.Map as Map
+import Data.Map (Map)
 
 import Language.SMTLib2 as SMT
 
+import Lang.LAMA.Identifier
+
 import LamaSMTTypes
+import TransformEnv
 import Internal.Monads
 
-data Definition =
-  SingleDef (SMTFunction [SMTExpr Bool] Bool)
-  | ProdDef (Array Int Definition)
+data Definition i =
+  SingleDef [i] (SMTFunction [SMTExpr Bool] Bool)
+  | ProdDef (Array Int (Definition i))
   deriving Show
 
-ensureDefinition :: TypedFunc i -> Definition
-ensureDefinition (BoolFunc s) = SingleDef s
-ensureDefinition (ProdFunc ps) = ProdDef $ fmap ensureDefinition ps
-ensureDefinition _
+ensureDefinition :: [i] -> TypedFunc i -> Definition i
+ensureDefinition al (BoolFunc s) = SingleDef al s
+ensureDefinition al (ProdFunc ps) = ProdDef $ fmap (ensureDefinition al) ps
+ensureDefinition al _
   = error $ "ensureDefinition: not a boolean function" -- : " ++ show s
 
-assertDefinition :: MonadSMT m =>
+assertDefinition :: (Ident i, MonadSMT m) =>
                     (SMTExpr Bool -> SMTExpr Bool)
-                    -> StreamPos
-                    -> Definition
+                    -> VarEnv i
+                    -> Definition i
                     -> m ()
-assertDefinition f i (SingleDef s) = do return ()--liftSMT $ assert (f $ s `app` i)
-assertDefinition f i (ProdDef ps) = mapM_ (assertDefinition f i) $ Arr.elems ps
+assertDefinition f env (SingleDef al s) = liftSMT $ assert (f $ s `app` (lookupArgs al env))
+assertDefinition f env (ProdDef ps) = mapM_ (assertDefinition f env) $ Arr.elems ps
+
+lookupArgs :: Ident i => [i] -> VarEnv i -> [SMTExpr Bool]
+lookupArgs al env = map (lookupArgs' env) al
+  where
+    lookupArgs' env i = case Map.lookup i (vars env) of
+                          Just x -> unBool' x
+                          Nothing -> error "bla"--(flip lookupArgs' $ i) . nodeEnvVars $ Map.elems (nodes env)
+
 
-data ProgDefs = ProgDefs
-                { flowDef :: [Definition]
-                , precondition :: Definition
-                , invariantDef :: Definition
+data ProgDefs i = ProgDefs
+                { flowDef :: [Definition i]
+                , precondition :: Definition i
+                , invariantDef :: Definition i
                 }
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index e468975..3172b71 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -12,10 +12,13 @@ import Control.Monad (when, liftM)
 
 import Language.SMTLib2
 
+import Lang.LAMA.Identifier
+
 import Strategy
 import LamaSMTTypes
 import Definition
-import Model (Model)
+import Model (Model, getModel)
+import TransformEnv
 import Internal.Monads
 
 data BMC = BMC
@@ -33,55 +36,56 @@ instance StrategyClass BMC where
     s { bmcPrintProgress = True }
   readOption o _ = error $ "Invalid BMC option: " ++ o
 
-  check natAnn s getModel defs =
+  check natAnn s env defs =
     let base = 0
     in do baseDef <- liftSMT . defConst $ constantAnn base natAnn
-          check' natAnn s getModel defs (Map.singleton base baseDef) base baseDef
+          check' natAnn s env defs (Map.singleton base baseDef) base baseDef
 
-assumeTrace :: MonadSMT m => ProgDefs -> StreamPos -> m ()
-assumeTrace defs iDef =
-  assertDefs iDef (flowDef defs) >>
-  assertPrecond iDef (precondition defs)
+assumeTrace :: (Ident i, MonadSMT m) => ProgDefs i -> VarEnv i -> m ()
+assumeTrace defs env =
+  assertDefs env (flowDef defs) >>
+  assertPrecond env (precondition defs)
 
-bmcStep :: MonadSMT m =>
-        (Map Natural StreamPos -> SMT (Model i))
-        -> ProgDefs
+bmcStep :: (Ident i, MonadSMT m) =>
+        VarEnv i   
+        -> ProgDefs i
         -> Map Natural StreamPos
         -> StreamPos
         -> m (Maybe (Model i))
-bmcStep getModel defs pastIndices iDef =
-  do assumeTrace defs iDef
+bmcStep env defs pastIndices iDef =
+  do assumeTrace defs env
      let invs = invariantDef defs
      liftSMT . stack
-       $ checkInvariant iDef invs >>=
-       checkGetModel getModel pastIndices
+       $ checkInvariant env invs >>=
+       checkGetModel (getModel env) pastIndices
 
-check' :: SMTAnnotation Natural
+check' :: Ident i =>
+       SMTAnnotation Natural
        -> BMC
-       -> (Map Natural StreamPos -> SMT (Model i))
-       -> ProgDefs
+       -> VarEnv i
+       -> ProgDefs i
        -> Map Natural StreamPos
        -> Natural
        -> StreamPos
        -> SMTErr (StrategyResult i)
-check' natAnn s getModel defs pastIndices i iDef =
+check' natAnn s env defs pastIndices i iDef =
   do liftIO $ when (bmcPrintProgress s) (putStrLn $ "Depth " ++ show i)
-     r <- bmcStep getModel defs pastIndices iDef
+     r <- bmcStep env defs pastIndices iDef
      case r of
-       Nothing -> next (check' natAnn s getModel defs) natAnn s pastIndices i iDef
+       Nothing -> next (check' natAnn s env defs) natAnn s pastIndices i iDef
        Just m -> return $ Failure i m
 
-assertDefs :: MonadSMT m => SMTExpr Natural -> [Definition] -> m ()
+assertDefs :: (Ident i, MonadSMT m) => VarEnv i -> [Definition i] -> m ()
 assertDefs i = mapM_ (assertDef i)
 
-assertDef :: MonadSMT m => SMTExpr Natural -> Definition -> m ()
+assertDef :: (Ident i, MonadSMT m) => VarEnv i -> Definition i -> m ()
 assertDef = assertDefinition id
 
-assertPrecond :: MonadSMT m => SMTExpr Natural -> Definition -> m ()
+assertPrecond :: (Ident i, MonadSMT m) => VarEnv i -> Definition i -> m ()
 assertPrecond = assertDefinition id
 
 -- | Returns true, if the invariant holds
-checkInvariant :: MonadSMT m => SMTExpr Natural -> Definition -> m Bool
+checkInvariant :: (Ident i, MonadSMT m) => VarEnv i -> Definition i -> m Bool
 checkInvariant i p = liftSMT $ assertDefinition not' i p >> liftM not checkSat
 
 checkGetModel :: MonadSMT m =>
diff --git a/lamaSMT/lib/Strategies/Factory.hs b/lamaSMT/lib/Strategies/Factory.hs
index e4b6e7e..f27c36e 100644
--- a/lamaSMT/lib/Strategies/Factory.hs
+++ b/lamaSMT/lib/Strategies/Factory.hs
@@ -44,5 +44,5 @@ getStrategyHelp lineLength = renderStyle (style { lineLength }) $
 
 getStrategy :: String -> Strategy
 getStrategy "bmc" = Strategy (defaultStrategyOpts :: BMC)
-getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
-getStrategy _ = error "Unknown strategy"
\ No newline at end of file
+--getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
+getStrategy _ = error "Unknown strategy"
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index 7377ba4..12ebb79 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 module Strategies.KInduction where
-
+{-
 import Data.Natural
 import NatInstance
 import Data.List (stripPrefix)
@@ -140,3 +140,4 @@ retrieveHints getModel indOpts k success =
          else return []
        (AllInductionSteps, _      ) ->
          getModel >>= \m -> return [Hint (show k) m]
+-}
diff --git a/lamaSMT/lib/Strategy.hs b/lamaSMT/lib/Strategy.hs
index 8f421a3..2a38324 100644
--- a/lamaSMT/lib/Strategy.hs
+++ b/lamaSMT/lib/Strategy.hs
@@ -10,6 +10,9 @@ import Control.Monad.Error
 
 import Language.SMTLib2
 
+import Debug.Trace
+import Lang.LAMA.Identifier
+
 import LamaSMTTypes
 import Definition
 import TransformEnv
@@ -28,18 +31,18 @@ data Strategy = forall s. StrategyClass s => Strategy s
 class StrategyClass s where
   defaultStrategyOpts :: s
   readOption :: String -> s -> s
-  check :: SMTAnnotation Natural
+  check :: Ident i => SMTAnnotation Natural
            -> s
-           -> (Map Natural StreamPos -> SMT (Model i))
-           -> ProgDefs
+           -> VarEnv i
+           -> ProgDefs i
            -> SMTErr (StrategyResult i)
 
-checkWithModel :: SMTAnnotation Natural
+checkWithModel :: Ident i => SMTAnnotation Natural
                -> Strategy
-               -> ProgDefs
+               -> ProgDefs i
                -> VarEnv i
                -> SMTErr (StrategyResult i)
-checkWithModel natAnn (Strategy s) d env = check natAnn s (getModel env) d
+checkWithModel natAnn (Strategy s) d env = trace (show env) $ check natAnn s env d
 
 readOptions' :: String -> Strategy -> Strategy
 readOptions' o (Strategy s) = Strategy $ readOption o s
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index f84cccd..ce2f475 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -73,14 +73,14 @@ getBottom (ProdExpr strs)  = ProdExpr $ fmap getBottom strs
 -- gets a value at that time (after getting the model).
 lamaSMT :: Ident i =>
            NatImplementation -> EnumImplementation -> Program i
-           -> ErrorT String SMT (ProgDefs, VarEnv i)
+           -> ErrorT String SMT (ProgDefs i, VarEnv i)
 lamaSMT natImpl' enumImpl' =
   fmap (second varEnv)
   . flip runStateT (emptyEnv natImpl' enumImpl')
   . declProgram
 
 -- | Declare the formulas which define a LAMA program.
-declProgram :: Ident i => Program i -> DeclM i ProgDefs
+declProgram :: Ident i => Program i -> DeclM i (ProgDefs i)
 declProgram p =
   do preamble
      putConstants (progConstantDefinitions p)
@@ -90,7 +90,7 @@ declProgram p =
      assertInits (progInitial p)
      precondDef <- declarePrecond Nothing (progAssertion p)
      invarDef <- declareInvariant Nothing (progInvariant p)
-     return $ ProgDefs (declDefs{- ++ flowDefs-}) precondDef invarDef
+     return $ ProgDefs (declDefs ++ flowDefs) precondDef invarDef
 
 -- | Declares common types etc.
 -- At the moment just Natural is defined.
@@ -122,7 +122,7 @@ declareDecls :: Ident i =>
                 Maybe (SMTFunction [SMTExpr Bool] Bool)
                 -> Set i
                 -> Declarations i
-                -> DeclM i ([Definition], Map i (Node i))
+                -> DeclM i ([Definition i], Map i (Node i))
 declareDecls activeCond excludeNodes d =
   do let (excluded, toDeclare)
            = Map.partitionWithKey (\n _ -> n `Set.member` excludeNodes)
@@ -132,7 +132,7 @@ declareDecls activeCond excludeNodes d =
      locs <- declareVars $ declsLocal d
      states <- declareVars $ declsState d
      modifyVars $ mappend (inp `mappend` locs `mappend` states)
-     return ({-concat defs-}[], excluded)
+     return (concat defs, excluded)
 
 declareVars :: Ident i => [Variable i] -> DeclM i (Map i (TypedExpr i))
 declareVars = fmap (Map.fromList) . declareVarList
@@ -187,7 +187,7 @@ enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
 -- declared. The other nodes are deferred to be declared in the corresponding
 -- location (see declareAutomaton and declareLocations).
 declareNode :: Ident i =>
-               Maybe (SMTFunction [SMTExpr Bool] Bool) -> i -> Node i -> DeclM i [Definition]
+               Maybe (SMTFunction [SMTExpr Bool] Bool) -> i -> Node i -> DeclM i [Definition i]
 declareNode active nName nDecl =
   do (interface, defs) <- localVarEnv (const emptyVarEnv) $
                           declareNode' active nDecl
@@ -196,7 +196,7 @@ declareNode active nName nDecl =
   where
     declareNode' :: Ident i =>
                     Maybe (SMTFunction [SMTExpr Bool] Bool) -> Node i
-                    -> DeclM i (NodeEnv i, [Definition])
+                    -> DeclM i (NodeEnv i, [Definition i])
     declareNode' activeCond n =
       do let automNodes =
                mconcat . map getNodesInLocations . Map.elems $ nodeAutomata n
@@ -231,7 +231,7 @@ getNodesInLocations = mconcat . map getUsedLoc . automLocations
 declareInstantDef :: Ident i =>
                      Maybe (SMTFunction [SMTExpr Bool] Bool)
                      -> InstantDefinition i
-                     -> DeclM i [Definition]
+                     -> DeclM i [Definition i]
 declareInstantDef activeCond inst@(InstantExpr x e) =
   do (res, []) <- trInstant (error "no activation condition") inst
      xVar <- lookupVar x
@@ -250,7 +250,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
 -- used to further refine this instant (e.g. wrap it into an ite).
 -- This may also return definitions of the parameters of a node.
 -- The activation condition is only used for the inputs of a node.
-trInstant :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i, [Definition])
+trInstant :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i, [Definition i])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
 trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
@@ -279,7 +279,7 @@ trOutput map = do
 declareTransition :: Ident i =>
                      Maybe (SMTFunction [SMTExpr Bool] Bool)
                      -> StateTransition i
-                     -> DeclM i Definition
+                     -> DeclM i (Definition i)
 declareTransition activeCond (StateTransition x e) =
   do xVar     <- lookupVar x
      let e'      = runTransM $ trExpr e
@@ -296,7 +296,7 @@ declareConditionalAssign :: Ident i =>
                             -> TypedExpr i
                             -> Set i
                             -> (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i)
-                            -> DeclM i Definition
+                            -> DeclM i (Definition i)
 declareConditionalAssign activeCond defaultExpr x al ef =
   case activeCond of
     Nothing -> declareDef x al ef
@@ -317,18 +317,18 @@ declareConditionalAssign activeCond defaultExpr x al ef =
 -- The second argument /x/ is the stream to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
 declareDef :: Ident i => TypedExpr i -> Set i ->
-              (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i) -> DeclM i Definition
+              (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i) -> DeclM i (Definition i)
 declareDef x as ef =
   do env         <- get
      let defType = varDefType x
      d           <- defFunc (1 + Set.size as) defType
                     $ \a -> liftRel (.==.) (BoolExpr $ head a) $ ef env $ zip (Set.toList as) (tail a)
-     return $ ensureDefinition d
+     return $ ensureDefinition (Set.toList as) d
   where
     varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
     varDefType _               = boolT
 
-declareFlow :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Flow i -> DeclM i [Definition]
+declareFlow :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Flow i -> DeclM i [Definition i]
 declareFlow activeCond f =
   do defDefs        <- fmap concat
                        . mapM (declareInstantDef activeCond)
@@ -680,7 +680,7 @@ assertInit (x, e) =
 
 -- | Creates a definition for a precondition p. If an activation condition c
 -- is given, the resulting condition is (=> c p).
-declarePrecond :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
+declarePrecond :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i (Definition i)
 declarePrecond activeCond e =
   do env <- get
      d <- case activeCond of
@@ -689,10 +689,10 @@ declarePrecond activeCond e =
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ getArgSet e) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
-     return $ ensureDefinition d
+     return $ ensureDefinition (Set.toList $ getArgSet e)d
 
 declareInvariant :: Ident i =>
-                    Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
+                    Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i (Definition i)
 declareInvariant = declarePrecond
 
 trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr i)
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index c01f831..21911e2 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -31,6 +31,7 @@ data NodeEnv i = NodeEnv
                  , nodeEnvOut :: Map i (TypedExpr i)
                  , nodeEnvVars :: VarEnv i
                  }
+  deriving Show
 
 data VarEnv i = VarEnv
                 { nodes :: Map i (NodeEnv i)
@@ -38,6 +39,7 @@ data VarEnv i = VarEnv
                   -- ^ Maps names of variables to a SMT expression for using
                   -- that variable
                 }
+  deriving Show
 
 data Env i = Env
            { constants :: Map i (TypedExpr i)

From 2f302bb5dc76d69574e6a424eb8c4d6dc180ae3e Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 17 Sep 2015 01:49:50 +0200
Subject: [PATCH 021/104] Revert "First try on using Idents in Definitions to
 get TypedExpr from VarEnv"

This reverts commit fb292d6dce502375f1f83a1892c24d5366e4dac5.
---
 lamaSMT/Main.hs                      |  4 +--
 lamaSMT/lib/Definition.hs            | 45 +++++++++---------------
 lamaSMT/lib/Strategies/BMC.hs        | 52 +++++++++++++---------------
 lamaSMT/lib/Strategies/Factory.hs    |  4 +--
 lamaSMT/lib/Strategies/KInduction.hs |  3 +-
 lamaSMT/lib/Strategy.hs              | 15 ++++----
 lamaSMT/lib/Transform.hs             | 34 +++++++++---------
 lamaSMT/lib/TransformEnv.hs          |  2 --
 8 files changed, 68 insertions(+), 91 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index a56b6ee..47eb06c 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -169,8 +169,8 @@ run opts@Options{..} file inp = do
   liftIO $ when optDumpLama (print p)
   model <- runCheck opts
     ( (liftSMT $ mapM_ setOption optSMTOpts) >>
-      lamaSMT optNatImpl optEnumImpl p >>=
-      (uncurry $ checkWithModel optNatImpl optStrategy) )
+      lamaSMT optNatImpl optEnumImpl p) {- >>=
+      (uncurry $ checkWithModel optNatImpl optStrategy) ) -}
   --liftIO $ checkModel opts p model
   liftIO $ putStr "Test"
 
diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 8445dd6..3aaafa7 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -1,46 +1,33 @@
 module Definition where
 
 import Data.Array as Arr
-import qualified Data.Map as Map
-import Data.Map (Map)
 
 import Language.SMTLib2 as SMT
 
-import Lang.LAMA.Identifier
-
 import LamaSMTTypes
-import TransformEnv
 import Internal.Monads
 
-data Definition i =
-  SingleDef [i] (SMTFunction [SMTExpr Bool] Bool)
-  | ProdDef (Array Int (Definition i))
+data Definition =
+  SingleDef (SMTFunction [SMTExpr Bool] Bool)
+  | ProdDef (Array Int Definition)
   deriving Show
 
-ensureDefinition :: [i] -> TypedFunc i -> Definition i
-ensureDefinition al (BoolFunc s) = SingleDef al s
-ensureDefinition al (ProdFunc ps) = ProdDef $ fmap (ensureDefinition al) ps
-ensureDefinition al _
+ensureDefinition :: TypedFunc i -> Definition
+ensureDefinition (BoolFunc s) = SingleDef s
+ensureDefinition (ProdFunc ps) = ProdDef $ fmap ensureDefinition ps
+ensureDefinition _
   = error $ "ensureDefinition: not a boolean function" -- : " ++ show s
 
-assertDefinition :: (Ident i, MonadSMT m) =>
+assertDefinition :: MonadSMT m =>
                     (SMTExpr Bool -> SMTExpr Bool)
-                    -> VarEnv i
-                    -> Definition i
+                    -> StreamPos
+                    -> Definition
                     -> m ()
-assertDefinition f env (SingleDef al s) = liftSMT $ assert (f $ s `app` (lookupArgs al env))
-assertDefinition f env (ProdDef ps) = mapM_ (assertDefinition f env) $ Arr.elems ps
-
-lookupArgs :: Ident i => [i] -> VarEnv i -> [SMTExpr Bool]
-lookupArgs al env = map (lookupArgs' env) al
-  where
-    lookupArgs' env i = case Map.lookup i (vars env) of
-                          Just x -> unBool' x
-                          Nothing -> error "bla"--(flip lookupArgs' $ i) . nodeEnvVars $ Map.elems (nodes env)
-
+assertDefinition f i (SingleDef s) = do return ()--liftSMT $ assert (f $ s `app` i)
+assertDefinition f i (ProdDef ps) = mapM_ (assertDefinition f i) $ Arr.elems ps
 
-data ProgDefs i = ProgDefs
-                { flowDef :: [Definition i]
-                , precondition :: Definition i
-                , invariantDef :: Definition i
+data ProgDefs = ProgDefs
+                { flowDef :: [Definition]
+                , precondition :: Definition
+                , invariantDef :: Definition
                 }
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index 3172b71..e468975 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -12,13 +12,10 @@ import Control.Monad (when, liftM)
 
 import Language.SMTLib2
 
-import Lang.LAMA.Identifier
-
 import Strategy
 import LamaSMTTypes
 import Definition
-import Model (Model, getModel)
-import TransformEnv
+import Model (Model)
 import Internal.Monads
 
 data BMC = BMC
@@ -36,56 +33,55 @@ instance StrategyClass BMC where
     s { bmcPrintProgress = True }
   readOption o _ = error $ "Invalid BMC option: " ++ o
 
-  check natAnn s env defs =
+  check natAnn s getModel defs =
     let base = 0
     in do baseDef <- liftSMT . defConst $ constantAnn base natAnn
-          check' natAnn s env defs (Map.singleton base baseDef) base baseDef
+          check' natAnn s getModel defs (Map.singleton base baseDef) base baseDef
 
-assumeTrace :: (Ident i, MonadSMT m) => ProgDefs i -> VarEnv i -> m ()
-assumeTrace defs env =
-  assertDefs env (flowDef defs) >>
-  assertPrecond env (precondition defs)
+assumeTrace :: MonadSMT m => ProgDefs -> StreamPos -> m ()
+assumeTrace defs iDef =
+  assertDefs iDef (flowDef defs) >>
+  assertPrecond iDef (precondition defs)
 
-bmcStep :: (Ident i, MonadSMT m) =>
-        VarEnv i   
-        -> ProgDefs i
+bmcStep :: MonadSMT m =>
+        (Map Natural StreamPos -> SMT (Model i))
+        -> ProgDefs
         -> Map Natural StreamPos
         -> StreamPos
         -> m (Maybe (Model i))
-bmcStep env defs pastIndices iDef =
-  do assumeTrace defs env
+bmcStep getModel defs pastIndices iDef =
+  do assumeTrace defs iDef
      let invs = invariantDef defs
      liftSMT . stack
-       $ checkInvariant env invs >>=
-       checkGetModel (getModel env) pastIndices
+       $ checkInvariant iDef invs >>=
+       checkGetModel getModel pastIndices
 
-check' :: Ident i =>
-       SMTAnnotation Natural
+check' :: SMTAnnotation Natural
        -> BMC
-       -> VarEnv i
-       -> ProgDefs i
+       -> (Map Natural StreamPos -> SMT (Model i))
+       -> ProgDefs
        -> Map Natural StreamPos
        -> Natural
        -> StreamPos
        -> SMTErr (StrategyResult i)
-check' natAnn s env defs pastIndices i iDef =
+check' natAnn s getModel defs pastIndices i iDef =
   do liftIO $ when (bmcPrintProgress s) (putStrLn $ "Depth " ++ show i)
-     r <- bmcStep env defs pastIndices iDef
+     r <- bmcStep getModel defs pastIndices iDef
      case r of
-       Nothing -> next (check' natAnn s env defs) natAnn s pastIndices i iDef
+       Nothing -> next (check' natAnn s getModel defs) natAnn s pastIndices i iDef
        Just m -> return $ Failure i m
 
-assertDefs :: (Ident i, MonadSMT m) => VarEnv i -> [Definition i] -> m ()
+assertDefs :: MonadSMT m => SMTExpr Natural -> [Definition] -> m ()
 assertDefs i = mapM_ (assertDef i)
 
-assertDef :: (Ident i, MonadSMT m) => VarEnv i -> Definition i -> m ()
+assertDef :: MonadSMT m => SMTExpr Natural -> Definition -> m ()
 assertDef = assertDefinition id
 
-assertPrecond :: (Ident i, MonadSMT m) => VarEnv i -> Definition i -> m ()
+assertPrecond :: MonadSMT m => SMTExpr Natural -> Definition -> m ()
 assertPrecond = assertDefinition id
 
 -- | Returns true, if the invariant holds
-checkInvariant :: (Ident i, MonadSMT m) => VarEnv i -> Definition i -> m Bool
+checkInvariant :: MonadSMT m => SMTExpr Natural -> Definition -> m Bool
 checkInvariant i p = liftSMT $ assertDefinition not' i p >> liftM not checkSat
 
 checkGetModel :: MonadSMT m =>
diff --git a/lamaSMT/lib/Strategies/Factory.hs b/lamaSMT/lib/Strategies/Factory.hs
index f27c36e..e4b6e7e 100644
--- a/lamaSMT/lib/Strategies/Factory.hs
+++ b/lamaSMT/lib/Strategies/Factory.hs
@@ -44,5 +44,5 @@ getStrategyHelp lineLength = renderStyle (style { lineLength }) $
 
 getStrategy :: String -> Strategy
 getStrategy "bmc" = Strategy (defaultStrategyOpts :: BMC)
---getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
-getStrategy _ = error "Unknown strategy"
+getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
+getStrategy _ = error "Unknown strategy"
\ No newline at end of file
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index 12ebb79..7377ba4 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 module Strategies.KInduction where
-{-
+
 import Data.Natural
 import NatInstance
 import Data.List (stripPrefix)
@@ -140,4 +140,3 @@ retrieveHints getModel indOpts k success =
          else return []
        (AllInductionSteps, _      ) ->
          getModel >>= \m -> return [Hint (show k) m]
--}
diff --git a/lamaSMT/lib/Strategy.hs b/lamaSMT/lib/Strategy.hs
index 2a38324..8f421a3 100644
--- a/lamaSMT/lib/Strategy.hs
+++ b/lamaSMT/lib/Strategy.hs
@@ -10,9 +10,6 @@ import Control.Monad.Error
 
 import Language.SMTLib2
 
-import Debug.Trace
-import Lang.LAMA.Identifier
-
 import LamaSMTTypes
 import Definition
 import TransformEnv
@@ -31,18 +28,18 @@ data Strategy = forall s. StrategyClass s => Strategy s
 class StrategyClass s where
   defaultStrategyOpts :: s
   readOption :: String -> s -> s
-  check :: Ident i => SMTAnnotation Natural
+  check :: SMTAnnotation Natural
            -> s
-           -> VarEnv i
-           -> ProgDefs i
+           -> (Map Natural StreamPos -> SMT (Model i))
+           -> ProgDefs
            -> SMTErr (StrategyResult i)
 
-checkWithModel :: Ident i => SMTAnnotation Natural
+checkWithModel :: SMTAnnotation Natural
                -> Strategy
-               -> ProgDefs i
+               -> ProgDefs
                -> VarEnv i
                -> SMTErr (StrategyResult i)
-checkWithModel natAnn (Strategy s) d env = trace (show env) $ check natAnn s env d
+checkWithModel natAnn (Strategy s) d env = check natAnn s (getModel env) d
 
 readOptions' :: String -> Strategy -> Strategy
 readOptions' o (Strategy s) = Strategy $ readOption o s
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index ce2f475..f84cccd 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -73,14 +73,14 @@ getBottom (ProdExpr strs)  = ProdExpr $ fmap getBottom strs
 -- gets a value at that time (after getting the model).
 lamaSMT :: Ident i =>
            NatImplementation -> EnumImplementation -> Program i
-           -> ErrorT String SMT (ProgDefs i, VarEnv i)
+           -> ErrorT String SMT (ProgDefs, VarEnv i)
 lamaSMT natImpl' enumImpl' =
   fmap (second varEnv)
   . flip runStateT (emptyEnv natImpl' enumImpl')
   . declProgram
 
 -- | Declare the formulas which define a LAMA program.
-declProgram :: Ident i => Program i -> DeclM i (ProgDefs i)
+declProgram :: Ident i => Program i -> DeclM i ProgDefs
 declProgram p =
   do preamble
      putConstants (progConstantDefinitions p)
@@ -90,7 +90,7 @@ declProgram p =
      assertInits (progInitial p)
      precondDef <- declarePrecond Nothing (progAssertion p)
      invarDef <- declareInvariant Nothing (progInvariant p)
-     return $ ProgDefs (declDefs ++ flowDefs) precondDef invarDef
+     return $ ProgDefs (declDefs{- ++ flowDefs-}) precondDef invarDef
 
 -- | Declares common types etc.
 -- At the moment just Natural is defined.
@@ -122,7 +122,7 @@ declareDecls :: Ident i =>
                 Maybe (SMTFunction [SMTExpr Bool] Bool)
                 -> Set i
                 -> Declarations i
-                -> DeclM i ([Definition i], Map i (Node i))
+                -> DeclM i ([Definition], Map i (Node i))
 declareDecls activeCond excludeNodes d =
   do let (excluded, toDeclare)
            = Map.partitionWithKey (\n _ -> n `Set.member` excludeNodes)
@@ -132,7 +132,7 @@ declareDecls activeCond excludeNodes d =
      locs <- declareVars $ declsLocal d
      states <- declareVars $ declsState d
      modifyVars $ mappend (inp `mappend` locs `mappend` states)
-     return (concat defs, excluded)
+     return ({-concat defs-}[], excluded)
 
 declareVars :: Ident i => [Variable i] -> DeclM i (Map i (TypedExpr i))
 declareVars = fmap (Map.fromList) . declareVarList
@@ -187,7 +187,7 @@ enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
 -- declared. The other nodes are deferred to be declared in the corresponding
 -- location (see declareAutomaton and declareLocations).
 declareNode :: Ident i =>
-               Maybe (SMTFunction [SMTExpr Bool] Bool) -> i -> Node i -> DeclM i [Definition i]
+               Maybe (SMTFunction [SMTExpr Bool] Bool) -> i -> Node i -> DeclM i [Definition]
 declareNode active nName nDecl =
   do (interface, defs) <- localVarEnv (const emptyVarEnv) $
                           declareNode' active nDecl
@@ -196,7 +196,7 @@ declareNode active nName nDecl =
   where
     declareNode' :: Ident i =>
                     Maybe (SMTFunction [SMTExpr Bool] Bool) -> Node i
-                    -> DeclM i (NodeEnv i, [Definition i])
+                    -> DeclM i (NodeEnv i, [Definition])
     declareNode' activeCond n =
       do let automNodes =
                mconcat . map getNodesInLocations . Map.elems $ nodeAutomata n
@@ -231,7 +231,7 @@ getNodesInLocations = mconcat . map getUsedLoc . automLocations
 declareInstantDef :: Ident i =>
                      Maybe (SMTFunction [SMTExpr Bool] Bool)
                      -> InstantDefinition i
-                     -> DeclM i [Definition i]
+                     -> DeclM i [Definition]
 declareInstantDef activeCond inst@(InstantExpr x e) =
   do (res, []) <- trInstant (error "no activation condition") inst
      xVar <- lookupVar x
@@ -250,7 +250,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
 -- used to further refine this instant (e.g. wrap it into an ite).
 -- This may also return definitions of the parameters of a node.
 -- The activation condition is only used for the inputs of a node.
-trInstant :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i, [Definition i])
+trInstant :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i, [Definition])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
 trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
@@ -279,7 +279,7 @@ trOutput map = do
 declareTransition :: Ident i =>
                      Maybe (SMTFunction [SMTExpr Bool] Bool)
                      -> StateTransition i
-                     -> DeclM i (Definition i)
+                     -> DeclM i Definition
 declareTransition activeCond (StateTransition x e) =
   do xVar     <- lookupVar x
      let e'      = runTransM $ trExpr e
@@ -296,7 +296,7 @@ declareConditionalAssign :: Ident i =>
                             -> TypedExpr i
                             -> Set i
                             -> (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i)
-                            -> DeclM i (Definition i)
+                            -> DeclM i Definition
 declareConditionalAssign activeCond defaultExpr x al ef =
   case activeCond of
     Nothing -> declareDef x al ef
@@ -317,18 +317,18 @@ declareConditionalAssign activeCond defaultExpr x al ef =
 -- The second argument /x/ is the stream to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
 declareDef :: Ident i => TypedExpr i -> Set i ->
-              (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i) -> DeclM i (Definition i)
+              (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i) -> DeclM i Definition
 declareDef x as ef =
   do env         <- get
      let defType = varDefType x
      d           <- defFunc (1 + Set.size as) defType
                     $ \a -> liftRel (.==.) (BoolExpr $ head a) $ ef env $ zip (Set.toList as) (tail a)
-     return $ ensureDefinition (Set.toList as) d
+     return $ ensureDefinition d
   where
     varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
     varDefType _               = boolT
 
-declareFlow :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Flow i -> DeclM i [Definition i]
+declareFlow :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Flow i -> DeclM i [Definition]
 declareFlow activeCond f =
   do defDefs        <- fmap concat
                        . mapM (declareInstantDef activeCond)
@@ -680,7 +680,7 @@ assertInit (x, e) =
 
 -- | Creates a definition for a precondition p. If an activation condition c
 -- is given, the resulting condition is (=> c p).
-declarePrecond :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i (Definition i)
+declarePrecond :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
   do env <- get
      d <- case activeCond of
@@ -689,10 +689,10 @@ declarePrecond activeCond e =
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ getArgSet e) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
-     return $ ensureDefinition (Set.toList $ getArgSet e)d
+     return $ ensureDefinition d
 
 declareInvariant :: Ident i =>
-                    Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i (Definition i)
+                    Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
 declareInvariant = declarePrecond
 
 trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr i)
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 21911e2..c01f831 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -31,7 +31,6 @@ data NodeEnv i = NodeEnv
                  , nodeEnvOut :: Map i (TypedExpr i)
                  , nodeEnvVars :: VarEnv i
                  }
-  deriving Show
 
 data VarEnv i = VarEnv
                 { nodes :: Map i (NodeEnv i)
@@ -39,7 +38,6 @@ data VarEnv i = VarEnv
                   -- ^ Maps names of variables to a SMT expression for using
                   -- that variable
                 }
-  deriving Show
 
 data Env i = Env
            { constants :: Map i (TypedExpr i)

From 277966c87bfe058f1325f3dc47c71329000069e9 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 16 Sep 2015 16:50:14 +0200
Subject: [PATCH 022/104] Reactivated some commented Declarations

---
 lamaSMT/lib/Transform.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index f84cccd..cc6039f 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -90,7 +90,7 @@ declProgram p =
      assertInits (progInitial p)
      precondDef <- declarePrecond Nothing (progAssertion p)
      invarDef <- declareInvariant Nothing (progInvariant p)
-     return $ ProgDefs (declDefs{- ++ flowDefs-}) precondDef invarDef
+     return $ ProgDefs (declDefs ++ flowDefs) precondDef invarDef
 
 -- | Declares common types etc.
 -- At the moment just Natural is defined.
@@ -132,7 +132,7 @@ declareDecls activeCond excludeNodes d =
      locs <- declareVars $ declsLocal d
      states <- declareVars $ declsState d
      modifyVars $ mappend (inp `mappend` locs `mappend` states)
-     return ({-concat defs-}[], excluded)
+     return (concat defs, excluded)
 
 declareVars :: Ident i => [Variable i] -> DeclM i (Map i (TypedExpr i))
 declareVars = fmap (Map.fromList) . declareVarList

From a3cc3b72929ee3a905dbcc232e56fff6cdf97733 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 16 Sep 2015 18:33:59 +0200
Subject: [PATCH 023/104] Global list of variables, but no correct assignment

---
 lamaSMT/Main.hs                      |  4 +--
 lamaSMT/lib/Definition.hs            | 17 +++++++-----
 lamaSMT/lib/Strategies/BMC.hs        | 41 ++++++++++++++--------------
 lamaSMT/lib/Strategies/Factory.hs    |  4 +--
 lamaSMT/lib/Strategies/KInduction.hs |  3 +-
 lamaSMT/lib/Strategy.hs              |  6 ++--
 lamaSMT/lib/Transform.hs             | 23 ++++++++--------
 lamaSMT/lib/TransformEnv.hs          |  7 ++++-
 8 files changed, 57 insertions(+), 48 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index 47eb06c..a56b6ee 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -169,8 +169,8 @@ run opts@Options{..} file inp = do
   liftIO $ when optDumpLama (print p)
   model <- runCheck opts
     ( (liftSMT $ mapM_ setOption optSMTOpts) >>
-      lamaSMT optNatImpl optEnumImpl p) {- >>=
-      (uncurry $ checkWithModel optNatImpl optStrategy) ) -}
+      lamaSMT optNatImpl optEnumImpl p >>=
+      (uncurry $ checkWithModel optNatImpl optStrategy) )
   --liftIO $ checkModel opts p model
   liftIO $ putStr "Test"
 
diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 3aaafa7..74e8f39 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -8,24 +8,27 @@ import LamaSMTTypes
 import Internal.Monads
 
 data Definition =
-  SingleDef (SMTFunction [SMTExpr Bool] Bool)
+  SingleDef [Int] (SMTFunction [SMTExpr Bool] Bool)
   | ProdDef (Array Int Definition)
   deriving Show
 
-ensureDefinition :: TypedFunc i -> Definition
-ensureDefinition (BoolFunc s) = SingleDef s
-ensureDefinition (ProdFunc ps) = ProdDef $ fmap ensureDefinition ps
-ensureDefinition _
+ensureDefinition :: [Int] -> TypedFunc i -> Definition
+ensureDefinition argN (BoolFunc s) = SingleDef argN s
+ensureDefinition argN (ProdFunc ps) = ProdDef $ fmap (ensureDefinition argN) ps
+ensureDefinition argN _
   = error $ "ensureDefinition: not a boolean function" -- : " ++ show s
 
 assertDefinition :: MonadSMT m =>
                     (SMTExpr Bool -> SMTExpr Bool)
-                    -> StreamPos
+                    -> [SMTExpr Bool]
                     -> Definition
                     -> m ()
-assertDefinition f i (SingleDef s) = do return ()--liftSMT $ assert (f $ s `app` i)
+assertDefinition f i (SingleDef argN s) = liftSMT $ assert (f $ s `app` (lookupArgs argN i))
 assertDefinition f i (ProdDef ps) = mapM_ (assertDefinition f i) $ Arr.elems ps
 
+lookupArgs :: [Int] -> [SMTExpr Bool] -> [SMTExpr Bool]
+lookupArgs argN vars = map ((!!) vars) argN
+
 data ProgDefs = ProgDefs
                 { flowDef :: [Definition]
                 , precondition :: Definition
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index e468975..93cf8d8 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -15,7 +15,8 @@ import Language.SMTLib2
 import Strategy
 import LamaSMTTypes
 import Definition
-import Model (Model)
+import TransformEnv
+import Model (Model, getModel)
 import Internal.Monads
 
 data BMC = BMC
@@ -33,55 +34,55 @@ instance StrategyClass BMC where
     s { bmcPrintProgress = True }
   readOption o _ = error $ "Invalid BMC option: " ++ o
 
-  check natAnn s getModel defs =
+  check natAnn s env defs =
     let base = 0
     in do baseDef <- liftSMT . defConst $ constantAnn base natAnn
-          check' natAnn s getModel defs (Map.singleton base baseDef) base baseDef
+          check' natAnn s env defs (Map.singleton base baseDef) base baseDef
 
-assumeTrace :: MonadSMT m => ProgDefs -> StreamPos -> m ()
-assumeTrace defs iDef =
-  assertDefs iDef (flowDef defs) >>
-  assertPrecond iDef (precondition defs)
+assumeTrace :: MonadSMT m => ProgDefs -> [SMTExpr Bool] -> m ()
+assumeTrace defs args =
+  assertDefs args (flowDef defs) >>
+  assertPrecond args (precondition defs)
 
 bmcStep :: MonadSMT m =>
-        (Map Natural StreamPos -> SMT (Model i))
+        Env i
         -> ProgDefs
         -> Map Natural StreamPos
         -> StreamPos
         -> m (Maybe (Model i))
-bmcStep getModel defs pastIndices iDef =
-  do assumeTrace defs iDef
+bmcStep env defs pastIndices iDef =
+  do assumeTrace defs $ varList env
      let invs = invariantDef defs
      liftSMT . stack
-       $ checkInvariant iDef invs >>=
-       checkGetModel getModel pastIndices
+       $ checkInvariant (varList env) invs >>=
+       checkGetModel (getModel $ varEnv env) pastIndices
 
 check' :: SMTAnnotation Natural
        -> BMC
-       -> (Map Natural StreamPos -> SMT (Model i))
+       -> Env i
        -> ProgDefs
        -> Map Natural StreamPos
        -> Natural
        -> StreamPos
        -> SMTErr (StrategyResult i)
-check' natAnn s getModel defs pastIndices i iDef =
+check' natAnn s env defs pastIndices i iDef =
   do liftIO $ when (bmcPrintProgress s) (putStrLn $ "Depth " ++ show i)
-     r <- bmcStep getModel defs pastIndices iDef
+     r <- bmcStep env defs pastIndices iDef
      case r of
-       Nothing -> next (check' natAnn s getModel defs) natAnn s pastIndices i iDef
+       Nothing -> next (check' natAnn s env defs) natAnn s pastIndices i iDef
        Just m -> return $ Failure i m
 
-assertDefs :: MonadSMT m => SMTExpr Natural -> [Definition] -> m ()
+assertDefs :: MonadSMT m => [SMTExpr Bool] -> [Definition] -> m ()
 assertDefs i = mapM_ (assertDef i)
 
-assertDef :: MonadSMT m => SMTExpr Natural -> Definition -> m ()
+assertDef :: MonadSMT m => [SMTExpr Bool] -> Definition -> m ()
 assertDef = assertDefinition id
 
-assertPrecond :: MonadSMT m => SMTExpr Natural -> Definition -> m ()
+assertPrecond :: MonadSMT m => [SMTExpr Bool] -> Definition -> m ()
 assertPrecond = assertDefinition id
 
 -- | Returns true, if the invariant holds
-checkInvariant :: MonadSMT m => SMTExpr Natural -> Definition -> m Bool
+checkInvariant :: MonadSMT m => [SMTExpr Bool] -> Definition -> m Bool
 checkInvariant i p = liftSMT $ assertDefinition not' i p >> liftM not checkSat
 
 checkGetModel :: MonadSMT m =>
diff --git a/lamaSMT/lib/Strategies/Factory.hs b/lamaSMT/lib/Strategies/Factory.hs
index e4b6e7e..f27c36e 100644
--- a/lamaSMT/lib/Strategies/Factory.hs
+++ b/lamaSMT/lib/Strategies/Factory.hs
@@ -44,5 +44,5 @@ getStrategyHelp lineLength = renderStyle (style { lineLength }) $
 
 getStrategy :: String -> Strategy
 getStrategy "bmc" = Strategy (defaultStrategyOpts :: BMC)
-getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
-getStrategy _ = error "Unknown strategy"
\ No newline at end of file
+--getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
+getStrategy _ = error "Unknown strategy"
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index 7377ba4..12ebb79 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 module Strategies.KInduction where
-
+{-
 import Data.Natural
 import NatInstance
 import Data.List (stripPrefix)
@@ -140,3 +140,4 @@ retrieveHints getModel indOpts k success =
          else return []
        (AllInductionSteps, _      ) ->
          getModel >>= \m -> return [Hint (show k) m]
+-}
diff --git a/lamaSMT/lib/Strategy.hs b/lamaSMT/lib/Strategy.hs
index 8f421a3..e35e92e 100644
--- a/lamaSMT/lib/Strategy.hs
+++ b/lamaSMT/lib/Strategy.hs
@@ -30,16 +30,16 @@ class StrategyClass s where
   readOption :: String -> s -> s
   check :: SMTAnnotation Natural
            -> s
-           -> (Map Natural StreamPos -> SMT (Model i))
+           -> Env i
            -> ProgDefs
            -> SMTErr (StrategyResult i)
 
 checkWithModel :: SMTAnnotation Natural
                -> Strategy
                -> ProgDefs
-               -> VarEnv i
+               -> Env i
                -> SMTErr (StrategyResult i)
-checkWithModel natAnn (Strategy s) d env = check natAnn s (getModel env) d
+checkWithModel natAnn (Strategy s) d env = check natAnn s env d
 
 readOptions' :: String -> Strategy -> Strategy
 readOptions' o (Strategy s) = Strategy $ readOption o s
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index cc6039f..ab4ee49 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -73,10 +73,9 @@ getBottom (ProdExpr strs)  = ProdExpr $ fmap getBottom strs
 -- gets a value at that time (after getting the model).
 lamaSMT :: Ident i =>
            NatImplementation -> EnumImplementation -> Program i
-           -> ErrorT String SMT (ProgDefs, VarEnv i)
+           -> ErrorT String SMT (ProgDefs, Env i)
 lamaSMT natImpl' enumImpl' =
-  fmap (second varEnv)
-  . flip runStateT (emptyEnv natImpl' enumImpl')
+  flip runStateT (emptyEnv natImpl' enumImpl')
   . declProgram
 
 -- | Declare the formulas which define a LAMA program.
@@ -128,9 +127,9 @@ declareDecls activeCond excludeNodes d =
            = Map.partitionWithKey (\n _ -> n `Set.member` excludeNodes)
              $ declsNode d
      defs <- mapM (uncurry $ declareNode activeCond) $ Map.toList toDeclare
-     inp <- declareVars $ declsInput d
-     locs <- declareVars $ declsLocal d
-     states <- declareVars $ declsState d
+     inp <- trace "inp" $ declareVars $ declsInput d
+     locs <- trace "locs" $ declareVars $ declsLocal d
+     states <- trace "states" $ declareVars $ declsState d
      modifyVars $ mappend (inp `mappend` locs `mappend` states)
      return (concat defs, excluded)
 
@@ -142,12 +141,12 @@ declareVarList = mapM declareVar
 
 declareVar :: Ident i => Variable i -> DeclM i ((i, TypedExpr i))
 declareVar (Variable x t) =
-  --do natAnn <- gets natImpl
-     (x,) <$> typedVar (identString x) t
+  do v    <- typedVar (identString x) t
+     addVar v
+     return (x, v)
   where
     typedVar :: Ident i =>
                 String
-                -- -> SMTAnnotation Natural
                 -> Type i
                 -> DeclM i (TypedExpr i)
     typedVar v (GroundType BoolT)
@@ -202,7 +201,7 @@ declareNode active nName nDecl =
                mconcat . map getNodesInLocations . Map.elems $ nodeAutomata n
          (declDefs, undeclaredNodes) <-
            declareDecls activeCond automNodes $ nodeDecls n
-         outDecls <- declareVarList $ nodeOutputs n
+         outDecls <- trace "outDecls" $ declareVarList $ nodeOutputs n
          ins <- mapM (lookupVar . varIdent) . declsInput $ nodeDecls n
          let outs = Map.fromList outDecls
          modifyVars $ Map.union (Map.fromList outDecls)
@@ -323,7 +322,7 @@ declareDef x as ef =
      let defType = varDefType x
      d           <- defFunc (1 + Set.size as) defType
                     $ \a -> liftRel (.==.) (BoolExpr $ head a) $ ef env $ zip (Set.toList as) (tail a)
-     return $ ensureDefinition d
+     return $ ensureDefinition [1, 2] d
   where
     varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
     varDefType _               = boolT
@@ -689,7 +688,7 @@ declarePrecond activeCond e =
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ getArgSet e) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
-     return $ ensureDefinition d
+     return $ ensureDefinition [1, 2] d
 
 declareInvariant :: Ident i =>
                     Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index c01f831..1b3e183 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -45,6 +45,7 @@ data Env i = Env
            , enumConsAnn :: Map (EnumConstr i) (SMTAnnotation SMTEnum)
            , varEnv :: VarEnv i
            , currAutomatonIndex :: Integer
+           , varList :: [SMTExpr Bool]
            , natImpl :: NatImplementation
            , enumImpl :: EnumImplementation
            }
@@ -53,7 +54,7 @@ emptyVarEnv :: VarEnv i
 emptyVarEnv = VarEnv Map.empty Map.empty
 
 emptyEnv :: NatImplementation -> EnumImplementation -> Env i
-emptyEnv = Env Map.empty Map.empty Map.empty emptyVarEnv 0
+emptyEnv = Env Map.empty Map.empty Map.empty emptyVarEnv 0 []
 
 type DeclM i = StateT (Env i) (ErrorT String SMT)
 
@@ -62,6 +63,10 @@ putConstants cs =
   let cs' = fmap trConstant cs
   in modify $ \env -> env { constants = cs' }
 
+addVar :: Ident i => TypedExpr i -> DeclM i ()
+addVar var =
+  modify $ \env -> env { varList = (varList env) ++ [unBool' var] }
+
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()
 putEnumAnn eAnns =
   modify $ \env -> env { enumAnn = (enumAnn env) `Map.union` eAnns }

From 3dc270fef24f20e441deb742e2059ac3124c17f0 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 17 Sep 2015 01:46:39 +0200
Subject: [PATCH 024/104] Assignment now working except for transitions

---
 lamaSMT/lib/Transform.hs    | 53 +++++++++++++++++++++++--------------
 lamaSMT/lib/TransformEnv.hs |  8 ++++++
 2 files changed, 41 insertions(+), 20 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index ab4ee49..14f108e 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -34,6 +34,8 @@ import qualified Data.Set as Set
 import Data.Set (Set, union, unions)
 import qualified Data.Map as Map
 import Data.Map (Map)
+import qualified Data.List as List
+import Data.List (zip4)
 import Prelude hiding (mapM)
 import Data.Traversable
 import Data.Foldable (foldlM, foldrM)
@@ -234,15 +236,19 @@ declareInstantDef :: Ident i =>
 declareInstantDef activeCond inst@(InstantExpr x e) =
   do (res, []) <- trInstant (error "no activation condition") inst
      xVar <- lookupVar x
+     let args = getArgSet e
+     argsE <- mapM lookupVar $ Set.toList args
+     argsN <- mapM getN argsE
      def <- declareConditionalAssign
-            activeCond (getBottom xVar) xVar (getArgSet e) res
+            activeCond (getBottom xVar) xVar args argsN res
      return [def]
 declareInstantDef activeCond inst@(NodeUsage x n _) =
   do (outp, inpDefs) <- trInstant activeCond inst
      xVar            <- lookupVar x
      nEnv            <- lookupNode n
+     outN            <- mapM getN $ nodeEnvOut nEnv
      outpDef         <- declareConditionalAssign
-                        activeCond (getBottom xVar) xVar (Map.keysSet $ nodeEnvOut nEnv) outp
+                        activeCond (getBottom xVar) xVar (Map.keysSet $ nodeEnvOut nEnv) (Map.elems outN) outp
      return $ inpDefs ++ [outpDef]
 
 -- | Translates an instant definition into a function which can be
@@ -255,10 +261,13 @@ trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
      let esTr = map (runTransM . trExpr) es
          y    = runTransM $ trOutput $ nodeEnvOut nEnv
-     inpDefs  <- mapM (\(x, eTr, e) ->
+         ins = map (Set.toList . getArgSet) es
+     insE <- mapM (mapM lookupVar) ins
+     insN <- mapM (mapM getN) insE
+     inpDefs  <- mapM (\(x, n, e, eTr) ->
                         declareConditionalAssign
-                        inpActive (getBottom x) x (getArgSet e) eTr)
-                 $ zip3 (nodeEnvIn nEnv) esTr es
+                        inpActive (getBottom x) x (getArgSet e) n eTr)
+                 $ zip4 (nodeEnvIn nEnv) insN es esTr
      return (y, inpDefs)
 
 trOutput :: Ident i => Map i (TypedExpr i) -> TransM i (TypedExpr i)
@@ -282,7 +291,7 @@ declareTransition :: Ident i =>
 declareTransition activeCond (StateTransition x e) =
   do xVar     <- lookupVar x
      let e'      = runTransM $ trExpr e
-     declareConditionalAssign activeCond (getBottom xVar) xVar (getArgSet e) e'
+     declareConditionalAssign activeCond (getBottom xVar) xVar (getArgSet e) [] e'
 
 -- | Creates a declaration for an assignment. Depending on the
 -- activation condition the given expression or a default expression
@@ -294,13 +303,14 @@ declareConditionalAssign :: Ident i =>
                             -> TypedExpr i
                             -> TypedExpr i
                             -> Set i
+                            -> [Int]
                             -> (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i)
                             -> DeclM i Definition
-declareConditionalAssign activeCond defaultExpr x al ef =
+declareConditionalAssign activeCond defaultExpr x al ns ef =
   case activeCond of
-    Nothing -> declareDef x al ef
+    Nothing -> declareDef x al ns ef
     Just c  ->
-      declareDef x al ef
+      declareDef x al ns ef
       --declareDef modPos x (mkConditionalExpr c e defaultExpr)
   where
     -- | Takes a condition and the corresponding branches which may depend
@@ -315,14 +325,15 @@ declareConditionalAssign activeCond defaultExpr x al ef =
 -- id or succ' to define instances or state transitions).
 -- The second argument /x/ is the stream to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
-declareDef :: Ident i => TypedExpr i -> Set i ->
+declareDef :: Ident i => TypedExpr i -> Set i -> [Int] ->
               (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i) -> DeclM i Definition
-declareDef x as ef =
+declareDef x as ns ef =
   do env         <- get
      let defType = varDefType x
+     xN          <- getN x
      d           <- defFunc (1 + Set.size as) defType
                     $ \a -> liftRel (.==.) (BoolExpr $ head a) $ ef env $ zip (Set.toList as) (tail a)
-     return $ ensureDefinition [1, 2] d
+     return $ ensureDefinition ([xN] ++ ns) d
   where
     varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
     varDefType _               = boolT
@@ -681,14 +692,17 @@ assertInit (x, e) =
 -- is given, the resulting condition is (=> c p).
 declarePrecond :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
-  do env <- get
-     d <- case activeCond of
-       Nothing -> defFunc (Set.size $ getArgSet e) boolT $ \a -> runTransM (trExpr e) env (zip (Set.toList $ getArgSet e) a)
-       Just c -> defFunc (Set.size $ getArgSet e) boolT $
-                 \a -> (flip (flip runTransM env) (zip (Set.toList $ getArgSet e) a))
+  do env      <- get
+     let args = getArgSet e
+     argsE    <- mapM lookupVar $ Set.toList args
+     argsN    <- mapM getN argsE
+     d        <- case activeCond of
+       Nothing -> defFunc (Set.size $ args) boolT $ \a -> runTransM (trExpr e) env (zip (Set.toList $ args) a)
+       Just c -> defFunc (Set.size $ args) boolT $
+                 \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
-     return $ ensureDefinition [1, 2] d
+     return $ ensureDefinition argsN d
 
 declareInvariant :: Ident i =>
                     Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
@@ -741,11 +755,10 @@ getArgSet expr = case untyped expr of
   LogNot e             -> getArgSet e
   Expr2 op e1 e2       -> Set.union (getArgSet e1) (getArgSet e2)
   Ite c e1 e2          -> Set.unions [getArgSet c, getArgSet e1, getArgSet e2]
-  ProdCons (Prod es)   -> foldr (union . getArgSet) Set.empty es
+  ProdCons (Prod es)   -> foldr (Set.union . getArgSet) Set.empty es
   Project x i          -> Set.empty
   Match e pats         -> getArgSet e
 
-
 -- we do no further type checks since this
 -- has been done beforehand.
 trExpr :: Ident i => Expr i -> TransM i (TypedExpr i)
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 1b3e183..35a9d7a 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -11,6 +11,8 @@ import Lang.LAMA.Types
 import Language.SMTLib2 as SMT
 
 import Data.Array as Arr
+import qualified Data.List as List
+import Data.List (elemIndex)
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Prelude hiding (mapM)
@@ -67,6 +69,12 @@ addVar :: Ident i => TypedExpr i -> DeclM i ()
 addVar var =
   modify $ \env -> env { varList = (varList env) ++ [unBool' var] }
 
+getN :: TypedExpr i -> DeclM i Int
+getN x = do vars <- gets varList
+            return $ case List.elemIndex (unBool' x) vars of
+                          Nothing -> error $ "Could not be found in list of     variables: " ++ show x
+                          Just n -> n
+
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()
 putEnumAnn eAnns =
   modify $ \env -> env { enumAnn = (enumAnn env) `Map.union` eAnns }

From 11e17fc83304029278ed726e92cd1adabd7fd4c4 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 17 Sep 2015 03:50:31 +0200
Subject: [PATCH 025/104] BMC working on nodes without automatons

Assignment are now also correct for transitions.
The argument assignments are stored in the
definitions. BMC is working for some LAMA programs
(Switch.lm).
---
 lamaSMT/Main.hs               |  4 +-
 lamaSMT/lib/Definition.hs     | 20 +++++-----
 lamaSMT/lib/Strategies/BMC.hs | 71 +++++++++++++++++------------------
 lamaSMT/lib/Strategy.hs       |  2 +-
 lamaSMT/lib/Transform.hs      | 26 +++++++------
 5 files changed, 65 insertions(+), 58 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index a56b6ee..ed145cf 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -205,13 +205,14 @@ runCheck progOpts = chooseSolver progOpts . checkError
                       -- ++ solverBase
   -- withPipe solverCmd []
 
+{-
 checkModel :: Ident i =>
            Options
            -> Program i
            -> (StrategyResult i)
            -> IO ()
 checkModel _ _ Success = putStrLn "42"
-checkModel opts prog (Failure lastIndex m) =
+checkModel opts prog (Failure lastIndexm) =
   do putStrLn ":-("
      putStrLn $ "Found counterexample at depth " ++ show lastIndex
      when (optDumpModel opts) (putStrLn . render $ prettyModel m)
@@ -231,6 +232,7 @@ checkModel opts prog (Unknown what hints) =
                  . render
                  $ scadeScenario prog (optTopNodePath opts) (hintModel h))
                hints
+-}
 
 prettyHints :: Ident i => Hints i -> Doc
 prettyHints = vcat . map prettyHint
diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 74e8f39..11c9436 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -8,26 +8,28 @@ import LamaSMTTypes
 import Internal.Monads
 
 data Definition =
-  SingleDef [Int] (SMTFunction [SMTExpr Bool] Bool)
+  SingleDef [Int] Bool (SMTFunction [SMTExpr Bool] Bool)
   | ProdDef (Array Int Definition)
   deriving Show
 
-ensureDefinition :: [Int] -> TypedFunc i -> Definition
-ensureDefinition argN (BoolFunc s) = SingleDef argN s
-ensureDefinition argN (ProdFunc ps) = ProdDef $ fmap (ensureDefinition argN) ps
-ensureDefinition argN _
+ensureDefinition :: [Int] -> Bool -> TypedFunc i -> Definition
+ensureDefinition argN succ (BoolFunc s) = SingleDef argN succ s
+ensureDefinition argN succ (ProdFunc ps) = ProdDef $ fmap (ensureDefinition argN succ) ps
+ensureDefinition argN succ _
   = error $ "ensureDefinition: not a boolean function" -- : " ++ show s
 
 assertDefinition :: MonadSMT m =>
                     (SMTExpr Bool -> SMTExpr Bool)
-                    -> [SMTExpr Bool]
+                    -> ([SMTExpr Bool], [SMTExpr Bool])
                     -> Definition
                     -> m ()
-assertDefinition f i (SingleDef argN s) = liftSMT $ assert (f $ s `app` (lookupArgs argN i))
+assertDefinition f i (SingleDef argN succ s) = liftSMT $ assert (f $ s `app` (lookupArgs argN succ i))
 assertDefinition f i (ProdDef ps) = mapM_ (assertDefinition f i) $ Arr.elems ps
 
-lookupArgs :: [Int] -> [SMTExpr Bool] -> [SMTExpr Bool]
-lookupArgs argN vars = map ((!!) vars) argN
+lookupArgs :: [Int] -> Bool -> ([SMTExpr Bool], [SMTExpr Bool])
+               -> [SMTExpr Bool]
+lookupArgs argN True vars = [(snd vars) !! (head argN)] ++ (map ((!!) (fst vars)) $ tail argN)
+lookupArgs argN False vars = map ((!!) (fst vars)) argN
 
 data ProgDefs = ProgDefs
                 { flowDef :: [Definition]
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index 93cf8d8..6ccc47d 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -36,53 +36,52 @@ instance StrategyClass BMC where
 
   check natAnn s env defs =
     let base = 0
+        vars = varList env
     in do baseDef <- liftSMT . defConst $ constantAnn base natAnn
-          check' natAnn s env defs (Map.singleton base baseDef) base baseDef
+          fresh <- freshVars vars
+          check' s (getModel $ varEnv env) defs base (vars, fresh)
 
-assumeTrace :: MonadSMT m => ProgDefs -> [SMTExpr Bool] -> m ()
+assumeTrace :: MonadSMT m => ProgDefs -> ([SMTExpr Bool], [SMTExpr Bool]) -> m ()
 assumeTrace defs args =
   assertDefs args (flowDef defs) >>
   assertPrecond args (precondition defs)
 
 bmcStep :: MonadSMT m =>
-        Env i
+        (Map Natural StreamPos -> SMT (Model i))
         -> ProgDefs
-        -> Map Natural StreamPos
-        -> StreamPos
-        -> m (Maybe (Model i))
-bmcStep env defs pastIndices iDef =
-  do assumeTrace defs $ varList env
+        -> ([SMTExpr Bool], [SMTExpr Bool])
+        -> m (Bool)
+bmcStep getModel defs vars =
+  do assumeTrace defs vars
      let invs = invariantDef defs
      liftSMT . stack
-       $ checkInvariant (varList env) invs >>=
-       checkGetModel (getModel $ varEnv env) pastIndices
+       $ checkInvariant vars invs-- >>=
+       --checkGetModel getModel pastIndices
 
-check' :: SMTAnnotation Natural
-       -> BMC
-       -> Env i
+check' :: BMC
+       -> (Map Natural StreamPos -> SMT (Model i))
        -> ProgDefs
-       -> Map Natural StreamPos
        -> Natural
-       -> StreamPos
+       -> ([SMTExpr Bool], [SMTExpr Bool])
        -> SMTErr (StrategyResult i)
-check' natAnn s env defs pastIndices i iDef =
+check' s getModel defs i vars =
   do liftIO $ when (bmcPrintProgress s) (putStrLn $ "Depth " ++ show i)
-     r <- bmcStep env defs pastIndices iDef
+     r <- bmcStep getModel defs vars
      case r of
-       Nothing -> next (check' natAnn s env defs) natAnn s pastIndices i iDef
-       Just m -> return $ Failure i m
+       True -> next (check' s getModel defs) s i vars
+       False -> return $ Failure i 
 
-assertDefs :: MonadSMT m => [SMTExpr Bool] -> [Definition] -> m ()
+assertDefs :: MonadSMT m => ([SMTExpr Bool], [SMTExpr Bool]) -> [Definition] -> m ()
 assertDefs i = mapM_ (assertDef i)
 
-assertDef :: MonadSMT m => [SMTExpr Bool] -> Definition -> m ()
+assertDef :: MonadSMT m => ([SMTExpr Bool], [SMTExpr Bool]) -> Definition -> m ()
 assertDef = assertDefinition id
 
-assertPrecond :: MonadSMT m => [SMTExpr Bool] -> Definition -> m ()
+assertPrecond :: MonadSMT m => ([SMTExpr Bool], [SMTExpr Bool]) -> Definition -> m ()
 assertPrecond = assertDefinition id
 
 -- | Returns true, if the invariant holds
-checkInvariant :: MonadSMT m => [SMTExpr Bool] -> Definition -> m Bool
+checkInvariant :: MonadSMT m => ([SMTExpr Bool], [SMTExpr Bool]) -> Definition -> m Bool
 checkInvariant i p = liftSMT $ assertDefinition not' i p >> liftM not checkSat
 
 checkGetModel :: MonadSMT m =>
@@ -93,24 +92,24 @@ checkGetModel :: MonadSMT m =>
 checkGetModel getModel indices r = liftSMT $
   if r then return Nothing else fmap Just $ getModel indices
 
-next :: (Map Natural StreamPos
-             -> Natural
-             -> SMTExpr Natural
+next :: (Natural
+             -> ([SMTExpr Bool], [SMTExpr Bool])
              -> SMTErr (StrategyResult i)
         )
-        -> SMTAnnotation Natural
         -> BMC
-        -> Map Natural StreamPos
         -> Natural
-        -> SMTExpr Natural
+        -> ([SMTExpr Bool], [SMTExpr Bool])
         -> SMTErr (StrategyResult i)
-next checkCont natAnn s pastIndices i iDef =
-  do let i' = succ i
-     iDef' <- liftSMT . defConst$ succ' natAnn iDef
-     let pastIndices' = Map.insert i' iDef' pastIndices
-     case bmcDepth s of
-       Nothing -> checkCont pastIndices' i' iDef'
+next checkCont s i vars =
+  let i' = succ i
+  in case bmcDepth s of
+       Nothing -> do vars' <- freshVars $ snd vars
+                     checkCont i' (snd vars, vars')
        Just l ->
          if i' < l
-         then checkCont pastIndices' i' iDef'
+         then do vars' <- freshVars $ snd vars
+                 checkCont i' (snd vars, vars')
          else return Success
+
+freshVars :: [SMTExpr Bool] -> SMTErr [SMTExpr Bool]
+freshVars vars = liftSMT $ mapM (\v -> var) vars
diff --git a/lamaSMT/lib/Strategy.hs b/lamaSMT/lib/Strategy.hs
index e35e92e..2732e12 100644
--- a/lamaSMT/lib/Strategy.hs
+++ b/lamaSMT/lib/Strategy.hs
@@ -20,7 +20,7 @@ data Hint i = Hint { hintDescr :: String, hintModel :: Model i }
 type Hints i = [Hint i]
 data StrategyResult i =
      Success
-     | Failure Natural (Model i)
+     | Failure Natural-- (Model i)
      | Unknown String (Hints i)
 
 data Strategy = forall s. StrategyClass s => Strategy s
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 14f108e..e203378 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -240,7 +240,7 @@ declareInstantDef activeCond inst@(InstantExpr x e) =
      argsE <- mapM lookupVar $ Set.toList args
      argsN <- mapM getN argsE
      def <- declareConditionalAssign
-            activeCond (getBottom xVar) xVar args argsN res
+            activeCond (getBottom xVar) xVar args argsN False res
      return [def]
 declareInstantDef activeCond inst@(NodeUsage x n _) =
   do (outp, inpDefs) <- trInstant activeCond inst
@@ -248,7 +248,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
      nEnv            <- lookupNode n
      outN            <- mapM getN $ nodeEnvOut nEnv
      outpDef         <- declareConditionalAssign
-                        activeCond (getBottom xVar) xVar (Map.keysSet $ nodeEnvOut nEnv) (Map.elems outN) outp
+                        activeCond (getBottom xVar) xVar (Map.keysSet $ nodeEnvOut nEnv) (Map.elems outN) False outp
      return $ inpDefs ++ [outpDef]
 
 -- | Translates an instant definition into a function which can be
@@ -266,7 +266,7 @@ trInstant inpActive (NodeUsage _ n es) =
      insN <- mapM (mapM getN) insE
      inpDefs  <- mapM (\(x, n, e, eTr) ->
                         declareConditionalAssign
-                        inpActive (getBottom x) x (getArgSet e) n eTr)
+                        inpActive (getBottom x) x (getArgSet e) n False eTr)
                  $ zip4 (nodeEnvIn nEnv) insN es esTr
      return (y, inpDefs)
 
@@ -291,7 +291,10 @@ declareTransition :: Ident i =>
 declareTransition activeCond (StateTransition x e) =
   do xVar     <- lookupVar x
      let e'      = runTransM $ trExpr e
-     declareConditionalAssign activeCond (getBottom xVar) xVar (getArgSet e) [] e'
+         args    = getArgSet e
+     argsE <- mapM lookupVar $ Set.toList args
+     argsN <- mapM getN argsE
+     declareConditionalAssign activeCond (getBottom xVar) xVar args argsN True e'
 
 -- | Creates a declaration for an assignment. Depending on the
 -- activation condition the given expression or a default expression
@@ -304,13 +307,14 @@ declareConditionalAssign :: Ident i =>
                             -> TypedExpr i
                             -> Set i
                             -> [Int]
+                            -> Bool
                             -> (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i)
                             -> DeclM i Definition
-declareConditionalAssign activeCond defaultExpr x al ns ef =
+declareConditionalAssign activeCond defaultExpr x al ns succ ef =
   case activeCond of
-    Nothing -> declareDef x al ns ef
+    Nothing -> declareDef x al ns succ ef
     Just c  ->
-      declareDef x al ns ef
+      declareDef x al ns succ ef
       --declareDef modPos x (mkConditionalExpr c e defaultExpr)
   where
     -- | Takes a condition and the corresponding branches which may depend
@@ -325,15 +329,15 @@ declareConditionalAssign activeCond defaultExpr x al ns ef =
 -- id or succ' to define instances or state transitions).
 -- The second argument /x/ is the stream to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
-declareDef :: Ident i => TypedExpr i -> Set i -> [Int] ->
+declareDef :: Ident i => TypedExpr i -> Set i -> [Int] -> Bool ->
               (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i) -> DeclM i Definition
-declareDef x as ns ef =
+declareDef x as ns succ ef =
   do env         <- get
      let defType = varDefType x
      xN          <- getN x
      d           <- defFunc (1 + Set.size as) defType
                     $ \a -> liftRel (.==.) (BoolExpr $ head a) $ ef env $ zip (Set.toList as) (tail a)
-     return $ ensureDefinition ([xN] ++ ns) d
+     return $ ensureDefinition ([xN] ++ ns) succ d
   where
     varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
     varDefType _               = boolT
@@ -702,7 +706,7 @@ declarePrecond activeCond e =
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
-     return $ ensureDefinition argsN d
+     return $ ensureDefinition argsN False d
 
 declareInvariant :: Ident i =>
                     Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition

From cfcfbff0e4917ebbfc64df7e999504e5421326bd Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 17 Sep 2015 05:57:22 +0200
Subject: [PATCH 026/104] (0-co)induction working for some nodes

---
 lamaSMT/Main.hs                      | 10 ++--
 lamaSMT/lib/Strategies/BMC.hs        |  9 ++--
 lamaSMT/lib/Strategies/Factory.hs    |  2 +-
 lamaSMT/lib/Strategies/KInduction.hs | 76 +++++++++++++++-------------
 lamaSMT/lib/Strategy.hs              |  5 +-
 lamaSMT/lib/Transform.hs             | 10 ++--
 6 files changed, 56 insertions(+), 56 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index ed145cf..7b825c5 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -171,8 +171,7 @@ run opts@Options{..} file inp = do
     ( (liftSMT $ mapM_ setOption optSMTOpts) >>
       lamaSMT optNatImpl optEnumImpl p >>=
       (uncurry $ checkWithModel optNatImpl optStrategy) )
-  --liftIO $ checkModel opts p model
-  liftIO $ putStr "Test"
+  liftIO $ checkModel opts p model
 
 checkErrors :: Either Error a -> MaybeT IO a
 checkErrors r = case r of
@@ -205,20 +204,20 @@ runCheck progOpts = chooseSolver progOpts . checkError
                       -- ++ solverBase
   -- withPipe solverCmd []
 
-{-
 checkModel :: Ident i =>
            Options
            -> Program i
            -> (StrategyResult i)
            -> IO ()
 checkModel _ _ Success = putStrLn "42"
-checkModel opts prog (Failure lastIndexm) =
+checkModel opts prog (Failure lastIndex) =
   do putStrLn ":-("
      putStrLn $ "Found counterexample at depth " ++ show lastIndex
-     when (optDumpModel opts) (putStrLn . render $ prettyModel m)
+{-     when (optDumpModel opts) (putStrLn . render $ prettyModel m)
      case optScenarioFile opts of
        Nothing -> return ()
        Just f -> writeFile f $ render $ scadeScenario prog (optTopNodePath opts) m
+-}
 checkModel opts prog (Unknown what hints) =
   do putStrLn ":-("
      putStrLn what
@@ -232,7 +231,6 @@ checkModel opts prog (Unknown what hints) =
                  . render
                  $ scadeScenario prog (optTopNodePath opts) (hintModel h))
                hints
--}
 
 prettyHints :: Ident i => Hints i -> Doc
 prettyHints = vcat . map prettyHint
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index 6ccc47d..fb64413 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE ViewPatterns #-}
-module Strategies.BMC (BMC, assumeTrace, checkInvariant, bmcStep, assertPrecond) where
+module Strategies.BMC (BMC, assumeTrace, checkInvariant, bmcStep, assertPrecond, freshVars) where
 
 import Data.Natural
 import NatInstance
@@ -34,11 +34,10 @@ instance StrategyClass BMC where
     s { bmcPrintProgress = True }
   readOption o _ = error $ "Invalid BMC option: " ++ o
 
-  check natAnn s env defs =
+  check s env defs =
     let base = 0
         vars = varList env
-    in do baseDef <- liftSMT . defConst $ constantAnn base natAnn
-          fresh <- freshVars vars
+    in do fresh <- freshVars vars
           check' s (getModel $ varEnv env) defs base (vars, fresh)
 
 assumeTrace :: MonadSMT m => ProgDefs -> ([SMTExpr Bool], [SMTExpr Bool]) -> m ()
@@ -111,5 +110,5 @@ next checkCont s i vars =
                  checkCont i' (snd vars, vars')
          else return Success
 
-freshVars :: [SMTExpr Bool] -> SMTErr [SMTExpr Bool]
+freshVars :: MonadSMT m =>[SMTExpr Bool] -> m [SMTExpr Bool]
 freshVars vars = liftSMT $ mapM (\v -> var) vars
diff --git a/lamaSMT/lib/Strategies/Factory.hs b/lamaSMT/lib/Strategies/Factory.hs
index f27c36e..6f0584f 100644
--- a/lamaSMT/lib/Strategies/Factory.hs
+++ b/lamaSMT/lib/Strategies/Factory.hs
@@ -44,5 +44,5 @@ getStrategyHelp lineLength = renderStyle (style { lineLength }) $
 
 getStrategy :: String -> Strategy
 getStrategy "bmc" = Strategy (defaultStrategyOpts :: BMC)
---getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
+getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
 getStrategy _ = error "Unknown strategy"
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index 12ebb79..927b51b 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 module Strategies.KInduction where
-{-
+
 import Data.Natural
 import NatInstance
 import Data.List (stripPrefix)
@@ -19,7 +19,8 @@ import Language.SMTLib2
 import Strategy
 import LamaSMTTypes
 import Definition
-import Model (Model)
+import TransformEnv
+import Model (Model, getModel)
 import Strategies.BMC
 import Internal.Monads
 
@@ -50,34 +51,36 @@ instance StrategyClass KInduct where
               _      -> error $ "Invalid hint option: " ++ which
   readOption o _ = error $ "Invalid k-induction option: " ++ o
 
-  check natAnn indOpts getModel defs =
+  check indOpts env defs =
     let baseK = 0
-    in do baseKDef <- liftSMT . defConst $ constantAnn baseK natAnn
-          baseNDef <- liftSMT $ varAnn natAnn
-          assumeTrace defs baseNDef
-          let s0 = InductState baseK baseKDef
-                               baseNDef (Map.singleton baseK baseKDef)
+        vars  = varList env
+    in do fresh <- freshVars vars
+          nf0   <- freshVars vars
+          nf1   <- freshVars vars
+          nf2   <- freshVars vars
+          --assumeTrace defs (vars, fresh)
+          let s0 = InductState baseK nf0 nf1 nf2
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
-                $ check' natAnn indOpts getModel defs
+                $ check' indOpts (getModel $ varEnv env) defs (vars, fresh)
           case r of
                Unknown what h -> return $ Unknown what (h ++ hints)
                _ -> return r
 
 -- | Checks the induction step and returns true if the invariant could be
 -- proven
-checkStep :: ProgDefs -> StreamPos -> SMT Bool
-checkStep defs iDef =
-  do assumeTrace defs iDef
+checkStep :: ProgDefs -> ([SMTExpr Bool], [SMTExpr Bool]) -> SMT Bool
+checkStep defs vars =
+  do assumeTrace defs vars
      let invs = invariantDef defs
-     checkInvariant iDef invs
+     checkInvariant vars invs
 
 -- | Holds current depth k and definitions of last k and n
 data InductState = InductState
                    { kVal :: Natural
-                   , kDef :: StreamPos -- ^ Induction depth k (in solver)
-                   , nDef :: StreamPos -- ^ Induction variable n (in solver)
-                   , pastKs :: Map Natural StreamPos }
+                   , n0   :: [SMTExpr Bool]
+                   , n1   :: [SMTExpr Bool]
+                   , n2   :: [SMTExpr Bool] }
 type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 
 -- | Checks the program against its invariant. If the invariant
@@ -85,26 +88,30 @@ type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 -- If the base case is fine, but the induction step is not, we
 -- call next, which increases k. Finally, if also the induction
 -- step can be proven, Nothing is returned.
-check' :: SMTAnnotation Natural
-       -> KInduct
+check' :: KInduct
        -> (Map Natural StreamPos -> SMT (Model i))
        -> ProgDefs
+       -> ([SMTExpr Bool], [SMTExpr Bool])
        -> KInductM i (StrategyResult i)
-check' natAnn indOpts getModel defs =
+check' indOpts getModel defs vars =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
-     rBMC <- bmcStep getModel defs pastKs kDef
+     rBMC <- bmcStep getModel defs vars
      case rBMC of
-       Just m -> return $ Failure kVal m
-       Nothing ->
-         do n1 <- liftSMT . defConst $ succ' natAnn nDef
-            modify $ \indSt -> indSt { nDef = n1 }
-            assertPrecond nDef $ invariantDef defs
-            (indSuccess, hints) <- liftSMT . stack $
-              do r <- checkStep defs n1
-                 h <- retrieveHints (getModel pastKs) indOpts kVal r
-                 return (r, h)
-            tell hints
+       False -> return $ Failure kVal
+       True ->
+         do {-nf0 <- freshVars $ fst vars
+            nf1 <- freshVars $ fst vars
+            nf2 <- freshVars $ fst vars
+            modify $ \indSt -> indSt { n0 = nf0, n1 = nf1, n2 = nf2 }-}
+            assumeTrace defs (n0, n1)
+            assertPrecond (n0, n1) $ invariantDef defs
+            indSuccess <- liftSMT . stack $
+              do r <- checkStep defs (n1, n2)
+                 --h <- retrieveHints (getModel pastKs) indOpts kVal r
+                 --return (r, h)
+                 return r
+            --tell hints
             let k' = succ kVal
             if indSuccess
                then return Success
@@ -119,10 +126,10 @@ check' natAnn indOpts getModel defs =
   where
     cont k' =
       do indState@InductState{..} <- get
-         kDef' <- liftSMT . defConst $ succ' natAnn kDef
-         let pastKs' = Map.insert k' kDef' pastKs
-         put $ indState { kVal = k', kDef = kDef', pastKs = pastKs' }
-         check' natAnn indOpts getModel defs
+         --kDef' <- liftSMT . defConst $ succ' natAnn kDef
+         --let pastKs' = Map.insert k' kDef' pastKs
+         put $ indState { kVal = k' }--, kDef = kDef', pastKs = pastKs' }
+         check' indOpts getModel defs vars
 
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)
@@ -140,4 +147,3 @@ retrieveHints getModel indOpts k success =
          else return []
        (AllInductionSteps, _      ) ->
          getModel >>= \m -> return [Hint (show k) m]
--}
diff --git a/lamaSMT/lib/Strategy.hs b/lamaSMT/lib/Strategy.hs
index 2732e12..2ed14df 100644
--- a/lamaSMT/lib/Strategy.hs
+++ b/lamaSMT/lib/Strategy.hs
@@ -28,8 +28,7 @@ data Strategy = forall s. StrategyClass s => Strategy s
 class StrategyClass s where
   defaultStrategyOpts :: s
   readOption :: String -> s -> s
-  check :: SMTAnnotation Natural
-           -> s
+  check :: s
            -> Env i
            -> ProgDefs
            -> SMTErr (StrategyResult i)
@@ -39,7 +38,7 @@ checkWithModel :: SMTAnnotation Natural
                -> ProgDefs
                -> Env i
                -> SMTErr (StrategyResult i)
-checkWithModel natAnn (Strategy s) d env = check natAnn s env d
+checkWithModel natAnn (Strategy s) d env = check s env d
 
 readOptions' :: String -> Strategy -> Strategy
 readOptions' o (Strategy s) = Strategy $ readOption o s
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index e203378..178ddb8 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -15,8 +15,6 @@
 
 module Transform where
 
-import Debug.Trace
-
 import Development.Placeholders
 
 import Lang.LAMA.Identifier
@@ -129,9 +127,9 @@ declareDecls activeCond excludeNodes d =
            = Map.partitionWithKey (\n _ -> n `Set.member` excludeNodes)
              $ declsNode d
      defs <- mapM (uncurry $ declareNode activeCond) $ Map.toList toDeclare
-     inp <- trace "inp" $ declareVars $ declsInput d
-     locs <- trace "locs" $ declareVars $ declsLocal d
-     states <- trace "states" $ declareVars $ declsState d
+     inp <- declareVars $ declsInput d
+     locs <- declareVars $ declsLocal d
+     states <- declareVars $ declsState d
      modifyVars $ mappend (inp `mappend` locs `mappend` states)
      return (concat defs, excluded)
 
@@ -203,7 +201,7 @@ declareNode active nName nDecl =
                mconcat . map getNodesInLocations . Map.elems $ nodeAutomata n
          (declDefs, undeclaredNodes) <-
            declareDecls activeCond automNodes $ nodeDecls n
-         outDecls <- trace "outDecls" $ declareVarList $ nodeOutputs n
+         outDecls <- declareVarList $ nodeOutputs n
          ins <- mapM (lookupVar . varIdent) . declsInput $ nodeDecls n
          let outs = Map.fromList outDecls
          modifyVars $ Map.union (Map.fromList outDecls)

From 9a6f2fc20d51a3fb73fb57ca773bde44b1a1c172 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 17 Sep 2015 07:06:42 +0200
Subject: [PATCH 027/104] 0-coinduction is now k-coinduction

---
 lamaSMT/lib/Strategies/KInduction.hs | 42 +++++++++++++---------------
 1 file changed, 19 insertions(+), 23 deletions(-)

diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index 927b51b..36f9230 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -54,15 +54,14 @@ instance StrategyClass KInduct where
   check indOpts env defs =
     let baseK = 0
         vars  = varList env
-    in do fresh <- freshVars vars
-          nf0   <- freshVars vars
-          nf1   <- freshVars vars
-          nf2   <- freshVars vars
-          --assumeTrace defs (vars, fresh)
-          let s0 = InductState baseK nf0 nf1 nf2
+    in do k1  <- freshVars vars
+          n0  <- freshVars vars
+          n1  <- freshVars vars
+          assumeTrace defs (n0, n1)
+          let s0 = InductState baseK (vars, k1) (n0, n1)
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
-                $ check' indOpts (getModel $ varEnv env) defs (vars, fresh)
+                $ check' indOpts (getModel $ varEnv env) defs
           case r of
                Unknown what h -> return $ Unknown what (h ++ hints)
                _ -> return r
@@ -77,10 +76,9 @@ checkStep defs vars =
 
 -- | Holds current depth k and definitions of last k and n
 data InductState = InductState
-                   { kVal :: Natural
-                   , n0   :: [SMTExpr Bool]
-                   , n1   :: [SMTExpr Bool]
-                   , n2   :: [SMTExpr Bool] }
+                   { kVal  :: Natural
+                   , kDefs :: ([SMTExpr Bool], [SMTExpr Bool])
+                   , nDefs :: ([SMTExpr Bool], [SMTExpr Bool]) }
 type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 
 -- | Checks the program against its invariant. If the invariant
@@ -91,21 +89,19 @@ type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 check' :: KInduct
        -> (Map Natural StreamPos -> SMT (Model i))
        -> ProgDefs
-       -> ([SMTExpr Bool], [SMTExpr Bool])
        -> KInductM i (StrategyResult i)
-check' indOpts getModel defs vars =
+check' indOpts getModel defs =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
-     rBMC <- bmcStep getModel defs vars
+     rBMC <- bmcStep getModel defs kDefs
      case rBMC of
        False -> return $ Failure kVal
        True ->
-         do {-nf0 <- freshVars $ fst vars
-            nf1 <- freshVars $ fst vars
-            nf2 <- freshVars $ fst vars
-            modify $ \indSt -> indSt { n0 = nf0, n1 = nf1, n2 = nf2 }-}
-            assumeTrace defs (n0, n1)
+         do let n0 = fst nDefs
+                n1 = snd nDefs
+            n2 <- freshVars n1
             assertPrecond (n0, n1) $ invariantDef defs
+            modify $ \indSt -> indSt { nDefs = (n1, n2) }
             indSuccess <- liftSMT . stack $
               do r <- checkStep defs (n1, n2)
                  --h <- retrieveHints (getModel pastKs) indOpts kVal r
@@ -126,10 +122,10 @@ check' indOpts getModel defs vars =
   where
     cont k' =
       do indState@InductState{..} <- get
-         --kDef' <- liftSMT . defConst $ succ' natAnn kDef
-         --let pastKs' = Map.insert k' kDef' pastKs
-         put $ indState { kVal = k' }--, kDef = kDef', pastKs = pastKs' }
-         check' indOpts getModel defs vars
+         let k1 = snd kDefs
+         k2 <- freshVars k1
+         put $ indState { kVal = k', kDefs = (k1, k2) }
+         check' indOpts getModel defs
 
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)

From 03a39e0ae0620ce25c618fbb93f048aa3abcae92 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 24 Sep 2015 01:35:41 +0200
Subject: [PATCH 028/104] Added an Args instance declaration for TypedExpr

---
 lamaSMT/lib/LamaSMTTypes.hs | 47 +++++++++++++++++++++++++------------
 1 file changed, 32 insertions(+), 15 deletions(-)

diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index 18e85b4..c94f1c5 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -2,11 +2,16 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
 module LamaSMTTypes where
 
 import Data.Natural
 import NatInstance ()
 import Data.Array as Arr
+import Data.Typeable
 
 import Control.Arrow ((&&&))
 
@@ -19,7 +24,15 @@ data TypedExpr i
   | RealExpr { unReal :: SMTExpr Rational }
   | EnumExpr { unEnum :: SMTExpr SMTEnum }
   | ProdExpr { unProd :: Array Int (TypedExpr i) }
-  deriving (Eq, Show)
+  deriving (Ord, Typeable, Eq, Show)
+
+data TypedAnnotation
+  = BoolAnnotation { anBool :: ArgAnnotation (SMTExpr Bool) }
+  | IntAnnotation { anInt :: ArgAnnotation (SMTExpr Integer) }
+  | RealAnnotation { anReal :: ArgAnnotation (SMTExpr Rational) }
+  | EnumAnnotation { anEnum :: ArgAnnotation (SMTExpr SMTEnum) }
+  -- | ProdAnnotation { anProd :: ArgAnnotation a }
+  deriving (Typeable, Show, Ord, Eq)
 
 unBool' :: TypedExpr i -> SMTExpr Bool
 unBool' (BoolExpr e) = e
@@ -49,20 +62,24 @@ appFunc (RealFunc f) arg = RealExpr $ f `app` arg
 appFunc (EnumFunc _ f) arg = EnumExpr $ f `app` arg
 appFunc (ProdFunc f) arg = ProdExpr $ fmap (`appFunc` arg) f
 
-{-instance (SMTExpr i) => Args (TypedExpr i) where
-  type ArgAnnotation (TypedExpr i) = SMTAnnotation i
-  foldExprs f = f
-  foldsExprs f = f
-  extractArgAnnotation (BoolExpr expr) = extractAnnotation expr
-  toArgs _ (x:xs) = do
-    r <- entype gcast x
-    return (r,xs)
-  toArgs _ [] = Nothing
-  fromArgs x = [UntypedExpr x]
-  getSorts (_::SMTExpr a) ann = [getSort (undefined::a) ann]
-  getArgAnnotation u (s:rest) = (annotationFromSort (getUndef u) s,rest)
-  getArgAnnotation _ [] = error "smtlib2: To few sorts provided."
-  showsArgs = showExpr-}
+instance Typeable i => Args (TypedExpr i) where
+  type ArgAnnotation (TypedExpr a) = TypedAnnotation
+  foldExprs f s ~(BoolExpr x) (BoolAnnotation ann) = do
+    (ns, res) <- foldExprs f s x ann
+    return (ns, BoolExpr res)
+  foldsExprs f s lst (BoolAnnotation ann) = do
+    (ns, ress, res) <- foldsExprs f s (fmap (\(x,p) -> (case x of BoolExpr x' -> x',p)) lst) ann
+    return (ns, fmap BoolExpr ress, BoolExpr res)
+  extractArgAnnotation (BoolExpr x) = BoolAnnotation $ extractArgAnnotation x
+  toArgs (BoolAnnotation ann) exprs = do
+    (res, rest) <- toArgs ann exprs
+    return (BoolExpr res, rest)
+  fromArgs (BoolExpr xs) = fromArgs xs
+  getSorts (_::TypedExpr x) (BoolAnnotation ann) = error "lamasmt: no getSorts for TypedExpr"--getSorts (undefined::x) $ extractArgAnnotation ann
+  getArgAnnotation _ _ = error "lamasmt: getArgAnnotation undefined for TypedExpr"
+  showsArgs n p (BoolExpr x) = let (showx,nn) = showsArgs n 11 x
+                               in (showParen (p>10) $
+                                   showString "BoolExpr " . showx,nn)
 
 ------------------------------
 

From 2463185d6b982ba211273507f1e50dd2d7800274 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 24 Sep 2015 01:51:00 +0200
Subject: [PATCH 029/104] Removed type parameter from TypedExpr and TypedFunc

---
 lamaSMT/lib/Definition.hs   |  2 +-
 lamaSMT/lib/LamaSMTTypes.hs | 58 ++++++++++++++++++-------------------
 lamaSMT/lib/Model.hs        |  4 +--
 lamaSMT/lib/Transform.hs    | 50 ++++++++++++++++----------------
 lamaSMT/lib/TransformEnv.hs | 24 +++++++--------
 5 files changed, 69 insertions(+), 69 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 11c9436..70875a4 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -12,7 +12,7 @@ data Definition =
   | ProdDef (Array Int Definition)
   deriving Show
 
-ensureDefinition :: [Int] -> Bool -> TypedFunc i -> Definition
+ensureDefinition :: [Int] -> Bool -> TypedFunc -> Definition
 ensureDefinition argN succ (BoolFunc s) = SingleDef argN succ s
 ensureDefinition argN succ (ProdFunc ps) = ProdDef $ fmap (ensureDefinition argN succ) ps
 ensureDefinition argN succ _
diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index c94f1c5..e22820f 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -18,12 +18,12 @@ import Control.Arrow ((&&&))
 import Language.SMTLib2 as SMT
 import SMTEnum
 
-data TypedExpr i
+data TypedExpr
   = BoolExpr { unBool :: SMTExpr Bool }
   | IntExpr { unInt :: SMTExpr Integer }
   | RealExpr { unReal :: SMTExpr Rational }
   | EnumExpr { unEnum :: SMTExpr SMTEnum }
-  | ProdExpr { unProd :: Array Int (TypedExpr i) }
+  | ProdExpr { unProd :: Array Int (TypedExpr) }
   deriving (Ord, Typeable, Eq, Show)
 
 data TypedAnnotation
@@ -32,38 +32,38 @@ data TypedAnnotation
   | RealAnnotation { anReal :: ArgAnnotation (SMTExpr Rational) }
   | EnumAnnotation { anEnum :: ArgAnnotation (SMTExpr SMTEnum) }
   -- | ProdAnnotation { anProd :: ArgAnnotation a }
-  deriving (Typeable, Show, Ord, Eq)
+  deriving (Ord, Typeable, Eq, Show)
 
-unBool' :: TypedExpr i -> SMTExpr Bool
+unBool' :: TypedExpr -> SMTExpr Bool
 unBool' (BoolExpr e) = e
 unBool' e = error $ "Cannot unBool: " ++ show e
 
-unProd' :: TypedExpr i -> Array Int (TypedExpr i)
+unProd' :: TypedExpr -> Array Int (TypedExpr)
 unProd' (ProdExpr e) = e
 unProd' e = error $ "Cannot unProd: " ++ show e
 
-data TypedFunc i
+data TypedFunc
   = BoolFunc (SMTFunction [SMTExpr Bool] Bool)
   | IntFunc (SMTFunction [SMTExpr Bool] Integer)
   | RealFunc (SMTFunction [SMTExpr Bool] Rational)
   | EnumFunc EnumAnn (SMTFunction [SMTExpr Bool] SMTEnum)
-  | ProdFunc (Array Int (TypedFunc i))
+  | ProdFunc (Array Int (TypedFunc))
   deriving Show
 
-mkProdExpr :: [TypedExpr i] -> TypedExpr i
+mkProdExpr :: [TypedExpr] -> TypedExpr
 mkProdExpr [] = error "Cannot create empty product expression"
 mkProdExpr [s] = s
 mkProdExpr sts = ProdExpr . uncurry listArray $ ((0,) . pred . length &&& id) sts
 
-appFunc :: TypedFunc i -> [SMTExpr Bool] -> TypedExpr i
+appFunc :: TypedFunc -> [SMTExpr Bool] -> TypedExpr
 appFunc (BoolFunc f) arg = BoolExpr $ f `app` arg
 appFunc (IntFunc f) arg = IntExpr $ f `app` arg
 appFunc (RealFunc f) arg = RealExpr $ f `app` arg
 appFunc (EnumFunc _ f) arg = EnumExpr $ f `app` arg
 appFunc (ProdFunc f) arg = ProdExpr $ fmap (`appFunc` arg) f
 
-instance Typeable i => Args (TypedExpr i) where
-  type ArgAnnotation (TypedExpr a) = TypedAnnotation
+instance Args (TypedExpr) where
+  type ArgAnnotation TypedExpr = TypedAnnotation
   foldExprs f s ~(BoolExpr x) (BoolAnnotation ann) = do
     (ns, res) <- foldExprs f s x ann
     return (ns, BoolExpr res)
@@ -75,7 +75,7 @@ instance Typeable i => Args (TypedExpr i) where
     (res, rest) <- toArgs ann exprs
     return (BoolExpr res, rest)
   fromArgs (BoolExpr xs) = fromArgs xs
-  getSorts (_::TypedExpr x) (BoolAnnotation ann) = error "lamasmt: no getSorts for TypedExpr"--getSorts (undefined::x) $ extractArgAnnotation ann
+  getSorts (_::TypedExpr) (BoolAnnotation ann) = error "lamasmt: no getSorts for TypedExpr"--getSorts (undefined::x) $ extractArgAnnotation ann
   getArgAnnotation _ _ = error "lamasmt: getArgAnnotation undefined for TypedExpr"
   showsArgs n p (BoolExpr x) = let (showx,nn) = showsArgs n 11 x
                                in (showParen (p>10) $
@@ -98,20 +98,20 @@ mkProdStream [] = error "Cannot create empty product stream"
 mkProdStream [s] = s
 mkProdStream sts = ProdStream . uncurry listArray $ ((0,) . pred . length &&& id) sts
 
-appStream :: TypedStream i -> StreamPos -> TypedExpr i
+appStream :: TypedStream i -> StreamPos -> TypedExpr
 appStream (BoolStream s) n = BoolExpr $ s `app` n
 appStream (IntStream s) n = IntExpr $ s `app` n
 appStream (RealStream s) n = RealExpr $ s `app` n
 appStream (EnumStream _ s) n = EnumExpr $ s `app` n
 appStream (ProdStream s) n = ProdExpr $ fmap (`appStream` n) s
 
-liftAssert :: TypedExpr i -> SMT ()
+liftAssert :: TypedExpr -> SMT ()
 liftAssert (BoolExpr e) = assert e
 liftAssert (ProdExpr es) = mapM_ liftAssert $ Arr.elems es
 liftAssert e = error $ "liftAssert: cannot assert non-boolean expression: " ++ show e
 
 liftRel :: (forall a. SMTType a => SMTExpr a -> SMTExpr a -> SMTExpr Bool)
-           -> TypedExpr i -> TypedExpr i -> TypedExpr i
+           -> TypedExpr -> TypedExpr -> TypedExpr
 liftRel r (BoolExpr e1) (BoolExpr e2) = BoolExpr $ r e1 e2
 liftRel r (IntExpr e1) (IntExpr e2) = BoolExpr $ r e1 e2
 liftRel r (RealExpr e1) (RealExpr e2) = BoolExpr $ r e1 e2
@@ -122,33 +122,33 @@ liftRel _ _ _ = error "liftRel: argument types don't match"
 -- | Only for boolean product streams. Ensures that all fields of
 -- a product hold simultaniuosly. Useful for elementwise
 -- extended relatations.
-prodAll :: TypedExpr i -> TypedExpr i
+prodAll :: TypedExpr -> TypedExpr
 prodAll (BoolExpr e) = BoolExpr e
 prodAll (ProdExpr e) = liftBoolL and' $ Arr.elems e
 prodAll e = error $ "prodAll: not a product or boolean expr: " ++ show e
 
 liftOrd :: (forall a. (SMTType a, SMTOrd a) => SMTExpr a -> SMTExpr a -> SMTExpr Bool)
-           -> TypedExpr i -> TypedExpr i -> TypedExpr i
+           -> TypedExpr -> TypedExpr -> TypedExpr
 liftOrd r (IntExpr e1) (IntExpr e2) = BoolExpr $ r e1 e2
 liftOrd r (RealExpr e1) (RealExpr e2) = BoolExpr $ r e1 e2
 liftOrd _ _ _ = error "liftRel: argument types don't match or are not ordered"
 
 
-lift1Bool :: (SMTExpr Bool -> SMTExpr Bool) -> TypedExpr i -> TypedExpr i
+lift1Bool :: (SMTExpr Bool -> SMTExpr Bool) -> TypedExpr -> TypedExpr
 lift1Bool f (BoolExpr e) = BoolExpr $ f e
 lift1Bool _ _ = error "lift1Bool: argument is not boolean"
 
 liftBool2 :: (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool)
-             -> TypedExpr i -> TypedExpr i -> TypedExpr i
+             -> TypedExpr -> TypedExpr -> TypedExpr
 liftBool2 f (BoolExpr e1) (BoolExpr e2) = BoolExpr $ f e1 e2
 liftBool2 _ e1 e2 = error $ "liftBool2: arguments are not boolean: " ++ show e1 ++ "; " ++ show e2
 
-liftBoolL :: SMTFunction [SMTExpr Bool] Bool -> [TypedExpr i] -> TypedExpr i
+liftBoolL :: SMTFunction [SMTExpr Bool] Bool -> [TypedExpr] -> TypedExpr
 liftBoolL f es@((BoolExpr _):_) = BoolExpr . app f $ map unBool es
 liftBoolL _ es = error $ "Cannot lift bool expr for" ++ show es
 
 lift2 :: (forall a. SMTType a => SMTExpr a -> SMTExpr a -> SMTExpr a)
-         -> TypedExpr i -> TypedExpr i -> TypedExpr i
+         -> TypedExpr -> TypedExpr -> TypedExpr
 lift2 f (BoolExpr e1) (BoolExpr e2) = BoolExpr $ f e1 e2
 lift2 f (IntExpr e1) (IntExpr e2) = IntExpr $ f e1 e2
 lift2 f (RealExpr e1) (RealExpr e2) = RealExpr $ f e1 e2
@@ -156,33 +156,33 @@ lift2 f (EnumExpr e1) (EnumExpr e2) = EnumExpr $ f e1 e2
 lift2 f (ProdExpr e1) (ProdExpr e2) = ProdExpr $ accum (lift2 f) e1 (Arr.assocs e2)
 lift2 _ _ _ = error "lift2: argument types don't match"
 
-liftIte :: TypedExpr i -> TypedExpr i -> TypedExpr i -> TypedExpr i
+liftIte :: TypedExpr -> TypedExpr -> TypedExpr -> TypedExpr
 liftIte (BoolExpr c) = lift2 (ite c)
 liftIte _ = error "liftIte: condition is not boolean"
 
 liftArith :: (forall a. SMTArith a => SMTFunction (SMTExpr a, SMTExpr a) a)
-             -> TypedExpr i
-             -> TypedExpr i
-             -> TypedExpr i
+             -> TypedExpr
+             -> TypedExpr
+             -> TypedExpr
 liftArith f (IntExpr e1)  (IntExpr e2)  = IntExpr  $ app f (e1, e2)
 liftArith f (RealExpr e1) (RealExpr e2) = RealExpr $ app f (e1, e2)
 liftArith _ _ _
   = error "liftArith: argument types don't match or are not aritemetic types"
 
 liftArithL :: (forall a. SMTArith a => SMTFunction [SMTExpr a] a)
-              -> [TypedExpr i]
-              -> TypedExpr i
+              -> [TypedExpr]
+              -> TypedExpr
 liftArithL f es@((IntExpr _):_)  = IntExpr  . app f $ map unInt  es
 liftArithL f es@((RealExpr _):_) = RealExpr . app f $ map unReal es
 liftArithL _ _
   = error "liftArithL: argument types don't match or are not arithmetic types"
 
 liftInt2 :: (SMTExpr Integer -> SMTExpr Integer -> SMTExpr Integer)
-              -> TypedExpr i -> TypedExpr i -> TypedExpr i
+              -> TypedExpr -> TypedExpr -> TypedExpr
 liftInt2 f (IntExpr e1) (IntExpr e2) = IntExpr $ f e1 e2
 liftInt2 _ _ _ = error "liftInt2: argument types are not integers"
 
 liftReal2 :: (SMTExpr Rational -> SMTExpr Rational -> SMTExpr Rational)
-              -> TypedExpr i -> TypedExpr i -> TypedExpr i
+              -> TypedExpr -> TypedExpr -> TypedExpr
 liftReal2 f (RealExpr e1) (RealExpr e2) = RealExpr $ f e1 e2
 liftReal2 _ _ _ = error "liftReal2: argument types are not rational"
diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index bb2a6d1..b0f9f96 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -87,11 +87,11 @@ getNodeModel :: NodeEnv i -> ModelM (NodeModel i)
 getNodeModel (NodeEnv i o e) =
   NodeModel <$> mapM getVarModel i <*> getVarsModel o <*> getModel' e
 
-getVarsModel :: Map i (TypedExpr i) -> ModelM (Map i ValueStream)
+getVarsModel :: Map i (TypedExpr) -> ModelM (Map i ValueStream)
 getVarsModel = mapM getVarModel
 
 --TODO
-getVarModel :: TypedExpr i -> ModelM ValueStream
+getVarModel :: TypedExpr -> ModelM ValueStream
 getVarModel (BoolExpr s) = BoolVStream <$> getStreamValue s
 getVarModel (IntExpr  s) = IntVStream  <$> getStreamValue s
 getVarModel (RealExpr s) = RealVStream <$> getStreamValue s
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 178ddb8..5c4c959 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -57,7 +57,7 @@ import Internal.Monads
 -- FIXME: Make behaviour configurable, i.e. bottom can be some
 -- default value or a left open stream
 -- (atm it does the former).
-getBottom :: TypedExpr i -> TypedExpr i
+getBottom :: TypedExpr -> TypedExpr
 getBottom (BoolExpr _)     = BoolExpr $ constant False
 getBottom (IntExpr _)      = IntExpr  $ constant 0xdeadbeef
 getBottom (RealExpr _)     = RealExpr . constant $ fromInteger 0xdeadbeef
@@ -133,13 +133,13 @@ declareDecls activeCond excludeNodes d =
      modifyVars $ mappend (inp `mappend` locs `mappend` states)
      return (concat defs, excluded)
 
-declareVars :: Ident i => [Variable i] -> DeclM i (Map i (TypedExpr i))
+declareVars :: Ident i => [Variable i] -> DeclM i (Map i (TypedExpr))
 declareVars = fmap (Map.fromList) . declareVarList
 
-declareVarList :: Ident i => [Variable i] -> DeclM i ([(i, TypedExpr i)])
+declareVarList :: Ident i => [Variable i] -> DeclM i ([(i, TypedExpr)])
 declareVarList = mapM declareVar
 
-declareVar :: Ident i => Variable i -> DeclM i ((i, TypedExpr i))
+declareVar :: Ident i => Variable i -> DeclM i ((i, TypedExpr))
 declareVar (Variable x t) =
   do v    <- typedVar (identString x) t
      addVar v
@@ -148,7 +148,7 @@ declareVar (Variable x t) =
     typedVar :: Ident i =>
                 String
                 -> Type i
-                -> DeclM i (TypedExpr i)
+                -> DeclM i (TypedExpr)
     typedVar v (GroundType BoolT)
       = liftSMT $ fmap BoolExpr $ varNamed v
     typedVar v (GroundType IntT)
@@ -253,7 +253,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
 -- used to further refine this instant (e.g. wrap it into an ite).
 -- This may also return definitions of the parameters of a node.
 -- The activation condition is only used for the inputs of a node.
-trInstant :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i, [Definition])
+trInstant :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr, [Definition])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
 trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
@@ -268,7 +268,7 @@ trInstant inpActive (NodeUsage _ n es) =
                  $ zip4 (nodeEnvIn nEnv) insN es esTr
      return (y, inpDefs)
 
-trOutput :: Ident i => Map i (TypedExpr i) -> TransM i (TypedExpr i)
+trOutput :: Ident i => Map i (TypedExpr) -> TransM i (TypedExpr)
 trOutput map = do
                  s <- ask
                  outList <- mapM (trOutput' s) (Map.toList map)
@@ -301,12 +301,12 @@ declareTransition activeCond (StateTransition x e) =
 -- (see declareDef).
 declareConditionalAssign :: Ident i =>
                             Maybe (SMTFunction [SMTExpr Bool] Bool)
-                            -> TypedExpr i
-                            -> TypedExpr i
+                            -> TypedExpr
+                            -> TypedExpr
                             -> Set i
                             -> [Int]
                             -> Bool
-                            -> (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i)
+                            -> (Env i -> [(i, SMTExpr Bool)] -> TypedExpr)
                             -> DeclM i Definition
 declareConditionalAssign activeCond defaultExpr x al ns succ ef =
   case activeCond of
@@ -327,8 +327,8 @@ declareConditionalAssign activeCond defaultExpr x al ns succ ef =
 -- id or succ' to define instances or state transitions).
 -- The second argument /x/ is the stream to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
-declareDef :: Ident i => TypedExpr i -> Set i -> [Int] -> Bool ->
-              (Env i -> [(i, SMTExpr Bool)] -> TypedExpr i) -> DeclM i Definition
+declareDef :: Ident i => TypedExpr -> Set i -> [Int] -> Bool ->
+              (Env i -> [(i, SMTExpr Bool)] -> TypedExpr) -> DeclM i Definition
 declareDef x as ns succ ef =
   do env         <- get
      let defType = varDefType x
@@ -525,7 +525,7 @@ declareLocDef :: Ident i =>
                  -> Stream SMTEnum
                  -> Maybe (Expr i)
                  -> [(LocationId i, InstantDefinition i)]
-                 -> AutomTransM i (Env i -> StreamPos -> TypedExpr i, [Definition])
+                 -> AutomTransM i (Env i -> StreamPos -> TypedExpr, [Definition])
 declareLocDef activeCond s defaultExpr locs =
   do (innerPat, locs') <- case defaultExpr of
        Nothing -> case locs of
@@ -542,7 +542,7 @@ declareLocDef activeCond s defaultExpr locs =
                     Maybe (Stream Bool)
                     -> LocationId i
                     -> InstantDefinition i
-                    -> AutomTransM i (Env i -> StreamPos -> TypedExpr i, [Definition])
+                    -> AutomTransM i (Env i -> StreamPos -> TypedExpr, [Definition])
     trLocInstant _ _ inst@(InstantExpr _ _) =
       lift $ trInstant (error "no activation condition required") inst
     trLocInstant active l inst@(NodeUsage _ n _) =
@@ -555,7 +555,7 @@ declareLocDef activeCond s defaultExpr locs =
 trLocTransition :: Ident i =>
                    Stream SMTEnum
                    -> [(LocationId i, StateTransition i)]
-                   -> AutomTransM i (Env i -> StreamPos -> TypedExpr i)
+                   -> AutomTransM i (Env i -> StreamPos -> TypedExpr)
 trLocTransition s locs =
   let (innerPat, locs') = case locs of
         (l:ls) -> (trLocTrans $ snd l, ls)
@@ -568,10 +568,10 @@ trLocTransition s locs =
 
 mkLocationMatch :: Ident i =>
                    Stream SMTEnum
-                   -> (Env i -> StreamPos -> TypedExpr i)
+                   -> (Env i -> StreamPos -> TypedExpr)
                    -> LocationId i
-                   -> (Env i -> StreamPos -> TypedExpr i)
-                   -> AutomTransM i (Env i -> StreamPos -> TypedExpr i)
+                   -> (Env i -> StreamPos -> TypedExpr)
+                   -> AutomTransM i (Env i -> StreamPos -> TypedExpr)
 mkLocationMatch s f l lExpr =
   do lCons <- lookupLocName l
      lEnum <- lift $ trEnumConsAnn lCons <$> lookupEnumConsAnn lCons
@@ -710,7 +710,7 @@ declareInvariant :: Ident i =>
                     Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
 declareInvariant = declarePrecond
 
-trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr i)
+trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr)
 trConstExpr (untyped -> Const c)
   = return $ trConstant c
 trConstExpr (untyped -> ConstEnum x)
@@ -721,7 +721,7 @@ trConstExpr (untyped -> ConstProd (Prod cs)) =
 type TransM i = ReaderT ([(i, SMTExpr Bool)], Env i) (Either String)
 
 {-
-doAppStream :: TypedStream i -> TransM i (TypedExpr i)
+doAppStream :: TypedStream i -> TransM i (TypedExpr)
 doAppStream s = askStreamPos >>= return . appStream s
 -}
 
@@ -731,7 +731,7 @@ runTransM m e a = case runReaderT m (a, e) of
   Left err -> error err
   Right r -> r
 
-lookupVar' :: Ident i => i -> TransM i (TypedExpr i)
+lookupVar' :: Ident i => i -> TransM i (TypedExpr)
 lookupVar' x =
   do vs <- asks $ vars . varEnv . snd
      case Map.lookup x vs of
@@ -763,7 +763,7 @@ getArgSet expr = case untyped expr of
 
 -- we do no further type checks since this
 -- has been done beforehand.
-trExpr :: Ident i => Expr i -> TransM i (TypedExpr i)
+trExpr :: Ident i => Expr i -> TransM i (TypedExpr)
 trExpr expr = case untyped expr of
   AtExpr (AtomConst c) -> return $ trConstant c
   AtExpr (AtomVar x)   -> do
@@ -782,11 +782,11 @@ trExpr expr = case untyped expr of
        return $ (s ! fromEnum i)
   Match e pats         -> trExpr e >>= flip trPattern pats
 
-trPattern :: Ident i => TypedExpr i -> [Pattern i] -> TransM i (TypedExpr i)
+trPattern :: Ident i => TypedExpr -> [Pattern i] -> TransM i (TypedExpr)
 trPattern e@(EnumExpr _) = trEnumMatch e
 trPattern _ = error "Cannot match on non enum expression"
 
-trEnumMatch :: Ident i => TypedExpr i -> [Pattern i] -> TransM i (TypedExpr i)
+trEnumMatch :: Ident i => TypedExpr -> [Pattern i] -> TransM i (TypedExpr)
 trEnumMatch x pats =
   -- respect order of patterns here by putting the last in the default match
   -- and bulding the expression bottom-up:
@@ -811,7 +811,7 @@ trEnumConsAnn x = constantAnn (SMTEnum . fromString $ identString x)
 trEnumCons :: Ident i => EnumConstr i -> TransM i (SMTExpr SMTEnum)
 trEnumCons x = lookupEnumConsAnn' x >>= return . trEnumConsAnn x
 
-applyOp :: BinOp -> TypedExpr i -> TypedExpr i -> TypedExpr i
+applyOp :: BinOp -> TypedExpr -> TypedExpr -> TypedExpr
 applyOp Or      e1 e2 = liftBoolL or'  [e1, e2]
 applyOp And     e1 e2 = liftBoolL and' [e1, e2]
 applyOp Xor     e1 e2 = liftBoolL xor  [e1, e2]
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 35a9d7a..0c7bbfe 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -29,20 +29,20 @@ import LamaSMTTypes
 import Internal.Monads
 
 data NodeEnv i = NodeEnv
-                 { nodeEnvIn :: [TypedExpr i]
-                 , nodeEnvOut :: Map i (TypedExpr i)
+                 { nodeEnvIn :: [TypedExpr]
+                 , nodeEnvOut :: Map i (TypedExpr)
                  , nodeEnvVars :: VarEnv i
                  }
 
 data VarEnv i = VarEnv
                 { nodes :: Map i (NodeEnv i)
-                , vars :: Map i (TypedExpr i)
+                , vars :: Map i (TypedExpr)
                   -- ^ Maps names of variables to a SMT expression for using
                   -- that variable
                 }
 
 data Env i = Env
-           { constants :: Map i (TypedExpr i)
+           { constants :: Map i (TypedExpr)
            , enumAnn :: Map i (SMTAnnotation SMTEnum)
            , enumConsAnn :: Map (EnumConstr i) (SMTAnnotation SMTEnum)
            , varEnv :: VarEnv i
@@ -65,11 +65,11 @@ putConstants cs =
   let cs' = fmap trConstant cs
   in modify $ \env -> env { constants = cs' }
 
-addVar :: Ident i => TypedExpr i -> DeclM i ()
+addVar :: Ident i => TypedExpr -> DeclM i ()
 addVar var =
   modify $ \env -> env { varList = (varList env) ++ [unBool' var] }
 
-getN :: TypedExpr i -> DeclM i Int
+getN :: TypedExpr -> DeclM i Int
 getN x = do vars <- gets varList
             return $ case List.elemIndex (unBool' x) vars of
                           Nothing -> error $ "Could not be found in list of     variables: " ++ show x
@@ -89,7 +89,7 @@ modifyVarEnv f = modify $ \env -> env { varEnv = f $ varEnv env }
 modifyNodes :: (Map i (NodeEnv i) -> Map i (NodeEnv i)) -> DeclM i ()
 modifyNodes f = modifyVarEnv $ (\env -> env { nodes = f $ nodes env })
 
-modifyVars :: (Map i (TypedExpr i) -> Map i (TypedExpr i)) -> DeclM i ()
+modifyVars :: (Map i (TypedExpr) -> Map i (TypedExpr)) -> DeclM i ()
 modifyVars f = modifyVarEnv $ (\env -> env { vars = f $ vars env })
 
 lookupErr :: (MonadError e m, Ord k) => e -> k -> Map k v -> m v
@@ -97,7 +97,7 @@ lookupErr err k m = case Map.lookup k m of
   Nothing -> throwError err
   Just v -> return v
 
-lookupVar :: (MonadState (Env i) m, MonadError String m, Ident i) => i -> m (TypedExpr i)
+lookupVar :: (MonadState (Env i) m, MonadError String m, Ident i) => i -> m (TypedExpr)
 lookupVar x = gets (vars . varEnv) >>= lookupErr ("Unknown variable " ++ identPretty x) x
 
 lookupNode :: Ident i => i -> DeclM i (NodeEnv i)
@@ -131,11 +131,11 @@ nextAutomatonIndex = state $ \env ->
 
 -- | Defines a stream analogous to defFun.
 defStream :: Ident i =>
-             Type i -> (StreamPos -> TypedExpr i) -> DeclM i (TypedStream i)
+             Type i -> (StreamPos -> TypedExpr) -> DeclM i (TypedStream i)
 defStream ty sf = gets natImpl >>= \natAnn -> defStream' natAnn ty sf
   where
     defStream' :: Ident i =>
-                  NatImplementation -> Type i -> (StreamPos -> TypedExpr i)
+                  NatImplementation -> Type i -> (StreamPos -> TypedExpr)
                   -> DeclM i (TypedStream i)
     defStream' natAnn (GroundType BoolT) f
       = liftSMT . fmap BoolStream $ defFunAnn natAnn (unBool' . f)
@@ -161,7 +161,7 @@ defStream ty sf = gets natImpl >>= \natAnn -> defStream' natAnn ty sf
 
 -- | Defines a function instead of streams
 defFunc :: Ident i =>
-             Int -> Type i -> ([SMTExpr Bool] -> TypedExpr i) -> DeclM i (TypedFunc i)
+             Int -> Type i -> ([SMTExpr Bool] -> TypedExpr) -> DeclM i (TypedFunc)
 defFunc i (GroundType BoolT) f = liftSMT . fmap BoolFunc $
                                 defFunAnn (replicate i ()) (unBool' . f)
 defFunc i (GroundType IntT) f = liftSMT . fmap IntFunc $
@@ -186,7 +186,7 @@ defFunc i (ProdType ts) f =
 
 -- stream :: Ident i => Type i -> DeclM i (Stream t)
 
-trConstant :: Ident i => Constant i -> TypedExpr i
+trConstant :: Ident i => Constant i -> TypedExpr
 trConstant (untyped -> BoolConst c) = BoolExpr $ constant c
 trConstant (untyped -> IntConst c) = IntExpr $ constant c
 trConstant (untyped -> RealConst c) = RealExpr $ constant c

From 1c3b112da6729e45b05f348320dfe69c86b900b1 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 24 Sep 2015 05:22:52 +0200
Subject: [PATCH 030/104] Replaced SMTExpr Bool through TypedExpr as argument
 list

Verification now also working for some other data types
(integer and real) but not for enum and (probably) product
types.
---
 lamaSMT/lib/Definition.hs            |  8 ++--
 lamaSMT/lib/LamaSMTTypes.hs          | 40 +++++++++++++++----
 lamaSMT/lib/Strategies/BMC.hs        | 39 ++++++++++++------
 lamaSMT/lib/Strategies/KInduction.hs |  6 +--
 lamaSMT/lib/Transform.hs             | 59 ++++++++++++++++++----------
 lamaSMT/lib/TransformEnv.hs          | 32 +++++++--------
 6 files changed, 121 insertions(+), 63 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 70875a4..adc17fc 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -8,7 +8,7 @@ import LamaSMTTypes
 import Internal.Monads
 
 data Definition =
-  SingleDef [Int] Bool (SMTFunction [SMTExpr Bool] Bool)
+  SingleDef [Int] Bool (SMTFunction [TypedExpr] Bool)
   | ProdDef (Array Int Definition)
   deriving Show
 
@@ -20,14 +20,14 @@ ensureDefinition argN succ _
 
 assertDefinition :: MonadSMT m =>
                     (SMTExpr Bool -> SMTExpr Bool)
-                    -> ([SMTExpr Bool], [SMTExpr Bool])
+                    -> ([TypedExpr], [TypedExpr])
                     -> Definition
                     -> m ()
 assertDefinition f i (SingleDef argN succ s) = liftSMT $ assert (f $ s `app` (lookupArgs argN succ i))
 assertDefinition f i (ProdDef ps) = mapM_ (assertDefinition f i) $ Arr.elems ps
 
-lookupArgs :: [Int] -> Bool -> ([SMTExpr Bool], [SMTExpr Bool])
-               -> [SMTExpr Bool]
+lookupArgs :: [Int] -> Bool -> ([TypedExpr], [TypedExpr])
+               -> [TypedExpr]
 lookupArgs argN True vars = [(snd vars) !! (head argN)] ++ (map ((!!) (fst vars)) $ tail argN)
 lookupArgs argN False vars = map ((!!) (fst vars)) argN
 
diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index e22820f..56c8a96 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -30,7 +30,7 @@ data TypedAnnotation
   = BoolAnnotation { anBool :: ArgAnnotation (SMTExpr Bool) }
   | IntAnnotation { anInt :: ArgAnnotation (SMTExpr Integer) }
   | RealAnnotation { anReal :: ArgAnnotation (SMTExpr Rational) }
-  | EnumAnnotation { anEnum :: ArgAnnotation (SMTExpr SMTEnum) }
+  | EnumAnnotation { anEnum :: SMTAnnotation SMTEnum}--ArgAnnotation (SMTExpr SMTEnum) }
   -- | ProdAnnotation { anProd :: ArgAnnotation a }
   deriving (Ord, Typeable, Eq, Show)
 
@@ -43,10 +43,10 @@ unProd' (ProdExpr e) = e
 unProd' e = error $ "Cannot unProd: " ++ show e
 
 data TypedFunc
-  = BoolFunc (SMTFunction [SMTExpr Bool] Bool)
-  | IntFunc (SMTFunction [SMTExpr Bool] Integer)
-  | RealFunc (SMTFunction [SMTExpr Bool] Rational)
-  | EnumFunc EnumAnn (SMTFunction [SMTExpr Bool] SMTEnum)
+  = BoolFunc (SMTFunction [TypedExpr] Bool)
+  | IntFunc (SMTFunction [TypedExpr] Integer)
+  | RealFunc (SMTFunction [TypedExpr] Rational)
+  | EnumFunc EnumAnn (SMTFunction [TypedExpr] SMTEnum)
   | ProdFunc (Array Int (TypedFunc))
   deriving Show
 
@@ -55,7 +55,7 @@ mkProdExpr [] = error "Cannot create empty product expression"
 mkProdExpr [s] = s
 mkProdExpr sts = ProdExpr . uncurry listArray $ ((0,) . pred . length &&& id) sts
 
-appFunc :: TypedFunc -> [SMTExpr Bool] -> TypedExpr
+appFunc :: TypedFunc -> [TypedExpr] -> TypedExpr
 appFunc (BoolFunc f) arg = BoolExpr $ f `app` arg
 appFunc (IntFunc f) arg = IntExpr $ f `app` arg
 appFunc (RealFunc f) arg = RealExpr $ f `app` arg
@@ -67,21 +67,45 @@ instance Args (TypedExpr) where
   foldExprs f s ~(BoolExpr x) (BoolAnnotation ann) = do
     (ns, res) <- foldExprs f s x ann
     return (ns, BoolExpr res)
+  foldExprs f s ~(IntExpr x) (IntAnnotation ann) = do
+    (ns, res) <- foldExprs f s x ann
+    return (ns, IntExpr res)
+  foldExprs f s ~(RealExpr x) (RealAnnotation ann) = do
+    (ns, res) <- foldExprs f s x ann
+    return (ns, RealExpr res)
   foldsExprs f s lst (BoolAnnotation ann) = do
     (ns, ress, res) <- foldsExprs f s (fmap (\(x,p) -> (case x of BoolExpr x' -> x',p)) lst) ann
     return (ns, fmap BoolExpr ress, BoolExpr res)
+  foldsExprs f s lst (IntAnnotation ann) = do
+    (ns, ress, res) <- foldsExprs f s (fmap (\(x,p) -> (case x of IntExpr x' -> x',p)) lst) ann
+    return (ns, fmap IntExpr ress, IntExpr res)
+  foldsExprs f s lst (RealAnnotation ann) = do
+    (ns, ress, res) <- foldsExprs f s (fmap (\(x,p) -> (case x of RealExpr x' -> x',p)) lst) ann
+    return (ns, fmap RealExpr ress, RealExpr res)
   extractArgAnnotation (BoolExpr x) = BoolAnnotation $ extractArgAnnotation x
+  extractArgAnnotation (IntExpr x) = IntAnnotation $ extractArgAnnotation x
+  extractArgAnnotation (RealExpr x) = RealAnnotation $ extractArgAnnotation x
   toArgs (BoolAnnotation ann) exprs = do
     (res, rest) <- toArgs ann exprs
     return (BoolExpr res, rest)
+  toArgs (IntAnnotation ann) exprs = do
+    (res, rest) <- toArgs ann exprs
+    return (IntExpr res, rest)
+  toArgs (RealAnnotation ann) exprs = do
+    (res, rest) <- toArgs ann exprs
+    return (RealExpr res, rest)
   fromArgs (BoolExpr xs) = fromArgs xs
   getSorts (_::TypedExpr) (BoolAnnotation ann) = error "lamasmt: no getSorts for TypedExpr"--getSorts (undefined::x) $ extractArgAnnotation ann
   getArgAnnotation _ _ = error "lamasmt: getArgAnnotation undefined for TypedExpr"
   showsArgs n p (BoolExpr x) = let (showx,nn) = showsArgs n 11 x
                                in (showParen (p>10) $
                                    showString "BoolExpr " . showx,nn)
-
-------------------------------
+  showsArgs n p (IntExpr x) = let (showx,nn) = showsArgs n 11 x
+                               in (showParen (p>10) $
+                                   showString "BoolExpr " . showx,nn)
+  showsArgs n p (RealExpr x) = let (showx,nn) = showsArgs n 11 x
+                               in (showParen (p>10) $
+                                   showString "BoolExpr " . showx,nn)
 
 type StreamPos = SMTExpr Natural
 type Stream t = SMTFunction StreamPos t
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index fb64413..75a0236 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Strategies.BMC (BMC, assumeTrace, checkInvariant, bmcStep, assertPrecond, freshVars) where
 
 import Data.Natural
@@ -6,9 +7,12 @@ import NatInstance
 import Data.List (stripPrefix)
 import qualified Data.Map as Map
 import Data.Map (Map)
+import qualified Data.Array as Array
+import Data.Array (Array)
 
 import Control.Monad.IO.Class
 import Control.Monad (when, liftM)
+import Control.Monad.State
 
 import Language.SMTLib2
 
@@ -40,7 +44,7 @@ instance StrategyClass BMC where
     in do fresh <- freshVars vars
           check' s (getModel $ varEnv env) defs base (vars, fresh)
 
-assumeTrace :: MonadSMT m => ProgDefs -> ([SMTExpr Bool], [SMTExpr Bool]) -> m ()
+assumeTrace :: MonadSMT m => ProgDefs -> ([TypedExpr], [TypedExpr]) -> m ()
 assumeTrace defs args =
   assertDefs args (flowDef defs) >>
   assertPrecond args (precondition defs)
@@ -48,7 +52,7 @@ assumeTrace defs args =
 bmcStep :: MonadSMT m =>
         (Map Natural StreamPos -> SMT (Model i))
         -> ProgDefs
-        -> ([SMTExpr Bool], [SMTExpr Bool])
+        -> ([TypedExpr], [TypedExpr])
         -> m (Bool)
 bmcStep getModel defs vars =
   do assumeTrace defs vars
@@ -61,7 +65,7 @@ check' :: BMC
        -> (Map Natural StreamPos -> SMT (Model i))
        -> ProgDefs
        -> Natural
-       -> ([SMTExpr Bool], [SMTExpr Bool])
+       -> ([TypedExpr], [TypedExpr])
        -> SMTErr (StrategyResult i)
 check' s getModel defs i vars =
   do liftIO $ when (bmcPrintProgress s) (putStrLn $ "Depth " ++ show i)
@@ -70,17 +74,17 @@ check' s getModel defs i vars =
        True -> next (check' s getModel defs) s i vars
        False -> return $ Failure i 
 
-assertDefs :: MonadSMT m => ([SMTExpr Bool], [SMTExpr Bool]) -> [Definition] -> m ()
+assertDefs :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> [Definition] -> m ()
 assertDefs i = mapM_ (assertDef i)
 
-assertDef :: MonadSMT m => ([SMTExpr Bool], [SMTExpr Bool]) -> Definition -> m ()
+assertDef :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> Definition -> m ()
 assertDef = assertDefinition id
 
-assertPrecond :: MonadSMT m => ([SMTExpr Bool], [SMTExpr Bool]) -> Definition -> m ()
+assertPrecond :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> Definition -> m ()
 assertPrecond = assertDefinition id
 
 -- | Returns true, if the invariant holds
-checkInvariant :: MonadSMT m => ([SMTExpr Bool], [SMTExpr Bool]) -> Definition -> m Bool
+checkInvariant :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> Definition -> m Bool
 checkInvariant i p = liftSMT $ assertDefinition not' i p >> liftM not checkSat
 
 checkGetModel :: MonadSMT m =>
@@ -92,12 +96,12 @@ checkGetModel getModel indices r = liftSMT $
   if r then return Nothing else fmap Just $ getModel indices
 
 next :: (Natural
-             -> ([SMTExpr Bool], [SMTExpr Bool])
+             -> ([TypedExpr], [TypedExpr])
              -> SMTErr (StrategyResult i)
         )
         -> BMC
         -> Natural
-        -> ([SMTExpr Bool], [SMTExpr Bool])
+        -> ([TypedExpr], [TypedExpr])
         -> SMTErr (StrategyResult i)
 next checkCont s i vars =
   let i' = succ i
@@ -110,5 +114,18 @@ next checkCont s i vars =
                  checkCont i' (snd vars, vars')
          else return Success
 
-freshVars :: MonadSMT m =>[SMTExpr Bool] -> m [SMTExpr Bool]
-freshVars vars = liftSMT $ mapM (\v -> var) vars
+freshVars :: MonadSMT m => [TypedExpr] -> m [TypedExpr]
+freshVars vars = liftSMT $ mapM newVar vars
+  where
+    newVar (BoolExpr _) = do new <- var
+                             return $ BoolExpr new
+    newVar (IntExpr _)  = do new <- var
+                             return $ IntExpr new
+    newVar (RealExpr _) = do new <- var
+                             return $ RealExpr new
+    --newVar (EnumExpr et) = do etAnn <- lookupEnumAnn et
+    --                          new <- varAnn etAnn
+    --                          return $ EnumExpr new
+    newVar (ProdExpr arr) = do newList <- mapM newVar (Array.elems arr)
+                               let newProd = mkProdExpr newList
+                               return newProd
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index 36f9230..aa92c90 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -68,7 +68,7 @@ instance StrategyClass KInduct where
 
 -- | Checks the induction step and returns true if the invariant could be
 -- proven
-checkStep :: ProgDefs -> ([SMTExpr Bool], [SMTExpr Bool]) -> SMT Bool
+checkStep :: ProgDefs -> ([TypedExpr], [TypedExpr]) -> SMT Bool
 checkStep defs vars =
   do assumeTrace defs vars
      let invs = invariantDef defs
@@ -77,8 +77,8 @@ checkStep defs vars =
 -- | Holds current depth k and definitions of last k and n
 data InductState = InductState
                    { kVal  :: Natural
-                   , kDefs :: ([SMTExpr Bool], [SMTExpr Bool])
-                   , nDefs :: ([SMTExpr Bool], [SMTExpr Bool]) }
+                   , kDefs :: ([TypedExpr], [TypedExpr])
+                   , nDefs :: ([TypedExpr], [TypedExpr]) }
 type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 
 -- | Checks the program against its invariant. If the invariant
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 5c4c959..276af14 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -118,7 +118,7 @@ declareEnum (t, EnumDef cs) =
         liftSMT (declareType (undefined :: SMTEnum) ann) >> return (t, ann)
 
 declareDecls :: Ident i =>
-                Maybe (SMTFunction [SMTExpr Bool] Bool)
+                Maybe (SMTFunction [TypedExpr] Bool)
                 -> Set i
                 -> Declarations i
                 -> DeclM i ([Definition], Map i (Node i))
@@ -186,7 +186,7 @@ enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
 -- declared. The other nodes are deferred to be declared in the corresponding
 -- location (see declareAutomaton and declareLocations).
 declareNode :: Ident i =>
-               Maybe (SMTFunction [SMTExpr Bool] Bool) -> i -> Node i -> DeclM i [Definition]
+               Maybe (SMTFunction [TypedExpr] Bool) -> i -> Node i -> DeclM i [Definition]
 declareNode active nName nDecl =
   do (interface, defs) <- localVarEnv (const emptyVarEnv) $
                           declareNode' active nDecl
@@ -194,7 +194,7 @@ declareNode active nName nDecl =
      return defs
   where
     declareNode' :: Ident i =>
-                    Maybe (SMTFunction [SMTExpr Bool] Bool) -> Node i
+                    Maybe (SMTFunction [TypedExpr] Bool) -> Node i
                     -> DeclM i (NodeEnv i, [Definition])
     declareNode' activeCond n =
       do let automNodes =
@@ -228,7 +228,7 @@ getNodesInLocations = mconcat . map getUsedLoc . automLocations
 -- | Creates definitions for instant definitions. In case of a node usage this
 -- may produce multiple definitions. If 
 declareInstantDef :: Ident i =>
-                     Maybe (SMTFunction [SMTExpr Bool] Bool)
+                     Maybe (SMTFunction [TypedExpr] Bool)
                      -> InstantDefinition i
                      -> DeclM i [Definition]
 declareInstantDef activeCond inst@(InstantExpr x e) =
@@ -253,7 +253,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
 -- used to further refine this instant (e.g. wrap it into an ite).
 -- This may also return definitions of the parameters of a node.
 -- The activation condition is only used for the inputs of a node.
-trInstant :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, SMTExpr Bool)] -> TypedExpr, [Definition])
+trInstant :: Ident i => Maybe (SMTFunction [TypedExpr] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
 trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
@@ -275,15 +275,15 @@ trOutput map = do
                  return $ mkProdExpr outList
                where
                  trOutput' s (i, te) = case lookup i (fst s) of
-                                       Nothing -> throwError $ "No argument binding for " ++ identPretty i
-                                       Just n -> return $ BoolExpr n
+                                       Nothing -> throwError $ "No argument (output) binding for " ++ identPretty i
+                                       Just n -> return n
 
 -- | Creates a declaration for a state transition.
 -- If an activation condition c is given, the declaration boils down to
 -- x' = (ite c e x) where e is the defining expression. Otherwise it is just
 -- x' = e.
 declareTransition :: Ident i =>
-                     Maybe (SMTFunction [SMTExpr Bool] Bool)
+                     Maybe (SMTFunction [TypedExpr] Bool)
                      -> StateTransition i
                      -> DeclM i Definition
 declareTransition activeCond (StateTransition x e) =
@@ -300,13 +300,13 @@ declareTransition activeCond (StateTransition x e) =
 -- stream of /x/ which will be defined, can be specified by modPos
 -- (see declareDef).
 declareConditionalAssign :: Ident i =>
-                            Maybe (SMTFunction [SMTExpr Bool] Bool)
+                            Maybe (SMTFunction [TypedExpr] Bool)
                             -> TypedExpr
                             -> TypedExpr
                             -> Set i
                             -> [Int]
                             -> Bool
-                            -> (Env i -> [(i, SMTExpr Bool)] -> TypedExpr)
+                            -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
                             -> DeclM i Definition
 declareConditionalAssign activeCond defaultExpr x al ns succ ef =
   case activeCond of
@@ -328,19 +328,35 @@ declareConditionalAssign activeCond defaultExpr x al ns succ ef =
 -- The second argument /x/ is the stream to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
 declareDef :: Ident i => TypedExpr -> Set i -> [Int] -> Bool ->
-              (Env i -> [(i, SMTExpr Bool)] -> TypedExpr) -> DeclM i Definition
+              (Env i -> [(i, TypedExpr)] -> TypedExpr) -> DeclM i Definition
 declareDef x as ns succ ef =
   do env         <- get
      let defType = varDefType x
      xN          <- getN x
-     d           <- defFunc (1 + Set.size as) defType
-                    $ \a -> liftRel (.==.) (BoolExpr $ head a) $ ef env $ zip (Set.toList as) (tail a)
+     ann         <- getTypedAnnotation $ [xN] ++ ns
+     d           <- defFunc (1 + Set.size as) defType ann
+                    $ \a -> liftRel (.==.) (head a) $ ef env $ zip (Set.toList as) (tail a)
      return $ ensureDefinition ([xN] ++ ns) succ d
   where
     varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
     varDefType _               = boolT
 
-declareFlow :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Flow i -> DeclM i [Definition]
+getTypedAnnotation :: Ident i => [Int] -> DeclM i [TypedAnnotation]
+getTypedAnnotation ns = mapM getTypedAnnotation' ns
+  where
+    getTypedAnnotation' n =
+      do vars <- gets varList
+         case vars !! n of
+           BoolExpr _ -> return $ BoolAnnotation ()
+           IntExpr _ -> return $ IntAnnotation ()
+           RealExpr _ -> return $ RealAnnotation ()
+           --EnumExpr k -> do ea <- lookupEnumAnn k        
+                            --return $ EnumAnnotation ea
+        --                Nothing -> error "enum annotation not doung in environment"
+        --                Just v -> EnumAnnotation v
+        --ProdExpr _ -> ProdAnnotation ()
+
+declareFlow :: Ident i => Maybe (SMTFunction [TypedExpr] Bool) -> Flow i -> DeclM i [Definition]
 declareFlow activeCond f =
   do defDefs        <- fmap concat
                        . mapM (declareInstantDef activeCond)
@@ -692,22 +708,23 @@ assertInit (x, e) =
 
 -- | Creates a definition for a precondition p. If an activation condition c
 -- is given, the resulting condition is (=> c p).
-declarePrecond :: Ident i => Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
+declarePrecond :: Ident i => Maybe (SMTFunction [TypedExpr] Bool) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
   do env      <- get
      let args = getArgSet e
      argsE    <- mapM lookupVar $ Set.toList args
      argsN    <- mapM getN argsE
+     ann      <- getTypedAnnotation argsN
      d        <- case activeCond of
-       Nothing -> defFunc (Set.size $ args) boolT $ \a -> runTransM (trExpr e) env (zip (Set.toList $ args) a)
-       Just c -> defFunc (Set.size $ args) boolT $
+       Nothing -> defFunc (Set.size $ args) boolT ann $ \a -> runTransM (trExpr e) env (zip (Set.toList $ args) a)
+       Just c -> defFunc (Set.size $ args) boolT ann $
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
      return $ ensureDefinition argsN False d
 
 declareInvariant :: Ident i =>
-                    Maybe (SMTFunction [SMTExpr Bool] Bool) -> Expr i -> DeclM i Definition
+                    Maybe (SMTFunction [TypedExpr] Bool) -> Expr i -> DeclM i Definition
 declareInvariant = declarePrecond
 
 trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr)
@@ -718,7 +735,7 @@ trConstExpr (untyped -> ConstEnum x)
 trConstExpr (untyped -> ConstProd (Prod cs)) =
   ProdExpr . listArray (0, length cs - 1) <$> mapM trConstExpr cs
 
-type TransM i = ReaderT ([(i, SMTExpr Bool)], Env i) (Either String)
+type TransM i = ReaderT ([(i, TypedExpr)], Env i) (Either String)
 
 {-
 doAppStream :: TypedStream i -> TransM i (TypedExpr)
@@ -726,7 +743,7 @@ doAppStream s = askStreamPos >>= return . appStream s
 -}
 
 -- beware: uses error
-runTransM :: TransM i a -> Env i -> [(i, SMTExpr Bool)] -> a
+runTransM :: TransM i a -> Env i -> [(i, TypedExpr)] -> a
 runTransM m e a = case runReaderT m (a, e) of
   Left err -> error err
   Right r -> r
@@ -770,7 +787,7 @@ trExpr expr = case untyped expr of
                             s <- ask
                             case lookup x (fst s) of
                               Nothing -> throwError $ "No argument binding for " ++ identPretty x
-                              Just n -> return $ BoolExpr n
+                              Just n -> return n
   AtExpr (AtomEnum x)  -> EnumExpr <$> trEnumCons x
   LogNot e             -> lift1Bool not' <$> trExpr e
   Expr2 op e1 e2       -> applyOp op <$> trExpr e1 <*> trExpr e2
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 0c7bbfe..8e2d78b 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -47,7 +47,7 @@ data Env i = Env
            , enumConsAnn :: Map (EnumConstr i) (SMTAnnotation SMTEnum)
            , varEnv :: VarEnv i
            , currAutomatonIndex :: Integer
-           , varList :: [SMTExpr Bool]
+           , varList :: [TypedExpr]
            , natImpl :: NatImplementation
            , enumImpl :: EnumImplementation
            }
@@ -67,11 +67,11 @@ putConstants cs =
 
 addVar :: Ident i => TypedExpr -> DeclM i ()
 addVar var =
-  modify $ \env -> env { varList = (varList env) ++ [unBool' var] }
+  modify $ \env -> env { varList = (varList env) ++ [var] }
 
 getN :: TypedExpr -> DeclM i Int
 getN x = do vars <- gets varList
-            return $ case List.elemIndex (unBool' x) vars of
+            return $ case List.elemIndex x vars of
                           Nothing -> error $ "Could not be found in list of     variables: " ++ show x
                           Just n -> n
 
@@ -161,28 +161,28 @@ defStream ty sf = gets natImpl >>= \natAnn -> defStream' natAnn ty sf
 
 -- | Defines a function instead of streams
 defFunc :: Ident i =>
-             Int -> Type i -> ([SMTExpr Bool] -> TypedExpr) -> DeclM i (TypedFunc)
-defFunc i (GroundType BoolT) f = liftSMT . fmap BoolFunc $
-                                defFunAnn (replicate i ()) (unBool' . f)
-defFunc i (GroundType IntT) f = liftSMT . fmap IntFunc $
-                                defFunAnn (replicate i ()) (unInt . f)
-defFunc i (GroundType RealT) f = liftSMT . fmap RealFunc $
-                               defFunAnn (replicate i ()) (unReal . f)
-defFunc i (GroundType _) f = $notImplemented
-defFunc i (EnumType alias) f = do ann <- lookupEnumAnn alias
-                                  liftSMT $ fmap (EnumFunc ann) $
-                                   defFunAnn (replicate i ()) (unEnum . f)
+             Int -> Type i -> [TypedAnnotation] -> ([TypedExpr] -> TypedExpr) -> DeclM i (TypedFunc)
+defFunc i (GroundType BoolT) ann f = liftSMT . fmap BoolFunc $
+                                defFunAnn ann (unBool' . f)
+defFunc i (GroundType IntT) ann f = liftSMT . fmap IntFunc $
+                                defFunAnn ann (unInt . f)
+defFunc i (GroundType RealT) ann f = liftSMT . fmap RealFunc $
+                               defFunAnn ann (unReal . f)
+defFunc i (GroundType _) ann f = $notImplemented
+defFunc i (EnumType alias) ann f = do eann <- lookupEnumAnn alias
+                                      liftSMT $ fmap (EnumFunc eann) $
+                                       defFunAnn ann (unEnum . f)
 -- We have to pull the product out of a stream.
 -- If we are given a function f : FuncPos -> (Ix -> TE) = TypedExpr as above,
 -- we would like to have as result something like:
 -- g : Ix -> (FuncPos -> TE)
 -- g(i)(t) = defFunc(λt'.f(t')(i))(t)
 -- Here i is the index into the product and t,t' are time variables.
-defFunc i (ProdType ts) f =
+defFunc i (ProdType ts) ann f =
   do let u = length ts - 1
      x <- mapM defParts $ zip ts [0..u]
      return . ProdFunc $ listArray (0,u) x
-  where defParts (ty2, i) = defFunc i ty2 ((! i) . unProd' . f)
+  where defParts (ty2, i) = defFunc i ty2 ann ((! i) . unProd' . f)
 
 -- stream :: Ident i => Type i -> DeclM i (Stream t)
 

From 3b72c1807494250c186dbc48b7af895cedf01a5f Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Fri, 25 Sep 2015 21:41:06 +0200
Subject: [PATCH 031/104] Enum datatypes (probably) working

---
 lamaSMT/lib/LamaSMTTypes.hs   | 22 +++++++++++++++++++---
 lamaSMT/lib/Strategies/BMC.hs | 17 ++++++++++-------
 lamaSMT/lib/Transform.hs      |  6 ++++--
 3 files changed, 33 insertions(+), 12 deletions(-)

diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index 56c8a96..dc95f36 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -30,7 +30,7 @@ data TypedAnnotation
   = BoolAnnotation { anBool :: ArgAnnotation (SMTExpr Bool) }
   | IntAnnotation { anInt :: ArgAnnotation (SMTExpr Integer) }
   | RealAnnotation { anReal :: ArgAnnotation (SMTExpr Rational) }
-  | EnumAnnotation { anEnum :: SMTAnnotation SMTEnum}--ArgAnnotation (SMTExpr SMTEnum) }
+  | EnumAnnotation { anEnum ::{- SMTAnnotation SMTEnum-}ArgAnnotation (SMTExpr SMTEnum) }
   -- | ProdAnnotation { anProd :: ArgAnnotation a }
   deriving (Ord, Typeable, Eq, Show)
 
@@ -73,6 +73,9 @@ instance Args (TypedExpr) where
   foldExprs f s ~(RealExpr x) (RealAnnotation ann) = do
     (ns, res) <- foldExprs f s x ann
     return (ns, RealExpr res)
+  foldExprs f s ~(EnumExpr x) (EnumAnnotation ann) = do
+    (ns, res) <- foldExprs f s x ann
+    return (ns, EnumExpr res)
   foldsExprs f s lst (BoolAnnotation ann) = do
     (ns, ress, res) <- foldsExprs f s (fmap (\(x,p) -> (case x of BoolExpr x' -> x',p)) lst) ann
     return (ns, fmap BoolExpr ress, BoolExpr res)
@@ -82,9 +85,13 @@ instance Args (TypedExpr) where
   foldsExprs f s lst (RealAnnotation ann) = do
     (ns, ress, res) <- foldsExprs f s (fmap (\(x,p) -> (case x of RealExpr x' -> x',p)) lst) ann
     return (ns, fmap RealExpr ress, RealExpr res)
+  foldsExprs f s lst (EnumAnnotation ann) = do
+    (ns, ress, res) <- foldsExprs f s (fmap (\(x,p) -> (case x of EnumExpr x' -> x',p)) lst) ann
+    return (ns, fmap EnumExpr ress, EnumExpr res)
   extractArgAnnotation (BoolExpr x) = BoolAnnotation $ extractArgAnnotation x
   extractArgAnnotation (IntExpr x) = IntAnnotation $ extractArgAnnotation x
   extractArgAnnotation (RealExpr x) = RealAnnotation $ extractArgAnnotation x
+  extractArgAnnotation (EnumExpr x) = EnumAnnotation $ extractArgAnnotation x
   toArgs (BoolAnnotation ann) exprs = do
     (res, rest) <- toArgs ann exprs
     return (BoolExpr res, rest)
@@ -94,7 +101,13 @@ instance Args (TypedExpr) where
   toArgs (RealAnnotation ann) exprs = do
     (res, rest) <- toArgs ann exprs
     return (RealExpr res, rest)
+  toArgs (EnumAnnotation ann) exprs = do
+    (res, rest) <- toArgs ann exprs
+    return (EnumExpr res, rest)
   fromArgs (BoolExpr xs) = fromArgs xs
+  fromArgs (IntExpr xs) = fromArgs xs
+  fromArgs (RealExpr xs) = fromArgs xs
+  fromArgs (EnumExpr xs) = fromArgs xs
   getSorts (_::TypedExpr) (BoolAnnotation ann) = error "lamasmt: no getSorts for TypedExpr"--getSorts (undefined::x) $ extractArgAnnotation ann
   getArgAnnotation _ _ = error "lamasmt: getArgAnnotation undefined for TypedExpr"
   showsArgs n p (BoolExpr x) = let (showx,nn) = showsArgs n 11 x
@@ -102,10 +115,13 @@ instance Args (TypedExpr) where
                                    showString "BoolExpr " . showx,nn)
   showsArgs n p (IntExpr x) = let (showx,nn) = showsArgs n 11 x
                                in (showParen (p>10) $
-                                   showString "BoolExpr " . showx,nn)
+                                   showString "IntExpr " . showx,nn)
   showsArgs n p (RealExpr x) = let (showx,nn) = showsArgs n 11 x
                                in (showParen (p>10) $
-                                   showString "BoolExpr " . showx,nn)
+                                   showString "RealExpr " . showx,nn)
+  showsArgs n p (EnumExpr x) = let (showx,nn) = showsArgs n 11 x
+                               in (showParen (p>10) $
+                                   showString "EnumExpr " . showx,nn)
 
 type StreamPos = SMTExpr Natural
 type Stream t = SMTFunction StreamPos t
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index 75a0236..eb2af4e 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -15,6 +15,7 @@ import Control.Monad (when, liftM)
 import Control.Monad.State
 
 import Language.SMTLib2
+import Language.SMTLib2.Internals (SMTExpr(Var))
 
 import Strategy
 import LamaSMTTypes
@@ -117,13 +118,15 @@ next checkCont s i vars =
 freshVars :: MonadSMT m => [TypedExpr] -> m [TypedExpr]
 freshVars vars = liftSMT $ mapM newVar vars
   where
-    newVar (BoolExpr _) = do new <- var
-                             return $ BoolExpr new
-    newVar (IntExpr _)  = do new <- var
-                             return $ IntExpr new
-    newVar (RealExpr _) = do new <- var
-                             return $ RealExpr new
-    --newVar (EnumExpr et) = do etAnn <- lookupEnumAnn et
+    newVar (BoolExpr _)   = do new <- var
+                               return $ BoolExpr new
+    newVar (IntExpr _)    = do new <- var
+                               return $ IntExpr new
+    newVar (RealExpr _)   = do new <- var
+                               return $ RealExpr new
+    newVar (EnumExpr (Var _ k))  = do new <- varAnn k
+                                      return $ EnumExpr new
+                              --etAnn <- lookupEnumAnn et
     --                          new <- varAnn etAnn
     --                          return $ EnumExpr new
     newVar (ProdExpr arr) = do newList <- mapM newVar (Array.elems arr)
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 276af14..513cb38 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -21,7 +21,7 @@ import Lang.LAMA.Identifier
 import Lang.LAMA.Typing.TypedStructure
 import Lang.LAMA.Types
 import Language.SMTLib2 as SMT
-import Language.SMTLib2.Internals (declareType)
+import Language.SMTLib2.Internals (declareType, SMTExpr(Var))
 import Data.Unit
 import Data.String (IsString(..))
 import Data.Array as Arr
@@ -345,11 +345,13 @@ getTypedAnnotation :: Ident i => [Int] -> DeclM i [TypedAnnotation]
 getTypedAnnotation ns = mapM getTypedAnnotation' ns
   where
     getTypedAnnotation' n =
-      do vars <- gets varList
+      do vars    <- gets varList
+         eAnn <- gets enumAnn
          case vars !! n of
            BoolExpr _ -> return $ BoolAnnotation ()
            IntExpr _ -> return $ IntAnnotation ()
            RealExpr _ -> return $ RealAnnotation ()
+           EnumExpr (Var _ k) -> return $ EnumAnnotation k--return $ EnumAnnotation ()
            --EnumExpr k -> do ea <- lookupEnumAnn k        
                             --return $ EnumAnnotation ea
         --                Nothing -> error "enum annotation not doung in environment"

From e24dab454593c98218e7257830539ed664b445b4 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 26 Sep 2015 01:25:10 +0200
Subject: [PATCH 032/104] Product datatypes now also working, but not verified

---
 lamaSMT/lib/LamaSMTTypes.hs   | 44 ++++++++++++++++++++++++++++++++---
 lamaSMT/lib/Strategies/BMC.hs | 22 ++++++++----------
 lamaSMT/lib/Transform.hs      | 36 ++++++++++++++--------------
 3 files changed, 68 insertions(+), 34 deletions(-)

diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index dc95f36..2ba571c 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -12,6 +12,10 @@ import Data.Natural
 import NatInstance ()
 import Data.Array as Arr
 import Data.Typeable
+import Data.Foldable (foldlM)
+import Data.List (mapAccumL)
+
+import Text.Show
 
 import Control.Arrow ((&&&))
 
@@ -30,8 +34,8 @@ data TypedAnnotation
   = BoolAnnotation { anBool :: ArgAnnotation (SMTExpr Bool) }
   | IntAnnotation { anInt :: ArgAnnotation (SMTExpr Integer) }
   | RealAnnotation { anReal :: ArgAnnotation (SMTExpr Rational) }
-  | EnumAnnotation { anEnum ::{- SMTAnnotation SMTEnum-}ArgAnnotation (SMTExpr SMTEnum) }
-  -- | ProdAnnotation { anProd :: ArgAnnotation a }
+  | EnumAnnotation { anEnum :: ArgAnnotation (SMTExpr SMTEnum) }
+  | ProdAnnotation { anProd :: Array Int TypedAnnotation }
   deriving (Ord, Typeable, Eq, Show)
 
 unBool' :: TypedExpr -> SMTExpr Bool
@@ -76,6 +80,12 @@ instance Args (TypedExpr) where
   foldExprs f s ~(EnumExpr x) (EnumAnnotation ann) = do
     (ns, res) <- foldExprs f s x ann
     return (ns, EnumExpr res)
+  foldExprs f s ~(ProdExpr x) (ProdAnnotation y) =
+    foldlM (\(s',ProdExpr cmp) (k,ann) -> do
+      let el = x ! k
+      (s'',el') <- foldExprs f s' el ann
+      return (s'', ProdExpr $ cmp Arr.// [(k,el')])
+      ) (s,ProdExpr $ Arr.array (bounds y) []) (Arr.assocs y)
   foldsExprs f s lst (BoolAnnotation ann) = do
     (ns, ress, res) <- foldsExprs f s (fmap (\(x,p) -> (case x of BoolExpr x' -> x',p)) lst) ann
     return (ns, fmap BoolExpr ress, BoolExpr res)
@@ -88,10 +98,18 @@ instance Args (TypedExpr) where
   foldsExprs f s lst (EnumAnnotation ann) = do
     (ns, ress, res) <- foldsExprs f s (fmap (\(x,p) -> (case x of EnumExpr x' -> x',p)) lst) ann
     return (ns, fmap EnumExpr ress, EnumExpr res)
+  foldsExprs f s args (ProdAnnotation ann) = do
+    let lst_ann = Arr.assocs ann
+        lst = fmap (\(ProdExpr mp,extra) -> ([ mp ! k | (k,_) <- lst_ann ],extra)
+                   ) args
+    (ns,lst',lst_merged) <- foldsExprs f s lst (fmap snd lst_ann)
+    return (ns,fmap (\lst'' -> ProdExpr $ Arr.array (bounds ann) $ zip (fmap fst lst_ann) lst''
+                    ) lst',ProdExpr $ Arr.array (bounds ann)  $ zip (fmap fst lst_ann) lst_merged)
   extractArgAnnotation (BoolExpr x) = BoolAnnotation $ extractArgAnnotation x
   extractArgAnnotation (IntExpr x) = IntAnnotation $ extractArgAnnotation x
   extractArgAnnotation (RealExpr x) = RealAnnotation $ extractArgAnnotation x
   extractArgAnnotation (EnumExpr x) = EnumAnnotation $ extractArgAnnotation x
+  extractArgAnnotation (ProdExpr x) = ProdAnnotation $ fmap extractArgAnnotation x
   toArgs (BoolAnnotation ann) exprs = do
     (res, rest) <- toArgs ann exprs
     return (BoolExpr res, rest)
@@ -104,10 +122,20 @@ instance Args (TypedExpr) where
   toArgs (EnumAnnotation ann) exprs = do
     (res, rest) <- toArgs ann exprs
     return (EnumExpr res, rest)
+  toArgs (ProdAnnotation mp_ann) exprs =
+    case mapAccumL (\cst (k,ann) -> case cst of
+        Nothing -> (Nothing,undefined)
+        Just rest -> case toArgs ann rest of
+          Nothing -> (Nothing,undefined)
+          Just (res,rest') -> (Just rest', (k,res))
+                   ) (Just exprs) (Arr.assocs mp_ann) of
+      (Nothing,_) -> Nothing
+      (Just rest,mp) -> Just (ProdExpr $ Arr.array (bounds mp_ann) mp,rest)
   fromArgs (BoolExpr xs) = fromArgs xs
-  fromArgs (IntExpr xs) = fromArgs xs
+  fromArgs (IntExpr  xs) = fromArgs xs
   fromArgs (RealExpr xs) = fromArgs xs
   fromArgs (EnumExpr xs) = fromArgs xs
+  fromArgs (ProdExpr xs) = concat $ fmap fromArgs $ Arr.elems xs
   getSorts (_::TypedExpr) (BoolAnnotation ann) = error "lamasmt: no getSorts for TypedExpr"--getSorts (undefined::x) $ extractArgAnnotation ann
   getArgAnnotation _ _ = error "lamasmt: getArgAnnotation undefined for TypedExpr"
   showsArgs n p (BoolExpr x) = let (showx,nn) = showsArgs n 11 x
@@ -122,6 +150,16 @@ instance Args (TypedExpr) where
   showsArgs n p (EnumExpr x) = let (showx,nn) = showsArgs n 11 x
                                in (showParen (p>10) $
                                    showString "EnumExpr " . showx,nn)
+  showsArgs n p (ProdExpr x) =
+    let (ni,lst') = mapAccumL (\ci (key,arg)
+                               -> let (str,ci') = showsArgs ci 0 arg
+                                  in (ci',(key,str))
+                              ) n (Arr.assocs x)
+    in (showString "fromList " . showListWith (\(key,str)
+                                               -> showChar '(' .
+                                                  showsPrec 0 key .
+                                                  showChar ',' .
+                                                  str . showChar ')') lst',ni)
 
 type StreamPos = SMTExpr Natural
 type Stream t = SMTFunction StreamPos t
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index eb2af4e..2721682 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -118,17 +118,15 @@ next checkCont s i vars =
 freshVars :: MonadSMT m => [TypedExpr] -> m [TypedExpr]
 freshVars vars = liftSMT $ mapM newVar vars
   where
-    newVar (BoolExpr _)   = do new <- var
-                               return $ BoolExpr new
-    newVar (IntExpr _)    = do new <- var
-                               return $ IntExpr new
-    newVar (RealExpr _)   = do new <- var
-                               return $ RealExpr new
+    newVar (BoolExpr _)          = do new <- var
+                                      return $ BoolExpr new
+    newVar (IntExpr _)           = do new <- var
+                                      return $ IntExpr new
+    newVar (RealExpr _)          = do new <- var
+                                      return $ RealExpr new
     newVar (EnumExpr (Var _ k))  = do new <- varAnn k
                                       return $ EnumExpr new
-                              --etAnn <- lookupEnumAnn et
-    --                          new <- varAnn etAnn
-    --                          return $ EnumExpr new
-    newVar (ProdExpr arr) = do newList <- mapM newVar (Array.elems arr)
-                               let newProd = mkProdExpr newList
-                               return newProd
+    newVar (ProdExpr arr)        =
+      do newList <- mapM newVar (Array.elems arr)
+         let newProd = mkProdExpr newList
+         return newProd
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 513cb38..c6bec89 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -347,16 +347,14 @@ getTypedAnnotation ns = mapM getTypedAnnotation' ns
     getTypedAnnotation' n =
       do vars    <- gets varList
          eAnn <- gets enumAnn
-         case vars !! n of
-           BoolExpr _ -> return $ BoolAnnotation ()
-           IntExpr _ -> return $ IntAnnotation ()
-           RealExpr _ -> return $ RealAnnotation ()
-           EnumExpr (Var _ k) -> return $ EnumAnnotation k--return $ EnumAnnotation ()
-           --EnumExpr k -> do ea <- lookupEnumAnn k        
-                            --return $ EnumAnnotation ea
-        --                Nothing -> error "enum annotation not doung in environment"
-        --                Just v -> EnumAnnotation v
-        --ProdExpr _ -> ProdAnnotation ()
+         return $ getTypedAnnCases $ vars !! n
+           where getTypedAnnCases var =
+                   case var of
+                     BoolExpr _ -> BoolAnnotation ()
+                     IntExpr _ -> IntAnnotation ()
+                     RealExpr _ -> RealAnnotation ()
+                     EnumExpr (Var _ k) -> EnumAnnotation k
+                     ProdExpr k -> ProdAnnotation $ fmap getTypedAnnCases k
 
 declareFlow :: Ident i => Maybe (SMTFunction [TypedExpr] Bool) -> Flow i -> DeclM i [Definition]
 declareFlow activeCond f =
@@ -770,15 +768,15 @@ askStreamPos = asks fst
 
 getArgSet :: Ident i => Expr i -> Set i
 getArgSet expr = case untyped expr of
-  AtExpr (AtomConst c) -> Set.empty
-  AtExpr (AtomVar x)   -> Set.singleton x
-  AtExpr (AtomEnum x)  -> Set.empty
-  LogNot e             -> getArgSet e
-  Expr2 op e1 e2       -> Set.union (getArgSet e1) (getArgSet e2)
-  Ite c e1 e2          -> Set.unions [getArgSet c, getArgSet e1, getArgSet e2]
-  ProdCons (Prod es)   -> foldr (Set.union . getArgSet) Set.empty es
-  Project x i          -> Set.empty
-  Match e pats         -> getArgSet e
+  AtExpr (AtomConst c)  -> Set.empty
+  AtExpr (AtomVar x)    -> Set.singleton x
+  AtExpr (AtomEnum x)   -> Set.empty
+  LogNot e              -> getArgSet e
+  Expr2 op e1 e2        -> Set.union (getArgSet e1) (getArgSet e2)
+  Ite c e1 e2           -> Set.unions [getArgSet c, getArgSet e1, getArgSet e2]
+  ProdCons (Prod es)    -> foldr (Set.union . getArgSet) Set.empty es
+  Project x i           -> Set.singleton x
+  Match e pats -> Set.unions $ [getArgSet e] ++ map (\(Pattern _ x) -> getArgSet x) pats
 
 -- we do no further type checks since this
 -- has been done beforehand.

From 85f8ee3c7e1a1f96066503f66c72ee5a027c5642 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 26 Sep 2015 04:14:00 +0200
Subject: [PATCH 033/104] Conditional assign implemented correctly

---
 lamaSMT/lib/Transform.hs | 32 ++++++++++++--------------------
 1 file changed, 12 insertions(+), 20 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index c6bec89..31db521 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -118,7 +118,7 @@ declareEnum (t, EnumDef cs) =
         liftSMT (declareType (undefined :: SMTEnum) ann) >> return (t, ann)
 
 declareDecls :: Ident i =>
-                Maybe (SMTFunction [TypedExpr] Bool)
+                Maybe (TypedExpr)
                 -> Set i
                 -> Declarations i
                 -> DeclM i ([Definition], Map i (Node i))
@@ -186,7 +186,7 @@ enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
 -- declared. The other nodes are deferred to be declared in the corresponding
 -- location (see declareAutomaton and declareLocations).
 declareNode :: Ident i =>
-               Maybe (SMTFunction [TypedExpr] Bool) -> i -> Node i -> DeclM i [Definition]
+               Maybe (TypedExpr) -> i -> Node i -> DeclM i [Definition]
 declareNode active nName nDecl =
   do (interface, defs) <- localVarEnv (const emptyVarEnv) $
                           declareNode' active nDecl
@@ -194,7 +194,7 @@ declareNode active nName nDecl =
      return defs
   where
     declareNode' :: Ident i =>
-                    Maybe (SMTFunction [TypedExpr] Bool) -> Node i
+                    Maybe (TypedExpr) -> Node i
                     -> DeclM i (NodeEnv i, [Definition])
     declareNode' activeCond n =
       do let automNodes =
@@ -228,7 +228,7 @@ getNodesInLocations = mconcat . map getUsedLoc . automLocations
 -- | Creates definitions for instant definitions. In case of a node usage this
 -- may produce multiple definitions. If 
 declareInstantDef :: Ident i =>
-                     Maybe (SMTFunction [TypedExpr] Bool)
+                     Maybe (TypedExpr)
                      -> InstantDefinition i
                      -> DeclM i [Definition]
 declareInstantDef activeCond inst@(InstantExpr x e) =
@@ -253,7 +253,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
 -- used to further refine this instant (e.g. wrap it into an ite).
 -- This may also return definitions of the parameters of a node.
 -- The activation condition is only used for the inputs of a node.
-trInstant :: Ident i => Maybe (SMTFunction [TypedExpr] Bool) -> InstantDefinition i -> DeclM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
+trInstant :: Ident i => Maybe (TypedExpr) -> InstantDefinition i -> DeclM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
 trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
@@ -283,7 +283,7 @@ trOutput map = do
 -- x' = (ite c e x) where e is the defining expression. Otherwise it is just
 -- x' = e.
 declareTransition :: Ident i =>
-                     Maybe (SMTFunction [TypedExpr] Bool)
+                     Maybe (TypedExpr)
                      -> StateTransition i
                      -> DeclM i Definition
 declareTransition activeCond (StateTransition x e) =
@@ -300,7 +300,7 @@ declareTransition activeCond (StateTransition x e) =
 -- stream of /x/ which will be defined, can be specified by modPos
 -- (see declareDef).
 declareConditionalAssign :: Ident i =>
-                            Maybe (SMTFunction [TypedExpr] Bool)
+                            Maybe (TypedExpr)
                             -> TypedExpr
                             -> TypedExpr
                             -> Set i
@@ -312,15 +312,7 @@ declareConditionalAssign activeCond defaultExpr x al ns succ ef =
   case activeCond of
     Nothing -> declareDef x al ns succ ef
     Just c  ->
-      declareDef x al ns succ ef
-      --declareDef modPos x (mkConditionalExpr c e defaultExpr)
-  where
-    -- | Takes a condition and the corresponding branches which may depend
-    -- on the current time and builds an expression which takes the corresponding
-    -- branch depending on the condition (if c then s_1(n) else s_2(n)).
-    mkConditionalExpr c s1 s2 =
-      let c' = BoolExpr $ c
-      in liftIte c' s1 s2
+      declareDef x al ns succ (\env t -> liftIte c (ef env t) defaultExpr)
 
 -- | Creates a definition for a given variable. Whereby a function to
 -- manipulate the stream position at which it is defined is used (normally
@@ -356,7 +348,7 @@ getTypedAnnotation ns = mapM getTypedAnnotation' ns
                      EnumExpr (Var _ k) -> EnumAnnotation k
                      ProdExpr k -> ProdAnnotation $ fmap getTypedAnnCases k
 
-declareFlow :: Ident i => Maybe (SMTFunction [TypedExpr] Bool) -> Flow i -> DeclM i [Definition]
+declareFlow :: Ident i => Maybe (TypedExpr) -> Flow i -> DeclM i [Definition]
 declareFlow activeCond f =
   do defDefs        <- fmap concat
                        . mapM (declareInstantDef activeCond)
@@ -708,7 +700,7 @@ assertInit (x, e) =
 
 -- | Creates a definition for a precondition p. If an activation condition c
 -- is given, the resulting condition is (=> c p).
-declarePrecond :: Ident i => Maybe (SMTFunction [TypedExpr] Bool) -> Expr i -> DeclM i Definition
+declarePrecond :: Ident i => Maybe (TypedExpr) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
   do env      <- get
      let args = getArgSet e
@@ -720,11 +712,11 @@ declarePrecond activeCond e =
        Just c -> defFunc (Set.size $ args) boolT ann $
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
 		       (trExpr e >>= \e' ->
-                         return $ liftBool2 (.=>.) (BoolExpr $ c `app` a) e')
+                         return $ liftBool2 (.=>.) c e')
      return $ ensureDefinition argsN False d
 
 declareInvariant :: Ident i =>
-                    Maybe (SMTFunction [TypedExpr] Bool) -> Expr i -> DeclM i Definition
+                    Maybe (TypedExpr) -> Expr i -> DeclM i Definition
 declareInvariant = declarePrecond
 
 trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr)

From 02062760acac9a3e5397257d95bd3c43454e68c5 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 26 Sep 2015 16:01:31 +0200
Subject: [PATCH 034/104] Definitions in automaton locations but arguments not
 correct

---
 lamaSMT/lib/Transform.hs | 111 +++++++++++++++++++++------------------
 1 file changed, 59 insertions(+), 52 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 31db521..09e7bb9 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -206,15 +206,15 @@ declareNode active nName nDecl =
          let outs = Map.fromList outDecls
          modifyVars $ Map.union (Map.fromList outDecls)
          flowDefs <- declareFlow activeCond $ nodeFlow n
-         --automDefs <-
-         --  fmap concat .
-         --  mapM (declareAutomaton activeCond undeclaredNodes) .
-         --  Map.toList $ nodeAutomata n
+         automDefs <-
+           fmap concat .
+           mapM (declareAutomaton activeCond undeclaredNodes) .
+           Map.toList $ nodeAutomata n
          assertInits $ nodeInitial n
          precondDef <- declarePrecond activeCond $ nodeAssertion n
          varDefs <- gets varEnv
          return (NodeEnv ins outs varDefs,
-                 declDefs ++ flowDefs ++{- automDefs ++-} [precondDef])
+                 declDefs ++ flowDefs ++ automDefs ++ [precondDef])
 
 -- | Extracts all nodes which are used inside some location.
 getNodesInLocations :: Ident i => Automaton i -> Set i
@@ -356,7 +356,6 @@ declareFlow activeCond f =
      transitionDefs <- mapM (declareTransition activeCond) $ flowTransitions f
      return $ defDefs ++ transitionDefs
 
-{-
 -- | Declares an automaton by
 -- * defining an enum for the locations
 -- * defining two variables which hold the active location (see mkStateVars)
@@ -367,7 +366,7 @@ declareFlow activeCond f =
 --    conditions (mkTransitionEq)
 -- * asserting the initial location
 declareAutomaton :: Ident i =>
-                    Maybe (Stream Bool)
+                    Maybe (TypedExpr)
                     -> Map i (Node i)
                     -> (Int, Automaton i)
                     -> DeclM i [Definition]
@@ -387,19 +386,19 @@ declareAutomaton activeCond localNodes (_, a) =
          selName   = "sel" ++ automName
          selId     = fromString selName
      declareEnums $ Map.singleton enumName enum
-     (act, sel, eAnn) <- mkStateVars actName selName enumName
+     (act, sel) <- mkStateVars actName selName enumName
      modifyVars ( `Map.union` Map.fromList
-                  [(actId, EnumStream eAnn act),
-                   (selId, EnumStream eAnn sel)
+                  [(actId, act),
+                   (selId, sel)
                   ]
                 )
      locDefs <- (flip runReaderT (locCons, localNodes))
                 $ declareLocations activeCond act
                 (automDefaults a) (automLocations a)
-     edgeDefs <- mkTransitionEq activeCond stateT locCons actId selId
+     {-edgeDefs <- mkTransitionEq activeCond stateT locCons actId selId
                  $ automEdges a
      assertInit (selId, locConsConstExpr locCons stateT $ automInitial a)
-     return $ locDefs ++ edgeDefs
+   -}return $ locDefs-- ++ edgeDefs
 
   where
     getLocId (Location i _) = i
@@ -409,6 +408,7 @@ declareAutomaton activeCond localNodes (_, a) =
     locationName :: Ident i => String -> i -> i
     locationName automName sName = fromString $ automName ++ identString sName
 
+{-
     -- | Create the enum constructor for a given location name as constant.
     locConsConstExpr :: Ord i =>
                         Map (LocationId i) (EnumConstr i)
@@ -417,6 +417,7 @@ declareAutomaton activeCond localNodes (_, a) =
                         -> ConstExpr i
     locConsConstExpr locNames t loc
       = mkTyped (ConstEnum ((Map.!) locNames loc)) t
+-}
 
 -- | Generate names of two variable which represent
 -- the state of the automaton (s, sel). Where
@@ -427,13 +428,12 @@ mkStateVars :: Ident i =>
                String
                -> String
                -> i
-               -> DeclM i (Stream SMTEnum, Stream SMTEnum, EnumAnn)
+               -> DeclM i (TypedExpr, TypedExpr)
 mkStateVars actName selName stateEnum =
   do stEnumAnn <- lookupEnumAnn stateEnum
-     natAnn <- gets natImpl
-     act <- liftSMT $ funAnnNamed actName natAnn stEnumAnn
-     sel <- liftSMT $ funAnnNamed selName natAnn stEnumAnn
-     return (act, sel, stEnumAnn)
+     act <- liftSMT $ fmap EnumExpr $ varNamedAnn actName stEnumAnn
+     sel <- liftSMT $ fmap EnumExpr $ varNamedAnn selName stEnumAnn
+     return (act, sel)
 
 -- | Extracts the the expressions for each variable seperated into
 -- local definitons and state transitions.
@@ -473,8 +473,8 @@ lookupLocalNode n
 
 -- | Declares the data flow inside the locations of an automaton.
 declareLocations :: Ident i =>
-                    Maybe (Stream Bool)
-                    -> Stream SMTEnum
+                    Maybe (TypedExpr)
+                    -> TypedExpr
                     -> Map i (Expr i)
                     -> [Location i]
                     -> AutomTransM i [Definition]
@@ -485,26 +485,30 @@ declareLocations activeCond s defaultExprs locations =
   in do instDefs    <- fmap concat
                        . mapM (declareLocDefs activeCond defaultExprs)
                        $ Map.toList defs'
-        transDefs   <- mapM (declareLocTransitions activeCond)
-                       $ Map.toList trans
-        return $ instDefs ++ transDefs
+        --transDefs   <- mapM (declareLocTransitions activeCond)
+        --               $ Map.toList trans
+        return $ instDefs-- ++ transDefs
   where
     declareLocDefs :: Ident i =>
-                      Maybe (Stream Bool)
+                      Maybe (TypedExpr)
                       -> Map i (Expr i)
                       -> (i, [(LocationId i, InstantDefinition i)])
                       -> AutomTransM i [Definition]
     declareLocDefs active defaults (x, locs) =
       do defaultExpr    <- getDefault defaults x locs
          (res, inpDefs) <- declareLocDef active s defaultExpr locs
-         xStream        <- lookupVar x
-         let xBottom    = const $ getBottom xStream
+         xVar           <- lookupVar x
+         let xBottom    = getBottom xVar
+             args       = Set.unions $ map (\(_,InstantExpr _ e) -> getArgSet e) locs
+         argsE          <- mapM lookupVar $ Set.toList args
+         argsN          <- lift $ mapM getN argsE
          def            <-
-           lift $ declareConditionalAssign active id xBottom xStream res
+           lift $ declareConditionalAssign active xBottom xVar args argsN False res
          return $ inpDefs ++ [def]
 
+{-
     declareLocTransitions :: Ident i =>
-                             Maybe (Stream Bool)
+                             Maybe (TypedExpr)
                              -> (i, [(LocationId i, StateTransition i)])
                              -> AutomTransM i Definition
     declareLocTransitions active (x, locs) =
@@ -516,6 +520,7 @@ declareLocations activeCond s defaultExprs locations =
          def         <-
            lift $ declareConditionalAssign active succAnn xApp xStream res
          return def
+-}
 
     getDefault defaults x locs =
       do fullyDefined <- isFullyDefined locs
@@ -529,11 +534,11 @@ declareLocations activeCond s defaultExprs locations =
          return $ (Map.keysSet locNames) == (Set.fromList $ map fst locDefs)
 
 declareLocDef :: Ident i =>
-                 Maybe (Stream Bool)
-                 -> Stream SMTEnum
+                 Maybe (TypedExpr)
+                 -> TypedExpr
                  -> Maybe (Expr i)
                  -> [(LocationId i, InstantDefinition i)]
-                 -> AutomTransM i (Env i -> StreamPos -> TypedExpr, [Definition])
+                 -> AutomTransM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
 declareLocDef activeCond s defaultExpr locs =
   do (innerPat, locs') <- case defaultExpr of
        Nothing -> case locs of
@@ -547,10 +552,10 @@ declareLocDef activeCond s defaultExpr locs =
        innerPat locs'
   where
     trLocInstant :: Ident i =>
-                    Maybe (Stream Bool)
+                    Maybe (TypedExpr)
                     -> LocationId i
                     -> InstantDefinition i
-                    -> AutomTransM i (Env i -> StreamPos -> TypedExpr, [Definition])
+                    -> AutomTransM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
     trLocInstant _ _ inst@(InstantExpr _ _) =
       lift $ trInstant (error "no activation condition required") inst
     trLocInstant active l inst@(NodeUsage _ n _) =
@@ -560,10 +565,11 @@ declareLocDef activeCond s defaultExpr locs =
          (r, inpDefs)           <- lift $ trInstant (Just locActive) inst
          return (r, [activeDef] ++ nodeDefs ++ inpDefs)
 
+{-
 trLocTransition :: Ident i =>
-                   Stream SMTEnum
+                   SMTFunction [TypedExpr] SMTEnum
                    -> [(LocationId i, StateTransition i)]
-                   -> AutomTransM i (Env i -> StreamPos -> TypedExpr)
+                   -> AutomTransM i (Env i -> [(i, TypedExpr)] -> TypedExpr)
 trLocTransition s locs =
   let (innerPat, locs') = case locs of
         (l:ls) -> (trLocTrans $ snd l, ls)
@@ -573,45 +579,47 @@ trLocTransition s locs =
      innerPat locs'
   where
     trLocTrans (StateTransition _ e) = runTransM $ trExpr e
+-}
 
 mkLocationMatch :: Ident i =>
-                   Stream SMTEnum
-                   -> (Env i -> StreamPos -> TypedExpr)
+                   TypedExpr
+                   -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
                    -> LocationId i
-                   -> (Env i -> StreamPos -> TypedExpr)
-                   -> AutomTransM i (Env i -> StreamPos -> TypedExpr)
-mkLocationMatch s f l lExpr =
+                   -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
+                   -> AutomTransM i (Env i -> [(i, TypedExpr)] -> TypedExpr)
+mkLocationMatch (EnumExpr s) f l lExpr =
   do lCons <- lookupLocName l
      lEnum <- lift $ trEnumConsAnn lCons <$> lookupEnumConsAnn lCons
      return
        (\env t -> liftIte
-                  (BoolExpr $ (s `app` t) .==. lEnum)
+                  (BoolExpr $ s  .==. lEnum)
                   (lExpr env t)
                   (f env t))
 
 -- | Creates a variable which is true iff the given activation
 -- condition is true and the the given location is active.
 mkLocationActivationCond :: Ident i =>
-                            Maybe (Stream Bool)
-                            -> Stream SMTEnum
+                            Maybe (TypedExpr)
+                            -> TypedExpr
                             -> LocationId i
-                            -> AutomTransM i (Stream Bool, Definition)
-mkLocationActivationCond activeCond s l =
+                            -> AutomTransM i (TypedExpr, Definition)
+mkLocationActivationCond activeCond (EnumExpr s) l =
   do lCons <- lookupLocName l
      lEnum <- lift $ trEnumConsAnn lCons <$> lookupEnumConsAnn lCons
-     natAnn <- gets natImpl
-     let cond = \_env t -> BoolExpr $ (s `app` t) .==. lEnum
-     activeVar <- liftSMT $ funAnn natAnn unit
-     def <- lift $ declareConditionalAssign activeCond id
-            (const . BoolExpr $ constant False) (BoolStream activeVar) cond
+     --natAnn <- gets natImpl
+     let cond = \_env t -> BoolExpr $ s .==. lEnum
+     activeVar <- liftSMT $ fmap BoolExpr $ var
+     def <- lift $ declareConditionalAssign activeCond
+            (BoolExpr $ constant False) activeVar Set.empty [] False cond
      return (activeVar, def)
 
+{-
 -- | Creates two equations for the edges. The first calculates
 -- the next location (act). This is a chain of ite for each state surrounded
 -- by a match on the last location (sel). The definition of sel is just
 -- the saving of act for the next cycle.
 mkTransitionEq :: Ident i =>
-                  Maybe (Stream Bool)
+                  Maybe (TypedExpr)
                   -> Type i
                   -> Map (LocationId i) (EnumConstr i)
                   -> i
@@ -692,8 +700,7 @@ assertInits = mapM_ assertInit . Map.toList
 
 assertInit :: Ident i => (i, ConstExpr i) -> DeclM i ()
 assertInit (x, e) =
-  do natAnn <- gets natImpl
-     x' <- lookupVar x
+  do x' <- lookupVar x
      e' <- trConstExpr e
      let def = liftRel (.==.) x' e'
      liftSMT $ liftAssert def

From 70f22a5ef421a6964858145619990d2ec0e62e32 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Thu, 24 Sep 2015 16:57:01 +0200
Subject: [PATCH 035/104] Migration to ghc-7.10

---
 language/lib/Lang/LAMA/Parser/ErrM.hs | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/language/lib/Lang/LAMA/Parser/ErrM.hs b/language/lib/Lang/LAMA/Parser/ErrM.hs
index 84ff334..27c1d33 100644
--- a/language/lib/Lang/LAMA/Parser/ErrM.hs
+++ b/language/lib/Lang/LAMA/Parser/ErrM.hs
@@ -6,7 +6,8 @@ module Lang.LAMA.Parser.ErrM where
 
 -- the Error monad: like Maybe type with error msgs
 
-import Control.Monad (MonadPlus(..), liftM)
+import Control.Monad (MonadPlus(..), liftM, ap)
+import Control.Applicative
 
 data Err a = Ok a | Bad String
   deriving (Read, Show, Eq, Ord)
@@ -17,6 +18,14 @@ instance Monad Err where
   Ok a  >>= f = f a
   Bad s >>= f = Bad s
 
+instance Applicative Err where
+    pure  = return
+    (<*>) = ap
+
+instance Alternative Err where
+    (<|>) = mplus
+    empty = mzero
+
 instance Functor Err where
   fmap = liftM
 

From eb2180531c412715df1b296e26f7bab8766071b4 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 26 Sep 2015 21:40:05 +0200
Subject: [PATCH 036/104] Some improvments for location arguments

---
 lamaSMT/lib/Transform.hs | 18 ++++++++++--------
 1 file changed, 10 insertions(+), 8 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 09e7bb9..7699ad9 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -15,6 +15,8 @@
 
 module Transform where
 
+import Debug.Trace
+
 import Development.Placeholders
 
 import Lang.LAMA.Identifier
@@ -432,7 +434,9 @@ mkStateVars :: Ident i =>
 mkStateVars actName selName stateEnum =
   do stEnumAnn <- lookupEnumAnn stateEnum
      act <- liftSMT $ fmap EnumExpr $ varNamedAnn actName stEnumAnn
+     addVar act
      sel <- liftSMT $ fmap EnumExpr $ varNamedAnn selName stEnumAnn
+     addVar sel
      return (act, sel)
 
 -- | Extracts the the expressions for each variable seperated into
@@ -499,11 +503,11 @@ declareLocations activeCond s defaultExprs locations =
          (res, inpDefs) <- declareLocDef active s defaultExpr locs
          xVar           <- lookupVar x
          let xBottom    = getBottom xVar
-             args       = Set.unions $ map (\(_,InstantExpr _ e) -> getArgSet e) locs
+             args       = (\(_,InstantExpr _ e) -> getArgSet e) $ head locs
          argsE          <- mapM lookupVar $ Set.toList args
-         argsN          <- lift $ mapM getN argsE
+         argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-
-           lift $ declareConditionalAssign active xBottom xVar args argsN False res
+           trace (show args) $ trace (show argsN) $ lift $ declareConditionalAssign active xBottom xVar (Set.insert x args)argsN False res
          return $ inpDefs ++ [def]
 
 {-
@@ -558,14 +562,13 @@ declareLocDef activeCond s defaultExpr locs =
                     -> AutomTransM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
     trLocInstant _ _ inst@(InstantExpr _ _) =
       lift $ trInstant (error "no activation condition required") inst
-    trLocInstant active l inst@(NodeUsage _ n _) =
-      do (locActive, activeDef) <- mkLocationActivationCond active s l
+    trLocInstant active l inst@(NodeUsage _ n _) = error ("Not yet implemented")
+      {-do (locActive, activeDef) <- mkLocationActivationCond active s l
          node                   <- lookupLocalNode n
          nodeDefs               <- lift $ declareNode (Just locActive) n node
          (r, inpDefs)           <- lift $ trInstant (Just locActive) inst
          return (r, [activeDef] ++ nodeDefs ++ inpDefs)
 
-{-
 trLocTransition :: Ident i =>
                    SMTFunction [TypedExpr] SMTEnum
                    -> [(LocationId i, StateTransition i)]
@@ -606,7 +609,6 @@ mkLocationActivationCond :: Ident i =>
 mkLocationActivationCond activeCond (EnumExpr s) l =
   do lCons <- lookupLocName l
      lEnum <- lift $ trEnumConsAnn lCons <$> lookupEnumConsAnn lCons
-     --natAnn <- gets natImpl
      let cond = \_env t -> BoolExpr $ s .==. lEnum
      activeVar <- liftSMT $ fmap BoolExpr $ var
      def <- lift $ declareConditionalAssign activeCond
@@ -786,7 +788,7 @@ trExpr expr = case untyped expr of
                             s <- ask
                             case lookup x (fst s) of
                               Nothing -> throwError $ "No argument binding for " ++ identPretty x
-                              Just n -> return n
+                              Just n -> trace (show x) $ trace (show n) $ return n
   AtExpr (AtomEnum x)  -> EnumExpr <$> trEnumCons x
   LogNot e             -> lift1Bool not' <$> trExpr e
   Expr2 op e1 e2       -> applyOp op <$> trExpr e1 <*> trExpr e2

From f7a66098d4492e7877836e18d42a1fc74f08dd0e Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 26 Sep 2015 22:39:41 +0200
Subject: [PATCH 037/104] No integer argument for defFunc any more

---
 lamaSMT/lib/Transform.hs    |  6 +++---
 lamaSMT/lib/TransformEnv.hs | 20 ++++++++++----------
 2 files changed, 13 insertions(+), 13 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 7699ad9..d793407 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -328,7 +328,7 @@ declareDef x as ns succ ef =
      let defType = varDefType x
      xN          <- getN x
      ann         <- getTypedAnnotation $ [xN] ++ ns
-     d           <- defFunc (1 + Set.size as) defType ann
+     d           <- defFunc defType ann
                     $ \a -> liftRel (.==.) (head a) $ ef env $ zip (Set.toList as) (tail a)
      return $ ensureDefinition ([xN] ++ ns) succ d
   where
@@ -717,8 +717,8 @@ declarePrecond activeCond e =
      argsN    <- mapM getN argsE
      ann      <- getTypedAnnotation argsN
      d        <- case activeCond of
-       Nothing -> defFunc (Set.size $ args) boolT ann $ \a -> runTransM (trExpr e) env (zip (Set.toList $ args) a)
-       Just c -> defFunc (Set.size $ args) boolT ann $
+       Nothing -> defFunc boolT ann $ \a -> runTransM (trExpr e) env (zip (Set.toList $ args) a)
+       Just c -> defFunc boolT ann $
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) c e')
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 8e2d78b..0e62e18 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -161,28 +161,28 @@ defStream ty sf = gets natImpl >>= \natAnn -> defStream' natAnn ty sf
 
 -- | Defines a function instead of streams
 defFunc :: Ident i =>
-             Int -> Type i -> [TypedAnnotation] -> ([TypedExpr] -> TypedExpr) -> DeclM i (TypedFunc)
-defFunc i (GroundType BoolT) ann f = liftSMT . fmap BoolFunc $
+            Type i -> [TypedAnnotation] -> ([TypedExpr] -> TypedExpr) -> DeclM i (TypedFunc)
+defFunc (GroundType BoolT) ann f = liftSMT . fmap BoolFunc $
                                 defFunAnn ann (unBool' . f)
-defFunc i (GroundType IntT) ann f = liftSMT . fmap IntFunc $
+defFunc (GroundType IntT) ann f = liftSMT . fmap IntFunc $
                                 defFunAnn ann (unInt . f)
-defFunc i (GroundType RealT) ann f = liftSMT . fmap RealFunc $
+defFunc (GroundType RealT) ann f = liftSMT . fmap RealFunc $
                                defFunAnn ann (unReal . f)
-defFunc i (GroundType _) ann f = $notImplemented
-defFunc i (EnumType alias) ann f = do eann <- lookupEnumAnn alias
-                                      liftSMT $ fmap (EnumFunc eann) $
-                                       defFunAnn ann (unEnum . f)
+defFunc (GroundType _) ann f = $notImplemented
+defFunc (EnumType alias) ann f = do eann <- lookupEnumAnn alias
+                                    liftSMT $ fmap (EnumFunc eann) $
+                                      defFunAnn ann (unEnum . f)
 -- We have to pull the product out of a stream.
 -- If we are given a function f : FuncPos -> (Ix -> TE) = TypedExpr as above,
 -- we would like to have as result something like:
 -- g : Ix -> (FuncPos -> TE)
 -- g(i)(t) = defFunc(λt'.f(t')(i))(t)
 -- Here i is the index into the product and t,t' are time variables.
-defFunc i (ProdType ts) ann f =
+defFunc (ProdType ts) ann f =
   do let u = length ts - 1
      x <- mapM defParts $ zip ts [0..u]
      return . ProdFunc $ listArray (0,u) x
-  where defParts (ty2, i) = defFunc i ty2 ann ((! i) . unProd' . f)
+  where defParts (ty2, i) = defFunc ty2 ann ((! i) . unProd' . f)
 
 -- stream :: Ident i => Type i -> DeclM i (Stream t)
 

From e9895acde8596121d18246470f569bc0b1297e97 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 28 Sep 2015 21:58:02 +0200
Subject: [PATCH 038/104] Location match no with right arguments

---
 lamaSMT/lib/Transform.hs | 10 ++++------
 1 file changed, 4 insertions(+), 6 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index d793407..9e64ed4 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -15,8 +15,6 @@
 
 module Transform where
 
-import Debug.Trace
-
 import Development.Placeholders
 
 import Lang.LAMA.Identifier
@@ -329,7 +327,7 @@ declareDef x as ns succ ef =
      xN          <- getN x
      ann         <- getTypedAnnotation $ [xN] ++ ns
      d           <- defFunc defType ann
-                    $ \a -> liftRel (.==.) (head a) $ ef env $ zip (Set.toList as) (tail a)
+                    $ \a -> liftRel (.==.) (head a) $ ef env $ zip ((Set.toList as) ++ [error "Last argument must not be evaluated!"]) (tail a)
      return $ ensureDefinition ([xN] ++ ns) succ d
   where
     varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
@@ -507,7 +505,7 @@ declareLocations activeCond s defaultExprs locations =
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-
-           trace (show args) $ trace (show argsN) $ lift $ declareConditionalAssign active xBottom xVar (Set.insert x args)argsN False res
+           lift $ declareConditionalAssign active xBottom xVar args argsN False res
          return $ inpDefs ++ [def]
 
 {-
@@ -595,7 +593,7 @@ mkLocationMatch (EnumExpr s) f l lExpr =
      lEnum <- lift $ trEnumConsAnn lCons <$> lookupEnumConsAnn lCons
      return
        (\env t -> liftIte
-                  (BoolExpr $ s  .==. lEnum)
+                  (BoolExpr $ (unEnum $ snd $ last t) .==. lEnum)
                   (lExpr env t)
                   (f env t))
 
@@ -788,7 +786,7 @@ trExpr expr = case untyped expr of
                             s <- ask
                             case lookup x (fst s) of
                               Nothing -> throwError $ "No argument binding for " ++ identPretty x
-                              Just n -> trace (show x) $ trace (show n) $ return n
+                              Just n -> return n
   AtExpr (AtomEnum x)  -> EnumExpr <$> trEnumCons x
   LogNot e             -> lift1Bool not' <$> trExpr e
   Expr2 op e1 e2       -> applyOp op <$> trExpr e1 <*> trExpr e2

From 9065d0630b6acef262020cabe59934730b5d18ee Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 28 Sep 2015 23:53:44 +0200
Subject: [PATCH 039/104] Transitions in automata

---
 lamaSMT/lib/Transform.hs | 23 +++++++++++------------
 1 file changed, 11 insertions(+), 12 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 9e64ed4..f1884b8 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -487,9 +487,9 @@ declareLocations activeCond s defaultExprs locations =
   in do instDefs    <- fmap concat
                        . mapM (declareLocDefs activeCond defaultExprs)
                        $ Map.toList defs'
-        --transDefs   <- mapM (declareLocTransitions activeCond)
-        --               $ Map.toList trans
-        return $ instDefs-- ++ transDefs
+        transDefs   <- mapM (declareLocTransitions activeCond)
+                       $ Map.toList trans
+        return $ instDefs ++ transDefs
   where
     declareLocDefs :: Ident i =>
                       Maybe (TypedExpr)
@@ -508,21 +508,20 @@ declareLocations activeCond s defaultExprs locations =
            lift $ declareConditionalAssign active xBottom xVar args argsN False res
          return $ inpDefs ++ [def]
 
-{-
     declareLocTransitions :: Ident i =>
                              Maybe (TypedExpr)
                              -> (i, [(LocationId i, StateTransition i)])
                              -> AutomTransM i Definition
     declareLocTransitions active (x, locs) =
       do res         <- trLocTransition s locs
-         xStream     <- lookupVar x
-         natAnn      <- gets natImpl
-         let succAnn = succ' natAnn
-             xApp    = appStream xStream
+         xVar     <- lookupVar x
+         let xBottom    = getBottom xVar
+             args       = (\(_,StateTransition _ e) -> getArgSet e) $ head locs
+         argsE          <- mapM lookupVar $ Set.toList args
+         argsN          <- lift $ mapM getN (argsE ++ [s])
          def         <-
-           lift $ declareConditionalAssign active succAnn xApp xStream res
+           lift $ declareConditionalAssign active xBottom xVar args argsN True res
          return def
--}
 
     getDefault defaults x locs =
       do fullyDefined <- isFullyDefined locs
@@ -566,9 +565,10 @@ declareLocDef activeCond s defaultExpr locs =
          nodeDefs               <- lift $ declareNode (Just locActive) n node
          (r, inpDefs)           <- lift $ trInstant (Just locActive) inst
          return (r, [activeDef] ++ nodeDefs ++ inpDefs)
+-}
 
 trLocTransition :: Ident i =>
-                   SMTFunction [TypedExpr] SMTEnum
+                   TypedExpr
                    -> [(LocationId i, StateTransition i)]
                    -> AutomTransM i (Env i -> [(i, TypedExpr)] -> TypedExpr)
 trLocTransition s locs =
@@ -580,7 +580,6 @@ trLocTransition s locs =
      innerPat locs'
   where
     trLocTrans (StateTransition _ e) = runTransM $ trExpr e
--}
 
 mkLocationMatch :: Ident i =>
                    TypedExpr

From 3dad98aa7752819121319cd22afab61bde2210dd Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 29 Sep 2015 00:07:25 +0200
Subject: [PATCH 040/104] Fixed transitions and definition having only one
 variable

---
 lamaSMT/lib/Transform.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index f1884b8..f8bb87a 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -501,7 +501,7 @@ declareLocations activeCond s defaultExprs locations =
          (res, inpDefs) <- declareLocDef active s defaultExpr locs
          xVar           <- lookupVar x
          let xBottom    = getBottom xVar
-             args       = (\(_,InstantExpr _ e) -> getArgSet e) $ head locs
+             args       = Set.unions $ map (\(_,InstantExpr _ e) -> getArgSet e) locs
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-
@@ -516,7 +516,7 @@ declareLocations activeCond s defaultExprs locations =
       do res         <- trLocTransition s locs
          xVar     <- lookupVar x
          let xBottom    = getBottom xVar
-             args       = (\(_,StateTransition _ e) -> getArgSet e) $ head locs
+             args       = Set.unions $ map (\(_,StateTransition _ e) -> getArgSet e) locs
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def         <-

From f3e4dc8e4a4e3b35fc1c633d08c104b027c80374 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 29 Sep 2015 00:19:03 +0200
Subject: [PATCH 041/104] Fixed bug in project argument bindings

---
 lamaSMT/lib/Transform.hs | 9 ++++++---
 1 file changed, 6 insertions(+), 3 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index f8bb87a..d25e2c8 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -785,7 +785,7 @@ trExpr expr = case untyped expr of
                             s <- ask
                             case lookup x (fst s) of
                               Nothing -> throwError $ "No argument binding for " ++ identPretty x
-                              Just n -> return n
+                              Just n  -> return n
   AtExpr (AtomEnum x)  -> EnumExpr <$> trEnumCons x
   LogNot e             -> lift1Bool not' <$> trExpr e
   Expr2 op e1 e2       -> applyOp op <$> trExpr e1 <*> trExpr e2
@@ -793,8 +793,11 @@ trExpr expr = case untyped expr of
   ProdCons (Prod es)   -> (ProdExpr . listArray (0, (length es) - 1))
                           <$> mapM trExpr es
   Project x i          ->
-    do (ProdExpr s) <- lookupVar' x
-       return $ (s ! fromEnum i)
+    do s <- ask
+       (ProdExpr e) <- case lookup x (fst s) of
+                         Nothing -> throwError $ "No argument binding for " ++ identPretty x
+                         Just n  -> return n
+       return $ (e ! fromEnum i)
   Match e pats         -> trExpr e >>= flip trPattern pats
 
 trPattern :: Ident i => TypedExpr -> [Pattern i] -> TransM i (TypedExpr)

From c6234551ef4d3bae29d287feb2d2608a8813c7f9 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 29 Sep 2015 00:35:13 +0200
Subject: [PATCH 042/104] Automata have now edges

---
 lamaSMT/lib/Transform.hs | 8 ++------
 1 file changed, 2 insertions(+), 6 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index d25e2c8..bbe6b3d 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -395,10 +395,10 @@ declareAutomaton activeCond localNodes (_, a) =
      locDefs <- (flip runReaderT (locCons, localNodes))
                 $ declareLocations activeCond act
                 (automDefaults a) (automLocations a)
-     {-edgeDefs <- mkTransitionEq activeCond stateT locCons actId selId
+     edgeDefs <- mkTransitionEq activeCond stateT locCons actId selId
                  $ automEdges a
      assertInit (selId, locConsConstExpr locCons stateT $ automInitial a)
-   -}return $ locDefs-- ++ edgeDefs
+     return $ locDefs ++ edgeDefs
 
   where
     getLocId (Location i _) = i
@@ -408,7 +408,6 @@ declareAutomaton activeCond localNodes (_, a) =
     locationName :: Ident i => String -> i -> i
     locationName automName sName = fromString $ automName ++ identString sName
 
-{-
     -- | Create the enum constructor for a given location name as constant.
     locConsConstExpr :: Ord i =>
                         Map (LocationId i) (EnumConstr i)
@@ -417,7 +416,6 @@ declareAutomaton activeCond localNodes (_, a) =
                         -> ConstExpr i
     locConsConstExpr locNames t loc
       = mkTyped (ConstEnum ((Map.!) locNames loc)) t
--}
 
 -- | Generate names of two variable which represent
 -- the state of the automaton (s, sel). Where
@@ -612,7 +610,6 @@ mkLocationActivationCond activeCond (EnumExpr s) l =
             (BoolExpr $ constant False) activeVar Set.empty [] False cond
      return (activeVar, def)
 
-{-
 -- | Creates two equations for the edges. The first calculates
 -- the next location (act). This is a chain of ite for each state surrounded
 -- by a match on the last location (sel). The definition of sel is just
@@ -692,7 +689,6 @@ mkTransitionEq activeCond locationEnumTy locationEnumConstrs act sel es =
                     -> Expr i
      locConsExpr locNames t loc
        = mkTyped (AtExpr $ AtomEnum ((Map.!) locNames loc)) t
--}
 
 assertInits :: Ident i => StateInit i -> DeclM i ()
 assertInits = mapM_ assertInit . Map.toList

From e98a37e42e22bfc1fe49fa7cde8d1c24d4eba429 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 29 Sep 2015 16:57:22 +0200
Subject: [PATCH 043/104] Subautomata in locations but buggy

---
 lamaSMT/lib/Transform.hs    | 22 ++++++++++++++--------
 lamaSMT/lib/TransformEnv.hs |  2 +-
 2 files changed, 15 insertions(+), 9 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index bbe6b3d..bdfad6c 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -187,7 +187,7 @@ enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
 -- location (see declareAutomaton and declareLocations).
 declareNode :: Ident i =>
                Maybe (TypedExpr) -> i -> Node i -> DeclM i [Definition]
-declareNode active nName nDecl =
+declareNode active nName nDecl = 
   do (interface, defs) <- localVarEnv (const emptyVarEnv) $
                           declareNode' active nDecl
      modifyNodes $ Map.insert nName interface
@@ -498,13 +498,18 @@ declareLocations activeCond s defaultExprs locations =
       do defaultExpr    <- getDefault defaults x locs
          (res, inpDefs) <- declareLocDef active s defaultExpr locs
          xVar           <- lookupVar x
+         argss          <- lift $ mapM locArgSet locs
          let xBottom    = getBottom xVar
-             args       = Set.unions $ map (\(_,InstantExpr _ e) -> getArgSet e) locs
+             args       = Set.unions argss
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-
            lift $ declareConditionalAssign active xBottom xVar args argsN False res
          return $ inpDefs ++ [def]
+      where
+        locArgSet (_,InstantExpr _ e) = return $ getArgSet e
+        locArgSet (_,NodeUsage _ n _) = do nEnv <- lookupNode n
+                                           return $ Map.keysSet (nodeEnvOut nEnv)
 
     declareLocTransitions :: Ident i =>
                              Maybe (TypedExpr)
@@ -557,13 +562,12 @@ declareLocDef activeCond s defaultExpr locs =
                     -> AutomTransM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
     trLocInstant _ _ inst@(InstantExpr _ _) =
       lift $ trInstant (error "no activation condition required") inst
-    trLocInstant active l inst@(NodeUsage _ n _) = error ("Not yet implemented")
-      {-do (locActive, activeDef) <- mkLocationActivationCond active s l
+    trLocInstant active l inst@(NodeUsage _ n _) =
+      do (locActive, activeDef) <- mkLocationActivationCond active s l
          node                   <- lookupLocalNode n
          nodeDefs               <- lift $ declareNode (Just locActive) n node
          (r, inpDefs)           <- lift $ trInstant (Just locActive) inst
          return (r, [activeDef] ++ nodeDefs ++ inpDefs)
--}
 
 trLocTransition :: Ident i =>
                    TypedExpr
@@ -601,13 +605,15 @@ mkLocationActivationCond :: Ident i =>
                             -> TypedExpr
                             -> LocationId i
                             -> AutomTransM i (TypedExpr, Definition)
-mkLocationActivationCond activeCond (EnumExpr s) l =
+mkLocationActivationCond activeCond e l =
   do lCons <- lookupLocName l
      lEnum <- lift $ trEnumConsAnn lCons <$> lookupEnumConsAnn lCons
-     let cond = \_env t -> BoolExpr $ s .==. lEnum
+     let cond = \_env t -> BoolExpr $ (unEnum $ snd $ last t) .==. lEnum
      activeVar <- liftSMT $ fmap BoolExpr $ var
+     lift $ addVar activeVar
+     argN <- lift $ getN e
      def <- lift $ declareConditionalAssign activeCond
-            (BoolExpr $ constant False) activeVar Set.empty [] False cond
+            (BoolExpr $ constant False) activeVar Set.empty [argN] False cond
      return (activeVar, def)
 
 -- | Creates two equations for the edges. The first calculates
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 0e62e18..854d217 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -72,7 +72,7 @@ addVar var =
 getN :: TypedExpr -> DeclM i Int
 getN x = do vars <- gets varList
             return $ case List.elemIndex x vars of
-                          Nothing -> error $ "Could not be found in list of     variables: " ++ show x
+                          Nothing -> error $ "Could not be found in list of variables: " ++ show x
                           Just n -> n
 
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()

From 58136eb065226be5696b703821672427c01dbde3 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 29 Sep 2015 18:07:38 +0200
Subject: [PATCH 044/104] Fixed default in location transitions being bottom

---
 lamaSMT/lib/Transform.hs | 29 +++++++++++++++--------------
 1 file changed, 15 insertions(+), 14 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index bdfad6c..6c74161 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -238,7 +238,7 @@ declareInstantDef activeCond inst@(InstantExpr x e) =
      argsE <- mapM lookupVar $ Set.toList args
      argsN <- mapM getN argsE
      def <- declareConditionalAssign
-            activeCond (getBottom xVar) xVar args argsN False res
+            activeCond (const $ const $ getBottom xVar) xVar args argsN False res
      return [def]
 declareInstantDef activeCond inst@(NodeUsage x n _) =
   do (outp, inpDefs) <- trInstant activeCond inst
@@ -246,7 +246,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
      nEnv            <- lookupNode n
      outN            <- mapM getN $ nodeEnvOut nEnv
      outpDef         <- declareConditionalAssign
-                        activeCond (getBottom xVar) xVar (Map.keysSet $ nodeEnvOut nEnv) (Map.elems outN) False outp
+                        activeCond (const $ const $ getBottom xVar) xVar (Map.keysSet $ nodeEnvOut nEnv) (Map.elems outN) False outp
      return $ inpDefs ++ [outpDef]
 
 -- | Translates an instant definition into a function which can be
@@ -264,7 +264,7 @@ trInstant inpActive (NodeUsage _ n es) =
      insN <- mapM (mapM getN) insE
      inpDefs  <- mapM (\(x, n, e, eTr) ->
                         declareConditionalAssign
-                        inpActive (getBottom x) x (getArgSet e) n False eTr)
+                        inpActive (const $ const $ getBottom x) x (getArgSet e) n False eTr)
                  $ zip4 (nodeEnvIn nEnv) insN es esTr
      return (y, inpDefs)
 
@@ -292,7 +292,7 @@ declareTransition activeCond (StateTransition x e) =
          args    = getArgSet e
      argsE <- mapM lookupVar $ Set.toList args
      argsN <- mapM getN argsE
-     declareConditionalAssign activeCond (getBottom xVar) xVar args argsN True e'
+     declareConditionalAssign activeCond (const $ const $ getBottom xVar) xVar args argsN True e'
 
 -- | Creates a declaration for an assignment. Depending on the
 -- activation condition the given expression or a default expression
@@ -301,7 +301,7 @@ declareTransition activeCond (StateTransition x e) =
 -- (see declareDef).
 declareConditionalAssign :: Ident i =>
                             Maybe (TypedExpr)
-                            -> TypedExpr
+                            -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
                             -> TypedExpr
                             -> Set i
                             -> [Int]
@@ -312,7 +312,7 @@ declareConditionalAssign activeCond defaultExpr x al ns succ ef =
   case activeCond of
     Nothing -> declareDef x al ns succ ef
     Just c  ->
-      declareDef x al ns succ (\env t -> liftIte c (ef env t) defaultExpr)
+      declareDef x al ns succ (\env t -> liftIte c (ef env t) (defaultExpr env t))
 
 -- | Creates a definition for a given variable. Whereby a function to
 -- manipulate the stream position at which it is defined is used (normally
@@ -329,9 +329,10 @@ declareDef x as ns succ ef =
      d           <- defFunc defType ann
                     $ \a -> liftRel (.==.) (head a) $ ef env $ zip ((Set.toList as) ++ [error "Last argument must not be evaluated!"]) (tail a)
      return $ ensureDefinition ([xN] ++ ns) succ d
-  where
-    varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
-    varDefType _               = boolT
+
+varDefType :: TypedExpr -> Type i
+varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts
+varDefType _               = boolT
 
 getTypedAnnotation :: Ident i => [Int] -> DeclM i [TypedAnnotation]
 getTypedAnnotation ns = mapM getTypedAnnotation' ns
@@ -499,7 +500,7 @@ declareLocations activeCond s defaultExprs locations =
          (res, inpDefs) <- declareLocDef active s defaultExpr locs
          xVar           <- lookupVar x
          argss          <- lift $ mapM locArgSet locs
-         let xBottom    = getBottom xVar
+         let xBottom    = const $ const $ getBottom xVar
              args       = Set.unions argss
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
@@ -518,12 +519,12 @@ declareLocations activeCond s defaultExprs locations =
     declareLocTransitions active (x, locs) =
       do res         <- trLocTransition s locs
          xVar     <- lookupVar x
-         let xBottom    = getBottom xVar
-             args       = Set.unions $ map (\(_,StateTransition _ e) -> getArgSet e) locs
+         let defExpr    = mkTyped (AtExpr (AtomVar x)) $ varDefType xVar
+             args       = Set.unions $ (map (\(_,StateTransition _ e) -> getArgSet e) locs) ++ [getArgSet defExpr]
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def         <-
-           lift $ declareConditionalAssign active xBottom xVar args argsN True res
+           lift $ declareConditionalAssign active (runTransM $ trExpr defExpr) xVar args argsN True res
          return def
 
     getDefault defaults x locs =
@@ -613,7 +614,7 @@ mkLocationActivationCond activeCond e l =
      lift $ addVar activeVar
      argN <- lift $ getN e
      def <- lift $ declareConditionalAssign activeCond
-            (BoolExpr $ constant False) activeVar Set.empty [argN] False cond
+            (const $ const $ BoolExpr $ constant False) activeVar Set.empty [argN] False cond
      return (activeVar, def)
 
 -- | Creates two equations for the edges. The first calculates

From d75283255dbad75b574864f323ff11c68f3a3156 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 13 Oct 2015 21:21:25 +0200
Subject: [PATCH 045/104] Models are being dumped again

---
 lamaSMT/Main.hs                      |  5 ++--
 lamaSMT/lib/Model.hs                 | 36 ++++++++++++++++---------
 lamaSMT/lib/Strategies/BMC.hs        | 39 ++++++++++++++++------------
 lamaSMT/lib/Strategies/Factory.hs    |  2 +-
 lamaSMT/lib/Strategies/KInduction.hs |  2 ++
 lamaSMT/lib/Strategy.hs              |  2 +-
 6 files changed, 52 insertions(+), 34 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index 7b825c5..3840f8b 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -210,14 +210,13 @@ checkModel :: Ident i =>
            -> (StrategyResult i)
            -> IO ()
 checkModel _ _ Success = putStrLn "42"
-checkModel opts prog (Failure lastIndex) =
+checkModel opts prog (Failure lastIndex m) =
   do putStrLn ":-("
      putStrLn $ "Found counterexample at depth " ++ show lastIndex
-{-     when (optDumpModel opts) (putStrLn . render $ prettyModel m)
+     when (optDumpModel opts) (putStrLn . render $ prettyModel m)
      case optScenarioFile opts of
        Nothing -> return ()
        Just f -> writeFile f $ render $ scadeScenario prog (optTopNodePath opts) m
--}
 checkModel opts prog (Unknown what hints) =
   do putStrLn ":-("
      putStrLn what
diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index b0f9f96..33fe757 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -8,6 +8,11 @@ import Data.Natural
 import Text.PrettyPrint hiding ((<>))
 import Data.Array as Arr
 import Data.Monoid
+import Data.Maybe (fromJust)
+import qualified Data.List as List
+import Data.List (elemIndex)
+
+import Debug.Trace
 
 import Control.Monad.Reader (MonadReader(..), ReaderT(..))
 import Control.Applicative (Applicative(..), (<$>))
@@ -74,10 +79,10 @@ prettyStreamVals
                 (integer $ toInteger n) <+> text "->" <+> text (show v))
           . Map.toList
 
-getModel :: VarEnv i -> Map Natural StreamPos -> SMT (Model i)
-getModel env = runReaderT (getModel' env)
+getModel :: VarEnv i -> Map Natural [TypedExpr] -> SMT (Model i)
+getModel env m = runReaderT (getModel' env) m
 
-type ModelM = ReaderT (Map Natural StreamPos) SMT
+type ModelM = ReaderT (Map Natural [TypedExpr]) SMT
 
 getModel' :: VarEnv i -> ModelM (Model i)
 getModel' env =
@@ -92,17 +97,24 @@ getVarsModel = mapM getVarModel
 
 --TODO
 getVarModel :: TypedExpr -> ModelM ValueStream
-getVarModel (BoolExpr s) = BoolVStream <$> getStreamValue s
-getVarModel (IntExpr  s) = IntVStream  <$> getStreamValue s
-getVarModel (RealExpr s) = RealVStream <$> getStreamValue s
-getVarModel (EnumExpr s) = EnumVStream <$> getStreamValue s
+getVarModel (BoolExpr s) = do vars   <- ask
+                              let i = fromJust $ List.elemIndex (BoolExpr s) (vars Map.! 0)
+                              stream <- liftSMT $ mapM (\l -> getValue $ unBool $ l !! i) vars
+                              return $ BoolVStream stream
+getVarModel (IntExpr s)  = do vars   <- ask
+                              let i = fromJust $ List.elemIndex (IntExpr s) (vars Map.! 0)
+                              stream <- liftSMT $ mapM (\l -> getValue $ unInt $ l !! i) vars
+                              return $ IntVStream stream
+getVarModel (RealExpr s) = do vars   <- ask
+                              let i = fromJust $ List.elemIndex (RealExpr s) (vars Map.! 0)
+                              stream <- liftSMT $ mapM (\l -> getValue $ unReal $ l !! i) vars
+                              return $ RealVStream stream
+getVarModel (EnumExpr s) = do vars   <- ask
+                              let i = fromJust $ List.elemIndex (EnumExpr s) (vars Map.! 0)
+                              stream <- liftSMT $ mapM (\l -> getValue $ unEnum $ l !! i) vars
+                              return $ EnumVStream stream
 getVarModel (ProdExpr s) = ProdVStream <$> mapM getVarModel s
 
-getStreamValue :: SMTValue t => SMTExpr t -> ModelM (ValueStreamT t)
-getStreamValue s
-  = ask >>=
-    liftSMT . mapM (\i -> getValue $ s)
-
 scadeScenario :: Ident i =>
               Program i -> [String] -> Model i -> Doc
 scadeScenario p varPath m =
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index 2721682..9e20d44 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -43,7 +43,7 @@ instance StrategyClass BMC where
     let base = 0
         vars = varList env
     in do fresh <- freshVars vars
-          check' s (getModel $ varEnv env) defs base (vars, fresh)
+          check' s (getModel $ varEnv env) defs (Map.singleton base vars) base (vars, fresh)
 
 assumeTrace :: MonadSMT m => ProgDefs -> ([TypedExpr], [TypedExpr]) -> m ()
 assumeTrace defs args =
@@ -51,29 +51,31 @@ assumeTrace defs args =
   assertPrecond args (precondition defs)
 
 bmcStep :: MonadSMT m =>
-        (Map Natural StreamPos -> SMT (Model i))
+        (Map Natural [TypedExpr] -> SMT (Model i))
         -> ProgDefs
+        -> Map Natural [TypedExpr]
         -> ([TypedExpr], [TypedExpr])
-        -> m (Bool)
-bmcStep getModel defs vars =
+        -> m (Maybe (Model i))
+bmcStep getModel defs pastVars vars =
   do assumeTrace defs vars
      let invs = invariantDef defs
      liftSMT . stack
-       $ checkInvariant vars invs-- >>=
-       --checkGetModel getModel pastIndices
+       $ checkInvariant vars invs >>=
+       checkGetModel getModel pastVars
 
 check' :: BMC
-       -> (Map Natural StreamPos -> SMT (Model i))
+       -> (Map Natural [TypedExpr] -> SMT (Model i))
        -> ProgDefs
+       -> Map Natural [TypedExpr]
        -> Natural
        -> ([TypedExpr], [TypedExpr])
        -> SMTErr (StrategyResult i)
-check' s getModel defs i vars =
+check' s getModel defs pastVars i vars =
   do liftIO $ when (bmcPrintProgress s) (putStrLn $ "Depth " ++ show i)
-     r <- bmcStep getModel defs vars
+     r <- bmcStep getModel defs pastVars vars
      case r of
-       True -> next (check' s getModel defs) s i vars
-       False -> return $ Failure i 
+       Nothing -> next (check' s getModel defs) s pastVars i vars
+       Just m -> return $ Failure i m
 
 assertDefs :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> [Definition] -> m ()
 assertDefs i = mapM_ (assertDef i)
@@ -89,30 +91,33 @@ checkInvariant :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> Definition -> m Bo
 checkInvariant i p = liftSMT $ assertDefinition not' i p >> liftM not checkSat
 
 checkGetModel :: MonadSMT m =>
-              (Map Natural StreamPos -> SMT (Model i))
-              -> Map Natural StreamPos
+              (Map Natural [TypedExpr] -> SMT (Model i))
+              -> Map Natural [TypedExpr]
               -> Bool
               -> m (Maybe (Model i))
 checkGetModel getModel indices r = liftSMT $
   if r then return Nothing else fmap Just $ getModel indices
 
-next :: (Natural
+next :: (Map Natural [TypedExpr]
+             -> Natural
              -> ([TypedExpr], [TypedExpr])
              -> SMTErr (StrategyResult i)
         )
         -> BMC
+        -> Map Natural [TypedExpr]
         -> Natural
         -> ([TypedExpr], [TypedExpr])
         -> SMTErr (StrategyResult i)
-next checkCont s i vars =
+next checkCont s pastVars i vars =
   let i' = succ i
+      pastVars' = Map.insert i' (snd vars) pastVars
   in case bmcDepth s of
        Nothing -> do vars' <- freshVars $ snd vars
-                     checkCont i' (snd vars, vars')
+                     checkCont pastVars' i' (snd vars, vars')
        Just l ->
          if i' < l
          then do vars' <- freshVars $ snd vars
-                 checkCont i' (snd vars, vars')
+                 checkCont pastVars' i' (snd vars, vars')
          else return Success
 
 freshVars :: MonadSMT m => [TypedExpr] -> m [TypedExpr]
diff --git a/lamaSMT/lib/Strategies/Factory.hs b/lamaSMT/lib/Strategies/Factory.hs
index 6f0584f..f27c36e 100644
--- a/lamaSMT/lib/Strategies/Factory.hs
+++ b/lamaSMT/lib/Strategies/Factory.hs
@@ -44,5 +44,5 @@ getStrategyHelp lineLength = renderStyle (style { lineLength }) $
 
 getStrategy :: String -> Strategy
 getStrategy "bmc" = Strategy (defaultStrategyOpts :: BMC)
-getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
+--getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
 getStrategy _ = error "Unknown strategy"
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index aa92c90..38fd109 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE ViewPatterns #-}
 module Strategies.KInduction where
 
+{-
 import Data.Natural
 import NatInstance
 import Data.List (stripPrefix)
@@ -143,3 +144,4 @@ retrieveHints getModel indOpts k success =
          else return []
        (AllInductionSteps, _      ) ->
          getModel >>= \m -> return [Hint (show k) m]
+-}
diff --git a/lamaSMT/lib/Strategy.hs b/lamaSMT/lib/Strategy.hs
index 2ed14df..18be727 100644
--- a/lamaSMT/lib/Strategy.hs
+++ b/lamaSMT/lib/Strategy.hs
@@ -20,7 +20,7 @@ data Hint i = Hint { hintDescr :: String, hintModel :: Model i }
 type Hints i = [Hint i]
 data StrategyResult i =
      Success
-     | Failure Natural-- (Model i)
+     | Failure Natural (Model i)
      | Unknown String (Hints i)
 
 data Strategy = forall s. StrategyClass s => Strategy s

From 4935c9e5a0c89b4091fc6570417ecc9b947f79e5 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 14 Oct 2015 14:53:22 +0200
Subject: [PATCH 046/104] Fixed bug with ProdType models

---
 lamaSMT/lib/Model.hs | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index 33fe757..71ede51 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -12,8 +12,6 @@ import Data.Maybe (fromJust)
 import qualified Data.List as List
 import Data.List (elemIndex)
 
-import Debug.Trace
-
 import Control.Monad.Reader (MonadReader(..), ReaderT(..))
 import Control.Applicative (Applicative(..), (<$>))
 
@@ -113,7 +111,11 @@ getVarModel (EnumExpr s) = do vars   <- ask
                               let i = fromJust $ List.elemIndex (EnumExpr s) (vars Map.! 0)
                               stream <- liftSMT $ mapM (\l -> getValue $ unEnum $ l !! i) vars
                               return $ EnumVStream stream
-getVarModel (ProdExpr s) = ProdVStream <$> mapM getVarModel s
+getVarModel (ProdExpr s) = do vars <- ask
+                              let i = fromJust $ List.elemIndex (ProdExpr s) (vars Map.! 0)
+                                  newArg = Map.map (\l -> Arr.elems $ unProd $ l !! i) vars
+                              stream <- liftSMT $ mapM (\a -> runReaderT (getVarModel a) newArg) s
+                              return $ ProdVStream stream
 
 scadeScenario :: Ident i =>
               Program i -> [String] -> Model i -> Doc

From 539293bb175c1e139fbbe1c42380ba3bf3c9db34 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Fri, 16 Oct 2015 16:26:14 +0200
Subject: [PATCH 047/104] First automaton transition bug fixed

---
 lamaSMT/lib/Transform.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 6c74161..b59532e 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -289,10 +289,11 @@ declareTransition :: Ident i =>
 declareTransition activeCond (StateTransition x e) =
   do xVar     <- lookupVar x
      let e'      = runTransM $ trExpr e
-         args    = getArgSet e
+         defExpr = mkTyped (AtExpr (AtomVar x)) $ varDefType xVar
+         args    = Set.union (getArgSet e) (getArgSet defExpr)
      argsE <- mapM lookupVar $ Set.toList args
      argsN <- mapM getN argsE
-     declareConditionalAssign activeCond (const $ const $ getBottom xVar) xVar args argsN True e'
+     declareConditionalAssign activeCond (runTransM $ trExpr defExpr) xVar args argsN True e'
 
 -- | Creates a declaration for an assignment. Depending on the
 -- activation condition the given expression or a default expression

From 233dd73cf1bc6c24d0ba8ec366d72edb804b9a38 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 17 Oct 2015 13:47:35 +0200
Subject: [PATCH 048/104] Models with kinduction, too

---
 lamaSMT/lib/Strategies/Factory.hs    |  2 +-
 lamaSMT/lib/Strategies/KInduction.hs | 33 ++++++++++++++--------------
 2 files changed, 17 insertions(+), 18 deletions(-)

diff --git a/lamaSMT/lib/Strategies/Factory.hs b/lamaSMT/lib/Strategies/Factory.hs
index f27c36e..6f0584f 100644
--- a/lamaSMT/lib/Strategies/Factory.hs
+++ b/lamaSMT/lib/Strategies/Factory.hs
@@ -44,5 +44,5 @@ getStrategyHelp lineLength = renderStyle (style { lineLength }) $
 
 getStrategy :: String -> Strategy
 getStrategy "bmc" = Strategy (defaultStrategyOpts :: BMC)
---getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
+getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
 getStrategy _ = error "Unknown strategy"
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index 38fd109..8aae239 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE ViewPatterns #-}
 module Strategies.KInduction where
 
-{-
 import Data.Natural
 import NatInstance
 import Data.List (stripPrefix)
@@ -62,7 +61,7 @@ instance StrategyClass KInduct where
           let s0 = InductState baseK (vars, k1) (n0, n1)
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
-                $ check' indOpts (getModel $ varEnv env) defs
+                $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
           case r of
                Unknown what h -> return $ Unknown what (h ++ hints)
                _ -> return r
@@ -88,45 +87,46 @@ type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 -- call next, which increases k. Finally, if also the induction
 -- step can be proven, Nothing is returned.
 check' :: KInduct
-       -> (Map Natural StreamPos -> SMT (Model i))
+       -> (Map Natural [TypedExpr] -> SMT (Model i))
        -> ProgDefs
+       -> Map Natural [TypedExpr]
        -> KInductM i (StrategyResult i)
-check' indOpts getModel defs =
+check' indOpts getModel defs pastVars =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
-     rBMC <- bmcStep getModel defs kDefs
+     rBMC <- bmcStep getModel defs pastVars kDefs
      case rBMC of
-       False -> return $ Failure kVal
-       True ->
+       Just m -> return $ Failure kVal m
+       Nothing ->
          do let n0 = fst nDefs
                 n1 = snd nDefs
             n2 <- freshVars n1
             assertPrecond (n0, n1) $ invariantDef defs
             modify $ \indSt -> indSt { nDefs = (n1, n2) }
-            indSuccess <- liftSMT . stack $
+            (indSuccess, hints) <- liftSMT . stack $
               do r <- checkStep defs (n1, n2)
-                 --h <- retrieveHints (getModel pastKs) indOpts kVal r
-                 --return (r, h)
-                 return r
-            --tell hints
+                 h <- retrieveHints (getModel pastVars) indOpts kVal r
+                 return (r, h)
+            tell hints
             let k' = succ kVal
             if indSuccess
                then return Success
                else case depth indOpts of
-                    Nothing -> cont k'
+                    Nothing -> cont k' pastVars
                     Just l  ->
                       if k' > l
                       then return $ Unknown ("Cancelled induction. Found no"
                                               ++" proof within given depth")
                                     []
-                      else cont k'
+                      else cont k' pastVars
   where
-    cont k' =
+    cont k' pastVars =
       do indState@InductState{..} <- get
          let k1 = snd kDefs
+             pastVars' = Map.insert k' k1 pastVars
          k2 <- freshVars k1
          put $ indState { kVal = k', kDefs = (k1, k2) }
-         check' indOpts getModel defs
+         check' indOpts getModel defs pastVars'
 
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)
@@ -144,4 +144,3 @@ retrieveHints getModel indOpts k success =
          else return []
        (AllInductionSteps, _      ) ->
          getModel >>= \m -> return [Hint (show k) m]
--}

From 963a4c4b9a7f6c4e698151280be4a0ffdd9084f0 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 17 Oct 2015 13:51:21 +0200
Subject: [PATCH 049/104] Unit not needed anymore

---
 lamaSMT/lib/TransformEnv.hs |  1 -
 lamaSMT/lib/Unit.hs         | 30 ------------------------------
 2 files changed, 31 deletions(-)
 delete mode 100644 lamaSMT/lib/Unit.hs

diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 854d217..88463c4 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -22,7 +22,6 @@ import Data.List (replicate)
 import Control.Monad.State (StateT(..), MonadState(..), modify, gets)
 import Control.Monad.Error (ErrorT(..), MonadError(..))
 
-import Unit
 import SMTEnum
 import NatInstance
 import LamaSMTTypes
diff --git a/lamaSMT/lib/Unit.hs b/lamaSMT/lib/Unit.hs
deleted file mode 100644
index e731f44..0000000
--- a/lamaSMT/lib/Unit.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module Unit where
-
-import Data.Unit
-
-{-
-class Unit t where
-    -- | Constructs a unit type
-    unit :: t
-
-instance Unit () where
-    unit = ()
-
-instance (Unit a,Unit b) => Unit (a,b) where
-    unit = (unit,unit)
-
-instance (Unit a,Unit b,Unit c) => Unit (a,b,c) where
-    unit = (unit,unit,unit)
-
-instance (Unit a,Unit b,Unit c,Unit d) => Unit (a,b,c,d) where
-    unit = (unit,unit,unit,unit)
-
-instance (Unit a,Unit b,Unit c,Unit d,Unit e) => Unit (a,b,c,d,e) where
-    unit = (unit,unit,unit,unit,unit)
-
-instance (Unit a,Unit b,Unit c,Unit d,Unit e,Unit f) => Unit (a,b,c,d,e,f) where
-    unit = (unit,unit,unit,unit,unit,unit)
--}
-
-instance (Unit a) => Unit ([a]) where
-    unit = ([unit])

From 02074912dda8939e09a6a357074e3a903e19ea46 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 17 Oct 2015 15:59:59 +0200
Subject: [PATCH 050/104] Second automaton "bug" fixed

---
 lamaSMT/lib/Transform.hs | 44 ++++++++++++++++++++++++----------------
 1 file changed, 26 insertions(+), 18 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index b59532e..a7b7d40 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -397,8 +397,9 @@ declareAutomaton activeCond localNodes (_, a) =
      locDefs <- (flip runReaderT (locCons, localNodes))
                 $ declareLocations activeCond act
                 (automDefaults a) (automLocations a)
-     edgeDefs <- mkTransitionEq activeCond stateT locCons actId selId
-                 $ automEdges a
+     enumAnn <- lookupEnumAnn enumName
+     let bottom = EnumExpr $ constantAnn (enumBottom enumAnn) enumAnn
+     edgeDefs <- mkTransitionEq activeCond stateT locCons actId selId (automEdges a) bottom
      assertInit (selId, locConsConstExpr locCons stateT $ automInitial a)
      return $ locDefs ++ edgeDefs
 
@@ -629,25 +630,32 @@ mkTransitionEq :: Ident i =>
                   -> i
                   -> i
                   -> [Edge i]
+                  -> TypedExpr
                   -> DeclM i [Definition]
-mkTransitionEq activeCond locationEnumTy locationEnumConstrs act sel es =
-  -- we reuse the translation machinery by building a match expression and
-  -- translating that.
+mkTransitionEq activeCond locationEnumTy locationEnumConstrs act sel es bot =
   -- We use foldr to enforce that transition that occur later in the
   -- source get a lower priority.
-  do stateDef <- declareInstantDef activeCond
-                 . InstantExpr act
-                 . mkMatch
-                   locationEnumConstrs
-                   locationEnumTy
-                   sel
-                   (mkTyped (AtExpr $ AtomVar sel) locationEnumTy)
-                 . Map.toList
-                 $ foldr addEdge Map.empty es
-     stateTr <- declareTransition activeCond
-                $ StateTransition
-                  sel
-                  (mkTyped (AtExpr $ AtomVar act) locationEnumTy)
+  do stateDef <- do 
+                   let e = mkMatch locationEnumConstrs
+                           locationEnumTy sel (mkTyped (AtExpr $
+                           AtomVar sel) locationEnumTy) . Map.toList
+                           $ foldr addEdge Map.empty es
+                       inst = InstantExpr act e
+                       args = getArgSet e
+                   (res, []) <- trInstant (error "no activation condition") inst
+                   xVar <- lookupVar act
+                   argsE <- mapM lookupVar $ Set.toList args
+                   argsN <- mapM getN argsE
+                   def <- declareConditionalAssign activeCond (const $ const $ bot) xVar args argsN False res
+                   return [def]
+     stateTr <- do 
+       xVar     <- lookupVar sel
+       let e'      = runTransM $ trExpr (mkTyped (AtExpr $ AtomVar act) locationEnumTy)
+           defExpr = mkTyped (AtExpr (AtomVar sel)) $ varDefType xVar
+           args    = Set.union (getArgSet (mkTyped (AtExpr $ AtomVar act) locationEnumTy)) (getArgSet defExpr)
+       argsE <- mapM lookupVar $ Set.toList args
+       argsN <- mapM getN argsE
+       declareConditionalAssign activeCond (runTransM $ trExpr defExpr) xVar args argsN True e'
      return $ stateDef ++ [stateTr]
   where
      addEdge (Edge h t c) m =

From 2db55196e8ef78e85d2d46820872c0e5fe4f1dea Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 17 Oct 2015 13:55:43 +0200
Subject: [PATCH 051/104] Corrected options in runBase.sh

---
 example/runBase.sh | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/example/runBase.sh b/example/runBase.sh
index 282aea2..a5d2f33 100755
--- a/example/runBase.sh
+++ b/example/runBase.sh
@@ -10,7 +10,7 @@ if [ -z "$4" ]; then
 else
   d="$4";
 fi
-strategy="-s $3 -o depth=$d -o progress -o hints"
+strategy="-s $3 -o depth=$d -o progress"
 
 timefmt="%U user\n%S system\n%E elapsed\n%P CPU\n%Xkb text + %Dkb data -> %Kkb total + %Mkb max\n%I inputs + %O outputs\n%F major + %R minor pagefaults\n%W swaps"
 

From e048f33e0a3fa9df2d1e0867e7c8471f6a28237d Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 19 Oct 2015 15:34:24 +0200
Subject: [PATCH 052/104] Created new strategy Invariant and set of terms in
 environment

---
 lamaSMT/lib/Strategies/Factory.hs   |   2 +
 lamaSMT/lib/Strategies/Invariant.hs | 146 ++++++++++++++++++++++++++++
 lamaSMT/lib/TransformEnv.hs         |   5 +-
 3 files changed, 152 insertions(+), 1 deletion(-)
 create mode 100644 lamaSMT/lib/Strategies/Invariant.hs

diff --git a/lamaSMT/lib/Strategies/Factory.hs b/lamaSMT/lib/Strategies/Factory.hs
index 6f0584f..e3b440c 100644
--- a/lamaSMT/lib/Strategies/Factory.hs
+++ b/lamaSMT/lib/Strategies/Factory.hs
@@ -6,6 +6,7 @@ import Text.PrettyPrint
 import Strategy
 import Strategies.BMC
 import Strategies.KInduction
+import Strategies.Invariant
 
 defaultStrategy :: Strategy
 defaultStrategy = Strategy (defaultStrategyOpts :: BMC)
@@ -45,4 +46,5 @@ getStrategyHelp lineLength = renderStyle (style { lineLength }) $
 getStrategy :: String -> Strategy
 getStrategy "bmc" = Strategy (defaultStrategyOpts :: BMC)
 getStrategy "kinduct" = Strategy (defaultStrategyOpts :: KInduct)
+getStrategy "kinduct-inv" = Strategy (defaultStrategyOpts :: Invar)
 getStrategy _ = error "Unknown strategy"
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
new file mode 100644
index 0000000..7b4d878
--- /dev/null
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -0,0 +1,146 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+module Strategies.Invariant where
+
+import Data.Natural
+import NatInstance
+import Data.List (stripPrefix)
+import qualified Data.Map as Map
+import Data.Map (Map)
+
+import Control.Monad.State (MonadState(..), StateT, evalStateT, modify)
+import Control.Monad.Writer (MonadWriter(..), WriterT, runWriterT)
+import Control.Monad.IO.Class
+import Control.Monad (when)
+import Control.Arrow ((&&&))
+
+import Language.SMTLib2
+
+import Strategy
+import LamaSMTTypes
+import Definition
+import TransformEnv
+import Model (Model, getModel)
+import Strategies.BMC
+import Internal.Monads
+
+data GenerateHints =
+     NoHints
+     | LastInductionStep
+     | AllInductionSteps
+data Invar = Invar
+               { depth :: Maybe Natural
+               , printProgress :: Bool
+               , generateHints :: GenerateHints }
+
+instance StrategyClass Invar where
+  defaultStrategyOpts = Invar Nothing False NoHints
+
+  readOption (stripPrefix "depth=" -> Just d) indOpts =
+    case d of
+      "inf" -> indOpts { depth = Nothing }
+      _     -> indOpts { depth = Just $ read d }
+  readOption "progress" indOpts =
+    indOpts { printProgress = True }
+  readOption (stripPrefix "hints" -> Just r) indOpts =
+    case (stripPrefix "=" r) of
+         Nothing    -> indOpts { generateHints = LastInductionStep }
+         Just which -> case which of
+              "all"  -> indOpts { generateHints = AllInductionSteps }
+              "last" -> indOpts { generateHints = LastInductionStep }
+              _      -> error $ "Invalid hint option: " ++ which
+  readOption o _ = error $ "Invalid k-induction option: " ++ o
+
+  check indOpts env defs =
+    let baseK = 0
+        vars  = varList env
+    in do k1  <- freshVars vars
+          n0  <- freshVars vars
+          n1  <- freshVars vars
+          assumeTrace defs (n0, n1)
+          let s0 = InductState baseK (vars, k1) (n0, n1)
+          (r, hints) <- runWriterT
+                $ (flip evalStateT s0)
+                $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
+          case r of
+               Unknown what h -> return $ Unknown what (h ++ hints)
+               _ -> return r
+
+-- | Checks the induction step and returns true if the invariant could be
+-- proven
+checkStep :: ProgDefs -> ([TypedExpr], [TypedExpr]) -> SMT Bool
+checkStep defs vars =
+  do assumeTrace defs vars
+     let invs = invariantDef defs
+     checkInvariant vars invs
+
+-- | Holds current depth k and definitions of last k and n
+data InductState = InductState
+                   { kVal  :: Natural
+                   , kDefs :: ([TypedExpr], [TypedExpr])
+                   , nDefs :: ([TypedExpr], [TypedExpr]) }
+type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
+
+-- | Checks the program against its invariant. If the invariant
+-- does not hold in the base case, then a model is returned.
+-- If the base case is fine, but the induction step is not, we
+-- call next, which increases k. Finally, if also the induction
+-- step can be proven, Nothing is returned.
+check' :: Invar
+       -> (Map Natural [TypedExpr] -> SMT (Model i))
+       -> ProgDefs
+       -> Map Natural [TypedExpr]
+       -> KInductM i (StrategyResult i)
+check' indOpts getModel defs pastVars =
+  do InductState{..} <- get
+     liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
+     rBMC <- bmcStep getModel defs pastVars kDefs
+     case rBMC of
+       Just m -> return $ Failure kVal m
+       Nothing ->
+         do let n0 = fst nDefs
+                n1 = snd nDefs
+            n2 <- freshVars n1
+            assertPrecond (n0, n1) $ invariantDef defs
+            modify $ \indSt -> indSt { nDefs = (n1, n2) }
+            (indSuccess, hints) <- liftSMT . stack $
+              do r <- checkStep defs (n1, n2)
+                 h <- retrieveHints (getModel pastVars) indOpts kVal r
+                 return (r, h)
+            tell hints
+            let k' = succ kVal
+            if indSuccess
+               then return Success
+               else case depth indOpts of
+                    Nothing -> cont k' pastVars
+                    Just l  ->
+                      if k' > l
+                      then return $ Unknown ("Cancelled induction. Found no"
+                                              ++" proof within given depth")
+                                    []
+                      else cont k' pastVars
+  where
+    cont k' pastVars =
+      do indState@InductState{..} <- get
+         let k1 = snd kDefs
+             pastVars' = Map.insert k' k1 pastVars
+         k2 <- freshVars k1
+         put $ indState { kVal = k', kDefs = (k1, k2) }
+         check' indOpts getModel defs pastVars'
+
+-- | If requested, gets a model for the induction step
+retrieveHints :: SMT (Model i)
+              -> Invar
+              -> Natural
+              -> Bool
+              -> SMT [(Hint i)]
+retrieveHints getModel indOpts k success =
+  case (generateHints  &&& depth) indOpts of
+       (NoHints          , _      ) -> return []
+       (LastInductionStep, Nothing) -> return []
+       (LastInductionStep, Just l ) ->
+         if not success && succ k > l
+         then getModel >>= \m -> return [Hint (show k) m]
+         else return []
+       (AllInductionSteps, _      ) ->
+         getModel >>= \m -> return [Hint (show k) m]
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 88463c4..5e691a5 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -15,6 +15,8 @@ import qualified Data.List as List
 import Data.List (elemIndex)
 import qualified Data.Map as Map
 import Data.Map (Map)
+import qualified Data.Set as Set
+import Data.Set (Set)
 import Prelude hiding (mapM)
 import Data.Traversable
 import Data.List (replicate)
@@ -47,6 +49,7 @@ data Env i = Env
            , varEnv :: VarEnv i
            , currAutomatonIndex :: Integer
            , varList :: [TypedExpr]
+           , instSet :: Set (SMTExpr Bool)
            , natImpl :: NatImplementation
            , enumImpl :: EnumImplementation
            }
@@ -55,7 +58,7 @@ emptyVarEnv :: VarEnv i
 emptyVarEnv = VarEnv Map.empty Map.empty
 
 emptyEnv :: NatImplementation -> EnumImplementation -> Env i
-emptyEnv = Env Map.empty Map.empty Map.empty emptyVarEnv 0 []
+emptyEnv = Env Map.empty Map.empty Map.empty emptyVarEnv 0 [] Set.empty
 
 type DeclM i = StateT (Env i) (ErrorT String SMT)
 

From de4633e71d15fcf6976aca66f9cbd914bb21f642 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 19 Oct 2015 22:30:59 +0200
Subject: [PATCH 053/104] Renamed addVar to putVar

---
 lamaSMT/lib/Transform.hs    | 8 ++++----
 lamaSMT/lib/TransformEnv.hs | 4 ++--
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index a7b7d40..dc3e91f 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -142,7 +142,7 @@ declareVarList = mapM declareVar
 declareVar :: Ident i => Variable i -> DeclM i ((i, TypedExpr))
 declareVar (Variable x t) =
   do v    <- typedVar (identString x) t
-     addVar v
+     putVar v
      return (x, v)
   where
     typedVar :: Ident i =>
@@ -433,9 +433,9 @@ mkStateVars :: Ident i =>
 mkStateVars actName selName stateEnum =
   do stEnumAnn <- lookupEnumAnn stateEnum
      act <- liftSMT $ fmap EnumExpr $ varNamedAnn actName stEnumAnn
-     addVar act
+     putVar act
      sel <- liftSMT $ fmap EnumExpr $ varNamedAnn selName stEnumAnn
-     addVar sel
+     putVar sel
      return (act, sel)
 
 -- | Extracts the the expressions for each variable seperated into
@@ -613,7 +613,7 @@ mkLocationActivationCond activeCond e l =
      lEnum <- lift $ trEnumConsAnn lCons <$> lookupEnumConsAnn lCons
      let cond = \_env t -> BoolExpr $ (unEnum $ snd $ last t) .==. lEnum
      activeVar <- liftSMT $ fmap BoolExpr $ var
-     lift $ addVar activeVar
+     lift $ putVar activeVar
      argN <- lift $ getN e
      def <- lift $ declareConditionalAssign activeCond
             (const $ const $ BoolExpr $ constant False) activeVar Set.empty [argN] False cond
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 5e691a5..ceb72fe 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -67,8 +67,8 @@ putConstants cs =
   let cs' = fmap trConstant cs
   in modify $ \env -> env { constants = cs' }
 
-addVar :: Ident i => TypedExpr -> DeclM i ()
-addVar var =
+putVar :: Ident i => TypedExpr -> DeclM i ()
+putVar var =
   modify $ \env -> env { varList = (varList env) ++ [var] }
 
 getN :: TypedExpr -> DeclM i Int

From c89f028b4fc1e82c6ac0274eb9348f84bb2b05c9 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 20 Oct 2015 00:00:19 +0200
Subject: [PATCH 054/104] First assertions about r made

---
 lamaSMT/lib/Definition.hs           | 23 +++++++++++++++++++++++
 lamaSMT/lib/Strategies/Invariant.hs | 16 +++++++++++++---
 lamaSMT/lib/Transform.hs            |  1 +
 lamaSMT/lib/TransformEnv.hs         |  7 ++++++-
 4 files changed, 43 insertions(+), 4 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index adc17fc..d7ee78a 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -4,6 +4,9 @@ import Data.Array as Arr
 
 import Language.SMTLib2 as SMT
 
+import qualified Data.Set as Set
+import Data.Set (Set)
+
 import LamaSMTTypes
 import Internal.Monads
 
@@ -36,3 +39,23 @@ data ProgDefs = ProgDefs
                 , precondition :: Definition
                 , invariantDef :: Definition
                 }
+
+data Term =
+  BoolTerm [Int] (SMTFunction [TypedExpr] Bool)
+  | IntTerm [Int] (SMTFunction [TypedExpr] Int)
+  | RealTerm [Int] (SMTFunction [TypedExpr] Rational)
+  deriving (Show, Ord, Eq)
+
+constructRs :: Set Term -> [(Term, Term)]
+constructRs ts = [(x,y) | x <- Set.toList ts, y <- Set.toList ts, x /= y]
+
+assertRs :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> [(Term, Term)] -> m ()
+{-
+assertRs i rs = liftSMT $ assert (not' (foldl (\(t, s) -> and' t s) (constant True) (assertRs' i rs)))
+  where assertRs' :: ([TypedExpr], [TypedExpr]) -> [(Term, Term)] -> [(SMTExpr t, SMTExpr t)]
+        assertRs' i ((BoolTerm argsf f, BoolTerm argsg g):rs) = 
+          [(f `app` (lookupArgs argsf False i), g `app` (lookupArgs argsg False i))] ++ assertRs' i rs
+        assertRs' i [] = []
+-}
+assertRs i ((BoolTerm argsf f, BoolTerm argsg g):rs) = liftSMT $ assert ((f `app` (lookupArgs argsf False i)) .=>. (g `app` (lookupArgs argsg False i))) >> assertRs i rs
+assertRs i [] = return ()
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 7b4d878..f6d5d0d 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -58,7 +58,7 @@ instance StrategyClass Invar where
           n0  <- freshVars vars
           n1  <- freshVars vars
           assumeTrace defs (n0, n1)
-          let s0 = InductState baseK (vars, k1) (n0, n1)
+          let s0 = InductState baseK (vars, k1) (n0, n1) $ constructRs (instSet env)
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
                 $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
@@ -78,7 +78,8 @@ checkStep defs vars =
 data InductState = InductState
                    { kVal  :: Natural
                    , kDefs :: ([TypedExpr], [TypedExpr])
-                   , nDefs :: ([TypedExpr], [TypedExpr]) }
+                   , nDefs :: ([TypedExpr], [TypedExpr])
+                   , rs    :: [(Term, Term)] }
 type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 
 -- | Checks the program against its invariant. If the invariant
@@ -98,7 +99,9 @@ check' indOpts getModel defs pastVars =
      case rBMC of
        Just m -> return $ Failure kVal m
        Nothing ->
-         do let n0 = fst nDefs
+         do rs' <- filterRs rs kDefs
+            modify $ \indSt -> indSt { rs = rs' }
+            let n0 = fst nDefs
                 n1 = snd nDefs
             n2 <- freshVars n1
             assertPrecond (n0, n1) $ invariantDef defs
@@ -128,6 +131,13 @@ check' indOpts getModel defs pastVars =
          put $ indState { kVal = k', kDefs = (k1, k2) }
          check' indOpts getModel defs pastVars'
 
+filterRs :: MonadSMT m => [(Term, Term)] -> ([TypedExpr], [TypedExpr]) -> m [(Term, Term)]
+filterRs rs args = liftSMT $ do push
+                                assertRs args rs
+                                r <-checkSat
+                                pop
+                                return rs
+
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)
               -> Invar
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index dc3e91f..f305ec0 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -731,6 +731,7 @@ declarePrecond activeCond e =
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) c e')
+     putTerm argsN d
      return $ ensureDefinition argsN False d
 
 declareInvariant :: Ident i =>
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index ceb72fe..cb90c12 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -27,6 +27,7 @@ import Control.Monad.Error (ErrorT(..), MonadError(..))
 import SMTEnum
 import NatInstance
 import LamaSMTTypes
+import Definition
 import Internal.Monads
 
 data NodeEnv i = NodeEnv
@@ -49,7 +50,7 @@ data Env i = Env
            , varEnv :: VarEnv i
            , currAutomatonIndex :: Integer
            , varList :: [TypedExpr]
-           , instSet :: Set (SMTExpr Bool)
+           , instSet :: Set Term
            , natImpl :: NatImplementation
            , enumImpl :: EnumImplementation
            }
@@ -77,6 +78,10 @@ getN x = do vars <- gets varList
                           Nothing -> error $ "Could not be found in list of variables: " ++ show x
                           Just n -> n
 
+putTerm :: Ident i => [Int] -> TypedFunc -> DeclM i ()
+putTerm argsN (BoolFunc t) = 
+  modify $ \env -> env { instSet = Set.insert (BoolTerm argsN t) (instSet env) }
+
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()
 putEnumAnn eAnns =
   modify $ \env -> env { enumAnn = (enumAnn env) `Map.union` eAnns }

From 68d25cd7f17971723e57706abda28e065d086e64 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 20 Oct 2015 10:33:49 +0200
Subject: [PATCH 055/104] Assertion is now correctly conjunctive

---
 lamaSMT/lib/Definition.hs | 15 ++++++---------
 1 file changed, 6 insertions(+), 9 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index d7ee78a..23f00a9 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -49,13 +49,10 @@ data Term =
 constructRs :: Set Term -> [(Term, Term)]
 constructRs ts = [(x,y) | x <- Set.toList ts, y <- Set.toList ts, x /= y]
 
+mkRelation :: ([TypedExpr], [TypedExpr]) -> (Term, Term) -> SMTExpr Bool
+mkRelation i (BoolTerm argsf f, BoolTerm argsg g) = (f `app` (lookupArgs argsf False i)) .=>.
+                                                       (g `app` (lookupArgs argsg False i))
+
 assertRs :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> [(Term, Term)] -> m ()
-{-
-assertRs i rs = liftSMT $ assert (not' (foldl (\(t, s) -> and' t s) (constant True) (assertRs' i rs)))
-  where assertRs' :: ([TypedExpr], [TypedExpr]) -> [(Term, Term)] -> [(SMTExpr t, SMTExpr t)]
-        assertRs' i ((BoolTerm argsf f, BoolTerm argsg g):rs) = 
-          [(f `app` (lookupArgs argsf False i), g `app` (lookupArgs argsg False i))] ++ assertRs' i rs
-        assertRs' i [] = []
--}
-assertRs i ((BoolTerm argsf f, BoolTerm argsg g):rs) = liftSMT $ assert ((f `app` (lookupArgs argsf False i)) .=>. (g `app` (lookupArgs argsg False i))) >> assertRs i rs
-assertRs i [] = return ()
+assertRs i rs = let c = (map (mkRelation i) rs) in
+                  liftSMT $ assert (not' $ foldl (.&&.) (head c) $ tail c)

From da974b3fa76654e1afe151e78f06827670d58976 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 20 Oct 2015 11:41:55 +0200
Subject: [PATCH 056/104] Filtering in first step implemented

---
 lamaSMT/lib/Definition.hs           |  4 ++--
 lamaSMT/lib/Strategies/Invariant.hs | 22 +++++++++++++++++-----
 2 files changed, 19 insertions(+), 7 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 23f00a9..cd7e007 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -53,6 +53,6 @@ mkRelation :: ([TypedExpr], [TypedExpr]) -> (Term, Term) -> SMTExpr Bool
 mkRelation i (BoolTerm argsf f, BoolTerm argsg g) = (f `app` (lookupArgs argsf False i)) .=>.
                                                        (g `app` (lookupArgs argsg False i))
 
-assertRs :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> [(Term, Term)] -> m ()
+assertRs :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> [(Term, Term)] -> m [SMTExpr Bool]
 assertRs i rs = let c = (map (mkRelation i) rs) in
-                  liftSMT $ assert (not' $ foldl (.&&.) (head c) $ tail c)
+                  liftSMT $ assert (not' $ foldl (.&&.) (head c) $ tail c) >> return c
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index f6d5d0d..489ef76 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -2,6 +2,8 @@
 {-# LANGUAGE ViewPatterns #-}
 module Strategies.Invariant where
 
+import Debug.Trace
+
 import Data.Natural
 import NatInstance
 import Data.List (stripPrefix)
@@ -132,11 +134,21 @@ check' indOpts getModel defs pastVars =
          check' indOpts getModel defs pastVars'
 
 filterRs :: MonadSMT m => [(Term, Term)] -> ([TypedExpr], [TypedExpr]) -> m [(Term, Term)]
-filterRs rs args = liftSMT $ do push
-                                assertRs args rs
-                                r <-checkSat
-                                pop
-                                return rs
+filterRs rs@(r:rss) args = liftSMT $ do push
+                                        c <- assertRs args rs
+                                        r <- checkSat
+                                        trace (show r) $ pop
+                                        if r
+                                           then do model <- mapM getValue c
+                                                   filtered <- filterRs' model rs
+                                                   filterRs filtered args
+                                           else return rs
+filterRs [] _ = liftSMT $ return []
+
+filterRs' :: (SMTValue t, MonadSMT m) => [t] -> [(Term, Term)] -> m [(Term, Term)]
+filterRs' model rs = liftSMT $ do push
+                                  pop
+                                  return rs
 
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)

From d28ad38e2234a2c5c273f065a106b0ed2d870567 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 20 Oct 2015 22:18:36 +0200
Subject: [PATCH 057/104] More term for relations are being saved

---
 lamaSMT/lib/Definition.hs           | 8 +++++---
 lamaSMT/lib/Strategies/Invariant.hs | 7 +++++--
 lamaSMT/lib/Transform.hs            | 4 +++-
 3 files changed, 13 insertions(+), 6 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index cd7e007..5049380 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -1,9 +1,10 @@
 module Definition where
 
-import Data.Array as Arr
+import Lang.LAMA.Types
 
 import Language.SMTLib2 as SMT
 
+import Data.Array as Arr
 import qualified Data.Set as Set
 import Data.Set (Set)
 
@@ -46,8 +47,9 @@ data Term =
   | RealTerm [Int] (SMTFunction [TypedExpr] Rational)
   deriving (Show, Ord, Eq)
 
-constructRs :: Set Term -> [(Term, Term)]
-constructRs ts = [(x,y) | x <- Set.toList ts, y <- Set.toList ts, x /= y]
+constructRs :: Set Term -> Type i -> [(Term, Term)]
+constructRs ts (GroundType BoolT) = [(x,y) | x@(BoolTerm _ _) <- Set.toList ts,
+                                      y@(BoolTerm _ _) <- Set.toList ts, x /= y]
 
 mkRelation :: ([TypedExpr], [TypedExpr]) -> (Term, Term) -> SMTExpr Bool
 mkRelation i (BoolTerm argsf f, BoolTerm argsg g) = (f `app` (lookupArgs argsf False i)) .=>.
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 489ef76..382d75b 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -4,6 +4,8 @@ module Strategies.Invariant where
 
 import Debug.Trace
 
+import Lang.LAMA.Types
+
 import Data.Natural
 import NatInstance
 import Data.List (stripPrefix)
@@ -60,8 +62,9 @@ instance StrategyClass Invar where
           n0  <- freshVars vars
           n1  <- freshVars vars
           assumeTrace defs (n0, n1)
-          let s0 = InductState baseK (vars, k1) (n0, n1) $ constructRs (instSet env)
-          (r, hints) <- runWriterT
+          let s0 = InductState baseK (vars, k1) (n0, n1)
+                     $ constructRs (instSet env) (GroundType BoolT)
+          (r, hints) <- trace (show $ rs s0) $ runWriterT
                 $ (flip evalStateT s0)
                 $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
           case r of
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index f305ec0..42e6ce0 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -329,7 +329,9 @@ declareDef x as ns succ ef =
      ann         <- getTypedAnnotation $ [xN] ++ ns
      d           <- defFunc defType ann
                     $ \a -> liftRel (.==.) (head a) $ ef env $ zip ((Set.toList as) ++ [error "Last argument must not be evaluated!"]) (tail a)
-     return $ ensureDefinition ([xN] ++ ns) succ d
+     let argsN   = ([xN] ++ ns)
+     putTerm argsN d
+     return $ ensureDefinition argsN succ d
 
 varDefType :: TypedExpr -> Type i
 varDefType (ProdExpr ts) = ProdType . fmap varDefType $ Arr.elems ts

From 50cf1df6d33f8c31acf85d0f47a97f710fdd056f Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 20 Oct 2015 23:25:07 +0200
Subject: [PATCH 058/104] Filtering is now propably correct

---
 lamaSMT/lib/Definition.hs           |  9 +++++++--
 lamaSMT/lib/Strategies/Invariant.hs | 29 ++++++++++++++++++-----------
 2 files changed, 25 insertions(+), 13 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 5049380..d02ace8 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -55,6 +55,11 @@ mkRelation :: ([TypedExpr], [TypedExpr]) -> (Term, Term) -> SMTExpr Bool
 mkRelation i (BoolTerm argsf f, BoolTerm argsg g) = (f `app` (lookupArgs argsf False i)) .=>.
                                                        (g `app` (lookupArgs argsg False i))
 
-assertRs :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> [(Term, Term)] -> m [SMTExpr Bool]
+assertRs :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> [(Term, Term)] -> m ()
 assertRs i rs = let c = (map (mkRelation i) rs) in
-                  liftSMT $ assert (not' $ foldl (.&&.) (head c) $ tail c) >> return c
+                  liftSMT $ assert (not' $ foldl (.&&.) (head c) $ tail c)
+
+assertR :: MonadSMT m => [TypedExpr] -> (Term, Term) -> m ()
+assertR i (BoolTerm argsf f, BoolTerm argsg g) =
+  liftSMT $ assert ((f `app` (lookupArgs argsf False (i, i))) .=>.
+    (g `app` (lookupArgs argsg False (i, i))))
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 382d75b..ffe3c13 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -64,7 +64,7 @@ instance StrategyClass Invar where
           assumeTrace defs (n0, n1)
           let s0 = InductState baseK (vars, k1) (n0, n1)
                      $ constructRs (instSet env) (GroundType BoolT)
-          (r, hints) <- trace (show $ rs s0) $ runWriterT
+          (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
                 $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
           case r of
@@ -138,20 +138,27 @@ check' indOpts getModel defs pastVars =
 
 filterRs :: MonadSMT m => [(Term, Term)] -> ([TypedExpr], [TypedExpr]) -> m [(Term, Term)]
 filterRs rs@(r:rss) args = liftSMT $ do push
-                                        c <- assertRs args rs
+                                        assertRs args rs
                                         r <- checkSat
-                                        trace (show r) $ pop
-                                        if r
-                                           then do model <- mapM getValue c
-                                                   filtered <- filterRs' model rs
+                                        trace (show r ) $ if r
+                                           then do model <- mapM (\(BoolExpr s) -> getValue s) $ fst args
+                                                   let model' = map (\s -> BoolExpr $ constant s) model
+                                                   pop
+                                                   filtered <- filterRs' model' rs
                                                    filterRs filtered args
-                                           else return rs
+                                           else pop >> return rs
 filterRs [] _ = liftSMT $ return []
 
-filterRs' :: (SMTValue t, MonadSMT m) => [t] -> [(Term, Term)] -> m [(Term, Term)]
-filterRs' model rs = liftSMT $ do push
-                                  pop
-                                  return rs
+filterRs' :: MonadSMT m => [TypedExpr] -> [(Term, Term)] -> m [(Term, Term)]
+filterRs' model (r:rs) = liftSMT $ do trace (show r) $ push
+                                      assertR model r
+                                      e <- checkSat
+                                      pop
+                                      rest <- filterRs' model rs
+                                      if e
+                                         then return $ [r] ++ rest
+                                         else return rest
+filterRs' model [] = liftSMT $ return []
 
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)

From eaeacac9deeb99c79b459bf52f00f94f2ba6b76e Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 21 Oct 2015 18:28:11 +0200
Subject: [PATCH 059/104] Automatons now activated conditionally each step

---
 lamaSMT/lib/Transform.hs | 76 ++++++++++++++++++++++------------------
 1 file changed, 41 insertions(+), 35 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index a7b7d40..3603fb9 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -118,7 +118,7 @@ declareEnum (t, EnumDef cs) =
         liftSMT (declareType (undefined :: SMTEnum) ann) >> return (t, ann)
 
 declareDecls :: Ident i =>
-                Maybe (TypedExpr)
+                Maybe (i, TypedExpr)
                 -> Set i
                 -> Declarations i
                 -> DeclM i ([Definition], Map i (Node i))
@@ -186,7 +186,7 @@ enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
 -- declared. The other nodes are deferred to be declared in the corresponding
 -- location (see declareAutomaton and declareLocations).
 declareNode :: Ident i =>
-               Maybe (TypedExpr) -> i -> Node i -> DeclM i [Definition]
+               Maybe (i, TypedExpr) -> i -> Node i -> DeclM i [Definition]
 declareNode active nName nDecl = 
   do (interface, defs) <- localVarEnv (const emptyVarEnv) $
                           declareNode' active nDecl
@@ -194,7 +194,7 @@ declareNode active nName nDecl =
      return defs
   where
     declareNode' :: Ident i =>
-                    Maybe (TypedExpr) -> Node i
+                    Maybe (i, TypedExpr) -> Node i
                     -> DeclM i (NodeEnv i, [Definition])
     declareNode' activeCond n =
       do let automNodes =
@@ -228,7 +228,7 @@ getNodesInLocations = mconcat . map getUsedLoc . automLocations
 -- | Creates definitions for instant definitions. In case of a node usage this
 -- may produce multiple definitions. If 
 declareInstantDef :: Ident i =>
-                     Maybe (TypedExpr)
+                     Maybe (i, TypedExpr)
                      -> InstantDefinition i
                      -> DeclM i [Definition]
 declareInstantDef activeCond inst@(InstantExpr x e) =
@@ -253,7 +253,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
 -- used to further refine this instant (e.g. wrap it into an ite).
 -- This may also return definitions of the parameters of a node.
 -- The activation condition is only used for the inputs of a node.
-trInstant :: Ident i => Maybe (TypedExpr) -> InstantDefinition i -> DeclM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
+trInstant :: Ident i => Maybe (i, TypedExpr) -> InstantDefinition i -> DeclM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
 trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
@@ -283,7 +283,7 @@ trOutput map = do
 -- x' = (ite c e x) where e is the defining expression. Otherwise it is just
 -- x' = e.
 declareTransition :: Ident i =>
-                     Maybe (TypedExpr)
+                     Maybe (i, TypedExpr)
                      -> StateTransition i
                      -> DeclM i Definition
 declareTransition activeCond (StateTransition x e) =
@@ -301,7 +301,7 @@ declareTransition activeCond (StateTransition x e) =
 -- stream of /x/ which will be defined, can be specified by modPos
 -- (see declareDef).
 declareConditionalAssign :: Ident i =>
-                            Maybe (TypedExpr)
+                            Maybe (i, TypedExpr)
                             -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
                             -> TypedExpr
                             -> Set i
@@ -309,11 +309,15 @@ declareConditionalAssign :: Ident i =>
                             -> Bool
                             -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
                             -> DeclM i Definition
-declareConditionalAssign activeCond defaultExpr x al ns succ ef =
+declareConditionalAssign activeCond defaultExpr x as ns succ ef =
   case activeCond of
-    Nothing -> declareDef x al ns succ ef
-    Just c  ->
-      declareDef x al ns succ (\env t -> liftIte c (ef env t) (defaultExpr env t))
+    Nothing -> declareDef x as ns succ ef
+    Just (ident, c)  -> do
+      condN <- getN c
+      let condExpr = mkTyped (AtExpr (AtomVar (ident))) $ varDefType c
+          arg      = getArgSet condExpr
+          condVar  = runTransM $ trExpr condExpr
+      declareDef x (Set.union as arg) ([condN] ++ ns) succ (\env t -> liftIte (condVar env t) (ef env t) (defaultExpr env t))
 
 -- | Creates a definition for a given variable. Whereby a function to
 -- manipulate the stream position at which it is defined is used (normally
@@ -350,7 +354,7 @@ getTypedAnnotation ns = mapM getTypedAnnotation' ns
                      EnumExpr (Var _ k) -> EnumAnnotation k
                      ProdExpr k -> ProdAnnotation $ fmap getTypedAnnCases k
 
-declareFlow :: Ident i => Maybe (TypedExpr) -> Flow i -> DeclM i [Definition]
+declareFlow :: Ident i => Maybe (i, TypedExpr) -> Flow i -> DeclM i [Definition]
 declareFlow activeCond f =
   do defDefs        <- fmap concat
                        . mapM (declareInstantDef activeCond)
@@ -368,13 +372,14 @@ declareFlow activeCond f =
 --    conditions (mkTransitionEq)
 -- * asserting the initial location
 declareAutomaton :: Ident i =>
-                    Maybe (TypedExpr)
+                    Maybe (i, TypedExpr)
                     -> Map i (Node i)
                     -> (Int, Automaton i)
                     -> DeclM i [Definition]
 declareAutomaton activeCond localNodes (_, a) =
   do automIndex <- nextAutomatonIndex
      let automName = "Autom" ++ show automIndex
+         condName  = automName ++ "_active"
          enumName  = fromString $ automName ++ "States"
          stateT    = EnumType enumName
          locNames  =
@@ -394,7 +399,7 @@ declareAutomaton activeCond localNodes (_, a) =
                    (selId, sel)
                   ]
                 )
-     locDefs <- (flip runReaderT (locCons, localNodes))
+     locDefs <- (flip runReaderT ((locCons, localNodes), condName))
                 $ declareLocations activeCond act
                 (automDefaults a) (automLocations a)
      enumAnn <- lookupEnumAnn enumName
@@ -464,19 +469,19 @@ extractAssigns = foldl addLocExprs (Map.empty, Map.empty)
 -- beforehand and the undeclared nodes which are used in one of the
 -- locations of the automata to be defined.
 type AutomTransM i =
-  ReaderT (Map (LocationId i) (EnumConstr i), Map i (Node i)) (DeclM i)
+  ReaderT ((Map (LocationId i) (EnumConstr i), Map i (Node i)), String) (DeclM i)
 
 lookupLocName :: Ident i => LocationId i -> AutomTransM i (EnumConstr i)
 lookupLocName l
-  = asks fst >>= lookupErr ("Unknown location " ++ identPretty l) l
+  = asks (fst . fst) >>= lookupErr ("Unknown location " ++ identPretty l) l
 
 lookupLocalNode :: Ident i => i -> AutomTransM i (Node i)
 lookupLocalNode n
-  = asks snd >>= lookupErr ("Unknow local node " ++ identPretty n) n
+  = asks (snd .fst) >>= lookupErr ("Unknow local node " ++ identPretty n) n
 
 -- | Declares the data flow inside the locations of an automaton.
 declareLocations :: Ident i =>
-                    Maybe (TypedExpr)
+                    Maybe (i, TypedExpr)
                     -> TypedExpr
                     -> Map i (Expr i)
                     -> [Location i]
@@ -493,7 +498,7 @@ declareLocations activeCond s defaultExprs locations =
         return $ instDefs ++ transDefs
   where
     declareLocDefs :: Ident i =>
-                      Maybe (TypedExpr)
+                      Maybe (i, TypedExpr)
                       -> Map i (Expr i)
                       -> (i, [(LocationId i, InstantDefinition i)])
                       -> AutomTransM i [Definition]
@@ -515,7 +520,7 @@ declareLocations activeCond s defaultExprs locations =
                                            return $ Map.keysSet (nodeEnvOut nEnv)
 
     declareLocTransitions :: Ident i =>
-                             Maybe (TypedExpr)
+                             Maybe (i, TypedExpr)
                              -> (i, [(LocationId i, StateTransition i)])
                              -> AutomTransM i Definition
     declareLocTransitions active (x, locs) =
@@ -537,11 +542,11 @@ declareLocations activeCond s defaultExprs locations =
                 $ lookupErr (identPretty x ++ " not fully defined") x defaults
 
     isFullyDefined locDefs =
-      do locNames <- asks fst
+      do locNames <- asks (fst . fst)
          return $ (Map.keysSet locNames) == (Set.fromList $ map fst locDefs)
 
 declareLocDef :: Ident i =>
-                 Maybe (TypedExpr)
+                 Maybe (i, TypedExpr)
                  -> TypedExpr
                  -> Maybe (Expr i)
                  -> [(LocationId i, InstantDefinition i)]
@@ -559,17 +564,17 @@ declareLocDef activeCond s defaultExpr locs =
        innerPat locs'
   where
     trLocInstant :: Ident i =>
-                    Maybe (TypedExpr)
+                    Maybe (i, TypedExpr)
                     -> LocationId i
                     -> InstantDefinition i
                     -> AutomTransM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
     trLocInstant _ _ inst@(InstantExpr _ _) =
       lift $ trInstant (error "no activation condition required") inst
     trLocInstant active l inst@(NodeUsage _ n _) =
-      do (locActive, activeDef) <- mkLocationActivationCond active s l
+      do (identActive, locActive, activeDef) <- mkLocationActivationCond active s l
          node                   <- lookupLocalNode n
-         nodeDefs               <- lift $ declareNode (Just locActive) n node
-         (r, inpDefs)           <- lift $ trInstant (Just locActive) inst
+         nodeDefs               <- lift $ declareNode (Just (identActive, locActive)) n node
+         (r, inpDefs)           <- lift $ trInstant (Just (identActive, locActive)) inst
          return (r, [activeDef] ++ nodeDefs ++ inpDefs)
 
 trLocTransition :: Ident i =>
@@ -604,27 +609,28 @@ mkLocationMatch (EnumExpr s) f l lExpr =
 -- | Creates a variable which is true iff the given activation
 -- condition is true and the the given location is active.
 mkLocationActivationCond :: Ident i =>
-                            Maybe (TypedExpr)
+                            Maybe (i, TypedExpr)
                             -> TypedExpr
                             -> LocationId i
-                            -> AutomTransM i (TypedExpr, Definition)
+                            -> AutomTransM i (i, TypedExpr, Definition)
 mkLocationActivationCond activeCond e l =
-  do lCons <- lookupLocName l
+  do condName <- asks snd
+     lCons <- lookupLocName l
      lEnum <- lift $ trEnumConsAnn lCons <$> lookupEnumConsAnn lCons
      let cond = \_env t -> BoolExpr $ (unEnum $ snd $ last t) .==. lEnum
-     activeVar <- liftSMT $ fmap BoolExpr $ var
+     activeVar <- liftSMT $ fmap BoolExpr $ varNamed condName
      lift $ addVar activeVar
      argN <- lift $ getN e
      def <- lift $ declareConditionalAssign activeCond
             (const $ const $ BoolExpr $ constant False) activeVar Set.empty [argN] False cond
-     return (activeVar, def)
+     return (fromString condName, activeVar, def)
 
 -- | Creates two equations for the edges. The first calculates
 -- the next location (act). This is a chain of ite for each state surrounded
 -- by a match on the last location (sel). The definition of sel is just
 -- the saving of act for the next cycle.
 mkTransitionEq :: Ident i =>
-                  Maybe (TypedExpr)
+                  Maybe (i, TypedExpr)
                   -> Type i
                   -> Map (LocationId i) (EnumConstr i)
                   -> i
@@ -718,7 +724,7 @@ assertInit (x, e) =
 
 -- | Creates a definition for a precondition p. If an activation condition c
 -- is given, the resulting condition is (=> c p).
-declarePrecond :: Ident i => Maybe (TypedExpr) -> Expr i -> DeclM i Definition
+declarePrecond :: Ident i => Maybe (i, TypedExpr) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
   do env      <- get
      let args = getArgSet e
@@ -727,14 +733,14 @@ declarePrecond activeCond e =
      ann      <- getTypedAnnotation argsN
      d        <- case activeCond of
        Nothing -> defFunc boolT ann $ \a -> runTransM (trExpr e) env (zip (Set.toList $ args) a)
-       Just c -> defFunc boolT ann $
+       Just (ident, c) -> defFunc boolT ann $
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) c e')
      return $ ensureDefinition argsN False d
 
 declareInvariant :: Ident i =>
-                    Maybe (TypedExpr) -> Expr i -> DeclM i Definition
+                    Maybe (i, TypedExpr) -> Expr i -> DeclM i Definition
 declareInvariant = declarePrecond
 
 trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr)

From 1f34ba685371034a726f180bad327eb97aa6bddd Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 21 Oct 2015 18:29:36 +0200
Subject: [PATCH 060/104] Bumped LamaSMT version to 0.2

---
 lamaSMT/LamaSMT.cabal | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/lamaSMT/LamaSMT.cabal b/lamaSMT/LamaSMT.cabal
index eeb0587..c38b050 100644
--- a/lamaSMT/LamaSMT.cabal
+++ b/lamaSMT/LamaSMT.cabal
@@ -1,5 +1,5 @@
 Name:           LamaSMT
-Version:        0.1
+Version:        0.2
 Build-Type:     Simple
 Cabal-Version:  >= 1.10
 Description:
@@ -15,4 +15,4 @@ Executable lamasmt
   GHC-Options: -Wall -rtsopts
   other-modules:
     Transform
-  Main-Is: Main.hs
\ No newline at end of file
+  Main-Is: Main.hs

From 4d7891c99da2d2c085030111f22934a97aed9532 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 4 Nov 2015 13:11:42 +0100
Subject: [PATCH 061/104] Ident for location match enum

---
 lamaSMT/lib/Transform.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 3603fb9..b397b61 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -333,6 +333,7 @@ declareDef x as ns succ ef =
      ann         <- getTypedAnnotation $ [xN] ++ ns
      d           <- defFunc defType ann
                     $ \a -> liftRel (.==.) (head a) $ ef env $ zip ((Set.toList as) ++ [error "Last argument must not be evaluated!"]) (tail a)
+
      return $ ensureDefinition ([xN] ++ ns) succ d
 
 varDefType :: TypedExpr -> Type i
@@ -512,7 +513,7 @@ declareLocations activeCond s defaultExprs locations =
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-
-           lift $ declareConditionalAssign active xBottom xVar args argsN False res
+           lift $ declareConditionalAssign active xBottom xVar (Set.insert (fromString "dummyForLocEnum") args) argsN False res
          return $ inpDefs ++ [def]
       where
         locArgSet (_,InstantExpr _ e) = return $ getArgSet e
@@ -531,7 +532,7 @@ declareLocations activeCond s defaultExprs locations =
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def         <-
-           lift $ declareConditionalAssign active (runTransM $ trExpr defExpr) xVar args argsN True res
+           lift $ declareConditionalAssign active (runTransM $ trExpr defExpr) xVar (Set.insert (fromString "dummyForLocEnum") args) argsN True res
          return def
 
     getDefault defaults x locs =

From 39285f4cecf6539c48567063c808219a51981d23 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 9 Nov 2015 14:26:37 +0100
Subject: [PATCH 062/104] Replaced set of idents through list of idents

---
 lamaSMT/lib/Transform.hs | 85 ++++++++++++++++++++--------------------
 1 file changed, 42 insertions(+), 43 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index b397b61..d07aaae 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -234,8 +234,8 @@ declareInstantDef :: Ident i =>
 declareInstantDef activeCond inst@(InstantExpr x e) =
   do (res, []) <- trInstant (error "no activation condition") inst
      xVar <- lookupVar x
-     let args = getArgSet e
-     argsE <- mapM lookupVar $ Set.toList args
+     let args = getArgList e
+     argsE <- mapM lookupVar args
      argsN <- mapM getN argsE
      def <- declareConditionalAssign
             activeCond (const $ const $ getBottom xVar) xVar args argsN False res
@@ -246,7 +246,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
      nEnv            <- lookupNode n
      outN            <- mapM getN $ nodeEnvOut nEnv
      outpDef         <- declareConditionalAssign
-                        activeCond (const $ const $ getBottom xVar) xVar (Map.keysSet $ nodeEnvOut nEnv) (Map.elems outN) False outp
+                        activeCond (const $ const $ getBottom xVar) xVar (Map.keys $ nodeEnvOut nEnv) (Map.elems outN) False outp
      return $ inpDefs ++ [outpDef]
 
 -- | Translates an instant definition into a function which can be
@@ -259,12 +259,12 @@ trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
      let esTr = map (runTransM . trExpr) es
          y    = runTransM $ trOutput $ nodeEnvOut nEnv
-         ins = map (Set.toList . getArgSet) es
+         ins = map getArgList es
      insE <- mapM (mapM lookupVar) ins
      insN <- mapM (mapM getN) insE
      inpDefs  <- mapM (\(x, n, e, eTr) ->
                         declareConditionalAssign
-                        inpActive (const $ const $ getBottom x) x (getArgSet e) n False eTr)
+                        inpActive (const $ const $ getBottom x) x (getArgList e) n False eTr)
                  $ zip4 (nodeEnvIn nEnv) insN es esTr
      return (y, inpDefs)
 
@@ -290,8 +290,8 @@ declareTransition activeCond (StateTransition x e) =
   do xVar     <- lookupVar x
      let e'      = runTransM $ trExpr e
          defExpr = mkTyped (AtExpr (AtomVar x)) $ varDefType xVar
-         args    = Set.union (getArgSet e) (getArgSet defExpr)
-     argsE <- mapM lookupVar $ Set.toList args
+         args    = getArgList defExpr ++ getArgList e
+     argsE <- mapM lookupVar args
      argsN <- mapM getN argsE
      declareConditionalAssign activeCond (runTransM $ trExpr defExpr) xVar args argsN True e'
 
@@ -304,7 +304,7 @@ declareConditionalAssign :: Ident i =>
                             Maybe (i, TypedExpr)
                             -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
                             -> TypedExpr
-                            -> Set i
+                            -> [i]
                             -> [Int]
                             -> Bool
                             -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
@@ -315,16 +315,16 @@ declareConditionalAssign activeCond defaultExpr x as ns succ ef =
     Just (ident, c)  -> do
       condN <- getN c
       let condExpr = mkTyped (AtExpr (AtomVar (ident))) $ varDefType c
-          arg      = getArgSet condExpr
+          arg      = getArgList condExpr
           condVar  = runTransM $ trExpr condExpr
-      declareDef x (Set.union as arg) ([condN] ++ ns) succ (\env t -> liftIte (condVar env t) (ef env t) (defaultExpr env t))
+      declareDef x (arg ++ as) ([condN] ++ ns) succ (\env t -> liftIte (condVar env t) (ef env t) (defaultExpr env t))
 
 -- | Creates a definition for a given variable. Whereby a function to
 -- manipulate the stream position at which it is defined is used (normally
 -- id or succ' to define instances or state transitions).
 -- The second argument /x/ is the stream to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
-declareDef :: Ident i => TypedExpr -> Set i -> [Int] -> Bool ->
+declareDef :: Ident i => TypedExpr -> [i] -> [Int] -> Bool ->
               (Env i -> [(i, TypedExpr)] -> TypedExpr) -> DeclM i Definition
 declareDef x as ns succ ef =
   do env         <- get
@@ -332,8 +332,7 @@ declareDef x as ns succ ef =
      xN          <- getN x
      ann         <- getTypedAnnotation $ [xN] ++ ns
      d           <- defFunc defType ann
-                    $ \a -> liftRel (.==.) (head a) $ ef env $ zip ((Set.toList as) ++ [error "Last argument must not be evaluated!"]) (tail a)
-
+                    $ \a -> liftRel (.==.) (head a) $ ef env $ zip (as ++ [error "Last argument must not be evaluated!"]) (tail a)
      return $ ensureDefinition ([xN] ++ ns) succ d
 
 varDefType :: TypedExpr -> Type i
@@ -507,18 +506,18 @@ declareLocations activeCond s defaultExprs locations =
       do defaultExpr    <- getDefault defaults x locs
          (res, inpDefs) <- declareLocDef active s defaultExpr locs
          xVar           <- lookupVar x
-         argss          <- lift $ mapM locArgSet locs
+         argss          <- lift $ mapM locArgList locs
          let xBottom    = const $ const $ getBottom xVar
-             args       = Set.unions argss
-         argsE          <- mapM lookupVar $ Set.toList args
+             args       = concat argss
+         argsE          <- mapM lookupVar args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-
-           lift $ declareConditionalAssign active xBottom xVar (Set.insert (fromString "dummyForLocEnum") args) argsN False res
+           lift $ declareConditionalAssign active xBottom xVar (args ++ [fromString "dummyForLocEnum"]) argsN False res
          return $ inpDefs ++ [def]
       where
-        locArgSet (_,InstantExpr _ e) = return $ getArgSet e
-        locArgSet (_,NodeUsage _ n _) = do nEnv <- lookupNode n
-                                           return $ Map.keysSet (nodeEnvOut nEnv)
+        locArgList (_,InstantExpr _ e) = return $ getArgList e
+        locArgList (_,NodeUsage _ n _) = do nEnv <- lookupNode n
+                                            return $ Map.keys (nodeEnvOut nEnv)
 
     declareLocTransitions :: Ident i =>
                              Maybe (i, TypedExpr)
@@ -528,11 +527,11 @@ declareLocations activeCond s defaultExprs locations =
       do res         <- trLocTransition s locs
          xVar     <- lookupVar x
          let defExpr    = mkTyped (AtExpr (AtomVar x)) $ varDefType xVar
-             args       = Set.unions $ (map (\(_,StateTransition _ e) -> getArgSet e) locs) ++ [getArgSet defExpr]
-         argsE          <- mapM lookupVar $ Set.toList args
+             args       = concat $ (map (\(_,StateTransition _ e) -> getArgList e) locs) ++ [getArgList defExpr]
+         argsE          <- mapM lookupVar args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def         <-
-           lift $ declareConditionalAssign active (runTransM $ trExpr defExpr) xVar (Set.insert (fromString "dummyForLocEnum") args) argsN True res
+           lift $ declareConditionalAssign active (runTransM $ trExpr defExpr) xVar (args ++ [fromString "dummyForLocEnum"]) argsN True res
          return def
 
     getDefault defaults x locs =
@@ -623,7 +622,7 @@ mkLocationActivationCond activeCond e l =
      lift $ addVar activeVar
      argN <- lift $ getN e
      def <- lift $ declareConditionalAssign activeCond
-            (const $ const $ BoolExpr $ constant False) activeVar Set.empty [argN] False cond
+            (const $ const $ BoolExpr $ constant False) activeVar [] [argN] False cond
      return (fromString condName, activeVar, def)
 
 -- | Creates two equations for the edges. The first calculates
@@ -648,10 +647,10 @@ mkTransitionEq activeCond locationEnumTy locationEnumConstrs act sel es bot =
                            AtomVar sel) locationEnumTy) . Map.toList
                            $ foldr addEdge Map.empty es
                        inst = InstantExpr act e
-                       args = getArgSet e
+                       args = getArgList e
                    (res, []) <- trInstant (error "no activation condition") inst
                    xVar <- lookupVar act
-                   argsE <- mapM lookupVar $ Set.toList args
+                   argsE <- mapM lookupVar args
                    argsN <- mapM getN argsE
                    def <- declareConditionalAssign activeCond (const $ const $ bot) xVar args argsN False res
                    return [def]
@@ -659,8 +658,8 @@ mkTransitionEq activeCond locationEnumTy locationEnumConstrs act sel es bot =
        xVar     <- lookupVar sel
        let e'      = runTransM $ trExpr (mkTyped (AtExpr $ AtomVar act) locationEnumTy)
            defExpr = mkTyped (AtExpr (AtomVar sel)) $ varDefType xVar
-           args    = Set.union (getArgSet (mkTyped (AtExpr $ AtomVar act) locationEnumTy)) (getArgSet defExpr)
-       argsE <- mapM lookupVar $ Set.toList args
+           args    = (getArgList defExpr) ++ (getArgList (mkTyped (AtExpr $ AtomVar act) locationEnumTy))
+       argsE <- mapM lookupVar args
        argsN <- mapM getN argsE
        declareConditionalAssign activeCond (runTransM $ trExpr defExpr) xVar args argsN True e'
      return $ stateDef ++ [stateTr]
@@ -728,14 +727,14 @@ assertInit (x, e) =
 declarePrecond :: Ident i => Maybe (i, TypedExpr) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
   do env      <- get
-     let args = getArgSet e
-     argsE    <- mapM lookupVar $ Set.toList args
+     let args = getArgList e
+     argsE    <- mapM lookupVar args
      argsN    <- mapM getN argsE
      ann      <- getTypedAnnotation argsN
      d        <- case activeCond of
-       Nothing -> defFunc boolT ann $ \a -> runTransM (trExpr e) env (zip (Set.toList $ args) a)
+       Nothing -> defFunc boolT ann $ \a -> runTransM (trExpr e) env $ zip args a
        Just (ident, c) -> defFunc boolT ann $
-                 \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
+                 \a -> (flip (flip runTransM env) (zip args a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) c e')
      return $ ensureDefinition argsN False d
@@ -783,17 +782,17 @@ askStreamPos :: TransM i StreamPos
 askStreamPos = asks fst
 -}
 
-getArgSet :: Ident i => Expr i -> Set i
-getArgSet expr = case untyped expr of
-  AtExpr (AtomConst c)  -> Set.empty
-  AtExpr (AtomVar x)    -> Set.singleton x
-  AtExpr (AtomEnum x)   -> Set.empty
-  LogNot e              -> getArgSet e
-  Expr2 op e1 e2        -> Set.union (getArgSet e1) (getArgSet e2)
-  Ite c e1 e2           -> Set.unions [getArgSet c, getArgSet e1, getArgSet e2]
-  ProdCons (Prod es)    -> foldr (Set.union . getArgSet) Set.empty es
-  Project x i           -> Set.singleton x
-  Match e pats -> Set.unions $ [getArgSet e] ++ map (\(Pattern _ x) -> getArgSet x) pats
+getArgList :: Ident i => Expr i ->  [i]
+getArgList expr = case untyped expr of
+  AtExpr (AtomConst c)  -> []
+  AtExpr (AtomVar x)    -> [x]
+  AtExpr (AtomEnum x)   -> []
+  LogNot e              -> getArgList e
+  Expr2 op e1 e2        -> getArgList e2 ++ getArgList e1
+  Ite c e1 e2           -> getArgList e2 ++ getArgList e1 ++ getArgList c
+  ProdCons (Prod es)    -> foldr ((++) . getArgList) [] es
+  Project x i           -> [x]
+  Match e pats -> concat $ [getArgList e] ++ map (\(Pattern _ x) -> getArgList x) pats
 
 -- we do no further type checks since this
 -- has been done beforehand.

From 2a06155a0c9c31e5614ed7ba3b14afa3aa0d0f27 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 9 Nov 2015 15:06:25 +0100
Subject: [PATCH 063/104] Default expression's arguments added to argument list

---
 lamaSMT/lib/Transform.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index d07aaae..958f8dc 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -38,6 +38,7 @@ import Prelude hiding (mapM)
 import Data.Traversable
 import Data.Foldable (foldlM, foldrM)
 import Data.Monoid
+import Data.Maybe
 
 import Control.Monad.Trans.Class
 import Control.Monad.State (StateT(..), MonadState(..), gets)
@@ -508,7 +509,7 @@ declareLocations activeCond s defaultExprs locations =
          xVar           <- lookupVar x
          argss          <- lift $ mapM locArgList locs
          let xBottom    = const $ const $ getBottom xVar
-             args       = concat argss
+             args       = concat argss ++ maybe [] getArgList defaultExpr
          argsE          <- mapM lookupVar args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-

From 67cf546649edad167d998089c49ac6dfd917022a Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 21 Oct 2015 22:14:07 +0200
Subject: [PATCH 064/104] Corrected bug with node returns

---
 lamaSMT/lib/Transform.hs | 21 ++++++++++++++-------
 1 file changed, 14 insertions(+), 7 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 958f8dc..35cc04d 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -509,16 +509,23 @@ declareLocations activeCond s defaultExprs locations =
          xVar           <- lookupVar x
          argss          <- lift $ mapM locArgList locs
          let xBottom    = const $ const $ getBottom xVar
-             args       = concat argss ++ maybe [] getArgList defaultExpr
-         argsE          <- mapM lookupVar args
-         argsN          <- lift $ mapM getN (argsE ++ [s])
+             args       = concat $ map (\(s, _) -> s) argss ++ [maybe [] getArgList defaultExpr]
+
+             argsN      = snd $ foldl (\(_, a) (_, b) -> (Set.empty, a ++ b)) (Set.empty, []) argss
+         argsNs         <- lift $ getN s
          def            <-
-           lift $ declareConditionalAssign active xBottom xVar (args ++ [fromString "dummyForLocEnum"]) argsN False res
+           lift $ declareConditionalAssign active xBottom xVar (args ++[fromString "dummyForLocEnum"]) (argsN ++ [argsNs])False res
          return $ inpDefs ++ [def]
       where
-        locArgList (_,InstantExpr _ e) = return $ getArgList e
-        locArgList (_,NodeUsage _ n _) = do nEnv <- lookupNode n
-                                            return $ Map.keys (nodeEnvOut nEnv)
+        locArgList (_,InstantExpr _ e) = do 
+                                          let args = getArgList e
+                                          argsE <- mapM lookupVar args
+                                          argsN <- mapM getN argsE
+                                          return (args, argsN)
+        locArgList (_,NodeUsage _ n _) = do nEnv  <- lookupNode n
+                                            let args = Map.keys (nodeEnvOut nEnv)
+                                            argsN <- mapM getN $ nodeEnvOut nEnv
+                                            return (args, Map.elems argsN)
 
     declareLocTransitions :: Ident i =>
                              Maybe (i, TypedExpr)

From 1125d494500ca59add63e6609e40b7ceb5ef258f Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 10 Nov 2015 19:23:42 +0100
Subject: [PATCH 065/104] Correct default values not being added to argument
 list

---
 lamaSMT/lib/Transform.hs | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 35cc04d..b53bc4d 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -509,12 +509,14 @@ declareLocations activeCond s defaultExprs locations =
          xVar           <- lookupVar x
          argss          <- lift $ mapM locArgList locs
          let xBottom    = const $ const $ getBottom xVar
-             args       = concat $ map (\(s, _) -> s) argss ++ [maybe [] getArgList defaultExpr]
-
-             argsN      = snd $ foldl (\(_, a) (_, b) -> (Set.empty, a ++ b)) (Set.empty, []) argss
+             argDefault  = maybe [] getArgList defaultExpr
+         argDefaultE    <- mapM lookupVar argDefault
+         argDefaultN    <- lift $ mapM getN argDefaultE
+         let args       = concat $ map fst argss ++ [argDefault]
+             argsN      = concat $ map snd argss ++ [argDefaultN]
          argsNs         <- lift $ getN s
          def            <-
-           lift $ declareConditionalAssign active xBottom xVar (args ++[fromString "dummyForLocEnum"]) (argsN ++ [argsNs])False res
+           lift $ declareConditionalAssign active xBottom xVar (args ++ [fromString "dummyForLocEnum"]) (argsN ++ [argsNs]) False res
          return $ inpDefs ++ [def]
       where
         locArgList (_,InstantExpr _ e) = do 

From e4c27b0e9eebf62139ff8e1f0aea9264919bbed8 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 11 Nov 2015 00:34:45 +0100
Subject: [PATCH 066/104] Brought node output in right order with list instead
 of map

---
 lamaSMT/lib/Model.hs        |  6 +++---
 lamaSMT/lib/Transform.hs    | 18 +++++++++---------
 lamaSMT/lib/TransformEnv.hs |  2 +-
 3 files changed, 13 insertions(+), 13 deletions(-)

diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index 71ede51..a0e69be 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -43,7 +43,7 @@ data Model i = Model
 
 data NodeModel i = NodeModel
                    { nodeModelIn :: [ValueStream]
-                   , nodeModelOut :: Map i ValueStream
+                   , nodeModelOut :: [ValueStream]
                    , nodeModelVars :: Model i
                    } deriving Show
 
@@ -59,7 +59,7 @@ prettyNodes = vcat . map (\(x, n) -> (ptext $ identString x) <+> prettyNodeModel
 prettyNodeModel :: Ident i => NodeModel i -> Doc
 prettyNodeModel m = braces . nest 2 $
   text "Inputs:" $+$ nest 2 (vcat . map prettyStream $ nodeModelIn m) $+$
-  text "Outputs:" $+$ nest 2 (vcat . map prettyStream $ Map.elems $ nodeModelOut m) $+$
+  text "Outputs:" $+$ nest 2 (vcat . map prettyStream $ nodeModelOut m) $+$
   prettyModel (nodeModelVars m)
 
 prettyStream :: ValueStream -> Doc
@@ -88,7 +88,7 @@ getModel' env =
 
 getNodeModel :: NodeEnv i -> ModelM (NodeModel i)
 getNodeModel (NodeEnv i o e) =
-  NodeModel <$> mapM getVarModel i <*> getVarsModel o <*> getModel' e
+  NodeModel <$> mapM getVarModel i <*> mapM (getVarModel . snd) o <*> getModel' e
 
 getVarsModel :: Map i (TypedExpr) -> ModelM (Map i ValueStream)
 getVarsModel = mapM getVarModel
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index b53bc4d..3139e07 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -204,7 +204,7 @@ declareNode active nName nDecl =
            declareDecls activeCond automNodes $ nodeDecls n
          outDecls <- declareVarList $ nodeOutputs n
          ins <- mapM (lookupVar . varIdent) . declsInput $ nodeDecls n
-         let outs = Map.fromList outDecls
+         let outs = outDecls
          modifyVars $ Map.union (Map.fromList outDecls)
          flowDefs <- declareFlow activeCond $ nodeFlow n
          automDefs <-
@@ -245,9 +245,9 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
   do (outp, inpDefs) <- trInstant activeCond inst
      xVar            <- lookupVar x
      nEnv            <- lookupNode n
-     outN            <- mapM getN $ nodeEnvOut nEnv
+     outN            <- mapM (\(_, e) -> getN e) $ nodeEnvOut nEnv
      outpDef         <- declareConditionalAssign
-                        activeCond (const $ const $ getBottom xVar) xVar (Map.keys $ nodeEnvOut nEnv) (Map.elems outN) False outp
+                        activeCond (const $ const $ getBottom xVar) xVar (map fst $ nodeEnvOut nEnv) outN False outp
      return $ inpDefs ++ [outpDef]
 
 -- | Translates an instant definition into a function which can be
@@ -269,10 +269,10 @@ trInstant inpActive (NodeUsage _ n es) =
                  $ zip4 (nodeEnvIn nEnv) insN es esTr
      return (y, inpDefs)
 
-trOutput :: Ident i => Map i (TypedExpr) -> TransM i (TypedExpr)
-trOutput map = do
+trOutput :: Ident i => [(i, TypedExpr)] -> TransM i (TypedExpr)
+trOutput m = do
                  s <- ask
-                 outList <- mapM (trOutput' s) (Map.toList map)
+                 outList <- mapM (trOutput' s) m
                  return $ mkProdExpr outList
                where
                  trOutput' s (i, te) = case lookup i (fst s) of
@@ -525,9 +525,9 @@ declareLocations activeCond s defaultExprs locations =
                                           argsN <- mapM getN argsE
                                           return (args, argsN)
         locArgList (_,NodeUsage _ n _) = do nEnv  <- lookupNode n
-                                            let args = Map.keys (nodeEnvOut nEnv)
-                                            argsN <- mapM getN $ nodeEnvOut nEnv
-                                            return (args, Map.elems argsN)
+                                            let args = map fst $ nodeEnvOut nEnv
+                                            argsN <- mapM (getN . snd) $ nodeEnvOut nEnv
+                                            return (args, argsN)
 
     declareLocTransitions :: Ident i =>
                              Maybe (i, TypedExpr)
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 88463c4..791af0c 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -29,7 +29,7 @@ import Internal.Monads
 
 data NodeEnv i = NodeEnv
                  { nodeEnvIn :: [TypedExpr]
-                 , nodeEnvOut :: Map i (TypedExpr)
+                 , nodeEnvOut :: [(i, TypedExpr)]
                  , nodeEnvVars :: VarEnv i
                  }
 

From 6ca2846a04500e6c9762ab5d5290a4b161441904 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 21 Oct 2015 18:28:11 +0200
Subject: [PATCH 067/104] Automatons now activated conditionally each step

---
 lamaSMT/lib/Transform.hs | 76 ++++++++++++++++++++++------------------
 1 file changed, 41 insertions(+), 35 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 42e6ce0..4edecc1 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -118,7 +118,7 @@ declareEnum (t, EnumDef cs) =
         liftSMT (declareType (undefined :: SMTEnum) ann) >> return (t, ann)
 
 declareDecls :: Ident i =>
-                Maybe (TypedExpr)
+                Maybe (i, TypedExpr)
                 -> Set i
                 -> Declarations i
                 -> DeclM i ([Definition], Map i (Node i))
@@ -186,7 +186,7 @@ enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
 -- declared. The other nodes are deferred to be declared in the corresponding
 -- location (see declareAutomaton and declareLocations).
 declareNode :: Ident i =>
-               Maybe (TypedExpr) -> i -> Node i -> DeclM i [Definition]
+               Maybe (i, TypedExpr) -> i -> Node i -> DeclM i [Definition]
 declareNode active nName nDecl = 
   do (interface, defs) <- localVarEnv (const emptyVarEnv) $
                           declareNode' active nDecl
@@ -194,7 +194,7 @@ declareNode active nName nDecl =
      return defs
   where
     declareNode' :: Ident i =>
-                    Maybe (TypedExpr) -> Node i
+                    Maybe (i, TypedExpr) -> Node i
                     -> DeclM i (NodeEnv i, [Definition])
     declareNode' activeCond n =
       do let automNodes =
@@ -228,7 +228,7 @@ getNodesInLocations = mconcat . map getUsedLoc . automLocations
 -- | Creates definitions for instant definitions. In case of a node usage this
 -- may produce multiple definitions. If 
 declareInstantDef :: Ident i =>
-                     Maybe (TypedExpr)
+                     Maybe (i, TypedExpr)
                      -> InstantDefinition i
                      -> DeclM i [Definition]
 declareInstantDef activeCond inst@(InstantExpr x e) =
@@ -253,7 +253,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
 -- used to further refine this instant (e.g. wrap it into an ite).
 -- This may also return definitions of the parameters of a node.
 -- The activation condition is only used for the inputs of a node.
-trInstant :: Ident i => Maybe (TypedExpr) -> InstantDefinition i -> DeclM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
+trInstant :: Ident i => Maybe (i, TypedExpr) -> InstantDefinition i -> DeclM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
 trInstant _ (InstantExpr _ e) = return (runTransM $ trExpr e, [])
 trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
@@ -283,7 +283,7 @@ trOutput map = do
 -- x' = (ite c e x) where e is the defining expression. Otherwise it is just
 -- x' = e.
 declareTransition :: Ident i =>
-                     Maybe (TypedExpr)
+                     Maybe (i, TypedExpr)
                      -> StateTransition i
                      -> DeclM i Definition
 declareTransition activeCond (StateTransition x e) =
@@ -301,7 +301,7 @@ declareTransition activeCond (StateTransition x e) =
 -- stream of /x/ which will be defined, can be specified by modPos
 -- (see declareDef).
 declareConditionalAssign :: Ident i =>
-                            Maybe (TypedExpr)
+                            Maybe (i, TypedExpr)
                             -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
                             -> TypedExpr
                             -> Set i
@@ -309,11 +309,15 @@ declareConditionalAssign :: Ident i =>
                             -> Bool
                             -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
                             -> DeclM i Definition
-declareConditionalAssign activeCond defaultExpr x al ns succ ef =
+declareConditionalAssign activeCond defaultExpr x as ns succ ef =
   case activeCond of
-    Nothing -> declareDef x al ns succ ef
-    Just c  ->
-      declareDef x al ns succ (\env t -> liftIte c (ef env t) (defaultExpr env t))
+    Nothing -> declareDef x as ns succ ef
+    Just (ident, c)  -> do
+      condN <- getN c
+      let condExpr = mkTyped (AtExpr (AtomVar (ident))) $ varDefType c
+          arg      = getArgSet condExpr
+          condVar  = runTransM $ trExpr condExpr
+      declareDef x (Set.union as arg) ([condN] ++ ns) succ (\env t -> liftIte (condVar env t) (ef env t) (defaultExpr env t))
 
 -- | Creates a definition for a given variable. Whereby a function to
 -- manipulate the stream position at which it is defined is used (normally
@@ -352,7 +356,7 @@ getTypedAnnotation ns = mapM getTypedAnnotation' ns
                      EnumExpr (Var _ k) -> EnumAnnotation k
                      ProdExpr k -> ProdAnnotation $ fmap getTypedAnnCases k
 
-declareFlow :: Ident i => Maybe (TypedExpr) -> Flow i -> DeclM i [Definition]
+declareFlow :: Ident i => Maybe (i, TypedExpr) -> Flow i -> DeclM i [Definition]
 declareFlow activeCond f =
   do defDefs        <- fmap concat
                        . mapM (declareInstantDef activeCond)
@@ -370,13 +374,14 @@ declareFlow activeCond f =
 --    conditions (mkTransitionEq)
 -- * asserting the initial location
 declareAutomaton :: Ident i =>
-                    Maybe (TypedExpr)
+                    Maybe (i, TypedExpr)
                     -> Map i (Node i)
                     -> (Int, Automaton i)
                     -> DeclM i [Definition]
 declareAutomaton activeCond localNodes (_, a) =
   do automIndex <- nextAutomatonIndex
      let automName = "Autom" ++ show automIndex
+         condName  = automName ++ "_active"
          enumName  = fromString $ automName ++ "States"
          stateT    = EnumType enumName
          locNames  =
@@ -396,7 +401,7 @@ declareAutomaton activeCond localNodes (_, a) =
                    (selId, sel)
                   ]
                 )
-     locDefs <- (flip runReaderT (locCons, localNodes))
+     locDefs <- (flip runReaderT ((locCons, localNodes), condName))
                 $ declareLocations activeCond act
                 (automDefaults a) (automLocations a)
      enumAnn <- lookupEnumAnn enumName
@@ -466,19 +471,19 @@ extractAssigns = foldl addLocExprs (Map.empty, Map.empty)
 -- beforehand and the undeclared nodes which are used in one of the
 -- locations of the automata to be defined.
 type AutomTransM i =
-  ReaderT (Map (LocationId i) (EnumConstr i), Map i (Node i)) (DeclM i)
+  ReaderT ((Map (LocationId i) (EnumConstr i), Map i (Node i)), String) (DeclM i)
 
 lookupLocName :: Ident i => LocationId i -> AutomTransM i (EnumConstr i)
 lookupLocName l
-  = asks fst >>= lookupErr ("Unknown location " ++ identPretty l) l
+  = asks (fst . fst) >>= lookupErr ("Unknown location " ++ identPretty l) l
 
 lookupLocalNode :: Ident i => i -> AutomTransM i (Node i)
 lookupLocalNode n
-  = asks snd >>= lookupErr ("Unknow local node " ++ identPretty n) n
+  = asks (snd .fst) >>= lookupErr ("Unknow local node " ++ identPretty n) n
 
 -- | Declares the data flow inside the locations of an automaton.
 declareLocations :: Ident i =>
-                    Maybe (TypedExpr)
+                    Maybe (i, TypedExpr)
                     -> TypedExpr
                     -> Map i (Expr i)
                     -> [Location i]
@@ -495,7 +500,7 @@ declareLocations activeCond s defaultExprs locations =
         return $ instDefs ++ transDefs
   where
     declareLocDefs :: Ident i =>
-                      Maybe (TypedExpr)
+                      Maybe (i, TypedExpr)
                       -> Map i (Expr i)
                       -> (i, [(LocationId i, InstantDefinition i)])
                       -> AutomTransM i [Definition]
@@ -517,7 +522,7 @@ declareLocations activeCond s defaultExprs locations =
                                            return $ Map.keysSet (nodeEnvOut nEnv)
 
     declareLocTransitions :: Ident i =>
-                             Maybe (TypedExpr)
+                             Maybe (i, TypedExpr)
                              -> (i, [(LocationId i, StateTransition i)])
                              -> AutomTransM i Definition
     declareLocTransitions active (x, locs) =
@@ -539,11 +544,11 @@ declareLocations activeCond s defaultExprs locations =
                 $ lookupErr (identPretty x ++ " not fully defined") x defaults
 
     isFullyDefined locDefs =
-      do locNames <- asks fst
+      do locNames <- asks (fst . fst)
          return $ (Map.keysSet locNames) == (Set.fromList $ map fst locDefs)
 
 declareLocDef :: Ident i =>
-                 Maybe (TypedExpr)
+                 Maybe (i, TypedExpr)
                  -> TypedExpr
                  -> Maybe (Expr i)
                  -> [(LocationId i, InstantDefinition i)]
@@ -561,17 +566,17 @@ declareLocDef activeCond s defaultExpr locs =
        innerPat locs'
   where
     trLocInstant :: Ident i =>
-                    Maybe (TypedExpr)
+                    Maybe (i, TypedExpr)
                     -> LocationId i
                     -> InstantDefinition i
                     -> AutomTransM i (Env i -> [(i, TypedExpr)] -> TypedExpr, [Definition])
     trLocInstant _ _ inst@(InstantExpr _ _) =
       lift $ trInstant (error "no activation condition required") inst
     trLocInstant active l inst@(NodeUsage _ n _) =
-      do (locActive, activeDef) <- mkLocationActivationCond active s l
+      do (identActive, locActive, activeDef) <- mkLocationActivationCond active s l
          node                   <- lookupLocalNode n
-         nodeDefs               <- lift $ declareNode (Just locActive) n node
-         (r, inpDefs)           <- lift $ trInstant (Just locActive) inst
+         nodeDefs               <- lift $ declareNode (Just (identActive, locActive)) n node
+         (r, inpDefs)           <- lift $ trInstant (Just (identActive, locActive)) inst
          return (r, [activeDef] ++ nodeDefs ++ inpDefs)
 
 trLocTransition :: Ident i =>
@@ -606,27 +611,28 @@ mkLocationMatch (EnumExpr s) f l lExpr =
 -- | Creates a variable which is true iff the given activation
 -- condition is true and the the given location is active.
 mkLocationActivationCond :: Ident i =>
-                            Maybe (TypedExpr)
+                            Maybe (i, TypedExpr)
                             -> TypedExpr
                             -> LocationId i
-                            -> AutomTransM i (TypedExpr, Definition)
+                            -> AutomTransM i (i, TypedExpr, Definition)
 mkLocationActivationCond activeCond e l =
-  do lCons <- lookupLocName l
+  do condName <- asks snd
+     lCons <- lookupLocName l
      lEnum <- lift $ trEnumConsAnn lCons <$> lookupEnumConsAnn lCons
      let cond = \_env t -> BoolExpr $ (unEnum $ snd $ last t) .==. lEnum
-     activeVar <- liftSMT $ fmap BoolExpr $ var
+     activeVar <- liftSMT $ fmap BoolExpr $ varNamed condName
      lift $ putVar activeVar
      argN <- lift $ getN e
      def <- lift $ declareConditionalAssign activeCond
             (const $ const $ BoolExpr $ constant False) activeVar Set.empty [argN] False cond
-     return (activeVar, def)
+     return (fromString condName, activeVar, def)
 
 -- | Creates two equations for the edges. The first calculates
 -- the next location (act). This is a chain of ite for each state surrounded
 -- by a match on the last location (sel). The definition of sel is just
 -- the saving of act for the next cycle.
 mkTransitionEq :: Ident i =>
-                  Maybe (TypedExpr)
+                  Maybe (i, TypedExpr)
                   -> Type i
                   -> Map (LocationId i) (EnumConstr i)
                   -> i
@@ -720,7 +726,7 @@ assertInit (x, e) =
 
 -- | Creates a definition for a precondition p. If an activation condition c
 -- is given, the resulting condition is (=> c p).
-declarePrecond :: Ident i => Maybe (TypedExpr) -> Expr i -> DeclM i Definition
+declarePrecond :: Ident i => Maybe (i, TypedExpr) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
   do env      <- get
      let args = getArgSet e
@@ -729,7 +735,7 @@ declarePrecond activeCond e =
      ann      <- getTypedAnnotation argsN
      d        <- case activeCond of
        Nothing -> defFunc boolT ann $ \a -> runTransM (trExpr e) env (zip (Set.toList $ args) a)
-       Just c -> defFunc boolT ann $
+       Just (ident, c) -> defFunc boolT ann $
                  \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) c e')
@@ -737,7 +743,7 @@ declarePrecond activeCond e =
      return $ ensureDefinition argsN False d
 
 declareInvariant :: Ident i =>
-                    Maybe (TypedExpr) -> Expr i -> DeclM i Definition
+                    Maybe (i, TypedExpr) -> Expr i -> DeclM i Definition
 declareInvariant = declarePrecond
 
 trConstExpr :: Ident i => ConstExpr i -> DeclM i (TypedExpr)

From 5280edefcd19d2d469f98ad1aa3015f207097bf6 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 21 Oct 2015 18:29:36 +0200
Subject: [PATCH 068/104] Bumped LamaSMT version to 0.2

---
 lamaSMT/LamaSMT.cabal | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/lamaSMT/LamaSMT.cabal b/lamaSMT/LamaSMT.cabal
index eeb0587..c38b050 100644
--- a/lamaSMT/LamaSMT.cabal
+++ b/lamaSMT/LamaSMT.cabal
@@ -1,5 +1,5 @@
 Name:           LamaSMT
-Version:        0.1
+Version:        0.2
 Build-Type:     Simple
 Cabal-Version:  >= 1.10
 Description:
@@ -15,4 +15,4 @@ Executable lamasmt
   GHC-Options: -Wall -rtsopts
   other-modules:
     Transform
-  Main-Is: Main.hs
\ No newline at end of file
+  Main-Is: Main.hs

From b6bec08223932178d383dac48dea0acab0174e26 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 4 Nov 2015 13:11:42 +0100
Subject: [PATCH 069/104] Ident for location match enum

---
 lamaSMT/lib/Transform.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 4edecc1..71e4267 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -514,7 +514,7 @@ declareLocations activeCond s defaultExprs locations =
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-
-           lift $ declareConditionalAssign active xBottom xVar args argsN False res
+           lift $ declareConditionalAssign active xBottom xVar (Set.insert (fromString "dummyForLocEnum") args) argsN False res
          return $ inpDefs ++ [def]
       where
         locArgSet (_,InstantExpr _ e) = return $ getArgSet e
@@ -533,7 +533,7 @@ declareLocations activeCond s defaultExprs locations =
          argsE          <- mapM lookupVar $ Set.toList args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def         <-
-           lift $ declareConditionalAssign active (runTransM $ trExpr defExpr) xVar args argsN True res
+           lift $ declareConditionalAssign active (runTransM $ trExpr defExpr) xVar (Set.insert (fromString "dummyForLocEnum") args) argsN True res
          return def
 
     getDefault defaults x locs =

From d3f5681529bf518858bbd9013d5db94f06c4f103 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 9 Nov 2015 14:26:37 +0100
Subject: [PATCH 070/104] Replaced set of idents through list of idents

---
 lamaSMT/lib/Transform.hs | 84 ++++++++++++++++++++--------------------
 1 file changed, 42 insertions(+), 42 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 71e4267..33faa68 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -234,8 +234,8 @@ declareInstantDef :: Ident i =>
 declareInstantDef activeCond inst@(InstantExpr x e) =
   do (res, []) <- trInstant (error "no activation condition") inst
      xVar <- lookupVar x
-     let args = getArgSet e
-     argsE <- mapM lookupVar $ Set.toList args
+     let args = getArgList e
+     argsE <- mapM lookupVar args
      argsN <- mapM getN argsE
      def <- declareConditionalAssign
             activeCond (const $ const $ getBottom xVar) xVar args argsN False res
@@ -246,7 +246,7 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
      nEnv            <- lookupNode n
      outN            <- mapM getN $ nodeEnvOut nEnv
      outpDef         <- declareConditionalAssign
-                        activeCond (const $ const $ getBottom xVar) xVar (Map.keysSet $ nodeEnvOut nEnv) (Map.elems outN) False outp
+                        activeCond (const $ const $ getBottom xVar) xVar (Map.keys $ nodeEnvOut nEnv) (Map.elems outN) False outp
      return $ inpDefs ++ [outpDef]
 
 -- | Translates an instant definition into a function which can be
@@ -259,12 +259,12 @@ trInstant inpActive (NodeUsage _ n es) =
   do nEnv <- lookupNode n
      let esTr = map (runTransM . trExpr) es
          y    = runTransM $ trOutput $ nodeEnvOut nEnv
-         ins = map (Set.toList . getArgSet) es
+         ins = map getArgList es
      insE <- mapM (mapM lookupVar) ins
      insN <- mapM (mapM getN) insE
      inpDefs  <- mapM (\(x, n, e, eTr) ->
                         declareConditionalAssign
-                        inpActive (const $ const $ getBottom x) x (getArgSet e) n False eTr)
+                        inpActive (const $ const $ getBottom x) x (getArgList e) n False eTr)
                  $ zip4 (nodeEnvIn nEnv) insN es esTr
      return (y, inpDefs)
 
@@ -290,8 +290,8 @@ declareTransition activeCond (StateTransition x e) =
   do xVar     <- lookupVar x
      let e'      = runTransM $ trExpr e
          defExpr = mkTyped (AtExpr (AtomVar x)) $ varDefType xVar
-         args    = Set.union (getArgSet e) (getArgSet defExpr)
-     argsE <- mapM lookupVar $ Set.toList args
+         args    = getArgList defExpr ++ getArgList e
+     argsE <- mapM lookupVar args
      argsN <- mapM getN argsE
      declareConditionalAssign activeCond (runTransM $ trExpr defExpr) xVar args argsN True e'
 
@@ -304,7 +304,7 @@ declareConditionalAssign :: Ident i =>
                             Maybe (i, TypedExpr)
                             -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
                             -> TypedExpr
-                            -> Set i
+                            -> [i]
                             -> [Int]
                             -> Bool
                             -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
@@ -315,16 +315,16 @@ declareConditionalAssign activeCond defaultExpr x as ns succ ef =
     Just (ident, c)  -> do
       condN <- getN c
       let condExpr = mkTyped (AtExpr (AtomVar (ident))) $ varDefType c
-          arg      = getArgSet condExpr
+          arg      = getArgList condExpr
           condVar  = runTransM $ trExpr condExpr
-      declareDef x (Set.union as arg) ([condN] ++ ns) succ (\env t -> liftIte (condVar env t) (ef env t) (defaultExpr env t))
+      declareDef x (arg ++ as) ([condN] ++ ns) succ (\env t -> liftIte (condVar env t) (ef env t) (defaultExpr env t))
 
 -- | Creates a definition for a given variable. Whereby a function to
 -- manipulate the stream position at which it is defined is used (normally
 -- id or succ' to define instances or state transitions).
 -- The second argument /x/ is the stream to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
-declareDef :: Ident i => TypedExpr -> Set i -> [Int] -> Bool ->
+declareDef :: Ident i => TypedExpr -> [i] -> [Int] -> Bool ->
               (Env i -> [(i, TypedExpr)] -> TypedExpr) -> DeclM i Definition
 declareDef x as ns succ ef =
   do env         <- get
@@ -332,7 +332,7 @@ declareDef x as ns succ ef =
      xN          <- getN x
      ann         <- getTypedAnnotation $ [xN] ++ ns
      d           <- defFunc defType ann
-                    $ \a -> liftRel (.==.) (head a) $ ef env $ zip ((Set.toList as) ++ [error "Last argument must not be evaluated!"]) (tail a)
+                    $ \a -> liftRel (.==.) (head a) $ ef env $ zip (as ++ [error "Last argument must not be evaluated!"]) (tail a)
      let argsN   = ([xN] ++ ns)
      putTerm argsN d
      return $ ensureDefinition argsN succ d
@@ -508,18 +508,18 @@ declareLocations activeCond s defaultExprs locations =
       do defaultExpr    <- getDefault defaults x locs
          (res, inpDefs) <- declareLocDef active s defaultExpr locs
          xVar           <- lookupVar x
-         argss          <- lift $ mapM locArgSet locs
+         argss          <- lift $ mapM locArgList locs
          let xBottom    = const $ const $ getBottom xVar
-             args       = Set.unions argss
-         argsE          <- mapM lookupVar $ Set.toList args
+             args       = concat argss
+         argsE          <- mapM lookupVar args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-
-           lift $ declareConditionalAssign active xBottom xVar (Set.insert (fromString "dummyForLocEnum") args) argsN False res
+           lift $ declareConditionalAssign active xBottom xVar (args ++ [fromString "dummyForLocEnum"]) argsN False res
          return $ inpDefs ++ [def]
       where
-        locArgSet (_,InstantExpr _ e) = return $ getArgSet e
-        locArgSet (_,NodeUsage _ n _) = do nEnv <- lookupNode n
-                                           return $ Map.keysSet (nodeEnvOut nEnv)
+        locArgList (_,InstantExpr _ e) = return $ getArgList e
+        locArgList (_,NodeUsage _ n _) = do nEnv <- lookupNode n
+                                            return $ Map.keys (nodeEnvOut nEnv)
 
     declareLocTransitions :: Ident i =>
                              Maybe (i, TypedExpr)
@@ -529,11 +529,11 @@ declareLocations activeCond s defaultExprs locations =
       do res         <- trLocTransition s locs
          xVar     <- lookupVar x
          let defExpr    = mkTyped (AtExpr (AtomVar x)) $ varDefType xVar
-             args       = Set.unions $ (map (\(_,StateTransition _ e) -> getArgSet e) locs) ++ [getArgSet defExpr]
-         argsE          <- mapM lookupVar $ Set.toList args
+             args       = concat $ (map (\(_,StateTransition _ e) -> getArgList e) locs) ++ [getArgList defExpr]
+         argsE          <- mapM lookupVar args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def         <-
-           lift $ declareConditionalAssign active (runTransM $ trExpr defExpr) xVar (Set.insert (fromString "dummyForLocEnum") args) argsN True res
+           lift $ declareConditionalAssign active (runTransM $ trExpr defExpr) xVar (args ++ [fromString "dummyForLocEnum"]) argsN True res
          return def
 
     getDefault defaults x locs =
@@ -624,7 +624,7 @@ mkLocationActivationCond activeCond e l =
      lift $ putVar activeVar
      argN <- lift $ getN e
      def <- lift $ declareConditionalAssign activeCond
-            (const $ const $ BoolExpr $ constant False) activeVar Set.empty [argN] False cond
+            (const $ const $ BoolExpr $ constant False) activeVar [] [argN] False cond
      return (fromString condName, activeVar, def)
 
 -- | Creates two equations for the edges. The first calculates
@@ -649,10 +649,10 @@ mkTransitionEq activeCond locationEnumTy locationEnumConstrs act sel es bot =
                            AtomVar sel) locationEnumTy) . Map.toList
                            $ foldr addEdge Map.empty es
                        inst = InstantExpr act e
-                       args = getArgSet e
+                       args = getArgList e
                    (res, []) <- trInstant (error "no activation condition") inst
                    xVar <- lookupVar act
-                   argsE <- mapM lookupVar $ Set.toList args
+                   argsE <- mapM lookupVar args
                    argsN <- mapM getN argsE
                    def <- declareConditionalAssign activeCond (const $ const $ bot) xVar args argsN False res
                    return [def]
@@ -660,8 +660,8 @@ mkTransitionEq activeCond locationEnumTy locationEnumConstrs act sel es bot =
        xVar     <- lookupVar sel
        let e'      = runTransM $ trExpr (mkTyped (AtExpr $ AtomVar act) locationEnumTy)
            defExpr = mkTyped (AtExpr (AtomVar sel)) $ varDefType xVar
-           args    = Set.union (getArgSet (mkTyped (AtExpr $ AtomVar act) locationEnumTy)) (getArgSet defExpr)
-       argsE <- mapM lookupVar $ Set.toList args
+           args    = (getArgList defExpr) ++ (getArgList (mkTyped (AtExpr $ AtomVar act) locationEnumTy))
+       argsE <- mapM lookupVar args
        argsN <- mapM getN argsE
        declareConditionalAssign activeCond (runTransM $ trExpr defExpr) xVar args argsN True e'
      return $ stateDef ++ [stateTr]
@@ -729,14 +729,14 @@ assertInit (x, e) =
 declarePrecond :: Ident i => Maybe (i, TypedExpr) -> Expr i -> DeclM i Definition
 declarePrecond activeCond e =
   do env      <- get
-     let args = getArgSet e
-     argsE    <- mapM lookupVar $ Set.toList args
+     let args = getArgList e
+     argsE    <- mapM lookupVar args
      argsN    <- mapM getN argsE
      ann      <- getTypedAnnotation argsN
      d        <- case activeCond of
-       Nothing -> defFunc boolT ann $ \a -> runTransM (trExpr e) env (zip (Set.toList $ args) a)
+       Nothing -> defFunc boolT ann $ \a -> runTransM (trExpr e) env $ zip args a
        Just (ident, c) -> defFunc boolT ann $
-                 \a -> (flip (flip runTransM env) (zip (Set.toList $ args) a))
+                 \a -> (flip (flip runTransM env) (zip args a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) c e')
      putTerm argsN d
@@ -785,17 +785,17 @@ askStreamPos :: TransM i StreamPos
 askStreamPos = asks fst
 -}
 
-getArgSet :: Ident i => Expr i -> Set i
-getArgSet expr = case untyped expr of
-  AtExpr (AtomConst c)  -> Set.empty
-  AtExpr (AtomVar x)    -> Set.singleton x
-  AtExpr (AtomEnum x)   -> Set.empty
-  LogNot e              -> getArgSet e
-  Expr2 op e1 e2        -> Set.union (getArgSet e1) (getArgSet e2)
-  Ite c e1 e2           -> Set.unions [getArgSet c, getArgSet e1, getArgSet e2]
-  ProdCons (Prod es)    -> foldr (Set.union . getArgSet) Set.empty es
-  Project x i           -> Set.singleton x
-  Match e pats -> Set.unions $ [getArgSet e] ++ map (\(Pattern _ x) -> getArgSet x) pats
+getArgList :: Ident i => Expr i ->  [i]
+getArgList expr = case untyped expr of
+  AtExpr (AtomConst c)  -> []
+  AtExpr (AtomVar x)    -> [x]
+  AtExpr (AtomEnum x)   -> []
+  LogNot e              -> getArgList e
+  Expr2 op e1 e2        -> getArgList e2 ++ getArgList e1
+  Ite c e1 e2           -> getArgList e2 ++ getArgList e1 ++ getArgList c
+  ProdCons (Prod es)    -> foldr ((++) . getArgList) [] es
+  Project x i           -> [x]
+  Match e pats -> concat $ [getArgList e] ++ map (\(Pattern _ x) -> getArgList x) pats
 
 -- we do no further type checks since this
 -- has been done beforehand.

From d440cf69c4a478e97753741ec0c0fb5b30e69d03 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 9 Nov 2015 15:06:25 +0100
Subject: [PATCH 071/104] Default expression's arguments added to argument list

---
 lamaSMT/lib/Transform.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 33faa68..9d45eec 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -38,6 +38,7 @@ import Prelude hiding (mapM)
 import Data.Traversable
 import Data.Foldable (foldlM, foldrM)
 import Data.Monoid
+import Data.Maybe
 
 import Control.Monad.Trans.Class
 import Control.Monad.State (StateT(..), MonadState(..), gets)
@@ -510,7 +511,7 @@ declareLocations activeCond s defaultExprs locations =
          xVar           <- lookupVar x
          argss          <- lift $ mapM locArgList locs
          let xBottom    = const $ const $ getBottom xVar
-             args       = concat argss
+             args       = concat argss ++ maybe [] getArgList defaultExpr
          argsE          <- mapM lookupVar args
          argsN          <- lift $ mapM getN (argsE ++ [s])
          def            <-

From 0c23586911e873cce7154b835e938b77935e6a02 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 21 Oct 2015 22:14:07 +0200
Subject: [PATCH 072/104] Corrected bug with node returns

---
 lamaSMT/lib/Transform.hs | 21 ++++++++++++++-------
 1 file changed, 14 insertions(+), 7 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 9d45eec..22e32f2 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -511,16 +511,23 @@ declareLocations activeCond s defaultExprs locations =
          xVar           <- lookupVar x
          argss          <- lift $ mapM locArgList locs
          let xBottom    = const $ const $ getBottom xVar
-             args       = concat argss ++ maybe [] getArgList defaultExpr
-         argsE          <- mapM lookupVar args
-         argsN          <- lift $ mapM getN (argsE ++ [s])
+             args       = concat $ map (\(s, _) -> s) argss ++ [maybe [] getArgList defaultExpr]
+
+             argsN      = snd $ foldl (\(_, a) (_, b) -> (Set.empty, a ++ b)) (Set.empty, []) argss
+         argsNs         <- lift $ getN s
          def            <-
-           lift $ declareConditionalAssign active xBottom xVar (args ++ [fromString "dummyForLocEnum"]) argsN False res
+           lift $ declareConditionalAssign active xBottom xVar (args ++[fromString "dummyForLocEnum"]) (argsN ++ [argsNs])False res
          return $ inpDefs ++ [def]
       where
-        locArgList (_,InstantExpr _ e) = return $ getArgList e
-        locArgList (_,NodeUsage _ n _) = do nEnv <- lookupNode n
-                                            return $ Map.keys (nodeEnvOut nEnv)
+        locArgList (_,InstantExpr _ e) = do 
+                                          let args = getArgList e
+                                          argsE <- mapM lookupVar args
+                                          argsN <- mapM getN argsE
+                                          return (args, argsN)
+        locArgList (_,NodeUsage _ n _) = do nEnv  <- lookupNode n
+                                            let args = Map.keys (nodeEnvOut nEnv)
+                                            argsN <- mapM getN $ nodeEnvOut nEnv
+                                            return (args, Map.elems argsN)
 
     declareLocTransitions :: Ident i =>
                              Maybe (i, TypedExpr)

From 6b3096e315b2b089997df59361f3acc181704156 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 10 Nov 2015 19:23:42 +0100
Subject: [PATCH 073/104] Correct default values not being added to argument
 list

---
 lamaSMT/lib/Transform.hs | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 22e32f2..dede794 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -511,12 +511,14 @@ declareLocations activeCond s defaultExprs locations =
          xVar           <- lookupVar x
          argss          <- lift $ mapM locArgList locs
          let xBottom    = const $ const $ getBottom xVar
-             args       = concat $ map (\(s, _) -> s) argss ++ [maybe [] getArgList defaultExpr]
-
-             argsN      = snd $ foldl (\(_, a) (_, b) -> (Set.empty, a ++ b)) (Set.empty, []) argss
+             argDefault  = maybe [] getArgList defaultExpr
+         argDefaultE    <- mapM lookupVar argDefault
+         argDefaultN    <- lift $ mapM getN argDefaultE
+         let args       = concat $ map fst argss ++ [argDefault]
+             argsN      = concat $ map snd argss ++ [argDefaultN]
          argsNs         <- lift $ getN s
          def            <-
-           lift $ declareConditionalAssign active xBottom xVar (args ++[fromString "dummyForLocEnum"]) (argsN ++ [argsNs])False res
+           lift $ declareConditionalAssign active xBottom xVar (args ++ [fromString "dummyForLocEnum"]) (argsN ++ [argsNs]) False res
          return $ inpDefs ++ [def]
       where
         locArgList (_,InstantExpr _ e) = do 

From 207a1e1106610df59163a3227c06d1b6462276e1 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 11 Nov 2015 00:34:45 +0100
Subject: [PATCH 074/104] Brought node output in right order with list instead
 of map

---
 lamaSMT/lib/Model.hs        |  6 +++---
 lamaSMT/lib/Transform.hs    | 18 +++++++++---------
 lamaSMT/lib/TransformEnv.hs |  2 +-
 3 files changed, 13 insertions(+), 13 deletions(-)

diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index 71ede51..a0e69be 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -43,7 +43,7 @@ data Model i = Model
 
 data NodeModel i = NodeModel
                    { nodeModelIn :: [ValueStream]
-                   , nodeModelOut :: Map i ValueStream
+                   , nodeModelOut :: [ValueStream]
                    , nodeModelVars :: Model i
                    } deriving Show
 
@@ -59,7 +59,7 @@ prettyNodes = vcat . map (\(x, n) -> (ptext $ identString x) <+> prettyNodeModel
 prettyNodeModel :: Ident i => NodeModel i -> Doc
 prettyNodeModel m = braces . nest 2 $
   text "Inputs:" $+$ nest 2 (vcat . map prettyStream $ nodeModelIn m) $+$
-  text "Outputs:" $+$ nest 2 (vcat . map prettyStream $ Map.elems $ nodeModelOut m) $+$
+  text "Outputs:" $+$ nest 2 (vcat . map prettyStream $ nodeModelOut m) $+$
   prettyModel (nodeModelVars m)
 
 prettyStream :: ValueStream -> Doc
@@ -88,7 +88,7 @@ getModel' env =
 
 getNodeModel :: NodeEnv i -> ModelM (NodeModel i)
 getNodeModel (NodeEnv i o e) =
-  NodeModel <$> mapM getVarModel i <*> getVarsModel o <*> getModel' e
+  NodeModel <$> mapM getVarModel i <*> mapM (getVarModel . snd) o <*> getModel' e
 
 getVarsModel :: Map i (TypedExpr) -> ModelM (Map i ValueStream)
 getVarsModel = mapM getVarModel
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index dede794..2f070e1 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -204,7 +204,7 @@ declareNode active nName nDecl =
            declareDecls activeCond automNodes $ nodeDecls n
          outDecls <- declareVarList $ nodeOutputs n
          ins <- mapM (lookupVar . varIdent) . declsInput $ nodeDecls n
-         let outs = Map.fromList outDecls
+         let outs = outDecls
          modifyVars $ Map.union (Map.fromList outDecls)
          flowDefs <- declareFlow activeCond $ nodeFlow n
          automDefs <-
@@ -245,9 +245,9 @@ declareInstantDef activeCond inst@(NodeUsage x n _) =
   do (outp, inpDefs) <- trInstant activeCond inst
      xVar            <- lookupVar x
      nEnv            <- lookupNode n
-     outN            <- mapM getN $ nodeEnvOut nEnv
+     outN            <- mapM (\(_, e) -> getN e) $ nodeEnvOut nEnv
      outpDef         <- declareConditionalAssign
-                        activeCond (const $ const $ getBottom xVar) xVar (Map.keys $ nodeEnvOut nEnv) (Map.elems outN) False outp
+                        activeCond (const $ const $ getBottom xVar) xVar (map fst $ nodeEnvOut nEnv) outN False outp
      return $ inpDefs ++ [outpDef]
 
 -- | Translates an instant definition into a function which can be
@@ -269,10 +269,10 @@ trInstant inpActive (NodeUsage _ n es) =
                  $ zip4 (nodeEnvIn nEnv) insN es esTr
      return (y, inpDefs)
 
-trOutput :: Ident i => Map i (TypedExpr) -> TransM i (TypedExpr)
-trOutput map = do
+trOutput :: Ident i => [(i, TypedExpr)] -> TransM i (TypedExpr)
+trOutput m = do
                  s <- ask
-                 outList <- mapM (trOutput' s) (Map.toList map)
+                 outList <- mapM (trOutput' s) m
                  return $ mkProdExpr outList
                where
                  trOutput' s (i, te) = case lookup i (fst s) of
@@ -527,9 +527,9 @@ declareLocations activeCond s defaultExprs locations =
                                           argsN <- mapM getN argsE
                                           return (args, argsN)
         locArgList (_,NodeUsage _ n _) = do nEnv  <- lookupNode n
-                                            let args = Map.keys (nodeEnvOut nEnv)
-                                            argsN <- mapM getN $ nodeEnvOut nEnv
-                                            return (args, Map.elems argsN)
+                                            let args = map fst $ nodeEnvOut nEnv
+                                            argsN <- mapM (getN . snd) $ nodeEnvOut nEnv
+                                            return (args, argsN)
 
     declareLocTransitions :: Ident i =>
                              Maybe (i, TypedExpr)
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index cb90c12..958f50f 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -32,7 +32,7 @@ import Internal.Monads
 
 data NodeEnv i = NodeEnv
                  { nodeEnvIn :: [TypedExpr]
-                 , nodeEnvOut :: Map i (TypedExpr)
+                 , nodeEnvOut :: [(i, TypedExpr)]
                  , nodeEnvVars :: VarEnv i
                  }
 

From 2cbc7f1689462075a94c90a648a961cb8d2538f0 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 11 Nov 2015 11:19:56 +0100
Subject: [PATCH 075/104] Added instantiation set for integers

---
 lamaSMT/lib/Definition.hs           |  2 +-
 lamaSMT/lib/Strategies/Invariant.hs |  2 +-
 lamaSMT/lib/TransformEnv.hs         | 11 ++++++++---
 3 files changed, 10 insertions(+), 5 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index d02ace8..38a2346 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -43,7 +43,7 @@ data ProgDefs = ProgDefs
 
 data Term =
   BoolTerm [Int] (SMTFunction [TypedExpr] Bool)
-  | IntTerm [Int] (SMTFunction [TypedExpr] Int)
+  | IntTerm [Int] (SMTFunction [TypedExpr] Integer)
   | RealTerm [Int] (SMTFunction [TypedExpr] Rational)
   deriving (Show, Ord, Eq)
 
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index ffe3c13..1097aa4 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -63,7 +63,7 @@ instance StrategyClass Invar where
           n1  <- freshVars vars
           assumeTrace defs (n0, n1)
           let s0 = InductState baseK (vars, k1) (n0, n1)
-                     $ constructRs (instSet env) (GroundType BoolT)
+                     $ constructRs (instSetBool env) (GroundType BoolT)
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
                 $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 958f50f..7d33e5b 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -50,7 +50,8 @@ data Env i = Env
            , varEnv :: VarEnv i
            , currAutomatonIndex :: Integer
            , varList :: [TypedExpr]
-           , instSet :: Set Term
+           , instSetBool :: Set Term
+           , instSetInt :: Set Term
            , natImpl :: NatImplementation
            , enumImpl :: EnumImplementation
            }
@@ -59,7 +60,7 @@ emptyVarEnv :: VarEnv i
 emptyVarEnv = VarEnv Map.empty Map.empty
 
 emptyEnv :: NatImplementation -> EnumImplementation -> Env i
-emptyEnv = Env Map.empty Map.empty Map.empty emptyVarEnv 0 [] Set.empty
+emptyEnv = Env Map.empty Map.empty Map.empty emptyVarEnv 0 [] Set.empty Set.empty
 
 type DeclM i = StateT (Env i) (ErrorT String SMT)
 
@@ -80,7 +81,11 @@ getN x = do vars <- gets varList
 
 putTerm :: Ident i => [Int] -> TypedFunc -> DeclM i ()
 putTerm argsN (BoolFunc t) = 
-  modify $ \env -> env { instSet = Set.insert (BoolTerm argsN t) (instSet env) }
+  modify $ \env -> env { instSetBool = Set.insert (BoolTerm argsN t) (instSetBool env) }
+putTerm argsN (IntFunc t) = 
+  modify $ \env -> env { instSetInt = Set.insert (IntTerm argsN t) (instSetInt env) }
+putTerm argsN _ = 
+  modify $ \env -> env
 
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()
 putEnumAnn eAnns =

From 8c84970b4cc87b5765faaaff141383d072b8bc60 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 11 Nov 2015 12:58:00 +0100
Subject: [PATCH 076/104] Added option for showing number of invariants

---
 lamaSMT/lib/Strategies/Invariant.hs | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 1097aa4..c00280b 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -35,10 +35,11 @@ data GenerateHints =
 data Invar = Invar
                { depth :: Maybe Natural
                , printProgress :: Bool
+               , printInvCount :: Bool
                , generateHints :: GenerateHints }
 
 instance StrategyClass Invar where
-  defaultStrategyOpts = Invar Nothing False NoHints
+  defaultStrategyOpts = Invar Nothing False False NoHints
 
   readOption (stripPrefix "depth=" -> Just d) indOpts =
     case d of
@@ -46,6 +47,8 @@ instance StrategyClass Invar where
       _     -> indOpts { depth = Just $ read d }
   readOption "progress" indOpts =
     indOpts { printProgress = True }
+  readOption "invariant-count" indOpts =
+    indOpts { printInvCount = True }
   readOption (stripPrefix "hints" -> Just r) indOpts =
     case (stripPrefix "=" r) of
          Nothing    -> indOpts { generateHints = LastInductionStep }
@@ -100,6 +103,7 @@ check' :: Invar
 check' indOpts getModel defs pastVars =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
+     liftIO $ when (printInvCount indOpts) (putStrLn $ "Number of Invariants: " ++ (show $ length rs))
      rBMC <- bmcStep getModel defs pastVars kDefs
      case rBMC of
        Just m -> return $ Failure kVal m

From 535a49006d2ab6438766922cb3cc761ff4c331b3 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 23 Nov 2015 13:50:53 +0100
Subject: [PATCH 077/104] Simplification in implementation of getting values
 for filtering

---
 lamaSMT/lib/Strategies/Invariant.hs |  9 ++++-----
 lamaSMT/lib/Transform.hs            | 12 ------------
 lamaSMT/lib/TransformEnv.hs         | 17 +++++++++++++++++
 3 files changed, 21 insertions(+), 17 deletions(-)

diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index c00280b..84b5388 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -144,17 +144,16 @@ filterRs :: MonadSMT m => [(Term, Term)] -> ([TypedExpr], [TypedExpr]) -> m [(Te
 filterRs rs@(r:rss) args = liftSMT $ do push
                                         assertRs args rs
                                         r <- checkSat
-                                        trace (show r ) $ if r
-                                           then do model <- mapM (\(BoolExpr s) -> getValue s) $ fst args
-                                                   let model' = map (\s -> BoolExpr $ constant s) model
+                                        if r
+                                           then do model <- mapM getTypedValue $ fst args
                                                    pop
-                                                   filtered <- filterRs' model' rs
+                                                   filtered <- filterRs' model rs
                                                    filterRs filtered args
                                            else pop >> return rs
 filterRs [] _ = liftSMT $ return []
 
 filterRs' :: MonadSMT m => [TypedExpr] -> [(Term, Term)] -> m [(Term, Term)]
-filterRs' model (r:rs) = liftSMT $ do trace (show r) $ push
+filterRs' model (r:rs) = liftSMT $ do push
                                       assertR model r
                                       e <- checkSat
                                       pop
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 2f070e1..cc0122f 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -53,18 +53,6 @@ import Definition
 import TransformEnv
 import Internal.Monads
 
--- | Gets an "undefined" value for a given type of expression.
--- The expression itself is not further analysed.
--- FIXME: Make behaviour configurable, i.e. bottom can be some
--- default value or a left open stream
--- (atm it does the former).
-getBottom :: TypedExpr -> TypedExpr
-getBottom (BoolExpr _)     = BoolExpr $ constant False
-getBottom (IntExpr _)      = IntExpr  $ constant 0xdeadbeef
-getBottom (RealExpr _)     = RealExpr . constant $ fromInteger 0xdeadbeef
-getBottom (EnumExpr e) = EnumExpr e --evtl. TODO
-getBottom (ProdExpr strs)  = ProdExpr $ fmap getBottom strs
-
 -- | Transforms a LAMA program into a set of formulas which is
 -- directly declared and a set of defining functions. Those functions
 -- can be used to define a cycle by giving it the point in time.
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 7d33e5b..0755f53 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -56,6 +56,18 @@ data Env i = Env
            , enumImpl :: EnumImplementation
            }
 
+-- | Gets an "undefined" value for a given type of expression.
+-- The expression itself is not further analysed.
+-- FIXME: Make behaviour configurable, i.e. bottom can be some
+-- default value or a left open stream
+-- (atm it does the former).
+getBottom :: TypedExpr -> TypedExpr
+getBottom (BoolExpr _)     = BoolExpr $ constant False
+getBottom (IntExpr _)      = IntExpr  $ constant 0xdeadbeef
+getBottom (RealExpr _)     = RealExpr . constant $ fromInteger 0xdeadbeef
+getBottom (EnumExpr e) = EnumExpr e --evtl. TODO
+getBottom (ProdExpr strs)  = ProdExpr $ fmap getBottom strs
+
 emptyVarEnv :: VarEnv i
 emptyVarEnv = VarEnv Map.empty Map.empty
 
@@ -87,6 +99,11 @@ putTerm argsN (IntFunc t) =
 putTerm argsN _ = 
   modify $ \env -> env
 
+getTypedValue :: MonadSMT m => TypedExpr -> m (TypedExpr)
+getTypedValue (BoolExpr s) = liftSMT $ getValue s >>= return . BoolExpr . constant
+getTypedValue (IntExpr s) = liftSMT $ getValue s >>= return . IntExpr . constant
+getTypedValue e = liftSMT $ return $ getBottom e
+
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()
 putEnumAnn eAnns =
   modify $ \env -> env { enumAnn = (enumAnn env) `Map.union` eAnns }

From 6e4b8badb4653cd42492d48536280982958d076b Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 23 Nov 2015 21:54:32 +0100
Subject: [PATCH 078/104] Instantiation sets are now lists instead of Data.Set

---
 lamaSMT/lib/TransformEnv.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 0755f53..eb162fd 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -50,8 +50,8 @@ data Env i = Env
            , varEnv :: VarEnv i
            , currAutomatonIndex :: Integer
            , varList :: [TypedExpr]
-           , instSetBool :: Set Term
-           , instSetInt :: Set Term
+           , instSetBool :: [Term]
+           , instSetInt :: [Term]
            , natImpl :: NatImplementation
            , enumImpl :: EnumImplementation
            }
@@ -72,7 +72,7 @@ emptyVarEnv :: VarEnv i
 emptyVarEnv = VarEnv Map.empty Map.empty
 
 emptyEnv :: NatImplementation -> EnumImplementation -> Env i
-emptyEnv = Env Map.empty Map.empty Map.empty emptyVarEnv 0 [] Set.empty Set.empty
+emptyEnv = Env Map.empty Map.empty Map.empty emptyVarEnv 0 [] [] []
 
 type DeclM i = StateT (Env i) (ErrorT String SMT)
 
@@ -93,9 +93,9 @@ getN x = do vars <- gets varList
 
 putTerm :: Ident i => [Int] -> TypedFunc -> DeclM i ()
 putTerm argsN (BoolFunc t) = 
-  modify $ \env -> env { instSetBool = Set.insert (BoolTerm argsN t) (instSetBool env) }
+  modify $ \env -> env { instSetBool = instSetBool env ++ [BoolTerm argsN t] }
 putTerm argsN (IntFunc t) = 
-  modify $ \env -> env { instSetInt = Set.insert (IntTerm argsN t) (instSetInt env) }
+  modify $ \env -> env { instSetBool = instSetBool env ++ [IntTerm argsN t] }
 putTerm argsN _ = 
   modify $ \env -> env
 

From b6aa00611249a933086319ac045c1532e0efbb6d Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 23 Nov 2015 22:05:05 +0100
Subject: [PATCH 079/104] First implementation of poset graph and assertions

---
 lamaSMT/lib/Definition.hs           | 17 +++++++++++++
 lamaSMT/lib/Strategies/Invariant.hs | 38 ++++++++++++++---------------
 2 files changed, 36 insertions(+), 19 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 38a2346..4c069f8 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -47,6 +47,23 @@ data Term =
   | RealTerm [Int] (SMTFunction [TypedExpr] Rational)
   deriving (Show, Ord, Eq)
 
+type PosetGraphNode = [Term]
+
+data PosetGraph = PosetGraph
+                  { vertices :: [PosetGraphNode]
+                  , edges    :: [(PosetGraphNode, PosetGraphNode)]
+                  }
+
+assertPosetGraph :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> PosetGraph -> m [()]
+assertPosetGraph i (PosetGraph vertices edges) = do mapM (\v -> mapM (\a -> assertRelation (fst i) (a, head v) (.==.)) (tail v)) vertices
+                                                    mapM (\(a, b) -> assertRelation (fst i) (head a, head b) (.=>.)) edges
+                                                   
+
+assertRelation :: MonadSMT m => [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> m ()
+assertRelation i (BoolTerm argsf f, BoolTerm argsg g) r =
+  liftSMT $ assert ((f `app` (lookupArgs argsf False (i, i))) `r`
+    (g `app` (lookupArgs argsg False (i, i))))
+
 constructRs :: Set Term -> Type i -> [(Term, Term)]
 constructRs ts (GroundType BoolT) = [(x,y) | x@(BoolTerm _ _) <- Set.toList ts,
                                       y@(BoolTerm _ _) <- Set.toList ts, x /= y]
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 84b5388..ad669f4 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -65,8 +65,7 @@ instance StrategyClass Invar where
           n0  <- freshVars vars
           n1  <- freshVars vars
           assumeTrace defs (n0, n1)
-          let s0 = InductState baseK (vars, k1) (n0, n1)
-                     $ constructRs (instSetBool env) (GroundType BoolT)
+          let s0 = InductState baseK (vars, k1) (n0, n1) $ PosetGraph [instSetBool env] []
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
                 $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
@@ -84,10 +83,10 @@ checkStep defs vars =
 
 -- | Holds current depth k and definitions of last k and n
 data InductState = InductState
-                   { kVal  :: Natural
-                   , kDefs :: ([TypedExpr], [TypedExpr])
-                   , nDefs :: ([TypedExpr], [TypedExpr])
-                   , rs    :: [(Term, Term)] }
+                   { kVal     :: Natural
+                   , kDefs    :: ([TypedExpr], [TypedExpr])
+                   , nDefs    :: ([TypedExpr], [TypedExpr])
+                   , binPoset :: PosetGraph }
 type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 
 -- | Checks the program against its invariant. If the invariant
@@ -103,13 +102,13 @@ check' :: Invar
 check' indOpts getModel defs pastVars =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
-     liftIO $ when (printInvCount indOpts) (putStrLn $ "Number of Invariants: " ++ (show $ length rs))
+     --liftIO $ when (printInvCount indOpts) (putStrLn $ "Number of Invariants: " ++ (show $ length rs))
      rBMC <- bmcStep getModel defs pastVars kDefs
      case rBMC of
        Just m -> return $ Failure kVal m
        Nothing ->
-         do rs' <- filterRs rs kDefs
-            modify $ \indSt -> indSt { rs = rs' }
+         do rs' <- filterC binPoset kDefs
+            --modify $ \indSt -> indSt { rs = rs' }
             let n0 = fst nDefs
                 n1 = snd nDefs
             n2 <- freshVars n1
@@ -140,16 +139,17 @@ check' indOpts getModel defs pastVars =
          put $ indState { kVal = k', kDefs = (k1, k2) }
          check' indOpts getModel defs pastVars'
 
-filterRs :: MonadSMT m => [(Term, Term)] -> ([TypedExpr], [TypedExpr]) -> m [(Term, Term)]
-filterRs rs@(r:rss) args = liftSMT $ do push
-                                        assertRs args rs
-                                        r <- checkSat
-                                        if r
-                                           then do model <- mapM getTypedValue $ fst args
-                                                   pop
-                                                   filtered <- filterRs' model rs
-                                                   filterRs filtered args
-                                           else pop >> return rs
+filterC :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> m PosetGraph
+filterC g@(PosetGraph v e) args = liftSMT $ do push
+                                               assertPosetGraph args g
+                                               r <- checkSat
+                                               if r
+                                                  then do model <- mapM getTypedValue $ fst args
+                                                          pop
+                                                          --filtered <- filterRs' model rs
+                                                          --filterRs filtered args
+                                                          return g
+                                                  else pop >> return g
 filterRs [] _ = liftSMT $ return []
 
 filterRs' :: MonadSMT m => [TypedExpr] -> [(Term, Term)] -> m [(Term, Term)]

From 5eb779284165afd730a304fa554c8aee1e29350a Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 24 Nov 2015 00:46:22 +0100
Subject: [PATCH 080/104] Trying to create new nodes and edges

---
 lamaSMT/lib/Definition.hs           | 10 ++++++---
 lamaSMT/lib/Strategies/Invariant.hs | 33 ++++++++++++++++-------------
 lamaSMT/lib/TransformEnv.hs         |  7 ++++++
 3 files changed, 32 insertions(+), 18 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 4c069f8..5fc8361 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -51,12 +51,16 @@ type PosetGraphNode = [Term]
 
 data PosetGraph = PosetGraph
                   { vertices :: [PosetGraphNode]
-                  , edges    :: [(PosetGraphNode, PosetGraphNode)]
+                  , edges    :: [(Int, Int)]
                   }
 
 assertPosetGraph :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> PosetGraph -> m [()]
-assertPosetGraph i (PosetGraph vertices edges) = do mapM (\v -> mapM (\a -> assertRelation (fst i) (a, head v) (.==.)) (tail v)) vertices
-                                                    mapM (\(a, b) -> assertRelation (fst i) (head a, head b) (.=>.)) edges
+assertPosetGraph i (PosetGraph vertices edges) = do mapM assertPosetGraph' vertices
+                                                    --mapM (\(a, b) -> assertRelation (fst i) (head (vertices !! a), head (vertices !! b)) (.=>.)) edges
+                                                    return []
+  where
+    assertPosetGraph' (v:vs) = mapM (\a -> assertRelation (fst i) (a, v) (.==.)) vs
+    assertPosetGraph' _ = return []
                                                    
 
 assertRelation :: MonadSMT m => [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> m ()
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index ad669f4..e808e53 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -8,7 +8,7 @@ import Lang.LAMA.Types
 
 import Data.Natural
 import NatInstance
-import Data.List (stripPrefix)
+import Data.List (stripPrefix, partition)
 import qualified Data.Map as Map
 import Data.Map (Map)
 
@@ -107,8 +107,8 @@ check' indOpts getModel defs pastVars =
      case rBMC of
        Just m -> return $ Failure kVal m
        Nothing ->
-         do rs' <- filterC binPoset kDefs
-            --modify $ \indSt -> indSt { rs = rs' }
+         do binPoset' <- filterC binPoset kDefs
+            modify $ \indSt -> indSt { binPoset = binPoset' }
             let n0 = fst nDefs
                 n1 = snd nDefs
             n2 <- freshVars n1
@@ -120,16 +120,17 @@ check' indOpts getModel defs pastVars =
                  return (r, h)
             tell hints
             let k' = succ kVal
-            if indSuccess
-               then return Success
-               else case depth indOpts of
-                    Nothing -> cont k' pastVars
-                    Just l  ->
-                      if k' > l
-                      then return $ Unknown ("Cancelled induction. Found no"
-                                              ++" proof within given depth")
-                                    []
-                      else cont k' pastVars
+            --if indSuccess
+               --then return Success
+               --else case depth indOpts of
+            case depth indOpts of
+              Nothing -> cont k' pastVars
+              Just l  ->
+                if k' > l
+                  then return $ Unknown ("Cancelled induction. Found no"
+                                           ++" proof within given depth")
+                                 []
+                  else cont k' pastVars
   where
     cont k' pastVars =
       do indState@InductState{..} <- get
@@ -142,13 +143,15 @@ check' indOpts getModel defs pastVars =
 filterC :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> m PosetGraph
 filterC g@(PosetGraph v e) args = liftSMT $ do push
                                                assertPosetGraph args g
-                                               r <- checkSat
+                                               r  <- checkSat
                                                if r
                                                   then do model <- mapM getTypedValue $ fst args
+                                                          let v' = map (partition $ evalTerm args) v
+                                                              e' = [(a+(length v'), a) | a <- [0..(length v')-1]]
                                                           pop
                                                           --filtered <- filterRs' model rs
                                                           --filterRs filtered args
-                                                          return g
+                                                          return $ trace "hi" $ PosetGraph (map fst v' ++ map snd v') e'
                                                   else pop >> return g
 filterRs [] _ = liftSMT $ return []
 
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index eb162fd..4fc9693 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -104,6 +104,13 @@ getTypedValue (BoolExpr s) = liftSMT $ getValue s >>= return . BoolExpr . consta
 getTypedValue (IntExpr s) = liftSMT $ getValue s >>= return . IntExpr . constant
 getTypedValue e = liftSMT $ return $ getBottom e
 
+evalTerm :: ([TypedExpr], [TypedExpr]) -> Term -> Bool
+evalTerm i (BoolTerm args f) = let smtTrue  = constant True
+                                   smtFalse = constant False
+                               in case f `app` (lookupArgs args False i) of
+                                 smtTrue  -> True
+                                 smtFalse -> False
+
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()
 putEnumAnn eAnns =
   modify $ \env -> env { enumAnn = (enumAnn env) `Map.union` eAnns }

From 2a2176911ebde679fcd2f852f1d290360a98bd29 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Fri, 27 Nov 2015 11:10:29 +0100
Subject: [PATCH 081/104] Creation of bool invariant now better but not
 finished

---
 lamaSMT/lib/Definition.hs | 25 +++++++++----------------
 1 file changed, 9 insertions(+), 16 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 5fc8361..55ad80d 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -53,33 +53,26 @@ data PosetGraph = PosetGraph
                   { vertices :: [PosetGraphNode]
                   , edges    :: [(Int, Int)]
                   }
+  deriving (Show, Ord, Eq)
 
 assertPosetGraph :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> PosetGraph -> m [()]
-assertPosetGraph i (PosetGraph vertices edges) = do mapM assertPosetGraph' vertices
-                                                    --mapM (\(a, b) -> assertRelation (fst i) (head (vertices !! a), head (vertices !! b)) (.=>.)) edges
+assertPosetGraph i (PosetGraph vertices edges) = do let vcs = map assertPosetGraph' vertices
+                                                        vc = foldl (.&&.) (head vcs) $ tail vcs
+                                                    liftSMT $ assert (not' vc)
                                                     return []
   where
-    assertPosetGraph' (v:vs) = mapM (\a -> assertRelation (fst i) (a, v) (.==.)) vs
-    assertPosetGraph' _ = return []
+    assertPosetGraph' (v:vs) = let c = map (\a -> mkRelation (fst i) (a, v) (.==.)) vs in
+                                 foldl (.&&.) (head c) $ tail c
                                                    
 
-assertRelation :: MonadSMT m => [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> m ()
-assertRelation i (BoolTerm argsf f, BoolTerm argsg g) r =
-  liftSMT $ assert ((f `app` (lookupArgs argsf False (i, i))) `r`
-    (g `app` (lookupArgs argsg False (i, i))))
+mkRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> SMTExpr Bool
+mkRelation i (BoolTerm argsf f, BoolTerm argsg g) r =
+  (f `app` lookupArgs argsf False (i, i)) `r` (g `app` lookupArgs argsg False (i, i))
 
 constructRs :: Set Term -> Type i -> [(Term, Term)]
 constructRs ts (GroundType BoolT) = [(x,y) | x@(BoolTerm _ _) <- Set.toList ts,
                                       y@(BoolTerm _ _) <- Set.toList ts, x /= y]
 
-mkRelation :: ([TypedExpr], [TypedExpr]) -> (Term, Term) -> SMTExpr Bool
-mkRelation i (BoolTerm argsf f, BoolTerm argsg g) = (f `app` (lookupArgs argsf False i)) .=>.
-                                                       (g `app` (lookupArgs argsg False i))
-
-assertRs :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> [(Term, Term)] -> m ()
-assertRs i rs = let c = (map (mkRelation i) rs) in
-                  liftSMT $ assert (not' $ foldl (.&&.) (head c) $ tail c)
-
 assertR :: MonadSMT m => [TypedExpr] -> (Term, Term) -> m ()
 assertR i (BoolTerm argsf f, BoolTerm argsg g) =
   liftSMT $ assert ((f `app` (lookupArgs argsf False (i, i))) .=>.

From 3a4a4c0c42e21509239be6072bcfd955794c27a7 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Fri, 27 Nov 2015 11:11:45 +0100
Subject: [PATCH 082/104] evalTerm gets Value from Solver

---
 lamaSMT/lib/TransformEnv.hs | 8 ++------
 1 file changed, 2 insertions(+), 6 deletions(-)

diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 4fc9693..7e2de4d 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -104,12 +104,8 @@ getTypedValue (BoolExpr s) = liftSMT $ getValue s >>= return . BoolExpr . consta
 getTypedValue (IntExpr s) = liftSMT $ getValue s >>= return . IntExpr . constant
 getTypedValue e = liftSMT $ return $ getBottom e
 
-evalTerm :: ([TypedExpr], [TypedExpr]) -> Term -> Bool
-evalTerm i (BoolTerm args f) = let smtTrue  = constant True
-                                   smtFalse = constant False
-                               in case f `app` (lookupArgs args False i) of
-                                 smtTrue  -> True
-                                 smtFalse -> False
+evalTerm :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> Term -> m Bool
+evalTerm i (BoolTerm args f) = liftSMT $ getValue $ f `app` (lookupArgs args False i)
 
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()
 putEnumAnn eAnns =

From 78fa02135b6936015529eaf1cf5cc4d016646551 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Fri, 27 Nov 2015 12:04:08 +0100
Subject: [PATCH 083/104] Partition of graph nodes implemented but no edges

---
 lamaSMT/lib/Strategies/Invariant.hs | 28 ++++++----------------------
 1 file changed, 6 insertions(+), 22 deletions(-)

diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index e808e53..a7c91a0 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -15,7 +15,7 @@ import Data.Map (Map)
 import Control.Monad.State (MonadState(..), StateT, evalStateT, modify)
 import Control.Monad.Writer (MonadWriter(..), WriterT, runWriterT)
 import Control.Monad.IO.Class
-import Control.Monad (when)
+import Control.Monad (when, filterM)
 import Control.Arrow ((&&&))
 
 import Language.SMTLib2
@@ -142,30 +142,14 @@ check' indOpts getModel defs pastVars =
 
 filterC :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> m PosetGraph
 filterC g@(PosetGraph v e) args = liftSMT $ do push
-                                               assertPosetGraph args g
+                                               assertPosetGraph args $trace (show g) $ g
                                                r  <- checkSat
-                                               if r
-                                                  then do model <- mapM getTypedValue $ fst args
-                                                          let v' = map (partition $ evalTerm args) v
-                                                              e' = [(a+(length v'), a) | a <- [0..(length v')-1]]
+                                               trace (show r) $ if r
+                                                  then do v1' <- mapM (filterM $ evalTerm args) v
+                                                          v2' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v
                                                           pop
-                                                          --filtered <- filterRs' model rs
-                                                          --filterRs filtered args
-                                                          return $ trace "hi" $ PosetGraph (map fst v' ++ map snd v') e'
+                                                          return $ trace (show v1') $ trace (show v2') $ PosetGraph (v1' ++ v2') e
                                                   else pop >> return g
-filterRs [] _ = liftSMT $ return []
-
-filterRs' :: MonadSMT m => [TypedExpr] -> [(Term, Term)] -> m [(Term, Term)]
-filterRs' model (r:rs) = liftSMT $ do push
-                                      assertR model r
-                                      e <- checkSat
-                                      pop
-                                      rest <- filterRs' model rs
-                                      if e
-                                         then return $ [r] ++ rest
-                                         else return rest
-filterRs' model [] = liftSMT $ return []
-
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)
               -> Invar

From c782d621c1fc72dc6f7ed65ef29e5a7a7969ab18 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Fri, 27 Nov 2015 15:26:24 +0100
Subject: [PATCH 084/104] Implemented building of new Graph

---
 lamaSMT/lib/Definition.hs           | 35 +++++++++++++++++++++++++++--
 lamaSMT/lib/Strategies/Invariant.hs | 10 ++++-----
 2 files changed, 38 insertions(+), 7 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 55ad80d..74338e3 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -7,6 +7,10 @@ import Language.SMTLib2 as SMT
 import Data.Array as Arr
 import qualified Data.Set as Set
 import Data.Set (Set)
+import qualified Data.List as List
+import Data.List ((\\))
+import Control.Monad.State
+import Control.Arrow ((***))
 
 import LamaSMTTypes
 import Internal.Monads
@@ -48,21 +52,48 @@ data Term =
   deriving (Show, Ord, Eq)
 
 type PosetGraphNode = [Term]
+type PosetGraphEdge = (Int, Int)
 
 data PosetGraph = PosetGraph
                   { vertices :: [PosetGraphNode]
-                  , edges    :: [(Int, Int)]
+                  , edges    :: [PosetGraphEdge]
                   }
   deriving (Show, Ord, Eq)
 
+type GraphM = State [PosetGraphEdge]
+
+buildNextGraph :: ([PosetGraphNode], [PosetGraphNode]) -> [PosetGraphEdge] -> PosetGraph
+buildNextGraph (v0, v1) e = let leaves = getLeaves e
+                                i = length v0
+                                firstEdges = [(a, a+i) | a <- [0..i-1]] ++ e
+                                otherEdges = evalState (traverseGraph i leaves) e
+                                in PosetGraph (v0 ++ v1) (firstEdges ++ otherEdges)
+  where
+    getLeaves e = [snd $ head e]
+
+traverseGraph :: Int -> [Int] -> GraphM [PosetGraphEdge]
+traverseGraph i (l:ls) = do edgesLeft <- get
+                            let p = getPredecessors l edgesLeft
+                            put $ edgesLeft \\ p
+                            top <- traverseGraph i (map fst p)
+                            rest <- traverseGraph i ls
+                            return $ map ((+i) *** (+i)) p ++ top ++ rest
+  where
+    getPredecessors l e = [(x,y) | (x,y) <- e, y == l]
+                            
+traverseGraph _ [] = return []
+
 assertPosetGraph :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> PosetGraph -> m [()]
 assertPosetGraph i (PosetGraph vertices edges) = do let vcs = map assertPosetGraph' vertices
-                                                        vc = foldl (.&&.) (head vcs) $ tail vcs
+                                                        --vc = foldl (.&&.) (head vcs) $ tail vcs
+                                                        vc = foldl (.&&.) (constant True) vcs
                                                     liftSMT $ assert (not' vc)
                                                     return []
   where
+    assertPosetGraph' (v:[]) = constant True
     assertPosetGraph' (v:vs) = let c = map (\a -> mkRelation (fst i) (a, v) (.==.)) vs in
                                  foldl (.&&.) (head c) $ tail c
+    assertPosetGraph' [] = constant True
                                                    
 
 mkRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> SMTExpr Bool
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index a7c91a0..747e28b 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -65,7 +65,7 @@ instance StrategyClass Invar where
           n0  <- freshVars vars
           n1  <- freshVars vars
           assumeTrace defs (n0, n1)
-          let s0 = InductState baseK (vars, k1) (n0, n1) $ PosetGraph [instSetBool env] []
+          let s0 = InductState baseK (vars, k1) (n0, n1) $ PosetGraph [map fst . filter (\(x,y) -> (mod y 100) == 0) $ zip (instSetBool env) [1..]] []
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
                 $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
@@ -145,10 +145,10 @@ filterC g@(PosetGraph v e) args = liftSMT $ do push
                                                assertPosetGraph args $trace (show g) $ g
                                                r  <- checkSat
                                                trace (show r) $ if r
-                                                  then do v1' <- mapM (filterM $ evalTerm args) v
-                                                          v2' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v
-                                                          pop
-                                                          return $ trace (show v1') $ trace (show v2') $ PosetGraph (v1' ++ v2') e
+                                                 then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v
+                                                         v1' <- mapM (filterM $ evalTerm args) v
+                                                         pop
+                                                         return ${- trace (show v0') $ trace (show v1') $-} buildNextGraph (v0', v1') e
                                                   else pop >> return g
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)

From a807c0d44fc2a70bb6827f04dc266ad275fa2ea8 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 30 Nov 2015 22:00:39 +0100
Subject: [PATCH 085/104] Empty nodes are removed during building of new graph

---
 lamaSMT/lib/Definition.hs | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 74338e3..9dfa604 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -67,10 +67,20 @@ buildNextGraph (v0, v1) e = let leaves = getLeaves e
                                 i = length v0
                                 firstEdges = [(a, a+i) | a <- [0..i-1]] ++ e
                                 otherEdges = evalState (traverseGraph i leaves) e
-                                in PosetGraph (v0 ++ v1) (firstEdges ++ otherEdges)
+                                in removeEmptyNodes $ PosetGraph (v0 ++ v1) (firstEdges ++ otherEdges)
   where
     getLeaves e = [snd $ head e]
 
+removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
+  where
+    vs' = filter (\(_,v) -> not $ null v) $ zip [0..] vs
+    newEdges ((a,b):eds) = case List.elemIndex a (map fst vs') of
+                           Nothing -> newEdges eds
+                           Just i -> case List.elemIndex b (map fst vs') of
+                                       Nothing -> newEdges eds
+                                       Just j -> [(i,j)] ++ newEdges eds
+    newEdges [] = []
+
 traverseGraph :: Int -> [Int] -> GraphM [PosetGraphEdge]
 traverseGraph i (l:ls) = do edgesLeft <- get
                             let p = getPredecessors l edgesLeft

From 7f193145bb2411de909c9b2ec167e776119dd121 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 30 Nov 2015 22:03:27 +0100
Subject: [PATCH 086/104] invariant-stats instead of invariant-count activated

---
 lamaSMT/lib/Strategies/Invariant.hs | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 747e28b..5307db6 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -35,7 +35,7 @@ data GenerateHints =
 data Invar = Invar
                { depth :: Maybe Natural
                , printProgress :: Bool
-               , printInvCount :: Bool
+               , printInvStats :: Bool
                , generateHints :: GenerateHints }
 
 instance StrategyClass Invar where
@@ -47,8 +47,8 @@ instance StrategyClass Invar where
       _     -> indOpts { depth = Just $ read d }
   readOption "progress" indOpts =
     indOpts { printProgress = True }
-  readOption "invariant-count" indOpts =
-    indOpts { printInvCount = True }
+  readOption "invariant-stats" indOpts =
+    indOpts { printInvStats = True }
   readOption (stripPrefix "hints" -> Just r) indOpts =
     case (stripPrefix "=" r) of
          Nothing    -> indOpts { generateHints = LastInductionStep }
@@ -65,7 +65,7 @@ instance StrategyClass Invar where
           n0  <- freshVars vars
           n1  <- freshVars vars
           assumeTrace defs (n0, n1)
-          let s0 = InductState baseK (vars, k1) (n0, n1) $ PosetGraph [map fst . filter (\(x,y) -> (mod y 100) == 0) $ zip (instSetBool env) [1..]] []
+          let s0 = InductState baseK (vars, k1) (n0, n1) $ PosetGraph [map fst . filter (\(x,y) -> (mod y 1) == 0) $ zip (instSetBool env) [1..]] []
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
                 $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
@@ -102,7 +102,7 @@ check' :: Invar
 check' indOpts getModel defs pastVars =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
-     --liftIO $ when (printInvCount indOpts) (putStrLn $ "Number of Invariants: " ++ (show $ length rs))
+     liftIO $ when (printInvStats indOpts) (putStrLn $ "Boolean Invariants:\n" ++ (show $ length $ vertices binPoset) ++ " Node(s) with\n" ++ (show $ length $ concat $ vertices binPoset) ++ " Element(s) and\n" ++ (show $ length $ edges binPoset) ++ " Edge(s)\n")
      rBMC <- bmcStep getModel defs pastVars kDefs
      case rBMC of
        Just m -> return $ Failure kVal m
@@ -142,7 +142,7 @@ check' indOpts getModel defs pastVars =
 
 filterC :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> m PosetGraph
 filterC g@(PosetGraph v e) args = liftSMT $ do push
-                                               assertPosetGraph args $trace (show g) $ g
+                                               assertPosetGraph args g
                                                r  <- checkSat
                                                trace (show r) $ if r
                                                  then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v

From 641628d03acaf82330efb94df0d4055ac8a50dde Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 30 Nov 2015 22:46:23 +0100
Subject: [PATCH 087/104] Forgot to assert edges

---
 lamaSMT/lib/Definition.hs           | 20 ++++++++++----------
 lamaSMT/lib/Strategies/Invariant.hs |  2 +-
 2 files changed, 11 insertions(+), 11 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 9dfa604..b48d3a2 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -93,17 +93,17 @@ traverseGraph i (l:ls) = do edgesLeft <- get
                             
 traverseGraph _ [] = return []
 
-assertPosetGraph :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> PosetGraph -> m [()]
-assertPosetGraph i (PosetGraph vertices edges) = do let vcs = map assertPosetGraph' vertices
-                                                        --vc = foldl (.&&.) (head vcs) $ tail vcs
-                                                        vc = foldl (.&&.) (constant True) vcs
-                                                    liftSMT $ assert (not' vc)
-                                                    return []
+assertPosetGraph :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> PosetGraph -> m [()]
+assertPosetGraph f i (PosetGraph vertices edges) = do let vcs = map assertPosetGraphVs vertices
+                                                          vc = foldl (.&&.) (constant True) $ vcs ++ assertPosetGraphEs edges
+                                                      liftSMT $ assert (f vc)
+                                                      return []
   where
-    assertPosetGraph' (v:[]) = constant True
-    assertPosetGraph' (v:vs) = let c = map (\a -> mkRelation (fst i) (a, v) (.==.)) vs in
-                                 foldl (.&&.) (head c) $ tail c
-    assertPosetGraph' [] = constant True
+    assertPosetGraphVs (v:[]) = constant True
+    assertPosetGraphVs (v:vs) = let c = map (\a -> mkRelation (fst i) (a, v) (.==.)) vs in
+                                  foldl (.&&.) (head c) $ tail c
+    assertPosetGraphVs [] = constant True
+    assertPosetGraphEs es = map (\(a,b) -> mkRelation (fst i) (head (vertices !! a), head (vertices !! b)) (.=>.)) es
                                                    
 
 mkRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> SMTExpr Bool
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 5307db6..b8ff467 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -142,7 +142,7 @@ check' indOpts getModel defs pastVars =
 
 filterC :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> m PosetGraph
 filterC g@(PosetGraph v e) args = liftSMT $ do push
-                                               assertPosetGraph args g
+                                               assertPosetGraph not' args g
                                                r  <- checkSat
                                                trace (show r) $ if r
                                                  then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v

From 1a2f4be7159a19795b8d199d77de966543a1aa59 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 1 Dec 2015 16:16:08 +0100
Subject: [PATCH 088/104] Induction step for invariants is being made. Possibly
 correct

---
 lamaSMT/lib/Definition.hs           |  6 +--
 lamaSMT/lib/Strategies/Invariant.hs | 70 +++++++++++++++++++----------
 2 files changed, 50 insertions(+), 26 deletions(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index b48d3a2..9581a08 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -70,7 +70,7 @@ buildNextGraph (v0, v1) e = let leaves = getLeaves e
                                 in removeEmptyNodes $ PosetGraph (v0 ++ v1) (firstEdges ++ otherEdges)
   where
     getLeaves e = [snd $ head e]
-
+removeEmptyNodes :: PosetGraph -> PosetGraph
 removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
   where
     vs' = filter (\(_,v) -> not $ null v) $ zip [0..] vs
@@ -93,11 +93,11 @@ traverseGraph i (l:ls) = do edgesLeft <- get
                             
 traverseGraph _ [] = return []
 
-assertPosetGraph :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> PosetGraph -> m [()]
+assertPosetGraph :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> PosetGraph -> m ()
 assertPosetGraph f i (PosetGraph vertices edges) = do let vcs = map assertPosetGraphVs vertices
                                                           vc = foldl (.&&.) (constant True) $ vcs ++ assertPosetGraphEs edges
                                                       liftSMT $ assert (f vc)
-                                                      return []
+                                                      --return
   where
     assertPosetGraphVs (v:[]) = constant True
     assertPosetGraphVs (v:vs) = let c = map (\a -> mkRelation (fst i) (a, v) (.==.)) vs in
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index b8ff467..628f846 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -11,6 +11,7 @@ import NatInstance
 import Data.List (stripPrefix, partition)
 import qualified Data.Map as Map
 import Data.Map (Map)
+import Data.Maybe (fromMaybe, isJust, fromJust)
 
 import Control.Monad.State (MonadState(..), StateT, evalStateT, modify)
 import Control.Monad.Writer (MonadWriter(..), WriterT, runWriterT)
@@ -65,10 +66,10 @@ instance StrategyClass Invar where
           n0  <- freshVars vars
           n1  <- freshVars vars
           assumeTrace defs (n0, n1)
-          let s0 = InductState baseK (vars, k1) (n0, n1) $ PosetGraph [map fst . filter (\(x,y) -> (mod y 1) == 0) $ zip (instSetBool env) [1..]] []
+          let s0 = InductState baseK (vars, k1) (n0, n1) (Just $ PosetGraph [map fst . filter (\(x,y) -> (mod y 1) == 0) $ zip (instSetBool env) [1..]] []) Nothing
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
-                $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars)
+                $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars) [n0]
           case r of
                Unknown what h -> return $ Unknown what (h ++ hints)
                _ -> return r
@@ -86,7 +87,8 @@ data InductState = InductState
                    { kVal     :: Natural
                    , kDefs    :: ([TypedExpr], [TypedExpr])
                    , nDefs    :: ([TypedExpr], [TypedExpr])
-                   , binPoset :: PosetGraph }
+                   , binPoset :: Maybe PosetGraph
+                   , binInv   :: Maybe PosetGraph }
 type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 
 -- | Checks the program against its invariant. If the invariant
@@ -98,21 +100,29 @@ check' :: Invar
        -> (Map Natural [TypedExpr] -> SMT (Model i))
        -> ProgDefs
        -> Map Natural [TypedExpr]
+       -> [[TypedExpr]]
        -> KInductM i (StrategyResult i)
-check' indOpts getModel defs pastVars =
+check' indOpts getModel defs pastVars pastNs =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
-     liftIO $ when (printInvStats indOpts) (putStrLn $ "Boolean Invariants:\n" ++ (show $ length $ vertices binPoset) ++ " Node(s) with\n" ++ (show $ length $ concat $ vertices binPoset) ++ " Element(s) and\n" ++ (show $ length $ edges binPoset) ++ " Edge(s)\n")
+     let statGraph = fromMaybe (PosetGraph [] []) binPoset
+     liftIO $ when (printInvStats indOpts) (putStrLn $ "Boolean Invariants:\n" ++ (show $ length $ vertices statGraph) ++ " Node(s) with\n" ++ (show $ length $ concat $ vertices statGraph) ++ " Element(s) and\n" ++ (show $ length $ edges statGraph) ++ " Edge(s)\n")
      rBMC <- bmcStep getModel defs pastVars kDefs
      case rBMC of
        Just m -> return $ Failure kVal m
        Nothing ->
-         do binPoset' <- filterC binPoset kDefs
-            modify $ \indSt -> indSt { binPoset = binPoset' }
-            let n0 = fst nDefs
+         do let n0 = fst nDefs
                 n1 = snd nDefs
+                pastNs' = pastNs ++ [n1]
             n2 <- freshVars n1
+            when (isJust binPoset) $
+              do binPoset' <- filterC (fromJust binPoset) kDefs
+                 case binPoset' of
+                   Just b  -> modify $ \indSt -> indSt { binPoset = Just b }
+                   Nothing -> do binInv' <- checkInvariantStep (fromJust binPoset) (n1,n2) pastNs
+                                 modify $ \indSt -> indSt { binPoset = Nothing, binInv = Just binInv' }
             assertPrecond (n0, n1) $ invariantDef defs
+            when (isJust binInv) $ assertPosetGraph id (n0, n1) $ fromJust binInv
             modify $ \indSt -> indSt { nDefs = (n1, n2) }
             (indSuccess, hints) <- liftSMT . stack $
               do r <- checkStep defs (n1, n2)
@@ -124,32 +134,46 @@ check' indOpts getModel defs pastVars =
                --then return Success
                --else case depth indOpts of
             case depth indOpts of
-              Nothing -> cont k' pastVars
+              Nothing -> cont k' pastVars pastNs'
               Just l  ->
                 if k' > l
                   then return $ Unknown ("Cancelled induction. Found no"
                                            ++" proof within given depth")
                                  []
-                  else cont k' pastVars
+                  else cont k' pastVars pastNs'
   where
-    cont k' pastVars =
+    cont k' pastVars pNs =
       do indState@InductState{..} <- get
          let k1 = snd kDefs
              pastVars' = Map.insert k' k1 pastVars
          k2 <- freshVars k1
          put $ indState { kVal = k', kDefs = (k1, k2) }
-         check' indOpts getModel defs pastVars'
-
-filterC :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> m PosetGraph
-filterC g@(PosetGraph v e) args = liftSMT $ do push
-                                               assertPosetGraph not' args g
-                                               r  <- checkSat
-                                               trace (show r) $ if r
-                                                 then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v
-                                                         v1' <- mapM (filterM $ evalTerm args) v
-                                                         pop
-                                                         return ${- trace (show v0') $ trace (show v1') $-} buildNextGraph (v0', v1') e
-                                                  else pop >> return g
+         check' indOpts getModel defs pastVars' pNs
+
+filterC :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> m (Maybe PosetGraph)
+filterC g@(PosetGraph v e) args =
+  liftSMT $ do push
+               assertPosetGraph not' args g
+               r  <- checkSat
+               trace (show r) $ if r
+                 then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v
+                         v1' <- mapM (filterM $ evalTerm args) v
+                         pop
+                         return $ Just $ buildNextGraph (v0', v1') e
+                  else pop >> return Nothing
+
+checkInvariantStep :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> [[TypedExpr]] -> m PosetGraph
+checkInvariantStep g args pastVars = liftSMT $ do
+  push
+  mapM (\a -> assertPosetGraph id (a,a) g) $ pastVars
+  assertPosetGraph not' args g
+  r <- checkSat
+  trace (show r) $ if r
+    then do v' <- mapM (filterM $ evalTerm args) $ vertices g
+            pop
+            return $ removeEmptyNodes $ PosetGraph v' $ edges g
+     else pop >> return g
+
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)
               -> Invar

From bac6b6ef22716ddbe932356cfcc32eda2d08804d Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Fri, 4 Dec 2015 23:35:56 +0100
Subject: [PATCH 089/104] Miscellaneous changes to induction step and
 assertions

---
 lamaSMT/lib/Strategies/Invariant.hs | 37 +++++++++++++++++++----------
 1 file changed, 24 insertions(+), 13 deletions(-)

diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 628f846..177cce3 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -105,8 +105,9 @@ check' :: Invar
 check' indOpts getModel defs pastVars pastNs =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
-     let statGraph = fromMaybe (PosetGraph [] []) binPoset
-     liftIO $ when (printInvStats indOpts) (putStrLn $ "Boolean Invariants:\n" ++ (show $ length $ vertices statGraph) ++ " Node(s) with\n" ++ (show $ length $ concat $ vertices statGraph) ++ " Element(s) and\n" ++ (show $ length $ edges statGraph) ++ " Edge(s)\n")
+     let statGraph = fromMaybe (fromMaybe (PosetGraph [] []) binInv) binPoset
+     let statMessage = if (isJust binPoset) then "Possible " else "Actual "
+     liftIO $ when (printInvStats indOpts) (putStrLn $ statMessage ++ "Boolean Invariants:\n" ++ (show $ length $ vertices statGraph) ++ " Node(s) with\n" ++ (show $ length $ concat $ vertices statGraph) ++ " Element(s) and\n" ++ (show $ length $ edges statGraph) ++ " Edge(s)\n")
      rBMC <- bmcStep getModel defs pastVars kDefs
      case rBMC of
        Just m -> return $ Failure kVal m
@@ -119,10 +120,11 @@ check' indOpts getModel defs pastVars pastNs =
               do binPoset' <- filterC (fromJust binPoset) kDefs
                  case binPoset' of
                    Just b  -> modify $ \indSt -> indSt { binPoset = Just b }
-                   Nothing -> do binInv' <- checkInvariantStep (fromJust binPoset) (n1,n2) pastNs
+                   Nothing -> do binInv' <- checkInvariantStep (fromJust binPoset) (n1,n2) pastNs defs
+                                 assertPosetGraph id (n1, n2) binInv'
                                  modify $ \indSt -> indSt { binPoset = Nothing, binInv = Just binInv' }
             assertPrecond (n0, n1) $ invariantDef defs
-            when (isJust binInv) $ assertPosetGraph id (n0, n1) $ fromJust binInv
+            when (isJust binInv) $ assertPosetGraph id (n1, n2) $ fromJust binInv
             modify $ \indSt -> indSt { nDefs = (n1, n2) }
             (indSuccess, hints) <- liftSMT . stack $
               do r <- checkStep defs (n1, n2)
@@ -162,17 +164,26 @@ filterC g@(PosetGraph v e) args =
                          return $ Just $ buildNextGraph (v0', v1') e
                   else pop >> return Nothing
 
-checkInvariantStep :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> [[TypedExpr]] -> m PosetGraph
-checkInvariantStep g args pastVars = liftSMT $ do
+checkInvariantStep :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> [[TypedExpr]] -> ProgDefs -> m PosetGraph
+checkInvariantStep g args pastVars defs = liftSMT $ do
   push
   mapM (\a -> assertPosetGraph id (a,a) g) $ pastVars
-  assertPosetGraph not' args g
-  r <- checkSat
-  trace (show r) $ if r
-    then do v' <- mapM (filterM $ evalTerm args) $ vertices g
-            pop
-            return $ removeEmptyNodes $ PosetGraph v' $ edges g
-     else pop >> return g
+  assumeTrace defs args
+  g' <- checkInvariantStep' g
+  pop
+  return g'
+  where
+    checkInvariantStep' graph@(PosetGraph v e) = do
+      push
+      assertPosetGraph not' args graph
+      r <- checkSat
+      trace (show r) $ if r
+        then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v
+                v1' <- mapM (filterM $ evalTerm args) v
+                pop
+                graph' <- checkInvariantStep' $ buildNextGraph (v0', v1') e
+                return graph'
+         else pop >> return graph
 
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)

From 9e4c9903c98be3b4dcd999f553ed5c5c32f00d99 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 5 Dec 2015 00:03:32 +0100
Subject: [PATCH 090/104] Optimization regarding the removal of useless nodes

---
 lamaSMT/lib/Definition.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 9581a08..35df2b9 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -67,9 +67,10 @@ buildNextGraph (v0, v1) e = let leaves = getLeaves e
                                 i = length v0
                                 firstEdges = [(a, a+i) | a <- [0..i-1]] ++ e
                                 otherEdges = evalState (traverseGraph i leaves) e
-                                in removeEmptyNodes $ PosetGraph (v0 ++ v1) (firstEdges ++ otherEdges)
+                                in removeUnreachableNodes $ removeEmptyNodes $ PosetGraph (v0 ++ v1) (firstEdges ++ otherEdges)
   where
     getLeaves e = [snd $ head e]
+
 removeEmptyNodes :: PosetGraph -> PosetGraph
 removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
   where
@@ -81,6 +82,11 @@ removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
                                        Just j -> [(i,j)] ++ newEdges eds
     newEdges [] = []
 
+removeUnreachableNodes :: PosetGraph -> PosetGraph
+removeUnreachableNodes (PosetGraph vs es) = PosetGraph (map snd (filter (\a -> (elem (fst a) nodesWithEdges) || (length (snd a) > 1)) $ zip [0..] vs)) es
+  where
+    nodesWithEdges = (fst $ unzip es) ++ (snd $ unzip es)
+
 traverseGraph :: Int -> [Int] -> GraphM [PosetGraphEdge]
 traverseGraph i (l:ls) = do edgesLeft <- get
                             let p = getPredecessors l edgesLeft

From 515bb82b9b3dfbffa36698cfb623f5c46510c405 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 5 Dec 2015 11:07:33 +0100
Subject: [PATCH 091/104] Corrected mistake with useless nodes

---
 lamaSMT/lib/Definition.hs | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 35df2b9..f30480c 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -83,9 +83,16 @@ removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
     newEdges [] = []
 
 removeUnreachableNodes :: PosetGraph -> PosetGraph
-removeUnreachableNodes (PosetGraph vs es) = PosetGraph (map snd (filter (\a -> (elem (fst a) nodesWithEdges) || (length (snd a) > 1)) $ zip [0..] vs)) es
+removeUnreachableNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
   where
+    vs' = filter (\a -> (elem (fst a) nodesWithEdges) || (length (snd a) > 1)) $ zip [0..] vs
     nodesWithEdges = (fst $ unzip es) ++ (snd $ unzip es)
+    newEdges ((a,b):eds) = case List.elemIndex a (map fst vs') of
+                           Nothing -> newEdges eds
+                           Just i -> case List.elemIndex b (map fst vs') of
+                                       Nothing -> newEdges eds
+                                       Just j -> [(i,j)] ++ newEdges eds
+    newEdges [] = []
 
 traverseGraph :: Int -> [Int] -> GraphM [PosetGraphEdge]
 traverseGraph i (l:ls) = do edgesLeft <- get

From 995ad42299c357d5fd7ee7c43717afc0b0a6a0d2 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 5 Dec 2015 11:22:45 +0100
Subject: [PATCH 092/104] Moved poset calculation to dedicated module

---
 lamaSMT/lib/Definition.hs           |  93 -------------------------
 lamaSMT/lib/Posets.hs               | 103 ++++++++++++++++++++++++++++
 lamaSMT/lib/Strategies/Invariant.hs |   1 +
 lamaSMT/lib/TransformEnv.hs         |   1 +
 4 files changed, 105 insertions(+), 93 deletions(-)
 create mode 100644 lamaSMT/lib/Posets.hs

diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index f30480c..60ba859 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -5,12 +5,6 @@ import Lang.LAMA.Types
 import Language.SMTLib2 as SMT
 
 import Data.Array as Arr
-import qualified Data.Set as Set
-import Data.Set (Set)
-import qualified Data.List as List
-import Data.List ((\\))
-import Control.Monad.State
-import Control.Arrow ((***))
 
 import LamaSMTTypes
 import Internal.Monads
@@ -44,90 +38,3 @@ data ProgDefs = ProgDefs
                 , precondition :: Definition
                 , invariantDef :: Definition
                 }
-
-data Term =
-  BoolTerm [Int] (SMTFunction [TypedExpr] Bool)
-  | IntTerm [Int] (SMTFunction [TypedExpr] Integer)
-  | RealTerm [Int] (SMTFunction [TypedExpr] Rational)
-  deriving (Show, Ord, Eq)
-
-type PosetGraphNode = [Term]
-type PosetGraphEdge = (Int, Int)
-
-data PosetGraph = PosetGraph
-                  { vertices :: [PosetGraphNode]
-                  , edges    :: [PosetGraphEdge]
-                  }
-  deriving (Show, Ord, Eq)
-
-type GraphM = State [PosetGraphEdge]
-
-buildNextGraph :: ([PosetGraphNode], [PosetGraphNode]) -> [PosetGraphEdge] -> PosetGraph
-buildNextGraph (v0, v1) e = let leaves = getLeaves e
-                                i = length v0
-                                firstEdges = [(a, a+i) | a <- [0..i-1]] ++ e
-                                otherEdges = evalState (traverseGraph i leaves) e
-                                in removeUnreachableNodes $ removeEmptyNodes $ PosetGraph (v0 ++ v1) (firstEdges ++ otherEdges)
-  where
-    getLeaves e = [snd $ head e]
-
-removeEmptyNodes :: PosetGraph -> PosetGraph
-removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
-  where
-    vs' = filter (\(_,v) -> not $ null v) $ zip [0..] vs
-    newEdges ((a,b):eds) = case List.elemIndex a (map fst vs') of
-                           Nothing -> newEdges eds
-                           Just i -> case List.elemIndex b (map fst vs') of
-                                       Nothing -> newEdges eds
-                                       Just j -> [(i,j)] ++ newEdges eds
-    newEdges [] = []
-
-removeUnreachableNodes :: PosetGraph -> PosetGraph
-removeUnreachableNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
-  where
-    vs' = filter (\a -> (elem (fst a) nodesWithEdges) || (length (snd a) > 1)) $ zip [0..] vs
-    nodesWithEdges = (fst $ unzip es) ++ (snd $ unzip es)
-    newEdges ((a,b):eds) = case List.elemIndex a (map fst vs') of
-                           Nothing -> newEdges eds
-                           Just i -> case List.elemIndex b (map fst vs') of
-                                       Nothing -> newEdges eds
-                                       Just j -> [(i,j)] ++ newEdges eds
-    newEdges [] = []
-
-traverseGraph :: Int -> [Int] -> GraphM [PosetGraphEdge]
-traverseGraph i (l:ls) = do edgesLeft <- get
-                            let p = getPredecessors l edgesLeft
-                            put $ edgesLeft \\ p
-                            top <- traverseGraph i (map fst p)
-                            rest <- traverseGraph i ls
-                            return $ map ((+i) *** (+i)) p ++ top ++ rest
-  where
-    getPredecessors l e = [(x,y) | (x,y) <- e, y == l]
-                            
-traverseGraph _ [] = return []
-
-assertPosetGraph :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> PosetGraph -> m ()
-assertPosetGraph f i (PosetGraph vertices edges) = do let vcs = map assertPosetGraphVs vertices
-                                                          vc = foldl (.&&.) (constant True) $ vcs ++ assertPosetGraphEs edges
-                                                      liftSMT $ assert (f vc)
-                                                      --return
-  where
-    assertPosetGraphVs (v:[]) = constant True
-    assertPosetGraphVs (v:vs) = let c = map (\a -> mkRelation (fst i) (a, v) (.==.)) vs in
-                                  foldl (.&&.) (head c) $ tail c
-    assertPosetGraphVs [] = constant True
-    assertPosetGraphEs es = map (\(a,b) -> mkRelation (fst i) (head (vertices !! a), head (vertices !! b)) (.=>.)) es
-                                                   
-
-mkRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> SMTExpr Bool
-mkRelation i (BoolTerm argsf f, BoolTerm argsg g) r =
-  (f `app` lookupArgs argsf False (i, i)) `r` (g `app` lookupArgs argsg False (i, i))
-
-constructRs :: Set Term -> Type i -> [(Term, Term)]
-constructRs ts (GroundType BoolT) = [(x,y) | x@(BoolTerm _ _) <- Set.toList ts,
-                                      y@(BoolTerm _ _) <- Set.toList ts, x /= y]
-
-assertR :: MonadSMT m => [TypedExpr] -> (Term, Term) -> m ()
-assertR i (BoolTerm argsf f, BoolTerm argsg g) =
-  liftSMT $ assert ((f `app` (lookupArgs argsf False (i, i))) .=>.
-    (g `app` (lookupArgs argsg False (i, i))))
diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
new file mode 100644
index 0000000..1bd7f15
--- /dev/null
+++ b/lamaSMT/lib/Posets.hs
@@ -0,0 +1,103 @@
+module Posets where
+
+import Lang.LAMA.Types
+
+import Language.SMTLib2 as SMT
+
+import qualified Data.Set as Set
+import Data.Set (Set)
+import qualified Data.List as List
+import Data.List ((\\))
+import Control.Monad.State
+import Control.Arrow ((***))
+
+import LamaSMTTypes
+import Internal.Monads
+import Definition
+
+data Term =
+  BoolTerm [Int] (SMTFunction [TypedExpr] Bool)
+  | IntTerm [Int] (SMTFunction [TypedExpr] Integer)
+  | RealTerm [Int] (SMTFunction [TypedExpr] Rational)
+  deriving (Show, Ord, Eq)
+
+type PosetGraphNode = [Term]
+type PosetGraphEdge = (Int, Int)
+
+data PosetGraph = PosetGraph
+                  { vertices :: [PosetGraphNode]
+                  , edges    :: [PosetGraphEdge]
+                  }
+  deriving (Show, Ord, Eq)
+
+type GraphM = State [PosetGraphEdge]
+
+buildNextGraph :: ([PosetGraphNode], [PosetGraphNode]) -> [PosetGraphEdge] -> PosetGraph
+buildNextGraph (v0, v1) e = let leaves = getLeaves e
+                                i = length v0
+                                firstEdges = [(a, a+i) | a <- [0..i-1]] ++ e
+                                otherEdges = evalState (traverseGraph i leaves) e
+                                in removeUnreachableNodes $ removeEmptyNodes $ PosetGraph (v0 ++ v1) (firstEdges ++ otherEdges)
+  where
+    getLeaves e = [snd $ head e]
+
+removeEmptyNodes :: PosetGraph -> PosetGraph
+removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
+  where
+    vs' = filter (\(_,v) -> not $ null v) $ zip [0..] vs
+    newEdges ((a,b):eds) = case List.elemIndex a (map fst vs') of
+                           Nothing -> newEdges eds
+                           Just i -> case List.elemIndex b (map fst vs') of
+                                       Nothing -> newEdges eds
+                                       Just j -> [(i,j)] ++ newEdges eds
+    newEdges [] = []
+
+removeUnreachableNodes :: PosetGraph -> PosetGraph
+removeUnreachableNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
+  where
+    vs' = filter (\a -> (elem (fst a) nodesWithEdges) || (length (snd a) > 1)) $ zip [0..] vs
+    nodesWithEdges = (fst $ unzip es) ++ (snd $ unzip es)
+    newEdges ((a,b):eds) = case List.elemIndex a (map fst vs') of
+                           Nothing -> newEdges eds
+                           Just i -> case List.elemIndex b (map fst vs') of
+                                       Nothing -> newEdges eds
+                                       Just j -> [(i,j)] ++ newEdges eds
+    newEdges [] = []
+
+traverseGraph :: Int -> [Int] -> GraphM [PosetGraphEdge]
+traverseGraph i (l:ls) = do edgesLeft <- get
+                            let p = getPredecessors l edgesLeft
+                            put $ edgesLeft \\ p
+                            top <- traverseGraph i (map fst p)
+                            rest <- traverseGraph i ls
+                            return $ map ((+i) *** (+i)) p ++ top ++ rest
+  where
+    getPredecessors l e = [(x,y) | (x,y) <- e, y == l]
+
+traverseGraph _ [] = return []
+
+assertPosetGraph :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> PosetGraph -> m ()
+assertPosetGraph f i (PosetGraph vertices edges) = do let vcs = map assertPosetGraphVs vertices
+                                                          vc = foldl (.&&.) (constant True) $ vcs ++ assertPosetGraphEs edges
+                                                      liftSMT $ assert (f vc)
+                                                      --return
+  where
+    assertPosetGraphVs (v:[]) = constant True
+    assertPosetGraphVs (v:vs) = let c = map (\a -> mkRelation (fst i) (a, v) (.==.)) vs in
+                                  foldl (.&&.) (head c) $ tail c
+    assertPosetGraphVs [] = constant True
+    assertPosetGraphEs es = map (\(a,b) -> mkRelation (fst i) (head (vertices !! a), head (vertices !! b)) (.=>.)) es
+
+
+mkRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> SMTExpr Bool
+mkRelation i (BoolTerm argsf f, BoolTerm argsg g) r =
+  (f `app` lookupArgs argsf False (i, i)) `r` (g `app` lookupArgs argsg False (i, i))
+
+constructRs :: Set Term -> Type i -> [(Term, Term)]
+constructRs ts (GroundType BoolT) = [(x,y) | x@(BoolTerm _ _) <- Set.toList ts,
+                                      y@(BoolTerm _ _) <- Set.toList ts, x /= y]
+
+assertR :: MonadSMT m => [TypedExpr] -> (Term, Term) -> m ()
+assertR i (BoolTerm argsf f, BoolTerm argsg g) =
+  liftSMT $ assert ((f `app` (lookupArgs argsf False (i, i))) .=>.
+    (g `app` (lookupArgs argsg False (i, i))))
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 177cce3..3d430ec 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -24,6 +24,7 @@ import Language.SMTLib2
 import Strategy
 import LamaSMTTypes
 import Definition
+import Posets
 import TransformEnv
 import Model (Model, getModel)
 import Strategies.BMC
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 7e2de4d..48328e7 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -28,6 +28,7 @@ import SMTEnum
 import NatInstance
 import LamaSMTTypes
 import Definition
+import Posets
 import Internal.Monads
 
 data NodeEnv i = NodeEnv

From f551d847b32cd2571d013a13c62fa2200e04c0d5 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 5 Dec 2015 12:01:43 +0100
Subject: [PATCH 093/104] Code cleanup, remove redundant imports

---
 lamaSMT/Main.hs                      |  4 +---
 lamaSMT/lib/Definition.hs            |  4 +---
 lamaSMT/lib/LamaSMTTypes.hs          |  2 +-
 lamaSMT/lib/Model.hs                 | 31 ++++++++++++++--------------
 lamaSMT/lib/Posets.hs                | 17 +++++++--------
 lamaSMT/lib/Strategies/BMC.hs        |  3 ---
 lamaSMT/lib/Strategies/Invariant.hs  |  5 +----
 lamaSMT/lib/Strategies/KInduction.hs |  1 -
 lamaSMT/lib/Strategy.hs              |  7 ++-----
 lamaSMT/lib/Transform.hs             |  7 ++-----
 lamaSMT/lib/TransformEnv.hs          |  4 ----
 11 files changed, 31 insertions(+), 54 deletions(-)

diff --git a/lamaSMT/Main.hs b/lamaSMT/Main.hs
index 3840f8b..440c3df 100644
--- a/lamaSMT/Main.hs
+++ b/lamaSMT/Main.hs
@@ -7,8 +7,6 @@ import qualified Data.ByteString.Lazy.Char8 as BL
 
 import Text.PrettyPrint (Doc, render, vcat, text, ($$))
 import Data.List.Split (splitOn)
-import Data.List (intercalate)
-import Data.Natural
 
 import System.IO (stdin)
 import System.Environment (getArgs)
@@ -170,7 +168,7 @@ run opts@Options{..} file inp = do
   model <- runCheck opts
     ( (liftSMT $ mapM_ setOption optSMTOpts) >>
       lamaSMT optNatImpl optEnumImpl p >>=
-      (uncurry $ checkWithModel optNatImpl optStrategy) )
+      (uncurry $ checkWithModel optStrategy) )
   liftIO $ checkModel opts p model
 
 checkErrors :: Either Error a -> MaybeT IO a
diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 60ba859..66d82b1 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -1,7 +1,5 @@
 module Definition where
 
-import Lang.LAMA.Types
-
 import Language.SMTLib2 as SMT
 
 import Data.Array as Arr
@@ -17,7 +15,7 @@ data Definition =
 ensureDefinition :: [Int] -> Bool -> TypedFunc -> Definition
 ensureDefinition argN succ (BoolFunc s) = SingleDef argN succ s
 ensureDefinition argN succ (ProdFunc ps) = ProdDef $ fmap (ensureDefinition argN succ) ps
-ensureDefinition argN succ _
+ensureDefinition _ _ _
   = error $ "ensureDefinition: not a boolean function" -- : " ++ show s
 
 assertDefinition :: MonadSMT m =>
diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index 2ba571c..3c66f4c 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -136,7 +136,7 @@ instance Args (TypedExpr) where
   fromArgs (RealExpr xs) = fromArgs xs
   fromArgs (EnumExpr xs) = fromArgs xs
   fromArgs (ProdExpr xs) = concat $ fmap fromArgs $ Arr.elems xs
-  getSorts (_::TypedExpr) (BoolAnnotation ann) = error "lamasmt: no getSorts for TypedExpr"--getSorts (undefined::x) $ extractArgAnnotation ann
+  getSorts (_::TypedExpr) (BoolAnnotation _) = error "lamasmt: no getSorts for TypedExpr"--getSorts (undefined::x) $ extractArgAnnotation ann
   getArgAnnotation _ _ = error "lamasmt: getArgAnnotation undefined for TypedExpr"
   showsArgs n p (BoolExpr x) = let (showx,nn) = showsArgs n 11 x
                                in (showParen (p>10) $
diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index a0e69be..fe45e04 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -10,7 +10,6 @@ import Data.Array as Arr
 import Data.Monoid
 import Data.Maybe (fromJust)
 import qualified Data.List as List
-import Data.List (elemIndex)
 
 import Control.Monad.Reader (MonadReader(..), ReaderT(..))
 import Control.Applicative (Applicative(..), (<$>))
@@ -95,25 +94,25 @@ getVarsModel = mapM getVarModel
 
 --TODO
 getVarModel :: TypedExpr -> ModelM ValueStream
-getVarModel (BoolExpr s) = do vars   <- ask
-                              let i = fromJust $ List.elemIndex (BoolExpr s) (vars Map.! 0)
-                              stream <- liftSMT $ mapM (\l -> getValue $ unBool $ l !! i) vars
+getVarModel (BoolExpr s) = do varMap   <- ask
+                              let i = fromJust $ List.elemIndex (BoolExpr s) (varMap Map.! 0)
+                              stream <- liftSMT $ mapM (\l -> getValue $ unBool $ l !! i) varMap
                               return $ BoolVStream stream
-getVarModel (IntExpr s)  = do vars   <- ask
-                              let i = fromJust $ List.elemIndex (IntExpr s) (vars Map.! 0)
-                              stream <- liftSMT $ mapM (\l -> getValue $ unInt $ l !! i) vars
+getVarModel (IntExpr s)  = do varMap   <- ask
+                              let i = fromJust $ List.elemIndex (IntExpr s) (varMap Map.! 0)
+                              stream <- liftSMT $ mapM (\l -> getValue $ unInt $ l !! i) varMap
                               return $ IntVStream stream
-getVarModel (RealExpr s) = do vars   <- ask
-                              let i = fromJust $ List.elemIndex (RealExpr s) (vars Map.! 0)
-                              stream <- liftSMT $ mapM (\l -> getValue $ unReal $ l !! i) vars
+getVarModel (RealExpr s) = do varMap   <- ask
+                              let i = fromJust $ List.elemIndex (RealExpr s) (varMap Map.! 0)
+                              stream <- liftSMT $ mapM (\l -> getValue $ unReal $ l !! i) varMap
                               return $ RealVStream stream
-getVarModel (EnumExpr s) = do vars   <- ask
-                              let i = fromJust $ List.elemIndex (EnumExpr s) (vars Map.! 0)
-                              stream <- liftSMT $ mapM (\l -> getValue $ unEnum $ l !! i) vars
+getVarModel (EnumExpr s) = do varMap   <- ask
+                              let i = fromJust $ List.elemIndex (EnumExpr s) (varMap Map.! 0)
+                              stream <- liftSMT $ mapM (\l -> getValue $ unEnum $ l !! i) varMap
                               return $ EnumVStream stream
-getVarModel (ProdExpr s) = do vars <- ask
-                              let i = fromJust $ List.elemIndex (ProdExpr s) (vars Map.! 0)
-                                  newArg = Map.map (\l -> Arr.elems $ unProd $ l !! i) vars
+getVarModel (ProdExpr s) = do varMap <- ask
+                              let i = fromJust $ List.elemIndex (ProdExpr s) (varMap Map.! 0)
+                                  newArg = Map.map (\l -> Arr.elems $ unProd $ l !! i) varMap
                               stream <- liftSMT $ mapM (\a -> runReaderT (getVarModel a) newArg) s
                               return $ ProdVStream stream
 
diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
index 1bd7f15..84393e9 100644
--- a/lamaSMT/lib/Posets.hs
+++ b/lamaSMT/lib/Posets.hs
@@ -39,7 +39,7 @@ buildNextGraph (v0, v1) e = let leaves = getLeaves e
                                 otherEdges = evalState (traverseGraph i leaves) e
                                 in removeUnreachableNodes $ removeEmptyNodes $ PosetGraph (v0 ++ v1) (firstEdges ++ otherEdges)
   where
-    getLeaves e = [snd $ head e]
+    getLeaves ed = [snd $ head ed]
 
 removeEmptyNodes :: PosetGraph -> PosetGraph
 removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
@@ -72,21 +72,20 @@ traverseGraph i (l:ls) = do edgesLeft <- get
                             rest <- traverseGraph i ls
                             return $ map ((+i) *** (+i)) p ++ top ++ rest
   where
-    getPredecessors l e = [(x,y) | (x,y) <- e, y == l]
+    getPredecessors a e = [(x,y) | (x,y) <- e, y == a]
 
 traverseGraph _ [] = return []
 
 assertPosetGraph :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> PosetGraph -> m ()
-assertPosetGraph f i (PosetGraph vertices edges) = do let vcs = map assertPosetGraphVs vertices
-                                                          vc = foldl (.&&.) (constant True) $ vcs ++ assertPosetGraphEs edges
-                                                      liftSMT $ assert (f vc)
-                                                      --return
+assertPosetGraph f i (PosetGraph vs es) = do let vcs = map assertPosetGraphVs vs
+                                                 vc = foldl (.&&.) (constant True) $ vcs ++ assertPosetGraphEs es
+                                             liftSMT $ assert (f vc)
   where
-    assertPosetGraphVs (v:[]) = constant True
-    assertPosetGraphVs (v:vs) = let c = map (\a -> mkRelation (fst i) (a, v) (.==.)) vs in
+    assertPosetGraphVs (_:[]) = constant True
+    assertPosetGraphVs (vc:vcs) = let c = map (\a -> mkRelation (fst i) (a, vc) (.==.)) vcs in
                                   foldl (.&&.) (head c) $ tail c
     assertPosetGraphVs [] = constant True
-    assertPosetGraphEs es = map (\(a,b) -> mkRelation (fst i) (head (vertices !! a), head (vertices !! b)) (.=>.)) es
+    assertPosetGraphEs ecs = map (\(a,b) -> mkRelation (fst i) (head (vs !! a), head (vs !! b)) (.=>.)) ecs
 
 
 mkRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> SMTExpr Bool
diff --git a/lamaSMT/lib/Strategies/BMC.hs b/lamaSMT/lib/Strategies/BMC.hs
index 9e20d44..4457654 100644
--- a/lamaSMT/lib/Strategies/BMC.hs
+++ b/lamaSMT/lib/Strategies/BMC.hs
@@ -3,15 +3,12 @@
 module Strategies.BMC (BMC, assumeTrace, checkInvariant, bmcStep, assertPrecond, freshVars) where
 
 import Data.Natural
-import NatInstance
 import Data.List (stripPrefix)
 import qualified Data.Map as Map
 import Data.Map (Map)
 import qualified Data.Array as Array
-import Data.Array (Array)
 
 import Control.Monad.IO.Class
-import Control.Monad (when, liftM)
 import Control.Monad.State
 
 import Language.SMTLib2
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 3d430ec..e55c1ff 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -4,11 +4,8 @@ module Strategies.Invariant where
 
 import Debug.Trace
 
-import Lang.LAMA.Types
-
 import Data.Natural
-import NatInstance
-import Data.List (stripPrefix, partition)
+import Data.List (stripPrefix)
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Data.Maybe (fromMaybe, isJust, fromJust)
diff --git a/lamaSMT/lib/Strategies/KInduction.hs b/lamaSMT/lib/Strategies/KInduction.hs
index 8aae239..6572d7d 100644
--- a/lamaSMT/lib/Strategies/KInduction.hs
+++ b/lamaSMT/lib/Strategies/KInduction.hs
@@ -3,7 +3,6 @@
 module Strategies.KInduction where
 
 import Data.Natural
-import NatInstance
 import Data.List (stripPrefix)
 import qualified Data.Map as Map
 import Data.Map (Map)
diff --git a/lamaSMT/lib/Strategy.hs b/lamaSMT/lib/Strategy.hs
index 18be727..c88f427 100644
--- a/lamaSMT/lib/Strategy.hs
+++ b/lamaSMT/lib/Strategy.hs
@@ -4,13 +4,11 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 module Strategy where
 
-import Data.Map (Map)
 import Data.Natural
 import Control.Monad.Error
 
 import Language.SMTLib2
 
-import LamaSMTTypes
 import Definition
 import TransformEnv
 import Model
@@ -33,12 +31,11 @@ class StrategyClass s where
            -> ProgDefs
            -> SMTErr (StrategyResult i)
 
-checkWithModel :: SMTAnnotation Natural
-               -> Strategy
+checkWithModel :: Strategy
                -> ProgDefs
                -> Env i
                -> SMTErr (StrategyResult i)
-checkWithModel natAnn (Strategy s) d env = check s env d
+checkWithModel (Strategy s) d env = check s env d
 
 readOptions' :: String -> Strategy -> Strategy
 readOptions' o (Strategy s) = Strategy $ readOption o s
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index cc0122f..2cbc0b3 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -22,23 +22,20 @@ import Lang.LAMA.Typing.TypedStructure
 import Lang.LAMA.Types
 import Language.SMTLib2 as SMT
 import Language.SMTLib2.Internals (declareType, SMTExpr(Var))
-import Data.Unit
 import Data.String (IsString(..))
 import Data.Array as Arr
 
 import Data.Natural
 import NatInstance
 import qualified Data.Set as Set
-import Data.Set (Set, union, unions)
+import Data.Set (Set)
 import qualified Data.Map as Map
 import Data.Map (Map)
-import qualified Data.List as List
 import Data.List (zip4)
 import Prelude hiding (mapM)
 import Data.Traversable
 import Data.Foldable (foldlM, foldrM)
 import Data.Monoid
-import Data.Maybe
 
 import Control.Monad.Trans.Class
 import Control.Monad.State (StateT(..), MonadState(..), gets)
@@ -263,7 +260,7 @@ trOutput m = do
                  outList <- mapM (trOutput' s) m
                  return $ mkProdExpr outList
                where
-                 trOutput' s (i, te) = case lookup i (fst s) of
+                 trOutput' s (i, _) = case lookup i (fst s) of
                                        Nothing -> throwError $ "No argument (output) binding for " ++ identPretty i
                                        Just n -> return n
 
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 48328e7..e8bc905 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -12,14 +12,10 @@ import Language.SMTLib2 as SMT
 
 import Data.Array as Arr
 import qualified Data.List as List
-import Data.List (elemIndex)
 import qualified Data.Map as Map
 import Data.Map (Map)
-import qualified Data.Set as Set
-import Data.Set (Set)
 import Prelude hiding (mapM)
 import Data.Traversable
-import Data.List (replicate)
 
 import Control.Monad.State (StateT(..), MonadState(..), modify, gets)
 import Control.Monad.Error (ErrorT(..), MonadError(..))

From 00d9273af23fc2e78932e10fcd426a660798aca0 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Sat, 5 Dec 2015 15:03:35 +0100
Subject: [PATCH 094/104] Made invariant checks more generic for int
 implementation

---
 lamaSMT/lib/Posets.hs               | 46 ++++++++++++------------
 lamaSMT/lib/Strategies/Invariant.hs | 54 ++++++++++++++++++++---------
 2 files changed, 59 insertions(+), 41 deletions(-)

diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
index 84393e9..c719577 100644
--- a/lamaSMT/lib/Posets.hs
+++ b/lamaSMT/lib/Posets.hs
@@ -7,6 +7,8 @@ import Language.SMTLib2 as SMT
 import qualified Data.Set as Set
 import Data.Set (Set)
 import qualified Data.List as List
+import qualified Data.Map as Map
+import Data.Map (Map)
 import Data.List ((\\))
 import Control.Monad.State
 import Control.Arrow ((***))
@@ -21,18 +23,21 @@ data Term =
   | RealTerm [Int] (SMTFunction [TypedExpr] Rational)
   deriving (Show, Ord, Eq)
 
-type PosetGraphNode = [Term]
-type PosetGraphEdge = (Int, Int)
+type GraphNode = [Term]
+type GraphEdge = (Int, Int)
+type Chain     = [Term]
 
-data PosetGraph = PosetGraph
-                  { vertices :: [PosetGraphNode]
-                  , edges    :: [PosetGraphEdge]
-                  }
+data Poset =
+  PosetGraph [GraphNode] [GraphEdge]
+  | PosetChains [Chain] (Map Term [Term])
   deriving (Show, Ord, Eq)
 
-type GraphM = State [PosetGraphEdge]
+type GraphM = State [GraphEdge]
 
-buildNextGraph :: ([PosetGraphNode], [PosetGraphNode]) -> [PosetGraphEdge] -> PosetGraph
+initGraph :: [Term] -> Maybe Poset
+initGraph instSet = Just $ PosetGraph [instSet] []
+
+buildNextGraph :: ([GraphNode], [GraphNode]) -> [GraphEdge] -> Poset
 buildNextGraph (v0, v1) e = let leaves = getLeaves e
                                 i = length v0
                                 firstEdges = [(a, a+i) | a <- [0..i-1]] ++ e
@@ -41,7 +46,7 @@ buildNextGraph (v0, v1) e = let leaves = getLeaves e
   where
     getLeaves ed = [snd $ head ed]
 
-removeEmptyNodes :: PosetGraph -> PosetGraph
+removeEmptyNodes :: Poset -> Poset
 removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
   where
     vs' = filter (\(_,v) -> not $ null v) $ zip [0..] vs
@@ -51,8 +56,9 @@ removeEmptyNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
                                        Nothing -> newEdges eds
                                        Just j -> [(i,j)] ++ newEdges eds
     newEdges [] = []
+removeEmptyNodes _ = error "Poset is not a graph"
 
-removeUnreachableNodes :: PosetGraph -> PosetGraph
+removeUnreachableNodes :: Poset -> Poset
 removeUnreachableNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges es
   where
     vs' = filter (\a -> (elem (fst a) nodesWithEdges) || (length (snd a) > 1)) $ zip [0..] vs
@@ -63,8 +69,9 @@ removeUnreachableNodes (PosetGraph vs es) = PosetGraph (map snd vs') $ newEdges
                                        Nothing -> newEdges eds
                                        Just j -> [(i,j)] ++ newEdges eds
     newEdges [] = []
+removeUnreachableNodes _ = error "Poset is not a graph"
 
-traverseGraph :: Int -> [Int] -> GraphM [PosetGraphEdge]
+traverseGraph :: Int -> [Int] -> GraphM [GraphEdge]
 traverseGraph i (l:ls) = do edgesLeft <- get
                             let p = getPredecessors l edgesLeft
                             put $ edgesLeft \\ p
@@ -76,10 +83,10 @@ traverseGraph i (l:ls) = do edgesLeft <- get
 
 traverseGraph _ [] = return []
 
-assertPosetGraph :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> PosetGraph -> m ()
-assertPosetGraph f i (PosetGraph vs es) = do let vcs = map assertPosetGraphVs vs
-                                                 vc = foldl (.&&.) (constant True) $ vcs ++ assertPosetGraphEs es
-                                             liftSMT $ assert (f vc)
+assertPoset :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> Poset -> m ()
+assertPoset f i (PosetGraph vs es) = do let vcs = map assertPosetGraphVs vs
+                                            vc = foldl (.&&.) (constant True) $ vcs ++ assertPosetGraphEs es
+                                        liftSMT $ assert (f vc)
   where
     assertPosetGraphVs (_:[]) = constant True
     assertPosetGraphVs (vc:vcs) = let c = map (\a -> mkRelation (fst i) (a, vc) (.==.)) vcs in
@@ -91,12 +98,3 @@ assertPosetGraph f i (PosetGraph vs es) = do let vcs = map assertPosetGraphVs vs
 mkRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> SMTExpr Bool
 mkRelation i (BoolTerm argsf f, BoolTerm argsg g) r =
   (f `app` lookupArgs argsf False (i, i)) `r` (g `app` lookupArgs argsg False (i, i))
-
-constructRs :: Set Term -> Type i -> [(Term, Term)]
-constructRs ts (GroundType BoolT) = [(x,y) | x@(BoolTerm _ _) <- Set.toList ts,
-                                      y@(BoolTerm _ _) <- Set.toList ts, x /= y]
-
-assertR :: MonadSMT m => [TypedExpr] -> (Term, Term) -> m ()
-assertR i (BoolTerm argsf f, BoolTerm argsg g) =
-  liftSMT $ assert ((f `app` (lookupArgs argsf False (i, i))) .=>.
-    (g `app` (lookupArgs argsg False (i, i))))
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index e55c1ff..d48c2f9 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -64,7 +64,7 @@ instance StrategyClass Invar where
           n0  <- freshVars vars
           n1  <- freshVars vars
           assumeTrace defs (n0, n1)
-          let s0 = InductState baseK (vars, k1) (n0, n1) (Just $ PosetGraph [map fst . filter (\(x,y) -> (mod y 1) == 0) $ zip (instSetBool env) [1..]] []) Nothing
+          let s0 = InductState baseK (vars, k1) (n0, n1) (initGraph $ instSetBool env) Nothing Nothing Nothing
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
                 $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars) [n0]
@@ -85,8 +85,10 @@ data InductState = InductState
                    { kVal     :: Natural
                    , kDefs    :: ([TypedExpr], [TypedExpr])
                    , nDefs    :: ([TypedExpr], [TypedExpr])
-                   , binPoset :: Maybe PosetGraph
-                   , binInv   :: Maybe PosetGraph }
+                   , binPoset :: Maybe Poset
+                   , binInv   :: Maybe Poset
+                   , intPoset :: Maybe Poset
+                   , intInv   :: Maybe Poset }
 type KInductM i = StateT InductState (WriterT (Hints i) SMTErr)
 
 -- | Checks the program against its invariant. If the invariant
@@ -105,7 +107,7 @@ check' indOpts getModel defs pastVars pastNs =
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
      let statGraph = fromMaybe (fromMaybe (PosetGraph [] []) binInv) binPoset
      let statMessage = if (isJust binPoset) then "Possible " else "Actual "
-     liftIO $ when (printInvStats indOpts) (putStrLn $ statMessage ++ "Boolean Invariants:\n" ++ (show $ length $ vertices statGraph) ++ " Node(s) with\n" ++ (show $ length $ concat $ vertices statGraph) ++ " Element(s) and\n" ++ (show $ length $ edges statGraph) ++ " Edge(s)\n")
+     --liftIO $ when (printInvStats indOpts) (putStrLn $ statMessage ++ "Boolean Invariants:\n" ++ (show $ length $ vertices statGraph) ++ " Node(s) with\n" ++ (show $ length $ concat $ vertices statGraph) ++ " Element(s) and\n" ++ (show $ length $ edges statGraph) ++ " Edge(s)\n")
      rBMC <- bmcStep getModel defs pastVars kDefs
      case rBMC of
        Just m -> return $ Failure kVal m
@@ -114,16 +116,9 @@ check' indOpts getModel defs pastVars pastNs =
                 n1 = snd nDefs
                 pastNs' = pastNs ++ [n1]
             n2 <- freshVars n1
-            when (isJust binPoset) $
-              do binPoset' <- filterC (fromJust binPoset) kDefs
-                 case binPoset' of
-                   Just b  -> modify $ \indSt -> indSt { binPoset = Just b }
-                   Nothing -> do binInv' <- checkInvariantStep (fromJust binPoset) (n1,n2) pastNs defs
-                                 assertPosetGraph id (n1, n2) binInv'
-                                 modify $ \indSt -> indSt { binPoset = Nothing, binInv = Just binInv' }
             assertPrecond (n0, n1) $ invariantDef defs
-            when (isJust binInv) $ assertPosetGraph id (n1, n2) $ fromJust binInv
             modify $ \indSt -> indSt { nDefs = (n1, n2) }
+            heuristicInvariants defs pastNs
             (indSuccess, hints) <- liftSMT . stack $
               do r <- checkStep defs (n1, n2)
                  h <- retrieveHints (getModel pastVars) indOpts kVal r
@@ -150,10 +145,34 @@ check' indOpts getModel defs pastVars pastNs =
          put $ indState { kVal = k', kDefs = (k1, k2) }
          check' indOpts getModel defs pastVars' pNs
 
-filterC :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> m (Maybe PosetGraph)
+heuristicInvariants :: ProgDefs -> [[TypedExpr]] -> KInductM i ()
+heuristicInvariants defs pastNs = do
+  InductState{..} <- get
+  if (isJust binPoset)
+  then
+    do binPoset' <- filterC (fromJust binPoset) kDefs
+       case binPoset' of
+         Just b  -> modify $ \indSt -> indSt { binPoset = Just b }
+         Nothing -> do binInv' <- checkInvariantStep (fromJust binPoset) nDefs pastNs defs
+                       assertPoset id nDefs binInv'
+                       modify $ \indSt -> indSt { binPoset = Nothing, binInv = Just binInv' }
+  else
+    assertPoset id nDefs $ fromJust binInv
+  if (isJust intPoset)
+  then
+    do intPoset' <- filterC (fromJust intPoset) kDefs
+       case intPoset' of
+         Just i  -> modify $ \indSt -> indSt { intPoset = Just i }
+         Nothing -> do intInv' <- checkInvariantStep (fromJust intPoset) nDefs pastNs defs
+                       assertPoset id nDefs intInv'
+                       modify $ \indSt -> indSt { intPoset = Nothing, intInv = Just intInv' }
+  else
+    return ()--assertPoset id nDefs $ fromJust intInv
+
+filterC :: MonadSMT m => Poset -> ([TypedExpr], [TypedExpr]) -> m (Maybe Poset)
 filterC g@(PosetGraph v e) args =
   liftSMT $ do push
-               assertPosetGraph not' args g
+               assertPoset not' args g
                r  <- checkSat
                trace (show r) $ if r
                  then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v
@@ -162,10 +181,11 @@ filterC g@(PosetGraph v e) args =
                          return $ Just $ buildNextGraph (v0', v1') e
                   else pop >> return Nothing
 
-checkInvariantStep :: MonadSMT m => PosetGraph -> ([TypedExpr], [TypedExpr]) -> [[TypedExpr]] -> ProgDefs -> m PosetGraph
+checkInvariantStep :: MonadSMT m => Poset -> ([TypedExpr], [TypedExpr]) -> [[TypedExpr]] -> ProgDefs -> m Poset
+
 checkInvariantStep g args pastVars defs = liftSMT $ do
   push
-  mapM (\a -> assertPosetGraph id (a,a) g) $ pastVars
+  mapM (\a -> assertPoset id (a,a) g) $ pastVars
   assumeTrace defs args
   g' <- checkInvariantStep' g
   pop
@@ -173,7 +193,7 @@ checkInvariantStep g args pastVars defs = liftSMT $ do
   where
     checkInvariantStep' graph@(PosetGraph v e) = do
       push
-      assertPosetGraph not' args graph
+      assertPoset not' args graph
       r <- checkSat
       trace (show r) $ if r
         then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v

From 4088132c9fce0195994dd7f236f5a2044083ff9e Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 7 Dec 2015 14:41:47 +0100
Subject: [PATCH 095/104] Term does now take a type parameter

---
 lamaSMT/lib/Posets.hs       | 17 +++++++----------
 lamaSMT/lib/TransformEnv.hs | 12 ++++++------
 2 files changed, 13 insertions(+), 16 deletions(-)

diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
index c719577..e74b750 100644
--- a/lamaSMT/lib/Posets.hs
+++ b/lamaSMT/lib/Posets.hs
@@ -17,24 +17,21 @@ import LamaSMTTypes
 import Internal.Monads
 import Definition
 
-data Term =
-  BoolTerm [Int] (SMTFunction [TypedExpr] Bool)
-  | IntTerm [Int] (SMTFunction [TypedExpr] Integer)
-  | RealTerm [Int] (SMTFunction [TypedExpr] Rational)
+data Term a = Term [Int] (SMTFunction [TypedExpr] a)
   deriving (Show, Ord, Eq)
 
-type GraphNode = [Term]
+type GraphNode = [Term Bool]
 type GraphEdge = (Int, Int)
-type Chain     = [Term]
+type Chain     = [Term Integer]
 
 data Poset =
   PosetGraph [GraphNode] [GraphEdge]
-  | PosetChains [Chain] (Map Term [Term])
+  | PosetChains [Chain] (Map (Term Integer) [Term Integer])
   deriving (Show, Ord, Eq)
 
 type GraphM = State [GraphEdge]
 
-initGraph :: [Term] -> Maybe Poset
+initGraph :: [Term Bool] -> Maybe Poset
 initGraph instSet = Just $ PosetGraph [instSet] []
 
 buildNextGraph :: ([GraphNode], [GraphNode]) -> [GraphEdge] -> Poset
@@ -95,6 +92,6 @@ assertPoset f i (PosetGraph vs es) = do let vcs = map assertPosetGraphVs vs
     assertPosetGraphEs ecs = map (\(a,b) -> mkRelation (fst i) (head (vs !! a), head (vs !! b)) (.=>.)) ecs
 
 
-mkRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> SMTExpr Bool
-mkRelation i (BoolTerm argsf f, BoolTerm argsg g) r =
+mkRelation :: SMTType a => [TypedExpr] -> (Term a, Term a) -> (SMTExpr a -> SMTExpr a -> SMTExpr Bool) -> SMTExpr Bool
+mkRelation i (Term argsf f, Term argsg g) r =
   (f `app` lookupArgs argsf False (i, i)) `r` (g `app` lookupArgs argsg False (i, i))
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index e8bc905..8837603 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -47,8 +47,8 @@ data Env i = Env
            , varEnv :: VarEnv i
            , currAutomatonIndex :: Integer
            , varList :: [TypedExpr]
-           , instSetBool :: [Term]
-           , instSetInt :: [Term]
+           , instSetBool :: [Term Bool]
+           , instSetInt :: [Term Integer]
            , natImpl :: NatImplementation
            , enumImpl :: EnumImplementation
            }
@@ -90,9 +90,9 @@ getN x = do vars <- gets varList
 
 putTerm :: Ident i => [Int] -> TypedFunc -> DeclM i ()
 putTerm argsN (BoolFunc t) = 
-  modify $ \env -> env { instSetBool = instSetBool env ++ [BoolTerm argsN t] }
+  modify $ \env -> env { instSetBool = instSetBool env ++ [Term argsN t] }
 putTerm argsN (IntFunc t) = 
-  modify $ \env -> env { instSetBool = instSetBool env ++ [IntTerm argsN t] }
+  modify $ \env -> env { instSetInt = instSetInt env ++ [Term argsN t] }
 putTerm argsN _ = 
   modify $ \env -> env
 
@@ -101,8 +101,8 @@ getTypedValue (BoolExpr s) = liftSMT $ getValue s >>= return . BoolExpr . consta
 getTypedValue (IntExpr s) = liftSMT $ getValue s >>= return . IntExpr . constant
 getTypedValue e = liftSMT $ return $ getBottom e
 
-evalTerm :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> Term -> m Bool
-evalTerm i (BoolTerm args f) = liftSMT $ getValue $ f `app` (lookupArgs args False i)
+evalTerm :: SMTValue t => MonadSMT m => ([TypedExpr], [TypedExpr]) -> Term t -> m t
+evalTerm i (Term args f) = liftSMT $ getValue $ f `app` (lookupArgs args False i)
 
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()
 putEnumAnn eAnns =

From 9dc6685f833944d8274e8607d193c49224947b7f Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Tue, 8 Dec 2015 12:13:29 +0100
Subject: [PATCH 096/104] Alternatively try to use variables instead of
 expressions

---
 lamaSMT/lib/Posets.hs               | 24 ++++++++++++++----------
 lamaSMT/lib/Strategies/Invariant.hs |  8 ++++----
 lamaSMT/lib/Transform.hs            |  6 ++++--
 lamaSMT/lib/TransformEnv.hs         | 26 +++++++++++++++-----------
 4 files changed, 37 insertions(+), 27 deletions(-)

diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
index e74b750..bd236ea 100644
--- a/lamaSMT/lib/Posets.hs
+++ b/lamaSMT/lib/Posets.hs
@@ -17,21 +17,21 @@ import LamaSMTTypes
 import Internal.Monads
 import Definition
 
-data Term a = Term [Int] (SMTFunction [TypedExpr] a)
+data Term = BoolTerm Int | IntTerm Int
   deriving (Show, Ord, Eq)
 
-type GraphNode = [Term Bool]
+type GraphNode = [Term]
 type GraphEdge = (Int, Int)
-type Chain     = [Term Integer]
+type Chain     = [Term]
 
 data Poset =
   PosetGraph [GraphNode] [GraphEdge]
-  | PosetChains [Chain] (Map (Term Integer) [Term Integer])
+  | PosetChains [Chain] (Map Term [Term])
   deriving (Show, Ord, Eq)
 
 type GraphM = State [GraphEdge]
 
-initGraph :: [Term Bool] -> Maybe Poset
+initGraph :: [Term] -> Maybe Poset
 initGraph instSet = Just $ PosetGraph [instSet] []
 
 buildNextGraph :: ([GraphNode], [GraphNode]) -> [GraphEdge] -> Poset
@@ -86,12 +86,16 @@ assertPoset f i (PosetGraph vs es) = do let vcs = map assertPosetGraphVs vs
                                         liftSMT $ assert (f vc)
   where
     assertPosetGraphVs (_:[]) = constant True
-    assertPosetGraphVs (vc:vcs) = let c = map (\a -> mkRelation (fst i) (a, vc) (.==.)) vcs in
+    assertPosetGraphVs (vc:vcs) = let c = map (\a -> mkBoolRelation (fst i) (a, vc) (.==.)) vcs in
                                   foldl (.&&.) (head c) $ tail c
     assertPosetGraphVs [] = constant True
-    assertPosetGraphEs ecs = map (\(a,b) -> mkRelation (fst i) (head (vs !! a), head (vs !! b)) (.=>.)) ecs
+    assertPosetGraphEs ecs = map (\(a,b) -> mkBoolRelation (fst i) (head (vs !! a), head (vs !! b)) (.=>.)) ecs
 
 
-mkRelation :: SMTType a => [TypedExpr] -> (Term a, Term a) -> (SMTExpr a -> SMTExpr a -> SMTExpr Bool) -> SMTExpr Bool
-mkRelation i (Term argsf f, Term argsg g) r =
-  (f `app` lookupArgs argsf False (i, i)) `r` (g `app` lookupArgs argsg False (i, i))
+mkBoolRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool) -> SMTExpr Bool
+mkBoolRelation i (BoolTerm f, BoolTerm g) r =
+  (unBool $ head $ lookupArgs [f] False (i,i)) `r` (unBool $ head $ lookupArgs [g] False (i,i))
+
+mkIntRelation :: [TypedExpr] -> (Term, Term) -> (SMTExpr Integer -> SMTExpr Integer -> SMTExpr Bool) -> SMTExpr Bool
+mkIntRelation i (IntTerm f, IntTerm g) r =
+  (unInt $ head $ lookupArgs [f] False (i,i)) `r` (unInt $ head $ lookupArgs [g] False (i,i))
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index d48c2f9..974cae2 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -175,8 +175,8 @@ filterC g@(PosetGraph v e) args =
                assertPoset not' args g
                r  <- checkSat
                trace (show r) $ if r
-                 then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v
-                         v1' <- mapM (filterM $ evalTerm args) v
+                 then do v0' <- mapM (filterM (\a -> evalBoolTerm args a >>= return . not)) v
+                         v1' <- mapM (filterM $ evalBoolTerm args) v
                          pop
                          return $ Just $ buildNextGraph (v0', v1') e
                   else pop >> return Nothing
@@ -196,8 +196,8 @@ checkInvariantStep g args pastVars defs = liftSMT $ do
       assertPoset not' args graph
       r <- checkSat
       trace (show r) $ if r
-        then do v0' <- mapM (filterM (\a -> evalTerm args a >>= return . not)) v
-                v1' <- mapM (filterM $ evalTerm args) v
+        then do v0' <- mapM (filterM (\a -> evalBoolTerm args a >>= return . not)) v
+                v1' <- mapM (filterM $ evalBoolTerm args) v
                 pop
                 graph' <- checkInvariantStep' $ buildNextGraph (v0', v1') e
                 return graph'
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index 2cbc0b3..f602c28 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -129,6 +129,7 @@ declareVar :: Ident i => Variable i -> DeclM i ((i, TypedExpr))
 declareVar (Variable x t) =
   do v    <- typedVar (identString x) t
      putVar v
+     putTerm v
      return (x, v)
   where
     typedVar :: Ident i =>
@@ -320,7 +321,7 @@ declareDef x as ns succ ef =
      d           <- defFunc defType ann
                     $ \a -> liftRel (.==.) (head a) $ ef env $ zip (as ++ [error "Last argument must not be evaluated!"]) (tail a)
      let argsN   = ([xN] ++ ns)
-     putTerm argsN d
+     --putTerm argsN d
      return $ ensureDefinition argsN succ d
 
 varDefType :: TypedExpr -> Type i
@@ -617,6 +618,7 @@ mkLocationActivationCond activeCond e l =
      let cond = \_env t -> BoolExpr $ (unEnum $ snd $ last t) .==. lEnum
      activeVar <- liftSMT $ fmap BoolExpr $ varNamed condName
      lift $ putVar activeVar
+     lift $ putTerm activeVar
      argN <- lift $ getN e
      def <- lift $ declareConditionalAssign activeCond
             (const $ const $ BoolExpr $ constant False) activeVar [] [argN] False cond
@@ -734,7 +736,7 @@ declarePrecond activeCond e =
                  \a -> (flip (flip runTransM env) (zip args a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) c e')
-     putTerm argsN d
+     --putTerm argsN d
      return $ ensureDefinition argsN False d
 
 declareInvariant :: Ident i =>
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index 8837603..fe662a6 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -47,8 +47,8 @@ data Env i = Env
            , varEnv :: VarEnv i
            , currAutomatonIndex :: Integer
            , varList :: [TypedExpr]
-           , instSetBool :: [Term Bool]
-           , instSetInt :: [Term Integer]
+           , instSetBool :: [Term]
+           , instSetInt :: [Term]
            , natImpl :: NatImplementation
            , enumImpl :: EnumImplementation
            }
@@ -88,21 +88,25 @@ getN x = do vars <- gets varList
                           Nothing -> error $ "Could not be found in list of variables: " ++ show x
                           Just n -> n
 
-putTerm :: Ident i => [Int] -> TypedFunc -> DeclM i ()
-putTerm argsN (BoolFunc t) = 
-  modify $ \env -> env { instSetBool = instSetBool env ++ [Term argsN t] }
-putTerm argsN (IntFunc t) = 
-  modify $ \env -> env { instSetInt = instSetInt env ++ [Term argsN t] }
-putTerm argsN _ = 
-  modify $ \env -> env
+putTerm :: Ident i => TypedExpr -> DeclM i ()
+putTerm e@(BoolExpr s) = do
+  n <- getN e
+  modify $ \env -> env { instSetBool = instSetBool env ++ [BoolTerm n] }
+putTerm e@(IntExpr s) = do
+  n <- getN e
+  modify $ \env -> env { instSetInt = instSetInt env ++ [IntTerm n] }
+putTerm _ = return ()
 
 getTypedValue :: MonadSMT m => TypedExpr -> m (TypedExpr)
 getTypedValue (BoolExpr s) = liftSMT $ getValue s >>= return . BoolExpr . constant
 getTypedValue (IntExpr s) = liftSMT $ getValue s >>= return . IntExpr . constant
 getTypedValue e = liftSMT $ return $ getBottom e
 
-evalTerm :: SMTValue t => MonadSMT m => ([TypedExpr], [TypedExpr]) -> Term t -> m t
-evalTerm i (Term args f) = liftSMT $ getValue $ f `app` (lookupArgs args False i)
+evalBoolTerm :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> Term -> m Bool
+evalBoolTerm i (BoolTerm f) = liftSMT $ getValue $ unBool $ head $ lookupArgs [f] False i
+
+evalIntTerm :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> Term -> m Integer
+evalIntTerm i (IntTerm f) = liftSMT $ getValue $ unInt $ head $ lookupArgs [f] False i
 
 putEnumAnn :: Ident i => Map i (SMTAnnotation SMTEnum) -> DeclM i ()
 putEnumAnn eAnns =

From b54a9b4b5133a7e89e33960a4f687971f5715577 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 9 Dec 2015 15:39:00 +0100
Subject: [PATCH 097/104] Sorting algorithm for integer invariants

---
 lamaSMT/lib/Posets.hs               | 54 +++++++++++++++++++++++++++--
 lamaSMT/lib/Strategies/Invariant.hs | 36 ++++++++++++++++---
 2 files changed, 84 insertions(+), 6 deletions(-)

diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
index bd236ea..bb5deea 100644
--- a/lamaSMT/lib/Posets.hs
+++ b/lamaSMT/lib/Posets.hs
@@ -1,5 +1,7 @@
 module Posets where
 
+import Debug.Trace
+
 import Lang.LAMA.Types
 
 import Language.SMTLib2 as SMT
@@ -22,7 +24,11 @@ data Term = BoolTerm Int | IntTerm Int
 
 type GraphNode = [Term]
 type GraphEdge = (Int, Int)
-type Chain     = [Term]
+type ChainNode = ([Integer], [Term])
+type Chain     = [ChainNode]
+
+--instance Ord ChainNode where
+--  compare (is,_) (js,_) = foldl (\b (i,j) -> b &&  zip is js
 
 data Poset =
   PosetGraph [GraphNode] [GraphEdge]
@@ -31,9 +37,12 @@ data Poset =
 
 type GraphM = State [GraphEdge]
 
-initGraph :: [Term] -> Maybe Poset
+initGraph :: GraphNode -> Maybe Poset
 initGraph instSet = Just $ PosetGraph [instSet] []
 
+initChains :: [Term] -> Maybe Poset
+initChains instSet = Just $ PosetChains [[([], instSet)]] $ Map.singleton (head instSet) []
+
 buildNextGraph :: ([GraphNode], [GraphNode]) -> [GraphEdge] -> Poset
 buildNextGraph (v0, v1) e = let leaves = getLeaves e
                                 i = length v0
@@ -80,7 +89,48 @@ traverseGraph i (l:ls) = do edgesLeft <- get
 
 traverseGraph _ [] = return []
 
+type SortM = State ([Chain], Map Term [Term])
+
+buildNextChain :: [ChainNode] -> Poset
+buildNextChain ns = let s = execState (mapM insertChain ns) ([], Map.empty)
+                    in {-trace (show $ fst s) $ trace (show $ snd s) $-} PosetChains (fst s) (snd s)
+
+insertChain :: ChainNode -> SortM ()
+insertChain node = do chains <- get
+                      let res = unzip $ map (tryChain node) $ fst chains
+                          newChains = if fst chains == fst res then [[node]] else []
+                      put (fst res ++ newChains, Map.unions $ snd res ++ [snd chains, Map.singleton (head $ snd node) []])
+  where
+    tryChain :: ChainNode -> Chain -> (Chain, Map Term [Term])
+    tryChain n@(is,ts) c = let gB = List.findIndices (\a -> and $ map (\(b,c) -> b < c) $ zip (fst a) is) c
+                               i  = if List.length gB == 0 then 0 else (maximum gB) + 1
+                               lA = List.findIndices (\a -> and $ map (\(b,c) -> b > c) $ zip (fst a) is) c
+                               j  = if List.length lA == 0 then 0 else (minimum lA) + 1
+                           in if j == 1
+                             then ([n] ++ c, Map.empty)
+                             else if i == j - 1
+                               then let (cl,cr) = List.splitAt i c
+                                    in (cl ++ [n] ++ cr, Map.empty)
+                               else if i == List.length c
+                                 then (c ++ [n], Map.empty)
+                                 else let m1 = if i > 0 then Map.singleton (head $ snd (c !! (i - 1))) [head ts] else Map.empty
+                                          m2 = if j > 0 then Map.singleton (head ts) [head $ snd (c !! (j - 1))] else Map.empty
+                                      in (c, m1 `Map.union` m2)
+
 assertPoset :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> Poset -> m ()
+assertPoset f i (PosetChains cs m) = do let eq = concat $ map (map (assertEquality . snd)) cs
+                                            rep = map (map (head . snd)) cs
+                                            ccs = map assertChain rep
+                                            cc  = concat $ ccs ++ eq
+                                            c  = foldl (.&&.) (constant True) cc
+                                        liftSMT $ assert $ f c
+  where
+    assertEquality (_:[]) = [constant True]
+    assertEquality (t:ts) = map (\a -> mkIntRelation (fst i) (a, t) (.==.)) ts
+    assertChain [] = [constant True]
+    assertChain (_:[]) = [constant True]
+    assertChain (t:ts) = [mkIntRelation (fst i) (t, head ts) (.<=.)] ++ assertChain (m Map.! t) ++ assertChain ts
+    assertChain x = error $ "ha: " ++ show x
 assertPoset f i (PosetGraph vs es) = do let vcs = map assertPosetGraphVs vs
                                             vc = foldl (.&&.) (constant True) $ vcs ++ assertPosetGraphEs es
                                         liftSMT $ assert (f vc)
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 974cae2..52f2255 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -5,6 +5,7 @@ module Strategies.Invariant where
 import Debug.Trace
 
 import Data.Natural
+import qualified Data.List as List
 import Data.List (stripPrefix)
 import qualified Data.Map as Map
 import Data.Map (Map)
@@ -64,7 +65,7 @@ instance StrategyClass Invar where
           n0  <- freshVars vars
           n1  <- freshVars vars
           assumeTrace defs (n0, n1)
-          let s0 = InductState baseK (vars, k1) (n0, n1) (initGraph $ instSetBool env) Nothing Nothing Nothing
+          let s0 = InductState baseK (vars, k1) (n0, n1) (initGraph $ instSetBool env) Nothing (initChains $ instSetInt env) Nothing
           (r, hints) <- runWriterT
                 $ (flip evalStateT s0)
                 $ check' indOpts (getModel $ varEnv env) defs (Map.singleton baseK vars) [n0]
@@ -167,19 +168,35 @@ heuristicInvariants defs pastNs = do
                        assertPoset id nDefs intInv'
                        modify $ \indSt -> indSt { intPoset = Nothing, intInv = Just intInv' }
   else
-    return ()--assertPoset id nDefs $ fromJust intInv
+    assertPoset id nDefs $ fromJust intInv
 
 filterC :: MonadSMT m => Poset -> ([TypedExpr], [TypedExpr]) -> m (Maybe Poset)
 filterC g@(PosetGraph v e) args =
   liftSMT $ do push
                assertPoset not' args g
                r  <- checkSat
-               trace (show r) $ if r
+               if r
                  then do v0' <- mapM (filterM (\a -> evalBoolTerm args a >>= return . not)) v
                          v1' <- mapM (filterM $ evalBoolTerm args) v
                          pop
                          return $ Just $ buildNextGraph (v0', v1') e
                   else pop >> return Nothing
+filterC i@(PosetChains cs m) args =
+  liftSMT $ do push
+               assertPoset not' args i
+               r  <- checkSat
+               trace (show r) $ if r
+                 then do let nodes = concat cs
+                         part <- mapM (partitionChainNode args) nodes
+                         pop
+                         return $ Just $ buildNextChain $ concat part
+                  else pop >> return Nothing
+
+partitionChainNode :: MonadSMT m => ([TypedExpr], [TypedExpr]) -> ChainNode -> m [ChainNode]
+partitionChainNode args node = do values <- mapM (evalIntTerm args) $ snd node
+                                  let comb = zip values (snd node)
+                                      part = List.groupBy (\(a,_) (b,_) -> a == b) $ List.sort comb
+                                  return $ map (\n -> (fst node ++ [fst (head n)], map snd n)) part
 
 checkInvariantStep :: MonadSMT m => Poset -> ([TypedExpr], [TypedExpr]) -> [[TypedExpr]] -> ProgDefs -> m Poset
 
@@ -195,13 +212,24 @@ checkInvariantStep g args pastVars defs = liftSMT $ do
       push
       assertPoset not' args graph
       r <- checkSat
-      trace (show r) $ if r
+      if r
         then do v0' <- mapM (filterM (\a -> evalBoolTerm args a >>= return . not)) v
                 v1' <- mapM (filterM $ evalBoolTerm args) v
                 pop
                 graph' <- checkInvariantStep' $ buildNextGraph (v0', v1') e
                 return graph'
          else pop >> return graph
+    checkInvariantStep' chains@(PosetChains cs m) = do
+      push
+      assertPoset not' args chains
+      r <- checkSat
+      trace (show r) $ if r
+        then do let nodes = concat cs
+                part <- mapM (partitionChainNode args) nodes
+                pop
+                chains' <- checkInvariantStep' $ buildNextChain $ concat part
+                return chains'
+        else pop >> return chains
 
 -- | If requested, gets a model for the induction step
 retrieveHints :: SMT (Model i)

From 6e07e9cf9bec51cdd945bfcde6e6bfff4df12959 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 9 Dec 2015 16:43:46 +0100
Subject: [PATCH 098/104] Correct union of mapping for sorting

---
 lamaSMT/lib/Posets.hs | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
index bb5deea..526a73e 100644
--- a/lamaSMT/lib/Posets.hs
+++ b/lamaSMT/lib/Posets.hs
@@ -27,9 +27,6 @@ type GraphEdge = (Int, Int)
 type ChainNode = ([Integer], [Term])
 type Chain     = [ChainNode]
 
---instance Ord ChainNode where
---  compare (is,_) (js,_) = foldl (\b (i,j) -> b &&  zip is js
-
 data Poset =
   PosetGraph [GraphNode] [GraphEdge]
   | PosetChains [Chain] (Map Term [Term])
@@ -99,7 +96,7 @@ insertChain :: ChainNode -> SortM ()
 insertChain node = do chains <- get
                       let res = unzip $ map (tryChain node) $ fst chains
                           newChains = if fst chains == fst res then [[node]] else []
-                      put (fst res ++ newChains, Map.unions $ snd res ++ [snd chains, Map.singleton (head $ snd node) []])
+                      put (fst res ++ newChains, Map.unionsWith (++) $ snd res ++ [snd chains, Map.singleton (head $ snd node) []])
   where
     tryChain :: ChainNode -> Chain -> (Chain, Map Term [Term])
     tryChain n@(is,ts) c = let gB = List.findIndices (\a -> and $ map (\(b,c) -> b < c) $ zip (fst a) is) c

From 7eefa030ac78e4f12ff19e24ded8ad79c6d247ff Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 9 Dec 2015 17:46:24 +0100
Subject: [PATCH 099/104] Renewed invariant statistics

---
 lamaSMT/lib/Posets.hs               |  9 ++++++++-
 lamaSMT/lib/Strategies/Invariant.hs | 27 +++++++++++++++++----------
 2 files changed, 25 insertions(+), 11 deletions(-)

diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
index 526a73e..0cf9ca4 100644
--- a/lamaSMT/lib/Posets.hs
+++ b/lamaSMT/lib/Posets.hs
@@ -40,6 +40,13 @@ initGraph instSet = Just $ PosetGraph [instSet] []
 initChains :: [Term] -> Maybe Poset
 initChains instSet = Just $ PosetChains [[([], instSet)]] $ Map.singleton (head instSet) []
 
+getPosetStats :: Poset -> String
+getPosetStats (PosetGraph ns es) = (show $ sum (map (\i -> (List.length i) - 1) ns)) ++ " equalities and " ++ (show $ List.length es) ++  " inequalities"
+getPosetStats (PosetChains cs m) = (show $ sum $ Set.toList (Set.map (\(_,i) -> (List.length i) - 1) $ getChainNodeSet cs)) ++ " equalities and " ++ (show $ (sum (map (\i -> (List.length i) - 1) cs)) + (List.length $ concat $ Map.elems m)) ++  " inequalities"
+
+getChainNodeSet :: [Chain] -> Set ChainNode
+getChainNodeSet cs = foldl (\s t -> Set.insert t s) Set.empty $ concat cs
+
 buildNextGraph :: ([GraphNode], [GraphNode]) -> [GraphEdge] -> Poset
 buildNextGraph (v0, v1) e = let leaves = getLeaves e
                                 i = length v0
@@ -96,7 +103,7 @@ insertChain :: ChainNode -> SortM ()
 insertChain node = do chains <- get
                       let res = unzip $ map (tryChain node) $ fst chains
                           newChains = if fst chains == fst res then [[node]] else []
-                      put (fst res ++ newChains, Map.unionsWith (++) $ snd res ++ [snd chains, Map.singleton (head $ snd node) []])
+                      put (fst res ++ newChains, Map.unions{-With (++)-}  $ snd res ++ [snd chains, Map.singleton (head $ snd node) []])
   where
     tryChain :: ChainNode -> Chain -> (Chain, Map Term [Term])
     tryChain n@(is,ts) c = let gB = List.findIndices (\a -> and $ map (\(b,c) -> b < c) $ zip (fst a) is) c
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 52f2255..44bc982 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -106,9 +106,8 @@ check' :: Invar
 check' indOpts getModel defs pastVars pastNs =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
-     let statGraph = fromMaybe (fromMaybe (PosetGraph [] []) binInv) binPoset
-     let statMessage = if (isJust binPoset) then "Possible " else "Actual "
-     --liftIO $ when (printInvStats indOpts) (putStrLn $ statMessage ++ "Boolean Invariants:\n" ++ (show $ length $ vertices statGraph) ++ " Node(s) with\n" ++ (show $ length $ concat $ vertices statGraph) ++ " Element(s) and\n" ++ (show $ length $ edges statGraph) ++ " Edge(s)\n")
+     when (printInvStats indOpts) $ do invStats <- showInvStats
+                                       liftIO $ putStrLn invStats
      rBMC <- bmcStep getModel defs pastVars kDefs
      case rBMC of
        Just m -> return $ Failure kVal m
@@ -119,7 +118,7 @@ check' indOpts getModel defs pastVars pastNs =
             n2 <- freshVars n1
             assertPrecond (n0, n1) $ invariantDef defs
             modify $ \indSt -> indSt { nDefs = (n1, n2) }
-            heuristicInvariants defs pastNs
+            heuristicInvariants indOpts defs pastNs
             (indSuccess, hints) <- liftSMT . stack $
               do r <- checkStep defs (n1, n2)
                  h <- retrieveHints (getModel pastVars) indOpts kVal r
@@ -145,16 +144,23 @@ check' indOpts getModel defs pastVars pastNs =
          k2 <- freshVars k1
          put $ indState { kVal = k', kDefs = (k1, k2) }
          check' indOpts getModel defs pastVars' pNs
+    showInvStats = do
+      InductState{..} <- get
+      let boolStat = getPosetStats $ fromMaybe (fromJust binInv) binPoset
+          intStat  = getPosetStats $ fromMaybe (fromJust intInv) intPoset
+      return $ (if isJust binPoset then "Possible boolean invariants: " ++ boolStat else "Boolean invariants: " ++ boolStat) ++ "\n" ++ (if isJust intPoset then "Possible integer invariants: " ++ intStat else "Integer invariants: " ++ intStat)
 
-heuristicInvariants :: ProgDefs -> [[TypedExpr]] -> KInductM i ()
-heuristicInvariants defs pastNs = do
+heuristicInvariants :: Invar -> ProgDefs -> [[TypedExpr]] -> KInductM i ()
+heuristicInvariants indOpts defs pastNs = do
   InductState{..} <- get
   if (isJust binPoset)
   then
     do binPoset' <- filterC (fromJust binPoset) kDefs
        case binPoset' of
          Just b  -> modify $ \indSt -> indSt { binPoset = Just b }
-         Nothing -> do binInv' <- checkInvariantStep (fromJust binPoset) nDefs pastNs defs
+         Nothing -> do liftIO $ when (printInvStats indOpts) $ putStrLn "Trying to prove inductive boolean invariants..."
+                       binInv' <- checkInvariantStep (fromJust binPoset) nDefs pastNs defs
+
                        assertPoset id nDefs binInv'
                        modify $ \indSt -> indSt { binPoset = Nothing, binInv = Just binInv' }
   else
@@ -164,7 +170,8 @@ heuristicInvariants defs pastNs = do
     do intPoset' <- filterC (fromJust intPoset) kDefs
        case intPoset' of
          Just i  -> modify $ \indSt -> indSt { intPoset = Just i }
-         Nothing -> do intInv' <- checkInvariantStep (fromJust intPoset) nDefs pastNs defs
+         Nothing -> do liftIO $ when (printInvStats indOpts) $ putStrLn "Trying to prove inductive integer invariants..."
+                       intInv' <- checkInvariantStep (fromJust intPoset) nDefs pastNs defs
                        assertPoset id nDefs intInv'
                        modify $ \indSt -> indSt { intPoset = Nothing, intInv = Just intInv' }
   else
@@ -185,7 +192,7 @@ filterC i@(PosetChains cs m) args =
   liftSMT $ do push
                assertPoset not' args i
                r  <- checkSat
-               trace (show r) $ if r
+               if r
                  then do let nodes = concat cs
                          part <- mapM (partitionChainNode args) nodes
                          pop
@@ -223,7 +230,7 @@ checkInvariantStep g args pastVars defs = liftSMT $ do
       push
       assertPoset not' args chains
       r <- checkSat
-      trace (show r) $ if r
+      if r
         then do let nodes = concat cs
                 part <- mapM (partitionChainNode args) nodes
                 pop

From dc2c2c633f8c181a4e0529e0e45ec9002847ee92 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 9 Dec 2015 17:51:49 +0100
Subject: [PATCH 100/104] Assert integer equality just once

---
 lamaSMT/lib/Posets.hs | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
index 0cf9ca4..597fc54 100644
--- a/lamaSMT/lib/Posets.hs
+++ b/lamaSMT/lib/Posets.hs
@@ -122,11 +122,10 @@ insertChain node = do chains <- get
                                       in (c, m1 `Map.union` m2)
 
 assertPoset :: MonadSMT m => (SMTExpr Bool -> SMTExpr Bool) -> ([TypedExpr], [TypedExpr]) -> Poset -> m ()
-assertPoset f i (PosetChains cs m) = do let eq = concat $ map (map (assertEquality . snd)) cs
+assertPoset f i (PosetChains cs m) = do let eq = concat $ map (assertEquality . snd) $ Set.toList $ getChainNodeSet cs
                                             rep = map (map (head . snd)) cs
-                                            ccs = map assertChain rep
-                                            cc  = concat $ ccs ++ eq
-                                            c  = foldl (.&&.) (constant True) cc
+                                            cc = concat $ map assertChain rep
+                                            c  = foldl (.&&.) (constant True) $ cc ++ eq
                                         liftSMT $ assert $ f c
   where
     assertEquality (_:[]) = [constant True]

From 69b706c526f13a7fd02114c653a0bad8d9757606 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Wed, 9 Dec 2015 18:08:00 +0100
Subject: [PATCH 101/104] Introduced option to use just bool or int invariants

---
 lamaSMT/lib/Strategies/Invariant.hs | 26 +++++++++++++++++---------
 1 file changed, 17 insertions(+), 9 deletions(-)

diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 44bc982..7759270 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -34,12 +34,14 @@ data GenerateHints =
      | AllInductionSteps
 data Invar = Invar
                { depth :: Maybe Natural
-               , printProgress :: Bool
-               , printInvStats :: Bool
-               , generateHints :: GenerateHints }
+               , printProgress  :: Bool
+               , printInvStats  :: Bool
+               , boolInvariants :: Bool
+               , intInvariants  :: Bool
+               , generateHints  :: GenerateHints }
 
 instance StrategyClass Invar where
-  defaultStrategyOpts = Invar Nothing False False NoHints
+  defaultStrategyOpts = Invar Nothing False False True True NoHints
 
   readOption (stripPrefix "depth=" -> Just d) indOpts =
     case d of
@@ -49,6 +51,10 @@ instance StrategyClass Invar where
     indOpts { printProgress = True }
   readOption "invariant-stats" indOpts =
     indOpts { printInvStats = True }
+  readOption "only-bool-inv" indOpts =
+    indOpts { intInvariants = False }
+  readOption "only-int-inv" indOpts =
+    indOpts { boolInvariants = False }
   readOption (stripPrefix "hints" -> Just r) indOpts =
     case (stripPrefix "=" r) of
          Nothing    -> indOpts { generateHints = LastInductionStep }
@@ -56,7 +62,7 @@ instance StrategyClass Invar where
               "all"  -> indOpts { generateHints = AllInductionSteps }
               "last" -> indOpts { generateHints = LastInductionStep }
               _      -> error $ "Invalid hint option: " ++ which
-  readOption o _ = error $ "Invalid k-induction option: " ++ o
+  readOption o _ = error $ "Invalid invariant option: " ++ o
 
   check indOpts env defs =
     let baseK = 0
@@ -107,7 +113,7 @@ check' indOpts getModel defs pastVars pastNs =
   do InductState{..} <- get
      liftIO $ when (printProgress indOpts) (putStrLn $ "Depth " ++ show kVal)
      when (printInvStats indOpts) $ do invStats <- showInvStats
-                                       liftIO $ putStrLn invStats
+                                       liftIO $ putStr invStats
      rBMC <- bmcStep getModel defs pastVars kDefs
      case rBMC of
        Just m -> return $ Failure kVal m
@@ -148,12 +154,14 @@ check' indOpts getModel defs pastVars pastNs =
       InductState{..} <- get
       let boolStat = getPosetStats $ fromMaybe (fromJust binInv) binPoset
           intStat  = getPosetStats $ fromMaybe (fromJust intInv) intPoset
-      return $ (if isJust binPoset then "Possible boolean invariants: " ++ boolStat else "Boolean invariants: " ++ boolStat) ++ "\n" ++ (if isJust intPoset then "Possible integer invariants: " ++ intStat else "Integer invariants: " ++ intStat)
+          boolText = if isJust binPoset then "Possible boolean invariants: " ++ boolStat else "Boolean invariants: " ++ boolStat
+          intText  = if isJust intPoset then "Possible integer invariants: " ++ intStat else "Integer invariants: " ++ intStat
+      return $ (if boolInvariants indOpts then boolText ++ "\n" else "") ++ (if intInvariants indOpts then intText ++ "\n" else "")
 
 heuristicInvariants :: Invar -> ProgDefs -> [[TypedExpr]] -> KInductM i ()
 heuristicInvariants indOpts defs pastNs = do
   InductState{..} <- get
-  if (isJust binPoset)
+  when (boolInvariants indOpts) $ if (isJust binPoset)
   then
     do binPoset' <- filterC (fromJust binPoset) kDefs
        case binPoset' of
@@ -165,7 +173,7 @@ heuristicInvariants indOpts defs pastNs = do
                        modify $ \indSt -> indSt { binPoset = Nothing, binInv = Just binInv' }
   else
     assertPoset id nDefs $ fromJust binInv
-  if (isJust intPoset)
+  when (intInvariants indOpts) $ if (isJust intPoset)
   then
     do intPoset' <- filterC (fromJust intPoset) kDefs
        case intPoset' of

From c6711ef4151c9cd5421c97388e1763669f33b262 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 25 Jan 2016 21:38:51 +0100
Subject: [PATCH 102/104] Some code cleanup and comments

---
 lamaSMT/lib/Check.hs                |  2 +-
 lamaSMT/lib/Definition.hs           |  2 +-
 lamaSMT/lib/LamaSMTTypes.hs         | 24 +-----------------
 lamaSMT/lib/Model.hs                |  1 -
 lamaSMT/lib/Posets.hs               |  6 ++---
 lamaSMT/lib/Strategies/Invariant.hs | 23 ++++++++---------
 lamaSMT/lib/Transform.hs            | 36 +++-----------------------
 lamaSMT/lib/TransformEnv.hs         | 39 +----------------------------
 lamaSMT/lib/TypeInstances.hs        |  2 +-
 lamaSMT/lib/Wrapping.hs             |  2 +-
 10 files changed, 22 insertions(+), 115 deletions(-)

diff --git a/lamaSMT/lib/Check.hs b/lamaSMT/lib/Check.hs
index ff1ecc4..3ce8c96 100644
--- a/lamaSMT/lib/Check.hs
+++ b/lamaSMT/lib/Check.hs
@@ -3,4 +3,4 @@ module Check where
 import Strategy
 
 check :: Strategy s => 
-check = undefined
\ No newline at end of file
+check = undefined
diff --git a/lamaSMT/lib/Definition.hs b/lamaSMT/lib/Definition.hs
index 66d82b1..0c4c41c 100644
--- a/lamaSMT/lib/Definition.hs
+++ b/lamaSMT/lib/Definition.hs
@@ -16,7 +16,7 @@ ensureDefinition :: [Int] -> Bool -> TypedFunc -> Definition
 ensureDefinition argN succ (BoolFunc s) = SingleDef argN succ s
 ensureDefinition argN succ (ProdFunc ps) = ProdDef $ fmap (ensureDefinition argN succ) ps
 ensureDefinition _ _ _
-  = error $ "ensureDefinition: not a boolean function" -- : " ++ show s
+  = error $ "ensureDefinition: not a boolean function"
 
 assertDefinition :: MonadSMT m =>
                     (SMTExpr Bool -> SMTExpr Bool)
diff --git a/lamaSMT/lib/LamaSMTTypes.hs b/lamaSMT/lib/LamaSMTTypes.hs
index 3c66f4c..459342e 100644
--- a/lamaSMT/lib/LamaSMTTypes.hs
+++ b/lamaSMT/lib/LamaSMTTypes.hs
@@ -136,7 +136,7 @@ instance Args (TypedExpr) where
   fromArgs (RealExpr xs) = fromArgs xs
   fromArgs (EnumExpr xs) = fromArgs xs
   fromArgs (ProdExpr xs) = concat $ fmap fromArgs $ Arr.elems xs
-  getSorts (_::TypedExpr) (BoolAnnotation _) = error "lamasmt: no getSorts for TypedExpr"--getSorts (undefined::x) $ extractArgAnnotation ann
+  getSorts (_::TypedExpr) (BoolAnnotation _) = error "lamasmt: no getSorts for TypedExpr"
   getArgAnnotation _ _ = error "lamasmt: getArgAnnotation undefined for TypedExpr"
   showsArgs n p (BoolExpr x) = let (showx,nn) = showsArgs n 11 x
                                in (showParen (p>10) $
@@ -161,28 +161,6 @@ instance Args (TypedExpr) where
                                                   showChar ',' .
                                                   str . showChar ')') lst',ni)
 
-type StreamPos = SMTExpr Natural
-type Stream t = SMTFunction StreamPos t
-data TypedStream i
-  = BoolStream (Stream Bool)
-  | IntStream (Stream Integer)
-  | RealStream (Stream Rational)
-  | EnumStream EnumAnn (Stream SMTEnum)
-  | ProdStream (Array Int (TypedStream i))
-  deriving Show
-
-mkProdStream :: [TypedStream i] -> TypedStream i
-mkProdStream [] = error "Cannot create empty product stream"
-mkProdStream [s] = s
-mkProdStream sts = ProdStream . uncurry listArray $ ((0,) . pred . length &&& id) sts
-
-appStream :: TypedStream i -> StreamPos -> TypedExpr
-appStream (BoolStream s) n = BoolExpr $ s `app` n
-appStream (IntStream s) n = IntExpr $ s `app` n
-appStream (RealStream s) n = RealExpr $ s `app` n
-appStream (EnumStream _ s) n = EnumExpr $ s `app` n
-appStream (ProdStream s) n = ProdExpr $ fmap (`appStream` n) s
-
 liftAssert :: TypedExpr -> SMT ()
 liftAssert (BoolExpr e) = assert e
 liftAssert (ProdExpr es) = mapM_ liftAssert $ Arr.elems es
diff --git a/lamaSMT/lib/Model.hs b/lamaSMT/lib/Model.hs
index fe45e04..5b9123f 100644
--- a/lamaSMT/lib/Model.hs
+++ b/lamaSMT/lib/Model.hs
@@ -92,7 +92,6 @@ getNodeModel (NodeEnv i o e) =
 getVarsModel :: Map i (TypedExpr) -> ModelM (Map i ValueStream)
 getVarsModel = mapM getVarModel
 
---TODO
 getVarModel :: TypedExpr -> ModelM ValueStream
 getVarModel (BoolExpr s) = do varMap   <- ask
                               let i = fromJust $ List.elemIndex (BoolExpr s) (varMap Map.! 0)
diff --git a/lamaSMT/lib/Posets.hs b/lamaSMT/lib/Posets.hs
index 597fc54..62a13ef 100644
--- a/lamaSMT/lib/Posets.hs
+++ b/lamaSMT/lib/Posets.hs
@@ -1,7 +1,5 @@
 module Posets where
 
-import Debug.Trace
-
 import Lang.LAMA.Types
 
 import Language.SMTLib2 as SMT
@@ -97,13 +95,13 @@ type SortM = State ([Chain], Map Term [Term])
 
 buildNextChain :: [ChainNode] -> Poset
 buildNextChain ns = let s = execState (mapM insertChain ns) ([], Map.empty)
-                    in {-trace (show $ fst s) $ trace (show $ snd s) $-} PosetChains (fst s) (snd s)
+                    in PosetChains (fst s) (snd s)
 
 insertChain :: ChainNode -> SortM ()
 insertChain node = do chains <- get
                       let res = unzip $ map (tryChain node) $ fst chains
                           newChains = if fst chains == fst res then [[node]] else []
-                      put (fst res ++ newChains, Map.unions{-With (++)-}  $ snd res ++ [snd chains, Map.singleton (head $ snd node) []])
+                      put (fst res ++ newChains, Map.unions $ snd res ++ [snd chains, Map.singleton (head $ snd node) []])
   where
     tryChain :: ChainNode -> Chain -> (Chain, Map Term [Term])
     tryChain n@(is,ts) c = let gB = List.findIndices (\a -> and $ map (\(b,c) -> b < c) $ zip (fst a) is) c
diff --git a/lamaSMT/lib/Strategies/Invariant.hs b/lamaSMT/lib/Strategies/Invariant.hs
index 7759270..4efd238 100644
--- a/lamaSMT/lib/Strategies/Invariant.hs
+++ b/lamaSMT/lib/Strategies/Invariant.hs
@@ -2,8 +2,6 @@
 {-# LANGUAGE ViewPatterns #-}
 module Strategies.Invariant where
 
-import Debug.Trace
-
 import Data.Natural
 import qualified Data.List as List
 import Data.List (stripPrefix)
@@ -131,17 +129,16 @@ check' indOpts getModel defs pastVars pastNs =
                  return (r, h)
             tell hints
             let k' = succ kVal
-            --if indSuccess
-               --then return Success
-               --else case depth indOpts of
-            case depth indOpts of
-              Nothing -> cont k' pastVars pastNs'
-              Just l  ->
-                if k' > l
-                  then return $ Unknown ("Cancelled induction. Found no"
-                                           ++" proof within given depth")
-                                 []
-                  else cont k' pastVars pastNs'
+            if indSuccess
+               then return Success
+               else case depth indOpts of
+                      Nothing -> cont k' pastVars pastNs'
+                      Just l  ->
+                        if k' > l
+                          then return $ Unknown ("Cancelled induction. Found no"
+                                                   ++" proof within given depth")
+                                         []
+                          else cont k' pastVars pastNs'
   where
     cont k' pastVars pNs =
       do indState@InductState{..} <- get
diff --git a/lamaSMT/lib/Transform.hs b/lamaSMT/lib/Transform.hs
index bd79432..74faf36 100644
--- a/lamaSMT/lib/Transform.hs
+++ b/lamaSMT/lib/Transform.hs
@@ -150,19 +150,6 @@ declareVar (Variable x t) =
     typedVar v (ProdType ts) =
       do vs <- mapM (typedVar (v ++ "_comp")) ts
          return (ProdExpr $ listArray (0, (length vs) - 1) vs)
-{-
--- | Declares a stream of type Enum, including possible extra constraints on it.
-enumVar :: MonadSMT m
-           => SMTAnnotation Natural -> SMTAnnotation SMTEnum
-           -> m (Stream SMTEnum, [Definition])
-enumVar argAnn ann@(EnumTypeAnn _ _ _) = liftSMT (funAnn argAnn ann) >>= return . (, [])
-enumVar argAnn ann@(EnumBitAnn size _ biggestCons) =
-  do v <- liftSMT (funAnn argAnn ann)
-     constr <- liftSMT $
-               defFunAnn argAnn unit $
-               \t -> bvule (toBVExpr (v `app` t)) (constantAnn biggestCons size)
-     return (v, [SingleDef constr])
--}
 
 -- | Declares a node and puts the interface variables into the environment.
 -- Here it becomes crucial that a node is used at most once in a program, since
@@ -285,9 +272,8 @@ declareTransition activeCond (StateTransition x e) =
 
 -- | Creates a declaration for an assignment. Depending on the
 -- activation condition the given expression or a default expression
--- is used (generated by genDefault). Additionally the position in the
--- stream of /x/ which will be defined, can be specified by modPos
--- (see declareDef).
+-- is used (generated by genDefault). Additionally the cycle of the
+-- variable which will be defined, can be specified by succ.
 declareConditionalAssign :: Ident i =>
                             Maybe (i, TypedExpr)
                             -> (Env i -> [(i, TypedExpr)] -> TypedExpr)
@@ -307,10 +293,8 @@ declareConditionalAssign activeCond defaultExpr x as ns succ ef =
           condVar  = runTransM $ trExpr condExpr
       declareDef x (arg ++ as) ([condN] ++ ns) succ (\env t -> liftIte (condVar env t) (ef env t) (defaultExpr env t))
 
--- | Creates a definition for a given variable. Whereby a function to
--- manipulate the stream position at which it is defined is used (normally
--- id or succ' to define instances or state transitions).
--- The second argument /x/ is the stream to be defined and the last
+-- | Creates a definition for a given variable. 
+-- The first argument /x/ is the variable to be defined and the last
 -- argument (/ef/) is a function that generates the defining expression.
 declareDef :: Ident i => TypedExpr -> [i] -> [Int] -> Bool ->
               (Env i -> [(i, TypedExpr)] -> TypedExpr) -> DeclM i Definition
@@ -322,7 +306,6 @@ declareDef x as ns succ ef =
      d           <- defFunc defType ann
                     $ \a -> liftRel (.==.) (head a) $ ef env $ zip (as ++ [error "Last argument must not be evaluated!"]) (tail a)
      let argsN   = ([xN] ++ ns)
-     --putTerm argsN d
      return $ ensureDefinition argsN succ d
 
 varDefType :: TypedExpr -> Type i
@@ -737,7 +720,6 @@ declarePrecond activeCond e =
                  \a -> (flip (flip runTransM env) (zip args a))
 		       (trExpr e >>= \e' ->
                          return $ liftBool2 (.=>.) c e')
-     --putTerm argsN d
      return $ ensureDefinition argsN False d
 
 declareInvariant :: Ident i =>
@@ -754,11 +736,6 @@ trConstExpr (untyped -> ConstProd (Prod cs)) =
 
 type TransM i = ReaderT ([(i, TypedExpr)], Env i) (Either String)
 
-{-
-doAppStream :: TypedStream i -> TransM i (TypedExpr)
-doAppStream s = askStreamPos >>= return . appStream s
--}
-
 -- beware: uses error
 runTransM :: TransM i a -> Env i -> [(i, TypedExpr)] -> a
 runTransM m e a = case runReaderT m (a, e) of
@@ -778,11 +755,6 @@ lookupEnumConsAnn' t
   = asks (enumConsAnn . snd)
     >>= lookupErr ("Unknown enum constructor " ++ identPretty t) t
 
-{-
-askStreamPos :: TransM i StreamPos
-askStreamPos = asks fst
--}
-
 getArgList :: Ident i => Expr i ->  [i]
 getArgList expr = case untyped expr of
   AtExpr (AtomConst c)  -> []
diff --git a/lamaSMT/lib/TransformEnv.hs b/lamaSMT/lib/TransformEnv.hs
index fe662a6..2c579ef 100644
--- a/lamaSMT/lib/TransformEnv.hs
+++ b/lamaSMT/lib/TransformEnv.hs
@@ -162,36 +162,6 @@ nextAutomatonIndex = state $ \env ->
   let i = currAutomatonIndex env
   in (i, env { currAutomatonIndex = i+1 })
 
--- | Defines a stream analogous to defFun.
-defStream :: Ident i =>
-             Type i -> (StreamPos -> TypedExpr) -> DeclM i (TypedStream i)
-defStream ty sf = gets natImpl >>= \natAnn -> defStream' natAnn ty sf
-  where
-    defStream' :: Ident i =>
-                  NatImplementation -> Type i -> (StreamPos -> TypedExpr)
-                  -> DeclM i (TypedStream i)
-    defStream' natAnn (GroundType BoolT) f
-      = liftSMT . fmap BoolStream $ defFunAnn natAnn (unBool' . f)
-    defStream' natAnn (GroundType IntT) f
-      = liftSMT . fmap IntStream $ defFunAnn natAnn (unInt . f)
-    defStream' natAnn (GroundType RealT) f
-      = liftSMT . fmap RealStream $ defFunAnn natAnn (unReal . f)
-    defStream' natAnn (GroundType _) f = $notImplemented
-    defStream' natAnn (EnumType alias) f
-      = do ann <- lookupEnumAnn alias
-           liftSMT $ fmap (EnumStream ann) $ defFunAnn natAnn (unEnum . f)
-    -- We have to pull the product out of a stream.
-    -- If we are given a function f : StreamPos -> (Ix -> TE) = TypedExpr as above,
-    -- we would like to have as result something like:
-    -- g : Ix -> (StreamPos -> TE)
-    -- g(i)(t) = defStream(λt'.f(t')(i))(t)
-    -- Here i is the index into the product and t,t' are time variables.
-    defStream' natAnn (ProdType ts) f =
-      do let u = length ts - 1
-         x <- mapM defParts $ zip ts [0..u]
-         return . ProdStream $ listArray (0,u) x
-      where defParts (ty2, i) = defStream' natAnn ty2 ((! i) . unProd' . f)
-
 -- | Defines a function instead of streams
 defFunc :: Ident i =>
             Type i -> [TypedAnnotation] -> ([TypedExpr] -> TypedExpr) -> DeclM i (TypedFunc)
@@ -205,20 +175,13 @@ defFunc (GroundType _) ann f = $notImplemented
 defFunc (EnumType alias) ann f = do eann <- lookupEnumAnn alias
                                     liftSMT $ fmap (EnumFunc eann) $
                                       defFunAnn ann (unEnum . f)
--- We have to pull the product out of a stream.
--- If we are given a function f : FuncPos -> (Ix -> TE) = TypedExpr as above,
--- we would like to have as result something like:
--- g : Ix -> (FuncPos -> TE)
--- g(i)(t) = defFunc(λt'.f(t')(i))(t)
--- Here i is the index into the product and t,t' are time variables.
+-- We have to pull the product out of a function
 defFunc (ProdType ts) ann f =
   do let u = length ts - 1
      x <- mapM defParts $ zip ts [0..u]
      return . ProdFunc $ listArray (0,u) x
   where defParts (ty2, i) = defFunc ty2 ann ((! i) . unProd' . f)
 
--- stream :: Ident i => Type i -> DeclM i (Stream t)
-
 trConstant :: Ident i => Constant i -> TypedExpr
 trConstant (untyped -> BoolConst c) = BoolExpr $ constant c
 trConstant (untyped -> IntConst c) = IntExpr $ constant c
diff --git a/lamaSMT/lib/TypeInstances.hs b/lamaSMT/lib/TypeInstances.hs
index e8b4d36..72c82f0 100644
--- a/lamaSMT/lib/TypeInstances.hs
+++ b/lamaSMT/lib/TypeInstances.hs
@@ -20,4 +20,4 @@ instance SMTValue Natural where
   unmangle _ _ = return Nothing
 
   mangle (view -> Zero) _ = L.Symbol "zero"
-  mangle (view -> Succ n) a = L.List [L.Symbol "succ", mangle n a]
\ No newline at end of file
+  mangle (view -> Succ n) a = L.List [L.Symbol "succ", mangle n a]
diff --git a/lamaSMT/lib/Wrapping.hs b/lamaSMT/lib/Wrapping.hs
index 990f201..03e013e 100644
--- a/lamaSMT/lib/Wrapping.hs
+++ b/lamaSMT/lib/Wrapping.hs
@@ -28,4 +28,4 @@ firstM :: Monad m => (a -> m b) -> (a, c) -> m (b, c)
 firstM = ala Kleisli first
 
 fanoutM :: Monad m => (a -> m b) -> (a -> m b') -> a -> m (b, b')
-fanoutM f = ala Kleisli ((Kleisli f) &&&)
\ No newline at end of file
+fanoutM f = ala Kleisli ((Kleisli f) &&&)

From 5c99910797a3f2ee3b7572090d62b1c59145a649 Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 25 Jan 2016 21:39:51 +0100
Subject: [PATCH 103/104] Script for viewing the SMT-LIB stream

---
 lamaSMT/smt_stream.py | 13 +++++++++++++
 1 file changed, 13 insertions(+)
 create mode 100755 lamaSMT/smt_stream.py

diff --git a/lamaSMT/smt_stream.py b/lamaSMT/smt_stream.py
new file mode 100755
index 0000000..be783e2
--- /dev/null
+++ b/lamaSMT/smt_stream.py
@@ -0,0 +1,13 @@
+#!/usr/bin/python2
+
+import subprocess
+import re
+import sys
+
+pattern = re.compile(r"write\(4, \"(\(.*?)\\n")
+
+proc = subprocess.Popen("strace -s 5000 " + " ".join(sys.argv[1:]), stdout=subprocess.PIPE, stderr=subprocess.PIPE, shell=True)
+for line in proc.communicate()[1].splitlines():
+    match = pattern.search(line)
+    if match:
+        print match.group(1)

From b12608ce8fee554a952ae33cfe4c000824fc53fa Mon Sep 17 00:00:00 2001
From: Daniel Schraudner <daniel.schraudner@arcor.de>
Date: Mon, 25 Jan 2016 21:49:21 +0100
Subject: [PATCH 104/104] Version bump to lamasmt-0.3

---
 lamaSMT/LamaSMT.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/lamaSMT/LamaSMT.cabal b/lamaSMT/LamaSMT.cabal
index c38b050..bf48018 100644
--- a/lamaSMT/LamaSMT.cabal
+++ b/lamaSMT/LamaSMT.cabal
@@ -1,5 +1,5 @@
 Name:           LamaSMT
-Version:        0.2
+Version:        0.3
 Build-Type:     Simple
 Cabal-Version:  >= 1.10
 Description: