packages feed

sbv 11.7 → 12.0

raw patch · 187 files changed

+14366/−9973 lines, 187 filesdep +haskell-src-extsdep +haskell-src-metadep ~asyncdep ~libBF

Dependencies added: haskell-src-exts, haskell-src-meta

Dependency ranges changed: async, libBF

Files

CHANGES.md view
@@ -1,6 +1,69 @@ * Hackage: <http://hackage.haskell.org/package/sbv> * GitHub:  <http://github.com/LeventErkok/sbv> +### Version 12.0, 2025-07-04+  +  * [BACKWARDS COMPATIBILITY] Renamed KnuckleDragger to TP, for theorem-proving. The original name was confusing, and+    the design has diverged from Phil's tool in significant ways and goals.++  * TP:+      - Keep track of proofs with a unique id.+      - Removed theorem variants; lemmas are almost exclusively used and the only difference was in printing.+      - Add method rootOfTrust which can be used to retrieve uses of sorry in a proof. The idea is that+        to get a proof clean, you need to resolve all the proofs returned by this call.+      - Renamed kdShowDepsHTML to showProofTreeHTML. (Along with showProofTree which renders in ASCII.)+      - Renamed the unicode symbol for hints from ⁇ to ∵, which is more mathematical.+      - TP utils:+          - Add tpQuiet : quiets TP proofs+          - Add tpRibbon: simplifies setting the ribbon size in a proof.+          - Add tpStats : makes TP proofs print detailed statistics+          - Add tpCache : makes TP proofs use caching. This option can save time in re-running proofs. It comes+                with the proof-obligation on the user that all the name/type pairs used in lemmas are unique. See+                Documentation.SBV.Examples.TP.Basics for an example demonstration.+        Note that all these utils will be in effect with the closest call to runTP/runTPWith. If you change the+        solver for a specific lemma, we'll only change the solver, not TP-options.+      - Generalize various TP list/sort proofs.+      - Added qc/qcWith helpers, which allow you to run quick-check on specific proof steps+      - Added disp as TP helper: It allows you to print the value of arbitrary expressions if a proof-step fails. Good for debugging.++   * New TP examples:+      - Documentation.SBV.Examples.TP.Fibonacci:  Proving tail-recursive fibonacci is equivalent to textbook definition+      - Documentation.SBV.Examples.TP.Majority:   Proof of Boyer-Moore's majority selection algorithm correct.+      - Documentation.SBV.Examples.TP.McCarthy91: Proof of correctness for McCarthy's 91 function.+      - Documentation.SBV.Examples.TP.PowerMod:   Proving arithmetic properties relating power operation and modular arithmetic.+      - Documentation.SBV.Examples.TP.ReverseAcc: Proving the accummulating reverse definition is correct.+      - Documentation.SBV.Examples.TP.Reverse:    Proving a definition of reverse that uses no auxiliary definitions is correct.+      - Documentation.SBV.Examples.TP.SumReverse: Proving summing a list and its reverse are equivalent.++  * [BACKWARDS COMPATIBILITY] Reworked enum instances for symbolic values. Removed old Enum class instances for symbolic values,+    as that API is not compatible with symbolic values, and only worked when the arguments used were literal constants. There is+    now a new class 'EnumSymbolic' which has the exact same methods as 'Enum', except their types are more symbolic friendly. (For+    instance, enumerations produce symbolic ists.) These definitions are now much more symbolic/proof friendly as well. In particular,+    there is now an sEnum quasiquoter that allows you to construct symbolic enumerations of the form [|sEnum|a, b .. c|] etc., akin to+    regular Haskell enumerations but working on symbolic values and constructing symbolic lists. If you had old code that relied+    on Enum instances over constant symbolic values, you might have to use the underlying type for the enum, and then lift to+    the symbolic level. Please get in touch if this causes issues.++  * [BACKWARDS COMPATIBILITY] Remove Data.SBV.Tools.NaturalInduction. The functionality provided by this tool is much better+    addressed by TP'sinduction methods. If you were using this functionality and have problems+    porting to TP, please get in touch!++  * Added functions 'takeWhile', 'dropWhile', 'sum', 'product', 'last', 'replicate', '\\', upFromTo, upFrom,+    downFromTo, and downFrom to Data.SBV.List; corresponding to the symbolic equivalents of usual list processing functions.++  * [BACKWARDS COMPATIBILITY] Removed Data.SBV.String, and unified list and string functions just as in Haskell. This was a+    long-time wart in SBV, where we distinguished strings and list of characters since SMTLib does not equate them. SBV now+    treats these uniformly, obviating the need for Data.SBV.String.++  * Improved smt-function definitions: You can now define polymorphic, recursive, and higher-order functions in SBV+    that will be translated to SMTLib functions, without expanding them. Polymorphic functions get monomorphised. Recursive+    functions are supported, including mutual recursion.++    NB. For higher-order functions, if the function passed (whether named or lambda defined) as the higher-order argument have+    free variables, you must create a closure. See the 'Closure' type. If they are already closed, then you can use them as is.++    See 'smtFunction' and 'smtHOFunction' for details.+ ### Version 11.7, 2025-05-16    * KnuckleDragger: Add a proof of correctness for the quick-sort algorithm.@@ -2739,9 +2802,6 @@    * Add a hook so users can add custom script segments for SMT solvers. The new     "solverTweaks" field in the SMTConfig data-type can be used for this purpose.-    The need for this came about due to the need to workaround a Z3 v3.2 issue-    detailed below:-      http://stackoverflow.com/questions/9426420/soundness-issue-with-integer-bv-mixed-benchmarks     As a consequence, mixed Integer/BV problems can cause soundness issues in Z3     and does in SBV. Unfortunately, it is too severe for SBV to add the workaround     option, as it slows down the solver as a side effect as well. Thus, we are
Data/SBV.hs view
@@ -132,7 +132,7 @@ -- --   * MathSAT from Fondazione Bruno Kessler and DISI-University of Trento: <http://mathsat.fbk.eu/> -----   * Yices from SRI: <http://yices.csl.sri.com/>+--   * Yices from SRI: <http://github.com/SRI-CSL/yices2> -- --   * DReal from CMU: <http://dreal.github.io/> --@@ -150,31 +150,34 @@ -- get in touch if there is a solver you'd like to see included. -- ----- __KnuckleDragger: Semi-automated theorem proving__+-- __TP: Semi-automated theorem proving__ -- -- While SMT solvers are quite powerful, there is a certain class of problems that they are just not well suited for. In particular, SMT -- solvers are not good at proofs that require induction, or those that require complex chains of reasoning. Induction is necessary to reason about -- any recursive algorithm, and most such proofs require carefully constructed equational steps. ----- SBV allows for a style of semi-automated theorem proving, called KnuckleDragger, that can be used to construct such proofs.--- The documentation includes example proofs for many list functions, and even inductive proofs for the familiar insertion--- and merge-sort algorithms, along with a proof that the square-root of 2 is irrational. While a proper theorem prover (such as Lean, Isabelle--- etc.) is a more appropriate choice for such proofs, with some guidance (and acceptance of a much larger trusted code base!), SBV can--- be used to establish correctness of various mathematical claims and algorithms that are usually beyond the scope of SMT--- solvers alone. See "Data.SBV.Tools.KnuckleDragger" for the API, and+-- SBV allows for a style of semi-automated theorem proving, called TP. which can be used to construct such proofs.+-- The documentation includes example proofs for many list functions, and even inductive proofs for+-- the familiar insertion, merge, quick-sort algorithms, along with a proof that the square-root of 2 is irrational.+-- While a proper theorem prover (such as Lean, Isabelle etc.) is a more appropriate choice for such proofs, with some+-- guidance (and acceptance of a much larger trusted code base!), SBV can be used to establish correctness of various mathematical+-- claims and algorithms that are usually beyond the scope of SMT solvers alone.+-- See "Data.SBV.TP" for the API, and -----    - "Documentation.SBV.Examples.KnuckleDragger.InsertionSort"---    - "Documentation.SBV.Examples.KnuckleDragger.MergeSort"---    - "Documentation.SBV.Examples.KnuckleDragger.Sqrt2IsIrrational"---    - "Documentation.SBV.Examples.KnuckleDragger.ShefferStroke"---    - "Documentation.SBV.Examples.KnuckleDragger.Lists"+--    - "Documentation.SBV.Examples.TP.BinarySearch"+--    - "Documentation.SBV.Examples.TP.InsertionSort"+--    - "Documentation.SBV.Examples.TP.MergeSort"+--    - "Documentation.SBV.Examples.TP.QuickSort"+--    - "Documentation.SBV.Examples.TP.Sqrt2IsIrrational"+--    - "Documentation.SBV.Examples.TP.ShefferStroke"+--    - "Documentation.SBV.Examples.TP.Lists" -- -- for various proofs performed in this style. ----- Note that knuckle-dragger proofs are upto termination, i.e., if you axiomatize+-- Note that SBV's TP proofs are upto termination, i.e., if you axiomatize -- non-terminating behavior, then you can prove arbitrary results. SBV neither -- checks nor ensures termination, which is beyond its scope and capabilities.--- So, any KnuckleDragger proof should be considered true so long as all functions+-- So, any TP proof should be considered true so long as all functions -- used in the property are terminating. ----------------------------------------------------------------------------- @@ -233,6 +236,8 @@   -- ** Symbolic lists   -- $lists   , SList+  -- ** Symbolic enumerators+  , EnumSymbolic(..), sEnum   -- ** Tuples   -- $tuples   , SymTuple, STuple, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, STuple8@@ -241,7 +246,7 @@   -- ** Sets   , RCSet(..), SSet   -- * Arrays of symbolic values-  , SArray, sArray, sArray_, sArrays, readArray, writeArray, lambdaArray, listArray+  , SArray, sArray, sArray_, sArrays, readArray, writeArray, lambdaArray, listArray, ArrayModel    -- * Creating symbolic values   -- ** Single value@@ -346,7 +351,7 @@   , mkUninterpretedSort    -- * Stopping unrolling: Defined functions-  , SMTDefinable(..), registerType+  , SMTDefinable(..), smtHOFunction, Closure(..), registerType    -- * Special relations   -- $specialRels@@ -439,7 +444,7 @@   , getModelDictionaries, getModelValues, getModelUninterpretedValues    -- * SMT Interface-  , SMTConfig(..), KDOptions(..), Timing(..), SMTLibVersion(..), Solver(..), SMTSolver(..)+  , SMTConfig(..), TPOptions(..), Timing(..), SMTLibVersion(..), Solver(..), SMTSolver(..)   -- ** Controlling verbosity   -- $verbosity @@ -539,9 +544,9 @@ import Data.Kind  (Type) import GHC.TypeLits (KnownNat, type (<=), type (+), type (-)) -import Prelude hiding((+), (-)) -- to avoid the haddock ambiguity- import Data.Char (isSpace, isPunctuation)+import Data.SBV.List (EnumSymbolic(..))+import Data.SBV.SEnum (sEnum)  #ifdef DOCTEST --- $setup@@ -852,7 +857,7 @@ Support for characters, strings, and regular expressions (initial version contributed by Joel Burget) adds support for QF_S logic, described here: <https://smt-lib.org/theories-UnicodeStrings.shtml> -See "Data.SBV.Char", "Data.SBV.String", "Data.SBV.RegExp" for related functions.+See "Data.SBV.Char", "Data.SBV.List", "Data.SBV.RegExp" for related functions. -}  {- $lists@@ -1132,7 +1137,7 @@ A simple example is:  @-    data X = A | B | C+    data X = A | B | C deriving (Enum, Bounded)     mkSymbolicEnumeration ''X @ @@ -1144,7 +1149,8 @@ >   LANGUAGE DeriveDataTypeable >   LANGUAGE DeriveAnyClass -The declaration will automatically introduce the type:+and your own declaration must have instances of 'Enum' and 'Bounded'. (The instances can be derived, as above.)+This will automatically introduce the type:  @     type SX = SBV X@@ -1152,7 +1158,8 @@  along with symbolic values of each of the enumerated values @sA@, @sB@, and @sC@. This way, you can refer to the symbolic version as @SX@, treating it as a regular symbolic type ranging over the values @A@, @B@, and @C@. Such values can be compared for equality, and with the usual-other comparison operators, such as @.==@, @./=@, @.>@, @.>=@, @<@, and @<=@. For each enumerated value @X@, the symbolic versions @sX@ is defined to be equal to @literal X@.+other comparison operators, such as @.==@, @./=@, @.>@, @.>=@, @<@, and @<=@. For each enumerated value @X@, the symbolic versions @sX@ is defined to be equal to @literal X@. Furthermore, the symbolic type will be an instance of 'EnumSymbolic', allowing you to use+arithmetic progressions on symbolic values.  A simple query would look like:
Data/SBV/Char.hs view
@@ -22,11 +22,13 @@ -----------------------------------------------------------------------------  {-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedLists     #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE Rank2Types          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}  module Data.SBV.Char (         -- * Occurrence in a string@@ -44,7 +46,7 @@         , isAscii, isLatin1, isAsciiUpper, isAsciiLower         ) where -import Prelude hiding (elem, notElem)+import Prelude hiding (elem, notElem, Enum(..)) import qualified Prelude as P  import Data.SBV.Core.Data@@ -52,20 +54,22 @@  import qualified Data.Char as C -import Data.SBV.String (isInfixOf, singleton)+import Data.SBV.List (EnumSymbolic(..))+import qualified Data.SBV.List as SL  #ifdef DOCTEST -- $setup -- >>> import Data.SBV--- >>> import Data.SBV.String (isInfixOf, singleton)+-- >>> import Data.SBV.List (isInfixOf) -- >>> import Prelude hiding(elem, notElem)+-- >>> :set -XOverloadedLists -- >>> :set -XOverloadedStrings #endif  -- | Is the character in the string? -- -- >>> :set -XOverloadedStrings--- >>> prove $ \c -> c `elem` singleton c+-- >>> prove $ \c -> c `elem` [c] -- Q.E.D. -- >>> prove $ \c -> sNot (c `elem` "") -- Q.E.D.@@ -76,7 +80,7 @@  | Just cs <- unliteral s                            -- If only the second string is concrete, element-wise checking is still much better!  = sAny (c .==) $ map literal cs  | True- = singleton c `isInfixOf` s+ = [c] `SL.isInfixOf` s  -- | Is the character not in the string? --@@ -288,3 +292,26 @@ -- Q.E.D. isAsciiLower :: SChar -> SBool isAsciiLower = liftPredL1 C.isAsciiLower++-- | Symbolic enum instance for symbolic characters+instance EnumSymbolic Char where+   succ     = smtFunction "EnumSymbolic.Char.succ"   (\x -> ite (x .== maxBound) (some "EnumSymbolic.Char.succ_maxBound" (const sTrue)) (chr (ord x + 1)))+   pred     = smtFunction "EnumSymbolic.Char.pred"   (\x -> ite (x .== minBound) (some "EnumSymbolic.Char.pred_minBound" (const sTrue)) (chr (ord x - 1)))+   toEnum   = smtFunction "EnumSymbolic.Char.toEnum" (\x ->+                            ite (x .< ord (minBound :: SChar)) (some "EnumSymbolic.Char.toEnum.<minBound" (const sTrue))+                          $ ite (x .> ord (maxBound :: SChar)) (some "EnumSymbolic.Char.toEnum.>maxBound" (const sTrue))+                          $ chr x)++   fromEnum = ord++   enumFrom n   = SL.map chr (enumFromTo @Integer (ord n) (ord (maxBound @SChar)))+   enumFromThen = smtFunction "EnumSymbolic.Char.enumFromThen" $ \n1 n2 ->+                              let i_n1, i_n2 :: SInteger+                                  i_n1 = ord n1+                                  i_n2 = ord n2+                              in SL.map chr (ite (i_n2 .>= i_n1)+                                                 (enumFromThenTo i_n1 i_n2 (ord (maxBound @SChar)))+                                                 (enumFromThenTo i_n1 i_n2 (ord (minBound @SChar))))++   enumFromTo     n m   = SL.map chr (enumFromTo     @Integer (ord n) (ord m))+   enumFromThenTo n m t = SL.map chr (enumFromThenTo @Integer (ord n) (ord m) (ord t))
Data/SBV/Client.hs view
@@ -16,7 +16,12 @@ {-# LANGUAGE StandaloneDeriving  #-} {-# LANGUAGE TemplateHaskell     #-} +#if MIN_VERSION_template_haskell(2,22,1) {-# OPTIONS_GHC -Wall -Werror #-}+#else+{-# LANGUAGE DeriveLift #-}+{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+#endif  module Data.SBV.Client   ( sbvCheckSolverInstallation@@ -29,6 +34,10 @@ import Control.Monad (filterM) import Data.Generics +import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum)++import qualified Data.SBV.List as SL+ import qualified Control.Exception as C  import qualified "template-haskell" Language.Haskell.TH        as TH@@ -66,7 +75,18 @@ getAvailableSolvers :: IO [SMTConfig] getAvailableSolvers = filterM sbvCheckSolverInstallation (map defaultSolverConfig [minBound .. maxBound]) --- | Turn a name into a symbolic type. If first argument is true, we'll also derive Eq and Ord instances.+#if MIN_VERSION_template_haskell(2,22,1)+-- Starting template haskell 2.22.1 the following instances are automatically provided+#else+deriving instance TH.Lift TH.OccName+deriving instance TH.Lift TH.NameSpace+deriving instance TH.Lift TH.PkgName+deriving instance TH.Lift TH.ModName+deriving instance TH.Lift TH.NameFlavour+deriving instance TH.Lift TH.Name+#endif++-- | Turn a name into a symbolic type. If first argument is true, then we're doing an enumeration, otherwise it's an uninterpreted type declareSymbolic :: Bool -> TH.Name -> TH.Q [TH.Dec] declareSymbolic isEnum typeName = do     let typeCon = TH.conT typeName@@ -74,21 +94,60 @@     cstrs <- if isEnum then ensureEnumeration typeName                        else ensureEmptyData   typeName -    deriveEqOrds <- if isEnum-                       then [d| deriving instance Eq       $typeCon-                                deriving instance Ord      $typeCon-                            |]-                       else pure []-     derives <- [d| deriving instance Show     $typeCon                    deriving instance Read     $typeCon                    deriving instance Data     $typeCon-                   deriving instance SymVal   $typeCon                    deriving instance HasKind  $typeCon                    deriving instance SatModel $typeCon                |] +    symVals <- if isEnum+                  then [d| instance SymVal $typeCon where+                             minMaxBound = Just (minBound, maxBound) +                           instance Arbitrary $typeCon where+                             arbitrary = arbitraryBoundedEnum+                       |]+                  else [d| instance SymVal $typeCon where+                             minMaxBound = Nothing++                           -- It's unfortunate we have to give this instance to make things+                           -- simple; but uninterpreted types don't really fit with the testing strategy.+                           instance {-# OVERLAPPABLE #-} Arbitrary $typeCon where+                             arbitrary = error $ unlines [ ""+                                                         , "*** Data.SBV: Cannot quickcheck the given property."+                                                         , "***"+                                                         , "*** Default arbitrary instance for " ++ TH.nameBase typeName ++ " is too limited."+                                                         , "***"+                                                         , "*** You can overcome this by giving your own Arbitrary instance."+                                                         , "*** Please get in touch if this workaround is not suitable for your case."+                                                         ]+                       |]++    symEnum <- if isEnum+                  then [d| instance SL.EnumSymbolic $typeCon where+                              succ     x = let elts = [minBound .. maxBound] in x `SL.lookup` literal (zip elts (drop 1 elts))+                              pred     x = let elts = [minBound .. maxBound] in x `SL.lookup` literal (zip (drop 1 elts) elts)++                              toEnum   x = let elts = [minBound .. maxBound] in x `SL.lookup` literal (zip [0..] elts)+                              fromEnum x = let elts = [minBound .. maxBound] in x `SL.lookup` literal (zip elts [0..])++                              enumFrom n = SL.map SL.toEnum (SL.enumFromTo (SL.fromEnum n) (SL.fromEnum (literal (maxBound :: $typeCon))))++                              enumFromThen = smtFunction ("EnumSymbolic." ++ TH.nameBase typeName ++ ".enumFromThen") $ \n1 n2 ->+                                                         let i_n1, i_n2 :: SInteger+                                                             i_n1 = SL.fromEnum n1+                                                             i_n2 = SL.fromEnum n2+                                                         in SL.map SL.toEnum (ite (i_n2 .>= i_n1)+                                                                                  (SL.enumFromThenTo i_n1 i_n2 (SL.fromEnum (literal (maxBound :: $typeCon))))+                                                                                  (SL.enumFromThenTo i_n1 i_n2 (SL.fromEnum (literal (minBound :: $typeCon)))))++                              enumFromTo     n m   = SL.map SL.toEnum (SL.enumFromTo     (SL.fromEnum n) (SL.fromEnum m))++                              enumFromThenTo n m t = SL.map SL.toEnum (SL.enumFromThenTo (SL.fromEnum n) (SL.fromEnum m) (SL.fromEnum t))+                       |]+                  else pure []+     sType <- TH.conT ''SBV `TH.appT` typeCon      let declConstructor c = ((nm, bnm), [sig, def])@@ -106,7 +165,7 @@      addDocs (tname, btname) constrNames -    pure $ deriveEqOrds ++ derives ++ [tdecl] ++ concat cdecls+    pure $ derives ++ symVals ++ symEnum ++ [tdecl] ++ concat cdecls   where addDocs :: (TH.Name, String) -> [(TH.Name, String)] -> TH.Q () #if MIN_VERSION_template_haskell(2,18,0)
Data/SBV/Client/BaseIO.hs view
@@ -11,14 +11,8 @@ -- @Data.SBV@, where we restrict the underlying monad to be IO. ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE DefaultSignatures    #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE NamedFieldPuns       #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns   #-}  {-# OPTIONS_GHC -Wall -Werror #-} @@ -30,7 +24,6 @@                                 SInt8, SInt16, SInt32, SInt64, SInteger, SList,                                 SReal, SString, SV, SWord8, SWord16, SWord32,                                 SWord64, SEither, SRational, SMaybe, SSet, SArray, constrain, (.==))-import Data.SBV.Core.Sized     (IntN, WordN) import Data.SBV.Core.Kind      (BVIsNonZero, ValidFloat) import Data.SBV.Core.Model     (Metric(..), SymTuple) import Data.SBV.Core.Symbolic  (Objective, OptimizeStyle, Result, VarContext, Symbolic, SBVRunMode, SMTConfig,@@ -38,13 +31,8 @@ import Data.SBV.Control.Types  (SMTOption) import Data.SBV.Provers.Prover (Provable, Satisfiable, SExecutable, ThmResult) import Data.SBV.SMT.SMT        (AllSatResult, SafeResult, SatResult, OptimizeResult)-import Data.SBV.Utils.Lib      (checkObservableName) -import GHC.TypeLits (KnownNat, TypeError, ErrorMessage(..))-import Data.Kind--import Data.Int-import Data.Word+import GHC.TypeLits (KnownNat)  import Data.IORef(readIORef, writeIORef) @@ -900,153 +888,4 @@ -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sObserve' sObserve :: SymVal a => String -> SBV a -> Symbolic ()-sObserve m x-  | Just bad <- checkObservableName m-  = error bad-  | True-  = do st <- symbolicEnv-       liftIO $ do xsv <- Trans.sbvToSV st x-                   Trans.recordObservable st m (const True) xsv---- | Capturing non-matching instances for better error messages, conversions from sized-type FromSizedErr (arg :: Type) =     'Text "fromSized: Cannot convert from type: " ':<>: 'ShowType arg-                                ':$$: 'Text "           Source type must be one of SInt N, SWord N, IntN N, WordN N"-                                ':$$: 'Text "           where N is 8, 16, 32, or 64."---- | Capturing non-matching instances for better error messages, conversions to sized-type ToSizedErr (arg :: Type) =      'Text "toSized: Cannot convert from type: " ':<>: 'ShowType arg-                              ':$$: 'Text "          Source type must be one of Int8/16/32/64"-                              ':$$: 'Text "                                  OR Word8/16/32/64"-                              ':$$: 'Text "                                  OR their symbolic variants."---- | Capture the correspondence between sized and fixed-sized BVs-type family FromSized (t :: Type) :: Type where-   FromSized (WordN  8) = Word8-   FromSized (WordN 16) = Word16-   FromSized (WordN 32) = Word32-   FromSized (WordN 64) = Word64-   FromSized (IntN   8) = Int8-   FromSized (IntN  16) = Int16-   FromSized (IntN  32) = Int32-   FromSized (IntN  64) = Int64-   FromSized (SWord  8) = SWord8-   FromSized (SWord 16) = SWord16-   FromSized (SWord 32) = SWord32-   FromSized (SWord 64) = SWord64-   FromSized (SInt   8) = SInt8-   FromSized (SInt  16) = SInt16-   FromSized (SInt  32) = SInt32-   FromSized (SInt  64) = SInt64---- | Capture the correspondence, in terms of a constraint-type family FromSizedCstr (t :: Type) :: Constraint where-   FromSizedCstr (WordN  8) = ()-   FromSizedCstr (WordN 16) = ()-   FromSizedCstr (WordN 32) = ()-   FromSizedCstr (WordN 64) = ()-   FromSizedCstr (IntN   8) = ()-   FromSizedCstr (IntN  16) = ()-   FromSizedCstr (IntN  32) = ()-   FromSizedCstr (IntN  64) = ()-   FromSizedCstr (SWord  8) = ()-   FromSizedCstr (SWord 16) = ()-   FromSizedCstr (SWord 32) = ()-   FromSizedCstr (SWord 64) = ()-   FromSizedCstr (SInt   8) = ()-   FromSizedCstr (SInt  16) = ()-   FromSizedCstr (SInt  32) = ()-   FromSizedCstr (SInt  64) = ()-   FromSizedCstr arg        = TypeError (FromSizedErr arg)---- | Conversion from a sized BV to a fixed-sized bit-vector.-class FromSizedBV a where-   -- | Convert a sized bit-vector to the corresponding fixed-sized bit-vector,-   -- for instance 'SWord 16' to 'SWord16'. See also 'toSized'.-   fromSized :: a -> FromSized a--   default fromSized :: (Num (FromSized a), Integral a) => a -> FromSized a-   fromSized = fromIntegral--instance {-# OVERLAPPING  #-} FromSizedBV (WordN   8)-instance {-# OVERLAPPING  #-} FromSizedBV (WordN  16)-instance {-# OVERLAPPING  #-} FromSizedBV (WordN  32)-instance {-# OVERLAPPING  #-} FromSizedBV (WordN  64)-instance {-# OVERLAPPING  #-} FromSizedBV (IntN    8)-instance {-# OVERLAPPING  #-} FromSizedBV (IntN   16)-instance {-# OVERLAPPING  #-} FromSizedBV (IntN   32)-instance {-# OVERLAPPING  #-} FromSizedBV (IntN   64)-instance {-# OVERLAPPING  #-} FromSizedBV (SWord   8) where fromSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} FromSizedBV (SWord  16) where fromSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} FromSizedBV (SWord  32) where fromSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} FromSizedBV (SWord  64) where fromSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} FromSizedBV (SInt    8) where fromSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} FromSizedBV (SInt   16) where fromSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} FromSizedBV (SInt   32) where fromSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} FromSizedBV (SInt   64) where fromSized = Trans.sFromIntegral-instance {-# OVERLAPPABLE #-} FromSizedCstr arg => FromSizedBV arg where fromSized = error "unreachable"---- | Capture the correspondence between fixed-sized and sized BVs-type family ToSized (t :: Type) :: Type where-   ToSized Word8   = WordN  8-   ToSized Word16  = WordN 16-   ToSized Word32  = WordN 32-   ToSized Word64  = WordN 64-   ToSized Int8    = IntN   8-   ToSized Int16   = IntN  16-   ToSized Int32   = IntN  32-   ToSized Int64   = IntN  64-   ToSized SWord8  = SWord  8-   ToSized SWord16 = SWord 16-   ToSized SWord32 = SWord 32-   ToSized SWord64 = SWord 64-   ToSized SInt8   = SInt   8-   ToSized SInt16  = SInt  16-   ToSized SInt32  = SInt  32-   ToSized SInt64  = SInt  64---- | Capture the correspondence in terms of a constraint-type family ToSizedCstr (t :: Type) :: Constraint where-   ToSizedCstr Word8   = ()-   ToSizedCstr Word16  = ()-   ToSizedCstr Word32  = ()-   ToSizedCstr Word64  = ()-   ToSizedCstr Int8    = ()-   ToSizedCstr Int16   = ()-   ToSizedCstr Int32   = ()-   ToSizedCstr Int64   = ()-   ToSizedCstr SWord8  = ()-   ToSizedCstr SWord16 = ()-   ToSizedCstr SWord32 = ()-   ToSizedCstr SWord64 = ()-   ToSizedCstr SInt8   = ()-   ToSizedCstr SInt16  = ()-   ToSizedCstr SInt32  = ()-   ToSizedCstr SInt64  = ()-   ToSizedCstr arg     = TypeError (ToSizedErr arg)---- | Conversion from a fixed-sized BV to a sized bit-vector.-class ToSizedBV a where-   -- | Convert a fixed-sized bit-vector to the corresponding sized bit-vector,-   -- for instance 'SWord16' to 'SWord 16'. See also 'fromSized'.-   toSized :: a -> ToSized a--   default toSized :: (Num (ToSized a), Integral a) => (a -> ToSized a)-   toSized = fromIntegral--instance {-# OVERLAPPING  #-} ToSizedBV Word8-instance {-# OVERLAPPING  #-} ToSizedBV Word16-instance {-# OVERLAPPING  #-} ToSizedBV Word32-instance {-# OVERLAPPING  #-} ToSizedBV Word64-instance {-# OVERLAPPING  #-} ToSizedBV Int8-instance {-# OVERLAPPING  #-} ToSizedBV Int16-instance {-# OVERLAPPING  #-} ToSizedBV Int32-instance {-# OVERLAPPING  #-} ToSizedBV Int64-instance {-# OVERLAPPING  #-} ToSizedBV SWord8  where toSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} ToSizedBV SWord16 where toSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} ToSizedBV SWord32 where toSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} ToSizedBV SWord64 where toSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} ToSizedBV SInt8   where toSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} ToSizedBV SInt16  where toSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} ToSizedBV SInt32  where toSized = Trans.sFromIntegral-instance {-# OVERLAPPING  #-} ToSizedBV SInt64  where toSized = Trans.sFromIntegral-instance {-# OVERLAPPABLE #-} ToSizedCstr arg => ToSizedBV arg where toSized = error "unreachable"+sObserve m x = Trans.sObserve m (Trans.unSBV x)
Data/SBV/Control/Utils.hs view
@@ -56,7 +56,7 @@ import Control.Monad.Trans      (lift) import Control.Monad.Reader     (runReaderT) -import Data.Maybe (isNothing, isJust, mapMaybe)+import Data.Maybe (isNothing, isJust)  import Data.IORef (readIORef, writeIORef, IORef, newIORef, modifyIORef') @@ -80,7 +80,7 @@                               , isSafetyCheckingIStage, isSetupIStage, isRunIStage, IStage(..), QueryT(..)                               , extractSymbolicSimulationState, MonadSymbolic(..)                               , UserInputs, getSV, NamedSymVar(..), lookupInput, getUserName'-                              , Name, CnstMap, smtDefGivenName, Inputs(..), ProgInfo(..)+                              , Name, CnstMap, Inputs(..), ProgInfo(..)                               , mustIgnoreVar, newInternalVariable                               ) @@ -1271,7 +1271,7 @@ getUIs = do State{rUIMap, rDefns, rIncState} <- queryState             -- NB. no need to worry about new-defines, because we don't allow definitions once query mode starts             defines <- do allDefs <- io $ readIORef rDefns-                          pure $ mapMaybe (smtDefGivenName . fst) allDefs+                          pure $ map fst allDefs              prior <- io $ readIORef rUIMap             new   <- io $ readIORef rIncState >>= readIORef . rNewUIs
Data/SBV/Core/AlgReals.hs view
@@ -36,7 +36,6 @@ import Data.Char       (isDigit)  import Data.List       (sortBy, isPrefixOf, partition)-import Data.Ratio      ((%), numerator, denominator) import Data.Function   (on) import System.Random import Test.QuickCheck (Arbitrary(..))@@ -47,6 +46,7 @@  import qualified Data.Generics as G import GHC.Generics+import GHC.Real  -- | Is the endpoint included in the interval? data RealPoint a = OpenPoint   a -- ^ open: i.e., doesn't include the point@@ -196,6 +196,7 @@   toRational (AlgRational True v) = v   toRational x                    = error $ "AlgReal.toRational: Argument cannot be represented as a rational value: " ++ algRealToHaskell x +-- | Random instance for rational needs to be careful to split the generator twice for numerator and denumerator instance Random Rational where   random g = (a % b', g'')      where (a, g')  = random g@@ -210,10 +211,27 @@            r = a % b'            d = h - l +-- | Random generates a rational, so perhaps not as random as one wants instance Random AlgReal where   random g = let (a, g') = random g in (AlgRational True a, g')   randomR (AlgRational True l, AlgRational True h) g = let (a, g') = randomR (l, h) g in (AlgRational True a, g')   randomR lh                                       _ = error $ "AlgReal.randomR: unsupported bounds: " ++ show lh++instance Enum AlgReal where+  succ x =  x + 1+  pred x =  x - 1++  toEnum n =  AlgRational True (fromIntegral n)++  fromEnum (AlgRational True  r) = fromEnum r+  fromEnum (AlgRational False r) = error $ "AlgReal.Enum: unsupported inexact rational: " ++ show r+  fromEnum r@AlgPolyRoot{}       = error $ "AlgReal.Enum: unsupported inexact rational: " ++ show r+  fromEnum r@AlgInterval{}       = error $ "AlgReal.Enum: unsupported inexact rational: " ++ show r++  enumFrom       = numericEnumFrom+  enumFromTo     = numericEnumFromTo+  enumFromThen   = numericEnumFromThen+  enumFromThenTo = numericEnumFromThenTo  -- | Render an 'AlgReal' as an SMTLib2 value. Only supports rationals for the time being. algRealToSMTLib2 :: AlgReal -> String
Data/SBV/Core/Concrete.hs view
@@ -45,11 +45,18 @@  import GHC.Generics +import Test.QuickCheck (Arbitrary(..))+ -- | A 'RCSet' is either a regular set or a set given by its complement from the corresponding universal set. data RCSet a = RegularSet    (Set a)              | ComplementSet (Set a)              deriving (NFData, G.Data, Generic) +instance (Ord a, Arbitrary a) => Arbitrary (RCSet a) where+  arbitrary = do c :: Bool <- arbitrary+                 if c then RegularSet    <$> arbitrary+                      else ComplementSet <$> arbitrary+ -- | Show instance. Regular sets are shown as usual. -- Complements are shown "U -" notation. instance Show a => Show (RCSet a) where@@ -486,25 +493,32 @@     KString            -> do l <- randomRIO (0, 100)                              CString <$> replicateM l (chr <$> randomRIO (0, 255))     KChar              -> CChar . chr <$> randomRIO (0, 255)+     KUserSort s es     -> case es of                             Just vs@(_:_) -> do i <- randomRIO (0, length vs - 1)                                                 pure $ CUserSort (Just i, vs !! i)                             _             -> error $ "randomCVal: Not supported for completely uninterpreted type: " ++ s+     KList ek           -> do l <- randomRIO (0, 100)                              CList <$> replicateM l (randomCVal ek)+     KSet  ek           -> do i <- randomIO                           -- regular or complement                              l <- randomRIO (0, 100)                 -- some set upto 100 elements                              vals <- Set.fromList <$> replicateM l (randomCVal ek)                              return $ CSet $ if i then RegularSet vals else ComplementSet vals+     KTuple ks          -> CTuple <$> traverse randomCVal ks+     KMaybe ke          -> do i <- randomIO                              if i                                 then return $ CMaybe Nothing                                 else CMaybe . Just <$> randomCVal ke+     KEither k1 k2      -> do i <- randomIO                              if i                                 then CEither . Left  <$> randomCVal k1                                 else CEither . Right <$> randomCVal k2+     KArray k1 k2       -> do l   <- randomRIO (0, 100)                              ks  <- replicateM l (randomCVal k1)                              vs  <- replicateM l (randomCVal k2)
Data/SBV/Core/Data.hs view
@@ -16,7 +16,6 @@ {-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE InstanceSigs          #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards         #-} {-# LANGUAGE ScopedTypeVariables   #-}@@ -25,7 +24,7 @@ {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE UndecidableInstances  #-} -{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}  module Data.SBV.Core.Data  ( SBool, SWord8, SWord16, SWord32, SWord64@@ -59,7 +58,7 @@  , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension  , SolverCapabilities(..)  , extractSymbolicSimulationState- , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), KDOptions(..)+ , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), TPOptions(..)  , OptimizeStyle(..), Penalty(..), Objective(..)  , QueryState(..), QueryT(..), SMTProblem(..), Constraint(..), Lambda(..), Forall(..), Exists(..), ExistsUnique(..), ForallN(..), ExistsN(..)  , QuantifiedBool(..), EqSymbolic(..), QNot(..), Skolemize(SkolemsTo, skolemize, taggedSkolemize)@@ -69,15 +68,12 @@  import GHC.TypeLits (KnownNat, Nat, Symbol, KnownSymbol, symbolVal, AppendSymbol, type (+), type (-), type (<=), natVal) -import GHC.Exts     (IsList(..))- import Control.DeepSeq        (NFData(..)) import Control.Monad          (void, replicateM) import Control.Monad.Trans    (liftIO, MonadIO) import Data.Int               (Int8, Int16, Int32, Int64) import Data.Word              (Word8, Word16, Word32, Word64) import Data.List              (elemIndex)-import Data.Maybe             (fromMaybe)  import Data.Kind (Type) import Data.Proxy@@ -101,6 +97,8 @@  import Data.SBV.Utils.Lib +import Test.QuickCheck (Arbitrary(..))+ -- | Get the current path condition getPathCondition :: State -> SBool getPathCondition st = SBV (getSValPathCondition st)@@ -244,12 +242,6 @@ -- | Symbolic 8-tuple. type STuple8 a b c d e f g h = SBV (a, b, c, d, e, f, g, h) --- | IsList instance allows list literals to be written compactly.-instance SymVal [a] => IsList (SList a) where-  type Item (SList a) = a-  fromList = literal-  toList x = fromMaybe (error "IsList.toList used in a symbolic context!") (unliteral x)- -- | Not-A-Number for 'Double' and 'Float'. Surprisingly, Haskell -- Prelude doesn't have this value defined, so we provide it here. nan :: Floating a => a@@ -606,7 +598,7 @@ -- * Symbolic Values ------------------------------------------------------------------------------- -- | A 'SymVal' is a potential symbolic value that can be created instances of to be fed to a symbolic program.-class (HasKind a, Typeable a) => SymVal a where+class (HasKind a, Typeable a, Arbitrary a) => SymVal a where   -- | Generalization of 'Data.SBV.mkSymVal'   mkSymVal :: MonadSymbolic m => VarContext -> Maybe String -> m (SBV a) @@ -619,6 +611,10 @@   -- | Does it concretely satisfy the given predicate?   isConcretely :: SBV a -> (a -> Bool) -> Bool +  -- | If bounded, what's the min/max value for this type?+  -- If the underlying type is bounded, we have a default below. Otherwise it's nothing.+  minMaxBound :: Maybe (a, a)+   -- minimal complete definition: Nothing.   -- Giving no instances is okay when defining an uninterpreted/enumerated sort, but otherwise you really   -- want to define: literal, fromCV, mkSymVal@@ -646,6 +642,9 @@   fromCV (CV _ (CUserSort (_, s))) = read s   fromCV cv                        = error $ "Cannot convert CV " ++ show cv ++ " to kind " ++ show (kindOf (Proxy @a)) +  default minMaxBound :: Bounded a => Maybe (a, a)+  minMaxBound = Just (minBound, maxBound)+   isConcretely s p     | Just i <- unliteral s = p i     | True                  = False@@ -812,33 +811,34 @@ -- So, we have to declare the instances individually. I played around doing this via iso-deriving and -- other generic mechanisms, but failed to do so. The CPP solution here is crude, but it avoids the -- code duplication.-#define MKSNUM(CSTR, TYPE, KIND)                                                            \-instance (CSTR) => Num (TYPE) where {                                                       \-  fromInteger i  = SBV $ SVal (KIND) $ Left $ mkConstCV (KIND) (fromIntegral i :: Integer); \-  SBV a + SBV b  = SBV $ a `svPlus`  b;                                                     \-  SBV a * SBV b  = SBV $ a `svTimes` b;                                                     \-  SBV a - SBV b  = SBV $ a `svMinus` b;                                                     \-  abs    (SBV a) = SBV $ svAbs    a;                                                        \-  signum (SBV a) = SBV $ svSignum a;                                                        \-  negate (SBV a) = SBV $ svUNeg   a;                                                        \+#define MKSNUM(CSTR, TYPE, KIND)                                                        \+instance CSTR => Num TYPE where {                                                       \+  fromInteger i  = SBV $ SVal KIND $ Left $ mkConstCV KIND (fromIntegral i :: Integer); \+  SBV a + SBV b  = SBV $ a `svPlus`  b;                                                 \+  SBV a * SBV b  = SBV $ a `svTimes` b;                                                 \+  SBV a - SBV b  = SBV $ a `svMinus` b;                                                 \+  abs    (SBV a) = SBV $ svAbs    a;                                                    \+  signum (SBV a) = SBV $ svSignum a;                                                    \+  negate (SBV a) = SBV $ svUNeg   a;                                                    \ }  -- Derive basic instances we need-MKSNUM((),               SInteger,             KUnbounded)-MKSNUM((),               SWord8,               KBounded False  8)-MKSNUM((),               SWord16,              KBounded False 16)-MKSNUM((),               SWord32,              KBounded False 32)-MKSNUM((),               SWord64,              KBounded False 64)-MKSNUM((),               SInt8,                KBounded True   8)-MKSNUM((),               SInt16,               KBounded True  16)-MKSNUM((),               SInt32,               KBounded True  32)-MKSNUM((),               SInt64,               KBounded True  64)-MKSNUM((),               SFloat,               KFloat)-MKSNUM((),               SDouble,              KDouble)-MKSNUM((),               SReal,                KReal)-MKSNUM(KnownNat n,       SWord n,              KBounded False (intOfProxy (Proxy @n)))-MKSNUM(KnownNat n,       SInt  n,              KBounded True  (intOfProxy (Proxy @n)))-MKSNUM(ValidFloat eb sb, SFloatingPoint eb sb, KFP (intOfProxy (Proxy @eb)) (intOfProxy (Proxy @sb)))+MKSNUM((),                 SInteger,               KUnbounded)+MKSNUM((),                 SWord8,                 (KBounded False  8))+MKSNUM((),                 SWord16,                (KBounded False 16))+MKSNUM((),                 SWord32,                (KBounded False 32))+MKSNUM((),                 SWord64,                (KBounded False 64))+MKSNUM((),                 SInt8,                  (KBounded True   8))+MKSNUM((),                 SInt16,                 (KBounded True  16))+MKSNUM((),                 SInt32,                 (KBounded True  32))+MKSNUM((),                 SInt64,                 (KBounded True  64))+MKSNUM((),                 SFloat,                 KFloat)+MKSNUM((),                 SDouble,                KDouble)+MKSNUM((),                 SReal,                  KReal)+MKSNUM((KnownNat n),       (SWord n),              (KBounded False (intOfProxy (Proxy @n))))+MKSNUM((KnownNat n),       (SInt  n),              (KBounded True  (intOfProxy (Proxy @n))))+MKSNUM((ValidFloat eb sb), (SFloatingPoint eb sb), (KFP (intOfProxy (Proxy @eb)) (intOfProxy (Proxy @sb))))+#undef MKSNUM  -- | Extract a portion of bits to form a smaller bit-vector. bvExtract :: forall i j n bv proxy. ( KnownNat n, BVIsNonZero n, SymVal (bv n)
Data/SBV/Core/Floating.hs view
@@ -51,8 +51,6 @@  import Data.SBV.Utils.Numeric -import Data.Ratio- import GHC.TypeLits  import LibBF@@ -593,26 +591,6 @@                         addSValOptGoal $ unSBV `fmap` Maximize nm' (toMetricSpace o)     annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"---- | Real instance for FloatingPoint. NB. The methods haven't been subjected to much testing, so beware of any floating-point snafus here.-instance ValidFloat eb sb => Real (FloatingPoint eb sb) where-  toRational (FloatingPoint (FP _ _ r)) = case bfToRep r of-                                            BFNaN     -> toRational (0/0 :: Double)-                                            BFRep s n -> case n of-                                                           Zero    -> 0 % 1-                                                           Inf     -> (if s == Neg then -1 else 1) % 0-                                                           Num x y -> -- The value here is x * 2^y-                                                                      let v :: Integer-                                                                          v   = 2 ^ abs (fromIntegral y :: Integer)-                                                                          sgn = if s == Neg then ((-1) *) else id-                                                                      in if y > 0-                                                                            then sgn $ x * v % 1-                                                                            else sgn $ x % v---- | RealFrac instance for FloatingPoint. NB. The methods haven't been subjected to much testing, so beware of any floating-point snafus here.-instance ValidFloat eb sb => RealFrac (FloatingPoint eb sb) where-  properFraction (FloatingPoint f) = (a, FloatingPoint b)-     where (a, b) = properFraction f  -- | RealFloat instance for FloatingPoint. NB. The methods haven't been subjected to much testing, so beware of any floating-point snafus here. instance ValidFloat eb sb => RealFloat (FloatingPoint eb sb) where
Data/SBV/Core/Kind.hs view
@@ -59,6 +59,8 @@ import GHC.Generics import qualified Data.Generics.Uniplate.Data as G +import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum)+ -- | Kind of symbolic value data Kind = KBool           | KBounded !Bool !Int@@ -461,8 +463,6 @@    BVIsNonZero 0 = TypeError BVZeroWidth    BVIsNonZero _ = () -#include "MachDeps.h"- -- Allowed sizes for floats, imposed by LibBF. -- -- NB. In LibBF bindings (and libbf itself as well), minimum number of exponent bits is specified as 3. But this@@ -478,7 +478,6 @@ -- -- NB. It would be nice if we could use the LibBF constants expBitsMin, expBitsMax, precBitsMin, precBitsMax -- for determining the valid range. Unfortunately this doesn't seem to be possible.--- See <https://stackoverflow.com/questions/51900360/making-a-type-constraint-based-on-runtime-value-of-maxbound-int> for a discussion. -- So, we use CPP to work-around that. #define FP_MIN_EB 2 #define FP_MIN_SB 2@@ -536,6 +535,10 @@  -- | 'RoundingMode' kind instance HasKind RoundingMode++-- | An arbitrary rounding mode+instance Arbitrary RoundingMode where+  arbitrary = arbitraryBoundedEnum  -- | Convert a rounding mode to the format SMT-Lib2 understands. smtRoundingMode :: RoundingMode -> String
Data/SBV/Core/Model.hs view
@@ -50,13 +50,15 @@   , sDivides   , solve   , slet-  , sRealToSInteger, label, observe, observeIf, sObserve+  , sRealToSInteger, sRealToSIntegerTruncate, label, observe, observeIf, sObserve   , sAssert   , liftQRem, liftDMod, symbolicMergeWithKind   , genLiteral, genFromCV, genMkSymVar   , zeroExtend, signExtend   , sbvQuickCheck   , readArray, writeArray, lambdaArray, listArray+  , FromSized, ToSized, FromSizedBV(..), ToSizedBV(..)+  , smtHOFunction, Closure(..)   )   where @@ -64,6 +66,8 @@ import Control.Monad          (when, unless, mplus, replicateM) import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Control.Exception as C+ import GHC.Generics (M1(..), U1(..), (:*:)(..), K1(..)) import qualified GHC.Generics as G @@ -78,7 +82,7 @@  import Data.Bits   (Bits(..)) import Data.Int    (Int8, Int16, Int32, Int64)-import Data.Kind   (Type)+import Data.Kind   (Type, Constraint) import Data.List   (genericLength, genericIndex, genericTake, unzip4, unzip5, unzip6, unzip7, intercalate) import Data.Maybe  (fromMaybe, mapMaybe) import Data.String (IsString(..))@@ -90,7 +94,7 @@ import qualified Data.Set as Set  import Data.Proxy-import Data.Dynamic (fromDynamic, toDyn)+import Data.Dynamic (fromDynamic, toDyn, Typeable)  import Test.QuickCheck                         (Testable(..), Arbitrary(..)) import qualified Test.QuickCheck.Test    as QC (isSuccess)@@ -102,7 +106,7 @@ import Data.SBV.Core.AlgReals import Data.SBV.Core.Sized import Data.SBV.Core.SizedFloats-import Data.SBV.Core.Data+import Data.SBV.Core.Data hiding (Constraint) import Data.SBV.Core.Symbolic import Data.SBV.Core.Operations import Data.SBV.Core.Kind@@ -117,8 +121,14 @@ import Data.IORef (readIORef, writeIORef) import Data.SBV.Utils.Lib +import Data.Char+ -- Symbolic-Word class instances +import Crypto.Hash.SHA512 (hash)+import qualified Data.ByteString.Base16 as B+import qualified Data.ByteString.Char8  as BC+ -- | Generate a variable, named genVar :: MonadSymbolic m => VarContext -> Kind -> String -> m (SBV a) genVar q k = mkSymSBV q k . Just@@ -187,21 +197,24 @@   fromCV   = genFromCV  instance SymVal Integer where-  mkSymVal = genMkSymVar KUnbounded-  literal  = SBV . SVal KUnbounded . Left . mkConstCV KUnbounded-  fromCV   = genFromCV+  mkSymVal    = genMkSymVar KUnbounded+  literal     = SBV . SVal KUnbounded . Left . mkConstCV KUnbounded+  fromCV      = genFromCV+  minMaxBound = Nothing  instance SymVal Rational where   mkSymVal                    = genMkSymVar KRational   literal                     = SBV . SVal KRational  . Left . CV KRational . CRational   fromCV (CV _ (CRational r)) = r   fromCV c                    = error $ "SymVal.Rational: Unexpected non-rational value: " ++ show c+  minMaxBound                 = Nothing  instance SymVal AlgReal where   mkSymVal                   = genMkSymVar KReal   literal                    = SBV . SVal KReal . Left . CV KReal . CAlgReal   fromCV (CV _ (CAlgReal a)) = a   fromCV c                   = error $ "SymVal.AlgReal: Unexpected non-real value: " ++ show c+  minMaxBound               = Nothing    -- AlgReal needs its own definition of isConcretely   -- to make sure we avoid using unimplementable Haskell functions@@ -214,6 +227,7 @@   literal                  = SBV . SVal KFloat . Left . CV KFloat . CFloat   fromCV (CV _ (CFloat a)) = a   fromCV c                 = error $ "SymVal.Float: Unexpected non-float value: " ++ show c+  minMaxBound              = Nothing    -- For Float, we conservatively return 'False' for isConcretely. The reason is that   -- this function is used for optimizations when only one of the argument is concrete,@@ -225,6 +239,7 @@   literal                   = SBV . SVal KDouble . Left . CV KDouble . CDouble   fromCV (CV _ (CDouble a)) = a   fromCV c                  = error $ "SymVal.Double: Unexpected non-double value: " ++ show c+  minMaxBound               = Nothing    -- For Double, we conservatively return 'False' for isConcretely. The reason is that   -- this function is used for optimizations when only one of the argument is concrete,@@ -254,6 +269,8 @@   fromCV (CV _ (CList a))   = fromCV . CV (kindOf (Proxy @a)) <$> a   fromCV c                  = error $ "SymVal.fromCV: Unexpected non-list value: " ++ show c +  minMaxBound               = Nothing+ instance ValidFloat eb sb => HasKind (FloatingPoint eb sb) where   kindOf _ = KFP (intOfProxy (Proxy @eb)) (intOfProxy (Proxy @sb)) @@ -263,6 +280,7 @@                                in SBV $ SVal k $ Left $ CV k (CFP r)   fromCV  (CV _ (CFP r))     = FloatingPoint r   fromCV  c                  = error $ "SymVal.FPR: Unexpected non-arbitrary-precision value: " ++ show c+  minMaxBound                = Nothing  -- | 'SymVal' instance for 'WordN' instance (KnownNat n, BVIsNonZero n) => SymVal (WordN n) where@@ -314,8 +332,10 @@    fromCV (CV (KEither k1 _ ) (CEither (Left c)))  = Left  $ fromCV $ CV k1 c   fromCV (CV (KEither _  k2) (CEither (Right c))) = Right $ fromCV $ CV k2 c-  fromCV bad                                   = error $ "SymVal.fromCV (Either): Malformed either received: " ++ show bad+  fromCV bad                                      = error $ "SymVal.fromCV (Either): Malformed either received: " ++ show bad +  minMaxBound = Nothing+ instance SymVal a => SymVal (Maybe a) where   mkSymVal = genMkSymVar (kindOf (Proxy @(Maybe a))) @@ -330,6 +350,8 @@   fromCV (CV (KMaybe k) (CMaybe (Just x))) = Just $ fromCV $ CV k x   fromCV bad                               = error $ "SymVal.fromCV (Maybe): Malformed sum received: " ++ show bad +  minMaxBound = Nothing+ instance (HasKind a, HasKind b, SymVal a, SymVal b) => SymVal (ArrayModel a b) where   mkSymVal = genMkSymVar (KArray (kindOf (Proxy @a)) (kindOf (Proxy @b))) @@ -345,6 +367,11 @@    fromCV bad = error $ "SymVal.fromCV (SArray): Malformed array received: " ++ show bad +  minMaxBound = Nothing++instance (Arbitrary a, Arbitrary b) => Arbitrary (ArrayModel a b) where+  arbitrary = ArrayModel <$> arbitrary <*> arbitrary+ instance (Ord a, SymVal a) => SymVal (RCSet a) where   mkSymVal = genMkSymVar (kindOf (Proxy @(RCSet a))) @@ -358,6 +385,8 @@   fromCV (CV (KSet a) (CSet (ComplementSet s))) = ComplementSet $ Set.map (fromCV . CV a) s   fromCV bad                                    = error $ "SymVal.fromCV (Set): Malformed set received: " ++ show bad +  minMaxBound = Nothing+ -- | SymVal for 0-tuple (i.e., unit) instance SymVal () where   mkSymVal   = genMkSymVar (KTuple [])@@ -371,12 +400,15 @@    fromCV  cv       = let ~[v1, v2] = fromCVTup 2 cv                       in (fromCV v1, fromCV v2) +   minMaxBound = Nothing+ -- | SymVal for 3-tuples instance (SymVal a, SymVal b, SymVal c) => SymVal (a, b, c) where    mkSymVal             = genMkSymVar (kindOf (Proxy @(a, b, c)))    literal (v1, v2, v3) = mkCVTup 3   (kindOf (Proxy @(a, b, c))) [toCV v1, toCV v2, toCV v3]    fromCV  cv           = let ~[v1, v2, v3] = fromCVTup 3 cv                           in (fromCV v1, fromCV v2, fromCV v3)+   minMaxBound          = Nothing  -- | SymVal for 4-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d) => SymVal (a, b, c, d) where@@ -384,6 +416,7 @@    literal (v1, v2, v3, v4) = mkCVTup 4   (kindOf (Proxy @(a, b, c, d))) [toCV v1, toCV v2, toCV v3, toCV v4]    fromCV  cv               = let ~[v1, v2, v3, v4] = fromCVTup 4 cv                               in (fromCV v1, fromCV v2, fromCV v3, fromCV v4)+   minMaxBound              = Nothing  -- | SymVal for 5-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e) => SymVal (a, b, c, d, e) where@@ -391,6 +424,7 @@    literal (v1, v2, v3, v4, v5) = mkCVTup 5   (kindOf (Proxy @(a, b, c, d, e))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5]    fromCV  cv                   = let ~[v1, v2, v3, v4, v5] = fromCVTup 5 cv                                   in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5)+   minMaxBound                  = Nothing  -- | SymVal for 6-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f) => SymVal (a, b, c, d, e, f) where@@ -398,6 +432,7 @@    literal (v1, v2, v3, v4, v5, v6) = mkCVTup 6   (kindOf (Proxy @(a, b, c, d, e, f))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5, toCV v6]    fromCV  cv                       = let ~[v1, v2, v3, v4, v5, v6] = fromCVTup 6 cv                                       in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6)+   minMaxBound                      = Nothing  -- | SymVal for 7-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g) => SymVal (a, b, c, d, e, f, g) where@@ -405,6 +440,7 @@    literal (v1, v2, v3, v4, v5, v6, v7) = mkCVTup 7   (kindOf (Proxy @(a, b, c, d, e, f, g))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5, toCV v6, toCV v7]    fromCV  cv                           = let ~[v1, v2, v3, v4, v5, v6, v7] = fromCVTup 7 cv                                           in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7)+   minMaxBound                          = Nothing  -- | SymVal for 8-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h) => SymVal (a, b, c, d, e, f, g, h) where@@ -412,6 +448,7 @@    literal (v1, v2, v3, v4, v5, v6, v7, v8) = mkCVTup 8   (kindOf (Proxy @(a, b, c, d, e, f, g, h))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5, toCV v6, toCV v7, toCV v8]    fromCV  cv                               = let ~[v1, v2, v3, v4, v5, v6, v7, v8] = fromCVTup 8 cv                                               in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7, fromCV v8)+   minMaxBound                              = Nothing  instance IsString SString where   fromString = literal@@ -811,6 +848,10 @@   where y st = do xsv <- sbvToSV st x                   newExpr st KUnbounded (SBVApp (KindCast KReal KUnbounded) [xsv]) +-- | Convert an SReal to an SInteger, truncating version.+sRealToSIntegerTruncate :: SReal -> SInteger+sRealToSIntegerTruncate x = ite (x .< 0) (sRealToSInteger x) (- (sRealToSInteger (- x)))+ -- | label: Label the result of an expression. This is essentially a no-op, but useful as it generates a comment in the generated C/SMT-Lib code. -- Note that if the argument is a constant, then the label is dropped completely, per the usual constant folding strategy. Compare this to 'observe' -- which is good for printing counter-examples.@@ -1731,57 +1772,149 @@ sBarrelRotateRight :: (SFiniteBits a, SFiniteBits b) => SBV a -> SBV b -> SBV a sBarrelRotateRight = liftViaSVal svBarrelRotateRight --- Enum instance. These instances are suitable for use with concrete values,--- and will be less useful for symbolic values around. Note that `fromEnum` requires--- a concrete argument for obvious reasons. Other variants (succ, pred, [x..]) etc are similarly--- limited. While symbolic variants can be defined for many of these, they will just diverge--- as final sizes cannot be determined statically.-instance (Show a, Bounded a, Integral a, Num a, Num (SBV a), SymVal a) => Enum (SBV a) where-  succ x-    | v == (maxBound :: a) = error $ "Enum.succ{" ++ showType x ++ "}: tried to take `succ' of maxBound"-    | True                 = fromIntegral $ v + 1-    where v = enumCvt "succ" x-  pred x-    | v == (minBound :: a) = error $ "Enum.pred{" ++ showType x ++ "}: tried to take `pred' of minBound"-    | True                 = fromIntegral $ v - 1-    where v = enumCvt "pred" x-  toEnum x-    | xi < fromIntegral (minBound :: a) || xi > fromIntegral (maxBound :: a)-    = error $ "Enum.toEnum{" ++ showType r ++ "}: " ++ show x ++ " is out-of-bounds " ++ show (minBound :: a, maxBound :: a)-    | True-    = r-    where xi :: Integer-          xi = fromIntegral x-          r  :: SBV a-          r  = fromIntegral x-  fromEnum x-     | r < fromIntegral (minBound :: Int) || r > fromIntegral (maxBound :: Int)-     = error $ "Enum.fromEnum{" ++ showType x ++ "}:  value " ++ show r ++ " is outside of Int's bounds " ++ show (minBound :: Int, maxBound :: Int)-     | True-     = fromIntegral r-    where r :: Integer-          r = enumCvt "fromEnum" x-  enumFrom x = map fromIntegral [xi .. fromIntegral (maxBound :: a)]-     where xi :: Integer-           xi = enumCvt "enumFrom" x-  enumFromThen x y-     | yi >= xi  = map fromIntegral [xi, yi .. fromIntegral (maxBound :: a)]-     | True      = map fromIntegral [xi, yi .. fromIntegral (minBound :: a)]-       where xi, yi :: Integer-             xi = enumCvt "enumFromThen.x" x-             yi = enumCvt "enumFromThen.y" y-  enumFromThenTo x y z = map fromIntegral [xi, yi .. zi]-       where xi, yi, zi :: Integer-             xi = enumCvt "enumFromThenTo.x" x-             yi = enumCvt "enumFromThenTo.y" y-             zi = enumCvt "enumFromThenTo.z" z+-- | Capturing non-matching instances for better error messages, conversions from sized+type FromSizedErr (arg :: Type) =     'Text "fromSized: Cannot convert from type: " ':<>: 'ShowType arg+                                ':$$: 'Text "           Source type must be one of SInt N, SWord N, IntN N, WordN N"+                                ':$$: 'Text "           where N is 8, 16, 32, or 64." --- | Helper function for use in enum operations-enumCvt :: (SymVal a, Integral a, Num b) => String -> SBV a -> b-enumCvt w x = case unliteral x of-                Nothing -> error $ "Enum." ++ w ++ "{" ++ showType x ++ "}: Called on symbolic value " ++ show x-                Just v  -> fromIntegral v+-- | Capturing non-matching instances for better error messages, conversions to sized+type ToSizedErr (arg :: Type) =      'Text "toSized: Cannot convert from type: " ':<>: 'ShowType arg+                              ':$$: 'Text "          Source type must be one of Int8/16/32/64"+                              ':$$: 'Text "                                  OR Word8/16/32/64"+                              ':$$: 'Text "                                  OR their symbolic variants." +-- | Capture the correspondence between sized and fixed-sized BVs+type family FromSized (t :: Type) :: Type where+   FromSized (WordN  8) = Word8+   FromSized (WordN 16) = Word16+   FromSized (WordN 32) = Word32+   FromSized (WordN 64) = Word64+   FromSized (IntN   8) = Int8+   FromSized (IntN  16) = Int16+   FromSized (IntN  32) = Int32+   FromSized (IntN  64) = Int64+   FromSized (SWord  8) = SWord8+   FromSized (SWord 16) = SWord16+   FromSized (SWord 32) = SWord32+   FromSized (SWord 64) = SWord64+   FromSized (SInt   8) = SInt8+   FromSized (SInt  16) = SInt16+   FromSized (SInt  32) = SInt32+   FromSized (SInt  64) = SInt64++-- | Capture the correspondence, in terms of a constraint+type family FromSizedCstr (t :: Type) :: Constraint where+   FromSizedCstr (WordN  8) = ()+   FromSizedCstr (WordN 16) = ()+   FromSizedCstr (WordN 32) = ()+   FromSizedCstr (WordN 64) = ()+   FromSizedCstr (IntN   8) = ()+   FromSizedCstr (IntN  16) = ()+   FromSizedCstr (IntN  32) = ()+   FromSizedCstr (IntN  64) = ()+   FromSizedCstr (SWord  8) = ()+   FromSizedCstr (SWord 16) = ()+   FromSizedCstr (SWord 32) = ()+   FromSizedCstr (SWord 64) = ()+   FromSizedCstr (SInt   8) = ()+   FromSizedCstr (SInt  16) = ()+   FromSizedCstr (SInt  32) = ()+   FromSizedCstr (SInt  64) = ()+   FromSizedCstr arg        = TypeError (FromSizedErr arg)++-- | Conversion from a sized BV to a fixed-sized bit-vector.+class FromSizedBV a where+   -- | Convert a sized bit-vector to the corresponding fixed-sized bit-vector,+   -- for instance 'SWord 16' to 'SWord16'. See also 'toSized'.+   fromSized :: a -> FromSized a++   default fromSized :: (Num (FromSized a), Integral a) => a -> FromSized a+   fromSized = fromIntegral++instance {-# OVERLAPPING  #-} FromSizedBV (WordN   8)+instance {-# OVERLAPPING  #-} FromSizedBV (WordN  16)+instance {-# OVERLAPPING  #-} FromSizedBV (WordN  32)+instance {-# OVERLAPPING  #-} FromSizedBV (WordN  64)+instance {-# OVERLAPPING  #-} FromSizedBV (IntN    8)+instance {-# OVERLAPPING  #-} FromSizedBV (IntN   16)+instance {-# OVERLAPPING  #-} FromSizedBV (IntN   32)+instance {-# OVERLAPPING  #-} FromSizedBV (IntN   64)+instance {-# OVERLAPPING  #-} FromSizedBV (SWord   8) where fromSized = sFromIntegral+instance {-# OVERLAPPING  #-} FromSizedBV (SWord  16) where fromSized = sFromIntegral+instance {-# OVERLAPPING  #-} FromSizedBV (SWord  32) where fromSized = sFromIntegral+instance {-# OVERLAPPING  #-} FromSizedBV (SWord  64) where fromSized = sFromIntegral+instance {-# OVERLAPPING  #-} FromSizedBV (SInt    8) where fromSized = sFromIntegral+instance {-# OVERLAPPING  #-} FromSizedBV (SInt   16) where fromSized = sFromIntegral+instance {-# OVERLAPPING  #-} FromSizedBV (SInt   32) where fromSized = sFromIntegral+instance {-# OVERLAPPING  #-} FromSizedBV (SInt   64) where fromSized = sFromIntegral+instance {-# OVERLAPPABLE #-} FromSizedCstr arg => FromSizedBV arg where fromSized = error "unreachable"++-- | Capture the correspondence between fixed-sized and sized BVs+type family ToSized (t :: Type) :: Type where+   ToSized Word8   = WordN  8+   ToSized Word16  = WordN 16+   ToSized Word32  = WordN 32+   ToSized Word64  = WordN 64+   ToSized Int8    = IntN   8+   ToSized Int16   = IntN  16+   ToSized Int32   = IntN  32+   ToSized Int64   = IntN  64+   ToSized SWord8  = SWord  8+   ToSized SWord16 = SWord 16+   ToSized SWord32 = SWord 32+   ToSized SWord64 = SWord 64+   ToSized SInt8   = SInt   8+   ToSized SInt16  = SInt  16+   ToSized SInt32  = SInt  32+   ToSized SInt64  = SInt  64++-- | Capture the correspondence in terms of a constraint+type family ToSizedCstr (t :: Type) :: Constraint where+   ToSizedCstr Word8   = ()+   ToSizedCstr Word16  = ()+   ToSizedCstr Word32  = ()+   ToSizedCstr Word64  = ()+   ToSizedCstr Int8    = ()+   ToSizedCstr Int16   = ()+   ToSizedCstr Int32   = ()+   ToSizedCstr Int64   = ()+   ToSizedCstr SWord8  = ()+   ToSizedCstr SWord16 = ()+   ToSizedCstr SWord32 = ()+   ToSizedCstr SWord64 = ()+   ToSizedCstr SInt8   = ()+   ToSizedCstr SInt16  = ()+   ToSizedCstr SInt32  = ()+   ToSizedCstr SInt64  = ()+   ToSizedCstr arg     = TypeError (ToSizedErr arg)++-- | Conversion from a fixed-sized BV to a sized bit-vector.+class ToSizedBV a where+   -- | Convert a fixed-sized bit-vector to the corresponding sized bit-vector,+   -- for instance 'SWord16' to 'SWord 16'. See also 'fromSized'.+   toSized :: a -> ToSized a++   default toSized :: (Num (ToSized a), Integral a) => (a -> ToSized a)+   toSized = fromIntegral++instance {-# OVERLAPPING  #-} ToSizedBV Word8+instance {-# OVERLAPPING  #-} ToSizedBV Word16+instance {-# OVERLAPPING  #-} ToSizedBV Word32+instance {-# OVERLAPPING  #-} ToSizedBV Word64+instance {-# OVERLAPPING  #-} ToSizedBV Int8+instance {-# OVERLAPPING  #-} ToSizedBV Int16+instance {-# OVERLAPPING  #-} ToSizedBV Int32+instance {-# OVERLAPPING  #-} ToSizedBV Int64+instance {-# OVERLAPPING  #-} ToSizedBV SWord8  where toSized = sFromIntegral+instance {-# OVERLAPPING  #-} ToSizedBV SWord16 where toSized = sFromIntegral+instance {-# OVERLAPPING  #-} ToSizedBV SWord32 where toSized = sFromIntegral+instance {-# OVERLAPPING  #-} ToSizedBV SWord64 where toSized = sFromIntegral+instance {-# OVERLAPPING  #-} ToSizedBV SInt8   where toSized = sFromIntegral+instance {-# OVERLAPPING  #-} ToSizedBV SInt16  where toSized = sFromIntegral+instance {-# OVERLAPPING  #-} ToSizedBV SInt32  where toSized = sFromIntegral+instance {-# OVERLAPPING  #-} ToSizedBV SInt64  where toSized = sFromIntegral+instance {-# OVERLAPPABLE #-} ToSizedCstr arg => ToSizedBV arg where toSized = error "unreachable"+ -- | The 'SDivisible' class captures the essence of division. -- Unfortunately we cannot use Haskell's 'Integral' class since the 'Real' -- and 'Enum' superclasses are not implementable for symbolic bit-vectors.@@ -1978,7 +2111,7 @@ -- uses "truncate to 0" for quotRem, and "truncate to negative infinity" for divMod. -- So, we cannot just use the above liftings directly. instance SDivisible SInteger where-  sDivMod = liftDMod+  sDivMod x y = ite (y .> 0) (sEDivMod x y) (liftDMod x y)   sQuotRem x y     | not (isSymbolic x || isSymbolic y)     = liftQRem x y@@ -2392,28 +2525,39 @@ -}  -- Bounded instances-instance (SymVal a, Bounded a) => Bounded (SBV a) where+instance {-# OVERLAPPABLE #-} (SymVal a, Bounded a) => Bounded (SBV a) where   minBound = literal minBound   maxBound = literal maxBound +-- Haskell and SMTLib differ in their default char ranges. In Haskell, maxbound is a lot larger.+-- But in SMTLib, we only go upto 0x2FFFF. So, we adopt the SMTLib variant here. This is hardly+-- an issue in practice, but the discrepancy is disconcerting.+instance {-# OVERLAPPING #-} Bounded SChar where+  minBound = literal (chr 0)+  maxBound = literal (chr 0x2FFFF)+ -- | Choose a value that satisfies the given predicate. This is Hillbert's choice, essentially. Note that -- if the predicate given is not satisfiable (for instance @const sFalse@), then the element returned will be arbitrary. -- The only guarantee is that if there's at least one element that satisfies the predicate, then the returned -- element will be one of those that do. The returned element is not guaranteed to be unique, least, greatest etc, unless -- there happens to be exactly one satisfying element. some :: forall a. (SymVal a, HasKind a) => String -> (SBV a -> SBool) -> SBV a-some nm cond = mk f+some inpName cond = mk f   where mk = SBV . SVal k . Right . cache          k = kindOf (Proxy @a) -        f st = do nm' <- newUninterpreted st (UIGiven nm) Nothing (SBVType [k]) (UINone False)++        f st = do ctr <- incrementFreshNameCounter st+                  let pre = atProxy (Proxy @a) inpName+                      nm  | ctr == 0 = pre+                          | True     = pre ++ "_" ++ show ctr+                  nm' <- newUninterpreted st (UIGiven nm) Nothing (SBVType [k]) (UINone False)                   chosen <- newExpr st k $ SBVApp (Uninterpreted nm') []                   let ifExists  = quantifiedBool $ \(Exists ex) -> cond ex                   internalConstraint st False [] (unSBV (ifExists .=> cond (mk (pure (pure chosen)))))                   pure chosen - -- | SMT definable constants and functions, which can also be uninterpeted. -- This class captures functions that we can generate standalone-code for -- in the SMT solver. Note that we also allow uninterpreted constants and@@ -2458,12 +2602,15 @@   --   -- Then, make sure you use @bar "two" 2@ and @bar "three" 3@ etc. to preserve the invariant.   --+  -- Furthermore, the function argument must not capture any non-constant variables in the context.+  -- You can also define higher-order functions, see 'smtHOFunction' for that purpose.+  --   -- Note that this is a design choice, to keep function creation as easy to use as possible. SBV   -- could've made 'smtFunction' a monadic call and generated the name itself to avoid all these issues.   -- But the ergonomics of that is worse, and doesn't fit with the general design philosophy. If you   -- can think of a solution (perhaps using some nifty GHC tricks?) to avoid this issue without making   -- 'smtFunction' return a monadic result, please get in touch!-  smtFunction :: Lambda Symbolic a => String -> a -> a+  smtFunction :: (Typeable a, Lambda Symbolic a) => String -> a -> a    -- | Register a function. This function is typically not needed as SBV will register functions used   -- automatically upon first use. However, there are scenarios (in particular query contexts)@@ -2527,12 +2674,13 @@   {-# MINIMAL sbvDefineValue, sbv2smt #-}    -- defaults:-  uninterpret         nm         = sbvDefineValue (UIGiven nm)   Nothing   $ UIFree True-  uninterpretWithArgs nm  as     = sbvDefineValue (UIGiven nm)   (Just as) $ UIFree True-  smtFunction         nm       v = sbvDefineValue (UIGiven nm)   Nothing   $ UIFun   (v, \st fk -> namedLambda TopLevel st nm fk v)-  cgUninterpret       nm  code v = sbvDefineValue (UIGiven nm)   Nothing   $ UICodeC (v, code)+  uninterpret         nm         = sbvDefineValue (UIGiven nm) Nothing   $ UIFree True+  uninterpretWithArgs nm  as     = sbvDefineValue (UIGiven nm) (Just as) $ UIFree True+  cgUninterpret       nm  code v = sbvDefineValue (UIGiven nm) Nothing   $ UICodeC (v, code)   sym                            = uninterpret +  smtFunction nm v = sbvDefineValue (UIGiven (atProxy (Proxy @a) nm)) Nothing $ UIFun (v, \st fk -> lambda st TopLevel fk v)+   default registerFunction :: forall b c. (a ~ (SBV b -> c), SymVal b, SMTDefinable c) => a -> Symbolic ()   registerFunction f = do let k = kindOf (Proxy @b)                           st <- symbolicEnv@@ -2551,7 +2699,6 @@ -- Get the code associated with the UI, unless we've already did this once. (To support recursive defs.) retrieveUICode :: UIName -> State -> Kind -> UIKind a -> IO UICodeKind retrieveUICode _             _  _  (UIFree  c)      = pure $ UINone c-retrieveUICode (UIPrefix nm) _  _  _                = error $ "Data.SBV.retrieveUICode: Unexpected prefix name received: " ++ nm retrieveUICode (UIGiven  nm) st fk (UIFun   (_, f)) = do userFuncs <- readIORef (rUserFuncs st)                                                          if nm `Set.member` userFuncs                                                             then pure $ UINone True@@ -3170,47 +3317,56 @@ -- Quickcheck interface on symbolic-booleans.. instance Testable SBool where   property (SBV (SVal _ (Left b))) = property (cvToBool b)-  property _                       = cantQuickCheck+  property s                       = cantQuickCheck $ "Result did not evaluate to a concrete boolean: " ++ show s  instance Testable (Symbolic SBool) where    property prop = QC.monadicIO $ do (cond, r, modelVals) <- QC.run test                                      QC.pre cond                                      unless (r || null modelVals) $ QC.monitor (QC.counterexample (complain modelVals))                                      QC.assert r-     where test = do (r, Result{resTraces=tvals, resObservables=ovals, resConsts=(_, cs), resConstraints=cstrs, resUIConsts=unints}) <- runSymbolic defaultSMTCfg (Concrete Nothing) prop+     where test = do (r, Result{resTraces=tvals, resObservables=ovals, resConsts=(_, cs), resConstraints=cstrs, resUIConsts=unints}) <- +                                 C.catch (runSymbolic defaultSMTCfg (Concrete Nothing) prop)+                                         (\(e :: C.SomeException) -> cantQuickCheck (show e)) -                     let cval = fromMaybe cantQuickCheck . (`lookup` cs)++                     let cval = fromMaybe (cantQuickCheck "A constraint did not evaluate to a concrete boolean") . (`lookup` cs)                          cond = -- Only pick-up "hard" constraints, as indicated by False in the fist component                                 and [cvToBool (cval v) | (False, _, v) <- F.toList cstrs]                           getObservable (nm, f, v) = case v `lookup` cs of                                                       Just cv -> if f cv then Just (nm, cv) else Nothing-                                                      Nothing -> cantQuickCheck+                                                      Nothing -> cantQuickCheck "An observable did not evaluate to a concrete value"                       case map fst unints of                        [] -> case unliteral r of-                               Nothing -> cantQuickCheck+                               Nothing -> cantQuickCheck "The result did not evaluate to a concrete value"                                Just b  -> return (cond, b, tvals ++ mapMaybe getObservable ovals)-                       _  -> cantQuickCheck+                       uis -> cantQuickCheck $ "Uninterpreted constants remain: " ++ unwords uis             complain qcInfo = showModel defaultSMTCfg (SMTModel [] Nothing qcInfo [])  -- Complain if what we got isn't something we can quick-check-cantQuickCheck :: a-cantQuickCheck = error $ unlines [ "*** Data.SBV: Cannot quickcheck the given property."-                                 , "***"-                                 , "*** Certain SBV properties cannot be quick-checked. In particular,"-                                 , "*** SBV can't quick-check in the presence of:"-                                 , "***"-                                 , "***   - Uninterpreted constants."-                                 , "***   - Floating point operations with rounding modes other than RNE."-                                 , "***   - Floating point FMA operation, regardless of rounding mode."-                                 , "***   - Quantified booleans, i.e., uses of Forall/Exists/ExistsUnique."-                                 , "***   - Calls to 'observe' (use 'sObserve' instead)"-                                 , "***"-                                 , "*** If you can't avoid the above features or run into an issue with"-                                 , "*** quickcheck even though you haven't used these features, please report this as a bug!"-                                 ]+cantQuickCheck :: String -> a+cantQuickCheck why = error $ unlines [ "*** Data.SBV: Cannot quickcheck the given property."+                                     , "***"+                                     , "*** Certain SBV properties cannot be quick-checked. In particular,"+                                     , "*** SBV can't quick-check in the presence of:"+                                     , "***"+                                     , "***   - Uninterpreted constants."+                                     , "***   - Uninterpreted types."+                                     , "***   - Floating point operations with rounding modes other than RNE."+                                     , "***   - Floating point FMA operation, regardless of rounding mode."+                                     , "***   - Quantified booleans, i.e., uses of Forall/Exists/ExistsUnique."+                                     , "***   - Uses of quantifiedBool"+                                     , "***   - Calls to 'observe' (use 'sObserve' instead)"+                                     , "***"+                                     , "*** If you can't avoid the above features or run into an issue with"+                                     , "*** quickcheck even though you haven't used these features, please report this as a bug!"+                                     , "***"+                                     , "*** Origin:"+                                     , "***"+                                     , why+                                     ]  -- | Quick check an SBV property. Note that a regular @quickCheck@ call will work just as -- well. Use this variant if you want to receive the boolean result.@@ -3368,6 +3524,43 @@ listArray :: (SymVal a, SymVal b) => [(a, b)] -> b -> SArray a b listArray ascs def = literal $ ArrayModel ascs def +-- | Create a closure, wrapping the free variables together with the function. When using higher-order functions+-- in SBV (like map), the function passed must be closed, i.e., not have any free variables. If you need to call+-- such a function with a function capturing a free variable, you should create a closure instead.+data Closure env a = Closure { closureEnv :: env+                             , closureFun :: env -> a+                             }++-- | Define a higher-order function. Similar to 'smtFunction', but when we have a higher-order argument. Note that+-- the higher-order argument cannot have free variables. Also, if the function is recursive, you should call+-- the first argument of the defining function, which SBV uses to tie the recursive knot. (Note that recursive+-- functions defined via 'smtFunction' don't have this latter requirement as they can figure out the recursion+-- automatically. Higher-order functions, unfortunately, can't do this: They firstify their high-order argument,+-- giving the whole function a unique name; captured via the call to the recursive definition.)+smtHOFunction :: forall a b f.+                 ( SMTDefinable (a -> SBV b)+                 , Lambda Symbolic f+                 , Lambda Symbolic (a -> SBV b)+                 , HasKind b+                 , HasKind f+                 , Typeable a+                 , Typeable b+                 , Typeable f+                 ) => String       -- prefix to use+                   -> f            -- The higher-order argument. We're very generic here!+                   -> (a -> SBV b) -- The ho-function we're modeling+                   ->  a -> SBV b  -- The resulting function, that can be used as is, and will be rendered in SMTLib without unfolding+smtHOFunction nm f hof arg = SBV $ SVal (kindOf (Proxy @(SBV b))) $ Right $ cache r+  where r st = do SMTLambda lam <- lambdaStr st HigherOrderArg (resKindOf (kindOf (Proxy @f))) f+                  let uniqLen = firstifyUniqueLen $ stCfg st+                      uniq    = take uniqLen (BC.unpack (B.encode (hash (BC.pack (unwords (words lam))))))+                  sbvToSV st (smtFunction (atProxy (Proxy @f) nm <> "_" <> uniq) hof arg)++        -- we get the functions as arrays here, so chase to find the result+        resKindOf (KArray _ k) = resKindOf k+        resKindOf k            = k+ {- HLint ignore module "Reduce duplication"   -} {- HLint ignore module "Eta reduce"           -} {- HLint ignore module "Avoid NonEmpty.unzip" -}+{- HLint ignore module "Redundant id"         -}
Data/SBV/Core/Operations.hs view
@@ -820,8 +820,8 @@                     () | swt == trueSV  -> svToSV st a       -- these two cases should never be needed as we expect symbolicMerge to be                     () | swt == falseSV -> svToSV st b       -- called with symbolic tests, but just in case..                     () -> do {- It is tempting to record the choice of the test expression here as we branch down to the 'then' and 'else' branches. That is,-                                when we evaluate 'a', we can make use of the fact that the test expression is True, and similarly we can use the fact that it-                                is False when b is evaluated. In certain cases this can cut down on symbolic simulation significantly, for instance if+                                when we evaluate @a@, we can make use of the fact that the test expression is True, and similarly we can use the fact that it+                                is False when @b@ is evaluated. In certain cases this can cut down on symbolic simulation significantly, for instance if                                 repetitive decisions are made in a recursive loop. Unfortunately, the implementation of this idea is quite tricky, due to                                 our sharing based implementation. As the 'then' branch is evaluated, we will create many expressions that are likely going                                 to be "reused" when the 'else' branch is executed. But, it would be *dead wrong* to share those values, as they were "cached"
Data/SBV/Core/Sized.hs view
@@ -31,6 +31,7 @@ import Data.Proxy (Proxy(..))  import GHC.TypeLits+import GHC.Real  import Data.SBV.Core.Kind import Data.SBV.Core.Symbolic@@ -125,13 +126,43 @@  -- | 'Enum' instance for t'WordN' instance (KnownNat n, BVIsNonZero n) => Enum (WordN n) where-   toEnum   = fromInteger  . toInteger+   succ x | x == maxBound = error $ "Enum.succ{" ++ show (kindOf x) ++ "}: tried to take `succ' of last tag in enumeration"+          | True          = x + 1++   pred x | x == minBound = error $ "Enum.pred{" ++ show (kindOf x) ++ "}: tried to take `pred' of first tag in enumeration"+          | True          = x - 1++   toEnum i | toInteger i < toInteger (minBound :: WordN n) = bad $ show i ++ " < minBound of " ++ show (minBound :: WordN n)+            | toInteger i > toInteger (maxBound :: WordN n) = bad $ show i ++ " > maxBound of " ++ show (maxBound :: WordN n)+            | True                                          = fromInteger (toInteger i)+     where bad why = error $ "Enum." ++ showType (Proxy @(WordN n)) ++ ".toEnum: bad argument: (" ++ why ++ ")"+    fromEnum = fromIntegral . toInteger +   enumFrom       = integralEnumFrom+   enumFromTo     = integralEnumFromTo+   enumFromThen   = integralEnumFromThen+   enumFromThenTo = integralEnumFromThenTo+ -- | 'Enum' instance for t'IntN' instance (KnownNat n, BVIsNonZero n) => Enum (IntN n) where-   toEnum   = fromInteger  . toInteger+   succ x | x == maxBound = error $ "Enum.succ{" ++ show (kindOf x) ++ "}: tried to take `succ' of last tag in enumeration"+          | True          = x + 1++   pred x | x == minBound = error $ "Enum.pred{" ++ show (kindOf x) ++ "}: tried to take `pred' of first tag in enumeration"+          | True          = x - 1++   toEnum i | toInteger i < toInteger (minBound :: IntN n) = bad $ show i ++ " < minBound of " ++ show (minBound :: IntN n)+            | toInteger i > toInteger (maxBound :: IntN n) = bad $ show i ++ " > maxBound of " ++ show (maxBound :: IntN n)+            | True                                         = fromInteger (toInteger i)+     where bad why = error $ "Enum." ++ showType (Proxy @(IntN n)) ++ ".toEnum: bad argument: (" ++ why ++ ")"+    fromEnum = fromIntegral . toInteger++   enumFrom       = integralEnumFrom+   enumFromTo     = integralEnumFromTo+   enumFromThen   = integralEnumFromThen+   enumFromThenTo = integralEnumFromThenTo  -- | 'Real' instance for t'WordN' instance (KnownNat n, BVIsNonZero n) => Real (WordN n) where
Data/SBV/Core/SizedFloats.hs view
@@ -17,7 +17,7 @@ {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}  module Data.SBV.Core.SizedFloats (         -- * Type-sized floats@@ -37,21 +37,23 @@ import Data.List (isSuffixOf) import Data.Proxy import GHC.TypeLits+import GHC.Real  import Data.Bits-import Data.Ratio import Numeric  import Data.SBV.Core.Kind import Data.SBV.Utils.Numeric (floatToWord) -import LibBF (BigFloat, BFOpts, RoundMode, Status)+import LibBF (BigFloat, BFOpts, RoundMode, Status, BFRep(..), BFNum(..), bfToRep, Sign(Neg)) import qualified LibBF as BF  import qualified Data.Generics as G  import Control.DeepSeq(NFData(..)) +import Test.QuickCheck (Arbitrary(..))+ -- | A floating point value, indexed by its exponent and significand sizes. -- --   An IEEE SP is @FloatingPoint  8 24@@@ -72,6 +74,21 @@   f0               >  f1               = f1 <  f0       -- See the note above   f0               >= f1               = f1 <= f0       -- See the note above +-- | 'Enum' instance for t'FloatingPoint'. Note that Haskell requires+-- float termination conditions to go over @delta/2@. Also, repeated addition+-- is wrong; instead we need to use multiplication to avoid accuracy issues per the report.+instance ValidFloat eb sb => Enum (FloatingPoint eb sb) where+   succ x = x + 1+   pred x = x - 1++   toEnum                      = fromIntegral+   fromEnum (FloatingPoint fp) = fromInteger (truncate fp)++   enumFrom       = numericEnumFrom+   enumFromTo     = numericEnumFromTo+   enumFromThen   = numericEnumFromThen+   enumFromThenTo = numericEnumFromThenTo+ -- | Abbreviation for IEEE half precision float, bit width 16 = 5 + 11. type FPHalf = FloatingPoint 5 11 @@ -107,6 +124,14 @@ instance NFData FP where   rnf (FP e s _) = e `seq` s `seq` () +instance ValidFloat eb sb => Arbitrary (FloatingPoint eb sb) where+  arbitrary = FloatingPoint . FP (intOfProxy (Proxy @eb)) (intOfProxy (Proxy @sb))  <$> arbitrary++-- | This arbitrary instance is questionable, but seems to work ok. We get an arbitrary double,+-- and just use that. Probably not good enough for real random work, but good enough here.+instance Arbitrary BigFloat where+  arbitrary = BF.bfFromDouble <$> arbitrary+ -- Manually implemented instance as GHC generated a non-IEEE 754 compliant instance. -- Note that we cannot pack the values in a tuple and then compare them as that will -- also give non-IEEE 754 compilant results.@@ -359,6 +384,26 @@                                                          in if y > 0                                                             then fromIntegral $ sgn $ v * e                                                             else fromIntegral $ sgn v++-- | Real instance for FloatingPoint. NB. The methods haven't been subjected to much testing, so beware of any floating-point snafus here.+instance ValidFloat eb sb => Real (FloatingPoint eb sb) where+  toRational (FloatingPoint (FP _ _ r)) = case bfToRep r of+                                            BFNaN     -> toRational (0/0 :: Double)+                                            BFRep s n -> case n of+                                                           Zero    -> 0 % 1+                                                           Inf     -> (if s == Neg then -1 else 1) % 0+                                                           Num x y -> -- The value here is x * 2^y+                                                                      let v :: Integer+                                                                          v   = 2 ^ abs (fromIntegral y :: Integer)+                                                                          sgn = if s == Neg then ((-1) *) else id+                                                                      in if y > 0+                                                                            then sgn $ x * v % 1+                                                                            else sgn $ x % v++-- | RealFrac instance for FloatingPoint. NB. The methods haven't been subjected to much testing, so beware of any floating-point snafus here.+instance ValidFloat eb sb => RealFrac (FloatingPoint eb sb) where+  properFraction (FloatingPoint f) = (a, FloatingPoint b)+     where (a, b) = properFraction f  -- | Num instance for FloatingPoint instance ValidFloat eb sb => Num (FloatingPoint eb sb) where
Data/SBV/Core/Symbolic.hs view
@@ -41,7 +41,7 @@   , RegExp(..), regExpToSMTString, SMTLambda(..)   , Quantifier(..), needsExistentials, SBVContext(..), checkCompatibleContext, VarContext(..)   , RoundingMode(..)-  , SBVType(..), svUninterpreted, svUninterpretedNamedArgs, newUninterpreted+  , SBVType(..), svUninterpreted, svUninterpretedNamedArgs, newUninterpreted, prefixNameToUnique   , SVal(..)   , svMkSymVar, sWordN, sWordN_, sIntN, sIntN_   , svToSV, svToSymSV, forceSVArg@@ -52,21 +52,21 @@   , getUserName', getUserName   , lookupInput , getSValPathCondition, extendSValPathCondition   , getTableIndex, sObserve-  , SBVPgm(..), MonadSymbolic(..), SymbolicT, Symbolic, runSymbolic, mkNewState, runSymbolicInState, State(..), SMTDef(..), smtDefGivenName, withNewIncState, IncState(..), incrementInternalCounter+  , SBVPgm(..), MonadSymbolic(..), SymbolicT, Symbolic, runSymbolic, mkNewState, runSymbolicInState, State(..), SMTDef(..), withNewIncState, IncState(..), incrementInternalCounter, incrementFreshNameCounter   , inSMTMode, SBVRunMode(..), IStage(..), Result(..), ResultInp(..), UICodeKind(..), UIName(..)-  , registerKind, registerLabel, registerSpecialFunction, recordObservable+  , registerKind, registerLabel, recordObservable   , addAssertion, addNewSMTOption, imposeConstraint, internalConstraint, newInternalVariable, lambdaVar, quantVar   , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension   , SolverCapabilities(..)   , extractSymbolicSimulationState, CnstMap   , OptimizeStyle(..), Objective(..), Penalty(..), objectiveName, addSValOptGoal   , MonadQuery(..), QueryT(..), Query, QueryState(..), QueryContext(..)-  , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), KDOptions(..), SMTEngine, isEmptyModel+  , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), TPOptions(..), SMTEngine, isEmptyModel   , validationRequested, outputSVal, ProgInfo(..), mustIgnoreVar, getRootState   ) where  import Control.DeepSeq             (NFData(..))-import Control.Monad               (when, unless)+import Control.Monad               (when) import Control.Monad.Except        (MonadError, ExceptT) import Control.Monad.Reader        (MonadReader(..), ReaderT, runReaderT,                                     mapReaderT)@@ -74,10 +74,9 @@ import Control.Monad.Trans         (MonadIO(liftIO), MonadTrans(lift)) import Control.Monad.Trans.Maybe   (MaybeT) import Control.Monad.Writer.Strict (MonadWriter)-import Data.Char                   (isSpace) import Data.IORef                  (IORef, newIORef, readIORef) import Data.List                   (intercalate, sortBy, isPrefixOf)-import Data.Maybe                  (fromMaybe, mapMaybe)+import Data.Maybe                  (fromMaybe) import Data.String                 (IsString(fromString))  import Data.Time (getCurrentTime, UTCTime)@@ -110,7 +109,7 @@ import Data.SBV.Core.Concrete import Data.SBV.SMT.SMTLibNames import Data.SBV.Utils.TDiff (Timing)-import Data.SBV.Utils.Lib   (stringToQFS, checkObservableName, needsBars)+import Data.SBV.Utils.Lib   (stringToQFS, checkObservableName, barify)  import Data.Containers.ListUtils (nubOrd) @@ -386,18 +385,8 @@   show DivOv           = "bvsdivo" -- This is confusing, the division is called bvsdivo, but negation is bvnego   show NegOv           = "bvnego"  -- But SMTLib's choice is deliberate: https://groups.google.com/u/0/g/smt-lib/c/J4D99wT0aKI --- | String operations. Note that we do not define @StrAt@ as it translates to 'StrSubstr' trivially.-data StrOp = StrConcat       -- ^ Concatenation of one or more strings-           | StrLen          -- ^ String length-           | StrUnit         -- ^ Unit string-           | StrNth          -- ^ Nth element-           | StrSubstr       -- ^ Retrieves substring of @s@ at @offset@-           | StrIndexOf      -- ^ Retrieves first position of @sub@ in @s@, @-1@ if there are no occurrences-           | StrContains     -- ^ Does @s@ contain the substring @sub@?-           | StrPrefixOf     -- ^ Is @pre@ a prefix of @s@?-           | StrSuffixOf     -- ^ Is @suf@ a suffix of @s@?-           | StrReplace      -- ^ Replace the first occurrence of @src@ by @dst@ in @s@-           | StrStrToNat     -- ^ Retrieve integer encoded by string @s@ (ground rewriting only)+-- | String operations.+data StrOp = StrStrToNat     -- ^ Retrieve integer encoded by string @s@ (ground rewriting only)            | StrNatToStr     -- ^ Retrieve string encoded by integer @i@ (ground rewriting only)            | StrToCode       -- ^ Equivalent to Haskell's ord            | StrFromCode     -- ^ Equivalent to Haskell's chr@@ -500,16 +489,6 @@  -- | Show instance for @StrOp@. Note that the mapping here is important to match the SMTLib equivalents. instance Show StrOp where-  show StrConcat   = "str.++"-  show StrLen      = "str.len"-  show StrUnit     = "str.unit"      -- NB. This is actually a no-op, since in SMTLib characters are the same as strings.-  show StrNth      = "str.at"-  show StrSubstr   = "str.substr"-  show StrIndexOf  = "str.indexof"-  show StrContains = "str.contains"-  show StrPrefixOf = "str.prefixof"-  show StrSuffixOf = "str.suffixof"-  show StrReplace  = "str.replace"   show StrStrToNat = "str.to.int"    -- NB. SMTLib uses "int" here though only nats are supported   show StrNatToStr = "int.to.str"    -- NB. SMTLib uses "int" here though only nats are supported   show StrToCode   = "str.to_code"@@ -532,63 +511,36 @@ instance Show SMTLambda where   show (SMTLambda s) = s --- | Sequence operations.-data SeqOp = SeqConcat                           -- ^ See StrConcat-           | SeqLen                              -- ^ See StrLen-           | SeqUnit                             -- ^ See StrUnit-           | SeqNth                              -- ^ See StrNth-           | SeqSubseq                           -- ^ See StrSubseq-           | SeqIndexOf                          -- ^ See StrIndexOf-           | SeqContains                         -- ^ See StrContains-           | SeqPrefixOf                         -- ^ See StrPrefixOf-           | SeqSuffixOf                         -- ^ See StrSuffixOf-           | SeqReplace                          -- ^ See StrReplace-           -- Polymorphic and higher order functions-           | SBVReverse   Kind                     -- ^ reverse k.         Where k is either [a] or String. Reverses the argument, accordingly.-           | SBVZip       Kind Kind                -- ^ zip a b.           Where we zip [a] and [b] to produce [(a, b)]-           | SBVZipWith   Kind Kind Kind SMTLambda -- ^ zipWith a b c fun. Where fun :: a -> b -> c, and zipWith   :: (a -> b -> c) -> [a] -> [b] -> [c]-           | SBVPartition Kind           SMTLambda -- ^ partition a fun.   Where fun :: a -> SBool,  and partition :: (a -> Bool) -> [a] -> ([a], [a])-           | SBVMap       Kind Kind      SMTLambda -- ^ map    a b fun.    Where fun :: a -> b,      and map       :: (a -> b) -> [a] -> [b]-           | SBVFoldl     Kind Kind      SMTLambda -- ^ foldl  a b fun.    Where fun :: b -> a -> b, and foldl     :: (b -> a -> b) -> b -> [a] -> b-           | SBVFoldr     Kind Kind      SMTLambda -- ^ foldr  a b fun.    Where fun :: a -> b -> b, and foldr     :: (a -> b -> b) -> b -> [a] -> b-           | SBVFilter    Kind           SMTLambda -- ^ filter a fun.      Where fun :: a -> Bool,   and filter    :: (a -> Bool) -> [a] -> [a]-           | SBVAll       Kind           SMTLambda -- ^ all    a fun.      Where fun :: a -> Bool,   and all       :: (a -> Bool) -> [a] -> Bool-           | SBVAny       Kind           SMTLambda -- ^ any    a fun.      Where fun :: a -> Bool,   and any       :: (a -> Bool) -> [a] -> Bool-           | SBVConcat    Kind                     -- ^ concat a.          Where we concat [[a]] to get [a] (a is the inside-element type)+-- | Sequence operations. Indexed by the element kind.+data SeqOp = SeqLen      Kind+           | SeqConcat   Kind+           | SeqNth      Kind+           | SeqUnit     Kind+           | SeqSubseq   Kind+           | SeqIndexOf  Kind+           | SeqContains Kind+           | SeqPrefixOf Kind+           | SeqSuffixOf Kind+           | SeqReplace  Kind   deriving (Eq, Ord, G.Data, NFData, Generic) +-- | Pick the correct operator+pickSeqOp :: Kind -> String -> String -> String+pickSeqOp KChar st _  = st+pickSeqOp _     _  sq = sq+ -- | Show instance for SeqOp. Again, mapping is important. instance Show SeqOp where-  show SeqConcat        = "seq.++"-  show SeqLen           = "seq.len"-  show SeqUnit          = "seq.unit"-  show SeqNth           = "seq.nth"-  show SeqSubseq        = "seq.extract"-  show SeqIndexOf       = "seq.indexof"-  show SeqContains      = "seq.contains"-  show SeqPrefixOf      = "seq.prefixof"-  show SeqSuffixOf      = "seq.suffixof"-  show SeqReplace       = "seq.replace"--  -- Note: The followings aren't part of SMTLib, we explicitly handle them-  show (SBVReverse   a)       = funcWithKind "sbv.reverse"   a                  Nothing-  show (SBVZip       a b)     = funcWithKind "sbv.zip"       (KTuple [a, b])    Nothing-  show (SBVZipWith   a b c f) = funcWithKind "sbv.zipWith"   (KTuple [a, b, c]) (Just f)-  show (SBVPartition a     f) = funcWithKind "sbv.partition" a                  (Just f)-  show (SBVMap       a b   f) = funcWithKind "sbv.map"       (KTuple [a, b])    (Just f)-  show (SBVFoldl     a b   f) = funcWithKind "sbv.foldl"     (KTuple [a, b])    (Just f)-  show (SBVFoldr     a b   f) = funcWithKind "sbv.foldr"     (KTuple [a, b])    (Just f)-  show (SBVFilter    a     f) = funcWithKind "sbv.filter"    a                  (Just f)-  show (SBVAll       a     f) = funcWithKind "sbv.all"       a                  (Just f)-  show (SBVAny       a     f) = funcWithKind "sbv.any"       a                  (Just f)-  show (SBVConcat    a)       = funcWithKind "sbv.concat"    a                  Nothing---- helper for above-funcWithKind :: String -> Kind -> Maybe SMTLambda -> String-funcWithKind f k mbExtra = f ++ " @" ++ ssk ++ maybe "" (\l -> ' ' : show l) mbExtra-  where sk  = show k-        ssk | any isSpace sk = '(' : sk ++ ")"-            | True           = sk+  show (SeqLen      k) = pickSeqOp k "str.len"      "seq.len"+  show (SeqConcat   k) = pickSeqOp k "str.++"       "seq.++"+  show (SeqNth      k) = pickSeqOp k "str.at"       "seq.nth"+  show (SeqUnit     k) = pickSeqOp k "str.unit"     "seq.unit"+  show (SeqSubseq   k) = pickSeqOp k "str.substr"   "seq.extract"+  show (SeqIndexOf  k) = pickSeqOp k "str.indexof"  "seq.indexof"+  show (SeqContains k) = pickSeqOp k "str.contains" "seq.contains"+  show (SeqPrefixOf k) = pickSeqOp k "str.prefixof" "seq.prefixof"+  show (SeqSuffixOf k) = pickSeqOp k "str.suffixof" "seq.suffixof"+  show (SeqReplace  k) = pickSeqOp k "str.replace"  "seq.replace"  -- | Set operations. data SetOp = SetEqual@@ -845,8 +797,7 @@ -- | A query is a user-guided mechanism to directly communicate and extract -- results from the solver. A generalization of 'Data.SBV.Query'. newtype QueryT m a = QueryT { runQueryT :: ReaderT State m a }-    deriving newtype (Applicative, Functor, Monad, MonadIO, MonadTrans,-              MonadError e, MonadState s, MonadWriter w)+    deriving newtype (Applicative, Functor, Monad, MonadIO, MonadTrans, MonadError e, MonadState s, MonadWriter w)  instance Monad m => MonadQuery (QueryT m) where   queryState = QueryT ask@@ -892,12 +843,11 @@ data ProgInfo = ProgInfo { hasQuants         :: Bool                          , progSpecialRels   :: [SpecialRelOp]                          , progTransClosures :: [(String, String)]-                         , progSpecialFuncs  :: [Op]                -- functions that need to be generated, like list reverse/all/any/filter                          }                          deriving G.Data  instance NFData ProgInfo where-   rnf (ProgInfo a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+   rnf (ProgInfo a b c) = rnf a `seq` rnf b `seq` rnf c  deriving instance G.Data CallStack deriving instance G.Data SrcLoc@@ -912,7 +862,7 @@                      , resConsts      :: (CnstMap, [(SV, CV)])                        -- ^ constants                      , resTables      :: [((Int, Kind, Kind), [SV])]                  -- ^ tables (automatically constructed) (tableno, index-type, result-type) elts                      , resUIConsts    :: [(String, (Bool, Maybe [String], SBVType))]  -- ^ uninterpreted constants-                     , resDefinitions :: [(SMTDef, SBVType)]                          -- ^ definitions created via smtFunction or lambda+                     , resDefinitions :: [(String, (SMTDef, SBVType))]                -- ^ definitions created via smtFunction                      , resAsgns       :: SBVPgm                                       -- ^ assignments                      , resConstraints :: S.Seq (Bool, [(String, String)], SV)         -- ^ additional constraints (boolean)                      , resAssertions  :: [(String, Maybe CallStack, SV)]              -- ^ assertions@@ -1182,39 +1132,25 @@     secondLookup = S.elemIndexL sv svs >>= flip S.lookup ns  -- | A defined function/value-data SMTDef = SMTDef String           -- ^ Defined functions -- name-                     Kind             -- ^ Final kind of the definition (resulting kind, not the params)+data SMTDef = SMTDef Kind             -- ^ Final kind of the definition (resulting kind, not the params)                      [String]         -- ^ other definitions it refers to                      (Maybe String)   -- ^ parameter string                      (Int -> String)  -- ^ Body, in SMTLib syntax, given the tab amount-            | SMTLam Kind             -- ^ Final kind of the definition (resulting kind, not the params)-                     [String]         -- ^ Anonymous function -- other definitions it refers to-                     (Maybe String)   -- ^ parameter string-                     (Int -> String)  -- ^ Body, in SMTLib syntax, given the tab amount             deriving G.Data  -- | For debug purposes instance Show SMTDef where-  show d = case d of-             SMTDef nm fk frees p body -> shDef (Just nm) fk frees p body-             SMTLam    fk frees p body -> shDef Nothing   fk frees p body-    where shDef mbNm fk frees p body = unlines [ "-- User defined function: " ++ fromMaybe "Anonymous" mbNm-                                               , "-- Final return type    : " ++ show fk-                                               , "-- Refers to            : " ++ intercalate ", " frees-                                               , "-- Parameters           : " ++ fromMaybe "NONE" p-                                               , "-- Body                 : "-                                               , body 2-                                               ]---- The name of this definition-smtDefGivenName :: SMTDef -> Maybe String-smtDefGivenName (SMTDef n _ _ _ _) = Just n-smtDefGivenName SMTLam{}           = Nothing+  show (SMTDef fk frees p body) = unlines [ "-- User defined function:"+                                          , "-- Final return type    : " ++ show fk+                                          , "-- Refers to            : " ++ intercalate ", " frees+                                          , "-- Parameters           : " ++ fromMaybe "NONE" p+                                          , "-- Body                 : "+                                          , body 2+                                          ]  -- | NFData instance for SMTDef instance NFData SMTDef where-  rnf (SMTDef n fk frees params body) = rnf n `seq` rnf fk `seq` rnf frees `seq` rnf params `seq` rnf body-  rnf (SMTLam   fk frees params body) =             rnf fk `seq` rnf frees `seq` rnf params `seq` rnf body+  rnf (SMTDef fk frees params body) = rnf fk `seq` rnf frees `seq` rnf params `seq` rnf body  -- | The state of the symbolic interpreter data State  = State { sbvContext          :: SBVContext@@ -1226,7 +1162,8 @@                     , rIncState           :: IORef IncState                     , rCInfo              :: IORef [(String, CV)]                     , rObservables        :: IORef (S.Seq (Name, CV -> Bool, SV))-                    , rctr                :: IORef Int+                    , rctr                :: IORef Int             -- Used for numbering SVs+                    , freshNameCtr        :: IORef Int             -- Used for calls to some                     , rLambdaLevel        :: IORef (Maybe Int)     -- If Nothing, then top-level lambda                     , rUsedKinds          :: IORef KindSet                     , rUsedLbls           :: IORef (Set.Set String)@@ -1242,7 +1179,7 @@                     , rUIMap              :: IORef UIMap                     , rUserFuncs          :: IORef (Set.Set String) -- Functions that the user wanted explicit code generation for                     , rCgMap              :: IORef CgMap-                    , rDefns              :: IORef [(SMTDef, SBVType)]+                    , rDefns              :: IORef [(String, (SMTDef, SBVType))]                     , rSMTOptions         :: IORef [SMTOption]                     , rOptGoals           :: IORef [Objective (SV, SV)]                     , rAsserts            :: IORef [(String, Maybe CallStack, SV)]@@ -1338,14 +1275,21 @@                                  return ctr {-# INLINE incrementInternalCounter #-} +-- | Increment the fresh-var counter+incrementFreshNameCounter :: State -> IO Int+incrementFreshNameCounter st = do ctr <- readIORef (freshNameCtr st)+                                  modifyState st freshNameCtr (+1) (return ())+                                  return ctr+{-# INLINE incrementFreshNameCounter #-}+ -- | Kind of code we have for uninterpretation data UICodeKind = UINone Bool     -- no code. If bool is true, then curried.                 | UISMT  SMTDef   -- SMTLib, first argument are the free-variables in it                 | UICgC  [String] -- Code-gen, currently only C --- | Is the name given by the user for the uninterpreted constant a prefix or a full name?-data UIName = UIGiven  String  -- ^ Full name-            | UIPrefix String  -- ^ Prefix+-- | A newtype wrapper for uninterpreted function names. This is in preparation+-- for a possibility of having other alternatives here, which we haven't needed so far.+newtype UIName = UIGiven String -- ^ Full name  -- | Uninterpreted constants and functions. An uninterpreted constant is -- a value that is indexed by its name. The only property the prover assumes@@ -1368,31 +1312,34 @@                        mapM_ forceSVArg sws                        newExpr st k $ SBVApp (Uninterpreted nm') sws +-- | Generate a unique name for the fiven function based on the object's stable name+prefixNameToUnique :: State -> String -> IO String+prefixNameToUnique st pre = do+   uiMap <- readIORef (rUIMap st)++   let suffix 0 = pre+       suffix i = pre ++ "_" ++ show i++   case [cand | i <- [0::Int ..], let cand = suffix i, cand `Map.notMember` uiMap] of+      (n:_) -> pure n+      []    -> error $ "genUniqueName: Can't generate a unique name for prefix: " ++ pre   -- can't happen+ -- | Create a new uninterpreted symbol, possibly with user given code. This function might change -- the name given, putting bars around it if needed. That's the name returned. newUninterpreted :: State -> UIName -> Maybe [String] -> SBVType -> UICodeKind -> IO String newUninterpreted st uiName mbArgNames t uiCode = do -  uiMap <- readIORef (rUIMap st)--  let candName = case uiName of-                   UIGiven  n   -> n-                   UIPrefix pre -> let suffix 0 = pre-                                       suffix i = pre ++ show i-                                   in case [cand | i <- [0::Int ..], let cand = suffix i, cand `Map.notMember` uiMap] of-                                        (n:_) -> n-                                        []    -> error $ "newUninterpreted: Can't generate a unique name for prefix: " ++ pre   -- can't happen+  candName <- case uiName of+                UIGiven n -> pure n        -- determine the final name-      nm = case () of+  let nm = case () of              () | "__internal_sbv_" `isPrefixOf` candName -> candName                -- internal names go thru-             () | needsBars candName                      -> '|' : candName ++ "|"   -- surround with bars if not legitimate in SMTLib-             ()                                           -> candName+                | True                                    -> barify candName         -- surround with bars if not legitimate in SMTLib        extraComment = case uiName of-                      UIGiven  n | nm /= n                 -> " (Given: " ++ n ++ ")"-                      UIPrefix n | not (nm `isPrefixOf` n) -> " (Given prefix: " ++ n ++ ")"-                      _                                    -> ""+                      UIGiven  n | nm /= n -> " (Given: " ++ n ++ ")"+                      _                    -> ""    -- Check if reserved:   when (isReserved nm) $@@ -1404,7 +1351,7 @@    isCurried <- case uiCode of                  UINone c -> pure c-                 UISMT d  -> do modifyState st rDefns (\defs -> (d, t) : filter (\(o, _) -> smtDefGivenName o /= Just nm) defs)+                 UISMT d  -> do modifyState st rDefns (\defs -> (nm, (d, t)) : filter (\(onm, _) -> onm /= nm) defs)                                   $ noInteractive [ "Defined functions (smtFunction):"                                                   , "  Name: " ++ nm ++ extraComment                                                   , "  Type: " ++ show t@@ -1424,6 +1371,7 @@                           ++ "      Previously used at: " ++ show t'         | True    = cont +  uiMap <- readIORef (rUIMap st)   case nm `Map.lookup` uiMap of     Just (_, _, t') -> checkType t' (return ())     Nothing         -> modifyState st rUIMap (Map.insert nm (isCurried, mbArgNames, t))@@ -1547,13 +1495,6 @@    where err w = error $ "SBV (" ++ whence ++ "): " ++ show nm ++ " " ++ w --- We need to auto-generate certain functions, so keep track of them here-registerSpecialFunction :: State -> Op -> IO ()-registerSpecialFunction st o =-  do progInfo <- readIORef (rProgInfo (getRootState st))-     let upd p@ProgInfo{progSpecialFuncs} = p{progSpecialFuncs = o : progSpecialFuncs}-     unless (o `elem` progSpecialFuncs progInfo) $ modifyState st rProgInfo upd (pure ())- -- | Create a new constant; hash-cons as necessary newConst :: State -> CV -> IO SV newConst st c = do@@ -1605,14 +1546,12 @@ -- This isn't a full solution, but handles the common case (hopefully!) checkConsistent :: SV -> SBVExpr -> IO () checkConsistent lhs (SBVApp _ args) = mapM_ check args-   where SV _ (NodeId (lhsContext, mbLambdaLevel, lhsId)) = lhs-         check (SV _ (NodeId (rhsContext, mbLL, ni)))-           | lhsContext `compatibleContext` rhsContext && lambdaLevel >= ll && (lambdaLevel /= ll || lhsId > ni)+   where SV _ (NodeId (lhsContext, _, _)) = lhs+         check (SV _ (NodeId (rhsContext, _, _)))+           | lhsContext `compatibleContext` rhsContext            = pure ()            | True-           = contextMismatchError lhsContext rhsContext (Just (lambdaLevel, lhsId)) (Just (ll, ni))-           where lambdaLevel = fromMaybe 0 mbLambdaLevel-                 ll          = fromMaybe 0 mbLL+           = contextMismatchError lhsContext rhsContext {-# INLINE checkConsistent #-}  -- | Are these compatible contexts? Either the same, or one of them is global@@ -1626,7 +1565,7 @@    | ctx1 `compatibleContext` ctx2    = pure ()    | True-   = contextMismatchError ctx1 ctx2 Nothing Nothing+   = contextMismatchError ctx1 ctx2 {-# INLINE checkCompatibleContext #-}  -- | Convert a symbolic value to an internal SV@@ -1726,10 +1665,15 @@         rm <- readIORef (runMode st)          let varInfo = case mbNm of-                        Nothing -> ", of type " ++ show k-                        Just nm -> ", while defining " ++ nm ++ " :: " ++ show k+                        Nothing -> "While defining a variable of type " ++ show k+                        Just nm -> "While defining: " ++ nm ++ " :: " ++ show k -            disallow what  = error $ "Data.SBV: Unsupported: " ++ what ++ varInfo ++ " in mode: " ++ show rm+            disallow what  = error $ unlines [ "*** Data.SBV: Unsupported: " ++ what+                                             , "***"+                                             , "*** " ++ varInfo+                                             , "*** "+                                             , "*** In mode: " ++ show rm+                                             ]              noUI cont               | isUserSort k  = disallow "User defined sorts"@@ -1855,10 +1799,10 @@      progInfo           <- newIORef ProgInfo { hasQuants         = False                                              , progSpecialRels   = []                                              , progTransClosures = []-                                             , progSpecialFuncs  = []                                              }      rm                 <- newIORef currentRunMode      ctr                <- newIORef (-2) -- start from -2; False and True will always occupy the first two elements+     fnctr              <- newIORef 0      lambda             <- newIORef $ case currentRunMode of                                         SMTMode{}     -> Just 0                                         CodeGen{}     -> Just 0@@ -1899,6 +1843,7 @@                   , rCInfo              = cInfo                   , rObservables        = observes                   , rctr                = ctr+                  , freshNameCtr        = fnctr                   , rLambdaLevel        = lambda                   , rUsedKinds          = usedKinds                   , rUsedLbls           = usedLbls@@ -1931,9 +1876,9 @@    runSymbolicInState st comp  -- | Catch the catastrophic case of context mismatch-contextMismatchError :: SBVContext -> SBVContext -> Maybe (Int, Int) -> Maybe (Int, Int) -> a-contextMismatchError ctx1 ctx2 level1 level2 = error $ unlines msg-  where msg | ctx1 /= ctx2 = [ "Data.SBV: Mismatched contexts detected."+contextMismatchError :: SBVContext -> SBVContext -> a+contextMismatchError ctx1 ctx2 = error $ unlines [+                               "Data.SBV: Mismatched contexts detected."                              , "***"                              , "***   Current context: " ++ show ctx1                              , "***   Mixed with     : " ++ show ctx2@@ -1943,22 +1888,6 @@                              , "*** Please avoid such nested calls, all interactions should be from the same context."                              , "*** See https://github.com/LeventErkok/sbv/issues/71 for several examples."                              ]-            | True         = [ "Data.SBV: Mismatched levels detected in the same context."-                             , "***"-                             , "***   Refers to: " ++ show level1-                             , "***   And also : " ++ show level2-                             , "***"-                             , "*** A typical reason for this is the use of a higher order function, typically from"-                             , "*** Data.SBV.List, with a lambda that refers to a free variable. (For instance calling"-                             , "*** 'f e xs = filter (.> e) xs' where 'x' is free in the lambda-expression '(.> e)'.)"-                             , "***"-                             , "*** While SBV does allow symbolic use of a selected subset of higher-order functions"-                             , "*** like filter/map/fold, the lambda-arguments must be closed. (This is due to the"-                             , "*** fact that SMTLib doesn't allow higher-order functions, and SBV firstifies such"-                             , "*** uses with a simple translation that doesn't allow for captured variables.) As"-                             , "*** SMTLib gains more higher order features, we might relax this constraint. Please"-                             , "*** report your use case as an example application."-                             ]  -- | Run a symbolic computation in a given state runSymbolicInState :: MonadIO m => State -> SymbolicT m a -> m (a, Result)@@ -1972,7 +1901,7 @@    let check ctx | ctx == sbvContext st || ctx == globalSBVContext                  = pure ()                  | True-                 = contextMismatchError (sbvContext st) ctx Nothing Nothing+                 = contextMismatchError (sbvContext st) ctx     mapM_ check $ nubOrd $ G.universeBi res @@ -2031,7 +1960,7 @@    ds    <- reverse <$> readIORef defns    unint <- do unints <- Map.toList <$> readIORef uis                -- drop those that has a definition associated with it-               let defineds = mapMaybe (smtDefGivenName . fst) ds+               let defineds = map fst ds                pure [ui | ui@(nm, _) <- unints, nm `notElem` defineds]    knds  <- readIORef usedKinds    cgMap <- Map.toList <$> readIORef cgs@@ -2295,18 +2224,18 @@        , solverSetOptions            :: [SMTOption]         -- ^ Options to set as we start the solver        , ignoreExitCode              :: Bool                -- ^ If true, we shall ignore the exit code upon exit. Otherwise we require ExitSuccess.        , redirectVerbose             :: Maybe FilePath      -- ^ Redirect the verbose output to this file if given. If Nothing, stdout is implied.-       , generateHOEquivs            :: Bool                -- ^ Should SBV generate function-level equivalences for firstified functions?-                                                            --   The default is False, but in certain cases this can lead the solver to loop-forever,-                                                            --   especially in KnuckleDragger proofs. In such cases, set this to True to see if it helps.-       , kdOptions                   :: KDOptions           -- ^ KnuckleDragger specific options+       , firstifyUniqueLen           :: Int                 -- ^ Unique length used for firstified higher-order function names+       , tpOptions                   :: TPOptions           -- ^ TP specific options        } --- | Configuration for KnuckleDragger-data KDOptions = KDOptions {-         ribbonLength      :: Int  -- ^ Line length for KD proofs-       , firstifyUniqueLen :: Int  -- ^ Unique length used for firstified names.-       , quiet             :: Bool -- ^ No messages what-so-ever for successful steps. (Will print if something fails)-       , measureTime       :: Bool -- ^ Print time/statistics. If quiet is True, then measureTime is ignored.+-- | Configuration for TP+data TPOptions = TPOptions {+         ribbonLength :: Int  -- ^ Line length for TP proofs+       , quiet        :: Bool -- ^ No messages what-so-ever for successful steps. (Will print if something fails)+       , printStats   :: Bool -- ^ Print time/statistics. If quiet is True, then measureTime is ignored.+       , cacheProofs  :: Bool -- ^ Treat lemma names as unique, and cache the results. Default: False. Note that this+                              -- feature is unsound unless you make sure (by some other mechanism) that your lemma names+                              -- are indeed unique.        }  -- | Ignore internal names and those the user told us to
Data/SBV/Internals.hs view
@@ -69,7 +69,7 @@   , svFloatingPointAsSWord    -- * lambdas and axioms-  , lambda, lambdaStr, namedLambda, namedLambdaStr, constraint, constraintStr, Lambda(..), Constraint(..), LambdaScope(..)+  , lambda, lambdaStr, constraint, constraintStr, Lambda(..), Constraint(..), LambdaScope(..)   ) where  import Control.Monad.IO.Class (MonadIO)
Data/SBV/Lambda.hs view
@@ -22,7 +22,6 @@  module Data.SBV.Lambda (             lambda,      lambdaStr-          , namedLambda, namedLambdaStr           , constraint,  constraintStr           , LambdaScope(..)         ) where@@ -60,19 +59,12 @@ inSubState :: MonadIO m => LambdaScope -> State -> (State -> m b) -> m b inSubState scope inState comp = do -        let noNesting = error $ unlines [ ""-                                        , "*** Data.SBV.Lambda: Detected nested lambda-definitions."-                                        , "***"-                                        , "*** SBV uses firstification to deal-with lambdas, and SMTLib's first-order nature does not allow"-                                        , "*** for easy translation of nested lambdas. As SMTLib gets higher-order features, SBV will eventually"-                                        , "*** relax this restriction. In the mean-time, please rewrite your program without using nested-lambdas"-                                        , "*** if possible. If this workaround isn't applicable, please report this as a use-case for further"-                                        , "*** possible enhancements."-                                        ]-         newLevel <- do ll <- liftIO $ readIORef (rLambdaLevel inState)                        pure $ case ll of-                                Nothing -> noNesting+                                Nothing -> -- We used to error out here, as this is nested-lambda+                                           -- But the recent fixes to support for higher-order functions made this+                                           -- unnecessary. (I hope!)+                                           Just 0                                 Just i  -> case scope of                                              HigherOrderArg -> Nothing                                              TopLevel       -> Just $ i + 1@@ -119,6 +111,7 @@                    , stCfg               = fresh stCfg                    , runMode             = fresh runMode                    , rctr                = fresh rctr+                   , freshNameCtr        = fresh freshNameCtr                    , rLambdaLevel        = fresh rLambdaLevel                    , rtblMap             = fresh rtblMap                    , rinps               = fresh rinps@@ -151,22 +144,40 @@ -- | Generic creator for anonymous lamdas. lambdaGen :: (MonadIO m, Lambda (SymbolicT m) a) => LambdaScope -> (Defn -> b) -> State -> Kind -> a -> m b lambdaGen scope trans inState fk f = inSubState scope inState $ \st -> handle <$> convert st fk (mkLambda st f)-  where handle d@(Defn _ frees _ _) =-            case scope of-              TopLevel       -> trans d-              HigherOrderArg -> if null frees-                                then trans d-                                else error $ unlines [ ""-                                                     , "*** Data.SBV.Lambda: Detected free variables passed to a lambda."-                                                     , "***"-                                                     , "***  Free vars : " ++ unwords frees-                                                     , "***  Definition: " ++ shift (lines (sh d))-                                                     , "***"-                                                     , "*** In certain contexts, SBV only allows closed-lambdas, i.e., those that do not have any free variables in."-                                                     , "***"-                                                     , "*** Please rewrite your program to pass the free variable as an explicit argument to the lambda if possible."-                                                     , "*** If this workaround isn't applicable, please report this as a use-case for further possible enhancements."-                                                     ]+  where handle d@(Defn _ frees _ _)+            | null frees+            = trans d+            | True+            = error $ unlines [ ""+                              , "*** Data.SBV.Lambda: Detected free variables passed to a lambda."+                              , "***"+                              , "***  Free vars : " ++ unwords frees+                              , "***  Definition: " ++ shift (lines (sh d))+                              , "***"+                              , "*** SBV currently does not support lambda-functions that capture variables. For"+                              , "*** instance, consider:"+                              , "***"+                              , "***     map (\\x -> map (\\y -> x + y))"+                              , "***"+                              , "*** where the inner 'map' uses 'x', bound by the outer 'map'. Instead, create"+                              , "*** a closure instead:"+                              , "***"+                              , "***     map (\\x -> map (Closure { closureEnv = x"+                              , "***                             , closureFun = \\env y -> env + y"+                              , "***                             }))"+                              , "***"+                              , "*** which will explicitly create the closure before calling 'map'. The environment can"+                              , "*** be any symbolic value: You can use a tuple to support multiple free variables."+                              , "***"+                              , "*** (SBV firstifies higher-order functions via a simple translation to make it fit with"+                              , "*** SMTLib's first-order logic. This translation does not currently support free"+                              , "*** variables. In technical terms, we would need to do closure conversion and lambda-lifting."+                              , "*** SBV isn't capable of doing the closure-conversion part, relying on the user to do so.)"+                              , "***"+                              , "*** Please rewrite your program to create a closure and use that as an argument."+                              , "*** If this solution isn't applicable, or if you'd like help doing so, please get in"+                              , "*** touch for further possible enhancements."+                              ]          sh (Defn _unints _frees Nothing       body) = body 0         sh (Defn _unints _frees (Just params) body) = "(lambda " ++ extractAllUniversals params ++ "\n" ++ body 2 ++ ")"@@ -178,7 +189,7 @@ -- | Create an SMTLib lambda, in the given state. lambda :: (MonadIO m, Lambda (SymbolicT m) a) => State -> LambdaScope -> Kind -> a -> m SMTDef lambda inState scope fk = lambdaGen scope mkLam inState fk-   where mkLam (Defn unints _frees params body) = SMTLam fk unints (extractAllUniversals <$> params) body+   where mkLam (Defn unints _frees params body) = SMTDef fk unints (extractAllUniversals <$> params) body  -- | Create an anonymous lambda, rendered as n SMTLib string. The kind passed is the kind of the final result. lambdaStr :: (MonadIO m, Lambda (SymbolicT m) a) => State -> LambdaScope -> Kind -> a -> m SMTLambda@@ -186,23 +197,6 @@    where mkLam (Defn _unints _frees Nothing       body) = body 0          mkLam (Defn _unints _frees (Just params) body) = "(lambda " ++ extractAllUniversals params ++ "\n" ++ body 2 ++ ")" --- | Generaic creator for named functions,-namedLambdaGen :: (MonadIO m, Lambda (SymbolicT m) a) => LambdaScope -> (Defn -> b) -> State -> Kind -> a -> m b-namedLambdaGen scope trans inState fk f = inSubState scope inState $ \st -> trans <$> convert st fk (mkLambda st f)---- | Create a named SMTLib function, in the given state.-namedLambda :: (MonadIO m, Lambda (SymbolicT m) a) => LambdaScope -> State -> String -> Kind -> a -> m SMTDef-namedLambda scope inState nm fk = namedLambdaGen scope mkDef inState fk-   where mkDef (Defn unints _frees params body) = SMTDef nm fk unints (extractAllUniversals <$> params) body---- | Create a named SMTLib function, in the given state, string version-namedLambdaStr :: (MonadIO m, Lambda (SymbolicT m) a) => LambdaScope -> State -> String -> SBVType -> a -> m String-namedLambdaStr scope inState nm t = namedLambdaGen scope mkDef inState fk-   where mkDef (Defn unints _frees params body) = concat $ declUserFuns [(SMTDef nm fk unints (extractAllUniversals <$> params) body, t)]-         fk = case t of-                SBVType [] -> error $ "namedLambdaStr: Invalid type for " ++ show nm ++ ", empty!"-                SBVType xs -> last xs- -- | Generic constraint generator. constraintGen :: (MonadIO m, Constraint (SymbolicT m) a) => LambdaScope -> ([String] -> (Int -> String) -> b) -> State -> a -> m b constraintGen scope trans inState@State{rProgInfo} f = do@@ -324,10 +318,16 @@                                                   ]                           ResultLamInps xs -> map (\(q, v) -> (q, getSV v)) xs -               frees = map show $ nub allUses \\ nub allDefs+               frees = map show badFrees                  where (defs, uses) = unzip [(d, u) | (d, SBVApp _ u) <- F.toList asgnsSeq]                        allDefs      = defs ++ map snd params ++ map fst constants                        allUses      = concat uses+                       allFrees     = nub allUses \\ nub allDefs+                       badFrees     = filter (not . global . getId . swNodeId) allFrees++                       -- is this a global?+                       global (_, Just 0, _) = True+                       global (_, _     , n) = n < 0  -- -1/-2 for false true                 mbParam                  | null params = Nothing
Data/SBV/List.hs view
@@ -10,707 +10,1366 @@ -- A collection of list utilities, useful when working with symbolic lists. -- To the extent possible, the functions in this module follow those of "Data.List" -- so importing qualified is the recommended workflow. Also, it is recommended--- you use the @OverloadedLists@ extension to allow literal lists to--- be used as symbolic-lists.--------------------------------------------------------------------------------{-# LANGUAGE CPP                 #-}-{-# LANGUAGE OverloadedLists     #-}-{-# LANGUAGE Rank2Types          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.List (-        -- * Length, emptiness-          length, null-        -- * Deconstructing/Reconstructing-        , head, tail, uncons, init, singleton, listToListAt, elemAt, (!!), implode, concat, (.:), snoc, nil, (++)-        -- * Containment-        , elem, notElem, isInfixOf, isSuffixOf, isPrefixOf-        -- * Sublists-        , take, drop, splitAt, subList, replace, indexOf, offsetIndexOf-        -- * Reverse-        , reverse-        -- * Mapping-        , map, concatMap-        -- * Folding-        , foldl, foldr-        -- * Zipping-        , zip, zipWith-        -- * Filtering-        , filter, partition-        -- * Other list functions-        , all, any, and, or-        ) where--import Prelude hiding (head, tail, init, length, take, drop, splitAt, concat, null, elem,-                       notElem, reverse, (++), (!!), map, concatMap, foldl, foldr, zip, zipWith, filter,-                       all, any, and, or)-import qualified Prelude as P--import Data.SBV.Core.Kind-import Data.SBV.Core.Data hiding (StrOp(..))-import Data.SBV.Core.Model-import Data.SBV.Core.Symbolic (registerSpecialFunction)--import Data.SBV.Lambda--import Data.SBV.Tuple hiding (fst, snd)--import Data.Maybe (isNothing, catMaybes)--import Data.List (genericLength, genericIndex, genericDrop, genericTake)-import qualified Data.List as L (tails, isSuffixOf, isPrefixOf, isInfixOf, partition)--import Data.Proxy--#ifdef DOCTEST--- $setup--- >>> import Prelude hiding (head, tail, init, length, take, drop, concat, null, elem, notElem, reverse, (++), (!!), map, foldl, foldr, zip, zipWith, filter, all, any)--- >>> import qualified Prelude as P(map)--- >>> import Data.SBV--- >>> :set -XDataKinds--- >>> :set -XOverloadedLists--- >>> :set -XScopedTypeVariables-#endif---- | Length of a list.------ >>> sat $ \(l :: SList Word16) -> length l .== 2--- Satisfiable. Model:---   s0 = [0,0] :: [Word16]--- >>> sat $ \(l :: SList Word16) -> length l .< 0--- Unsatisfiable--- >>> prove $ \(l1 :: SList Word16) (l2 :: SList Word16) -> length l1 + length l2 .== length (l1 ++ l2)--- Q.E.D.-length :: SymVal a => SList a -> SInteger-length = lift1 False SeqLen (Just (fromIntegral . P.length))---- | @`null` s@ is True iff the list is empty------ >>> prove $ \(l :: SList Word16) -> null l .<=> length l .== 0--- Q.E.D.--- >>> prove $ \(l :: SList Word16) -> null l .<=> l .== []--- Q.E.D.-null :: SymVal a => SList a -> SBool-null l-  | Just cs <- unliteral l-  = literal (P.null cs)-  | True-  = length l .== 0---- | @`head`@ returns the first element of a list. Unspecified if the list is empty.------ >>> prove $ \c -> head (singleton c) .== (c :: SInteger)--- Q.E.D.-head :: SymVal a => SList a -> SBV a-head = (`elemAt` 0)---- | @`tail`@ returns the tail of a list. Unspecified if the list is empty.------ >>> prove $ \(h :: SInteger) t -> tail (singleton h ++ t) .== t--- Q.E.D.--- >>> prove $ \(l :: SList Integer) -> length l .> 0 .=> length (tail l) .== length l - 1--- Q.E.D.--- >>> prove $ \(l :: SList Integer) -> sNot (null l) .=> singleton (head l) ++ tail l .== l--- Q.E.D.-tail :: SymVal a => SList a -> SList a-tail l- | Just (_:cs) <- unliteral l- = literal cs- | True- = subList l 1 (length l - 1)---- | @`uncons`@ returns the pair of the head and tail. Unspecified if the list is empty.-uncons :: SymVal a => SList a -> (SBV a, SList a)-uncons l = (head l, tail l)---- | @`init`@ returns all but the last element of the list. Unspecified if the list is empty.------ >>> prove $ \(h :: SInteger) t -> init (t ++ singleton h) .== t--- Q.E.D.-init :: SymVal a => SList a -> SList a-init l- | Just cs@(_:_) <- unliteral l- = literal $ P.init cs- | True- = subList l 0 (length l - 1)---- | @`singleton` x@ is the list of length 1 that contains the only value @x@.------ >>> prove $ \(x :: SInteger) -> head (singleton x) .== x--- Q.E.D.--- >>> prove $ \(x :: SInteger) -> length (singleton x) .== 1--- Q.E.D.-singleton :: SymVal a => SBV a -> SList a-singleton = lift1 False SeqUnit (Just (: []))---- | @`listToListAt` l offset@. List of length 1 at @offset@ in @l@. Unspecified if--- index is out of bounds.------ >>> prove $ \(l1 :: SList Integer) l2 -> listToListAt (l1 ++ l2) (length l1) .== listToListAt l2 0--- Q.E.D.--- >>> sat $ \(l :: SList Word16) -> length l .>= 2 .&& listToListAt l 0 ./= listToListAt l (length l - 1)--- Satisfiable. Model:---   s0 = [0,64] :: [Word16]-listToListAt :: SymVal a => SList a -> SInteger -> SList a-listToListAt s offset = subList s offset 1---- | @`elemAt` l i@ is the value stored at location @i@, starting at 0. Unspecified if--- index is out of bounds.------ >>> prove $ \i -> i `inRange` (0, 4) .=> [1,1,1,1,1] `elemAt` i .== (1::SInteger)--- Q.E.D.-elemAt :: SymVal a => SList a -> SInteger -> SBV a-elemAt l i-  | Just xs <- unliteral l, Just ci <- unliteral i, ci >= 0, ci < genericLength xs, let x = xs `genericIndex` ci-  = literal x-  | True-  = lift2 False SeqNth Nothing l i---- | Short cut for 'elemAt'-(!!) :: SymVal a => SList a -> SInteger -> SBV a-(!!) = elemAt---- | @`implode` es@ is the list of length @|es|@ containing precisely those--- elements. Note that there is no corresponding function @explode@, since--- we wouldn't know the length of a symbolic list.------ >>> prove $ \(e1 :: SInteger) e2 e3 -> length (implode [e1, e2, e3]) .== 3--- Q.E.D.--- >>> prove $ \(e1 :: SInteger) e2 e3 -> P.map (elemAt (implode [e1, e2, e3])) (P.map literal [0 .. 2]) .== [e1, e2, e3]--- Q.E.D.-implode :: SymVal a => [SBV a] -> SList a-implode = P.foldr ((++) . singleton) (literal [])---- | Prepend an element, the traditional @cons@.-infixr 5 .:-(.:) :: SymVal a => SBV a -> SList a -> SList a-a .: as = singleton a ++ as---- | Append an element-snoc :: SymVal a => SList a -> SBV a -> SList a-as `snoc` a = as ++ singleton a---- | Empty list. This value has the property that it's the only list with length 0:------ >>> prove $ \(l :: SList Integer) -> length l .== 0 .<=> l .== nil--- Q.E.D.-nil :: SymVal a => SList a-nil = []---- | Append two lists.------ >>> sat $ \x y z -> length x .== 5 .&& length y .== 1 .&& x ++ y ++ z .== [1 .. 12]--- Satisfiable. Model:---   s0 =      [1,2,3,4,5] :: [Integer]---   s1 =              [6] :: [Integer]---   s2 = [7,8,9,10,11,12] :: [Integer]-infixr 5 ++-(++) :: SymVal a => SList a -> SList a -> SList a-x ++ y | isConcretelyEmpty x = y-       | isConcretelyEmpty y = x-       | True                = lift2 False SeqConcat (Just (P.++)) x y---- | @`elem` e l@. Does @l@ contain the element @e@?-elem :: (Eq a, SymVal a) => SBV a -> SList a -> SBool-e `elem` l = singleton e `isInfixOf` l---- | @`notElem` e l@. Does @l@ not contain the element @e@?-notElem :: (Eq a, SymVal a) => SBV a -> SList a -> SBool-e `notElem` l = sNot (e `elem` l)---- | @`isInfixOf` sub l@. Does @l@ contain the subsequence @sub@?------ >>> prove $ \(l1 :: SList Integer) l2 l3 -> l2 `isInfixOf` (l1 ++ l2 ++ l3)--- Q.E.D.--- >>> prove $ \(l1 :: SList Integer) l2 -> l1 `isInfixOf` l2 .&& l2 `isInfixOf` l1 .<=> l1 .== l2--- Q.E.D.-isInfixOf :: (Eq a, SymVal a) => SList a -> SList a -> SBool-sub `isInfixOf` l-  | isConcretelyEmpty sub-  = literal True-  | True-  = lift2 True SeqContains (Just (flip L.isInfixOf)) l sub -- NB. flip, since `SeqContains` takes args in rev order!---- | @`isPrefixOf` pre l@. Is @pre@ a prefix of @l@?------ >>> prove $ \(l1 :: SList Integer) l2 -> l1 `isPrefixOf` (l1 ++ l2)--- Q.E.D.--- >>> prove $ \(l1 :: SList Integer) l2 -> l1 `isPrefixOf` l2 .=> subList l2 0 (length l1) .== l1--- Q.E.D.-isPrefixOf :: (Eq a, SymVal a) => SList a -> SList a -> SBool-pre `isPrefixOf` l-  | isConcretelyEmpty pre-  = literal True-  | True-  = lift2 True SeqPrefixOf (Just L.isPrefixOf) pre l---- | @`isSuffixOf` suf l@. Is @suf@ a suffix of @l@?------ >>> prove $ \(l1 :: SList Word16) l2 -> l2 `isSuffixOf` (l1 ++ l2)--- Q.E.D.--- >>> prove $ \(l1 :: SList Word16) l2 -> l1 `isSuffixOf` l2 .=> subList l2 (length l2 - length l1) (length l1) .== l1--- Q.E.D.-isSuffixOf :: (Eq a, SymVal a) => SList a -> SList a -> SBool-suf `isSuffixOf` l-  | isConcretelyEmpty suf-  = literal True-  | True-  = lift2 True SeqSuffixOf (Just L.isSuffixOf) suf l---- | @`take` len l@. Corresponds to Haskell's `take` on symbolic lists.------ >>> prove $ \(l :: SList Integer) i -> i .>= 0 .=> length (take i l) .<= i--- Q.E.D.-take :: SymVal a => SInteger -> SList a -> SList a-take i l = ite (i .<= 0)        (literal [])-         $ ite (i .>= length l) l-         $ subList l 0 i---- | @`drop` len s@. Corresponds to Haskell's `drop` on symbolic-lists.------ >>> prove $ \(l :: SList Word16) i -> length (drop i l) .<= length l--- Q.E.D.--- >>> prove $ \(l :: SList Word16) i -> take i l ++ drop i l .== l--- Q.E.D.-drop :: SymVal a => SInteger -> SList a -> SList a-drop i s = ite (i .>= ls) (literal [])-         $ ite (i .<= 0)  s-         $ subList s i (ls - i)-  where ls = length s---- | @splitAt n xs = (take n xs, drop n xs)@-splitAt :: SymVal a => SInteger -> SList a -> (SList a, SList a)-splitAt n xs = (take n xs, drop n xs)---- | @`subList` s offset len@ is the sublist of @s@ at offset @offset@ with length @len@.--- This function is under-specified when the offset is outside the range of positions in @s@ or @len@--- is negative or @offset+len@ exceeds the length of @s@.------ >>> prove $ \(l :: SList Integer) i -> i .>= 0 .&& i .< length l .=> subList l 0 i ++ subList l i (length l - i) .== l--- Q.E.D.--- >>> sat  $ \i j -> subList [1..5] i j .== ([2..4] :: SList Integer)--- Satisfiable. Model:---   s0 = 1 :: Integer---   s1 = 3 :: Integer--- >>> sat  $ \i j -> subList [1..5] i j .== ([6..7] :: SList Integer)--- Unsatisfiable-subList :: SymVal a => SList a -> SInteger -> SInteger -> SList a-subList l offset len-  | Just c  <- unliteral l                   -- a constant list-  , Just o  <- unliteral offset              -- a constant offset-  , Just sz <- unliteral len                 -- a constant length-  , let lc = genericLength c                 -- length of the list-  , let valid x = x >= 0 && x <= lc          -- predicate that checks valid point-  , valid o                                  -- offset is valid-  , sz >= 0                                  -- length is not-negative-  , valid $ o + sz                           -- we don't overrun-  = literal $ genericTake sz $ genericDrop o c-  | True                                     -- either symbolic, or something is out-of-bounds-  = lift3 False SeqSubseq Nothing l offset len---- | @`replace` l src dst@. Replace the first occurrence of @src@ by @dst@ in @s@------ >>> prove $ \l -> replace [1..5] l [6..10] .== [6..10] .=> l .== ([1..5] :: SList Word8)--- Q.E.D.--- >>> prove $ \(l1 :: SList Integer) l2 l3 -> length l2 .> length l1 .=> replace l1 l2 l3 .== l1--- Q.E.D.-replace :: forall a. (Eq a, SymVal a) => SList a -> SList a -> SList a -> SList a-replace l src dst-  | Just b <- unliteral src, P.null b   -- If src is null, simply prepend-  = dst ++ l-  | eqCheckIsObjectEq ka-  , Just a <- unliteral l-  , Just b <- unliteral src-  , Just c <- unliteral dst-  = literal $ walk a b c-  | True-  = lift3 True SeqReplace Nothing l src dst-  where walk haystack needle newNeedle = go haystack   -- note that needle is guaranteed non-empty here.-           where go []       = []-                 go i@(c:cs)-                  | needle `L.isPrefixOf` i = newNeedle P.++ genericDrop (genericLength needle :: Integer) i-                  | True                    = c : go cs--        ka = kindOf (Proxy @a)---- | @`indexOf` l sub@. Retrieves first position of @sub@ in @l@, @-1@ if there are no occurrences.--- Equivalent to @`offsetIndexOf` l sub 0@.------ >>> prove $ \(l1 :: SList Word16) l2 -> length l2 .> length l1 .=> indexOf l1 l2 .== -1--- Q.E.D.-indexOf :: (Eq a, SymVal a) => SList a -> SList a -> SInteger-indexOf s sub = offsetIndexOf s sub 0---- | @`offsetIndexOf` l sub offset@. Retrieves first position of @sub@ at or--- after @offset@ in @l@, @-1@ if there are no occurrences.------ >>> prove $ \(l :: SList Int8) sub -> offsetIndexOf l sub 0 .== indexOf l sub--- Q.E.D.--- >>> prove $ \(l :: SList Int8) sub i -> i .>= length l .&& length sub .> 0 .=> offsetIndexOf l sub i .== -1--- Q.E.D.--- >>> prove $ \(l :: SList Int8) sub i -> i .> length l .=> offsetIndexOf l sub i .== -1--- Q.E.D.-offsetIndexOf :: forall a. (Eq a, SymVal a) => SList a -> SList a -> SInteger -> SInteger-offsetIndexOf s sub offset-  | eqCheckIsObjectEq ka-  , Just c <- unliteral s        -- a constant list-  , Just n <- unliteral sub      -- a constant search pattern-  , Just o <- unliteral offset   -- at a constant offset-  , o >= 0, o <= genericLength c        -- offset is good-  = case [i | (i, t) <- P.zip [o ..] (L.tails (genericDrop o c)), n `L.isPrefixOf` t] of-      (i:_) -> literal i-      _     -> -1-  | True-  = lift3 True SeqIndexOf Nothing s sub offset-  where ka = kindOf (Proxy @a)---- | @`reverse` s@ reverses the sequence.------ NB. We can define @reverse@ in terms of @foldl@ as: @foldl (\soFar elt -> singleton elt ++ soFar) []@--- But in my experiments, I found that this definition performs worse instead of the recursive definition--- SBV generates for reverse calls. So we're keeping it intact.------ >>> sat $ \(l :: SList Integer) -> reverse l .== literal [3, 2, 1]--- Satisfiable. Model:---   s0 = [1,2,3] :: [Integer]--- >>> prove $ \(l :: SList Word32) -> reverse l .== [] .<=> null l--- Q.E.D.-reverse :: SymVal a => SList a -> SList a-reverse l-  | Just l' <- unliteral l-  = literal (P.reverse l')-  | True-  = SBV $ SVal k $ Right $ cache r-  where k = kindOf l-        r st = do sva <- sbvToSV st l-                  let op = SeqOp (SBVReverse k)-                  registerSpecialFunction st op-                  newExpr st k (SBVApp op [sva])---- | @`map` f s@ maps the operation on to sequence.------ >>> map (+1) [1 .. 5 :: Integer]--- [2,3,4,5,6] :: [SInteger]--- >>> map (+1) [1 .. 5 :: WordN 8]--- [2,3,4,5,6] :: [SWord8]--- >>> map singleton [1 .. 3 :: Integer]--- [[1],[2],[3]] :: [[SInteger]]--- >>> import Data.SBV.Tuple--- >>> import GHC.Exts (fromList)--- >>> map (\t -> t^._1 + t^._2) (fromList [(x, y) | x <- [1..3], y <- [4..6]] :: SList (Integer, Integer))--- [5,6,7,6,7,8,7,8,9] :: [SInteger]------ Of course, SBV's 'map' can also be reused in reverse:------ >>> sat $ \l -> map (+1) l .== [1,2,3 :: Integer]--- Satisfiable. Model:---   s0 = [0,1,2] :: [Integer]-map :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> SList a -> SList b-map f l-  | Just l' <- unliteral l, Just concResult <- concreteMap l'-  = literal concResult-  | True-  = SBV $ SVal klb $ Right $ cache r-  where concreteMap l' = case P.map (unliteral . f . literal) l' of-                           xs | P.any isNothing xs -> Nothing-                              | True               -> Just (catMaybes xs)--        ka  = kindOf (Proxy @a)-        kb  = kindOf (Proxy @b)-        klb = kindOf (Proxy @(SList b))-        r st = do sva <- sbvToSV st l-                  lam <- lambdaStr st HigherOrderArg kb f-                  let op = SeqOp (SBVMap ka kb lam)-                  registerSpecialFunction st op-                  newExpr st klb (SBVApp op [sva])---- | @concatMap f xs@ maps f over elements and concats the result.-concatMap :: (SymVal a, SymVal b) => (SBV a -> SList b) -> SList a -> SList b-concatMap f xs = concat (map f xs)---- | @`foldl` f base s@ folds the from the left.------ >>> foldl (+) 0 [1 .. 5 :: Integer]--- 15 :: SInteger--- >>> foldl (*) 1 [1 .. 5 :: Integer]--- 120 :: SInteger--- >>> foldl (\soFar elt -> singleton elt ++ soFar) ([] :: SList Integer) [1 .. 5 :: Integer]--- [5,4,3,2,1] :: [SInteger]------ Again, we can use 'Data.SBV.List.foldl' in the reverse too:------ >>> sat $ \l -> foldl (\soFar elt -> singleton elt ++ soFar) ([] :: SList Integer) l .== [5, 4, 3, 2, 1 :: Integer]--- Satisfiable. Model:---   s0 = [1,2,3,4,5] :: [Integer]-foldl :: forall a b. (SymVal a, SymVal b) => (SBV b -> SBV a -> SBV b) -> SBV b -> SList a -> SBV b-foldl f base l-  | Just l' <- unliteral l, Just base' <- unliteral base, Just concResult <- concreteFoldl base' l'-  = literal concResult-  | True-  = SBV $ SVal kb $ Right $ cache r-  where concreteFoldl b []     = Just b-        concreteFoldl b (e:es) = case unliteral (literal b `f` literal e) of-                                   Nothing -> Nothing-                                   Just b' -> concreteFoldl b' es--        ka = kindOf (Proxy @a)-        kb = kindOf (Proxy @b)-        r st = do svb <- sbvToSV st base-                  svl <- sbvToSV st l-                  lam <- lambdaStr st HigherOrderArg kb f-                  let op = SeqOp (SBVFoldl ka kb lam)-                  registerSpecialFunction st op-                  newExpr st kb (SBVApp op [svb, svl])---- | @`foldr` f base s@ folds the sequence from the right.------ >>> foldr (+) 0 [1 .. 5 :: Integer]--- 15 :: SInteger--- >>> foldr (*) 1 [1 .. 5 :: Integer]--- 120 :: SInteger--- >>> foldr (\elt soFar -> soFar ++ singleton elt) ([] :: SList Integer) [1 .. 5 :: Integer]--- [5,4,3,2,1] :: [SInteger]-foldr :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b -> SBV b) -> SBV b -> SList a -> SBV b-foldr f base l-  | Just l' <- unliteral l, Just base' <- unliteral base, Just concResult <- concreteFoldr base' l'-  = literal concResult-  | True-  = SBV $ SVal kb $ Right $ cache r-  where concreteFoldr b []     = Just b-        concreteFoldr b (e:es) = case concreteFoldr b es of-                                   Nothing  -> Nothing-                                   Just res -> unliteral (literal e `f` literal res)--        ka = kindOf (Proxy @a)-        kb = kindOf (Proxy @b)-        r st = do svb <- sbvToSV st base-                  svl <- sbvToSV st l-                  lam <- lambdaStr st HigherOrderArg kb f-                  let op = SeqOp (SBVFoldr ka kb lam)-                  registerSpecialFunction st op-                  newExpr st kb (SBVApp op [svb, svl])---- | @`zip` xs ys@ zips the lists to give a list of pairs. The length of the final list is--- the minumum of the lengths of the given lists.------ >>> zip [1..10::Integer] [11..20::Integer]--- [(1,11),(2,12),(3,13),(4,14),(5,15),(6,16),(7,17),(8,18),(9,19),(10,20)] :: [(SInteger, SInteger)]--- >>> import Data.SBV.Tuple--- >>> foldr (+) 0 (map (\t -> t^._1+t^._2::SInteger) (zip [1..10::Integer] [10, 9..1::Integer]))--- 110 :: SInteger-zip :: forall a b. (SymVal a, SymVal b) => SList a -> SList b -> SList (a, b)-zip xs ys- | Just xs' <- unliteral xs, Just ys' <- unliteral ys- = literal $ P.zip xs' ys'- | True- = SBV $ SVal kr $ Right $ cache r- where ka = kindOf (Proxy @a)-       kb = kindOf (Proxy @b)-       kr = KList $ KTuple [ka, kb]--       r st = do svxs <- sbvToSV st xs-                 svys <- sbvToSV st ys-                 let op = SeqOp (SBVZip ka kb)-                 registerSpecialFunction st op-                 newExpr st kr (SBVApp op [svxs, svys])---- | @`zipWith` f xs ys@ zips the lists to give a list of pairs, applying the function to each pair of elements.--- The length of the final list is the minumum of the lengths of the given lists.------ >>> zipWith (+) [1..10::Integer] [11..20::Integer]--- [12,14,16,18,20,22,24,26,28,30] :: [SInteger]--- >>> foldr (+) 0 (zipWith (+) [1..10::Integer] [10, 9..1::Integer])--- 110 :: SInteger-zipWith :: forall a b c. (SymVal a, SymVal b, SymVal c) => (SBV a -> SBV b -> SBV c) -> SList a -> SList b -> SList c-zipWith f xs ys- | Just xs' <- unliteral xs, Just ys' <- unliteral ys, Just concResult <- concreteZipWith xs' ys'- = literal concResult- | True- = SBV $ SVal kr $ Right $ cache r- where concreteZipWith []     _      = Just []-       concreteZipWith _      []     = Just []-       concreteZipWith (a:as) (b:bs) = (:) <$> unliteral (literal a `f` literal b) <*> concreteZipWith as bs--       ka = kindOf (Proxy @a)-       kb = kindOf (Proxy @b)-       kc = kindOf (Proxy @c)-       kr = KList kc--       r st = do svxs <- sbvToSV st xs-                 svys <- sbvToSV st ys-                 lam <- lambdaStr st HigherOrderArg kc f-                 let op = SeqOp (SBVZipWith ka kb kc lam)-                 registerSpecialFunction st op-                 newExpr st kr (SBVApp op [svxs, svys])---- | Concatenate list of lists.------ >>> concat [[1..3::Integer], [4..7], [8..10]]--- [1,2,3,4,5,6,7,8,9,10] :: [SInteger]-concat :: forall a. SymVal a => SList [a] -> SList a-concat l-  | Just l' <- unliteral l-  = literal (P.concat l')-  | True-  = SBV $ SVal kla $ Right $ cache r-  where ka   = kindOf (Proxy @a)-        kla  = kindOf (Proxy @[a])--        r st = do sva <- sbvToSV st l-                  let op = SeqOp (SBVConcat ka)-                  registerSpecialFunction st op-                  newExpr st kla (SBVApp op [sva])---- | Check all elements satisfy the predicate.------ >>> let isEven x = x `sMod` 2 .== 0--- >>> all isEven [2, 4, 6, 8, 10 :: Integer]--- True--- >>> all isEven [2, 4, 6, 1, 8, 10 :: Integer]--- False-all :: forall a. SymVal a => (SBV a -> SBool) -> SList a -> SBool-all f l- | Just l' <- unliteral l- = sAll f (P.map literal l')- | True- = SBV $ SVal KBool $ Right $ cache r- where r st = do sva <- sbvToSV st l-                 lam <- lambdaStr st HigherOrderArg KBool f-                 let op = SeqOp (SBVAll (kindOf (Proxy @a)) lam)-                 registerSpecialFunction st op-                 newExpr st KBool (SBVApp op [sva])---- | Check some element satisfies the predicate.--- ----- >>> let isEven x = x `sMod` 2 .== 0--- >>> any (sNot . isEven) [2, 4, 6, 8, 10 :: Integer]--- False--- >>> any isEven [2, 4, 6, 1, 8, 10 :: Integer]--- True-any :: forall a. SymVal a => (SBV a -> SBool) -> SList a -> SBool-any f l- | Just l' <- unliteral l- = sAny f (P.map literal l')- | True- = SBV $ SVal KBool $ Right $ cache r- where r st = do sva <- sbvToSV st l-                 lam <- lambdaStr st HigherOrderArg KBool f-                 let op = SeqOp (SBVAny (kindOf (Proxy @a)) lam)-                 registerSpecialFunction st op-                 newExpr st KBool (SBVApp op [sva])---- | Conjunction of all the elements.-and :: SList Bool -> SBool-and = all id---- | Disjunction of all the elements.-or :: SList Bool -> SBool-or = any id---- | @filter f xs@ filters the list with the given predicate.------ >>> filter (\x -> x `sMod` 2 .== 0) [1 .. 10 :: Integer]--- [2,4,6,8,10] :: [SInteger]--- >>> filter (\x -> x `sMod` 2 ./= 0) [1 .. 10 :: Integer]--- [1,3,5,7,9] :: [SInteger]-filter :: forall a. SymVal a => (SBV a -> SBool) -> SList a -> SList a-filter f l-  | Just l' <- unliteral l, Just concResult <- concreteFilter l'-  = literal concResult-  | True-  = SBV $ SVal k $ Right $ cache r-  where concreteFilter l' = case P.map (unliteral . f . literal) l' of-                              xs | P.any isNothing xs -> Nothing-                                 | True               -> Just [e | (True, e) <- P.zip (catMaybes xs) l']--        k = kindOf (Proxy @(SList a))-        r st = do sva <- sbvToSV st l-                  lam <- lambdaStr st HigherOrderArg KBool f-                  let op = SeqOp (SBVFilter (kindOf (Proxy @a)) lam)-                  registerSpecialFunction st op-                  newExpr st k (SBVApp op [sva])---- | @partition f xs@ splits the list into two and returns those that satisfy the predicate in the--- first element, and those that don't in the second.-partition :: forall a. SymVal a => (SBV a -> SBool) -> SList a -> STuple [a] [a]-partition f l-  | Just l' <- unliteral l, Just concResult <- concretePartition l'-  = concResult-  | True-  = SBV $ SVal k $ Right $ cache r-  where concretePartition l' = case P.map (unliteral . f . literal) l' of-                                 xs | P.any isNothing xs -> Nothing-                                    | True               -> let (ts, fs) = L.partition fst (P.zip (catMaybes xs) l')-                                                            in Just $ tuple (literal (P.map snd ts), literal (P.map snd fs))---        k = kindOf (Proxy @(STuple [a] [a]))--        r st = do sva <- sbvToSV st l-                  lam <- lambdaStr st HigherOrderArg KBool f-                  let op = SeqOp (SBVPartition (kindOf (Proxy @a)) lam)-                  registerSpecialFunction st op-                  newExpr st k (SBVApp op [sva])---- | Lift a unary operator over lists.-lift1 :: forall a b. (SymVal a, SymVal b) => Bool -> SeqOp -> Maybe (a -> b) -> SBV a -> SBV b-lift1 simpleEq w mbOp a-  | Just cv <- concEval1 simpleEq mbOp a-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where k = kindOf (Proxy @b)-        r st = do sva <- sbvToSV st a-                  newExpr st k (SBVApp (SeqOp w) [sva])---- | Lift a binary operator over lists.-lift2 :: forall a b c. (SymVal a, SymVal b, SymVal c) => Bool -> SeqOp -> Maybe (a -> b -> c) -> SBV a -> SBV b -> SBV c-lift2 simpleEq w mbOp a b-  | Just cv <- concEval2 simpleEq mbOp a b-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where k = kindOf (Proxy @c)-        r st = do sva <- sbvToSV st a-                  svb <- sbvToSV st b-                  newExpr st k (SBVApp (SeqOp w) [sva, svb])---- | Lift a ternary operator over lists.-lift3 :: forall a b c d. (SymVal a, SymVal b, SymVal c, SymVal d) => Bool -> SeqOp -> Maybe (a -> b -> c -> d) -> SBV a -> SBV b -> SBV c -> SBV d-lift3 simpleEq w mbOp a b c-  | Just cv <- concEval3 simpleEq mbOp a b c-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where k = kindOf (Proxy @d)-        r st = do sva <- sbvToSV st a-                  svb <- sbvToSV st b-                  svc <- sbvToSV st c-                  newExpr st k (SBVApp (SeqOp w) [sva, svb, svc])---- | Concrete evaluation for unary ops-concEval1 :: forall a b. (SymVal a, SymVal b) => Bool -> Maybe (a -> b) -> SBV a -> Maybe (SBV b)-concEval1 simpleEq mbOp a-  | not simpleEq || eqCheckIsObjectEq (kindOf (Proxy @a)) = literal <$> (mbOp <*> unliteral a)-  | True                                                  = Nothing---- | Concrete evaluation for binary ops-concEval2 :: forall a b c. (SymVal a, SymVal b, SymVal c) => Bool -> Maybe (a -> b -> c) -> SBV a -> SBV b -> Maybe (SBV c)-concEval2 simpleEq mbOp a b-  | not simpleEq || eqCheckIsObjectEq (kindOf (Proxy @a)) = literal <$> (mbOp <*> unliteral a <*> unliteral b)-  | True                                                  = Nothing---- | Concrete evaluation for ternary ops-concEval3 :: forall a b c d. (SymVal a, SymVal b, SymVal c, SymVal d) => Bool -> Maybe (a -> b -> c -> d) -> SBV a -> SBV b -> SBV c -> Maybe (SBV d)-concEval3 simpleEq mbOp a b c-  | not simpleEq || eqCheckIsObjectEq (kindOf (Proxy @a)) = literal <$> (mbOp <*> unliteral a <*> unliteral b <*> unliteral c)-  | True                                                  = Nothing---- | Is the list concretely known empty?-isConcretelyEmpty :: SymVal a => SList a -> Bool-isConcretelyEmpty sl | Just l <- unliteral sl = P.null l-                     | True                   = False+-- you use the @OverloadedLists@ and @OverloadedStrings@ extensions to allow literal+-- lists and strings to be used as symbolic literals.+--+-- You can find proofs of many list related properties in "Data.SBV.TP.List".+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                    #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NamedFieldPuns         #-}+{-# LANGUAGE OverloadedLists        #-}+{-# LANGUAGE Rank2Types             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE UndecidableInstances   #-}++{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}++module Data.SBV.List (+        -- * Length, emptiness+          length, null++        -- * Deconstructing/Reconstructing+        , nil, (.:), snoc, head, tail, uncons, init, last, singleton, listToListAt, elemAt, (!!), implode, concat, (++)++        -- * Containment+        , elem, notElem, isInfixOf, isSuffixOf, isPrefixOf++        -- * Sublists+        , take, drop, splitAt, subList, replace, indexOf, offsetIndexOf++        -- * Reverse+        , reverse++        -- * Mapping+        , map, concatMap++        -- * Difference+        , (\\)++        -- * Folding+        , foldl, foldr++        -- * Zipping+        , zip, zipWith++        -- * Lookup+        , lookup++        -- * Filtering+        , filter, partition, takeWhile, dropWhile++        -- * Predicate transformers+        , all, any, and, or++        -- * Generators+        , replicate, inits, tails++        -- * Sum and product+        , sum, product++        -- * Conversion between strings and naturals+        , strToNat, natToStr++        -- * Symbolic enumerations+        , EnumSymbolic(..)+        ) where++import Prelude hiding (head, tail, init, last, length, take, drop, splitAt, concat, null, elem,+                       notElem, reverse, (++), (!!), map, concatMap, foldl, foldr, zip, zipWith, filter,+                       all, any, and, or, replicate, fst, snd, sum, product, Enum(..), lookup,+                       takeWhile, dropWhile)+import qualified Prelude as P++import Data.SBV.Core.Kind+import Data.SBV.Core.Data+import Data.SBV.Core.Model+import Data.SBV.Core.SizedFloats+import Data.SBV.Core.Floating++import Data.SBV.Tuple++import Data.Maybe (isNothing, catMaybes)+import qualified Data.Char as C++import Data.List (genericLength, genericIndex, genericDrop, genericTake, genericReplicate)+import qualified Data.List as L (inits, tails, isSuffixOf, isPrefixOf, isInfixOf, partition, (\\))++import Data.Proxy++import GHC.Exts (IsList(..))++#ifdef DOCTEST+-- $setup+-- >>> import Prelude hiding (head, tail, init, last, length, take, drop, concat, null, elem, notElem, reverse, (++), (!!), map, foldl, foldr, zip, zipWith, filter, all, any, replicate, lookup, splitAt, concatMap, and, or, sum, product, takeWhile, dropWhile)+-- >>> import qualified Prelude as P(map)+-- >>> import Data.SBV+-- >>> :set -XDataKinds+-- >>> :set -XOverloadedLists+-- >>> :set -XOverloadedStrings+-- >>> :set -XScopedTypeVariables+-- >>> :set -XTypeApplications+-- >>> :set -XQuasiQuotes+#endif++-- | IsList instance allows list literals to be written compactly.+instance SymVal a => IsList (SList a) where+  type Item (SList a) = SBV a++  fromList = P.foldr (.:) nil -- Don't use [] here for nil, as this is the very definition of doing overloaded lists+  toList x = case unliteral x of+               Nothing -> error "IsList.toList used in a symbolic context"+               Just xs -> P.map literal xs++-- | Length of a list.+--+-- >>> sat $ \(l :: SList Word16) -> length l .== 2+-- Satisfiable. Model:+--   s0 = [0,0] :: [Word16]+-- >>> sat $ \(l :: SList Word16) -> length l .< 0+-- Unsatisfiable+-- >>> prove $ \(l1 :: SList Word16) (l2 :: SList Word16) -> length l1 + length l2 .== length (l1 ++ l2)+-- Q.E.D.+-- >>> sat $ \(s :: SString) -> length s .== 2+-- Satisfiable. Model:+--   s0 = "BA" :: String+-- >>> sat $ \(s :: SString) -> length s .< 0+-- Unsatisfiable+-- >>> prove $ \(s1 :: SString) s2 -> length s1 + length s2 .== length (s1 ++ s2)+-- Q.E.D.+length :: forall a. SymVal a => SList a -> SInteger+length = lift1 False (SeqLen (kindOf (Proxy @a))) (Just (fromIntegral . P.length))++-- | @`null` s@ is True iff the list is empty+--+-- >>> prove $ \(l :: SList Word16) -> null l .<=> length l .== 0+-- Q.E.D.+-- >>> prove $ \(l :: SList Word16) -> null l .<=> l .== []+-- Q.E.D.+-- >>> prove $ \(s :: SString) -> null s .<=> length s .== 0+-- Q.E.D.+-- >>> prove $ \(s :: SString) -> null s .<=> s .== ""+-- Q.E.D.+null :: SymVal a => SList a -> SBool+null l+  | Just cs <- unliteral l+  = literal (P.null cs)+  | True+  = length l .== 0++-- | @`head`@ returns the first element of a list. Unspecified if the list is empty.+--+-- >>> prove $ \c -> head [c] .== (c :: SInteger)+-- Q.E.D.+-- >>> prove $ \c -> c .== literal 'A' .=> ([c] :: SString) .== "A"+-- Q.E.D.+-- >>> prove $ \(c :: SChar) -> length ([c] :: SString) .== 1+-- Q.E.D.+-- >>> prove $ \(c :: SChar) -> head ([c] :: SString) .== c+-- Q.E.D.+head :: SymVal a => SList a -> SBV a+head = (`elemAt` 0)++-- | @`tail`@ returns the tail of a list. Unspecified if the list is empty.+--+-- >>> prove $ \(h :: SInteger) t -> tail ([h] ++ t) .== t+-- Q.E.D.+-- >>> prove $ \(l :: SList Integer) -> length l .> 0 .=> length (tail l) .== length l - 1+-- Q.E.D.+-- >>> prove $ \(l :: SList Integer) -> sNot (null l) .=> [head l] ++ tail l .== l+-- Q.E.D.+-- >>> prove $ \(h :: SChar) s -> tail ([h] ++ s) .== s+-- Q.E.D.+-- >>> prove $ \(s :: SString) -> length s .> 0 .=> length (tail s) .== length s - 1+-- Q.E.D.+-- >>> prove $ \(s :: SString) -> sNot (null s) .=> [head s] ++ tail s .== s+-- Q.E.D.+tail :: SymVal a => SList a -> SList a+tail l+ | Just (_:cs) <- unliteral l+ = literal cs+ | True+ = subList l 1 (length l - 1)++-- | @`uncons`@ returns the pair of the head and tail. Unspecified if the list is empty.+--+-- >>> prove $ \(x :: SInteger) xs -> uncons (x .: xs) .== (x, xs)+-- Q.E.D.+uncons :: SymVal a => SList a -> (SBV a, SList a)+uncons l = (head l, tail l)++-- | @`init`@ returns all but the last element of the list. Unspecified if the list is empty.+--+-- >>> prove $ \(h :: SInteger) t -> init (t ++ [h]) .== t+-- Q.E.D.+-- >>> prove $ \(c :: SChar) t -> init (t ++ [c]) .== t+-- Q.E.D.+init :: SymVal a => SList a -> SList a+init l+ | Just cs@(_:_) <- unliteral l+ = literal $ P.init cs+ | True+ = subList l 0 (length l - 1)++-- | @`last`@ returns the last element of the list. Unspecified if the list is empty.+--+-- >>> prove $ \(l :: SInteger) i -> last (i ++ [l]) .== l+-- Q.E.D.+last :: SymVal a => SList a -> SBV a+last l = l `elemAt` (length l - 1)++-- | @`singleton` x@ is the list of length 1 that contains the only value @x@.+--+-- >>> prove $ \(x :: SInteger) -> head [x] .== x+-- Q.E.D.+-- >>> prove $ \(x :: SInteger) -> length [x] .== 1+-- Q.E.D.+singleton :: forall a. SymVal a => SBV a -> SList a+singleton = lift1 False (SeqUnit (kindOf (Proxy @a))) (Just (: []))++-- | @`listToListAt` l offset@. List of length 1 at @offset@ in @l@. Unspecified if+-- index is out of bounds.+--+-- >>> prove $ \(l1 :: SList Integer) l2 -> listToListAt (l1 ++ l2) (length l1) .== listToListAt l2 0+-- Q.E.D.+-- >>> sat $ \(l :: SList Word16) -> length l .>= 2 .&& listToListAt l 0 ./= listToListAt l (length l - 1)+-- Satisfiable. Model:+--   s0 = [0,64] :: [Word16]+listToListAt :: SymVal a => SList a -> SInteger -> SList a+listToListAt s offset = subList s offset 1++-- | @`elemAt` l i@ is the value stored at location @i@, starting at 0. Unspecified if+-- index is out of bounds.+--+-- >>> prove $ \i -> i `inRange` (0, 4) .=> [1,1,1,1,1] `elemAt` i .== (1::SInteger)+-- Q.E.D.+-- >>> prove $ \i -> i .>= 0 .&& i .<= 4 .=> "AAAAA" `elemAt` i .== literal 'A'+-- Q.E.D.+elemAt :: forall a. SymVal a => SList a -> SInteger -> SBV a+elemAt l i+  | Just xs <- unliteral l, Just ci <- unliteral i, ci >= 0, ci < genericLength xs, let x = xs `genericIndex` ci+  = literal x+  | True+  = lift2 False (SeqNth (kindOf (Proxy @a))) Nothing l i++-- | Short cut for 'elemAt'+--+-- >>> prove $ \(xs :: SList Integer) i -> xs !! i .== xs `elemAt` i+-- Q.E.D.+(!!) :: SymVal a => SList a -> SInteger -> SBV a+(!!) = elemAt++-- | @`implode` es@ is the list of length @|es|@ containing precisely those+-- elements. Note that there is no corresponding function @explode@, since+-- we wouldn't know the length of a symbolic list.+--+-- >>> prove $ \(e1 :: SInteger) e2 e3 -> length (implode [e1, e2, e3]) .== 3+-- Q.E.D.+-- >>> prove $ \(e1 :: SInteger) e2 e3 -> P.map (elemAt (implode [e1, e2, e3])) (P.map literal [0 .. 2]) .== [e1, e2, e3]+-- Q.E.D.+-- >>> prove $ \(c1 :: SChar) c2 c3 -> length (implode [c1, c2, c3]) .== 3+-- Q.E.D.+-- >>> prove $ \(c1 :: SChar) c2 c3 -> P.map (elemAt (implode [c1, c2, c3])) (P.map literal [0 .. 2]) .== [c1, c2, c3]+-- Q.E.D.+implode :: SymVal a => [SBV a] -> SList a+implode = P.foldr ((++) . \x -> [x]) (literal [])++-- | Prepend an element, the traditional @cons@.+--+-- >>> 1 .: 2 .: 3 .: [4, 5, 6 :: SInteger]+-- [1,2,3,4,5,6] :: [SInteger]+infixr 5 .:+(.:) :: SymVal a => SBV a -> SList a -> SList a+a .: as = singleton a ++ as  -- NB. Don't do "[a] ++ as" here. That type-checks but is recursive due to how overloaded-lists work.++-- | Append an element+--+-- >>> [1, 2, 3 :: SInteger] `snoc` 4 `snoc` 5 `snoc` 6+-- [1,2,3,4,5,6] :: [SInteger]+snoc :: SymVal a => SList a -> SBV a -> SList a+as `snoc` a = as ++ [a]++-- | Empty list. This value has the property that it's the only list with length 0. If you use @OverloadedLists@ extension,+-- you can write it as the familiar `[]`.+--+-- >>> prove $ \(l :: SList Integer) -> length l .== 0 .<=> l .== []+-- Q.E.D.+-- >>> prove $ \(l :: SString) -> length l .== 0 .<=> l .== []+-- Q.E.D.+nil :: SymVal a => SList a+nil = literal []++-- | Append two lists.+--+-- >>> sat $ \x y (z :: SList Integer) -> length x .== 5 .&& length y .== 1 .&& x ++ y ++ z .== [sEnum|1 .. 12|]+-- Satisfiable. Model:+--   s0 =      [1,2,3,4,5] :: [Integer]+--   s1 =              [6] :: [Integer]+--   s2 = [7,8,9,10,11,12] :: [Integer]+-- >>> sat $ \(x :: SString) y z -> length x .== 5 .&& length y .== 1 .&& x ++ y ++ z .== "Hello world!"+-- Satisfiable. Model:+--   s0 =  "Hello" :: String+--   s1 =      " " :: String+--   s2 = "world!" :: String+infixr 5 +++(++) :: forall a. SymVal a => SList a -> SList a -> SList a+x ++ y | isConcretelyEmpty x = y+       | isConcretelyEmpty y = x+       | True                = lift2 False (SeqConcat (kindOf (Proxy @a))) (Just (P.++)) x y++-- | @`elem` e l@. Does @l@ contain the element @e@?+--+-- >>> prove $ \(xs :: SList Integer) x -> x `elem` xs .=> length xs .>= 1+-- Q.E.D.+elem :: (Eq a, SymVal a) => SBV a -> SList a -> SBool+e `elem` l = [e] `isInfixOf` l++-- | @`notElem` e l@. Does @l@ not contain the element @e@?+--+-- >>> prove $ \(x :: SList Integer) -> x `notElem` []+-- Q.E.D.+notElem :: (Eq a, SymVal a) => SBV a -> SList a -> SBool+e `notElem` l = sNot (e `elem` l)++-- | @`isInfixOf` sub l@. Does @l@ contain the subsequence @sub@?+--+-- >>> prove $ \(l1 :: SList Integer) l2 l3 -> l2 `isInfixOf` (l1 ++ l2 ++ l3)+-- Q.E.D.+-- >>> prove $ \(l1 :: SList Integer) l2 -> l1 `isInfixOf` l2 .&& l2 `isInfixOf` l1 .<=> l1 .== l2+-- Q.E.D.+-- >>> prove $ \(s1 :: SString) s2 s3 -> s2 `isInfixOf` (s1 ++ s2 ++ s3)+-- Q.E.D.+-- >>> prove $ \(s1 :: SString) s2 -> s1 `isInfixOf` s2 .&& s2 `isInfixOf` s1 .<=> s1 .== s2+-- Q.E.D.+isInfixOf :: forall a. (Eq a, SymVal a) => SList a -> SList a -> SBool+sub `isInfixOf` l+  | isConcretelyEmpty sub+  = literal True+  | True+  = lift2 True (SeqContains (kindOf (Proxy @a))) (Just (flip L.isInfixOf)) l sub -- NB. flip, since `SeqContains` takes args in rev order!++-- | @`isPrefixOf` pre l@. Is @pre@ a prefix of @l@?+--+-- >>> prove $ \(l1 :: SList Integer) l2 -> l1 `isPrefixOf` (l1 ++ l2)+-- Q.E.D.+-- >>> prove $ \(l1 :: SList Integer) l2 -> l1 `isPrefixOf` l2 .=> subList l2 0 (length l1) .== l1+-- Q.E.D.+-- >>> prove $ \(s1 :: SString) s2 -> s1 `isPrefixOf` (s1 ++ s2)+-- Q.E.D.+-- >>> prove $ \(s1 :: SString) s2 -> s1 `isPrefixOf` s2 .=> subList s2 0 (length s1) .== s1+-- Q.E.D.+isPrefixOf :: forall a. (Eq a, SymVal a) => SList a -> SList a -> SBool+pre `isPrefixOf` l+  | isConcretelyEmpty pre+  = literal True+  | True+  = lift2 True (SeqPrefixOf (kindOf (Proxy @a))) (Just L.isPrefixOf) pre l++-- | @`isSuffixOf` suf l@. Is @suf@ a suffix of @l@?+--+-- >>> prove $ \(l1 :: SList Word16) l2 -> l2 `isSuffixOf` (l1 ++ l2)+-- Q.E.D.+-- >>> prove $ \(l1 :: SList Word16) l2 -> l1 `isSuffixOf` l2 .=> subList l2 (length l2 - length l1) (length l1) .== l1+-- Q.E.D.+-- >>> prove $ \(s1 :: SString) s2 -> s2 `isSuffixOf` (s1 ++ s2)+-- Q.E.D.+-- >>> prove $ \(s1 :: SString) s2 -> s1 `isSuffixOf` s2 .=> subList s2 (length s2 - length s1) (length s1) .== s1+-- Q.E.D.+isSuffixOf :: forall a. (Eq a, SymVal a) => SList a -> SList a -> SBool+suf `isSuffixOf` l+  | isConcretelyEmpty suf+  = literal True+  | True+  = lift2 True (SeqSuffixOf (kindOf (Proxy @a))) (Just L.isSuffixOf) suf l++-- | @`take` len l@. Corresponds to Haskell's `take` on symbolic lists.+--+-- >>> prove $ \(l :: SList Integer) i -> i .>= 0 .=> length (take i l) .<= i+-- Q.E.D.+-- >>> prove $ \(s :: SString) i -> i .>= 0 .=> length (take i s) .<= i+-- Q.E.D.+take :: SymVal a => SInteger -> SList a -> SList a+take i l = ite (i .<= 0)        (literal [])+         $ ite (i .>= length l) l+         $ subList l 0 i++-- | @`drop` len s@. Corresponds to Haskell's `drop` on symbolic-lists.+--+-- >>> prove $ \(l :: SList Word16) i -> length (drop i l) .<= length l+-- Q.E.D.+-- >>> prove $ \(l :: SList Word16) i -> take i l ++ drop i l .== l+-- Q.E.D.+-- >>> prove $ \(s :: SString) i -> length (drop i s) .<= length s+-- Q.E.D.+-- >>> prove $ \(s :: SString) i -> take i s ++ drop i s .== s+-- Q.E.D.+drop :: SymVal a => SInteger -> SList a -> SList a+drop i s = ite (i .>= ls) (literal [])+         $ ite (i .<= 0)  s+         $ subList s i (ls - i)+  where ls = length s++-- | @splitAt n xs = (take n xs, drop n xs)@+--+-- >>> prove $ \n (xs :: SList Integer) -> let (l, r) = splitAt n xs in l ++ r .== xs+-- Q.E.D.+splitAt :: SymVal a => SInteger -> SList a -> (SList a, SList a)+splitAt n xs = (take n xs, drop n xs)++-- | @`subList` s offset len@ is the sublist of @s@ at offset @offset@ with length @len@.+-- This function is under-specified when the offset is outside the range of positions in @s@ or @len@+-- is negative or @offset+len@ exceeds the length of @s@.+--+-- >>> prove $ \(l :: SList Integer) i -> i .>= 0 .&& i .< length l .=> subList l 0 i ++ subList l i (length l - i) .== l+-- Q.E.D.+-- >>> sat  $ \i j -> subList [sEnum|1..5|] i j .== [sEnum|2..4::SInteger|]+-- Satisfiable. Model:+--   s0 = 1 :: Integer+--   s1 = 3 :: Integer+-- >>> sat  $ \i j -> subList [sEnum|1..5|] i j .== [sEnum|6..7::SInteger|]+-- Unsatisfiable+-- >>> prove $ \(s1 :: SString) (s2 :: SString) -> subList (s1 ++ s2) (length s1) 1 .== subList s2 0 1+-- Q.E.D.+-- >>> sat $ \(s :: SString) -> length s .>= 2 .&& subList s 0 1 ./= subList s (length s - 1) 1+-- Satisfiable. Model:+--   s0 = "AB" :: String+-- >>> prove $ \(s :: SString) i -> i .>= 0 .&& i .< length s .=> subList s 0 i ++ subList s i (length s - i) .== s+-- Q.E.D.+-- >>> sat  $ \i j -> subList "hello" i j .== ("ell" :: SString)+-- Satisfiable. Model:+--   s0 = 1 :: Integer+--   s1 = 3 :: Integer+-- >>> sat  $ \i j -> subList "hell" i j .== ("no" :: SString)+-- Unsatisfiable+subList :: forall a. SymVal a => SList a -> SInteger -> SInteger -> SList a+subList l offset len+  | Just c  <- unliteral l                   -- a constant list+  , Just o  <- unliteral offset              -- a constant offset+  , Just sz <- unliteral len                 -- a constant length+  , let lc = genericLength c                 -- length of the list+  , let valid x = x >= 0 && x <= lc          -- predicate that checks valid point+  , valid o                                  -- offset is valid+  , sz >= 0                                  -- length is not-negative+  , valid $ o + sz                           -- we don't overrun+  = literal $ genericTake sz $ genericDrop o c+  | True                                     -- either symbolic, or something is out-of-bounds+  = lift3 False (SeqSubseq (kindOf (Proxy @a))) Nothing l offset len++-- | @`replace` l src dst@. Replace the first occurrence of @src@ by @dst@ in @s@+--+-- >>> prove $ \l -> replace [sEnum|1..5|] l [sEnum|6..10|] .== [sEnum|6..10|] .=> l .== [sEnum|1..5::SWord8|]+-- Q.E.D.+-- >>> prove $ \(l1 :: SList Integer) l2 l3 -> length l2 .> length l1 .=> replace l1 l2 l3 .== l1+-- Q.E.D.+-- >>> prove $ \(s :: SString) -> replace "hello" s "world" .== "world" .=> s .== "hello"+-- Q.E.D.+-- >>> prove $ \(s1 :: SString) s2 s3 -> length s2 .> length s1 .=> replace s1 s2 s3 .== s1+-- Q.E.D.+replace :: forall a. (Eq a, SymVal a) => SList a -> SList a -> SList a -> SList a+replace l src dst+  | Just b <- unliteral src, P.null b   -- If src is null, simply prepend+  = dst ++ l+  | eqCheckIsObjectEq ka+  , Just a <- unliteral l+  , Just b <- unliteral src+  , Just c <- unliteral dst+  = literal $ walk a b c+  | True+  = lift3 True (SeqReplace ka) Nothing l src dst+  where walk haystack needle newNeedle = go haystack   -- note that needle is guaranteed non-empty here.+           where go []       = []+                 go i@(c:cs)+                  | needle `L.isPrefixOf` i = newNeedle P.++ genericDrop (genericLength needle :: Integer) i+                  | True                    = c : go cs++        ka = kindOf (Proxy @a)++-- | @`indexOf` l sub@. Retrieves first position of @sub@ in @l@, @-1@ if there are no occurrences.+-- Equivalent to @`offsetIndexOf` l sub 0@.+--+-- >>> prove $ \(l1 :: SList Word16) l2 -> length l2 .> length l1 .=> indexOf l1 l2 .== -1+-- Q.E.D.+-- >>> prove $ \s1 s2 -> length s2 .> length s1 .=> indexOf s1 s2 .== -1+-- Q.E.D.+indexOf :: (Eq a, SymVal a) => SList a -> SList a -> SInteger+indexOf s sub = offsetIndexOf s sub 0++-- | @`offsetIndexOf` l sub offset@. Retrieves first position of @sub@ at or+-- after @offset@ in @l@, @-1@ if there are no occurrences.+--+-- >>> prove $ \(l :: SList Int8) sub -> offsetIndexOf l sub 0 .== indexOf l sub+-- Q.E.D.+-- >>> prove $ \(l :: SList Int8) sub i -> i .>= length l .&& length sub .> 0 .=> offsetIndexOf l sub i .== -1+-- Q.E.D.+-- >>> prove $ \(l :: SList Int8) sub i -> i .> length l .=> offsetIndexOf l sub i .== -1+-- Q.E.D.+-- >>> prove $ \(s :: SString) sub -> offsetIndexOf s sub 0 .== indexOf s sub+-- Q.E.D.+-- >>> prove $ \(s :: SString) sub i -> i .>= length s .&& length sub .> 0 .=> offsetIndexOf s sub i .== -1+-- Q.E.D.+-- >>> prove $ \(s :: SString) sub i -> i .> length s .=> offsetIndexOf s sub i .== -1+-- Q.E.D.+offsetIndexOf :: forall a. (Eq a, SymVal a) => SList a -> SList a -> SInteger -> SInteger+offsetIndexOf s sub offset+  | eqCheckIsObjectEq ka+  , Just c <- unliteral s        -- a constant list+  , Just n <- unliteral sub      -- a constant search pattern+  , Just o <- unliteral offset   -- at a constant offset+  , o >= 0, o <= genericLength c        -- offset is good+  = case [i | (i, t) <- P.zip [o ..] (L.tails (genericDrop o c)), n `L.isPrefixOf` t] of+      (i:_) -> literal i+      _     -> -1+  | True+  = lift3 True (SeqIndexOf ka) Nothing s sub offset+  where ka = kindOf (Proxy @a)++-- | @`reverse` s@ reverses the sequence.+--+-- NB. We can define @reverse@ in terms of @foldl@ as: @foldl (\soFar elt -> [elt] ++ soFar) []@+-- But in my experiments, I found that this definition performs worse instead of the recursive definition+-- SBV generates for reverse calls. So we're keeping it intact.+--+-- >>> sat $ \(l :: SList Integer) -> reverse l .== literal [3, 2, 1]+-- Satisfiable. Model:+--   s0 = [1,2,3] :: [Integer]+-- >>> prove $ \(l :: SList Word32) -> reverse l .== [] .<=> null l+-- Q.E.D.+-- >>> sat $ \(l :: SString ) -> reverse l .== "321"+-- Satisfiable. Model:+--   s0 = "123" :: String+-- >>> prove $ \(l :: SString) -> reverse l .== "" .<=> null l+-- Q.E.D.+reverse :: forall a. SymVal a => SList a -> SList a+reverse l+  | Just l' <- unliteral l+  = literal (P.reverse l')+  | True+  = def l+  where def = smtFunction "sbv.reverse" $ \xs -> ite (null xs) [] (let (h, t) = uncons xs in def t ++ [h])++-- | A class of mappable functions. In SBV, we make a distinction between closures and regular functions, and+-- we instantiate this class appropriately so it can handle both cases.+class (SymVal a, SymVal b) => SMap func a b | func -> a b where+  -- | Map a function (or a closure) over a symbolic list.+  --+  -- >>> map (+ (1 :: SInteger)) [sEnum|1 .. 5 :: SInteger|]+  -- [2,3,4,5,6] :: [SInteger]+  -- >>> map (+ (1 :: SWord 8)) [sEnum|1 .. 5 :: SWord 8|]+  -- [2,3,4,5,6] :: [SWord8]+  -- >>> map (\x -> [x] :: SList Integer) [sEnum|1 .. 3 :: SInteger|]+  -- [[1],[2],[3]] :: [[SInteger]]+  -- >>> import Data.SBV.Tuple+  -- >>> map (\t -> t^._1 + t^._2) (literal [(x, y) | x <- [1..3], y <- [4..6]] :: SList (Integer, Integer))+  -- [5,6,7,6,7,8,7,8,9] :: [SInteger]+  --+  -- Of course, SBV's 'map' can also be reused in reverse:+  --+  -- >>> sat $ \l -> map (+(1 :: SInteger)) l .== [1,2,3 :: SInteger]+  -- Satisfiable. Model:+  --   s0 = [0,1,2] :: [Integer]+  map :: func -> SList a -> SList b++  -- | Handle the concrete case of mapping. Used internally only.+  concreteMap :: func -> (SBV a -> SBV b) -> SList a -> Maybe [b]+  concreteMap _ f sas+    | Just as <- unliteral sas+    = case P.map (unliteral . f . literal) as of+         bs | P.any isNothing bs -> Nothing+            | True               -> Just (catMaybes bs)+    | True+    = Nothing++-- | Mapping symbolic functions.+instance (SymVal a, SymVal b) => SMap (SBV a -> SBV b) a b where+  -- | @`map` f s@ maps the operation on to sequence.+  map f l+    | Just concResult <- concreteMap f f l+    = literal concResult+    | True+    = sbvMap l+    where sbvMap = smtHOFunction "sbv.map" f $ \xs -> ite (null xs) [] (let (h, t) = uncons xs in f h .: sbvMap t)++-- | Mapping symbolic closures.+instance (SymVal env, SymVal a, SymVal b) => SMap (Closure (SBV env) (SBV a -> SBV b)) a b where+  map cls@Closure{closureEnv, closureFun} l+    | Just concResult <- concreteMap cls (closureFun closureEnv) l+    = literal concResult+    | True+    = sbvMap (tuple (closureEnv, l))+    where sbvMap = smtHOFunction "sbv.closureMap" closureFun+                 $ \envxs -> let (cEnv, xs) = untuple envxs+                                 (h, t)     = uncons xs+                             in ite (null xs) [] (closureFun cEnv h .: sbvMap (tuple (cEnv, t)))++-- | @concatMap f xs@ maps f over elements and concats the result.+--+-- >>> concatMap (\x -> [x, x] :: SList Integer) [sEnum|1 .. 3|]+-- [1,1,2,2,3,3] :: [SInteger]+concatMap :: (SMap func a [b], SymVal b) => func -> SList a -> SList b+concatMap f = concat . map f++-- | A class of left foldable functions. In SBV, we make a distinction between closures and regular functions, and+-- we instantiate this class appropriately so it can handle both cases.+class (SymVal a, SymVal b) => SFoldL func a b | func -> a b where+  -- | @`foldl` f base s@ folds the from the left.+  --+  -- >>> foldl ((+) @SInteger) 0 [sEnum|1 .. 5|]+  -- 15 :: SInteger+  -- >>> foldl ((*) @SInteger) 1 [sEnum|1 .. 5|]+  -- 120 :: SInteger+  -- >>> foldl (\soFar elt -> [elt] ++ soFar) ([] :: SList Integer) [sEnum|1 .. 5|]+  -- [5,4,3,2,1] :: [SInteger]+  --+  -- Again, we can use 'Data.SBV.List.foldl' in the reverse too:+  --+  -- >>> sat $ \l -> foldl (\soFar elt -> [elt] ++ soFar) ([] :: SList Integer) l .== [5, 4, 3, 2, 1 :: SInteger]+  -- Satisfiable. Model:+  --   s0 = [1,2,3,4,5] :: [Integer]+  foldl :: (SymVal a, SymVal b) => func -> SBV b -> SList a -> SBV b++  -- | Handle the concrete case for folding left. Used internally only.+  concreteFoldl :: func -> (SBV b -> SBV a -> SBV b) -> SBV b -> SList a -> Maybe b+  concreteFoldl _ f sb sas+     | Just b <- unliteral sb, Just as <- unliteral sas+     = go b as+     | True+     = Nothing+     where go b []     = Just b+           go b (e:es) = case unliteral (literal b `f` literal e) of+                           Nothing -> Nothing+                           Just b' -> go b' es++-- | Folding left with symbolic functions.+instance (SymVal a, SymVal b) => SFoldL (SBV b -> SBV a -> SBV b) a b where+  -- | @`foldl` f b s@ folds the sequence from the left.+  foldl f base l+    | Just concResult <- concreteFoldl f f base l+    = literal concResult+    | True+    = sbvFoldl $ tuple (base, l)+    where sbvFoldl = smtHOFunction "sbv.foldl" (uncurry f . untuple)+                   $ \exs -> let (e, xs) = untuple exs+                                 (h, t)  = uncons xs+                             in ite (null xs)+                                    e+                                    (sbvFoldl (tuple (e `f` h, t)))++-- | Folding left with symbolic closures.+instance (SymVal env, SymVal a, SymVal b) => SFoldL (Closure (SBV env) (SBV b -> SBV a -> SBV b)) a b where+  foldl cls@Closure{closureEnv, closureFun} base l+    | Just concResult <- concreteFoldl cls (closureFun closureEnv) base l+    = literal concResult+    | True+    = sbvFoldl $ tuple (closureEnv, base, l)+    where sbvFoldl = smtHOFunction "sbv.closureFoldl" closureFun+                   $ \envxs -> let (cEnv, e, xs) = untuple envxs+                                   (h, t)        = uncons xs+                               in ite (null xs)+                                      e+                                      (sbvFoldl (tuple (cEnv, closureFun closureEnv e h, t)))++-- | A class of right foldable functions. In SBV, we make a distinction between closures and regular functions, and+-- we instantiate this class appropriately so it can handle both cases.+class (SymVal a, SymVal b) => SFoldR func a b | func -> a b where+  -- | @`foldr` f base s@ folds the from the right.+  --+  -- >>> foldr ((+) @SInteger) 0 [sEnum|1 .. 5|]+  -- 15 :: SInteger+  -- >>> foldr ((*) @SInteger) 1 [sEnum|1 .. 5|]+  -- 120 :: SInteger+  -- >>> foldr (\elt soFar -> soFar ++ [elt]) ([] :: SList Integer) [sEnum|1 .. 5|]+  -- [5,4,3,2,1] :: [SInteger]+  foldr :: func -> SBV b -> SList a -> SBV b++  -- | Handle the concrete case for folding left. Used internally only.+  concreteFoldr :: func -> (SBV a -> SBV b -> SBV b) -> SBV b -> SList a -> Maybe b+  concreteFoldr _ f sb sas+     | Just b <- unliteral sb, Just as <- unliteral sas+     = go b as+     | True+     = Nothing+     where go b []     = Just b+           go b (e:es) = case go b es of+                           Nothing  -> Nothing+                           Just res -> unliteral (literal e `f` literal res)++-- | Folding right with symbolic functions.+instance (SymVal a, SymVal b) => SFoldR (SBV a -> SBV b -> SBV b) a b where+  -- | @`foldr` f base s@ folds the sequence from the right.+  foldr f base l+    | Just concResult <- concreteFoldr f f base l+    = literal concResult+    | True+    = sbvFoldr $ tuple (base, l)+    where sbvFoldr = smtHOFunction "sbv.foldr" (uncurry f . untuple)+                   $ \exs -> let (e, xs) = untuple exs+                                 (h, t)  = uncons xs+                             in ite (null xs)+                                    e+                                    (h `f` sbvFoldr (tuple (e, t)))++-- | Folding right with symbolic closures.+instance (SymVal env, SymVal a, SymVal b) => SFoldR (Closure (SBV env) (SBV a -> SBV b -> SBV b)) a b where+  foldr cls@Closure{closureEnv, closureFun} base l+    | Just concResult <- concreteFoldr cls (closureFun closureEnv) base l+    = literal concResult+    | True+    = sbvFoldr $ tuple (closureEnv, base, l)+    where sbvFoldr = smtHOFunction "sbv.closureFoldr" closureFun+                   $ \envxs -> let (cEnv, e, xs) = untuple envxs+                                   (h, t)        = uncons xs+                               in ite (null xs)+                                      e+                                      (closureFun closureEnv h (sbvFoldr (tuple (cEnv, e, t))))++-- | @`zip` xs ys@ zips the lists to give a list of pairs. The length of the final list is+-- the minumum of the lengths of the given lists.+--+-- >>> zip [sEnum|1..10 :: SInteger|] [sEnum|11..20 :: SInteger|]+-- [(1,11),(2,12),(3,13),(4,14),(5,15),(6,16),(7,17),(8,18),(9,19),(10,20)] :: [(SInteger, SInteger)]+-- >>> import Data.SBV.Tuple+-- >>> foldr ((+) @SInteger) 0 (map (\t -> t^._1+t^._2::SInteger) (zip [sEnum|1..10|] [sEnum|10, 9..1|]))+-- 110 :: SInteger+zip :: forall a b. (SymVal a, SymVal b) => SList a -> SList b -> SList (a, b)+zip xs ys+ | Just xs' <- unliteral xs, Just ys' <- unliteral ys+ = literal $ P.zip xs' ys'+ | True+ = def xs ys+ where def = smtFunction "sbv.zip" $ \as bs -> ite (null as .|| null bs) [] (tuple (head as, head bs) .: def (tail as) (tail bs))++-- | A class of function that we can zip-with. In SBV, we make a distinction between closures and regular+-- functions, and we instantiate this class appropriately so it can handle both cases.+class (SymVal a, SymVal b, SymVal c) => SZipWith func a b c | func -> a b c where+  -- | @`zipWith` f xs ys@ zips the lists to give a list of pairs, applying the function to each pair of elements.+  -- The length of the final list is the minumum of the lengths of the given lists.+   --+   -- >>> zipWith ((+) @SInteger) ([sEnum|1..10::SInteger|]) ([sEnum|11..20::SInteger|])+   -- [12,14,16,18,20,22,24,26,28,30] :: [SInteger]+   -- >>> foldr ((+) @SInteger) 0 (zipWith ((+) @SInteger) [sEnum|1..10 :: SInteger|] [sEnum|10, 9..1 :: SInteger|])+   -- 110 :: SInteger+  zipWith :: func -> SList a -> SList b -> SList c++  -- | Handle the concrete case of zipping. Used internally only.+  concreteZipWith :: func -> (SBV a -> SBV b -> SBV c) -> SList a -> SList b -> Maybe [c]+  concreteZipWith _ f sas sbs+   | Just as <- unliteral sas, Just bs <- unliteral sbs+   = go as bs+   | True+   = Nothing+   where go []     _      = Just []+         go _      []     = Just []+         go (a:as) (b:bs) = (:) <$> unliteral (literal a `f` literal b) <*> go as bs++-- | Zipping with symbolic functions.+instance (SymVal a, SymVal b, SymVal c) => SZipWith (SBV a -> SBV b -> SBV c) a b c where+   -- | @`zipWith`@ zips two sequences with a symbolic function.+   zipWith f xs ys+    | Just concResult <- concreteZipWith f f xs ys+    = literal concResult+    | True+    = sbvZipWith $ tuple (xs, ys)+    where sbvZipWith = smtHOFunction "sbv.zipWith" (uncurry f . untuple)+                     $ \asbs -> let (as, bs) = untuple asbs+                                in ite (null as .|| null bs)+                                       []+                                       (f (head as) (head bs) .: sbvZipWith (tuple (tail as, tail bs)))++-- | Zipping with closures.+instance (SymVal env, SymVal a, SymVal b, SymVal c) => SZipWith (Closure (SBV env) (SBV a -> SBV b -> SBV c)) a b c where+   zipWith cls@Closure{closureEnv, closureFun} xs ys+    | Just concResult <- concreteZipWith cls (closureFun closureEnv) xs ys+    = literal concResult+    | True+    = sbvZipWith $ tuple (closureEnv, xs, ys)+    where sbvZipWith = smtHOFunction "sbv.closureZipWith" closureFun+                     $ \envasbs -> let (cEnv, as, bs) = untuple envasbs+                                   in ite (null as .|| null bs)+                                          []+                                          (closureFun cEnv (head as) (head bs) .: sbvZipWith (tuple (cEnv, tail as, tail bs)))++-- | Concatenate list of lists.+--+-- >>> concat [[sEnum|1..3::SInteger|], [sEnum|4..7|], [sEnum|8..10|]]+-- [1,2,3,4,5,6,7,8,9,10] :: [SInteger]+concat :: forall a. SymVal a => SList [a] -> SList a+concat = foldr (++) []++-- | Check all elements satisfy the predicate.+--+-- >>> let isEven x = x `sMod` 2 .== 0+-- >>> all isEven [2, 4, 6, 8, 10 :: SInteger]+-- True+-- >>> all isEven [2, 4, 6, 1, 8, 10 :: SInteger]+-- False+all :: forall a. SymVal a => (SBV a -> SBool) -> SList a -> SBool+all f = foldr ((.&&) . f) sTrue++-- | Check some element satisfies the predicate.+--+-- >>> let isEven x = x `sMod` 2 .== 0+-- >>> any (sNot . isEven) [2, 4, 6, 8, 10 :: SInteger]+-- False+-- >>> any isEven [2, 4, 6, 1, 8, 10 :: SInteger]+-- True+any :: forall a. SymVal a => (SBV a -> SBool) -> SList a -> SBool+any f = foldr ((.||) . f) sFalse++-- | Conjunction of all the elements.+--+-- >>> and []+-- True+-- >>> prove $ \s -> and [s, sNot s] .== sFalse+-- Q.E.D.+and :: SList Bool -> SBool+and = all id++-- | Disjunction of all the elements.+--+-- >>> or []+-- False+-- >>> prove $ \s -> or [s, sNot s]+-- Q.E.D.+or :: SList Bool -> SBool+or = any id++-- | Replicate an element a given number of times.+--+-- >>> replicate 3 (2 :: SInteger) .== [2, 2, 2 :: SInteger]+-- True+-- >>> replicate (-2) (2 :: SInteger) .== ([] :: SList Integer)+-- True+replicate :: forall a. SymVal a => SInteger -> SBV a -> SList a+replicate c e+ | Just c' <- unliteral c, Just e' <- unliteral e+ = literal (genericReplicate c' e')+ | True+ = def c e+ where def = smtFunction "sbv.replicate" $ \count elt -> ite (count .<= 0) [] (elt .: def (count - 1) elt)++-- | inits of a list.+--+-- >>> inits ([] :: SList Integer)+-- [[]] :: [[SInteger]]+-- >>> inits [1,2,3,4::SInteger]+-- [[],[1],[1,2],[1,2,3],[1,2,3,4]] :: [[SInteger]]+inits :: forall a. SymVal a => SList a -> SList [a]+inits xs+ | Just xs' <- unliteral xs+ = literal (L.inits xs')+ | True+ = def xs+ where def = smtFunction "sbv.inits" $ \l -> ite (null l) [[]] (def (init l) ++ [l])++-- | tails of a list.+--+-- >>> tails ([] :: SList Integer)+-- [[]] :: [[SInteger]]+-- >>> tails [1,2,3,4::SInteger]+-- [[1,2,3,4],[2,3,4],[3,4],[4],[]] :: [[SInteger]]+tails :: forall a. SymVal a => SList a -> SList [a]+tails xs+ | Just xs' <- unliteral xs+ = literal (L.tails xs')+ | True+ = def xs+ where def = smtFunction "sbv.tails" $ \l -> ite (null l) [[]] (l .: def (tail l))++-- | Difference.+--+-- >>> [1, 2] \\ [3, 4 :: SInteger]+-- [1,2] :: [SInteger]+-- >>> [1, 2] \\ [2, 4 :: SInteger]+-- [1] :: [SInteger]+(\\) :: forall a. (Eq a, SymVal a) => SList a -> SList a -> SList a+xs \\ ys+ | Just xs' <- unliteral xs, Just ys' <- unliteral ys+ = literal (xs' L.\\ ys')+ | True+ = def xs ys+ where def = smtFunction "sbv.diff" $ \x y -> ite (null x)+                                                  []+                                                  (let (h, t) = uncons x+                                                       r      = def t y+                                                   in ite (h `elem` y) r (h .: r))+infix 5 \\  -- CPP: do not eat the final newline++-- | A class of filtering-like functions. In SBV, we make a distinction between closures and regular functions,+-- and we instantiate this class appropriately so it can handle both cases.+class SymVal a => SFilter func a | func -> a where+  -- | Filter a list via a predicate.+  --+  -- >>> filter (\(x :: SInteger) -> x `sMod` 2 .== 0) (literal [1 .. 10])+  -- [2,4,6,8,10] :: [SInteger]+  -- >>> filter (\(x :: SInteger) -> x `sMod` 2 ./= 0) (literal [1 .. 10])+  -- [1,3,5,7,9] :: [SInteger]+  filter :: func -> SList a -> SList a++  -- | Handle the concrete case of filtering. Used internally only.+  concreteFilter :: func -> (SBV a -> SBool) -> SList a -> Maybe [a]+  concreteFilter _ f sas+   | Just as <- unliteral sas+   = case P.map (unliteral . f . literal) as of+        xs | P.any isNothing xs -> Nothing+           | True               -> Just [e | (True, e) <- P.zip (catMaybes xs) as]+   | True+   = Nothing++  -- | Partition a symbolic list according to a predicate.+  --+  -- >>> partition (\(x :: SInteger) -> x `sMod` 2 .== 0) (literal [1 .. 10])+  -- ([2,4,6,8,10],[1,3,5,7,9]) :: ([SInteger], [SInteger])+  partition :: func -> SList a -> STuple [a] [a]++  -- | Handle the concrete case of partitioning. Used internally only.+  concretePartition :: func -> (SBV a -> SBool) -> SList a -> Maybe ([a], [a])+  concretePartition _ f l+    | Just l' <- unliteral l+    = case P.map (unliteral . f . literal) l' of+        xs | P.any isNothing xs -> Nothing+           | True               -> let (ts, fs) = L.partition P.fst (P.zip (catMaybes xs) l')+                                   in Just (P.map P.snd ts, P.map P.snd fs)+    | True+    = Nothing++  -- | Symbolic equivalent of @takeWhile@+  --+  -- >>> takeWhile (\(x :: SInteger) -> x `sMod` 2 .== 0) (literal [1..10])+  -- [] :: [SInteger]+  -- >>> takeWhile (\(x :: SInteger) -> x `sMod` 2 ./= 0) (literal [1..10])+  -- [1] :: [SInteger]+  takeWhile :: func -> SList a -> SList a++  -- | Handle the concrete case of take-while. Used internally only.+  concreteTakeWhile :: func -> (SBV a -> SBool) -> SList a -> Maybe [a]+  concreteTakeWhile _ f sas+   | Just as <- unliteral sas+   = case P.map (unliteral . f . literal) as of+        xs | P.any isNothing xs -> Nothing+           | True               -> Just (P.map P.snd (P.takeWhile P.fst (P.zip (catMaybes xs) as)))+   | True+   = Nothing++  -- | Symbolic equivalent of @dropWhile@+  -- >>> dropWhile (\(x :: SInteger) -> x `sMod` 2 .== 0) (literal [1..10])+  -- [1,2,3,4,5,6,7,8,9,10] :: [SInteger]+  -- >>> dropWhile (\(x :: SInteger) -> x `sMod` 2 ./= 0) (literal [1..10])+  -- [2,3,4,5,6,7,8,9,10] :: [SInteger]+  dropWhile :: func -> SList a -> SList a++  -- | Handle the concrete case of take-while. Used internally only.+  concreteDropWhile :: func -> (SBV a -> SBool) -> SList a -> Maybe [a]+  concreteDropWhile _ f sas+   | Just as <- unliteral sas+   = case P.map (unliteral . f . literal) as of+        xs | P.any isNothing xs -> Nothing+           | True               -> Just (P.map P.snd (P.dropWhile P.fst (P.zip (catMaybes xs) as)))+   | True+   = Nothing++-- | Filtering with symbolic functions.+instance SymVal a => SFilter (SBV a -> SBool) a where+  -- | @filter f xs@ filters the list with the given predicate.+  filter f l+    | Just concResult <- concreteFilter f f l+    = literal concResult+    | True+    = sbvFilter l+    where sbvFilter = smtHOFunction "sbv.filter" f $ \xs -> ite (null xs)+                                                                []+                                                                (let (h, t) = uncons xs+                                                                     r      = sbvFilter t+                                                                 in ite (f h) (h .: r) r)++  -- | @partition f xs@ splits the list into two and returns those that satisfy the predicate in the+  -- first element, and those that don't in the second.+  partition f l+    | Just concResult <- concretePartition f f l+    = literal concResult+    | True+    = sbvPartition l+    where sbvPartition = smtHOFunction "sbv.partition" f $ \xs -> ite (null xs)+                                                                      (tuple ([], []))+                                                                      (let (h, t)   = uncons xs+                                                                           (as, bs) = untuple $ sbvPartition t+                                                                       in ite (f h)+                                                                              (tuple (h .: as, bs))+                                                                              (tuple (as, h .: bs)))++  -- | @takeWhile f xs@ takes the prefix of @xs@ that satisfy the predicate.+  takeWhile f l+    | Just concResult <- concreteTakeWhile f f l+    = literal concResult+    | True+    = sbvTakeWhile l+    where sbvTakeWhile = smtHOFunction "sbv.takeWhile" f $ \xs -> ite (null xs)+                                                                      []+                                                                      (let (h, t) = uncons xs+                                                                       in ite (f h) (h .: sbvTakeWhile t) [])++  -- | @dropWhile f xs@ drops the prefix of @xs@ that satisfy the predicate.+  dropWhile f l+    | Just concResult <- concreteDropWhile f f l+    = literal concResult+    | True+    = sbvDropWhile l+    where sbvDropWhile = smtHOFunction "sbv.dropWhile" f $ \xs -> ite (null xs)+                                                                      []+                                                                      (let (h, t) = uncons xs+                                                                       in ite (f h) (sbvDropWhile t) xs)++-- | Filtering with closures.+instance (SymVal env, SymVal a) => SFilter (Closure (SBV env) (SBV a -> SBool)) a where+  filter cls@Closure{closureEnv, closureFun} l+    | Just concResult <- concreteFilter cls (closureFun closureEnv) l+    = literal concResult+    | True+    = sbvFilter (tuple (closureEnv, l))+    where sbvFilter = smtHOFunction "sbv.closureFilter" closureFun+                    $ \envxs -> let (cEnv, xs) = untuple envxs+                                    (h, t)     = uncons xs+                                    r          = sbvFilter (tuple (cEnv, t))+                                in ite (closureFun cEnv h) (h .: r) r++  partition cls@Closure{closureEnv, closureFun} l+    | Just concResult <- concretePartition cls (closureFun closureEnv) l+    = literal concResult+    | True+    = sbvPartition (tuple (closureEnv, l))+    where sbvPartition = smtHOFunction "sbv.closurePartition" closureFun+                       $ \envxs -> let (cEnv, xs) = untuple envxs+                                       (h,    t)  = uncons xs+                                       (as,   bs) = untuple $ sbvPartition (tuple (cEnv, t))+                                   in ite (closureFun cEnv h)+                                          (tuple (h .: as, bs))+                                          (tuple (as, h .: bs))++  takeWhile cls@Closure{closureEnv, closureFun} l+    | Just concResult <- concreteTakeWhile cls (closureFun closureEnv) l+    = literal concResult+    | True+    = sbvTakeWhile (tuple (closureEnv, l))+    where sbvTakeWhile = smtHOFunction "sbv.closureTakeWhile" closureFun+                       $ \envxs -> let (cEnv, xs) = untuple envxs+                                       (h, t)     = uncons xs+                                in ite (closureFun cEnv h) (h .: sbvTakeWhile (tuple (cEnv, t))) []++  dropWhile cls@Closure{closureEnv, closureFun} l+    | Just concResult <- concreteDropWhile cls (closureFun closureEnv) l+    = literal concResult+    | True+    = sbvDropWhile (tuple (closureEnv, l))+    where sbvDropWhile = smtHOFunction "sbv.closureDropWhile" closureFun+                       $ \envxs -> let (cEnv, xs) = untuple envxs+                                       (h, t)     = uncons xs+                                in ite (closureFun cEnv h) (sbvDropWhile (tuple (cEnv, t))) xs++-- | @`sum` s@. Sum the given sequence.+--+-- >>> sum [sEnum|1 .. 10::SInteger|]+-- 55 :: SInteger+sum :: forall a. (SymVal a, Num (SBV a)) => SList a -> SBV a+sum = foldr ((+) @(SBV a)) 0++-- | @`product` s@. Multiply out the given sequence.+--+-- >>> product [sEnum|1 .. 10::SInteger|]+-- 3628800 :: SInteger+product :: forall a. (SymVal a, Num (SBV a)) => SList a -> SBV a+product = foldr ((*) @(SBV a)) 1++-- | A class of symbolic aware enumerations. This is similar to Haskell's @Enum@ class,+-- except some of the methods are generalized to work with symbolic values. Together+-- with the 'Data.SBV.sEnum' quasiquoter, you can write symbolic arithmetic progressions,+-- such as:+--+-- >>> [sEnum| 5, 7 .. 16::SInteger|]+-- [5,7,9,11,13,15] :: [SInteger]+-- >>> [sEnum| 4 ..|] :: SList (WordN 4)+-- [4,5,6,7,8,9,10,11,12,13,14,15] :: [SWord 4]+-- >>> [sEnum| 9, 12 ..|] :: SList (IntN 4)+-- [-7,-4,-1,2,5] :: [SInt 4]+class EnumSymbolic a where+   -- | @`succ`@, same as in the @Enum@ class+   succ :: SBV a -> SBV a++   -- | @`pred`@, same as in the @Enum@ class+   pred :: SBV a -> SBV a++   -- | @`toEnum`@, same as in the @Enum@ class, except it takes an 'SInteger'+   toEnum :: SInteger -> SBV a++   -- | @`fromEnum`@, same as in the @Enum@ class, except it returns an 'SInteger'+   fromEnum :: SBV a -> SInteger++   -- | @`enumFrom` m@. Symbolic version of @[m ..]@+   enumFrom :: SBV a -> SList a++   -- | @`enumFromThen` m@. Symbolic version of @[m, m' ..]@+   enumFromThen :: SBV a -> SBV a -> SList a++   -- | @`enumFromTo` m n@. Symbolic version of @[m .. n]@+   enumFromTo :: SymVal a => SBV a -> SBV a -> SList a++   -- | @`enumFromThenTo` m n@. Symbolic version of @[m, m' .. n]@+   enumFromThenTo :: SymVal a => SBV a -> SBV a -> SBV a -> SList a++-- | 'EnumSymbolic' instance for words+instance {-# OVERLAPPABLE #-} (SymVal a, Bounded a, Integral a, Num a, Num (SBV a)) => EnumSymbolic a where+  succ = smtFunction "EnumSymbolic.succ" (\x -> ite (x .== maxBound) (some "EnumSymbolic.succ.maxBound" (const sTrue)) (x+1))+  pred = smtFunction "EnumSymbolic.pred" (\x -> ite (x .== minBound) (some "EnumSymbolic.pred.minBound" (const sTrue)) (x-1))++  toEnum = smtFunction "EnumSymbolic.toEnum" $ \x ->+                         ite (x .< sFromIntegral (minBound @(SBV a))) (some "EnumSymbolic.toEnum.<minBound" (const sTrue))+                       $ ite (x .> sFromIntegral (maxBound @(SBV a))) (some "EnumSymbolic.toEnum.>maxBound" (const sTrue))+                       $ sFromIntegral x++  fromEnum = sFromIntegral++  enumFrom n   = map sFromIntegral (enumFromTo @Integer (sFromIntegral n) (sFromIntegral (maxBound @(SBV a))))+  enumFromThen = smtFunction "EnumSymbolic.enumFromThen" $ \n1 n2 ->+                             let i_n1, i_n2 :: SInteger+                                 i_n1 = sFromIntegral n1+                                 i_n2 = sFromIntegral n2+                             in map sFromIntegral (ite (i_n2 .>= i_n1)+                                                       (enumFromThenTo i_n1 i_n2 (sFromIntegral (maxBound @(SBV a))))+                                                       (enumFromThenTo i_n1 i_n2 (sFromIntegral (minBound @(SBV a)))))++  enumFromTo     n m   = map sFromIntegral (enumFromTo     @Integer (sFromIntegral n) (sFromIntegral m))+  enumFromThenTo n m t = map sFromIntegral (enumFromThenTo @Integer (sFromIntegral n) (sFromIntegral m) (sFromIntegral t))++-- | 'EnumSymbolic' instance for integer. NB. The above definition goes thru integers, hence we need to define this explicitly.+instance {-# OVERLAPPING #-} EnumSymbolic Integer where+   succ x = x + 1+   pred x = x - 1++   toEnum   = id+   fromEnum = id++   enumFrom   n = enumFromThen   n (n+1)+   enumFromTo n = enumFromThenTo n (n+1)++   enumFromThen x y = go x (y-x)+     where go = smtFunction "EnumSymbolic.Integer.enumFromThen" $ \start delta -> start .: go (start+delta) delta++   enumFromThenTo x y z = ite (delta .>= 0) (up x delta z) (down x delta z)+     where delta = y - x++           up, down :: SInteger -> SInteger -> SInteger -> SList Integer+           up    = smtFunction "EnumSymbolic.Integer.enumFromThenTo.up"   $ \start d end -> ite (start .> end) [] (start .: up   (start + d) d end)+           down  = smtFunction "EnumSymbolic.Integer.enumFromThenTo.down" $ \start d end -> ite (start .< end) [] (start .: down (start + d) d end)++-- | 'EnumSymbolic instance for 'Float'. Note that the termination requirement as defined by the Haskell standard for floats state:+--      > For Float and Double, the semantics of the enumFrom family is given by the rules for Int above,+--      > except that the list terminates when the elements become greater than @e3 + i/2@ for positive increment @i@,+--      > or when they become less than @e3 + i/2@ for negative @i@.+instance {-# OVERLAPPING #-} EnumSymbolic Float where+   succ x = x + 1+   pred x = x - 1++   toEnum   = sFromIntegral+   fromEnum = fromSFloat sRTZ++   enumFrom   n = enumFromThen   n (n+1)+   enumFromTo n = enumFromThenTo n (n+1)++   enumFromThen x y = go 0 x (y-x)+     where go = smtFunction "EnumSymbolic.Float.enumFromThen" $ \k n d -> (n + k * d) .: go (k+1) n d++   enumFromThenTo x y zIn = ite (delta .>= 0) (up 0 x delta z) (down 0 x delta z)+     where delta, z :: SFloat+           delta = y - x+           z     = zIn + delta / 2++           up, down :: SFloat -> SFloat -> SFloat -> SFloat -> SList Float+           up    = smtFunction "EnumSymbolic.Float.enumFromThenTo.up"   $ \k n d end -> let c = n + k * d in ite (c .> end) [] (c .: up   (k+1) n d end)+           down  = smtFunction "EnumSymbolic.Float.enumFromThenTo.down" $ \k n d end -> let c = n + k * d in ite (c .< end) [] (c .: down (k+1) n d end)++-- | 'EnumSymbolic instance for 'Double'+instance {-# OVERLAPPING #-} EnumSymbolic Double where+   succ x = x + 1+   pred x = x - 1++   toEnum   = sFromIntegral+   fromEnum = fromSDouble sRTZ++   enumFrom   n = enumFromThen   n (n+1)+   enumFromTo n = enumFromThenTo n (n+1)++   enumFromThen x y = go 0 x (y-x)+     where go = smtFunction "EnumSymbolic.Double.enumFromThen" $ \k n d -> (n + k * d) .: go (k+1) n d++   enumFromThenTo x y zIn = ite (delta .>= 0) (up 0 x delta z) (down 0 x delta z)+     where delta, z :: SDouble+           delta = y - x+           z     = zIn + delta / 2++           up, down :: SDouble -> SDouble -> SDouble -> SDouble -> SList Double+           up    = smtFunction "EnumSymbolic.Double.enumFromThenTo.up"   $ \k n d end -> let c = n + k * d in ite (c .> end) [] (c .: up   (k+1) n d end)+           down  = smtFunction "EnumSymbolic.Double.enumFromThenTo.down" $ \k n d end -> let c = n + k * d in ite (c .< end) [] (c .: down (k+1) n d end)++-- | 'EnumSymbolic instance for arbitrary floats+instance {-# OVERLAPPING #-} ValidFloat eb sb => EnumSymbolic (FloatingPoint eb sb) where+   succ x = x + 1+   pred x = x - 1++   toEnum   = sFromIntegral+   fromEnum = fromSFloatingPoint sRTZ++   enumFrom   n = enumFromThen   n (n+1)+   enumFromTo n = enumFromThenTo n (n+1)++   enumFromThen x y = go 0 x (y-x)+     where go = smtFunction "EnumSymbolic.FloatingPoint.enumFromThen" $ \k n d -> (n + k * d) .: go (k+1) n d++   enumFromThenTo x y zIn = ite (delta .>= 0) (up 0 x delta z) (down 0 x delta z)+     where delta, z :: SFloatingPoint eb sb+           delta = y - x+           z     = zIn + delta / 2++           up, down :: SFloatingPoint eb sb -> SFloatingPoint eb sb -> SFloatingPoint eb sb -> SFloatingPoint eb sb -> SList (FloatingPoint eb sb)+           up    = smtFunction "EnumSymbolic.FloatingPoint.enumFromThenTo.up"   $ \k n d end -> let c = n + k * d in ite (c .> end) [] (c .: up   (k+1) n d end)+           down  = smtFunction "EnumSymbolic.FloatingPoint.enumFromThenTo.down" $ \k n d end -> let c = n + k * d in ite (c .< end) [] (c .: down (k+1) n d end)++-- | 'EnumSymbolic instance for arbitrary AlgReal. We don't have to use the multiplicative trick here+-- since alg-reals are precise. But, following rational in Haskell, we do use the stopping point of @z + delta / 2@.+instance {-# OVERLAPPING #-} EnumSymbolic AlgReal where+   succ x = x + 1+   pred x = x - 1++   toEnum   = sFromIntegral+   fromEnum = sRealToSIntegerTruncate++   enumFrom   n = enumFromThen   n (n+1)+   enumFromTo n = enumFromThenTo n (n+1)++   enumFromThen x y = go x (y-x)+     where go = smtFunction "EnumSymbolic.AlgReal.enumFromThen" $ \start delta -> start .: go (start+delta) delta++   enumFromThenTo x y zIn = ite (delta .>= 0) (up x delta z) (down x delta z)+     where delta, z :: SReal+           delta = y - x+           z     = zIn + delta / 2++           up, down :: SReal -> SReal -> SReal -> SList AlgReal+           up    = smtFunction "EnumSymbolic.AlgReal.enumFromThenTo.up"   $ \start d end -> ite (start .> end) [] (start .: up   (start + d) d end)+           down  = smtFunction "EnumSymbolic.AlgReal.enumFromThenTo.down" $ \start d end -> ite (start .< end) [] (start .: down (start + d) d end)++-- | Lookup. If we can't find, then the result is unspecified.+--+-- >>> lookup (4 :: SInteger) (literal [(5, 12), (4, 3), (2, 6 :: Integer)])+-- 3 :: SInteger+-- >>> prove  $ \(x :: SInteger) -> x .== lookup 9 (literal [(5, 12), (4, 3), (2, 6 :: Integer)])+-- Falsifiable. Counter-example:+--   Data.SBV.List.lookup_notFound @Integer = 0 :: Integer+--   s0                                     = 1 :: Integer+lookup :: (SymVal k, SymVal v) => SBV k -> SList (k, v) -> SBV v+lookup = smtFunction "Data.SBV.List.lookup" $ \k lst -> ite (null lst)+                                                            (some "Data.SBV.List.lookup_notFound" (const sTrue))+                                                            (let (k', v) = untuple (head lst)+                                                             in ite (k .== k') v (lookup k (tail lst)))++-- | @`strToNat` s@. Retrieve integer encoded by string @s@ (ground rewriting only).+-- Note that by definition this function only works when @s@ only contains digits,+-- that is, if it encodes a natural number. Otherwise, it returns '-1'.+--+-- >>> prove $ \s -> let n = strToNat s in length s .== 1 .=> (-1) .<= n .&& n .<= 9+-- Q.E.D.+strToNat :: SString -> SInteger+strToNat s+ | Just a <- unliteral s+ = if P.all C.isDigit a && not (P.null a)+   then literal (read a)+   else -1+ | True+ = lift1Str StrStrToNat Nothing s++-- | @`natToStr` i@. Retrieve string encoded by integer @i@ (ground rewriting only).+-- Again, only naturals are supported, any input that is not a natural number+-- produces empty string, even though we take an integer as an argument.+--+-- >>> prove $ \i -> length (natToStr i) .== 3 .=> i .<= 999+-- Q.E.D.+natToStr :: SInteger -> SString+natToStr i+ | Just v <- unliteral i+ = literal $ if v >= 0 then show v else ""+ | True+ = lift1Str StrNatToStr Nothing i++-- | Lift a unary operator over lists.+lift1 :: forall a b. (SymVal a, SymVal b) => Bool -> SeqOp -> Maybe (a -> b) -> SBV a -> SBV b+lift1 simpleEq w mbOp a+  | Just cv <- concEval1 simpleEq mbOp a+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k = kindOf (Proxy @b)+        r st = do sva <- sbvToSV st a+                  newExpr st k (SBVApp (SeqOp w) [sva])++-- | Lift a binary operator over lists.+lift2 :: forall a b c. (SymVal a, SymVal b, SymVal c) => Bool -> SeqOp -> Maybe (a -> b -> c) -> SBV a -> SBV b -> SBV c+lift2 simpleEq w mbOp a b+  | Just cv <- concEval2 simpleEq mbOp a b+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k = kindOf (Proxy @c)+        r st = do sva <- sbvToSV st a+                  svb <- sbvToSV st b+                  newExpr st k (SBVApp (SeqOp w) [sva, svb])++-- | Lift a ternary operator over lists.+lift3 :: forall a b c d. (SymVal a, SymVal b, SymVal c, SymVal d) => Bool -> SeqOp -> Maybe (a -> b -> c -> d) -> SBV a -> SBV b -> SBV c -> SBV d+lift3 simpleEq w mbOp a b c+  | Just cv <- concEval3 simpleEq mbOp a b c+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k = kindOf (Proxy @d)+        r st = do sva <- sbvToSV st a+                  svb <- sbvToSV st b+                  svc <- sbvToSV st c+                  newExpr st k (SBVApp (SeqOp w) [sva, svb, svc])++-- | Concrete evaluation for unary ops+concEval1 :: forall a b. (SymVal a, SymVal b) => Bool -> Maybe (a -> b) -> SBV a -> Maybe (SBV b)+concEval1 simpleEq mbOp a+  | not simpleEq || eqCheckIsObjectEq (kindOf (Proxy @a)) = literal <$> (mbOp <*> unliteral a)+  | True                                                  = Nothing++-- | Concrete evaluation for binary ops+concEval2 :: forall a b c. (SymVal a, SymVal b, SymVal c) => Bool -> Maybe (a -> b -> c) -> SBV a -> SBV b -> Maybe (SBV c)+concEval2 simpleEq mbOp a b+  | not simpleEq || eqCheckIsObjectEq (kindOf (Proxy @a)) = literal <$> (mbOp <*> unliteral a <*> unliteral b)+  | True                                                  = Nothing++-- | Concrete evaluation for ternary ops+concEval3 :: forall a b c d. (SymVal a, SymVal b, SymVal c, SymVal d) => Bool -> Maybe (a -> b -> c -> d) -> SBV a -> SBV b -> SBV c -> Maybe (SBV d)+concEval3 simpleEq mbOp a b c+  | not simpleEq || eqCheckIsObjectEq (kindOf (Proxy @a)) = literal <$> (mbOp <*> unliteral a <*> unliteral b <*> unliteral c)+  | True                                                  = Nothing++-- | Is the list concretely known empty?+isConcretelyEmpty :: SymVal a => SList a -> Bool+isConcretelyEmpty sl | Just l <- unliteral sl = P.null l+                     | True                   = False++-- | Lift a unary operator over strings.+lift1Str :: forall a b. (SymVal a, SymVal b) => StrOp -> Maybe (a -> b) -> SBV a -> SBV b+lift1Str w mbOp a+  | Just cv <- literal <$> (mbOp <*> unliteral a)+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k = kindOf (Proxy @b)+        r st = do sva <- sbvToSV st a+                  newExpr st k (SBVApp (StrOp w) [sva])++{- HLint ignore implode "Use :" -}
Data/SBV/Provers/Prover.hs view
@@ -106,11 +106,11 @@                                             , solverSetOptions            = startOpts                                             , ignoreExitCode              = False                                             , redirectVerbose             = Nothing-                                            , generateHOEquivs            = False-                                            , kdOptions                   = KDOptions { ribbonLength      = 40-                                                                                      , firstifyUniqueLen = 6-                                                                                      , quiet             = False-                                                                                      , measureTime       = False+                                            , firstifyUniqueLen           = 10+                                            , tpOptions                   = TPOptions { ribbonLength = 40+                                                                                      , quiet        = False+                                                                                      , printStats   = False+                                                                                      , cacheProofs  = False                                                                                       }                                             }
Data/SBV/RegExp.hs view
@@ -51,15 +51,14 @@         , identifier         ) where -import Prelude hiding (length, take, elem, notElem, head)+import Prelude hiding (length, take, elem, notElem, head, replicate, filter, map)  import qualified Prelude   as P import qualified Data.List as L  import Data.SBV.Core.Data-import Data.SBV.Core.Model () -- instances only -import Data.SBV.String+import Data.SBV.List import qualified Data.Char as C  import Data.Proxy@@ -71,8 +70,9 @@ -- $setup -- >>> import Data.SBV -- >>> import Data.SBV.Char--- >>> import Data.SBV.String--- >>> import Prelude hiding (length, take, elem, notElem, head)+-- >>> import Data.SBV.List+-- >>> import Prelude hiding (length, take, elem, notElem, head, map)+-- >>> import qualified Prelude as P -- >>> :set -XOverloadedStrings -- >>> :set -XScopedTypeVariables #endif@@ -87,7 +87,7 @@ -- >>> let pre   = dig19 * Loop 2 2 dig09 -- >>> let post  = dig19 * Loop 3 3 dig09 -- >>> let phone = pre * "-" * post--- >>> sat $ \s -> (s :: SString) `match` phone+-- >>> sat $ \(s :: SString) -> s `match` phone -- Satisfiable. Model: --   s0 = "800-8000" :: String class RegExpMatchable a where@@ -116,7 +116,7 @@            go (Opt r)        k s      = k s || go r k s            go (Comp r)       k s      = not $ go r k s            go (Diff r1 r2)   k s      = go r1 k s && not (go r2 k s)-           go (Loop i j r)   k s      = go (Conc (replicate i r P.++ replicate (j - i) (Opt r))) k s+           go (Loop i j r)   k s      = go (Conc (P.replicate i r P.++ P.replicate (j - i) (Opt r))) k s            go (Power n r)    k s      = go (Loop n n r) k s            go (Union [])     _ _      = False            go (Union [x])    k s      = go x k s@@ -159,7 +159,7 @@  -- | Helper to define a character class. ----- >>> prove $ \(c :: SChar) -> c `match` oneOf "ABCD" .<=> sAny (c .==) (map literal "ABCD")+-- >>> prove $ \(c :: SChar) -> c `match` oneOf "ABCD" .<=> sAny (c .==) (P.map literal "ABCD") -- Q.E.D. oneOf :: String -> RegExp oneOf xs = Union [exactly [x] | x <- xs]@@ -184,7 +184,7 @@  -- | Lift a char function to a regular expression that recognizes it. liftPredL1 :: (Char -> Bool) -> RegExp-liftPredL1 predicate = oneOf $ filter predicate (map C.chr [0 .. 255])+liftPredL1 predicate = oneOf $ P.filter predicate (P.map C.chr [0 .. 255])  -- | Recognize white-space, but without a new line. --@@ -215,11 +215,11 @@ -- -- >>> asciiLower -- (re.range "a" "z")--- >>> prove $ \c -> (c :: SChar) `match` asciiLower  .=> c `match` asciiLetter+-- >>> prove $ \(c :: SChar) -> c `match` asciiLower  .=> c `match` asciiLetter -- Q.E.D.--- >>> prove $ \c -> c `match` asciiLower  .=> toUpperL1 c `match` asciiUpper+-- >>> prove $ \(c :: SChar) -> c `match` asciiLower  .=> toUpperL1 c `match` asciiUpper -- Q.E.D.--- >>> prove $ \c -> c `match` asciiLetter .=> toLowerL1 c `match` asciiLower+-- >>> prove $ \(c :: SChar) -> c `match` asciiLetter .=> toLowerL1 c `match` asciiLower -- Q.E.D. asciiLower :: RegExp asciiLower = Range 'a' 'z'@@ -228,11 +228,11 @@ -- -- >>> asciiUpper -- (re.range "A" "Z")--- >>> prove $ \c -> (c :: SChar) `match` asciiUpper  .=> c `match` asciiLetter+-- >>> prove $ \(c :: SChar) -> c `match` asciiUpper  .=> c `match` asciiLetter -- Q.E.D.--- >>> prove $ \c -> c `match` asciiUpper  .=> toLowerL1 c `match` asciiLower+-- >>> prove $ \(c :: SChar) -> c `match` asciiUpper  .=> toLowerL1 c `match` asciiLower -- Q.E.D.--- >>> prove $ \c -> c `match` asciiLetter .=> toUpperL1 c `match` asciiUpper+-- >>> prove $ \(c :: SChar) -> c `match` asciiLetter .=> toUpperL1 c `match` asciiUpper -- Q.E.D. asciiUpper :: RegExp asciiUpper = Range 'A' 'Z'@@ -274,7 +274,7 @@ -- -- >>> decimal -- (re.+ (re.range "0" "9"))--- >>> prove $ \s -> (s::SString) `match` decimal .=> sNot (s `match` KStar asciiLetter)+-- >>> prove $ \(s :: SString) -> s `match` decimal .=> sNot (s `match` KStar asciiLetter) -- Q.E.D. decimal :: RegExp decimal = KPlus digit@@ -283,7 +283,7 @@ -- -- >>> octal -- (re.++ (re.union (str.to.re "0o") (str.to.re "0O")) (re.+ (re.range "0" "7")))--- >>> prove $ \s -> s `match` octal .=> sAny (.== take 2 s) ["0o", "0O"]+-- >>> prove $ \(s :: SString) -> s `match` octal .=> sAny (.== take 2 s) ["0o", "0O"] -- Q.E.D. octal :: RegExp octal = ("0o" + "0O") * KPlus octDigit@@ -292,7 +292,7 @@ -- -- >>> hexadecimal -- (re.++ (re.union (str.to.re "0x") (str.to.re "0X")) (re.+ (re.union (re.range "0" "9") (re.range "a" "f") (re.range "A" "F"))))--- >>> prove $ \s -> s `match` hexadecimal .=> sAny (.== take 2 s) ["0x", "0X"]+-- >>> prove $ \(s :: SString) -> s `match` hexadecimal .=> sAny (.== take 2 s) ["0x", "0X"] -- Q.E.D. hexadecimal :: RegExp hexadecimal = ("0x" + "0X") * KPlus hexDigit@@ -300,7 +300,7 @@ -- | Recognize a floating point number. The exponent part is optional if a fraction -- is present. The exponent may or may not have a sign. ----- >>> prove $ \s -> s `match` floating .=> length s .>= 3+-- >>> prove $ \(s :: SString) -> s `match` floating .=> length s .>= 3 -- Q.E.D. floating :: RegExp floating = withFraction + withoutFraction@@ -312,9 +312,9 @@ -- followed by zero or more letters, digits, underscores, and single quotes. The first -- letter must be lowercase. ----- >>> prove $ \s -> s `match` identifier .=> isAsciiLower (head s)+-- >>> prove $ \(s :: SString) -> s `match` identifier .=> isAsciiLower (head s) -- Q.E.D.--- >>> prove $ \s -> s `match` identifier .=> length s .>= 1+-- >>> prove $ \(s :: SString) -> s `match` identifier .=> length s .>= 1 -- Q.E.D. identifier :: RegExp identifier = asciiLower * KStar (asciiLetter + digit + "_" + "'")@@ -336,7 +336,7 @@  -- | Quiet GHC about testing only imports __unused :: a-__unused = undefined isSpaceL1 length take elem notElem head+__unused = undefined isSpaceL1  {- $matching A symbolic string or a character ('SString' or 'SChar') can be matched against a regular-expression. Note@@ -349,22 +349,22 @@ an argument for matching. In practice, this means you might have to disambiguate with a type-ascription if it is not deducible from context. ->>> prove $ \s -> (s :: SString) `match` "hello" .<=> s .== "hello"+>>> prove $ \(s :: SString) -> s `match` "hello" .<=> s .== "hello" Q.E.D.->>> prove $ \s -> s `match` Loop 2 5 "xyz" .=> length s .>= 6+>>> prove $ \(s :: SString) -> s `match` Loop 2 5 "xyz" .=> length s .>= 6 Q.E.D.->>> prove $ \s -> s `match` Loop 2 5 "xyz" .=> length s .<= 15+>>> prove $ \(s :: SString) -> s `match` Loop 2 5 "xyz" .=> length s .<= 15 Q.E.D.->>> prove $ \s -> s `match` Power 3 "xyz" .=> length s .== 9+>>> prove $ \(s :: SString) -> s `match` Power 3 "xyz" .=> length s .== 9 Q.E.D.->>> prove $ \s -> s `match`  (exactly "xyz" ^ 3) .=> length s .== 9+>>> prove $ \(s :: SString) -> s `match`  (exactly "xyz" ^ 3) .=> length s .== 9 Q.E.D.->>> prove $ \s -> match s (Loop 2 5 "xyz") .=> length s .>= 7+>>> prove $ \(s :: SString) -> match s (Loop 2 5 "xyz") .=> length s .>= 7 Falsifiable. Counter-example:   s0 = "xyzxyz" :: String->>> prove $ \s -> (s :: SString) `match` "hello" .=> s `match` ("hello" + "world")+>>> prove $ \(s :: SString) -> s `match` "hello" .=> s `match` ("hello" + "world") Q.E.D.->>> prove $ \s -> sNot $ (s::SString) `match` ("so close" * 0)+>>> prove $ \(s :: SString) -> sNot $ s `match` ("so close" * 0) Q.E.D. >>> prove $ \c -> (c :: SChar) `match` oneOf "abcd" .=> ord c .>= ord (literal 'a') .&& ord c .<= ord (literal 'd') Q.E.D.
+ Data/SBV/SEnum.hs view
@@ -0,0 +1,153 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.SEnum+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Add support for symbolic enumerations via a quasi-quoter. The code in this+-- file was initially generated by ChatGPT, which didn't quite work but was+-- close enough to let me finish it off.+--+-- Provides a quasiquoter `[sEnum| ... |]` for enumerations, like:+--+-- > [sEnum| a .. |]       ==> enumFrom a+-- > [sEnum| a, b .. |]    ==> enumFromThen a b+-- > [sEnum| a .. c |]     ==> enumFromTo a c+-- > [sEnum| a, b .. c |]  ==> enumFromThenTo a b c+--+-- All of @a@, @b@, @c@ can be arbitrary expressions.+--+-- If you pass invalid Haskell expressions or incorrect format, a detailed+-- error is raised with source location.+-----------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskellQuotes #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.SEnum (sEnum) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import qualified Language.Haskell.Exts                  as Exts+import qualified Language.Haskell.Meta.Parse            as Meta+import qualified Language.Haskell.Meta.Syntax.Translate as Meta++import Data.Char (isSpace)++import Prelude hiding (enumFrom, enumFromThen, enumFromTo, enumFromThenTo)+import Data.SBV.List  (enumFrom, enumFromThen, enumFromTo, enumFromThenTo)++import Control.Monad (unless)+import Data.List (isInfixOf, intercalate)++-- | The `sEnum` quasiquoter.+--+-- Supports formats:+--+--   * [sEnum| a    ..   |]+--   * [sEnum| a, b ..   |]+--   * [sEnum| a    .. c |]+--   * [sEnum| a, b .. c |]+--+-- All expressions may be arbitrary Haskell expressions, including floating point.+sEnum :: QuasiQuoter+sEnum = QuasiQuoter { quoteExp  = parseSEnumExpr+                    , quotePat  = err "patterns"+                    , quoteType = err "types"+                    , quoteDec  = err "declarations"+                    }+  where err ctx = error $ "Data.SBV.sEnum does not support " ++ ctx++-- | Parse the sequence syntax into a TH Exp. This isn't the most robust parser, but it gets the job done.+parseSEnumExpr :: String -> Q Exp+parseSEnumExpr input = do+  loc <- location++  -- Make sure there's a .. somewhere+  unless (".." `isInfixOf` input) $ errorWithLoc loc "There must be exactly one occurrence of '..'"++  -- Find that occurrence of ..+  (prefix, mEnd) <- do+        let walk ('.':'.':cs) sofar+             | ".." `isInfixOf` cs = errorWithLoc loc "Unexpected multiple occurrences of '..'"+             | True                = pure (reverse sofar, cs)+            walk (c:cs)         sofar = walk cs (c : sofar)+            walk ""             sofar = pure (reverse sofar, "")++        (pre, post) <- walk (trim input) ""+        pure (trim pre, case trim post of+                          "" -> Nothing+                          s  -> Just s)++  -- Now find the comma in the prefix. We only expect one comma here; though I suspect there might be more+  -- in complicated expressions. Let's ignore that for now.+  prefixParts <- do+       let walk (',':cs) sofar+            | ',' `elem` cs = errorWithLoc loc "Unexpected multiple commas."+            | True          = pure (reverse sofar, cs)+           walk (c:cs) sofar = walk cs (c : sofar)+           walk ""     sofar = pure (reverse sofar, "")++           hasComma = ',' `elem` prefix++       (pre, post) <- walk prefix ""++       -- post can be empty but pre can't+       case (trim pre, trim post) of+         ("", _)  | hasComma -> errorWithLoc loc "parse error on input ','"+                  | True     -> errorWithLoc loc "parse error on input '..'"+         (a,  "") | hasComma -> errorWithLoc loc "parse error on input '..'"+                  | True     -> pure [a]+         (a,  b)             -> pure [a, b]++  case (prefixParts, mEnd) of+    ([a],    Nothing) -> varE 'enumFrom       `appE` parseHaskellExpr loc a+    ([a, b], Nothing) -> varE 'enumFromThen   `appE` parseHaskellExpr loc a `appE` parseHaskellExpr loc b+    ([a],    Just c)  -> varE 'enumFromTo     `appE` parseHaskellExpr loc a `appE`                               parseHaskellExpr loc c+    ([a, b], Just c)  -> varE 'enumFromThenTo `appE` parseHaskellExpr loc a `appE` parseHaskellExpr loc b `appE` parseHaskellExpr loc c++    _ -> errorWithLoc loc $ unlines [ "Data.SBV.Enum: Invalid format. Use one of:"+                                    , ""+                                    , "  [sEnum| a    ..   |]"+                                    , "  [sEnum| a, b ..   |]"+                                    , "  [sEnum| a    .. c |]"+                                    , "  [sEnum| a, b .. c |]"+                                    ]++-- | Parses a string into a Haskell TH Exp using haskell-src-meta+parseHaskellExpr :: Loc -> String -> Q Exp+parseHaskellExpr loc s = case parse (trim s) of+                           Left err -> errorWithLoc loc $ intercalate "\n"+                                                             [ "*** Could not parse expression:"+                                                             , "***"+                                                             , "***   " ++ s ++ if all isSpace s then "<empty>" else ""+                                                             , "***"+                                                             , "*** Error: " ++ err+                                                             ]+                           Right e  -> return e+  where parse = fmap Meta.toExp . Meta.parseResultToEither . Exts.parseExpWithMode mode+        mode = Exts.defaultParseMode {+                  Exts.extensions = Exts.extensions Exts.defaultParseMode+                                        ++ [ Exts.EnableExtension Exts.TypeApplications+                                           , Exts.EnableExtension Exts.DataKinds+                                           ]+              }++-- | Utility: add filename and line number to an error+errorWithLoc :: Loc -> String -> Q a+errorWithLoc loc msg = fail $ intercalate "\n" $ ("Data.SBV.sEnum: error at " ++ formatLoc loc)+                                               : map ("        " ++) (lines msg)++-- | Show `file.hs:line:col`+formatLoc :: Loc -> String+formatLoc loc = loc_filename loc ++ ":" ++ show line ++ ":" ++ show col+  where (line, col) = loc_start loc++-- | Trim whitespace from both ends+trim :: String -> String+trim = f . f+  where f = reverse . dropWhile isSpace
Data/SBV/SMT/SMTLib2.hs view
@@ -18,10 +18,6 @@  module Data.SBV.SMT.SMTLib2(cvt, cvtExp, cvtCV, cvtInc, declUserFuns, constructTables, setSMTOption) where -import Crypto.Hash.SHA512 (hash)-import qualified Data.ByteString.Base16 as B-import qualified Data.ByteString.Char8  as BC- import Data.List  (intercalate, partition, nub, elemIndex) import Data.Maybe (listToMaybe, catMaybes) @@ -33,11 +29,12 @@  import Data.SBV.Core.Data import Data.SBV.Core.Kind (smtType, needsFlattening, expandKinds)-import Data.SBV.SMT.Utils import Data.SBV.Control.Types +import Data.SBV.SMT.Utils+ import Data.SBV.Core.Symbolic ( QueryContext(..), SetOp(..), getUserName', getSV, regExpToSMTString, NROp(..)-                              , SMTDef(..), ResultInp(..), ProgInfo(..), SpecialRelOp(..), SMTLambda(..)+                              , SMTDef(..), ResultInp(..), ProgInfo(..), SpecialRelOp(..)                               )  import Data.SBV.Utils.PrettyNum (smtRoundingMode, cvToSMTLib)@@ -46,32 +43,6 @@  import qualified Data.Graph as DG --- | For higher-order functions, we firstify them. This requires a uniqu name creation. Here,--- we create a firstified name based on the operation. The suffix appended will have at most uniqLen length.-firstify :: Int -> Op -> String-firstify uniqLen o = prefix o ++ "_" ++ take uniqLen (BC.unpack (B.encode (hash (BC.pack (compress (show o))))))-  where prefix (SeqOp SBVReverse   {}) = "sbv.reverse"-        prefix (SeqOp SBVZip       {}) = "sbv.zip"-        prefix (SeqOp SBVZipWith   {}) = "sbv.zipWith"-        prefix (SeqOp SBVPartition {}) = "sbv.partition"-        prefix (SeqOp SBVMap       {}) = "sbv.map"-        prefix (SeqOp SBVFoldl     {}) = "sbv.foldl"-        prefix (SeqOp SBVFoldr     {}) = "sbv.foldr"-        prefix (SeqOp SBVFilter    {}) = "sbv.filter"-        prefix (SeqOp SBVAll       {}) = "sbv.all"-        prefix (SeqOp SBVAny       {}) = "sbv.any"-        prefix (SeqOp SBVConcat    {}) = "sbv.concat"-        prefix _                       = error $ unlines [ "***"-                                                         , "*** Data.SBV.firstify: Didn't expect firstification to be called."-                                                         , "***"-                                                         , "***   Operator: " ++ show o-                                                         , "***"-                                                         , "*** Please report this as a bug."-                                                         ]--        -- compress and make spaces uniform; get words, and then unwords-        compress = unwords . words- -- | Translate a problem into an SMTLib2 script cvt :: SMTLibConverter ([String], [String]) cvt ctx curProgInfo kindInfo isSat comments allInputs (_, consts) tbls uis defs (SBVPgm asgnsSeq) cstrs out cfg = (pgm, exportedDefs)@@ -106,25 +77,14 @@         hasRational    = any isRational kindInfo         rm             = roundingMode cfg         solverCaps     = capabilities (solver cfg)-        hasLambdas     = let needsLambda SBVZipWith{}   = True-                             needsLambda SBVPartition{} = True-                             needsLambda SBVMap{}       = True-                             needsLambda SBVFoldl{}     = True-                             needsLambda SBVFoldr{}     = True-                             needsLambda SBVFilter{}    = True-                             needsLambda SBVAll{}       = True-                             needsLambda SBVAny{}       = True-                             needsLambda _              = False-                         in (not . null) [() | o :: SeqOp <- G.universeBi allTopOps, needsLambda o] -        (needsQuantifiers, needsSpecialRels, specialFuncs) = case curProgInfo of-           ProgInfo hasQ srs tcs sf -> (hasQ, not (null srs && null tcs), sf)+        (needsQuantifiers, needsSpecialRels) = case curProgInfo of+           ProgInfo hasQ srs tcs -> (hasQ, not (null srs && null tcs))          -- Is there a reason why we can't handle this problem?         -- NB. There's probably a lot more checking we can do here, but this is a start:         doesntHandle = listToMaybe [nope w | (w, have, need) <- checks, need && not (have solverCaps)]            where checks = [ ("data types",             supportsDataTypes,          hasTuples || hasEither || hasMaybe)-                          , ("needs lambdas",          supportsLambdas,            hasLambdas)                           , ("set operations",         supportsSets,               hasSets)                           , ("bit vectors",            supportsBitVectors,         hasBVs)                           , ("special relations",      supportsSpecialRels,        needsSpecialRels)@@ -139,15 +99,17 @@                           , "***     But the chosen solver (" ++ show (name (solver cfg)) ++ ") doesn't support this feature."                           ] -        -- Some cases require all, some require none. Sigh.. Also, if there're lambdas CVC5 needs HO_ALL-        setAll reason = ["(set-logic " ++ allName ++ ") ; "  ++ reason ++ ", using catch-all."]-          where allName | hasLambdas && isCVC5 = "HO_ALL"-                        | True                 = "ALL"+        -- Some cases require all, some require none.+        setAll reason = ["(set-logic " ++ showLogic Logic_ALL ++ ") ; "  ++ reason ++ ", using catch-all."] -                isCVC5 = case name (solver cfg) of-                           CVC5 -> True-                           _    -> False+        isCVC5 = case name (solver cfg) of+                   CVC5 -> True+                   _    -> False +        -- If ALL is selected, use HO_ALL for CVC5 to get support for higher-order features. Yet another discrepancy.+        showLogic Logic_ALL | isCVC5 = "HO_ALL"+        showLogic l                  = show l+         -- Determining the logic is surprisingly tricky!         logic            -- user told us what to do: so just take it:@@ -160,7 +122,7 @@                                                 ]            = case l of                Logic_NONE -> ["; NB. Not setting the logic per user request of Logic_NONE"]-               _          -> ["(set-logic " ++ show l ++ ") ; NB. User specified."]+               _          -> ["(set-logic " ++ showLogic l ++ ") ; NB. User specified."]             -- There's a reason why we can't handle this problem:            | Just cantDo <- doesntHandle@@ -181,7 +143,6 @@            | needsSpecialRels      = ["; has special relations, no logic set."]             -- Things that require ALL-           | hasLambdas            = setAll "has lambda expressions"            | hasInteger            = setAll "has unbounded values"            | hasRational           = setAll "has rational values"            | hasReal               = setAll "has algebraic reals"@@ -275,11 +236,6 @@              ++ map nonConstTable nonConstTables              ++ [ "; --- uninterpreted constants ---" ]              ++ concatMap (declUI curProgInfo) uis-             ++ [ "; --- Firstified function definitions" | not (null specialFuncs) ]-             ++ concat firstifiedDefs-             ++ [ "; --- Firstified equivalences"         | not (null exportedFirstifiedEqualities) ]-             ++ concat exportedFirstifiedEqualities-             ++ [ "; -- NB. Skipping firstified equivalences, due to generateHOEquivs setting." | not (null firstifiedEqualities || generateHOEquivs)]              ++ [ "; --- user defined functions ---"]              ++ userDefs              ++ [ "; --- assignments ---" ]@@ -289,82 +245,6 @@              ++ [ "; --- formula ---" ]              ++ finalAssert -        SMTConfig{generateHOEquivs, kdOptions = KDOptions{firstifyUniqueLen}} = cfg--        (firstifiedDefs, firstifiedFuncs)-           = case dup res of-               Nothing         -> ([def | (_, (_, def)) <- res], [(op, nm) | (op, (nm, _)) <- res])-               Just (o, o', n) -> error $ unlines [ ""-                                                  , "*** Data.SBV: Insufficient unique length in firstification."-                                                  , "***"-                                                  , "***   Operator 1 : " ++ show o-                                                  , "***   Operator 2 : " ++ show o'-                                                  , "***   Mapped name: " ++ n-                                                  , "***   Unique len : " ++ show firstifyUniqueLen-                                                  , "***"-                                                  , "*** Such collisions should be rare, but looks like you ran into one!"-                                                  , "*** Try running with an increased unique-length:"-                                                  , "***"-                                                  , "***     solver{firstifyUniqueLen = N}"-                                                  , "***"-                                                  , "*** where N is larger than " ++ show firstifyUniqueLen-                                                  , "***"-                                                  , "*** For instance:"-                                                  , "***"-                                                  , "***     satWith z3{firstUniqueLen = " ++ show (firstifyUniqueLen + 1) ++ "}"-                                                  , "***"-                                                  , "*** If that doesn't resolve the problem, or if you believe this is caused by some"-                                                  , "*** other problem, please report his as a bug."-                                                  ]-           where res = [(op, declSBVFunc cfg op) | op <- reverse specialFuncs]-                 dup []                = Nothing-                 dup ((o, (n, _)): xs) = case [o' | (o', (n', _)) <- xs, n == n'] of-                                           []       -> dup xs-                                           (o' : _) -> Just (o, o', n)--        exportedFirstifiedEqualities-           | generateHOEquivs-           = firstifiedEqualities-           | True-           = []--        firstifiedEqualities = map equate $ combs firstifiedFuncs-           where combs :: [(Op, String)] -> [(Op, (String, SMTLambda), (String, SMTLambda))]-                 combs []             = []-                 combs ((o1, nm1):fs) = [(o1, (nm1, l1), (nm2, l2)) | (o2, nm2) <- fs, Just (l1, l2) <- [getFuncs o1 o2]] ++ combs fs--                 -- same if the same op sans the lambda-                 getFuncs :: Op -> Op -> Maybe (SMTLambda, SMTLambda)-                 getFuncs (SeqOp (SBVZipWith   a b c f)) (SeqOp (SBVZipWith   x y z g)) | [a, b, c] == [x, y, z] = Just (f, g)-                 getFuncs (SeqOp (SBVPartition a     f)) (SeqOp (SBVPartition x     g)) | [a      ] == [x      ] = Just (f, g)-                 getFuncs (SeqOp (SBVMap       a b   f)) (SeqOp (SBVMap       x y   g)) | [a, b   ] == [x, y   ] = Just (f, g)-                 getFuncs (SeqOp (SBVFoldl     a b   f)) (SeqOp (SBVFoldl     x y   g)) | [a, b   ] == [x, y   ] = Just (f, g)-                 getFuncs (SeqOp (SBVFoldr     a b   f)) (SeqOp (SBVFoldr     x y   g)) | [a, b   ] == [x, y   ] = Just (f, g)-                 getFuncs (SeqOp (SBVFilter    a     f)) (SeqOp (SBVFilter    x     g)) | [a      ] == [x      ] = Just (f, g)-                 getFuncs (SeqOp (SBVAll       a     f)) (SeqOp (SBVAll       x     g)) | [a      ] == [x      ] = Just (f, g)-                 getFuncs (SeqOp (SBVAny       a     f)) (SeqOp (SBVAny       x     g)) | [a      ] == [x      ] = Just (f, g)-                 getFuncs _                              _                                                     = Nothing--                 equate :: (Op, (String, SMTLambda), (String, SMTLambda)) -> [String]-                 equate (o, (nm1, f), (nm2, g)) = [ "; Equality for " ++ nm1 ++ " vs. " ++ nm2-                                                  , "(assert (forall (" ++ decls ++ ")"-                                                  , "                (=> (= " ++ show f ++ " " ++ show g ++ ")"-                                                  , "                    (= (" ++ nm1 ++ " " ++ args ++ ") (" ++ nm2 ++ " " ++ args ++ ")))))"-                                                  ]-                      where params = paramsOf o-                            args   = unwords $ map fst params-                            decls  = unwords ['(' : n ++ " " ++ smtType k ++ ")" | (n, k) <- params]--                            paramsOf (SeqOp (SBVZipWith   k1 k2 _ _)) = [           ("xs", KList k1), ("ys", KList k2)]-                            paramsOf (SeqOp (SBVPartition k1      _)) = [           ("xs", KList k1)]-                            paramsOf (SeqOp (SBVMap       k1    _ _)) = [           ("xs", KList k1)]-                            paramsOf (SeqOp (SBVFoldl     k1 k2   _)) = [("b", k2), ("xs", KList k1)]-                            paramsOf (SeqOp (SBVFoldr     k1 k2   _)) = [("b", k2), ("xs", KList k1)]-                            paramsOf (SeqOp (SBVFilter    k1      _)) = [           ("xs", KList k1)]-                            paramsOf (SeqOp (SBVAll       k1      _)) = [           ("xs", KList k1)]-                            paramsOf (SeqOp (SBVAny       k1      _)) = [           ("xs", KList k1)]-                            paramsOf op                               = error $ "Data.SBV.firstifiedEqualities: Unexpected op: " ++ show op-         userDefs = declUserFuns defs         exportedDefs           | null userDefs@@ -419,179 +299,6 @@                         Just u  | show s /= u -> Just $ "tracks user variable " ++ show u                         _                     -> Nothing --- Declare "known" SBV functions here-declSBVFunc :: SMTConfig -> Op -> (String, [String])-declSBVFunc cfg op = (nm, comment ++ body)-  where nm = firstify (firstifyUniqueLen (kdOptions cfg)) op--        comment = ["; Firstified function: " ++ htyp]--        body = case op of-                 SeqOp (SBVReverse   KString)                -> mkStringRev-                 SeqOp (SBVReverse   (KList k))              -> mkSeqRev    (KList k)-                 SeqOp (SBVZip       k1 k2)                  -> mkZip       k1 k2 Nothing-                 SeqOp (SBVZipWith   k1 k2 k3 (SMTLambda f)) -> mkZip       k1 k2 (Just (k3, f))-                 SeqOp (SBVPartition ek       (SMTLambda f)) -> mkPartition ek f-                 SeqOp (SBVMap       k1 k2    (SMTLambda f)) -> mkMap       k1 k2 f-                 SeqOp (SBVFoldl     k1 k2    (SMTLambda f)) -> mkFoldl     k1 k2 f-                 SeqOp (SBVFoldr     k1 k2    (SMTLambda f)) -> mkFoldr     k1 k2 f-                 SeqOp (SBVFilter    ek       (SMTLambda f)) -> mkFilter    ek    f-                 SeqOp (SBVAll       ek       (SMTLambda f)) -> mkAnyAll    True  ek f-                 SeqOp (SBVAny       ek       (SMTLambda f)) -> mkAnyAll    False ek f-                 SeqOp (SBVConcat    ek)                     -> mkConcat    ek-                 _                                           -> error $ "Data.SBV.declSBVFunc.body: Unexpected internal function: " ++ show (op, nm)--        -- helper when there's no higher order arg-        shf :: String -> [Kind] -> Kind -> String-        shf f args rt = f ++ " :: " ++ intercalate " -> " (map show (args ++ [rt]))--        -- helper when there's a function arg-        shh :: String -> ([Kind], Kind) -> ([Kind], Kind) -> String-        shh f (fargs, fret) (args, rt) = f ++ " :: (" ++ intercalate " -> " (map show (fargs ++ [fret])) ++ ") -> "-                                           ++ intercalate " -> " (map show (args ++ [rt]))--        -- This is the haskell type-        htyp = case op of-                 SeqOp (SBVReverse   KString)   -> shf "reverse"   [KString] KString-                 SeqOp (SBVReverse   k@KList{}) -> shf "reverse"   [k] k-                 SeqOp (SBVZip       a b)       -> shf "zip"       [KList a, KList b] (KList (KTuple [a, b]))-                 SeqOp (SBVZipWith   a b c _)   -> shh "zipWith"   ([a, b], c)  ([KList a, KList b], KList c)-                 SeqOp (SBVPartition a     _)   -> shh "partition" ([a], KBool) ([KList a], KTuple [KList a, KList a])-                 SeqOp (SBVMap       a b   _)   -> shh "map"       ([a], b)     ([KList a], KList b)-                 SeqOp (SBVFoldl     a b   _)   -> shh "foldl"     ([b, a], b)  ([b, KList a], b)-                 SeqOp (SBVFoldr     a b   _)   -> shh "foldr"     ([a, b], b)  ([b, KList a], b)-                 SeqOp (SBVFilter    a     _)   -> shh "filter"    ([a], KBool) ([KList a], KList a)-                 SeqOp (SBVAll       a     _)   -> shh "all"       ([a], KBool) ([KList a], KBool)-                 SeqOp (SBVAny       a     _)   -> shh "any"       ([a], KBool) ([KList a], KBool)-                 SeqOp (SBVConcat    a)         -> shf "concat"    [KList (KList a)] (KList a)-                 _                              -> error $ "Data.SBV.declSBVFunc.htyp: Unexpected internal function: " ++ show (op, nm)--        -- in Z3, lambdas are applied with select. In CVC5, it's @. This might change with higher-order features being added to SMTLib in v3-        par x = "(" ++ x ++ ")"-        app f args = par $ unwords $ f : args--        happ f args | isCVC5 = app "@"      (f : args)-                    | True   = app "select" (f : args)--        hd l = app "seq.nth"     [l, "0"]-        tl l = app "seq.extract" [l, "1", app "-" [app "seq.len" [l], "1"]]--        empty   typ     = app "as seq.empty" [typ]-        isEmpty arg typ = app "=" [arg, empty typ]--        isCVC5 = case name (solver cfg) of-                   CVC5 -> True-                   _    -> False--        mkStringRev = [ "(define-fun-rec " ++ nm ++ " ((str String)) String"-                      , "                (ite (= str \"\")"-                      , "                     \"\""-                      , "                     (str.++ (" ++ nm ++ " (str.substr str 1 (- (str.len str) 1)))"-                      , "                             (str.substr str 0 1))))"-                      ]---        mkSeqRev k = [ "(define-fun-rec " ++ nm ++ " ((lst " ++ t ++ ")) " ++ t-                     , "                (ite " ++ isEmpty "lst" t-                     , "                     " ++ empty t-                     , "                     (seq.++ " ++ app nm [tl "lst"] ++ " (seq.unit " ++ hd "lst" ++ "))))"-                     ]-          where t = smtType k--        -- [a] -> [b] -> [(a, b)]-        -- [a] -> [b] -> (a -> b -> c) -> [c]-        mkZip a b mbcF = [ "(define-fun-rec " ++ nm ++ " ((lst1 " ++ tla ++ ") (lst2 " ++ tlb ++ ")) " ++ tlr-                         , "               (ite " ++ app "or" [isEmpty "lst1" tla, isEmpty "lst2" tlb]-                         , "                    " ++ empty tlr-                         , "                    (seq.++ (seq.unit " ++ mkTup (hd "lst1") (hd "lst2") ++ ") " ++ app nm [tl "lst1", tl "lst2"] ++ ")))"-                         ]-         where tla = smtType (KList a)-               tlb = smtType (KList b)-               tlr = case mbcF of-                       Nothing     -> smtType (KList (KTuple [a, b]))-                       Just (c, _) -> smtType (KList c)--               mkTup x y = case mbcF of-                             Just (_, f) -> happ f   [x, y]-                             Nothing     -> app  tup [x, y]-               tup = app "as" ["mkSBVTuple2", app "SBVTuple2" [smtType a, smtType b]]--        -- (a -> Bool) -> [a] -> ([a], [a])-        mkPartition a f = [ "(define-fun-rec " ++ nm ++ " ((lst " ++ tla ++ ")) " ++ tpla-                          , "                (ite " ++ isEmpty "lst" tla-                          , "                     " ++ base-                          , "                     (let ((a    " ++ hd "lst" ++ "))"-                          , "                     (let ((ua   (seq.unit a)))"-                          , "                     (let ((rest " ++ app nm [tl "lst"] ++ "))"-                          , "                     (let ((ts   (proj_1_SBVTuple2 rest)))"-                          , "                     (let ((fs   (proj_2_SBVTuple2 rest)))"-                          , "                     (ite " ++ happ f [hd "lst"]-                          , "                          " ++ pair "(seq.++ ua ts)" "fs"-                          , "                          " ++ pair "ts" "(seq.++ ua fs)" ++ "))))))))"-                          ]-           where tla  = smtType (KList a)-                 tpla = smtType (KTuple [KList a, KList a])-                 base       = "(mkSBVTuple2 (as seq.empty " ++ tla ++ ") (as seq.empty " ++ tla ++ "))"-                 pair ts fs = "((as mkSBVTuple2 (SBVTuple2 " ++ tla ++ " " ++ tla ++ ")) " ++ ts ++ " " ++ fs ++ ")"--        -- (b -> a -> b) -> b -> [a] -> b-        mkFoldl a b f = [ "(define-fun-rec " ++ nm ++ " ((base " ++ tb ++ ") (lst " ++ tla ++ ")) " ++ tb-                        , "                (ite " ++ isEmpty "lst" tla-                        , "                     base"-                        , "                     " ++ app nm [happ f ["base", hd "lst"], tl "lst"] ++ "))"-                        ]-           where tla = smtType (KList a)-                 tb  = smtType b--        -- (a -> b -> b) -> b -> [a] -> b-        mkFoldr a b f = [ "(define-fun-rec " ++ nm ++ " ((base " ++ tb ++ ") (lst " ++ tla ++ ")) " ++ tb-                        , "                (ite " ++ isEmpty "lst" tla-                        , "                     base"-                        , "                     " ++ happ f [hd "lst", app nm ["base", tl "lst"]] ++ "))"-                        ]-           where tla = smtType (KList a)-                 tb  = smtType b--        -- (a -> b) -> [a] -> [b]-        mkMap a b f = [ "(define-fun-rec " ++ nm ++ " ((lst " ++ tla ++ ")) " ++ tlb-                      , "              (ite " ++ isEmpty "lst" tla-                      , "                   " ++ empty tlb-                      , "                   (seq.++ (seq.unit " ++ happ f [hd "lst"] ++ ")"-                      , "                           " ++ app nm [tl "lst"] ++ ")))"-                      ]-           where tla = smtType (KList a)-                 tlb = smtType (KList b)--        -- (a -> Bool) -> [a] -> [a]-        mkFilter a f = [ "(define-fun-rec " ++ nm ++ " ((lst " ++ tla ++ ")) " ++ tla-                       , "                (ite " ++ isEmpty "lst" tla-                       , "                     " ++ empty tla-                       , "                     (let ((rest (" ++ nm ++ " " ++ tl "lst" ++ ")))"-                       , "                          (ite " ++ happ f [hd "lst"]-                       , "                               (seq.++ (seq.unit " ++ hd "lst" ++ ") rest)"-                       , "                                       rest))))"-                       ]-          where tla = smtType (KList a)--        -- (a -> Bool) -> [a] -> Bool-        mkAnyAll isAll a f = [ "(define-fun-rec " ++ nm ++ " ((lst " ++ tla ++ ")) Bool"-                             , "                (ite " ++ isEmpty "lst" tla-                             , "                     " ++ base-                             , "                     " ++ app conn [happ f [hd "lst"], app nm [tl "lst"]] ++ "))"-                             ]-          where tla = smtType (KList a)-                (base, conn) | isAll = ("true",  "and")-                             | True  = ("false", "or")--        -- [[a]] -> [a]-        mkConcat a = [ "(define-fun-rec " ++ nm ++ " ((lst " ++ tlla ++ ")) " ++ tla-                     , "                (ite " ++ isEmpty "lst" tlla-                     , "                     " ++ empty tla-                     , "                     (seq.++ " ++ hd "lst" ++ " (" ++ nm ++ " " ++ tl "lst" ++ "))))"-                     ]-         where tla  = smtType (KList a)-               tlla = smtType (KList (KList a))- -- | Declare new sorts declSort :: (String, Maybe [String]) -> [String] declSort (s, _)@@ -816,28 +523,11 @@  -- Note that even though we get all user defined-functions here (i.e., lambda and axiom), we can only have defined-functions -- and axioms. We spit axioms as is; and topologically sort the definitions.-declUserFuns :: [(SMTDef, SBVType)] -> [String]-declUserFuns ds-  | not (null lambdas)-  = error $ unlines $ "Data.SBV.declUserFuns: Unexpected anonymous functions in declDef:" : map show lambdas-  | True-  = declFuncs others-  where (lambdas, others) = partition (isLam . fst) ds-        isLam SMTLam{} = True-        isLam SMTDef{} = False---- We need to topologically sort the user given definitions and axioms and put them in the proper order and construct.--- Note that there are no anonymous functions at this level.-declFuncs :: [(SMTDef, SBVType)] -> [String]-declFuncs ds = map declGroup sorted-  where mkNode d = (d, getKey d, getDeps d)--        getKey (d, _) = case d of-                         SMTDef n _ _ _ _ -> n-                         SMTLam{}         -> error $ "Data.SBV.declFuns: Unexpected definition kind: " ++ show d+declUserFuns :: [(String, (SMTDef, SBVType))] -> [String]+declUserFuns ds = map declGroup sorted+  where mkNode d = (d, fst d, getDeps d) -        getDeps (SMTDef _ _ d _ _, _) = d-        getDeps (l@SMTLam{}, t)       = error $ "Data.SBV.declFuns: Unexpected definition: " ++ show (l, t)+        getDeps (_, (SMTDef _ d _ _, _)) = d          mkDecl Nothing  rt = "() "    ++ rt         mkDecl (Just p) rt = p ++ " " ++ rt@@ -850,8 +540,7 @@                                          [x] -> declUserDef True x                                          xs  -> declUserDefMulti xs -        declUserDef _ d@(SMTLam{}, _) = error $ "Data.SBV.declFuns: Unexpected anonymous lambda in user-defined functions: " ++ show d-        declUserDef isRec (SMTDef nm fk deps param body, ty) = ("; " ++ nm ++ " :: " ++ show ty ++ recursive ++ frees ++ "\n") ++ s+        declUserDef isRec (nm, (SMTDef fk deps param body, ty)) = ("; " ++ nm ++ " :: " ++ show ty ++ recursive ++ frees ++ "\n") ++ s            where (recursive, definer) | isRec = (" [Recursive]", "define-fun-rec")                                       | True  = ("",             "define-fun") @@ -865,8 +554,7 @@          -- declare a bunch of mutually-recursive functions         declUserDefMulti bs = render $ map collect bs-          where collect d@(SMTLam{}, _) = error $ "Data.SBV.declFuns: Unexpected lambda in user-defined mutual-recursion group: " ++ show d-                collect (SMTDef nm fk deps param body, ty) = (deps, nm, ty, '(' : nm ++ " " ++  decl ++ ")", body 3)+          where collect (nm, (SMTDef fk deps param body, ty)) = (deps, nm, ty, '(' : nm ++ " " ++  decl ++ ")", body 3)                   where decl = mkDecl param (smtType fk)                  render defs = intercalate "\n" $@@ -1107,8 +795,6 @@                 ps      = " (" ++ unwords (map smtType params) ++ ") "                 aResult = "(_ is (" ++ fld ++ ps ++ smtType res ++ "))" -        firstifiedName = firstify (firstifyUniqueLen (kdOptions cfg))-         sh (SBVApp Ite [a, b, c]) = "(ite " ++ cvtSV a ++ " " ++ cvtSV b ++ " " ++ cvtSV c ++ ")"          sh (SBVApp (LkUp (t, aKnd, _, l) i e) [])@@ -1254,28 +940,15 @@          -- Note the unfortunate reversal in StrInRe..         sh (SBVApp (StrOp (StrInRe r)) args) = "(str.in.re " ++ unwords (map cvtSV args) ++ " " ++ regExpToSMTString r ++ ")"-        -- StrUnit is no-op, since a character in SMTLib is the same as a string-        sh (SBVApp (StrOp StrUnit)     [a])  = cvtSV a         sh (SBVApp (StrOp op)          args) = "(" ++ show op ++ " " ++ unwords (map cvtSV args) ++ ")"          sh (SBVApp (RegExOp o@RegExEq{})  []) = show o         sh (SBVApp (RegExOp o@RegExNEq{}) []) = show o -        -- Reverse and higher order functions are special-        sh (SBVApp o@(SeqOp SBVReverse{})   args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVZip{})       args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVZipWith{})   args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVPartition{}) args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVReverse{})   args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVMap{})       args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVFoldl{})     args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVFoldr{})     args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVFilter{})    args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVAll{} )      args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVAny{} )      args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"-        sh (SBVApp o@(SeqOp SBVConcat{})    args) = "(" ++ firstifiedName o ++ " " ++ unwords (map cvtSV args) ++ ")"--        sh (SBVApp (SeqOp op) args) = "(" ++ show op ++ " " ++ unwords (map cvtSV args) ++ ")"+        -- Sequences. The only interesting thing here is that unit over KChar is a no-op since SMTLib doesn't distinguish+        -- Strings and Characters, but SBV does.+        sh (SBVApp (SeqOp (SeqUnit KChar)) [a]) = cvtSV a+        sh (SBVApp (SeqOp op)             args) = "(" ++ show op ++ " " ++ unwords (map cvtSV args) ++ ")"          sh (SBVApp (SetOp SetEqual)      args)   = "(= "      ++ unwords (map cvtSV args) ++ ")"         sh (SBVApp (SetOp SetMember)     [e, s]) = "(select " ++ cvtSV s ++ " " ++ cvtSV e ++ ")"
Data/SBV/SMT/Utils.hs view
@@ -67,7 +67,7 @@                        -> (CnstMap, [(SV, CV)])                          -- ^ constants. The map, and as rendered in order                        -> [((Int, Kind, Kind), [SV])]                    -- ^ auto-generated tables                        -> [(String, (Bool, Maybe [String], SBVType))]    -- ^ uninterpreted functions/constants-                       -> [(SMTDef, SBVType)]                            -- ^ user given axioms/definitions+                       -> [(String, (SMTDef, SBVType))]                  -- ^ user given axioms/definitions                        -> SBVPgm                                         -- ^ assignments                        -> S.Seq (Bool, [(String, String)], SV)           -- ^ extra constraints                        -> SV                                             -- ^ output variable
Data/SBV/Set.hs view
@@ -499,7 +499,7 @@         ka = kindOf (Proxy @a)  -- | Synonym for 'Data.SBV.Set.difference'.-infixl 9 \\  -- This comment avoids CPP to eat up the trailing backspace in this line  Do not remove!+infix 5 \\  -- This comment avoids CPP to eat up the trailing backspace in this line  Do not remove! (\\) :: (Ord a, SymVal a) => SSet a -> SSet a -> SSet a (\\) = difference
− Data/SBV/String.hs 
@@ -1,440 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Data.SBV.String--- Copyright : (c) Joel Burget---                 Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ A collection of string/character utilities, useful when working--- with symbolic strings. To the extent possible, the functions--- in this module follow those of "Data.List" so importing qualified--- is the recommended workflow. Also, it is recommended you use the--- @OverloadedStrings@ extension to allow literal strings to be--- used as symbolic-strings.--------------------------------------------------------------------------------{-# LANGUAGE CPP                 #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE Rank2Types          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.String (-        -- * Length, emptiness-          length, null-        -- * Deconstructing/Reconstructing-        , head, tail, uncons, init, singleton, strToStrAt, strToCharAt, (!!), implode, concat, (.:), snoc, nil, (++)-        -- * Containment-        , isInfixOf, isSuffixOf, isPrefixOf-        -- * Substrings-        , take, drop, subStr, replace, indexOf, offsetIndexOf-        -- * Reverse-        , reverse-        -- * Conversion to\/from naturals-        , strToNat, natToStr-        ) where--import Prelude hiding (head, tail, init, length, take, drop, concat, null, reverse, (++), (!!))-import qualified Prelude as P--import Data.SBV.Core.Data hiding (SeqOp(..))-import Data.SBV.Core.Model-import Data.SBV.Core.Data (SeqOp(SBVReverse))-import Data.SBV.Core.Symbolic (registerSpecialFunction)--import qualified Data.Char as C-import Data.List (genericLength, genericIndex, genericDrop, genericTake)-import qualified Data.List as L (tails, isSuffixOf, isPrefixOf, isInfixOf)--import Data.Proxy--#ifdef DOCTEST--- $setup--- >>> import Data.SBV--- >>> import Prelude hiding (head, tail, init, length, take, drop, concat, null, reverse, (++), (!!))--- >>> :set -XOverloadedStrings-#endif---- | Length of a string.------ >>> sat $ \s -> length s .== 2--- Satisfiable. Model:---   s0 = "BA" :: String--- >>> sat $ \s -> length s .< 0--- Unsatisfiable--- >>> prove $ \s1 s2 -> length s1 + length s2 .== length (s1 ++ s2)--- Q.E.D.-length :: SString -> SInteger-length = lift1 StrLen (Just (fromIntegral . P.length))---- | @`null` s@ is True iff the string is empty------ >>> prove $ \s -> null s .<=> length s .== 0--- Q.E.D.--- >>> prove $ \s -> null s .<=> s .== ""--- Q.E.D.-null :: SString -> SBool-null s-  | Just cs <- unliteral s-  = literal (P.null cs)-  | True-  = s .== literal ""---- | @`head`@ returns the head of a string. Unspecified if the string is empty.------ >>> prove $ \c -> head (singleton c) .== c--- Q.E.D.-head :: SString -> SChar-head = (`strToCharAt` 0)---- | @`tail`@ returns the tail of a string. Unspecified if the string is empty.------ >>> prove $ \h s -> tail (singleton h ++ s) .== s--- Q.E.D.--- >>> prove $ \s -> length s .> 0 .=> length (tail s) .== length s - 1--- Q.E.D.--- >>> prove $ \s -> sNot (null s) .=> singleton (head s) ++ tail s .== s--- Q.E.D.-tail :: SString -> SString-tail s- | Just (_:cs) <- unliteral s- = literal cs- | True- = subStr s 1 (length s - 1)---- | @`uncons`@ returns the pair of the first character and tail. Unspecified if the string is empty.-uncons :: SString -> (SChar, SString)-uncons l = (head l, tail l)---- | @`init`@ returns all but the last element of the list. Unspecified if the string is empty.------ >>> prove $ \c t -> init (t ++ singleton c) .== t--- Q.E.D.-init :: SString -> SString-init s- | Just cs@(_:_) <- unliteral s- = literal $ P.init cs- | True- = subStr s 0 (length s - 1)---- | @`singleton` c@ is the string of length 1 that contains the only character @c@.------ >>> prove $ \c -> c .== literal 'A' .=> singleton c .== "A"--- Q.E.D.--- >>> prove $ \c -> length (singleton c) .== 1--- Q.E.D.-singleton :: SChar -> SString-singleton = lift1 StrUnit (Just wrap)-  where wrap c = [c]---- | @`strToStrAt` s offset@. Substring of length 1 at @offset@ in @s@. Unspecified if--- offset is out of bounds.------ >>> prove $ \s1 s2 -> strToStrAt (s1 ++ s2) (length s1) .== strToStrAt s2 0--- Q.E.D.--- >>> sat $ \s -> length s .>= 2 .&& strToStrAt s 0 ./= strToStrAt s (length s - 1)--- Satisfiable. Model:---   s0 = "AB" :: String-strToStrAt :: SString -> SInteger -> SString-strToStrAt s offset = subStr s offset 1---- | @`strToCharAt` s i@ is the character stored at location @i@. Unspecified if--- index is out of bounds.------ >>> prove $ \i -> i .>= 0 .&& i .<= 4 .=> "AAAAA" `strToCharAt` i .== literal 'A'--- Q.E.D.-strToCharAt :: SString -> SInteger -> SChar-strToCharAt s i-  | Just cs <- unliteral s, Just ci <- unliteral i, ci >= 0, ci < genericLength cs, let c = C.ord (cs `genericIndex` ci)-  = literal (C.chr c)-  | True-  = lift2 StrNth Nothing s i---- | Short cut for 'strToCharAt'-(!!) :: SString -> SInteger -> SChar-(!!) = strToCharAt---- | @`implode` cs@ is the string of length @|cs|@ containing precisely those--- characters. Note that there is no corresponding function @explode@, since--- we wouldn't know the length of a symbolic string.------ >>> prove $ \c1 c2 c3 -> length (implode [c1, c2, c3]) .== 3--- Q.E.D.--- >>> prove $ \c1 c2 c3 -> map (strToCharAt (implode [c1, c2, c3])) (map literal [0 .. 2]) .== [c1, c2, c3]--- Q.E.D.-implode :: [SChar] -> SString-implode = foldr ((++) . singleton) ""---- | Prepend an element, the traditional @cons@.-infixr 5 .:-(.:) :: SChar -> SString -> SString-c .: cs = singleton c ++ cs---- | Append an element-snoc :: SString -> SChar -> SString-s `snoc` c = s ++ singleton c---- | Empty string. This value has the property that it's the only string with length 0:------ >>> prove $ \l -> length l .== 0 .<=> l .== nil--- Q.E.D.-nil :: SString-nil = ""---- | Concatenate two strings. See also `++`.-concat :: SString -> SString -> SString-concat x y | isConcretelyEmpty x = y-           | isConcretelyEmpty y = x-           | True                = lift2 StrConcat (Just (P.++)) x y---- | Short cut for `concat`.------ >>> sat $ \x y z -> length x .== 5 .&& length y .== 1 .&& x ++ y ++ z .== "Hello world!"--- Satisfiable. Model:---   s0 =  "Hello" :: String---   s1 =      " " :: String---   s2 = "world!" :: String-infixr 5 ++-(++) :: SString -> SString -> SString-(++) = concat---- | @`isInfixOf` sub s@. Does @s@ contain the substring @sub@?------ >>> prove $ \s1 s2 s3 -> s2 `isInfixOf` (s1 ++ s2 ++ s3)--- Q.E.D.--- >>> prove $ \s1 s2 -> s1 `isInfixOf` s2 .&& s2 `isInfixOf` s1 .<=> s1 .== s2--- Q.E.D.-isInfixOf :: SString -> SString -> SBool-sub `isInfixOf` s-  | isConcretelyEmpty sub-  = literal True-  | True-  = lift2 StrContains (Just (flip L.isInfixOf)) s sub -- NB. flip, since `StrContains` takes args in rev order!---- | @`isPrefixOf` pre s@. Is @pre@ a prefix of @s@?------ >>> prove $ \s1 s2 -> s1 `isPrefixOf` (s1 ++ s2)--- Q.E.D.--- >>> prove $ \s1 s2 -> s1 `isPrefixOf` s2 .=> subStr s2 0 (length s1) .== s1--- Q.E.D.-isPrefixOf :: SString -> SString -> SBool-pre `isPrefixOf` s-  | isConcretelyEmpty pre-  = literal True-  | True-  = lift2 StrPrefixOf (Just L.isPrefixOf) pre s---- | @`isSuffixOf` suf s@. Is @suf@ a suffix of @s@?------ >>> prove $ \s1 s2 -> s2 `isSuffixOf` (s1 ++ s2)--- Q.E.D.--- >>> prove $ \s1 s2 -> s1 `isSuffixOf` s2 .=> subStr s2 (length s2 - length s1) (length s1) .== s1--- Q.E.D.-isSuffixOf :: SString -> SString -> SBool-suf `isSuffixOf` s-  | isConcretelyEmpty suf-  = literal True-  | True-  = lift2 StrSuffixOf (Just L.isSuffixOf) suf s---- | @`take` len s@. Corresponds to Haskell's `take` on symbolic-strings.------ >>> prove $ \s i -> i .>= 0 .=> length (take i s) .<= i--- Q.E.D.-take :: SInteger -> SString -> SString-take i s = ite (i .<= 0)        (literal "")-         $ ite (i .>= length s) s-         $ subStr s 0 i---- | @`drop` len s@. Corresponds to Haskell's `drop` on symbolic-strings.------ >>> prove $ \s i -> length (drop i s) .<= length s--- Q.E.D.--- >>> prove $ \s i -> take i s ++ drop i s .== s--- Q.E.D.-drop :: SInteger -> SString -> SString-drop i s = ite (i .>= ls) (literal "")-         $ ite (i .<= 0)  s-         $ subStr s i (ls - i)-  where ls = length s---- | @`subStr` s offset len@ is the substring of @s@ at offset @offset@ with length @len@.--- This function is under-specified when the offset is outside the range of positions in @s@ or @len@--- is negative or @offset+len@ exceeds the length of @s@.------ >>> prove $ \s i -> i .>= 0 .&& i .< length s .=> subStr s 0 i ++ subStr s i (length s - i) .== s--- Q.E.D.--- >>> sat  $ \i j -> subStr "hello" i j .== "ell"--- Satisfiable. Model:---   s0 = 1 :: Integer---   s1 = 3 :: Integer--- >>> sat  $ \i j -> subStr "hell" i j .== "no"--- Unsatisfiable-subStr :: SString -> SInteger -> SInteger -> SString-subStr s offset len-  | Just c <- unliteral s                    -- a constant string-  , Just o <- unliteral offset               -- a constant offset-  , Just l <- unliteral len                  -- a constant length-  , let lc = genericLength c                 -- length of the string-  , let valid x = x >= 0 && x <= lc          -- predicate that checks valid point-  , valid o                                  -- offset is valid-  , l >= 0                                   -- length is not-negative-  , valid $ o + l                            -- we don't overrun-  = literal $ genericTake l $ genericDrop o c-  | True                                     -- either symbolic, or something is out-of-bounds-  = lift3 StrSubstr Nothing s offset len---- | @`replace` s src dst@. Replace the first occurrence of @src@ by @dst@ in @s@------ >>> prove $ \s -> replace "hello" s "world" .== "world" .=> s .== "hello"--- Q.E.D.--- >>> prove $ \s1 s2 s3 -> length s2 .> length s1 .=> replace s1 s2 s3 .== s1--- Q.E.D.-replace :: SString -> SString -> SString -> SString-replace s src dst-  | Just b <- unliteral src, P.null b   -- If src is null, simply prepend-  = dst ++ s-  | Just a <- unliteral s-  , Just b <- unliteral src-  , Just c <- unliteral dst-  = literal $ walk a b c-  | True-  = lift3 StrReplace Nothing s src dst-  where walk haystack needle newNeedle = go haystack   -- note that needle is guaranteed non-empty here.-           where go []       = []-                 go i@(c:cs)-                  | needle `L.isPrefixOf` i = newNeedle P.++ genericDrop (genericLength needle :: Integer) i-                  | True                    = c : go cs---- | @`indexOf` s sub@. Retrieves first position of @sub@ in @s@, @-1@ if there are no occurrences.--- Equivalent to @`offsetIndexOf` s sub 0@.------ >>> prove $ \s1 s2 -> length s2 .> length s1 .=> indexOf s1 s2 .== -1--- Q.E.D.-indexOf :: SString -> SString -> SInteger-indexOf s sub = offsetIndexOf s sub 0---- | @`offsetIndexOf` s sub offset@. Retrieves first position of @sub@ at or--- after @offset@ in @s@, @-1@ if there are no occurrences.------ >>> prove $ \s sub -> offsetIndexOf s sub 0 .== indexOf s sub--- Q.E.D.--- >>> prove $ \s sub i -> i .>= length s .&& length sub .> 0 .=> offsetIndexOf s sub i .== -1--- Q.E.D.--- >>> prove $ \s sub i -> i .> length s .=> offsetIndexOf s sub i .== -1--- Q.E.D.-offsetIndexOf :: SString -> SString -> SInteger -> SInteger-offsetIndexOf s sub offset-  | Just c <- unliteral s               -- a constant string-  , Just n <- unliteral sub             -- a constant search pattern-  , Just o <- unliteral offset          -- at a constant offset-  , o >= 0, o <= genericLength c        -- offset is good-  = case [i | (i, t) <- zip [o ..] (L.tails (genericDrop o c)), n `L.isPrefixOf` t] of-      (i:_) -> literal i-      _     -> -1-  | True-  = lift3 StrIndexOf Nothing s sub offset---- | @`reverse` s@ reverses the string.--- >>> sat $ \s -> reverse s .== "abc"--- Satisfiable. Model:---   s0 = "cba" :: String--- >>> prove $ \s -> reverse s .== "" .<=> null s--- Q.E.D.-reverse :: SString -> SString-reverse s-  | Just s' <- unliteral s-  = literal (P.reverse s')-  | True-  = SBV $ SVal KString $ Right $ cache r-  where r st = do sva <- sbvToSV st s-                  let op = SeqOp (SBVReverse KString)-                  registerSpecialFunction st op-                  newExpr st KString (SBVApp op [sva])---- | @`strToNat` s@. Retrieve integer encoded by string @s@ (ground rewriting only).--- Note that by definition this function only works when @s@ only contains digits,--- that is, if it encodes a natural number. Otherwise, it returns '-1'.------ >>> prove $ \s -> let n = strToNat s in length s .== 1 .=> (-1) .<= n .&& n .<= 9--- Q.E.D.-strToNat :: SString -> SInteger-strToNat s- | Just a <- unliteral s- = if all C.isDigit a && not (P.null a)-   then literal (read a)-   else -1- | True- = lift1 StrStrToNat Nothing s---- | @`natToStr` i@. Retrieve string encoded by integer @i@ (ground rewriting only).--- Again, only naturals are supported, any input that is not a natural number--- produces empty string, even though we take an integer as an argument.------ >>> prove $ \i -> length (natToStr i) .== 3 .=> i .<= 999--- Q.E.D.-natToStr :: SInteger -> SString-natToStr i- | Just v <- unliteral i- = literal $ if v >= 0 then show v else ""- | True- = lift1 StrNatToStr Nothing i---- | Lift a unary operator over strings.-lift1 :: forall a b. (SymVal a, SymVal b) => StrOp -> Maybe (a -> b) -> SBV a -> SBV b-lift1 w mbOp a-  | Just cv <- concEval1 mbOp a-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where k = kindOf (Proxy @b)-        r st = do sva <- sbvToSV st a-                  newExpr st k (SBVApp (StrOp w) [sva])---- | Lift a binary operator over strings.-lift2 :: forall a b c. (SymVal a, SymVal b, SymVal c) => StrOp -> Maybe (a -> b -> c) -> SBV a -> SBV b -> SBV c-lift2 w mbOp a b-  | Just cv <- concEval2 mbOp a b-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where k = kindOf (Proxy @c)-        r st = do sva <- sbvToSV st a-                  svb <- sbvToSV st b-                  newExpr st k (SBVApp (StrOp w) [sva, svb])---- | Lift a ternary operator over strings.-lift3 :: forall a b c d. (SymVal a, SymVal b, SymVal c, SymVal d) => StrOp -> Maybe (a -> b -> c -> d) -> SBV a -> SBV b -> SBV c -> SBV d-lift3 w mbOp a b c-  | Just cv <- concEval3 mbOp a b c-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where k = kindOf (Proxy @d)-        r st = do sva <- sbvToSV st a-                  svb <- sbvToSV st b-                  svc <- sbvToSV st c-                  newExpr st k (SBVApp (StrOp w) [sva, svb, svc])---- | Concrete evaluation for unary ops-concEval1 :: (SymVal a, SymVal b) => Maybe (a -> b) -> SBV a -> Maybe (SBV b)-concEval1 mbOp a = literal <$> (mbOp <*> unliteral a)---- | Concrete evaluation for binary ops-concEval2 :: (SymVal a, SymVal b, SymVal c) => Maybe (a -> b -> c) -> SBV a -> SBV b -> Maybe (SBV c)-concEval2 mbOp a b = literal <$> (mbOp <*> unliteral a <*> unliteral b)---- | Concrete evaluation for ternary ops-concEval3 :: (SymVal a, SymVal b, SymVal c, SymVal d) => Maybe (a -> b -> c -> d) -> SBV a -> SBV b -> SBV c -> Maybe (SBV d)-concEval3 mbOp a b c = literal <$> (mbOp <*> unliteral a <*> unliteral b <*> unliteral c)---- | Is the string concretely known empty?-isConcretelyEmpty :: SString -> Bool-isConcretelyEmpty ss | Just s <- unliteral ss = P.null s-                     | True                   = False--{- HLint ignore implode "Use concatMap" -}
+ Data/SBV/TP.hs view
@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.TP+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- A lightweight theorem proving like interface, built on top of SBV.+-- Originally inspired by Philip Zucker's tool KnuckleDragger+-- see <http://github.com/philzook58/knuckledragger>, though SBV's+-- version is different in its scope and design significantly.+--+-- See the directory Documentation.SBV.Examples.TP for various examples.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.TP (+       -- * Propositions and their proofs+         Proposition, Proof, proofOf, assumptionFromProof++       -- * Getting the proof tree+       , rootOfTrust, RootOfTrust(..), ProofTree(..), showProofTree, showProofTreeHTML++       -- * Adding axioms/definitions+       , axiom++       -- * Basic proofs+       , lemma, lemmaWith++       -- * Reasoning via calculation+       , calc, calcWith++       -- * Reasoning via regular induction+       , induct, inductWith++       -- * Reasoning via measure-based strong induction+       , sInduct, sInductWith++       -- * Creating instances of proofs+       , at, Inst(..)++       -- * Faking proofs+       , sorry++       -- * Running TP proofs+       , TP, runTP, runTPWith, tpQuiet, tpRibbon, tpStats, tpCache++       -- * Starting a calculation proof+       , (|-), (⊢)++       -- * Sequence of calculation steps+       , (=:), (≡)++       -- * Supplying hints for a calculation step+       , (??), (∵)++       -- * Using quickcheck+       , qc, qcWith++       -- * Case splits+       , split, split2, cases, (⟹), (==>)++       -- * Finishing up a calculational proof+       , qed, trivial, contradiction++       -- * Displaying intermediate values of expressions+       , disp+       ) where++import Data.SBV.TP.TP
+ Data/SBV/TP/Kernel.hs view
@@ -0,0 +1,188 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.TP.Kernel+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Kernel of the TP prover API.+-----------------------------------------------------------------------------++{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeAbstractions     #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.TP.Kernel (+         Proposition,  Proof(..)+       , axiom+       , lemma+       , lemmaWith+       , internalAxiom+       , TPProofContext (..), smtProofStep+       ) where++import Control.Monad.Trans  (liftIO, MonadIO)++import Data.List  (intercalate)+import Data.Maybe (catMaybes)++import Data.SBV.Core.Data     hiding (None)+import Data.SBV.Trans.Control hiding (getProof)+import Data.SBV.Core.Symbolic (MonadSymbolic)++import Data.SBV.SMT.SMT+import Data.SBV.Core.Model+import Data.SBV.Provers.Prover++import Data.SBV.TP.Utils++import Data.Time (NominalDiffTime)+import Data.SBV.Utils.TDiff++import Data.Dynamic++-- | A proposition is something SBV is capable of proving/disproving in TP.+type Proposition a = ( QNot a+                     , QuantifiedBool a+                     , QSaturate Symbolic a+                     , Skolemize (NegatesTo a)+                     , Satisfiable (Symbolic (SkolemsTo (NegatesTo a)))+                     , Constraint  Symbolic  (SkolemsTo (NegatesTo a))+                     , Typeable a+                     )++-- | Accept the given definition as a fact. Usually used to introduce definitial axioms,+-- giving meaning to uninterpreted symbols. Note that we perform no checks on these propositions,+-- if you assert nonsense, then you get nonsense back. So, calls to 'axiom' should be limited to+-- definitions, or basic axioms (like commutativity, associativity) of uninterpreted function symbols.+axiom :: Proposition a => String -> a -> TP (Proof a)+axiom nm p = do cfg <- getTPConfig+                u   <- tpGetNextUnique+                _   <- liftIO $ startTP cfg True "Axiom" 0 (TPProofOneShot nm [])+                let Proof iax = internalAxiom nm p+                pure $ Proof (iax { isUserAxiom = True, uniqId = u })++-- | Internal axiom generator; so we can keep truck of TP's trusted axioms, vs. user given axioms.+internalAxiom :: Proposition a => String -> a -> Proof a+internalAxiom nm p = Proof $ ProofObj { dependencies = []+                                      , isUserAxiom  = False+                                      , getObjProof  = label nm (quantifiedBool p)+                                      , getProp      = toDyn p+                                      , proofName    = nm+                                      , uniqId       = TPInternal+                                      , isCached     = False+                                      }++-- | Prove a lemma, using the given configuration+lemmaWith :: Proposition a => SMTConfig -> String -> a -> [ProofObj] -> TP (Proof a)+lemmaWith cfg@SMTConfig{tpOptions = TPOptions{printStats}} nm inputProp by = withProofCache nm $ do+                 tpSt <- getTPState+                 u    <- tpGetNextUnique+                 liftIO $ getTimeStampIf printStats >>= runSMTWith cfg . go tpSt u+  where go tpSt u mbStartTime = do qSaturateSavingObservables inputProp+                                   mapM_ (constrain . getObjProof) by+                                   query $ smtProofStep cfg tpSt "Lemma" 0 (TPProofOneShot nm by) Nothing inputProp [] (good mbStartTime u)++        -- What to do if all goes well+        good mbStart u d = do mbElapsed <- getElapsedTime mbStart+                              liftIO $ finishTP cfg ("Q.E.D." ++ concludeModulo by) d $ catMaybes [mbElapsed]+                              pure $ Proof $ ProofObj { dependencies = by+                                                      , isUserAxiom  = False+                                                      , getObjProof  = label nm (quantifiedBool inputProp)+                                                      , getProp      = toDyn inputProp+                                                      , proofName    = nm+                                                      , uniqId       = u+                                                      , isCached     = False+                                                      }++-- | Prove a given statement, using auxiliaries as helpers. Using the default solver.+lemma :: Proposition a => String -> a -> [ProofObj] -> TP (Proof a)+lemma nm f by = do cfg <- getTPConfig+                   lemmaWith cfg nm f by++-- | Capture the general flow of a proof-step. Note that this is the only point where we call the backend solver+-- in a TP proof.+smtProofStep :: (SolverContext m, MonadIO m, MonadQuery m, MonadSymbolic m, Proposition a)+   => SMTConfig                              -- ^ config+   -> TPState                                -- ^ TPState+   -> String                                 -- ^ tag+   -> Int                                    -- ^ level+   -> TPProofContext                         -- ^ the context in which we're doing the proof+   -> Maybe SBool                            -- ^ Assumptions under which we do the check-sat. If there's one we'll push/pop+   -> a                                      -- ^ what we want to prove+   -> [(String, SVal)]                       -- ^ Values to display in case of failure+   -> ((Int, Maybe NominalDiffTime) -> IO r) -- ^ what to do when unsat, with the tab amount and time elapsed (if asked)+   -> m r+smtProofStep cfg@SMTConfig{verbose, tpOptions = TPOptions{printStats}} tpState tag level ctx mbAssumptions prop disps unsat = do++        case mbAssumptions of+           Nothing  -> do queryDebug ["; smtProofStep: No context value to push."]+                          check+           Just asm -> do queryDebug ["; smtProofStep: Pushing in the context: " ++ show asm]+                          inNewAssertionStack $ do constrain asm+                                                   check++ where check = do+           tab <- liftIO $ startTP cfg verbose tag level ctx++           -- It's tempting to skolemize here.. But skolemization creates fresh constants+           -- based on the name given, and they mess with all else. So, don't skolemize!+           constrain $ sNot (quantifiedBool prop)++           (mbT, r) <- timeIf printStats checkSat++           updStats tpState (\s -> s{noOfCheckSats = noOfCheckSats s + 1})++           case mbT of+             Nothing -> pure ()+             Just t  -> updStats tpState (\s -> s{solverElapsed = solverElapsed s + t})++           case r of+             Unk    -> unknown+             Sat    -> cex+             DSat{} -> cex+             Unsat  -> liftIO $ unsat (tab, mbT)++       die = error "Failed"++       fullNm = case ctx of+                  TPProofOneShot       s _    -> s+                  TPProofStep    True  s _ ss -> "assumptions for " ++ intercalate "." (s : ss)+                  TPProofStep    False s _ ss ->                       intercalate "." (s : ss)++       unknown = do r <- getUnknownReason+                    liftIO $ do putStrLn $ "\n*** Failed to prove " ++ fullNm ++ "."+                                putStrLn $ "\n*** Solver reported: " ++ show r+                                die++       -- What to do if the proof fails+       cex = do+         liftIO $ putStrLn $ "\n*** Failed to prove " ++ fullNm ++ "."++         res <- case ctx of+                  TPProofStep{} -> do mapM_ (uncurry sObserve) disps+                                      Satisfiable cfg <$> getModel+                  TPProofOneShot _ by ->+                     -- When trying to get a counter-example not in query mode, we+                     -- do a skolemized sat call, which gets better counter-examples.+                     -- We only include the those facts that are user-given axioms. This+                     -- way our counter-example will be more likely to be relevant+                     -- to the proposition we're currently proving. (Hopefully.)+                     -- Remember that we first have to negate, and then skolemize!+                     do SatResult res <- liftIO $ satWith cfg $ do+                                           qSaturateSavingObservables prop+                                           mapM_ constrain [getObjProof | ProofObj{isUserAxiom, getObjProof} <- by, isUserAxiom] :: Symbolic ()+                                           mapM_ (uncurry sObserve) disps+                                           pure $ skolemize (qNot prop)+                        pure res++         liftIO $ print $ ThmResult res++         die
+ Data/SBV/TP/List.hs view
@@ -0,0 +1,1939 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.TP.List+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- A variety of TP proofs on list processing functions. Note that+-- these proofs only hold for finite lists. SMT-solvers do not model infinite+-- lists, and hence all claims are for finite (but arbitrary-length) lists.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.TP.List (+     -- * Append+     appendNull, consApp, appendAssoc, initsLength, tailsLength, tailsAppend++     -- * Reverse+   , revLen, revApp, revCons, revSnoc, revRev, enumLen, revNM++     -- * Length+   , lengthTail, lenAppend, lenAppend2++     -- * Replicate+   , replicateLength++     -- * All and any+   , allAny++     -- * Map+   , mapEquiv, mapAppend, mapReverse, mapCompose++     -- * Foldr and foldl+   , foldrMapFusion, foldrFusion, foldrOverAppend, foldlOverAppend, foldrFoldlDuality, foldrFoldlDualityGeneralized, foldrFoldl+   , bookKeeping++     -- * Filter+   , filterAppend, filterConcat, takeDropWhile++     -- * Stutter removal+   , destutter, destutterIdempotent++     -- * Difference+   , appendDiff, diffAppend, diffDiff++     -- * Partition+   , partition1, partition2++    -- * Take and drop+   , take_take, drop_drop, take_drop, take_cons, take_map, drop_cons, drop_map, length_take, length_drop, take_all, drop_all+   , take_append, drop_append++   -- * Zip+   , map_fst_zip+   , map_snd_zip+   , map_fst_zip_take+   , map_snd_zip_take++   -- * Counting elements+   , count, countAppend, takeDropCount, countNonNeg, countElem, elemCount++   -- * Disjointness+   , disjoint, disjointDiff++   -- * Interleaving+   , interleave, uninterleave, interleaveLen, interleaveRoundTrip+ ) where++import Prelude (Integer, Bool, Eq, ($), Num(..), id, (.), flip)++import Data.SBV+import Data.SBV.List+import Data.SBV.Tuple+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> :set -XScopedTypeVariables+-- >>> :set -XTypeApplications+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+-- >>> import Control.Exception+#endif++-- | @xs ++ [] == xs@+--+-- >>> runTP $ appendNull @Integer+-- Lemma: appendNull                       Q.E.D.+-- [Proven] appendNull :: Ɐxs ∷ [Integer] → Bool+appendNull :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+appendNull = lemma "appendNull"+                   (\(Forall xs) -> xs ++ nil .== xs)+                   []++-- | @(x : xs) ++ ys == x : (xs ++ ys)@+--+-- >>> runTP $ consApp @Integer+-- Lemma: consApp                          Q.E.D.+-- [Proven] consApp :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+consApp :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> Forall "ys" [a] -> SBool))+consApp = lemma "consApp"+                (\(Forall x) (Forall xs) (Forall ys) -> (x .: xs) ++ ys .== x .: (xs ++ ys))+                []++-- | @(xs ++ ys) ++ zs == xs ++ (ys ++ zs)@+--+-- >>> runTP $ appendAssoc @Integer+-- Lemma: appendAssoc                      Q.E.D.+-- [Proven] appendAssoc :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐzs ∷ [Integer] → Bool+--+-- Surprisingly, z3 can prove this without any induction. (Since SBV's append translates directly to+-- the concatenation of sequences in SMTLib, it must trigger an internal heuristic in z3+-- that proves it right out-of-the-box!)+appendAssoc :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "zs" [a] -> SBool))+appendAssoc =+   lemma "appendAssoc"+         (\(Forall xs) (Forall ys) (Forall zs) -> xs ++ (ys ++ zs) .== (xs ++ ys) ++ zs)+         []++-- | @length (inits xs) == 1 + length xs@+--+-- >>> runTP $ initsLength @Integer+-- Inductive lemma (strong): initsLength+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] initsLength :: Ɐxs ∷ [Integer] → Bool+initsLength :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+initsLength =+   sInduct "initsLength"+           (\(Forall xs) -> length (inits xs) .== 1 + length xs)+           (length @a) $+           \ih xs -> [] |- length (inits xs)+                        ?? ih+                        =: 1 + length xs+                        =: qed++-- | @length (tails xs) == 1 + length xs@+--+-- >>> runTP $ tailsLength @Integer+-- Inductive lemma: tailsLength+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] tailsLength :: Ɐxs ∷ [Integer] → Bool+tailsLength :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+tailsLength =+   induct "tailsLength"+          (\(Forall xs) -> length (tails xs) .== 1 + length xs) $+          \ih (x, xs) -> [] |- length (tails (x .: xs))+                            =: length (tails xs ++ [x .: xs])+                            =: length (tails xs) + 1+                            ?? ih+                            =: 1 + length xs + 1+                            =: 1 + length (x .: xs)+                            =: qed++-- | @tails (xs ++ ys) == map (++ ys) (tails xs) ++ tail (tails ys)@+--+-- This property comes from Richard Bird's "Pearls of functional Algorithm Design" book, chapter 2.+-- Note that it is not exactly as stated there, as the definition of @tail@ Bird uses is different+-- than the standard Haskell function @tails@: Bird's version does not return the empty list as the+-- tail. So, we slightly modify it to fit the standard definition.+--+-- >>> runTP $ tailsAppend @Integer+-- Inductive lemma: base case+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: helper+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: tailsAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] tailsAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+tailsAppend :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+tailsAppend = do++   let -- Ideally, we would like to define appendEach like this:+       --+       --       appendEach xs ys = map (++ ys) xs+       --+       -- But capture of ys is not allowed when we use the higher-order+       -- function map in SBV. So, we create a closure instead.+       appendEach :: SList a -> SList [a] -> SList [a]+       appendEach ys = map $ Closure { closureEnv = ys+                                     , closureFun = \env xs -> xs ++ env+                                     }++   -- Even proving the base case of induction is hard due to recursive definition. So we first prove the base case by induction.+   bc <- induct "base case"+                (\(Forall @"ys" (ys :: SList a)) -> tails ys .== [ys] ++ tail (tails ys)) $+                \ih (y, ys) -> [] |- tails (y .: ys)+                                  =: [y .: ys] ++ tails ys+                                  ?? ih+                                  =: [y .: ys] ++ [ys] ++ tail (tails ys)+                                  =: [y .: ys] ++ tail (tails (y .: ys))+                                  =: qed++   -- Also need a helper to relate how appendEach and tails work together+   helper <- calc "helper"+                   (\(Forall @"xs" xs) (Forall @"ys" ys) (Forall @"x" x) ->+                        appendEach ys (tails (x .: xs)) .== [(x .: xs) ++ ys] ++ appendEach ys (tails xs)) $+                   \xs ys x -> [] |- appendEach ys (tails (x .: xs))+                                  =: appendEach ys ([x .: xs] ++ tails xs)+                                  =: [(x .: xs) ++ ys] ++ appendEach ys (tails xs)+                                  =: qed++   induct "tailsAppend"+          (\(Forall xs) (Forall ys) -> tails (xs ++ ys) .== appendEach ys (tails xs) ++ tail (tails ys)) $+          \ih (x, xs) ys -> [assumptionFromProof bc]+                         |- tails ((x .: xs) ++ ys)+                         =: tails (x .: (xs ++ ys))+                         =: [x .: (xs ++ ys)] ++ tails (xs ++ ys)+                         ?? ih+                         =: [(x .: xs) ++ ys] ++ appendEach ys (tails xs) ++ tail (tails ys)+                         ?? helper+                         =: appendEach ys (tails (x .: xs)) ++ tail (tails ys)+                         =: qed++-- | @length xs == length (reverse xs)@+--+-- >>> runTP $ revLen @Integer+-- Inductive lemma: revLen+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] revLen :: Ɐxs ∷ [Integer] → Bool+revLen :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+revLen = induct "revLen"+                (\(Forall xs) -> length (reverse xs) .== length xs) $+                \ih (x, xs) -> [] |- length (reverse (x .: xs))+                                  =: length (reverse xs ++ [x])+                                  =: length (reverse xs) + length [x]+                                  ?? ih+                                  =: length xs + 1+                                  =: length (x .: xs)+                                  =: qed++-- | @reverse (xs ++ ys) .== reverse ys ++ reverse xs@+--+-- >>> runTP $ revApp @Integer+-- Inductive lemma: revApp+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] revApp :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+revApp :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+revApp = induct "revApp"+                 (\(Forall xs) (Forall ys) -> reverse (xs ++ ys) .== reverse ys ++ reverse xs) $+                 \ih (x, xs) ys -> [] |- reverse ((x .: xs) ++ ys)+                                      =: reverse (x .: (xs ++ ys))+                                      =: reverse (xs ++ ys) ++ [x]+                                      ?? ih+                                      =: (reverse ys ++ reverse xs) ++ [x]+                                      =: reverse ys ++ (reverse xs ++ [x])+                                      =: reverse ys ++ reverse (x .: xs)+                                      =: qed++-- | @reverse (x:xs) == reverse xs ++ [x]@+--+-- >>> runTP $ revCons @Integer+-- Lemma: revCons                          Q.E.D.+-- [Proven] revCons :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+revCons :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool))+revCons = lemma "revCons"+                (\(Forall x) (Forall xs) -> reverse (x .: xs) .== reverse xs ++ [x])+                []++-- | @reverse (xs ++ [x]) == x : reverse xs@+--+-- >>> runTP $ revSnoc @Integer+-- Inductive lemma: revApp+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: revSnoc                          Q.E.D.+-- [Proven] revSnoc :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+revSnoc :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool))+revSnoc = do+   ra <- revApp @a++   lemma "revSnoc"+         (\(Forall x) (Forall xs) -> reverse (xs ++ [x]) .== x .: reverse xs)+         [proofOf ra]++-- | @reverse (reverse xs) == xs@+--+-- >>> runTP $ revRev @Integer+-- Inductive lemma: revApp+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: revRev+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] revRev :: Ɐxs ∷ [Integer] → Bool+revRev :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+revRev = do++   ra <- revApp @a++   induct "revRev"+          (\(Forall xs) -> reverse (reverse xs) .== xs) $+          \ih (x, xs) -> [] |- reverse (reverse (x .: xs))+                            =: reverse (reverse xs ++ [x])+                            ?? ra+                            =: reverse [x] ++ reverse (reverse xs)+                            ?? ih+                            =: [x] ++ xs+                            =: x .: xs+                            =: qed++-- | \(\text{length } [n \dots m] = \max(0,\; m - n + 1)\)+--+-- The proof uses the metric @|m-n|@.+--+-- >>> runTP enumLen+-- Inductive lemma (strong): enumLen+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.2.3                         Q.E.D.+--     Step: 1.2.4                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] enumLen :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool+enumLen :: TP (Proof (Forall "n" Integer -> Forall "m" Integer -> SBool))+enumLen =+  sInduct "enumLen"+          (\(Forall n) (Forall m) -> length [sEnum|n .. m|] .== 0 `smax` (m - n + 1))+          (\n m -> abs (m - n)) $+          \ih n m -> [] |- length [sEnum|n+1 .. m|]+                        =: cases [ n+1 .>  m ==> trivial+                                 , n+1 .<= m ==> length (n+1 .: [sEnum|n+2 .. m|])+                                              =: 1 + length [sEnum|n+2 .. m|]+                                              ?? ih+                                              =: 1 + (0 `smax` (m - (n+2) + 1))+                                              =: 0 `smax` (m - (n+1) + 1)+                                              =: qed+                                 ]++-- | @reverse [n .. m] == [m, m-1 .. n]@+--+-- The proof uses the metric @|m-n|@.+--+-- >>> runTP $ revNM+-- Inductive lemma (strong): helper+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma (strong): revNM+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.2.3                         Q.E.D.+--     Step: 1.2.4                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] revNM :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool+revNM :: TP (Proof (Forall "n" Integer -> Forall "m" Integer -> SBool))+revNM = do++  helper <- sInduct "helper"+                    (\(Forall @"m" (m :: SInteger)) (Forall @"n" n) ->+                          n .< m .=> [sEnum|m, m-1 .. n+1|] ++ [n] .== [sEnum|m, m-1 .. n|])+                    (\m n -> abs (m - n)) $+                    \ih m n -> [n .< m] |- [sEnum|m, m-1 .. n+1|] ++ [n]+                                        =: m .: [sEnum|m-1, m-2 .. n+1|] ++ [n]+                                        ?? ih+                                        =: m .: [sEnum|m-1, m-2 .. n|]+                                        =: [sEnum|m, m-1 .. n|]+                                        =: qed++  sInduct "revNM"+          (\(Forall n) (Forall m) -> reverse [sEnum|n .. m|] .== [sEnum|m, m-1 .. n|])+          (\n m -> abs (m - n)) $+          \ih n m -> [] |- reverse [sEnum|n .. m|]+                        =: cases [ n .>  m ==> trivial+                                 , n .<= m ==> reverse (n .: [sEnum|(n+1) .. m|])+                                            =: reverse [sEnum|(n+1) .. m|] ++ [n]+                                            ?? ih+                                            =: [sEnum|m, m-1 .. n+1|] ++ [n]+                                            ?? helper+                                            =: [sEnum|m, m-1 .. n|]+                                            =: qed+                                 ]++-- | @length (x : xs) == 1 + length xs@+--+-- >>> runTP $ lengthTail @Integer+-- Lemma: lengthTail                       Q.E.D.+-- [Proven] lengthTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+lengthTail :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool))+lengthTail = lemma "lengthTail"+                   (\(Forall x) (Forall xs) -> length (x .: xs) .== 1 + length xs)+                   []++-- | @length (xs ++ ys) == length xs + length ys@+--+-- >>> runTP $ lenAppend @Integer+-- Lemma: lenAppend                        Q.E.D.+-- [Proven] lenAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+lenAppend :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+lenAppend = lemma "lenAppend"+                  (\(Forall xs) (Forall ys) -> length (xs ++ ys) .== length xs + length ys)+                  []++-- | @length xs == length ys -> length (xs ++ ys) == 2 * length xs@+--+-- >>> runTP $ lenAppend2 @Integer+-- Lemma: lenAppend2                       Q.E.D.+-- [Proven] lenAppend2 :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+lenAppend2 :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+lenAppend2 = lemma "lenAppend2"+                   (\(Forall xs) (Forall ys) -> length xs .== length ys .=> length (xs ++ ys) .== 2 * length xs)+                   []++-- | @length (replicate k x) == max (0, k)@+--+-- >>> runTP $ replicateLength @Integer+-- Inductive lemma: replicateLength+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.2.3                         Q.E.D.+--     Step: 1.2.4                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] replicateLength :: Ɐk ∷ Integer → Ɐx ∷ Integer → Bool+replicateLength :: forall a. SymVal a => TP (Proof (Forall "k" Integer -> Forall "x" a -> SBool))+replicateLength = induct "replicateLength"+                         (\(Forall k) (Forall x) -> length (replicate k x) .== 0 `smax` k) $+                         \ih k x -> [] |- length (replicate (k+1) x)+                                       =: cases [ k .< 0  ==> trivial+                                                , k .>= 0 ==> length (x .: replicate k x)+                                                           =: 1 + length (replicate k x)+                                                           ?? ih+                                                           =: 1 + 0 `smax` k+                                                           =: 0 `smax` (k+1)+                                                           =: qed+                                                ]++-- | @not (all id xs) == any not xs@+--+-- A list of booleans is not all true, if any of them is false.+--+-- >>> runTP allAny+-- Inductive lemma: allAny+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] allAny :: Ɐxs ∷ [Bool] → Bool+allAny :: TP (Proof (Forall "xs" [Bool] -> SBool))+allAny = induct "allAny"+                (\(Forall xs) -> sNot (all id xs) .== any sNot xs) $+                \ih (x, xs) -> [] |- sNot (all id (x .: xs))+                                  =: sNot (x .&& all id xs)+                                  =: (sNot x .|| sNot (all id xs))+                                  ?? ih+                                  =: sNot x .|| any sNot xs+                                  =: any sNot (x .: xs)+                                  =: qed++-- | @f == g ==> map f xs == map g xs@+--+-- >>> runTP $ mapEquiv @Integer @Integer (uninterpret "f") (uninterpret "g")+-- Inductive lemma: mapEquiv+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] mapEquiv :: Ɐxs ∷ [Integer] → Bool+mapEquiv :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> (SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> SBool))+mapEquiv f g = do+   let f'eq'g :: SBool+       f'eq'g = quantifiedBool $ \(Forall x) -> f x .== g x++   induct "mapEquiv"+          (\(Forall xs) -> f'eq'g .=> map f xs .== map g xs) $+          \ih (x, xs) -> [f'eq'g] |- map f (x .: xs) .== map g (x .: xs)+                                  =: f x .: map f xs .== g x .: map g xs+                                  =: f x .: map f xs .== f x .: map g xs+                                  ?? ih+                                  =: f x .: map f xs .== f x .: map f xs+                                  =: map f (x .: xs) .== map f (x .: xs)+                                  =: qed++-- | @map f (xs ++ ys) == map f xs ++ map f ys@+--+-- >>> runTP $ mapAppend @Integer @Integer (uninterpret "f")+-- Inductive lemma: mapAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] mapAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+mapAppend :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+mapAppend f =+   induct "mapAppend"+          (\(Forall xs) (Forall ys) -> map f (xs ++ ys) .== map f xs ++ map f ys) $+          \ih (x, xs) ys -> [] |- map f ((x .: xs) ++ ys)+                               =: map f (x .: (xs ++ ys))+                             =: f x .: map f (xs ++ ys)+                             ?? ih+                             =: f x .: (map f xs  ++ map f ys)+                             =: (f x .: map f xs) ++ map f ys+                             =: map f (x .: xs) ++ map f ys+                             =: qed++-- | @map f . reverse == reverse . map f@+--+-- >>> runTP $ mapReverse @Integer @String (uninterpret "f")+-- Inductive lemma: mapAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: mapReverse+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] mapReverse :: Ɐxs ∷ [Integer] → Bool+mapReverse :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> SBool))+mapReverse f = do+     mApp <- mapAppend f++     induct "mapReverse"+            (\(Forall xs) -> reverse (map f xs) .== map f (reverse xs)) $+            \ih (x, xs) -> [] |- reverse (map f (x .: xs))+                              =: reverse (f x .: map f xs)+                              =: reverse (map f xs) ++ [f x]+                              ?? ih+                              =: map f (reverse xs) ++ [f x]+                              =: map f (reverse xs) ++ map f [x]+                              ?? mApp+                              =: map f (reverse xs ++ [x])+                              =: map f (reverse (x .: xs))+                              =: qed++-- | @map f . map g == map (f . g)@+--+-- >>> runTP $ mapCompose @Integer @Bool @String (uninterpret "f") (uninterpret "g")+-- Inductive lemma: mapCompose+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] mapCompose :: Ɐxs ∷ [Integer] → Bool+mapCompose :: forall a b c. (SymVal a, SymVal b, SymVal c) => (SBV a -> SBV b) -> (SBV b -> SBV c) -> TP (Proof (Forall "xs" [a] -> SBool))+mapCompose f g =+  induct "mapCompose"+         (\(Forall xs) -> map g (map f xs) .== map (g . f) xs) $+         \ih (x, xs) -> [] |- map g (map f (x .: xs))+                           =: map g (f x .: map f xs)+                           =: g (f x) .: map g (map f xs)+                           ?? ih+                           =: (g . f) x .: map (g . f) xs+                           =: map (g . f) (x .: xs)+                           =: qed++-- | @foldr f a . map g == foldr (f . g) a@+--+-- >>> runTP $ foldrMapFusion @String @Bool @Integer (uninterpret "a") (uninterpret "b") (uninterpret "c")+-- Inductive lemma: foldrMapFusion+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] foldrMapFusion :: Ɐxs ∷ [[Char]] → Bool+foldrMapFusion :: forall a b c. (SymVal a, SymVal b, SymVal c) => SBV c -> (SBV a -> SBV b) -> (SBV b -> SBV c -> SBV c) -> TP (Proof (Forall "xs" [a] -> SBool))+foldrMapFusion a g f =+  induct "foldrMapFusion"+         (\(Forall xs) -> foldr f a (map g xs) .== foldr (f . g) a xs) $+         \ih (x, xs) -> [] |- foldr f a (map g (x .: xs))+                           =: foldr f a (g x .: map g xs)+                           =: g x `f` foldr f a (map g xs)+                           ?? ih+                           =: g x `f` foldr (f . g) a xs+                           =: foldr (f . g) a (x .: xs)+                           =: qed++-- |+--+-- @+--   f . foldr g a == foldr h b+--   provided, f a = b and for all x and y, f (g x y) == h x (f y).+-- @+--+-- >>> runTP $ foldrFusion @String @Bool @Integer (uninterpret "a") (uninterpret "b") (uninterpret "f") (uninterpret "g") (uninterpret "h")+-- Inductive lemma: foldrFusion+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] foldrFusion :: Ɐxs ∷ [[Char]] → Bool+foldrFusion :: forall a b c. (SymVal a, SymVal b, SymVal c) => SBV c -> SBV b -> (SBV c -> SBV b) -> (SBV a -> SBV c -> SBV c) -> (SBV a -> SBV b -> SBV b) -> TP (Proof (Forall "xs" [a] -> SBool))+foldrFusion a b f g h = do+   let -- Assumptions under which the equality holds+       h1 = f a .== b+       h2 = quantifiedBool $ \(Forall x) (Forall y) -> f (g x y) .== h x (f y)++   induct "foldrFusion"+          (\(Forall xs) -> h1 .&& h2 .=> f (foldr g a xs) .== foldr h b xs) $+          \ih (x, xs) -> [h1, h2] |- f (foldr g a (x .: xs))+                                  =: f (g x (foldr g a xs))+                                  =: h x (f (foldr g a xs))+                                  ?? ih+                                  =: h x (foldr h b xs)+                                  =: foldr h b (x .: xs)+                                  =: qed++-- | @foldr f a (xs ++ ys) == foldr f (foldr f a ys) xs@+--+-- >>> runTP $ foldrOverAppend @Integer (uninterpret "a") (uninterpret "f")+-- Inductive lemma: foldrOverAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] foldrOverAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+foldrOverAppend :: forall a. SymVal a => SBV a -> (SBV a -> SBV a -> SBV a) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+foldrOverAppend a f =+   induct "foldrOverAppend"+          (\(Forall xs) (Forall ys) -> foldr f a (xs ++ ys) .== foldr f (foldr f a ys) xs) $+          \ih (x, xs) ys -> [] |- foldr f a ((x .: xs) ++ ys)+                               =: foldr f a (x .: (xs ++ ys))+                               =: x `f` foldr f a (xs ++ ys)+                               ?? ih+                               =: x `f` foldr f (foldr f a ys) xs+                               =: foldr f (foldr f a ys) (x .: xs)+                               =: qed++-- | @foldl f e (xs ++ ys) == foldl f (foldl f e xs) ys@+--+-- >>> runTP $ foldlOverAppend @Integer @Bool (uninterpret "f")+-- Inductive lemma: foldlOverAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] foldlOverAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐe ∷ Bool → Bool+foldlOverAppend :: forall a b. (SymVal a, SymVal b) => (SBV b -> SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "e" b -> SBool))+foldlOverAppend f =+   induct "foldlOverAppend"+          (\(Forall xs) (Forall ys) (Forall a) -> foldl f a (xs ++ ys) .== foldl f (foldl f a xs) ys) $+          \ih (x, xs) ys a -> [] |- foldl f a ((x .: xs) ++ ys)+                                 =: foldl f a (x .: (xs ++ ys))+                                 =: foldl f (a `f` x) (xs ++ ys)+                                 -- z3 is smart enough to instantiate the IH correctly below, but we're+                                 -- using an explicit instantiation to be clear about the use of @a@ at a different value+                                 ?? ih `at` (Inst @"ys" ys, Inst @"e" (a `f` x))+                                 =: foldl f (foldl f (a `f` x) xs) ys+                                 =: qed++-- | @foldr f e xs == foldl (flip f) e (reverse xs)@+--+-- >>> runTP $ foldrFoldlDuality @Integer @String (uninterpret "f")+-- Inductive lemma: foldlOverAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: foldrFoldlDuality+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] foldrFoldlDuality :: Ɐxs ∷ [Integer] → Ɐe ∷ [Char] → Bool+foldrFoldlDuality :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b -> SBV b) -> TP (Proof (Forall "xs" [a] -> Forall "e" b -> SBool))+foldrFoldlDuality f = do+   foa <- foldlOverAppend (flip f)++   induct "foldrFoldlDuality"+          (\(Forall xs) (Forall e) -> foldr f e xs .== foldl (flip f) e (reverse xs)) $+          \ih (x, xs) e -> [] |- let ff  = flip f+                                     rxs = reverse xs+                                 in foldr f e (x .: xs)+                                 =: x `f` foldr f e xs+                                 ?? ih+                                 =: x `f` foldl ff e rxs+                                 =: foldl ff e rxs `ff` x+                                 =: foldl ff (foldl ff e rxs) [x]+                                 ?? foa+                                 =: foldl ff e (rxs ++ [x])+                                 =: foldl ff e (reverse (x .: xs))+                                 =: qed++-- | Given:+--+-- @+--     x \@ (y \@ z) = (x \@ y) \@ z     (associativity of @)+-- and e \@ x = x                     (left unit)+-- and x \@ e = x                     (right unit)+-- @+--+-- Proves:+--+-- @+--     foldr (\@) e xs == foldl (\@) e xs+-- @+--+-- >>> runTP $ foldrFoldlDualityGeneralized @Integer (uninterpret "e") (uninterpret "|@|")+-- Inductive lemma: helper+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: foldrFoldlDuality+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] foldrFoldlDuality :: Ɐxs ∷ [Integer] → Bool+foldrFoldlDualityGeneralized :: forall a. SymVal a => SBV a -> (SBV a -> SBV a -> SBV a) -> TP (Proof (Forall "xs" [a] -> SBool))+foldrFoldlDualityGeneralized e (@) = do+   -- Assumptions under which the equality holds+   let assoc = quantifiedBool $ \(Forall x) (Forall y) (Forall z) -> x @ (y @ z) .== (x @ y) @ z+       lunit = quantifiedBool $ \(Forall x) -> e @ x .== x+       runit = quantifiedBool $ \(Forall x) -> x @ e .== x++   -- Helper: foldl (@) (y @ z) xs = y @ foldl (@) z xs+   -- Note the instantiation of the IH at a different value for z. It turns out+   -- we don't have to actually specify this since z3 can figure it out by itself, but we're being explicit.+   helper <- induct "helper"+                    (\(Forall @"xs" xs) (Forall @"y" y) (Forall @"z" z) -> assoc .=> foldl (@) (y @ z) xs .== y @ foldl (@) z xs) $+                    \ih (x, xs) y z -> [assoc] |- foldl (@) (y @ z) (x .: xs)+                                               =: foldl (@) ((y @ z) @ x) xs+                                               ?? assoc+                                               =: foldl (@) (y @ (z @ x)) xs+                                               ?? ih `at` (Inst @"y" y, Inst @"z" (z @ x))+                                               =: y @ foldl (@) (z @ x) xs+                                               =: y @ foldl (@) z (x .: xs)+                                               =: qed++   induct "foldrFoldlDuality"+          (\(Forall xs) -> assoc .&& lunit .&& runit .=> foldr (@) e xs .== foldl (@) e xs) $+          \ih (x, xs) -> [assoc, lunit, runit] |- foldr (@) e (x .: xs)+                                               =: x @ foldr (@) e xs+                                               ?? ih+                                               =: x @ foldl (@) e xs+                                               ?? helper+                                               =: foldl (@) (x @ e) xs+                                               ?? runit+                                               =: foldl (@) x xs+                                               ?? lunit+                                               =: foldl (@) (e @ x) xs+                                               =: foldl (@) e (x .: xs)+                                               =: qed++-- | Given:+--+-- @+--        (x \<+> y) \<*> z = x \<+> (y \<*> z)+--   and  x \<+> e = e \<*> x+-- @+--+-- Proves:+--+-- @+--    foldr (\<+>) e xs = foldl (\<*>) e xs+-- @+--+-- In Bird's Introduction to Functional Programming book (2nd edition) this is called the second duality theorem:+--+-- >>> runTP $ foldrFoldl @Integer @String (uninterpret "<+>") (uninterpret "<*>") (uninterpret "e")+-- Inductive lemma: foldl over <*>/<+>+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: foldrFoldl+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] foldrFoldl :: Ɐxs ∷ [Integer] → Bool+foldrFoldl :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b -> SBV b) -> (SBV b -> SBV a -> SBV b) -> SBV b-> TP (Proof (Forall "xs" [a] -> SBool))+foldrFoldl (<+>) (<*>) e = do+   -- Assumptions about the operators+   let -- (x <+> y) <*> z == x <+> (y <*> z)+       assoc = quantifiedBool $ \(Forall x) (Forall y) (Forall z) -> (x <+> y) <*> z .== x <+> (y <*> z)++       -- x <+> e == e <*> x+       unit  = quantifiedBool $ \(Forall x) -> x <+> e .== e <*> x++   -- Helper: x <+> foldl (<*>) y xs == foldl (<*>) (x <+> y) xs+   helper <-+      induct "foldl over <*>/<+>"+             (\(Forall @"xs" xs) (Forall @"x" x) (Forall @"y" y) -> assoc .=> x <+> foldl (<*>) y xs .== foldl (<*>) (x <+> y) xs) $++             -- Using z to avoid confusion with the variable x already present, following Bird.+             -- z3 can figure out the proper instantiation of ih so the at call is unnecessary, but being explicit is helpful.+             \ih (z, xs) x y -> [assoc] |- x <+> foldl (<*>) y (z .: xs)+                                        =: x <+> foldl (<*>) (y <*> z) xs+                                        ?? ih `at` (Inst @"x" x, Inst @"y" (y <*> z))+                                        =: foldl (<*>) (x <+> (y <*> z)) xs+                                        ?? assoc+                                        =: foldl (<*>) ((x <+> y) <*> z) xs+                                        =: foldl (<*>) (x <+> y) (z .: xs)+                                        =: qed++   -- Final proof:+   induct "foldrFoldl"+          (\(Forall xs) -> assoc .&& unit .=> foldr (<+>) e xs .== foldl (<*>) e xs) $+          \ih (x, xs) -> [assoc, unit] |- foldr (<+>) e (x .: xs)+                                       =: x <+> foldr (<+>) e xs+                                       ?? ih+                                       =: x <+> foldl (<*>) e xs+                                       ?? helper+                                       =: foldl (<*>) (x <+> e) xs+                                       =: foldl (<*>) (e <*> x) xs+                                       =: foldl (<*>) e (x .: xs)+                                       =: qed++-- | Provided @f@ is associative and @a@ is its both left and right-unit:+--+-- @foldr f a . concat == foldr f a . map (foldr f a)@+--+-- >>> runTP $ bookKeeping @Integer (uninterpret "a") (uninterpret "f")+-- Inductive lemma: foldBase+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: foldrOverAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: bookKeeping+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] bookKeeping :: Ɐxss ∷ [[Integer]] → Bool+--+-- NB. This theorem does not hold if @f@ does not have a left-unit! Consider the input @[[], [x]]@. Left hand side reduces to+-- @x@, while the right hand side reduces to: @f a x@. And unless @f@ is commutative or @a@ is not also a left-unit,+-- then one can find a counter-example. (Aside: if both left and right units exist for a binary operator, then they+-- are necessarily the same element, since @l = f l r = r@. So, an equivalent statement could simply say @f@ has+-- both left and right units.) A concrete counter-example is:+--+-- @+--   data T = A | B | C+--+--   f :: T -> T -> T+--   f C A = A+--   f C B = A+--   f x _ = x+-- @+--+-- You can verify @f@ is associative. Also note that @C@ is the right-unit for @f@, but it isn't the left-unit.+-- In fact, @f@ has no-left unit by the above argument. In this case, the bookkeeping law produces @B@ for+-- the left-hand-side, and @A@ for the right-hand-side for the input @[[], [B]]@.+bookKeeping :: forall a. SymVal a => SBV a -> (SBV a -> SBV a -> SBV a) -> TP (Proof (Forall "xss" [[a]] -> SBool))+bookKeeping a f = do++   -- Assumptions about f+   let assoc = quantifiedBool $ \(Forall x) (Forall y) (Forall z) -> x `f` (y `f` z) .== (x `f` y) `f` z+       rUnit = quantifiedBool $ \(Forall x) -> x `f` a .== x+       lUnit = quantifiedBool $ \(Forall x) -> a `f` x .== x++   -- Helper: @foldr f y xs = foldr f a xs `f` y@+   helper <- induct "foldBase"+                    (\(Forall xs) (Forall y) -> lUnit .&& assoc .=> foldr f y xs .== foldr f a xs `f` y) $+                    \ih (x, xs) y -> [lUnit, assoc] |- foldr f y (x .: xs)+                                                    =: x `f` foldr f y xs+                                                    ?? ih+                                                    =: x `f` (foldr f a xs `f` y)+                                                    =: (x `f` foldr f a xs) `f` y+                                                    =: foldr f a (x .: xs) `f` y+                                                    =: qed++   foa <- foldrOverAppend a f++   induct "bookKeeping"+          (\(Forall xss) -> assoc .&& rUnit .&& lUnit .=> foldr f a (concat xss) .== foldr f a (map (foldr f a) xss)) $+          \ih (xs, xss) -> [assoc, rUnit, lUnit] |- foldr f a (concat (xs .: xss))+                                                 =: foldr f a (xs ++ concat xss)+                                                 ?? foa+                                                 =: foldr f (foldr f a (concat xss)) xs+                                                 ?? ih+                                                 =: foldr f (foldr f a (map (foldr f a) xss)) xs+                                                 ?? helper `at` (Inst @"xs" xs, Inst @"y" (foldr f a (map (foldr f a) xss)))+                                                 =: foldr f a xs `f` foldr f a (map (foldr f a) xss)+                                                 =: foldr f a (foldr f a xs .: map (foldr f a) xss)+                                                 =: foldr f a (map (foldr f a) (xs .: xss))+                                                 =: qed++-- | @filter p (xs ++ ys) == filter p xs ++ filter p ys@+--+-- >>> runTP $ filterAppend @Integer (uninterpret "p")+-- Inductive lemma: filterAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] filterAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+filterAppend :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+filterAppend p =+   induct "filterAppend"+          (\(Forall xs) (Forall ys) -> filter p xs ++ filter p ys .== filter p (xs ++ ys)) $+          \ih (x, xs) ys -> [] |- filter p (x .: xs) ++ filter p ys+                               =: ite (p x) (x .: filter p xs) (filter p xs) ++ filter p ys+                               =: ite (p x) (x .: filter p xs ++ filter p ys) (filter p xs ++ filter p ys)+                               ?? ih+                               =: ite (p x) (x .: filter p (xs ++ ys)) (filter p (xs ++ ys))+                               =: filter p (x .: (xs ++ ys))+                               =: filter p ((x .: xs) ++ ys)+                               =: qed++-- | @filter p (concat xss) == concatMap (filter p xss)@+--+-- >>> runTP $ filterConcat @Integer (uninterpret "f")+-- Inductive lemma: filterAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: filterConcat+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] filterConcat :: Ɐxss ∷ [[Integer]] → Bool+filterConcat :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xss" [[a]] -> SBool))+filterConcat p = do+  fa <- filterAppend p++  inductWith cvc5 "filterConcat"+         (\(Forall xss) -> filter p (concat xss) .== concatMap (filter p) xss) $+         \ih (xs, xss) -> [] |- filter p (concat (xs .: xss))+                             =: filter p (xs ++ concat xss)+                             ?? fa+                             =: filter p xs ++ filter p (concat xss)+                             ?? ih+                             =: concatMap (filter p) (xs .: xss)+                             =: qed++-- | @takeWhile f xs ++ dropWhile f xs == xs@+--+-- >>> runTP $ takeDropWhile @Integer (uninterpret "f")+-- Inductive lemma: takeDropWhile+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] takeDropWhile :: Ɐxs ∷ [Integer] → Bool+takeDropWhile :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> SBool))+takeDropWhile f =+   induct "takeDropWhile"+          (\(Forall xs) -> takeWhile f xs ++ dropWhile f xs .== xs) $+          \ih (x, xs) -> [] |- takeWhile f (x .: xs) ++ dropWhile f (x .: xs)+                            =: cases [ f x        ==> x .: takeWhile f xs ++ dropWhile f xs+                                                   ?? ih+                                                   =: x .: xs+                                                   =: qed+                                     , sNot (f x) ==> [] ++ x .: xs+                                                   =: x .: xs+                                                   =: qed+                                     ]+-- | Remove adjacent duplicates.+destutter :: SymVal a => SList a -> SList a+destutter = smtFunction "destutter" $ \xs -> ite (null xs .|| null (tail xs))+                                                 xs+                                                 (let (a, as) = uncons xs+                                                      r       = destutter as+                                                  in ite (a .== head as) r (a .: r))++-- | @destutter (destutter xs) == destutter xs@+--+-- >>> runTP $ destutterIdempotent @Integer+-- Inductive lemma: helper1+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: helper2+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma (strong): helper3+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2 (2 way full case split)+--       Step: 1.2.1                       Q.E.D.+--       Step: 1.2.2.1                     Q.E.D.+--       Step: 1.2.2.2 (2 way case split)+--         Step: 1.2.2.2.1.1               Q.E.D.+--         Step: 1.2.2.2.1.2               Q.E.D.+--         Step: 1.2.2.2.2.1               Q.E.D.+--         Step: 1.2.2.2.2.2               Q.E.D.+--         Step: 1.2.2.2.Completeness      Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: destutterIdempotent              Q.E.D.+-- [Proven] destutterIdempotent :: Ɐxs ∷ [Integer] → Bool+destutterIdempotent :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+destutterIdempotent = do++   -- No adjacent duplicates+   let noAdd = smtFunction "noAdd" $ \xs -> null xs .|| null (tail xs) .|| (head xs ./= head (tail xs) .&& noAdd (tail xs))++   -- Helper: The head of a destuttered non-empty list does not change+   helper1 <- induct "helper1"+                     (\(Forall @"xs" (xs :: SList a)) (Forall @"h" h) -> head (destutter (h .: xs)) .== h) $+                     \ih (x, xs) h -> []+                                   |- head (destutter (h .: x .: xs))+                                   =: cases [ h ./= x ==> trivial+                                            , h .== x ==> head (destutter (x .: xs))+                                                       ?? ih+                                                       =: x+                                                       =: qed+                                            ]++   -- Helper: show that if a list has no adjacent duplicates, then destutter leaves it unchanged:+   helper2 <- induct "helper2"+                     (\(Forall @"xs" (xs :: SList a)) -> noAdd xs .=> destutter xs .== xs) $+                     \ih (x, xs) -> [noAdd (x .: xs)]+                                 |- destutter (x .: xs)+                                 ?? ih+                                 =: x .: xs+                                 =: qed++   -- Helper: prove that noAdd is true for the result of destutter+   helper3 <- sInductWith cvc5 "helper3"+                  (\(Forall @"xs" (xs :: SList a)) -> noAdd (destutter xs))+                  length $+                  \ih xs -> []+                         |- noAdd (destutter xs)+                         =: split xs+                                  trivial+                                  (\a as -> split as+                                                  trivial+                                                  (\b bs -> noAdd (destutter (a .: b .: bs))+                                                         =: cases [a .== b  ==> noAdd (destutter (b .: bs))+                                                                             ?? ih+                                                                             =: sTrue+                                                                             =: qed+                                                                  , a ./= b ==> noAdd (a .: destutter (b .: bs))+                                                                             ?? helper1 `at` (Inst @"xs" bs, Inst @"h" b)+                                                                             ?? ih+                                                                             =: sTrue+                                                                             =: qed+                                                                  ]))++   -- Now we can prove idempotency easily:+   lemma "destutterIdempotent"+          (\(Forall xs) -> destutter (destutter xs) .== destutter xs)+          [proofOf helper2, proofOf helper3]++-- | @(as ++ bs) \\ cs == (as \\ cs) ++ (bs \\ cs)@+--+-- >>> runTP $ appendDiff @Integer+-- Inductive lemma: appendDiff+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] appendDiff :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Ɐcs ∷ [Integer] → Bool+appendDiff :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> Forall "cs" [a] -> SBool))+appendDiff = induct "appendDiff"+                    (\(Forall as) (Forall bs) (Forall cs) -> (as ++ bs) \\ cs .== (as \\ cs) ++ (bs \\ cs)) $+                    \ih (a, as) bs cs -> [] |- (a .: as ++ bs) \\ cs+                                            =: (a .: (as ++ bs)) \\ cs+                                            =: ite (a `elem` cs) ((as ++ bs) \\ cs) (a .: ((as ++ bs) \\ cs))+                                            ?? ih+                                            =: ((a .: as) \\ cs) ++ (bs \\ cs)+                                            =: qed++-- | @as \\ (bs ++ cs) == (as \\ bs) \\ cs@+--+-- >>> runTP $ diffAppend @Integer+-- Inductive lemma: diffAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] diffAppend :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Ɐcs ∷ [Integer] → Bool+diffAppend :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> Forall "cs" [a] -> SBool))+diffAppend = induct "diffAppend"+                    (\(Forall as) (Forall bs) (Forall cs) -> as \\ (bs ++ cs) .== (as \\ bs) \\ cs) $+                    \ih (a, as) bs cs -> [] |- (a .: as) \\ (bs ++ cs)+                                            =: ite (a `elem` (bs ++ cs)) (as \\ (bs ++ cs)) (a .: (as \\ (bs ++ cs)))+                                            ?? ih `at` (Inst @"bs" bs, Inst @"cs" cs)+                                            =: ite (a `elem` (bs ++ cs)) ((as \\ bs) \\ cs) (a .: (as \\ (bs ++ cs)))+                                            ?? ih `at` (Inst @"bs" bs, Inst @"cs" cs)+                                            =: ite (a `elem` (bs ++ cs)) ((as \\ bs) \\ cs) (a .: ((as \\ bs) \\ cs))+                                            =: ((a .: as) \\ bs) \\ cs+                                            =: qed++-- | @(as \\ bs) \\ cs == (as \\ cs) \\ bs@+--+-- >>> runTP $ diffDiff @Integer+-- Inductive lemma: diffDiff+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.1.3 (2 way case split)+--       Step: 1.1.3.1                     Q.E.D.+--       Step: 1.1.3.2.1                   Q.E.D.+--       Step: 1.1.3.2.2 (a ∉ cs)          Q.E.D.+--       Step: 1.1.3.Completeness          Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2 (2 way case split)+--       Step: 1.2.2.1.1                   Q.E.D.+--       Step: 1.2.2.1.2                   Q.E.D.+--       Step: 1.2.2.1.3 (a ∈ cs)          Q.E.D.+--       Step: 1.2.2.2.1                   Q.E.D.+--       Step: 1.2.2.2.2                   Q.E.D.+--       Step: 1.2.2.2.3 (a ∉ bs)          Q.E.D.+--       Step: 1.2.2.2.4 (a ∉ cs)          Q.E.D.+--       Step: 1.2.2.Completeness          Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] diffDiff :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Ɐcs ∷ [Integer] → Bool+diffDiff :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> Forall "cs" [a] -> SBool))+diffDiff = induct "diffDiff"+                  (\(Forall as) (Forall bs) (Forall cs) -> (as \\ bs) \\ cs .== (as \\ cs) \\ bs) $+                  \ih (a, as) bs cs ->+                      [] |- ((a .: as) \\ bs) \\ cs+                         =: cases [ a `elem`    bs ==> (as \\ bs) \\ cs+                                                    ?? ih+                                                    =: (as \\ cs) \\ bs+                                                    =: cases [ a `elem`    cs ==> ((a .: as) \\ cs) \\ bs+                                                                               =: qed+                                                             , a `notElem` cs ==> (a .: (as \\ cs)) \\ bs+                                                                               ?? "a ∉ cs"+                                                                               =: ((a .: as) \\ cs) \\ bs+                                                                               =: qed+                                                             ]+                                  , a `notElem` bs ==> (a .: (as \\ bs)) \\ cs+                                                    =: cases [ a `elem`    cs ==> (as \\ bs) \\ cs+                                                                               ?? ih+                                                                               =: (as \\ cs) \\ bs+                                                                               ?? "a ∈ cs"+                                                                               =: ((a .: as) \\ cs) \\ bs+                                                                               =: qed+                                                             , a `notElem` cs ==> a .: ((as \\ bs) \\ cs)+                                                                               ?? ih+                                                                               =: a .: ((as \\ cs) \\ bs)+                                                                               ?? "a ∉ bs"+                                                                               =: (a .: (as \\ cs)) \\ bs+                                                                               ?? "a ∉ cs"+                                                                               =: ((a .: as) \\ cs) \\ bs+                                                                               =: qed+                                                             ]+                                  ]++-- | Are the two lists disjoint?+disjoint :: (Eq a, SymVal a) => SList a -> SList a -> SBool+disjoint = smtFunction "disjoint" $ \xs ys -> null xs .|| head xs `notElem` ys .&& disjoint (tail xs) ys++-- | @disjoint as bs .=> as \\ bs == as@+--+-- >>> runTP $ disjointDiff @Integer+-- Inductive lemma: disjointDiff+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] disjointDiff :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Bool+disjointDiff :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> SBool))+disjointDiff = induct "disjointDiff"+                      (\(Forall as) (Forall bs) -> disjoint as bs .=> as \\ bs .== as) $+                      \ih (a, as) bs -> [disjoint (a .: as) bs]+                                     |- (a .: as) \\ bs+                                     =: a .: (as \\ bs)+                                     ?? ih+                                     =: a .: as+                                     =: qed++-- | @fst (partition f xs) == filter f xs@+--+-- >>> runTP $ partition1 @Integer (uninterpret "f")+-- Inductive lemma: partition1+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] partition1 :: Ɐxs ∷ [Integer] → Bool+partition1 :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> SBool))+partition1 f =+   induct "partition1"+          (\(Forall xs) -> fst (partition f xs) .== filter f xs) $+          \ih (x, xs) -> [] |- fst (partition f (x .: xs))+                            =: fst (let res = partition f xs+                                    in ite (f x)+                                           (tuple (x .: fst res, snd res))+                                           (tuple (fst res, x .: snd res)))+                            =: ite (f x) (x .: fst (partition f xs)) (fst (partition f xs))+                            ?? ih+                            =: ite (f x) (x .: filter f xs) (filter f xs)+                            =: filter f (x .: xs)+                            =: qed++-- | @snd (partition f xs) == filter (not . f) xs@+--+-- >>> runTP $ partition2 @Integer (uninterpret "f")+-- Inductive lemma: partition2+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] partition2 :: Ɐxs ∷ [Integer] → Bool+partition2 :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> SBool))+partition2 f =+   induct "partition2"+          (\(Forall xs) -> snd (partition f xs) .== filter (sNot . f) xs) $+          \ih (x, xs) -> [] |- snd (partition f (x .: xs))+                            =: snd (let res = partition f xs+                                    in ite (f x)+                                           (tuple (x .: fst res, snd res))+                                           (tuple (fst res, x .: snd res)))+                            =: ite (f x) (snd (partition f xs)) (x .: snd (partition f xs))+                            ?? ih+                            =: ite (f x) (filter (sNot . f) xs) (x .: filter (sNot . f) xs)+                            =: filter (sNot . f) (x .: xs)+                            =: qed++-- | @take n (take m xs) == take (n `smin` m) xs@+--+-- >>> runTP $ take_take @Integer+-- Lemma: take_take                        Q.E.D.+-- [Proven] take_take :: Ɐm ∷ Integer → Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool+take_take :: forall a. SymVal a => TP (Proof (Forall "m" Integer -> Forall "n" Integer -> Forall "xs" [a] -> SBool))+take_take = lemma "take_take"+                  (\(Forall m) (Forall n) (Forall xs) -> take n (take m xs) .== take (n `smin` m) xs)+                  []++-- | @n >= 0 && m >= 0 ==> drop n (drop m xs) == drop (n + m) xs@+--+-- >>> runTP $ drop_drop @Integer+-- Lemma: drop_drop                        Q.E.D.+-- [Proven] drop_drop :: Ɐm ∷ Integer → Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool+drop_drop :: forall a. SymVal a => TP (Proof (Forall "m" Integer -> Forall "n" Integer -> Forall "xs" [a] -> SBool))+drop_drop = lemma "drop_drop"+                  (\(Forall m) (Forall n) (Forall xs) -> n .>= 0 .&& m .>= 0 .=> drop n (drop m xs) .== drop (n + m) xs)+                  []++-- | @take n xs ++ drop n xs == xs@+--+-- >>> runTP $ take_drop @Integer+-- Lemma: take_drop                        Q.E.D.+-- [Proven] take_drop :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool+take_drop :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool))+take_drop = lemma "take_drop"+                  (\(Forall n) (Forall xs) -> take n xs ++ drop n xs .== xs)+                  []++-- | @n .> 0 ==> take n (x .: xs) == x .: take (n - 1) xs@+--+-- >>> runTP $ take_cons @Integer+-- Lemma: take_cons                        Q.E.D.+-- [Proven] take_cons :: Ɐn ∷ Integer → Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+take_cons :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "x" a -> Forall "xs" [a] -> SBool))+take_cons = lemma "take_cons"+                  (\(Forall n) (Forall x) (Forall xs) -> n .> 0 .=> take n (x .: xs) .== x .: take (n - 1) xs)+                  []++-- | @take n (map f xs) == map f (take n xs)@+--+-- >>> runTP $ take_map @Integer @Float (uninterpret "f")+-- Lemma: take_cons                        Q.E.D.+-- Lemma: map1                             Q.E.D.+-- Lemma: take_map.n <= 0                  Q.E.D.+-- Inductive lemma: take_map.n > 0+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: take_map                         Q.E.D.+-- [Proven] take_map :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool+take_map :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool))+take_map f = do+    tc   <- take_cons @a++    map1 <- lemma "map1"+                  (\(Forall x) (Forall xs) -> map f (x .: xs) .== f x .: map f xs)+                  []++    h1 <- lemma "take_map.n <= 0"+                 (\(Forall @"xs" xs) (Forall @"n" n) -> n .<= 0 .=> take n (map f xs) .== map f (take n xs))+                 []++    h2 <- induct "take_map.n > 0"+                 (\(Forall @"xs" xs) (Forall @"n" n) -> n .> 0 .=> take n (map f xs) .== map f (take n xs)) $+                 \ih (x, xs) n -> [n .> 0] |- take n (map f (x .: xs))+                                           =: take n (f x .: map f xs)+                                           =: f x .: take (n - 1) (map f xs)+                                           ?? ih `at` Inst @"n" (n-1)+                                           =: f x .: map f (take (n - 1) xs)+                                           ?? map1 `at` (Inst @"x" x, Inst @"xs" (take (n - 1) xs))+                                           =: map f (x .: take (n - 1) xs)+                                           ?? tc+                                           =: map f (take n (x .: xs))+                                           =: qed++    lemma "take_map"+          (\(Forall n) (Forall xs) -> take n (map f xs) .== map f (take n xs))+          [proofOf h1, proofOf h2]++-- | @n .> 0 ==> drop n (x .: xs) == drop (n - 1) xs@+--+-- >>> runTP $ drop_cons @Integer+-- Lemma: drop_cons                        Q.E.D.+-- [Proven] drop_cons :: Ɐn ∷ Integer → Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+drop_cons :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "x" a -> Forall "xs" [a] -> SBool))+drop_cons = lemma "drop_cons"+                  (\(Forall n) (Forall x) (Forall xs) -> n .> 0 .=> drop n (x .: xs) .== drop (n - 1) xs)+                  []++-- | @drop n (map f xs) == map f (drop n xs)@+--+-- >>> runTP $ drop_map @Integer @String (uninterpret "f")+-- Lemma: drop_cons                        Q.E.D.+-- Lemma: drop_cons                        Q.E.D.+-- Lemma: drop_map.n <= 0                  Q.E.D.+-- Inductive lemma: drop_map.n > 0+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: drop_map+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] drop_map :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool+drop_map :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool))+drop_map f = do+   dcA <- drop_cons @a+   dcB <- drop_cons @b++   h1 <- lemma "drop_map.n <= 0"+               (\(Forall @"xs" xs) (Forall @"n" n) -> n .<= 0 .=> drop n (map f xs) .== map f (drop n xs))+               []++   h2 <- induct "drop_map.n > 0"+                (\(Forall @"xs" xs) (Forall @"n" n) -> n .> 0 .=> drop n (map f xs) .== map f (drop n xs)) $+                \ih (x, xs) n -> [n .> 0] |- drop n (map f (x .: xs))+                                          =: drop n (f x .: map f xs)+                                          ?? dcB `at` (Inst @"n" n, Inst @"x" (f x), Inst @"xs" (map f xs))+                                          =: drop (n - 1) (map f xs)+                                          ?? ih `at` Inst @"n" (n-1)+                                          =: map f (drop (n - 1) xs)+                                          ?? dcA `at` (Inst @"n" n, Inst @"x" x, Inst @"xs" xs)+                                          =: map f (drop n (x .: xs))+                                          =: qed++   -- I'm a bit surprised that z3 can't deduce the following with a simple-lemma, which is essentially a simple case-split.+   -- But the good thing about calc is that it lets us direct the tool in precise ways that we'd like.+   calc "drop_map"+        (\(Forall n) (Forall xs) -> drop n (map f xs) .== map f (drop n xs)) $+        \n xs -> [] |- let result = drop n (map f xs) .== map f (drop n xs)+                       in result+                       =: ite (n .<= 0) (n .<= 0 .=> result) (n .> 0 .=> result)+                       ?? h1+                       =: ite (n .<= 0) sTrue (n .> 0 .=> result)+                       ?? h2+                       =: ite (n .<= 0) sTrue sTrue+                       =: sTrue+                       =: qed++-- | @n >= 0 ==> length (take n xs) == length xs \`min\` n@+--+-- >>> runTP $ length_take @Integer+-- Lemma: length_take                      Q.E.D.+-- [Proven] length_take :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool+length_take :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool))+length_take = lemma "length_take"+                    (\(Forall n) (Forall xs) -> n .>= 0 .=> length (take n xs) .== length xs `smin` n)+                    []++-- | @n >= 0 ==> length (drop n xs) == (length xs - n) \`max\` 0@+--+-- >>> runTP $ length_drop @Integer+-- Lemma: length_drop                      Q.E.D.+-- [Proven] length_drop :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool+length_drop :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool))+length_drop = lemma "length_drop"+                    (\(Forall n) (Forall xs) -> n .>= 0 .=> length (drop n xs) .== (length xs - n) `smax` 0)+                    []++-- | @length xs \<= n ==\> take n xs == xs@+--+-- >>> runTP $ take_all @Integer+-- Lemma: take_all                         Q.E.D.+-- [Proven] take_all :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool+take_all :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool))+take_all = lemma "take_all"+                 (\(Forall n) (Forall xs) -> length xs .<= n .=> take n xs .== xs)+                 []++-- | @length xs \<= n ==\> drop n xs == nil@+--+-- >>> runTP $ drop_all @Integer+-- Lemma: drop_all                         Q.E.D.+-- [Proven] drop_all :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool+drop_all :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool))+drop_all = lemma "drop_all"+                 (\(Forall n) (Forall xs) -> length xs .<= n .=> drop n xs .== nil)+                 []++-- | @take n (xs ++ ys) == (take n xs ++ take (n - length xs) ys)@+--+-- >>> runTP $ take_append @Integer+-- Lemma: take_append                      Q.E.D.+-- [Proven] take_append :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+take_append :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> Forall "ys" [a] -> SBool))+take_append = lemmaWith cvc5 "take_append"+                        (\(Forall n) (Forall xs) (Forall ys) -> take n (xs ++ ys) .== take n xs ++ take (n - length xs) ys)+                        []++-- | @drop n (xs ++ ys) == drop n xs ++ drop (n - length xs) ys@+--+-- NB. As of Feb 2025, z3 struggles to prove this, but cvc5 gets it out-of-the-box.+--+-- >>> runTP $ drop_append @Integer+-- Lemma: drop_append                      Q.E.D.+-- [Proven] drop_append :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+drop_append :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> Forall "ys" [a] -> SBool))+drop_append = lemmaWith cvc5 "drop_append"+                        (\(Forall n) (Forall xs) (Forall ys) -> drop n (xs ++ ys) .== drop n xs ++ drop (n - length xs) ys)+                        []++-- | @length xs == length ys ==> map fst (zip xs ys) = xs@+--+-- >>> runTP $ map_fst_zip @Integer @Integer+-- Inductive lemma: map_fst_zip+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] map_fst_zip :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool+map_fst_zip :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool))+map_fst_zip = induct "map_fst_zip"+                     (\(Forall xs, Forall ys) -> length xs .== length ys .=> map fst (zip xs ys) .== xs) $+                     \ih (x, xs, y, ys) -> [length (x .: xs) .== length (y .: ys)]+                                        |- map fst (zip (x .: xs) (y .: ys))+                                        =: map fst (tuple (x, y) .: zip xs ys)+                                        =: fst (tuple (x, y)) .: map fst (zip xs ys)+                                        =: x .: map fst (zip xs ys)+                                        ?? ih+                                        =: x .: xs+                                        =: qed++-- | @length xs == length ys ==> map snd (zip xs ys) = xs@+--+-- >>> runTP $ map_snd_zip @Integer @Integer+-- Inductive lemma: map_snd_zip+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] map_snd_zip :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool+map_snd_zip :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool))+map_snd_zip = induct "map_snd_zip"+                     (\(Forall xs, Forall ys) -> length xs .== length ys .=> map snd (zip xs ys) .== ys) $+                     \ih (x, xs, y, ys) -> [length (x .: xs) .== length (y .: ys)]+                                        |- map snd (zip (x .: xs) (y .: ys))+                                        =: map snd (tuple (x, y) .: zip xs ys)+                                        =: snd (tuple (x, y)) .: map snd (zip xs ys)+                                        =: y .: map snd (zip xs ys)+                                        ?? ih+                                        =: y .: ys+                                        =: qed++-- | @map fst (zip xs ys) == take (min (length xs) (length ys)) xs@+--+-- >>> runTP $ map_fst_zip_take @Integer @Integer+-- Lemma: take_cons                        Q.E.D.+-- Inductive lemma: map_fst_zip_take+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] map_fst_zip_take :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool+map_fst_zip_take :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool))+map_fst_zip_take = do+   tc <- take_cons @a++   induct "map_fst_zip_take"+          (\(Forall xs, Forall ys) -> map fst (zip xs ys) .== take (length xs `smin` length ys) xs) $+          \ih (x, xs, y, ys) -> [] |- map fst (zip (x .: xs) (y .: ys))+                                   =: map fst (tuple (x, y) .: zip xs ys)+                                   =: x .: map fst (zip xs ys)+                                   ?? ih+                                   =: x .: take (length xs `smin` length ys) xs+                                   ?? tc+                                   =: take (1 + (length xs `smin` length ys)) (x .: xs)+                                   =: take (length (x .: xs) `smin` length (y .: ys)) (x .: xs)+                                   =: qed++-- | @map snd (zip xs ys) == take (min (length xs) (length ys)) xs@+--+-- >>> runTP $ map_snd_zip_take @Integer @Integer+-- Lemma: take_cons                        Q.E.D.+-- Inductive lemma: map_snd_zip_take+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] map_snd_zip_take :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool+map_snd_zip_take :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool))+map_snd_zip_take = do+   tc <- take_cons @a++   induct "map_snd_zip_take"+          (\(Forall xs, Forall ys) -> map snd (zip xs ys) .== take (length xs `smin` length ys) ys) $+          \ih (x, xs, y, ys) -> [] |- map snd (zip (x .: xs) (y .: ys))+                                   =: map snd (tuple (x, y) .: zip xs ys)+                                   =: y .: map snd (zip xs ys)+                                   ?? ih+                                   =: y .: take (length xs `smin` length ys) ys+                                   ?? tc+                                   =: take (1 + (length xs `smin` length ys)) (y .: ys)+                                   =: take (length (x .: xs) `smin` length (y .: ys)) (y .: ys)+                                   =: qed++-- | Count the number of occurrences of an element in a list+count :: SymVal a => SBV a -> SList a -> SInteger+count = smtFunction "count" $ \e l -> ite (null l)+                                          0+                                          (let (x, xs) = uncons l+                                               cxs     = count e xs+                                           in ite (e .== x) (1 + cxs) cxs)++-- | Interleave the elements of two lists. If one ends, we take the rest from the other.+interleave :: SymVal a => SList a -> SList a -> SList a+interleave = smtFunction "interleave" (\xs ys -> ite (null  xs) ys (head xs .: interleave ys (tail xs)))++-- | Prove that interleave preserves total length.+--+-- The induction here is on the total length of the lists, and hence+-- we use the generalized induction principle. We have:+--+-- >>> runTP $ interleaveLen @Integer+-- Inductive lemma (strong): interleaveLen+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.2.3                         Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] interleaveLen :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+interleaveLen :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+interleaveLen = sInduct "interleaveLen"+                        (\(Forall xs) (Forall ys) -> length xs + length ys .== length (interleave xs ys))+                        (\xs ys -> length xs + length ys) $+                        \ih xs ys -> [] |- length xs + length ys .== length (interleave xs ys)+                                        =: split xs+                                                 trivial+                                                 (\a as -> length (a .: as) + length ys .== length (interleave (a .: as) ys)+                                                        =: 1 + length as + length ys .== 1 + length (interleave ys as)+                                                        ?? ih `at` (Inst @"xs" ys, Inst @"ys" as)+                                                        =: sTrue+                                                        =: qed)++-- | Uninterleave the elements of two lists. We roughly split it into two, of alternating elements.+uninterleave :: SymVal a => SList a -> STuple [a] [a]+uninterleave lst = uninterleaveGen lst (tuple (nil, nil))++-- | Generalized form of uninterleave with the auxilary lists made explicit.+uninterleaveGen :: SymVal a => SList a -> STuple [a] [a] -> STuple [a] [a]+uninterleaveGen = smtFunction "uninterleave" (\xs alts -> let (es, os) = untuple alts+                                                          in ite (null xs)+                                                                 (tuple (reverse es, reverse os))+                                                                 (uninterleaveGen (tail xs) (tuple (os, head xs .: es))))++-- | The functions 'uninterleave' and 'interleave' are inverses so long as the inputs are of the same length. (The equality+-- would even hold if the first argument has one extra element, but we keep things simple here.)+--+-- We have:+--+-- >>> runTP $ interleaveRoundTrip @Integer+-- Lemma: revCons                          Q.E.D.+-- Inductive lemma (strong): roundTripGen+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (4 way full case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2                           Q.E.D.+--     Step: 1.3                           Q.E.D.+--     Step: 1.4.1                         Q.E.D.+--     Step: 1.4.2                         Q.E.D.+--     Step: 1.4.3                         Q.E.D.+--     Step: 1.4.4                         Q.E.D.+--     Step: 1.4.5                         Q.E.D.+--     Step: 1.4.6                         Q.E.D.+--     Step: 1.4.7                         Q.E.D.+--     Step: 1.4.8                         Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: interleaveRoundTrip+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] interleaveRoundTrip :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+interleaveRoundTrip :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+interleaveRoundTrip = do++   revHelper <- lemma "revCons" (\(Forall a) (Forall as) (Forall bs) -> reverse @a (a .: as) ++ bs .== reverse as ++ (a .: bs)) []++   -- Generalize the theorem first to take the helper lists explicitly+   roundTripGen <- sInductWith cvc5+         "roundTripGen"+         (\(Forall @"xs" xs) (Forall @"ys" ys) (Forall @"alts" alts) ->+               length xs .== length ys .=> let (es, os) = untuple alts+                                           in uninterleaveGen (interleave xs ys) alts .== tuple (reverse es ++ xs, reverse os ++ ys))+         (\xs ys _alts -> length xs + length ys) $+         \ih xs ys alts -> [length xs .== length ys]+                        |- let (es, os) = untuple alts+                        in uninterleaveGen (interleave xs ys) alts+                        =: split2 (xs, ys)+                                  trivial+                                  trivial+                                  trivial+                                  (\(a, as) (b, bs) -> uninterleaveGen (interleave (a .: as) (b .: bs)) alts+                                                    =: uninterleaveGen (a .: interleave (b .: bs) as) alts+                                                    =: uninterleaveGen (a .: b .: interleave as bs) alts+                                                    =: uninterleaveGen (interleave as bs) (tuple (a .: es, b .: os))+                                                    ?? ih `at` (Inst @"xs" as, Inst @"ys" bs, Inst @"alts" (tuple (a .: es, b .: os)))+                                                    =: tuple (reverse (a .: es) ++ as, reverse (b .: os) ++ bs)+                                                    ?? revHelper `at` (Inst @"a" a, Inst @"as" es, Inst @"bs" as)+                                                    =: tuple (reverse es ++ (a .: as), reverse (b .: os) ++ bs)+                                                    ?? revHelper `at` (Inst @"a" b, Inst @"as" os, Inst @"bs" bs)+                                                    =: tuple (reverse es ++ (a .: as), reverse os ++ (b .: bs))+                                                    =: tuple (reverse es ++ xs, reverse os ++ ys)+                                                    =: qed)++   -- Round-trip theorem:+   calc "interleaveRoundTrip"+           (\(Forall xs) (Forall ys) -> length xs .== length ys .=> uninterleave (interleave xs ys) .== tuple (xs, ys)) $+           \xs ys -> [length xs .== length ys]+                  |- uninterleave (interleave xs ys)+                  =: uninterleaveGen (interleave xs ys) (tuple (nil, nil))+                  ?? roundTripGen `at` (Inst @"xs" xs, Inst @"ys" ys, Inst @"alts" (tuple (nil, nil)))+                  =: tuple (reverse nil ++ xs, reverse nil ++ ys)+                  =: qed++-- | @count e (xs ++ ys) == count e xs + count e ys@+--+-- >>> runTP $ countAppend @Integer+-- Inductive lemma: countAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2 (unfold count)                Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4 (simplify)                    Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] countAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐe ∷ Integer → Bool+countAppend :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "e" a -> SBool))+countAppend =+   induct "countAppend"+          (\(Forall xs) (Forall ys) (Forall e) -> count e (xs ++ ys) .== count e xs + count e ys) $+          \ih (x, xs) ys e -> [] |- count e ((x .: xs) ++ ys)+                                 =: count e (x .: (xs ++ ys))+                                 ?? "unfold count"+                                 =: (let r = count e (xs ++ ys) in ite (e .== x) (1+r) r)+                                 ?? ih `at` (Inst @"ys" ys, Inst @"e" e)+                                 =: (let r = count e xs + count e ys in ite (e .== x) (1+r) r)+                                 ?? "simplify"+                                 =: count e (x .: xs) + count e ys+                                 =: qed++-- | @count e (take n xs) + count e (drop n xs) == count e xs@+--+-- >>> runTP $ takeDropCount @Integer+-- Inductive lemma: countAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2 (unfold count)                Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4 (simplify)                    Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: take_drop                        Q.E.D.+-- Lemma: takeDropCount+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] takeDropCount :: Ɐxs ∷ [Integer] → Ɐn ∷ Integer → Ɐe ∷ Integer → Bool+takeDropCount :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "n" Integer -> Forall "e" a -> SBool))+takeDropCount = do+       capp     <- countAppend @a+       takeDrop <- take_drop   @a++       calc "takeDropCount"+            (\(Forall xs) (Forall n) (Forall e) -> count e (take n xs) + count e (drop n xs) .== count e xs) $+            \xs n e -> [] |- count e (take n xs) + count e (drop n xs)+                          ?? capp `at` (Inst @"xs" (take n xs), Inst @"ys" (drop n xs), Inst @"e" e)+                          =: count e (take n xs ++ drop n xs)+                          ?? takeDrop+                          =: count e xs+                          =: qed++-- | @count e xs >= 0@+--+-- >>> runTP $ countNonNeg @Integer+-- Inductive lemma: countNonNeg+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] countNonNeg :: Ɐxs ∷ [Integer] → Ɐe ∷ Integer → Bool+countNonNeg :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "e" a -> SBool))+countNonNeg =+   induct "countNonNeg"+          (\(Forall xs) (Forall e) -> count e xs .>= 0) $+          \ih (x, xs) e -> [] |- count e (x .: xs) .>= 0+                              =: cases [ e .== x ==> 1 + count e xs .>= 0+                                                  ?? ih+                                                  =: sTrue+                                                  =: qed+                                       , e ./= x ==> count e xs .>= 0+                                                  ?? ih+                                                  =: sTrue+                                                  =: qed+                                       ]++-- | @e \`elem\` xs ==> count e xs .> 0@+--+-- >>> runTP $ countElem @Integer+-- Inductive lemma: countNonNeg+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: countElem+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] countElem :: Ɐxs ∷ [Integer] → Ɐe ∷ Integer → Bool+countElem :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "e" a -> SBool))+countElem = do++    cnn <- countNonNeg @a++    induct "countElem"+           (\(Forall xs) (Forall e) -> e `elem` xs .=> count e xs .> 0) $+           \ih (x, xs) e -> [e `elem` (x .: xs)]+                         |- count e (x .: xs) .> 0+                         =: cases [ e .== x ==> 1 + count e xs .> 0+                                             ?? cnn+                                             =: sTrue+                                             =: qed+                                  , e ./= x ==> count e xs .> 0+                                             ?? ih+                                             =: sTrue+                                             =: qed+                                  ]++-- | @count e xs .> 0 .=> e \`elem\` xs@+--+-- >>> runTP $ elemCount @Integer+-- Inductive lemma: elemCount+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] elemCount :: Ɐxs ∷ [Integer] → Ɐe ∷ Integer → Bool+elemCount :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "e" a -> SBool))+elemCount =+    induct "elemCount"+           (\(Forall xs) (Forall e) -> count e xs .> 0 .=> e `elem` xs) $+           \ih (x, xs) e -> [count e xs .> 0]+                         |- e `elem` (x .: xs)+                         =: cases [ e .== x ==> trivial+                                  , e ./= x ==> e `elem` xs+                                             ?? ih+                                             =: sTrue+                                             =: qed+                                  ]++{- HLint ignore revRev         "Redundant reverse" -}+{- HLint ignore allAny         "Use and"           -}+{- HLint ignore bookKeeping    "Fuse foldr/map"    -}+{- HLint ignore foldrMapFusion "Fuse foldr/map"    -}+{- HLint ignore filterConcat   "Move filter"       -}+{- HLint ignore module         "Use camelCase"     -}+{- HLint ignore module         "Use first"         -}+{- HLint ignore module         "Use second"        -}+{- HLint ignore module         "Use zipWith"       -}+{- HLint ignore mapCompose     "Use map once"      -}+{- HLint ignore tailsAppend    "Avoid lambda"      -}+{- HLint ignore tailsAppend    "Use :"             -}+{- HLint ignore mapReverse     "Evaluate"          -}+{- HLint ignore takeDropWhile  "Evaluate"          -}
+ Data/SBV/TP/TP.hs view
@@ -0,0 +1,1507 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.TP.TP+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+-----------------------------------------------------------------------------++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeAbstractions           #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilyDependencies     #-}+{-# LANGUAGE TypeOperators              #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.TP.TP (+         Proposition, Proof, proofOf, assumptionFromProof, Instantiatable(..), Inst(..)+       , rootOfTrust, RootOfTrust(..), ProofTree(..), showProofTree, showProofTreeHTML+       ,   axiom+       ,   lemma,   lemmaWith+       ,    calc,    calcWith+       ,  induct,  inductWith+       , sInduct, sInductWith+       , sorry+       , TP, runTP, runTPWith, tpQuiet, tpRibbon, tpStats, tpCache+       , (|-), (⊢), (=:), (≡), (??), (∵), split, split2, cases, (==>), (⟹), qed, trivial, contradiction+       , qc, qcWith+       , disp+       ) where++import Data.SBV+import Data.SBV.Core.Model (qSaturateSavingObservables)+import Data.SBV.Core.Data  (SBV(..), SVal(..))+import qualified Data.SBV.Core.Symbolic as S (sObserve)++import Data.SBV.Core.Operations (svEqual)+import Data.SBV.Control hiding (getProof)++import Data.SBV.TP.Kernel+import Data.SBV.TP.Utils++import qualified Data.SBV.List as SL++import Control.Monad (when)+import Control.Monad.Trans (liftIO)++import Data.Char  (isSpace)+import Data.List  (intercalate, isPrefixOf, isSuffixOf)+import Data.Maybe (catMaybes, maybeToList)++import Data.Proxy+import Data.Kind    (Type)+import GHC.TypeLits (KnownSymbol, symbolVal, Symbol)++import Data.SBV.Utils.TDiff++import Data.Dynamic++import qualified Test.QuickCheck as QC+import Test.QuickCheck (quickCheckWithResult)++-- | Captures the steps for a calculationa proof+data CalcStrategy = CalcStrategy { calcIntros     :: SBool+                                 , calcProofTree  :: TPProof+                                 , calcQCInstance :: [Int] -> Symbolic SBool+                                 }++-- | Saturatable things in steps+proofTreeSaturatables :: TPProof -> [SBool]+proofTreeSaturatables = go+  where go (ProofEnd    b           hs                ) = b : concatMap getH hs+        go (ProofStep   a           hs               r) = a : concatMap getH hs ++ go r+        go (ProofBranch (_ :: Bool) (_ :: [String]) ps) = concat [b : go p | (b, p) <- ps]++        getH (HelperProof  p) = [getObjProof p]+        getH (HelperAssum  b) = [b]+        getH HelperQC{}       = []+        getH HelperString{}   = []+        getH (HelperDisp _ v) = [SBV (v `svEqual` v)]++-- | Things that are inside calc-strategy that we have to saturate+getCalcStrategySaturatables :: CalcStrategy -> [SBool]+getCalcStrategySaturatables (CalcStrategy calcIntros calcProofTree _calcQCInstance) = calcIntros : proofTreeSaturatables calcProofTree++-- | Propagate the settings for ribbon/timing from top to current. Because in any subsequent configuration+-- in a lemmaWith, inductWith etc., we just want to change the solver, not the actual settings for TP.+tpMergeCfg :: SMTConfig -> SMTConfig -> SMTConfig+tpMergeCfg cur top = cur{tpOptions = tpOptions top}++-- | Use an injective type family to allow for curried use of calc and strong induction steps.+type family StepArgs a t = result | result -> t where+  StepArgs                                                                             SBool  t =                                               (SBool, TPProofRaw (SBV t))+  StepArgs (Forall na a                                                             -> SBool) t = (SBV a                                     -> (SBool, TPProofRaw (SBV t)))+  StepArgs (Forall na a -> Forall nb b                                              -> SBool) t = (SBV a -> SBV b                            -> (SBool, TPProofRaw (SBV t)))+  StepArgs (Forall na a -> Forall nb b -> Forall nc c                               -> SBool) t = (SBV a -> SBV b -> SBV c                   -> (SBool, TPProofRaw (SBV t)))+  StepArgs (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d                -> SBool) t = (SBV a -> SBV b -> SBV c -> SBV d          -> (SBool, TPProofRaw (SBV t)))+  StepArgs (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) t = (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> (SBool, TPProofRaw (SBV t)))++-- | Use an injective type family to allow for curried use of measures in strong induction instances+type family MeasureArgs a t = result | result -> t where+  MeasureArgs                                                                             SBool  t = (                                             SBV t)+  MeasureArgs (Forall na a                                                             -> SBool) t = (SBV a                                     -> SBV t)+  MeasureArgs (Forall na a -> Forall nb b                                              -> SBool) t = (SBV a -> SBV b                            -> SBV t)+  MeasureArgs (Forall na a -> Forall nb b -> Forall nc c                               -> SBool) t = (SBV a -> SBV b -> SBV c                   -> SBV t)+  MeasureArgs (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d                -> SBool) t = (SBV a -> SBV b -> SBV c -> SBV d          -> SBV t)+  MeasureArgs (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) t = (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV t)++-- | Use an injective type family to allow for curried use of regular induction steps. The first argument is the inductive arg that comes separately,+-- and hence is not used in the right-hand side of the equation.+type family IStepArgs a t = result | result -> t where+  IStepArgs ( Forall nx x                                                                                          -> SBool) t =                                               (SBool, TPProofRaw (SBV t))+  IStepArgs ( Forall nx x               -> Forall na a                                                             -> SBool) t = (SBV a ->                                     (SBool, TPProofRaw (SBV t)))+  IStepArgs ( Forall nx x               -> Forall na a -> Forall nb b                                              -> SBool) t = (SBV a -> SBV b                            -> (SBool, TPProofRaw (SBV t)))+  IStepArgs ( Forall nx x               -> Forall na a -> Forall nb b -> Forall nc c                               -> SBool) t = (SBV a -> SBV b -> SBV c                   -> (SBool, TPProofRaw (SBV t)))+  IStepArgs ( Forall nx x               -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d                -> SBool) t = (SBV a -> SBV b -> SBV c -> SBV d          -> (SBool, TPProofRaw (SBV t)))+  IStepArgs ( Forall nx x               -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) t = (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> (SBool, TPProofRaw (SBV t)))+  IStepArgs ((Forall nx x, Forall ny y)                                                                            -> SBool) t =                                               (SBool, TPProofRaw (SBV t))+  IStepArgs ((Forall nx x, Forall ny y) -> Forall na a                                                             -> SBool) t = (SBV a ->                                     (SBool, TPProofRaw (SBV t)))+  IStepArgs ((Forall nx x, Forall ny y) -> Forall na a -> Forall nb b                                              -> SBool) t = (SBV a -> SBV b                            -> (SBool, TPProofRaw (SBV t)))+  IStepArgs ((Forall nx x, Forall ny y) -> Forall na a -> Forall nb b -> Forall nc c                               -> SBool) t = (SBV a -> SBV b -> SBV c                   -> (SBool, TPProofRaw (SBV t)))+  IStepArgs ((Forall nx x, Forall ny y) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d                -> SBool) t = (SBV a -> SBV b -> SBV c -> SBV d          -> (SBool, TPProofRaw (SBV t)))+  IStepArgs ((Forall nx x, Forall ny y) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) t = (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> (SBool, TPProofRaw (SBV t)))++-- | A class for doing equational reasoning style calculational proofs. Use 'calc' to prove a given theorem+-- as a sequence of equalities, each step following from the previous.+class Calc a where+  -- | Prove a property via a series of equality steps, using the default solver.+  -- Let @H@ be a list of already established lemmas. Let @P@ be a property we wanted to prove, named @name@.+  -- Consider a call of the form @calc name P (cond, [A, B, C, D]) H@. Note that @H@ is+  -- a list of already proven facts, ensured by the type signature. We proceed as follows:+  --+  --    * Prove: @(H && cond)                                   -> (A == B)@+  --    * Prove: @(H && cond && A == B)                         -> (B == C)@+  --    * Prove: @(H && cond && A == B && B == C)               -> (C == D)@+  --    * Prove: @(H && (cond -> (A == B && B == C && C == D))) -> P@+  --    * If all of the above steps succeed, conclude @P@.+  --+  -- cond acts as the context. Typically, if you are trying to prove @Y -> Z@, then you want cond to be Y.+  -- (This is similar to @intros@ commands in theorem provers.)+  --+  -- So, calc-lemma is essentially modus-ponens, applied in a sequence of stepwise equality reasoning in the case of+  -- non-boolean steps.+  --+  -- If there are no helpers given (i.e., if @H@ is empty), then this call is equivalent to 'lemmaWith'.+  calc :: (Proposition a, SymVal t, EqSymbolic (SBV t)) => String -> a -> StepArgs a t -> TP (Proof a)++  -- | Prove a property via a series of equality steps, using the given solver.+  calcWith :: (Proposition a, SymVal t, EqSymbolic (SBV t)) => SMTConfig -> String -> a -> StepArgs a t -> TP (Proof a)++  -- | Internal, shouldn't be needed outside the library+  {-# MINIMAL calcSteps #-}+  calcSteps :: (SymVal t, EqSymbolic (SBV t)) => a -> StepArgs a t -> Symbolic (SBool, CalcStrategy)++  calc         nm p steps = getTPConfig >>= \cfg  -> calcWith          cfg                   nm p steps+  calcWith cfg nm p steps = getTPConfig >>= \cfg' -> calcGeneric False (tpMergeCfg cfg cfg') nm p steps++  calcGeneric :: (SymVal t, EqSymbolic (SBV t), Proposition a) => Bool -> SMTConfig -> String -> a -> StepArgs a t -> TP (Proof a)+  calcGeneric tagTheorem cfg nm result steps = withProofCache nm $ do+      tpSt <- getTPState+      u    <- tpGetNextUnique++      (_, CalcStrategy {calcQCInstance}) <- liftIO $ runSMTWith cfg (calcSteps result steps)++      liftIO $ runSMTWith cfg $ do++         qSaturateSavingObservables result -- make sure we saturate the result, i.e., get all it's UI's, types etc. pop out++         message cfg $ (if tagTheorem then "Theorem" else "Lemma") ++ ": " ++ nm ++ "\n"++         (calcGoal, strategy@CalcStrategy {calcIntros, calcProofTree}) <- calcSteps result steps++         -- Collect all subterms and saturate them+         mapM_ qSaturateSavingObservables $ getCalcStrategySaturatables strategy++         query $ proveProofTree cfg tpSt nm (result, calcGoal) calcIntros calcProofTree u calcQCInstance++-- | In the proof tree, what's the next node label?+nextProofStep :: [Int] -> [Int]+nextProofStep bs = case reverse bs of+                     i : rs -> reverse $ i + 1 : rs+                     []     -> [1]++-- | Prove the proof tree. The arguments are:+--+--      result           : The ultimate goal we want to prove. Note that this is a general proposition, and we don't actually prove it. See the next param.+--      resultBool       : The instance of result that, if we prove it, establishes the result itself+--      initialHypotheses: Hypotheses (conjuncted)+--      calcProofTree    : A tree of steps, which give rise to a bunch of equalities+--+-- Note that we do not check the resultBool is the result itself just "instantiated" appropriately. This is the contract with the caller who+-- has to establish that by whatever means it chooses to do so.+--+-- The final proof we have has the following form:+--+--     - For each "link" in the proofTree, prove that intros .=> link+--     - The above will give us a bunch of results, for each leaf node in the tree.+--     - Then prove: (intros .=> sAnd results) .=> resultBool+--     - Then conclude result, based on what assumption that proving resultBool establishes result+--+-- NB. This function needs to be in "sync" with qcRun below for obvious reasons. So, any changes there+-- make it here too!+proveProofTree :: Proposition a+               => SMTConfig+               -> TPState+               -> String                    -- ^ the name of the top result+               -> (a, SBool)                -- ^ goal: as a proposition and as a boolean+               -> SBool                     -- ^ hypotheses+               -> TPProof                   -- ^ proof tree+               -> TPUnique                  -- ^ unique id+               -> ([Int] -> Symbolic SBool) -- ^ quick-checker+               -> Query (Proof a)+proveProofTree cfg tpSt nm (result, resultBool) initialHypotheses calcProofTree uniq quickCheckInstance = do+    results <- walk initialHypotheses 1 ([1], calcProofTree)++    queryDebug [nm ++ ": Proof end: proving the result:"]++    mbStartTime <- getTimeStampIf printStats+    smtProofStep cfg tpSt "Result" 1+                 (TPProofStep False nm [] [""])+                 (Just (initialHypotheses .=> sAnd results))+                 resultBool [] $ \d ->+                   do mbElapsed <- getElapsedTime mbStartTime+                      let modulo = concludeModulo (concatMap getHelperProofs (getAllHelpers calcProofTree))+                      finishTP cfg ("Q.E.D." ++ modulo) d (catMaybes [mbElapsed])++                      pure $ Proof $ ProofObj { dependencies = getDependencies calcProofTree+                                              , isUserAxiom  = False+                                              , getObjProof  = label nm (quantifiedBool result)+                                              , getProp      = toDyn result+                                              , proofName    = nm+                                              , uniqId       = uniq+                                              , isCached     = False+                                              }++  where SMTConfig{tpOptions = TPOptions{printStats}} = cfg++        isEnd ProofEnd{}    = True+        isEnd ProofStep{}   = False+        isEnd ProofBranch{} = False++        -- trim the branch-name, if we're in a deeper level, and we're at the end+        trimBN level bn | level > 1, 1 : _ <- reverse bn = init bn+                        | True                           = bn++        -- If the next step is ending and we're the 1st step; our number can be skipped+        mkStepName level bn nextStep | isEnd nextStep = map show (trimBN level bn)+                                     | True           = map show bn++        walk :: SBool -> Int -> ([Int], TPProof) -> Query [SBool]++        -- End of proof, return what it established. If there's a hint associated here, it was probably by mistake; so tell it to the user.+        walk intros level (bn, ProofEnd calcResult hs)+           | not (null hs)+           = error $ unlines [ ""+                             , "*** Incorrect calc/induct lemma calculations."+                             , "***"+                             , "***    The last step in the proof has a helper, which isn't used."+                             , "***"+                             , "*** Perhaps the hint is off-by-one in its placement?"+                             ]+           | True+           =  do -- If we're not at the top-level and this is the only step, print it.+                 -- Otherwise the noise isn't necessary.+                 when (level > 1) $ case reverse bn of+                                      1 : _ -> liftIO $ do tab <- startTP cfg False "Step" level (TPProofStep False nm [] (map show (init bn)))+                                                           finishTP cfg "Q.E.D." (tab, Nothing) []+                                      _     -> pure ()++                 pure [intros .=> calcResult]++        -- Do the branches separately and collect the results. If there's coverage needed, we do it too; which+        -- is essentially the assumption here.+        walk intros level (bnTop, ProofBranch checkCompleteness hintStrings ps) = do++          let bn = trimBN level bnTop++              addSuffix xs s = case reverse xs of+                                  l : p -> reverse $ (l ++ s) : p+                                  []    -> [s]++              full | checkCompleteness = ""+                   | True              = "full "++              stepName = map show bn++          _ <- io $ startTP cfg True "Step" level (TPProofStep False nm hintStrings (addSuffix stepName (" (" ++ show (length ps) ++ " way " ++ full ++ "case split)")))++          results <- concat <$> sequence [walk (intros .&& branchCond) (level + 1) (bn ++ [i, 1], p) | (i, (branchCond, p)) <- zip [1..] ps]++          when checkCompleteness $ smtProofStep cfg tpSt "Step" (level+1)+                                                         (TPProofStep False nm [] (stepName ++ ["Completeness"]))+                                                         (Just intros)+                                                         (sOr (map fst ps))+                                                         []+                                                         (\d -> finishTP cfg "Q.E.D." d [])+          pure results++        -- Do a proof step+        walk intros level (bn, ProofStep cur hs p) = do++             let finish et helpers d = finishTP cfg ("Q.E.D." ++ concludeModulo helpers) d et+                 stepName            = mkStepName level bn p+                 disps               = [(n, v) | HelperDisp n v <- hs]++                 -- First prove the assumptions, if there are any. We stay quiet, unless timing is asked for+                 (quietCfg, finalizer)+                   | printStats = (cfg,                                             finish [] [])+                   | True       = (cfg{tpOptions = (tpOptions cfg) {quiet = True}}, const (pure ()))++                 as = concatMap getHelperAssumes hs+                 ss = getHelperText hs++             case as of+               [] -> pure ()+               _  -> smtProofStep quietCfg tpSt "Asms" level+                                           (TPProofStep True nm [] stepName)+                                           (Just intros)+                                           (sAnd as)+                                           disps+                                           finalizer++             -- Are we asked to do quick-check?+             case [qcArg | HelperQC qcArg <- hs] of+               [] -> do -- No quickcheck. Just prove the step+                        let by = concatMap getHelperProofs hs++                        smtProofStep cfg tpSt "Step" level+                                         (TPProofStep False nm ss stepName)+                                         (Just (sAnd (intros : as ++ map getObjProof by)))+                                         cur+                                         disps+                                         (finish [] by)++               xs -> do let qcArg = last xs -- take the last one if multiple exists. Why not?++                            hs' = concatMap xform hs ++ [HelperString ("qc: Running " ++ show (QC.maxSuccess qcArg) ++ " tests")]+                            xform HelperProof{}    = []+                            xform HelperAssum{}    = []+                            xform h@HelperQC{}     = [h]+                            xform h@HelperString{} = [h]+                            xform HelperDisp{}     = []++                        liftIO $ do++                           tab <- startTP cfg (verbose cfg) "Step" level (TPProofStep False nm (getHelperText hs') stepName)++                           (mbT, r) <- timeIf printStats $ quickCheckWithResult qcArg{QC.chatty = verbose cfg} $ quickCheckInstance bn++                           case mbT of+                             Nothing -> pure ()+                             Just t  -> updStats tpSt (\s -> s{qcElapsed = qcElapsed s + t})++                           let err = case r of+                                   QC.Success {}                -> Nothing+                                   QC.Failure {QC.output = out} -> Just out+                                   QC.GaveUp  {}                -> Just $ unlines [ "*** QuickCheck reported \"GaveUp\""+                                                                                  , "***"+                                                                                  , "*** This can happen if you have assumptions in the environment"+                                                                                  , "*** that makes it hard for quick-check to generate valid test values."+                                                                                  , "***"+                                                                                  , "*** See if you can reduce assumptions. If not, please get in touch,"+                                                                                  , "*** to see if we can handle the problem via custom Arbitrary instances."+                                                                                  ]+                                   QC.NoExpectedFailure {}      -> Just "Expected failure but test passed." -- can't happen++                           case err of+                             Just e  -> do putStrLn $ "\n*** QuickCheck failed for " ++ intercalate "." (nm : stepName)+                                           putStrLn e+                                           error "Failed"++                             Nothing -> let extra = [' ' | printStats]  -- aligns better when printing stats+                                        in finishTP cfg ("QC OK" ++ extra) (tab, mbT) []++             -- Move to next+             walk intros level (nextProofStep bn, p)++-- | Helper data-type for calc-step below+data CalcContext a = CalcStart     [Helper] -- Haven't started yet+                   | CalcStep  a a [Helper] -- Intermediate step: first value, prev value+++-- | Turn a raw (i.e., as written by the user) proof tree to a tree where the successive equalities are made explicit.+mkProofTree :: SymVal a => (SBV a -> SBV a -> c) -> TPProofRaw (SBV a) -> TPProofGen c [String] SBool+mkProofTree symEq = go (CalcStart [])+  where -- End of the proof; tie the begin and end+        go step (ProofEnd () hs) = case step of+                                     -- It's tempting to error out if we're at the start and already reached the end+                                     -- This means we're given a sequence of no-steps. While this is useless in the+                                     -- general case, it's quite valid in a case-split; where one of the case-splits+                                     -- might be easy enough for the solver to deduce so the user simply says "just derive it for me."+                                     CalcStart hs'           -> ProofEnd sTrue (hs' ++ hs) -- Nothing proven!+                                     CalcStep  begin end hs' -> ProofEnd (begin .== end) (hs' ++ hs)++        -- Branch: Just push it down. We use the hints from previous step, and pass the current ones down.+        go step (ProofBranch c hs ps) = ProofBranch c (getHelperText hs) [(bc, go step' p) | (bc, p) <- ps]+           where step' = case step of+                           CalcStart hs'     -> CalcStart (hs' ++ hs)+                           CalcStep  a b hs' -> CalcStep a b (hs' ++ hs)++        -- Step:+        go (CalcStart hs)           (ProofStep cur hs' p) = go (CalcStep cur cur (hs' ++ hs)) p+        go (CalcStep first prev hs) (ProofStep cur hs' p) = ProofStep (symEq prev cur) hs (go (CalcStep first cur hs') p)++-- | Turn a sequence of steps into a chain of equalities+mkCalcSteps :: SymVal a => (SBool, TPProofRaw (SBV a)) -> ([Int] -> Symbolic SBool) -> Symbolic CalcStrategy+mkCalcSteps (intros, tpp) qcInstance = do+        pure $ CalcStrategy { calcIntros     = intros+                            , calcProofTree  = mkProofTree (.==) tpp+                            , calcQCInstance = qcInstance+                            }++-- | Given initial hypothesis, and a raw proof tree, build the quick-check walk over this tree for the step that's marked as such.+qcRun :: SymVal a => [Int] -> (SBool, TPProofRaw (SBV a)) -> Symbolic SBool+qcRun checkedLabel (intros, tpp) = do+        results <- runTree sTrue 1 ([1], mkProofTree (\a b -> (a, b, a .== b)) tpp)+        case [b | (l, b) <- results, l == checkedLabel] of+          [(caseCond, b)] -> do constrain $ intros .&& caseCond+                                pure b+          []              -> notFound+          _               -> die "Hit the label multiple times."++ where die why =  error $ unlines [ ""+                                  , "*** Data.SBV.patch: Impossible happened."+                                  , "***"+                                  , "*** " ++ why+                                  , "***"+                                  , "*** While trying to quickcheck at level " ++ show checkedLabel+                                  , "*** Please report this as a bug!"+                                  ]++       -- It is possible that we may not find the node. Why? Because it might be under a case-split (ite essentially)+       -- and the random choices we made before-hand may just not get us there. Sigh. So, the right thing to do is+       -- to just say "we're good." But this can also indicate a bug in our code. Oh well, we'll ignore it.+       notFound = pure sTrue++       -- "run" the tree, and if we hit the correct label return the result.+       -- This needs to be in "sync" with proveProofTree for obvious reasons. So, any changes there+       -- make it here too!+       runTree :: SymVal a => SBool -> Int -> ([Int], TPProofGen (SBV a, SBV a, SBool) [String] SBool) -> Symbolic [([Int], (SBool, SBool))]+       runTree _        _     (_,  ProofEnd{})         = pure []+       runTree caseCond level (bn, ProofBranch _ _ ps) = concat <$> sequence [runTree (caseCond .&& branchCond) (level + 1) (bn ++ [i, 1], p)+                                                                             | (i, (branchCond, p)) <- zip [1..] ps+                                                                             ]+       runTree caseCond level (bn, ProofStep (lhs, rhs, cur) hs p) = do rest <- runTree caseCond level (nextProofStep bn, p)+                                                                        when (bn == checkedLabel) $ do+                                                                                sObserve "lhs" lhs+                                                                                sObserve "rhs" rhs+                                                                                mapM_ (uncurry S.sObserve) [(n, v) | HelperDisp n v <- hs]+                                                                        pure $ (bn, (caseCond, cur)) : rest++-- | Chaining lemmas that depend on no extra variables+instance Calc SBool where+   calcSteps result steps = (result,) <$> mkCalcSteps steps (`qcRun` steps)++-- | Chaining lemmas that depend on a single extra variable.+instance (KnownSymbol na, SymVal a) => Calc (Forall na a -> SBool) where+   calcSteps result steps = do a  <- free (symbolVal (Proxy @na))+                               let q checkedLabel = do aa <- free (symbolVal (Proxy @na))+                                                       qcRun checkedLabel (steps aa)+                               (result (Forall a),) <$> mkCalcSteps (steps a) q++-- | Chaining lemmas that depend on two extra variables.+instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b) => Calc (Forall na a -> Forall nb b -> SBool) where+   calcSteps result steps = do (a, b) <- (,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb))+                               let q checkedLabel = do (aa, ab) <- (,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb))+                                                       qcRun checkedLabel (steps aa ab)+                               (result (Forall a) (Forall b),) <$> mkCalcSteps (steps a b) q++-- | Chaining lemmas that depend on three extra variables.+instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c) => Calc (Forall na a -> Forall nb b -> Forall nc c -> SBool) where+   calcSteps result steps = do (a, b, c) <- (,,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb)) <*> free (symbolVal (Proxy @nc))+                               let q checkedLabel = do (aa, ab, ac) <- (,,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb)) <*> free (symbolVal (Proxy @nc))+                                                       qcRun checkedLabel (steps aa ab ac)+                               (result (Forall a) (Forall b) (Forall c),) <$> mkCalcSteps (steps a b c) q++-- | Chaining lemmas that depend on four extra variables.+instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d) => Calc (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) where+   calcSteps result steps = do (a, b, c, d) <- (,,,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb)) <*> free (symbolVal (Proxy @nc)) <*> free (symbolVal (Proxy @nd))+                               let q checkedLabel = do sb <- steps <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb)) <*> free (symbolVal (Proxy @nc)) <*> free (symbolVal (Proxy @nd))+                                                       qcRun checkedLabel sb+                               (result (Forall a) (Forall b) (Forall c) (Forall d),) <$> mkCalcSteps (steps a b c d) q++-- | Chaining lemmas that depend on five extra variables.+instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e)+      => Calc (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) where+   calcSteps result steps = do (a, b, c, d, e) <- (,,,,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb)) <*> free (symbolVal (Proxy @nc)) <*> free (symbolVal (Proxy @nd)) <*> free (symbolVal (Proxy @ne))+                               let q checkedLabel = do sb <- steps <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb)) <*> free (symbolVal (Proxy @nc)) <*> free (symbolVal (Proxy @nd)) <*> free (symbolVal (Proxy @ne))+                                                       qcRun checkedLabel sb+                               (result (Forall a) (Forall b) (Forall c) (Forall d) (Forall e),) <$> mkCalcSteps (steps a b c d e) q++-- | Captures the schema for an inductive proof. Base case might be nothing, to cover strong induction.+data InductionStrategy = InductionStrategy { inductionIntros     :: SBool+                                           , inductionMeasure    :: Maybe SBool+                                           , inductionBaseCase   :: Maybe SBool+                                           , inductionProofTree  :: TPProof+                                           , inductiveStep       :: SBool+                                           , inductiveQCInstance :: [Int] -> Symbolic SBool+                                           }++-- | Are we doing regular induction or measure based general induction?+data InductionStyle = RegularInduction | GeneralInduction++getInductionStrategySaturatables :: InductionStrategy -> [SBool]+getInductionStrategySaturatables (InductionStrategy inductionIntros+                                                    inductionMeasure+                                                    inductionBaseCase+                                                    inductionProofSteps+                                                    inductiveStep+                                                    _inductiveQCInstance)+  = inductionIntros : inductiveStep : proofTreeSaturatables inductionProofSteps ++ maybeToList inductionBaseCase ++ maybeToList inductionMeasure++-- | A class for doing regular inductive proofs.+class Inductive a where+   type IHType a :: Type+   type IHArg  a :: Type++   -- | Inductively prove a lemma, using the default config.+   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only+   -- partial correctness is guaranteed if non-terminating functions are involved.+   induct  :: (Proposition a, SymVal t, EqSymbolic (SBV t)) => String -> a -> (Proof (IHType a) -> IHArg a -> IStepArgs a t) -> TP (Proof a)++   -- | Same as 'induct', but with the given solver configuration.+   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only+   -- partial correctness is guaranteed if non-terminating functions are involved.+   inductWith :: (Proposition a, SymVal t, EqSymbolic (SBV t)) => SMTConfig -> String -> a -> (Proof (IHType a) -> IHArg a -> IStepArgs a t) -> TP (Proof a)++   induct         nm p steps = getTPConfig >>= \cfg  -> inductWith                             cfg                   nm p steps+   inductWith cfg nm p steps = getTPConfig >>= \cfg' -> inductionEngine RegularInduction False (tpMergeCfg cfg cfg') nm p (inductionStrategy p steps)++   -- | Internal, shouldn't be needed outside the library+   {-# MINIMAL inductionStrategy #-}+   inductionStrategy :: (Proposition a, SymVal t, EqSymbolic (SBV t)) => a -> (Proof (IHType a) -> IHArg a -> IStepArgs a t) -> Symbolic InductionStrategy++-- | A class of values, capturing the zero of a measure value+class OrdSymbolic (SBV a) => Zero a where+  zero :: SBV a++-- | An integer as a measure+instance Zero Integer where+   zero = literal 0++-- | A tuple of integers as a measure+instance Zero (Integer, Integer) where+  zero = literal (0, 0)++-- | A triple of integers as a measure+instance Zero (Integer, Integer, Integer) where+  zero = literal (0, 0, 0)++-- | A quadruple of integers as a measure+instance Zero (Integer, Integer, Integer, Integer) where+  zero = literal (0, 0, 0, 0)++instance Zero (Integer, Integer, Integer, Integer, Integer) where+  zero = literal (0, 0, 0, 0, 0)++-- | A class for doing generalized measure based strong inductive proofs.+class SInductive a where+   -- | Inductively prove a lemma, using measure based induction, using the default config.+   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only+   -- partial correctness is guaranteed if non-terminating functions are involved.+   sInduct :: (Proposition a, Zero m, SymVal t, EqSymbolic (SBV t)) => String -> a -> MeasureArgs a m -> (Proof a -> StepArgs a t) -> TP (Proof a)++   -- | Same as 'sInduct', but with the given solver configuration.+   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only+   -- partial correctness is guaranteed if non-terminating functions are involved.+   sInductWith :: (Proposition a, Zero m, SymVal t, EqSymbolic (SBV t)) => SMTConfig -> String -> a -> MeasureArgs a m -> (Proof a -> StepArgs a t) -> TP (Proof a)++   sInduct         nm p m steps = getTPConfig >>= \cfg  -> sInductWith                            cfg                   nm p m steps+   sInductWith cfg nm p m steps = getTPConfig >>= \cfg' -> inductionEngine GeneralInduction False (tpMergeCfg cfg cfg') nm p (sInductionStrategy p m steps)++   -- | Internal, shouldn't be needed outside the library+   {-# MINIMAL sInductionStrategy #-}+   sInductionStrategy :: (Proposition a, Zero m, SymVal t, EqSymbolic (SBV t)) => a -> MeasureArgs a m -> (Proof a -> StepArgs a t) -> Symbolic InductionStrategy++-- | Do an inductive proof, based on the given strategy+inductionEngine :: Proposition a => InductionStyle -> Bool -> SMTConfig -> String -> a -> Symbolic InductionStrategy -> TP (Proof a)+inductionEngine style tagTheorem cfg nm result getStrategy = withProofCache nm $ do+   tpSt <- getTPState+   u    <- tpGetNextUnique++   liftIO $ runSMTWith cfg $ do++      qSaturateSavingObservables result -- make sure we saturate the result, i.e., get all it's UI's, types etc. pop out++      let qual = case style of+                   RegularInduction -> ""+                   GeneralInduction  -> " (strong)"++      message cfg $ "Inductive " ++ (if tagTheorem then "theorem" else "lemma") ++ qual ++ ": " ++ nm ++ "\n"++      strategy@InductionStrategy { inductionIntros+                                 , inductionMeasure+                                 , inductionBaseCase+                                 , inductionProofTree+                                 , inductiveStep+                                 , inductiveQCInstance+                                 } <- getStrategy++      mapM_ qSaturateSavingObservables $ getInductionStrategySaturatables strategy++      query $ do++       case inductionMeasure of+          Nothing -> queryDebug [nm ++ ": Induction" ++ qual ++ ", there is no custom measure to show non-negativeness."]+          Just ms -> do queryDebug [nm ++ ": Induction, proving measure is always non-negative:"]+                        smtProofStep cfg tpSt "Step" 1+                                              (TPProofStep False nm [] ["Measure is non-negative"])+                                              (Just inductionIntros)+                                              ms+                                              []+                                              (\d -> finishTP cfg "Q.E.D." d [])+       case inductionBaseCase of+          Nothing -> queryDebug [nm ++ ": Induction" ++ qual ++ ", there is no base case to prove."]+          Just bc -> do queryDebug [nm ++ ": Induction, proving base case:"]+                        smtProofStep cfg tpSt "Step" 1+                                              (TPProofStep False nm [] ["Base"])+                                              (Just inductionIntros)+                                              bc+                                              []+                                              (\d -> finishTP cfg "Q.E.D." d [])++       proveProofTree cfg tpSt nm (result, inductiveStep) inductionIntros inductionProofTree u inductiveQCInstance++-- Induction strategy helper+mkIndStrategy :: (SymVal a, EqSymbolic (SBV a)) => Maybe SBool -> Maybe SBool -> (SBool, TPProofRaw (SBV a)) -> SBool -> ([Int] -> Symbolic SBool) -> Symbolic InductionStrategy+mkIndStrategy mbMeasure mbBaseCase indSteps step indQCInstance = do+        CalcStrategy { calcIntros, calcProofTree, calcQCInstance } <- mkCalcSteps indSteps indQCInstance+        pure $ InductionStrategy { inductionIntros     = calcIntros+                                 , inductionMeasure    = mbMeasure+                                 , inductionBaseCase   = mbBaseCase+                                 , inductionProofTree  = calcProofTree+                                 , inductiveStep       = step+                                 , inductiveQCInstance = calcQCInstance+                                 }++-- | Create a new variable with the given name, return both the variable and the name+mkVar :: (KnownSymbol n, SymVal a) => proxy n -> Symbolic (SBV a, String)+mkVar x = do let nn = symbolVal x+             n <- free nn+             pure (n, nn)++-- | Create a new variable with the given name, return both the variable and the name. List version.+mkLVar :: (KnownSymbol n, SymVal a) => proxy n -> Symbolic (SBV a, SList a, String, String, String)+mkLVar x = do let nxs = symbolVal x+                  nx  = singular nxs+              e  <- free nx+              es <- free nxs+              pure (e, es, nx, nxs, nx ++ ":" ++ nxs)++-- | Helper for induction result+indResult :: [String] -> SBool -> SBool+indResult nms = observeIf not ("P(" ++ intercalate ", " nms ++ ")")++-- | Induction over 'SInteger'+instance KnownSymbol nn => Inductive (Forall nn Integer -> SBool) where+  type IHType (Forall nn Integer -> SBool) = SBool+  type IHArg  (Forall nn Integer -> SBool) = SInteger++  inductionStrategy result steps = do+       (n, nn) <- mkVar (Proxy @nn)++       let bc = result (Forall 0)+           ih = internalAxiom "IH" (n .>= zero .=> result (Forall n))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih n)+                     (indResult [nn ++ "+1"] (result (Forall (n+1))))+                     (\checkedLabel -> free nn >>= qcRun checkedLabel . steps ih)++-- | Induction over 'SInteger', taking an extra argument+instance (KnownSymbol nn, KnownSymbol na, SymVal a) => Inductive (Forall nn Integer -> Forall na a -> SBool) where+  type IHType (Forall nn Integer -> Forall na a -> SBool) = Forall na a -> SBool+  type IHArg  (Forall nn Integer -> Forall na a -> SBool) = SInteger++  inductionStrategy result steps = do+       (n, nn) <- mkVar (Proxy @nn)+       (a, na) <- mkVar (Proxy @na)++       let bc = result (Forall 0) (Forall a)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) -> n .>= zero .=> result (Forall n) (Forall a'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih n a)+                     (indResult [nn ++ "+1", na] (result (Forall (n+1)) (Forall a)))+                     (\checkedLabel -> steps ih <$> free nn <*> free na >>= qcRun checkedLabel)++-- | Induction over 'SInteger', taking two extra arguments+instance (KnownSymbol nn, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b) => Inductive (Forall nn Integer -> Forall na a -> Forall nb b -> SBool) where+  type IHType (Forall nn Integer -> Forall na a -> Forall nb b -> SBool) = Forall na a -> Forall nb b -> SBool+  type IHArg  (Forall nn Integer -> Forall na a -> Forall nb b -> SBool) = SInteger++  inductionStrategy result steps = do+       (n, nn) <- mkVar (Proxy @nn)+       (a, na) <- mkVar (Proxy @na)+       (b, nb) <- mkVar (Proxy @nb)++       let bc = result (Forall 0) (Forall a) (Forall b)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) -> n .>= zero .=> result (Forall n) (Forall a') (Forall b'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih n a b)+                     (indResult [nn ++ "+1", na, nb] (result (Forall (n+1)) (Forall a) (Forall b)))+                     (\checkedLabel -> steps ih <$> free nn <*> free na <*> free nb >>= qcRun checkedLabel)++-- | Induction over 'SInteger', taking three extra arguments+instance (KnownSymbol nn, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c) => Inductive (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> SBool) where+  type IHType (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> SBool) = Forall na a -> Forall nb b -> Forall nc c -> SBool+  type IHArg  (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> SBool) = SInteger++  inductionStrategy result steps = do+       (n, nn) <- mkVar (Proxy @nn)+       (a, na) <- mkVar (Proxy @na)+       (b, nb) <- mkVar (Proxy @nb)+       (c, nc) <- mkVar (Proxy @nc)++       let bc = result (Forall 0) (Forall a) (Forall b) (Forall c)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) -> n .>= zero .=> result (Forall n) (Forall a') (Forall b') (Forall c'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih n a b c)+                     (indResult [nn ++ "+1", na, nb, nc] (result (Forall (n+1)) (Forall a) (Forall b) (Forall c)))+                     (\checkedLabel -> steps ih <$> free nn <*> free na <*> free nb <*> free nc >>= qcRun checkedLabel)++-- | Induction over 'SInteger', taking four extra arguments+instance (KnownSymbol nn, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d) => Inductive (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) where+  type IHType (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) = Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool+  type IHArg  (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) = SInteger++  inductionStrategy result steps = do+       (n, nn) <- mkVar (Proxy @nn)+       (a, na) <- mkVar (Proxy @na)+       (b, nb) <- mkVar (Proxy @nb)+       (c, nc) <- mkVar (Proxy @nc)+       (d, nd) <- mkVar (Proxy @nd)++       let bc = result (Forall 0) (Forall a) (Forall b) (Forall c) (Forall d)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) -> n .>= zero .=> result (Forall n) (Forall a') (Forall b') (Forall c') (Forall d'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih n a b c d)+                     (indResult [nn ++ "+1", na, nb, nc, nd] (result (Forall (n+1)) (Forall a) (Forall b) (Forall c) (Forall d)))+                     (\checkedLabel -> steps ih <$> free nn <*> free na <*> free nb <*> free nc <*> free nd >>= qcRun checkedLabel)++-- | Induction over 'SInteger', taking five extra arguments+instance (KnownSymbol nn, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e) => Inductive (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) where+  type IHType (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) = Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool+  type IHArg  (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) = SInteger++  inductionStrategy result steps = do+       (n, nn) <- mkVar (Proxy @nn)+       (a, na) <- mkVar (Proxy @na)+       (b, nb) <- mkVar (Proxy @nb)+       (c, nc) <- mkVar (Proxy @nc)+       (d, nd) <- mkVar (Proxy @nd)+       (e, ne) <- mkVar (Proxy @ne)++       let bc = result (Forall 0) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) (Forall e' :: Forall ne e) -> n .>= zero .=> result (Forall n) (Forall a') (Forall b') (Forall c') (Forall d') (Forall e'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih n a b c d e)+                     (indResult [nn ++ "+1", na, nb, nc, nd, ne] (result (Forall (n+1)) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))+                     (\checkedLabel -> steps ih <$> free nn <*> free na <*> free nb <*> free nc <*> free nd <*> free ne >>= qcRun checkedLabel)++-- Given a user name for the list, get a name for the element, in the most suggestive way possible+--   xs  -> x+--   xss -> xs+--   foo -> fooElt+singular :: String -> String+singular n = case reverse n of+               's':_:_ -> init n+               _       -> n ++ "Elt"++-- | Induction over 'SList'+instance (KnownSymbol nxs, SymVal x) => Inductive (Forall nxs [x] -> SBool) where+  type IHType (Forall nxs [x] -> SBool) = SBool+  type IHArg  (Forall nxs [x] -> SBool) = (SBV x, SList x)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)++       let bc = result (Forall SL.nil)+           ih = internalAxiom "IH" (result (Forall xs))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs))+                     (indResult [nxxs] (result (Forall (x SL..: xs))))+                     (\checkedLabel ->  ((,) <$> free nx <*> free nxs) >>= qcRun checkedLabel . steps ih)++-- | Induction over 'SList', taking an extra argument+instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a) => Inductive (Forall nxs [x] -> Forall na a -> SBool) where+  type IHType (Forall nxs [x] -> Forall na a -> SBool) = Forall na a -> SBool+  type IHArg  (Forall nxs [x] -> Forall na a -> SBool) = (SBV x, SList x)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (a, na)                <- mkVar  (Proxy @na)++       let bc = result (Forall SL.nil) (Forall a)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) -> result (Forall xs) (Forall a'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs) a)+                     (indResult [nxxs, na] (result (Forall (x SL..: xs)) (Forall a)))+                     (\checkedLabel -> steps ih <$> ((,) <$> free nx <*> free nxs) <*> free na >>= qcRun checkedLabel)++-- | Induction over 'SList', taking two extra arguments+instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b) => Inductive (Forall nxs [x] -> Forall na a -> Forall nb b -> SBool) where+  type IHType (Forall nxs [x] -> Forall na a -> Forall nb b -> SBool) = Forall na a -> Forall nb b -> SBool+  type IHArg  (Forall nxs [x] -> Forall na a -> Forall nb b -> SBool) = (SBV x, SList x)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (a, na)                <- mkVar  (Proxy @na)+       (b, nb)                <- mkVar  (Proxy @nb)++       let bc = result (Forall SL.nil) (Forall a) (Forall b)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) -> result (Forall xs) (Forall a') (Forall b'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs) a b)+                     (indResult [nxxs, na, nb] (result (Forall (x SL..: xs)) (Forall a) (Forall b)))+                     (\checkedLabel -> steps ih <$> ((,) <$> free nx <*> free nxs) <*> free na <*> free nb >>= qcRun checkedLabel)++-- | Induction over 'SList', taking three extra arguments+instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c) => Inductive (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> SBool) where+  type IHType (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> SBool) = Forall na a -> Forall nb b -> Forall nc c -> SBool+  type IHArg  (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> SBool) = (SBV x, SList x)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (a, na)                <- mkVar  (Proxy @na)+       (b, nb)                <- mkVar  (Proxy @nb)+       (c, nc)                <- mkVar  (Proxy @nc)++       let bc = result (Forall SL.nil) (Forall a) (Forall b) (Forall c)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) -> result (Forall xs) (Forall a') (Forall b') (Forall c'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs) a b c)+                     (indResult [nxxs, na, nb, nc] (result (Forall (x SL..: xs)) (Forall a) (Forall b) (Forall c)))+                     (\checkedLabel -> steps ih <$> ((,) <$> free nx <*> free nxs) <*> free na <*> free nb <*> free nc >>= qcRun checkedLabel)++-- | Induction over 'SList', taking four extra arguments+instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d) => Inductive (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) where+  type IHType (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) = Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool+  type IHArg  (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) = (SBV x, SList x)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (a, na)                <- mkVar  (Proxy @na)+       (b, nb)                <- mkVar  (Proxy @nb)+       (c, nc)                <- mkVar  (Proxy @nc)+       (d, nd)                <- mkVar  (Proxy @nd)++       let bc = result (Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) -> result (Forall xs) (Forall a') (Forall b') (Forall c') (Forall d'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs) a b c d)+                     (indResult [nxxs, na, nb, nc, nd] (result (Forall (x SL..: xs)) (Forall a) (Forall b) (Forall c) (Forall d)))+                     (\checkedLabel -> steps ih <$> ((,) <$> free nx <*> free nxs) <*> free na <*> free nb <*> free nc <*> free nd >>= qcRun checkedLabel)++-- | Induction over 'SList', taking five extra arguments+instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e) => Inductive (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) where+  type IHType (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) = Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool+  type IHArg  (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) = (SBV x, SList x)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (a, na)                <- mkVar  (Proxy @na)+       (b, nb)                <- mkVar  (Proxy @nb)+       (c, nc)                <- mkVar  (Proxy @nc)+       (d, nd)                <- mkVar  (Proxy @nd)+       (e, ne)                <- mkVar  (Proxy @ne)++       let bc = result (Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) (Forall e' :: Forall ne e) -> result (Forall xs) (Forall a') (Forall b') (Forall c') (Forall d') (Forall e'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs) a b c d e)+                     (indResult [nxxs, na, nb, nc, nd, ne] (result (Forall (x SL..: xs)) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))+                     (\checkedLabel -> steps ih <$> ((,) <$> free nx <*> free nxs) <*> free na <*> free nb <*> free nc <*> free nd <*> free ne >>= qcRun checkedLabel)++-- | Induction over two 'SList', simultaneously+instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y) => Inductive ((Forall nxs [x], Forall nys [y]) -> SBool) where+  type IHType ((Forall nxs [x], Forall nys [y]) -> SBool) = SBool+  type IHArg  ((Forall nxs [x], Forall nys [y]) -> SBool) = (SBV x, SList x, SBV y, SList y)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (y, ys, ny, nys, nyys) <- mkLVar (Proxy @nys)++       let bc = result (Forall SL.nil, Forall SL.nil) .&& result (Forall SL.nil, Forall (y SL..: ys)) .&& result (Forall (x SL..: xs), Forall SL.nil)+           ih = internalAxiom "IH" (result (Forall xs, Forall ys))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs, y, ys))+                     (indResult [nxxs, nyys] (result (Forall (x SL..: xs), Forall (y SL..: ys))))+                     (\checkedLabel -> ((,,,) <$> free nx <*> free nxs <*> free ny <*> free nys) >>= qcRun checkedLabel . steps ih)++-- | Induction over two 'SList', simultaneously, taking an extra argument+instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> SBool) where+  type IHType ((Forall nxs [x], Forall nys [y]) -> Forall na a -> SBool) = Forall na a -> SBool+  type IHArg  ((Forall nxs [x], Forall nys [y]) -> Forall na a -> SBool) = (SBV x, SList x, SBV y, SList y)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (y, ys, ny, nys, nyys) <- mkLVar (Proxy @nys)+       (a, na)                <- mkVar  (Proxy @na)++       let bc = result (Forall SL.nil, Forall SL.nil) (Forall a) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) -> result (Forall xs, Forall ys) (Forall a'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs, y, ys) a)+                     (indResult [nxxs, nyys, na] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a)))+                     (\checkedLabel -> steps ih <$> ((,,,) <$> free nx <*> free nxs <*> free ny <*> free nys) <*> free na >>= qcRun checkedLabel)++-- | Induction over two 'SList', simultaneously, taking two extra arguments+instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> SBool) where+  type IHType ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> SBool) = Forall na a -> Forall nb b -> SBool+  type IHArg  ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> SBool) = (SBV x, SList x, SBV y, SList y)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (y, ys, ny, nys, nyys) <- mkLVar (Proxy @nys)+       (a, na)                <- mkVar  (Proxy @na)+       (b, nb)                <- mkVar  (Proxy @nb)++       let bc = result (Forall SL.nil, Forall SL.nil) (Forall a) (Forall b) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) (Forall b) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a) (Forall b)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) -> result (Forall xs, Forall ys) (Forall a') (Forall b'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs, y, ys) a b)+                     (indResult [nxxs, nyys, na, nb] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a) (Forall b)))+                     (\checkedLabel -> steps ih <$> ((,,,) <$> free nx <*> free nxs <*> free ny <*> free nys) <*> free na <*> free nb >>= qcRun checkedLabel)++-- | Induction over two 'SList', simultaneously, taking three extra arguments+instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> SBool) where+  type IHType ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> SBool) = Forall na a -> Forall nb b -> Forall nc c -> SBool+  type IHArg  ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> SBool) = (SBV x, SList x, SBV y, SList y)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (y, ys, ny, nys, nyys) <- mkLVar (Proxy @nys)+       (a, na)                <- mkVar  (Proxy @na)+       (b, nb)                <- mkVar  (Proxy @nb)+       (c, nc)                <- mkVar  (Proxy @nc)++       let bc = result (Forall SL.nil, Forall SL.nil) (Forall a) (Forall b) (Forall c) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a) (Forall b) (Forall c)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) -> result (Forall xs, Forall ys) (Forall a') (Forall b') (Forall c'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs, y, ys) a b c)+                     (indResult [nxxs, nyys, na, nb, nc] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c)))+                     (\checkedLabel -> steps ih <$> ((,,,) <$> free nx <*> free nxs <*> free ny <*> free nys) <*> free na <*> free nb <*> free nc >>= qcRun checkedLabel)++-- | Induction over two 'SList', simultaneously, taking four extra arguments+instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) where+  type IHType ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) = Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool+  type IHArg  ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) = (SBV x, SList x, SBV y, SList y)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (y, ys, ny, nys, nyys) <- mkLVar (Proxy @nys)+       (a, na)                <- mkVar  (Proxy @na)+       (b, nb)                <- mkVar  (Proxy @nb)+       (c, nc)                <- mkVar  (Proxy @nc)+       (d, nd)                <- mkVar  (Proxy @nd)++       let bc = result (Forall SL.nil, Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) -> result (Forall xs, Forall ys) (Forall a') (Forall b') (Forall c') (Forall d'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs, y, ys) a b c d)+                     (indResult [nxxs, nyys, na, nb, nc, nd] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d)))+                     (\checkedLabel -> steps ih <$> ((,,,) <$> free nx <*> free nxs <*> free ny <*> free nys) <*> free na <*> free nb <*> free nc <*> free nd >>= qcRun checkedLabel)++-- | Induction over two 'SList', simultaneously, taking five extra arguments+instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) where+  type IHType ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) = Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool+  type IHArg  ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) = (SBV x, SList x, SBV y, SList y)++  inductionStrategy result steps = do+       (x, xs, nx, nxs, nxxs) <- mkLVar (Proxy @nxs)+       (y, ys, ny, nys, nyys) <- mkLVar (Proxy @nys)+       (a, na)                <- mkVar  (Proxy @na)+       (b, nb)                <- mkVar  (Proxy @nb)+       (c, nc)                <- mkVar  (Proxy @nc)+       (d, nd)                <- mkVar  (Proxy @nd)+       (e, ne)                <- mkVar  (Proxy @ne)++       let bc = result (Forall SL.nil, Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)+           ih = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) (Forall e' :: Forall ne e) -> result (Forall xs, Forall ys) (Forall a') (Forall b') (Forall c') (Forall d') (Forall e'))++       mkIndStrategy Nothing+                     (Just bc)+                     (steps ih (x, xs, y, ys) a b c d e)+                     (indResult [nxxs, nyys, na, nb, nc, nd, ne] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))+                     (\checkedLabel -> steps ih <$> ((,,,) <$> free nx <*> free nxs <*> free ny <*> free nys) <*> free na <*> free nb <*> free nc <*> free nd <*> free ne >>= qcRun checkedLabel)++-- | Generalized induction with one parameter+instance (KnownSymbol na, SymVal a) => SInductive (Forall na a -> SBool) where+  sInductionStrategy result measure steps = do+      (a, na) <- mkVar (Proxy @na)++      let ih   = internalAxiom "IH" (\(Forall a' :: Forall na a) -> measure a' .< measure a .=> result (Forall a'))+          conc = result (Forall a)++      mkIndStrategy (Just (measure a .>= zero))+                    Nothing+                    (steps ih a)+                    (indResult [na] conc)+                    (\checkedLabel -> free na >>= qcRun checkedLabel . steps ih)++-- | Generalized induction with two parameters+instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b) => SInductive (Forall na a -> Forall nb b -> SBool) where+  sInductionStrategy result measure steps = do+      (a, na) <- mkVar (Proxy @na)+      (b, nb) <- mkVar (Proxy @nb)++      let ih   = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) -> measure a' b' .< measure a b .=> result (Forall a') (Forall b'))+          conc = result (Forall a) (Forall b)++      mkIndStrategy (Just (measure a b .>= zero))+                    Nothing+                    (steps ih a b)+                    (indResult [na, nb] conc)+                    (\checkedLabel -> steps ih <$> free na <*> free nb >>= qcRun checkedLabel)++-- | Generalized induction with three parameters+instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c) => SInductive (Forall na a -> Forall nb b -> Forall nc c -> SBool) where+  sInductionStrategy result measure steps = do+      (a, na) <- mkVar (Proxy @na)+      (b, nb) <- mkVar (Proxy @nb)+      (c, nc) <- mkVar (Proxy @nc)++      let ih   = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) -> measure a' b' c' .< measure a b c .=> result (Forall a') (Forall b') (Forall c'))+          conc = result (Forall a) (Forall b) (Forall c)++      mkIndStrategy (Just (measure a b c .>= zero))+                    Nothing+                    (steps ih a b c)+                    (indResult [na, nb, nc] conc)+                    (\checkedLabel -> steps ih <$> free na <*> free nb <*> free nc >>= qcRun checkedLabel)++-- | Generalized induction with four parameters+instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d) => SInductive (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) where+  sInductionStrategy result measure steps = do+      (a, na) <- mkVar (Proxy @na)+      (b, nb) <- mkVar (Proxy @nb)+      (c, nc) <- mkVar (Proxy @nc)+      (d, nd) <- mkVar (Proxy @nd)++      let ih   = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) -> measure a' b' c' d' .< measure a b c d .=> result (Forall a') (Forall b') (Forall c') (Forall d'))+          conc = result (Forall a) (Forall b) (Forall c) (Forall d)++      mkIndStrategy (Just (measure a b c d .>= zero))+                    Nothing+                    (steps ih a b c d)+                    (indResult [na, nb, nc, nd] conc)+                    (\checkedLabel -> steps ih <$> free na <*> free nb <*> free nc <*> free nd >>= qcRun checkedLabel)++-- | Generalized induction with five parameters+instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e) => SInductive (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) where+  sInductionStrategy result measure steps = do+      (a, na) <- mkVar (Proxy @na)+      (b, nb) <- mkVar (Proxy @nb)+      (c, nc) <- mkVar (Proxy @nc)+      (d, nd) <- mkVar (Proxy @nd)+      (e, ne) <- mkVar (Proxy @ne)++      let ih   = internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) (Forall e' :: Forall ne e) -> measure a' b' c' d' e' .< measure a b c d e .=> result (Forall a') (Forall b') (Forall c') (Forall d') (Forall e'))+          conc = result (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)++      mkIndStrategy (Just (measure a b c d e .>= zero))+                    Nothing+                    (steps ih a b c d e)+                    (indResult [na, nb, nc, nd, ne] conc)+                    (\checkedLabel -> steps ih <$> free na <*> free nb <*> free nc <*> free nd <*> free ne >>= qcRun checkedLabel)++-- | Instantiation for a universally quantified variable+newtype Inst (nm :: Symbol) a = Inst (SBV a)++instance KnownSymbol nm => Show (Inst nm a) where+   show (Inst a) = symbolVal (Proxy @nm) ++ " |-> " ++ show a++-- | Instantiating a proof at a particular choice of arguments+class Instantiatable a where+  type IArgs a :: Type++  -- | Apply a universal proof to some arguments, creating a boolean expression guaranteed to be true+  at :: Proof a -> IArgs a -> Proof Bool++-- | Instantiation a single parameter proof+instance (KnownSymbol na, Typeable a) => Instantiatable (Forall na a -> SBool) where+  type IArgs (Forall na a -> SBool) = Inst na a++  at = instantiate $ \f (Inst a) -> f (Forall a :: Forall na a)++-- | Two parameters+instance ( KnownSymbol na, HasKind a, Typeable a+         , KnownSymbol nb, HasKind b, Typeable b+         ) => Instantiatable (Forall na a -> Forall nb b -> SBool) where+  type IArgs (Forall na a -> Forall nb b -> SBool) = (Inst na a, Inst nb b)++  at  = instantiate $ \f (Inst a, Inst b) -> f (Forall a :: Forall na a) (Forall b :: Forall nb b)++-- | Three parameters+instance ( KnownSymbol na, HasKind a, Typeable a+         , KnownSymbol nb, HasKind b, Typeable b+         , KnownSymbol nc, HasKind c, Typeable c+         ) => Instantiatable (Forall na a -> Forall nb b -> Forall nc c -> SBool) where+  type IArgs (Forall na a -> Forall nb b -> Forall nc c -> SBool) = (Inst na a, Inst nb b, Inst nc c)++  at  = instantiate $ \f (Inst a, Inst b, Inst c) -> f (Forall a :: Forall na a) (Forall b :: Forall nb b) (Forall c :: Forall nc c)++-- | Four parameters+instance ( KnownSymbol na, HasKind a, Typeable a+         , KnownSymbol nb, HasKind b, Typeable b+         , KnownSymbol nc, HasKind c, Typeable c+         , KnownSymbol nd, HasKind d, Typeable d+         ) => Instantiatable (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) where+  type IArgs (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) = (Inst na a, Inst nb b, Inst nc c, Inst nd d)++  at  = instantiate $ \f (Inst a, Inst b, Inst c, Inst d) -> f (Forall a :: Forall na a) (Forall b :: Forall nb b) (Forall c :: Forall nc c) (Forall d :: Forall nd d)++-- | Five parameters+instance ( KnownSymbol na, HasKind a, Typeable a+         , KnownSymbol nb, HasKind b, Typeable b+         , KnownSymbol nc, HasKind c, Typeable c+         , KnownSymbol nd, HasKind d, Typeable d+         , KnownSymbol ne, HasKind e, Typeable e+         ) => Instantiatable (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) where+  type IArgs (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) = (Inst na a, Inst nb b, Inst nc c, Inst nd d, Inst ne e)++  at  = instantiate $ \f (Inst a, Inst b, Inst c, Inst d, Inst e) -> f (Forall a :: Forall na a) (Forall b :: Forall nb b) (Forall c :: Forall nc c) (Forall d :: Forall nd d) (Forall e :: Forall ne e)++-- | Instantiate a proof over an arg. This uses dynamic typing, kind of hacky, but works sufficiently well.+instantiate :: (Typeable f, Show arg) => (f -> arg -> SBool) -> Proof a -> arg -> Proof Bool+instantiate ap (Proof p@ProofObj{getProp, proofName}) a = case fromDynamic getProp of+                                                            Nothing -> cantInstantiate+                                                            Just f  -> let result = f `ap` a+                                                                           nm     = proofName ++ " @ " ++ paren sha+                                                                       in Proof $ p { getObjProof = label nm result+                                                                                    , getProp     = toDyn result+                                                                                    , proofName   = nm+                                                                                    }+ where sha = show a+       cantInstantiate = error $ unlines [ "***"+                                         , "Data.SBV.TP: Impossible happened: Cannot instantiate proof:"+                                         , ""+                                         , "   Name: " ++ proofName+                                         , "   Type: " ++ trim (show getProp)+                                         , "   At  : " ++ sha+                                         , ""+                                         , "Please report this as a bug!"+                                         ]++       -- dynamic puts funky <</>> at the beginning and end; trim it:+       trim  ('<':'<':s) = reverse (trimE (reverse s))+       trim  s           = s+       trimE ('>':'>':s) = s+       trimE s           = s++       -- Add parens if necessary+       paren s | "(" `isPrefixOf` s && ")" `isSuffixOf` s = s+               | not (any isSpace s)                      = s+               | True                                     = '(' : s ++ ")"++-- | Helpers for a step+data Helper = HelperProof  ProofObj     -- A previously proven theorem+            | HelperAssum  SBool        -- A hypothesis+            | HelperQC     QC.Args      -- Quickcheck with these args+            | HelperString String       -- Just a text, only used for diagnostics+            | HelperDisp   String SVal  -- Show the value of this expression in case of failure++-- | Get all helpers used in a proof+getAllHelpers :: TPProof -> [Helper]+getAllHelpers (ProofStep   _           hs               p)  = hs ++ getAllHelpers p+getAllHelpers (ProofBranch (_ :: Bool) (_ :: [String]) ps) = concatMap (getAllHelpers . snd) ps+getAllHelpers (ProofEnd    _           hs                ) = hs++-- | Get proofs from helpers+getHelperProofs :: Helper -> [ProofObj]+getHelperProofs (HelperProof p) = [p]+getHelperProofs HelperAssum {}  = []+getHelperProofs HelperQC    {}  = [quickCheckProof]+getHelperProofs HelperString{}  = []+getHelperProofs HelperDisp{}    = []++-- | Get proofs from helpers+getHelperAssumes :: Helper -> [SBool]+getHelperAssumes HelperProof  {} = []+getHelperAssumes (HelperAssum b) = [b]+getHelperAssumes HelperQC     {} = []+getHelperAssumes HelperString {} = []+getHelperAssumes HelperDisp{}    = []++-- | Get hint strings from helpers. If there's an explicit comment given, just pass that. If not, collect all the names+getHelperText :: [Helper] -> [String]+getHelperText hs = case [s | HelperString s <- hs] of+                     [] -> concatMap collect hs+                     ss -> ss+  where collect :: Helper -> [String]+        collect (HelperProof  p) = [proofName p | isUserAxiom p]  -- Don't put out internals (inductive hypotheses)+        collect HelperAssum  {}  = []+        collect (HelperQC     i) = ["qc: Running " ++ show (QC.maxSuccess i) ++ " tests"]+        collect (HelperString s) = [s]+        collect HelperDisp{}     = []++-- | A proof is a sequence of steps, supporting branching+data TPProofGen a bh b = ProofStep   a    [Helper] (TPProofGen a bh b)          -- ^ A single step+                       | ProofBranch Bool bh       [(SBool, TPProofGen a bh b)] -- ^ A branching step. Bool indicates if completeness check is needed+                       | ProofEnd    b    [Helper]                              -- ^ End of proof++-- | A proof, as written by the user. No produced result, but helpers on branches+type TPProofRaw a = TPProofGen a [Helper] ()++-- | A proof, as processed by TP. Producing a boolean result and each step is a boolean. Helpers on branches dispersed down, only strings are left for printing+type TPProof = TPProofGen SBool [String] SBool++-- | Collect dependencies for a TPProof+getDependencies :: TPProof -> [ProofObj]+getDependencies = collect+  where collect (ProofStep   _ hs next) = concatMap getHelperProofs hs ++ collect next+        collect (ProofBranch _ _  bs)   = concatMap (collect . snd) bs+        collect (ProofEnd    _    hs)   = concatMap getHelperProofs hs++-- | Class capturing giving a proof-step helper+type family Hinted a where+  Hinted (TPProofRaw a) = TPProofRaw a+  Hinted a              = TPProofRaw a++-- | Attaching a hint+(??) :: HintsTo a b => a -> b -> Hinted a+(??) = addHint+infixl 2 ??++-- | Alternative unicode for `??`.+(∵) :: HintsTo a b => a -> b -> Hinted a+(∵) = (??)+infixl 2 ∵++-- | Class capturing hints+class HintsTo a b where+  addHint :: a -> b -> Hinted a++-- | Giving just one proof as a helper.+instance Hinted a ~ TPProofRaw a => HintsTo a (Proof b) where+  a `addHint` p = ProofStep a [HelperProof (proofOf p)] qed++-- | Giving a bunch of proofs at the same type as a helper.+instance Hinted a ~ TPProofRaw a => HintsTo a [Proof b] where+  a `addHint` ps = ProofStep a (map (HelperProof . proofOf) ps) qed++-- | Giving just one proof-obj as a helper.+instance Hinted a ~ TPProofRaw a => HintsTo a ProofObj where+  a `addHint` p = ProofStep a [HelperProof p] qed++-- | Giving a bunch of proof-objs at the same type as a helper.+instance Hinted a ~ TPProofRaw a => HintsTo a [ProofObj] where+  a `addHint` ps = ProofStep a (map HelperProof ps) qed++-- | Giving just one boolean as a helper.+instance Hinted a ~ TPProofRaw a => HintsTo a SBool where+  a `addHint` p = ProofStep a [HelperAssum p] qed++-- | Giving a list of booleans as a helper.+instance Hinted a ~ TPProofRaw a => HintsTo a [SBool] where+  a `addHint` ps = ProofStep a (map HelperAssum ps) qed++-- | Giving just one helper+instance Hinted a ~ TPProofRaw a => HintsTo a Helper where+  a `addHint` h = ProofStep a [h] qed++-- | Giving a list of helper+instance Hinted a ~ TPProofRaw a => HintsTo a [Helper] where+  a `addHint` hs = ProofStep a hs qed++-- | Giving user a hint as a string. This doesn't actually do anything for the solver, it just helps with readability+instance Hinted a ~ TPProofRaw a => HintsTo a String where+  a `addHint` s = ProofStep a [HelperString s] qed++-- | Giving a bunch of strings+instance Hinted a ~ TPProofRaw a => HintsTo a [String] where+  a `addHint` ss = ProofStep a (map HelperString ss) qed++-- | Giving just one proof as a helper, starting from a proof+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) (Proof b) where+  ProofStep   a hs ps `addHint` h = ProofStep   a (hs ++ [HelperProof (proofOf h)]) ps+  ProofBranch b hs bs `addHint` h = ProofBranch b (hs ++ [HelperProof (proofOf h)]) bs+  ProofEnd    b hs    `addHint` h = ProofEnd    b (hs ++ [HelperProof (proofOf h)])++-- | Giving just one proofobj as a helper, starting from a proof+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) ProofObj where+  ProofStep   a hs ps `addHint` h = ProofStep   a (hs ++ [HelperProof h]) ps+  ProofBranch b hs bs `addHint` h = ProofBranch b (hs ++ [HelperProof h]) bs+  ProofEnd    b hs    `addHint` h = ProofEnd    b (hs ++ [HelperProof h])++-- | Giving a bunch of proofs at the same type as a helper, starting from a proof+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) [Proof b] where+  ProofStep   a hs ps `addHint` hs' = ProofStep   a (hs ++ map (HelperProof . proofOf) hs') ps+  ProofBranch b hs bs `addHint` hs' = ProofBranch b (hs ++ map (HelperProof . proofOf) hs') bs+  ProofEnd    b hs    `addHint` hs' = ProofEnd    b (hs ++ map (HelperProof . proofOf) hs')++-- | Giving just one boolean as a helper.+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) SBool where+  ProofStep   a hs ps `addHint` h = ProofStep   a (hs ++ [HelperAssum h]) ps+  ProofBranch b hs bs `addHint` h = ProofBranch b (hs ++ [HelperAssum h]) bs+  ProofEnd    b hs    `addHint` h = ProofEnd    b (hs ++ [HelperAssum h])++-- | Giving a bunch of booleans as a helper.+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) [SBool] where+  ProofStep   a hs ps `addHint` hs' = ProofStep   a (hs ++ map HelperAssum hs') ps+  ProofBranch b hs bs `addHint` hs' = ProofBranch b (hs ++ map HelperAssum hs') bs+  ProofEnd    b hs    `addHint` hs' = ProofEnd    b (hs ++ map HelperAssum hs')++-- | Giving just one helper+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) Helper where+  ProofStep   a hs ps `addHint` h = ProofStep   a (hs ++ [h]) ps+  ProofBranch b hs bs `addHint` h = ProofBranch b (hs ++ [h]) bs+  ProofEnd    b hs    `addHint` h = ProofEnd    b (hs ++ [h])++-- | Giving a set of helpers+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) [Helper] where+  ProofStep   a hs ps `addHint` hs' = ProofStep   a (hs ++ hs') ps+  ProofBranch b hs bs `addHint` hs' = ProofBranch b (hs ++ hs') bs+  ProofEnd    b hs    `addHint` hs' = ProofEnd    b (hs ++ hs')++-- | Giving user a hint as a string. This doesn't actually do anything for the solver, it just helps with readability+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) String where+  a `addHint` s = a `addHint` HelperString s++-- | Giving a bunch of strings as hints. This doesn't actually do anything for the solver, it just helps with readability+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) [String] where+  a `addHint` ss = a `addHint` map HelperString ss++-- | Giving a set of proof objects as helpers. This is helpful since we occasionally put a bunch of proofs together.+instance {-# OVERLAPPING #-} Hinted (TPProofRaw a) ~ TPProofRaw a => HintsTo (TPProofRaw a) [ProofObj] where+  ProofStep   a hs ps `addHint` hs' = ProofStep   a (hs ++ map HelperProof hs') ps+  ProofBranch b hs bs `addHint` hs' = ProofBranch b (hs ++ map HelperProof hs') bs+  ProofEnd    b hs    `addHint` hs' = ProofEnd    b (hs ++ map HelperProof hs')++-- | Capture what a given step can chain-to. This is a closed-type family, i.e.,+-- we don't allow users to change this and write other chainable things. Probably it is not really necessary,+-- but we'll cross that bridge if someone actually asks for it.+type family ChainsTo a where+  ChainsTo (TPProofRaw a) = TPProofRaw a+  ChainsTo a              = TPProofRaw a++-- | Chain steps in a calculational proof.+(=:) :: ChainStep a (ChainsTo a) =>  a -> ChainsTo a -> ChainsTo a+(=:) = chain+infixr 1 =:++-- | Unicode alternative for `=:`.+(≡) :: ChainStep a (ChainsTo a) =>  a -> ChainsTo a -> ChainsTo a+(≡) = (=:)+infixr 1 ≡++-- | Chaining two steps together+class ChainStep a b where+  chain :: a -> b -> b++-- | Chaining from a value without any annotation+instance ChainStep a (TPProofRaw a) where+  chain x y = ProofStep x [] y++-- | Chaining from another proof step+instance ChainStep (TPProofRaw a) (TPProofRaw a) where+  chain (ProofStep   a  hs  p)  y = ProofStep   a hs (chain p y)+  chain (ProofBranch c  hs  ps) y = ProofBranch c hs [(branchCond, chain p y) | (branchCond, p) <- ps]+  chain (ProofEnd    () hs)     y = case y of+                                      ProofStep   a  hs' p  -> ProofStep   a  (hs' ++ hs) p+                                      ProofBranch b  hs' bs -> ProofBranch b  (hs' ++ hs) bs+                                      ProofEnd    () hs'    -> ProofEnd    () (hs' ++ hs)++-- | Mark the end of a calculational proof.+qed :: TPProofRaw a+qed = ProofEnd () []++-- | Mark a trivial proof. This is essentially the same as 'qed', but reads better in proof scripts.+class Trivial a where+  -- | Mark a proof as trivial, i.e., the solver should be able to deduce it without any help.+  trivial :: a++-- | Trivial proofs with no arguments+instance Trivial (TPProofRaw a) where+  trivial = qed++-- | Trivial proofs with many arguments arguments+instance Trivial a => Trivial (b -> a) where+  trivial = const trivial++-- | Mark a contradictory proof path. This is essentially the same as @sFalse := qed@, but reads better in proof scripts.+class Contradiction a where+  -- | Mark a proof as contradiction, i.e., the solver should be able to conclude it by reasoning that the current path is infeasible+  contradiction :: a++-- | Contradiction proofs with no arguments+instance Contradiction (TPProofRaw SBool) where+  contradiction = sFalse =: qed++-- | Contradiction proofs with many arguments+instance Contradiction a => Contradiction (b -> a) where+  contradiction = const contradiction++-- | Start a calculational proof, with the given hypothesis. Use @[]@ as the+-- first argument if the calculation holds unconditionally. The first argument is+-- typically used to introduce hypotheses in proofs of implications such as @A .=> B .=> C@, where+-- we would put @[A, B]@ as the starting assumption. You can name these and later use in the derivation steps.+(|-) :: [SBool] -> TPProofRaw a -> (SBool, TPProofRaw a)+bs |- p = (sAnd bs, p)+infixl 0 |-++-- | Alternative unicode for `|-`.+(⊢) :: [SBool] -> TPProofRaw a -> (SBool, TPProofRaw a)+(⊢) = (|-)+infixl 0 ⊢++-- | The boolean case-split+cases :: [(SBool, TPProofRaw a)] -> TPProofRaw a+cases = ProofBranch True []++-- | Case splitting over a list; empty and full cases+split :: SymVal a => SList a -> TPProofRaw r -> (SBV a -> SList a -> TPProofRaw r) -> TPProofRaw r+split xs empty cons = ProofBranch False [] [(cnil, empty), (ccons, cons h t)]+   where cnil   = SL.null   xs+         (h, t) = SL.uncons xs+         ccons  = sNot cnil .&& xs .== h SL..: t++-- | Case splitting over two lists; empty and full cases for each+split2 :: (SymVal a, SymVal b)+       => (SList a, SList b)+       -> TPProofRaw r+       -> ((SBV b, SList b)                     -> TPProofRaw r) -- empty first+       -> ((SBV a, SList a)                     -> TPProofRaw r) -- empty second+       -> ((SBV a, SList a) -> (SBV b, SList b) -> TPProofRaw r) -- neither empty+       -> TPProofRaw r+split2 (xs, ys) ee ec ce cc = ProofBranch False+                                          []+                                          [ (xnil  .&& ynil,  ee)+                                          , (xnil  .&& ycons, ec (hy, ty))+                                          , (xcons .&& ynil,  ce (hx, tx))+                                          , (xcons .&& ycons, cc (hx, tx) (hy, ty))+                                          ]+  where xnil     = SL.null   xs+        (hx, tx) = SL.uncons xs+        xcons    = sNot xnil .&& xs .== hx SL..: tx++        ynil     = SL.null   ys+        (hy, ty) = SL.uncons ys+        ycons    = sNot ynil .&& ys .== hy SL..: ty++-- | A quick-check step, taking number of tests.+qc :: Int -> Helper+qc cnt = HelperQC QC.stdArgs{QC.maxSuccess = cnt}++-- | A quick-check step, with specific quick-check args.+qcWith :: QC.Args -> Helper+qcWith = HelperQC++-- | Observing values in case of failure.+disp :: String -> SBV a -> Helper+disp n v = HelperDisp n (unSBV v)++-- | Specifying a case-split, helps with the boolean case.+(==>) :: SBool -> TPProofRaw a -> (SBool, TPProofRaw a)+(==>) = (,)+infix 0 ==>++-- | Alternative unicode for `==>`+(⟹) :: SBool -> TPProofRaw a -> (SBool, TPProofRaw a)+(⟹) = (==>)+infix 0 ⟹++{- HLint ignore module "Eta reduce" -}
+ Data/SBV/TP/Utils.hs view
@@ -0,0 +1,457 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Data.SBV.TP.Utils+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Various theorem-proving machinery.+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveAnyClass             #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeAbstractions           #-}+{-# LANGUAGE TypeApplications           #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.TP.Utils (+         TP, runTP, runTPWith, Proof(..), ProofObj(..), assumptionFromProof, sorry, quickCheckProof+       , startTP, finishTP, getTPState, getTPConfig, tpGetNextUnique, TPState(..), TPStats(..), RootOfTrust(..)+       , TPProofContext(..), message, updStats, rootOfTrust, concludeModulo+       , ProofTree(..), TPUnique(..), showProofTree, showProofTreeHTML, shortProofName+       , withProofCache+       , tpQuiet, tpRibbon, tpStats, tpCache+       ) where++import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, ask, liftIO)+import Control.Monad.Trans  (MonadIO)++import Data.Time (NominalDiffTime)++import Data.Tree+import Data.Tree.View++import Data.Proxy+import Data.Typeable (typeOf, TypeRep)++import Data.Char (isSpace)+import Data.List (intercalate, isPrefixOf, isSuffixOf, isInfixOf, nubBy, partition, sort)+import Data.Int  (Int64)++import Data.SBV.Utils.Lib (unQuote)++import System.IO     (hFlush, stdout)+import System.Random (randomIO)++import Data.SBV.Core.Data      (SBool, Forall(..), quantifiedBool)+import Data.SBV.Core.Model     (label)+import Data.SBV.Core.Symbolic  (SMTConfig, TPOptions(..))+import Data.SBV.Provers.Prover (defaultSMTCfg, SMTConfig(..))++import Data.SBV.Utils.TDiff (showTDiff, timeIf)+import Control.DeepSeq (NFData(rnf))++import Data.IORef++import GHC.Generics+import Data.Dynamic++import qualified Data.Map as Map+import Data.Map (Map)++-- | Various statistics we collect+data TPStats = TPStats { noOfCheckSats :: Int+                       , solverElapsed :: NominalDiffTime+                       , qcElapsed     :: NominalDiffTime+                       }++-- | Extra state we carry in a TP context+data TPState = TPState { stats      :: IORef TPStats+                       , proofCache :: IORef (Map (String, TypeRep) ProofObj)+                       , config     :: SMTConfig+                       }++-- | Monad for running TP proofs in.+newtype TP a = TP (ReaderT TPState IO a)+            deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader TPState, MonadFail)++-- | If caches are enabled, see if we cached this proof and return it; otherwise generate it, cache it, and return it+withProofCache :: forall a. Typeable a => String -> TP (Proof a) -> TP (Proof a)+withProofCache nm genProof = do+  TPState{proofCache, config = cfg@SMTConfig {tpOptions = TPOptions {cacheProofs}}} <- getTPState++  let key = (nm, typeOf (Proxy @a))++  if not cacheProofs+     then genProof+     else do cache <- liftIO $ readIORef proofCache+             case key `Map.lookup` cache of+               Just prf -> do liftIO $ do tab <- startTP cfg False "Cached" 0 (TPProofOneShot nm [])+                                          finishTP cfg "Q.E.D." (tab, Nothing) []+                              pure $ Proof prf{isCached = True}+               Nothing  -> do p <- genProof+                              liftIO $ modifyIORef' proofCache (Map.insert key (proofOf p))+                              pure p++-- | The context in which we make a check-sat call+data TPProofContext = TPProofOneShot String      -- ^ A one shot proof, with string containing its name+                                     [ProofObj]  -- ^ Helpers used (latter only used for cex generation)+                    | TPProofStep    Bool        -- ^ A proof step. If Bool is true, then these are the assumptions for that step+                                     String      -- ^ Name of original goal+                                     [String]    -- ^ The helper "strings" given by the user+                                     [String]    -- ^ The step name, i.e., the name of the branch in the proof tree++-- | Run a TP proof, using the default configuration.+runTP :: TP a -> IO a+runTP = runTPWith defaultSMTCfg++-- | Run a TP proof, using the given configuration.+runTPWith :: SMTConfig -> TP a -> IO a+runTPWith cfg@SMTConfig{tpOptions = TPOptions{printStats}} (TP f) = do+   rStats <- newIORef $ TPStats { noOfCheckSats = 0, solverElapsed = 0, qcElapsed = 0 }+   rCache <- newIORef Map.empty+   (mbT, r) <- timeIf printStats $ runReaderT f TPState {config = cfg, stats = rStats, proofCache = rCache}+   case mbT of+     Nothing -> pure ()+     Just t  -> do TPStats noOfCheckSats solverTime qcElapsed <- readIORef rStats++                   let stats = [ ("SBV",       showTDiff (t - solverTime - qcElapsed))+                               , ("Solver",    showTDiff solverTime)+                               , ("QC",        showTDiff qcElapsed)+                               , ("Total",     showTDiff t)+                               , ("Decisions", show noOfCheckSats)+                               ]++                   message cfg $ '[' : intercalate ", " [k ++ ": " ++ v | (k, v) <- stats] ++ "]\n"+   pure r++-- | get the state+getTPState :: TP TPState+getTPState = ask++-- | Make a unique number in this TP run. We combine that context with the proof-count+tpGetNextUnique :: TP TPUnique+tpGetNextUnique = TPUser <$> liftIO randomIO++-- | get the configuration+getTPConfig :: TP SMTConfig+getTPConfig = config <$> getTPState++-- | Update stats+updStats :: MonadIO m => TPState -> (TPStats -> TPStats) -> m ()+updStats TPState{stats} u = liftIO $ modifyIORef' stats u++-- | Display the message if not quiet. Note that we don't print a newline; so the message must have it if needed.+message :: MonadIO m => SMTConfig -> String -> m ()+message SMTConfig{tpOptions = TPOptions{quiet}} s+  | quiet = pure ()+  | True  = liftIO $ putStr s++-- | Start a proof. We return the number of characters we printed, so the finisher can align the result.+startTP :: SMTConfig -> Bool -> String -> Int -> TPProofContext -> IO Int+startTP cfg newLine what level ctx = do message cfg $ line ++ if newLine then "\n" else ""+                                        hFlush stdout+                                        return (length line)+  where nm = case ctx of+               TPProofOneShot n _       -> n+               TPProofStep    _ _ hs ss -> intercalate "." ss ++ userHints hs++        tab = 2 * level++        line = replicate tab ' ' ++ what ++ ": " ++ nm++        userHints [] = ""+        userHints ss = " (" ++ intercalate ", " ss ++ ")"++-- | Finish a proof. First argument is what we got from the call of 'startTP' above.+finishTP :: SMTConfig -> String -> (Int, Maybe NominalDiffTime) -> [NominalDiffTime] -> IO ()+finishTP cfg@SMTConfig{tpOptions = TPOptions{ribbonLength}} what (skip, mbT) extraTiming =+   message cfg $ replicate (ribbonLength - skip) ' ' ++ what ++ timing ++ extras ++ "\n"+ where timing = maybe "" ((' ' :) . mkTiming) mbT+       extras = concatMap mkTiming extraTiming++       mkTiming t = '[' : showTDiff t ++ "]"++-- | Unique identifier for each proof.+data TPUnique = TPInternal    -- IH's+              | TPSorry       -- sorry+              | TPQC          -- qc (quick-check)+              | TPUser Int64  -- user given+              deriving (NFData, Generic, Eq)++-- | Proof for a property. This type is left abstract, i.e., the only way to create on is via a+-- call to lemma/theorem etc., ensuring soundness. (Note that the trusted-code base here+-- is still large: The underlying solver, SBV, and TP kernel itself. But this+-- mechanism ensures we can't create proven things out of thin air, following the standard LCF+-- methodology.)+newtype Proof a = Proof { proofOf :: ProofObj -- ^ Get the underlying proof object+                        }++-- | Grab the underlying boolean in a proof. Useful in assumption contexts where we need a boolean+assumptionFromProof :: Proof a -> SBool+assumptionFromProof = getObjProof . proofOf++-- | The actual proof container+data ProofObj = ProofObj { dependencies :: [ProofObj]     -- ^ Immediate dependencies of this proof. (Not transitive)+                         , isUserAxiom  :: Bool           -- ^ Was this an axiom given by the user?+                         , getObjProof  :: SBool          -- ^ Get the underlying boolean+                         , getProp      :: Dynamic        -- ^ The actual proposition+                         , proofName    :: String         -- ^ User given name+                         , uniqId       :: TPUnique       -- ^ Unique identifier+                         , isCached     :: Bool           -- ^ Was this a cached proof?+                         }++-- | Drop the instantiation part+shortProofName :: ProofObj -> String+shortProofName p | " @ " `isInfixOf` s = reverse . dropWhile isSpace . reverse . takeWhile (/= '@') $ s+                 | True                = s+   where s = proofName p++-- | Keeping track of where the sorry originates from. Used in displaying dependencies.+newtype RootOfTrust = RootOfTrust (Maybe [ProofObj])++-- | Show instance for t'RootOfTrust'+instance Show RootOfTrust where+  show (RootOfTrust mbp) = case mbp of+                             Nothing -> "Nothing"+                             Just ps -> "Just [" ++ intercalate ", " (map shortProofName ps) ++ "]"++-- | Trust forms a semigroup+instance Semigroup RootOfTrust where+   RootOfTrust as <> RootOfTrust bs = RootOfTrust $ nubBy (\a b -> uniqId a == uniqId b) <$> (as <> bs)++-- | Trust forms a monoid+instance Monoid RootOfTrust where+  mempty = RootOfTrust Nothing++-- | NFData ignores the getProp field+instance NFData ProofObj where+  rnf (ProofObj dependencies isUserAxiom getObjProof _getProp proofName uniqId isCached) =     rnf dependencies+                                                                                         `seq` rnf isUserAxiom+                                                                                         `seq` rnf getObjProof+                                                                                         `seq` rnf proofName+                                                                                         `seq` rnf uniqId+                                                                                         `seq` rnf isCached++-- | Dependencies of a proof, in a tree format.+data ProofTree = ProofTree ProofObj [ProofTree]++-- | Return all the proofs this particular proof depends on, transitively+getProofTree :: ProofObj -> ProofTree+getProofTree p = ProofTree p $ map getProofTree (dependencies p)++-- | Turn dependencies to a container tree, for display purposes+depsToTree :: Bool -> [TPUnique] -> (String -> Int -> Int -> a) -> (Int, ProofTree) -> ([TPUnique], Tree a)+depsToTree shouldCompress visited xform (cnt, ProofTree top ds) = (nVisited, Node (xform nTop cnt (length chlds)) chlds)+  where nTop = shortProofName top+        uniq = uniqId top++        (nVisited, chlds)+           | shouldCompress && uniq `elem` visited = (visited, [])+           | shouldCompress                        = walk (uniq : visited) (compress (filter interesting ds))+           | True                                  = walk         visited  (map (1,) (filter interesting ds))++        walk v []     = (v, [])+        walk v (c:cs) = let (v',  t)  = depsToTree shouldCompress v xform c+                            (v'', ts) = walk v' cs+                        in (v'', t : ts)++        -- Don't show internal axioms, not interesting+        interesting (ProofTree p _) = case uniqId p of+                                        TPInternal -> False+                                        TPSorry    -> True+                                        TPQC       -> True+                                        TPUser{}   -> True++        -- If a proof is used twice in the same proof, compress it+        compress :: [ProofTree] -> [(Int, ProofTree)]+        compress []       = []+        compress (p : ps) = (1 + length [() | (_, True) <- filtered], p) : compress [d | (d, False) <- filtered]+          where filtered = [(d, uniqId p' == curUniq) | d@(ProofTree p' _) <- ps]+                curUniq  = case p of+                             ProofTree curProof _ -> uniqId curProof++-- | Display the proof tree as ASCII text. The first argument is if we should compress the tree, showing only the first+-- use of any sublemma.+showProofTree :: Bool -> Proof a -> String+showProofTree compress d = showTree $ snd $ depsToTree compress [] sh (1, getProofTree (proofOf d))+    where sh nm 1 _ = nm+          sh nm x _= nm ++ " (x" ++ show x ++ ")"++-- | Display the tree as an html doc for rendering purposes.+-- The first argument is if we should compress the tree, showing only the first+-- use of any sublemma. Second is the path (or URL) to external CSS file, if needed.+showProofTreeHTML :: Bool -> Maybe FilePath -> Proof a -> String+showProofTreeHTML compress mbCSS p = htmlTree mbCSS $ snd $ depsToTree compress [] nodify (1, getProofTree (proofOf p))+  where nodify :: String -> Int -> Int -> NodeInfo+        nodify nm cnt dc = NodeInfo { nodeBehavior = InitiallyExpanded+                                    , nodeName     = nm+                                    , nodeInfo     = spc (used cnt) ++ depCount dc+                                    }+        used 1 = ""+        used n = "Used " ++ show n ++ " times."++        spc "" = ""+        spc s  = s ++ " "++        depCount 0 = ""+        depCount 1 = "Has one dependency."+        depCount n = "Has " ++ show n ++ " dependencies."++-- | Show instance for t'Proof'+instance Typeable a => Show (Proof a) where+  show p@(Proof po@ProofObj{proofName = nm}) = '[' : sh (rootOfTrust p) ++ "] " ++ nm ++ " :: " ++ pretty (show (typeOf p))+    where sh (RootOfTrust Nothing)   = "Proven" ++ cacheInfo+          sh (RootOfTrust (Just ps)) = "Modulo: " ++ join ps ++ cacheInfo++          join = intercalate ", " . sort . map shortProofName++          cacheInfo = case cachedProofs po of+                        [] -> ""+                        cs -> ". Cached: " ++ join (nubBy (\p1 p2 -> uniqId p1 == uniqId p2) cs)++          cachedProofs prf@ProofObj{isCached} = if isCached then prf : rest else rest+            where rest = concatMap cachedProofs (dependencies prf)++          -- More mathematical notation for types.+          pretty :: String -> String+          pretty = unwords . walk . words . concatMap (\c -> if c == ',' then " , " else [c]) . clean+            where fa v = ['Ɐ' : unQuote v, "∷"]+                  ex v = ['∃' : unQuote v, "∷"]++                  walk ("SBV"    : "Bool" : rest) = walk $ "Bool" :  rest+                  walk ("Forall" : xs     : rest) = walk $ fa xs  ++ rest+                  walk ("Exists" : xs     : rest) = walk $ ex xs  ++ rest+                  walk ("->"              : rest) = walk $ "→"    :  rest++                  -- handle the double case. This isn't quite solid, but it does the trick.+                  walk ("((Forall" : xs : t1 : "," : "(Forall" : ys : t2 : rest) = ap (fa xs) ++ [np t1 ++ ","] ++ fa ys ++ [np t2] ++ walk rest+                     where -- remove a closing paren from the end if it's there+                           np s | ")" `isSuffixOf` s = init s+                                | True               = s+                           -- add open paren to the first word+                           ap (t : ts) = ('(':t) : ts+                           ap []       = []++                  -- Otherwise, pass along+                  walk (c : cs) = c : walk cs+                  walk []       = []++          -- Strip of Proof (...)+          clean :: String -> String+          clean s | pre `isPrefixOf` s && suf `isSuffixOf` s+                  = reverse . drop (length suf) . reverse . drop (length pre) $ s+                  | True+                  = s+            where pre = "Proof ("+                  suf = ")"++-- | A manifestly false theorem. This is useful when we want to prove a theorem that the underlying solver+-- cannot deal with, or if we want to postpone the proof for the time being. TP will keep+-- track of the uses of 'sorry' and will print them appropriately while printing proofs.+-- NB. We keep this as a t'ProofObj' as opposed to a t'Proof' as it is then easier to use it as a lemma helper.+sorry :: ProofObj+sorry = ProofObj { dependencies = []+                 , isUserAxiom  = False+                 , getObjProof  = label "sorry" (quantifiedBool p)+                 , getProp      = toDyn p+                 , proofName    = "sorry"+                 , uniqId       = TPSorry+                 , isCached     = False+                 }+  where -- ideally, I'd rather just use+        --   p = sFalse+        -- but then SBV constant folds the boolean, and the generated script+        -- doesn't contain the actual contents, as SBV determines unsatisfiability+        -- itself. By using the following proposition (which is easy for the backend+        -- solver to determine as false, we avoid the constant folding.+        p (Forall @"__sbvTP_sorry" (x :: SBool)) = label "SORRY: TP, proof uses \"sorry\"" x++-- | Quick-check uses this proof. It's equivalent to sorry, really; except for its name+quickCheckProof :: ProofObj+quickCheckProof = ProofObj { dependencies = []+                           , isUserAxiom  = False+                           , getObjProof  = label "quickCheck" (quantifiedBool p)+                           , getProp      = toDyn p+                           , proofName    = "quickCheck"+                           , uniqId       = TPQC+                           , isCached     = False+                           }+  where -- ideally, I'd rather just use+        --   p = sFalse+        -- but then SBV constant folds the boolean, and the generated script+        -- doesn't contain the actual contents, as SBV determines unsatisfiability+        -- itself. By using the following proposition (which is easy for the backend+        -- solver to determine as false, we avoid the constant folding.+        p (Forall @"__sbvTP_quickCheck" (x :: SBool)) = label "QUICKCHECK: TP, proof uses \"qc\"" x++-- | Calculate the root of trust. The returned list of proofs, if any, will need to be sorry and quickcheck free to+-- have the given proof to be sorry-free.+rootOfTrust :: Proof a -> RootOfTrust+rootOfTrust = rot True . proofOf+  where rot atTop p@ProofObj{uniqId = curUniq, dependencies} = compress res+          where res = case curUniq of+                        TPInternal -> RootOfTrust Nothing+                        TPQC       -> RootOfTrust $ Just [quickCheckProof]+                        TPSorry    -> RootOfTrust $ Just [sorry]+                        TPUser {}  -> self <> foldMap (rot False) dependencies++                -- if sorry or quickcheck is one of our direct dependencies, then we trust this proof.+                -- Note that we skip this at the top. Why? at that level, we want to see the direct+                -- dependency. But if we're down at a lower level, we just want to pick up+                self | atTop                     = mempty+                     | any isUnsafe dependencies = RootOfTrust $ Just [p]+                     | True                      = mempty++                isUnsafe ProofObj{uniqId = u} = u `elem` [TPSorry, TPQC]++                -- If we have any dependency that is not sorry itself, then we can skip all the sorries.+                -- Why? Because "sorry" will implicitly be coming from one of these anyhow. (In other+                -- words, we do not need to (or want to) distinguish between different uses of sorry.+                compress (RootOfTrust mbps) = RootOfTrust $ reduce <$> mbps+                  where reduce ps = case partition isUnsafe ps of+                                      (l, []) | TPSorry `elem` map uniqId l -> [sorry]+                                              | True                        -> [quickCheckProof]+                                      (_, os) -> os++-- | Calculate the modulo string for dependencies+concludeModulo :: [ProofObj] -> String+concludeModulo by = case foldMap (rootOfTrust . Proof) by of+                      RootOfTrust Nothing   -> ""+                      RootOfTrust (Just ps) -> " [Modulo: " ++ intercalate ", " (map shortProofName ps) ++ "]"++-- | Make TP proofs quiet. Note that this setting will be effective with the+-- call to 'runTP'\/'runTPWith', i.e., if you change the solver in a call to 'Data.SBV.TP.lemmaWith'\/'Data.SBV.TP.theoremWith', we+-- will inherit the quiet settings from the surrounding environment.+tpQuiet :: Bool -> SMTConfig -> SMTConfig+tpQuiet b cfg = cfg{tpOptions = (tpOptions cfg) { quiet = b }}++-- | Change the size of the ribbon for TP proofs. Note that this setting will be effective with the+-- call to 'runTP'\/'runTPWith', i.e., if you change the solver in a call to 'Data.SBV.TP.lemmaWith'\/'Data.SBV.TP.theoremWith', we+-- will inherit the ribbon settings from the surrounding environment.+tpRibbon :: Int -> SMTConfig -> SMTConfig+tpRibbon i cfg = cfg{tpOptions = (tpOptions cfg) { ribbonLength = i }}++-- | Make TP proofs produce statistics. Note that this setting will be effective with the+-- call to 'runTP'\/'runTPWith', i.e., if you change the solver in a call to 'Data.SBV.TP.lemmaWith'\/'Data.SBV.TP.theoremWith', we+-- will inherit the statistics settings from the surrounding environment.+tpStats :: SMTConfig -> SMTConfig+tpStats cfg = cfg{tpOptions = (tpOptions cfg) { printStats = True }}++-- | Make TP proofs use proof-cache. Note that if you use this option then you are obligated to ensure all+-- lemma\/theorem names\/type pairs you use are unique for the whole run. (That is, we will reuse proofs if they have the+-- same name and type; hence if you prove two theorems that share name and type will be considered the same.)+-- If you don't ensure this uniqueness,  the results are not guaranteed to be sound. A good tip is to run the proof at+-- least once to completion, and use cache for regression purposes to avoid re-runs. Also, this setting will be effective+-- with the call to 'runTP'\/'runTPWith', i.e., if you -- the solver in a call to 'Data.SBV.TP.lemmaWith'\/'Data.SBV.TP.theoremWith', we will+-- inherit the caching behavior settings from the surrounding environment.+tpCache :: SMTConfig -> SMTConfig+tpCache cfg = cfg{tpOptions = (tpOptions cfg) { cacheProofs = True }}
− Data/SBV/Tools/KD/Kernel.hs 
@@ -1,212 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Data.SBV.Tools.KD.Kernel--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Kernel of the KnuckleDragger prover API.--------------------------------------------------------------------------------{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE NamedFieldPuns       #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeAbstractions     #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.Tools.KD.Kernel (-         Proposition,  Proof(..)-       , axiom-       , lemma,   lemmaWith,   lemmaGen-       , theorem, theoremWith-       , sorry-       , internalAxiom-       , KDProofContext (..), smtProofStep-       ) where--import Control.Monad.Trans  (liftIO, MonadIO)--import Data.List  (intercalate)-import Data.Maybe (catMaybes)--import Data.SBV.Core.Data hiding (None)-import Data.SBV.Trans.Control hiding (getProof)--import Data.SBV.SMT.SMT-import Data.SBV.Core.Model-import Data.SBV.Provers.Prover--import Data.SBV.Tools.KD.Utils--import Data.Time (NominalDiffTime)-import Data.SBV.Utils.TDiff--import Data.Dynamic---- | A proposition is something SBV is capable of proving/disproving in KnuckleDragger.-type Proposition a = ( QNot a-                     , QuantifiedBool a-                     , QSaturate Symbolic a-                     , Skolemize (NegatesTo a)-                     , Satisfiable (Symbolic (SkolemsTo (NegatesTo a)))-                     , Constraint  Symbolic  (SkolemsTo (NegatesTo a))-                     , Typeable a-                     )---- | Accept the given definition as a fact. Usually used to introduce definitial axioms,--- giving meaning to uninterpreted symbols. Note that we perform no checks on these propositions,--- if you assert nonsense, then you get nonsense back. So, calls to 'axiom' should be limited to--- definitions, or basic axioms (like commutativity, associativity) of uninterpreted function symbols.-axiom :: Proposition a => String -> a -> KD Proof-axiom nm p = do cfg <- getKDConfig-                _   <- liftIO $ startKD cfg True "Axiom" 0 (KDProofOneShot nm [])-                pure (internalAxiom nm p) { isUserAxiom = True }---- | Internal axiom generator; so we can keep truck of KnuckleDrugger's trusted axioms, vs. user given axioms.-internalAxiom :: Proposition a => String -> a -> Proof-internalAxiom nm p = Proof { rootOfTrust  = None-                           , dependencies = []-                           , isUserAxiom  = False-                           , getProof     = label nm (quantifiedBool p)-                           , getProp      = toDyn p-                           , proofName    = nm-                           }---- | A manifestly false theorem. This is useful when we want to prove a theorem that the underlying solver--- cannot deal with, or if we want to postpone the proof for the time being. KnuckleDragger will keep--- track of the uses of 'sorry' and will print them appropriately while printing proofs.-sorry :: Proof-sorry = Proof { rootOfTrust  = Self-              , dependencies = []-              , isUserAxiom  = False-              , getProof     = label "sorry" (quantifiedBool p)-              , getProp      = toDyn p-              , proofName    = "sorry"-              }-  where -- ideally, I'd rather just use-        --   p = sFalse-        -- but then SBV constant folds the boolean, and the generated script-        -- doesn't contain the actual contents, as SBV determines unsatisfiability-        -- itself. By using the following proposition (which is easy for the backend-        -- solver to determine as false, we avoid the constant folding.-        p (Forall @"__sbvKD_sorry" (x :: SBool)) = label "SORRY: KnuckleDragger, proof uses \"sorry\"" x---- | Helper to generate lemma/theorem statements.-lemmaGen :: Proposition a => SMTConfig -> String -> String -> a -> [Proof] -> KD Proof-lemmaGen cfg@SMTConfig{kdOptions = KDOptions{measureTime}} tag nm inputProp by = do-        kdSt <- getKDState-        liftIO $ getTimeStampIf measureTime >>= runSMTWith cfg . go kdSt-  where go kdSt mbStartTime = do qSaturateSavingObservables inputProp-                                 mapM_ (constrain . getProof) by-                                 query $ smtProofStep cfg kdSt tag 0 (KDProofOneShot nm by) Nothing inputProp (good mbStartTime)--        -- What to do if all goes well-        good mbStart d = do mbElapsed <- getElapsedTime mbStart-                            liftIO $ finishKD cfg ("Q.E.D." ++ modulo) d $ catMaybes [mbElapsed]-                            pure Proof { rootOfTrust  = ros-                                       , dependencies = by-                                       , isUserAxiom  = False-                                       , getProof     = label nm (quantifiedBool inputProp)-                                       , getProp      = toDyn inputProp-                                       , proofName    = nm-                                       }-          where (ros, modulo) = calculateRootOfTrust nm by---- | Prove a given statement, using auxiliaries as helpers. Using the default solver.-lemma :: Proposition a => String -> a -> [Proof] -> KD Proof-lemma nm f by = do cfg <- getKDConfig-                   lemmaWith cfg nm f by---- | Prove a given statement, using auxiliaries as helpers. Using the given solver.-lemmaWith :: Proposition a => SMTConfig -> String -> a -> [Proof] -> KD Proof-lemmaWith cfg = lemmaGen cfg "Lemma"---- | Prove a given statement, using auxiliaries as helpers. Essentially the same as 'lemma', except for the name, using the default solver.-theorem :: Proposition a => String -> a -> [Proof] -> KD Proof-theorem nm f by = do cfg <- getKDConfig-                     theoremWith cfg nm f by---- | Prove a given statement, using auxiliaries as helpers. Essentially the same as 'lemmaWith', except for the name.-theoremWith :: Proposition a => SMTConfig -> String -> a -> [Proof] -> KD Proof-theoremWith cfg = lemmaGen cfg "Theorem"---- | Capture the general flow of a proof-step.-smtProofStep :: (SolverContext m, MonadIO m, MonadQuery m, Proposition a)-   => SMTConfig                              -- ^ config-   -> KDState                                -- ^ KDState-   -> String                                 -- ^ tag-   -> Int                                    -- ^ level-   -> KDProofContext                         -- ^ the context in which we're doing the proof-   -> Maybe SBool                            -- ^ Assumptions under which we do the check-sat. If there's one we'll push/pop-   -> a                                      -- ^ what we want to prove-   -> ((Int, Maybe NominalDiffTime) -> IO r) -- ^ what to do when unsat, with the tab amount and time elapsed (if asked)-   -> m r-smtProofStep cfg@SMTConfig{verbose, kdOptions = KDOptions{measureTime}} kdState tag level ctx mbAssumptions prop unsat = do--        case mbAssumptions of-           Nothing  -> do queryDebug ["; smtProofStep: No context value to push."]-                          check-           Just asm -> do queryDebug ["; smtProofStep: Pushing in the context: " ++ show asm]-                          inNewAssertionStack $ do constrain asm-                                                   check-- where check = do-           tab <- liftIO $ startKD cfg verbose tag level ctx--           -- It's tempting to skolemize here.. But skolemization creates fresh constants-           -- based on the name given, and they mess with all else. So, don't skolemize!-           constrain $ sNot (quantifiedBool prop)--           (mbT, r) <- timeIf measureTime checkSat--           updStats kdState (\s -> s{noOfCheckSats = noOfCheckSats s + 1})--           case mbT of-             Nothing -> pure ()-             Just t  -> updStats kdState (\s -> s{solverElapsed = solverElapsed s + t})--           case r of-             Unk    -> unknown-             Sat    -> cex-             DSat{} -> cex-             Unsat  -> liftIO $ unsat (tab, mbT)--       die = error "Failed"--       fullNm = case ctx of-                  KDProofOneShot       s _    -> s-                  KDProofStep    True  s _ ss -> "assumptions for " ++ intercalate "." (s : ss)-                  KDProofStep    False s _ ss ->                       intercalate "." (s : ss)--       unknown = do r <- getUnknownReason-                    liftIO $ do putStrLn $ "\n*** Failed to prove " ++ fullNm ++ "."-                                putStrLn $ "\n*** Solver reported: " ++ show r-                                die--       -- What to do if the proof fails-       cex = do-         liftIO $ putStrLn $ "\n*** Failed to prove " ++ fullNm ++ "."--         res <- case ctx of-                  KDProofStep{}       -> Satisfiable cfg <$> getModel-                  KDProofOneShot _ by ->-                     -- When trying to get a counter-example not in query mode, we-                     -- do a skolemized sat call, which gets better counter-examples.-                     -- We only include the those facts that are user-given axioms. This-                     -- way our counter-example will be more likely to be relevant-                     -- to the proposition we're currently proving. (Hopefully.)-                     -- Remember that we first have to negate, and then skolemize!-                     do SatResult res <- liftIO $ satWith cfg $ do-                                           qSaturateSavingObservables prop-                                           mapM_ constrain [getProof | Proof{isUserAxiom, getProof} <- by, isUserAxiom] :: Symbolic ()-                                           pure $ skolemize (qNot prop)-                        pure res--         liftIO $ print $ ThmResult res--         die
− Data/SBV/Tools/KD/KnuckleDragger.hs 
@@ -1,1172 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Data.SBV.Tools.KD.KnuckleDragger--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ A lightweight theorem proving like interface, built on top of SBV.--- Inspired by and modeled after Philip Zucker's tool with the same--- name, see <http://github.com/philzook58/knuckledragger>.------ See the directory Documentation.SBV.Examples.KnuckleDragger for various examples.--------------------------------------------------------------------------------{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DerivingStrategies    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns        #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeAbstractions      #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.Tools.KD.KnuckleDragger (-         Proposition, Proof, Instantiatable(..), Inst(..), getProofTree, kdShowDepsHTML, KDProofDeps(..)-       , axiom-       , lemma,   lemmaWith-       , theorem, theoremWith-       ,    calc,    calcWith,    calcThm,    calcThmWith-       ,  induct,  inductWith,  inductThm,  inductThmWith-       , sInduct, sInductWith, sInductThm, sInductThmWith-       , sorry-       , KD, runKD, runKDWith, use-       , (|-), (⊢), (=:), (≡), (??), (⁇), split, split2, cases, (==>), (⟹), hasm, hprf, hcmnt, qed, trivial, contradiction-       ) where--import Data.SBV-import Data.SBV.Core.Model (qSaturateSavingObservables)--import Data.SBV.Control hiding (getProof)--import Data.SBV.Tools.KD.Kernel-import Data.SBV.Tools.KD.Utils--import qualified Data.SBV.List as SL--import Control.Monad (when)-import Control.Monad.Trans (liftIO)--import Data.Char (isSpace)-import Data.List (isPrefixOf, isSuffixOf, intercalate)-import Data.Maybe (catMaybes, maybeToList)--import Data.Proxy-import GHC.TypeLits (KnownSymbol, symbolVal, Symbol)--import Data.SBV.Utils.TDiff--import Data.Dynamic---- | Bring an IO proof into current proof context.-use :: IO Proof -> KD Proof-use = liftIO---- | Captures the steps for a calculationa proof-data CalcStrategy = CalcStrategy { calcIntros    :: SBool-                                 , calcProofTree :: KDProof-                                 }---- | Saturatable things in steps-proofTreeSaturatables :: KDProof -> [SBool]-proofTreeSaturatables = go-  where go (ProofEnd    b           hs                ) = b : concatMap getH hs-        go (ProofStep   a           hs               r) = a : concatMap getH hs ++ go r-        go (ProofBranch (_ :: Bool) (_ :: [String]) ps) = concat [b : go p | (b, p) <- ps]--        getH (HelperProof  p) = [getProof p]-        getH (HelperAssum  b) = [b]-        getH HelperString{}   = []---- | Things that are inside calc-strategy that we have to saturate-getCalcStrategySaturatables :: CalcStrategy -> [SBool]-getCalcStrategySaturatables (CalcStrategy calcIntros calcProofTree) = calcIntros : proofTreeSaturatables calcProofTree---- | Propagate the settings for ribbon/timing from top to current. Because in any subsequent configuration--- in a lemmaWith, inductWith etc., we just want to change the solver, not the actual settings for KD.-kdMergeCfg :: SMTConfig -> SMTConfig -> SMTConfig-kdMergeCfg cur top = cur{kdOptions = kdOptions top}---- | A class for doing equational reasoning style calculational proofs. Use 'calc' to prove a given theorem--- as a sequence of equalities, each step following from the previous.-class CalcLemma a steps where--  -- | Prove a property via a series of equality steps, using the default solver.-  -- Let @H@ be a list of already established lemmas. Let @P@ be a property we wanted to prove, named @name@.-  -- Consider a call of the form @calc name P (cond, [A, B, C, D]) H@. Note that @H@ is-  -- a list of already proven facts, ensured by the type signature. We proceed as follows:-  ---  --    * Prove: @(H && cond)                                   -> (A == B)@-  --    * Prove: @(H && cond && A == B)                         -> (B == C)@-  --    * Prove: @(H && cond && A == B && B == C)               -> (C == D)@-  --    * Prove: @(H && (cond -> (A == B && B == C && C == D))) -> P@-  --    * If all of the above steps succeed, conclude @P@.-  ---  -- cond acts as the context. Typically, if you are trying to prove @Y -> Z@, then you want cond to be Y.-  -- (This is similar to @intros@ commands in theorem provers.)-  ---  -- So, calc-lemma is essentially modus-ponens, applied in a sequence of stepwise equality reasoning in the case of-  -- non-boolean steps.-  ---  -- If there are no helpers given (i.e., if @H@ is empty), then this call is equivalent to 'lemmaWith'.-  -- If @H@ is a singleton, then we bail out. A single step in @H@ indicates a usage mistake, since there's-  -- no sequence of steps to reason about.-  calc :: Proposition a => String -> a -> steps -> KD Proof--  -- | Same as calc, except tagged as Theorem-  calcThm :: Proposition a => String -> a -> steps -> KD Proof--  -- | Prove a property via a series of equality steps, using the given solver.-  calcWith :: Proposition a => SMTConfig -> String -> a -> steps -> KD Proof--  -- | Same as calcWith, except tagged as Theorem-  calcThmWith :: Proposition a => SMTConfig -> String -> a -> steps -> KD Proof--  -- | Internal, shouldn't be needed outside the library-  {-# MINIMAL calcSteps #-}-  calcSteps :: a -> steps -> Symbolic (SBool, CalcStrategy)--  calc            nm p steps = getKDConfig >>= \cfg  -> calcWith          cfg                   nm p steps-  calcThm         nm p steps = getKDConfig >>= \cfg  -> calcThmWith       cfg                   nm p steps-  calcWith    cfg nm p steps = getKDConfig >>= \cfg' -> calcGeneric False (kdMergeCfg cfg cfg') nm p steps-  calcThmWith cfg nm p steps = getKDConfig >>= \cfg' -> calcGeneric True  (kdMergeCfg cfg cfg') nm p steps--  calcGeneric :: Proposition a => Bool -> SMTConfig -> String -> a -> steps -> KD Proof-  calcGeneric tagTheorem cfg nm result steps = do-     kdSt <- getKDState--     liftIO $ runSMTWith cfg $ do--        qSaturateSavingObservables result -- make sure we saturate the result, i.e., get all it's UI's, types etc. pop out--        message cfg $ (if tagTheorem then "Theorem" else "Lemma") ++ ": " ++ nm ++ "\n"--        (calcGoal, strategy@CalcStrategy {calcIntros, calcProofTree}) <- calcSteps result steps--        -- Collect all subterms and saturate them-        mapM_ qSaturateSavingObservables $ getCalcStrategySaturatables strategy--        query $ proveProofTree cfg kdSt nm (result, calcGoal) calcIntros calcProofTree---- | Prove the proof tree. The arguments are:------      result           : The ultimate goal we want to prove. Note that this is a general proposition, and we don't actually prove it. See the next param.---      resultBool       : The instance of result that, if we prove it, establishes the result itself---      initialHypotheses: Hypotheses (conjuncted)---      calcProofTree    : A tree of steps, which give rise to a bunch of equalities------ Note that we do not check the resultBool is the result itself just "instantiated" appropriately. This is the contract with the caller who--- has to establish that by whatever means it chooses to do so.------ The final proof we have has the following form:------     - For each "link" in the proofTree, prove that intros .=> link---     - The above will give us a bunch of results, for each leaf node in the tree.---     - Then prove: (intros .=> sAnd results) .=> resultBool---     - Then conclude result, based on what assumption that proving resultBool establishes result-proveProofTree :: Proposition a-               => SMTConfig-               -> KDState-               -> String        -- ^ the name of the top result-               -> (a, SBool)    -- ^ goal: as a proposition and as a boolean-               -> SBool         -- ^ hypotheses-               -> KDProof       -- ^ proof tree-               -> Query Proof-proveProofTree cfg kdSt nm (result, resultBool) initialHypotheses calcProofTree = do--  let SMTConfig{kdOptions = KDOptions{measureTime}} = cfg-  mbStartTime <- getTimeStampIf measureTime--  let next :: [Int] -> [Int]-      next bs = case reverse bs of-                  i : rs -> reverse $ i + 1 : rs-                  []     -> [1]--      isEnd ProofEnd{}    = True-      isEnd ProofStep{}   = False-      isEnd ProofBranch{} = False--      -- trim the branch-name, if we're in a deeper level, and we're at the end-      trimBN level bn | level > 1, 1 : _ <- reverse bn = init bn-                      | True                           = bn--      -- If the next step is ending and we're the 1st step; our number can be skipped-      mkStepName level bn nextStep | isEnd nextStep = map show (trimBN level bn)-                                   | True           = map show bn--      walk :: SBool -> Int -> ([Int], KDProof) -> Query [SBool]--      -- End of proof, return what it established. If there's a hint associated here, it was probably by mistake; so tell it to the user.-      walk intros level (bn, ProofEnd calcResult hs)-         | not (null hs)-         = error $ unlines [ ""-                           , "*** Incorrect calc/induct lemma calculations."-                           , "***"-                           , "***    The last step in the proof has a helper, which isn't used."-                           , "***"-                           , "*** Perhaps the hint is off-by-one in its placement?"-                           ]-         | True-         =  do -- If we're not at the top-level and this is the only step, print it.-               -- Otherwise the noise isn't necessary.-               when (level > 1) $ case reverse bn of-                                    1 : _ -> liftIO $ do tab <- startKD cfg False "Step" level (KDProofStep False nm [] (map show (init bn)))-                                                         finishKD cfg "Q.E.D." (tab, Nothing) []-                                    _     -> pure ()--               pure [intros .=> calcResult]--      -- Do the branches separately and collect the results. If there's coverage needed, we do it too; which-      -- is essentially the assumption here.-      walk intros level (bnTop, ProofBranch checkCompleteness hintStrings ps) = do--        let bn = trimBN level bnTop--            addSuffix xs s = case reverse xs of-                                l : p -> reverse $ (l ++ s) : p-                                []    -> [s]--            full | checkCompleteness = ""-                 | True              = "full "--            stepName = map show bn--        _ <- io $ startKD cfg True "Step" level (KDProofStep False nm hintStrings (addSuffix stepName (" (" ++ show (length ps) ++ " way " ++ full ++ "case split)")))--        results <- concat <$> sequence [walk (intros .&& branchCond) (level + 1) (bn ++ [i, 1], p) | (i, (branchCond, p)) <- zip [1..] ps]--        when checkCompleteness $ smtProofStep cfg kdSt "Step" (level+1)-                                                       (KDProofStep False nm [] (stepName ++ ["Completeness"]))-                                                       (Just intros)-                                                       (sOr (map fst ps))-                                                       (\d -> finishKD cfg "Q.E.D." d [])-        pure results--      -- Do a proof step-      walk intros level (bn, ProofStep cur hs p) = do--           let finish et helpers d = finishKD cfg ("Q.E.D." ++ modulo) d et-                  where (_, modulo) = calculateRootOfTrust nm helpers--               stepName = mkStepName level bn p--           -- First prove the assumptions, if there are any. We stay quiet, unless timing is asked for-           let (quietCfg, finalizer)-                 | measureTime = (cfg,                                              finish [] [])-                 | True        = (cfg{kdOptions = (kdOptions cfg) { quiet = True}}, const (pure ()))--               as = concatMap getHelperAssumes hs-               ss = getHelperText hs-           case as of-             [] -> pure ()-             _  -> smtProofStep quietCfg kdSt "Asms" level-                                         (KDProofStep True nm [] stepName)-                                         (Just intros)-                                         (sAnd as)-                                         finalizer--           -- Now prove the step-           let by = concatMap getHelperProofs hs-           smtProofStep cfg kdSt "Step" level-                                 (KDProofStep False nm ss stepName)-                                 (Just (sAnd (intros : as ++ map getProof by)))-                                 cur-                                 (finish [] by)--           -- Move to next-           walk intros level (next bn, p)--  results <- walk initialHypotheses 1 ([1], calcProofTree)--  queryDebug [nm ++ ": Proof end: proving the result:"]--  smtProofStep cfg kdSt "Result" 1-               (KDProofStep False nm [] [""])-               (Just (initialHypotheses .=> sAnd results))-               resultBool $ \d ->-                 do mbElapsed <- getElapsedTime mbStartTime-                    let (ros, modulo) = calculateRootOfTrust nm (concatMap getHelperProofs (getAllHelpers calcProofTree))-                    finishKD cfg ("Q.E.D." ++ modulo) d (catMaybes [mbElapsed])--                    pure Proof { rootOfTrust  = ros-                               , dependencies = getDependencies calcProofTree-                               , isUserAxiom  = False-                               , getProof     = label nm (quantifiedBool result)-                               , getProp      = toDyn result-                               , proofName    = nm-                               }---- Helper data-type for calc-step below-data CalcContext a = CalcStart     [Helper] -- Haven't started yet-                   | CalcStep  a a [Helper] -- Intermediate step: first value, prev value---- | Turn a sequence of steps into a chain of equalities-mkCalcSteps :: EqSymbolic a => (SBool, KDProofRaw a) -> CalcStrategy-mkCalcSteps (intros, kdp) = CalcStrategy { calcIntros    = intros-                                         , calcProofTree = go (CalcStart []) kdp-                                         }-  where go :: EqSymbolic a => CalcContext a -> KDProofRaw a -> KDProof--        -- End of the proof; tie the begin and end-        go step (ProofEnd () hs) = case step of-                                     -- It's tempting to error out if we're at the start and already reached the end-                                     -- This means we're given a sequence of no-steps. While this is useless in the-                                     -- general case, it's quite valid in a case-split; where one of the case-splits-                                     -- might be easy enough for the solver to deduce so the user simply says "just derive it for me."-                                     CalcStart hs'          -> ProofEnd sTrue           (hs' ++ hs) -- Nothing proven!-                                     CalcStep begin end hs' -> ProofEnd (begin .== end) (hs' ++ hs)--        -- Branch: Just push it down. We use the hints from previous step, and pass the current ones down.-        go step (ProofBranch c hs ps) = ProofBranch c (getHelperText hs) [(branchCond, go step' p) | (branchCond, p) <- ps]-           where step' = case step of-                           CalcStart hs'     -> CalcStart (hs' ++ hs)-                           CalcStep  a b hs' -> CalcStep a b (hs' ++ hs)--        -- Step:-        go (CalcStart hs)           (ProofStep cur hs' p) =                               go (CalcStep cur   cur (hs' ++ hs)) p-        go (CalcStep first prev hs) (ProofStep cur hs' p) = ProofStep (prev  .== cur) hs (go (CalcStep first cur hs')         p)---- | Chaining lemmas that depend on no extra variables-instance EqSymbolic z => CalcLemma SBool (SBool, KDProofRaw z) where-   calcSteps result steps = pure (result, mkCalcSteps steps)---- | Chaining lemmas that depend on a single extra variable.-instance (KnownSymbol na, SymVal a, EqSymbolic z) => CalcLemma (Forall na a -> SBool) (SBV a -> (SBool, KDProofRaw z)) where-   calcSteps result steps = do a <- free (symbolVal (Proxy @na))-                               pure (result (Forall a), mkCalcSteps (steps a))---- | Chaining lemmas that depend on two extra variables.-instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, EqSymbolic z)-      => CalcLemma (Forall na a -> Forall nb b -> SBool)-                   (SBV a -> SBV b -> (SBool, KDProofRaw z)) where-   calcSteps result steps = do (a, b) <- (,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb))-                               pure (result (Forall a) (Forall b), mkCalcSteps (steps a b))---- | Chaining lemmas that depend on three extra variables.-instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, EqSymbolic z)-      => CalcLemma (Forall na a -> Forall nb b -> Forall nc c -> SBool)-                   (SBV a -> SBV b -> SBV c -> (SBool, KDProofRaw z)) where-   calcSteps result steps = do (a, b, c) <- (,,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb)) <*> free (symbolVal (Proxy @nc))-                               pure (result (Forall a) (Forall b) (Forall c), mkCalcSteps (steps a b c))---- | Chaining lemmas that depend on four extra variables.-instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, EqSymbolic z)-      => CalcLemma (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool)-                   (SBV a -> SBV b -> SBV c -> SBV d -> (SBool, KDProofRaw z)) where-   calcSteps result steps = do (a, b, c, d) <- (,,,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb)) <*> free (symbolVal (Proxy @nc)) <*> free (symbolVal (Proxy @nd))-                               pure (result (Forall a) (Forall b) (Forall c) (Forall d), mkCalcSteps (steps a b c d))---- | Chaining lemmas that depend on five extra variables.-instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e, EqSymbolic z)-      => CalcLemma (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool)-                   (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> (SBool, KDProofRaw z)) where-   calcSteps result steps = do (a, b, c, d, e) <- (,,,,) <$> free (symbolVal (Proxy @na)) <*> free (symbolVal (Proxy @nb)) <*> free (symbolVal (Proxy @nc)) <*> free (symbolVal (Proxy @nd)) <*> free (symbolVal (Proxy @ne))-                               pure (result (Forall a) (Forall b) (Forall c) (Forall d) (Forall e), mkCalcSteps (steps a b c d e))---- | Captures the schema for an inductive proof. Base case might be nothing, to cover strong induction.-data InductionStrategy = InductionStrategy { inductionIntros    :: SBool-                                           , inductionMeasure   :: Maybe SBool-                                           , inductionBaseCase  :: Maybe SBool-                                           , inductionProofTree :: KDProof-                                           , inductiveStep      :: SBool-                                           }---- | Are we doing regular induction or measure based general induction?-data InductionStyle = RegularInduction | GeneralInduction--getInductionStrategySaturatables :: InductionStrategy -> [SBool]-getInductionStrategySaturatables (InductionStrategy inductionIntros-                                                    inductionMeasure-                                                    inductionBaseCase-                                                    inductionProofSteps-                                                    inductiveStep)-  = inductionIntros : inductiveStep : proofTreeSaturatables inductionProofSteps ++ maybeToList inductionBaseCase ++ maybeToList inductionMeasure---- | A class for doing regular inductive proofs.-class Inductive a steps where-   -- | Inductively prove a lemma, using the default config.-   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only-   -- partial correctness is guaranteed if non-terminating functions are involved.-   induct  :: Proposition a => String -> a -> (Proof -> steps) -> KD Proof--   -- | Inductively prove a theorem. Same as 'induct', but tagged as a theorem, using the default config.-   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only-   -- partial correctness is guaranteed if non-terminating functions are involved.-   inductThm :: Proposition a => String -> a -> (Proof -> steps) -> KD Proof--   -- | Same as 'induct', but with the given solver configuration.-   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only-   -- partial correctness is guaranteed if non-terminating functions are involved.-   inductWith :: Proposition a => SMTConfig -> String -> a -> (Proof -> steps) -> KD Proof--   -- | Same as 'inductThm', but with the given solver configuration.-   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only-   -- partial correctness is guaranteed if non-terminating functions are involved.-   inductThmWith :: Proposition a => SMTConfig -> String -> a -> (Proof -> steps) -> KD Proof--   induct            nm p steps = getKDConfig >>= \cfg  -> inductWith                             cfg                   nm p steps-   inductThm         nm p steps = getKDConfig >>= \cfg  -> inductThmWith                          cfg                   nm p steps-   inductWith    cfg nm p steps = getKDConfig >>= \cfg' -> inductionEngine RegularInduction False (kdMergeCfg cfg cfg') nm p (inductionStrategy p steps)-   inductThmWith cfg nm p steps = getKDConfig >>= \cfg' -> inductionEngine RegularInduction True  (kdMergeCfg cfg cfg') nm p (inductionStrategy p steps)--   -- | Internal, shouldn't be needed outside the library-   {-# MINIMAL inductionStrategy #-}-   inductionStrategy :: Proposition a => a -> (Proof -> steps) -> Symbolic InductionStrategy---- | A class of measures, used for inductive arguments.-class OrdSymbolic a => Measure a where-  zero :: a---- | An integer as a measure-instance Measure SInteger where-   zero = 0---- | A tuple of integers as a measure-instance Measure (SInteger, SInteger) where-  zero = (0, 0)---- | A triple of integers as a measure-instance Measure (SInteger, SInteger, SInteger) where-  zero = (0, 0, 0)---- | A quadruple of integers as a measure-instance Measure (SInteger, SInteger, SInteger, SInteger) where-  zero = (0, 0, 0, 0)--instance Measure (SInteger, SInteger, SInteger, SInteger, SInteger) where-  zero = (0, 0, 0, 0, 0)---- | A class for doing generalized measure based strong inductive proofs.-class SInductive a measure steps where-   -- | Inductively prove a lemma, using measure based induction, using the default config.-   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only-   -- partial correctness is guaranteed if non-terminating functions are involved.-   sInduct :: Proposition a => String -> a -> measure -> (Proof -> steps) -> KD Proof--   -- | Inductively prove a theorem, using measure based induction. Same as 'sInduct', but tagged as a theorem, using the default config.-   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only-   -- partial correctness is guaranteed if non-terminating functions are involved.-   sInductThm :: Proposition a => String -> a -> measure -> (Proof -> steps) -> KD Proof--   -- | Same as 'sInduct', but with the given solver configuration.-   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only-   -- partial correctness is guaranteed if non-terminating functions are involved.-   sInductWith :: Proposition a => SMTConfig -> String -> a -> measure -> (Proof -> steps) -> KD Proof--   -- | Same as 'sInductThm', but with the given solver configuration.-   -- Inductive proofs over lists only hold for finite lists. We also assume that all functions involved are terminating. SBV does not prove termination, so only-   -- partial correctness is guaranteed if non-terminating functions are involved.-   sInductThmWith :: Proposition a => SMTConfig -> String -> a -> measure -> (Proof -> steps) -> KD Proof--   sInduct            nm p m steps = getKDConfig >>= \cfg  -> sInductWith                            cfg                   nm p m steps-   sInductThm         nm p m steps = getKDConfig >>= \cfg  -> sInductThmWith                         cfg                   nm p m steps-   sInductWith    cfg nm p m steps = getKDConfig >>= \cfg' -> inductionEngine GeneralInduction False (kdMergeCfg cfg cfg') nm p (sInductionStrategy p m steps)-   sInductThmWith cfg nm p m steps = getKDConfig >>= \cfg' -> inductionEngine GeneralInduction True  (kdMergeCfg cfg cfg') nm p (sInductionStrategy p m steps)--   -- | Internal, shouldn't be needed outside the library-   {-# MINIMAL sInductionStrategy #-}-   sInductionStrategy :: Proposition a => a -> measure -> (Proof -> steps) -> Symbolic InductionStrategy---- | Do an inductive proof, based on the given strategy-inductionEngine :: Proposition a => InductionStyle -> Bool -> SMTConfig -> String -> a -> Symbolic InductionStrategy -> KD Proof-inductionEngine style tagTheorem cfg nm result getStrategy = do-   kdSt <- getKDState--   liftIO $ runSMTWith cfg $ do--      qSaturateSavingObservables result -- make sure we saturate the result, i.e., get all it's UI's, types etc. pop out--      let qual = case style of-                   RegularInduction -> ""-                   GeneralInduction  -> " (strong)"--      message cfg $ "Inductive " ++ (if tagTheorem then "theorem" else "lemma") ++ qual ++ ": " ++ nm ++ "\n"--      strategy@InductionStrategy { inductionIntros-                                 , inductionMeasure-                                 , inductionBaseCase-                                 , inductionProofTree-                                 , inductiveStep-                                 } <- getStrategy--      mapM_ qSaturateSavingObservables $ getInductionStrategySaturatables strategy--      query $ do--       case inductionMeasure of-          Nothing -> queryDebug [nm ++ ": Induction" ++ qual ++ ", there is no custom measure to show non-negativeness."]-          Just ms -> do queryDebug [nm ++ ": Induction, proving measure is always non-negative:"]-                        smtProofStep cfg kdSt "Step" 1-                                              (KDProofStep False nm [] ["Measure is non-negative"])-                                              (Just inductionIntros)-                                              ms-                                              (\d -> finishKD cfg "Q.E.D." d [])-       case inductionBaseCase of-          Nothing -> queryDebug [nm ++ ": Induction" ++ qual ++ ", there is no base case to prove."]-          Just bc -> do queryDebug [nm ++ ": Induction, proving base case:"]-                        smtProofStep cfg kdSt "Step" 1-                                              (KDProofStep False nm [] ["Base"])-                                              (Just inductionIntros)-                                              bc-                                              (\d -> finishKD cfg "Q.E.D." d [])--       proveProofTree cfg kdSt nm (result, inductiveStep) inductionIntros inductionProofTree---- Induction strategy helper-mkIndStrategy :: EqSymbolic a => Maybe SBool -> Maybe SBool -> (SBool, KDProofRaw a) -> SBool -> InductionStrategy-mkIndStrategy mbMeasure mbBaseCase indSteps step =-        let CalcStrategy { calcIntros, calcProofTree } = mkCalcSteps indSteps-        in InductionStrategy { inductionIntros    = calcIntros-                             , inductionMeasure   = mbMeasure-                             , inductionBaseCase  = mbBaseCase-                             , inductionProofTree = calcProofTree-                             , inductiveStep      = step-                             }---- | Create a new variable with the given name, return both the variable and the name-mkVar :: (KnownSymbol n, SymVal a) => proxy n -> Symbolic (SBV a, String)-mkVar x = do let nn = symbolVal x-             n <- free nn-             pure (n, nn)---- | Create a new variable with the given name, return both the variable and the name. List version.-mkLVar :: (KnownSymbol n, SymVal a) => proxy n -> Symbolic (SBV a, SList a, String)-mkLVar x = do let nxs = symbolVal x-                  nx  = singular nxs-              e  <- free nx-              es <- free nxs-              pure (e, es, nx ++ ":" ++ nxs)---- | Helper for induction result-indResult :: [String] -> SBool -> SBool-indResult nms = observeIf not ("P(" ++ intercalate ", " nms ++ ")")---- | Induction over 'SInteger'-instance (KnownSymbol nn, EqSymbolic z) => Inductive (Forall nn Integer -> SBool) (SInteger -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (n, nn) <- mkVar (Proxy @nn)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall 0)))-                            (steps (internalAxiom "IH" (n .>= zero .=> result (Forall n))) n)-                            (indResult [nn ++ "+1"] (result (Forall (n+1))))---- | Induction over 'SInteger', taking an extra argument-instance (KnownSymbol nn, KnownSymbol na, SymVal a, EqSymbolic z) => Inductive (Forall nn Integer -> Forall na a -> SBool) (SInteger -> SBV a -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (n, nn) <- mkVar (Proxy @nn)-       (a, na) <- mkVar (Proxy @na)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall 0) (Forall a)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) -> n .>= zero .=> result (Forall n) (Forall a'))) n a)-                            (indResult [nn ++ "+1", na] (result (Forall (n+1)) (Forall a)))---- | Induction over 'SInteger', taking two extra arguments-instance (KnownSymbol nn, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, EqSymbolic z) => Inductive (Forall nn Integer -> Forall na a -> Forall nb b -> SBool) (SInteger -> SBV a -> SBV b -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (n, nn) <- mkVar (Proxy @nn)-       (a, na) <- mkVar (Proxy @na)-       (b, nb) <- mkVar (Proxy @nb)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall 0) (Forall a) (Forall b)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) -> n .>= zero .=> result (Forall n) (Forall a') (Forall b'))) n a b)-                            (indResult [nn ++ "+1", na, nb] (result (Forall (n+1)) (Forall a) (Forall b)))---- | Induction over 'SInteger', taking three extra arguments-instance (KnownSymbol nn, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, EqSymbolic z) => Inductive (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> SBool) (SInteger -> SBV a -> SBV b -> SBV c -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (n, nn) <- mkVar (Proxy @nn)-       (a, na) <- mkVar (Proxy @na)-       (b, nb) <- mkVar (Proxy @nb)-       (c, nc) <- mkVar (Proxy @nc)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall 0) (Forall a) (Forall b) (Forall c)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) -> n .>= zero .=> result (Forall n) (Forall a') (Forall b') (Forall c'))) n a b c)-                            (indResult [nn ++ "+1", na, nb, nc] (result (Forall (n+1)) (Forall a) (Forall b) (Forall c)))---- | Induction over 'SInteger', taking four extra arguments-instance (KnownSymbol nn, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, EqSymbolic z) => Inductive (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) (SInteger -> SBV a -> SBV b -> SBV c -> SBV d -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (n, nn) <- mkVar (Proxy @nn)-       (a, na) <- mkVar (Proxy @na)-       (b, nb) <- mkVar (Proxy @nb)-       (c, nc) <- mkVar (Proxy @nc)-       (d, nd) <- mkVar (Proxy @nd)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall 0) (Forall a) (Forall b) (Forall c) (Forall d)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) -> n .>= zero .=> result (Forall n) (Forall a') (Forall b') (Forall c') (Forall d'))) n a b c d)-                            (indResult [nn ++ "+1", na, nb, nc, nd] (result (Forall (n+1)) (Forall a) (Forall b) (Forall c) (Forall d)))---- | Induction over 'SInteger', taking five extra arguments-instance (KnownSymbol nn, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e, EqSymbolic z) => Inductive (Forall nn Integer -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) (SInteger -> SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (n, nn) <- mkVar (Proxy @nn)-       (a, na) <- mkVar (Proxy @na)-       (b, nb) <- mkVar (Proxy @nb)-       (c, nc) <- mkVar (Proxy @nc)-       (d, nd) <- mkVar (Proxy @nd)-       (e, ne) <- mkVar (Proxy @ne)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall 0) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) (Forall e' :: Forall ne e) -> n .>= zero .=> result (Forall n) (Forall a') (Forall b') (Forall c') (Forall d') (Forall e'))) n a b c d e)-                            (indResult [nn ++ "+1", na, nb, nc, nd, ne] (result (Forall (n+1)) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))---- Given a user name for the list, get a name for the element, in the most suggestive way possible---   xs  -> x---   xss -> xs---   foo -> fooElt-singular :: String -> String-singular n = case reverse n of-               's':_:_ -> init n-               _       -> n ++ "Elt"---- | Induction over 'SList'-instance (KnownSymbol nxs, SymVal x, EqSymbolic z) => Inductive (Forall nxs [x] -> SBool) (SBV x -> SList x -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil)))-                            (steps (internalAxiom "IH" (result (Forall xs))) x xs)-                            (indResult [nxxs] (result (Forall (x SL..: xs))))---- | Induction over 'SList', taking an extra argument-instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a, EqSymbolic z) => Inductive (Forall nxs [x] -> Forall na a -> SBool) (SBV x -> SList x -> SBV a -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (a, na)       <- mkVar  (Proxy @na)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil) (Forall a)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) -> result (Forall xs) (Forall a'))) x xs a)-                            (indResult [nxxs, na] (result (Forall (x SL..: xs)) (Forall a)))---- | Induction over 'SList', taking two extra arguments-instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, EqSymbolic z) => Inductive (Forall nxs [x] -> Forall na a -> Forall nb b -> SBool) (SBV x -> SList x -> SBV a -> SBV b -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (a, na)       <- mkVar  (Proxy @na)-       (b, nb)       <- mkVar  (Proxy @nb)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil) (Forall a) (Forall b)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) -> result (Forall xs) (Forall a') (Forall b'))) x xs a b)-                            (indResult [nxxs, na, nb] (result (Forall (x SL..: xs)) (Forall a) (Forall b)))---- | Induction over 'SList', taking three extra arguments-instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, EqSymbolic z) => Inductive (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> SBool) (SBV x -> SList x -> SBV a -> SBV b -> SBV c -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (a, na)       <- mkVar  (Proxy @na)-       (b, nb)       <- mkVar  (Proxy @nb)-       (c, nc)       <- mkVar  (Proxy @nc)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil) (Forall a) (Forall b) (Forall c)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) -> result (Forall xs) (Forall a') (Forall b') (Forall c'))) x xs a b c)-                            (indResult [nxxs, na, nb, nc] (result (Forall (x SL..: xs)) (Forall a) (Forall b) (Forall c)))---- | Induction over 'SList', taking four extra arguments-instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, EqSymbolic z) => Inductive (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) (SBV x -> SList x -> SBV a -> SBV b -> SBV c -> SBV d -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (a, na)       <- mkVar  (Proxy @na)-       (b, nb)       <- mkVar  (Proxy @nb)-       (c, nc)       <- mkVar  (Proxy @nc)-       (d, nd)       <- mkVar  (Proxy @nd)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) -> result (Forall xs) (Forall a') (Forall b') (Forall c') (Forall d'))) x xs a b c d)-                            (indResult [nxxs, na, nb, nc, nd] (result (Forall (x SL..: xs)) (Forall a) (Forall b) (Forall c) (Forall d)))---- | Induction over 'SList', taking five extra arguments-instance (KnownSymbol nxs, SymVal x, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e, EqSymbolic z) => Inductive (Forall nxs [x] -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) (SBV x -> SList x -> SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (a, na)       <- mkVar  (Proxy @na)-       (b, nb)       <- mkVar  (Proxy @nb)-       (c, nc)       <- mkVar  (Proxy @nc)-       (d, nd)       <- mkVar  (Proxy @nd)-       (e, ne)       <- mkVar  (Proxy @ne)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) (Forall e' :: Forall ne e) -> result (Forall xs) (Forall a') (Forall b') (Forall c') (Forall d') (Forall e'))) x xs a b c d e)-                            (indResult [nxxs, na, nb, nc, nd, ne] (result (Forall (x SL..: xs)) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))---- | Induction over two 'SList', simultaneously-instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, EqSymbolic z) => Inductive ((Forall nxs [x], Forall nys [y]) -> SBool) ((SBV x, SList x, SBV y, SList y) -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (y, ys, nyys) <- mkLVar (Proxy @nys)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil, Forall SL.nil) .&& result (Forall SL.nil, Forall (y SL..: ys)) .&& result (Forall (x SL..: xs), Forall SL.nil)))-                            (steps (internalAxiom "IH" (result (Forall xs, Forall ys))) (x, xs, y, ys))-                            (indResult [nxxs, nyys] (result (Forall (x SL..: xs), Forall (y SL..: ys))))---- | Induction over two 'SList', simultaneously, taking an extra argument-instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a, EqSymbolic z) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> SBool) ((SBV x, SList x, SBV y, SList y) -> SBV a -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (y, ys, nyys) <- mkLVar (Proxy @nys)-       (a, na)       <- mkVar  (Proxy @na)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil, Forall SL.nil) (Forall a) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) -> result (Forall xs, Forall ys) (Forall a'))) (x, xs, y, ys) a)-                            (indResult [nxxs, nyys, na] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a)))---- | Induction over two 'SList', simultaneously, taking two extra arguments-instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, EqSymbolic z) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> SBool) ((SBV x, SList x, SBV y, SList y) -> SBV a -> SBV b -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (y, ys, nyys) <- mkLVar (Proxy @nys)-       (a, na)       <- mkVar  (Proxy @na)-       (b, nb)       <- mkVar  (Proxy @nb)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil, Forall SL.nil) (Forall a) (Forall b) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) (Forall b) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a) (Forall b)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) -> result (Forall xs, Forall ys) (Forall a') (Forall b'))) (x, xs, y, ys) a b)-                            (indResult [nxxs, nyys, na, nb] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a) (Forall b)))---- | Generalized induction with one parameter-instance (KnownSymbol na, SymVal a, EqSymbolic z, Measure m) => SInductive (Forall na a -> SBool) (SBV a -> m) (SBV a -> (SBool, KDProofRaw z)) where-  sInductionStrategy result measure steps = do-      (a, na) <- mkVar (Proxy @na)-      pure $ mkIndStrategy (Just (measure a .>= zero))-                           Nothing-                           (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) -> measure a' .< measure a .=> result (Forall a'))) a)-                           (indResult [na] (result (Forall a)))---- | Generalized induction with two parameters-instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, EqSymbolic z, Measure m) => SInductive (Forall na a -> Forall nb b -> SBool) (SBV a -> SBV b -> m) (SBV a -> SBV b -> (SBool, KDProofRaw z)) where-  sInductionStrategy result measure steps = do-      (a, na) <- mkVar (Proxy @na)-      (b, nb) <- mkVar (Proxy @nb)-      pure $ mkIndStrategy (Just (measure a b .>= zero))-                           Nothing-                           (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) -> measure a' b' .< measure a b .=> result (Forall a') (Forall b'))) a b)-                           (indResult [na, nb] (result (Forall a) (Forall b)))---- | Generalized induction with three parameters-instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, EqSymbolic z, Measure m) => SInductive (Forall na a -> Forall nb b -> Forall nc c -> SBool) (SBV a -> SBV b -> SBV c -> m) (SBV a -> SBV b -> SBV c -> (SBool, KDProofRaw z)) where-  sInductionStrategy result measure steps = do-      (a, na) <- mkVar (Proxy @na)-      (b, nb) <- mkVar (Proxy @nb)-      (c, nc) <- mkVar (Proxy @nc)-      pure $ mkIndStrategy (Just (measure a b c .>= zero))-                           Nothing-                           (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) -> measure a' b' c' .< measure a b c .=> result (Forall a') (Forall b') (Forall c'))) a b c)-                           (indResult [na, nb, nc] (result (Forall a) (Forall b) (Forall c)))---- | Generalized induction with four parameters-instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, EqSymbolic z, Measure m) => SInductive (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) (SBV a -> SBV b -> SBV c -> SBV d -> m) (SBV a -> SBV b -> SBV c -> SBV d -> (SBool, KDProofRaw z)) where-  sInductionStrategy result measure steps = do-      (a, na) <- mkVar (Proxy @na)-      (b, nb) <- mkVar (Proxy @nb)-      (c, nc) <- mkVar (Proxy @nc)-      (d, nd) <- mkVar (Proxy @nd)-      pure $ mkIndStrategy (Just (measure a b c d .>= zero))-                           Nothing-                           (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) -> measure a' b' c' d' .< measure a b c d .=> result (Forall a') (Forall b') (Forall c') (Forall d'))) a b c d)-                           (indResult [na, nb, nc, nd] (result (Forall a) (Forall b) (Forall c) (Forall d)))---- | Generalized induction with five parameters-instance (KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e, EqSymbolic z, Measure m) => SInductive (Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> m) (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> (SBool, KDProofRaw z)) where-  sInductionStrategy result measure steps = do-      (a, na) <- mkVar (Proxy @na)-      (b, nb) <- mkVar (Proxy @nb)-      (c, nc) <- mkVar (Proxy @nc)-      (d, nd) <- mkVar (Proxy @nd)-      (e, ne) <- mkVar (Proxy @ne)-      pure $ mkIndStrategy (Just (measure a b c d e .>= zero))-                           Nothing-                           (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) (Forall e' :: Forall ne e) -> measure a' b' c' d' e' .< measure a b c d e .=> result (Forall a') (Forall b') (Forall c') (Forall d') (Forall e'))) a b c d e)-                           (indResult [na, nb, nc, nd, ne] (result (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))---- | Induction over two 'SList', simultaneously, taking three extra arguments-instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, EqSymbolic z) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> SBool) ((SBV x, SList x, SBV y, SList y) -> SBV a -> SBV b -> SBV c -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (y, ys, nyys) <- mkLVar (Proxy @nys)-       (a, na)       <- mkVar  (Proxy @na)-       (b, nb)       <- mkVar  (Proxy @nb)-       (c, nc)       <- mkVar  (Proxy @nc)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil, Forall SL.nil) (Forall a) (Forall b) (Forall c) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a) (Forall b) (Forall c)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) -> result (Forall xs, Forall ys) (Forall a') (Forall b') (Forall c'))) (x, xs, y, ys) a b c)-                            (indResult [nxxs, nyys, na, nb, nc] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c)))---- | Induction over two 'SList', simultaneously, taking four extra arguments-instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, EqSymbolic z) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> SBool) ((SBV x, SList x, SBV y, SList y) -> SBV a -> SBV b -> SBV c -> SBV d -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (y, ys, nyys) <- mkLVar (Proxy @nys)-       (a, na)       <- mkVar  (Proxy @na)-       (b, nb)       <- mkVar  (Proxy @nb)-       (c, nc)       <- mkVar  (Proxy @nc)-       (d, nd)       <- mkVar  (Proxy @nd)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil, Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) -> result (Forall xs, Forall ys) (Forall a') (Forall b') (Forall c') (Forall d'))) (x, xs, y, ys) a b c d)-                            (indResult [nxxs, nyys, na, nb, nc, nd] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d)))---- | Induction over two 'SList', simultaneously, taking five extra arguments-instance (KnownSymbol nxs, SymVal x, KnownSymbol nys, SymVal y, KnownSymbol na, SymVal a, KnownSymbol nb, SymVal b, KnownSymbol nc, SymVal c, KnownSymbol nd, SymVal d, KnownSymbol ne, SymVal e, EqSymbolic z) => Inductive ((Forall nxs [x], Forall nys [y]) -> Forall na a -> Forall nb b -> Forall nc c -> Forall nd d -> Forall ne e -> SBool) ((SBV x, SList x, SBV y, SList y) -> SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> (SBool, KDProofRaw z)) where-  inductionStrategy result steps = do-       (x, xs, nxxs) <- mkLVar (Proxy @nxs)-       (y, ys, nyys) <- mkLVar (Proxy @nys)-       (a, na)       <- mkVar  (Proxy @na)-       (b, nb)       <- mkVar  (Proxy @nb)-       (c, nc)       <- mkVar  (Proxy @nc)-       (d, nd)       <- mkVar  (Proxy @nd)-       (e, ne)       <- mkVar  (Proxy @ne)-       pure $ mkIndStrategy Nothing-                            (Just (result (Forall SL.nil, Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) .&& result (Forall SL.nil, Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) .&& result (Forall (x SL..: xs), Forall SL.nil) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))-                            (steps (internalAxiom "IH" (\(Forall a' :: Forall na a) (Forall b' :: Forall nb b) (Forall c' :: Forall nc c) (Forall d' :: Forall nd d) (Forall e' :: Forall ne e) -> result (Forall xs, Forall ys) (Forall a') (Forall b') (Forall c') (Forall d') (Forall e'))) (x, xs, y, ys) a b c d e)-                            (indResult [nxxs, nyys, na, nb, nc, nd, ne] (result (Forall (x SL..: xs), Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)))---- | Instantiation for a universally quantified variable-newtype Inst (nm :: Symbol) a = Inst (SBV a)--instance KnownSymbol nm => Show (Inst nm a) where-   show (Inst a) = symbolVal (Proxy @nm) ++ " |-> " ++ show a---- | Instantiating a proof at different types of arguments. This is necessarily done using--- dynamics, hand has a cost of not being applicable.-class Instantiatable a where-  -- | Apply a universal proof to some arguments, creating an instance of the proof itself.-  at :: Proof -> a -> Proof---- | Single parameter-instance (KnownSymbol na, HasKind a, Typeable a) => Instantiatable (Inst na a) where-  at  = instantiate $ \f (Inst a) -> f (Forall a :: Forall na a)---- | Two parameters-instance ( KnownSymbol na, HasKind a, Typeable a-         , KnownSymbol nb, HasKind b, Typeable b-         ) => Instantiatable (Inst na a, Inst nb b) where-  at  = instantiate $ \f (Inst a, Inst b) -> f (Forall a :: Forall na a) (Forall b :: Forall nb b)---- | Three parameters-instance ( KnownSymbol na, HasKind a, Typeable a-         , KnownSymbol nb, HasKind b, Typeable b-         , KnownSymbol nc, HasKind c, Typeable c-         ) => Instantiatable (Inst na a, Inst nb b, Inst nc c) where-  at  = instantiate $ \f (Inst a, Inst b, Inst c) -> f (Forall a :: Forall na a) (Forall b :: Forall nb b) (Forall c :: Forall nc c)---- | Four parameters-instance ( KnownSymbol na, HasKind a, Typeable a-         , KnownSymbol nb, HasKind b, Typeable b-         , KnownSymbol nc, HasKind c, Typeable c-         , KnownSymbol nd, HasKind d, Typeable d-         ) => Instantiatable (Inst na a, Inst nb b, Inst nc c, Inst nd d) where-  at  = instantiate $ \f (Inst a, Inst b, Inst c, Inst d) -> f (Forall a :: Forall na a) (Forall b :: Forall nb b) (Forall c :: Forall nc c) (Forall d :: Forall nd d)---- | Five parameters-instance ( KnownSymbol na, HasKind a, Typeable a-         , KnownSymbol nb, HasKind b, Typeable b-         , KnownSymbol nc, HasKind c, Typeable c-         , KnownSymbol nd, HasKind d, Typeable d-         , KnownSymbol ne, HasKind e, Typeable e-         ) => Instantiatable (Inst na a, Inst nb b, Inst nc c, Inst nd d, Inst ne e) where-  at  = instantiate $ \f (Inst a, Inst b, Inst c, Inst d, Inst e) -> f (Forall a :: Forall na a) (Forall b :: Forall nb b) (Forall c :: Forall nc c) (Forall d :: Forall nd d) (Forall e :: Forall ne e)---- | Instantiate a proof over an arg. This uses dynamic typing, kind of hacky, but works sufficiently well.-instantiate :: (Typeable f, Show arg) => (f -> arg -> SBool) -> Proof -> arg -> Proof-instantiate ap p@Proof{getProp, proofName} a = case fromDynamic getProp of-                                                 Nothing -> cantInstantiate-                                                 Just f  -> let result = f `ap` a-                                                                nm     = proofName ++ " @ " ++ paren sha-                                                            in p { getProof  = label nm result-                                                                 , getProp   = toDyn result-                                                                 , proofName = nm-                                                                 }- where sha = show a-       cantInstantiate = error $ unlines [ "at: Cannot instantiate proof:"-                                         , "   Name: " ++ proofName-                                         , "   Type: " ++ trim (show getProp)-                                         , "   At  : " ++ sha-                                         ]--       -- dynamic puts funky <</>> at the beginning and end; trim it:-       trim  ('<':'<':s) = reverse (trimE (reverse s))-       trim  s           = s-       trimE ('>':'>':s) = s-       trimE s           = s--       -- Add parens if necessary-       paren s | "(" `isPrefixOf` s && ")" `isSuffixOf` s = s-               | not (any isSpace s)                      = s-               | True                                     = '(' : s ++ ")"---- | Helpers for a step-data Helper = HelperProof  Proof  -- A previously proven theorem-            | HelperAssum  SBool  -- A hypothesis-            | HelperString String -- Just a text, only used for diagnostics---- | Get all helpers used in a proof-getAllHelpers :: KDProof -> [Helper]-getAllHelpers (ProofStep   _           hs               p)  = hs ++ getAllHelpers p-getAllHelpers (ProofBranch (_ :: Bool) (_ :: [String]) ps) = concatMap (getAllHelpers . snd) ps-getAllHelpers (ProofEnd    _           hs                ) = hs---- | Get proofs from helpers-getHelperProofs :: Helper -> [Proof]-getHelperProofs (HelperProof p) = [p]-getHelperProofs HelperAssum {}  = []-getHelperProofs HelperString{}  = []---- | Get proofs from helpers-getHelperAssumes :: Helper -> [SBool]-getHelperAssumes HelperProof  {} = []-getHelperAssumes (HelperAssum b) = [b]-getHelperAssumes HelperString {} = []---- | Get hint strings from helpers. If there's an explicit comment given, just pass that. If not, collect all the names-getHelperText :: [Helper] -> [String]-getHelperText hs = case [s | HelperString s <- hs] of-                     [] -> concatMap collect hs-                     ss -> ss-  where collect :: Helper -> [String]-        collect (HelperProof  p) = [proofName p | isUserAxiom p]  -- Don't put out internals (inductive hypotheses)-        collect HelperAssum  {}  = []-        collect (HelperString s) = [s]---- | Smart constructor for creating a helper from a boolean. This is hardly needed, unless you're--- mixing proofs and booleans in one group of hints.-hasm :: SBool -> Helper-hasm = HelperAssum---- | Smart constructor for creating a helper from a boolean. This is hardly needed, unless you're--- mixing proofs and booleans in one group of hints.-hprf :: Proof -> Helper-hprf = HelperProof---- | Smart constructor for adding a comment.-hcmnt :: String -> Helper-hcmnt = HelperString---- | A proof is a sequence of steps, supporting branching-data KDProofGen a bh b = ProofStep   a    [Helper] (KDProofGen a bh b)          -- ^ A single step-                       | ProofBranch Bool bh       [(SBool, KDProofGen a bh b)] -- ^ A branching step. Bool indicates if completeness check is needed-                       | ProofEnd    b    [Helper]                              -- ^ End of proof---- | A proof, as written by the user. No produced result, but helpers on branches-type KDProofRaw a = KDProofGen a [Helper] ()---- | A proof, as processed by KD. Producing a boolean result and each step is a boolean. Helpers on branches dispersed down, only strings are left for printing-type KDProof = KDProofGen SBool [String] SBool---- | Collect dependencies for a KDProof-getDependencies :: KDProof -> [Proof]-getDependencies = collect-  where collect (ProofStep   _ hs next) = concatMap getHelperProofs hs ++ collect next-        collect (ProofBranch _ _  bs)   = concatMap (collect . snd) bs-        collect (ProofEnd    _    hs)   = concatMap getHelperProofs hs---- | Class capturing giving a proof-step helper-type family Hinted a where-  Hinted (KDProofRaw a) = KDProofRaw a-  Hinted a              = KDProofRaw a---- | Attaching a hint-(??) :: HintsTo a b => a -> b -> Hinted a-(??) = addHint-infixl 2 ??---- | Class capturing hints-class HintsTo a b where-  addHint :: a -> b -> Hinted a---- | Giving just one proof as a helper.-instance Hinted a ~ KDProofRaw a => HintsTo a Proof where-  a `addHint` p = ProofStep a [HelperProof p] qed---- | Giving just one boolean as a helper.-instance Hinted a ~ KDProofRaw a => HintsTo a SBool where-  a `addHint` p = ProofStep a [HelperAssum p] qed---- | Giving just one helper-instance Hinted a ~ KDProofRaw a => HintsTo a Helper where-  a `addHint` h = ProofStep a [h] qed---- | Giving a bunch of proofs as a helper.-instance Hinted a ~ KDProofRaw a => HintsTo a [Proof] where-  a `addHint` ps = ProofStep a (map HelperProof ps) qed---- | Giving a bunch of booleans as a helper.-instance Hinted a ~ KDProofRaw a => HintsTo a [SBool] where-  a `addHint` ps = ProofStep a (map HelperAssum ps) qed---- | Giving a set of helpers-instance Hinted a ~ KDProofRaw a => HintsTo a [Helper] where-  a `addHint` hs = ProofStep a hs qed---- | Giving user a hint as a string. This doesn't actually do anything for the solver, it just helps with readability-instance Hinted a ~ KDProofRaw a => HintsTo a String where-  a `addHint` s = ProofStep a [HelperString s] qed---- | Giving just one proof as a helper, starting from a proof-instance {-# OVERLAPPING #-} Hinted (KDProofRaw a) ~ KDProofRaw a => HintsTo (KDProofRaw a) Proof where-  ProofStep   a hs ps `addHint` h = ProofStep   a (hs ++ [HelperProof h]) ps-  ProofBranch b hs bs `addHint` h = ProofBranch b (hs ++ [HelperProof h]) bs-  ProofEnd    b hs    `addHint` h = ProofEnd    b (hs ++ [HelperProof h])---- | Giving just one boolean as a helper.-instance {-# OVERLAPPING #-} Hinted (KDProofRaw a) ~ KDProofRaw a => HintsTo (KDProofRaw a) SBool where-  ProofStep   a hs ps `addHint` h = ProofStep   a (hs ++ [HelperAssum h]) ps-  ProofBranch b hs bs `addHint` h = ProofBranch b (hs ++ [HelperAssum h]) bs-  ProofEnd    b hs    `addHint` h = ProofEnd    b (hs ++ [HelperAssum h])---- | Giving just one helper-instance {-# OVERLAPPING #-} Hinted (KDProofRaw a) ~ KDProofRaw a => HintsTo (KDProofRaw a) Helper where-  ProofStep   a hs ps `addHint` h = ProofStep   a (hs ++ [h]) ps-  ProofBranch b hs bs `addHint` h = ProofBranch b (hs ++ [h]) bs-  ProofEnd    b hs    `addHint` h = ProofEnd    b (hs ++ [h])---- | Giving a bunch of proofs as a helper.-instance {-# OVERLAPPING #-} Hinted (KDProofRaw a) ~ KDProofRaw a => HintsTo (KDProofRaw a) [Proof] where-  ProofStep   a hs ps `addHint` hs' = ProofStep   a (hs ++ map HelperProof hs') ps-  ProofBranch b hs bs `addHint` hs' = ProofBranch b (hs ++ map HelperProof hs') bs-  ProofEnd    b hs    `addHint` hs' = ProofEnd    b (hs ++ map HelperProof hs')---- | Giving a bunch of booleans as a helper.-instance {-# OVERLAPPING #-} Hinted (KDProofRaw a) ~ KDProofRaw a => HintsTo (KDProofRaw a) [SBool] where-  ProofStep   a hs ps `addHint` hs' = ProofStep   a (hs ++ map HelperAssum hs') ps-  ProofBranch b hs bs `addHint` hs' = ProofBranch b (hs ++ map HelperAssum hs') bs-  ProofEnd    b hs    `addHint` hs' = ProofEnd    b (hs ++ map HelperAssum hs')---- | Giving a set of helpers-instance {-# OVERLAPPING #-} Hinted (KDProofRaw a) ~ KDProofRaw a => HintsTo (KDProofRaw a) [Helper] where-  ProofStep   a hs ps `addHint` hs' = ProofStep   a (hs ++ hs') ps-  ProofBranch b hs bs `addHint` hs' = ProofBranch b (hs ++ hs') bs-  ProofEnd    b hs    `addHint` hs' = ProofEnd    b (hs ++ hs')---- | Giving user a hint as a string. This doesn't actually do anything for the solver, it just helps with readability-instance {-# OVERLAPPING #-} Hinted (KDProofRaw a) ~ KDProofRaw a => HintsTo (KDProofRaw a) String where-  a `addHint` s = a `addHint` HelperString s---- | Giving a bunch of strings as hints. This doesn't actually do anything for the solver, it just helps with readability-instance {-# OVERLAPPING #-} Hinted (KDProofRaw a) ~ KDProofRaw a => HintsTo (KDProofRaw a) [String] where-  a `addHint` ss = a `addHint` map HelperString ss---- | Capture what a given step can chain-to. This is a closed-type family, i.e.,--- we don't allow users to change this and write other chainable things. Probably it is not really necessary,--- but we'll cross that bridge if someone actually asks for it.-type family ChainsTo a where-  ChainsTo (KDProofRaw a) = KDProofRaw a-  ChainsTo a              = KDProofRaw a---- | Chain steps in a calculational proof.-(=:) :: ChainStep a (ChainsTo a) =>  a -> ChainsTo a -> ChainsTo a-(=:) = chain-infixr 1 =:---- | Unicode alternative for `=:`.-(≡) :: ChainStep a (ChainsTo a) =>  a -> ChainsTo a -> ChainsTo a-(≡) = (=:)-infixr 1 ≡---- | Chaining two steps together-class ChainStep a b where-  chain :: a -> b -> b---- | Chaining from a value without any annotation-instance ChainStep a (KDProofRaw a) where-  chain x y = ProofStep x [] y---- | Chaining from another proof step-instance ChainStep (KDProofRaw a) (KDProofRaw a) where-  chain (ProofStep   a  hs  p)  y = ProofStep   a hs (chain p y)-  chain (ProofBranch c  hs  ps) y = ProofBranch c hs [(branchCond, chain p y) | (branchCond, p) <- ps]-  chain (ProofEnd    () hs)     y = case y of-                                      ProofStep   a  hs' p  -> ProofStep   a  (hs' ++ hs) p-                                      ProofBranch b  hs' bs -> ProofBranch b  (hs' ++ hs) bs-                                      ProofEnd    () hs'    -> ProofEnd    () (hs' ++ hs)---- | Mark the end of a calculational proof.-qed :: KDProofRaw a-qed = ProofEnd () []---- | Mark a trivial proof. This is essentially the same as 'qed', but reads better in proof scripts.-class Trivial a where-  -- | Mark a proof as trivial, i.e., the solver should be able to deduce it without any help.-  trivial :: a---- | Trivial proofs with no arguments-instance Trivial (KDProofRaw a) where-  trivial = qed---- | Trivial proofs with many arguments arguments-instance Trivial a => Trivial (b -> a) where-  trivial = const trivial---- | Mark a contradictory proof path. This is essentially the same as @sFalse := qed@, but reads better in proof scripts.-class Contradiction a where-  -- | Mark a proof as contradiction, i.e., the solver should be able to conclude it by reasoning that the current path is infeasible-  contradiction :: a---- | Contradiction proofs with no arguments-instance Contradiction (KDProofRaw SBool) where-  contradiction = sFalse =: qed---- | Contradiction proofs with many arguments-instance Contradiction a => Contradiction (b -> a) where-  contradiction = const contradiction----- | Start a calculational proof, with the given hypothesis. Use @[]@ as the--- first argument if the calculation holds unconditionally. The first argument is--- typically used to introduce hypotheses in proofs of implications such as @A .=> B .=> C@, where--- we would put @[A, B]@ as the starting assumption. You can name these and later use in the derivation steps.-(|-) :: [SBool] -> KDProofRaw a -> (SBool, KDProofRaw a)-bs |- p = (sAnd bs, p)-infixl 0 |----- | Alternative unicode for `|-`.-(⊢) :: [SBool] -> KDProofRaw a -> (SBool, KDProofRaw a)-(⊢) = (|-)-infixl 0 ⊢---- | Alternative unicode for `??`.-(⁇) :: HintsTo a b => a -> b -> Hinted a-(⁇) = (??)-infixl 2 ⁇---- | The boolean case-split-cases :: [(SBool, KDProofRaw a)] -> KDProofRaw a-cases = ProofBranch True []---- | Case splitting over a list; empty and full cases-split :: SymVal a => SList a -> KDProofRaw r -> (SBV a -> SList a -> KDProofRaw r) -> KDProofRaw r-split xs empty cons = ProofBranch False [] [ (      SL.null xs,  empty)-                                           , (sNot (SL.null xs), cons (SL.head xs) (SL.tail xs))-                                           ]---- | Case splitting over two lists; empty and full cases for each-split2 :: (SymVal a, SymVal b)-       => (SList a, SList b)-       -> KDProofRaw r-       -> ((SBV b, SList b)                     -> KDProofRaw r) -- empty first-       -> ((SBV a, SList a)                     -> KDProofRaw r) -- empty second-       -> ((SBV a, SList a) -> (SBV b, SList b) -> KDProofRaw r) -- neither empty-       -> KDProofRaw r-split2 (xs, ys) ee ec ce cc = ProofBranch False-                                          []-                                          [ (      SL.null xs  .&&       SL.null ys , ee)-                                          , (      SL.null xs  .&& sNot (SL.null ys), ec (SL.head ys, SL.tail ys))-                                          , (sNot (SL.null xs) .&&       SL.null ys , ce (SL.head xs, SL.tail xs))-                                          , (sNot (SL.null xs) .&& sNot (SL.null ys), cc (SL.head xs, SL.tail xs) (SL.head ys, SL.tail ys))-                                          ]---- | Specifying a case-split, helps with the boolean case.-(==>) :: SBool -> KDProofRaw a -> (SBool, KDProofRaw a)-(==>) = (,)-infix 0 ==>---- | Alternative unicode for `==>`-(⟹) :: SBool -> KDProofRaw a -> (SBool, KDProofRaw a)-(⟹) = (==>)-infix 0 ⟹--{- HLint ignore module "Eta reduce" -}
− Data/SBV/Tools/KD/Utils.hs 
@@ -1,250 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Data.SBV.Tools.KD.Utils--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Various KnuckleDrugger machinery.--------------------------------------------------------------------------------{-# LANGUAGE DeriveAnyClass             #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DerivingStrategies         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns             #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.Tools.KD.Utils (-         KD, runKD, runKDWith, Proof(..)-       , startKD, finishKD, getKDState, getKDConfig, KDState(..), KDStats(..)-       , RootOfTrust(..), KDProofContext(..), calculateRootOfTrust, message, updStats-       , KDProofDeps(..), getProofTree, kdShowDepsHTML-       ) where--import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, ask, liftIO)-import Control.Monad.Trans  (MonadIO)--import Data.Time (NominalDiffTime)--import Data.Tree-import Data.Tree.View--import Data.Char (isSpace)-import Data.List (intercalate, nub, sort, isInfixOf)-import System.IO (hFlush, stdout)--import Data.SBV.Core.Data (SBool)-import Data.SBV.Core.Symbolic  (SMTConfig, KDOptions(..))-import Data.SBV.Provers.Prover (defaultSMTCfg, SMTConfig(..))--import Data.SBV.Utils.TDiff (showTDiff, timeIf)-import Control.DeepSeq (NFData(rnf))--import Data.IORef--import GHC.Generics-import Data.Dynamic---- | Various statistics we collect-data KDStats = KDStats { noOfCheckSats :: Int-                       , solverElapsed :: NominalDiffTime-                       }---- | Extra state we carry in a KD context-data KDState = KDState { stats  :: IORef KDStats-                       , config :: SMTConfig-                       }---- | Monad for running KnuckleDragger proofs in.-newtype KD a = KD (ReaderT KDState IO a)-            deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader KDState, MonadFail)---- | The context in which we make a check-sat call-data KDProofContext = KDProofOneShot String   -- ^ A one shot proof, with string containing its name-                                     [Proof]  -- ^ Helpers used (latter only used for cex generation)-                    | KDProofStep    Bool     -- ^ A proof step. If Bool is true, then these are the assumptions for that step-                                     String   -- ^ Name of original goal-                                     [String] -- ^ The helper "strings" given by the user-                                     [String] -- ^ The step name, i.e., the name of the branch in the proof tree---- | Run a KD proof, using the default configuration.-runKD :: KD a -> IO a-runKD = runKDWith defaultSMTCfg---- | Run a KD proof, using the given configuration.-runKDWith :: SMTConfig -> KD a -> IO a-runKDWith cfg@SMTConfig{kdOptions = KDOptions{measureTime}} (KD f) = do-   rStats <- newIORef $ KDStats { noOfCheckSats = 0, solverElapsed = 0 }-   (mbT, r) <- timeIf measureTime $ runReaderT f KDState {config = cfg, stats = rStats}-   case mbT of-     Nothing -> pure ()-     Just t  -> do KDStats noOfCheckSats solverTime <- readIORef rStats--                   let stats = [ ("SBV",       showTDiff (t - solverTime))-                               , ("Solver",    showTDiff solverTime)-                               , ("Total",     showTDiff t)-                               , ("Decisions", show noOfCheckSats)-                               ]--                   message cfg $ '[' : intercalate ", " [k ++ ": " ++ v | (k, v) <- stats] ++ "]\n"-   pure r---- | get the state-getKDState :: KD KDState-getKDState = ask---- | get the configuration-getKDConfig :: KD SMTConfig-getKDConfig = config <$> getKDState---- | Update stats-updStats :: MonadIO m => KDState -> (KDStats -> KDStats) -> m ()-updStats KDState{stats} u = liftIO $ modifyIORef' stats u---- | Display the message if not quiet. Note that we don't print a newline; so the message must have it if needed.-message :: MonadIO m => SMTConfig -> String -> m ()-message SMTConfig{kdOptions = KDOptions{quiet}} s-  | quiet = pure ()-  | True  = liftIO $ putStr s---- | Start a proof. We return the number of characters we printed, so the finisher can align the result.-startKD :: SMTConfig -> Bool -> String -> Int -> KDProofContext -> IO Int-startKD cfg newLine what level ctx = do message cfg $ line ++ if newLine then "\n" else ""-                                        hFlush stdout-                                        return (length line)-  where nm = case ctx of-               KDProofOneShot n _       -> n-               KDProofStep    _ _ hs ss -> intercalate "." ss ++ userHints hs--        tab = 2 * level--        line = replicate tab ' ' ++ what ++ ": " ++ nm--        userHints [] = ""-        userHints ss = " (" ++ intercalate ", " ss ++ ")"---- | Finish a proof. First argument is what we got from the call of 'startKD' above.-finishKD :: SMTConfig -> String -> (Int, Maybe NominalDiffTime) -> [NominalDiffTime] -> IO ()-finishKD cfg@SMTConfig{kdOptions = KDOptions{ribbonLength}} what (skip, mbT) extraTiming =-   message cfg $ replicate (ribbonLength - skip) ' ' ++ what ++ timing ++ extras ++ "\n"- where timing = maybe "" ((' ' :) . mkTiming) mbT-       extras = concatMap mkTiming extraTiming--       mkTiming t = '[' : showTDiff t ++ "]"---- | Keeping track of where the sorry originates from. Used in displaying dependencies.-data RootOfTrust = None        -- ^ Trusts nothing (aside from SBV, underlying solver etc.)-                 | Self        -- ^ Trusts itself, i.e., established by a call to sorry-                 | Prop String -- ^ Trusts a parent that itself trusts something else. Note the name here is the-                               --   name of the proposition itself, not the parent that's trusted.-                deriving (NFData, Generic)---- | Proof for a property. This type is left abstract, i.e., the only way to create on is via a--- call to lemma/theorem etc., ensuring soundness. (Note that the trusted-code base here--- is still large: The underlying solver, SBV, and KnuckleDragger kernel itself. But this--- mechanism ensures we can't create proven things out of thin air, following the standard LCF--- methodology.)-data Proof = Proof { rootOfTrust  :: RootOfTrust -- ^ Root of trust, described above.-                   , dependencies :: [Proof]     -- ^ Immediate dependencies of this proof. (Not transitive)-                   , isUserAxiom  :: Bool        -- ^ Was this an axiom given by the user?-                   , getProof     :: SBool       -- ^ Get the underlying boolean-                   , getProp      :: Dynamic     -- ^ The actual proposition-                   , proofName    :: String      -- ^ User given name-                   }---- | NFData ignores the getProp field-instance NFData Proof where-  rnf (Proof rootOfTrust dependencies isUserAxiom getProof _getProp proofName) =     rnf rootOfTrust-                                                                               `seq` rnf dependencies-                                                                               `seq` rnf isUserAxiom-                                                                               `seq` rnf getProof-                                                                               `seq` rnf proofName---- | Dependencies of a proof, in a tree format.-data KDProofDeps = KDProofDeps Proof [KDProofDeps]---- | Return all the proofs this particular proof depends on, transitively-getProofTree :: Proof -> KDProofDeps-getProofTree p = KDProofDeps p $ map getProofTree (dependencies p)---- | Turn dependencies to a container tree, for display purposes-depsToTree :: [String] -> (String -> Int -> Int -> a) -> (Int, KDProofDeps) -> ([String], Tree a)-depsToTree visited xform (cnt, KDProofDeps top ds) = (nVisited, Node (xform nTop cnt (length chlds)) chlds)-  where nTop = shortName top--        (nVisited, chlds) | nTop `elem` visited = (visited, [])-                          | True                = walk (nTop : visited) (compress (filter interesting ds))--        walk v []     = (v, [])-        walk v (c:cs) = let (v',  t)  = depsToTree v xform c-                            (v'', ts) = walk v' cs-                        in (v'', t : ts)--        -- Don't show IH's, just not interesting-        interesting (KDProofDeps p _) = not ("IH" `isInfixOf` proofName p)--        -- If a proof is used twice in the same proof, compress it-        compress :: [KDProofDeps] -> [(Int, KDProofDeps)]-        compress []       = []-        compress (p : ps) = (1 + length [() | (_, True) <- filtered], p) : compress [d | (d, False) <- filtered]-          where filtered = [(d, shortName p' == curName) | d@(KDProofDeps p' _) <- ps]-                curName  = case p of-                             KDProofDeps curProof _ -> shortName curProof--        -- Drop the instantiation part-        shortName :: Proof -> String-        shortName p | "@" `isInfixOf` s = reverse . dropWhile isSpace . reverse . takeWhile (/= '@') $ s-                    | True              = s-           where s = proofName p---- | Display the dependencies as a tree-instance Show KDProofDeps where-  show d = showTree $ snd $ depsToTree [] sh (1, d)-    where sh nm 1 _ = nm-          sh nm x _= nm ++ " (x" ++ show x ++ ")"---- | Display the tree as an html doc for rendering purposes.--- The first argument is Path (or URL) to external CSS file, if needed.-kdShowDepsHTML :: Maybe FilePath -> KDProofDeps -> String-kdShowDepsHTML mbCSS deps = htmlTree mbCSS $ snd $ depsToTree [] nodify (1, deps)-  where nodify :: String -> Int -> Int -> NodeInfo-        nodify nm cnt dc = NodeInfo { nodeBehavior = InitiallyExpanded-                                    , nodeName     = nm-                                    , nodeInfo     = spc (used cnt) ++ depCount dc-                                    }-        used 1 = ""-        used n = "Used " ++ show n ++ " times."--        spc "" = ""-        spc s  = s ++ " "--        depCount 0 = ""-        depCount 1 = "Has one dependency."-        depCount n = "Has " ++ show n ++ " dependencies."---- | Show instance for t'Proof'-instance Show Proof where-  show Proof{rootOfTrust, isUserAxiom, proofName} = '[' : tag ++ "] " ++ proofName-     where tag | isUserAxiom = "Axiom"-               | True        = case rootOfTrust of-                                 None   -> "Proven"-                                 Self   -> "Sorry"-                                 Prop s -> "Modulo: " ++ s---- | Calculate the root of trust for a proof. The string is the modulo text, if any.-calculateRootOfTrust :: String -> [Proof] -> (RootOfTrust, String)-calculateRootOfTrust nm by | not hasSelf && null depNames = (None,    "")-                           | True                         = (Prop nm, " [Modulo: " ++ why ++ "]")-   where why | hasSelf = "sorry"-             | True    = intercalate ", " depNames--         -- What's the root-of-trust for this node?-         -- If there are no "sorry" parents, and no parent nodes-         -- that are marked with a root of trust, then we don't have it either.-         -- Otherwise, mark it accordingly.-         parentRoots = map rootOfTrust by-         hasSelf     = not $ null [() | Self   <- parentRoots]-         depNames    = nub $ sort [p  | Prop p <- parentRoots]
− Data/SBV/Tools/KnuckleDragger.hs 
@@ -1,65 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Data.SBV.Tools.KnuckleDragger--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ A lightweight theorem proving like interface, built on top of SBV.--- Inspired by and modeled after Philip Zucker's tool with the same--- name, see <http://github.com/philzook58/knuckledragger>.------ See the directory Documentation.SBV.Examples.KnuckleDragger for various examples.--------------------------------------------------------------------------------{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.Tools.KnuckleDragger (-       -- * Propositions and their proofs-         Proposition, Proof--       -- * Getting the proof tree-       , KDProofDeps(), getProofTree, kdShowDepsHTML--       -- * Adding axioms/definitions-       , axiom--       -- * Basic proofs-       , lemma, lemmaWith, theorem, theoremWith--       -- * Reasoning via calculation-       , calc, calcWith, calcThm, calcThmWith--       -- * Reasoning via regular induction-       , induct,  inductWith, inductThm, inductThmWith--       -- * Reasoning via measure-based strong induction-       , sInduct, sInductWith, sInductThm, sInductThmWith--       -- * Creating instances of proofs-       , at, Inst(..)--       -- * Faking proofs-       , sorry--       -- * Running KnuckleDragger proofs-       , KD, runKD, runKDWith, use--       -- * Starting a calculation proof-       , (|-), (⊢)--       -- * Sequence of calculation steps-       , (=:), (≡)--       -- * Supplying hints for a calculation step-       , (??), (⁇), hprf, hasm, hcmnt--       -- * Case splits-       , split, split2, cases, (⟹), (==>)--       -- * Finishing up a calculational proof-       , qed, trivial, contradiction-       ) where--import Data.SBV.Tools.KD.KnuckleDragger
− Data/SBV/Tools/NaturalInduction.hs 
@@ -1,60 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Data.SBV.Tools.NaturalInduction--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Proof by induction over naturals.--------------------------------------------------------------------------------module Data.SBV.Tools.NaturalInduction (-           inductNat-         , inductNatWith-       ) where--import Data.SBV-import Data.SBV.Tuple-------------------------------------------------------------------------- * Induction over natural numbers-------------------------------------------------------------------------- | Perform natural induction over the given function, which returns left and--- right hand-sides to be proven equal. Uses 'defaultSMTCfg'. That is,--- given @f x = (lhs x, rhs x)@, we inductively establish that @lhs@ and--- @rhs@ agree on @0@, @1@, ... @n@, i.e., for all non-negative integers.------ >>> import Data.SBV--- >>> import Data.SBV.Tools.NaturalInduction--- >>> let sumToN        :: SInteger -> SInteger = smtFunction "sumToN"        $ \x -> ite (x .<= 0) 0 (x   + sumToN        (x-1))--- >>> let sumSquaresToN :: SInteger -> SInteger = smtFunction "sumSquaresToN" $ \x -> ite (x .<= 0) 0 (x*x + sumSquaresToN (x-1))--- >>> inductNat $ \n -> (sumToN n, (n*(n+1)) `sEDiv` 2)--- Q.E.D.--- >>> inductNat $ \n -> (sumSquaresToN n, (n*(n+1)*(2*n+1)) `sEDiv` 6)--- Q.E.D.--- >>> inductNat $ \n -> (sumSquaresToN n, ite (n .== 12) 0 ((n*(n+1)*(2*n+1)) `sEDiv` 6))--- Falsifiable. Counter-example:---   k      =        11 :: Integer---   P(0)   =     (0,0) :: (Integer, Integer)---   P(k)   = (506,506) :: (Integer, Integer)---   P(k+1) =   (650,0) :: (Integer, Integer)-inductNat :: SymVal a => (SInteger -> (SBV a, SBV a)) -> IO ThmResult-inductNat = inductNatWith defaultSMTCfg---- | Perform natural induction over, using the given solver.-inductNatWith :: SymVal a => SMTConfig -> (SInteger -> (SBV a, SBV a)) -> IO ThmResult-inductNatWith cfg p = proveWith cfg $ do-                        k <- free "k"-                        let at0  = observe "P(0)"   (tuple (p 0))-                            atk  = observe "P(k)"   (tuple (p k))-                            atk1 = observe "P(k+1)" (tuple (p (k+1)))-                            p0   = at0^._1  .== at0^._2-                            pk   = atk^._1  .== atk^._2-                            pk1  = atk1^._1 .== atk1^._2-                        constrain $ k .>= 0-                        constrain pk-                        pure $ p0 .&& pk1--{- HLint ignore module "Redundant ^." -}
Data/SBV/Tools/Overflow.hs view
@@ -346,7 +346,7 @@         nonSignBitPos w = walk 0 rest           where (sign, rest) = case blastBE w of                                  []     -> error $ "Impossible happened, blastBE returned no bits for " ++ show w-                                 (b:bs) -> (b, zip [0..] (reverse bs))+                                 (b:bs) -> (b, zip (map literal [0..]) (reverse bs))                  walk sofar []          = sofar                 walk sofar ((i, b):bs) = walk (ite (b ./= sign) i sofar) bs
Data/SBV/Trans.hs view
@@ -173,9 +173,6 @@ import Data.SBV.Provers.Prover  import Data.SBV.Client-import Data.SBV.Client.BaseIO  (FromSized, ToSized, fromSized, toSized)-- import Data.SBV.Utils.TDiff   (Timing(..))  import Data.Bits
Data/SBV/Utils/Lib.hs view
@@ -11,6 +11,7 @@  {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}  {-# OPTIONS_GHC -Wall -Werror #-} @@ -19,8 +20,9 @@                           , stringToQFS, qfsToString                           , isKString                           , checkObservableName-                          , needsBars, isEnclosedInBars+                          , needsBars, barify, isEnclosedInBars                           , noSurrounding, unQuote, unBar, nameSupply+                          , atProxy                           ,   curry2,   curry3,   curry4,   curry5,   curry6,   curry7,   curry8,   curry9,   curry10,   curry11,   curry12                           , uncurry2, uncurry3, uncurry4, uncurry5, uncurry6, uncurry7, uncurry8, uncurry9, uncurry10, uncurry11, uncurry12                           )@@ -30,7 +32,10 @@ import Data.List    (isPrefixOf, isSuffixOf) import Data.Dynamic (fromDynamic, toDyn, Typeable) import Data.Maybe   (fromJust, isJust, isNothing)+import Data.Proxy +import Type.Reflection (typeRep)+ import Numeric (readHex, showHex)  import Data.SBV.SMT.SMTLibNames (isReserved)@@ -165,6 +170,11 @@ unBar :: String -> String unBar = noSurrounding '|' +-- | Add bars if needed+barify :: String -> String+barify s | needsBars s = '|' : s ++ "|"+         | True        = s+ -- Is this string surrounded by bars? NB. There shouldn't be any other bars or backslash anywhere isEnclosedInBars :: String -> Bool isEnclosedInBars nm =  "|" `isPrefixOf` nm@@ -177,6 +187,13 @@ needsBars ""        = error "Impossible happened: needsBars received an empty name!" needsBars nm@(h:tl) = not (isEnclosedInBars nm || (isAscii h && all validChar tl))  where  validChar x = isAscii x && (isAlphaNum x || x `elem` ("_" :: String))++-- | Converts a proxy to a readable result. This is useful when you want to write a polymorphic+-- proof, so that the name contains the instantiated version properly.+atProxy :: forall a. Typeable a => Proxy a -> String -> String+atProxy _ nm = nm ++ " @" ++ par (show (typeRep @a))+ where par s | any isSpace s = '(' : s ++ ")"+             | True          = s  -- An infinite supply of names, starting with a given set nameSupply :: [String] -> [String]
Documentation/SBV/Examples/BitPrecise/MergeSort.hs view
@@ -10,7 +10,7 @@ -- version, while fully push-button, proves merge-sort correct for fixed number -- of elements, i.e., not in its generality. A general proof would require -- non-trivial applications of induction and more manual guiding. We do--- such a proof in "Documentation.SBV.Examples.KnuckleDragger.MergeSort", which+-- such a proof in "Documentation.SBV.Examples.TP.MergeSort", which -- shows the full-power of the theorem-proving like aspects of SBV. -----------------------------------------------------------------------------
Documentation/SBV/Examples/BitPrecise/PEXT_PDEP.hs view
@@ -130,8 +130,8 @@ -- -- >>> putStrLn =<< sbv2smt pext_2 -- ; Automatically generated by SBV. Do not modify!--- ; pext_2 :: SWord 2 -> SWord 2 -> SWord 2--- (define-fun pext_2 ((l1_s0 (_ BitVec 2)) (l1_s1 (_ BitVec 2))) (_ BitVec 2)+-- ; |pext_2 @(SBV (WordN 2) -> SBV (WordN 2) -> SBV (WordN 2))| :: SWord 2 -> SWord 2 -> SWord 2+-- (define-fun |pext_2 @(SBV (WordN 2) -> SBV (WordN 2) -> SBV (WordN 2))| ((l1_s0 (_ BitVec 2)) (l1_s1 (_ BitVec 2))) (_ BitVec 2) --                           (let ((l1_s3 #b0)) --                           (let ((l1_s7 #b01)) --                           (let ((l1_s8 #b00))
Documentation/SBV/Examples/CodeGeneration/Fibonacci.hs view
@@ -13,6 +13,8 @@ -- and how to deal with such, eventually generating good C code. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-}  module Documentation.SBV.Examples.CodeGeneration.Fibonacci where@@ -20,6 +22,11 @@ import Data.SBV import Data.SBV.Tools.CodeGen +#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+#endif+ ----------------------------------------------------------------------------- -- * A naive implementation -----------------------------------------------------------------------------@@ -27,7 +34,7 @@ -- | This is a naive implementation of fibonacci, and will work fine (albeit slow) -- for concrete inputs: ----- >>> map fib0 [0..6]+-- >>> map (fib0 . literal) [0..6] -- [0 :: SWord64,1 :: SWord64,1 :: SWord64,2 :: SWord64,3 :: SWord64,5 :: SWord64,8 :: SWord64] -- -- However, it is not suitable for doing proofs or generating code, as it is not@@ -55,7 +62,7 @@  -- | The recursion-depth limited version of fibonacci. Limiting the maximum number to be 20, we can say: ----- >>> map (fib1 20) [0..6]+-- >>> map (fib1 20 . literal) [0..6] -- [0 :: SWord64,1 :: SWord64,1 :: SWord64,2 :: SWord64,3 :: SWord64,5 :: SWord64,8 :: SWord64] -- -- The function will work correctly, so long as the index we query is at most @top@, and otherwise@@ -120,9 +127,9 @@  -- | Compute the fibonacci numbers statically at /code-generation/ time and -- put them in a table, accessed by the 'select' call.-fib2 :: SWord64 -> SWord64 -> SWord64+fib2 :: Word64 -> SWord64 -> SWord64 fib2 top = select table 0-  where table = map (fib1 top) [0 .. top]+  where table = map (fib1 (literal top) . literal) [0 .. top]  -- | Once we have 'fib2', we can generate the C code straightforwardly. Below -- is an excerpt from the code that SBV generates for the call @genFib2 64@. Note@@ -172,7 +179,7 @@ -- >    -- >   return s65; -- > }-genFib2 :: SWord64 -> IO ()+genFib2 :: Word64 -> IO () genFib2 top = compileToC Nothing "fibLookup" $ do         cgPerformRTCs True       -- protect against potential overflow, our table is not big enough         x <- cgInput "x"
Documentation/SBV/Examples/CodeGeneration/PopulationCount.hs view
@@ -59,7 +59,7 @@ -- value, from 0 to 255. Note that we do not \"hard-code\" the values, but -- merely use the slow version to compute them. pop8 :: [SWord8]-pop8 = map popCountSlow [0 .. 255]+pop8 = map (popCountSlow . literal) [0 .. 255]  ----------------------------------------------------------------------------- -- * Verification
Documentation/SBV/Examples/Crypto/AES.hs view
@@ -146,10 +146,10 @@        mB = select mBTable 0        mD = select mDTable 0        m9 = select m9Table 0-       mETable = map (gf28Mult 0xE) [0..255]-       mBTable = map (gf28Mult 0xB) [0..255]-       mDTable = map (gf28Mult 0xD) [0..255]-       m9Table = map (gf28Mult 0x9) [0..255]+       mETable = map (gf28Mult 0xE . literal) [0..255]+       mBTable = map (gf28Mult 0xB . literal) [0..255]+       mDTable = map (gf28Mult 0xD . literal) [0..255]+       m9Table = map (gf28Mult 0x9 . literal) [0..255]  -- | Key expansion. Starting with the given key, returns an infinite sequence of -- words, as described by the AES standard, Section 5.2, Figure 11.@@ -177,7 +177,7 @@ -- the code-generation will turn this into a mere look-up table, as it is just a -- constant table, all computation being done at \"compile-time\". sboxTable :: [GF28]-sboxTable = [xformByte (gf28Inverse b) | b <- [0 .. 255]]+sboxTable = [xformByte (gf28Inverse (literal b)) | b <- [0 .. 255]]   where xformByte :: GF28 -> GF28         xformByte b = foldr xor 0x63 [b `rotateR` i | i <- [0, 4, 5, 6, 7]] @@ -194,7 +194,7 @@  -- | The values of the inverse S-box table. Again, the construction is programmatic. unSBoxTable :: [GF28]-unSBoxTable = [gf28Inverse (xformByte b) | b <- [0 .. 255]]+unSBoxTable = [gf28Inverse (xformByte (literal b)) | b <- [0 .. 255]]   where xformByte :: GF28 -> GF28         xformByte b = foldr xor 0x05 [b `rotateR` i | i <- [2, 5, 7]] @@ -229,19 +229,19 @@  -- | First look-up table used in encryption t0 :: GF28 -> SWord 32-t0 = select t0Table 0 where t0Table = [fromBytes (t0Func a)          | a <- [0..255]]+t0 = select t0Table 0 where t0Table = [fromBytes (t0Func a)          | a <- map literal [0..255]]  -- | Second look-up table used in encryption t1 :: GF28 -> SWord 32-t1 = select t1Table 0 where t1Table = [fromBytes (t0Func a `rotR` 1) | a <- [0..255]]+t1 = select t1Table 0 where t1Table = [fromBytes (t0Func a `rotR` 1) | a <- map literal [0..255]]  -- | Third look-up table used in encryption t2 :: GF28 -> SWord 32-t2 = select t2Table 0 where t2Table = [fromBytes (t0Func a `rotR` 2) | a <- [0..255]]+t2 = select t2Table 0 where t2Table = [fromBytes (t0Func a `rotR` 2) | a <- map literal [0..255]]  -- | Fourth look-up table used in encryption t3 :: GF28 -> SWord 32-t3 = select t3Table 0 where t3Table = [fromBytes (t0Func a `rotR` 3) | a <- [0..255]]+t3 = select t3Table 0 where t3Table = [fromBytes (t0Func a `rotR` 3) | a <- map literal [0..255]]  ----------------------------------------------------------------------------- -- ** Tables for T-Box decryption@@ -253,19 +253,19 @@  -- | First look-up table used in decryption u0 :: GF28 -> SWord 32-u0 = select t0Table 0 where t0Table = [fromBytes (u0Func a)          | a <- [0..255]]+u0 = select t0Table 0 where t0Table = [fromBytes (u0Func a)          | a <- map literal [0..255]]  -- | Second look-up table used in decryption u1 :: GF28 -> SWord 32-u1 = select t1Table 0 where t1Table = [fromBytes (u0Func a `rotR` 1) | a <- [0..255]]+u1 = select t1Table 0 where t1Table = [fromBytes (u0Func a `rotR` 1) | a <- map literal [0..255]]  -- | Third look-up table used in decryption u2 :: GF28 -> SWord 32-u2 = select t2Table 0 where t2Table = [fromBytes (u0Func a `rotR` 2) | a <- [0..255]]+u2 = select t2Table 0 where t2Table = [fromBytes (u0Func a `rotR` 2) | a <- map literal [0..255]]  -- | Fourth look-up table used in decryption u3 :: GF28 -> SWord 32-u3 = select t3Table 0 where t3Table = [fromBytes (u0Func a `rotR` 3) | a <- [0..255]]+u3 = select t3Table 0 where t3Table = [fromBytes (u0Func a `rotR` 3) | a <- map literal [0..255]]  ----------------------------------------------------------------------------- -- ** AES rounds@@ -429,10 +429,10 @@                                     e3 = otfU3 $ unSBox (a !! ((j+1) `mod` 4) !! 3) `xor` (kbs !! j !! 3)                  otfU0Func b = [b `gf28Mult` 0xE, b `gf28Mult` 0x9, b `gf28Mult` 0xD, b `gf28Mult` 0xB]-                otfU0 = select t0Table 0 where t0Table = [fromBytes (otfU0Func a)          | a <- [0..255]]-                otfU1 = select t1Table 0 where t1Table = [fromBytes (otfU0Func a `rotR` 1) | a <- [0..255]]-                otfU2 = select t2Table 0 where t2Table = [fromBytes (otfU0Func a `rotR` 2) | a <- [0..255]]-                otfU3 = select t3Table 0 where t3Table = [fromBytes (otfU0Func a `rotR` 3) | a <- [0..255]]+                otfU0 = select t0Table 0 where t0Table = [fromBytes (otfU0Func a)          | a <- map literal [0..255]]+                otfU1 = select t1Table 0 where t1Table = [fromBytes (otfU0Func a `rotR` 1) | a <- map literal [0..255]]+                otfU2 = select t2Table 0 where t2Table = [fromBytes (otfU0Func a `rotR` 2) | a <- map literal [0..255]]+                otfU3 = select t3Table 0 where t3Table = [fromBytes (otfU0Func a `rotR` 3) | a <- map literal [0..255]]  ----------------------------------------------------------------------------- -- * Test vectors
Documentation/SBV/Examples/Crypto/RC4.hs view
@@ -78,7 +78,7 @@  | keyLength < 1 || keyLength > 256  = error $ "RC4 requires a key of length between 1 and 256, received: " ++ show keyLength  | True- = snd $ foldl mix (0, initS) [0..255]+ = snd $ foldl mix (0, initS) (map literal [0..255])  where keyLength = length key        mix :: (SWord8, S) -> SWord8 -> (SWord8, S)        mix (j', s) i = let j = j' + readSTree s i + genericIndex key (fromJust (unliteral i) `mod` fromIntegral keyLength)
− Documentation/SBV/Examples/KnuckleDragger/Basics.hs 
@@ -1,217 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.Basics--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Some basic KD usage.--------------------------------------------------------------------------------{-# LANGUAGE CPP                #-}-{-# LANGUAGE DataKinds          #-}-{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell    #-}-{-# LANGUAGE TypeAbstractions   #-}-{-# LANGUAGE TypeApplications   #-}-{-# LANGUAGE StandaloneDeriving #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.Basics where--import Data.SBV-import Data.SBV.Tools.KnuckleDragger--#ifdef DOCTEST--- $setup--- >>> :set -XScopedTypeVariables--- >>> import Control.Exception-#endif---- * Truth and falsity---- | @sTrue@ is provable.------ We have:------ >>> trueIsProvable--- Lemma: true                             Q.E.D.--- [Proven] true-trueIsProvable :: IO Proof-trueIsProvable = runKD $ lemma "true" sTrue []---- | @sFalse@ isn't provable.------ We have:------ >>> falseIsn'tProvable `catch` (\(_ :: SomeException) -> pure ())--- Lemma: sFalse--- *** Failed to prove sFalse.--- Falsifiable-falseIsn'tProvable :: IO ()-falseIsn'tProvable = runKD $ do-        _won'tGoThrough <- lemma "sFalse" sFalse []-        pure ()---- * Quantification---- | Basic quantification example: For every integer, there's a larger integer.------ We have:--- >>> largerIntegerExists--- Lemma: largerIntegerExists              Q.E.D.--- [Proven] largerIntegerExists-largerIntegerExists :: IO Proof-largerIntegerExists = runKD $ lemma "largerIntegerExists"-                                    (\(Forall @"x" x) (Exists @"y" y) -> x .< (y :: SInteger))-                                    []---- | Use an uninterpreted type for the domain-data T-mkUninterpretedSort ''T---- * Basic connectives---- | Pushing a universal through conjunction. We have:------ >>> forallConjunction--- Lemma: forallConjunction                Q.E.D.--- [Proven] forallConjunction-forallConjunction :: IO Proof-forallConjunction = runKD $ do-    let p, q :: ST -> SBool-        p = uninterpret "p"-        q = uninterpret "q"--        qb = quantifiedBool--    lemma "forallConjunction"-           (      (qb (\(Forall @"x" x) -> p x) .&& qb (\(Forall @"x" x) -> q x))-            .<=> ------------------------------------------------------------------                          qb (\(Forall @"x" x) -> p x .&& q x)-           )-           []---- | Pushing an existential through disjunction. We have:------ >>> existsDisjunction--- Lemma: existsDisjunction                Q.E.D.--- [Proven] existsDisjunction-existsDisjunction :: IO Proof-existsDisjunction = runKD $ do-    let p, q :: ST -> SBool-        p = uninterpret "p"-        q = uninterpret "q"--        qb = quantifiedBool--    lemma "existsDisjunction"-           (      (qb (\(Exists @"x" x) -> p x) .|| qb (\(Exists @"x" x) -> q x))-            .<=> ------------------------------------------------------------------                          qb (\(Exists @"x" x) -> p x .|| q x)-           )-           []---- | We cannot push a universal through a disjunction. We have:------ >>> forallDisjunctionNot `catch` (\(_ :: SomeException) -> pure ())--- Lemma: forallConjunctionNot--- *** Failed to prove forallConjunctionNot.--- Falsifiable. Counter-example:---   p :: T -> Bool---   p T_2 = True---   p T_0 = True---   p _   = False--- <BLANKLINE>---   q :: T -> Bool---   q T_2 = False---   q T_0 = False---   q _   = True------ Note how @p@ assigns two selected values to @True@ and everything else to @False@, while @q@ does the exact opposite.--- So, there is no common value that satisfies both, providing a counter-example. (It's not clear why the solver finds--- a model with two distinct values, as one would have sufficed. But it is still a valud model.)-forallDisjunctionNot :: IO ()-forallDisjunctionNot = runKD $ do-    let p, q :: ST -> SBool-        p = uninterpret "p"-        q = uninterpret "q"--        qb = quantifiedBool--    -- This won't prove!-    _won'tGoThrough <- lemma "forallConjunctionNot"-                             (      (qb (\(Forall @"x" x) -> p x) .|| qb (\(Forall @"x" x) -> q x))-                              .<=> ------------------------------------------------------------------                                              qb (\(Forall @"x" x) -> p x .|| q x)-                             )-                             []--    pure ()---- | We cannot push an existential through conjunction. We have:------ >>> existsConjunctionNot `catch` (\(_ :: SomeException) -> pure ())--- Lemma: existsConjunctionNot--- *** Failed to prove existsConjunctionNot.--- Falsifiable. Counter-example:---   p :: T -> Bool---   p T_1 = False---   p _   = True--- <BLANKLINE>---   q :: T -> Bool---   q T_1 = True---   q _   = False------ In this case, we again have a predicate That disagree at every point, providing a counter-example.-existsConjunctionNot :: IO ()-existsConjunctionNot = runKD $ do-    let p, q :: ST -> SBool-        p = uninterpret "p"-        q = uninterpret "q"--        qb = quantifiedBool--    _wont'GoThrough <- lemma "existsConjunctionNot"-                             (      (qb (\(Exists @"x" x) -> p x) .&& qb (\(Exists @"x" x) -> q x))-                              .<=> ------------------------------------------------------------------                                              qb (\(Exists @"x" x) -> p x .&& q x)-                             )-                            []--    pure ()---- * No termination checks---- | It's important to realize that KnuckleDragger proofs in SBV neither check nor guarantee that the--- functions we use are terminating. This is beyond the scope (and current capabilities) of what SBV can handle.--- That is, the proof is up-to-termination, i.e., any proof implicitly assumes all functions defined (or axiomatized)--- terminate for all possible inputs. If non-termination is possible, then the logic becomes inconsistent, i.e.,--- we can prove arbitrary results.------ Here is a simple example where we tell SBV that there is a function @f@ with non terminating behavior. Using this,--- we can deduce @False@:------ >>> noTerminationChecks--- Axiom: bad--- Lemma: noTerminationImpliesFalse---   Step: 1 (bad @ (n |-> 0 :: SInteger)) Q.E.D.---   Result:                               Q.E.D.--- [Proven] noTerminationImpliesFalse-noTerminationChecks :: IO Proof-noTerminationChecks = runKD $ do--   let f :: SInteger -> SInteger-       f = uninterpret "f"--   badAxiom <- axiom "bad" (\(Forall @"n" n) -> f n .== 1 + f n)--   calc "noTerminationImpliesFalse"-        sFalse-        ([] |- f 0-            ?? badAxiom `at` Inst @"n" (0 :: SInteger)-            =: 1 + f 0-            =: qed)
− Documentation/SBV/Examples/KnuckleDragger/BinarySearch.hs 
@@ -1,271 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.BinarySearch--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Proving binary search correct--------------------------------------------------------------------------------{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE TypeAbstractions    #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.BinarySearch where--import Prelude hiding (null, length, (!!), drop, take, tail, elem, notElem)--import Data.SBV-import Data.SBV.Maybe-import Data.SBV.Tools.KnuckleDragger---- * Binary search---- | We will work with arrays containing integers, indexed by integers. Note that since SMTLib arrays--- are indexed by their entire domain, we explicitly take a lower/upper bounds as parameters, which fits well--- with the binary search algorithm.-type Arr = SArray Integer Integer---- | Bounds: This is the focus into the array; both indexes are inclusive.-type Idx = (SInteger, SInteger)---- | Encode binary search in a functional style.-bsearch :: Arr -> Idx -> SInteger -> SMaybe Integer-bsearch array (low, high) = f array low high-  where f = smtFunction "bsearch" $ \arr lo hi x ->-               let mid  = (lo + hi) `sEDiv` 2-                   xmid = arr `readArray` mid-               in ite (lo .> hi)-                      sNothing-                      (ite (xmid .== x)-                           (sJust mid)-                           (ite (xmid .< x)-                                (bsearch arr (mid+1, hi)    x)-                                (bsearch arr (lo,    mid-1) x)))---- * Correctness proof---- | A predicate testing whether a given array is non-decreasing in the given range-nonDecreasing :: Arr -> Idx -> SBool-nonDecreasing arr (low, high) = quantifiedBool $-    \(Forall @"i" i) (Forall @"j" j) -> low .<= i .&& i .<= j .&& j .<= high .=> arr `readArray` i .<= arr `readArray` j---- | A predicate testing whether an element is in the array within the given bounds-inArray :: Arr -> Idx -> SInteger -> SBool-inArray arr (low, high) elt = quantifiedBool $ \(Exists @"i" i) -> low .<= i .&& i .<= high .&& arr `readArray` i .== elt---- | Correctness of binary search.------ We have:------ >>> correctness--- Lemma: notInRange                                 Q.E.D.--- Lemma: inRangeHigh                                Q.E.D.--- Lemma: inRangeLow                                 Q.E.D.--- Lemma: nonDecreasing                              Q.E.D.--- Inductive lemma (strong): bsearchAbsent---   Step: Measure is non-negative                   Q.E.D.---   Step: 1 (unfold bsearch)                        Q.E.D.---   Step: 2 (push isNothing down, simplify)         Q.E.D.---   Step: 3 (2 way case split)---     Step: 3.1                                     Q.E.D.---     Step: 3.2.1                                   Q.E.D.---     Step: 3.2.2                                   Q.E.D.---     Step: 3.2.3                                   Q.E.D.---     Step: 3.2.4                                   Q.E.D.---     Step: 3.2.5 (simplify)                        Q.E.D.---     Step: 3.Completeness                          Q.E.D.---   Result:                                         Q.E.D.--- Inductive lemma (strong): bsearchPresent---   Step: Measure is non-negative                   Q.E.D.---   Step: 1 (unfold bsearch)                        Q.E.D.---   Step: 2 (simplify)                              Q.E.D.---   Step: 3 (3 way case split)---     Step: 3.1                                     Q.E.D.---     Step: 3.2                                     Q.E.D.---     Step: 3.3.1                                   Q.E.D.---     Step: 3.3.2 (3 way case split)---       Step: 3.3.2.1                               Q.E.D.---       Step: 3.3.2.2.1                             Q.E.D.---       Step: 3.3.2.2.2                             Q.E.D.---       Step: 3.3.2.3.1                             Q.E.D.---       Step: 3.3.2.3.2                             Q.E.D.---       Step: 3.3.2.Completeness                    Q.E.D.---     Step: 3.Completeness                          Q.E.D.---   Result:                                         Q.E.D.--- Lemma: bsearchCorrect---   Step: 1 (2 way case split)---     Step: 1.1.1                                   Q.E.D.---     Step: 1.1.2                                   Q.E.D.---     Step: 1.2.1                                   Q.E.D.---     Step: 1.2.2                                   Q.E.D.---     Step: 1.Completeness                          Q.E.D.---   Result:                                         Q.E.D.--- [Proven] bsearchCorrect-correctness :: IO Proof-correctness = runKDWith z3{kdOptions = (kdOptions z3) { ribbonLength = 50 }} $ do--  -- Helper: if a value is not in a range, then it isn't in any subrange of it:-  notInRange <- lemma "notInRange"-                           (\(Forall @"arr" arr) (Forall @"lo" lo) (Forall @"hi" hi) (Forall @"m" md) (Forall @"x" x)-                               ->  sNot (inArray arr (lo, hi) x) .&& lo .<= md .&& md .<= hi-                               .=> sNot (inArray arr (lo, md) x) .&& sNot (inArray arr (md, hi) x))-                           []--  -- Helper: if a value is in a range of a nonDecreasing array, and if its value is larger than a given mid point, then it's in the higher part-  inRangeHigh <- lemma "inRangeHigh"-                       (\(Forall @"arr" arr) (Forall @"lo" lo) (Forall @"hi" hi) (Forall @"m" md) (Forall @"x" x)-                           ->  nonDecreasing arr (lo, hi) .&& inArray arr (lo, hi) x .&& lo .<= md .&& md .<= hi .&& x .> arr `readArray` md-                           .=> inArray arr (md+1, hi) x)-                       []--  -- Helper: if a value is in a range of a nonDecreasing array, and if its value is lower than a given mid point, then it's in the lowr part-  inRangeLow  <- lemma "inRangeLow"-                       (\(Forall @"arr" arr) (Forall @"lo" lo) (Forall @"hi" hi) (Forall @"m" md) (Forall @"x" x)-                           ->  nonDecreasing arr (lo, hi) .&& inArray arr (lo, hi) x .&& lo .<= md .&& md .<= hi .&& x .< arr `readArray` md-                           .=> inArray arr (lo, md-1) x)-                       []--  -- Helper: if an array is nonDecreasing, then its parts are also non-decreasing when cut in any middle point-  nonDecreasingInRange <- lemma "nonDecreasing"-                                (\(Forall @"arr" arr) (Forall @"lo" lo) (Forall @"hi" hi) (Forall @"m" md)-                                    ->  nonDecreasing arr (lo, hi) .&& lo .<= md .&& md .<= hi-                                    .=> nonDecreasing arr (lo, md) .&& nonDecreasing arr (md, hi))-                                []--  -- Prove the case when the target is not in the array-  bsearchAbsent <- sInduct "bsearchAbsent"-        (\(Forall @"arr" arr) (Forall @"lo" lo) (Forall @"hi" hi) (Forall @"x" x) ->-            nonDecreasing arr (lo, hi) .&& sNot (inArray arr (lo, hi) x) .=> isNothing (bsearch arr (lo, hi) x))-        (\(_arr :: Arr) (lo :: SInteger) (hi :: SInteger) (_x :: SInteger) -> abs (hi - lo + 1)) $-        \ih arr lo hi x ->-              [nonDecreasing arr (lo, hi), sNot (inArray arr (lo, hi) x)]-           |- isNothing (bsearch arr (lo, hi) x)-           ?? "unfold bsearch"-           =: let mid  = (lo + hi) `sEDiv` 2-                  xmid = arr `readArray` mid-           in isNothing (ite (lo .> hi)-                             sNothing-                             (ite (xmid .== x)-                                  (sJust mid)-                                  (ite (xmid .< x)-                                       (bsearch arr (mid+1, hi)    x)-                                       (bsearch arr (lo,    mid-1) x))))-           ?? "push isNothing down, simplify"-           =: ite (lo .> hi)-                  sTrue-                  (ite (xmid .== x)-                       sFalse-                       (ite (xmid .< x)-                            (isNothing (bsearch arr (mid+1, hi)    x))-                            (isNothing (bsearch arr (lo,    mid-1) x))))-           =: cases [ lo .> hi  ==> trivial-                    , lo .<= hi ==> ite (xmid .== x)-                                        sFalse-                                        (ite (xmid .< x)-                                             (isNothing (bsearch arr (mid+1, hi)    x))-                                             (isNothing (bsearch arr (lo,    mid-1) x)))-                                 =: let inst1 l h m = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h, Inst @"m" m, Inst @"x" x)-                                        inst2 l h m = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h, Inst @"m" m             )-                                        inst3 l h   = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h,              Inst @"x" x)-                                 in ite (xmid .< x)-                                        (isNothing (bsearch arr (mid+1, hi)    x))-                                        (isNothing (bsearch arr (lo,    mid-1) x))-                                 ?? [ notInRange           `at` inst1 lo      hi (mid+1)-                                    , nonDecreasingInRange `at` inst2 lo      hi (mid+1)-                                    , ih                   `at` inst3 (mid+1) hi-                                    ]-                                 =: ite (xmid .< x)-                                        sTrue-                                        (isNothing (bsearch arr (lo,    mid-1) x))-                                 ?? [ notInRange           `at` inst1 lo hi      (mid-1)-                                    , nonDecreasingInRange `at` inst2 lo hi      (mid-1)-                                    , ih                   `at` inst3 lo (mid-1)-                                    ]-                                 =: ite (xmid .< x) sTrue sTrue-                                 ?? "simplify"-                                 =: sTrue-                                 =: qed-                    ]--  -- Prove the case when the target is in the array-  bsearchPresent <- sInduct "bsearchPresent"-        (\(Forall @"arr" arr) (Forall @"lo" lo) (Forall @"hi" hi) (Forall @"x" x) ->-            nonDecreasing arr (lo, hi) .&& inArray arr (lo, hi) x .=> arr `readArray` fromJust (bsearch arr (lo, hi) x) .== x)-        (\(_arr :: Arr) (lo :: SInteger) (hi :: SInteger) (_x :: SInteger) -> abs (hi - lo + 1)) $-        \ih arr lo hi x ->-             [nonDecreasing arr (lo, hi), inArray arr (lo, hi) x]-          |- x .== arr `readArray` fromJust (bsearch arr (lo, hi) x)-          ?? "unfold bsearch"-          =: let mid  = (lo + hi) `sEDiv` 2-                 xmid = arr `readArray` mid-          in x .== arr `readArray` fromJust (ite (lo .> hi)-                                                 sNothing-                                                 (ite (xmid .== x)-                                                      (sJust mid)-                                                      (ite (xmid .< x)-                                                           (bsearch arr (mid+1, hi)    x)-                                                           (bsearch arr (lo,    mid-1) x))))-          ?? "simplify"-          =: ite (lo .> hi)-                 (x .== arr `readArray` fromJust sNothing)-                 (ite (xmid .== x)-                      (x .== arr `readArray` mid)-                      (ite (xmid .< x)-                           (x .== arr `readArray` fromJust (bsearch arr (mid+1, hi)    x))-                           (x .== arr `readArray` fromJust (bsearch arr (lo,    mid-1) x))))-          =: cases [ lo .>  hi ==> trivial-                   , lo .== hi ==> trivial-                   , lo .<  hi ==> ite (xmid .== x)-                                       (x .== arr `readArray` mid)-                                       (ite (xmid .< x)-                                            (x .== arr `readArray` fromJust (bsearch arr (mid+1, hi)    x))-                                            (x .== arr `readArray` fromJust (bsearch arr (lo,    mid-1) x)))-                                =: let inst1 l h m = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h, Inst @"m" m, Inst @"x" x)-                                       inst2 l h m = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h, Inst @"m" m             )-                                       inst3 l h   = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h,              Inst @"x" x)-                                in cases [ xmid .== x ==> trivial-                                         , xmid .< x  ==> x .== arr `readArray` fromJust (bsearch arr (mid+1, hi)    x)-                                                       ?? [ inRangeHigh          `at` inst1 lo      hi mid-                                                          , nonDecreasingInRange `at` inst2 lo      hi (mid+1)-                                                          , ih                   `at` inst3 (mid+1) hi-                                                          ]-                                                       =: sTrue-                                                       =: qed-                                         , xmid .> x  ==> x .== arr `readArray` fromJust (bsearch arr (lo, mid-1) x)-                                                       ?? [ inRangeLow           `at` inst1 lo hi      mid-                                                          , nonDecreasingInRange `at` inst2 lo hi      (mid-1)-                                                          , ih                   `at` inst3 lo (mid-1)-                                                          ]-                                                       =: sTrue-                                                       =: qed-                                         ]-                   ]--  calc "bsearchCorrect"-        (\(Forall @"arr" arr) (Forall @"lo" lo) (Forall @"hi" hi) (Forall @"x" x) ->-            nonDecreasing arr (lo, hi) .=> let res = bsearch arr (lo, hi) x-                                           in ite (inArray arr (lo, hi) x)-                                                  (arr `readArray` fromJust res .== x)-                                                  (isNothing res)) $-        \arr lo hi x -> [nonDecreasing arr (lo, hi)]-                     |- let res = bsearch arr (lo, hi) x-                        in ite (inArray arr (lo, hi) x)-                               (arr `readArray` fromJust res .== x)-                               (isNothing res)-                     =: cases [ inArray arr (lo, hi) x-                                  ==> arr `readArray` fromJust (bsearch arr (lo, hi) x) .== x-                                   ?? bsearchPresent `at` (Inst @"arr" arr, Inst @"lo" lo, Inst @"hi" hi, Inst @"x" x)-                                   =: sTrue-                                   =: qed-                              , sNot (inArray arr (lo, hi) x)-                                  ==> isNothing (bsearch arr (lo, hi) x)-                                   ?? bsearchAbsent `at` (Inst @"arr" arr, Inst @"lo" lo, Inst @"hi" hi, Inst @"x" x)-                                   =: sTrue-                                   =: qed-                              ]
− Documentation/SBV/Examples/KnuckleDragger/CaseSplit.hs 
@@ -1,117 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.CaseSplit--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Use KnuckleDragger to prove @2n^2 + n + 1@ is never divisible by @3@.--------------------------------------------------------------------------------{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE TypeAbstractions #-}-{-# LANGUAGE TypeApplications #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.CaseSplit where--import Prelude hiding (sum, length)--import Data.SBV-import Data.SBV.Tools.KnuckleDragger---- | Prove that @2n^2 + n + 1@ is not divisible by @3@.------ We have:------ >>> notDiv3--- Lemma: case_n_mod_3_eq_0---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- Lemma: case_n_mod_3_eq_1---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Step: 6                               Q.E.D.---   Result:                               Q.E.D.--- Lemma: case_n_mod_3_eq_2---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Step: 6                               Q.E.D.---   Result:                               Q.E.D.--- Lemma: notDiv3---   Step: 1 (3 way case split)---     Step: 1.1                           Q.E.D.---     Step: 1.2                           Q.E.D.---     Step: 1.3                           Q.E.D.---     Step: 1.Completeness                Q.E.D.---   Result:                               Q.E.D.--- [Proven] notDiv3-notDiv3 :: IO Proof-notDiv3 = runKD $ do--   let s n = 2 * n * n + n + 1-       p n = s n `sEMod` 3 ./= 0--   -- Do the proof in 3 phases; one each for the possible value of n `mod` 3 being 0, 1, and 2-   -- Note that we use the euclidian definition of division/modulus.--   let case0 n = n `sEMod` 3 .== 0-       case1 n = n `sEMod` 3 .== 1-       case2 n = n `sEMod` 3 .== 2--   -- Case 0: n = 0 (mod 3)-   c0 <- calc "case_n_mod_3_eq_0"-              (\(Forall @"n" n) -> case0 n .=> p n) $-              \n -> [case0 n] |- s n-                              =: let w = some "witness" $ \k -> n .== 3*k  -- Grab the witness for the case-                              in s (3*w)-                              =: s (3*w)-                              =: 2*(3*w)*(3*w) + 3*w + 1-                              =: 18*w*w + 3*w + 1-                              =: 3*(6*w*w + w) + 1-                              =: qed--   -- Case 1: n = 1 (mod 3)-   c1 <- calc "case_n_mod_3_eq_1"-              (\(Forall @"n" n) -> case1 n .=> p n) $-              \n -> [case1 n] |- s n-                              =: let w = some "witness" $ \k -> n .== 3*k+1  -- Grab the witness for n being 1 modulo 3-                              in s (3*w+1)-                              =: 2*(3*w+1)*(3*w+1) + (3*w+1) + 1-                              =: 2*(9*w*w + 3*w + 3*w + 1) + (3*w + 1) + 1-                              =: 18*w*w + 12*w + 2 + 3*w + 2-                              =: 18*w*w + 15*w + 4-                              =: 3*(6*w*w + 5*w + 1) + 1-                              =: qed--   -- Case 2: n = 2 (mod 3)-   c2 <- calc "case_n_mod_3_eq_2"-              (\(Forall @"n" n) -> case2 n .=> p n) $-              \n -> [case2 n] |- s n-                              =: let w = some "witness" $ \k -> n .== 3*k+2 -- Grab the witness for n being 2 modulo 3-                              in s (3*w+2)-                              =: 2*(3*w+2)*(3*w+2) + (3*w+2) + 1-                              =: 2*(9*w*w + 6*w + 6*w + 4) + (3*w + 2) + 1-                              =: 18*w*w + 24*w + 8 + 3*w + 3-                              =: 18*w*w + 27*w + 11-                              =: 3*(6*w*w + 9*w + 3) + 2-                              =: qed--   calc "notDiv3"-        (\(Forall @"n" n) -> p n) $-        \n -> [] |- cases [ case0 n ==> p n ?? c0 `at` Inst @"n" n =: sTrue =: qed-                          , case1 n ==> p n ?? c1 `at` Inst @"n" n =: sTrue =: qed-                          , case2 n ==> p n ?? c2 `at` Inst @"n" n =: sTrue =: qed-                          ]
− Documentation/SBV/Examples/KnuckleDragger/InsertionSort.hs 
@@ -1,217 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.InsertionSort--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Proving insertion sort correct.--------------------------------------------------------------------------------{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE TypeAbstractions    #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.InsertionSort where--import Data.SBV-import Data.SBV.Tools.KnuckleDragger--import Prelude hiding (null, length, head, tail, elem)-import Data.SBV.List---- * Insertion sort---- | Insert an element into an already sorted list in the correct place.-insert :: SInteger -> SList Integer -> SList Integer-insert = smtFunction "insert" $ \e l -> ite (null l) (singleton e)-                                      $ let (x, xs) = uncons l-                                        in ite (e .<= x) (e .: x .: xs) (x .: insert e xs)---- | Insertion sort, using 'insert' above to successively insert the elements.-insertionSort :: SList Integer -> SList Integer-insertionSort = smtFunction "insertionSort" $ \l -> ite (null l) nil-                                                  $ let (x, xs) = uncons l-                                                    in insert x (insertionSort xs)----- * Helper functions---- | A predicate testing whether a given list is non-decreasing.-nonDecreasing :: SList Integer -> SBool-nonDecreasing = smtFunction "nonDecreasing" $ \l ->  null l .|| null (tail l)-                                                 .|| let (x, l') = uncons l-                                                         (y, _)  = uncons l'-                                                     in x .<= y .&& nonDecreasing l'---- | Remove the first occurrence of an number from a list, if any.-removeFirst :: SInteger -> SList Integer -> SList Integer-removeFirst = smtFunction "removeFirst" $ \e l -> ite (null l)-                                                      nil-                                                      (let (x, xs) = uncons l-                                                       in ite (e .== x) xs (x .: removeFirst e xs))---- | Are two lists permutations of each other?-isPermutation :: SList Integer -> SList Integer -> SBool-isPermutation = smtFunction "isPermutation" $ \l r -> ite (null l)-                                                          (null r)-                                                          (let (x, xs) = uncons l-                                                           in x `elem` r .&& isPermutation xs (removeFirst x r))---- * Correctness proof---- | Correctness of insertion-sort. z3 struggles with this, but CVC5 proves it just fine.------ We have:------ >>> correctness--- Lemma: nonDecTail                            Q.E.D.--- Inductive lemma: insertNonDecreasing---   Step: Base                                 Q.E.D.---   Step: 1 (unfold insert)                    Q.E.D.---   Step: 2 (push nonDecreasing down)          Q.E.D.---   Step: 3 (unfold simplify)                  Q.E.D.---   Step: 4                                    Q.E.D.---   Step: 5                                    Q.E.D.---   Result:                                    Q.E.D.--- Inductive lemma: sortNonDecreasing---   Step: Base                                 Q.E.D.---   Step: 1 (unfold insertionSort)             Q.E.D.---   Step: 2                                    Q.E.D.---   Result:                                    Q.E.D.--- Lemma: elemITE                               Q.E.D.--- Inductive lemma: insertIsElem---   Step: Base                                 Q.E.D.---   Step: 1                                    Q.E.D.---   Step: 2                                    Q.E.D.---   Step: 3                                    Q.E.D.---   Step: 4                                    Q.E.D.---   Result:                                    Q.E.D.--- Inductive lemma: removeAfterInsert---   Step: Base                                 Q.E.D.---   Step: 1 (expand insert)                    Q.E.D.---   Step: 2 (push removeFirst down ite)        Q.E.D.---   Step: 3 (unfold removeFirst on 'then')     Q.E.D.---   Step: 4 (unfold removeFirst on 'else')     Q.E.D.---   Step: 5                                    Q.E.D.---   Step: 6 (simplify)                         Q.E.D.---   Result:                                    Q.E.D.--- Inductive lemma: sortIsPermutation---   Step: Base                                 Q.E.D.---   Step: 1                                    Q.E.D.---   Step: 2                                    Q.E.D.---   Step: 3                                    Q.E.D.---   Step: 4                                    Q.E.D.---   Step: 5                                    Q.E.D.---   Result:                                    Q.E.D.--- Lemma: insertionSortIsCorrect                Q.E.D.--- [Proven] insertionSortIsCorrect-correctness :: IO Proof-correctness = runKDWith cvc5{kdOptions = (kdOptions cvc5) { ribbonLength = 45 }} $ do--    ---------------------------------------------------------------------------------------------    -- Part I. Prove that the output of insertion sort is non-decreasing.-    ----------------------------------------------------------------------------------------------    nonDecrTail <- lemma "nonDecTail"-                         (\(Forall @"x" x) (Forall @"xs" xs) -> nonDecreasing (x .: xs) .=> nonDecreasing xs)-                         []--    insertNonDecreasing <--        induct "insertNonDecreasing"-               (\(Forall @"xs" xs) (Forall @"e" e) -> nonDecreasing xs .=> nonDecreasing (insert e xs)) $-               \ih x xs e -> [nonDecreasing (x .: xs)]-                          |- nonDecreasing (insert e (x .: xs))-                          ?? "unfold insert"-                          =: nonDecreasing (ite (e .<= x) (e .: x .: xs) (x .: insert e xs))-                          ?? "push nonDecreasing down"-                          =: ite (e .<= x) (nonDecreasing (e .: x .: xs))-                                           (nonDecreasing (x .: insert e xs))-                          ?? "unfold simplify"-                          =: ite (e .<= x)-                                 (nonDecreasing (x .: xs))-                                 (nonDecreasing (x .: insert e xs))-                          ?? nonDecreasing (x .: xs)-                          =: (e .> x .=> nonDecreasing (x .: insert e xs))-                          ?? [ nonDecrTail `at` (Inst @"x" x, Inst @"xs" (insert e xs))-                             , ih-                             ]-                          =: sTrue-                          =: qed--    sortNonDecreasing <--        induct "sortNonDecreasing"-               (\(Forall @"xs" xs) -> nonDecreasing (insertionSort xs)) $-               \ih x xs -> [] |- nonDecreasing (insertionSort (x .: xs))-                              ?? "unfold insertionSort"-                              =: nonDecreasing (insert x (insertionSort xs))-                              ?? [ insertNonDecreasing `at` (Inst @"xs" (insertionSort xs), Inst @"e" x)-                                 , ih-                                 ]-                              =: sTrue-                              =: qed--    ---------------------------------------------------------------------------------------------    -- Part II. Prove that the output of insertion sort is a permuation of its input-    ----------------------------------------------------------------------------------------------    -- For whatever reason z3 can't figure this out in the below proof. This helper isn't needed for CVC5.-    -- Note that z3 is able to prove this out-of-the box without any helpers, but needs it in the next as a helper.-    elemITE <- lemma "elemITE" (\(Forall @"x" (x :: SInteger)) (Forall @"c" c) (Forall @"t" t) (Forall @"e" e)-                                        -> x `elem` ite c t e .== ite c (x `elem` t) (x `elem` e))-                     []--    insertIsElem <--        induct "insertIsElem"-               (\(Forall @"xs" xs) (Forall @"e" e) -> e `elem` insert e xs) $-               \ih x xs e -> [] |- e `elem` insert e (x .: xs)-                                =: e `elem` ite (e .<= x) (e .: x .: xs) (x .: insert e xs)-                                -- z3 has hard time making the following step (though cvc5 is OK with it)-                                ?? elemITE `at` (Inst @"x" e, Inst @"c" (e .<= x), Inst @"t" (e .: x .: xs), Inst @"e" (x .: insert e xs))-                                =: ite (e .<= x) (e `elem` (e .: x .: xs)) (e `elem` (x .: insert e xs))-                                =: ite (e .<= x) sTrue (e `elem` insert e xs) ?? ih-                                =: sTrue-                                =: qed--    removeAfterInsert <--        induct "removeAfterInsert"-               (\(Forall @"xs" xs) (Forall @"e" e) -> removeFirst e (insert e xs) .== xs) $-               \ih x xs e -> [] |- removeFirst e (insert e (x .: xs))-                                ??  "expand insert"-                                =: removeFirst e (ite (e .<= x) (e .: x .: xs) (x .: insert e xs))-                                ??  "push removeFirst down ite"-                                =: ite (e .<= x) (removeFirst e (e .: x .: xs)) (removeFirst e (x .: insert e xs))-                                ??  "unfold removeFirst on 'then'"-                                =: ite (e .<= x) (x .: xs) (removeFirst e (x .: insert e xs))-                                ??  "unfold removeFirst on 'else'"-                                =: ite (e .<= x) (x .: xs) (x .: removeFirst e (insert e xs))-                                ??  ih-                                =: ite (e .<= x) (x .: xs) (x .: xs)-                                ??  "simplify"-                                =: x .: xs-                                =: qed--    sortIsPermutation <--        induct "sortIsPermutation"-               (\(Forall @"xs" xs) -> isPermutation xs (insertionSort xs)) $-               \ih x xs -> [] |- isPermutation (x .: xs) (insertionSort (x .: xs))-                              =: isPermutation (x .: xs) (insert x (insertionSort xs))-                              =: x `elem` insert x (insertionSort xs) .&& isPermutation xs (removeFirst x (insert x (insertionSort xs)))-                              ?? insertIsElem-                              =: isPermutation xs (removeFirst x (insert x (insertionSort xs)))-                              ?? removeAfterInsert-                              =: isPermutation xs (insertionSort xs)-                              ?? ih-                              =: sTrue-                              =: qed--    ---------------------------------------------------------------------------------------------    -- Put the two parts together for the final proof-    ---------------------------------------------------------------------------------------------    lemma "insertionSortIsCorrect"-          (\(Forall @"xs" xs) -> let out = insertionSort xs in nonDecreasing out .&& isPermutation xs out)-          [sortNonDecreasing, sortIsPermutation]
− Documentation/SBV/Examples/KnuckleDragger/Kleene.hs 
@@ -1,142 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.Kleene--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Example use of the KnuckleDragger layer, proving some Kleene algebra theorems.------ Based on <http://www.philipzucker.com/bryzzowski_kat/>--------------------------------------------------------------------------------{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE DeriveAnyClass       #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE StandaloneDeriving   #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeAbstractions     #-}--{-# OPTIONS_GHC -Wall -Werror -Wno-unused-matches #-}--module Documentation.SBV.Examples.KnuckleDragger.Kleene where--import Prelude hiding((<=))--import Data.SBV-import Data.SBV.Tools.KnuckleDragger---- | An uninterpreted sort, corresponding to the type of Kleene algebra strings.-data Kleene-mkUninterpretedSort ''Kleene---- | Star operator over kleene algebras. We're leaving this uninterpreted.-star :: SKleene -> SKleene-star = uninterpret "STAR"---- | The 'Num' instance for Kleene makes it easy to write regular expressions--- in the more familiar form.-instance Num SKleene where-  (+) = uninterpret "PAR"-  (*) = uninterpret "SEQ"--  abs    = error "SKleene: not defined: abs"-  signum = error "SKleene: not defined: signum"-  negate = error "SKleene: not defined: signum"--  fromInteger 0 = uninterpret "zero"-  fromInteger 1 = uninterpret "one"-  fromInteger n = error $ "SKleene: not defined: fromInteger " ++ show n---- | The set of strings matched by one regular expression is a subset of the second,--- if adding it to the second doesn't change the second set.-(<=) :: SKleene -> SKleene -> SBool-x <= y = x + y .== y---- | A sequence of Kleene algebra proofs. See <http://www.cs.cornell.edu/~kozen/Papers/ka.pdf>------ We have:------ >>> kleeneProofs--- Axiom: par_assoc--- Axiom: par_comm--- Axiom: par_idem--- Axiom: par_zero--- Axiom: seq_assoc--- Axiom: seq_zero--- Axiom: seq_one--- Axiom: rdistrib--- Axiom: ldistrib--- Axiom: unfold--- Axiom: least_fix--- Lemma: par_lzero                        Q.E.D.--- Lemma: par_monotone                     Q.E.D.--- Lemma: seq_monotone                     Q.E.D.--- Lemma: star_star_1---   Step: 1 (unfold)                      Q.E.D.---   Step: 2 (factor out x * star x)       Q.E.D.---   Step: 3 (par_idem)                    Q.E.D.---   Step: 4 (unfold)                      Q.E.D.---   Result:                               Q.E.D.--- Lemma: subset_eq                        Q.E.D.--- Lemma: star_star_2_2                    Q.E.D.--- Lemma: star_star_2_3                    Q.E.D.--- Lemma: star_star_2_1                    Q.E.D.--- Lemma: star_star_2                      Q.E.D.-kleeneProofs :: IO ()-kleeneProofs = runKD $ do--  -- Kozen axioms-  par_assoc <- axiom "par_assoc" $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> x + (y + z) .== (x + y) + z-  par_comm  <- axiom "par_comm"  $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y)                 -> x + y       .== y + x-  par_idem  <- axiom "par_idem"  $ \(Forall @"x" (x :: SKleene))                                 -> x + x       .== x-  par_zero  <- axiom "par_zero"  $ \(Forall @"x" (x :: SKleene))                                 -> x + 0       .== x--  seq_assoc <- axiom "seq_assoc" $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> x * (y * z) .== (x * y) * z-  seq_zero  <- axiom "seq_zero"  $ \(Forall @"x" (x :: SKleene))                                 -> x * 0       .== 0-  seq_one   <- axiom "seq_one"   $ \(Forall @"x" (x :: SKleene))                                 -> x * 1       .== x--  rdistrib  <- axiom "rdistrib"  $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> x * (y + z) .== x * y + x * z-  ldistrib  <- axiom "ldistrib"  $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> (y + z) * x .== y * x + z * x--  unfold    <- axiom "unfold"    $ \(Forall @"e" e) -> star e .== 1 + e * star e--  least_fix <- axiom "least_fix" $ \(Forall @"x" x) (Forall @"e" e) (Forall @"f" f) -> ((f + e * x) <= x) .=> ((star e * f) <= x)--  -- Collect the basic axioms in a list for easy reference-  let kleene = [ par_assoc,  par_comm, par_idem, par_zero-               , seq_assoc,  seq_zero, seq_one-               , ldistrib,   rdistrib-               , unfold-               , least_fix-               ]--  -- Various proofs:-  par_lzero    <- lemma "par_lzero"    (\(Forall @"x" (x :: SKleene)) -> 0 + x .== x) kleene-  par_monotone <- lemma "par_monotone" (\(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> x <= y .=> ((x + z) <= (y + z))) kleene-  seq_monotone <- lemma "seq_monotone" (\(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> x <= y .=> ((x * z) <= (y * z))) kleene--  -- This one requires a chain of reasoning: x* x* == x*-  star_star_1  <- calc "star_star_1"-                       (\(Forall @"x" (x :: SKleene)) -> star x * star x .== star x) $-                       \x -> [] |- star x * star x                     ?? unfold-                                =: (1 + x * star x) * (1 + x * star x)-                                ?? hcmnt "factor out x * star x" : map hprf kleene-                                =: (1 + 1) + (x * star x + x * star x) ?? par_idem-                                =: 1 + x * star x                      ?? unfold-                                =: star x-                                =: qed--  subset_eq   <- lemma "subset_eq" (\(Forall @"x" x) (Forall @"y" y) -> (x .== y) .== (x <= y .&& y <= x)) kleene--  -- Prove: x** = x*-  star_star_2 <- do _1 <- lemma "star_star_2_2" (\(Forall @"x" x) -> ((star x * star x + 1) <= star x) .=> star (star x) <= star x) kleene-                    _2 <- lemma "star_star_2_3" (\(Forall @"x" x) -> star (star x) <= star x)                                       (kleene ++ [_1])-                    _3 <- lemma "star_star_2_1" (\(Forall @"x" x) -> star x        <= star (star x))                                kleene--                    lemma "star_star_2" (\(Forall @"x" (x :: SKleene)) -> star (star x) .== star x) [subset_eq, _2, _3]--  pure ()
− Documentation/SBV/Examples/KnuckleDragger/Lists.hs 
@@ -1,1447 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.Lists--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ A variety of KnuckleDragger proofs on list processing functions. Note that--- these proofs only hold for finite lists. SMT-solvers do not model infinite--- lists, and hence all claims are for finite (but arbitrary-length) lists.--------------------------------------------------------------------------------{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TypeAbstractions    #-}-{-# LANGUAGE TypeApplications    #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.Lists where--import Prelude (IO, ($), Integer, Num(..), id, (.), flip)--import Data.SBV-import Data.SBV.List-import Data.SBV.Tuple-import Data.SBV.Tools.KnuckleDragger--import Control.Monad (void)-import Data.Proxy--#ifdef DOCTEST--- $setup--- >>> :set -XScopedTypeVariables--- >>> :set -XTypeApplications--- >>> import Data.SBV--- >>> import Data.Proxy--- >>> import Control.Exception-#endif---- | Data declaration for an uninterpreted type, usually indicating source.-data A-mkUninterpretedSort ''A---- | Data declaration for an uninterpreted type, usually indicating target.-data B-mkUninterpretedSort ''B---- | Data declaration for an uninterpreted type, usually indicating an intermediate value.-data C-mkUninterpretedSort ''C---- * Appending null---- | @xs ++ [] == xs@------ We have:------ >>> appendNull--- Lemma: appendNull                       Q.E.D.--- [Proven] appendNull-appendNull :: IO Proof-appendNull = runKD $ lemma "appendNull" (\(Forall @"xs" (xs :: SList A)) -> xs ++ nil .== xs) []---- * Moving cons over append---- | @(x : xs) ++ ys == x : (xs ++ ys)@------ We have:------ >>> consApp--- Lemma: consApp                          Q.E.D.--- [Proven] consApp-consApp :: IO Proof-consApp = runKD $ lemma "consApp" (\(Forall @"x" (x :: SA)) (Forall @"xs" xs) (Forall @"ys" ys) -> (x .: xs) ++ ys .== x .: (xs ++ ys)) []---- * Associativity of append---- | @(xs ++ ys) ++ zs == xs ++ (ys ++ zs)@------ We have:------ >>> appendAssoc--- Lemma: appendAssoc                      Q.E.D.--- [Proven] appendAssoc------ Surprisingly, z3 can prove this without any induction. (Since SBV's append translates directly to--- the concatenation of sequences in SMTLib, it must trigger an internal heuristic in z3--- that proves it right out-of-the-box!)-appendAssoc :: IO Proof-appendAssoc = runKD $-   lemma "appendAssoc" (\(Forall @"xs" (xs :: SList A)) (Forall @"ys" ys) (Forall @"zs" zs) -> xs ++ (ys ++ zs) .== (xs ++ ys) ++ zs) []---- * Reverse and append---- | @reverse (x:xs) == reverse xs ++ [x]@------ >>> revCons--- Lemma: revCons                          Q.E.D.--- [Proven] revCons-revCons :: IO Proof-revCons = runKD $ lemma "revCons" (\(Forall @"x" (x :: SA)) (Forall @"xs" xs) -> reverse (x .: xs) .== reverse xs ++ singleton x) []---- | @reverse (xs ++ ys) .== reverse ys ++ reverse xs@------ We have:------ >>> revApp--- Inductive lemma: revApp---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] revApp-revApp :: IO Proof-revApp = runKD $-   induct "revApp"-          (\(Forall @"xs" (xs :: SList A)) (Forall @"ys" ys) -> reverse (xs ++ ys) .== reverse ys ++ reverse xs) $-          \ih (x :: SA) xs ys -> [] |- reverse ((x .: xs) ++ ys)-                                    =: reverse (x .: (xs ++ ys))-                                    =: reverse (xs ++ ys) ++ singleton x           ?? ih-                                    =: (reverse ys ++ reverse xs) ++ singleton x-                                    =: reverse ys ++ (reverse xs ++ singleton x)-                                    =: reverse ys ++ reverse (x .: xs)-                                    =: qed---- * Reversing twice is identity---- | @reverse (reverse xs) == xs@------ We have:------ >>> reverseReverse--- Inductive lemma: revApp---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- Inductive lemma: reverseReverse---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] reverseReverse-reverseReverse :: IO Proof-reverseReverse = runKD $ do--   ra <- use revApp--   induct "reverseReverse"-          (\(Forall @"xs" (xs :: SList A)) -> reverse (reverse xs) .== xs) $-          \ih (x :: SA) xs -> [] |- reverse (reverse (x .: xs))-                                 =: reverse (reverse xs ++ singleton x)           ?? ra-                                 =: reverse (singleton x) ++ reverse (reverse xs) ?? ih-                                 =: singleton x ++ xs-                                 =: x .: xs-                                 =: qed---- * Lengths of lists---- | @length (x : xs) = 1 + length xs@------ We have:------ >>> lengthTail--- Lemma: lengthTail                       Q.E.D.--- [Proven] lengthTail-lengthTail :: IO Proof-lengthTail = runKD $ lemma "lengthTail" (\(Forall @"x" (x :: SA)) (Forall @"xs" xs) -> length (x .: xs) .== 1 + length xs) []---- | It is instructive to see what kind of counter-example we get if a lemma fails to prove.--- Below, we do a variant of the 'lengthTail, but with a bad implementation over integers,--- and see the counter-example. Our implementation returns an incorrect answer if the given list is longer--- than 5 elements and have 42 in it. We have:------ >>> badLengthProof `catch` (\(_ :: SomeException) -> pure ())--- Lemma: badLengthProof--- *** Failed to prove badLengthProof.--- Falsifiable. Counter-example:---   xs   = [15,11,13,16,27,42] :: [Integer]---   imp  =                  42 :: Integer---   spec =                   6 :: Integer-badLengthProof :: IO ()-badLengthProof = runKD $ do-   let badLength :: SList Integer -> SInteger-       badLength xs = ite (length xs .> 5 .&& 42 `elem` xs) 42 (length xs)--   void $ lemma "badLengthProof" (\(Forall @"xs" xs) -> observe "imp" (badLength xs) .== observe "spec" (length xs)) []---- | @length (xs ++ ys) == length xs + length ys@------ We have:------ >>> lenAppend--- Lemma: lenAppend                        Q.E.D.--- [Proven] lenAppend-lenAppend :: IO Proof-lenAppend = runKD $ lemma "lenAppend" (\(Forall @"xs" (xs :: SList A)) (Forall @"ys" ys) -> length (xs ++ ys) .== length xs + length ys) []---- | @length xs == length ys -> length (xs ++ ys) == 2 * length xs@------ We have:------ >>> lenAppend2--- Lemma: lenAppend2                       Q.E.D.--- [Proven] lenAppend2-lenAppend2 :: IO Proof-lenAppend2 = runKD $-    lemma "lenAppend2" (\(Forall @"xs" (xs :: SList A)) (Forall @"ys" ys) -> length xs .== length ys .=> length (xs ++ ys) .== 2 * length xs) []---- * Any, all, and filtering---- | @not (all id xs) == any not xs@------ A list of booleans is not all true, if any of them is false. We have:------ >>> allAny--- Inductive lemma: allAny---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] allAny-allAny :: IO Proof-allAny = runKD $-   induct "allAny"-          (\(Forall @"xs" xs) -> sNot (all id xs) .== any sNot xs) $-          \ih x xs -> [] |- sNot (all id (x .: xs))-                         =: sNot (x .&& all id xs)-                         =: (sNot x .|| sNot (all id xs))   ?? ih-                         =: sNot x .|| any sNot xs-                         =: any sNot (x .: xs)-                         =: qed---- | If an integer list doesn't have 2 as an element, then filtering for @> 2@ or @.>= 2@--- yields the same result. We have:------ >>> filterEx--- Inductive lemma: filterEx---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] filterEx-filterEx :: IO Proof-filterEx = runKD $-  induct "filterEx"-         (\(Forall @"xs" xs) -> (2 :: SInteger) `notElem` xs .=> (filter (.> 2) xs .== filter (.>= 2) xs)) $-         \ih x xs -> let h = (2 :: SInteger) `notElem` (x .:  xs)-                  in [h] |- filter (.> 2) (x .: xs)-                         =: ite (x .> 2) (x .: filter (.>  2) xs) (filter (.>  2) xs) ?? ih-                         =: ite (x .> 2) (x .: filter (.>= 2) xs) (filter (.>= 2) xs)-                         =: qed---- | The 'filterEx' example above, except we get a counter-example if @2@ can be in the list. Note that--- we don't need the induction tactic here.------ >>> filterEx2 `catch` (\(_ :: SomeException) -> pure ())--- Lemma: filterEx2--- *** Failed to prove filterEx2.--- Falsifiable. Counter-example:---   xs = [2] :: [Integer]-filterEx2 :: IO ()-filterEx2 = runKD $-   void $ lemma "filterEx2" (\(Forall @"xs" xs) -> filter (.> (2 :: SInteger)) xs .== filter (.>= 2) xs) []---- * Map, append, and reverse---- | @f = g => map f xs = map g xs@------ >>> mapEquiv--- Inductive lemma: mapEquiv---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] mapEquiv-mapEquiv :: IO Proof-mapEquiv = runKD $ do-   let f, g :: SA -> SB-       f = uninterpret "f"-       g = uninterpret "g"--       f'eq'g :: SBool-       f'eq'g = quantifiedBool $ \(Forall @"x" x) -> f x .== g x--   induct "mapEquiv"-          (\(Forall @"xs" xs) -> f'eq'g .=> map f xs .== map g xs) $-          \ih x xs -> [f'eq'g] |- map f (x .: xs) .== map g (x .: xs)-                               =: f x .: map f xs .== g x .: map g xs-                               =: f x .: map f xs .== f x .: map g xs ?? ih-                               =: f x .: map f xs .== f x .: map f xs-                               =: map f (x .: xs) .== map f (x .: xs)-                               =: qed---- | @map f (xs ++ ys) == map f xs ++ map f ys@------ >>> mapAppend (uninterpret "f")--- Inductive lemma: mapAppend---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] mapAppend-mapAppend :: (SA -> SB) -> IO Proof-mapAppend f = runKD $ do-   induct "mapAppend"-          (\(Forall @"xs" (xs :: SList A)) (Forall @"ys" ys) -> map f (xs ++ ys) .== map f xs ++ map f ys) $-          \ih x xs ys -> [] |- map f ((x .: xs) ++ ys)-                            =: map f (x .: (xs ++ ys))-                            =: f x .: map f (xs ++ ys)        ?? ih-                            =: f x .: (map f xs  ++ map f ys)-                            =: (f x .: map f xs) ++ map f ys-                            =: map f (x .: xs) ++ map f ys-                            =: qed---- | @map f . reverse == reverse . map f@------ >>> mapReverse--- Inductive lemma: mapAppend---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- Inductive lemma: mapReverse---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Step: 6                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] mapReverse-mapReverse :: IO Proof-mapReverse = runKD $ do-     let -- For an arbitrary uninterpreted function 'f':-         f :: SA -> SB-         f = uninterpret "f"--     mApp <- use (mapAppend f)--     induct "mapReverse"-            (\(Forall @"xs" xs) -> reverse (map f xs) .== map f (reverse xs)) $-            \ih x xs -> [] |- reverse (map f (x .: xs))-                           =: reverse (f x .: map f xs)-                           =: reverse (map f xs) ++ singleton (f x)       ?? ih-                           =: map f (reverse xs) ++ singleton (f x)-                           =: map f (reverse xs) ++ map f (singleton x)   ?? mApp-                           =: map f (reverse xs ++ singleton x)-                           =: map f (reverse (x .: xs))-                           =: qed---- * Reverse and length---- | @length xs == length (reverse xs)@------ We have:------ >>> revLen--- Inductive lemma: revLen---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] revLen-revLen :: IO Proof-revLen = runKD $-   induct "revLen"-          (\(Forall @"xs" (xs :: SList A)) -> length (reverse xs) .== length xs) $-          \ih (x :: SA) xs -> [] |- length (reverse (x .: xs))-                                 =: length (reverse xs ++ singleton x)-                                 =: length (reverse xs) + length (singleton x)  ?? ih-                                 =: length xs + 1-                                 =: length (x .: xs)-                                 =: qed---- | An example where we attempt to prove a non-theorem. Notice the counter-example--- generated for:------ @length xs = ite (length xs .== 3) 5 (length xs)@------ We have:------ >>> badRevLen `catch` (\(_ :: SomeException) -> pure ())--- Lemma: badRevLen--- *** Failed to prove badRevLen.--- Falsifiable. Counter-example:---   xs = [A_1,A_2,A_1] :: [A]-badRevLen :: IO ()-badRevLen = runKD $-   void $ lemma "badRevLen" (\(Forall @"xs" (xs :: SList A)) -> length (reverse xs) .== ite (length xs .== 3) 5 (length xs)) []---- * Foldr-map fusion---- | @foldr f a . map g = foldr (f . g) a@------ We have:------ >>> foldrMapFusion--- Inductive lemma: foldrMapFusion---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] foldrMapFusion-foldrMapFusion :: IO Proof-foldrMapFusion = runKD $ do-  let a :: SA-      a = uninterpret "a"--      g :: SC -> SB-      g = uninterpret "g"--      f :: SB -> SA -> SA-      f = uninterpret "f"--  induct "foldrMapFusion"-         (\(Forall @"xs" xs) -> foldr f a (map g xs) .== foldr (f . g) a xs) $-         \ih x xs -> [] |- foldr f a (map g (x .: xs))-                        =: foldr f a (g x .: map g xs)-                        =: g x `f` foldr f a (map g xs) ?? ih-                        =: g x `f` foldr (f . g) a xs-                        =: foldr (f . g) a (x .: xs)-                        =: qed---- * Foldr-foldr fusion---- |------ @---   Given f a = b and f (g x y) = h x (f y), for all x and y---   We have: f . foldr g a = foldr h b--- @------ >>> foldrFusion--- Inductive lemma: foldrFusion---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] foldrFusion-foldrFusion :: IO Proof-foldrFusion = runKD $ do-   let a :: SA-       a = uninterpret "a"--       b :: SB-       b = uninterpret "b"--       f :: SA -> SB-       f = uninterpret "f"--       g :: SC -> SA -> SA-       g = uninterpret "g"--       h :: SC -> SB -> SB-       h = uninterpret "h"--       -- Assumptions under which the equality holds-       h1 = f a .== b-       h2 = quantifiedBool $ \(Forall @"x" x) (Forall @"y" y) -> f (g x y) .== h x (f y)--   induct "foldrFusion"-          (\(Forall @"xs" xs) -> h1 .&& h2 .=> f (foldr g a xs) .== foldr h b xs) $-          \ih x xs -> [h1, h2] |- f (foldr g a (x .: xs))-                               =: f (g x (foldr g a xs))-                               =: h x (f (foldr g a xs))  ?? ih-                               =: h x (foldr h b xs)-                               =: foldr h b (x .: xs)-                               =: qed---- * Foldr over append---- | @foldr f a (xs ++ ys) == foldr f (foldr f a ys) xs@------ We have:------ >>> foldrOverAppend--- Inductive lemma: foldrOverAppend---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] foldrOverAppend-foldrOverAppend :: IO Proof-foldrOverAppend = runKD $ do-   let a :: SA-       a = uninterpret "a"--       f :: SA -> SA -> SA-       f = uninterpret "f"--   induct "foldrOverAppend"-          (\(Forall @"xs" xs) (Forall @"ys" ys) -> foldr f a (xs ++ ys) .== foldr f (foldr f a ys) xs) $-          \ih x xs ys -> [] |- foldr f a ((x .: xs) ++ ys)-                            =: foldr f a (x .: (xs ++ ys))-                            =: x `f` foldr f a (xs ++ ys)       ?? ih-                            =: x `f` foldr f (foldr f a ys) xs-                            =: foldr f (foldr f a ys) (x .: xs)-                            =: qed---- * Foldl over append---- | @foldl f a (xs ++ ys) == foldl f (foldl f a xs) ys@------ We have:------ >>> foldlOverAppend (uninterpret "f")--- Inductive lemma: foldlOverAppend---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] foldlOverAppend-foldlOverAppend :: (SB -> SA -> SB) -> IO Proof-foldlOverAppend f = runKD $-   induct "foldlOverAppend"-          (\(Forall @"xs" xs) (Forall @"ys" ys) (Forall @"a" a) -> foldl f a (xs ++ ys) .== foldl f (foldl f a xs) ys) $-          \ih x xs ys a -> [] |- foldl f a ((x .: xs) ++ ys)-                              =: foldl f a (x .: (xs ++ ys))-                              =: foldl f (a `f` x) (xs ++ ys)-                              -- z3 is smart enough to instantiate the IH correctly below, but we're-                              -- using an explicit instantiation to be clear about the use of @a@ at a different value-                              ?? ih `at` (Inst @"ys" ys, Inst @"a" (a `f` x))-                              =: foldl f (foldl f (a `f` x) xs) ys-                              =: qed---- * Foldr-foldl correspondence---- | @foldr f e xs == foldl (flip f) e (reverse xs)@------ We have:------ >>> foldrFoldlDuality--- Inductive lemma: foldlOverAppend---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Result:                               Q.E.D.--- Inductive lemma: foldrFoldlDuality---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Step: 6                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] foldrFoldlDuality-foldrFoldlDuality :: IO Proof-foldrFoldlDuality = runKD $ do-   let f :: SA -> SB -> SB-       f = uninterpret "f"--   foa <- use (foldlOverAppend (flip f))--   induct "foldrFoldlDuality"-          (\(Forall @"xs" xs) (Forall @"e" e) -> foldr f e xs .== foldl (flip f) e (reverse xs)) $-          \ih x xs e ->-              let ff  = flip f-                  rxs = reverse xs-              in [] |- foldr f e (x .: xs) =: x `f` foldr f e xs                      ?? ih-                                           =: x `f` foldl ff e rxs-                                           =: foldl ff e rxs `ff` x-                                           =: foldl ff (foldl ff e rxs) (singleton x) ?? foa-                                           =: foldl ff e (rxs ++ singleton x)-                                           =: foldl ff e (reverse (x .: xs))-                                           =: qed---- * Foldr-foldl duality, generalized---- | Given:------ @---     x \@ (y \@ z) = (x \@ y) \@ z     (associativity of @)--- and e \@ x = x                     (left unit)--- and x \@ e = x                     (right unit)--- @------ Prove:------ @---     foldr (\@) e xs = foldl (\@) e xs--- @------ We have:------ >>> foldrFoldlDualityGeneralized--- Inductive lemma: helper---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- Inductive lemma: foldrFoldlDuality---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Step: 6                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] foldrFoldlDuality-foldrFoldlDualityGeneralized :: IO Proof-foldrFoldlDualityGeneralized  = runKD $ do-   let (@) :: SA -> SA -> SA-       (@) = uninterpret "|@|"--       e :: SA-       e = uninterpret "e"--   -- Assumptions under which the equality holds-   let assoc = quantifiedBool $ \(Forall @"x" x) (Forall @"y" y) (Forall @"z" z) -> x @ (y @ z) .== (x @ y) @ z-       lunit = quantifiedBool $ \(Forall @"x" x) -> e @ x .== x-       runit = quantifiedBool $ \(Forall @"x" x) -> x @ e .== x--   -- Helper: foldl (@) (y @ z) xs = y @ foldl (@) z xs-   -- Note the instantiation of the IH at a different value for z. It turns out-   -- we don't have to actually specify this since z3 can figure it out by itself, but we're being explicit.-   helper <- induct "helper"-                     (\(Forall @"xs" xs) (Forall @"y" y) (Forall @"z" z) -> assoc .=> foldl (@) (y @ z) xs .== y @ foldl (@) z xs) $-                     \ih x xs y z -> [assoc] |- foldl (@) (y @ z) (x .: xs)-                                             =: foldl (@) ((y @ z) @ x) xs-                                             ?? assoc-                                             =: foldl (@) (y @ (z @ x)) xs-                                             ?? ih `at` (Inst @"y" y, Inst @"z" (z @ x))-                                             =: y @ foldl (@) (z @ x) xs-                                             =: y @ foldl (@) z (x .: xs)-                                             =: qed--   induct "foldrFoldlDuality"-          (\(Forall @"xs" xs) -> assoc .&& lunit .&& runit .=> foldr (@) e xs .== foldl (@) e xs) $-          \ih x xs -> [assoc, lunit, runit] |- foldr (@) e (x .: xs)-                                            =: x @ foldr (@) e xs    ?? ih-                                            =: x @ foldl (@) e xs    ?? helper-                                            =: foldl (@) (x @ e) xs  ?? runit-                                            =: foldl (@) x xs        ?? lunit-                                            =: foldl (@) (e @ x) xs-                                            =: foldl (@) e (x .: xs)-                                            =: qed---- * Another foldl-foldr correspondence---- | Given:------ @---        (x \<+> y) \<*> z = x \<+> (y \<*> z)---   and  x \<+> e = e \<*> x--- @------ Proves:------ @---    foldr (\<+>) e xs = foldl (\<*>) e xs--- @------ In Bird's Introduction to Functional Programming book (2nd edition) this is called the second duality theorem. We have:------ >>> foldrFoldl--- Inductive lemma: foldl over <*>/<+>---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- Inductive lemma: foldrFoldl---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] foldrFoldl-foldrFoldl :: IO Proof-foldrFoldl = runKD $ do--   let -- Declare the operators as uninterpreted functions-       (<+>) :: SA -> SB -> SB-       (<+>) = uninterpret "<+>"--       (<*>) :: SB -> SA -> SB-       (<*>) = uninterpret "<*>"--       -- The unit element-       e :: SB-       e = uninterpret "e"--   -- Assumptions about the operators-   let -- (x <+> y) <*> z == x <+> (y <*> z)-       assoc = quantifiedBool $ \(Forall @"x" x) (Forall @"y" y) (Forall @"z" z) -> (x <+> y) <*> z .== x <+> (y <*> z)--       -- x <+> e == e <*> x-       unit  = quantifiedBool $ \(Forall @"x" x) -> x <+> e .== e <*> x--   -- Helper: x <+> foldl (<*>) y xs == foldl (<*>) (x <+> y) xs-   helper <--      induct "foldl over <*>/<+>"-             (\(Forall @"xs" xs) (Forall @"x" x) (Forall @"y" y) -> assoc .=> x <+> foldl (<*>) y xs .== foldl (<*>) (x <+> y) xs) $-             -- Using z to avoid confusion with the variable x already present, following Bird.-             -- z3 can figure out the proper instantiation of ih so the at call is unnecessary, but being explicit is helpful.-             \ih z xs x y -> [assoc] |- x <+> foldl (<*>) y (z .: xs)-                                     =: x <+> foldl (<*>) (y <*> z) xs    ?? ih `at` (Inst @"x" x, Inst @"y" (y <*> z))-                                     =: foldl (<*>) (x <+> (y <*> z)) xs  ?? assoc-                                     =: foldl (<*>) ((x <+> y) <*> z) xs-                                     =: foldl (<*>) (x <+> y) (z .: xs)-                                     =: qed--   -- Final proof:-   induct "foldrFoldl"-          (\(Forall @"xs" xs) -> assoc .&& unit .=> foldr (<+>) e xs .== foldl (<*>) e xs) $-          \ih x xs -> [assoc, unit] |- foldr (<+>) e (x .: xs)-                                    =: x <+> foldr (<+>) e xs    ?? ih-                                    =: x <+> foldl (<*>) e xs    ?? helper-                                    =: foldl (<*>) (x <+> e) xs-                                    =: foldl (<*>) (e <*> x) xs-                                    =: foldl (<*>) e (x .: xs)-                                    =: qed---- * Bookkeeping law---- | Provided @f@ is associative and @a@ is its both left and right-unit:------ @foldr f a . concat == foldr f a . map (foldr f a)@------ We have:------ >>> bookKeeping--- Inductive lemma: foldBase---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- Inductive lemma: foldrOverAppend---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- Inductive lemma: bookKeeping---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Step: 6                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] bookKeeping------ NB. As of early 2025, we cannot express the above theorem in SBV directly, since it involves nested lambdas.--- (On the right hand side map has an argument that is represented as a foldr, which itself has a lambda.) As--- SMTLib moves to a higher-order logic, we intend to make such expressions readily expressable. In the mean time,--- we use an equivalent (albeit roundabout) version, where we define map-foldr combo as a recursive function ourselves.------ NB. This theorem does not hold if @f@ does not have a left-unit! Consider the input @[[], [x]]@. Left hand side reduces to--- @x@, while the right hand side reduces to: @f a x@. And unless @f@ is commutative or @a@ is not also a left-unit,--- then one can find a counter-example. (Aside: if both left and right units exist for a binary operator, then they--- are necessarily the same element, since @l = f l r = r@. So, an equivalent statement could simply say @f@ has--- both left and right units.) A concrete counter-example is:------ @---   data T = A | B | C------   f :: T -> T -> T---   f C A = A---   f C B = A---   f x _ = x--- @------ You can verify @f@ is associative. Also note that @C@ is the right-unit for @f@, but it isn't the left-unit.--- In fact, @f@ has no-left unit by the above argument. In this case, the bookkeeping law produces @B@ for--- the left-hand-side, and @A@ for the right-hand-side for the input @[[], [B]]@.-bookKeeping :: IO Proof-bookKeeping = runKD $ do-   let a :: SA-       a = uninterpret "a"--       f :: SA -> SA -> SA-       f = uninterpret "f"--       -- Fuse map (foldr f a) in the theorem into one call to avoid nested lambdas. See above note.-       mapFoldr :: SA -> SList [A] -> SList A-       mapFoldr = smtFunction "mapFoldr" $ \e xss -> ite (null xss)-                                                         nil-                                                         (foldr f e (head xss) .: mapFoldr e (tail xss))--   -- Assumptions about f-   let assoc = quantifiedBool $ \(Forall @"x" x) (Forall @"y" y) (Forall @"z" z) -> x `f` (y `f` z) .== (x `f` y) `f` z-       rUnit = quantifiedBool $ \(Forall @"x" x) -> x `f` a .== x-       lUnit = quantifiedBool $ \(Forall @"x" x) -> a `f` x .== x--   -- Helper:-   --   foldr f y xs = foldr f a xs `f` y-   helper <- induct "foldBase"-                    (\(Forall @"xs" xs) (Forall @"y" y) -> lUnit .&& assoc .=> foldr f y xs .== foldr f a xs `f` y) $-                    \ih x xs y -> [lUnit, assoc] |- foldr f y (x .: xs)-                                                 =: x `f` foldr f y xs          ?? ih-                                                 =: x `f` (foldr f a xs `f` y)-                                                 =: (x `f` foldr f a xs) `f` y-                                                 =: foldr f a (x .: xs) `f` y-                                                 =: qed--   foa <- use foldrOverAppend--   induct "bookKeeping"-          (\(Forall @"xss" xss) -> assoc .&& rUnit .&& lUnit .=> foldr f a (concat xss) .== foldr f a (mapFoldr a xss)) $-          \ih xs xss -> [assoc, rUnit, lUnit] |- foldr f a (concat (xs .: xss))-                                              =: foldr f a (xs ++ concat xss)-                                              ?? foa-                                              =: foldr f (foldr f a (concat xss)) xs-                                              ?? ih-                                              =: foldr f (foldr f a (mapFoldr a xss)) xs-                                              ?? helper `at` (Inst @"xs" xs, Inst @"y" (foldr f a (mapFoldr a xss)))-                                              =: foldr f a xs `f` foldr f a (mapFoldr a xss)-                                              =: foldr f a (foldr f a xs .: mapFoldr a xss)-                                              =: foldr f a (mapFoldr a (xs .: xss))-                                              =: qed---- * Filter-append---- | @filter p (xs ++ ys) == filter p xs ++ filter p ys@------ We have:------ >>> filterAppend (uninterpret "p")--- Inductive lemma: filterAppend---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] filterAppend-filterAppend :: (SA -> SBool) -> IO Proof-filterAppend p = runKD $-   induct "filterAppend"-          (\(Forall @"xs" xs) (Forall @"ys" ys) -> filter p xs ++ filter p ys .== filter p (xs ++ ys)) $-          \ih x xs ys -> [] |- filter p (x .: xs) ++ filter p ys-                            =: ite (p x) (x .: filter p xs) (filter p xs) ++ filter p ys-                            =: ite (p x) (x .: filter p xs ++ filter p ys) (filter p xs ++ filter p ys)  ?? ih-                            =: ite (p x) (x .: filter p (xs ++ ys)) (filter p (xs ++ ys))-                            =: filter p (x .: (xs ++ ys))-                            =: filter p ((x .: xs) ++ ys)-                            =: qed---- | @filter p (concat xss) == concatMap (filter p xss)@------ Similar to the book-keeping law, we cannot express this in SBV directly, since it involves a nested lambda.--- @concatMap (filter p)@ maps a higher-order function @filter p@, which itself has a nested lambda. So, we use--- our own merged definition. Hopefully we'll relax this as SMTLib gains more higher order features.------ We have:------ >>> filterConcat--- Inductive lemma: filterAppend---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- Inductive lemma: filterConcat---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] filterConcat-filterConcat :: IO Proof-filterConcat = runKD $ do-  let -- For an arbitrary uninterpreted prediate 'p':-      p :: SA -> SBool-      p = uninterpret "p"--      -- Fuse concatMap (filter p) in the theorem to avoid nested lambdas. See above note-      concatMapFilter :: (SA -> SBool) -> SList [A] -> SList A-      concatMapFilter pred = smtFunction "concatMapFilter" $ \xs -> ite (null xs)-                                                                        nil-                                                                        (filter pred (head xs) ++ concatMapFilter pred (tail xs))---  fa <- use $ filterAppend p--  induct "filterConcat"-         (\(Forall @"xss" xss) -> filter p (concat xss) .== concatMapFilter p xss) $-         \ih xs xss -> [] |- filter p (concat (xs .: xss))-                          =: filter p (xs ++ concat xss)           ?? fa-                          =: filter p xs ++ filter p (concat xss)  ?? ih-                          =: filter p xs ++ concatMapFilter p xss-                          =: concatMapFilter p (xs .: xss)-                          =: qed---- * Map and filter don't commute---- | In general, mapping and filtering operations do not commute. We'll see the kind of counter-example we get from SBV if--- we attempt to prove:------ >>> mapFilter `catch` (\(_ :: SomeException) -> pure ())--- Lemma: badMapFilter--- *** Failed to prove badMapFilter.--- Falsifiable. Counter-example:---   xs  = [A_3] :: [A]---   lhs = [A_0] :: [A]---   rhs =    [] :: [A]--- <BLANKLINE>---   f :: A -> A---   f _ = A_0--- <BLANKLINE>---   p :: A -> Bool---   p A_3 = True---   p _   = False------ As expected, the function @f@ maps everything to @A_0@, and the predicate @p@ only lets @A_3@ through. As shown in the--- counter-example, for the input @[A_3]@, left-hand-side filters nothing and the result is the singleton @A_0@. But the--- map on the right-hand side maps everything to @[A_0]@ and the filter gets rid of the elements, resulting in an empty list.-mapFilter :: IO ()-mapFilter = runKD $ do-   let f :: SA -> SA-       f = uninterpret "f"--       p :: SA -> SBool-       p = uninterpret "p"--   void $ lemma "badMapFilter"-                (\(Forall @"xs" xs) -> observe "lhs" (map f (filter p xs)) .== observe "rhs" (filter p (map f xs)))-                []---- * Partition---- | @fst (partition f xs) == filter f xs@------ >>> partition1--- Inductive lemma: partition1---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] partition1-partition1 :: IO Proof-partition1 = runKD $ do-   let f :: SA -> SBool-       f = uninterpret "f"--   induct "partition1"-          (\(Forall @"xs" xs) -> fst (partition f xs) .== filter f xs) $-          \ih x xs -> [] |- fst (partition f (x .: xs))-                         =: fst (let res = partition f xs-                                 in ite (f x)-                                        (tuple (x .: fst res, snd res))-                                        (tuple (fst res, x .: snd res)))-                         =: ite (f x) (x .: fst (partition f xs)) (fst (partition f xs)) ?? ih-                         =: ite (f x) (x .: filter f xs) (filter f xs)-                         =: filter f (x .: xs)-                         =: qed---- | @snd (partition f xs) == filter (not . f) xs@------ >>> partition2--- Inductive lemma: partition2---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] partition2-partition2 :: IO Proof-partition2 = runKD $ do-   let f :: SA -> SBool-       f = uninterpret "f"--   induct "partition2"-          (\(Forall @"xs" xs) -> snd (partition f xs) .== filter (sNot . f) xs) $-          \ih x xs -> [] |- snd (partition f (x .: xs))-                         =: snd (let res = partition f xs-                                 in ite (f x)-                                        (tuple (x .: fst res, snd res))-                                        (tuple (fst res, x .: snd res)))-                         =: ite (f x) (snd (partition f xs)) (x .: snd (partition f xs)) ?? ih-                         =: ite (f x) (filter (sNot . f) xs) (x .: filter (sNot . f) xs)-                         =: filter (sNot . f) (x .: xs)-                         =: qed---- * Take and drop---- | @take n (take m xs) = take (n `smin` m) xs@------ >>> take_take--- Lemma: take_take                        Q.E.D.--- [Proven] take_take-take_take :: IO Proof-take_take = runKD $-   lemma "take_take"-         (\(Forall @"xs" (xs :: SList A)) (Forall @"m" m) (Forall @"n" n) -> take n (take m xs) .== take (n `smin` m) xs)-         []----- | @n >= 0 && m >= 0 => drop n (drop m xs) = drop (n + m) xs@------ >>> drop_drop--- Lemma: drop_drop                        Q.E.D.--- [Proven] drop_drop-drop_drop :: IO Proof-drop_drop = runKD $-   lemma "drop_drop"-          (\(Forall @"n" n) (Forall @"m" m) (Forall @"xs" (xs :: SList A)) ->-                n .>= 0 .&& m .>= 0 .=> drop n (drop m xs) .== drop (n + m) xs)-          []---- | @take n xs ++ drop n xs == xs@------ >>> take_drop--- Lemma: take_drop                        Q.E.D.--- [Proven] take_drop-take_drop :: IO Proof-take_drop = runKD $-    lemma "take_drop"-           (\(Forall @"n" n) (Forall @"xs" (xs :: SList A)) -> take n xs ++ drop n xs .== xs)-           []---- | @n .> 0 => take n (x .: xs) = x .: take (n - 1) xs@------ >>> take_cons--- Lemma: take_cons                        Q.E.D.--- [Proven] take_cons-take_cons :: IO Proof-take_cons = runKD $-   lemma "take_cons"-         (\(Forall @"n" n) (Forall @"x" x) (Forall @"xs" (xs :: SList A)) -> n .> 0 .=> take n (x .: xs) .== x .: take (n - 1) xs)-         []---- | @take n (map f xs) == map f (take n xs)@------ >>> take_map--- Lemma: take_cons                        Q.E.D.--- Lemma: map1                             Q.E.D.--- Lemma: take_map.n <= 0                  Q.E.D.--- Inductive lemma: take_map.n > 0---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- Lemma: take_map                         Q.E.D.--- [Proven] take_map-take_map :: IO Proof-take_map = runKD $ do-    let f :: SA -> SB-        f = uninterpret "f"--    tc   <- use take_cons-    map1 <- lemma "map1" (\(Forall @"x" x) (Forall @"xs" xs) -> map f (x .: xs) .== f x .: map f xs) []--    h1 <- lemma "take_map.n <= 0"-                 (\(Forall @"xs" xs) (Forall @"n" n) -> n .<= 0 .=> take n (map f xs) .== map f (take n xs))-                 []--    h2 <- induct "take_map.n > 0"-                 (\(Forall @"xs" xs) (Forall @"n" n) -> n .> 0 .=> take n (map f xs) .== map f (take n xs)) $-                 \ih x xs n -> [n .> 0] |- take n (map f (x .: xs))-                                        =: take n (f x .: map f xs)-                                        =: f x .: take (n - 1) (map f xs) ?? ih   `at` Inst @"n" (n-1)-                                        =: f x .: map f (take (n - 1) xs) ?? map1 `at` (Inst @"x" x, Inst @"xs" (take (n - 1) xs))-                                        =: map f (x .: take (n - 1) xs)   ?? tc-                                        =: map f (take n (x .: xs))-                                        =: qed--    lemma "take_map" (\(Forall @"xs" xs) (Forall @"n" n) -> take n (map f xs) .== map f (take n xs)) [h1, h2]---- | @n .> 0 => drop n (x .: xs) = drop (n - 1) xs@------ >>> drop_cons (Proxy @A)--- Lemma: drop_cons                        Q.E.D.--- [Proven] drop_cons-drop_cons :: forall elt. SymVal elt => Proxy elt -> IO Proof-drop_cons _ = runKD $-   lemma "drop_cons"-         (\(Forall @"n" n) (Forall @"x" x) (Forall @"xs" (xs :: SList elt)) -> n .> 0 .=> drop n (x .: xs) .== drop (n - 1) xs)-         []---- | @drop n (map f xs) == map f (drop n xs)@------ >>> drop_map--- Lemma: drop_cons                        Q.E.D.--- Lemma: drop_cons                        Q.E.D.--- Lemma: drop_map.n <= 0                  Q.E.D.--- Inductive lemma: drop_map.n > 0---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- Lemma: drop_map---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] drop_map-drop_map :: IO Proof-drop_map = runKD $ do-   let f :: SA -> SB-       f = uninterpret "f"--   dcA <- use $ drop_cons (Proxy @A)-   dcB <- use $ drop_cons (Proxy @B)--   h1 <- lemma "drop_map.n <= 0"-               (\(Forall @"xs" xs) (Forall @"n" n) -> n .<= 0 .=> drop n (map f xs) .== map f (drop n xs))-               []--   h2 <- induct "drop_map.n > 0"-                (\(Forall @"xs" xs) (Forall @"n" n) -> n .> 0 .=> drop n (map f xs) .== map f (drop n xs)) $-                \ih x xs n -> [n .> 0] |- drop n (map f (x .: xs))-                                       =: drop n (f x .: map f xs)-                                       ?? dcB `at` (Inst @"n" n, Inst @"x" (f x), Inst @"xs" (map f xs))-                                       =: drop (n - 1) (map f xs)-                                       ?? ih `at` Inst @"n" (n-1)-                                       =: map f (drop (n - 1) xs)-                                       ?? dcA `at` (Inst @"n" n, Inst @"x" x, Inst @"xs" xs)-                                       =: map f (drop n (x .: xs))-                                       =: qed--   -- I'm a bit surprised that z3 can't deduce the following with a simple-lemma, which is essentially a simple case-split.-   -- But the good thing about calc is that it lets us direct the tool in precise ways that we'd like.-   calc "drop_map"-        (\(Forall @"xs" xs) (Forall @"n" n) -> drop n (map f xs) .== map f (drop n xs)) $-        \xs n -> [] |- let result = drop n (map f xs) .== map f (drop n xs)-                    in result-                    =: ite (n .<= 0) (n .<= 0 .=> result) (n .> 0 .=> result) ?? h1-                    =: ite (n .<= 0) sTrue                (n .> 0 .=> result) ?? h2-                    =: ite (n .<= 0) sTrue                sTrue-                    =: sTrue-                    =: qed---- | @n >= 0 ==> length (take n xs) = length xs \`min\` n@------ >>> length_take--- Lemma: length_take                      Q.E.D.--- [Proven] length_take-length_take :: IO Proof-length_take = runKD $-     lemma "length_take"-           (\(Forall @"n" n) (Forall @"xs" (xs :: SList A)) -> n .>= 0 .=> length (take n xs) .== length xs `smin` n)-           []---- | @n >= 0 ==> length (drop n xs) = (length xs - n) \`max\` 0@------ >>> length_drop--- Lemma: length_drop                      Q.E.D.--- [Proven] length_drop-length_drop :: IO Proof-length_drop = runKD $-     lemma "length_drop"-           (\(Forall @"n" n) (Forall @"xs" (xs :: SList A)) -> n .>= 0 .=> length (drop n xs) .== (length xs - n) `smax` 0)-           []---- | @length xs \<= n ==\> take n xs == xs@------ >>> take_all--- Lemma: take_all                         Q.E.D.--- [Proven] take_all-take_all :: IO Proof-take_all = runKD $-    lemma "take_all"-          (\(Forall @"n" n) (Forall @"xs" (xs :: SList A)) -> length xs .<= n .=> take n xs .== xs)-          []---- | @length xs \<= n ==\> drop n xs == nil@------ >>> drop_all--- Lemma: drop_all                         Q.E.D.--- [Proven] drop_all-drop_all :: IO Proof-drop_all = runKD $-    lemma "drop_all"-          (\(Forall @"n" n) (Forall @"xs" (xs :: SList A)) -> length xs .<= n .=> drop n xs .== nil)-          []---- | @take n (xs ++ ys) = (take n xs ++ take (n - length xs) ys)@------ >>> take_append--- Lemma: take_append---   Step: 1 (case split on xs)            Q.E.D.---   Result:                               Q.E.D.--- [Proven] take_append-take_append :: IO Proof-take_append = runKD $-    calc "take_append"-         (\(Forall @"n" n) (Forall @"xs" (xs :: SList A)) (Forall @"ys" ys) -> take n (xs ++ ys) .== take n xs ++ take (n - length xs) ys) $--         -- z3 requires an explicit split here on xs. cvc5 actually proves this out-of-the-box without any helping steps.-         \n (xs :: SList A) ys -> [] |- take n (xs ++ ys)-                                     ?? "case split on xs"-                                     =: ite (null xs)-                                            (take n ys)-                                            (take n (head xs .: (tail xs ++ ys)))-                                     =: qed---- | @drop n (xs ++ ys) = drop n xs ++ drop (n - length xs) ys@------ NB. As of Feb 2025, z3 struggles to prove this, but cvc5 gets it out-of-the-box.------ >>> drop_append--- Lemma: drop_append                      Q.E.D.--- [Proven] drop_append-drop_append :: IO Proof-drop_append = runKD $-    lemmaWith cvc5 "drop_append"-                   (\(Forall @"n" n) (Forall @"xs" (xs :: SList A)) (Forall @"ys" ys) -> drop n (xs ++ ys) .== drop n xs ++ drop (n - length xs) ys)-                   []---- * Summing via halving---- | We prove that summing a list can be done by halving the list, summing parts, and adding the results. The proof uses--- strong induction. We have:------ >>> sumHalves--- Inductive lemma: sumAppend---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Result:                               Q.E.D.--- Inductive lemma (strong): sumHalves---   Step: Measure is non-negative         Q.E.D.---   Step: 1 (2 way full case split)---     Step: 1.1                           Q.E.D.---     Step: 1.2 (2 way full case split)---       Step: 1.2.1                       Q.E.D.---       Step: 1.2.2.1                     Q.E.D.---       Step: 1.2.2.2                     Q.E.D.---       Step: 1.2.2.3                     Q.E.D.---       Step: 1.2.2.4                     Q.E.D.---       Step: 1.2.2.5                     Q.E.D.---       Step: 1.2.2.6 (simplify)          Q.E.D.---   Result:                               Q.E.D.--- [Proven] sumHalves-sumHalves :: IO Proof-sumHalves = runKD $ do--    let halvingSum :: SList Integer -> SInteger-        halvingSum = smtFunction "halvingSum" $ \xs -> ite (null xs .|| null (tail xs))-                                                           (sum xs)-                                                           (let (f, s) = splitAt (length xs `sDiv` 2) xs-                                                            in halvingSum f + halvingSum s)--        sum :: SList Integer -> SInteger-        sum = smtFunction "sum" $ \xs -> ite (null xs) 0 (head xs + sum (tail xs))--    helper <- induct "sumAppend"-                     (\(Forall @"xs" xs) (Forall @"ys" ys) -> sum (xs ++ ys) .== sum xs + sum ys) $-                     \ih x xs ys -> [] |- sum (x .: xs ++ ys)-                                       =: x + sum (xs ++ ys)-                                       ?? ih-                                       =: x + sum xs + sum ys-                                       =: sum (x .: xs) + sum ys-                                       =: qed--    -- Use strong induction to prove the theorem. CVC5 solves this with ease, but z3 struggles.-    sInductWith cvc5 "sumHalves"-      (\(Forall @"xs" xs) -> halvingSum xs .== sum xs)-      (length @Integer) $-      \ih xs -> [] |- halvingSum xs-                   =: split xs qed-                            (\a as -> split as qed-                                            (\b bs -> halvingSum (a .: b .: bs)-                                                   =: let (f, s) = splitAt (length (a .: b .: bs) `sDiv` 2) (a .: b .: bs)-                                                   in halvingSum f + halvingSum s-                                                   ?? ih `at` Inst @"xs" f-                                                   =: sum f + halvingSum s-                                                   ?? ih `at` Inst @"xs" s-                                                   =: sum f + sum s-                                                   ?? helper `at` (Inst @"xs" f, Inst @"ys" s)-                                                   =: sum (f ++ s)-                                                   ?? "simplify"-                                                   =: sum (a .: b .: bs)-                                                   =: qed))---- * Zip---- | @length xs = length ys ⟹ map fst (zip xs ys) = xs@------ >>> map_fst_zip--- Inductive lemma: map_fst_zip---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] map_fst_zip-map_fst_zip :: IO Proof-map_fst_zip = runKD $-   induct "map_fst_zip"-          (\(Forall @"xs" (xs :: SList A), Forall @"ys" (ys :: SList B)) -> length xs .== length ys .=> map fst (zip xs ys) .== xs) $-          \ih (x :: SA, xs, y :: SB, ys) -> [length (x .: xs) .== length (y .: ys)]-                                         |- map fst (zip (x .: xs) (y .: ys))-                                         =: map fst (tuple (x, y) .: zip xs ys)-                                         =: fst (tuple (x, y)) .: map fst (zip xs ys)-                                         =: x .: map fst (zip xs ys)-                                         ?? ih-                                         =: x .: xs-                                         =: qed---- | @length xs = length ys ⟹ map snd (zip xs ys) = xs@------ >>> map_snd_zip--- Inductive lemma: map_snd_zip---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] map_snd_zip-map_snd_zip :: IO Proof-map_snd_zip = runKD $-   induct "map_snd_zip"-          (\(Forall @"xs" (xs :: SList A), Forall @"ys" (ys :: SList B)) -> length xs .== length ys .=> map snd (zip xs ys) .== ys) $-          \ih (x :: SA, xs, y :: SB, ys) -> [length (x .: xs) .== length (y .: ys)]-                                         |- map snd (zip (x .: xs) (y .: ys))-                                         =: map snd (tuple (x, y) .: zip xs ys)-                                         =: snd (tuple (x, y)) .: map snd (zip xs ys)-                                         =: y .: map snd (zip xs ys)-                                         ?? ih-                                         =: y .: ys-                                         =: qed---- | @map fst (zip xs ys) = take (min (length xs) (length ys)) xs@------ >>> map_fst_zip_take--- Lemma: take_cons                        Q.E.D.--- Inductive lemma: map_fst_zip_take---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] map_fst_zip_take-map_fst_zip_take :: IO Proof-map_fst_zip_take = runKD $ do-   tc <- use take_cons--   induct "map_fst_zip_take"-          (\(Forall @"xs" (xs :: SList A), Forall @"ys" (ys :: SList B)) -> map fst (zip xs ys) .== take (length xs `smin` length ys) xs) $-          \ih (x :: SA, xs, y :: SB, ys) -> []-                                         |- map fst (zip (x .: xs) (y .: ys))-                                         =: map fst (tuple (x, y) .: zip xs ys)-                                         =: x .: map fst (zip xs ys)-                                         ?? ih-                                         =: x .: take (length xs `smin` length ys) xs-                                         ?? tc-                                         =: take (1 + (length xs `smin` length ys)) (x .: xs)-                                         =: take (length (x .: xs) `smin` length (y .: ys)) (x .: xs)-                                         =: qed---- | @map snd (zip xs ys) = take (min (length xs) (length ys)) xs@------ >>> map_snd_zip_take--- Lemma: take_cons                        Q.E.D.--- Inductive lemma: map_snd_zip_take---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] map_snd_zip_take-map_snd_zip_take :: IO Proof-map_snd_zip_take = runKD $ do-   tc <- use take_cons--   induct "map_snd_zip_take"-          (\(Forall @"xs" (xs :: SList A), Forall @"ys" (ys :: SList B)) -> map snd (zip xs ys) .== take (length xs `smin` length ys) ys) $-          \ih (x :: SA, xs, y :: SB, ys) -> []-                                         |- map snd (zip (x .: xs) (y .: ys))-                                         =: map snd (tuple (x, y) .: zip xs ys)-                                         =: y .: map snd (zip xs ys)-                                         ?? ih-                                         =: y .: take (length xs `smin` length ys) ys-                                         ?? tc-                                         =: take (1 + (length xs `smin` length ys)) (y .: ys)-                                         =: take (length (x .: xs) `smin` length (y .: ys)) (y .: ys)-                                         =: qed--{- HLint ignore reverseReverse "Redundant reverse" -}-{- HLint ignore allAny         "Use and"           -}-{- HLint ignore foldrMapFusion "Fuse foldr/map"    -}-{- HLint ignore filterConcat   "Move filter"       -}-{- HLint ignore module         "Use camelCase"     -}-{- HLint ignore module         "Use first"         -}-{- HLint ignore module         "Use second"        -}-{- HLint ignore module         "Use zipWith"       -}
− Documentation/SBV/Examples/KnuckleDragger/MergeSort.hs 
@@ -1,311 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.MergeSort--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Proving merge sort correct.--------------------------------------------------------------------------------{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE TypeAbstractions    #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.MergeSort where--import Data.SBV-import Data.SBV.Tools.KnuckleDragger--import Prelude hiding (null, length, head, tail, elem, splitAt, (++), take, drop)-import Data.SBV.List---- * Merge sort---- | Merge two already sorted lists into another-merge :: SList Integer -> SList Integer -> SList Integer-merge = smtFunction "merge" $ \l r -> ite (null l) r-                                    $ ite (null r) l-                                    $ let (a, as) = uncons l-                                          (b, bs) = uncons r-                                      in ite (a .<= b) (a .: merge as r) (b .: merge l bs)---- | Merge sort, using 'merge' above to successively sort halved input-mergeSort :: SList Integer -> SList Integer-mergeSort = smtFunction "mergeSort" $ \l -> ite (length l .<= 1) l-                                              $ let (h1, h2) = splitAt (length l `sEDiv` 2) l-                                                in merge (mergeSort h1) (mergeSort h2)--- * Helper functions---- | A predicate testing whether a given list is non-decreasing.-nonDecreasing :: SList Integer -> SBool-nonDecreasing = smtFunction "nonDecreasing" $ \l ->  null l .|| null (tail l)-                                                 .|| let (x, l') = uncons l-                                                         (y, _)  = uncons l'-                                                     in x .<= y .&& nonDecreasing l'---- | Count the number of occurrences of an element in a list-count :: SInteger -> SList Integer -> SInteger-count = smtFunction "count" $ \e l -> ite (null l)-                                          0-                                          (let (x, xs) = uncons l-                                               cxs     = count e xs-                                           in ite (e .== x) (1 + cxs) cxs)---- | Are two lists permutations of each other?-isPermutation :: SList Integer -> SList Integer -> SBool-isPermutation xs ys = quantifiedBool (\(Forall @"x" x) -> count x xs .== count x ys)---- * Correctness proof---- | Correctness of merge-sort.------ We have:------ >>> correctness--- Lemma: nonDecrInsert                                        Q.E.D.--- Inductive lemma (strong): mergeKeepsSort---   Step: Measure is non-negative                             Q.E.D.---   Step: 1 (4 way full case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2                                               Q.E.D.---     Step: 1.3                                               Q.E.D.---     Step: 1.4.1 (unfold merge)                              Q.E.D.---     Step: 1.4.2 (2 way case split)---       Step: 1.4.2.1.1 (case split)                          Q.E.D.---       Step: 1.4.2.1.2                                       Q.E.D.---       Step: 1.4.2.2.1 (case split)                          Q.E.D.---       Step: 1.4.2.2.2                                       Q.E.D.---       Step: 1.4.2.Completeness                              Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma (strong): sortNonDecreasing---   Step: Measure is non-negative                             Q.E.D.---   Step: 1 (2 way full case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2.1 (unfold)                                    Q.E.D.---     Step: 1.2.2 (push nonDecreasing down)                   Q.E.D.---     Step: 1.2.3                                             Q.E.D.---     Step: 1.2.4                                             Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma (strong): mergeCount---   Step: Measure is non-negative                             Q.E.D.---   Step: 1 (4 way full case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2                                               Q.E.D.---     Step: 1.3                                               Q.E.D.---     Step: 1.4.1 (unfold merge)                              Q.E.D.---     Step: 1.4.2 (push count inside)                         Q.E.D.---     Step: 1.4.3 (unfold count, twice)                       Q.E.D.---     Step: 1.4.4                                             Q.E.D.---     Step: 1.4.5                                             Q.E.D.---     Step: 1.4.6 (unfold count in reverse, twice)            Q.E.D.---     Step: 1.4.7 (simplify)                                  Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: countAppend---   Step: Base                                                Q.E.D.---   Step: 1                                                   Q.E.D.---   Step: 2 (unfold count)                                    Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4 (simplify)                                        Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: take_drop                                            Q.E.D.--- Lemma: takeDropCount---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma (strong): sortIsPermutation---   Step: Measure is non-negative                             Q.E.D.---   Step: 1 (2 way full case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2.1 (unfold mergeSort)                          Q.E.D.---     Step: 1.2.2 (push count down, simplify, rearrange)      Q.E.D.---     Step: 1.2.3                                             Q.E.D.---     Step: 1.2.4                                             Q.E.D.---     Step: 1.2.5                                             Q.E.D.---     Step: 1.2.6                                             Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: mergeSortIsCorrect                                   Q.E.D.--- [Proven] mergeSortIsCorrect-correctness :: IO Proof-correctness = runKDWith z3{kdOptions = (kdOptions z3) {ribbonLength = 60}} $ do--    ---------------------------------------------------------------------------------------------    -- Part I. Prove that the output of merge sort is non-decreasing.-    ----------------------------------------------------------------------------------------------    nonDecrIns <- lemma "nonDecrInsert"-                        (\(Forall @"x" x) (Forall @"ys" ys) -> nonDecreasing ys .&& sNot (null ys) .&& x .<= head ys-                                                           .=> nonDecreasing (x .: ys))-                        []--    mergeKeepsSort <--        sInductWith cvc5 "mergeKeepsSort"-           (\(Forall @"xs" xs) (Forall @"ys" ys) -> nonDecreasing xs .&& nonDecreasing ys .=> nonDecreasing (merge xs ys))-           (\(xs :: SList Integer) (ys :: SList Integer) -> (length xs, length ys)) $-           \ih xs ys -> [nonDecreasing xs, nonDecreasing ys]-                     |- split2 (xs, ys)-                               trivial           -- when both xs and ys are empty.  Trivial.-                               trivial           -- when xs is empty, but ys isn't. Trivial.-                               trivial           -- when ys is empty, but xs isn't. Trivial.-                               (\(a, as) (b, bs) ->-                                     nonDecreasing (merge (a .: as) (b .: bs))-                                  ?? "unfold merge"-                                  =: nonDecreasing (ite (a .<= b)-                                                        (a .: merge as (b .: bs))-                                                        (b .: merge (a .: as) bs))-                                  ?? "case split"-                                  =: cases [ a .<= b ==> nonDecreasing (a .: merge as (b .: bs))-                                                      ?? [ ih         `at` (Inst @"xs" as, Inst @"ys" (b .: bs))-                                                         , nonDecrIns `at` (Inst @"x" a, Inst @"ys" (merge as (b .: bs)))-                                                         ]-                                                      =: sTrue-                                                      =: qed-                                           , a .> b  ==> nonDecreasing (b .: merge (a .: as) bs)-                                                      ?? [ ih         `at` (Inst @"xs" (a .: as), Inst @"ys" bs)-                                                         , nonDecrIns `at` (Inst @"x" b, Inst @"ys" (merge (a .: as) bs))-                                                         ]-                                                      =: sTrue-                                                      =: qed-                                           ])--    sortNonDecreasing <--        sInduct "sortNonDecreasing"-                (\(Forall @"xs" xs) -> nonDecreasing (mergeSort xs))-                (length @Integer) $-                \ih xs -> [] |- split xs-                                      qed-                                      (\e es -> nonDecreasing (mergeSort (e .: es))-                                             ?? "unfold"-                                             =: let (h1, h2) = splitAt (length (e .: es) `sEDiv` 2) (e .: es)-                                                in nonDecreasing (ite (length (e .: es) .<= 1)-                                                                      (e .: es)-                                                                      (merge (mergeSort h1) (mergeSort h2)))-                                             ?? "push nonDecreasing down"-                                             =: ite (length (e .: es) .<= 1)-                                                    (nonDecreasing (e .: es))-                                                    (nonDecreasing (merge (mergeSort h1) (mergeSort h2)))-                                             ?? ih `at` Inst @"xs" es-                                             =: ite (length (e .: es) .<= 1)-                                                    sTrue-                                                    (nonDecreasing (merge (mergeSort h1) (mergeSort h2)))-                                             ?? [ ih `at` Inst @"xs" h1-                                                , ih `at` Inst @"xs" h2-                                                , mergeKeepsSort `at` (Inst @"xs" (mergeSort h1), Inst @"ys" (mergeSort h2))-                                                ]-                                             =: sTrue-                                             =: qed)--    ---------------------------------------------------------------------------------------------    -- Part II. Prove that the output of merge sort is a permuation of its input-    ---------------------------------------------------------------------------------------------    mergeCount <--        sInduct "mergeCount"-                (\(Forall @"xs" xs) (Forall @"ys" ys) (Forall @"e" e) -> count e (merge xs ys) .== count e xs + count e ys)-                (\(xs :: SList Integer) (ys :: SList Integer) (_e :: SInteger) -> (length xs, length ys)) $-                \ih as bs e -> [] |--                        split2 (as, bs)-                               trivial-                               trivial-                               trivial-                               (\(x, xs) (y, ys) -> count e (merge (x .: xs) (y .: ys))-                                                 ?? "unfold merge"-                                                 =: count e (ite (x .<= y)-                                                                 (x .: merge xs (y .: ys))-                                                                 (y .: merge (x .: xs) ys))-                                                 ?? "push count inside"-                                                 =: ite (x .<= y)-                                                        (count e (x .: merge xs (y .: ys)))-                                                        (count e (y .: merge (x .: xs) ys))-                                                 ?? "unfold count, twice"-                                                 =: ite (x .<= y)-                                                        (let r = count e (merge xs (y .: ys)) in ite (e .== x) (1+r) r)-                                                        (let r = count e (merge (x .: xs) ys) in ite (e .== y) (1+r) r)-                                                 ?? ih `at` (Inst @"xs" xs, Inst @"ys" (y .: ys), Inst @"e" e)-                                                 =: ite (x .<= y)-                                                        (let r = count e xs + count e (y .: ys) in ite (e .== x) (1+r) r)-                                                        (let r = count e (merge (x .: xs) ys) in ite (e .== y) (1+r) r)-                                                 ?? ih `at` (Inst @"xs" (x .: xs), Inst @"ys" ys, Inst @"e" e)-                                                 =: ite (x .<= y)-                                                        (let r = count e xs + count e (y .: ys) in ite (e .== x) (1+r) r)-                                                        (let r = count e (x .: xs) + count e ys in ite (e .== y) (1+r) r)-                                                 ?? "unfold count in reverse, twice"-                                                 =: ite (x .<= y)-                                                        (count e (x .: xs) + count e (y .: ys))-                                                        (count e (x .: xs) + count e (y .: ys))-                                                 ?? "simplify"-                                                 =: count e (x .: xs) + count e (y .: ys)-                                                 =: qed)--    countAppend <--      induct "countAppend"-             (\(Forall @"xs" xs) (Forall @"ys" ys) (Forall @"e" e) -> count e (xs ++ ys) .== count e xs + count e ys) $-             \ih x xs ys e -> [] |- count e ((x .: xs) ++ ys)-                                 =: count e (x .: (xs ++ ys))-                                 ?? "unfold count"-                                 =: (let r = count e (xs ++ ys) in ite (e .== x) (1+r) r)-                                 ?? ih `at` (Inst @"ys" ys, Inst @"e" e)-                                 =: (let r = count e xs + count e ys in ite (e .== x) (1+r) r)-                                 ?? "simplify"-                                 =: count e (x .: xs) + count e ys-                                 =: qed--    takeDropCount <- do--       takeDrop <- lemma "take_drop"-                         (\(Forall @"n" n) (Forall @"xs" (xs :: SList Integer)) -> take n xs ++ drop n xs .== xs)-                         []--       calc "takeDropCount"-            (\(Forall @"xs" xs) (Forall @"n" n) (Forall @"e" e) -> count e (take n xs) + count e (drop n xs) .== count e xs) $-            \xs n e -> [] |- count e (take n xs) + count e (drop n xs)-                          ?? countAppend `at` (Inst @"xs" (take n xs), Inst @"ys" (drop n xs), Inst @"e" e)-                          =: count e (take n xs ++ drop n xs)-                          ?? takeDrop-                          =: count e xs-                          =: qed--    sortIsPermutation <--        sInductWith cvc5 "sortIsPermutation"-                (\(Forall @"xs" xs) (Forall @"e" e) -> count e xs .== count e (mergeSort xs))-                (\(xs :: SList Integer) (_e :: SInteger) -> length xs) $-                \ih as e -> [] |- split as-                                        qed-                                        (\x xs -> count e (mergeSort (x .: xs))-                                               ?? "unfold mergeSort"-                                               =: count e (ite (length (x .: xs) .<= 1)-                                                               (x .: xs)-                                                               (let (h1, h2) = splitAt (length (x .: xs) `sEDiv` 2) (x .: xs)-                                                                in merge (mergeSort h1) (mergeSort h2)))-                                               ?? "push count down, simplify, rearrange"-                                               =: let (h1, h2) = splitAt (length (x .: xs) `sEDiv` 2) (x .: xs)-                                               in ite (null xs)-                                                      (count e (singleton x))-                                                      (count e (merge (mergeSort h1) (mergeSort h2)))-                                               ?? mergeCount `at` (Inst @"xs" (mergeSort h1), Inst @"ys" (mergeSort h2), Inst @"e" e)-                                               =: ite (null xs)-                                                      (count e (singleton x))-                                                      (count e (mergeSort h1) + count e (mergeSort h2))-                                               ?? ih `at` (Inst @"xs" h1, Inst @"e" e)-                                               =: ite (null xs)-                                                      (count e (singleton x))-                                                      (count e h1 + count e (mergeSort h2))-                                               ?? ih `at` (Inst @"xs" h2, Inst @"e" e)-                                               =: ite (null xs)-                                                      (count e (singleton x))-                                                      (count e h1 + count e h2)-                                               ?? takeDropCount `at` (Inst @"xs" (x .: xs), Inst @"n" (length (x .: xs) `sEDiv` 2), Inst @"e" e)-                                               =: ite (null xs)-                                                      (count e (singleton x))-                                                      (count e (x .: xs))-                                               =: qed)--    ---------------------------------------------------------------------------------------------    -- Put the two parts together for the final proof-    ---------------------------------------------------------------------------------------------    lemma "mergeSortIsCorrect"-          (\(Forall @"xs" xs) -> let out = mergeSort xs in nonDecreasing out .&& isPermutation xs out)-          [sortNonDecreasing, sortIsPermutation]
− Documentation/SBV/Examples/KnuckleDragger/Numeric.hs 
@@ -1,194 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.Numeric--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Example use of inductive KnuckleDragger proofs, over integers.--------------------------------------------------------------------------------{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeAbstractions    #-}-{-# LANGUAGE TypeApplications    #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.Numeric where--import Prelude hiding (sum, length)--import Data.SBV-import Data.SBV.Tools.KnuckleDragger--#ifdef DOCTEST--- $setup--- >>> :set -XScopedTypeVariables--- >>> import Control.Exception-#endif---- | Prove that sum of constants @c@ from @0@ to @n@ is @n*c@.------ We have:------ >>> sumConstProof--- Inductive lemma: sumConst_correct---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] sumConst_correct-sumConstProof :: IO Proof-sumConstProof = runKD $ do-   let c :: SInteger-       c = uninterpret "c"--       sum :: SInteger -> SInteger-       sum = smtFunction "sum" $ \n -> ite (n .== 0) 0 (c + sum (n - 1))--       spec :: SInteger -> SInteger-       spec n = c * n--   induct "sumConst_correct"-          (\(Forall @"n" n) -> n .>= 0 .=> sum n .== spec n) $-          \ih n -> [n .>= 0] |- sum (n+1)-                             =: c + sum n  ?? ih-                             =: c + spec n-                             =: c + c*n-                             =: c*(n+1)-                             =: spec (n+1)-                             =: qed---- | Prove that sum of numbers from @0@ to @n@ is @n*(n-1)/2@.------ >>> sumProof--- Inductive lemma: sum_correct---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] sum_correct-sumProof :: IO Proof-sumProof = runKD $ do-   let sum :: SInteger -> SInteger-       sum = smtFunction "sum" $ \n -> ite (n .<= 0) 0 (n + sum (n - 1))--       spec :: SInteger -> SInteger-       spec n = (n * (n+1)) `sDiv` 2--       p :: SInteger -> SBool-       p n = sum n .== spec n--   induct "sum_correct"-          (\(Forall @"n" n) -> n .>= 0 .=> p n) $-          \ih n -> [n .>= 0] |- sum (n+1)-                             =: n+1 + sum n  ?? ih-                             =: n+1 + spec n-                             =: spec (n+1)-                             =: qed---- | Prove that sum of square of numbers from @0@ to @n@ is @n*(n+1)*(2n+1)/6@.------ >>> sumSquareProof--- Inductive lemma: sumSquare_correct---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] sumSquare_correct-sumSquareProof :: IO Proof-sumSquareProof = runKD $ do-   let sumSquare :: SInteger -> SInteger-       sumSquare = smtFunction "sumSquare" $ \n -> ite (n .<= 0) 0 (n * n + sumSquare (n - 1))--       spec :: SInteger -> SInteger-       spec n = (n * (n+1) * (2*n+1)) `sDiv` 6--       p :: SInteger -> SBool-       p n = sumSquare n .== spec n--   induct "sumSquare_correct"-          (\(Forall @"n" n) -> n .>= 0 .=> p n) $-          \ih n -> [n .>= 0] |- sumSquare (n+1)-                             =: (n+1)*(n+1) + sumSquare n ?? ih-                             =: (n+1)*(n+1) + spec n-                             =: spec (n+1)-                             =: qed---- | Prove that @11^n - 4^n@ is always divisible by 7.------ NB. As of Feb 2025, z3 struggles with the inductive step in this proof, but cvc5 performs just fine.------ We have:------ >>> elevenMinusFour--- Lemma: powN                             Q.E.D.--- Inductive lemma: elevenMinusFour---   Step: Base                            Q.E.D.---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Step: 3                               Q.E.D.---   Step: 4                               Q.E.D.---   Step: 5                               Q.E.D.---   Step: 6                               Q.E.D.---   Step: 7                               Q.E.D.---   Step: 8                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] elevenMinusFour-elevenMinusFour :: IO Proof-elevenMinusFour = runKD $ do-   let pow :: SInteger -> SInteger -> SInteger-       pow = smtFunction "pow" $ \x y -> ite (y .== 0) 1 (x * pow x (y - 1))--       emf :: SInteger -> SBool-       emf n = 7 `sDivides` (11 `pow` n - 4 `pow` n)--   -- helper-   powN <- lemma "powN" (\(Forall @"x" x) (Forall @"n" n) -> n .>= 0 .=> x `pow` (n+1) .== x * x `pow` n) []--   inductWith cvc5 "elevenMinusFour"-          (\(Forall @"n" n) -> n .>= 0 .=> emf n) $-          \ih n -> [n .>= 0]-                |- emf (n+1)-                =: 7 `sDivides` (11 `pow` (n+1) - 4 `pow` (n+1))-                ?? powN `at` (Inst @"x" (11 :: SInteger), Inst @"n" n)-                =: 7 `sDivides` (11 * 11 `pow` n - 4 `pow` (n+1))-                ?? powN `at` (Inst @"x" ( 4 :: SInteger), Inst @"n" n)-                =: 7 `sDivides` (11 * 11 `pow` n - 4 * 4 `pow` n)-                =: 7 `sDivides` (7 * 11 `pow` n + 4 * 11 `pow` n - 4 * 4 `pow` n)-                =: 7 `sDivides` (7 * 11 `pow` n + 4 * (11 `pow` n - 4 `pow` n))-                ?? ih-                =: let x = some "x" (\v -> 7*v .== 11 `pow` n - 4 `pow` n)   -- Apply the IH and grab the witness for it-                in 7 `sDivides` (7 * 11 `pow` n + 4 * 7 * x)-                =: 7 `sDivides` (7 * (11 `pow` n + 4 * x))-                =: sTrue-                =: qed---- | A negative example: The regular inductive proof on integers (i.e., proving at @0@, assuming at @n@ and proving at--- @n+1@ will not allow you to conclude things when @n < 0@. The following example demonstrates this with the most--- obvious example:------ >>> badNonNegative `catch` (\(_ :: SomeException) -> pure ())--- Inductive lemma: badNonNegative---   Step: Base                            Q.E.D.---   Step: 1--- *** Failed to prove badNonNegative.1.--- Falsifiable. Counter-example:---   n = -2 :: Integer-badNonNegative :: IO ()-badNonNegative = runKD $ do-    _ <- induct "badNonNegative"-                (\(Forall @"n" (n :: SInteger)) -> n .>= 0) $-                \ih n -> [] |- n + 1 .>= (0 :: SInteger)-                            ?? ih-                            =: sTrue-                            =: qed-    pure ()
− Documentation/SBV/Examples/KnuckleDragger/QuickSort.hs 
@@ -1,661 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.QuickSort--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Proving quick sort correct. The proof here closely follows the development--- given by Tobias Nipkow, in his paper  "Term Rewriting and Beyond -- Theorem--- Proving in Isabelle," published in Formal Aspects of Computing 1: 320-338--- back in 1989.--------------------------------------------------------------------------------{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE TypeAbstractions    #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.QuickSort where--import Prelude hiding (null, length, (++), tail, all, fst, snd, elem)-import Control.Monad.Trans (liftIO)--import Data.SBV-import Data.SBV.List hiding (partition)-import Data.SBV.Tuple-import Data.SBV.Tools.KnuckleDragger---- * Quick sort---- | Quick-sort, using the first element as pivot.-quickSort :: SList Integer -> SList Integer-quickSort = smtFunction "quickSort" $ \l -> ite (null l)-                                                nil-                                                (let (x,  xs) = uncons l-                                                     (lo, hi) = untuple (partition x xs)-                                                 in  quickSort lo ++ singleton x ++ quickSort hi)---- | We define @partition@ as an explicit function. Unfortunately, we can't just replace this--- with @\pivot xs -> Data.List.SBV.partition (.< pivot) xs@ because that would create a firstified version of partition--- with a free-variable captured, which isn't supported due to higher-order limitations in SMTLib.-partition :: SInteger -> SList Integer -> STuple [Integer] [Integer]-partition = smtFunction "partition" $ \pivot xs -> ite (null xs)-                                                       (tuple (nil, nil))-                                                       (let (a,  as) = uncons xs-                                                            (lo, hi) = untuple (partition pivot as)-                                                        in ite (a .< pivot)-                                                               (tuple (a .: lo, hi))-                                                               (tuple (lo, a .: hi)))---- * Helper functions---- | A predicate testing whether a given list is non-decreasing.-nonDecreasing :: SList Integer -> SBool-nonDecreasing = smtFunction "nonDecreasing" $ \l ->  null l .|| null (tail l)-                                                 .|| let (x, l') = uncons l-                                                         (y, _)  = uncons l'-                                                     in x .<= y .&& nonDecreasing l'---- | Count the number of occurrences of an element in a list-count :: SInteger -> SList Integer -> SInteger-count = smtFunction "count" $ \e l -> ite (null l)-                                          0-                                          (let (x, xs) = uncons l-                                               cxs     = count e xs-                                           in ite (e .== x) (1 + cxs) cxs)---- | Are two lists permutations of each other?-isPermutation :: SList Integer -> SList Integer -> SBool-isPermutation xs ys = quantifiedBool (\(Forall @"x" x) -> count x xs .== count x ys)---- * Correctness proof---- | Correctness of quick-sort.------ We have:------ >>> correctness--- Inductive lemma: lltCorrect---   Step: Base                                                Q.E.D.---   Step: 1                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: lgeCorrect---   Step: Base                                                Q.E.D.---   Step: 1                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: countNonNegative---   Step: Base                                                Q.E.D.---   Step: 1 (2 way case split)---     Step: 1.1.1                                             Q.E.D.---     Step: 1.1.2                                             Q.E.D.---     Step: 1.2.1                                             Q.E.D.---     Step: 1.2.2                                             Q.E.D.---     Step: 1.Completeness                                    Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: countElem---   Step: Base                                                Q.E.D.---   Step: 1 (2 way case split)---     Step: 1.1.1                                             Q.E.D.---     Step: 1.1.2                                             Q.E.D.---     Step: 1.2.1                                             Q.E.D.---     Step: 1.2.2                                             Q.E.D.---     Step: 1.Completeness                                    Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: elemCount---   Step: Base                                                Q.E.D.---   Step: 1 (2 way case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2.1                                             Q.E.D.---     Step: 1.2.2                                             Q.E.D.---     Step: 1.Completeness                                    Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: sublistCorrect---   Step: 1                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: sublistElem---   Step: 1                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: sublistTail                                          Q.E.D.--- Lemma: permutationImpliesSublist                            Q.E.D.--- Inductive lemma: lltSublist---   Step: Base                                                Q.E.D.---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: lltPermutation---   Step: 1                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: lgeSublist---   Step: Base                                                Q.E.D.---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: lgePermutation---   Step: 1                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: partitionFstLT---   Step: Base                                                Q.E.D.---   Step: 1                                                   Q.E.D.---   Step: 2 (push llt down)                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: partitionSndGE---   Step: Base                                                Q.E.D.---   Step: 1                                                   Q.E.D.---   Step: 2 (push lge down)                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma (strong): partitionNotLongerFst---   Step: Measure is non-negative                             Q.E.D.---   Step: 1 (2 way full case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2.1                                             Q.E.D.---     Step: 1.2.2 (simplify)                                  Q.E.D.---     Step: 1.2.3                                             Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma (strong): partitionNotLongerSnd---   Step: Measure is non-negative                             Q.E.D.---   Step: 1 (2 way full case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2.1                                             Q.E.D.---     Step: 1.2.2 (simplify)                                  Q.E.D.---     Step: 1.2.3                                             Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: countAppend---   Step: Base                                                Q.E.D.---   Step: 1                                                   Q.E.D.---   Step: 2 (unfold count)                                    Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4 (simplify)                                        Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma: countPartition---   Step: Base                                                Q.E.D.---   Step: 1 (expand partition)                                Q.E.D.---   Step: 2 (push countTuple down)                            Q.E.D.---   Step: 3 (2 way case split)---     Step: 3.1.1                                             Q.E.D.---     Step: 3.1.2 (simplify)                                  Q.E.D.---     Step: 3.1.3                                             Q.E.D.---     Step: 3.2.1                                             Q.E.D.---     Step: 3.2.2 (simplify)                                  Q.E.D.---     Step: 3.2.3                                             Q.E.D.---     Step: 3.Completeness                                    Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma (strong): sortCountsMatch---   Step: Measure is non-negative                             Q.E.D.---   Step: 1 (2 way full case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2.1                                             Q.E.D.---     Step: 1.2.2 (expand quickSort)                          Q.E.D.---     Step: 1.2.3 (push count down)                           Q.E.D.---     Step: 1.2.4                                             Q.E.D.---     Step: 1.2.5                                             Q.E.D.---     Step: 1.2.6 (IH on lo)                                  Q.E.D.---     Step: 1.2.7 (IH on hi)                                  Q.E.D.---     Step: 1.2.8                                             Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: sortIsPermutation                                    Q.E.D.--- Inductive lemma: nonDecreasingMerge---   Step: Base                                                Q.E.D.---   Step: 1 (2 way full case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2.1                                             Q.E.D.---     Step: 1.2.2                                             Q.E.D.---     Step: 1.2.3                                             Q.E.D.---   Result:                                                   Q.E.D.--- Inductive lemma (strong): sortIsNonDecreasing---   Step: Measure is non-negative                             Q.E.D.---   Step: 1 (2 way full case split)---     Step: 1.1                                               Q.E.D.---     Step: 1.2.1                                             Q.E.D.---     Step: 1.2.2 (expand quickSort)                          Q.E.D.---     Step: 1.2.3 (push nonDecreasing down)                   Q.E.D.---     Step: 1.2.4                                             Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: quickSortIsCorrect                                   Q.E.D.--- == Dependencies:--- quickSortIsCorrect---  ├╴sortIsPermutation---  │  └╴sortCountsMatch---  │     ├╴countAppend (x2)---  │     ├╴partitionNotLongerFst---  │     ├╴partitionNotLongerSnd---  │     └╴countPartition---  └╴sortIsNonDecreasing---     ├╴partitionNotLongerFst---     ├╴partitionNotLongerSnd---     ├╴partitionFstLT---     ├╴partitionSndGE---     ├╴sortIsPermutation (x2)---     ├╴lltPermutation---     │  ├╴lltSublist---     │  │  ├╴sublistElem---     │  │  │  └╴sublistCorrect---     │  │  │     ├╴countElem---     │  │  │     │  └╴countNonNegative---     │  │  │     └╴elemCount---     │  │  ├╴lltCorrect---     │  │  └╴sublistTail---     │  └╴permutationImpliesSublist---     ├╴lgePermutation---     │  ├╴lgeSublist---     │  │  ├╴sublistElem---     │  │  ├╴lgeCorrect---     │  │  └╴sublistTail---     │  └╴permutationImpliesSublist---     └╴nonDecreasingMerge--- [Proven] quickSortIsCorrect-correctness :: IO Proof-correctness = runKDWith z3{kdOptions = (kdOptions z3) {ribbonLength = 60}} $ do--  ----------------------------------------------------------------------------------------------------  -- Part I. Formalizing less-than/greater-than-or-equal over lists and relationship to permutations-  ----------------------------------------------------------------------------------------------------  -- llt: list less-than:     all the elements are <  pivot-  -- lge: list greater-equal: all the elements are >= pivot-  let llt, lge :: SInteger -> SList Integer -> SBool-      llt = smtFunction "llt" $ \pivot l -> null l .|| let (x, xs) = uncons l in x .<  pivot .&& llt pivot xs-      lge = smtFunction "lge" $ \pivot l -> null l .|| let (x, xs) = uncons l in x .>= pivot .&& lge pivot xs--      -- Sublist relationship-      sublist :: SList Integer -> SList Integer -> SBool-      sublist xs ys = quantifiedBool (\(Forall @"e" e) -> count e xs .> 0 .=> count e ys .> 0)--  -- llt correctness-  lltCorrect <--     induct "lltCorrect"-            (\(Forall @"xs" xs) (Forall @"e" e) (Forall @"pivot" pivot) -> llt pivot xs .&& e `elem` xs .=> e .< pivot) $-            \ih x xs e pivot -> [llt pivot (x .: xs), e `elem` (x .: xs)]-                             |- e .< pivot-                             ?? ih-                             =: sTrue-                             =: qed--  -- lge correctness-  lgeCorrect <--     induct "lgeCorrect"-            (\(Forall @"xs" xs) (Forall @"e" e) (Forall @"pivot" pivot) -> lge pivot xs .&& e `elem` xs .=> e .>= pivot) $-            \ih x xs e pivot -> [lge pivot (x .: xs), e `elem` (x .: xs)]-                             |- e .>= pivot-                             ?? ih-                             =: sTrue-                             =: qed--  -- count is always non-negative-  countNonNegative <- induct "countNonNegative"-                             (\(Forall @"xs" xs) (Forall @"e" e) -> count e xs .>= 0) $-                             \ih x xs e -> [] |- count e (x .: xs) .>= 0-                                              =: cases [ e .== x ==> 1 + count e xs .>= 0-                                                                  ?? ih-                                                                  =: sTrue-                                                                  =: qed-                                                       , e ./= x ==> count e xs .>= 0-                                                                  ?? ih-                                                                  =: sTrue-                                                                  =: qed-                                                       ]--  -- relationship between count and elem, forward direction-  countElem <- induct "countElem"-                      (\(Forall @"xs" xs) (Forall @"e" e) -> e `elem` xs .=> count e xs .> 0) $-                      \ih x xs e -> [e `elem` (x .: xs)]-                                 |- count e (x .: xs) .> 0-                                 =: cases [ e .== x ==> 1 + count e xs .> 0-                                                     ?? countNonNegative-                                                     =: sTrue-                                                     =: qed-                                          , e ./= x ==> count e xs .> 0-                                                     ?? ih-                                                     =: sTrue-                                                     =: qed-                                          ]--  -- relationship between count and elem, backwards direction-  elemCount <- induct "elemCount"-                      (\(Forall @"xs" xs) (Forall @"e" e) -> count e xs .> 0 .=> e `elem` xs) $-                      \ih x xs e -> [count e xs .> 0]-                                 |- e `elem` (x .: xs)-                                 =: cases [ e .== x ==> trivial-                                          , e ./= x ==> e `elem` xs-                                                     ?? ih-                                                     =: sTrue-                                                     =: qed-                                          ]--  -- sublist correctness-  sublistCorrect <- calc "sublistCorrect"-                          (\(Forall @"xs" xs) (Forall @"ys" ys) (Forall @"x" x) -> xs `sublist` ys .&& x `elem` xs .=> x `elem` ys) $-                          \xs ys x -> [xs `sublist` ys, x `elem` xs]-                                   |- x `elem` ys-                                   ?? [ countElem `at` (Inst @"xs" xs, Inst @"e" x)-                                      , elemCount `at` (Inst @"xs" ys, Inst @"e" x)-                                      ]-                                   =: sTrue-                                   =: qed--  -- If one list is a sublist of another, then its head is an elem-  sublistElem <- calc "sublistElem"-                       (\(Forall @"x" x) (Forall @"xs" xs) (Forall @"ys" ys) -> (x .: xs) `sublist` ys .=> x `elem` ys) $-                       \x xs ys -> [(x .: xs) `sublist` ys]-                                |- x `elem` ys-                                ?? sublistCorrect `at` (Inst @"xs" (x .: xs), Inst @"ys" ys, Inst @"x" x)-                                =: sTrue-                                =: qed--  -- If one list is a sublist of another so is its tail-  sublistTail <- lemma "sublistTail"-                       (\(Forall @"x" x) (Forall @"xs" xs) (Forall @"ys" ys) -> (x .: xs) `sublist` ys .=> xs `sublist` ys)-                       []--  -- Permutation implies sublist-  permutationImpliesSublist <- lemma "permutationImpliesSublist"-                                    (\(Forall @"xs" xs) (Forall @"ys" ys) -> isPermutation xs ys .=> xs `sublist` ys)-                                    []--  -- If a value is less than all the elements in a list, then it is also less than all the elements of any sublist of it-  lltSublist <--     inductWith cvc5 "lltSublist"-            (\(Forall @"xs" xs) (Forall @"pivot" pivot) (Forall @"ys" ys) -> llt pivot ys .&& xs `sublist` ys .=> llt pivot xs) $-            \ih x xs pivot ys -> [llt pivot ys, (x .: xs) `sublist` ys]-                              |- llt pivot (x .: xs)-                              =: x .< pivot .&& llt pivot xs-                              ?? [ -- To establish x .< pivot, observe that x is in ys, and together-                                   -- with llt pivot ys, we get that x is less than pivot-                                   sublistElem `at` (Inst @"x" x,   Inst @"xs" xs, Inst @"ys" ys)-                                 , lltCorrect `at` (Inst @"xs" ys, Inst @"e"  x,  Inst @"pivot" pivot)--                                   -- Use induction hypothesis to get rid of the second conjunct. We need to tell-                                   -- the prover that xs is a sublist of ys too so it can satisfy its precondition-                                 , sublistTail `at` (Inst @"x" x, Inst @"xs" xs, Inst @"ys" ys)-                                 , ih         `at` (Inst @"pivot" pivot, Inst @"ys" ys)-                                 ]-                              =: sTrue-                              =: qed--  -- Variant of the above for the permutation case-  lltPermutation <--     calc "lltPermutation"-           (\(Forall @"xs" xs) (Forall @"pivot" pivot) (Forall @"ys" ys) -> llt pivot ys .&& isPermutation xs ys .=> llt pivot xs) $-           \xs pivot ys -> [llt pivot ys, isPermutation xs ys]-                        |- llt pivot xs-                        ?? [ lltSublist                `at` (Inst @"xs" xs, Inst @"pivot" pivot, Inst @"ys" ys)-                           , permutationImpliesSublist `at` (Inst @"xs" xs, Inst @"ys" ys)-                           ]-                        =: sTrue-                        =: qed--  -- If a value is greater than or equal to all the elements in a list, then it is also less than all the elements of any sublist of it-  lgeSublist <--     inductWith cvc5 "lgeSublist"-            (\(Forall @"xs" xs) (Forall @"pivot" pivot) (Forall @"ys" ys) -> lge pivot ys .&& xs `sublist` ys .=> lge pivot xs) $-            \ih x xs pivot ys -> [lge pivot ys, (x .: xs) `sublist` ys]-                              |- lge pivot (x .: xs)-                              =: x .>= pivot .&& lge pivot xs-                              ?? [ -- To establish x .>= pivot, observe that x is in ys, and together-                                   -- with lge pivot ys, we get that x is greater than equal to the pivot-                                   sublistElem `at` (Inst @"x" x,   Inst @"xs" xs, Inst @"ys" ys)-                                 , lgeCorrect  `at` (Inst @"xs" ys, Inst @"e"  x,  Inst @"pivot" pivot)--                                   -- Use induction hypothesis to get rid of the second conjunct. We need to tell-                                   -- the prover that xs is a sublist of ys too so it can satisfy its precondition-                                 , sublistTail `at` (Inst @"x" x, Inst @"xs" xs, Inst @"ys" ys)-                                 , ih          `at` (Inst @"pivot" pivot, Inst @"ys" ys)-                                 ]-                              =: sTrue-                              =: qed--  -- Variant of the above for the permutation case-  lgePermutation <--     calc "lgePermutation"-           (\(Forall @"xs" xs) (Forall @"pivot" pivot) (Forall @"ys" ys) -> lge pivot ys .&& isPermutation xs ys .=> lge pivot xs) $-           \xs pivot ys -> [lge pivot ys, isPermutation xs ys]-                        |- lge pivot xs-                        ?? [ lgeSublist                `at` (Inst @"xs" xs, Inst @"pivot" pivot, Inst @"ys" ys)-                           , permutationImpliesSublist `at` (Inst @"xs" xs, Inst @"ys" ys)-                           ]-                        =: sTrue-                        =: qed--  ---------------------------------------------------------------------------------------------  -- Part II. Helper lemmas for partition-  ----------------------------------------------------------------------------------------------  -- The first element of the partition produces all smaller elements-  partitionFstLT <- inductWith cvc5 "partitionFstLT"-     (\(Forall @"l" l) (Forall @"pivot" pivot) -> llt pivot (fst (partition pivot l))) $-     \ih a as pivot -> [] |- llt pivot (fst (partition pivot (a .: as)))-                          =: llt pivot (ite (a .< pivot)-                                            (a .: fst (partition pivot as))-                                            (     fst (partition pivot as)))-                          ?? "push llt down"-                          =: ite (a .< pivot)-                                 (a .< pivot .&& llt pivot (fst (partition pivot as)))-                                 (               llt pivot (fst (partition pivot as)))-                          ?? ih-                          =: sTrue-                          =: qed--  -- The second element of the partition produces all greater-than-or-equal to elements-  partitionSndGE <- inductWith cvc5 "partitionSndGE"-     (\(Forall @"l" l) (Forall @"pivot" pivot) -> lge pivot (snd (partition pivot l))) $-     \ih a as pivot -> [] |- lge pivot (snd (partition pivot (a .: as)))-                          =: lge pivot (ite (a .< pivot)-                                            (     snd (partition pivot as))-                                            (a .: snd (partition pivot as)))-                          ?? "push lge down"-                          =: ite (a .< pivot)-                                 (a .< pivot .&& lge pivot (snd (partition pivot as)))-                                 (               lge pivot (snd (partition pivot as)))-                          ?? ih-                          =: sTrue-                          =: qed--  -- The first element of partition does not increase in size-  partitionNotLongerFst <- sInduct "partitionNotLongerFst"-     (\(Forall @"l" l) (Forall @"pivot" pivot) -> length (fst (partition pivot l)) .<= length l)-     (\l (_ :: SInteger) -> length @Integer l) $-     \ih l pivot -> [] |- length (fst (partition pivot l)) .<= length l-                       =: split l trivial-                                (\a as -> let lo = fst (partition pivot as)-                                       in ite (a .< pivot)-                                              (length (a .: lo) .<= length (a .: as))-                                              (length       lo  .<= length (a .: as))-                                       ?? "simplify"-                                       =: ite (a .< pivot)-                                              (length lo .<=     length as)-                                              (length lo .<= 1 + length as)-                                       ?? ih `at` (Inst @"l" as, Inst @"pivot" pivot)-                                       =: sTrue-                                       =: qed)--  -- The second element of partition does not increase in size-  partitionNotLongerSnd <- sInduct "partitionNotLongerSnd"-     (\(Forall @"l" l) (Forall @"pivot" pivot) -> length (snd (partition pivot l)) .<= length l)-     (\l (_ :: SInteger) -> length @Integer l) $-     \ih l pivot -> [] |- length (snd (partition pivot l)) .<= length l-                       =: split l trivial-                                (\a as -> let hi = snd (partition pivot as)-                                       in ite (a .< pivot)-                                              (length       hi  .<= length (a .: as))-                                              (length (a .: hi) .<= length (a .: as))-                                       ?? "simplify"-                                       =: ite (a .< pivot)-                                              (length hi .<= 1 + length as)-                                              (length hi .<=     length as)-                                       ?? ih `at` (Inst @"l" as, Inst @"pivot" pivot)-                                       =: sTrue-                                       =: qed)--  ---------------------------------------------------------------------------------------------  -- Part III. Helper lemmas for count-  ----------------------------------------------------------------------------------------------  -- Count distributes over append-  countAppend <--      induct "countAppend"-             (\(Forall @"xs" xs) (Forall @"ys" ys) (Forall @"e" e) -> count e (xs ++ ys) .== count e xs + count e ys) $-             \ih x xs ys e -> [] |- count e ((x .: xs) ++ ys)-                                 =: count e (x .: (xs ++ ys))-                                 ?? "unfold count"-                                 =: (let r = count e (xs ++ ys) in ite (e .== x) (1+r) r)-                                 ?? ih `at` (Inst @"ys" ys, Inst @"e" e)-                                 =: (let r = count e xs + count e ys in ite (e .== x) (1+r) r)-                                 ?? "simplify"-                                 =: count e (x .: xs) + count e ys-                                 =: qed--  -- Count is preserved over partition-  let countTuple :: SInteger -> STuple [Integer] [Integer] -> SInteger-      countTuple e xsys = count e xs + count e ys-        where (xs, ys) = untuple xsys--  countPartition <--     induct "countPartition"-            (\(Forall @"xs" xs) (Forall @"pivot" pivot) (Forall @"e" e) -> countTuple e (partition pivot xs) .== count e xs) $-            \ih a as pivot e ->-                [] |- countTuple e (partition pivot (a .: as))-                   ?? "expand partition"-                   =: countTuple e (let (lo, hi) = untuple (partition pivot as)-                                    in ite (a .< pivot)-                                           (tuple (a .: lo, hi))-                                           (tuple (lo, a .: hi)))-                   ?? "push countTuple down"-                   =: let (lo, hi) = untuple (partition pivot as)-                   in ite (a .< pivot)-                          (count e (a .: lo) + count e hi)-                          (count e lo + count e (a .: hi))-                   =: cases [e .== a  ==> ite (a .< pivot)-                                              (1 + count e lo + count e hi)-                                              (count e lo + 1 + count e hi)-                                       ?? "simplify"-                                       =: 1 + count e lo + count e hi-                                       ?? ih-                                       =: 1 + count e as-                                       =: qed-                            , e ./= a ==> ite (a .< pivot)-                                              (count e lo + count e hi)-                                              (count e lo + count e hi)-                                       ?? "simplify"-                                       =: count e lo + count e hi-                                       ?? ih-                                       =: count e as-                                       =: qed-                            ]-  ---------------------------------------------------------------------------------------------  -- Part IV. Prove that the output of quick sort is a permutation of its input-  ----------------------------------------------------------------------------------------------  sortCountsMatch <--     sInduct "sortCountsMatch"-             (\(Forall @"xs" xs) (Forall @"e" e) -> count e xs .== count e (quickSort xs))-             (\xs (_ :: SInteger) -> length @Integer xs) $-             \ih xs e ->-                [] |- count e (quickSort xs)-                   =: split xs trivial-                            (\a as -> count e (quickSort (a .: as))-                                   ?? "expand quickSort"-                                   =: count e (let (lo, hi) = untuple (partition a as)-                                               in quickSort lo ++ singleton a ++ quickSort hi)-                                   ?? "push count down"-                                   =: let (lo, hi) = untuple (partition a as)-                                   in count e (quickSort lo ++ singleton a ++ quickSort hi)-                                   ?? countAppend `at` (Inst @"xs" (quickSort lo), Inst @"ys" (singleton a ++ quickSort hi), Inst @"e" e)-                                   =: count e (quickSort lo) + count e (singleton a ++ quickSort hi)-                                   ?? countAppend `at` (Inst @"xs" (singleton a), Inst @"ys" (quickSort hi), Inst @"e" e)-                                   =: count e (quickSort lo) + count e (singleton a) + count e (quickSort hi)-                                   ?? [ hprf  $ ih                    `at` (Inst @"xs" lo, Inst @"e" e)-                                      , hprf  $ partitionNotLongerFst `at` (Inst @"l"  as, Inst @"pivot" a)-                                      , hasm  $ xs .== a .: as-                                      , hcmnt "IH on lo"-                                      ]-                                   =: count e lo + count e (singleton a) + count e (quickSort hi)-                                   ?? [ hprf  $ ih                    `at` (Inst @"xs" hi, Inst @"e" e)-                                      , hprf  $ partitionNotLongerSnd `at` (Inst @"l"  as, Inst @"pivot" a)-                                      , hasm  $ xs .== a .: as-                                      , hcmnt "IH on hi"-                                      ]-                                   =: count e lo + count e (singleton a) + count e hi-                                   ?? countPartition `at` (Inst @"xs" as, Inst @"pivot" a, Inst @"e" e)-                                   =: count e xs-                                   =: qed)--  sortIsPermutation <- lemma "sortIsPermutation" (\(Forall @"xs" xs) -> isPermutation xs (quickSort xs)) [sortCountsMatch]--  ---------------------------------------------------------------------------------------------  -- Part V. Helper lemmas for nonDecreasing-  ---------------------------------------------------------------------------------------------  nonDecreasingMerge <--      inductWith cvc5 "nonDecreasingMerge"-          (\(Forall @"xs" xs) (Forall @"pivot" pivot) (Forall @"ys" ys) ->-                     nonDecreasing xs .&& llt pivot xs-                 .&& nonDecreasing ys .&& lge pivot ys .=> nonDecreasing (xs ++ singleton pivot ++ ys)) $-          \ih x xs pivot ys ->-               [nonDecreasing (x .: xs), llt pivot xs, nonDecreasing ys, lge pivot ys]-            |- nonDecreasing (x .: xs ++ singleton pivot ++ ys)-            =: split xs trivial-                     (\a as -> nonDecreasing (x .: a .: as ++ singleton pivot ++ ys)-                            =: x .<= a .&& nonDecreasing (a .: as ++ singleton pivot ++ ys)-                            ?? ih-                            =: sTrue-                            =: qed)--  ---------------------------------------------------------------------------------------------  -- Part VI. Prove that the output of quick sort is non-decreasing-  ---------------------------------------------------------------------------------------------  sortIsNonDecreasing <--     sInductWith cvc5 "sortIsNonDecreasing"-             (\(Forall @"xs" xs) -> nonDecreasing (quickSort xs))-             (length @Integer) $-             \ih xs ->-                [] |- nonDecreasing (quickSort xs)-                   =: split xs trivial-                            (\a as -> nonDecreasing (quickSort (a .: as))-                                   ?? "expand quickSort"-                                   =: nonDecreasing (let (lo, hi) = untuple (partition a as)-                                                     in quickSort lo ++ singleton a ++ quickSort hi)-                                   ?? "push nonDecreasing down"-                                   =: let (lo, hi) = untuple (partition a as)-                                   in nonDecreasing (quickSort lo ++ singleton a ++ quickSort hi)-                                   ?? [ -- Deduce that lo/hi is not longer than as, and hence, shorter than xs-                                        partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a)-                                      , partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a)--                                        -- Use the inductive hypothesis twice to deduce quickSort of lo and hi are nonDecreasing-                                      , ih `at` Inst @"xs" lo  -- nonDecreasing (quickSort lo)-                                      , ih `at` Inst @"xs" hi  -- nonDecreasing (quickSort hi)--                                      -- Deduce that lo is all less than a, and hi is all greater than or equal to a-                                      , partitionFstLT `at` (Inst @"l" as, Inst @"pivot" a)-                                      , partitionSndGE `at` (Inst @"l" as, Inst @"pivot" a)--                                      -- Deduce that quickSort lo is all less than a-                                      , sortIsPermutation `at`  Inst @"xs" lo-                                      , lltPermutation    `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" lo)--                                      -- Deduce that quickSort hi is all greater than or equal to a-                                      , sortIsPermutation `at`  Inst @"xs" hi-                                      , lgePermutation    `at` (Inst @"xs" (quickSort hi), Inst @"pivot" a, Inst @"ys" hi)--                                      -- Finally conclude that the whole reconstruction is non-decreasing-                                      , nonDecreasingMerge `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" (quickSort hi))-                                      ]-                                   =: sTrue-                                   =: qed)--  ---------------------------------------------------------------------------------------------  -- Part VII. Putting it together-  ----------------------------------------------------------------------------------------------  qs <- lemma "quickSortIsCorrect"-           (\(Forall @"xs" xs) -> let out = quickSort xs in isPermutation xs out .&& nonDecreasing out)-           [sortIsPermutation, sortIsNonDecreasing]--  -- | We can display the dependencies in a proof-  liftIO $ do putStrLn "== Dependencies:"-              putStr $ show $ getProofTree qs--  pure qs
− Documentation/SBV/Examples/KnuckleDragger/ShefferStroke.hs 
@@ -1,657 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.ShefferStroke--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Inspired by https://www.philipzucker.com/cody_sheffer/, proving--- that the axioms of sheffer stroke (i.e., nand in traditional boolean--- logic), imply it is a boolean algebra.--------------------------------------------------------------------------------{-# LANGUAGE CPP                  #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE DeriveAnyClass       #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE NamedFieldPuns       #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE StandaloneDeriving   #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeAbstractions     #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.ShefferStroke where--import Prelude hiding ((<))-import Data.List (intercalate)--import Data.SBV-import Data.SBV.Tools.KnuckleDragger---- * Generalized Boolean Algebras---- | Capture what it means to be a boolean algebra. We follow Lean's--- definition, as much as we can: <https://leanprover-community.github.io/mathlib_docs/order/boolean_algebra.html>.--- Since there's no way in Haskell to capture properties together with a class, we'll represent the properties--- separately.-class BooleanAlgebra α where-  ﬧ    :: α -> α-  (⨆)  :: α -> α -> α-  (⨅)  :: α -> α -> α-  (≤)  :: α -> α -> SBool-  (<)  :: α -> α -> SBool-  (\\) :: α -> α -> α-  (⇨)  :: α -> α -> α-  ⲳ    :: α-  т    :: α--  infix  4 ≤-  infixl 6 ⨆-  infixl 7 ⨅---- | Proofs needed for a boolean-algebra. Again, we follow Lean's definition here. Since we cannot--- put these in the class definition above, we will keep them in a simple data-structure.-data BooleanAlgebraProof = BooleanAlgebraProof {-    le_refl          {- ∀ (a : α), a ≤ a                             -} :: Proof-  , le_trans         {- ∀ (a b c : α), a ≤ b → b ≤ c → a ≤ c         -} :: Proof-  , lt_iff_le_not_le {- (∀ (a b : α), a < b ↔ a ≤ b ∧ ¬b ≤ a)        -} :: Proof-  , le_antisymm      {- ∀ (a b : α), a ≤ b → b ≤ a → a = b           -} :: Proof-  , le_sup_left      {- ∀ (a b : α), a ≤ a ⊔ b                       -} :: Proof-  , le_sup_right     {- ∀ (a b : α), b ≤ a ⊔ b                       -} :: Proof-  , sup_le           {- ∀ (a b c : α), a ≤ c → b ≤ c → a ⊔ b ≤ c     -} :: Proof-  , inf_le_left      {- ∀ (a b : α), a ⊓ b ≤ a                       -} :: Proof-  , inf_le_right     {- ∀ (a b : α), a ⊓ b ≤ b                       -} :: Proof-  , le_inf           {- ∀ (a b c : α), a ≤ b → a ≤ c → a ≤ b ⊓ c     -} :: Proof-  , le_sup_inf       {- ∀ (x y z : α), (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z -} :: Proof-  , inf_compl_le_bot {- ∀ (x : α), x ⊓ xᶜ ≤ ⊥                        -} :: Proof-  , top_le_sup_compl {- ∀ (x : α), ⊤ ≤ x ⊔ xᶜ                        -} :: Proof-  , le_top           {- ∀ (a : α), a ≤ ⊤                             -} :: Proof-  , bot_le           {- ∀ (a : α), ⊥ ≤ a                             -} :: Proof-  , sdiff_eq         {- (∀ (x y : α), x \ y = x ⊓ yᶜ)                -} :: Proof-  , himp_eq          {- (∀ (x y : α), x ⇨ y = y ⊔ xᶜ)                -} :: Proof-  }---- | A somewhat prettier printer for a BooleanAlgebra proof-instance Show BooleanAlgebraProof where-  show p = intercalate "\n" [ "BooleanAlgebraProof {"-                            , "  le_refl         : " ++ show (le_refl          p)-                            , "  le_trans        : " ++ show (le_trans         p)-                            , "  lt_iff_le_not_le: " ++ show (lt_iff_le_not_le p)-                            , "  le_antisymm     : " ++ show (le_antisymm      p)-                            , "  le_sup_left     : " ++ show (le_sup_left      p)-                            , "  le_sup_right    : " ++ show (le_sup_right     p)-                            , "  sup_le          : " ++ show (sup_le           p)-                            , "  inf_le_left     : " ++ show (inf_le_left      p)-                            , "  inf_le_right    : " ++ show (inf_le_right     p)-                            , "  le_inf          : " ++ show (le_inf           p)-                            , "  le_sup_inf      : " ++ show (le_sup_inf       p)-                            , "  inf_compl_le_bot: " ++ show (inf_compl_le_bot p)-                            , "  top_le_sup_compl: " ++ show (top_le_sup_compl p)-                            , "  le_top          : " ++ show (le_top           p)-                            , "  bot_le          : " ++ show (bot_le           p)-                            , "  sdiff_eq        : " ++ show (sdiff_eq         p)-                            , "  himp_eq         : " ++ show (himp_eq          p)-                            , "}"-                            ]---- * The sheffer stroke---- | The abstract type for the domain.-data Stroke-mkUninterpretedSort ''Stroke---- | The sheffer stroke operator.-(⏐) :: SStroke -> SStroke -> SStroke-(⏐) = uninterpret "⏐"-infixl 7 ⏐---- | The boolean algebra of the sheffer stroke.-instance BooleanAlgebra SStroke where-  ﬧ x    = x ⏐ x-  a ⨆ b  = ﬧ(a ⏐ b)-  a ⨅ b  = ﬧ a ⏐ ﬧ b-  a ≤ b  = a .== b ⨅ a-  a < b  = a ≤ b .&& a ./= b-  a \\ b = a ⨅ ﬧ b-  a ⇨ b  = b ⨆ ﬧ a-  ⲳ      = arb ⏐ ﬧ arb where arb = some "ⲳ" (const sTrue)-  т      = ﬧ ⲳ---- | Double-negation-ﬧﬧ :: BooleanAlgebra a => a -> a-ﬧﬧ = ﬧ . ﬧ---- A couple of CPP defines make the code shorter to read-#define A      (Forall @"A"  (a  :: SStroke))-#define AAp A  (Forall @"A'" (a' :: SStroke))-#define AB  A  (Forall @"B"  (b  :: SStroke))-#define ABC AB (Forall @"C"  (c  :: SStroke))-#define X      (Forall @"X"  (x  :: SStroke))-#define XY  X  (Forall @"Y"  (y  :: SStroke))-#define XYZ XY (Forall @"Z"  (z  :: SStroke))---- | First Sheffer axiom: @ﬧﬧa == a@-sheffer1 :: KD Proof-sheffer1 = axiom "ﬧﬧa == a" $ \A -> ﬧﬧ a .== a---- | Second Sheffer axiom: @a ⏐ (b ⏐ ﬧb) == ﬧa@-sheffer2 :: KD Proof-sheffer2 = axiom "a ⏐ (b ⏐ ﬧb) == ﬧa" $ \AB -> a ⏐ (b ⏐ ﬧ b) .== ﬧ a---- | Third Sheffer axiom: @ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)@-sheffer3 :: KD Proof-sheffer3 = axiom "ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)" $ \ABC -> ﬧ(a ⏐ (b ⏐ c)) .== (ﬧ b ⏐ a) ⏐ (ﬧ c ⏐ a)---- * Sheffer's stroke defines a boolean algebra---- | Prove that Sheffer stroke axioms imply it is a boolean algebra. We have:------ >>> shefferBooleanAlgebra--- Axiom: ﬧﬧa == a--- Axiom: a ⏐ (b ⏐ ﬧb) == ﬧa--- Axiom: ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)--- Lemma: a | b = b | a---   Step: 1 (ﬧﬧa == a)                                        Q.E.D.---   Step: 2 (ﬧﬧa == a)                                        Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4 (ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a))           Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6 (ﬧﬧa == a)                                        Q.E.D.---   Step: 7 (ﬧﬧa == a)                                        Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a | a′ = b | b′---   Step: 1 (ﬧﬧa == a)                                        Q.E.D.---   Step: 2 (a ⏐ (b ⏐ ﬧb) == ﬧa)                              Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4 (a ⏐ (b ⏐ ﬧb) == ﬧa)                              Q.E.D.---   Step: 5 (ﬧﬧa == a)                                        Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ⊔ b = b ⊔ a                                        Q.E.D.--- Lemma: a ⊓ b = b ⊓ a                                        Q.E.D.--- Lemma: a ⊔ ⲳ = a                                            Q.E.D.--- Lemma: a ⊓ т = a                                            Q.E.D.--- Lemma: a ⊔ (b ⊓ c) = (a ⊔ b) ⊓ (a ⊔ c)                      Q.E.D.--- Lemma: a ⊓ (b ⊔ c) = (a ⊓ b) ⊔ (a ⊓ c)                      Q.E.D.--- Lemma: a ⊔ aᶜ = т                                           Q.E.D.--- Lemma: a ⊓ aᶜ = ⲳ                                           Q.E.D.--- Lemma: a ⊔ т = т---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ⊓ ⲳ = ⲳ---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ⊔ (a ⊓ b) = a---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ⊓ (a ⊔ b) = a---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ⊓ a = a---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ⊔ a' = т → a ⊓ a' = ⲳ → a' = aᶜ---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6                                                   Q.E.D.---   Step: 7                                                   Q.E.D.---   Step: 8                                                   Q.E.D.---   Step: 9                                                   Q.E.D.---   Step: 10                                                  Q.E.D.---   Step: 11                                                  Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: aᶜᶜ = a                                              Q.E.D.--- Lemma: aᶜ = bᶜ → a = b                                      Q.E.D.--- Lemma: a ⊔ bᶜ = т → a ⊓ bᶜ = ⲳ → a = b                      Q.E.D.--- Lemma: a ⊔ (aᶜ ⊔ b) = т---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ⊓ (aᶜ ⊓ b) = ⲳ---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: (a ⊔ b)ᶜ = aᶜ ⊓ bᶜ                                   Q.E.D.--- Lemma: (a ⨅ b)ᶜ = aᶜ ⨆ bᶜ                                   Q.E.D.--- Lemma: (a ⊔ (b ⊔ c)) ⊔ aᶜ = т                               Q.E.D.--- Lemma: b ⊓ (a ⊔ (b ⊔ c)) = b                                Q.E.D.--- Lemma: b ⊔ (a ⊓ (b ⊓ c)) = b                                Q.E.D.--- Lemma: (a ⊔ (b ⊔ c)) ⊔ bᶜ = т---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6                                                   Q.E.D.---   Step: 7                                                   Q.E.D.---   Step: 8                                                   Q.E.D.---   Step: 9                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: (a ⊔ (b ⊔ c)) ⊔ cᶜ = т                               Q.E.D.--- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ a = ⲳ---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6                                                   Q.E.D.---   Step: 7                                                   Q.E.D.---   Step: 8                                                   Q.E.D.---   Step: 9                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ b = ⲳ                                 Q.E.D.--- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ c = ⲳ                                 Q.E.D.--- Lemma: (a ⊔ (b ⊔ c)) ⊔ ((a ⊔ b) ⊔ c)ᶜ = т---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6                                                   Q.E.D.---   Step: 7                                                   Q.E.D.---   Step: 8                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: (a ⊔ (b ⊔ c)) ⊓ ((a ⊔ b) ⊔ c)ᶜ = ⲳ---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Step: 5                                                   Q.E.D.---   Step: 6                                                   Q.E.D.---   Step: 7                                                   Q.E.D.---   Step: 8                                                   Q.E.D.---   Step: 9                                                   Q.E.D.---   Step: 10                                                  Q.E.D.---   Step: 11                                                  Q.E.D.---   Step: 12                                                  Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ⊔ (b ⊔ c) = (a ⊔ b) ⊔ c                            Q.E.D.--- Lemma: a ⊓ (b ⊓ c) = (a ⊓ b) ⊓ c---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ≤ b → b ≤ a → a = b---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ≤ a                                                Q.E.D.--- Lemma: a ≤ b → b ≤ c → a ≤ c---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Step: 4                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a < b ↔ a ≤ b ∧ ¬b ≤ a                               Q.E.D.--- Lemma: a ≤ a ⊔ b                                            Q.E.D.--- Lemma: b ≤ a ⊔ b                                            Q.E.D.--- Lemma: a ≤ c → b ≤ c → a ⊔ b ≤ c---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: a ⊓ b ≤ a                                            Q.E.D.--- Lemma: a ⊓ b ≤ b                                            Q.E.D.--- Lemma: a ≤ b → a ≤ c → a ≤ b ⊓ c---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z                        Q.E.D.--- Lemma: x ⊓ xᶜ ≤ ⊥                                           Q.E.D.--- Lemma: ⊤ ≤ x ⊔ xᶜ                                           Q.E.D.--- Lemma: a ≤ ⊤---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Step: 3                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: ⊥ ≤ a---   Step: 1                                                   Q.E.D.---   Step: 2                                                   Q.E.D.---   Result:                                                   Q.E.D.--- Lemma: x \ y = x ⊓ yᶜ                                       Q.E.D.--- Lemma: x ⇨ y = y ⊔ xᶜ                                       Q.E.D.--- BooleanAlgebraProof {---   le_refl         : [Proven] a ≤ a---   le_trans        : [Proven] a ≤ b → b ≤ c → a ≤ c---   lt_iff_le_not_le: [Proven] a < b ↔ a ≤ b ∧ ¬b ≤ a---   le_antisymm     : [Proven] a ≤ b → b ≤ a → a = b---   le_sup_left     : [Proven] a ≤ a ⊔ b---   le_sup_right    : [Proven] b ≤ a ⊔ b---   sup_le          : [Proven] a ≤ c → b ≤ c → a ⊔ b ≤ c---   inf_le_left     : [Proven] a ⊓ b ≤ a---   inf_le_right    : [Proven] a ⊓ b ≤ b---   le_inf          : [Proven] a ≤ b → a ≤ c → a ≤ b ⊓ c---   le_sup_inf      : [Proven] (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z---   inf_compl_le_bot: [Proven] x ⊓ xᶜ ≤ ⊥---   top_le_sup_compl: [Proven] ⊤ ≤ x ⊔ xᶜ---   le_top          : [Proven] a ≤ ⊤---   bot_le          : [Proven] ⊥ ≤ a---   sdiff_eq        : [Proven] x \ y = x ⊓ yᶜ---   himp_eq         : [Proven] x ⇨ y = y ⊔ xᶜ--- }-shefferBooleanAlgebra :: IO BooleanAlgebraProof-shefferBooleanAlgebra = runKDWith z3{kdOptions = (kdOptions z3) {ribbonLength = 60}} $ do--  -- Get the axioms-  sh1 <- sheffer1-  sh2 <- sheffer2-  sh3 <- sheffer3--  commut <- calc "a | b = b | a" (\AB -> a ⏐ b .== b ⏐ a) $-                 \a b -> [] ⊢ a ⏐ b                       ⁇ sh1-                            ≡ ﬧﬧ(a ⏐ b)                   ⁇ sh1-                            ≡ ﬧﬧ(a ⏐ ﬧﬧ b)-                            ≡ ﬧﬧ(a ⏐ (ﬧ b ⏐ ﬧ b))         ⁇ sh3-                            ≡ ﬧ ((ﬧﬧ b ⏐ a) ⏐ (ﬧﬧ b ⏐ a))-                            ≡ ﬧﬧ(ﬧﬧ b ⏐ a)                ⁇ sh1-                            ≡ ﬧﬧ b ⏐ a                    ⁇ sh1-                            ≡ b ⏐ a-                            ≡ qed--  all_bot <- calc "a | a′ = b | b′" (\AB -> a ⏐ ﬧ a .== b ⏐ ﬧ b) $-                  \a b -> [] ⊢ a ⏐ ﬧ a                  ⁇ sh1-                             ≡ ﬧﬧ(a ⏐ ﬧ a)              ⁇ sh2-                             ≡ ﬧ((a ⏐ ﬧ a) ⏐ (b ⏐ ﬧ b)) ⁇ commut-                             ≡ ﬧ((b ⏐ ﬧ b) ⏐ (a ⏐ ﬧ a)) ⁇ sh2-                             ≡ ﬧﬧ (b ⏐ ﬧ b)             ⁇ sh1-                             ≡ b ⏐ ﬧ b-                             ≡ qed--  commut1  <- lemma "a ⊔ b = b ⊔ a" (\AB -> a ⨆ b .== b ⨆ a) [commut]-  commut2  <- lemma "a ⊓ b = b ⊓ a" (\AB -> a ⨅ b .== b ⨅ a) [commut]--  ident1   <- lemma "a ⊔ ⲳ = a" (\A  -> a ⨆ ⲳ .== a) [sh1, sh2]-  ident2   <- lemma "a ⊓ т = a" (\A  -> a ⨅ т .== a) [sh1, sh2]--  distrib1 <- lemma "a ⊔ (b ⊓ c) = (a ⊔ b) ⊓ (a ⊔ c)" (\ABC -> a ⨆ (b ⨅ c) .== (a ⨆ b) ⨅ (a ⨆ c)) [sh1, sh3, commut]-  distrib2 <- lemma "a ⊓ (b ⊔ c) = (a ⊓ b) ⊔ (a ⊓ c)" (\ABC -> a ⨅ (b ⨆ c) .== (a ⨅ b) ⨆ (a ⨅ c)) [sh1, sh3, commut]--  compl1 <- lemma "a ⊔ aᶜ = т" (\A -> a ⨆ ﬧ a .== т) [sh1, sh2, sh3, all_bot]-  compl2 <- lemma "a ⊓ aᶜ = ⲳ" (\A -> a ⨅ ﬧ a .== ⲳ) [sh1, commut, all_bot]--  bound1 <- calc "a ⊔ т = т" (\A -> a ⨆ т .== т) $-                 \(a :: SStroke) -> [] ⊢ a ⨆ т               ⁇ ident2-                                       ≡ (a ⨆ т) ⨅ т         ⁇ commut2-                                       ≡ т ⨅ (a ⨆ т)         ⁇ compl1-                                       ≡ (a ⨆ ﬧ a) ⨅ (a ⨆ т) ⁇ distrib1-                                       ≡ a ⨆ (ﬧ a ⨅ т)       ⁇ ident2-                                       ≡ a ⨆ ﬧ a             ⁇ compl1-                                       ≡ (т :: SStroke)-                                       ≡ qed--  bound2 <- calc "a ⊓ ⲳ = ⲳ" (\A -> a ⨅ ⲳ .== ⲳ) $-                 \(a :: SStroke) -> [] ⊢ a ⨅ ⲳ               ⁇ ident1-                                       ≡ (a ⨅ ⲳ) ⨆ ⲳ         ⁇ commut1-                                       ≡ ⲳ ⨆ (a ⨅ ⲳ)         ⁇ compl2-                                       ≡ (a ⨅ ﬧ a) ⨆ (a ⨅ ⲳ) ⁇ distrib2-                                       ≡ a ⨅ (ﬧ a ⨆ ⲳ)       ⁇ ident1-                                       ≡ a ⨅ ﬧ a             ⁇ compl2-                                       ≡ (ⲳ :: SStroke)-                                       ≡ qed--  absorb1 <- calc "a ⊔ (a ⊓ b) = a" (\AB -> a ⨆ (a ⨅ b) .== a) $-                  \(a :: SStroke) b -> [] ⊢ a ⨆ (a ⨅ b)       ⁇ ident2-                                          ≡ (a ⨅ т) ⨆ (a ⨅ b) ⁇ distrib2-                                          ≡ a ⨅ (т ⨆ b)       ⁇ commut1-                                          ≡ a ⨅ (b ⨆ т)       ⁇ bound1-                                          ≡ a ⨅ т             ⁇ ident2-                                          ≡ a-                                          ≡ qed--  absorb2 <- calc "a ⊓ (a ⊔ b) = a" (\AB -> a ⨅ (a ⨆ b) .== a) $-                  \(a :: SStroke) b -> [] ⊢ a ⨅ (a ⨆ b)       ⁇ ident1-                                          ≡ (a ⨆ ⲳ) ⨅ (a ⨆ b) ⁇ distrib1-                                          ≡ a ⨆ (ⲳ ⨅ b)       ⁇ commut2-                                          ≡ a ⨆ (b ⨅ ⲳ)       ⁇ bound2-                                          ≡ a ⨆ ⲳ             ⁇ ident1-                                          ≡ a-                                          ≡ qed--  idemp2 <- calc "a ⊓ a = a" (\A -> a ⨅ a .== a) $-                 \(a :: SStroke) -> [] ⊢ a ⨅ a       ⁇ ident1-                                       ≡ a ⨅ (a ⨆ ⲳ) ⁇ absorb2-                                       ≡ a-                                       ≡ qed--  inv <- calc "a ⊔ a' = т → a ⊓ a' = ⲳ → a' = aᶜ"-              (\AAp  -> a ⨆ a' .== т .=> a ⨅ a' .== ⲳ .=> a' .== ﬧ a) $-              \(a :: SStroke) a' -> [a ⨆ a' .== т, a ⨅ a' .== ⲳ] ⊢ a'                     ⁇ ident2-                                                                 ≡ a' ⨅ т                 ⁇ compl1-                                                                 ≡ a' ⨅ (a ⨆ ﬧ a)         ⁇ distrib2-                                                                 ≡ (a' ⨅ a) ⨆ (a' ⨅ ﬧ a)  ⁇ commut2-                                                                 ≡ (a' ⨅ a) ⨆ (ﬧ a ⨅ a')  ⁇ commut2-                                                                 ≡ (a ⨅ a') ⨆ (ﬧ a ⨅ a')  ⁇ a ⨅ a' .== ⲳ-                                                                 ≡ ⲳ ⨆ (ﬧ a ⨅ a')         ⁇ compl2-                                                                 ≡ (a ⨅ ﬧ a) ⨆ (ﬧ a ⨅ a') ⁇ commut2-                                                                 ≡ (ﬧ a ⨅ a) ⨆ (ﬧ a ⨅ a') ⁇ distrib2-                                                                 ≡ ﬧ a ⨅ (a ⨆ a')         ⁇ a ⨆ a' .== т-                                                                 ≡ ﬧ a ⨅ т                ⁇ ident2-                                                                 ≡ ﬧ a-                                                                 ≡ qed--  dne      <- lemma "aᶜᶜ = a"         (\A -> ﬧﬧ a .== a)               [inv, compl1, compl2, commut1, commut2]-  inv_elim <- lemma "aᶜ = bᶜ → a = b" (\AB -> ﬧ a .== ﬧ b .=> a .== b) [dne]--  cancel <- lemma "a ⊔ bᶜ = т → a ⊓ bᶜ = ⲳ → a = b" (\AB -> a ⨆ ﬧ b .== т .=> a ⨅ ﬧ b .== ⲳ .=> a .== b) [inv, inv_elim]--  a1 <- calc "a ⊔ (aᶜ ⊔ b) = т" (\AB  -> a ⨆ (ﬧ a ⨆ b) .== т) $-             \(a :: SStroke) b -> [] ⊢ a ⨆ (ﬧ a ⨆ b)               ⁇ ident2-                                     ≡ (a ⨆ (ﬧ a ⨆ b)) ⨅ т         ⁇ commut2-                                     ≡ т ⨅ (a ⨆ (ﬧ a ⨆ b))         ⁇ compl1-                                     ≡ (a ⨆ ﬧ a) ⨅ (a ⨆ (ﬧ a ⨆ b)) ⁇ distrib1-                                     ≡ a ⨆ (ﬧ a ⨅ (ﬧ a ⨆ b))       ⁇ absorb2-                                     ≡ a ⨆ ﬧ a                     ⁇ compl1-                                     ≡ (т :: SStroke)-                                     ≡ qed--  a2 <- calc "a ⊓ (aᶜ ⊓ b) = ⲳ" (\AB  -> a ⨅ (ﬧ a ⨅ b) .== ⲳ) $-             \(a :: SStroke) b -> [] ⊢ a ⨅ (ﬧ a ⨅ b)               ⁇ ident1-                                     ≡ (a ⨅ (ﬧ a ⨅ b)) ⨆ ⲳ         ⁇ commut1-                                     ≡ ⲳ ⨆ (a ⨅ (ﬧ a ⨅ b))         ⁇ compl2-                                     ≡ (a ⨅ ﬧ a) ⨆ (a ⨅ (ﬧ a ⨅ b)) ⁇ distrib2-                                     ≡ a ⨅ (ﬧ a ⨆ (ﬧ a ⨅ b))       ⁇ absorb1-                                     ≡ a ⨅ ﬧ a                     ⁇ compl2-                                     ≡ (ⲳ :: SStroke)-                                     ≡ qed--  dm1 <- lemma "(a ⊔ b)ᶜ = aᶜ ⊓ bᶜ" (\AB -> ﬧ(a ⨆ b) .== ﬧ a ⨅ ﬧ b)-               [a1, a2, dne, commut1, commut2, ident1, ident2, distrib1, distrib2]--  dm2 <- lemma "(a ⨅ b)ᶜ = aᶜ ⨆ bᶜ" (\AB -> ﬧ(a ⨅ b) .== ﬧ a ⨆ ﬧ b)-               [a1, a2, dne, commut1, commut2, ident1, ident2, distrib1, distrib2]---  d1 <- lemma "(a ⊔ (b ⊔ c)) ⊔ aᶜ = т" (\ABC -> (a ⨆ (b ⨆ c)) ⨆ ﬧ a .== т)-              [a1, a2, commut1, ident1, ident2, distrib1, compl1, compl2, dm1, dm2, idemp2]--  e1 <- lemma "b ⊓ (a ⊔ (b ⊔ c)) = b" (\ABC -> b ⨅ (a ⨆ (b ⨆ c)) .== b) [distrib2, absorb1, absorb2, commut1]--  e2 <- lemma "b ⊔ (a ⊓ (b ⊓ c)) = b" (\ABC -> b ⨆ (a ⨅ (b ⨅ c)) .== b) [distrib1, absorb1, absorb2, commut2]--  f1 <- calc "(a ⊔ (b ⊔ c)) ⊔ bᶜ = т" (\ABC -> (a ⨆ (b ⨆ c)) ⨆ ﬧ b .== т) $-             \(a :: SStroke) b c -> [] ⊢ (a ⨆ (b ⨆ c)) ⨆ ﬧ b               ⁇ commut1-                                       ≡ ﬧ b ⨆ (a ⨆ (b ⨆ c))               ⁇ ident2-                                       ≡ (ﬧ b ⨆ (a ⨆ (b ⨆ c))) ⨅ т         ⁇ commut2-                                       ≡ т ⨅ (ﬧ b ⨆ (a ⨆ (b ⨆ c)))         ⁇ compl1-                                       ≡ (b ⨆ ﬧ b) ⨅ (ﬧ b ⨆ (a ⨆ (b ⨆ c))) ⁇ commut1-                                       ≡ (ﬧ b ⨆ b) ⨅ (ﬧ b ⨆ (a ⨆ (b ⨆ c))) ⁇ distrib1-                                       ≡ ﬧ b ⨆ (b ⨅ (a ⨆ (b ⨆ c)))         ⁇ e1-                                       ≡ ﬧ b ⨆ b                           ⁇ commut1-                                       ≡ b ⨆ ﬧ b                           ⁇ compl1-                                       ≡ (т :: SStroke)-                                       ≡ qed--  g1 <- lemma "(a ⊔ (b ⊔ c)) ⊔ cᶜ = т" (\ABC -> (a ⨆ (b ⨆ c)) ⨆ ﬧ c .== т) [commut1, f1]--  h1 <- calc "(a ⊔ b ⊔ c)ᶜ ⊓ a = ⲳ" (\ABC -> ﬧ(a ⨆ b ⨆ c) ⨅ a .== ⲳ) $-             \(a :: SStroke) b c -> [] ⊢ ﬧ(a ⨆ b ⨆ c) ⨅ a                    ⁇ commut2-                                       ≡ a ⨅ ﬧ (a ⨆ b ⨆ c)                   ⁇ dm1-                                       ≡ a ⨅ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c)               ⁇ ident1-                                       ≡ (a ⨅  (ﬧ a ⨅ ﬧ b ⨅ ﬧ c)) ⨆ ⲳ        ⁇ commut1-                                       ≡ ⲳ ⨆ (a ⨅ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c))         ⁇ compl2-                                       ≡ (a ⨅ ﬧ a) ⨆ (a ⨅ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c)) ⁇ distrib2-                                       ≡ a ⨅ (ﬧ a ⨆ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c))       ⁇ commut2-                                       ≡ a ⨅ (ﬧ a ⨆ (ﬧ c ⨅ (ﬧ a ⨅ ﬧ b)))     ⁇ e2-                                       ≡ a ⨅ ﬧ a                             ⁇ compl2-                                       ≡ (ⲳ :: SStroke)-                                       ≡ qed--  i1 <- lemma "(a ⊔ b ⊔ c)ᶜ ⊓ b = ⲳ" (\ABC -> ﬧ(a ⨆ b ⨆ c) ⨅ b .== ⲳ) [commut1, h1]-  j1 <- lemma "(a ⊔ b ⊔ c)ᶜ ⊓ c = ⲳ" (\ABC -> ﬧ(a ⨆ b ⨆ c) ⨅ c .== ⲳ) [a2, dne, commut2]--  assoc1 <- do-    c1 <- calc "(a ⊔ (b ⊔ c)) ⊔ ((a ⊔ b) ⊔ c)ᶜ = т"-               (\ABC -> (a ⨆ (b ⨆ c)) ⨆ ﬧ((a ⨆ b) ⨆ c) .== т) $-               \(a :: SStroke) b c -> [] ⊢ (a ⨆ (b ⨆ c)) ⨆ ﬧ((a ⨆ b) ⨆ c)                        ⁇ dm1-                                         ≡ (a ⨆ (b ⨆ c)) ⨆ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c)                     ⁇ distrib1-                                         ≡ ((a ⨆ (b ⨆ c)) ⨆ (ﬧ a ⨅ ﬧ b)) ⨅ ((a ⨆ (b ⨆ c)) ⨆ ﬧ c) ⁇ g1-                                         ≡ ((a ⨆ (b ⨆ c)) ⨆ (ﬧ a ⨅ ﬧ b)) ⨅ т                     ⁇ ident2-                                         ≡ (a ⨆ (b ⨆ c)) ⨆ (ﬧ a ⨅ ﬧ b)                           ⁇ distrib1-                                         ≡ ((a ⨆ (b ⨆ c)) ⨆ ﬧ a) ⨅ ((a ⨆ (b ⨆ c)) ⨆ ﬧ b)         ⁇ d1-                                         ≡ т ⨅ ((a ⨆ (b ⨆ c)) ⨆ ﬧ b)                             ⁇ f1-                                         ≡ т ⨅ (т :: SStroke)                                    ⁇ idemp2-                                         ≡ (т :: SStroke)-                                         ≡ qed--    c2 <- calc "(a ⊔ (b ⊔ c)) ⊓ ((a ⊔ b) ⊔ c)ᶜ = ⲳ"-               (\ABC -> (a ⨆ (b ⨆ c)) ⨅ ﬧ((a ⨆ b) ⨆ c) .== ⲳ) $-               \(a :: SStroke) b c -> [] ⊢ (a ⨆ (b ⨆ c)) ⨅ ﬧ((a ⨆ b) ⨆ c)                    ⁇ commut2-                                         ≡ ﬧ((a ⨆ b) ⨆ c) ⨅ (a ⨆ (b ⨆ c))                    ⁇ distrib2-                                         ≡ (ﬧ((a ⨆ b) ⨆ c) ⨅ a) ⨆ (ﬧ((a ⨆ b) ⨆ c) ⨅ (b ⨆ c)) ⁇ commut2-                                         ≡ (a ⨅ ﬧ((a ⨆ b) ⨆ c)) ⨆ ((b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c)) ⁇ commut2-                                         ≡ (ﬧ((a ⨆ b) ⨆ c) ⨅ a) ⨆ ((b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c)) ⁇ h1-                                         ≡ ⲳ ⨆ ((b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c))                    ⁇ commut1-                                         ≡ ((b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c)) ⨆ ⲳ                    ⁇ ident1-                                         ≡ (b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c)                          ⁇ commut2-                                         ≡ ﬧ((a ⨆ b) ⨆ c) ⨅ (b ⨆ c)                          ⁇ distrib2-                                         ≡ (ﬧ((a ⨆ b) ⨆ c) ⨅ b) ⨆ (ﬧ((a ⨆ b) ⨆ c) ⨅ c)       ⁇ j1-                                         ≡ (ﬧ((a ⨆ b) ⨆ c) ⨅ b) ⨆ ⲳ                          ⁇ i1-                                         ≡ ⲳ ⨆ (ⲳ :: SStroke)                                ⁇ ident1-                                         ≡ (ⲳ :: SStroke)-                                         ≡ qed--    lemma "a ⊔ (b ⊔ c) = (a ⊔ b) ⊔ c" (\ABC -> a ⨆ (b ⨆ c) .== (a ⨆ b) ⨆ c) [c1, c2, cancel]--  assoc2 <- calc "a ⊓ (b ⊓ c) = (a ⊓ b) ⊓ c" (\ABC -> a ⨅ (b ⨅ c) .== (a ⨅ b) ⨅ c) $-                 \(a :: SStroke) b c -> [] ⊢ a ⨅ (b ⨅ c)     ⁇ dne-                                           ≡ ﬧﬧ(a ⨅ (b ⨅ c)) ⁇ assoc1-                                           ≡ ﬧﬧ((a ⨅ b) ⨅ c) ⁇ dne-                                           ≡   ((a ⨅ b) ⨅ c)-                                           ≡ qed--  le_antisymm <- calc "a ≤ b → b ≤ a → a = b" (\AB -> a ≤ b .=> b ≤ a .=> a .== b) $-                      \(a :: SStroke) b -> [a ≤ b, b ≤ a] ⊢ a     ⁇ a ≤ b-                                                          ≡ b ⨅ a ⁇ commut2-                                                          ≡ a ⨅ b ⁇ b ≤ a-                                                          ≡ b-                                                          ≡ qed--  le_refl <- lemma "a ≤ a" (\A -> a ≤ a) [idemp2]--  le_trans <- calc "a ≤ b → b ≤ c → a ≤ c" (\ABC -> a ≤ b .=> b ≤ c .=> a ≤ c) $-                   \(a :: SStroke) b c -> [a ≤ b, b ≤ c] ⊢ a            ⁇ a ≤ b-                                                         ≡ b ⨅ a        ⁇ b ≤ c-                                                         ≡ (c ⨅ b) ⨅ a  ⁇ assoc2-                                                         ≡ c ⨅ (b ⨅ a)  ⁇ a ≤ b-                                                         ≡ (c ⨅ a)-                                                         ≡ qed--  lt_iff_le_not_le <- lemma "a < b ↔ a ≤ b ∧ ¬b ≤ a" (\AB -> (a < b) .<=> a ≤ b .&& sNot (b ≤ a)) [sh3]--  le_sup_left  <- lemma "a ≤ a ⊔ b" (\AB -> a ≤ a ⨆ b) [commut1, commut2, absorb2]-  le_sup_right <- lemma "b ≤ a ⊔ b" (\AB -> a ≤ a ⨆ b) [commut1, commut2, absorb2]--  sup_le <- calc "a ≤ c → b ≤ c → a ⊔ b ≤ c"-                 (\ABC -> a ≤ c .=> b ≤ c .=> a ⨆ b ≤ c) $-                 \(a :: SStroke) b c -> [a ≤ c, b ≤ c] ⊢ a ⨆ b             ⁇ [a ≤ c, b ≤ c]-                                                       ≡ (c ⨅ a) ⨆ (c ⨅ b) ⁇ distrib2-                                                       ≡ c ⨅ (a ⨆ b)-                                                       ≡ qed--  inf_le_left  <- lemma "a ⊓ b ≤ a" (\AB -> a ⨅ b ≤ a) [assoc2, idemp2]-  inf_le_right <- lemma "a ⊓ b ≤ b" (\AB -> a ⨅ b ≤ b) [commut2, inf_le_left]--  le_inf <- calc "a ≤ b → a ≤ c → a ≤ b ⊓ c"-                 (\ABC -> a ≤ b .=> a ≤ c .=> a ≤ b ⨅ c) $-                 \(a :: SStroke) b c -> [a ≤ b, a ≤ c] ⊢ a           ⁇ a ≤ b-                                                       ≡ b ⨅ a       ⁇ a ≤ c-                                                       ≡ b ⨅ (c ⨅ a) ⁇ assoc2-                                                       ≡ (b ⨅ c ⨅ a)-                                                       ≡ qed--  le_sup_inf <- lemma "(x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z"-                      (\XYZ -> (x ⨆ y) ⨅ (x ⨆ z) ≤ x ⨆ y ⨅ z)-                      [distrib1, le_refl]--  inf_compl_le_bot <- lemma "x ⊓ xᶜ ≤ ⊥" (\X -> x ⨅ ﬧ x ≤ ⲳ) [compl2, le_refl]-  top_le_sup_compl <- lemma "⊤ ≤ x ⊔ xᶜ" (\X -> т ≤ x ⨆ ﬧ x) [compl1, le_refl]--  le_top <- calc "a ≤ ⊤" (\A -> a ≤ т) $-                 \(a :: SStroke)-> [] ⊢ a ≤ т-                                      ≡ a .== т ⨅ a ⁇ commut2-                                      ≡ a .== a ⨅ т ⁇ ident2-                                      ≡ a .== a-                                      ≡ qed--  bot_le <- calc "⊥ ≤ a" (\A -> ⲳ ≤ a) $-                 \(a :: SStroke) -> [] ⊢ ⲳ ≤ a-                                       ≡ ⲳ .== a ⨅ ⲳ            ⁇ bound2-                                       ≡ (ⲳ .== (ⲳ :: SStroke))-                                       ≡ qed--  sdiff_eq <- lemma "x \\ y = x ⊓ yᶜ" (\XY -> x \\ y .== x ⨅ ﬧ y) []-  himp_eq  <- lemma "x ⇨ y = y ⊔ xᶜ"  (\XY -> x ⇨ y .== y ⨆ ﬧ x)  []--  pure BooleanAlgebraProof {-            le_refl          {- ∀ (a : α), a ≤ a                             -} = le_refl-          , le_trans         {- ∀ (a b c : α), a ≤ b → b ≤ c → a ≤ c         -} = le_trans-          , lt_iff_le_not_le {- (∀ (a b : α), a < b ↔ a ≤ b ∧ ¬b ≤ a)        -} = lt_iff_le_not_le-          , le_antisymm      {- ∀ (a b : α), a ≤ b → b ≤ a → a = b           -} = le_antisymm-          , le_sup_left      {- ∀ (a b : α), a ≤ a ⊔ b                       -} = le_sup_left-          , le_sup_right     {- ∀ (a b : α), b ≤ a ⊔ b                       -} = le_sup_right-          , sup_le           {- ∀ (a b c : α), a ≤ c → b ≤ c → a ⊔ b ≤ c     -} = sup_le-          , inf_le_left      {- ∀ (a b : α), a ⊓ b ≤ a                       -} = inf_le_left-          , inf_le_right     {- ∀ (a b : α), a ⊓ b ≤ b                       -} = inf_le_right-          , le_inf           {- ∀ (a b c : α), a ≤ b → a ≤ c → a ≤ b ⊓ c     -} = le_inf-          , le_sup_inf       {- ∀ (x y z : α), (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z -} = le_sup_inf-          , inf_compl_le_bot {- ∀ (x : α), x ⊓ xᶜ ≤ ⊥                        -} = inf_compl_le_bot-          , top_le_sup_compl {- ∀ (x : α), ⊤ ≤ x ⊔ xᶜ                        -} = top_le_sup_compl-          , le_top           {- ∀ (a : α), a ≤ ⊤                             -} = le_top-          , bot_le           {- ∀ (a : α), ⊥ ≤ a                             -} = bot_le-          , sdiff_eq         {- (∀ (x y : α), x \ y = x ⊓ yᶜ)                -} = sdiff_eq-          , himp_eq          {- (∀ (x y : α), x ⇨ y = y ⊔ xᶜ)                -} = himp_eq-       }
− Documentation/SBV/Examples/KnuckleDragger/Sqrt2IsIrrational.hs 
@@ -1,112 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.Sqrt2IsIrrational--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Prove that square-root of 2 is irrational.--------------------------------------------------------------------------------{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeAbstractions    #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.Sqrt2IsIrrational where--import Prelude hiding (even, odd)--import Data.SBV-import Data.SBV.Tools.KnuckleDragger---- | Prove that square-root of @2@ is irrational. That is, we can never find @a@ and @b@ such that--- @sqrt 2 == a / b@ and @a@ and @b@ are co-prime.------ In order not to deal with reals and square-roots, we prove the integer-only alternative:--- If @a^2 = 2b^2@, then @a@ and @b@ cannot be co-prime. We proceed by establishing the--- following helpers first:------   (1) An odd number squared is odd: @odd x -> odd x^2@---   (2) An even number that is a perfect square must be the square of an even number: @even x^2 -> even x@.---   (3) If a number is even, then its square must be a multiple of 4: @even x .=> x*x % 4 == 0@.------  Using these helpers, we can argue:------   (4)  Start with the premise @a^2 = 2b^2@.---   (5)  Thus, @a^2@ must be even. (Since it equals @2b^2@ by 4.)---   (6)  Thus, @a@ must be even. (Using 2 and 5.)---   (7)  Thus, @a^2@ must be divisible by @4@. (Using 3 and 6. That is, @2b^2 == 4K@ for some @K@.)---   (8)  Thus, @b^2@ must be even. (Using 7, and @b^2 = 2K@.)---   (9)  Thus, @b@ must be even. (Using 2 and 8.)---   (10) Since @a@ and @b@ are both even, they cannot be co-prime. (Using 6 and 9.)------ Note that our proof is mostly about the first 3 facts above, then z3 and KnuckleDragger fills in the rest.------ We have:------ >>> sqrt2IsIrrational--- Lemma: oddSquaredIsOdd---   Step: 1                               Q.E.D.---   Step: 2 (expand square)               Q.E.D.---   Result:                               Q.E.D.--- Lemma: squareEvenImpliesEven            Q.E.D.--- Lemma: evenSquaredIsMult4---   Step: 1                               Q.E.D.---   Step: 2 (expand square)               Q.E.D.---   Result:                               Q.E.D.--- Lemma: sqrt2IsIrrational                Q.E.D.--- [Proven] sqrt2IsIrrational-sqrt2IsIrrational :: IO Proof-sqrt2IsIrrational = runKD $ do-    let even, odd :: SInteger -> SBool-        even = (2 `sDivides`)-        odd  = sNot . even--        sq :: SInteger -> SInteger-        sq x = x * x--    -- Prove that an odd number squared gives you an odd number.-    -- We need to help the solver by guiding it through how it can-    -- be decomposed as @2k+1@.-    ---    -- Interestingly, the solver doesn't need the analogous theorem that even number-    -- squared is even, possibly because the even/odd definition above is enough for-    -- it to deduce that fact automatically.-    oddSquaredIsOdd <- calc "oddSquaredIsOdd"-                             (\(Forall @"a" a) -> odd a .=> odd (sq a)) $-                             \a -> [odd a] |- sq a-                                           =: let k = some "k" $ \_k -> a .== 2*_k + 1  -- Grab the witness that a is odd-                                           in sq (2 * k + 1)-                                           ?? "expand square"-                                           =: 4*k*k + 4*k + 1-                                           =: qed--    -- Prove that if a perfect square is even, then it be the square of an even number. For z3, the above proof-    -- is enough to establish this.-    squareEvenImpliesEven <- lemma "squareEvenImpliesEven"-                                   (\(Forall @"a" a) -> even (sq a) .=> even a)-                                   [oddSquaredIsOdd]--    -- Prove that if @a@ is an even number, then its square is four times the square of another.-    evenSquaredIsMult4 <- calc "evenSquaredIsMult4"-                               (\(Forall @"a" a) -> even a .=> 4 `sDivides` sq a) $-                               \a -> [even a] |- sq a-                                              =: let k = some "k" $ \_k -> a .== 2*_k -- Grab the witness that a is even-                                              in sq (2 * k)-                                              ?? "expand square"-                                              =: 4*(k*k)-                                              =: qed--    -- Define what it means to be co-prime. Note that we use euclidian notion of modulus here-    -- as z3 deals with that much better. Two numbers are co-prime if 1 is their only common divisor.-    let coPrime :: SInteger -> SInteger -> SBool-        coPrime x y = quantifiedBool (\(Forall @"z" z) -> (x `sEMod` z .== 0 .&& y `sEMod` z .== 0) .=> z .== 1)--    -- Prove that square-root of 2 is irrational. We do this by showing for all pairs of integers @a@ and @b@-    -- such that @a*a == 2*b*b@, it must be the case that @a@ and @b@ are not be co-prime:-    lemma "sqrt2IsIrrational"-        (\(Forall @"a" a) (Forall @"b" b) -> (sq a .== 2 * sq b) .=> sNot (coPrime a b))-        [squareEvenImpliesEven, evenSquaredIsMult4]
− Documentation/SBV/Examples/KnuckleDragger/StrongInduction.hs 
@@ -1,366 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.StrongInduction--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Examples of strong induction.--------------------------------------------------------------------------------{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeAbstractions    #-}-{-# LANGUAGE TypeApplications    #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.StrongInduction where--import Prelude hiding (length, null, head, tail, reverse, (++))--import Data.SBV-import Data.SBV.List-import Data.SBV.Tuple-import Data.SBV.Tools.KnuckleDragger--#ifdef DOCTEST--- $setup--- >>> :set -XScopedTypeVariables--- >>> import Control.Exception-#endif---- * Numeric examples---- | Prove that the sequence @1@, @3@, @S_{k-2} + 2 S_{k-1}@ is always odd.------ We have:------ >>> oddSequence1--- Inductive lemma (strong): oddSequence---   Step: Measure is non-negative         Q.E.D.---   Step: 1 (3 way case split)---     Step: 1.1                           Q.E.D.---     Step: 1.2                           Q.E.D.---     Step: 1.3.1                         Q.E.D.---     Step: 1.3.2                         Q.E.D.---     Step: 1.3.3                         Q.E.D.---     Step: 1.Completeness                Q.E.D.---   Result:                               Q.E.D.--- [Proven] oddSequence-oddSequence1 :: IO Proof-oddSequence1 = runKD $ do-  let s :: SInteger -> SInteger-      s = smtFunction "seq" $ \n -> ite (n .<= 0) 1-                                  $ ite (n .== 1) 3-                                  $ s (n-2) + 2 * s (n-1)--  -- z3 can't handle this, but CVC5 is proves it just fine.-  -- Note also that we do a "proof-by-contradiction," by deriving that-  -- the negation of the goal leads to falsehood.-  sInductWith cvc5 "oddSequence"-          (\(Forall @"n" n) -> n .>= 0 .=> sNot (2 `sDivides` s n)) (abs @SInteger) $-          \ih n -> [n .>= 0] |- 2 `sDivides` s n-                             =: cases [ n .== 0 ==> contradiction-                                      , n .== 1 ==> contradiction-                                      , n .>= 2 ==> 2 `sDivides` (s (n-2) + 2 * s (n-1))-                                                 =: 2 `sDivides` s (n-2)-                                                 ?? ih `at` Inst @"n" (n - 2)-                                                 =: contradiction-                                      ]---- | Prove that the sequence @1@, @3@, @2 S_{k-1} - S_{k-2}@ generates sequence of odd numbers.------ We have:------ >>> oddSequence2--- Lemma: oddSequence_0                              Q.E.D.--- Lemma: oddSequence_1                              Q.E.D.--- Inductive lemma (strong): oddSequence_sNp2---   Step: Measure is non-negative                   Q.E.D.---   Step: 1                                         Q.E.D.---   Step: 2                                         Q.E.D.---   Step: 3 (simplify)                              Q.E.D.---   Step: 4                                         Q.E.D.---   Step: 5 (simplify)                              Q.E.D.---   Step: 6                                         Q.E.D.---   Result:                                         Q.E.D.--- Lemma: oddSequence2---   Step: 1 (3 way case split)---     Step: 1.1                                     Q.E.D.---     Step: 1.2                                     Q.E.D.---     Step: 1.3.1                                   Q.E.D.---     Step: 1.3.2                                   Q.E.D.---     Step: 1.Completeness                          Q.E.D.---   Result:                                         Q.E.D.--- [Proven] oddSequence2-oddSequence2 :: IO Proof-oddSequence2 = runKDWith z3{kdOptions = (kdOptions z3) {ribbonLength = 50}} $ do-  let s :: SInteger -> SInteger-      s = smtFunction "seq" $ \n -> ite (n .<= 0) 1-                                  $ ite (n .== 1) 3-                                  $ 2 * s (n-1) - s (n-2)--  s0 <- lemma "oddSequence_0" (s 0 .== 1) []-  s1 <- lemma "oddSequence_1" (s 1 .== 3) []--  sNp2 <- sInduct "oddSequence_sNp2"-                  (\(Forall @"n" n) -> n .>= 2 .=> s n .== 2 * n + 1) (abs @SInteger) $-                  \ih n -> [n .>= 2] |- s n-                                     =: 2 * s (n-1) - s (n-2)-                                     ?? ih `at` Inst @"n" (n-1)-                                     =: 2 * (2 * (n-1) + 1) - s (n-2)-                                     ?? "simplify"-                                     =: 4*n - 4 + 2 - s (n-2)-                                     ?? ih `at` Inst @"n" (n-2)-                                     =: 4*n - 2 - (2 * (n-2) + 1)-                                     ?? "simplify"-                                     =: 4*n - 2 - 2*n + 4 - 1-                                     =: 2*n + 1-                                     =: qed--  calc "oddSequence2" (\(Forall @"n" n) -> n .>= 0 .=> s n .== 2 * n + 1) $-                      \n -> [n .>= 0] |- s n-                                      =: cases [ n .== 0 ==> (1 :: SInteger) =: qed-                                               , n .== 1 ==> (3 :: SInteger) =: qed-                                               , n .>= 2 ==>    s n-                                                             ?? [ s0-                                                                , s1-                                                                , sNp2 `at` Inst @"n" n-                                                                ]-                                                             =: 2 * n + 1-                                                             =: qed-                                               ]---- * List examples---- | Interleave the elements of two lists. If one ends, we take the rest from the other.-interleave :: SymVal a => SList a -> SList a -> SList a-interleave = smtFunction "interleave" (\xs ys -> ite (null  xs) ys (head xs .: interleave ys (tail xs)))---- | Prove that interleave preserves total length.------ The induction here is on the total length of the lists, and hence--- we use the generalized induction principle. We have:------ >>> interleaveLen--- Inductive lemma (strong): interleaveLen---   Step: Measure is non-negative         Q.E.D.---   Step: 1 (2 way full case split)---     Step: 1.1                           Q.E.D.---     Step: 1.2.1                         Q.E.D.---     Step: 1.2.2                         Q.E.D.---     Step: 1.2.3                         Q.E.D.---   Result:                               Q.E.D.--- [Proven] interleaveLen-interleaveLen :: IO Proof-interleaveLen = runKD $ do--   sInduct "interleaveLen"-           (\(Forall @"xs" xs) (Forall @"ys" ys) -> length xs + length ys .== length (interleave @Integer xs ys))-           (\xs ys -> length @Integer xs + length @Integer ys) $-           \ih xs ys ->-              [] |- length xs + length ys .== length (interleave @Integer xs ys)-                 =: split xs-                          trivial-                          (\a as -> length (a .: as) + length ys .== length (interleave (a .: as) ys)-                                 =: 1 + length as + length ys .== 1 + length (interleave ys as)-                                 ?? ih `at` (Inst @"xs" ys, Inst @"ys" as)-                                 =: sTrue-                                 =: qed)---- | Uninterleave the elements of two lists. We roughly split it into two, of alternating elements.-uninterleave :: SymVal a => SList a -> STuple [a] [a]-uninterleave lst = uninterleaveGen lst (tuple (nil, nil))---- | Generalized form of uninterleave with the auxilary lists made explicit.C-uninterleaveGen :: SymVal a => SList a -> STuple [a] [a] -> STuple [a] [a]-uninterleaveGen = smtFunction "uninterleave" (\xs alts -> let (es, os) = untuple alts-                                                          in ite (null xs)-                                                                 (tuple (reverse es, reverse os))-                                                                 (uninterleaveGen (tail xs) (tuple (os, head xs .: es))))---- | The functions 'uninterleave' and 'interleave' are inverses so long as the inputs are of the same length. (The equality--- would even hold if the first argument has one extra element, but we keep things simple here.)------ We have:------ >>> interleaveRoundTrip--- Lemma: revCons                          Q.E.D.--- Inductive lemma (strong): roundTripGen---   Step: Measure is non-negative         Q.E.D.---   Step: 1 (4 way full case split)---     Step: 1.1                           Q.E.D.---     Step: 1.2                           Q.E.D.---     Step: 1.3                           Q.E.D.---     Step: 1.4.1                         Q.E.D.---     Step: 1.4.2                         Q.E.D.---     Step: 1.4.3                         Q.E.D.---     Step: 1.4.4                         Q.E.D.---     Step: 1.4.5                         Q.E.D.---     Step: 1.4.6                         Q.E.D.---     Step: 1.4.7                         Q.E.D.---     Step: 1.4.8                         Q.E.D.---   Result:                               Q.E.D.--- Lemma: interleaveRoundTrip---   Step: 1                               Q.E.D.---   Step: 2                               Q.E.D.---   Result:                               Q.E.D.--- [Proven] interleaveRoundTrip-interleaveRoundTrip :: IO Proof-interleaveRoundTrip = runKDWith cvc5 $ do--   revHelper <- lemma "revCons" (\(Forall @"a" a) (Forall @"as" as) (Forall @"bs" bs)-                                        -> reverse @Integer (a .: as) ++ bs .== reverse as ++ (a .: bs)) []--   -- Generalize the theorem first to take the helper lists explicitly-   roundTripGen <- sInduct-         "roundTripGen"-         (\(Forall @"xs" xs) (Forall @"ys" ys) (Forall @"alts" alts) ->-               length @Integer xs .== length ys-                  .=> let (es, os) = untuple alts-                      in uninterleaveGen (interleave xs ys) alts .== tuple (reverse es ++ xs, reverse os ++ ys))-         (\xs ys (_alts :: STuple [Integer] [Integer]) -> length @Integer xs + length @Integer ys) $-         \ih xs ys alts -> [length @Integer xs .== length ys]-                        |- let (es, os) = untuple alts-                        in uninterleaveGen (interleave xs ys) alts-                        =: split2 (xs, ys)-                                  trivial-                                  trivial-                                  trivial-                                  (\(a, as) (b, bs) -> uninterleaveGen (interleave (a .: as) (b .: bs)) alts-                                                    =: uninterleaveGen (a .: interleave (b .: bs) as) alts-                                                    =: uninterleaveGen (a .: b .: interleave as bs) alts-                                                    =: uninterleaveGen (interleave as bs) (tuple (a .: es, b .: os))-                                                    ?? ih `at` (Inst @"xs" as, Inst @"ys" bs, Inst @"alts" (tuple (a .: es, b .: os)))-                                                    =: tuple (reverse (a .: es) ++ as, reverse (b .: os) ++ bs)-                                                    ?? revHelper `at` (Inst @"a" a, Inst @"as" es, Inst @"bs" as)-                                                    =: tuple (reverse es ++ (a .: as), reverse (b .: os) ++ bs)-                                                    ?? revHelper `at` (Inst @"a" b, Inst @"as" os, Inst @"bs" bs)-                                                    =: tuple (reverse es ++ (a .: as), reverse os ++ (b .: bs))-                                                    =: tuple (reverse es ++ xs, reverse os ++ ys)-                                                    =: qed)--   -- Round-trip theorem:-   calc "interleaveRoundTrip"-           (\(Forall @"xs" xs) (Forall @"ys" ys) -> length xs .== length ys .=> uninterleave (interleave @Integer xs ys) .== tuple (xs, ys)) $-           \xs ys -> [length xs .== length ys]-                  |- uninterleave (interleave @Integer xs ys)-                  =: uninterleaveGen (interleave xs ys) (tuple (nil, nil))-                  ?? roundTripGen `at` (Inst @"xs" xs, Inst @"ys" ys, Inst @"alts" (tuple (nil :: SList Integer, nil :: SList Integer)))-                  =: tuple (reverse nil ++ xs, reverse nil ++ ys)-                  =: qed---- * Strong induction checks---- | For strong induction to work, We have to instantiate the proof at a "smaller" value. This--- example demonstrates what happens if we don't. We have:------ >>> won'tProve1 `catch` (\(_ :: SomeException) -> pure ())--- Inductive lemma (strong): lengthGood---   Step: Measure is non-negative         Q.E.D.---   Step: 1--- *** Failed to prove lengthGood.1.--- <BLANKLINE>--- *** Solver reported: canceled-won'tProve1 :: IO ()-won'tProve1 = runKD $ do-   let len :: SList Integer -> SInteger-       len = smtFunction "len" $ \xs -> ite (null xs) 0 (1 + len (tail xs))--   -- Run it for 5 seconds, as otherwise z3 will hang as it can't prove make the inductive step-   _ <- sInductWith z3{extraArgs = ["-t:5000"]} "lengthGood"-                (\(Forall @"xs" xs) -> len xs .== length xs)-                (length @Integer) $-                \ih xs -> [] |- len xs-                             -- incorrectly instantiate the IH at xs!-                             ?? ih `at` Inst @"xs" xs-                             =: length xs-                             =: qed-   pure ()---- | Note that strong induction does not need an explicit base case, as the base-cases is folded into the--- inductive step. Here's an example demonstrating what happens when the failure is only at the base case.------ >>> won'tProve2 `catch` (\(_ :: SomeException) -> pure ())--- Inductive lemma (strong): badLength---   Step: Measure is non-negative         Q.E.D.---   Step: 1--- *** Failed to prove badLength.1.--- Falsifiable. Counter-example:---   xs = [] :: [Integer]-won'tProve2 :: IO ()-won'tProve2 = runKD $ do-   let len :: SList Integer -> SInteger-       len = smtFunction "badLength" $ \xs -> ite (null xs)-                                                  123-                                                  (ite (null xs)-                                                       0-                                                       (1 + len (tail xs)))--   _ <- sInduct "badLength"-                (\(Forall @"xs" xs) -> len xs .== length xs)-                (length @Integer) $-                \ih xs -> [] |- len xs-                             ?? ih `at` Inst @"xs" xs-                             =: length xs-                             =: qed-   pure ()---- | The measure for strong induction should always produce a non-negative measure. The measure, in general, is an integer, or--- a tuple of integers, for tuples upto size 5. The ordering is lexicographic. This allows us to do proofs over 5-different arguments--- where their total measure goes down. If the measure can be negative, then we flag that as a failure, as demonstrated here. We have:------ >>> won'tProve3 `catch` (\(_ :: SomeException) -> pure ())--- Inductive lemma (strong): badMeasure---   Step: Measure is non-negative--- *** Failed to prove badMeasure.Measure is non-negative.--- Falsifiable. Counter-example:---   x = -1 :: Integer-won'tProve3 :: IO ()-won'tProve3 = runKD $ do-   _ <- sInduct "badMeasure"-                (\(Forall @"x" (x :: SInteger)) -> x .== x)-                (id @SInteger) $-                \_h (x :: SInteger) -> [] |- x-                                          =: x-                                          =: qed--   pure ()---- | The measure must always go down using lexicographic ordering. If not, SBV will flag this as a failure. We have:------ >>> won'tProve4 `catch` (\(_ :: SomeException) -> pure ())--- Inductive lemma (strong): badMeasure---   Step: Measure is non-negative         Q.E.D.---   Step: 1 (2 way case split)---     Step: 1.1                           Q.E.D.---     Step: 1.2.1                         Q.E.D.---     Step: 1.2.2--- *** Failed to prove badMeasure.1.2.2.--- <BLANKLINE>--- *** Solver reported: canceled-won'tProve4 :: IO ()-won'tProve4 = runKD $ do--   let -- a bizarre (but valid!) way to sum two integers-       weirdSum = smtFunction "weirdSum" (\x y -> ite (x .<= 0) y (weirdSum (x - 1) (y + 1)))--   _ <- sInductWith z3{extraArgs = ["-t:5000"]} "badMeasure"-                (\(Forall @"x" (x :: SInteger)) (Forall @"y" (y :: SInteger)) -> x .>= 0 .=> weirdSum x y .== x + y)-                -- This measure is not good, since it remains the same. Note that we do not get a-                -- failure, but the proof will never converge either; so we put a time bound-                (\x y -> abs x + abs @SInteger y) $-                \ih (x :: SInteger) (y :: SInteger) ->-                    [x .>= 0] |- ite (x .<= 0) y (weirdSum (x - 1) (y + 1))-                              =: cases [ x .<= 0 ==> trivial-                                       , x .>  0 ==> weirdSum (x - 1) (y + 1)-                                                  ?? ih `at` (Inst @"x" (x - 1), Inst @"y" (y + 1))-                                                  =: x - 1 + y + 1-                                                  =: x + y-                                                  =: qed-                                       ]--   pure ()
− Documentation/SBV/Examples/KnuckleDragger/Tao.hs 
@@ -1,62 +0,0 @@--------------------------------------------------------------------------------- |--- Module    : Documentation.SBV.Examples.KnuckleDragger.Tao--- Copyright : (c) Levent Erkok--- License   : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Proves a problem originating in algebra:---   https://mathoverflow.net/questions/450890/is-there-an-identity-between-the-commutative-identity-and-the-constant-identity/------ Apparently this was posed by Terrence Tao: https://mathstodon.xyz/@tao/110736805384878353------ Essentially, for an arbitrary binary operation op, we prove that------ @---    (x op x) op y == y op x--- @------ Implies that @op@ must be commutative.---------------------------------------------------------------------------------{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DataKinds          #-}-{-# LANGUAGE TypeAbstractions   #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell    #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.KnuckleDragger.Tao where--import Data.SBV-import Data.SBV.Tools.KnuckleDragger---- | Create an uninterpreted type to do the proofs over.-data T-mkUninterpretedSort ''T---- | Prove that:------  @---    (x op x) op y == y op x---  @------  means that @op@ is commutative.------ We have:------ >>> tao--- Lemma: tao                              Q.E.D.--- [Proven] tao-tao :: IO Proof-tao = runKD $ do-   let op :: ST -> ST -> ST-       op = uninterpret "op"--   lemma "tao" (    quantifiedBool (\(Forall @"x" x) (Forall @"y" y) -> ((x `op` x) `op` y) .== y `op` x)-                .=> quantifiedBool (\(Forall @"x" x) (Forall @"y" y) -> (x `op` y) .== (y `op` x)))-               []
Documentation/SBV/Examples/Lists/BoundedMutex.hs view
@@ -24,22 +24,19 @@ import Data.SBV import Data.SBV.Control -import Prelude hiding ((!!))-import Data.SBV.List ((!!))-import qualified Data.SBV.List as L- -- | Each agent can be in one of the three states data State = Idle     -- ^ Regular work            | Ready    -- ^ Intention to enter critical state            | Critical -- ^ In the critical state+           deriving (Enum, Bounded)  -- | Make 'State' a symbolic enumeration mkSymbolicEnumeration ''State  -- | The mutex property holds for two sequences of state transitions, if they are not in -- their critical section at the same time.-mutex :: SList State -> SList State -> SBool-mutex p1s p2s = L.and $ L.zipWith (\p1 p2 -> p1 ./= sCritical .|| p2 ./= sCritical) p1s p2s+mutex :: [SState] -> [SState] -> SBool+mutex p1s p2s = sAnd $ zipWith (\p1 p2 -> p1 ./= sCritical .|| p2 ./= sCritical) p1s p2s  -- | A sequence is valid upto a bound if it starts at 'Idle', and follows the mutex rules. That is: --@@ -48,36 +45,31 @@ --    * From 'Critical' it can either stay in 'Critical' or go back to 'Idle' -- -- The variable @me@ identifies the agent id.-validSequence :: Int -> Integer -> SList Integer -> SList State -> SBool-validSequence b me pturns proc = sAnd [ L.length proc .== fromIntegral b-                                      , sIdle .== L.head proc-                                      , check b pturns proc sIdle-                                      ]-   where check 0 _  _  _    = sTrue-         check i ts ps prev = let (cur,  rest)  = L.uncons ps-                                  (turn, turns) = L.uncons ts-                                  ok   = ite (prev .== sIdle)                          (cur `sElem` [sIdle, sReady])-                                       $ ite (prev .== sReady .&& turn .== literal me) (cur `sElem` [sCritical])-                                       $ ite (prev .== sCritical)                      (cur `sElem` [sCritical, sIdle])-                                                                                       (cur `sElem` [prev])-                              in ok .&& check (i-1) turns rest cur+validSequence :: Integer -> [SInteger] -> [SState] -> SBool+validSequence _  []     _           = sTrue+validSequence _  _      []          = sTrue+validSequence me pturns procs@(p:_) = sAnd [ sIdle .== p+                                           , check pturns procs sIdle+                                           ]+   where check []           _          _    = sTrue+         check _            []         _    = sTrue+         check (turn:turns) (cur:rest) prev = ok .&& check turns rest cur+           where ok = ite (prev .== sIdle)                          (cur `sElem` [sIdle, sReady])+                    $ ite (prev .== sReady .&& turn .== literal me) (cur `sElem` [sCritical])+                    $ ite (prev .== sCritical)                      (cur `sElem` [sCritical, sIdle])+                                                                    (cur `sElem` [prev])  -- | The mutex algorithm, coded implicitly as an assignment to turns. Turns start at @1@, and at each stage is either -- @1@ or @2@; giving preference to that process. The only condition is that if either process is in its critical -- section, then the turn value stays the same. Note that this is sufficient to satisfy safety (i.e., mutual -- exclusion), though it does not guarantee liveness.-validTurns :: Int -> SList Integer -> SList State -> SList State -> SBool-validTurns b turns process1 process2 = sAnd [ L.length turns .== fromIntegral b-                                            , 1 .== L.head turns-                                            , check b turns process1 process2 1-                                            ]-   where check 0 _  _     _     _    = sTrue-         check i ts proc1 proc2 prev =   cur `sElem` [1, 2]-                                     .&& (p1 .== sCritical .|| p2 .== sCritical .=> cur .== prev)-                                     .&& check (i-1) rest p1s p2s cur-            where (cur, rest) = L.uncons ts-                  (p1,  p1s)  = L.uncons proc1-                  (p2,  p2s)  = L.uncons proc2+validTurns :: [SInteger] -> [SState] -> [SState] -> SBool+validTurns []                    _        _        = sTrue+validTurns turns@(firstTurn : _) process1 process2 = firstTurn .== 1 .&& check (zip3 turns process1 process2) 1+  where check []                     _    = sTrue+        check ((cur, p1, p2) : rest) prev =   cur `sElem` map literal [1, 2]+                                          .&& (p1 .== sCritical .|| p2 .== sCritical .=> cur .== prev)+                                          .&& check rest cur  -- | Check that we have the mutex property so long as 'validSequence' and 'validTurns' holds; i.e., -- so long as both the agents and the arbiter act according to the rules. The check is bounded up-to-the@@ -87,14 +79,14 @@ -- All is good! checkMutex :: Int -> IO () checkMutex b = runSMT $ do-                  p1    :: SList State   <- sList "p1"-                  p2    :: SList State   <- sList "p2"-                  turns :: SList Integer <- sList "turns"+                  p1    :: [SState]   <- mapM (\i -> free ("p1_" ++ show i)) [1 .. b]+                  p2    :: [SState]   <- mapM (\i -> free ("p2_" ++ show i)) [1 .. b]+                  turns :: [SInteger] <- mapM (\i -> free ("t_"  ++ show i)) [1 .. b]                    -- Ensure that both sequences and the turns are valid-                  constrain $ validSequence b 1 turns p1-                  constrain $ validSequence b 2 turns p2-                  constrain $ validTurns    b turns p1 p2+                  constrain $ validSequence 1 turns p1+                  constrain $ validSequence 2 turns p2+                  constrain $ validTurns      turns p1 p2                    -- Try to assert that mutex does not hold. If we get a                   -- counter example, we would've found a violation!@@ -106,9 +98,9 @@                                DSat{} -> error "Solver said delta-satisfiable!"                                Unsat  -> io . putStrLn $ "All is good!"                                Sat    -> do io . putStrLn $ "Violation detected!"-                                            do p1V <- getValue p1-                                               p2V <- getValue p2-                                               ts  <- getValue turns+                                            do p1V <- mapM getValue p1+                                               p2V <- mapM getValue p2+                                               ts  <- mapM getValue turns                                                 io . putStrLn $ "P1: " ++ show p1V                                                io . putStrLn $ "P2: " ++ show p2V@@ -121,7 +113,7 @@ -- -- >>> notFair 10 -- Fairness is violated at bound: 10--- P1: [Idle,Idle,Idle,Ready,Critical,Critical,Critical,Idle,Ready,Critical]+-- P1: [Idle,Idle,Ready,Critical,Idle,Ready,Critical,Critical,Idle,Ready] -- P2: [Idle,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready] -- Ts: [1,1,1,1,1,1,1,1,1,1] --@@ -132,21 +124,21 @@ -- from the previous value if neither process is in critical. Show that this makes the 'notFair' -- function below no longer exhibits the issue. Is this sufficient? Concurrent programming is tricky! notFair :: Int -> IO ()-notFair b = runSMT $ do p1    :: SList State   <- sList "p1"-                        p2    :: SList State   <- sList "p2"-                        turns :: SList Integer <- sList "turns"+notFair b = runSMT $ do p1    :: [SState]   <- mapM (\i -> free ("p1_" ++ show i)) [1 .. b]+                        p2    :: [SState]   <- mapM (\i -> free ("p2_" ++ show i)) [1 .. b]+                        turns :: [SInteger] <- mapM (\i -> free ("t_"  ++ show i)) [1 .. b]                          -- Ensure that both sequences and the turns are valid-                        constrain $ validSequence b 1 turns p1-                        constrain $ validSequence b 2 turns p2-                        constrain $ validTurns    b turns p1 p2+                        constrain $ validSequence 1 turns p1+                        constrain $ validSequence 2 turns p2+                        constrain $ validTurns    turns p1 p2                          -- Ensure that the second process becomes ready in the second cycle:                         constrain $ p2 !! 1 .== sReady                          -- Find a trace where p2 never goes critical                         -- counter example, we would've found a violation!-                        constrain $ sNot $ sCritical `L.elem` p2+                        constrain $ sNot $ sCritical `sElem` p2                          query $ do cs <- checkSat                                    case cs of@@ -154,9 +146,9 @@                                      DSat{} -> error "Solver said delta-satisfiable!"                                      Unsat  -> error "Solver couldn't find a violating trace!"                                      Sat    -> do io . putStrLn $ "Fairness is violated at bound: " ++ show b-                                                  do p1V <- getValue p1-                                                     p2V <- getValue p2-                                                     ts  <- getValue turns+                                                  do p1V <- mapM getValue p1+                                                     p2V <- mapM getValue p2+                                                     ts  <- mapM getValue turns                                                       io . putStrLn $ "P1: " ++ show p1V                                                      io . putStrLn $ "P2: " ++ show p2V
Documentation/SBV/Examples/Misc/Definitions.hs view
@@ -76,7 +76,7 @@ --   s0 = [1,2,3] :: [Integer] --   s1 =       3 :: Integer lenExample :: IO SatResult-lenExample = sat $ \a r -> a .== [1,2,3::Integer] .&& r .== len a+lenExample = sat $ \a r -> a .== [1,2,3] .&& r .== len a  ------------------------------------------------------------------------- -- * Mutual recursion@@ -101,8 +101,8 @@ evenOdd :: IO SatResult evenOdd = satWith z3{verbose=True} $ \a r -> a .== 20 .&& r .== isE a   where isE, isO :: SInteger -> SBool-        isE = smtFunction "isE" $ \x -> ite (x .< 0) (isE (-x)) (x .== 0 .|| isO  (x - 1))-        isO = smtFunction "isO"  $ \x -> ite (x .< 0) (isO  (-x)) (x .== 0 .|| isE (x - 1))+        isE = smtFunction "isE" $ \x -> ite (x .< 0) (isE (-x)) (x .== 0 .|| isO (x - 1))+        isO = smtFunction "isO" $ \x -> ite (x .< 0) (isO (-x)) (x .== 0 .|| isE (x - 1))  -- | Another technique to handle mutually definitions is to define the functions together, and pull the results out individually. -- This usually works better than defining the functions separately, from a solver perspective.
Documentation/SBV/Examples/Misc/Enumerate.hs view
@@ -32,6 +32,7 @@ -- @TemplateHaskell@, @StandaloneDeriving@, @DeriveDataTypeable@, @DeriveAnyClass@ for -- this to work. data E = A | B | C+       deriving (Enum, Bounded, Eq, Ord)  -- | Make 'E' a symbolic value. mkSymbolicEnumeration ''E
Documentation/SBV/Examples/Misc/FirstOrderLogic.hs view
@@ -45,6 +45,8 @@  -- | An enumerated type for demo purposes, named 'E' data E = A | B | C+       deriving (Enum, Bounded, Ord, Eq)+ mkSymbolicEnumeration ''E  -- | Helper to turn quantified formula to a regular boolean. We
Documentation/SBV/Examples/Misc/Floating.hs view
@@ -179,9 +179,7 @@ -- -- we see that the "more precise" result is larger than what the 'Float' value is, justifying the -- larger value with 'RoundTowardPositive. A more detailed study is beyond our current scope, so we'll--- merely note that floating point representation and semantics is indeed a thorny--- subject, and point to <http://ece.uwaterloo.ca/~dwharder/NumericalAnalysis/02Numerics/Double/paper.pdf> as--- an excellent guide.+-- merely note that floating point representation and semantics is indeed a thorny subject. roundingAdd :: IO SatResult roundingAdd = sat $ do m :: SRoundingMode <- free "rm"                        constrain $ m ./= literal RoundNearestTiesToEven
Documentation/SBV/Examples/Misc/Newtypes.hs view
@@ -15,13 +15,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables        #-} -{-# OPTIONS_GHC -Wall -Werror           #-}+{-# OPTIONS_GHC -Wall -Werror #-}  module Documentation.SBV.Examples.Misc.Newtypes where  import Prelude hiding (ceiling) import Data.SBV import qualified Data.SBV.Internals as SI+import Test.QuickCheck(Arbitrary)  #ifdef DOCTEST -- $setup@@ -29,10 +30,10 @@ #endif  -- | A t'Metres' is a newtype wrapper around 'Integer'.-newtype Metres = Metres Integer deriving (Real, Integral, Num, Enum, Eq, Ord)+newtype Metres = Metres Integer deriving (Real, Integral, Num, Enum, Eq, Ord, Arbitrary)  -- | Symbolic version of t'Metres'.-type SMetres   = SBV Metres+type SMetres = SBV Metres  -- | To use t'Metres' symbolically, we associate it with the underlying symbolic -- type's kind.@@ -42,15 +43,16 @@ -- | The 'SymVal' instance simply uses stock definitions. This is always -- possible for newtypes that simply wrap over an existing symbolic type. instance SymVal Metres where-   mkSymVal = SI.genMkSymVar KUnbounded-   literal  = SI.genLiteral  KUnbounded-   fromCV   = SI.genFromCV+   mkSymVal    = SI.genMkSymVar KUnbounded+   literal     = SI.genLiteral  KUnbounded+   fromCV      = SI.genFromCV+   minMaxBound = Nothing  -- | Similarly, we can create another newtype, this time wrapping over 'Word16'. As an example, -- consider measuring the human height in centimetres? The tallest person in history, -- Robert Wadlow, was 272 cm. We don't need negative values, so 'Word16' is the smallest type that -- suits our needs.-newtype HumanHeightInCm = HumanHeightInCm Word16 deriving (Real, Integral, Num, Enum, Eq, Ord)+newtype HumanHeightInCm = HumanHeightInCm Word16 deriving (Real, Integral, Num, Enum, Eq, Ord, Bounded, Arbitrary)  -- | Symbolic version of t'HumanHeightInCm'. type SHumanHeightInCm = SBV HumanHeightInCm
Documentation/SBV/Examples/Misc/Tuple.hs view
@@ -13,6 +13,7 @@ -- arbitrary criteria. ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -28,8 +29,7 @@ import Data.SBV.List   ((!!)) import Data.SBV.RegExp -import qualified Data.SBV.String as S-import qualified Data.SBV.List   as L+import qualified Data.SBV.List as L  -- | A dictionary is a list of lookup values. Note that we -- store the type @[(a, b)]@ as a symbolic value here, mixing@@ -62,12 +62,12 @@                        -- require each key to be at of length 3 more than the index it occupies                       -- and look like an identifier-                      let goodKey i s = let l = S.length s+                      let goodKey i s = let l = L.length s                                             r = asciiLower * KStar (asciiLetter + digit + "_" + "'")                                       in l .== fromIntegral i+3 .&& s `match` r                            restrict i = case untuple (dict !! fromIntegral i) of-                                         (k, v) -> constrain $ goodKey i k .&& v .== S.length k+                                         (k, v) -> constrain $ goodKey i k .&& v .== L.length k                        mapM_ restrict range
Documentation/SBV/Examples/Optimization/Enumerate.hs view
@@ -25,6 +25,7 @@  -- | A simple enumeration data Day = Mon | Tue | Wed | Thu | Fri | Sat | Sun+         deriving (Enum, Bounded)  -- | Make 'Day' a symbolic value. mkSymbolicEnumeration ''Day
Documentation/SBV/Examples/ProofTools/Fibonacci.hs view
@@ -94,7 +94,7 @@                            .&& m .== fib i          -- Final goal. When the termination condition holds, the value @m@-        -- holds the @n@th fibonacc number. Note that SBV does not prove the+        -- holds the @n@th fibonacci number. Note that SBV does not prove the         -- termination condition; it simply is the indication that the loop         -- has ended as specified by the user.         goal :: S SInteger -> (SBool, SBool)
Documentation/SBV/Examples/Puzzles/Birthday.hs view
@@ -52,9 +52,11 @@  -- | Months. We only put in the months involved in the puzzle for simplicity data Month = May | Jun | Jul | Aug+           deriving (Enum, Bounded)  -- | Days. Again, only the ones mentioned in the puzzle. data Day = D14 | D15 | D16 | D17 | D18 | D19+         deriving (Enum, Bounded)  mkSymbolicEnumeration ''Month mkSymbolicEnumeration ''Day
Documentation/SBV/Examples/Puzzles/Counts.hs view
@@ -44,7 +44,7 @@                         (upd d1 (upd d2 (upd d3 cnts))))  -- three digits   where (r1, d1)   = n  `sQuotRem` 10         (d3, d2)   = r1 `sQuotRem` 10-        upd d = zipWith inc [0..]+        upd d = zipWith inc (map literal [0..])           where inc i c = ite (i .== d) (c+1) c  -- | Encoding of the puzzle. The solution is a sequence of 10 numbers
Documentation/SBV/Examples/Puzzles/DieHard.hs view
@@ -30,6 +30,7 @@  -- | Possible actions data Action = Initial | FillBig | FillSmall | EmptyBig | EmptySmall | BigToSmall | SmallToBig+            deriving (Enum, Bounded)  mkSymbolicEnumeration ''Action
Documentation/SBV/Examples/Puzzles/Fish.hs view
@@ -41,30 +41,35 @@  -- | Colors of houses data Color = Red | Green | White | Yellow | Blue+           deriving (Enum, Bounded)  -- | Make 'Color' a symbolic value. mkSymbolicEnumeration ''Color  -- | Nationalities of the occupants data Nationality = Briton | Dane | Swede | Norwegian | German+                 deriving (Enum, Bounded)  -- | Make 'Nationality' a symbolic value. mkSymbolicEnumeration ''Nationality  -- | Beverage choices data Beverage = Tea | Coffee | Milk | Beer | Water+              deriving (Enum, Bounded)  -- | Make 'Beverage' a symbolic value. mkSymbolicEnumeration ''Beverage  -- | Pets they keep data Pet = Dog | Horse | Cat | Bird | Fish+         deriving (Enum, Bounded)  -- | Make 'Pet' a symbolic value. mkSymbolicEnumeration ''Pet  -- | Sports they engage in data Sport = Football | Baseball | Volleyball | Hockey | Tennis+           deriving (Enum, Bounded)  -- | Make 'Sport' a symbolic value. mkSymbolicEnumeration ''Sport
Documentation/SBV/Examples/Puzzles/Garden.hs view
@@ -42,6 +42,7 @@  -- | Colors of the flowers data Color = Red | Yellow | Blue+          deriving (Enum, Bounded)  -- | Make 'Color' a symbolic value. mkSymbolicEnumeration ''Color
Documentation/SBV/Examples/Puzzles/HexPuzzle.hs view
@@ -54,6 +54,7 @@  -- | Colors we're allowed data Color = Black | Blue | Green | Red+          deriving (Enum, Bounded)  -- | Make 'Color' a symbolic value. mkSymbolicEnumeration ''Color
Documentation/SBV/Examples/Puzzles/KnightsAndKnaves.hs view
@@ -30,10 +30,14 @@  -- | Each inhabitant is either a knave or a knight data Identity = Knave | Knight+              deriving (Enum, Bounded)+ mkSymbolicEnumeration ''Identity  -- | Statements are utterances which are either true or false data Statement = Truth | Falsity+               deriving (Enum, Bounded)+ mkSymbolicEnumeration ''Statement  -- | John is an inhabitant of the island.
Documentation/SBV/Examples/Puzzles/Murder.hs view
@@ -39,12 +39,15 @@  -- | Locations data Location = Bar | Beach | Alone+              deriving (Enum, Bounded)  -- | Sexes data Sex  = Male | Female+          deriving (Enum, Bounded)  -- | Roles data Role = Victim | Killer | Bystander+          deriving (Enum, Bounded)  mkSymbolicEnumeration ''Location mkSymbolicEnumeration ''Sex
Documentation/SBV/Examples/Puzzles/Orangutans.hs view
@@ -31,13 +31,16 @@ #endif  -- | Orangutans in the puzzle.-data Orangutan = Merah   | Ofallo  | Quirrel  | Shamir   deriving (Enum, Bounded)+data Orangutan = Merah | Ofallo | Quirrel | Shamir+               deriving (Enum, Bounded)  -- | Handlers for each orangutan.-data Handler   = Dolly   | Eva     | Francine | Gracie+data Handler = Dolly | Eva | Francine | Gracie+             deriving (Enum, Bounded)  -- | Location for each orangutan.-data Location  = Ambalat | Basahan | Kendisi  | Tarakan+data Location = Ambalat | Basahan | Kendisi | Tarakan+             deriving (Enum, Bounded)  mkSymbolicEnumeration ''Orangutan mkSymbolicEnumeration ''Handler
Documentation/SBV/Examples/Puzzles/U2Bridge.hs view
@@ -36,6 +36,7 @@ -- | U2 band members. We want to translate this to SMT-Lib as a data-type, and hence the -- call to mkSymbolicEnumeration. data U2Member = Bono | Edge | Adam | Larry+              deriving (Enum, Bounded, Eq, Ord)  -- | Make 'U2Member' a symbolic value. mkSymbolicEnumeration ''U2Member@@ -62,6 +63,7 @@  -- | Location of the flash data Location = Here | There+              deriving (Enum, Bounded)  -- | Make 'Location' a symbolic value. mkSymbolicEnumeration ''Location
Documentation/SBV/Examples/Queries/Enums.hs view
@@ -24,6 +24,7 @@  -- | Days of the week. We make it symbolic using the 'mkSymbolicEnumeration' splice. data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday+         deriving (Eq, Ord, Bounded, Enum)  -- | Make 'Day' a symbolic value. mkSymbolicEnumeration ''Day
Documentation/SBV/Examples/Queries/FourFours.hs view
@@ -40,6 +40,7 @@ -- and exponentiation will only be to the power @0@. This does restrict the search space, but is sufficient to -- solve all the instances. data BinOp = Plus | Minus | Times | Divide | Expt+           deriving (Eq, Enum, Bounded)  -- | Make 'BinOp' a symbolic value. mkSymbolicEnumeration ''BinOp@@ -47,6 +48,7 @@ -- | Supported unary operators. Similar to 'BinOp' case, we will restrict square-root and factorial to -- be only applied to the value @4. data UnOp  = Negate | Sqrt | Factorial+           deriving (Eq, Enum, Bounded)  -- | Make 'UnOp' a symbolic value. mkSymbolicEnumeration ''UnOp
Documentation/SBV/Examples/Strings/RegexCrossword.hs view
@@ -9,7 +9,8 @@ -- This example solves regex crosswords from <http://regexcrossword.com> ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -Wall -Werror #-} @@ -20,10 +21,7 @@ import Data.SBV import Data.SBV.Control -import Prelude hiding ((!!))-import Data.SBV.String ((!!))--import qualified Data.SBV.String as S+import qualified Data.SBV.List   as L import qualified Data.SBV.RegExp as R  -- | Solve a given crossword, returning the corresponding rows@@ -33,24 +31,24 @@             numCols = genericLength colRegExps          -- constrain rows-        let mkRow rowRegExp = do row <- free_+        let mkRow rowRegExp = do row :: SString <- free_                                  constrain $ row `R.match` rowRegExp-                                 constrain $ S.length row .== literal numCols+                                 constrain $ L.length row .== literal numCols                                  return row          rows <- mapM mkRow rowRegExps          -- constrain columns-        let mkCol colRegExp = do col <- free_+        let mkCol colRegExp = do col :: SString <- free_                                  constrain $ col `R.match` colRegExp-                                 constrain $ S.length col .== literal numRows+                                 constrain $ L.length col .== literal numRows                                  return col          cols <- mapM mkCol colRegExps          -- constrain each "cell" as they rows/columns intersect:-        let rowss =           [[r !! literal i | i <- [0..numCols-1]] | r <- rows]-        let colss = transpose [[c !! literal i | i <- [0..numRows-1]] | c <- cols]+        let rowss =           [[r L.!! literal i | i <- [0..numCols-1]] | r <- rows]+        let colss = transpose [[c L.!! literal i | i <- [0..numRows-1]] | c <- cols]          constrain $ sAnd $ zipWith (.==) (concat rowss) (concat colss)
Documentation/SBV/Examples/Strings/SQLInjection.hs view
@@ -27,7 +27,7 @@ import Data.SBV.Control  import Prelude hiding ((++))-import Data.SBV.String ((++))+import Data.SBV.List ((++)) import qualified Data.SBV.RegExp as R  -- | Simple expression language
+ Documentation/SBV/Examples/TP/Basics.hs view
@@ -0,0 +1,339 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.Basics+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Some basic TP usage.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Basics where++import Prelude hiding(reverse, length, elem)++import Data.SBV+import Data.SBV.List+import Data.SBV.TP++import Control.Monad (void)++#ifdef DOCTEST+-- $setup+-- >>> :set -XScopedTypeVariables+-- >>> :set -XTypeApplications+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+-- >>> import Control.Exception+#endif++-- * Truth and falsity++-- | @sTrue@ is provable.+--+-- We have:+--+-- >>> trueIsProvable+-- Lemma: true                             Q.E.D.+-- [Proven] true :: Bool+trueIsProvable :: IO (Proof SBool)+trueIsProvable = runTP $ lemma "true" sTrue []++-- | @sFalse@ isn't provable.+--+-- We have:+--+-- >>> falseIsn'tProvable `catch` (\(_ :: SomeException) -> pure ())+-- Lemma: sFalse+-- *** Failed to prove sFalse.+-- Falsifiable+falseIsn'tProvable :: IO ()+falseIsn'tProvable = runTP $ do+        _won'tGoThrough <- lemma "sFalse" sFalse []+        pure ()++-- * Quantification++-- | Basic quantification example: For every integer, there's a larger integer.+--+-- We have:+-- >>> largerIntegerExists+-- Lemma: largerIntegerExists              Q.E.D.+-- [Proven] largerIntegerExists :: Ɐx ∷ Integer → ∃y ∷ Integer → Bool+largerIntegerExists :: IO (Proof (Forall "x" Integer -> Exists "y" Integer -> SBool))+largerIntegerExists = runTP $ lemma "largerIntegerExists"+                                    (\(Forall x) (Exists y) -> x .< y)+                                    []++-- * Basic connectives++-- | Pushing a universal through conjunction. We have:+--+-- >>> forallConjunction @Integer (uninterpret "p") (uninterpret "q")+-- Lemma: forallConjunction                Q.E.D.+-- [Proven] forallConjunction :: Bool+forallConjunction :: forall a. SymVal a => (SBV a -> SBool) -> (SBV a -> SBool) -> IO (Proof SBool)+forallConjunction p q = runTP $ do+    let qb = quantifiedBool++    lemma "forallConjunction"+           (      (qb (\(Forall x) -> p x) .&& qb (\(Forall x) -> q x))+            .<=> -------------------------------------------------------+                          qb (\(Forall x) -> p x .&& q x)+           )+           []++-- | Pushing an existential through disjunction. We have:+--+-- >>> existsDisjunction @Integer (uninterpret "p") (uninterpret "q")+-- Lemma: existsDisjunction                Q.E.D.+-- [Proven] existsDisjunction :: Bool+existsDisjunction :: forall a. SymVal a => (SBV a -> SBool) -> (SBV a -> SBool) -> IO (Proof SBool)+existsDisjunction p q = runTP $ do+    let qb = quantifiedBool++    lemma "existsDisjunction"+           (      (qb (\(Exists x) -> p x) .|| qb (\(Exists x) -> q x))+            .<=> -------------------------------------------------------+                          qb (\(Exists x) -> p x .|| q x)+           )+           []++-- | We cannot push a universal through a disjunction. We have:+--+-- >>> forallDisjunctionNot @Integer (uninterpret "p") (uninterpret "q") `catch` (\(_ :: SomeException) -> pure ())+-- Lemma: forallConjunctionNot+-- *** Failed to prove forallConjunctionNot.+-- Falsifiable. Counter-example:+--   p :: Integer -> Bool+--   p 2 = True+--   p 1 = False+--   p _ = True+-- <BLANKLINE>+--   q :: Integer -> Bool+--   q 2 = False+--   q 1 = True+--   q _ = True+--+-- Note how @p@ assigns two selected values to @True@ and everything else to @False@, while @q@ does the exact opposite.+-- So, there is no common value that satisfies both, providing a counter-example. (It's not clear why the solver finds+-- a model with two distinct values, as one would have sufficed. But it is still a valud model.)+forallDisjunctionNot :: forall a. SymVal a => (SBV a -> SBool) -> (SBV a -> SBool) -> IO ()+forallDisjunctionNot p q = runTP $ do+    let qb = quantifiedBool++    -- This won't prove!+    _won'tGoThrough <- lemma "forallConjunctionNot"+                             (      (qb (\(Forall x) -> p x) .|| qb (\(Forall x) -> q x))+                              .<=> -------------------------------------------------------+                                              qb (\(Forall x) -> p x .|| q x)+                             )+                             []++    pure ()++-- | We cannot push an existential through conjunction. We have:+--+-- >>> existsConjunctionNot @Integer (uninterpret "p") (uninterpret "q") `catch` (\(_ :: SomeException) -> pure ())+-- Lemma: existsConjunctionNot+-- *** Failed to prove existsConjunctionNot.+-- Falsifiable. Counter-example:+--   p :: Integer -> Bool+--   p 1 = False+--   p _ = True+-- <BLANKLINE>+--   q :: Integer -> Bool+--   q 1 = True+--   q _ = False+--+-- In this case, we again have a predicate That disagree at every point, providing a counter-example.+existsConjunctionNot :: forall a. SymVal a => (SBV a -> SBool) -> (SBV a -> SBool) -> IO ()+existsConjunctionNot p q = runTP $ do+    let qb = quantifiedBool++    _wont'GoThrough <- lemma "existsConjunctionNot"+                             (      (qb (\(Exists x) -> p x) .&& qb (\(Exists x) -> q x))+                              .<=> -------------------------------------------------------+                                              qb (\(Exists x) -> p x .&& q x)+                             )+                            []++    pure ()++-- * QuickCheck++-- | Using quick-check as a step. This can come in handy if a proof step isn't converging,+-- or if you want to quickly see if there are any obvious counterexamples. This example prints:+--+-- @+-- Lemma: qcExample+--   Step: 1 (passed 1000 tests)           Q.E.D. [Modulo: quickCheck]+--   Step: 2 (Failed during quickTest)+-- +-- *** QuickCheck failed for qcExample.2+-- *** Failed! Assertion failed (after 1 test):+--   n   = 175 :: Word8+--   lhs =  94 :: Word8+--   rhs =  95 :: Word8+--   val =  94 :: Word8+--+-- *** Exception: Failed+-- @+--+-- Of course, the counterexample you get might differ depending on the quickcheck outcome.+qcExample :: TP (Proof (Forall "n" Word8 -> SBool))+qcExample = calc "qcExample"+                 (\(Forall n) -> n + n .== 2 * n) $+                 \n -> [] |- n + n+                          ?? qc 1000+                          =: 2 * n+                          ?? qc 1000+                          ?? disp "val" (2 * n)+                          =: 2 * n + 1+                          =: qed++-- | We can't really prove Fermat's last theorem. But we can quick-check instances of it.+--+-- >>> runTP (qcFermat 3)+-- Lemma: qcFermat 3+--   Step: 1 (qc: Running 1000 tests)      QC OK+--   Result:                               Q.E.D. [Modulo: quickCheck]+-- [Modulo: quickCheck] qcFermat 3 :: Ɐx ∷ Integer → Ɐy ∷ Integer → Ɐz ∷ Integer → Bool+qcFermat :: Integer -> TP (Proof (Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> SBool))+qcFermat e = calc ("qcFermat " <> show e)+                  (\(Forall x) (Forall y) (Forall z) -> n .> 2 .=> x.^n + y.^n ./= z.^n) $+                  \x y z -> [n .> 2]+                         |- x .^ n + y .^ n ./= z .^ n+                         ?? qc 1000+                         =: sTrue+                         =: qed+  where n = literal e++-- * No termination checks++-- | It's important to realize that TP proofs in SBV neither check nor guarantee that the+-- functions we use are terminating. This is beyond the scope (and current capabilities) of what SBV can handle.+-- That is, the proof is up-to-termination, i.e., any proof implicitly assumes all functions defined (or axiomatized)+-- terminate for all possible inputs. If non-termination is possible, then the logic becomes inconsistent, i.e.,+-- we can prove arbitrary results.+--+-- Here is a simple example where we tell SBV that there is a function @f@ with non terminating behavior. Using this,+-- we can deduce @False@:+--+-- >>> noTerminationChecks+-- Axiom: bad+-- Lemma: noTerminationImpliesFalse+--   Step: 1 (bad @ (n |-> 0 :: SInteger)) Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] noTerminationImpliesFalse :: Bool+noTerminationChecks :: IO (Proof SBool)+noTerminationChecks = runTP $ do++   let f :: SInteger -> SInteger+       f = uninterpret "f"++   badAxiom <- axiom "bad" (\(Forall n) -> f n .== 1 + f n)++   calc "noTerminationImpliesFalse"+        sFalse+        ([] |- f 0+            ?? badAxiom `at` Inst @"n" (0 :: SInteger)+            =: 1 + f 0+            =: qed)++-- * Trying to prove non-theorems++-- | An example where we attempt to prove a non-theorem. Notice the counter-example+-- generated for:+--+-- @length xs == ite (length xs .== 3) 5 (length xs)@+--+-- >>> badRevLen `catch` (\(_ :: SomeException) -> pure ())+-- Lemma: badRevLen+-- *** Failed to prove badRevLen.+-- Falsifiable. Counter-example:+--   xs = [14,11,14] :: [Integer]+badRevLen :: IO ()+badRevLen = runTP $+   void $ lemma "badRevLen"+                (\(Forall @"xs" (xs :: SList Integer)) -> length (reverse xs) .== ite (length xs .== 3) 5 (length xs))+                []++-- | It is instructive to see what kind of counter-example we get if a lemma fails to prove.+-- Below, we do a variant of the 'lengthTail, but with a bad implementation over integers,+-- and see the counter-example. Our implementation returns an incorrect answer if the given list is longer+-- than 5 elements and have 42 in it:+--+-- >>> badLengthProof `catch` (\(_ :: SomeException) -> pure ())+-- Lemma: badLengthProof+-- *** Failed to prove badLengthProof.+-- Falsifiable. Counter-example:+--   xs   = [15,11,13,16,27,42] :: [Integer]+--   imp  =                  42 :: Integer+--   spec =                   6 :: Integer+badLengthProof :: IO ()+badLengthProof = runTP $ do+   let badLength :: SList Integer -> SInteger+       badLength xs = ite (length xs .> 5 .&& 42 `elem` xs) 42 (length xs)++   void $ lemma "badLengthProof" (\(Forall @"xs" xs) -> observe "imp" (badLength xs) .== observe "spec" (length xs)) []++-- * Caching++-- | It is not unusual that TP proofs rely on other proofs. Typically, all the helpers are used together and proven in+-- one go. It is, however, useful to be able to write these proofs as top-level entries, and reuse them multiple times+-- in several proofs. (See "Documentation/SBV/Examples/TP/PowerMod.hs" for an example.) To avoid re-proving such+-- lemmas, you can turn on proof caching. The idea behind caching is simple: If we see a lemma with the same name being+-- proven again, then we simply reuse the last result. The catch here is that lemmas are identified by their names: Hence,+-- for caching to be sound, you need to make sure all names used in your proof are unique. Otherwise you can+-- conclude wrong results!+--+-- A good trick is to pay the price and run your entire proof without caching (which is the default) once, and if it is+-- all good, turn on caching to save time in regressions. (And rerun without caching after code changes.)+--+-- To demonstrate why caching can be unsound, simply consider a proof where we first prove true, and then prove false+-- but we /trick/ TP by reusing the name. If you run this, you'll see:+--+-- >>> runTP badCaching `catch` (\(_ :: SomeException) -> pure ())+-- Lemma: evil                             Q.E.D.+-- Lemma: evil+-- *** Failed to prove evil.+-- Falsifiable+--+-- This is good, the proof failed since it's just not true. (Except for the confusing naming printed in the trace+-- due to our own choice.)+--+-- Let's see what happens if we turn caching on:+--+-- >>> runTPWith (tpCache z3) badCaching+-- Lemma: evil                             Q.E.D.+-- Cached: evil                            Q.E.D.+--+-- In this case we were able to ostensibly prove False, i.e., this result is unsound. But at least SBV warned us+-- that we used a cached proof (@evil@), reminding us that using unique names is a proof of obligation for the user+-- if caching is turned on. Clearly, we failed to uniquely name our proofs in this case.+--+-- Note that a bad proof obtained this way is unsound in the way that it is misleading: That is, it will lead you+-- to believe you proved something while you actually proved something else. (More technically, you cannot take the evil+-- lemma and use it to prove arbitrary things, since it's still just the proof of truth.) In this sense it is just+-- useless as opposed to soundness, but it is alarming as one can be led astray.+--+-- (Incidentally, if you really want to be evil, you can just use 'axiom' and assert false, but that's another story.)+badCaching :: TP ()+badCaching = do+   -- Prove true, giving it a bad name+   _ <- lemma "evil" sTrue []++   -- Attempt to prove false, using evil:+   _ <- lemma "evil" sFalse []++   pure ()
+ Documentation/SBV/Examples/TP/BinarySearch.hs view
@@ -0,0 +1,267 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.BinarySearch+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving binary search correct+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.BinarySearch where++import Prelude hiding (null, length, (!!), drop, take, tail, elem, notElem)++import Data.SBV+import Data.SBV.Maybe+import Data.SBV.TP++-- * Binary search++-- | We will work with arrays containing integers, indexed by integers. Note that since SMTLib arrays+-- are indexed by their entire domain, we explicitly take a lower/upper bounds as parameters, which fits well+-- with the binary search algorithm.+type Arr = SArray Integer Integer++-- | Bounds: This is the focus into the array; both indexes are inclusive.+type Idx = (SInteger, SInteger)++-- | Encode binary search in a functional style.+bsearch :: Arr -> Idx -> SInteger -> SMaybe Integer+bsearch array (low, high) = f array low high+  where f = smtFunction "bsearch" $ \arr lo hi x ->+               let mid  = (lo + hi) `sEDiv` 2+                   xmid = arr `readArray` mid+               in ite (lo .> hi)+                      sNothing+                      (ite (xmid .== x)+                           (sJust mid)+                           (ite (xmid .< x)+                                (bsearch arr (mid+1, hi)    x)+                                (bsearch arr (lo,    mid-1) x)))++-- * Correctness proof++-- | A predicate testing whether a given array is non-decreasing in the given range+nonDecreasing :: Arr -> Idx -> SBool+nonDecreasing arr (low, high) = quantifiedBool $+    \(Forall i) (Forall j) -> low .<= i .&& i .<= j .&& j .<= high .=> arr `readArray` i .<= arr `readArray` j++-- | A predicate testing whether an element is in the array within the given bounds+inArray :: Arr -> Idx -> SInteger -> SBool+inArray arr (low, high) elt = quantifiedBool $ \(Exists i) -> low .<= i .&& i .<= high .&& arr `readArray` i .== elt++-- | Correctness of binary search.+--+-- We have:+--+-- >>> correctness+-- Lemma: notInRange                                 Q.E.D.+-- Lemma: inRangeHigh                                Q.E.D.+-- Lemma: inRangeLow                                 Q.E.D.+-- Lemma: nonDecreasing                              Q.E.D.+-- Inductive lemma (strong): bsearchAbsent+--   Step: Measure is non-negative                   Q.E.D.+--   Step: 1 (unfold bsearch)                        Q.E.D.+--   Step: 2 (push isNothing down, simplify)         Q.E.D.+--   Step: 3 (2 way case split)+--     Step: 3.1                                     Q.E.D.+--     Step: 3.2.1                                   Q.E.D.+--     Step: 3.2.2                                   Q.E.D.+--     Step: 3.2.3                                   Q.E.D.+--     Step: 3.2.4                                   Q.E.D.+--     Step: 3.2.5 (simplify)                        Q.E.D.+--     Step: 3.Completeness                          Q.E.D.+--   Result:                                         Q.E.D.+-- Inductive lemma (strong): bsearchPresent+--   Step: Measure is non-negative                   Q.E.D.+--   Step: 1 (unfold bsearch)                        Q.E.D.+--   Step: 2 (simplify)                              Q.E.D.+--   Step: 3 (3 way case split)+--     Step: 3.1                                     Q.E.D.+--     Step: 3.2                                     Q.E.D.+--     Step: 3.3.1                                   Q.E.D.+--     Step: 3.3.2 (3 way case split)+--       Step: 3.3.2.1                               Q.E.D.+--       Step: 3.3.2.2.1                             Q.E.D.+--       Step: 3.3.2.2.2                             Q.E.D.+--       Step: 3.3.2.3.1                             Q.E.D.+--       Step: 3.3.2.3.2                             Q.E.D.+--       Step: 3.3.2.Completeness                    Q.E.D.+--     Step: 3.Completeness                          Q.E.D.+--   Result:                                         Q.E.D.+-- Lemma: bsearchCorrect+--   Step: 1 (2 way case split)+--     Step: 1.1.1                                   Q.E.D.+--     Step: 1.1.2                                   Q.E.D.+--     Step: 1.2.1                                   Q.E.D.+--     Step: 1.2.2                                   Q.E.D.+--     Step: 1.Completeness                          Q.E.D.+--   Result:                                         Q.E.D.+-- [Proven] bsearchCorrect :: Ɐarr ∷ (ArrayModel Integer Integer) → Ɐlo ∷ Integer → Ɐhi ∷ Integer → Ɐx ∷ Integer → Bool+correctness :: IO (Proof (Forall "arr" (ArrayModel Integer Integer) -> Forall "lo" Integer -> Forall "hi" Integer -> Forall "x" Integer -> SBool))+correctness = runTPWith (tpRibbon 50 cvc5) $ do++  -- Helper: if a value is not in a range, then it isn't in any subrange of it:+  notInRange <- lemma "notInRange"+                           (\(Forall arr) (Forall lo) (Forall hi) (Forall md) (Forall x)+                               ->  sNot (inArray arr (lo, hi) x) .&& lo .<= md .&& md .<= hi+                               .=> sNot (inArray arr (lo, md) x) .&& sNot (inArray arr (md, hi) x))+                           []++  -- Helper: if a value is in a range of a nonDecreasing array, and if its value is larger than a given mid point, then it's in the higher part+  inRangeHigh <- lemma "inRangeHigh"+                       (\(Forall arr) (Forall lo) (Forall hi) (Forall md) (Forall x)+                           ->  nonDecreasing arr (lo, hi) .&& inArray arr (lo, hi) x .&& lo .<= md .&& md .<= hi .&& x .> arr `readArray` md+                           .=> inArray arr (md+1, hi) x)+                       []++  -- Helper: if a value is in a range of a nonDecreasing array, and if its value is lower than a given mid point, then it's in the lowr part+  inRangeLow  <- lemma "inRangeLow"+                       (\(Forall arr) (Forall lo) (Forall hi) (Forall md) (Forall x)+                           ->  nonDecreasing arr (lo, hi) .&& inArray arr (lo, hi) x .&& lo .<= md .&& md .<= hi .&& x .< arr `readArray` md+                           .=> inArray arr (lo, md-1) x)+                       []++  -- Helper: if an array is nonDecreasing, then its parts are also non-decreasing when cut in any middle point+  nonDecreasingInRange <- lemma "nonDecreasing"+                                (\(Forall arr) (Forall lo) (Forall hi) (Forall md)+                                    ->  nonDecreasing arr (lo, hi) .&& lo .<= md .&& md .<= hi+                                    .=> nonDecreasing arr (lo, md) .&& nonDecreasing arr (md, hi))+                                []++  -- Prove the case when the target is not in the array+  bsearchAbsent <- sInduct "bsearchAbsent"+        (\(Forall arr) (Forall lo) (Forall hi) (Forall x) ->+            nonDecreasing arr (lo, hi) .&& sNot (inArray arr (lo, hi) x) .=> isNothing (bsearch arr (lo, hi) x))+        (\_arr lo hi _x -> abs (hi - lo + 1)) $+        \ih arr lo hi x ->+              [nonDecreasing arr (lo, hi), sNot (inArray arr (lo, hi) x)]+           |- isNothing (bsearch arr (lo, hi) x)+           ?? "unfold bsearch"+           =: let mid  = (lo + hi) `sEDiv` 2+                  xmid = arr `readArray` mid+           in isNothing (ite (lo .> hi)+                             sNothing+                             (ite (xmid .== x)+                                  (sJust mid)+                                  (ite (xmid .< x)+                                       (bsearch arr (mid+1, hi)    x)+                                       (bsearch arr (lo,    mid-1) x))))+           ?? "push isNothing down, simplify"+           =: ite (lo .> hi)+                  sTrue+                  (ite (xmid .== x)+                       sFalse+                       (ite (xmid .< x)+                            (isNothing (bsearch arr (mid+1, hi)    x))+                            (isNothing (bsearch arr (lo,    mid-1) x))))+           =: cases [ lo .> hi  ==> trivial+                    , lo .<= hi ==> ite (xmid .== x)+                                        sFalse+                                        (ite (xmid .< x)+                                             (isNothing (bsearch arr (mid+1, hi)    x))+                                             (isNothing (bsearch arr (lo,    mid-1) x)))+                                 =: let inst1 l h m = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h, Inst @"m" m, Inst @"x" x)+                                        inst2 l h m = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h, Inst @"m" m             )+                                        inst3 l h   = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h,              Inst @"x" x)+                                 in ite (xmid .< x)+                                        (isNothing (bsearch arr (mid+1, hi)    x))+                                        (isNothing (bsearch arr (lo,    mid-1) x))+                                 ?? notInRange           `at` inst1 lo      hi (mid+1)+                                 ?? nonDecreasingInRange `at` inst2 lo      hi (mid+1)+                                 ?? ih                   `at` inst3 (mid+1) hi+                                 =: ite (xmid .< x)+                                        sTrue+                                        (isNothing (bsearch arr (lo,    mid-1) x))+                                 ?? notInRange           `at` inst1 lo hi      (mid-1)+                                 ?? nonDecreasingInRange `at` inst2 lo hi      (mid-1)+                                 ?? ih                   `at` inst3 lo (mid-1)+                                 =: ite (xmid .< x) sTrue sTrue+                                 ?? "simplify"+                                 =: sTrue+                                 =: qed+                    ]++  -- Prove the case when the target is in the array+  bsearchPresent <- sInduct "bsearchPresent"+        (\(Forall arr) (Forall lo) (Forall hi) (Forall x) ->+            nonDecreasing arr (lo, hi) .&& inArray arr (lo, hi) x .=> arr `readArray` fromJust (bsearch arr (lo, hi) x) .== x)+        (\_arr lo hi _x -> abs (hi - lo + 1)) $+        \ih arr lo hi x ->+             [nonDecreasing arr (lo, hi), inArray arr (lo, hi) x]+          |- x .== arr `readArray` fromJust (bsearch arr (lo, hi) x)+          ?? "unfold bsearch"+          =: let mid  = (lo + hi) `sEDiv` 2+                 xmid = arr `readArray` mid+          in x .== arr `readArray` fromJust (ite (lo .> hi)+                                                 sNothing+                                                 (ite (xmid .== x)+                                                      (sJust mid)+                                                      (ite (xmid .< x)+                                                           (bsearch arr (mid+1, hi)    x)+                                                           (bsearch arr (lo,    mid-1) x))))+          ?? "simplify"+          =: ite (lo .> hi)+                 (x .== arr `readArray` fromJust sNothing)+                 (ite (xmid .== x)+                      (x .== arr `readArray` mid)+                      (ite (xmid .< x)+                           (x .== arr `readArray` fromJust (bsearch arr (mid+1, hi)    x))+                           (x .== arr `readArray` fromJust (bsearch arr (lo,    mid-1) x))))+          =: cases [ lo .>  hi ==> trivial+                   , lo .== hi ==> trivial+                   , lo .<  hi ==> ite (xmid .== x)+                                       (x .== arr `readArray` mid)+                                       (ite (xmid .< x)+                                            (x .== arr `readArray` fromJust (bsearch arr (mid+1, hi)    x))+                                            (x .== arr `readArray` fromJust (bsearch arr (lo,    mid-1) x)))+                                =: let inst1 l h m = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h, Inst @"m" m, Inst @"x" x)+                                       inst2 l h m = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h, Inst @"m" m             )+                                       inst3 l h   = (Inst @"arr" arr, Inst @"lo" l, Inst @"hi" h,              Inst @"x" x)+                                in cases [ xmid .== x ==> trivial+                                         , xmid .< x  ==> x .== arr `readArray` fromJust (bsearch arr (mid+1, hi)    x)+                                                       ?? inRangeHigh          `at` inst1 lo      hi mid+                                                       ?? nonDecreasingInRange `at` inst2 lo      hi (mid+1)+                                                       ?? ih                   `at` inst3 (mid+1) hi+                                                       =: sTrue+                                                       =: qed+                                         , xmid .> x  ==> x .== arr `readArray` fromJust (bsearch arr (lo, mid-1) x)+                                                       ?? inRangeLow           `at` inst1 lo hi      mid+                                                       ?? nonDecreasingInRange `at` inst2 lo hi      (mid-1)+                                                       ?? ih                   `at` inst3 lo (mid-1)+                                                       =: sTrue+                                                       =: qed+                                         ]+                   ]++  calc "bsearchCorrect"+        (\(Forall arr) (Forall lo) (Forall hi) (Forall x) ->+            nonDecreasing arr (lo, hi) .=> let res = bsearch arr (lo, hi) x+                                           in ite (inArray arr (lo, hi) x)+                                                  (arr `readArray` fromJust res .== x)+                                                  (isNothing res)) $+        \arr lo hi x -> [nonDecreasing arr (lo, hi)]+                     |- let res = bsearch arr (lo, hi) x+                        in ite (inArray arr (lo, hi) x)+                               (arr `readArray` fromJust res .== x)+                               (isNothing res)+                     =: cases [ inArray arr (lo, hi) x+                                  ==> arr `readArray` fromJust (bsearch arr (lo, hi) x) .== x+                                   ?? bsearchPresent `at` (Inst @"arr" arr, Inst @"lo" lo, Inst @"hi" hi, Inst @"x" x)+                                   =: sTrue+                                   =: qed+                              , sNot (inArray arr (lo, hi) x)+                                  ==> isNothing (bsearch arr (lo, hi) x)+                                   ?? bsearchAbsent `at` (Inst @"arr" arr, Inst @"lo" lo, Inst @"hi" hi, Inst @"x" x)+                                   =: sTrue+                                   =: qed+                              ]
+ Documentation/SBV/Examples/TP/CaseSplit.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.CaseSplit+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Use TP to prove @2n^2 + n + 1@ is never divisible by @3@.+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE TypeAbstractions #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.CaseSplit where++import Data.SBV+import Data.SBV.TP++-- | Prove that @2n^2 + n + 1@ is not divisible by @3@.+--+-- We have:+--+-- >>> notDiv3+-- Lemma: notDiv3+--   Step: 1 (3 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2                           Q.E.D.+--     Step: 1.3                           Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] notDiv3 :: Ɐn ∷ Integer → Bool+notDiv3 :: IO (Proof (Forall "n" Integer -> SBool))+notDiv3 = runTP $ do++   let s n = 2 * n * n + n + 1++   -- Do a case-split for each possible outcome of @s n `sEMod` 3@. In each case+   -- we get the witness that is guaranteed to exist by the case condition, and rewrite+   -- @s n@ accordingly. Once this is done, z3 can figure out the rest by itself.+   calc "notDiv3"+        (\(Forall n) -> s n `sEMod` 3 ./= 0) $+        \n -> [] |- s n+                 =: cases [ n `sEMod` 3 .== 0 ==> s (0 + 3 * some "k" (\k -> n .== 0 + 3 * k)) =: qed+                          , n `sEMod` 3 .== 1 ==> s (1 + 3 * some "k" (\k -> n .== 1 + 3 * k)) =: qed+                          , n `sEMod` 3 .== 2 ==> s (2 + 3 * some "k" (\k -> n .== 2 + 3 * k)) =: qed+                          ]
+ Documentation/SBV/Examples/TP/Fibonacci.hs view
@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.Fibonacci+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving that the naive version of fibonacci and the faster tail-recursive+-- version are equivalent.+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Fibonacci(correctness) where++import Data.SBV+import Data.SBV.TP++-- * Naive fibonacci++-- | Calculate fibonacci using the textbook definition.+fibonacci :: SInteger -> SInteger+fibonacci = smtFunction "fibonacci" $ \n -> ite (n .<= 1) 1 (fibonacci (n-1) + fibonacci (n-2))++-- * Tail recursive version++-- | Tail recursive version+fib :: SInteger -> SInteger -> SInteger -> SInteger+fib = smtFunction "fib" $ \a b n -> ite (n .<= 0) a (fib b (a+b) (n-1))++-- | Faster version of fibonacci, using the tail-recursive version.+fibTail :: SInteger -> SInteger+fibTail = fib 1 1++-- * Correctness++-- | Proving the the tail version of fibonacci is equivalent to the textbook version.+--+-- We have:+--+-- >>> correctness+-- Inductive lemma: helper+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2 (unfold fibonacci)            Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: fibCorrect+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] fibCorrect :: Ɐn ∷ Integer → Bool+correctness :: IO (Proof (Forall "n" Integer -> SBool))+correctness = runTP $ do++  helper <- induct "helper"+                   (\(Forall n) (Forall k) ->+                       n .>= 0 .&& k .>= 0 .=> fib (fibonacci k) (fibonacci (k+1)) n .== fibonacci (k+n)) $+                   \ih n k -> [n .>= 0, k .>= 0]+                           |- fib (fibonacci k) (fibonacci (k+1)) (n+1)+                           =: fib (fibonacci (k+1)) (fibonacci k + fibonacci (k+1)) n+                           ?? "unfold fibonacci"+                           =: fib (fibonacci (k+1)) (fibonacci (k+2)) n+                           ?? ih `at` Inst @"k" (k+1)+                           =: fibonacci (k+1+n)+                           =: qed++  calc "fibCorrect"+       (\(Forall n) -> n .>= 0 .=> fibonacci n .== fibTail n) $+       \n -> [n .>= 0] |- fibTail n+                       =: fib 1 1 n+                       ?? helper `at` (Inst @"n" n, Inst @"k" 0)+                       =: fibonacci n+                       =: qed
+ Documentation/SBV/Examples/TP/InsertionSort.hs view
@@ -0,0 +1,214 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.InsertionSort+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving insertion sort correct.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.InsertionSort where++import Prelude hiding (null, length, head, tail, elem)++import Data.SBV+import Data.SBV.List+import Data.SBV.TP++import qualified Documentation.SBV.Examples.TP.SortHelpers as SH++#ifdef DOCTEST+-- $setup+-- >>> :set -XTypeApplications+#endif++-- * Insertion sort++-- | Insert an element into an already sorted list in the correct place.+insert :: (Ord a, SymVal a) => SBV a -> SList a -> SList a+insert = smtFunction "insert" $ \e l -> ite (null l) [e]+                                      $ let (x, xs) = uncons l+                                        in ite (e .<= x) (e .: x .: xs) (x .: insert e xs)++-- | Insertion sort, using 'insert' above to successively insert the elements.+insertionSort :: (Ord a, SymVal a) => SList a -> SList a+insertionSort = smtFunction "insertionSort" $ \l -> ite (null l) nil+                                                  $ let (x, xs) = uncons l+                                                    in insert x (insertionSort xs)+++-- | Remove the first occurrence of an number from a list, if any.+removeFirst :: (Eq a, SymVal a) => SBV a -> SList a -> SList a+removeFirst = smtFunction "removeFirst" $ \e l -> ite (null l)+                                                      nil+                                                      (let (x, xs) = uncons l+                                                       in ite (e .== x) xs (x .: removeFirst e xs))++-- | Are two lists permutations of each other? Note that we diverge from the counting+-- based definition of permutation here, since this variant works better with insertion sort.+isPermutation :: (Eq a, SymVal a) => SList a -> SList a -> SBool+isPermutation = smtFunction "isPermutation" $ \l r -> ite (null l)+                                                          (null r)+                                                          (let (x, xs) = uncons l+                                                           in x `elem` r .&& isPermutation xs (removeFirst x r))++-- * Correctness proof++-- | Correctness of insertion-sort. z3 struggles with this, but CVC5 proves it just fine.+--+-- We have:+--+-- >>> correctness @Integer+-- Lemma: nonDecrTail                           Q.E.D.+-- Inductive lemma: insertNonDecreasing+--   Step: Base                                 Q.E.D.+--   Step: 1 (unfold insert)                    Q.E.D.+--   Step: 2 (push nonDecreasing down)          Q.E.D.+--   Step: 3 (unfold simplify)                  Q.E.D.+--   Step: 4                                    Q.E.D.+--   Step: 5                                    Q.E.D.+--   Result:                                    Q.E.D.+-- Inductive lemma: sortNonDecreasing+--   Step: Base                                 Q.E.D.+--   Step: 1 (unfold insertionSort)             Q.E.D.+--   Step: 2                                    Q.E.D.+--   Result:                                    Q.E.D.+-- Inductive lemma: insertIsElem+--   Step: Base                                 Q.E.D.+--   Step: 1                                    Q.E.D.+--   Step: 2                                    Q.E.D.+--   Step: 3                                    Q.E.D.+--   Step: 4                                    Q.E.D.+--   Result:                                    Q.E.D.+-- Inductive lemma: removeAfterInsert+--   Step: Base                                 Q.E.D.+--   Step: 1 (expand insert)                    Q.E.D.+--   Step: 2 (push removeFirst down ite)        Q.E.D.+--   Step: 3 (unfold removeFirst on 'then')     Q.E.D.+--   Step: 4 (unfold removeFirst on 'else')     Q.E.D.+--   Step: 5                                    Q.E.D.+--   Step: 6 (simplify)                         Q.E.D.+--   Result:                                    Q.E.D.+-- Inductive lemma: sortIsPermutation+--   Step: Base                                 Q.E.D.+--   Step: 1                                    Q.E.D.+--   Step: 2                                    Q.E.D.+--   Step: 3                                    Q.E.D.+--   Step: 4                                    Q.E.D.+--   Step: 5                                    Q.E.D.+--   Result:                                    Q.E.D.+-- Lemma: insertionSortIsCorrect                Q.E.D.+-- [Proven] insertionSortIsCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. (Ord a, SymVal a) => IO (Proof (Forall "xs" [a] -> SBool))+correctness = runTPWith (tpRibbon 45 cvc5) $ do++    --------------------------------------------------------------------------------------------+    -- Part I. Import helper lemmas, definitions+    --------------------------------------------------------------------------------------------+    let nonDecreasing = SH.nonDecreasing @a++    nonDecrTail <- SH.nonDecrTail @a++    --------------------------------------------------------------------------------------------+    -- Part II. Prove that the output of insertion sort is non-decreasing.+    --------------------------------------------------------------------------------------------++    insertNonDecreasing <-+        induct "insertNonDecreasing"+               (\(Forall xs) (Forall e) -> nonDecreasing xs .=> nonDecreasing (insert e xs)) $+               \ih (x, xs) e -> [nonDecreasing (x .: xs)]+                             |- nonDecreasing (insert e (x .: xs))+                             ?? "unfold insert"+                             =: nonDecreasing (ite (e .<= x) (e .: x .: xs) (x .: insert e xs))+                             ?? "push nonDecreasing down"+                             =: ite (e .<= x) (nonDecreasing (e .: x .: xs))+                                              (nonDecreasing (x .: insert e xs))+                             ?? "unfold simplify"+                             =: ite (e .<= x)+                                    (nonDecreasing (x .: xs))+                                    (nonDecreasing (x .: insert e xs))+                             ?? nonDecreasing (x .: xs)+                             =: (e .> x .=> nonDecreasing (x .: insert e xs))+                             ?? nonDecrTail `at` (Inst @"x" x, Inst @"xs" (insert e xs))+                             ?? ih+                             =: sTrue+                             =: qed++    sortNonDecreasing <-+        induct "sortNonDecreasing"+               (\(Forall @"xs" xs) -> nonDecreasing (insertionSort xs)) $+               \ih (x, xs) -> [] |- nonDecreasing (insertionSort (x .: xs))+                                 ?? "unfold insertionSort"+                                 =: nonDecreasing (insert x (insertionSort xs))+                                 ?? insertNonDecreasing `at` (Inst @"xs" (insertionSort xs), Inst @"e" x)+                                 ?? ih+                                 =: sTrue+                                 =: qed++    --------------------------------------------------------------------------------------------+    -- Part III. Prove that the output of insertion sort is a permuation of its input+    --------------------------------------------------------------------------------------------++    insertIsElem <-+        induct "insertIsElem"+               (\(Forall @"xs" xs) (Forall @"e" (e :: SBV a)) -> e `elem` insert e xs) $+               \ih (x, xs) e -> [] |- e `elem` insert e (x .: xs)+                                   =: e `elem` ite (e .<= x) (e .: x .: xs) (x .: insert e xs)+                                   =: ite (e .<= x) (e `elem` (e .: x .: xs)) (e `elem` (x .: insert e xs))+                                   =: ite (e .<= x) sTrue (e `elem` insert e xs)+                                   ?? ih+                                   =: sTrue+                                   =: qed++    removeAfterInsert <-+        induct "removeAfterInsert"+               (\(Forall @"xs" xs) (Forall @"e" (e :: SBV a)) -> removeFirst e (insert e xs) .== xs) $+               \ih (x, xs) e ->+                   [] |- removeFirst e (insert e (x .: xs))+                      ?? "expand insert"+                      =: removeFirst e (ite (e .<= x) (e .: x .: xs) (x .: insert e xs))+                      ?? "push removeFirst down ite"+                      =: ite (e .<= x) (removeFirst e (e .: x .: xs)) (removeFirst e (x .: insert e xs))+                      ?? "unfold removeFirst on 'then'"+                      =: ite (e .<= x) (x .: xs) (removeFirst e (x .: insert e xs))+                      ?? "unfold removeFirst on 'else'"+                      =: ite (e .<= x) (x .: xs) (x .: removeFirst e (insert e xs))+                      ?? ih+                      =: ite (e .<= x) (x .: xs) (x .: xs)+                      ?? "simplify"+                      =: x .: xs+                      =: qed++    sortIsPermutation <-+        induct "sortIsPermutation"+               (\(Forall @"xs" (xs :: SList a)) -> isPermutation xs (insertionSort xs)) $+               \ih (x, xs) ->+                   [] |- isPermutation (x .: xs) (insertionSort (x .: xs))+                      =: isPermutation (x .: xs) (insert x (insertionSort xs))+                      =:     x `elem` insert x (insertionSort xs)+                         .&& isPermutation xs (removeFirst x (insert x (insertionSort xs)))+                      ?? insertIsElem+                      =: isPermutation xs (removeFirst x (insert x (insertionSort xs)))+                      ?? removeAfterInsert+                      =: isPermutation xs (insertionSort xs)+                      ?? ih+                      =: sTrue+                      =: qed++    --------------------------------------------------------------------------------------------+    -- Put the two parts together for the final proof+    --------------------------------------------------------------------------------------------+    lemma "insertionSortIsCorrect"+          (\(Forall xs) -> let out = insertionSort xs in nonDecreasing out .&& isPermutation xs out)+          [proofOf sortNonDecreasing, proofOf sortIsPermutation]
+ Documentation/SBV/Examples/TP/Kleene.hs view
@@ -0,0 +1,143 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.Kleene+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Example use of the TP layer, proving some Kleene algebra theorems.+--+-- Based on <http://www.philipzucker.com/bryzzowski_kat/>+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeAbstractions     #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-unused-matches #-}++module Documentation.SBV.Examples.TP.Kleene where++import Prelude hiding((<=))++import Data.SBV+import Data.SBV.TP++-- | An uninterpreted sort, corresponding to the type of Kleene algebra strings.+data Kleene+mkUninterpretedSort ''Kleene++-- | Star operator over kleene algebras. We're leaving this uninterpreted.+star :: SKleene -> SKleene+star = uninterpret "STAR"++-- | The 'Num' instance for Kleene makes it easy to write regular expressions+-- in the more familiar form.+instance Num SKleene where+  (+) = uninterpret "PAR"+  (*) = uninterpret "SEQ"++  abs    = error "SKleene: not defined: abs"+  signum = error "SKleene: not defined: signum"+  negate = error "SKleene: not defined: signum"++  fromInteger 0 = uninterpret "zero"+  fromInteger 1 = uninterpret "one"+  fromInteger n = error $ "SKleene: not defined: fromInteger " ++ show n++-- | The set of strings matched by one regular expression is a subset of the second,+-- if adding it to the second doesn't change the second set.+(<=) :: SKleene -> SKleene -> SBool+x <= y = x + y .== y++-- | A sequence of Kleene algebra proofs. See <http://www.cs.cornell.edu/~kozen/Papers/ka.pdf>+--+-- We have:+--+-- >>> kleeneProofs+-- Axiom: par_assoc+-- Axiom: par_comm+-- Axiom: par_idem+-- Axiom: par_zero+-- Axiom: seq_assoc+-- Axiom: seq_zero+-- Axiom: seq_one+-- Axiom: rdistrib+-- Axiom: ldistrib+-- Axiom: unfold+-- Axiom: least_fix+-- Lemma: par_lzero                        Q.E.D.+-- Lemma: par_monotone                     Q.E.D.+-- Lemma: seq_monotone                     Q.E.D.+-- Lemma: star_star_1+--   Step: 1 (unfold)                      Q.E.D.+--   Step: 2 (factor out x * star x)       Q.E.D.+--   Step: 3 (par_idem)                    Q.E.D.+--   Step: 4 (unfold)                      Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: subset_eq                        Q.E.D.+-- Lemma: star_star_2_2                    Q.E.D.+-- Lemma: star_star_2_3                    Q.E.D.+-- Lemma: star_star_2_1                    Q.E.D.+-- Lemma: star_star_2                      Q.E.D.+kleeneProofs :: IO ()+kleeneProofs = runTP $ do++  -- Kozen axioms+  par_assoc <- axiom "par_assoc" $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> x + (y + z) .== (x + y) + z+  par_comm  <- axiom "par_comm"  $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y)                 -> x + y       .== y + x+  par_idem  <- axiom "par_idem"  $ \(Forall @"x" (x :: SKleene))                                 -> x + x       .== x+  par_zero  <- axiom "par_zero"  $ \(Forall @"x" (x :: SKleene))                                 -> x + 0       .== x++  seq_assoc <- axiom "seq_assoc" $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> x * (y * z) .== (x * y) * z+  seq_zero  <- axiom "seq_zero"  $ \(Forall @"x" (x :: SKleene))                                 -> x * 0       .== 0+  seq_one   <- axiom "seq_one"   $ \(Forall @"x" (x :: SKleene))                                 -> x * 1       .== x++  rdistrib  <- axiom "rdistrib"  $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> x * (y + z) .== x * y + x * z+  ldistrib  <- axiom "ldistrib"  $ \(Forall @"x" (x :: SKleene)) (Forall @"y" y) (Forall @"z" z) -> (y + z) * x .== y * x + z * x++  unfold    <- axiom "unfold"    $ \(Forall @"e" e) -> star e .== 1 + e * star e++  least_fix <- axiom "least_fix" $ \(Forall @"x" x) (Forall @"e" e) (Forall @"f" f) -> ((f + e * x) <= x) .=> ((star e * f) <= x)++  -- Collect the basic axioms in a list for easy reference+  let kleene = [ proofOf par_assoc,  proofOf par_comm, proofOf par_idem, proofOf par_zero+               , proofOf seq_assoc,  proofOf seq_zero, proofOf seq_one+               , proofOf ldistrib,   proofOf rdistrib+               , proofOf unfold+               , proofOf least_fix+               ]++  -- Various proofs:+  par_lzero    <- lemma "par_lzero"    (\(Forall @"x" x) -> (0 :: SKleene) + x .== x)                                        kleene+  par_monotone <- lemma "par_monotone" (\(Forall @"x" x) (Forall @"y" y) (Forall @"z" z) -> x <= y .=> ((x + z) <= (y + z))) kleene+  seq_monotone <- lemma "seq_monotone" (\(Forall @"x" x) (Forall @"y" y) (Forall @"z" z) -> x <= y .=> ((x * z) <= (y * z))) kleene++  -- This one requires a chain of reasoning: x* x* == x*+  star_star_1  <- calc "star_star_1"+                       (\(Forall @"x" x) -> star x * star x .== star x) $+                       \x -> [] |- star x * star x                     ?? unfold+                                =: (1 + x * star x) * (1 + x * star x)+                                ?? "factor out x * star x"+                                ?? kleene+                                =: (1 + 1) + (x * star x + x * star x) ?? par_idem+                                =: 1 + x * star x                      ?? unfold+                                =: star x+                                =: qed++  subset_eq   <- lemma "subset_eq" (\(Forall @"x" x) (Forall @"y" y) -> (x .== y) .== (x <= y .&& y <= x)) kleene++  -- Prove: x** = x*+  star_star_2 <- do _1 <- lemma "star_star_2_2" (\(Forall @"x" x) -> ((star x * star x + 1) <= star x) .=> star (star x) <= star x) kleene+                    _2 <- lemma "star_star_2_3" (\(Forall @"x" x) -> star (star x) <= star x)                                       (kleene ++ [proofOf _1])+                    _3 <- lemma "star_star_2_1" (\(Forall @"x" x) -> star x        <= star (star x))                                kleene++                    lemma "star_star_2" (\(Forall @"x" x) -> star (star x) .== star x) [proofOf subset_eq, proofOf _2, proofOf _3]++  pure ()
+ Documentation/SBV/Examples/TP/Majority.hs view
@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.Majority+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving Boyer-Moore's majority algorithm correct. We follow the ACL2 proof+-- closely, which you can find at <https://github.com/acl2/acl2/blob/master/books/demos/majority-vote.lisp>.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Majority where++import Prelude hiding (null, length)++import Data.SBV+import Data.SBV.List++import Data.SBV.TP+import qualified Data.SBV.TP.List as TP++-- * Calculating majority++-- | Given a list, calculate the majority element using Boyer-Moore's algorithm.+-- Note that the algorithm returns the majority if it exists. If there is no+-- majority element, then the result is irrelevant.+majority :: SymVal a => SBV a -> SInteger -> SList a -> SBV a+majority = smtFunction "majority"+                    $ \c i lst ->  ite (null lst) c+                                       (let (x, xs) = uncons lst+                                        in ite (i .== 0)+                                                (majority x 1 xs)+                                                (majority c (i + ite (c .== x) 1 (-1)) xs))++-- | We can now define mjrty, which simply feeds the majority function with an arbitrary element of the domain.+-- By the definition of 'majority' above, this arbitrary element will be returned if the given list is empty.+-- Otherwise, majority will be returned if it exists, and an element of the list otherwise.+mjrty :: SymVal a => SList a -> SBV a+mjrty = majority (some "arb" (const sTrue)) 0++-- | The function @how-many@ in the paper is already defined in SBV as 'TP.count'. Let's give it a name:+howMany :: SymVal a => SBV a -> SList a -> SInteger+howMany = TP.count++-- * Correctness++-- | The generalized majority theorem. This comment is taken more or less+-- directly from J's proof, cast in SBV terms:+--+-- This is the generalized theorem that explains how majority works on any @c@ and+-- @i@ instead of just on the initial @c@ and @i=0@.+--+-- The way to imagine @majority c i xs@ is that we started with+-- a bigger @xs'@ that contains @i@ occurrences of c followed by @xs@. That is,+-- @xs' = replicate i c ++ xs@.  We know that @majority c 0 xs'@ finds+-- the majority in @xs'@ if there is one.+--+-- So the generalized theorem supposes that @e@ occurs a majority of times in @xs'@.+-- We can say that in terms of @c@, @i@, and @xs@: the number of times @e@ occurs in @xs@+-- plus @i@ (if @e@ is @c@) is greater than half of the length of @xs@ plus @i@.+--+-- The conclusion states that @majority c i x@ is @e@. We have:+--+-- >>> correctness @Integer+-- Inductive lemma: majorityGeneral+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2 (2 way case split)+--       Step: 1.2.2.1.1                   Q.E.D.+--       Step: 1.2.2.1.2                   Q.E.D.+--       Step: 1.2.2.2.1                   Q.E.D.+--       Step: 1.2.2.2.2                   Q.E.D.+--       Step: 1.2.2.Completeness          Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: majority                         Q.E.D.+-- Lemma: ifExistsFound                    Q.E.D.+-- Lemma: ifNoMajority                     Q.E.D.+-- Lemma: uniqueness+--   Step: 1                               Q.E.D.+--   Result:                               Q.E.D.+-- ([Proven] majority :: Ɐc ∷ Integer → Ɐxs ∷ [Integer] → Bool,[Proven] ifExistsFound :: Ɐc ∷ Integer → Ɐxs ∷ [Integer] → Bool,[Proven] ifNoMajority :: Ɐc ∷ Integer → Ɐxs ∷ [Integer] → Bool,[Proven] uniqueness :: Ɐm1 ∷ Integer → Ɐm2 ∷ Integer → Ɐxs ∷ [Integer] → Bool)+correctness :: forall a. SymVal a+            => IO ( Proof (Forall "c" a -> Forall "xs" [a] -> SBool)                    -- If majority exists, the calculated value is majority+                  , Proof (Forall "c" a -> Forall "xs" [a] -> SBool)                    -- If majority exists, it is found+                  , Proof (Forall "c" a -> Forall "xs" [a] -> SBool)                    -- If returned value isn't majority, then no majority exists+                  , Proof (Forall "m1" a -> Forall "m2" a  -> Forall "xs" [a] -> SBool) -- Uniqueness: If there are two majorities, they're the same+                  )+correctness = runTP $ do++  -- Helper definition+  let isMajority :: SBV a -> SList a -> SBool+      isMajority e xs = length xs `sEDiv` 2 .< TP.count e xs++  -- First prove the generalized majority theorem+  majorityGeneral <-+     induct "majorityGeneral"+            (\(Forall @"xs" xs) (Forall @"i" i) (Forall @"e" (e :: SBV a)) (Forall @"c" c)+                  -> i .>= 0 .&& (length xs + i) `sEDiv` 2 .< ite (e .== c) i 0 + TP.count e xs .=> majority c i xs .== e) $+            \ih (x, xs) i e c ->+                   [i .>= 0, (length (x .: xs) + i) `sEDiv` 2 .< ite (e .== c) i 0 + TP.count e (x .: xs)]+                |- majority c i (x .: xs)+                =: cases [ i .== 0 ==> majority x 1 xs+                                    ?? ih `at` (Inst @"i" 1, Inst @"e" e, Inst @"c" x)+                                    =: e+                                    =: qed+                         , i .>  0 ==> majority c (i + ite (c .== x) 1 (-1)) xs+                                    =: cases [ c .== x ==> majority c (i + 1) xs+                                                        ?? ih `at` (Inst @"i" (i+1), Inst @"e" e, Inst @"c" c)+                                                        =: e+                                                        =: qed+                                             , c ./= x ==> majority c (i - 1) xs+                                                        ?? ih `at` (Inst @"i" (i-1), Inst @"e" e, Inst @"c" c)+                                                        =: e+                                                        =: qed+                                             ]+                         ]++  -- We can now prove the main theorem, by instantiating the general version.+  correct <- lemma "majority"+                   (\(Forall c) (Forall xs) -> isMajority c xs .=> mjrty xs .== c)+                   [proofOf majorityGeneral]++  -- Corollary: If there is a majority element, then what we return is a majority element:+  ifExistsFound <- lemma "ifExistsFound"+                        (\(Forall c) (Forall xs) -> isMajority c xs .=> isMajority (mjrty xs) xs)+                        [proofOf correct]++  -- Contrapositive to the above: If the returned value is not majority, then there is no majority:+  ifNoMajority <- lemma "ifNoMajority"+                        (\(Forall c) (Forall xs) -> sNot (isMajority (mjrty xs) xs) .=> sNot (isMajority c xs))+                        [proofOf ifExistsFound]++  -- Let's also prove majority is unique, while we're at it, even though it is not essential for our main argument.+  unique <- calc "uniqueness"+                 (\(Forall m1) (Forall m2) (Forall xs) -> isMajority m1 xs .&& isMajority m2 xs .=> m1 .== m2) $+                 \m1 m2 xs -> [isMajority m1 xs, isMajority m2 xs]+                           |- m1+                           ?? correct `at` (Inst @"c" m1, Inst @"xs" xs)+                           ?? correct `at` (Inst @"c" m2, Inst @"xs" xs)+                           =: m2+                           =: qed++  pure (correct, ifExistsFound, ifNoMajority, unique)
+ Documentation/SBV/Examples/TP/McCarthy91.hs view
@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.McCarthy91+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving McCarthy's 91 function correct.+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.McCarthy91 where++import Data.SBV+import Data.SBV.TP++-- * Definitions++-- | Nested recursive definition of McCarthy's function.+mcCarthy91 :: SInteger -> SInteger+mcCarthy91 = smtFunction "mcCarthy91" $ \n -> ite (n .> 100)+                                                  (n - 10)+                                                  (mcCarthy91 (mcCarthy91 (n + 11)))+-- | Specification for McCarthy's function.+spec91 :: SInteger -> SInteger+spec91 n = ite (n .> 100) (n - 10) 91++-- * Correctness++-- | We prove the equivalence of the nested recursive definition against the spec with a case analysis+-- and strong induction. We have:+--+-- >>> correctness+-- Lemma: case1                            Q.E.D.+-- Lemma: case2                            Q.E.D.+-- Inductive lemma (strong): case3+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (unfold)                      Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: mcCarthy91+--   Step: 1 (3 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2                           Q.E.D.+--     Step: 1.3                           Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] mcCarthy91 :: Ɐn ∷ Integer → Bool+correctness :: IO (Proof (Forall "n" Integer -> SBool))+correctness = runTP $ do++   -- Case 1. When @n > 100@+   case1 <- lemma "case1" (\(Forall @"n" n) -> n .>= 100 .=> mcCarthy91 n .== spec91 n) []++   -- Case 2. When @90 <= n <= 100@+   case2 <- lemma "case2" (\(Forall @"n" n) -> 90 .<= n .&& n .<= 100 .=> mcCarthy91 n .== spec91 n) []++   -- Case 3. When @n < 90@. The crucial point here is the measure, which makes sure 101 < 100 < 99 < ...+   case3 <- sInduct "case3"+                    (\(Forall n) -> n .< 90 .=> mcCarthy91 n .== spec91 n)+                    (\n -> abs (101 - n)) $+                    \ih n -> [n .< 90] |- mcCarthy91 n+                                       ?? "unfold"+                                       =: mcCarthy91 (mcCarthy91 (n + 11))+                                       ?? ih `at` Inst @"n" (n + 11)+                                       =: mcCarthy91 91+                                       =: qed++   -- Putting it all together+   calc "mcCarthy91"+        (\(Forall n) -> mcCarthy91 n .== spec91 n) $+        \n -> [] |- cases [ n .> 100               ==> mcCarthy91 n ?? case1 =: spec91 n =: qed+                          , 90 .<= n .&& n .<= 100 ==> mcCarthy91 n ?? case2 =: spec91 n =: qed+                          , n .< 90                ==> mcCarthy91 n ?? case3 =: spec91 n =: qed+                          ]
+ Documentation/SBV/Examples/TP/MergeSort.hs view
@@ -0,0 +1,275 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.MergeSort+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving merge sort correct.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.MergeSort where++import Prelude hiding (null, length, head, tail, elem, splitAt, (++), take, drop)++import Data.SBV+import Data.SBV.List+import Data.SBV.Tuple+import Data.SBV.TP+import qualified Data.SBV.TP.List as TP++import qualified Documentation.SBV.Examples.TP.SortHelpers as SH++#ifdef DOCTEST+-- $setup+-- >>> :set -XTypeApplications+#endif++-- * Merge sort++-- | Merge two already sorted lists into another+merge :: (Ord a, SymVal a) => SList a -> SList a -> SList a+merge = smtFunction "merge" $ \l r -> ite (null l) r+                                    $ ite (null r) l+                                    $ let (a, as) = uncons l+                                          (b, bs) = uncons r+                                      in ite (a .<= b) (a .: merge as r) (b .: merge l bs)++-- | Merge sort, using 'merge' above to successively sort halved input+mergeSort :: (Ord a, SymVal a) => SList a -> SList a+mergeSort = smtFunction "mergeSort" $ \l -> ite (length l .<= 1) l+                                              $ let (h1, h2) = splitAt (length l `sEDiv` 2) l+                                                in merge (mergeSort h1) (mergeSort h2)++-- * Correctness proof++-- | Correctness of merge-sort.+--+-- We have:+--+-- >>> correctness @Integer+-- Lemma: nonDecrInsert                                        Q.E.D.+-- Inductive lemma: countAppend+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Step: 2 (unfold count)                                    Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4 (simplify)                                        Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: take_drop                                            Q.E.D.+-- Lemma: takeDropCount+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma (strong): mergeKeepsSort+--   Step: Measure is non-negative                             Q.E.D.+--   Step: 1 (4 way full case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2                                               Q.E.D.+--     Step: 1.3                                               Q.E.D.+--     Step: 1.4.1 (unfold merge)                              Q.E.D.+--     Step: 1.4.2 (2 way case split)+--       Step: 1.4.2.1.1 (case split)                          Q.E.D.+--       Step: 1.4.2.1.2                                       Q.E.D.+--       Step: 1.4.2.2.1 (case split)                          Q.E.D.+--       Step: 1.4.2.2.2                                       Q.E.D.+--       Step: 1.4.2.Completeness                              Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma (strong): sortNonDecreasing+--   Step: Measure is non-negative                             Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2.1 (unfold)                                    Q.E.D.+--     Step: 1.2.2 (push nonDecreasing down)                   Q.E.D.+--     Step: 1.2.3                                             Q.E.D.+--     Step: 1.2.4                                             Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma (strong): mergeCount+--   Step: Measure is non-negative                             Q.E.D.+--   Step: 1 (4 way full case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2                                               Q.E.D.+--     Step: 1.3                                               Q.E.D.+--     Step: 1.4.1 (unfold merge)                              Q.E.D.+--     Step: 1.4.2 (push count inside)                         Q.E.D.+--     Step: 1.4.3 (unfold count, twice)                       Q.E.D.+--     Step: 1.4.4                                             Q.E.D.+--     Step: 1.4.5                                             Q.E.D.+--     Step: 1.4.6 (unfold count in reverse, twice)            Q.E.D.+--     Step: 1.4.7 (simplify)                                  Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma (strong): sortIsPermutation+--   Step: Measure is non-negative                             Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2.1 (unfold mergeSort)                          Q.E.D.+--     Step: 1.2.2 (push count down, simplify, rearrange)      Q.E.D.+--     Step: 1.2.3                                             Q.E.D.+--     Step: 1.2.4                                             Q.E.D.+--     Step: 1.2.5                                             Q.E.D.+--     Step: 1.2.6                                             Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: mergeSortIsCorrect                                   Q.E.D.+-- [Proven] mergeSortIsCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. (Ord a, SymVal a) => IO (Proof (Forall "xs" [a] -> SBool))+correctness = runTPWith (tpRibbon 60 z3) $ do++    --------------------------------------------------------------------------------------------+    -- Part I. Import helper lemmas, definitions+    --------------------------------------------------------------------------------------------+    let nonDecreasing = SH.nonDecreasing @a+        isPermutation = SH.isPermutation @a+        count         = TP.count         @a++    nonDecrIns    <- SH.nonDecrIns    @a+    takeDropCount <- TP.takeDropCount @a++    --------------------------------------------------------------------------------------------+    -- Part II. Prove that the output of merge sort is non-decreasing.+    --------------------------------------------------------------------------------------------++    mergeKeepsSort <-+        sInductWith cvc5 "mergeKeepsSort"+           (\(Forall xs) (Forall ys) -> nonDecreasing xs .&& nonDecreasing ys .=> nonDecreasing (merge xs ys))+           (\xs ys -> tuple (length xs, length ys)) $+           \ih xs ys -> [nonDecreasing xs, nonDecreasing ys]+                     |- split2 (xs, ys)+                               trivial           -- when both xs and ys are empty.  Trivial.+                               trivial           -- when xs is empty, but ys isn't. Trivial.+                               trivial           -- when ys is empty, but xs isn't. Trivial.+                               (\(a, as) (b, bs) ->+                                     nonDecreasing (merge (a .: as) (b .: bs))+                                  ?? "unfold merge"+                                  =: nonDecreasing (ite (a .<= b)+                                                        (a .: merge as (b .: bs))+                                                        (b .: merge (a .: as) bs))+                                  ?? "case split"+                                  =: cases [ a .<= b ==> nonDecreasing (a .: merge as (b .: bs))+                                                      ?? ih         `at` (Inst @"xs" as, Inst @"ys" (b .: bs))+                                                      ?? nonDecrIns `at` (Inst @"x" a, Inst @"xs" (merge as (b .: bs)))+                                                      =: sTrue+                                                      =: qed+                                           , a .> b  ==> nonDecreasing (b .: merge (a .: as) bs)+                                                      ?? ih         `at` (Inst @"xs" (a .: as), Inst @"ys" bs)+                                                      ?? nonDecrIns `at` (Inst @"x" b, Inst @"xs" (merge (a .: as) bs))+                                                      =: sTrue+                                                      =: qed+                                           ])++    sortNonDecreasing <-+        sInduct "sortNonDecreasing"+                (\(Forall xs) -> nonDecreasing (mergeSort xs))+                length $+                \ih xs -> [] |- split xs+                                      qed+                                      (\e es -> nonDecreasing (mergeSort (e .: es))+                                             ?? "unfold"+                                             =: let (h1, h2) = splitAt (length (e .: es) `sEDiv` 2) (e .: es)+                                                in nonDecreasing (ite (length (e .: es) .<= 1)+                                                                      (e .: es)+                                                                      (merge (mergeSort h1) (mergeSort h2)))+                                             ?? "push nonDecreasing down"+                                             =: ite (length (e .: es) .<= 1)+                                                    (nonDecreasing (e .: es))+                                                    (nonDecreasing (merge (mergeSort h1) (mergeSort h2)))+                                             ?? ih `at` Inst @"xs" es+                                             =: ite (length (e .: es) .<= 1)+                                                    sTrue+                                                    (nonDecreasing (merge (mergeSort h1) (mergeSort h2)))+                                             ?? ih `at` Inst @"xs" h1+                                             ?? ih `at` Inst @"xs" h2+                                             ?? mergeKeepsSort `at` (Inst @"xs" (mergeSort h1), Inst @"ys" (mergeSort h2))+                                             =: sTrue+                                             =: qed)++    --------------------------------------------------------------------------------------------+    -- Part III. Prove that the output of merge sort is a permuation of its input+    --------------------------------------------------------------------------------------------+    mergeCount <-+        sInduct "mergeCount"+                (\(Forall xs) (Forall ys) (Forall e) -> count e (merge xs ys) .== count e xs + count e ys)+                (\xs ys _e -> tuple (length xs, length ys)) $+                \ih as bs e -> [] |- split2 (as, bs)+                                            trivial+                                            trivial+                                            trivial+                                            (\(x, xs) (y, ys) -> count e (merge (x .: xs) (y .: ys))+                                                              ?? "unfold merge"+                                                              =: count e (ite (x .<= y)+                                                                              (x .: merge xs (y .: ys))+                                                                              (y .: merge (x .: xs) ys))+                                                              ?? "push count inside"+                                                              =: ite (x .<= y)+                                                                     (count e (x .: merge xs (y .: ys)))+                                                                     (count e (y .: merge (x .: xs) ys))+                                                              ?? "unfold count, twice"+                                                              =: ite (x .<= y)+                                                                     (let r = count e (merge xs (y .: ys)) in ite (e .== x) (1+r) r)+                                                                     (let r = count e (merge (x .: xs) ys) in ite (e .== y) (1+r) r)+                                                              ?? ih `at` (Inst @"xs" xs, Inst @"ys" (y .: ys), Inst @"e" e)+                                                              =: ite (x .<= y)+                                                                     (let r = count e xs + count e (y .: ys) in ite (e .== x) (1+r) r)+                                                                     (let r = count e (merge (x .: xs) ys) in ite (e .== y) (1+r) r)+                                                              ?? ih `at` (Inst @"xs" (x .: xs), Inst @"ys" ys, Inst @"e" e)+                                                              =: ite (x .<= y)+                                                                     (let r = count e xs + count e (y .: ys) in ite (e .== x) (1+r) r)+                                                                     (let r = count e (x .: xs) + count e ys in ite (e .== y) (1+r) r)+                                                              ?? "unfold count in reverse, twice"+                                                              =: ite (x .<= y)+                                                                     (count e (x .: xs) + count e (y .: ys))+                                                                     (count e (x .: xs) + count e (y .: ys))+                                                              ?? "simplify"+                                                              =: count e (x .: xs) + count e (y .: ys)+                                                              =: qed)++    sortIsPermutation <-+        sInductWith cvc5 "sortIsPermutation"+                (\(Forall xs) (Forall e) -> count e xs .== count e (mergeSort xs))+                (\xs _e -> length xs) $+                \ih as e -> [] |- split as+                                        trivial+                                        (\x xs -> count e (mergeSort (x .: xs))+                                               ?? "unfold mergeSort"+                                               =: count e (ite (length (x .: xs) .<= 1)+                                                               (x .: xs)+                                                               (let (h1, h2) = splitAt (length (x .: xs) `sEDiv` 2) (x .: xs)+                                                                in merge (mergeSort h1) (mergeSort h2)))+                                               ?? "push count down, simplify, rearrange"+                                               =: let (h1, h2) = splitAt (length (x .: xs) `sEDiv` 2) (x .: xs)+                                               in ite (null xs)+                                                      (count e [x])+                                                      (count e (merge (mergeSort h1) (mergeSort h2)))+                                               ?? mergeCount `at` (Inst @"xs" (mergeSort h1), Inst @"ys" (mergeSort h2), Inst @"e" e)+                                               =: ite (null xs)+                                                      (count e [x])+                                                      (count e (mergeSort h1) + count e (mergeSort h2))+                                               ?? ih `at` (Inst @"xs" h1, Inst @"e" e)+                                               =: ite (null xs)+                                                      (count e [x])+                                                      (count e h1 + count e (mergeSort h2))+                                               ?? ih `at` (Inst @"xs" h2, Inst @"e" e)+                                               =: ite (null xs)+                                                      (count e [x])+                                                      (count e h1 + count e h2)+                                               ?? takeDropCount `at` (Inst @"xs" (x .: xs), Inst @"n" (length (x .: xs) `sEDiv` 2), Inst @"e" e)+                                               =: ite (null xs)+                                                      (count e [x])+                                                      (count e (x .: xs))+                                               =: qed)++    --------------------------------------------------------------------------------------------+    -- Put the two parts together for the final proof+    --------------------------------------------------------------------------------------------+    lemma "mergeSortIsCorrect"+          (\(Forall xs) -> let out = mergeSort xs in nonDecreasing out .&& isPermutation xs out)+          [proofOf sortNonDecreasing, proofOf sortIsPermutation]
+ Documentation/SBV/Examples/TP/Numeric.hs view
@@ -0,0 +1,357 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.Numeric+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Example use of inductive TP proofs, over integers.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Numeric where++import Prelude hiding (sum, map, product, length, (^), replicate, elem)++import Data.SBV+import Data.SBV.TP+import Data.SBV.List++#ifdef DOCTEST+-- $setup+-- >>> :set -XScopedTypeVariables+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+-- >>> import Control.Exception+#endif++-- * Sum of constants++-- | \(\sum_{i=1}^{n} c = c \cdot n\)+--+-- >>> runTP $ sumConstProof (uninterpret "c")+-- Inductive lemma: sumConst_correct+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] sumConst_correct :: Ɐn ∷ Integer → Bool+sumConstProof :: SInteger -> TP (Proof (Forall "n" Integer -> SBool))+sumConstProof c = induct "sumConst_correct"+                         (\(Forall n) -> n .>= 0 .=> sum (replicate n c) .== c * n) $+                         \ih n -> [n .>= 0] |- sum (replicate (n+1) c)+                                            =: sum (c .: replicate n c)+                                            =: c + sum (replicate n c)+                                            ?? ih+                                            =: c + c*n+                                            =: c*(n+1)+                                            =: qed++-- * Sum of numbers++-- | \(\sum_{i=0}^{n} i = \frac{n(n+1)}{2}\)+--+-- NB. We define the sum of numbers from @0@ to @n@ as @sum [sEnum|n, n-1 .. 0|]@, i.e., we+-- construct the list starting from @n@ going down to @0@. Contrast this to the perhaps more natural+-- definition of @sum [sEnum|0 .. n]@, i.e., going up. While the latter is equivalent functionality, the former+-- works much better with the proof-structure: Since we induct on @n@, in each step we strip of one+-- layer, and the recursion in the down-to construction matches the inductive schema.+--+-- >>> runTP sumProof+-- Inductive lemma: sum_correct+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] sum_correct :: Ɐn ∷ Integer → Bool+sumProof :: TP (Proof (Forall "n" Integer -> SBool))+sumProof = induct "sum_correct"+                  (\(Forall n) -> n .>= 0 .=> sum [sEnum|n, n-1 .. 0|] .== (n * (n+1)) `sEDiv` 2) $+                  \ih n -> [n .>= 0] |- sum [sEnum|n+1, n .. 0|]+                                     =: n+1 + sum [sEnum|n, n-1 .. 0|]+                                     ?? ih+                                     =: n+1 + (n * (n+1)) `sEDiv` 2+                                     =: ((n+1) * (n+2)) `sEDiv` 2+                                     =: qed++-- * Sum of squares of numbers+--+-- | \(\sum_{i=0}^{n} i^2 = \frac{n(n+1)(2n+1)}{6}\)+--+-- >>> runTP sumSquareProof+-- Inductive lemma: sumSquare_correct+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] sumSquare_correct :: Ɐn ∷ Integer → Bool+sumSquareProof :: TP (Proof (Forall "n" Integer -> SBool))+sumSquareProof = do+   let sq :: SInteger -> SInteger+       sq k = k * k++       sumSquare n = sum $ map sq [sEnum|n, n-1 .. 0|]++   induct "sumSquare_correct"+          (\(Forall n) -> n .>= 0 .=> sumSquare n .== (n*(n+1)*(2*n+1)) `sEDiv` 6) $+          \ih n -> [n .>= 0] |- sumSquare (n+1)+                             =: sum (map sq [sEnum|n+1, n .. 0|])+                             =: sum (map sq (n+1 .: [sEnum|n, n-1 .. 0|]))+                             =: sum ((n+1)*(n+1) .: map sq [sEnum|n, n-1 .. 0|])+                             =: (n+1)*(n+1) + sum (map sq [sEnum|n, n-1 .. 0|])+                             ?? ih+                             =: (n+1)*(n+1) + (n*(n+1)*(2*n+1)) `sEDiv` 6+                             =: ((n+1)*(n+2)*(2*n+3)) `sEDiv` 6+                             =: qed++-- * Sum of cubes of numbers++-- | \(\sum_{i=0}^{n} i^3 = \left( \sum_{i=0}^{n} i \right)^2 = \left( \frac{n(n+1)}{2} \right)^2\)+--+-- This is attributed to Nicomachus, hence the name.+--+-- >>> runTP nicomachus+-- Inductive lemma: sum_correct+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: evenHalfSquared                  Q.E.D.+-- Inductive lemma: nn1IsEven+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: sum_squared+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: nicomachus+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] nicomachus :: Ɐn ∷ Integer → Bool+nicomachus :: TP (Proof (Forall "n" Integer -> SBool))+nicomachus = do+   let (^) :: SInteger -> Integer -> SInteger+       _ ^ 0 = 1+       b ^ n = b * b ^ (n-1)+       infixr 8 ^++       sumCubed :: SInteger -> SInteger+       sumCubed = smtFunction "sumCubed" $ \n -> ite (n .<= 0) 0 (n^3 + sumCubed (n - 1))++   -- Grab the proof of regular summation formula+   sp <- sumProof++   -- Square of the summation result. This is a trivial lemma for humans, but there are lots+   -- of multiplications involved making the problem non-linear and we need to spell it out.+   ssp <- do+        -- Squaring half of an even number? You can square the number and divide by 4 instead:+        -- z3 can prove this out of the box, but without it being explicitly expressed, the+        -- following proof doesn't go through.+        evenHalfSquared <- lemma "evenHalfSquared"+                                 (\(Forall n) -> 2 `sDivides` n .=> (n `sEDiv` 2) ^ 2 .== (n ^ 2) `sEDiv` 4)+                                 []++        -- The multiplication @n * (n+1)@ is always even. It's surprising that I had to use induction here+        -- but neither z3 nor cvc5 can converge on this out-of-the-box.+        nn1IsEven <- induct "nn1IsEven"+                            (\(Forall n) -> n .>= 0 .=> 2 `sDivides` (n * (n+1))) $+                            \ih n -> [n .>= 0] |- 2 `sDivides` ((n+1) * (n+2))+                                               =: 2 `sDivides` (n*(n+1) + 2*(n+1))+                                               =: 2 `sDivides` (n*(n+1))+                                               ?? ih+                                               =: sTrue+                                               =: qed++        calc "sum_squared"+               (\(Forall @"n" n) -> n .>= 0 .=> sum [sEnum|n, n-1 .. 0|] ^ 2 .== (n^2 * (n+1)^2) `sEDiv` 4) $+               \n -> [n .>= 0] |- sum [sEnum|n, n-1 .. 0|] ^ 2+                               ?? sp `at` Inst @"n" n+                               =: ((n * (n+1)) `sEDiv` 2)^2+                               ?? nn1IsEven `at` Inst @"n" n+                               ?? evenHalfSquared `at` Inst @"n" (n * (n+1))+                               =: ((n * (n+1))^2) `sEDiv` 4+                               =: qed++   -- We can finally put it together:+   induct "nicomachus"+          (\(Forall n) -> n .>= 0 .=> sumCubed n .== sum [sEnum|n, n-1 .. 0|] ^ 2) $+          \ih n -> [n .>= 0]+                |- sumCubed (n+1)+                =: (n+1)^3 + sumCubed n+                ?? ih+                ?? ssp+                =: sum [sEnum|n+1, n .. 0|] ^ 2+                =: qed++-- * Exponents and divisibility by 7++-- | \(7 \mid \left(11^n - 4^n\right)\)+--+-- NB. As of Feb 2025, z3 struggles with the inductive step in this proof, but cvc5 performs just fine.+--+-- >>> runTP elevenMinusFour+-- Lemma: powN                             Q.E.D.+-- Inductive lemma: elevenMinusFour+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Step: 7                               Q.E.D.+--   Step: 8                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] elevenMinusFour :: Ɐn ∷ Integer → Bool+elevenMinusFour :: TP (Proof (Forall "n" Integer -> SBool))+elevenMinusFour = do+   let pow :: SInteger -> SInteger -> SInteger+       pow = smtFunction "pow" $ \x y -> ite (y .== 0) 1 (x * pow x (y - 1))++       emf :: SInteger -> SBool+       emf n = 7 `sDivides` (11 `pow` n - 4 `pow` n)++   -- helper+   powN <- lemma "powN" (\(Forall x) (Forall n) -> n .>= 0 .=> x `pow` (n+1) .== x * x `pow` n) []++   inductWith cvc5 "elevenMinusFour"+          (\(Forall n) -> n .>= 0 .=> emf n) $+          \ih n -> [n .>= 0]+                |- emf (n+1)+                =: 7 `sDivides` (11 `pow` (n+1) - 4 `pow` (n+1))+                ?? powN `at` (Inst @"x" 11, Inst @"n" n)+                =: 7 `sDivides` (11 * 11 `pow` n - 4 `pow` (n+1))+                ?? powN `at` (Inst @"x" 4, Inst @"n" n)+                =: 7 `sDivides` (11 * 11 `pow` n - 4 * 4 `pow` n)+                =: 7 `sDivides` (7 * 11 `pow` n + 4 * 11 `pow` n - 4 * 4 `pow` n)+                =: 7 `sDivides` (7 * 11 `pow` n + 4 * (11 `pow` n - 4 `pow` n))+                ?? ih+                =: let x = some "x" (\v -> 7*v .== 11 `pow` n - 4 `pow` n)   -- Apply the IH and grab the witness for it+                in 7 `sDivides` (7 * 11 `pow` n + 4 * 7 * x)+                =: 7 `sDivides` (7 * (11 `pow` n + 4 * x))+                =: sTrue+                =: qed++-- * A proof about factorials++-- | \(\sum_{k=0}^{n} k \cdot k! = (n+1)! - 1\)+--+-- >>> runTP sumMulFactorial+-- Lemma: fact (n+1)+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: sumMulFactorial+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Step: 7                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] sumMulFactorial :: Ɐn ∷ Integer → Bool+sumMulFactorial :: TP (Proof (Forall "n" Integer -> SBool))+sumMulFactorial = do+  let fact :: SInteger -> SInteger+      fact n = product [sEnum|n, n-1 .. 1|]++  -- This is pure expansion, but without it z3 struggles in the next lemma.+  helper <- calc "fact (n+1)"+                 (\(Forall n) -> n .>= 0 .=> fact (n+1) .== (n+1) * fact n) $+                 \n -> [n .>= 0] |- fact (n+1)+                                 =: product [sEnum|n+1, n .. 1|]+                                 =: product (n+1 .: [sEnum|n, n-1 .. 1|])+                                 =: (n+1) * product [sEnum|n, n-1 .. 1|]+                                 =: (n+1) * fact n+                                 =: qed++  induct "sumMulFactorial"+         (\(Forall n) -> n .>= 0 .=> sum (map (\k -> k * fact k) [sEnum|n, n-1 .. 0|]) .== fact (n+1) - 1) $+         \ih n -> [n .>= 0] |- sum (map (\k -> k * fact k) [sEnum|n+1, n .. 0|])+                            =: sum (map (\k -> k * fact k) (n+1 .: [sEnum|n, n-1 .. 0|]))+                            =: sum ((n+1) * fact (n+1) .: map (\k -> k * fact k) [sEnum|n, n-1 .. 0|])+                            =: (n+1) * fact (n+1) + sum (map (\k -> k * fact k) [sEnum|n, n-1 .. 0|])+                            ?? ih+                            =: (n+1) * fact (n+1) + fact (n+1) - 1+                            =: ((n+1) + 1) * fact (n+1) - 1+                            =: (n+2) * fact (n+1) - 1+                            ?? helper `at` Inst @"n" (n+1)+                            =: fact (n+2) - 1+                            =: qed++-- * Product with 0++-- | \(\prod_{x \in xs} x = 0 \iff 0 \in xs\)+--+-- >>> runTP product0+-- Inductive lemma: product0+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2 (2 way case split)+--     Step: 2.1                           Q.E.D.+--     Step: 2.2.1                         Q.E.D.+--     Step: 2.2.2                         Q.E.D.+--     Step: 2.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] product0 :: Ɐxs ∷ [Integer] → Bool+product0 :: TP (Proof (Forall "xs" [Integer] -> SBool))+product0 =+  induct "product0"+         (\(Forall @"xs" (xs :: SList Integer)) -> product xs .== 0 .<=> 0 `elem` xs) $+         \ih (x, xs) -> [] |- (product (x .: xs) .== 0 .<=> 0 `elem` (x .: xs))+                           =: (x * product xs .== 0 .<=> x .== 0 .|| 0 `elem` xs)+                           =: cases [ x .== 0 ==> trivial+                                    , x ./= 0 ==> (x * product xs .== 0 .<=> 0 `elem` xs)+                                               ?? ih+                                               =: sTrue+                                               =: qed+                                    ]++-- * A negative example++-- | The regular inductive proof on integers (i.e., proving at @0@, assuming at @n@ and proving at+-- @n+1@ will not allow you to conclude things when @n < 0@. The following example demonstrates this with the most+-- obvious example:+--+-- >>> badNonNegative `catch` (\(_ :: SomeException) -> pure ())+-- Inductive lemma: badNonNegative+--   Step: Base                            Q.E.D.+--   Step: 1+-- *** Failed to prove badNonNegative.1.+-- Falsifiable. Counter-example:+--   n = -2 :: Integer+badNonNegative :: IO ()+badNonNegative = runTP $ do+    _ <- induct "badNonNegative"+                (\(Forall @"n" (n :: SInteger)) -> n .>= 0) $+                \ih n -> [] |- n + 1 .>= 0+                            ?? ih+                            =: sTrue+                            =: qed+    pure ()
+ Documentation/SBV/Examples/TP/PowerMod.hs view
@@ -0,0 +1,756 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.PowerMod+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proofs about power and modulus. Adapted from an example by amigalemming,+-- see <http://github.com/LeventErkok/sbv/issues/744>.+--+-- We also demonstrate the proof-caching features of TP.+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.PowerMod where++import Data.SBV+import Data.SBV.TP++-- | The proofs in this module are structured so they are presented at the top-level and reused.+-- This results in re-running the proofs over and over, as each proof has to run all its dependents.+-- To avoid re-running proofs, we tell TP to use a proof-cache. Note that use of a proof-cache comes+-- with the user obligation that all proofs used are uniquely named. Otherwise the results can be+-- unsound, and SBV will indicate this possibility in its output.+runCached :: TP a -> IO a+runCached = runTPWith (tpCache z3)++-- | Power function over integers.+power :: SInteger -> SInteger -> SInteger+power = smtFunction "power" $ \b n -> ite (n .<= 0) 1 (b * power b (n-1))++-- | \(m > 1 \Rightarrow n + mk \equiv n \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached modAddMultiple+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] modAddMultiple :: Ɐk ∷ Integer → Ɐn ∷ Integer → Ɐm ∷ Integer → Bool+modAddMultiple :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> Forall "m" Integer -> SBool))+modAddMultiple = do+   inductWith (tpCache cvc5) "modAddMultiple"+      (\(Forall k) (Forall n) (Forall m) -> m .> 1 .=> (n + m*k) `sEMod` m .== n `sEMod` m) $+      \ih k n m -> [m .> 1] |- (n + m*(k+1)) `sEMod` m+                              =: (n + m*k + m) `sEMod` m+                              =: (n + m*k) `sEMod` m+                              ?? ih `at` (Inst @"n" n, Inst @"m" m)+                              =: n `sEMod` m+                              =: qed++-- | \(m > 0 \Rightarrow a + b \equiv a + (b \bmod m) \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached modAddRight+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] modAddRight :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool+modAddRight :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool))+modAddRight = do+   mAddMul <- modAddMultiple+   calc "modAddRight"+      (\(Forall a) (Forall b) (Forall m) -> m .> 0  .=>  (a+b) `sEMod` m .== (a + b `sEMod` m) `sEMod` m) $+      \a b m -> [m .> 0] |- (a+b) `sEMod` m+                         =: (a + b `sEMod` m + m * b `sEDiv` m) `sEMod` m+                         ?? mAddMul `at` (Inst @"k" (b `sEDiv` m), Inst @"n" (a + b `sEMod` m), Inst @"m" m)+                         =: (a + b `sEMod` m) `sEMod` m+                         =: qed++-- | \(m > 0 \Rightarrow a + b \equiv (a \bmod m) + b \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached modAddLeft+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] modAddLeft :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool+modAddLeft :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool))+modAddLeft = do+   mAddR <- modAddRight+   calc "modAddLeft"+      (\(Forall a) (Forall b) (Forall m) -> m .> 0 .=>  (a+b) `sEMod` m .== (a `sEMod` m + b) `sEMod` m) $+      \a b m -> [m .> 0] |- (a+b) `sEMod` m+                         =: (b+a) `sEMod` m+                         ?? mAddR+                         =: (b + a `sEMod` m) `sEMod` m+                         =: (a `sEMod` m + b) `sEMod` m+                         =: qed++-- | \(m > 0 \Rightarrow a - b \equiv a - (b \bmod m) \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached modSubRight+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modSubRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] modSubRight :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool+modSubRight :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool))+modSubRight = do+   mAddMul <- modAddMultiple+   calc "modSubRight"+      (\(Forall a) (Forall b) (Forall m) -> m .> 0 .=>  (a-b) `sEMod` m .== (a - b `sEMod` m) `sEMod` m) $+      \a b m -> [m .> 0] |- (a-b) `sEMod` m+                         =: (a - (b `sEMod` m + m * b `sEDiv` m)) `sEMod` m+                         =: ((a - b `sEMod` m) + m*(- (b `sEDiv` m))) `sEMod` m+                         ?? mAddMul `at` (Inst @"k" (- (b `sEDiv` m)), Inst @"n" (a - b `sEMod` m), Inst @"m" m)+                         =: (a - b `sEMod` m) `sEMod` m+                         =: qed++-- | \(a \geq 0 \land m > 0 \Rightarrow ab \equiv a \cdot (b \bmod m) \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached modMulRightNonneg+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Inductive lemma: modMulRightNonneg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven. Cached: modAddRight] modMulRightNonneg :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool+modMulRightNonneg :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool))+modMulRightNonneg = do+   mAddL <- modAddLeft+   mAddR <- modAddRight++   induct "modMulRightNonneg"+      (\(Forall a) (Forall b) (Forall m) -> a .>= 0 .&& m .> 0 .=> (a*b) `sEMod` m .== (a * b `sEMod` m) `sEMod` m) $+      \ih a b m -> [a .>= 0, m .> 0] |- ((a+1)*b) `sEMod` m+                                     =: (a*b+b) `sEMod` m+                                     ?? mAddR `at` (Inst @"a" (a*b), Inst @"b" b, Inst @"m" m)+                                     =: (a*b + b `sEMod` m) `sEMod` m+                                     ?? mAddL `at` (Inst @"a" (a*b), Inst @"b" (b `sEMod` m), Inst @"m" m)+                                     =: ((a*b) `sEMod` m + b `sEMod` m) `sEMod` m+                                     ?? ih `at` (Inst @"b" b, Inst @"m" m)+                                     =: ((a * b `sEMod` m) `sEMod` m + b `sEMod` m) `sEMod` m+                                     ?? mAddL+                                     =: (a * b `sEMod` m + b `sEMod` m) `sEMod` m+                                     =: ((a+1) * b `sEMod` m) `sEMod` m+                                     =: qed++-- | \(a \geq 0 \land m > 0 \Rightarrow -ab \equiv -\left(a \cdot (b \bmod m)\right) \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached modMulRightNeg+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Lemma: modSubRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: modMulRightNeg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven. Cached: modAddMultiple] modMulRightNeg :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool+modMulRightNeg :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool))+modMulRightNeg = do+   mAddL <- modAddLeft+   mSubR <- modSubRight++   induct "modMulRightNeg"+      (\(Forall a) (Forall b) (Forall m) -> a .>= 0 .&& m .> 0 .=> (-(a*b)) `sEMod` m .== (-(a * b `sEMod` m)) `sEMod` m) $+      \ih a b m -> [a .>= 0, m .> 0] |- (-((a+1)*b)) `sEMod` m+                                     =: (-(a*b)-b) `sEMod` m+                                     ?? mSubR `at` (Inst @"a" (-(a*b)), Inst @"b" b, Inst @"m" m)+                                     =: (-(a*b) - b `sEMod` m) `sEMod` m+                                     ?? mAddL `at` (Inst @"a" (-(a*b)), Inst @"b" (- (b `sEMod` m)), Inst @"m" m)+                                     =: ((-(a*b)) `sEMod` m - b `sEMod` m) `sEMod` m+                                     ?? ih `at` (Inst @"b" b, Inst @"m" m)+                                     =: ((-(a * b `sEMod` m)) `sEMod` m - b `sEMod` m) `sEMod` m+                                     ?? mAddL+                                     =: (-(a * b `sEMod` m) - b `sEMod` m) `sEMod` m+                                     =: (-((a+1) * b `sEMod` m)) `sEMod` m+                                     =: qed++-- | \(m > 0 \Rightarrow ab \equiv a \cdot (b \bmod m) \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached modMulRight+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Inductive lemma: modMulRightNonneg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Lemma: modSubRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: modMulRightNeg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modMulRight+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.2.3                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven. Cached: modAddLeft, modAddMultiple, modAddRight] modMulRight :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool+modMulRight :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool))+modMulRight = do+   mMulNonneg <- modMulRightNonneg+   mMulNeg    <- modMulRightNeg++   calc "modMulRight"+        (\(Forall a) (Forall b) (Forall m) -> m .> 0 .=> (a*b) `sEMod` m .== (a * b `sEMod` m) `sEMod` m) $+        \a b m -> [m .> 0] |- cases [ a .>= 0 ==> (a*b) `sEMod` m+                                               ?? mMulNonneg `at` (Inst @"a" a, Inst @"b" b, Inst @"m" m)+                                               =: (a * b `sEMod` m) `sEMod` m+                                               =: qed+                                    , a .<  0 ==> (a*b) `sEMod` m+                                               =: (-((-a)*b)) `sEMod` m+                                               ?? mMulNeg `at` (Inst @"a" (-a), Inst @"b" b, Inst @"m" m)+                                               =: (-((-a) * b `sEMod` m)) `sEMod` m+                                               =: (a * b `sEMod` m) `sEMod` m+                                               =: qed+                                    ]++-- | \(m > 0 \Rightarrow ab \equiv (a \bmod m) \cdot b \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached modMulLeft+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Inductive lemma: modMulRightNonneg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Lemma: modSubRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: modMulRightNeg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modMulRight+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.2.3                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modMulLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven. Cached: modAddLeft, modAddMultiple, modAddRight] modMulLeft :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool+modMulLeft :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool))+modMulLeft = do+   mMulR <- modMulRight++   calc "modMulLeft"+        (\(Forall a) (Forall b) (Forall m) -> m .> 0 .=> (a*b) `sEMod` m .== (a `sEMod` m * b) `sEMod` m) $+        \a b m -> [m .> 0] |- (a*b) `sEMod` m+                           =: (b*a) `sEMod` m+                           ?? mMulR+                           =: (b * a `sEMod` m) `sEMod` m+                           =: (a `sEMod` m * b) `sEMod` m+                           =: qed++-- | \(n \geq 0 \land m > 0 \Rightarrow b^n \equiv (b \bmod m)^n \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached powerMod+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Inductive lemma: modMulRightNonneg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Lemma: modSubRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: modMulRightNeg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modMulRight+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.2.3                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modMulLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modMulRightNonneg               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modSubRight                     Q.E.D.+-- Cached: modMulRightNeg                  Q.E.D.+-- Cached: modMulRight                     Q.E.D.+-- Inductive lemma: powerModInduct+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: powerMod                         Q.E.D.+-- [Proven. Cached: modAddLeft, modAddMultiple, modAddRight, modMulRight] powerMod :: Ɐb ∷ Integer → Ɐn ∷ Integer → Ɐm ∷ Integer → Bool+powerMod :: TP (Proof (Forall "b" Integer -> Forall "n" Integer -> Forall "m" Integer -> SBool))+powerMod = do+   mMulL <- modMulLeft+   mMulR <- modMulRight++   -- We want to write the b parameter first, but need to induct on n. So, this helper rearranges the parameters only.+   pMod <- induct "powerModInduct"+      (\(Forall @"n" n) (Forall @"m" m) (Forall @"b" b) -> n .>= 0 .&& m .> 0 .=> power b n `sEMod` m .== power (b `sEMod` m) n `sEMod` m) $+      \ih n m b -> [n .>= 0, m .> 0] |- power b (n+1) `sEMod` m+                                     =: (power b n * b) `sEMod` m+                                     ?? mMulL `at` (Inst @"a" (power b n), Inst @"b" b, Inst @"m" m)+                                     =: (power b n `sEMod` m * b) `sEMod` m+                                     ?? ih `at` (Inst @"m" m, Inst @"b" b)+                                     =: (power (b `sEMod` m) n `sEMod` m * b) `sEMod` m+                                     ?? mMulL `at` (Inst @"a" (power (b `sEMod` m) n), Inst @"b" b, Inst @"m" m)+                                     =: (power (b `sEMod` m) n * b) `sEMod` m+                                     ?? mMulR `at` (Inst @"a" (power (b `sEMod` m) n), Inst @"b" b, Inst @"m" m)+                                     =: (power (b `sEMod` m) n * b `sEMod` m) `sEMod` m+                                     =: power (b `sEMod` m) (n+1) `sEMod` m+                                     =: qed++   -- Same as above, just a more natural selection of variable order.+   lemma "powerMod"+         (\(Forall b) (Forall n) (Forall m) -> n .>= 0 .&& m .> 0 .=> power b n `sEMod` m .== power (b `sEMod` m) n `sEMod` m)+         [proofOf pMod]++-- | \(n \geq 0 \Rightarrow 1^n = 1\)+--+-- ==== __Proof__+-- >>> runCached onePower+-- Inductive lemma: onePower+--   Step: Base                            Q.E.D.+--   Step: 1 (unfold power)                Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] onePower :: Ɐn ∷ Integer → Bool+onePower :: TP (Proof (Forall "n" Integer -> SBool))+onePower = induct "onePower"+                  (\(Forall n) -> n .>= 0 .=> power 1 n .== 1) $+                  \ih n -> [] |- power 1 (n+1)+                               ?? "unfold power"+                               =: 1 * power 1 n+                               ?? ih+                               =: (1 :: SInteger)+                               =: qed++-- | \(n \geq 0 \Rightarrow (27^n \bmod 13) = 1\)+--+-- ==== __Proof__+-- >>> runCached powerOf27+-- Inductive lemma: onePower+--   Step: Base                            Q.E.D.+--   Step: 1 (unfold power)                Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Inductive lemma: modMulRightNonneg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Lemma: modSubRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: modMulRightNeg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modMulRight+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.2.3                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modMulLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modMulRightNonneg               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modSubRight                     Q.E.D.+-- Cached: modMulRightNeg                  Q.E.D.+-- Cached: modMulRight                     Q.E.D.+-- Inductive lemma: powerModInduct+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: powerMod                         Q.E.D.+-- Lemma: powerOf27+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven. Cached: modAddLeft, modAddMultiple, modAddRight, modMulRight] powerOf27 :: Ɐn ∷ Integer → Bool+powerOf27 :: TP (Proof (Forall "n" Integer -> SBool))+powerOf27 = do+   pOne <- onePower+   pMod <- powerMod+   calc "powerOf27" (\(Forall n) -> n .>= 0 .=> power 27 n `sEMod` 13 .== 1) $+                    \n -> [n .>= 0]+                       |- power 27 n `sEMod` 13+                       ?? pMod `at` (Inst @"b" 27, Inst @"n" n, Inst @"m" 13)+                       =: power (27 `sEMod` 13) n `sEMod` 13+                       =: power 1 n `sEMod` 13+                       ?? pOne+                       =: 1 `sEMod` 13+                       =: (1 :: SInteger)+                       =: qed++-- | \(n \geq 0 \wedge m > 0 \implies (27^{\frac{n}{3}} \bmod 13) \cdot 3^{n \bmod 3} \equiv 3^{n \bmod 3} \pmod{m}\)+--+-- ==== __Proof__+-- >>> runCached powerOfThreeMod13VarDivisor+-- Inductive lemma: onePower+--   Step: Base                            Q.E.D.+--   Step: 1 (unfold power)                Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: modAddMultiple+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modAddLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Inductive lemma: modMulRightNonneg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Lemma: modSubRight+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: modMulRightNeg+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modMulRight+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.2.3                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: modMulLeft+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modMulRightNonneg               Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modAddRight                     Q.E.D.+-- Cached: modAddLeft                      Q.E.D.+-- Cached: modAddMultiple                  Q.E.D.+-- Cached: modSubRight                     Q.E.D.+-- Cached: modMulRightNeg                  Q.E.D.+-- Cached: modMulRight                     Q.E.D.+-- Inductive lemma: powerModInduct+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Step: 6                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: powerMod                         Q.E.D.+-- Lemma: powerOf27+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: powerOfThreeMod13VarDivisor+--   Step: 1                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven. Cached: modAddLeft, modAddMultiple, modAddRight, modMulRight] powerOfThreeMod13VarDivisor :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool+powerOfThreeMod13VarDivisor :: TP (Proof (Forall "n" Integer -> Forall "m" Integer -> SBool))+powerOfThreeMod13VarDivisor = do+   p27 <- powerOf27+   calc "powerOfThreeMod13VarDivisor"+        (\(Forall n) (Forall m) ->+            n .>= 0 .&& m .> 0 .=>     power 27 (n `sEDiv` 3) `sEMod` 13 * power 3 (n `sEMod` 3) `sEMod` m+                                   .== power  3 (n `sEMod` 3) `sEMod` m) $+        \n m -> [n .>= 0, m .> 0]+             |- power 27 (n `sEDiv` 3) `sEMod` 13 * power 3 (n `sEMod` 3) `sEMod` m+             ?? p27 `at` Inst @"n" (sEDiv n 3)+             =: power 3 (n `sEMod` 3) `sEMod` m+             =: qed
+ Documentation/SBV/Examples/TP/QuickSort.hs view
@@ -0,0 +1,633 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.QuickSort+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving quick sort correct. The proof here closely follows the development+-- given by Tobias Nipkow, in his paper  "Term Rewriting and Beyond -- Theorem+-- Proving in Isabelle," published in Formal Aspects of Computing 1: 320-338+-- back in 1989.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.QuickSort where++import Prelude hiding (null, length, (++), tail, all, fst, snd, elem)+import Control.Monad.Trans (liftIO)++import Data.SBV+import Data.SBV.List hiding (partition)+import Data.SBV.Tuple+import Data.SBV.TP+import qualified Data.SBV.TP.List as TP++import qualified Documentation.SBV.Examples.TP.SortHelpers as SH++#ifdef DOCTEST+-- $setup+-- >>> :set -XTypeApplications+#endif++-- * Quick sort++-- | Quick-sort, using the first element as pivot.+quickSort :: (Ord a, SymVal a) => SList a -> SList a+quickSort = smtFunction "quickSort" $ \l -> ite (null l)+                                                nil+                                                (let (x,  xs) = uncons l+                                                     (lo, hi) = untuple (partition x xs)+                                                 in  quickSort lo ++ [x] ++ quickSort hi)++-- | We define @partition@ as an explicit function. Unfortunately, we can't just replace this+-- with @\pivot xs -> Data.List.SBV.partition (.< pivot) xs@ because that would create a firstified version of partition+-- with a free-variable captured, which isn't supported due to higher-order limitations in SMTLib.+partition :: (Ord a, SymVal a) => SBV a -> SList a -> STuple [a] [a]+partition = smtFunction "partition" $ \pivot xs -> ite (null xs)+                                                       (tuple (nil, nil))+                                                       (let (a,  as) = uncons xs+                                                            (lo, hi) = untuple (partition pivot as)+                                                        in ite (a .< pivot)+                                                               (tuple (a .: lo, hi))+                                                               (tuple (lo, a .: hi)))++-- * Correctness proof++-- | Correctness of quick-sort.+--+-- We have:+--+-- >>> correctness @Integer+-- Inductive lemma: countAppend+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Step: 2 (unfold count)                                    Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4 (simplify)                                        Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: countNonNeg+--   Step: Base                                                Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                                             Q.E.D.+--     Step: 1.1.2                                             Q.E.D.+--     Step: 1.2.1                                             Q.E.D.+--     Step: 1.2.2                                             Q.E.D.+--     Step: 1.Completeness                                    Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: countElem+--   Step: Base                                                Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                                             Q.E.D.+--     Step: 1.1.2                                             Q.E.D.+--     Step: 1.2.1                                             Q.E.D.+--     Step: 1.2.2                                             Q.E.D.+--     Step: 1.Completeness                                    Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: elemCount+--   Step: Base                                                Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2.1                                             Q.E.D.+--     Step: 1.2.2                                             Q.E.D.+--     Step: 1.Completeness                                    Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: sublistCorrect+--   Step: 1                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: sublistElem+--   Step: 1                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: sublistTail                                          Q.E.D.+-- Lemma: sublistIfPerm                                        Q.E.D.+-- Inductive lemma: lltCorrect+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: lgeCorrect+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: lltSublist+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: lltPermutation+--   Step: 1                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: lgeSublist+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: lgePermutation+--   Step: 1                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: partitionFstLT+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Step: 2 (push llt down)                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: partitionSndGE+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Step: 2 (push lge down)                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma (strong): partitionNotLongerFst+--   Step: Measure is non-negative                             Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2.1                                             Q.E.D.+--     Step: 1.2.2 (simplify)                                  Q.E.D.+--     Step: 1.2.3                                             Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma (strong): partitionNotLongerSnd+--   Step: Measure is non-negative                             Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2.1                                             Q.E.D.+--     Step: 1.2.2 (simplify)                                  Q.E.D.+--     Step: 1.2.3                                             Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: countPartition+--   Step: Base                                                Q.E.D.+--   Step: 1 (expand partition)                                Q.E.D.+--   Step: 2 (push countTuple down)                            Q.E.D.+--   Step: 3 (2 way case split)+--     Step: 3.1.1                                             Q.E.D.+--     Step: 3.1.2 (simplify)                                  Q.E.D.+--     Step: 3.1.3                                             Q.E.D.+--     Step: 3.2.1                                             Q.E.D.+--     Step: 3.2.2 (simplify)                                  Q.E.D.+--     Step: 3.2.3                                             Q.E.D.+--     Step: 3.Completeness                                    Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma (strong): sortCountsMatch+--   Step: Measure is non-negative                             Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2.1                                             Q.E.D.+--     Step: 1.2.2 (expand quickSort)                          Q.E.D.+--     Step: 1.2.3 (push count down)                           Q.E.D.+--     Step: 1.2.4                                             Q.E.D.+--     Step: 1.2.5                                             Q.E.D.+--     Step: 1.2.6 (IH on lo)                                  Q.E.D.+--     Step: 1.2.7 (IH on hi)                                  Q.E.D.+--     Step: 1.2.8                                             Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: sortIsPermutation                                    Q.E.D.+-- Inductive lemma: nonDecreasingMerge+--   Step: Base                                                Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2.1                                             Q.E.D.+--     Step: 1.2.2                                             Q.E.D.+--     Step: 1.2.3                                             Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma (strong): sortIsNonDecreasing+--   Step: Measure is non-negative                             Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                                               Q.E.D.+--     Step: 1.2.1                                             Q.E.D.+--     Step: 1.2.2 (expand quickSort)                          Q.E.D.+--     Step: 1.2.3 (push nonDecreasing down)                   Q.E.D.+--     Step: 1.2.4                                             Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: quickSortIsCorrect                                   Q.E.D.+-- Inductive lemma: partitionSortedLeft+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: partitionSortedRight+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Inductive lemma: unchangedIfNondecreasing+--   Step: Base                                                Q.E.D.+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: ifChangedThenUnsorted                                Q.E.D.+-- == Proof tree:+-- quickSortIsCorrect+--  ├╴sortIsPermutation+--  │  └╴sortCountsMatch+--  │     ├╴countAppend (x2)+--  │     ├╴partitionNotLongerFst+--  │     ├╴partitionNotLongerSnd+--  │     └╴countPartition+--  └╴sortIsNonDecreasing+--     ├╴partitionNotLongerFst+--     ├╴partitionNotLongerSnd+--     ├╴partitionFstLT+--     ├╴partitionSndGE+--     ├╴sortIsPermutation (x2)+--     ├╴lltPermutation+--     │  ├╴lltSublist+--     │  │  ├╴sublistElem+--     │  │  │  └╴sublistCorrect+--     │  │  │     ├╴countElem+--     │  │  │     │  └╴countNonNeg+--     │  │  │     └╴elemCount+--     │  │  ├╴lltCorrect+--     │  │  └╴sublistTail+--     │  └╴sublistIfPerm+--     ├╴lgePermutation+--     │  ├╴lgeSublist+--     │  │  ├╴sublistElem+--     │  │  ├╴lgeCorrect+--     │  │  └╴sublistTail+--     │  └╴sublistIfPerm+--     └╴nonDecreasingMerge+-- [Proven] quickSortIsCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. (Ord a, SymVal a) => IO (Proof (Forall "xs" [a] -> SBool))+correctness = runTPWith (tpRibbon 60 z3) $ do++  --------------------------------------------------------------------------------------------+  -- Part I. Import helper lemmas, definitions+  --------------------------------------------------------------------------------------------+  let count         = TP.count         @a+      isPermutation = SH.isPermutation @a+      nonDecreasing = SH.nonDecreasing @a+      sublist       = SH.sublist       @a++  countAppend   <- TP.countAppend   @a+  sublistElem   <- SH.sublistElem   @a+  sublistTail   <- SH.sublistTail   @a+  sublistIfPerm <- SH.sublistIfPerm @a++  ---------------------------------------------------------------------------------------------------+  -- Part II. Formalizing less-than/greater-than-or-equal over lists and relationship to permutations+  ---------------------------------------------------------------------------------------------------+  -- llt: list less-than:     all the elements are <  pivot+  -- lge: list greater-equal: all the elements are >= pivot+  let llt, lge :: SBV a -> SList a -> SBool+      llt = smtFunction "llt" $ \pivot l -> null l .|| let (x, xs) = uncons l in x .<  pivot .&& llt pivot xs+      lge = smtFunction "lge" $ \pivot l -> null l .|| let (x, xs) = uncons l in x .>= pivot .&& lge pivot xs++  -- llt correctness+  lltCorrect <-+     induct "lltCorrect"+            (\(Forall xs) (Forall e) (Forall pivot) -> llt pivot xs .&& e `elem` xs .=> e .< pivot) $+            \ih (x, xs) e pivot -> [llt pivot (x .: xs), e `elem` (x .: xs)]+                                |- e .< pivot+                                ?? ih+                                =: sTrue+                                =: qed++  -- lge correctness+  lgeCorrect <-+     induct "lgeCorrect"+            (\(Forall xs) (Forall e) (Forall pivot) -> lge pivot xs .&& e `elem` xs .=> e .>= pivot) $+            \ih (x, xs) e pivot -> [lge pivot (x .: xs), e `elem` (x .: xs)]+                                |- e .>= pivot+                                ?? ih+                                =: sTrue+                                =: qed++  -- If a value is less than all the elements in a list, then it is also less than all the elements of any sublist of it+  lltSublist <-+     inductWith cvc5 "lltSublist"+            (\(Forall xs) (Forall pivot) (Forall ys) -> llt pivot ys .&& xs `sublist` ys .=> llt pivot xs) $+            \ih (x, xs) pivot ys -> [llt pivot ys, (x .: xs) `sublist` ys]+                                 |- llt pivot (x .: xs)+                                 =: x .< pivot .&& llt pivot xs+                                 -- To establish x .< pivot, observe that x is in ys, and together+                                 -- with llt pivot ys, we get that x is less than pivot+                                 ?? sublistElem `at` (Inst @"x" x,   Inst @"xs" xs, Inst @"ys" ys)+                                 ?? lltCorrect  `at` (Inst @"xs" ys, Inst @"e"  x,  Inst @"pivot" pivot)++                                 -- Use induction hypothesis to get rid of the second conjunct. We need to tell+                                 -- the prover that xs is a sublist of ys too so it can satisfy its precondition+                                 ?? sublistTail `at` (Inst @"x" x, Inst @"xs" xs, Inst @"ys" ys)+                                 ?? ih          `at` (Inst @"pivot" pivot, Inst @"ys" ys)+                                 =: sTrue+                                 =: qed++  -- Variant of the above for the permutation case+  lltPermutation <-+     calc "lltPermutation"+           (\(Forall xs) (Forall pivot) (Forall ys) -> llt pivot ys .&& isPermutation xs ys .=> llt pivot xs) $+           \xs pivot ys -> [llt pivot ys, isPermutation xs ys]+                        |- llt pivot xs+                        ?? lltSublist    `at` (Inst @"xs" xs, Inst @"pivot" pivot, Inst @"ys" ys)+                        ?? sublistIfPerm `at` (Inst @"xs" xs, Inst @"ys" ys)+                        =: sTrue+                        =: qed++  -- If a value is greater than or equal to all the elements in a list, then it is also less than all the elements of any sublist of it+  lgeSublist <-+     inductWith cvc5 "lgeSublist"+            (\(Forall xs) (Forall pivot) (Forall ys) -> lge pivot ys .&& xs `sublist` ys .=> lge pivot xs) $+            \ih (x, xs) pivot ys -> [lge pivot ys, (x .: xs) `sublist` ys]+                                 |- lge pivot (x .: xs)+                                 =: x .>= pivot .&& lge pivot xs+                                 -- To establish x .>= pivot, observe that x is in ys, and together+                                 -- with lge pivot ys, we get that x is greater than equal to the pivot+                                 ?? sublistElem `at` (Inst @"x" x,   Inst @"xs" xs, Inst @"ys" ys)+                                 ?? lgeCorrect  `at` (Inst @"xs" ys, Inst @"e"  x,  Inst @"pivot" pivot)++                                 -- Use induction hypothesis to get rid of the second conjunct. We need to tell+                                 -- the prover that xs is a sublist of ys too so it can satisfy its precondition+                                 ?? sublistTail `at` (Inst @"x" x, Inst @"xs" xs, Inst @"ys" ys)+                                 ?? ih          `at` (Inst @"pivot" pivot, Inst @"ys" ys)+                                 =: sTrue+                                 =: qed++  -- Variant of the above for the permutation case+  lgePermutation <-+     calc "lgePermutation"+           (\(Forall xs) (Forall pivot) (Forall ys) -> lge pivot ys .&& isPermutation xs ys .=> lge pivot xs) $+           \xs pivot ys -> [lge pivot ys, isPermutation xs ys]+                        |- lge pivot xs+                        ?? lgeSublist    `at` (Inst @"xs" xs, Inst @"pivot" pivot, Inst @"ys" ys)+                        ?? sublistIfPerm `at` (Inst @"xs" xs, Inst @"ys" ys)+                        =: sTrue+                        =: qed++  --------------------------------------------------------------------------------------------+  -- Part III. Helper lemmas for partition+  --------------------------------------------------------------------------------------------++  -- The first element of the partition produces all smaller elements+  partitionFstLT <- inductWith cvc5 "partitionFstLT"+     (\(Forall l) (Forall pivot) -> llt pivot (fst (partition pivot l))) $+     \ih (a, as) pivot -> [] |- llt pivot (fst (partition pivot (a .: as)))+                             =: llt pivot (ite (a .< pivot)+                                               (a .: fst (partition pivot as))+                                               (     fst (partition pivot as)))+                             ?? "push llt down"+                             =: ite (a .< pivot)+                                    (a .< pivot .&& llt pivot (fst (partition pivot as)))+                                    (               llt pivot (fst (partition pivot as)))+                             ?? ih+                             =: sTrue+                             =: qed++  -- The second element of the partition produces all greater-than-or-equal to elements+  partitionSndGE <- inductWith cvc5 "partitionSndGE"+     (\(Forall l) (Forall pivot) -> lge pivot (snd (partition pivot l))) $+     \ih (a, as) pivot -> [] |- lge pivot (snd (partition pivot (a .: as)))+                             =: lge pivot (ite (a .< pivot)+                                               (     snd (partition pivot as))+                                               (a .: snd (partition pivot as)))+                             ?? "push lge down"+                             =: ite (a .< pivot)+                                    (a .< pivot .&& lge pivot (snd (partition pivot as)))+                                    (               lge pivot (snd (partition pivot as)))+                             ?? ih+                             =: sTrue+                             =: qed++  -- The first element of partition does not increase in size+  partitionNotLongerFst <- sInduct "partitionNotLongerFst"+     (\(Forall l) (Forall pivot) -> length (fst (partition @a pivot l)) .<= length l)+     (\l _ -> length l) $+     \ih l pivot -> [] |- length (fst (partition @a pivot l)) .<= length l+                       =: split l trivial+                                (\a as -> let lo = fst (partition pivot as)+                                       in ite (a .< pivot)+                                              (length (a .: lo) .<= length (a .: as))+                                              (length       lo  .<= length (a .: as))+                                       ?? "simplify"+                                       =: ite (a .< pivot)+                                              (length lo .<=     length as)+                                              (length lo .<= 1 + length as)+                                       ?? ih `at` (Inst @"l" as, Inst @"pivot" pivot)+                                       =: sTrue+                                       =: qed)++  -- The second element of partition does not increase in size+  partitionNotLongerSnd <- sInduct "partitionNotLongerSnd"+     (\(Forall l) (Forall pivot) -> length (snd (partition @a pivot l)) .<= length l)+     (\l _ -> length l) $+     \ih l pivot -> [] |- length (snd (partition @a pivot l)) .<= length l+                       =: split l trivial+                                (\a as -> let hi = snd (partition pivot as)+                                       in ite (a .< pivot)+                                              (length       hi  .<= length (a .: as))+                                              (length (a .: hi) .<= length (a .: as))+                                       ?? "simplify"+                                       =: ite (a .< pivot)+                                              (length hi .<= 1 + length as)+                                              (length hi .<=     length as)+                                       ?? ih `at` (Inst @"l" as, Inst @"pivot" pivot)+                                       =: sTrue+                                       =: qed)++  --------------------------------------------------------------------------------------------+  -- Part IV. Helper lemmas for count+  --------------------------------------------------------------------------------------------++  -- Count is preserved over partition+  let countTuple :: SBV a -> STuple [a] [a] -> SInteger+      countTuple e xsys = count e xs + count e ys+        where (xs, ys) = untuple xsys++  countPartition <-+     induct "countPartition"+            (\(Forall xs) (Forall pivot) (Forall e) -> countTuple e (partition pivot xs) .== count e xs) $+            \ih (a, as) pivot e ->+                [] |- countTuple e (partition pivot (a .: as))+                   ?? "expand partition"+                   =: countTuple e (let (lo, hi) = untuple (partition pivot as)+                                    in ite (a .< pivot)+                                           (tuple (a .: lo, hi))+                                           (tuple (lo, a .: hi)))+                   ?? "push countTuple down"+                   =: let (lo, hi) = untuple (partition pivot as)+                   in ite (a .< pivot)+                          (count e (a .: lo) + count e hi)+                          (count e lo + count e (a .: hi))+                   =: cases [e .== a  ==> ite (a .< pivot)+                                              (1 + count e lo + count e hi)+                                              (count e lo + 1 + count e hi)+                                       ?? "simplify"+                                       =: 1 + count e lo + count e hi+                                       ?? ih+                                       =: 1 + count e as+                                       =: qed+                            , e ./= a ==> ite (a .< pivot)+                                              (count e lo + count e hi)+                                              (count e lo + count e hi)+                                       ?? "simplify"+                                       =: count e lo + count e hi+                                       ?? ih+                                       =: count e as+                                       =: qed+                            ]+  --------------------------------------------------------------------------------------------+  -- Part V. Prove that the output of quick sort is a permutation of its input+  --------------------------------------------------------------------------------------------++  sortCountsMatch <-+     sInduct "sortCountsMatch"+             (\(Forall xs) (Forall e) -> count e xs .== count e (quickSort xs))+             (\xs _ -> length xs) $+             \ih xs e ->+                [] |- count e (quickSort xs)+                   =: split xs trivial+                            (\a as -> count e (quickSort (a .: as))+                                   ?? "expand quickSort"+                                   =: count e (let (lo, hi) = untuple (partition a as)+                                               in quickSort lo ++ [a] ++ quickSort hi)+                                   ?? "push count down"+                                   =: let (lo, hi) = untuple (partition a as)+                                   in count e (quickSort lo ++ [a] ++ quickSort hi)+                                   ?? countAppend `at` (Inst @"xs" (quickSort lo), Inst @"ys" ([a] ++ quickSort hi), Inst @"e" e)+                                   =: count e (quickSort lo) + count e ([a] ++ quickSort hi)+                                   ?? countAppend `at` (Inst @"xs" [a], Inst @"ys" (quickSort hi), Inst @"e" e)+                                   =: count e (quickSort lo) + count e [a] + count e (quickSort hi)+                                   ?? ih                    `at` (Inst @"xs" lo, Inst @"e" e)+                                   ?? partitionNotLongerFst `at` (Inst @"l"  as, Inst @"pivot" a)+                                   ?? "IH on lo"+                                   =: count e lo + count e [a] + count e (quickSort hi)+                                   ?? ih                    `at` (Inst @"xs" hi, Inst @"e" e)+                                   ?? partitionNotLongerSnd `at` (Inst @"l"  as, Inst @"pivot" a)+                                   ?? "IH on hi"+                                   =: count e lo + count e [a] + count e hi+                                   ?? countPartition `at` (Inst @"xs" as, Inst @"pivot" a, Inst @"e" e)+                                   =: count e xs+                                   =: qed)++  sortIsPermutation <- lemma "sortIsPermutation" (\(Forall xs) -> isPermutation xs (quickSort xs)) [proofOf sortCountsMatch]++  --------------------------------------------------------------------------------------------+  -- Part VI. Helper lemmas for nonDecreasing+  --------------------------------------------------------------------------------------------+  nonDecreasingMerge <-+      inductWith cvc5 "nonDecreasingMerge"+          (\(Forall xs) (Forall pivot) (Forall ys) ->+                     nonDecreasing xs .&& llt pivot xs+                 .&& nonDecreasing ys .&& lge pivot ys .=> nonDecreasing (xs ++ [pivot] ++ ys)) $+          \ih (x, xs) pivot ys ->+                [nonDecreasing (x .: xs), llt pivot xs, nonDecreasing ys, lge pivot ys]+             |- nonDecreasing (x .: xs ++ [pivot] ++ ys)+             =: split xs trivial+                      (\a as -> nonDecreasing (x .: a .: as ++ [pivot] ++ ys)+                             =: x .<= a .&& nonDecreasing (a .: as ++ [pivot] ++ ys)+                             ?? ih+                             =: sTrue+                             =: qed)++  --------------------------------------------------------------------------------------------+  -- Part VII. Prove that the output of quick sort is non-decreasing+  --------------------------------------------------------------------------------------------+  sortIsNonDecreasing <-+     sInductWith cvc5 "sortIsNonDecreasing"+             (\(Forall xs) -> nonDecreasing (quickSort xs))+             (length @a) $+             \ih xs ->+                [] |- nonDecreasing (quickSort xs)+                   =: split xs trivial+                            (\a as -> nonDecreasing (quickSort (a .: as))+                                   ?? "expand quickSort"+                                   =: nonDecreasing (let (lo, hi) = untuple (partition a as)+                                                     in quickSort lo ++ [a] ++ quickSort hi)+                                   ?? "push nonDecreasing down"+                                   =: let (lo, hi) = untuple (partition a as)+                                   in nonDecreasing (quickSort lo ++ [a] ++ quickSort hi)+                                   -- Deduce that lo/hi is not longer than as, and hence, shorter than xs+                                   ?? partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a)+                                   ?? partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a)++                                   -- Use the inductive hypothesis twice to deduce quickSort of lo and hi are nonDecreasing+                                   ?? ih `at` Inst @"xs" lo  -- nonDecreasing (quickSort lo)+                                   ?? ih `at` Inst @"xs" hi  -- nonDecreasing (quickSort hi)++                                   -- Deduce that lo is all less than a, and hi is all greater than or equal to a+                                   ?? partitionFstLT `at` (Inst @"l" as, Inst @"pivot" a)+                                   ?? partitionSndGE `at` (Inst @"l" as, Inst @"pivot" a)++                                   -- Deduce that quickSort lo is all less than a+                                   ?? sortIsPermutation `at`  Inst @"xs" lo+                                   ?? lltPermutation    `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" lo)++                                   -- Deduce that quickSort hi is all greater than or equal to a+                                   ?? sortIsPermutation `at`  Inst @"xs" hi+                                   ?? lgePermutation    `at` (Inst @"xs" (quickSort hi), Inst @"pivot" a, Inst @"ys" hi)++                                   -- Finally conclude that the whole reconstruction is non-decreasing+                                   ?? nonDecreasingMerge `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" (quickSort hi))+                                   =: sTrue+                                   =: qed)++  --------------------------------------------------------------------------------------------+  -- Part VIII. Putting it together+  --------------------------------------------------------------------------------------------++  qs <- lemma "quickSortIsCorrect"+              (\(Forall xs) -> let out = quickSort xs in isPermutation xs out .&& nonDecreasing out)+              [proofOf sortIsPermutation, proofOf sortIsNonDecreasing]++  --------------------------------------------------------------------------------------------+  -- Part IX. Bonus: This property isn't really needed for correctness, but let's also prove+  -- that if a list is sorted, then quick-sort returns it unchanged.+  --------------------------------------------------------------------------------------------+  partitionSortedLeft <-+     inductWith cvc5 "partitionSortedLeft"+            (\(Forall @"as" as) (Forall @"pivot" pivot) -> nonDecreasing (pivot .: as) .=> null (fst (partition pivot as))) $+            \ih (a, as) pivot -> [nonDecreasing (pivot .: a .: as)]+                              |- fst (partition pivot (a .: as))+                              =: let (lo, _) = untuple (partition pivot as)+                              in lo+                              ?? ih+                              =: nil+                              =: qed++  partitionSortedRight <-+     inductWith cvc5 "partitionSortedRight"+           (\(Forall @"xs" xs) (Forall @"pivot" pivot) -> nonDecreasing (pivot .: xs) .=> xs .== snd (partition pivot xs)) $+           \ih (a, as) pivot -> [nonDecreasing (pivot .: a .: as)]+                             |- snd (partition pivot (a .: as))+                             =: let (_, hi) = untuple (partition pivot as)+                             in a .: hi+                             ?? ih+                             =: a .: as+                             =: qed++  unchangedIfNondecreasing <-+       induct "unchangedIfNondecreasing"+              (\(Forall @"xs" xs) -> nonDecreasing xs .=> quickSort xs .== xs) $+              \ih (x, xs) -> [nonDecreasing (x .: xs)]+                          |- quickSort (x .: xs)+                          =: let (lo, hi) = untuple (partition x xs)+                          in quickSort lo ++ [x] ++ quickSort hi+                          ?? partitionSortedLeft+                          =: [x] ++ quickSort hi+                          ?? partitionSortedRight+                          =: [x] ++ quickSort xs+                          ?? ih+                          =: x .: xs+                          =: qed++  -- A nice corrollary to the above is that if quicksort changes its input, that implies the input was not non-decreasing:+  _ <- lemma "ifChangedThenUnsorted"+             (\(Forall @"xs" xs) -> quickSort xs ./= xs .=> sNot (nonDecreasing xs))+             [proofOf unchangedIfNondecreasing]++  --------------------------------------------------------------------------------------------+  -- | We can display the dependencies in a proof+  --------------------------------------------------------------------------------------------+  liftIO $ do putStrLn "== Proof tree:"+              putStr $ showProofTree True qs++  pure qs++{- HLint ignore correctness "Use :" -}
+ Documentation/SBV/Examples/TP/RevAcc.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.RevAcc+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proves that the accummulating version of reverse is equivalent to the+-- standard definition.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions    #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.RevAcc where++import Prelude hiding (head, tail, null, reverse, (++))++import Data.SBV+import Data.SBV.List+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> :set -XTypeApplications+#endif++-- * Reversing with an accummulator.++-- | Accummulating reverse.+revAcc :: SymVal a => SList a -> SList a -> SList a+revAcc = smtFunction "revAcc" $ \acc xs -> ite (null xs) acc (revAcc (head xs .: acc) (tail xs))++-- | Given 'revAcc', we can reverse a list by providing the empty list as the initial accumulator.+rev :: SymVal a => SList a -> SList a+rev = revAcc []++-- * Correctness proof++-- | Correctness the function 'rev'. We have:+--+-- >>> correctness @Integer+-- Inductive lemma: revAccCorrect+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: revCorrect                       Q.E.D.+-- [Proven] revCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. SymVal a => IO (Proof (Forall "xs" [a] -> SBool))+correctness = runTP $ do++  -- Helper lemma regarding 'revAcc'+  helper <- induct "revAccCorrect"+                   (\(Forall @"xs" (xs :: SList a)) (Forall @"acc" acc) -> revAcc acc xs .== reverse xs ++ acc) $+                   \ih (x, xs) acc -> [] |- revAcc acc (x .: xs)+                                         =: revAcc (x .: acc) xs+                                         ?? ih+                                         =: reverse xs ++ x .: acc+                                         =: (reverse xs ++ [x]) ++ acc+                                         =: reverse (x .: xs) ++ acc+                                         =: qed++  -- The main theorem simply follows from the helper:+  lemma "revCorrect"+        (\(Forall xs) -> rev xs .== reverse xs)+        [proofOf helper]
+ Documentation/SBV/Examples/TP/Reverse.hs view
@@ -0,0 +1,164 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.Reverse+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Can we define the reverse function using no auxiliary functions, i.e., only+-- in terms of cons, head, tail, and itself (recursively)? This example+-- shows such a definition and proves that it is correct.+--+-- See Zohar Manna's 1974 "Mathematical Theory of Computation" book, where this+-- definition and its proof is presented as Example 5.36.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Reverse where++import Prelude hiding (head, tail, null, reverse, length, init, last, (++))++import Data.SBV+import Data.SBV.List hiding (partition)+import Data.SBV.TP++import qualified Data.SBV.TP.List as TP++#ifdef DOCTEST+-- $setup+-- >>> :set -XTypeApplications+#endif++-- * Reversing with no auxiliaries++-- | This definition of reverse uses no helper functions, other than the usual+-- head, tail, cons, and uncons to reverse a given list. Note that efficiency+-- is not our concern here, we call 'rev' itself three times in the body.+rev :: SymVal a => SList a -> SList a+rev = smtFunction "rev" $ \xs -> ite (null xs .|| null (tail xs)) xs+                                     (let (x, as)     = uncons xs+                                          (hras, tas) = uncons (rev as)+                                      in hras .: rev (x .: rev tas))++-- * Correctness proof++-- | Correctness the function 'rev'. We have:+--+-- >>> correctness @Integer+-- Inductive lemma: revLen+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: revApp+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: revApp+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: revSnoc                          Q.E.D.+-- Inductive lemma: revApp+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Step: 5                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: revRev+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma (strong): revCorrect+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2 (2 way full case split)+--       Step: 1.2.1                       Q.E.D.+--       Step: 1.2.2.1                     Q.E.D.+--       Step: 1.2.2.2                     Q.E.D.+--       Step: 1.2.2.3                     Q.E.D.+--       Step: 1.2.2.4                     Q.E.D.+--       Step: 1.2.2.5 (simplify head)     Q.E.D.+--       Step: 1.2.2.6                     Q.E.D.+--       Step: 1.2.2.7 (simplify tail)     Q.E.D.+--       Step: 1.2.2.8                     Q.E.D.+--       Step: 1.2.2.9                     Q.E.D.+--       Step: 1.2.2.10                    Q.E.D.+--       Step: 1.2.2.11 (substitute)       Q.E.D.+--       Step: 1.2.2.12                    Q.E.D.+--       Step: 1.2.2.13                    Q.E.D.+--       Step: 1.2.2.14                    Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] revCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. SymVal a => IO (Proof (Forall "xs" [a] -> SBool))+correctness = runTP $ do++  -- Import a few helpers from "Data.SBV.TP.List"+  revLen  <- TP.revLen  @a+  revApp  <- TP.revApp  @a+  revSnoc <- TP.revSnoc @a+  revRev  <- TP.revRev  @a++  sInductWith cvc5 "revCorrect"+    (\(Forall xs) -> rev xs .== reverse xs)+    length $+    \ih xs -> [] |- rev xs+                 =: split xs trivial+                          (\a as -> split as trivial+                                          (\_ _ -> head (rev as) .: rev (a .: rev (tail (rev as)))+                                                ?? ih `at` Inst @"xs" as+                                                =: head (reverse as) .: rev (a .: rev (tail (reverse as)))+                                                ?? ih `at` Inst @"xs" (tail (rev as))+                                                =: head (reverse as) .: rev (a .: rev (tail (reverse as)))+                                                ?? revSnoc `at` (Inst @"x" (last as), Inst @"xs" (init as))+                                                =: let w = init as+                                                       b = last as+                                                in head (b .: reverse w) .: rev (a .: rev (tail (reverse as)))+                                                ?? "simplify head"+                                                =: b .: rev (a .: rev (tail (reverse as)))+                                                ?? revSnoc `at` (Inst @"x" (last xs), Inst @"xs" (init as))+                                                =: b .: rev (a .: rev (tail (b .: reverse w)))+                                                ?? "simplify tail"+                                                =: b .: rev (a .: rev (reverse w))+                                                ?? ih     `at` Inst @"xs" (reverse w)+                                                ?? revLen `at` Inst @"xs" w+                                                =: b .: rev (a .: reverse (reverse w))+                                                ?? revRev `at` Inst @"xs" w+                                                =: b .: rev (a .: w)+                                                ?? ih+                                                =: b .: reverse (a .: w)+                                                ?? "substitute"+                                                =: last as .: reverse (a .: init as)+                                                ?? revApp `at` (Inst @"xs" (init as), Inst @"ys" [last as])+                                                =: reverse (a .: init as ++ [last as])+                                                =: reverse (a .: as)+                                                =: reverse xs+                                                =: qed))++{- HLint ignore correctness "Use last"          -}+{- HLint ignore correctness "Redundant reverse" -}
+ Documentation/SBV/Examples/TP/ShefferStroke.hs view
@@ -0,0 +1,692 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.ShefferStroke+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Inspired by https://www.philipzucker.com/cody_sheffer/, proving+-- that the axioms of sheffer stroke (i.e., nand in traditional boolean+-- logic), imply it is a boolean algebra.+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeAbstractions     #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.ShefferStroke where++import Prelude hiding ((<))+import Data.List (intercalate)++import Data.SBV+import Data.SBV.TP++-- * Generalized Boolean Algebras++-- | Capture what it means to be a boolean algebra. We follow Lean's+-- definition, as much as we can: <https://leanprover-community.github.io/mathlib_docs/order/boolean_algebra.html>.+-- Since there's no way in Haskell to capture properties together with a class, we'll represent the properties+-- separately.+class BooleanAlgebra α where+  ﬧ    :: α -> α+  (⨆)  :: α -> α -> α+  (⨅)  :: α -> α -> α+  (≤)  :: α -> α -> SBool+  (<)  :: α -> α -> SBool+  (\\) :: α -> α -> α+  (⇨)  :: α -> α -> α+  ⲳ    :: α+  т    :: α++  infix  4 ≤+  infixl 6 ⨆+  infixl 7 ⨅++-- | Proofs needed for a boolean-algebra. Again, we follow Lean's definition here. Since we cannot+-- put these in the class definition above, we will keep them in a simple data-structure.+data BooleanAlgebraProof = BooleanAlgebraProof {+    le_refl          {- ∀ (a : α), a ≤ a                             -} :: Proof (Forall "a" Stroke -> SBool)+  , le_trans         {- ∀ (a b c : α), a ≤ b → b ≤ c → a ≤ c         -} :: Proof (Forall "a" Stroke -> Forall "b" Stroke -> Forall "c" Stroke -> SBool)+  , lt_iff_le_not_le {- (∀ (a b : α), a < b ↔ a ≤ b ∧ ¬b ≤ a)        -} :: Proof (Forall "a" Stroke -> Forall "b" Stroke -> SBool)+  , le_antisymm      {- ∀ (a b : α), a ≤ b → b ≤ a → a = b           -} :: Proof (Forall "a" Stroke -> Forall "b" Stroke -> SBool)+  , le_sup_left      {- ∀ (a b : α), a ≤ a ⊔ b                       -} :: Proof (Forall "a" Stroke -> Forall "b" Stroke -> SBool)+  , le_sup_right     {- ∀ (a b : α), b ≤ a ⊔ b                       -} :: Proof (Forall "a" Stroke -> Forall "b" Stroke -> SBool)+  , sup_le           {- ∀ (a b c : α), a ≤ c → b ≤ c → a ⊔ b ≤ c     -} :: Proof (Forall "a" Stroke -> Forall "b" Stroke -> Forall "c" Stroke -> SBool)+  , inf_le_left      {- ∀ (a b : α), a ⊓ b ≤ a                       -} :: Proof (Forall "a" Stroke -> Forall "b" Stroke -> SBool)+  , inf_le_right     {- ∀ (a b : α), a ⊓ b ≤ b                       -} :: Proof (Forall "a" Stroke -> Forall "b" Stroke -> SBool)+  , le_inf           {- ∀ (a b c : α), a ≤ b → a ≤ c → a ≤ b ⊓ c     -} :: Proof (Forall "a" Stroke -> Forall "b" Stroke -> Forall "c" Stroke -> SBool)+  , le_sup_inf       {- ∀ (x y z : α), (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z -} :: Proof (Forall "x" Stroke -> Forall "y" Stroke -> Forall "z" Stroke -> SBool)+  , inf_compl_le_bot {- ∀ (x : α), x ⊓ xᶜ ≤ ⊥                        -} :: Proof (Forall "x" Stroke -> SBool)+  , top_le_sup_compl {- ∀ (x : α), ⊤ ≤ x ⊔ xᶜ                        -} :: Proof (Forall "x" Stroke -> SBool)+  , le_top           {- ∀ (a : α), a ≤ ⊤                             -} :: Proof (Forall "a" Stroke -> SBool)+  , bot_le           {- ∀ (a : α), ⊥ ≤ a                             -} :: Proof (Forall "a" Stroke -> SBool)+  , sdiff_eq         {- (∀ (x y : α), x \ y = x ⊓ yᶜ)                -} :: Proof (Forall "x" Stroke -> Forall "y" Stroke -> SBool)+  , himp_eq          {- (∀ (x y : α), x ⇨ y = y ⊔ xᶜ)                -} :: Proof (Forall "x" Stroke -> Forall "y" Stroke -> SBool)+  }++-- | A somewhat prettier printer for a BooleanAlgebra proof+instance Show BooleanAlgebraProof where+  show p = intercalate "\n" [ "BooleanAlgebraProof {"+                            , "  le_refl         : " ++ show (le_refl          p)+                            , "  le_trans        : " ++ show (le_trans         p)+                            , "  lt_iff_le_not_le: " ++ show (lt_iff_le_not_le p)+                            , "  le_antisymm     : " ++ show (le_antisymm      p)+                            , "  le_sup_left     : " ++ show (le_sup_left      p)+                            , "  le_sup_right    : " ++ show (le_sup_right     p)+                            , "  sup_le          : " ++ show (sup_le           p)+                            , "  inf_le_left     : " ++ show (inf_le_left      p)+                            , "  inf_le_right    : " ++ show (inf_le_right     p)+                            , "  le_inf          : " ++ show (le_inf           p)+                            , "  le_sup_inf      : " ++ show (le_sup_inf       p)+                            , "  inf_compl_le_bot: " ++ show (inf_compl_le_bot p)+                            , "  top_le_sup_compl: " ++ show (top_le_sup_compl p)+                            , "  le_top          : " ++ show (le_top           p)+                            , "  bot_le          : " ++ show (bot_le           p)+                            , "  sdiff_eq        : " ++ show (sdiff_eq         p)+                            , "  himp_eq         : " ++ show (himp_eq          p)+                            , "}"+                            ]++-- * The sheffer stroke++-- | The abstract type for the domain.+data Stroke+mkUninterpretedSort ''Stroke++-- | The sheffer stroke operator.+(⏐) :: SStroke -> SStroke -> SStroke+(⏐) = uninterpret "⏐"+infixl 7 ⏐++-- | The boolean algebra of the sheffer stroke.+instance BooleanAlgebra SStroke where+  ﬧ x    = x ⏐ x+  a ⨆ b  = ﬧ(a ⏐ b)+  a ⨅ b  = ﬧ a ⏐ ﬧ b+  a ≤ b  = a .== b ⨅ a+  a < b  = a ≤ b .&& a ./= b+  a \\ b = a ⨅ ﬧ b+  a ⇨ b  = b ⨆ ﬧ a+  ⲳ      = arb ⏐ ﬧ arb where arb = some "ⲳ" (const sTrue)+  т      = ﬧ ⲳ++-- | Double-negation+ﬧﬧ :: BooleanAlgebra a => a -> a+ﬧﬧ = ﬧ . ﬧ++-- | First Sheffer axiom: @ﬧﬧa == a@+sheffer1 :: TP (Proof (Forall "a" Stroke -> SBool))+sheffer1 = axiom "ﬧﬧa == a" $ \(Forall a) -> ﬧﬧ a .== a++-- | Second Sheffer axiom: @a ⏐ (b ⏐ ﬧb) == ﬧa@+sheffer2 :: TP (Proof (Forall "a" Stroke -> Forall "b" Stroke -> SBool))+sheffer2 = axiom "a ⏐ (b ⏐ ﬧb) == ﬧa" $ \(Forall a) (Forall b) -> a ⏐ (b ⏐ ﬧ b) .== ﬧ a++-- | Third Sheffer axiom: @ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)@+sheffer3 :: TP (Proof (Forall "a" Stroke -> Forall "b" Stroke -> Forall "c" Stroke -> SBool))+sheffer3 = axiom "ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)" $ \(Forall a) (Forall b) (Forall c) -> ﬧ(a ⏐ (b ⏐ c)) .== (ﬧ b ⏐ a) ⏐ (ﬧ c ⏐ a)++-- * Sheffer's stroke defines a boolean algebra++-- | Prove that Sheffer stroke axioms imply it is a boolean algebra. We have:+--+-- >>> shefferBooleanAlgebra+-- Axiom: ﬧﬧa == a+-- Axiom: a ⏐ (b ⏐ ﬧb) == ﬧa+-- Axiom: ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)+-- Lemma: a | b = b | a+--   Step: 1 (ﬧﬧa == a)                                        Q.E.D.+--   Step: 2 (ﬧﬧa == a)                                        Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4 (ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a))           Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6 (ﬧﬧa == a)                                        Q.E.D.+--   Step: 7 (ﬧﬧa == a)                                        Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a | a′ = b | b′+--   Step: 1 (ﬧﬧa == a)                                        Q.E.D.+--   Step: 2 (a ⏐ (b ⏐ ﬧb) == ﬧa)                              Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4 (a ⏐ (b ⏐ ﬧb) == ﬧa)                              Q.E.D.+--   Step: 5 (ﬧﬧa == a)                                        Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ⊔ b = b ⊔ a                                        Q.E.D.+-- Lemma: a ⊓ b = b ⊓ a                                        Q.E.D.+-- Lemma: a ⊔ ⲳ = a                                            Q.E.D.+-- Lemma: a ⊓ т = a                                            Q.E.D.+-- Lemma: a ⊔ (b ⊓ c) = (a ⊔ b) ⊓ (a ⊔ c)                      Q.E.D.+-- Lemma: a ⊓ (b ⊔ c) = (a ⊓ b) ⊔ (a ⊓ c)                      Q.E.D.+-- Lemma: a ⊔ aᶜ = т                                           Q.E.D.+-- Lemma: a ⊓ aᶜ = ⲳ                                           Q.E.D.+-- Lemma: a ⊔ т = т+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ⊓ ⲳ = ⲳ+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ⊔ (a ⊓ b) = a+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ⊓ (a ⊔ b) = a+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ⊓ a = a+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ⊔ a' = т → a ⊓ a' = ⲳ → a' = aᶜ+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6                                                   Q.E.D.+--   Step: 7                                                   Q.E.D.+--   Step: 8                                                   Q.E.D.+--   Step: 9                                                   Q.E.D.+--   Step: 10                                                  Q.E.D.+--   Step: 11                                                  Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: aᶜᶜ = a                                              Q.E.D.+-- Lemma: aᶜ = bᶜ → a = b                                      Q.E.D.+-- Lemma: a ⊔ bᶜ = т → a ⊓ bᶜ = ⲳ → a = b                      Q.E.D.+-- Lemma: a ⊔ (aᶜ ⊔ b) = т+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ⊓ (aᶜ ⊓ b) = ⲳ+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: (a ⊔ b)ᶜ = aᶜ ⊓ bᶜ                                   Q.E.D.+-- Lemma: (a ⨅ b)ᶜ = aᶜ ⨆ bᶜ                                   Q.E.D.+-- Lemma: (a ⊔ (b ⊔ c)) ⊔ aᶜ = т                               Q.E.D.+-- Lemma: b ⊓ (a ⊔ (b ⊔ c)) = b                                Q.E.D.+-- Lemma: b ⊔ (a ⊓ (b ⊓ c)) = b                                Q.E.D.+-- Lemma: (a ⊔ (b ⊔ c)) ⊔ bᶜ = т+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6                                                   Q.E.D.+--   Step: 7                                                   Q.E.D.+--   Step: 8                                                   Q.E.D.+--   Step: 9                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: (a ⊔ (b ⊔ c)) ⊔ cᶜ = т                               Q.E.D.+-- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ a = ⲳ+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6                                                   Q.E.D.+--   Step: 7                                                   Q.E.D.+--   Step: 8                                                   Q.E.D.+--   Step: 9                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ b = ⲳ                                 Q.E.D.+-- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ c = ⲳ                                 Q.E.D.+-- Lemma: (a ⊔ (b ⊔ c)) ⊔ ((a ⊔ b) ⊔ c)ᶜ = т+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6                                                   Q.E.D.+--   Step: 7                                                   Q.E.D.+--   Step: 8                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: (a ⊔ (b ⊔ c)) ⊓ ((a ⊔ b) ⊔ c)ᶜ = ⲳ+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Step: 5                                                   Q.E.D.+--   Step: 6                                                   Q.E.D.+--   Step: 7                                                   Q.E.D.+--   Step: 8                                                   Q.E.D.+--   Step: 9                                                   Q.E.D.+--   Step: 10                                                  Q.E.D.+--   Step: 11                                                  Q.E.D.+--   Step: 12                                                  Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ⊔ (b ⊔ c) = (a ⊔ b) ⊔ c                            Q.E.D.+-- Lemma: a ⊓ (b ⊓ c) = (a ⊓ b) ⊓ c+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ≤ b → b ≤ a → a = b+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ≤ a                                                Q.E.D.+-- Lemma: a ≤ b → b ≤ c → a ≤ c+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Step: 4                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a < b ↔ a ≤ b ∧ ¬b ≤ a                               Q.E.D.+-- Lemma: a ≤ a ⊔ b                                            Q.E.D.+-- Lemma: b ≤ a ⊔ b                                            Q.E.D.+-- Lemma: a ≤ c → b ≤ c → a ⊔ b ≤ c+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: a ⊓ b ≤ a                                            Q.E.D.+-- Lemma: a ⊓ b ≤ b                                            Q.E.D.+-- Lemma: a ≤ b → a ≤ c → a ≤ b ⊓ c+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z                        Q.E.D.+-- Lemma: x ⊓ xᶜ ≤ ⊥                                           Q.E.D.+-- Lemma: ⊤ ≤ x ⊔ xᶜ                                           Q.E.D.+-- Lemma: a ≤ ⊤+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Step: 3                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: ⊥ ≤ a+--   Step: 1                                                   Q.E.D.+--   Step: 2                                                   Q.E.D.+--   Result:                                                   Q.E.D.+-- Lemma: x \ y = x ⊓ yᶜ                                       Q.E.D.+-- Lemma: x ⇨ y = y ⊔ xᶜ                                       Q.E.D.+-- BooleanAlgebraProof {+--   le_refl         : [Proven] a ≤ a :: Ɐa ∷ Stroke → Bool+--   le_trans        : [Proven] a ≤ b → b ≤ c → a ≤ c :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Ɐc ∷ Stroke → Bool+--   lt_iff_le_not_le: [Proven] a < b ↔ a ≤ b ∧ ¬b ≤ a :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Bool+--   le_antisymm     : [Proven] a ≤ b → b ≤ a → a = b :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Bool+--   le_sup_left     : [Proven] a ≤ a ⊔ b :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Bool+--   le_sup_right    : [Proven] b ≤ a ⊔ b :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Bool+--   sup_le          : [Proven] a ≤ c → b ≤ c → a ⊔ b ≤ c :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Ɐc ∷ Stroke → Bool+--   inf_le_left     : [Proven] a ⊓ b ≤ a :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Bool+--   inf_le_right    : [Proven] a ⊓ b ≤ b :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Bool+--   le_inf          : [Proven] a ≤ b → a ≤ c → a ≤ b ⊓ c :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Ɐc ∷ Stroke → Bool+--   le_sup_inf      : [Proven] (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z :: Ɐx ∷ Stroke → Ɐy ∷ Stroke → Ɐz ∷ Stroke → Bool+--   inf_compl_le_bot: [Proven] x ⊓ xᶜ ≤ ⊥ :: Ɐx ∷ Stroke → Bool+--   top_le_sup_compl: [Proven] ⊤ ≤ x ⊔ xᶜ :: Ɐx ∷ Stroke → Bool+--   le_top          : [Proven] a ≤ ⊤ :: Ɐa ∷ Stroke → Bool+--   bot_le          : [Proven] ⊥ ≤ a :: Ɐa ∷ Stroke → Bool+--   sdiff_eq        : [Proven] x \ y = x ⊓ yᶜ :: Ɐx ∷ Stroke → Ɐy ∷ Stroke → Bool+--   himp_eq         : [Proven] x ⇨ y = y ⊔ xᶜ :: Ɐx ∷ Stroke → Ɐy ∷ Stroke → Bool+-- }+shefferBooleanAlgebra :: IO BooleanAlgebraProof+shefferBooleanAlgebra = runTPWith (tpRibbon 60 z3) $ do++  -- shorthand+  let p = proofOf++  -- Get the axioms+  sh1 <- sheffer1+  sh2 <- sheffer2+  sh3 <- sheffer3++  commut <- calc "a | b = b | a" (\(Forall @"a" a) (Forall @"b" b) -> a ⏐ b .== b ⏐ a) $+                 \a b -> [] ⊢ a ⏐ b                       ∵ sh1+                            ≡ ﬧﬧ(a ⏐ b)                   ∵ sh1+                            ≡ ﬧﬧ(a ⏐ ﬧﬧ b)+                            ≡ ﬧﬧ(a ⏐ (ﬧ b ⏐ ﬧ b))         ∵ sh3+                            ≡ ﬧ ((ﬧﬧ b ⏐ a) ⏐ (ﬧﬧ b ⏐ a))+                            ≡ ﬧﬧ(ﬧﬧ b ⏐ a)                ∵ sh1+                            ≡ ﬧﬧ b ⏐ a                    ∵ sh1+                            ≡ b ⏐ a+                            ≡ qed++  all_bot <- calc "a | a′ = b | b′" (\(Forall @"a" a) (Forall @"b" b) -> a ⏐ ﬧ a .== b ⏐ ﬧ b) $+                  \a b -> [] ⊢ a ⏐ ﬧ a                  ∵ sh1+                             ≡ ﬧﬧ(a ⏐ ﬧ a)              ∵ sh2+                             ≡ ﬧ((a ⏐ ﬧ a) ⏐ (b ⏐ ﬧ b)) ∵ commut+                             ≡ ﬧ((b ⏐ ﬧ b) ⏐ (a ⏐ ﬧ a)) ∵ sh2+                             ≡ ﬧﬧ (b ⏐ ﬧ b)             ∵ sh1+                             ≡ b ⏐ ﬧ b+                             ≡ qed++  commut1  <- lemma "a ⊔ b = b ⊔ a" (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> a ⨆ b .== b ⨆ a) [p commut]+  commut2  <- lemma "a ⊓ b = b ⊓ a" (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> a ⨅ b .== b ⨅ a) [p commut]++  ident1   <- lemma "a ⊔ ⲳ = a" (\(Forall @"a" (a :: SStroke)) -> a ⨆ ⲳ .== a) [p sh1, p sh2]+  ident2   <- lemma "a ⊓ т = a" (\(Forall @"a" (a :: SStroke)) -> a ⨅ т .== a) [p sh1, p sh2]++  distrib1 <- lemma "a ⊔ (b ⊓ c) = (a ⊔ b) ⊓ (a ⊔ c)"+                    (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> a ⨆ (b ⨅ c) .== (a ⨆ b) ⨅ (a ⨆ c))+                    [p sh1, p sh3, p commut]++  distrib2 <- lemma "a ⊓ (b ⊔ c) = (a ⊓ b) ⊔ (a ⊓ c)"+                    (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> a ⨅ (b ⨆ c) .== (a ⨅ b) ⨆ (a ⨅ c))+                    [p sh1, p sh3, p commut]++  compl1 <- lemma "a ⊔ aᶜ = т" (\(Forall @"a" (a :: SStroke)) -> a ⨆ ﬧ a .== т) [p sh1, p sh2, p sh3, p all_bot]+  compl2 <- lemma "a ⊓ aᶜ = ⲳ" (\(Forall @"a" (a :: SStroke)) -> a ⨅ ﬧ a .== ⲳ) [p sh1, p commut, p all_bot]++  bound1 <- calc "a ⊔ т = т" (\(Forall @"a"  a) -> a ⨆ т .== т) $+                 \a -> [] ⊢ a ⨆ т               ∵ ident2+                           ≡ (a ⨆ т) ⨅ т         ∵ commut2+                           ≡ т ⨅ (a ⨆ т)         ∵ compl1+                           ≡ (a ⨆ ﬧ a) ⨅ (a ⨆ т) ∵ distrib1+                           ≡ a ⨆ (ﬧ a ⨅ т)       ∵ ident2+                           ≡ a ⨆ ﬧ a             ∵ compl1+                           ≡ (т :: SStroke)+                           ≡ qed++  bound2 <- calc "a ⊓ ⲳ = ⲳ" (\(Forall @"a" a) -> a ⨅ ⲳ .== ⲳ) $+                 \a -> [] ⊢ a ⨅ ⲳ               ∵ ident1+                           ≡ (a ⨅ ⲳ) ⨆ ⲳ         ∵ commut1+                           ≡ ⲳ ⨆ (a ⨅ ⲳ)         ∵ compl2+                           ≡ (a ⨅ ﬧ a) ⨆ (a ⨅ ⲳ) ∵ distrib2+                           ≡ a ⨅ (ﬧ a ⨆ ⲳ)       ∵ ident1+                           ≡ a ⨅ ﬧ a             ∵ compl2+                           ≡ (ⲳ :: SStroke)+                           ≡ qed++  absorb1 <- calc "a ⊔ (a ⊓ b) = a" (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> a ⨆ (a ⨅ b) .== a) $+                  \a b -> [] ⊢ a ⨆ (a ⨅ b)       ∵ ident2+                             ≡ (a ⨅ т) ⨆ (a ⨅ b) ∵ distrib2+                             ≡ a ⨅ (т ⨆ b)       ∵ commut1+                             ≡ a ⨅ (b ⨆ т)       ∵ bound1+                             ≡ a ⨅ т             ∵ ident2+                             ≡ a+                             ≡ qed++  absorb2 <- calc "a ⊓ (a ⊔ b) = a" (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> a ⨅ (a ⨆ b) .== a) $+                  \a b -> [] ⊢ a ⨅ (a ⨆ b)       ∵ ident1+                             ≡ (a ⨆ ⲳ) ⨅ (a ⨆ b) ∵ distrib1+                             ≡ a ⨆ (ⲳ ⨅ b)       ∵ commut2+                             ≡ a ⨆ (b ⨅ ⲳ)       ∵ bound2+                             ≡ a ⨆ ⲳ             ∵ ident1+                             ≡ a+                             ≡ qed++  idemp2 <- calc "a ⊓ a = a" (\(Forall @"a" (a :: SStroke)) -> a ⨅ a .== a) $+                 \a -> [] ⊢ a ⨅ a       ∵ ident1+                          ≡ a ⨅ (a ⨆ ⲳ) ∵ absorb2+                          ≡ a+                          ≡ qed++  inv <- calc "a ⊔ a' = т → a ⊓ a' = ⲳ → a' = aᶜ"+              (\(Forall @"a" (a :: SStroke)) (Forall @"a'" a') -> a ⨆ a' .== т .=> a ⨅ a' .== ⲳ .=> a' .== ﬧ a) $+              \a a' -> [a ⨆ a' .== т, a ⨅ a' .== ⲳ] ⊢ a'                     ∵ ident2+                                                    ≡ a' ⨅ т                 ∵ compl1+                                                    ≡ a' ⨅ (a ⨆ ﬧ a)         ∵ distrib2+                                                    ≡ (a' ⨅ a) ⨆ (a' ⨅ ﬧ a)  ∵ commut2+                                                    ≡ (a' ⨅ a) ⨆ (ﬧ a ⨅ a')  ∵ commut2+                                                    ≡ (a ⨅ a') ⨆ (ﬧ a ⨅ a')  ∵ a ⨅ a' .== ⲳ+                                                    ≡ ⲳ ⨆ (ﬧ a ⨅ a')         ∵ compl2+                                                    ≡ (a ⨅ ﬧ a) ⨆ (ﬧ a ⨅ a') ∵ commut2+                                                    ≡ (ﬧ a ⨅ a) ⨆ (ﬧ a ⨅ a') ∵ distrib2+                                                    ≡ ﬧ a ⨅ (a ⨆ a')         ∵ a ⨆ a' .== т+                                                    ≡ ﬧ a ⨅ т                ∵ ident2+                                                    ≡ ﬧ a+                                                    ≡ qed++  dne      <- lemma "aᶜᶜ = a"+                    (\(Forall @"a" (a :: SStroke)) -> ﬧﬧ a .== a)+                    [p inv, p compl1, p compl2, p commut1, p commut2]++  inv_elim <- lemma "aᶜ = bᶜ → a = b"+                    (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> ﬧ a .== ﬧ b .=> a .== b)+                    [p dne]++  cancel <- lemma "a ⊔ bᶜ = т → a ⊓ bᶜ = ⲳ → a = b"+                  (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> a ⨆ ﬧ b .== т .=> a ⨅ ﬧ b .== ⲳ .=> a .== b)+                  [p inv, p inv_elim]++  a1 <- calc "a ⊔ (aᶜ ⊔ b) = т" (\(Forall @"a" a) (Forall @"b" b)  -> a ⨆ (ﬧ a ⨆ b) .== т) $+             \a b -> [] ⊢ a ⨆ (ﬧ a ⨆ b)               ∵ ident2+                        ≡ (a ⨆ (ﬧ a ⨆ b)) ⨅ т         ∵ commut2+                        ≡ т ⨅ (a ⨆ (ﬧ a ⨆ b))         ∵ compl1+                        ≡ (a ⨆ ﬧ a) ⨅ (a ⨆ (ﬧ a ⨆ b)) ∵ distrib1+                        ≡ a ⨆ (ﬧ a ⨅ (ﬧ a ⨆ b))       ∵ absorb2+                        ≡ a ⨆ ﬧ a                     ∵ compl1+                        ≡ (т :: SStroke)+                        ≡ qed++  a2 <- calc "a ⊓ (aᶜ ⊓ b) = ⲳ" (\(Forall @"a" a) (Forall @"b" b)  -> a ⨅ (ﬧ a ⨅ b) .== ⲳ) $+             \a b -> [] ⊢ a ⨅ (ﬧ a ⨅ b)               ∵ ident1+                        ≡ (a ⨅ (ﬧ a ⨅ b)) ⨆ ⲳ         ∵ commut1+                        ≡ ⲳ ⨆ (a ⨅ (ﬧ a ⨅ b))         ∵ compl2+                        ≡ (a ⨅ ﬧ a) ⨆ (a ⨅ (ﬧ a ⨅ b)) ∵ distrib2+                        ≡ a ⨅ (ﬧ a ⨆ (ﬧ a ⨅ b))       ∵ absorb1+                        ≡ a ⨅ ﬧ a                     ∵ compl2+                        ≡ (ⲳ :: SStroke)+                        ≡ qed++  dm1 <- lemma "(a ⊔ b)ᶜ = aᶜ ⊓ bᶜ"+               (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> ﬧ(a ⨆ b) .== ﬧ a ⨅ ﬧ b)+               [p a1, p a2, p dne, p commut1, p commut2, p ident1, p ident2, p distrib1, p distrib2]++  dm2 <- lemma "(a ⨅ b)ᶜ = aᶜ ⨆ bᶜ"+               (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> ﬧ(a ⨅ b) .== ﬧ a ⨆ ﬧ b)+               [p a1, p a2, p dne, p commut1, p commut2, p ident1, p ident2, p distrib1, p distrib2]+++  d1 <- lemma "(a ⊔ (b ⊔ c)) ⊔ aᶜ = т"+              (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> (a ⨆ (b ⨆ c)) ⨆ ﬧ a .== т)+              [p a1, p a2, p commut1, p ident1, p ident2, p distrib1, p compl1, p compl2, p dm1, p dm2, p idemp2]++  e1 <- lemma "b ⊓ (a ⊔ (b ⊔ c)) = b"+              (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> b ⨅ (a ⨆ (b ⨆ c)) .== b)+              [p distrib2, p absorb1, p absorb2, p commut1]++  e2 <- lemma "b ⊔ (a ⊓ (b ⊓ c)) = b" (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> b ⨆ (a ⨅ (b ⨅ c)) .== b) [p distrib1, p absorb1, p absorb2, p commut2]++  f1 <- calc "(a ⊔ (b ⊔ c)) ⊔ bᶜ = т" (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> (a ⨆ (b ⨆ c)) ⨆ ﬧ b .== т) $+             \a b c -> [] ⊢ (a ⨆ (b ⨆ c)) ⨆ ﬧ b               ∵ commut1+                          ≡ ﬧ b ⨆ (a ⨆ (b ⨆ c))               ∵ ident2+                          ≡ (ﬧ b ⨆ (a ⨆ (b ⨆ c))) ⨅ т         ∵ commut2+                          ≡ т ⨅ (ﬧ b ⨆ (a ⨆ (b ⨆ c)))         ∵ compl1+                          ≡ (b ⨆ ﬧ b) ⨅ (ﬧ b ⨆ (a ⨆ (b ⨆ c))) ∵ commut1+                          ≡ (ﬧ b ⨆ b) ⨅ (ﬧ b ⨆ (a ⨆ (b ⨆ c))) ∵ distrib1+                          ≡ ﬧ b ⨆ (b ⨅ (a ⨆ (b ⨆ c)))         ∵ e1+                          ≡ ﬧ b ⨆ b                           ∵ commut1+                          ≡ b ⨆ ﬧ b                           ∵ compl1+                          ≡ (т :: SStroke)+                          ≡ qed++  g1 <- lemma "(a ⊔ (b ⊔ c)) ⊔ cᶜ = т"+              (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> (a ⨆ (b ⨆ c)) ⨆ ﬧ c .== т)+              [p commut1, p f1]++  h1 <- calc "(a ⊔ b ⊔ c)ᶜ ⊓ a = ⲳ"+             (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> ﬧ(a ⨆ b ⨆ c) ⨅ a .== ⲳ) $+             \a b c -> [] ⊢ ﬧ(a ⨆ b ⨆ c) ⨅ a                    ∵ commut2+                          ≡ a ⨅ ﬧ (a ⨆ b ⨆ c)                   ∵ dm1+                          ≡ a ⨅ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c)               ∵ ident1+                          ≡ (a ⨅  (ﬧ a ⨅ ﬧ b ⨅ ﬧ c)) ⨆ ⲳ        ∵ commut1+                          ≡ ⲳ ⨆ (a ⨅ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c))         ∵ compl2+                          ≡ (a ⨅ ﬧ a) ⨆ (a ⨅ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c)) ∵ distrib2+                          ≡ a ⨅ (ﬧ a ⨆ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c))       ∵ commut2+                          ≡ a ⨅ (ﬧ a ⨆ (ﬧ c ⨅ (ﬧ a ⨅ ﬧ b)))     ∵ e2+                          ≡ a ⨅ ﬧ a                             ∵ compl2+                          ≡ (ⲳ :: SStroke)+                          ≡ qed++  i1 <- lemma "(a ⊔ b ⊔ c)ᶜ ⊓ b = ⲳ"+              (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> ﬧ(a ⨆ b ⨆ c) ⨅ b .== ⲳ)+              [p commut1, p h1]++  j1 <- lemma "(a ⊔ b ⊔ c)ᶜ ⊓ c = ⲳ"+              (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> ﬧ(a ⨆ b ⨆ c) ⨅ c .== ⲳ)+              [p a2, p dne, p commut2]+++  assoc1 <- do+    c1 <- calc "(a ⊔ (b ⊔ c)) ⊔ ((a ⊔ b) ⊔ c)ᶜ = т"+               (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> (a ⨆ (b ⨆ c)) ⨆ ﬧ((a ⨆ b) ⨆ c) .== т) $+               \a b c -> [] ⊢ (a ⨆ (b ⨆ c)) ⨆ ﬧ((a ⨆ b) ⨆ c)                        ∵ dm1+                            ≡ (a ⨆ (b ⨆ c)) ⨆ (ﬧ a ⨅ ﬧ b ⨅ ﬧ c)                     ∵ distrib1+                            ≡ ((a ⨆ (b ⨆ c)) ⨆ (ﬧ a ⨅ ﬧ b)) ⨅ ((a ⨆ (b ⨆ c)) ⨆ ﬧ c) ∵ g1+                            ≡ ((a ⨆ (b ⨆ c)) ⨆ (ﬧ a ⨅ ﬧ b)) ⨅ т                     ∵ ident2+                            ≡ (a ⨆ (b ⨆ c)) ⨆ (ﬧ a ⨅ ﬧ b)                           ∵ distrib1+                            ≡ ((a ⨆ (b ⨆ c)) ⨆ ﬧ a) ⨅ ((a ⨆ (b ⨆ c)) ⨆ ﬧ b)         ∵ d1+                            ≡ т ⨅ ((a ⨆ (b ⨆ c)) ⨆ ﬧ b)                             ∵ f1+                            ≡ (т ⨅ т :: SStroke)                                    ∵ idemp2+                            ≡ (т :: SStroke)+                            ≡ qed++    c2 <- calc "(a ⊔ (b ⊔ c)) ⊓ ((a ⊔ b) ⊔ c)ᶜ = ⲳ"+               (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> (a ⨆ (b ⨆ c)) ⨅ ﬧ((a ⨆ b) ⨆ c) .== ⲳ) $+               \a b c -> [] ⊢ (a ⨆ (b ⨆ c)) ⨅ ﬧ((a ⨆ b) ⨆ c)                    ∵ commut2+                            ≡ ﬧ((a ⨆ b) ⨆ c) ⨅ (a ⨆ (b ⨆ c))                    ∵ distrib2+                            ≡ (ﬧ((a ⨆ b) ⨆ c) ⨅ a) ⨆ (ﬧ((a ⨆ b) ⨆ c) ⨅ (b ⨆ c)) ∵ commut2+                            ≡ (a ⨅ ﬧ((a ⨆ b) ⨆ c)) ⨆ ((b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c)) ∵ commut2+                            ≡ (ﬧ((a ⨆ b) ⨆ c) ⨅ a) ⨆ ((b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c)) ∵ h1+                            ≡ ⲳ ⨆ ((b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c))                    ∵ commut1+                            ≡ ((b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c)) ⨆ ⲳ                    ∵ ident1+                            ≡ (b ⨆ c) ⨅ ﬧ((a ⨆ b) ⨆ c)                          ∵ commut2+                            ≡ ﬧ((a ⨆ b) ⨆ c) ⨅ (b ⨆ c)                          ∵ distrib2+                            ≡ (ﬧ((a ⨆ b) ⨆ c) ⨅ b) ⨆ (ﬧ((a ⨆ b) ⨆ c) ⨅ c)       ∵ j1+                            ≡ (ﬧ((a ⨆ b) ⨆ c) ⨅ b) ⨆ ⲳ                          ∵ i1+                            ≡ (ⲳ ⨆ ⲳ :: SStroke)                                ∵ ident1+                            ≡ (ⲳ :: SStroke)+                            ≡ qed++    lemma "a ⊔ (b ⊔ c) = (a ⊔ b) ⊔ c"+          (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> a ⨆ (b ⨆ c) .== (a ⨆ b) ⨆ c)+          [p c1, p c2, p cancel]++  assoc2 <- calc "a ⊓ (b ⊓ c) = (a ⊓ b) ⊓ c"+                 (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) (Forall @"c" c) -> a ⨅ (b ⨅ c) .== (a ⨅ b) ⨅ c) $+                 \a b c -> [] ⊢ a ⨅ (b ⨅ c)     ∵ dne+                              ≡ ﬧﬧ(a ⨅ (b ⨅ c)) ∵ assoc1+                              ≡ ﬧﬧ((a ⨅ b) ⨅ c) ∵ dne+                              ≡   ((a ⨅ b) ⨅ c)+                              ≡ qed++  le_antisymm <- calc "a ≤ b → b ≤ a → a = b"+                      (\(Forall @"a" a) (Forall @"b" b) -> a ≤ b .=> b ≤ a .=> a .== b) $+                      \a b -> [a ≤ b, b ≤ a] ⊢ a     ∵ a ≤ b+                                             ≡ b ⨅ a ∵ commut2+                                             ≡ a ⨅ b ∵ b ≤ a+                                             ≡ b+                                             ≡ qed++  le_refl <- lemma "a ≤ a" (\(Forall @"a" a) -> a ≤ a) [p idemp2]++  le_trans <- calc "a ≤ b → b ≤ c → a ≤ c" (\(Forall a) (Forall b) (Forall c) -> a ≤ b .=> b ≤ c .=> a ≤ c) $+                   \a b c -> [a ≤ b, b ≤ c] ⊢ a            ∵ a ≤ b+                                            ≡ b ⨅ a        ∵ b ≤ c+                                            ≡ (c ⨅ b) ⨅ a  ∵ assoc2+                                            ≡ c ⨅ (b ⨅ a)  ∵ a ≤ b+                                            ≡ (c ⨅ a)+                                            ≡ qed++  lt_iff_le_not_le <- lemma "a < b ↔ a ≤ b ∧ ¬b ≤ a"+                            (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> (a < b) .<=> a ≤ b .&& sNot (b ≤ a))+                            [p sh3]++  le_sup_left  <- lemma "a ≤ a ⊔ b"+                  (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> a ≤ a ⨆ b)+                  [p commut1, p commut2, p absorb2]++  le_sup_right <- lemma "b ≤ a ⊔ b"+                  (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> a ≤ a ⨆ b)+                  [p commut1, p commut2, p absorb2]++  sup_le <- calc "a ≤ c → b ≤ c → a ⊔ b ≤ c"+                 (\(Forall a) (Forall b) (Forall c) -> a ≤ c .=> b ≤ c .=> a ⨆ b ≤ c) $+                 \a b c -> [a ≤ c, b ≤ c] ⊢ a ⨆ b             ∵ [a ≤ c, b ≤ c]+                                          ≡ (c ⨅ a) ⨆ (c ⨅ b) ∵ distrib2+                                          ≡ c ⨅ (a ⨆ b)+                                          ≡ qed++  inf_le_left  <- lemma "a ⊓ b ≤ a"+                        (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> a ⨅ b ≤ a)+                        [p assoc2,  p idemp2]++  inf_le_right <- lemma "a ⊓ b ≤ b"+                        (\(Forall @"a" (a :: SStroke)) (Forall @"b" b) -> a ⨅ b ≤ b)+                        [p commut2, p inf_le_left]++  le_inf <- calc "a ≤ b → a ≤ c → a ≤ b ⊓ c"+                 (\(Forall a) (Forall b) (Forall c) -> a ≤ b .=> a ≤ c .=> a ≤ b ⨅ c) $+                 \a b c -> [a ≤ b, a ≤ c] ⊢ a           ∵ a ≤ b+                                          ≡ b ⨅ a       ∵ a ≤ c+                                          ≡ b ⨅ (c ⨅ a) ∵ assoc2+                                          ≡ (b ⨅ c ⨅ a)+                                          ≡ qed++  le_sup_inf <- lemma "(x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z"+                      (\(Forall x) (Forall y) (Forall z) -> (x ⨆ y) ⨅ (x ⨆ z) ≤ x ⨆ y ⨅ z)+                      [p distrib1, p le_refl]++  inf_compl_le_bot <- lemma "x ⊓ xᶜ ≤ ⊥" (\(Forall x) -> x ⨅ ﬧ x ≤ ⲳ) [p compl2, p le_refl]+  top_le_sup_compl <- lemma "⊤ ≤ x ⊔ xᶜ" (\(Forall x) -> т ≤ x ⨆ ﬧ x) [p compl1, p le_refl]++  le_top <- calc "a ≤ ⊤" (\(Forall @"a" a) -> a ≤ т) $+                 \a -> [] ⊢ a ≤ т+                          ≡ a .== т ⨅ a ∵ commut2+                          ≡ a .== a ⨅ т ∵ ident2+                          ≡ a .== a+                          ≡ qed++  bot_le <- calc "⊥ ≤ a" (\(Forall @"a" a) -> ⲳ ≤ a) $+                 \a -> [] ⊢ ⲳ ≤ a+                          ≡ ⲳ .== a ⨅ ⲳ            ∵ bound2+                          ≡ ⲳ .== (ⲳ :: SStroke)+                          ≡ qed++  sdiff_eq <- lemma "x \\ y = x ⊓ yᶜ" (\(Forall x) (Forall y) -> x \\ y .== x ⨅ ﬧ y) []+  himp_eq  <- lemma "x ⇨ y = y ⊔ xᶜ"  (\(Forall x) (Forall y) -> x ⇨ y .== y ⨆ ﬧ x)  []++  pure BooleanAlgebraProof {+            le_refl          {- ∀ (a : α), a ≤ a                             -} = le_refl+          , le_trans         {- ∀ (a b c : α), a ≤ b → b ≤ c → a ≤ c         -} = le_trans+          , lt_iff_le_not_le {- (∀ (a b : α), a < b ↔ a ≤ b ∧ ¬b ≤ a)        -} = lt_iff_le_not_le+          , le_antisymm      {- ∀ (a b : α), a ≤ b → b ≤ a → a = b           -} = le_antisymm+          , le_sup_left      {- ∀ (a b : α), a ≤ a ⊔ b                       -} = le_sup_left+          , le_sup_right     {- ∀ (a b : α), b ≤ a ⊔ b                       -} = le_sup_right+          , sup_le           {- ∀ (a b c : α), a ≤ c → b ≤ c → a ⊔ b ≤ c     -} = sup_le+          , inf_le_left      {- ∀ (a b : α), a ⊓ b ≤ a                       -} = inf_le_left+          , inf_le_right     {- ∀ (a b : α), a ⊓ b ≤ b                       -} = inf_le_right+          , le_inf           {- ∀ (a b c : α), a ≤ b → a ≤ c → a ≤ b ⊓ c     -} = le_inf+          , le_sup_inf       {- ∀ (x y z : α), (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z -} = le_sup_inf+          , inf_compl_le_bot {- ∀ (x : α), x ⊓ xᶜ ≤ ⊥                        -} = inf_compl_le_bot+          , top_le_sup_compl {- ∀ (x : α), ⊤ ≤ x ⊔ xᶜ                        -} = top_le_sup_compl+          , le_top           {- ∀ (a : α), a ≤ ⊤                             -} = le_top+          , bot_le           {- ∀ (a : α), ⊥ ≤ a                             -} = bot_le+          , sdiff_eq         {- (∀ (x y : α), x \ y = x ⊓ yᶜ)                -} = sdiff_eq+          , himp_eq          {- (∀ (x y : α), x ⇨ y = y ⊔ xᶜ)                -} = himp_eq+       }
+ Documentation/SBV/Examples/TP/SortHelpers.hs view
@@ -0,0 +1,185 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.SortHelpers+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Various definitions and lemmas that are useful for sorting related proofs.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.SortHelpers where++import Prelude hiding (null, tail, elem, head, (++), take, drop)++import Data.SBV+import Data.SBV.List+import Data.SBV.TP+import Data.SBV.TP.List++#ifdef DOCTEST+-- $setup+-- >>> :set -XTypeApplications+-- >>> import Data.SBV.TP+#endif++-- | A predicate testing whether a given list is non-decreasing.+nonDecreasing :: (Ord a, SymVal a) => SList a -> SBool+nonDecreasing = smtFunction "nonDecreasing" $ \l ->  null l .|| null (tail l)+                                                 .|| let (x, l') = uncons l+                                                         (y, _)  = uncons l'+                                                     in x .<= y .&& nonDecreasing l'++-- | Are two lists permutations of each other?+isPermutation :: SymVal a => SList a -> SList a -> SBool+isPermutation xs ys = quantifiedBool (\(Forall @"x" x) -> count x xs .== count x ys)++-- | The tail of a non-decreasing list is non-decreasing. We have:+--+-- >>> runTP $ nonDecrTail @Integer+-- Lemma: nonDecrTail                      Q.E.D.+-- [Proven] nonDecrTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+nonDecrTail :: forall a. (Ord a, SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool))+nonDecrTail = lemma "nonDecrTail"+                    (\(Forall x) (Forall xs) -> nonDecreasing (x .: xs) .=> nonDecreasing xs)+                    []++-- | If we insert an element that is less than the head of a nonDecreasing list, it remains nondecreasing. We have:+--+-- >>> runTP $ nonDecrIns @Integer+-- Lemma: nonDecrInsert                    Q.E.D.+-- [Proven] nonDecrInsert :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+nonDecrIns :: forall a. (Ord a, SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool))+nonDecrIns = lemma "nonDecrInsert"+                   (\(Forall x) (Forall xs) -> nonDecreasing xs .&& sNot (null xs) .&& x .<= head xs .=> nonDecreasing (x .: xs))+                   []++-- | Sublist relationship+sublist :: SymVal a => SList a -> SList a -> SBool+sublist xs ys = quantifiedBool (\(Forall @"e" e) -> count e xs .> 0 .=> count e ys .> 0)++-- | 'sublist' correctness. We have:+--+-- >>> runTP $ sublistCorrect @Integer+-- Inductive lemma: countNonNeg+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: countElem+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: elemCount+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: sublistCorrect+--   Step: 1                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] sublistCorrect :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐx ∷ Integer → Bool+sublistCorrect :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "x" a -> SBool))+sublistCorrect = do++    cElem  <- countElem @a+    eCount <- elemCount @a++    calc "sublistCorrect"+         (\(Forall xs) (Forall ys) (Forall x) -> xs `sublist` ys .&& x `elem` xs .=> x `elem` ys) $+         \xs ys x -> [xs `sublist` ys, x `elem` xs]+                  |- x `elem` ys+                  ?? cElem  `at` (Inst @"xs" xs, Inst @"e" x)+                  ?? eCount `at` (Inst @"xs" ys, Inst @"e" x)+                  =: sTrue+                  =: qed++-- | If one list is a sublist of another, then its head is an elem. We have:+--+-- >>> runTP $ sublistElem @Integer+-- Inductive lemma: countNonNeg+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: countElem+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1.1                         Q.E.D.+--     Step: 1.1.2                         Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: elemCount+--   Step: Base                            Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: sublistCorrect+--   Step: 1                               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: sublistElem+--   Step: 1                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] sublistElem :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+sublistElem :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> Forall "ys" [a] -> SBool))+sublistElem = do+   slc <- sublistCorrect @a++   calc "sublistElem"+        (\(Forall x) (Forall xs) (Forall ys) -> (x .: xs) `sublist` ys .=> x `elem` ys) $+        \x xs ys -> [(x .: xs) `sublist` ys]+                 |- x `elem` ys+                 ?? slc `at` (Inst @"xs" (x .: xs), Inst @"ys" ys, Inst @"x" x)+                 =: sTrue+                 =: qed++-- | If one list is a sublist of another so is its tail. We have:+--+-- >>> runTP $ sublistTail @Integer+-- Lemma: sublistTail                      Q.E.D.+-- [Proven] sublistTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+sublistTail :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> Forall "ys" [a] -> SBool))+sublistTail =+  lemma "sublistTail"+        (\(Forall x) (Forall xs) (Forall ys) -> (x .: xs) `sublist` ys .=> xs `sublist` ys)+        []++-- | Permutation implies sublist. We have:+--+-- >>> runTP $ sublistIfPerm @Integer+-- Lemma: sublistIfPerm                    Q.E.D.+-- [Proven] sublistIfPerm :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+sublistIfPerm :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+sublistIfPerm = lemma "sublistIfPerm"+                      (\(Forall xs) (Forall ys) -> isPermutation xs ys .=> xs `sublist` ys)+                      []
+ Documentation/SBV/Examples/TP/Sqrt2IsIrrational.hs view
@@ -0,0 +1,112 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.Sqrt2IsIrrational+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Prove that square-root of 2 is irrational.+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions    #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Sqrt2IsIrrational where++import Prelude hiding (even, odd)++import Data.SBV+import Data.SBV.TP++-- | Prove that square-root of @2@ is irrational. That is, we can never find @a@ and @b@ such that+-- @sqrt 2 == a / b@ and @a@ and @b@ are co-prime.+--+-- In order not to deal with reals and square-roots, we prove the integer-only alternative:+-- If @a^2 = 2b^2@, then @a@ and @b@ cannot be co-prime. We proceed by establishing the+-- following helpers first:+--+--   (1) An odd number squared is odd: @odd x -> odd x^2@+--   (2) An even number that is a perfect square must be the square of an even number: @even x^2 -> even x@.+--   (3) If a number is even, then its square must be a multiple of 4: @even x .=> x*x % 4 == 0@.+--+--  Using these helpers, we can argue:+--+--   (4)  Start with the premise @a^2 = 2b^2@.+--   (5)  Thus, @a^2@ must be even. (Since it equals @2b^2@ by 4.)+--   (6)  Thus, @a@ must be even. (Using 2 and 5.)+--   (7)  Thus, @a^2@ must be divisible by @4@. (Using 3 and 6. That is, @2b^2 == 4K@ for some @K@.)+--   (8)  Thus, @b^2@ must be even. (Using 7, and @b^2 = 2K@.)+--   (9)  Thus, @b@ must be even. (Using 2 and 8.)+--   (10) Since @a@ and @b@ are both even, they cannot be co-prime. (Using 6 and 9.)+--+-- Note that our proof is mostly about the first 3 facts above, then z3 and TP fills in the rest.+--+-- We have:+--+-- >>> sqrt2IsIrrational+-- Lemma: oddSquaredIsOdd+--   Step: 1                               Q.E.D.+--   Step: 2 (expand square)               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: squareEvenImpliesEven            Q.E.D.+-- Lemma: evenSquaredIsMult4+--   Step: 1                               Q.E.D.+--   Step: 2 (expand square)               Q.E.D.+--   Result:                               Q.E.D.+-- Lemma: sqrt2IsIrrational                Q.E.D.+-- [Proven] sqrt2IsIrrational :: Bool+sqrt2IsIrrational :: IO (Proof SBool)+sqrt2IsIrrational = runTP $ do+    let even, odd :: SInteger -> SBool+        even = (2 `sDivides`)+        odd  = sNot . even++        sq :: SInteger -> SInteger+        sq x = x * x++    -- Prove that an odd number squared gives you an odd number.+    -- We need to help the solver by guiding it through how it can+    -- be decomposed as @2k+1@.+    --+    -- Interestingly, the solver doesn't need the analogous theorem that even number+    -- squared is even, possibly because the even/odd definition above is enough for+    -- it to deduce that fact automatically.+    oddSquaredIsOdd <- calc "oddSquaredIsOdd"+                             (\(Forall @"a" a) -> odd a .=> odd (sq a)) $+                             \a -> [odd a] |- sq a+                                           =: let k = some "k" $ \_k -> a .== 2*_k + 1  -- Grab the witness that a is odd+                                           in sq (2 * k + 1)+                                           ?? "expand square"+                                           =: 4*k*k + 4*k + 1+                                           =: qed++    -- Prove that if a perfect square is even, then it be the square of an even number. For z3, the above proof+    -- is enough to establish this.+    squareEvenImpliesEven <- lemma "squareEvenImpliesEven"+                                   (\(Forall @"a" a) -> even (sq a) .=> even a)+                                   [proofOf oddSquaredIsOdd]++    -- Prove that if @a@ is an even number, then its square is four times the square of another.+    evenSquaredIsMult4 <- calc "evenSquaredIsMult4"+                               (\(Forall @"a" a) -> even a .=> 4 `sDivides` sq a) $+                               \a -> [even a] |- sq a+                                              =: let k = some "k" $ \_k -> a .== 2*_k -- Grab the witness that a is even+                                              in sq (2 * k)+                                              ?? "expand square"+                                              =: 4*(k*k)+                                              =: qed++    -- Define what it means to be co-prime. Note that we use euclidian notion of modulus here+    -- as z3 deals with that much better. Two numbers are co-prime if 1 is their only common divisor.+    let coPrime :: SInteger -> SInteger -> SBool+        coPrime x y = quantifiedBool (\(Forall z) -> (x `sEMod` z .== 0 .&& y `sEMod` z .== 0) .=> z .== 1)++    -- Prove that square-root of 2 is irrational. We do this by showing for all pairs of integers @a@ and @b@+    -- such that @a*a == 2*b*b@, it must be the case that @a@ and @b@ can not be co-prime:+    lemma "sqrt2IsIrrational"+          (quantifiedBool (\(Forall a) (Forall b) -> sq a .== 2 * sq b .=> sNot (coPrime a b)))+          [proofOf squareEvenImpliesEven, proofOf evenSquaredIsMult4]
+ Documentation/SBV/Examples/TP/StrongInduction.hs view
@@ -0,0 +1,312 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.StrongInduction+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Examples of strong induction.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.StrongInduction where++import Prelude hiding (length, null, head, tail, reverse, (++), splitAt, sum)++import Data.SBV+import Data.SBV.List+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> :set -XScopedTypeVariables+-- >>> import Control.Exception+#endif++-- * Numeric examples++-- | Prove that the sequence @1@, @3@, @S_{k-2} + 2 S_{k-1}@ is always odd.+--+-- We have:+--+-- >>> oddSequence1+-- Inductive lemma (strong): oddSequence1+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (3 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2                           Q.E.D.+--     Step: 1.3.1                         Q.E.D.+--     Step: 1.3.2                         Q.E.D.+--     Step: 1.3.3                         Q.E.D.+--     Step: 1.Completeness                Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] oddSequence1 :: Ɐn ∷ Integer → Bool+oddSequence1 :: IO (Proof (Forall "n" Integer -> SBool))+oddSequence1 = runTP $ do+  let s :: SInteger -> SInteger+      s = smtFunction "seq" $ \n -> ite (n .<= 0) 1+                                  $ ite (n .== 1) 3+                                  $ s (n-2) + 2 * s (n-1)++  -- z3 can't handle this, but CVC5 is proves it just fine.+  -- Note also that we do a "proof-by-contradiction," by deriving that+  -- the negation of the goal leads to falsehood.+  sInductWith cvc5 "oddSequence1"+          (\(Forall n) -> n .>= 0 .=> sNot (2 `sDivides` s n))+          abs $+          \ih n -> [n .>= 0] |- 2 `sDivides` s n+                             =: cases [ n .== 0 ==> contradiction+                                      , n .== 1 ==> contradiction+                                      , n .>= 2 ==> 2 `sDivides` (s (n-2) + 2 * s (n-1))+                                                 =: 2 `sDivides` s (n-2)+                                                 ?? ih `at` Inst @"n" (n - 2)+                                                 =: contradiction+                                      ]++-- | Prove that the sequence @1@, @3@, @2 S_{k-1} - S_{k-2}@ generates sequence of odd numbers.+--+-- We have:+--+-- >>> oddSequence2+-- Lemma: oddSequence_0                              Q.E.D.+-- Lemma: oddSequence_1                              Q.E.D.+-- Inductive lemma (strong): oddSequence_sNp2+--   Step: Measure is non-negative                   Q.E.D.+--   Step: 1                                         Q.E.D.+--   Step: 2                                         Q.E.D.+--   Step: 3 (simplify)                              Q.E.D.+--   Step: 4                                         Q.E.D.+--   Step: 5 (simplify)                              Q.E.D.+--   Step: 6                                         Q.E.D.+--   Result:                                         Q.E.D.+-- Lemma: oddSequence2+--   Step: 1 (3 way case split)+--     Step: 1.1                                     Q.E.D.+--     Step: 1.2                                     Q.E.D.+--     Step: 1.3.1                                   Q.E.D.+--     Step: 1.3.2                                   Q.E.D.+--     Step: 1.Completeness                          Q.E.D.+--   Result:                                         Q.E.D.+-- [Proven] oddSequence2 :: Ɐn ∷ Integer → Bool+oddSequence2 :: IO (Proof (Forall "n" Integer -> SBool))+oddSequence2 = runTPWith (tpRibbon 50 z3) $ do+  let s :: SInteger -> SInteger+      s = smtFunction "seq" $ \n -> ite (n .<= 0) 1+                                  $ ite (n .== 1) 3+                                  $ 2 * s (n-1) - s (n-2)++  s0 <- lemma "oddSequence_0" (s 0 .== 1) []+  s1 <- lemma "oddSequence_1" (s 1 .== 3) []++  sNp2 <- sInduct "oddSequence_sNp2"+                  (\(Forall n) -> n .>= 2 .=> s n .== 2 * n + 1)+                  abs $+                  \ih n -> [n .>= 2] |- s n+                                     =: 2 * s (n-1) - s (n-2)+                                     ?? ih `at` Inst @"n" (n-1)+                                     =: 2 * (2 * (n-1) + 1) - s (n-2)+                                     ?? "simplify"+                                     =: 4*n - 4 + 2 - s (n-2)+                                     ?? ih `at` Inst @"n" (n-2)+                                     =: 4*n - 2 - (2 * (n-2) + 1)+                                     ?? "simplify"+                                     =: 4*n - 2 - 2*n + 4 - 1+                                     =: 2*n + 1+                                     =: qed++  calc "oddSequence2" (\(Forall n) -> n .>= 0 .=> s n .== 2 * n + 1) $+                      \n -> [n .>= 0] |- s n+                                      =: cases [ n .== 0 ==> trivial+                                               , n .== 1 ==> trivial+                                               , n .>= 2 ==> s n+                                                          ?? s0+                                                          ?? s1+                                                          ?? sNp2 `at` Inst @"n" n+                                                          =: 2 * n + 1+                                                          =: qed+                                               ]++-- * Strong induction checks++-- | For strong induction to work, We have to instantiate the proof at a "smaller" value. This+-- example demonstrates what happens if we don't. We have:+--+-- >>> won'tProve1 `catch` (\(_ :: SomeException) -> pure ())+-- Inductive lemma (strong): lengthGood+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1+-- *** Failed to prove lengthGood.1.+-- <BLANKLINE>+-- *** Solver reported: canceled+won'tProve1 :: IO ()+won'tProve1 = runTP $ do+   let len :: SList Integer -> SInteger+       len = smtFunction "len" $ \xs -> ite (null xs) 0 (1 + len (tail xs))++   -- Run it for 5 seconds, as otherwise z3 will hang as it can't prove make the inductive step+   _ <- sInductWith z3{extraArgs = ["-t:5000"]} "lengthGood"+                (\(Forall xs) -> len xs .== length xs)+                length $+                \ih xs -> [] |- len xs+                             -- incorrectly instantiate the IH at xs!+                             ?? ih `at` Inst @"xs" xs+                             =: length xs+                             =: qed+   pure ()++-- | Note that strong induction does not need an explicit base case, as the base-cases is folded into the+-- inductive step. Here's an example demonstrating what happens when the failure is only at the base case.+--+-- >>> won'tProve2 `catch` (\(_ :: SomeException) -> pure ())+-- Inductive lemma (strong): badLength+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1+-- *** Failed to prove badLength.1.+-- Falsifiable. Counter-example:+--   xs = [] :: [Integer]+won'tProve2 :: IO ()+won'tProve2 = runTP $ do+   let len :: SList Integer -> SInteger+       len = smtFunction "badLength" $ \xs -> ite (null xs)+                                                  123+                                                  (ite (null xs)+                                                       0+                                                       (1 + len (tail xs)))++   _ <- sInduct "badLength"+                (\(Forall xs) -> len xs .== length xs)+                length $+                \ih xs -> [] |- len xs+                             ?? ih `at` Inst @"xs" xs+                             =: length xs+                             =: qed+   pure ()++-- | The measure for strong induction should always produce a non-negative measure. The measure, in general, is an integer, or+-- a tuple of integers, for tuples upto size 5. The ordering is lexicographic. This allows us to do proofs over 5-different arguments+-- where their total measure goes down. If the measure can be negative, then we flag that as a failure, as demonstrated here. We have:+--+-- >>> won'tProve3 `catch` (\(_ :: SomeException) -> pure ())+-- Inductive lemma (strong): badMeasure+--   Step: Measure is non-negative+-- *** Failed to prove badMeasure.Measure is non-negative.+-- Falsifiable. Counter-example:+--   x = -1 :: Integer+won'tProve3 :: IO ()+won'tProve3 = runTP $ do+   _ <- sInduct "badMeasure"+                (\(Forall @"x" (x :: SInteger)) -> x .== x)+                id $+                \_ih x -> [] |- x+                             =: x+                             =: qed+++   pure ()++-- | The measure must always go down using lexicographic ordering. If not, SBV will flag this as a failure. We have:+--+-- >>> won'tProve4 `catch` (\(_ :: SomeException) -> pure ())+-- Inductive lemma (strong): badMeasure+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (2 way case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2.1                         Q.E.D.+--     Step: 1.2.2+-- *** Failed to prove badMeasure.1.2.2.+-- <BLANKLINE>+-- *** Solver reported: canceled+won'tProve4 :: IO ()+won'tProve4 = runTP $ do++   let -- a bizarre (but valid!) way to sum two integers+       weirdSum :: SInteger -> SInteger -> SInteger+       weirdSum = smtFunction "weirdSum" (\x y -> ite (x .<= 0) y (weirdSum (x - 1) (y + 1)))++   _ <- sInductWith z3{extraArgs = ["-t:5000"]} "badMeasure"+                (\(Forall x) (Forall y) -> x .>= 0 .=> weirdSum x y .== x + y)+                -- This measure is not good, since it remains the same. Note that we do not get a+                -- failure, but the proof will never converge either; so we put a time bound+                (\x y -> abs x + abs y) $+                \ih x y -> [x .>= 0] |- ite (x .<= 0) y (weirdSum (x - 1) (y + 1))+                                     =: cases [ x .<= 0 ==> trivial+                                              , x .>  0 ==> weirdSum (x - 1) (y + 1)+                                                         ?? ih `at` (Inst @"x" (x - 1), Inst @"y" (y + 1))+                                                         =: x - 1 + y + 1+                                                         =: x + y+                                                         =: qed+                                              ]++   pure ()++-- * Summing via halving++-- | We prove that summing a list can be done by halving the list, summing parts, and adding the results. The proof uses+-- strong induction. We have:+--+-- >>> sumHalves+-- Inductive lemma: sumAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma (strong): sumHalves+--   Step: Measure is non-negative         Q.E.D.+--   Step: 1 (2 way full case split)+--     Step: 1.1                           Q.E.D.+--     Step: 1.2 (2 way full case split)+--       Step: 1.2.1                       Q.E.D.+--       Step: 1.2.2.1                     Q.E.D.+--       Step: 1.2.2.2                     Q.E.D.+--       Step: 1.2.2.3                     Q.E.D.+--       Step: 1.2.2.4                     Q.E.D.+--       Step: 1.2.2.5                     Q.E.D.+--       Step: 1.2.2.6 (simplify)          Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] sumHalves :: Ɐxs ∷ [Integer] → Bool+sumHalves :: IO (Proof (Forall "xs" [Integer] -> SBool))+sumHalves = runTP $ do++    let halvingSum :: SList Integer -> SInteger+        halvingSum = smtFunction "halvingSum" $ \xs -> ite (null xs .|| null (tail xs))+                                                           (sum xs)+                                                           (let (f, s) = splitAt (length xs `sDiv` 2) xs+                                                            in halvingSum f + halvingSum s)++    helper <- induct "sumAppend"+                     (\(Forall xs) (Forall ys) -> sum (xs ++ ys) .== sum xs + sum ys) $+                     \ih (x, xs) ys -> [] |- sum (x .: xs ++ ys)+                                          =: x + sum (xs ++ ys)+                                          ?? ih+                                          =: x + sum xs + sum ys+                                          =: sum (x .: xs) + sum ys+                                          =: qed++    -- Use strong induction to prove the theorem. CVC5 solves this with ease, but z3 struggles.+    sInductWith cvc5 "sumHalves"+      (\(Forall xs) -> halvingSum xs .== sum xs)+      length $+      \ih xs -> [] |- halvingSum xs+                   =: split xs qed+                            (\a as -> split as qed+                                            (\b bs -> halvingSum (a .: b .: bs)+                                                   =: let (f, s) = splitAt (length (a .: b .: bs) `sDiv` 2) (a .: b .: bs)+                                                   in halvingSum f + halvingSum s+                                                   ?? ih `at` Inst @"xs" f+                                                   =: sum f + halvingSum s+                                                   ?? ih `at` Inst @"xs" s+                                                   =: sum f + sum s+                                                   ?? helper `at` (Inst @"xs" f, Inst @"ys" s)+                                                   =: sum (f ++ s)+                                                   ?? "simplify"+                                                   =: sum (a .: b .: bs)+                                                   =: qed))
+ Documentation/SBV/Examples/TP/SumReverse.hs view
@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.SumReverse+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proves @sum (reverse xs) == sum xs@.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE OverloadedLists     #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.SumReverse where++import Prelude hiding ((++), foldr, sum, reverse)++import Data.SBV+import Data.SBV.TP+import Data.SBV.List+++#ifdef DOCTEST+-- $setup+-- >>> :set -XFlexibleContexts+-- >>> :set -XTypeApplications+#endif++-- | @sum (reverse xs) = sum xs@+--+-- >>> revSum @Integer+-- Inductive lemma: sumAppend+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- Inductive lemma: sumReverse+--   Step: Base                            Q.E.D.+--   Step: 1                               Q.E.D.+--   Step: 2                               Q.E.D.+--   Step: 3                               Q.E.D.+--   Step: 4                               Q.E.D.+--   Result:                               Q.E.D.+-- [Proven] sumReverse :: Ɐxs ∷ [Integer] → Bool+revSum :: forall a. (SymVal a, Num (SBV a)) => IO (Proof (Forall "xs" [a] -> SBool))+revSum = runTP $ do++  -- helper: sum distributes over append.+  sumAppend <- induct "sumAppend"+                      (\(Forall xs) (Forall ys) -> sum (xs ++ ys) .== sum xs + sum ys) $+                      \ih (x, xs) ys -> [] |- sum ((x .: xs) ++ ys)+                                           =: sum (x .: (xs ++ ys))+                                           =: x + sum (xs ++ ys)+                                           ?? ih+                                           =: x + sum xs + sum ys+                                           =: sum (x .: xs) + sum ys+                                           =: qed++  -- Now prove the original theorem by induction+  induct "sumReverse"+         (\(Forall xs) -> sum (reverse xs) .== sum xs) $+         \ih (x, xs) -> [] |- sum (reverse (x .: xs))+                           =: sum (reverse xs ++ [x])+                           ?? sumAppend `at` (Inst @"xs" (reverse xs), Inst @"ys" [x])+                           =: sum (reverse xs) + sum [x]+                           ?? ih+                           =: sum xs + x+                           =: sum (x .: xs)+                           =: qed
+ Documentation/SBV/Examples/TP/Tao.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module    : Documentation.SBV.Examples.TP.Tao+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- A question posed by Terrence Tao: <https://mathstodon.xyz/@tao/110736805384878353>.+-- Essentially, for an arbitrary binary operation op, we prove that+--+-- @+--    (x op x) op y == y op x+-- @+--+-- Implies @op@ must be commutative.+-----------------------------------------------------------------------------+++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE TypeAbstractions    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TemplateHaskell     #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Tao where++import Data.SBV+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> :set -XTypeApplications+#endif++-- | Create an uninterpreted type to do the proofs over.+data T+mkUninterpretedSort ''T++-- | Prove that:+--+--  @+--    (x op x) op y == y op x+--  @+--+--  means that @op@ is commutative.+--+-- We have:+--+-- >>> tao @T (uninterpret "op")+-- Lemma: tao                              Q.E.D.+-- [Proven] tao :: Bool+tao :: forall a. SymVal a => (SBV a -> SBV a -> SBV a) -> IO (Proof SBool)+tao op = runTP $+   lemma "tao" (    quantifiedBool (\(Forall x) (Forall y) -> ((x `op` x) `op` y) .== y `op` x)+                .=> quantifiedBool (\(Forall x) (Forall y) -> (x `op` y) .== (y `op` x)))+               []
Documentation/SBV/Examples/Uninterpreted/Deduce.hs view
@@ -7,8 +7,6 @@ -- Stability : experimental -- -- Demonstrates uninterpreted sorts and how they can be used for deduction.--- This example is inspired by the discussion at <http://stackoverflow.com/questions/10635783/using-axioms-for-deductions-in-z3>,--- essentially showing how to show the required deduction using SBV. -----------------------------------------------------------------------------  {-# LANGUAGE DeriveAnyClass     #-}
Documentation/SBV/Examples/WeakestPreconditions/Sum.hs view
@@ -239,10 +239,10 @@ Following proof obligation failed: ==================================   Measure for loop "i < n" does not decrease:-    Before : SumS {n = 1, i = 0, s = 0}+    Before : SumS {n = 2, i = -2, s = 1}+    Measure: 0+    After  : SumS {n = 2, i = -1, s = 0}     Measure: 1-    After  : SumS {n = 1, i = 1, s = 1}-    Measure: 2  Clearly, as @i@ increases, so does our bogus measure @n+i@. (Note that in this case the counterexample might have @i@ and @n@ as negative values, as the SMT solver finds a counter-example to induction, not necessarily a reachable state. Obviously, all such failures need to be addressed for the full proof.)
README.md view
@@ -6,6 +6,8 @@  Express properties about Haskell programs and automatically prove them using SMT solvers. +On one end, SBV can be used as a push-button prover over many types:+ ```haskell $ ghci ghci> :m Data.SBV@@ -16,7 +18,42 @@   s0 = 32 :: Word8 ``` -The function `prove` establishes theorem-hood, while `sat` finds a satisfying model if it exists.+On the other extreme, SBV can be used as an SMT-based proof assistant to prove equational and inductive program properties:++```haskell+revApp :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))+revApp = induct "revApp"+                 (\(Forall xs) (Forall ys) -> reverse (xs ++ ys) .== reverse ys ++ reverse xs) $+                 \ih (x, xs) ys -> [] |- reverse ((x .: xs) ++ ys)+                                      =: reverse (x .: (xs ++ ys))+                                      =: reverse (xs ++ ys) ++ [x]+                                      ?? ih+                                      =: (reverse ys ++ reverse xs) ++ [x]+                                      =: reverse ys ++ (reverse xs ++ [x])+                                      =: reverse ys ++ reverse (x .: xs)+                                      =: qed+```++Running this proof produces:++```haskell+ghci> runTP $ revApp @Integer+Inductive lemma: revApp+  Step: Base                            Q.E.D.+  Step: 1                               Q.E.D.+  Step: 2                               Q.E.D.+  Step: 3                               Q.E.D.+  Step: 4                               Q.E.D.+  Step: 5                               Q.E.D.+  Result:                               Q.E.D.+[Proven] revApp :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+```++Establishing how `reverse` distributes over `++` (at the monomorpic type of list of integers).++The function `prove` establishes theorem-hood, while `sat` finds a satisfying model if it exists. The `runTP` function+runs a proof script, establishing theorems with user guidance.+ All satisfying models can be computed using `allSat`. SBV can also perform static assertion checks, such as absence of division-by-0, and other user given properties. Furthermore, SBV can perform optimization, minimizing/maximizing arithmetic goals for their optimal values.@@ -73,14 +110,14 @@ The SBV library uses third-party SMT solvers via the standard SMT-Lib interface. The following solvers are supported:   - [ABC](http://www.eecs.berkeley.edu/~alanmi/abc) from University of Berkeley- - [Boolector](https://boolector.github.io/) from Johannes Kepler University- - [Bitwuzla](https://bitwuzla.github.io/) from Stanford University+ - [Boolector](http://boolector.github.io/) from Johannes Kepler University+ - [Bitwuzla](http://bitwuzla.github.io/) from Stanford University  - [CVC4](http://cvc4.github.io/) from Stanford University and the University of Iowa  - [CVC5](http://cvc5.github.io/) from Stanford University and the University of Iowa- - [DReal](https://dreal.github.io/) from CMU+ - [DReal](http://dreal.github.io/) from CMU  - [MathSAT](http://mathsat.fbk.eu/) from FBK and DISI-University of Trento- - [OpenSMT](https://verify.inf.usi.ch/opensmt) from Università della Svizzera italiana- - [Yices](http://yices.csl.sri.com/) from SRI+ - [OpenSMT](http://verify.inf.usi.ch/opensmt) from Università della Svizzera italiana+ - [Yices](http://github.com/SRI-CSL/yices2) from SRI  - [Z3](http://github.com/Z3Prover/z3/wiki) from Microsoft     Most functions have two variants: For instance `prove`/`proveWith`. The former uses the default solver, which is currently Z3. The latter expects you to pass it a configuration that picks the solver.@@ -95,18 +132,19 @@ SBV also allows for running multiple solvers at the same time, either picking the result of the first to complete, or getting results from all. See `proveWithAny`/`proveWithAll` and `satWithAny`/`satWithAll` functions. The function `sbvAvailableSolvers` can be used to query the available solvers at run-time. -## KnuckleDragger: Semi-automated theorem proving+## TP: Semi-automated theorem proving  While SMT solvers are quite powerful, there is a certain class of problems that they are just not well suited for. In particular, SMT solvers are not good at proofs that require induction, or those that require complex chains of reasoning. Induction is necessary to reason about any recursive algorithm, and most such proofs require carefully constructed equational steps. -SBV allows for a style of semi-automated theorem proving, called KnuckleDragger, that can be used to construct such proofs.-The documentation includes example proofs for many list functions, and even inductive proofs for the familiar insertion-and merge-sort algorithms, along with a proof that the square-root of 2 is irrational. While a proper theorem prover (such as Lean, Isabelle-etc.) is a more appropriate choice for such proofs, with some guidance (and acceptance of a much larger trusted code base!), SBV can-be used to establish correctness of various mathematical claims and algorithms that are usually beyond the scope of SMT-solvers alone. See the documentation under the `Documentation.SBV.Examples.KnuckleDragger` directory.+SBV allows for a style of semi-automated theorem proving, called TP. which can be used to construct such proofs.+The documentation includes example proofs for many list functions, and even inductive proofs for+the familiar insertion, merge, quick-sort algorithms, along with a proof that the square-root of 2 is irrational.+While a proper theorem prover (such as Lean, Isabelle etc.) is a more appropriate choice for such proofs, with some+guidance (and acceptance of a much larger trusted code base!), SBV can be used to establish correctness of various mathematical+claims and algorithms that are usually beyond the scope of SMT solvers alone. See the documentation under+the `Documentation.SBV.Examples.TP` directory.  ## Copyright, License
SBVTestSuite/GoldFiles/doctest_sanity.gold view
@@ -1,3 +1,3 @@-Total:       908; Tried:  908; Skipped:    0; Success:  908; Errors:    0; Failures    0-Examples:    819; Tried:  819; Skipped:    0; Success:  819; Errors:    0; Failures    0-Setup:        89; Tried:   89; Skipped:    0; Success:   89; Errors:    0; Failures    0+Total:       998; Tried:  998; Skipped:    0; Success:  998; Errors:    0; Failures    0+Examples:    890; Tried:  890; Skipped:    0; Success:  890; Errors:    0; Failures    0+Setup:       108; Tried:  108; Skipped:    0; Success:  108; Errors:    0; Failures    0
SBVTestSuite/GoldFiles/lambda04.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,18 +20,24 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: map :: (SInteger -> SBool) -> [SInteger] -> [SBool]-[GOOD] (define-fun-rec sbv.map_a4ae08 ((lst (Seq Int))) (Seq Bool)-                     (ite (= lst (as seq.empty (Seq Int)))-                          (as seq.empty (Seq Bool))-                          (seq.++ (seq.unit (select (lambda ((args0 Int))-                 false) (seq.nth lst 0)))-                                  (sbv.map_a4ae08 (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV Integer -> SBV Bool)_96a983e094 @(SBV [Integer] -> SBV [Bool])| :: [SInteger] -> [SBool] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Integer -> SBV Bool)_96a983e094 @(SBV [Integer] -> SBV [Bool])| ((l1_s0 (Seq Int))) (Seq Bool)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Bool))))+                                 (let ((l1_s5 (seq.unit false)))+                                 (let ((l1_s6 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s7 (- l1_s1 l1_s6)))+                                 (let ((l1_s8 (seq.extract l1_s0 l1_s6 l1_s7)))+                                 (let ((l1_s9 (|sbv.map @(SBV Integer -> SBV Bool)_96a983e094 @(SBV [Integer] -> SBV [Bool])| l1_s8)))+                                 (let ((l1_s10 (seq.++ l1_s5 l1_s9)))+                                 (let ((l1_s11 (ite l1_s3 l1_s4 l1_s10)))+                                 l1_s11)))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq Bool) (sbv.map_a4ae08 s0))+[GOOD] (define-fun s4 () (Seq Bool) (|sbv.map @(SBV Integer -> SBV Bool)_96a983e094 @(SBV [Integer] -> SBV [Bool])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda05.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,31 +20,44 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: map :: (SInteger -> SInteger) -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.map_58ac1e ((lst (Seq Int))) (Seq Int)-                     (ite (= lst (as seq.empty (Seq Int)))-                          (as seq.empty (Seq Int))-                          (seq.++ (seq.unit (select (lambda ((args0 Int))-                 (let ((args1 2))-                 (let ((args2 (+ args0 args1)))-                 args2))) (seq.nth lst 0)))-                                  (sbv.map_58ac1e (seq.extract lst 1 (- (seq.len lst) 1))))))-[GOOD] ; Firstified function: map :: (SInteger -> SInteger) -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.map_72c5bf ((lst (Seq Int))) (Seq Int)-                     (ite (= lst (as seq.empty (Seq Int)))-                          (as seq.empty (Seq Int))-                          (seq.++ (seq.unit (select (lambda ((args0 Int))-                 (let ((args1 1))-                 (let ((args2 (+ args0 args1)))-                 args2))) (seq.nth lst 0)))-                                  (sbv.map_72c5bf (seq.extract lst 1 (- (seq.len lst) 1))))))-[GOOD] ; -- NB. Skipping firstified equivalences, due to generateHOEquivs setting. [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV Integer -> SBV Integer)_aaa4562f59 @(SBV [Integer] -> SBV [Integer])| :: [SInteger] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Integer -> SBV Integer)_aaa4562f59 @(SBV [Integer] -> SBV [Integer])| ((l1_s0 (Seq Int))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s6 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (+ l1_s5 l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s7)))+                                 (let ((l1_s9 (- l1_s1 l1_s6)))+                                 (let ((l1_s10 (seq.extract l1_s0 l1_s6 l1_s9)))+                                 (let ((l1_s11 (|sbv.map @(SBV Integer -> SBV Integer)_aaa4562f59 @(SBV [Integer] -> SBV [Integer])| l1_s10)))+                                 (let ((l1_s12 (seq.++ l1_s8 l1_s11)))+                                 (let ((l1_s13 (ite l1_s3 l1_s4 l1_s12)))+                                 l1_s13))))))))))))))+[GOOD] ; |sbv.map @(SBV Integer -> SBV Integer)_6e8bf9627c @(SBV [Integer] -> SBV [Integer])| :: [SInteger] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Integer -> SBV Integer)_6e8bf9627c @(SBV [Integer] -> SBV [Integer])| ((l1_s0 (Seq Int))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s6 2))+                                 (let ((l1_s9 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (+ l1_s5 l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s7)))+                                 (let ((l1_s10 (- l1_s1 l1_s9)))+                                 (let ((l1_s11 (seq.extract l1_s0 l1_s9 l1_s10)))+                                 (let ((l1_s12 (|sbv.map @(SBV Integer -> SBV Integer)_6e8bf9627c @(SBV [Integer] -> SBV [Integer])| l1_s11)))+                                 (let ((l1_s13 (seq.++ l1_s8 l1_s12)))+                                 (let ((l1_s14 (ite l1_s3 l1_s4 l1_s13)))+                                 l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq Int) (sbv.map_58ac1e s0))-[GOOD] (define-fun s5 () (Seq Int) (sbv.map_72c5bf s4))+[GOOD] (define-fun s4 () (Seq Int) (|sbv.map @(SBV Integer -> SBV Integer)_6e8bf9627c @(SBV [Integer] -> SBV [Integer])| s0))+[GOOD] (define-fun s5 () (Seq Int) (|sbv.map @(SBV Integer -> SBV Integer)_aaa4562f59 @(SBV [Integer] -> SBV [Integer])| s4)) [GOOD] (define-fun s6 () Bool (= s1 s5)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda06.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,36 +20,43 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: map :: (SInteger -> SInteger) -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.map_066528 ((lst (Seq Int))) (Seq Int)-                     (ite (= lst (as seq.empty (Seq Int)))-                          (as seq.empty (Seq Int))-                          (seq.++ (seq.unit (select (lambda ((args0 Int))-                 (let ((args1 (* args0 args0)))-                 (let ((args2 (+ args0 args1)))-                 (let ((args3 (* args0 args1)))-                 (let ((args4 (+ args2 args3)))-                 (let ((args5 (* args1 args1)))-                 (let ((args6 (+ args4 args5)))-                 (let ((args7 (* args0 args5)))-                 (let ((args8 (+ args6 args7)))-                 (let ((args9 (* args1 args5)))-                 (let ((args10 (+ args8 args9)))-                 (let ((args11 (* args0 args9)))-                 (let ((args12 (+ args10 args11)))-                 (let ((args13 (* args5 args5)))-                 (let ((args14 (+ args12 args13)))-                 (let ((args15 (* args0 args13)))-                 (let ((args16 (+ args14 args15)))-                 (let ((args17 (* args1 args13)))-                 (let ((args18 (+ args16 args17)))-                 args18))))))))))))))))))) (seq.nth lst 0)))-                                  (sbv.map_066528 (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV Integer -> SBV Integer)_b01b78a2e9 @(SBV [Integer] -> SBV [Integer])| :: [SInteger] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Integer -> SBV Integer)_b01b78a2e9 @(SBV [Integer] -> SBV [Integer])| ((l1_s0 (Seq Int))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s25 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s6 (* l1_s5 l1_s5)))+                                 (let ((l1_s7 (+ l1_s5 l1_s6)))+                                 (let ((l1_s8 (* l1_s5 l1_s6)))+                                 (let ((l1_s9 (+ l1_s7 l1_s8)))+                                 (let ((l1_s10 (* l1_s6 l1_s6)))+                                 (let ((l1_s11 (+ l1_s9 l1_s10)))+                                 (let ((l1_s12 (* l1_s5 l1_s10)))+                                 (let ((l1_s13 (+ l1_s11 l1_s12)))+                                 (let ((l1_s14 (* l1_s6 l1_s10)))+                                 (let ((l1_s15 (+ l1_s13 l1_s14)))+                                 (let ((l1_s16 (* l1_s5 l1_s14)))+                                 (let ((l1_s17 (+ l1_s15 l1_s16)))+                                 (let ((l1_s18 (* l1_s10 l1_s10)))+                                 (let ((l1_s19 (+ l1_s17 l1_s18)))+                                 (let ((l1_s20 (* l1_s5 l1_s18)))+                                 (let ((l1_s21 (+ l1_s19 l1_s20)))+                                 (let ((l1_s22 (* l1_s6 l1_s18)))+                                 (let ((l1_s23 (+ l1_s21 l1_s22)))+                                 (let ((l1_s24 (seq.unit l1_s23)))+                                 (let ((l1_s26 (- l1_s1 l1_s25)))+                                 (let ((l1_s27 (seq.extract l1_s0 l1_s25 l1_s26)))+                                 (let ((l1_s28 (|sbv.map @(SBV Integer -> SBV Integer)_b01b78a2e9 @(SBV [Integer] -> SBV [Integer])| l1_s27)))+                                 (let ((l1_s29 (seq.++ l1_s24 l1_s28)))+                                 (let ((l1_s30 (ite l1_s3 l1_s4 l1_s29)))+                                 l1_s30))))))))))))))))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq Int) (sbv.map_066528 s0))+[GOOD] (define-fun s4 () (Seq Int) (|sbv.map @(SBV Integer -> SBV Integer)_b01b78a2e9 @(SBV [Integer] -> SBV [Integer])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda07.gold view
@@ -1,10 +1,134 @@-CAUGHT EXCEPTION-+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-option :pp.max_depth      4294967295)+[GOOD] (set-option :pp.min_alias_size 4294967295)+[GOOD] (set-option :model.inline_def  true      )+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s2 () (Seq (Seq Int)) (seq.++ (seq.unit (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5))) (seq.unit (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5) (seq.unit 6) (seq.unit 7) (seq.unit 8) (seq.unit 9) (seq.unit 10))) (seq.unit (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5) (seq.unit 6) (seq.unit 7) (seq.unit 8) (seq.unit 9) (seq.unit 10) (seq.unit 11) (seq.unit 12) (seq.unit 13) (seq.unit 14) (seq.unit 15) (seq.unit 16) (seq.unit 17) (seq.unit 18) (seq.unit 19) (seq.unit 20)))))+[GOOD] (define-fun s4 () Int 0)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (Seq Int)))+[GOOD] (declare-fun s1 () Int)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| :: (SInteger, [SInteger]) -> SInteger [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| ((l1_s0 (SBVTuple2 Int (Seq Int)))) Int+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (- l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.extract l1_s1 l1_s7 l1_s8)))+                                 (let ((l1_s10 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s5 l1_s9)))+                                 (let ((l1_s11 (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| l1_s10)))+                                 (let ((l1_s12 (+ l1_s6 l1_s11)))+                                 (let ((l1_s13 (ite l1_s4 l1_s5 l1_s12)))+                                 l1_s13))))))))))))))+[GOOD] ; |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_b97075844e @(SBV (Integer,[Integer]) -> SBV Integer)| :: (SInteger, [SInteger]) -> SInteger [Refers to: |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)|]+[GOOD] (define-fun |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_b97075844e @(SBV (Integer,[Integer]) -> SBV Integer)| ((s0 (SBVTuple2 Int (Seq Int)))) Int+                 (let ((s3 0))+                 (let ((s7 1))+                 (let ((s1 (proj_2_SBVTuple2 s0)))+                 (let ((s2 (seq.len s1)))+                 (let ((s4 (= s2 s3)))+                 (let ((s5 (proj_1_SBVTuple2 s0)))+                 (let ((s6 (seq.nth s1 s3)))+                 (let ((s8 (- s2 s7)))+                 (let ((s9 (seq.extract s1 s7 s8)))+                 (let ((s10 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) s5 s9)))+                 (let ((s11 (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| s10)))+                 (let ((s12 (+ s6 s11)))+                 (let ((s13 (ite s4 s5 s12)))+                 s13))))))))))))))+[GOOD] ; |sbv.map @(SBV [Integer] -> SBV Integer)_1b9bf3f573 @(SBV [[Integer]] -> SBV [Integer])| :: [[SInteger]] -> [SInteger] [Recursive] [Refers to: |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)|]+[GOOD] (define-fun-rec |sbv.map @(SBV [Integer] -> SBV Integer)_1b9bf3f573 @(SBV [[Integer]] -> SBV [Integer])| ((l1_s0 (Seq (Seq Int)))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s9 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s6 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s2 l1_s5)))+                                 (let ((l1_s7 (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s7)))+                                 (let ((l1_s10 (- l1_s1 l1_s9)))+                                 (let ((l1_s11 (seq.extract l1_s0 l1_s9 l1_s10)))+                                 (let ((l1_s12 (|sbv.map @(SBV [Integer] -> SBV Integer)_1b9bf3f573 @(SBV [[Integer]] -> SBV [Integer])| l1_s11)))+                                 (let ((l1_s13 (seq.++ l1_s8 l1_s12)))+                                 (let ((l1_s14 (ite l1_s3 l1_s4 l1_s13)))+                                 l1_s14)))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s3 () Bool (= s0 s2))+[GOOD] (define-fun s5 () (Seq Int) (|sbv.map @(SBV [Integer] -> SBV Integer)_1b9bf3f573 @(SBV [[Integer]] -> SBV [Integer])| s0))+[GOOD] (define-fun s6 () (SBVTuple2 Int (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) s4 s5))+[GOOD] (define-fun s7 () Int (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| s6))+[GOOD] (define-fun s8 () Bool (= s1 s7))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s3)+[GOOD] (assert s8)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s1))+[RECV] ((s1 280))+[SEND] (get-value (s0))+[RECV] ((s0 (seq.++ (seq.unit (seq.++ (seq.unit 1)+                                 (seq.unit 2)+                                 (seq.unit 3)+                                 (seq.unit 4)+                                 (seq.unit 5)))+               (seq.unit (seq.++ (seq.unit 1)+                                 (seq.unit 2)+                                 (seq.unit 3)+                                 (seq.unit 4)+                                 (seq.unit 5)+                                 (seq.unit 6)+                                 (seq.unit 7)+                                 (seq.unit 8)+                                 (seq.unit 9)+                                 (seq.unit 10)))+               (seq.unit (seq.++ (seq.unit 1)+                                 (seq.unit 2)+                                 (seq.unit 3)+                                 (seq.unit 4)+                                 (seq.unit 5)+                                 (seq.unit 6)+                                 (seq.unit 7)+                                 (seq.unit 8)+                                 (seq.unit 9)+                                 (seq.unit 10)+                                 (seq.unit 11)+                                 (seq.unit 12)+                                 (seq.unit 13)+                                 (seq.unit 14)+                                 (seq.unit 15)+                                 (seq.unit 16)+                                 (seq.unit 17)+                                 (seq.unit 18)+                                 (seq.unit 19)+                                 (seq.unit 20))))))+[SEND] (get-value (s1))+[RECV] ((s1 280))+*** Solver   : Z3+*** Exit code: ExitSuccess -*** Data.SBV.Lambda: Detected nested lambda-definitions.-***-*** SBV uses firstification to deal-with lambdas, and SMTLib's first-order nature does not allow-*** for easy translation of nested lambdas. As SMTLib gets higher-order features, SBV will eventually-*** relax this restriction. In the mean-time, please rewrite your program without using nested-lambdas-*** if possible. If this workaround isn't applicable, please report this as a use-case for further-*** possible enhancements.+RESULT:+  s0 = [[1,2,3,4,5],[1,2,3,4,5,6,7,8,9,10],[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]] :: [[Integer]]+  s1 =                                                                                       280 :: Integer
SBVTestSuite/GoldFiles/lambda08.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,20 +20,27 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: map :: (SFloat -> SFloat) -> [SFloat] -> [SFloat]-[GOOD] (define-fun-rec sbv.map_38e214 ((lst (Seq (_ FloatingPoint  8 24)))) (Seq (_ FloatingPoint  8 24))-                     (ite (= lst (as seq.empty (Seq (_ FloatingPoint  8 24))))-                          (as seq.empty (Seq (_ FloatingPoint  8 24)))-                          (seq.++ (seq.unit (select (lambda ((args0 (_ FloatingPoint  8 24)))-                 (let ((args1 ((_ to_fp 8 24) roundNearestTiesToEven (/ 1.0 1.0))))-                 (let ((args2 (fp.add roundNearestTiesToEven args0 args1)))-                 args2))) (seq.nth lst 0)))-                                  (sbv.map_38e214 (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV Float -> SBV Float)_55d10191cd @(SBV [Float] -> SBV [Float])| :: [SFloat] -> [SFloat] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Float -> SBV Float)_55d10191cd @(SBV [Float] -> SBV [Float])| ((l1_s0 (Seq (_ FloatingPoint  8 24)))) (Seq (_ FloatingPoint  8 24))+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq (_ FloatingPoint  8 24)))))+                                 (let ((l1_s6 ((_ to_fp 8 24) roundNearestTiesToEven (/ 1.0 1.0))))+                                 (let ((l1_s9 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (fp.add roundNearestTiesToEven l1_s5 l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s7)))+                                 (let ((l1_s10 (- l1_s1 l1_s9)))+                                 (let ((l1_s11 (seq.extract l1_s0 l1_s9 l1_s10)))+                                 (let ((l1_s12 (|sbv.map @(SBV Float -> SBV Float)_55d10191cd @(SBV [Float] -> SBV [Float])| l1_s11)))+                                 (let ((l1_s13 (seq.++ l1_s8 l1_s12)))+                                 (let ((l1_s14 (ite l1_s3 l1_s4 l1_s13)))+                                 l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq (_ FloatingPoint  8 24)) (sbv.map_38e214 s0))+[GOOD] (define-fun s4 () (Seq (_ FloatingPoint  8 24)) (|sbv.map @(SBV Float -> SBV Float)_55d10191cd @(SBV [Float] -> SBV [Float])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda09.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,20 +20,27 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: map :: (SInt8 -> SInt8) -> [SInt8] -> [SInt8]-[GOOD] (define-fun-rec sbv.map_f0bd1d ((lst (Seq (_ BitVec 8)))) (Seq (_ BitVec 8))-                     (ite (= lst (as seq.empty (Seq (_ BitVec 8))))-                          (as seq.empty (Seq (_ BitVec 8)))-                          (seq.++ (seq.unit (select (lambda ((args0 (_ BitVec 8)))-                 (let ((args1 #x01))-                 (let ((args2 (bvadd args0 args1)))-                 args2))) (seq.nth lst 0)))-                                  (sbv.map_f0bd1d (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV Int8 -> SBV Int8)_5111aac2ea @(SBV [Int8] -> SBV [Int8])| :: [SInt8] -> [SInt8] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Int8 -> SBV Int8)_5111aac2ea @(SBV [Int8] -> SBV [Int8])| ((l1_s0 (Seq (_ BitVec 8)))) (Seq (_ BitVec 8))+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq (_ BitVec 8)))))+                                 (let ((l1_s6 #x01))+                                 (let ((l1_s9 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (bvadd l1_s5 l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s7)))+                                 (let ((l1_s10 (- l1_s1 l1_s9)))+                                 (let ((l1_s11 (seq.extract l1_s0 l1_s9 l1_s10)))+                                 (let ((l1_s12 (|sbv.map @(SBV Int8 -> SBV Int8)_5111aac2ea @(SBV [Int8] -> SBV [Int8])| l1_s11)))+                                 (let ((l1_s13 (seq.++ l1_s8 l1_s12)))+                                 (let ((l1_s14 (ite l1_s3 l1_s4 l1_s13)))+                                 l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq (_ BitVec 8)) (sbv.map_f0bd1d s0))+[GOOD] (define-fun s4 () (Seq (_ BitVec 8)) (|sbv.map @(SBV Int8 -> SBV Int8)_5111aac2ea @(SBV [Int8] -> SBV [Int8])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda10.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,20 +20,26 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: map :: (SInteger -> SInteger) -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.map_72c5bf ((lst (Seq Int))) (Seq Int)-                     (ite (= lst (as seq.empty (Seq Int)))-                          (as seq.empty (Seq Int))-                          (seq.++ (seq.unit (select (lambda ((args0 Int))-                 (let ((args1 1))-                 (let ((args2 (+ args0 args1)))-                 args2))) (seq.nth lst 0)))-                                  (sbv.map_72c5bf (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV Integer -> SBV Integer)_aaa4562f59 @(SBV [Integer] -> SBV [Integer])| :: [SInteger] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Integer -> SBV Integer)_aaa4562f59 @(SBV [Integer] -> SBV [Integer])| ((l1_s0 (Seq Int))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s6 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (+ l1_s5 l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s7)))+                                 (let ((l1_s9 (- l1_s1 l1_s6)))+                                 (let ((l1_s10 (seq.extract l1_s0 l1_s6 l1_s9)))+                                 (let ((l1_s11 (|sbv.map @(SBV Integer -> SBV Integer)_aaa4562f59 @(SBV [Integer] -> SBV [Integer])| l1_s10)))+                                 (let ((l1_s12 (seq.++ l1_s8 l1_s11)))+                                 (let ((l1_s13 (ite l1_s3 l1_s4 l1_s12)))+                                 l1_s13)))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq Int) (sbv.map_72c5bf s0))+[GOOD] (define-fun s4 () (Seq Int) (|sbv.map @(SBV Integer -> SBV Integer)_aaa4562f59 @(SBV [Integer] -> SBV [Integer])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda11.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,20 +20,27 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: map :: (SWord8 -> SWord8) -> [SWord8] -> [SWord8]-[GOOD] (define-fun-rec sbv.map_1a14e2 ((lst (Seq (_ BitVec 8)))) (Seq (_ BitVec 8))-                     (ite (= lst (as seq.empty (Seq (_ BitVec 8))))-                          (as seq.empty (Seq (_ BitVec 8)))-                          (seq.++ (seq.unit (select (lambda ((args0 (_ BitVec 8)))-                 (let ((args1 #x01))-                 (let ((args2 (bvadd args0 args1)))-                 args2))) (seq.nth lst 0)))-                                  (sbv.map_1a14e2 (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV Word8 -> SBV Word8)_5111aac2ea @(SBV [Word8] -> SBV [Word8])| :: [SWord8] -> [SWord8] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Word8 -> SBV Word8)_5111aac2ea @(SBV [Word8] -> SBV [Word8])| ((l1_s0 (Seq (_ BitVec 8)))) (Seq (_ BitVec 8))+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq (_ BitVec 8)))))+                                 (let ((l1_s6 #x01))+                                 (let ((l1_s9 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (bvadd l1_s5 l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s7)))+                                 (let ((l1_s10 (- l1_s1 l1_s9)))+                                 (let ((l1_s11 (seq.extract l1_s0 l1_s9 l1_s10)))+                                 (let ((l1_s12 (|sbv.map @(SBV Word8 -> SBV Word8)_5111aac2ea @(SBV [Word8] -> SBV [Word8])| l1_s11)))+                                 (let ((l1_s13 (seq.++ l1_s8 l1_s12)))+                                 (let ((l1_s14 (ite l1_s3 l1_s4 l1_s13)))+                                 l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq (_ BitVec 8)) (sbv.map_1a14e2 s0))+[GOOD] (define-fun s4 () (Seq (_ BitVec 8)) (|sbv.map @(SBV Word8 -> SBV Word8)_5111aac2ea @(SBV [Word8] -> SBV [Word8])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda12.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,18 +20,26 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: map :: (SInteger -> [SInteger]) -> [SInteger] -> [[SInteger]]-[GOOD] (define-fun-rec sbv.map_0004cc ((lst (Seq Int))) (Seq (Seq Int))-                     (ite (= lst (as seq.empty (Seq Int)))-                          (as seq.empty (Seq (Seq Int)))-                          (seq.++ (seq.unit (select (lambda ((args0 Int))-         (seq.unit args0)) (seq.nth lst 0)))-                                  (sbv.map_0004cc (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV Integer -> SBV [Integer])_661d2aaa20 @(SBV [Integer] -> SBV [[Integer]])| :: [SInteger] -> [[SInteger]] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Integer -> SBV [Integer])_661d2aaa20 @(SBV [Integer] -> SBV [[Integer]])| ((l1_s0 (Seq Int))) (Seq (Seq Int))+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq (Seq Int)))))+                                 (let ((l1_s8 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s6 (seq.unit l1_s5)))+                                 (let ((l1_s7 (seq.unit l1_s6)))+                                 (let ((l1_s9 (- l1_s1 l1_s8)))+                                 (let ((l1_s10 (seq.extract l1_s0 l1_s8 l1_s9)))+                                 (let ((l1_s11 (|sbv.map @(SBV Integer -> SBV [Integer])_661d2aaa20 @(SBV [Integer] -> SBV [[Integer]])| l1_s10)))+                                 (let ((l1_s12 (seq.++ l1_s7 l1_s11)))+                                 (let ((l1_s13 (ite l1_s3 l1_s4 l1_s12)))+                                 l1_s13)))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq (Seq Int)) (sbv.map_0004cc s0))+[GOOD] (define-fun s4 () (Seq (Seq Int)) (|sbv.map @(SBV Integer -> SBV [Integer])_661d2aaa20 @(SBV [Integer] -> SBV [[Integer]])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda13.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)@@ -23,21 +23,28 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: map :: ((SInteger, SInteger) -> SInteger) -> [(SInteger, SInteger)] -> [SInteger]-[GOOD] (define-fun-rec sbv.map_cb21ff ((lst (Seq (SBVTuple2 Int Int)))) (Seq Int)-                     (ite (= lst (as seq.empty (Seq (SBVTuple2 Int Int))))-                          (as seq.empty (Seq Int))-                          (seq.++ (seq.unit (select (lambda ((args0 (SBVTuple2 Int Int)))-                 (let ((args1 (proj_1_SBVTuple2 args0)))-                 (let ((args2 (proj_2_SBVTuple2 args0)))-                 (let ((args3 (+ args1 args2)))-                 args3)))) (seq.nth lst 0)))-                                  (sbv.map_cb21ff (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV [(Integer,Integer)] -> SBV [Integer])| :: [(SInteger, SInteger)] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV [(Integer,Integer)] -> SBV [Integer])| ((l1_s0 (Seq (SBVTuple2 Int Int)))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s6 (proj_1_SBVTuple2 l1_s5)))+                                 (let ((l1_s7 (proj_2_SBVTuple2 l1_s5)))+                                 (let ((l1_s8 (+ l1_s6 l1_s7)))+                                 (let ((l1_s9 (seq.unit l1_s8)))+                                 (let ((l1_s11 (- l1_s1 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s0 l1_s10 l1_s11)))+                                 (let ((l1_s13 (|sbv.map @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV [(Integer,Integer)] -> SBV [Integer])| l1_s12)))+                                 (let ((l1_s14 (seq.++ l1_s9 l1_s13)))+                                 (let ((l1_s15 (ite l1_s3 l1_s4 l1_s14)))+                                 l1_s15)))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq Int) (sbv.map_cb21ff s0))+[GOOD] (define-fun s4 () (Seq Int) (|sbv.map @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV [(Integer,Integer)] -> SBV [Integer])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda14.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5)))@@ -21,22 +24,41 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: zipWith :: (SInteger -> SInteger -> SInteger) -> [SInteger] -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.zipWith_736833 ((lst1 (Seq Int)) (lst2 (Seq Int))) (Seq Int)-                      (ite (or (= lst1 (as seq.empty (Seq Int))) (= lst2 (as seq.empty (Seq Int))))-                           (as seq.empty (Seq Int))-                           (seq.++ (seq.unit (select (lambda ((args0 Int) (args1 Int))-         (+ args0 args1)) (seq.nth lst1 0) (seq.nth lst2 0))) (sbv.zipWith_736833 (seq.extract lst1 1 (- (seq.len lst1) 1)) (seq.extract lst2 1 (- (seq.len lst2) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| :: ([SInteger], [SInteger]) -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| ((l1_s0 (SBVTuple2 (Seq Int) (Seq Int)))) (Seq Int)+                                 (let ((l1_s3 0))+                                 (let ((l1_s9 (as seq.empty (Seq Int))))+                                 (let ((l1_s14 1))+                                 (let ((l1_s1 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.len l1_s5)))+                                 (let ((l1_s7 (= l1_s3 l1_s6)))+                                 (let ((l1_s8 (or l1_s4 l1_s7)))+                                 (let ((l1_s10 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s11 (seq.nth l1_s5 l1_s3)))+                                 (let ((l1_s12 (+ l1_s10 l1_s11)))+                                 (let ((l1_s13 (seq.unit l1_s12)))+                                 (let ((l1_s15 (- l1_s2 l1_s14)))+                                 (let ((l1_s16 (seq.extract l1_s1 l1_s14 l1_s15)))+                                 (let ((l1_s17 (- l1_s6 l1_s14)))+                                 (let ((l1_s18 (seq.extract l1_s5 l1_s14 l1_s17)))+                                 (let ((l1_s19 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) l1_s16 l1_s18)))+                                 (let ((l1_s20 (|sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| l1_s19)))+                                 (let ((l1_s21 (seq.++ l1_s13 l1_s20)))+                                 (let ((l1_s22 (ite l1_s8 l1_s9 l1_s21)))+                                 l1_s22))))))))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s5 () (Seq Int) (sbv.zipWith_736833 s4 s0))-[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s5 () (SBVTuple2 (Seq Int) (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) s4 s0))+[GOOD] (define-fun s6 () (Seq Int) (|sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| s5))+[GOOD] (define-fun s7 () Bool (= s1 s6)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s6)+[GOOD] (assert s7) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda15.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5)))@@ -21,22 +24,32 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: foldl :: (SInteger -> SInteger -> SInteger) -> SInteger -> [SInteger] -> SInteger-[GOOD] (define-fun-rec sbv.foldl_a12137 ((base Int) (lst (Seq Int))) Int-                       (ite (= lst (as seq.empty (Seq Int)))-                            base-                            (sbv.foldl_a12137 (select (lambda ((args0 Int) (args1 Int))-         (+ args0 args1)) base (seq.nth lst 0)) (seq.extract lst 1 (- (seq.len lst) 1))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldl @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| :: (SInteger, [SInteger]) -> SInteger [Recursive]+[GOOD] (define-fun-rec |sbv.foldl @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| ((l1_s0 (SBVTuple2 Int (Seq Int)))) Int+                                 (let ((l1_s3 0))+                                 (let ((l1_s8 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s7 (+ l1_s5 l1_s6)))+                                 (let ((l1_s9 (- l1_s2 l1_s8)))+                                 (let ((l1_s10 (seq.extract l1_s1 l1_s8 l1_s9)))+                                 (let ((l1_s11 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s7 l1_s10)))+                                 (let ((l1_s12 (|sbv.foldl @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| l1_s11)))+                                 (let ((l1_s13 (ite l1_s4 l1_s5 l1_s12)))+                                 l1_s13)))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s5 () Int (sbv.foldl_a12137 s4 s0))-[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s5 () (SBVTuple2 Int (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) s4 s0))+[GOOD] (define-fun s6 () Int (|sbv.foldl @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| s5))+[GOOD] (define-fun s7 () Bool (= s1 s6)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s6)+[GOOD] (assert s7) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda16.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5)))@@ -21,22 +24,32 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: foldl :: (SInteger -> SInteger -> SInteger) -> SInteger -> [SInteger] -> SInteger-[GOOD] (define-fun-rec sbv.foldl_33c9b2 ((base Int) (lst (Seq Int))) Int-                       (ite (= lst (as seq.empty (Seq Int)))-                            base-                            (sbv.foldl_33c9b2 (select (lambda ((args0 Int) (args1 Int))-         (* args0 args1)) base (seq.nth lst 0)) (seq.extract lst 1 (- (seq.len lst) 1))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldl @(SBV (Integer,Integer) -> SBV Integer)_dd270bb7de @(SBV (Integer,[Integer]) -> SBV Integer)| :: (SInteger, [SInteger]) -> SInteger [Recursive]+[GOOD] (define-fun-rec |sbv.foldl @(SBV (Integer,Integer) -> SBV Integer)_dd270bb7de @(SBV (Integer,[Integer]) -> SBV Integer)| ((l1_s0 (SBVTuple2 Int (Seq Int)))) Int+                                 (let ((l1_s3 0))+                                 (let ((l1_s8 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s7 (* l1_s5 l1_s6)))+                                 (let ((l1_s9 (- l1_s2 l1_s8)))+                                 (let ((l1_s10 (seq.extract l1_s1 l1_s8 l1_s9)))+                                 (let ((l1_s11 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s7 l1_s10)))+                                 (let ((l1_s12 (|sbv.foldl @(SBV (Integer,Integer) -> SBV Integer)_dd270bb7de @(SBV (Integer,[Integer]) -> SBV Integer)| l1_s11)))+                                 (let ((l1_s13 (ite l1_s4 l1_s5 l1_s12)))+                                 l1_s13)))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s5 () Int (sbv.foldl_33c9b2 s4 s0))-[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s5 () (SBVTuple2 Int (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) s4 s0))+[GOOD] (define-fun s6 () Int (|sbv.foldl @(SBV (Integer,Integer) -> SBV Integer)_dd270bb7de @(SBV (Integer,[Integer]) -> SBV Integer)| s5))+[GOOD] (define-fun s7 () Bool (= s1 s6)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s6)+[GOOD] (assert s7) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda17.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5)))@@ -21,24 +24,33 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: foldl :: ([SInteger] -> SInteger -> [SInteger]) -> [SInteger] -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.foldl_c4d425 ((base (Seq Int)) (lst (Seq Int))) (Seq Int)-                       (ite (= lst (as seq.empty (Seq Int)))-                            base-                            (sbv.foldl_c4d425 (select (lambda ((args0 (Seq Int)) (args1 Int))-                 (let ((args2 (seq.unit args1)))-                 (let ((args3 (seq.++ args2 args0)))-                 args3))) base (seq.nth lst 0)) (seq.extract lst 1 (- (seq.len lst) 1))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldl @(SBV ([Integer],Integer) -> SBV [Integer])_2d6951daf1 @(SBV ([Integer],[Integer]) -> SBV [Integer])| :: ([SInteger], [SInteger]) -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.foldl @(SBV ([Integer],Integer) -> SBV [Integer])_2d6951daf1 @(SBV ([Integer],[Integer]) -> SBV [Integer])| ((l1_s0 (SBVTuple2 (Seq Int) (Seq Int)))) (Seq Int)+                                 (let ((l1_s3 0))+                                 (let ((l1_s9 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s7 (seq.unit l1_s6)))+                                 (let ((l1_s8 (seq.++ l1_s7 l1_s5)))+                                 (let ((l1_s10 (- l1_s2 l1_s9)))+                                 (let ((l1_s11 (seq.extract l1_s1 l1_s9 l1_s10)))+                                 (let ((l1_s12 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) l1_s8 l1_s11)))+                                 (let ((l1_s13 (|sbv.foldl @(SBV ([Integer],Integer) -> SBV [Integer])_2d6951daf1 @(SBV ([Integer],[Integer]) -> SBV [Integer])| l1_s12)))+                                 (let ((l1_s14 (ite l1_s4 l1_s5 l1_s13)))+                                 l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s5 () (Seq Int) (sbv.foldl_c4d425 s4 s0))-[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s5 () (SBVTuple2 (Seq Int) (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) s4 s0))+[GOOD] (define-fun s6 () (Seq Int) (|sbv.foldl @(SBV ([Integer],Integer) -> SBV [Integer])_2d6951daf1 @(SBV ([Integer],[Integer]) -> SBV [Integer])| s5))+[GOOD] (define-fun s7 () Bool (= s1 s6)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s6)+[GOOD] (assert s7) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda18.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)@@ -25,32 +25,58 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: zip :: [SInteger] -> [SInteger] -> [(SInteger, SInteger)]-[GOOD] (define-fun-rec sbv.zip_88576a ((lst1 (Seq Int)) (lst2 (Seq Int))) (Seq (SBVTuple2 Int Int))-                      (ite (or (= lst1 (as seq.empty (Seq Int))) (= lst2 (as seq.empty (Seq Int))))-                           (as seq.empty (Seq (SBVTuple2 Int Int)))-                           (seq.++ (seq.unit ((as mkSBVTuple2 (SBVTuple2 Int Int)) (seq.nth lst1 0) (seq.nth lst2 0))) (sbv.zip_88576a (seq.extract lst1 1 (- (seq.len lst1) 1)) (seq.extract lst2 1 (- (seq.len lst2) 1))))))-[GOOD] ; Firstified function: foldl :: (SInteger -> (SInteger, SInteger) -> SInteger) -> SInteger -> [(SInteger, SInteger)] -> SInteger-[GOOD] (define-fun-rec sbv.foldl_7f1bfe ((base Int) (lst (Seq (SBVTuple2 Int Int)))) Int-                       (ite (= lst (as seq.empty (Seq (SBVTuple2 Int Int))))-                            base-                            (sbv.foldl_7f1bfe (select (lambda ((args0 Int) (args1 (SBVTuple2 Int Int)))-                 (let ((args2 (proj_1_SBVTuple2 args1)))-                 (let ((args3 (+ args0 args2)))-                 (let ((args4 (proj_2_SBVTuple2 args1)))-                 (let ((args5 (+ args3 args4)))-                 args5))))) base (seq.nth lst 0)) (seq.extract lst 1 (- (seq.len lst) 1))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| :: [SInteger] -> [SInteger] -> [(SInteger, SInteger)] [Recursive]+[GOOD] (define-fun-rec |sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| ((l1_s0 (Seq Int)) (l1_s1 (Seq Int))) (Seq (SBVTuple2 Int Int))+                                 (let ((l1_s3 0))+                                 (let ((l1_s8 (as seq.empty (Seq (SBVTuple2 Int Int)))))+                                 (let ((l1_s13 1))+                                 (let ((l1_s2 (seq.len l1_s0)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (seq.len l1_s1)))+                                 (let ((l1_s6 (= l1_s3 l1_s5)))+                                 (let ((l1_s7 (or l1_s4 l1_s6)))+                                 (let ((l1_s9 (seq.nth l1_s0 l1_s3)))+                                 (let ((l1_s10 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s11 ((as mkSBVTuple2 (SBVTuple2 Int Int)) l1_s9 l1_s10)))+                                 (let ((l1_s12 (seq.unit l1_s11)))+                                 (let ((l1_s14 (- l1_s2 l1_s13)))+                                 (let ((l1_s15 (seq.extract l1_s0 l1_s13 l1_s14)))+                                 (let ((l1_s16 (- l1_s5 l1_s13)))+                                 (let ((l1_s17 (seq.extract l1_s1 l1_s13 l1_s16)))+                                 (let ((l1_s18 (|sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| l1_s15 l1_s17)))+                                 (let ((l1_s19 (seq.++ l1_s12 l1_s18)))+                                 (let ((l1_s20 (ite l1_s7 l1_s8 l1_s19)))+                                 l1_s20))))))))))))))))))))+[GOOD] ; |sbv.foldl @(SBV (Integer,(Integer,Integer)) -> SBV Integer)_f29a298542 @(SBV (Integer,[(Integer,Integer)]) -> SBV Integer)| :: (SInteger, [(SInteger, SInteger)]) -> SInteger [Recursive]+[GOOD] (define-fun-rec |sbv.foldl @(SBV (Integer,(Integer,Integer)) -> SBV Integer)_f29a298542 @(SBV (Integer,[(Integer,Integer)]) -> SBV Integer)| ((l1_s0 (SBVTuple2 Int (Seq (SBVTuple2 Int Int))))) Int+                                 (let ((l1_s3 0))+                                 (let ((l1_s11 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s7 (proj_1_SBVTuple2 l1_s6)))+                                 (let ((l1_s8 (+ l1_s5 l1_s7)))+                                 (let ((l1_s9 (proj_2_SBVTuple2 l1_s6)))+                                 (let ((l1_s10 (+ l1_s8 l1_s9)))+                                 (let ((l1_s12 (- l1_s2 l1_s11)))+                                 (let ((l1_s13 (seq.extract l1_s1 l1_s11 l1_s12)))+                                 (let ((l1_s14 ((as mkSBVTuple2 (SBVTuple2 Int (Seq (SBVTuple2 Int Int)))) l1_s10 l1_s13)))+                                 (let ((l1_s15 (|sbv.foldl @(SBV (Integer,(Integer,Integer)) -> SBV Integer)_f29a298542 @(SBV (Integer,[(Integer,Integer)]) -> SBV Integer)| l1_s14)))+                                 (let ((l1_s16 (ite l1_s4 l1_s5 l1_s15)))+                                 l1_s16))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s6 () (Seq (SBVTuple2 Int Int)) (sbv.zip_88576a s5 s0))-[GOOD] (define-fun s7 () Int (sbv.foldl_7f1bfe s4 s6))-[GOOD] (define-fun s8 () Bool (= s1 s7))+[GOOD] (define-fun s6 () (Seq (SBVTuple2 Int Int)) (|sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| s5 s0))+[GOOD] (define-fun s7 () (SBVTuple2 Int (Seq (SBVTuple2 Int Int))) ((as mkSBVTuple2 (SBVTuple2 Int (Seq (SBVTuple2 Int Int)))) s4 s6))+[GOOD] (define-fun s8 () Int (|sbv.foldl @(SBV (Integer,(Integer,Integer)) -> SBV Integer)_f29a298542 @(SBV (Integer,[(Integer,Integer)]) -> SBV Integer)| s7))+[GOOD] (define-fun s9 () Bool (= s1 s8)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s8)+[GOOD] (assert s9) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda19.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5)))@@ -21,22 +24,32 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: foldr :: (SInteger -> SInteger -> SInteger) -> SInteger -> [SInteger] -> SInteger-[GOOD] (define-fun-rec sbv.foldr_5cb25c ((base Int) (lst (Seq Int))) Int-                       (ite (= lst (as seq.empty (Seq Int)))-                            base-                            (select (lambda ((args0 Int) (args1 Int))-         (+ args0 args1)) (seq.nth lst 0) (sbv.foldr_5cb25c base (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| :: (SInteger, [SInteger]) -> SInteger [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| ((l1_s0 (SBVTuple2 Int (Seq Int)))) Int+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (- l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.extract l1_s1 l1_s7 l1_s8)))+                                 (let ((l1_s10 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s5 l1_s9)))+                                 (let ((l1_s11 (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| l1_s10)))+                                 (let ((l1_s12 (+ l1_s6 l1_s11)))+                                 (let ((l1_s13 (ite l1_s4 l1_s5 l1_s12)))+                                 l1_s13)))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s5 () Int (sbv.foldr_5cb25c s4 s0))-[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s5 () (SBVTuple2 Int (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) s4 s0))+[GOOD] (define-fun s6 () Int (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| s5))+[GOOD] (define-fun s7 () Bool (= s1 s6)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s6)+[GOOD] (assert s7) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda20.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5)))@@ -21,22 +24,32 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: foldr :: (SInteger -> SInteger -> SInteger) -> SInteger -> [SInteger] -> SInteger-[GOOD] (define-fun-rec sbv.foldr_e5d95a ((base Int) (lst (Seq Int))) Int-                       (ite (= lst (as seq.empty (Seq Int)))-                            base-                            (select (lambda ((args0 Int) (args1 Int))-         (* args0 args1)) (seq.nth lst 0) (sbv.foldr_e5d95a base (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_dd270bb7de @(SBV (Integer,[Integer]) -> SBV Integer)| :: (SInteger, [SInteger]) -> SInteger [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_dd270bb7de @(SBV (Integer,[Integer]) -> SBV Integer)| ((l1_s0 (SBVTuple2 Int (Seq Int)))) Int+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (- l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.extract l1_s1 l1_s7 l1_s8)))+                                 (let ((l1_s10 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s5 l1_s9)))+                                 (let ((l1_s11 (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_dd270bb7de @(SBV (Integer,[Integer]) -> SBV Integer)| l1_s10)))+                                 (let ((l1_s12 (* l1_s6 l1_s11)))+                                 (let ((l1_s13 (ite l1_s4 l1_s5 l1_s12)))+                                 l1_s13)))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s5 () Int (sbv.foldr_e5d95a s4 s0))-[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s5 () (SBVTuple2 Int (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) s4 s0))+[GOOD] (define-fun s6 () Int (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_dd270bb7de @(SBV (Integer,[Integer]) -> SBV Integer)| s5))+[GOOD] (define-fun s7 () Bool (= s1 s6)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s6)+[GOOD] (assert s7) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda21.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5)))@@ -21,24 +24,33 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: foldr :: (SInteger -> [SInteger] -> [SInteger]) -> [SInteger] -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.foldr_3ea6b3 ((base (Seq Int)) (lst (Seq Int))) (Seq Int)-                       (ite (= lst (as seq.empty (Seq Int)))-                            base-                            (select (lambda ((args0 Int) (args1 (Seq Int)))-                 (let ((args2 (seq.unit args0)))-                 (let ((args3 (seq.++ args1 args2)))-                 args3))) (seq.nth lst 0) (sbv.foldr_3ea6b3 base (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldr @(SBV (Integer,[Integer]) -> SBV [Integer])_5c3e05abf3 @(SBV ([Integer],[Integer]) -> SBV [Integer])| :: ([SInteger], [SInteger]) -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,[Integer]) -> SBV [Integer])_5c3e05abf3 @(SBV ([Integer],[Integer]) -> SBV [Integer])| ((l1_s0 (SBVTuple2 (Seq Int) (Seq Int)))) (Seq Int)+                                 (let ((l1_s3 0))+                                 (let ((l1_s6 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s7 (- l1_s2 l1_s6)))+                                 (let ((l1_s8 (seq.extract l1_s1 l1_s6 l1_s7)))+                                 (let ((l1_s9 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) l1_s5 l1_s8)))+                                 (let ((l1_s10 (|sbv.foldr @(SBV (Integer,[Integer]) -> SBV [Integer])_5c3e05abf3 @(SBV ([Integer],[Integer]) -> SBV [Integer])| l1_s9)))+                                 (let ((l1_s11 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s12 (seq.unit l1_s11)))+                                 (let ((l1_s13 (seq.++ l1_s10 l1_s12)))+                                 (let ((l1_s14 (ite l1_s4 l1_s5 l1_s13)))+                                 l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s5 () (Seq Int) (sbv.foldr_3ea6b3 s4 s0))-[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s5 () (SBVTuple2 (Seq Int) (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) s4 s0))+[GOOD] (define-fun s6 () (Seq Int) (|sbv.foldr @(SBV (Integer,[Integer]) -> SBV [Integer])_5c3e05abf3 @(SBV ([Integer],[Integer]) -> SBV [Integer])| s5))+[GOOD] (define-fun s7 () Bool (= s1 s6)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s6)+[GOOD] (assert s7) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda22.gold view
@@ -25,17 +25,33 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: zip :: [SInteger] -> [SInteger] -> [(SInteger, SInteger)]-[GOOD] (define-fun-rec sbv.zip_88576a ((lst1 (Seq Int)) (lst2 (Seq Int))) (Seq (SBVTuple2 Int Int))-                      (ite (or (= lst1 (as seq.empty (Seq Int))) (= lst2 (as seq.empty (Seq Int))))-                           (as seq.empty (Seq (SBVTuple2 Int Int)))-                           (seq.++ (seq.unit ((as mkSBVTuple2 (SBVTuple2 Int Int)) (seq.nth lst1 0) (seq.nth lst2 0))) (sbv.zip_88576a (seq.extract lst1 1 (- (seq.len lst1) 1)) (seq.extract lst2 1 (- (seq.len lst2) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| :: [SInteger] -> [SInteger] -> [(SInteger, SInteger)] [Recursive]+[GOOD] (define-fun-rec |sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| ((l1_s0 (Seq Int)) (l1_s1 (Seq Int))) (Seq (SBVTuple2 Int Int))+                                 (let ((l1_s3 0))+                                 (let ((l1_s8 (as seq.empty (Seq (SBVTuple2 Int Int)))))+                                 (let ((l1_s13 1))+                                 (let ((l1_s2 (seq.len l1_s0)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (seq.len l1_s1)))+                                 (let ((l1_s6 (= l1_s3 l1_s5)))+                                 (let ((l1_s7 (or l1_s4 l1_s6)))+                                 (let ((l1_s9 (seq.nth l1_s0 l1_s3)))+                                 (let ((l1_s10 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s11 ((as mkSBVTuple2 (SBVTuple2 Int Int)) l1_s9 l1_s10)))+                                 (let ((l1_s12 (seq.unit l1_s11)))+                                 (let ((l1_s14 (- l1_s2 l1_s13)))+                                 (let ((l1_s15 (seq.extract l1_s0 l1_s13 l1_s14)))+                                 (let ((l1_s16 (- l1_s5 l1_s13)))+                                 (let ((l1_s17 (seq.extract l1_s1 l1_s13 l1_s16)))+                                 (let ((l1_s18 (|sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| l1_s15 l1_s17)))+                                 (let ((l1_s19 (seq.++ l1_s12 l1_s18)))+                                 (let ((l1_s20 (ite l1_s7 l1_s8 l1_s19)))+                                 l1_s20)))))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s4 () Bool (= s0 s3)) [GOOD] (define-fun s6 () Bool (= s1 s5))-[GOOD] (define-fun s7 () (Seq (SBVTuple2 Int Int)) (sbv.zip_88576a s0 s1))+[GOOD] (define-fun s7 () (Seq (SBVTuple2 Int Int)) (|sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| s0 s1)) [GOOD] (define-fun s8 () Bool (= s2 s7)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda23.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)@@ -26,41 +26,76 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: zip :: [SInteger] -> [SInteger] -> [(SInteger, SInteger)]-[GOOD] (define-fun-rec sbv.zip_88576a ((lst1 (Seq Int)) (lst2 (Seq Int))) (Seq (SBVTuple2 Int Int))-                      (ite (or (= lst1 (as seq.empty (Seq Int))) (= lst2 (as seq.empty (Seq Int))))-                           (as seq.empty (Seq (SBVTuple2 Int Int)))-                           (seq.++ (seq.unit ((as mkSBVTuple2 (SBVTuple2 Int Int)) (seq.nth lst1 0) (seq.nth lst2 0))) (sbv.zip_88576a (seq.extract lst1 1 (- (seq.len lst1) 1)) (seq.extract lst2 1 (- (seq.len lst2) 1))))))-[GOOD] ; Firstified function: map :: ((SInteger, SInteger) -> SInteger) -> [(SInteger, SInteger)] -> [SInteger]-[GOOD] (define-fun-rec sbv.map_cb21ff ((lst (Seq (SBVTuple2 Int Int)))) (Seq Int)-                     (ite (= lst (as seq.empty (Seq (SBVTuple2 Int Int))))-                          (as seq.empty (Seq Int))-                          (seq.++ (seq.unit (select (lambda ((args0 (SBVTuple2 Int Int)))-                 (let ((args1 (proj_1_SBVTuple2 args0)))-                 (let ((args2 (proj_2_SBVTuple2 args0)))-                 (let ((args3 (+ args1 args2)))-                 args3)))) (seq.nth lst 0)))-                                  (sbv.map_cb21ff (seq.extract lst 1 (- (seq.len lst) 1))))))-[GOOD] ; Firstified function: foldr :: (SInteger -> SInteger -> SInteger) -> SInteger -> [SInteger] -> SInteger-[GOOD] (define-fun-rec sbv.foldr_5cb25c ((base Int) (lst (Seq Int))) Int-                       (ite (= lst (as seq.empty (Seq Int)))-                            base-                            (select (lambda ((args0 Int) (args1 Int))-         (+ args0 args1)) (seq.nth lst 0) (sbv.foldr_5cb25c base (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| :: [SInteger] -> [SInteger] -> [(SInteger, SInteger)] [Recursive]+[GOOD] (define-fun-rec |sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| ((l1_s0 (Seq Int)) (l1_s1 (Seq Int))) (Seq (SBVTuple2 Int Int))+                                 (let ((l1_s3 0))+                                 (let ((l1_s8 (as seq.empty (Seq (SBVTuple2 Int Int)))))+                                 (let ((l1_s13 1))+                                 (let ((l1_s2 (seq.len l1_s0)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (seq.len l1_s1)))+                                 (let ((l1_s6 (= l1_s3 l1_s5)))+                                 (let ((l1_s7 (or l1_s4 l1_s6)))+                                 (let ((l1_s9 (seq.nth l1_s0 l1_s3)))+                                 (let ((l1_s10 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s11 ((as mkSBVTuple2 (SBVTuple2 Int Int)) l1_s9 l1_s10)))+                                 (let ((l1_s12 (seq.unit l1_s11)))+                                 (let ((l1_s14 (- l1_s2 l1_s13)))+                                 (let ((l1_s15 (seq.extract l1_s0 l1_s13 l1_s14)))+                                 (let ((l1_s16 (- l1_s5 l1_s13)))+                                 (let ((l1_s17 (seq.extract l1_s1 l1_s13 l1_s16)))+                                 (let ((l1_s18 (|sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| l1_s15 l1_s17)))+                                 (let ((l1_s19 (seq.++ l1_s12 l1_s18)))+                                 (let ((l1_s20 (ite l1_s7 l1_s8 l1_s19)))+                                 l1_s20))))))))))))))))))))+[GOOD] ; |sbv.map @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV [(Integer,Integer)] -> SBV [Integer])| :: [(SInteger, SInteger)] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV [(Integer,Integer)] -> SBV [Integer])| ((l1_s0 (Seq (SBVTuple2 Int Int)))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s6 (proj_1_SBVTuple2 l1_s5)))+                                 (let ((l1_s7 (proj_2_SBVTuple2 l1_s5)))+                                 (let ((l1_s8 (+ l1_s6 l1_s7)))+                                 (let ((l1_s9 (seq.unit l1_s8)))+                                 (let ((l1_s11 (- l1_s1 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s0 l1_s10 l1_s11)))+                                 (let ((l1_s13 (|sbv.map @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV [(Integer,Integer)] -> SBV [Integer])| l1_s12)))+                                 (let ((l1_s14 (seq.++ l1_s9 l1_s13)))+                                 (let ((l1_s15 (ite l1_s3 l1_s4 l1_s14)))+                                 l1_s15))))))))))))))))+[GOOD] ; |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| :: (SInteger, [SInteger]) -> SInteger [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| ((l1_s0 (SBVTuple2 Int (Seq Int)))) Int+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (- l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.extract l1_s1 l1_s7 l1_s8)))+                                 (let ((l1_s10 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s5 l1_s9)))+                                 (let ((l1_s11 (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| l1_s10)))+                                 (let ((l1_s12 (+ l1_s6 l1_s11)))+                                 (let ((l1_s13 (ite l1_s4 l1_s5 l1_s12)))+                                 l1_s13)))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s4 () Bool (= s0 s3)) [GOOD] (define-fun s6 () Bool (= s1 s5))-[GOOD] (define-fun s8 () (Seq (SBVTuple2 Int Int)) (sbv.zip_88576a s0 s1))-[GOOD] (define-fun s9 () (Seq Int) (sbv.map_cb21ff s8))-[GOOD] (define-fun s10 () Int (sbv.foldr_5cb25c s7 s9))-[GOOD] (define-fun s11 () Bool (= s2 s10))+[GOOD] (define-fun s8 () (Seq (SBVTuple2 Int Int)) (|sbv.zip @(SBV [Integer] -> SBV [Integer] -> SBV [(Integer,Integer)])| s0 s1))+[GOOD] (define-fun s9 () (Seq Int) (|sbv.map @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV [(Integer,Integer)] -> SBV [Integer])| s8))+[GOOD] (define-fun s10 () (SBVTuple2 Int (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) s7 s9))+[GOOD] (define-fun s11 () Int (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| s10))+[GOOD] (define-fun s12 () Bool (= s2 s11)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s4) [GOOD] (assert s6)-[GOOD] (assert s11)+[GOOD] (assert s12) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s2))
SBVTestSuite/GoldFiles/lambda24.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s3 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5) (seq.unit 6) (seq.unit 7) (seq.unit 8) (seq.unit 9) (seq.unit 10)))@@ -22,24 +25,43 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: zipWith :: (SInteger -> SInteger -> SInteger) -> [SInteger] -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.zipWith_736833 ((lst1 (Seq Int)) (lst2 (Seq Int))) (Seq Int)-                      (ite (or (= lst1 (as seq.empty (Seq Int))) (= lst2 (as seq.empty (Seq Int))))-                           (as seq.empty (Seq Int))-                           (seq.++ (seq.unit (select (lambda ((args0 Int) (args1 Int))-         (+ args0 args1)) (seq.nth lst1 0) (seq.nth lst2 0))) (sbv.zipWith_736833 (seq.extract lst1 1 (- (seq.len lst1) 1)) (seq.extract lst2 1 (- (seq.len lst2) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| :: ([SInteger], [SInteger]) -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| ((l1_s0 (SBVTuple2 (Seq Int) (Seq Int)))) (Seq Int)+                                 (let ((l1_s3 0))+                                 (let ((l1_s9 (as seq.empty (Seq Int))))+                                 (let ((l1_s14 1))+                                 (let ((l1_s1 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.len l1_s5)))+                                 (let ((l1_s7 (= l1_s3 l1_s6)))+                                 (let ((l1_s8 (or l1_s4 l1_s7)))+                                 (let ((l1_s10 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s11 (seq.nth l1_s5 l1_s3)))+                                 (let ((l1_s12 (+ l1_s10 l1_s11)))+                                 (let ((l1_s13 (seq.unit l1_s12)))+                                 (let ((l1_s15 (- l1_s2 l1_s14)))+                                 (let ((l1_s16 (seq.extract l1_s1 l1_s14 l1_s15)))+                                 (let ((l1_s17 (- l1_s6 l1_s14)))+                                 (let ((l1_s18 (seq.extract l1_s5 l1_s14 l1_s17)))+                                 (let ((l1_s19 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) l1_s16 l1_s18)))+                                 (let ((l1_s20 (|sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| l1_s19)))+                                 (let ((l1_s21 (seq.++ l1_s13 l1_s20)))+                                 (let ((l1_s22 (ite l1_s8 l1_s9 l1_s21)))+                                 l1_s22))))))))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s4 () Bool (= s0 s3)) [GOOD] (define-fun s6 () Bool (= s1 s5))-[GOOD] (define-fun s7 () (Seq Int) (sbv.zipWith_736833 s0 s1))-[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s7 () (SBVTuple2 (Seq Int) (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) s0 s1))+[GOOD] (define-fun s8 () (Seq Int) (|sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| s7))+[GOOD] (define-fun s9 () Bool (= s2 s8)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s4) [GOOD] (assert s6)-[GOOD] (assert s8)+[GOOD] (assert s9) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s2))
SBVTestSuite/GoldFiles/lambda25.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s3 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5) (seq.unit 6) (seq.unit 7) (seq.unit 8) (seq.unit 9) (seq.unit 10)))@@ -23,31 +26,61 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: zipWith :: (SInteger -> SInteger -> SInteger) -> [SInteger] -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.zipWith_736833 ((lst1 (Seq Int)) (lst2 (Seq Int))) (Seq Int)-                      (ite (or (= lst1 (as seq.empty (Seq Int))) (= lst2 (as seq.empty (Seq Int))))-                           (as seq.empty (Seq Int))-                           (seq.++ (seq.unit (select (lambda ((args0 Int) (args1 Int))-         (+ args0 args1)) (seq.nth lst1 0) (seq.nth lst2 0))) (sbv.zipWith_736833 (seq.extract lst1 1 (- (seq.len lst1) 1)) (seq.extract lst2 1 (- (seq.len lst2) 1))))))-[GOOD] ; Firstified function: foldr :: (SInteger -> SInteger -> SInteger) -> SInteger -> [SInteger] -> SInteger-[GOOD] (define-fun-rec sbv.foldr_5cb25c ((base Int) (lst (Seq Int))) Int-                       (ite (= lst (as seq.empty (Seq Int)))-                            base-                            (select (lambda ((args0 Int) (args1 Int))-         (+ args0 args1)) (seq.nth lst 0) (sbv.foldr_5cb25c base (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| :: ([SInteger], [SInteger]) -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| ((l1_s0 (SBVTuple2 (Seq Int) (Seq Int)))) (Seq Int)+                                 (let ((l1_s3 0))+                                 (let ((l1_s9 (as seq.empty (Seq Int))))+                                 (let ((l1_s14 1))+                                 (let ((l1_s1 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.len l1_s5)))+                                 (let ((l1_s7 (= l1_s3 l1_s6)))+                                 (let ((l1_s8 (or l1_s4 l1_s7)))+                                 (let ((l1_s10 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s11 (seq.nth l1_s5 l1_s3)))+                                 (let ((l1_s12 (+ l1_s10 l1_s11)))+                                 (let ((l1_s13 (seq.unit l1_s12)))+                                 (let ((l1_s15 (- l1_s2 l1_s14)))+                                 (let ((l1_s16 (seq.extract l1_s1 l1_s14 l1_s15)))+                                 (let ((l1_s17 (- l1_s6 l1_s14)))+                                 (let ((l1_s18 (seq.extract l1_s5 l1_s14 l1_s17)))+                                 (let ((l1_s19 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) l1_s16 l1_s18)))+                                 (let ((l1_s20 (|sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| l1_s19)))+                                 (let ((l1_s21 (seq.++ l1_s13 l1_s20)))+                                 (let ((l1_s22 (ite l1_s8 l1_s9 l1_s21)))+                                 l1_s22)))))))))))))))))))))))+[GOOD] ; |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| :: (SInteger, [SInteger]) -> SInteger [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| ((l1_s0 (SBVTuple2 Int (Seq Int)))) Int+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (- l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.extract l1_s1 l1_s7 l1_s8)))+                                 (let ((l1_s10 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s5 l1_s9)))+                                 (let ((l1_s11 (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| l1_s10)))+                                 (let ((l1_s12 (+ l1_s6 l1_s11)))+                                 (let ((l1_s13 (ite l1_s4 l1_s5 l1_s12)))+                                 l1_s13)))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s4 () Bool (= s0 s3)) [GOOD] (define-fun s6 () Bool (= s1 s5))-[GOOD] (define-fun s8 () (Seq Int) (sbv.zipWith_736833 s0 s1))-[GOOD] (define-fun s9 () Int (sbv.foldr_5cb25c s7 s8))-[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s8 () (SBVTuple2 (Seq Int) (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) s0 s1))+[GOOD] (define-fun s9 () (Seq Int) (|sbv.zipWith @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV ([Integer],[Integer]) -> SBV [Integer])| s8))+[GOOD] (define-fun s10 () (SBVTuple2 Int (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) s7 s9))+[GOOD] (define-fun s11 () Int (|sbv.foldr @(SBV (Integer,Integer) -> SBV Integer)_1fd06f7602 @(SBV (Integer,[Integer]) -> SBV Integer)| s10))+[GOOD] (define-fun s12 () Bool (= s2 s11)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s4) [GOOD] (assert s6)-[GOOD] (assert s10)+[GOOD] (assert s12) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s2))
SBVTestSuite/GoldFiles/lambda26.gold view
@@ -11,30 +11,45 @@ [GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq (Seq Int)) (seq.++ (seq.unit (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5))) (seq.unit (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5) (seq.unit 6) (seq.unit 7) (seq.unit 8) (seq.unit 9) (seq.unit 10))) (seq.unit (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5) (seq.unit 6) (seq.unit 7) (seq.unit 8) (seq.unit 9) (seq.unit 10) (seq.unit 11) (seq.unit 12) (seq.unit 13) (seq.unit 14) (seq.unit 15) (seq.unit 16) (seq.unit 17) (seq.unit 18) (seq.unit 19) (seq.unit 20)))))+[GOOD] (define-fun s4 () (Seq Int) (as seq.empty (Seq Int))) [GOOD] ; --- top level inputs --- [GOOD] (declare-fun s0 () (Seq (Seq Int))) [GOOD] (declare-fun s1 () (Seq Int)) [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: concat :: [[SInteger]] -> [SInteger]-[GOOD] (define-fun-rec sbv.concat_712066 ((lst (Seq (Seq Int)))) (Seq Int)-                       (ite (= lst (as seq.empty (Seq (Seq Int))))-                            (as seq.empty (Seq Int))-                            (seq.++ (seq.nth lst 0) (sbv.concat_712066 (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldr @(SBV ([Integer],[Integer]) -> SBV [Integer])_44d71053fc @(SBV ([Integer],[[Integer]]) -> SBV [Integer])| :: ([SInteger], [[SInteger]]) -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV ([Integer],[Integer]) -> SBV [Integer])_44d71053fc @(SBV ([Integer],[[Integer]]) -> SBV [Integer])| ((l1_s0 (SBVTuple2 (Seq Int) (Seq (Seq Int))))) (Seq Int)+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (- l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.extract l1_s1 l1_s7 l1_s8)))+                                 (let ((l1_s10 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq (Seq Int)))) l1_s5 l1_s9)))+                                 (let ((l1_s11 (|sbv.foldr @(SBV ([Integer],[Integer]) -> SBV [Integer])_44d71053fc @(SBV ([Integer],[[Integer]]) -> SBV [Integer])| l1_s10)))+                                 (let ((l1_s12 (seq.++ l1_s6 l1_s11)))+                                 (let ((l1_s13 (ite l1_s4 l1_s5 l1_s12)))+                                 l1_s13)))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq Int) (sbv.concat_712066 s0))-[GOOD] (define-fun s5 () Bool (= s1 s4))+[GOOD] (define-fun s5 () (SBVTuple2 (Seq Int) (Seq (Seq Int))) ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq (Seq Int)))) s4 s0))+[GOOD] (define-fun s6 () (Seq Int) (|sbv.foldr @(SBV ([Integer],[Integer]) -> SBV [Integer])_44d71053fc @(SBV ([Integer],[[Integer]]) -> SBV [Integer])| s5))+[GOOD] (define-fun s7 () Bool (= s1 s6)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s5)+[GOOD] (assert s7) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda27.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 2) (seq.unit 4) (seq.unit 6) (seq.unit 8) (seq.unit 10)))@@ -20,41 +23,35 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: all :: (SInteger -> SBool) -> [SInteger] -> SBool-[GOOD] (define-fun-rec sbv.all_f82c1b ((lst (Seq Int))) Bool-                       (ite (= lst (as seq.empty (Seq Int)))-                            true-                            (and (select (lambda ((args0 Int))-                 (let ((args1 2))-                 (let ((args3 0))-                 (let ((args7 1))-                 (let ((args13 (- 1)))-                 (let ((args2 (mod args0 args1)))-                 (let ((args4 (>= args0 args3)))-                 (let ((args5 (= args2 args3)))-                 (let ((args6 (or args4 args5)))-                 (let ((args8 (ite args6 args3 args7)))-                 (let ((args9 (* args1 args8)))-                 (let ((args10 (- args2 args9)))-                 (let ((args11 (> args10 args3)))-                 (let ((args12 (< args10 args3)))-                 (let ((args14 (ite args12 args13 args10)))-                 (let ((args15 (ite args11 args7 args14)))-                 (let ((args16 (= args13 args15)))-                 (let ((args17 (+ args1 args10)))-                 (let ((args18 (ite args16 args17 args10)))-                 (let ((args19 (= args3 args18)))-                 args19)))))))))))))))))))) (seq.nth lst 0)) (sbv.all_f82c1b (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_574b56f8c4 @(SBV (Bool,[Integer]) -> SBV Bool)| :: (SBool, [SInteger]) -> SBool [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_574b56f8c4 @(SBV (Bool,[Integer]) -> SBV Bool)| ((l1_s0 (SBVTuple2 Bool (Seq Int)))) Bool+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 2))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (mod l1_s6 l1_s7)))+                                 (let ((l1_s9 (= l1_s3 l1_s8)))+                                 (let ((l1_s11 (- l1_s2 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s1 l1_s10 l1_s11)))+                                 (let ((l1_s13 ((as mkSBVTuple2 (SBVTuple2 Bool (Seq Int))) l1_s5 l1_s12)))+                                 (let ((l1_s14 (|sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_574b56f8c4 @(SBV (Bool,[Integer]) -> SBV Bool)| l1_s13)))+                                 (let ((l1_s15 (and l1_s9 l1_s14)))+                                 (let ((l1_s16 (ite l1_s4 l1_s5 l1_s15)))+                                 l1_s16))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () Bool (sbv.all_f82c1b s0))-[GOOD] (define-fun s5 () Bool (= s1 s4))+[GOOD] (define-fun s4 () (SBVTuple2 Bool (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Bool (Seq Int))) true s0))+[GOOD] (define-fun s5 () Bool (|sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_574b56f8c4 @(SBV (Bool,[Integer]) -> SBV Bool)| s4))+[GOOD] (define-fun s6 () Bool (= s1 s5)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s5)+[GOOD] (assert s6) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda28.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 2) (seq.unit 4) (seq.unit 6) (seq.unit 1) (seq.unit 8) (seq.unit 10)))@@ -20,41 +23,35 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: all :: (SInteger -> SBool) -> [SInteger] -> SBool-[GOOD] (define-fun-rec sbv.all_f82c1b ((lst (Seq Int))) Bool-                       (ite (= lst (as seq.empty (Seq Int)))-                            true-                            (and (select (lambda ((args0 Int))-                 (let ((args1 2))-                 (let ((args3 0))-                 (let ((args7 1))-                 (let ((args13 (- 1)))-                 (let ((args2 (mod args0 args1)))-                 (let ((args4 (>= args0 args3)))-                 (let ((args5 (= args2 args3)))-                 (let ((args6 (or args4 args5)))-                 (let ((args8 (ite args6 args3 args7)))-                 (let ((args9 (* args1 args8)))-                 (let ((args10 (- args2 args9)))-                 (let ((args11 (> args10 args3)))-                 (let ((args12 (< args10 args3)))-                 (let ((args14 (ite args12 args13 args10)))-                 (let ((args15 (ite args11 args7 args14)))-                 (let ((args16 (= args13 args15)))-                 (let ((args17 (+ args1 args10)))-                 (let ((args18 (ite args16 args17 args10)))-                 (let ((args19 (= args3 args18)))-                 args19)))))))))))))))))))) (seq.nth lst 0)) (sbv.all_f82c1b (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_574b56f8c4 @(SBV (Bool,[Integer]) -> SBV Bool)| :: (SBool, [SInteger]) -> SBool [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_574b56f8c4 @(SBV (Bool,[Integer]) -> SBV Bool)| ((l1_s0 (SBVTuple2 Bool (Seq Int)))) Bool+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 2))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (mod l1_s6 l1_s7)))+                                 (let ((l1_s9 (= l1_s3 l1_s8)))+                                 (let ((l1_s11 (- l1_s2 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s1 l1_s10 l1_s11)))+                                 (let ((l1_s13 ((as mkSBVTuple2 (SBVTuple2 Bool (Seq Int))) l1_s5 l1_s12)))+                                 (let ((l1_s14 (|sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_574b56f8c4 @(SBV (Bool,[Integer]) -> SBV Bool)| l1_s13)))+                                 (let ((l1_s15 (and l1_s9 l1_s14)))+                                 (let ((l1_s16 (ite l1_s4 l1_s5 l1_s15)))+                                 l1_s16))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () Bool (sbv.all_f82c1b s0))-[GOOD] (define-fun s5 () Bool (= s1 s4))+[GOOD] (define-fun s4 () (SBVTuple2 Bool (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Bool (Seq Int))) true s0))+[GOOD] (define-fun s5 () Bool (|sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_574b56f8c4 @(SBV (Bool,[Integer]) -> SBV Bool)| s4))+[GOOD] (define-fun s6 () Bool (= s1 s5)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s5)+[GOOD] (assert s6) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda29.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 2) (seq.unit 4) (seq.unit 6) (seq.unit 8) (seq.unit 10)))@@ -20,41 +23,35 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: any :: (SInteger -> SBool) -> [SInteger] -> SBool-[GOOD] (define-fun-rec sbv.any_ca4250 ((lst (Seq Int))) Bool-                       (ite (= lst (as seq.empty (Seq Int)))-                            false-                            (or (select (lambda ((args0 Int))-                 (let ((args1 2))-                 (let ((args3 0))-                 (let ((args7 1))-                 (let ((args13 (- 1)))-                 (let ((args2 (mod args0 args1)))-                 (let ((args4 (>= args0 args3)))-                 (let ((args5 (= args2 args3)))-                 (let ((args6 (or args4 args5)))-                 (let ((args8 (ite args6 args3 args7)))-                 (let ((args9 (* args1 args8)))-                 (let ((args10 (- args2 args9)))-                 (let ((args11 (> args10 args3)))-                 (let ((args12 (< args10 args3)))-                 (let ((args14 (ite args12 args13 args10)))-                 (let ((args15 (ite args11 args7 args14)))-                 (let ((args16 (= args13 args15)))-                 (let ((args17 (+ args1 args10)))-                 (let ((args18 (ite args16 args17 args10)))-                 (let ((args19 (distinct args3 args18)))-                 args19)))))))))))))))))))) (seq.nth lst 0)) (sbv.any_ca4250 (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_01257e6724 @(SBV (Bool,[Integer]) -> SBV Bool)| :: (SBool, [SInteger]) -> SBool [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_01257e6724 @(SBV (Bool,[Integer]) -> SBV Bool)| ((l1_s0 (SBVTuple2 Bool (Seq Int)))) Bool+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 2))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (mod l1_s6 l1_s7)))+                                 (let ((l1_s9 (distinct l1_s3 l1_s8)))+                                 (let ((l1_s11 (- l1_s2 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s1 l1_s10 l1_s11)))+                                 (let ((l1_s13 ((as mkSBVTuple2 (SBVTuple2 Bool (Seq Int))) l1_s5 l1_s12)))+                                 (let ((l1_s14 (|sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_01257e6724 @(SBV (Bool,[Integer]) -> SBV Bool)| l1_s13)))+                                 (let ((l1_s15 (or l1_s9 l1_s14)))+                                 (let ((l1_s16 (ite l1_s4 l1_s5 l1_s15)))+                                 l1_s16))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () Bool (sbv.any_ca4250 s0))-[GOOD] (define-fun s5 () Bool (= s1 s4))+[GOOD] (define-fun s4 () (SBVTuple2 Bool (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Bool (Seq Int))) false s0))+[GOOD] (define-fun s5 () Bool (|sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_01257e6724 @(SBV (Bool,[Integer]) -> SBV Bool)| s4))+[GOOD] (define-fun s6 () Bool (= s1 s5)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s5)+[GOOD] (assert s6) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda30.gold view
@@ -8,9 +8,12 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2)))))) [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- [GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 2) (seq.unit 4) (seq.unit 6) (seq.unit 1) (seq.unit 8) (seq.unit 10)))@@ -20,41 +23,35 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: any :: (SInteger -> SBool) -> [SInteger] -> SBool-[GOOD] (define-fun-rec sbv.any_fec105 ((lst (Seq Int))) Bool-                       (ite (= lst (as seq.empty (Seq Int)))-                            false-                            (or (select (lambda ((args0 Int))-                 (let ((args1 2))-                 (let ((args3 0))-                 (let ((args7 1))-                 (let ((args13 (- 1)))-                 (let ((args2 (mod args0 args1)))-                 (let ((args4 (>= args0 args3)))-                 (let ((args5 (= args2 args3)))-                 (let ((args6 (or args4 args5)))-                 (let ((args8 (ite args6 args3 args7)))-                 (let ((args9 (* args1 args8)))-                 (let ((args10 (- args2 args9)))-                 (let ((args11 (> args10 args3)))-                 (let ((args12 (< args10 args3)))-                 (let ((args14 (ite args12 args13 args10)))-                 (let ((args15 (ite args11 args7 args14)))-                 (let ((args16 (= args13 args15)))-                 (let ((args17 (+ args1 args10)))-                 (let ((args18 (ite args16 args17 args10)))-                 (let ((args19 (= args3 args18)))-                 args19)))))))))))))))))))) (seq.nth lst 0)) (sbv.any_fec105 (seq.extract lst 1 (- (seq.len lst) 1)))))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_7182762f14 @(SBV (Bool,[Integer]) -> SBV Bool)| :: (SBool, [SInteger]) -> SBool [Recursive]+[GOOD] (define-fun-rec |sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_7182762f14 @(SBV (Bool,[Integer]) -> SBV Bool)| ((l1_s0 (SBVTuple2 Bool (Seq Int)))) Bool+                                 (let ((l1_s3 0))+                                 (let ((l1_s7 2))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s5 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (mod l1_s6 l1_s7)))+                                 (let ((l1_s9 (= l1_s3 l1_s8)))+                                 (let ((l1_s11 (- l1_s2 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s1 l1_s10 l1_s11)))+                                 (let ((l1_s13 ((as mkSBVTuple2 (SBVTuple2 Bool (Seq Int))) l1_s5 l1_s12)))+                                 (let ((l1_s14 (|sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_7182762f14 @(SBV (Bool,[Integer]) -> SBV Bool)| l1_s13)))+                                 (let ((l1_s15 (or l1_s9 l1_s14)))+                                 (let ((l1_s16 (ite l1_s4 l1_s5 l1_s15)))+                                 l1_s16))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () Bool (sbv.any_fec105 s0))-[GOOD] (define-fun s5 () Bool (= s1 s4))+[GOOD] (define-fun s4 () (SBVTuple2 Bool (Seq Int)) ((as mkSBVTuple2 (SBVTuple2 Bool (Seq Int))) false s0))+[GOOD] (define-fun s5 () Bool (|sbv.foldr @(SBV (Integer,Bool) -> SBV Bool)_7182762f14 @(SBV (Bool,[Integer]) -> SBV Bool)| s4))+[GOOD] (define-fun s6 () Bool (= s1 s5)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3)-[GOOD] (assert s5)+[GOOD] (assert s6) [SEND] (check-sat) [RECV] sat [SEND] (get-value (s1))
SBVTestSuite/GoldFiles/lambda31.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,39 +20,29 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: filter :: (SInteger -> SBool) -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.filter_75abb5 ((lst (Seq Int))) (Seq Int)-                       (ite (= lst (as seq.empty (Seq Int)))-                            (as seq.empty (Seq Int))-                            (let ((rest (sbv.filter_75abb5 (seq.extract lst 1 (- (seq.len lst) 1)))))-                                 (ite (select (lambda ((args0 Int))-                 (let ((args1 2))-                 (let ((args3 0))-                 (let ((args7 1))-                 (let ((args13 (- 1)))-                 (let ((args2 (mod args0 args1)))-                 (let ((args4 (>= args0 args3)))-                 (let ((args5 (= args2 args3)))-                 (let ((args6 (or args4 args5)))-                 (let ((args8 (ite args6 args3 args7)))-                 (let ((args9 (* args1 args8)))-                 (let ((args10 (- args2 args9)))-                 (let ((args11 (> args10 args3)))-                 (let ((args12 (< args10 args3)))-                 (let ((args14 (ite args12 args13 args10)))-                 (let ((args15 (ite args11 args7 args14)))-                 (let ((args16 (= args13 args15)))-                 (let ((args17 (+ args1 args10)))-                 (let ((args18 (ite args16 args17 args10)))-                 (let ((args19 (= args3 args18)))-                 args19)))))))))))))))))))) (seq.nth lst 0))-                                      (seq.++ (seq.unit (seq.nth lst 0)) rest)-                                              rest)))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.filter @(SBV Integer -> SBV Bool)_72b7bf5d4c @(SBV [Integer] -> SBV [Integer])| :: [SInteger] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.filter @(SBV Integer -> SBV Bool)_72b7bf5d4c @(SBV [Integer] -> SBV [Integer])| ((l1_s0 (Seq Int))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s6 2))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (mod l1_s5 l1_s6)))+                                 (let ((l1_s8 (= l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.unit l1_s5)))+                                 (let ((l1_s11 (- l1_s1 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s0 l1_s10 l1_s11)))+                                 (let ((l1_s13 (|sbv.filter @(SBV Integer -> SBV Bool)_72b7bf5d4c @(SBV [Integer] -> SBV [Integer])| l1_s12)))+                                 (let ((l1_s14 (seq.++ l1_s9 l1_s13)))+                                 (let ((l1_s15 (ite l1_s8 l1_s14 l1_s13)))+                                 (let ((l1_s16 (ite l1_s3 l1_s4 l1_s15)))+                                 l1_s16))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq Int) (sbv.filter_75abb5 s0))+[GOOD] (define-fun s4 () (Seq Int) (|sbv.filter @(SBV Integer -> SBV Bool)_72b7bf5d4c @(SBV [Integer] -> SBV [Integer])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda32.gold view
@@ -8,7 +8,7 @@ [GOOD] (set-option :pp.max_depth      4294967295) [GOOD] (set-option :pp.min_alias_size 4294967295) [GOOD] (set-option :model.inline_def  true      )-[GOOD] (set-logic ALL) ; has lambda expressions, using catch-all.+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---@@ -20,39 +20,29 @@ [GOOD] ; --- constant tables --- [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants ----[GOOD] ; --- Firstified function definitions-[GOOD] ; Firstified function: filter :: (SInteger -> SBool) -> [SInteger] -> [SInteger]-[GOOD] (define-fun-rec sbv.filter_86847f ((lst (Seq Int))) (Seq Int)-                       (ite (= lst (as seq.empty (Seq Int)))-                            (as seq.empty (Seq Int))-                            (let ((rest (sbv.filter_86847f (seq.extract lst 1 (- (seq.len lst) 1)))))-                                 (ite (select (lambda ((args0 Int))-                 (let ((args1 2))-                 (let ((args3 0))-                 (let ((args7 1))-                 (let ((args13 (- 1)))-                 (let ((args2 (mod args0 args1)))-                 (let ((args4 (>= args0 args3)))-                 (let ((args5 (= args2 args3)))-                 (let ((args6 (or args4 args5)))-                 (let ((args8 (ite args6 args3 args7)))-                 (let ((args9 (* args1 args8)))-                 (let ((args10 (- args2 args9)))-                 (let ((args11 (> args10 args3)))-                 (let ((args12 (< args10 args3)))-                 (let ((args14 (ite args12 args13 args10)))-                 (let ((args15 (ite args11 args7 args14)))-                 (let ((args16 (= args13 args15)))-                 (let ((args17 (+ args1 args10)))-                 (let ((args18 (ite args16 args17 args10)))-                 (let ((args19 (distinct args3 args18)))-                 args19)))))))))))))))))))) (seq.nth lst 0))-                                      (seq.++ (seq.unit (seq.nth lst 0)) rest)-                                              rest)))) [GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.filter @(SBV Integer -> SBV Bool)_cb04f986c4 @(SBV [Integer] -> SBV [Integer])| :: [SInteger] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.filter @(SBV Integer -> SBV Bool)_cb04f986c4 @(SBV [Integer] -> SBV [Integer])| ((l1_s0 (Seq Int))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s6 2))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (mod l1_s5 l1_s6)))+                                 (let ((l1_s8 (distinct l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.unit l1_s5)))+                                 (let ((l1_s11 (- l1_s1 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s0 l1_s10 l1_s11)))+                                 (let ((l1_s13 (|sbv.filter @(SBV Integer -> SBV Bool)_cb04f986c4 @(SBV [Integer] -> SBV [Integer])| l1_s12)))+                                 (let ((l1_s14 (seq.++ l1_s9 l1_s13)))+                                 (let ((l1_s15 (ite l1_s8 l1_s14 l1_s13)))+                                 (let ((l1_s16 (ite l1_s3 l1_s4 l1_s15)))+                                 l1_s16))))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (Seq Int) (sbv.filter_86847f s0))+[GOOD] (define-fun s4 () (Seq Int) (|sbv.filter @(SBV Integer -> SBV Bool)_cb04f986c4 @(SBV [Integer] -> SBV [Integer])| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda40.gold view
@@ -1,3 +1,1 @@-; lambda40 :: SInteger-(define-fun lambda40 () Int-  0)+0
SBVTestSuite/GoldFiles/lambda41.gold view
@@ -1,5 +1,4 @@-; lambda41 :: SInteger -> SInteger-(define-fun lambda41 ((l1_s0 Int)) Int+(lambda ((l1_s0 Int))                           (let ((l1_s1 1))                           (let ((l1_s2 (+ l1_s0 l1_s1)))                           l1_s2)))
SBVTestSuite/GoldFiles/lambda42.gold view
@@ -1,3 +1,2 @@-; lambda42 :: SInteger -> SInteger -> SInteger-(define-fun lambda42 ((l1_s0 Int) (l1_s1 Int)) Int+(lambda ((l1_s0 Int) (l1_s1 Int))   (+ l1_s0 l1_s1))
SBVTestSuite/GoldFiles/lambda43.gold view
@@ -1,3 +1,1 @@-; lambda43 :: SWord32-(define-fun lambda43 () (_ BitVec 32)-  #x00000000)+#x00000000
SBVTestSuite/GoldFiles/lambda44.gold view
@@ -1,5 +1,4 @@-; lambda44 :: SWord32 -> SWord32-(define-fun lambda44 ((l1_s0 (_ BitVec 32))) (_ BitVec 32)+(lambda ((l1_s0 (_ BitVec 32)))                           (let ((l1_s1 #x00000001))                           (let ((l1_s2 (bvadd l1_s0 l1_s1)))                           l1_s2)))
SBVTestSuite/GoldFiles/lambda45.gold view
@@ -1,3 +1,2 @@-; lambda45 :: SWord32 -> SWord32 -> SWord32-(define-fun lambda45 ((l1_s0 (_ BitVec 32)) (l1_s1 (_ BitVec 32))) (_ BitVec 32)+(lambda ((l1_s0 (_ BitVec 32)) (l1_s1 (_ BitVec 32)))   (bvadd l1_s0 l1_s1))
SBVTestSuite/GoldFiles/lambda46.gold view
@@ -17,19 +17,19 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; add1 :: SInteger -> SInteger-[GOOD] (define-fun add1 ((l1_s0 Int)) Int+[GOOD] ; |add1 @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger+[GOOD] (define-fun |add1 @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int                                  (let ((l1_s1 1))                                  (let ((l1_s2 (+ l1_s0 l1_s1)))                                  l1_s2))) [GOOD] ; --- assignments ----[GOOD] (define-fun s1 () Int (add1 s0))+[GOOD] (define-fun s1 () Int (|add1 @(SBV Integer -> SBV Integer)| s0)) [GOOD] (define-fun s3 () Bool (= s1 s2)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s3) [GOOD] (declare-fun s4 () Int)-[GOOD] (define-fun s5 () Int (add1 s4))+[GOOD] (define-fun s5 () Int (|add1 @(SBV Integer -> SBV Integer)| s4)) [GOOD] (define-fun s6 () Bool (= s2 s5)) [GOOD] (assert s6) [SEND] (check-sat)
SBVTestSuite/GoldFiles/lambda47.gold view
@@ -18,19 +18,19 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; sumToN :: SInteger -> SInteger [Recursive]-[GOOD] (define-fun-rec sumToN ((l1_s0 Int)) Int+[GOOD] ; |sumToN @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger [Recursive]+[GOOD] (define-fun-rec |sumToN @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int                                  (let ((l1_s1 0))                                  (let ((l1_s3 1))                                  (let ((l1_s2 (<= l1_s0 l1_s1)))                                  (let ((l1_s4 (- l1_s0 l1_s3)))-                                 (let ((l1_s5 (sumToN l1_s4)))+                                 (let ((l1_s5 (|sumToN @(SBV Integer -> SBV Integer)| l1_s4)))                                  (let ((l1_s6 (+ l1_s0 l1_s5)))                                  (let ((l1_s7 (ite l1_s2 l1_s1 l1_s6)))                                  l1_s7)))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () Int (sumToN s0))+[GOOD] (define-fun s4 () Int (|sumToN @(SBV Integer -> SBV Integer)| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] (define-fun s6 () Bool (and s3 s5)) [GOOD] ; --- delayedEqualities ---@@ -39,7 +39,7 @@ [GOOD] (declare-fun s7 () Int) [GOOD] (declare-fun s8 () Int) [GOOD] (define-fun s9 () Bool (= s2 s7))-[GOOD] (define-fun s10 () Int (sumToN s7))+[GOOD] (define-fun s10 () Int (|sumToN @(SBV Integer -> SBV Integer)| s7)) [GOOD] (define-fun s11 () Bool (= s8 s10)) [GOOD] (define-fun s12 () Bool (and s9 s11)) [GOOD] (assert s12)
SBVTestSuite/GoldFiles/lambda48.gold view
@@ -21,21 +21,21 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; list_length :: [SInteger] -> SInteger [Recursive]-[GOOD] (define-fun-rec list_length ((l1_s0 (Seq Int))) Int+[GOOD] ; |list_length @(SBV [Integer] -> SBV Integer)| :: [SInteger] -> SInteger [Recursive]+[GOOD] (define-fun-rec |list_length @(SBV [Integer] -> SBV Integer)| ((l1_s0 (Seq Int))) Int                                  (let ((l1_s2 0))                                  (let ((l1_s4 1))                                  (let ((l1_s1 (seq.len l1_s0)))                                  (let ((l1_s3 (= l1_s1 l1_s2)))                                  (let ((l1_s5 (- l1_s1 l1_s4)))                                  (let ((l1_s6 (seq.extract l1_s0 l1_s4 l1_s5)))-                                 (let ((l1_s7 (list_length l1_s6)))+                                 (let ((l1_s7 (|list_length @(SBV [Integer] -> SBV Integer)| l1_s6)))                                  (let ((l1_s8 (+ l1_s4 l1_s7)))                                  (let ((l1_s9 (ite l1_s3 l1_s2 l1_s8)))                                  l1_s9)))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () Int (list_length s0))+[GOOD] (define-fun s4 () Int (|list_length @(SBV [Integer] -> SBV Integer)| s0)) [GOOD] (define-fun s5 () Bool (= s1 s4)) [GOOD] (define-fun s6 () Bool (and s3 s5)) [GOOD] ; --- delayedEqualities ---@@ -44,7 +44,7 @@ [GOOD] (declare-fun s7 () (Seq Int)) [GOOD] (declare-fun s8 () Int) [GOOD] (define-fun s9 () Bool (= s2 s7))-[GOOD] (define-fun s10 () Int (list_length s7))+[GOOD] (define-fun s10 () Int (|list_length @(SBV [Integer] -> SBV Integer)| s7)) [GOOD] (define-fun s11 () Bool (= s8 s10)) [GOOD] (define-fun s12 () Bool (and s9 s11)) [GOOD] (assert s12)
SBVTestSuite/GoldFiles/lambda49.gold view
@@ -24,17 +24,17 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; isEvenOdd :: SInteger -> (SBool, SBool) [Recursive]-[GOOD] (define-fun-rec isEvenOdd ((l1_s0 Int)) (SBVTuple2 Bool Bool)+[GOOD] ; |isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| :: SInteger -> (SBool, SBool) [Recursive]+[GOOD] (define-fun-rec |isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| ((l1_s0 Int)) (SBVTuple2 Bool Bool)                                  (let ((l1_s1 0))                                  (let ((l1_s6 (mkSBVTuple2 true false)))                                  (let ((l1_s7 1))                                  (let ((l1_s2 (< l1_s0 l1_s1)))                                  (let ((l1_s3 (- l1_s0)))-                                 (let ((l1_s4 (isEvenOdd l1_s3)))+                                 (let ((l1_s4 (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| l1_s3)))                                  (let ((l1_s5 (= l1_s0 l1_s1)))                                  (let ((l1_s8 (- l1_s0 l1_s7)))-                                 (let ((l1_s9 (isEvenOdd l1_s8)))+                                 (let ((l1_s9 (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| l1_s8)))                                  (let ((l1_s10 (proj_2_SBVTuple2 l1_s9)))                                  (let ((l1_s11 (proj_1_SBVTuple2 l1_s9)))                                  (let ((l1_s12 ((as mkSBVTuple2 (SBVTuple2 Bool Bool)) l1_s10 l1_s11)))@@ -43,7 +43,7 @@                                  l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (SBVTuple2 Bool Bool) (isEvenOdd s0))+[GOOD] (define-fun s4 () (SBVTuple2 Bool Bool) (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| s0)) [GOOD] (define-fun s5 () Bool (proj_1_SBVTuple2 s4)) [GOOD] (define-fun s6 () Bool (= s1 s5)) [GOOD] (define-fun s7 () Bool (and s3 s6))@@ -53,7 +53,7 @@ [GOOD] (declare-fun s8 () Int) [GOOD] (declare-fun s9 () Bool) [GOOD] (define-fun s10 () Bool (= s2 s8))-[GOOD] (define-fun s11 () (SBVTuple2 Bool Bool) (isEvenOdd s8))+[GOOD] (define-fun s11 () (SBVTuple2 Bool Bool) (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| s8)) [GOOD] (define-fun s12 () Bool (proj_1_SBVTuple2 s11)) [GOOD] (define-fun s13 () Bool (= s9 s12)) [GOOD] (define-fun s14 () Bool (and s10 s13))
SBVTestSuite/GoldFiles/lambda50.gold view
@@ -24,17 +24,17 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; isEvenOdd :: SInteger -> (SBool, SBool) [Recursive]-[GOOD] (define-fun-rec isEvenOdd ((l1_s0 Int)) (SBVTuple2 Bool Bool)+[GOOD] ; |isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| :: SInteger -> (SBool, SBool) [Recursive]+[GOOD] (define-fun-rec |isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| ((l1_s0 Int)) (SBVTuple2 Bool Bool)                                  (let ((l1_s1 0))                                  (let ((l1_s6 (mkSBVTuple2 true false)))                                  (let ((l1_s7 1))                                  (let ((l1_s2 (< l1_s0 l1_s1)))                                  (let ((l1_s3 (- l1_s0)))-                                 (let ((l1_s4 (isEvenOdd l1_s3)))+                                 (let ((l1_s4 (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| l1_s3)))                                  (let ((l1_s5 (= l1_s0 l1_s1)))                                  (let ((l1_s8 (- l1_s0 l1_s7)))-                                 (let ((l1_s9 (isEvenOdd l1_s8)))+                                 (let ((l1_s9 (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| l1_s8)))                                  (let ((l1_s10 (proj_2_SBVTuple2 l1_s9)))                                  (let ((l1_s11 (proj_1_SBVTuple2 l1_s9)))                                  (let ((l1_s12 ((as mkSBVTuple2 (SBVTuple2 Bool Bool)) l1_s10 l1_s11)))@@ -43,7 +43,7 @@                                  l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (SBVTuple2 Bool Bool) (isEvenOdd s0))+[GOOD] (define-fun s4 () (SBVTuple2 Bool Bool) (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| s0)) [GOOD] (define-fun s5 () Bool (proj_1_SBVTuple2 s4)) [GOOD] (define-fun s6 () Bool (= s1 s5)) [GOOD] (define-fun s7 () Bool (and s3 s6))@@ -53,7 +53,7 @@ [GOOD] (declare-fun s8 () Int) [GOOD] (declare-fun s9 () Bool) [GOOD] (define-fun s10 () Bool (= s2 s8))-[GOOD] (define-fun s11 () (SBVTuple2 Bool Bool) (isEvenOdd s8))+[GOOD] (define-fun s11 () (SBVTuple2 Bool Bool) (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| s8)) [GOOD] (define-fun s12 () Bool (proj_1_SBVTuple2 s11)) [GOOD] (define-fun s13 () Bool (= s9 s12)) [GOOD] (define-fun s14 () Bool (and s10 s13))
SBVTestSuite/GoldFiles/lambda51.gold view
@@ -24,17 +24,17 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; isEvenOdd :: SInteger -> (SBool, SBool) [Recursive]-[GOOD] (define-fun-rec isEvenOdd ((l1_s0 Int)) (SBVTuple2 Bool Bool)+[GOOD] ; |isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| :: SInteger -> (SBool, SBool) [Recursive]+[GOOD] (define-fun-rec |isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| ((l1_s0 Int)) (SBVTuple2 Bool Bool)                                  (let ((l1_s1 0))                                  (let ((l1_s6 (mkSBVTuple2 true false)))                                  (let ((l1_s7 1))                                  (let ((l1_s2 (< l1_s0 l1_s1)))                                  (let ((l1_s3 (- l1_s0)))-                                 (let ((l1_s4 (isEvenOdd l1_s3)))+                                 (let ((l1_s4 (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| l1_s3)))                                  (let ((l1_s5 (= l1_s0 l1_s1)))                                  (let ((l1_s8 (- l1_s0 l1_s7)))-                                 (let ((l1_s9 (isEvenOdd l1_s8)))+                                 (let ((l1_s9 (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| l1_s8)))                                  (let ((l1_s10 (proj_2_SBVTuple2 l1_s9)))                                  (let ((l1_s11 (proj_1_SBVTuple2 l1_s9)))                                  (let ((l1_s12 ((as mkSBVTuple2 (SBVTuple2 Bool Bool)) l1_s10 l1_s11)))@@ -43,7 +43,7 @@                                  l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (SBVTuple2 Bool Bool) (isEvenOdd s0))+[GOOD] (define-fun s4 () (SBVTuple2 Bool Bool) (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| s0)) [GOOD] (define-fun s5 () Bool (proj_2_SBVTuple2 s4)) [GOOD] (define-fun s6 () Bool (= s1 s5)) [GOOD] (define-fun s7 () Bool (and s3 s6))@@ -53,7 +53,7 @@ [GOOD] (declare-fun s8 () Int) [GOOD] (declare-fun s9 () Bool) [GOOD] (define-fun s10 () Bool (= s2 s8))-[GOOD] (define-fun s11 () (SBVTuple2 Bool Bool) (isEvenOdd s8))+[GOOD] (define-fun s11 () (SBVTuple2 Bool Bool) (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| s8)) [GOOD] (define-fun s12 () Bool (proj_2_SBVTuple2 s11)) [GOOD] (define-fun s13 () Bool (= s9 s12)) [GOOD] (define-fun s14 () Bool (and s10 s13))
SBVTestSuite/GoldFiles/lambda52.gold view
@@ -24,17 +24,17 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; isEvenOdd :: SInteger -> (SBool, SBool) [Recursive]-[GOOD] (define-fun-rec isEvenOdd ((l1_s0 Int)) (SBVTuple2 Bool Bool)+[GOOD] ; |isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| :: SInteger -> (SBool, SBool) [Recursive]+[GOOD] (define-fun-rec |isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| ((l1_s0 Int)) (SBVTuple2 Bool Bool)                                  (let ((l1_s1 0))                                  (let ((l1_s6 (mkSBVTuple2 true false)))                                  (let ((l1_s7 1))                                  (let ((l1_s2 (< l1_s0 l1_s1)))                                  (let ((l1_s3 (- l1_s0)))-                                 (let ((l1_s4 (isEvenOdd l1_s3)))+                                 (let ((l1_s4 (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| l1_s3)))                                  (let ((l1_s5 (= l1_s0 l1_s1)))                                  (let ((l1_s8 (- l1_s0 l1_s7)))-                                 (let ((l1_s9 (isEvenOdd l1_s8)))+                                 (let ((l1_s9 (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| l1_s8)))                                  (let ((l1_s10 (proj_2_SBVTuple2 l1_s9)))                                  (let ((l1_s11 (proj_1_SBVTuple2 l1_s9)))                                  (let ((l1_s12 ((as mkSBVTuple2 (SBVTuple2 Bool Bool)) l1_s10 l1_s11)))@@ -43,7 +43,7 @@                                  l1_s14))))))))))))))) [GOOD] ; --- assignments --- [GOOD] (define-fun s3 () Bool (= s0 s2))-[GOOD] (define-fun s4 () (SBVTuple2 Bool Bool) (isEvenOdd s0))+[GOOD] (define-fun s4 () (SBVTuple2 Bool Bool) (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| s0)) [GOOD] (define-fun s5 () Bool (proj_2_SBVTuple2 s4)) [GOOD] (define-fun s6 () Bool (= s1 s5)) [GOOD] (define-fun s7 () Bool (and s3 s6))@@ -53,7 +53,7 @@ [GOOD] (declare-fun s8 () Int) [GOOD] (declare-fun s9 () Bool) [GOOD] (define-fun s10 () Bool (= s2 s8))-[GOOD] (define-fun s11 () (SBVTuple2 Bool Bool) (isEvenOdd s8))+[GOOD] (define-fun s11 () (SBVTuple2 Bool Bool) (|isEvenOdd @(SBV Integer -> SBV (Bool,Bool))| s8)) [GOOD] (define-fun s12 () Bool (proj_2_SBVTuple2 s11)) [GOOD] (define-fun s13 () Bool (= s9 s12)) [GOOD] (define-fun s14 () Bool (and s10 s13))
SBVTestSuite/GoldFiles/lambda53.gold view
@@ -16,17 +16,17 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; foo :: SInteger -> SInteger-[GOOD] (define-fun foo ((l1_s0 Int)) Int+[GOOD] ; |foo @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger+[GOOD] (define-fun |foo @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int          (+ s0 l1_s0)) [GOOD] ; --- assignments ----[GOOD] (define-fun s1 () Int (foo s0))+[GOOD] (define-fun s1 () Int (|foo @(SBV Integer -> SBV Integer)| s0)) [GOOD] (define-fun s2 () Bool (= s0 s1)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s2) [GOOD] (declare-fun s3 () Int)-[GOOD] (define-fun s4 () Int (foo s3))+[GOOD] (define-fun s4 () Int (|foo @(SBV Integer -> SBV Integer)| s3)) [GOOD] (define-fun s5 () Bool (= s3 s4)) [GOOD] (assert s5) [SEND] (check-sat)
SBVTestSuite/GoldFiles/lambda54.gold view
@@ -16,28 +16,28 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; bar :: SInteger -> SInteger-[GOOD] (define-fun bar ((l1_s0 Int)) Int+[GOOD] ; |bar @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger+[GOOD] (define-fun |bar @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int                                  (let ((l1_s1 1))                                  (let ((l1_s2 (+ l1_s0 l1_s1)))                                  l1_s2)))-[GOOD] ; foo :: SInteger -> SInteger [Refers to: bar]-[GOOD] (define-fun foo ((l1_s0 Int)) Int+[GOOD] ; |foo @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger [Refers to: |bar @(SBV Integer -> SBV Integer)|]+[GOOD] (define-fun |foo @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int                                  (let ((l1_s2 1))-                                 (let ((l1_s1 (bar l1_s0)))+                                 (let ((l1_s1 (|bar @(SBV Integer -> SBV Integer)| l1_s0)))                                  (let ((l1_s3 (+ l1_s1 l1_s2)))                                  l1_s3)))) [GOOD] ; --- assignments ----[GOOD] (define-fun s1 () Int (bar s0))-[GOOD] (define-fun s2 () Int (foo s0))+[GOOD] (define-fun s1 () Int (|bar @(SBV Integer -> SBV Integer)| s0))+[GOOD] (define-fun s2 () Int (|foo @(SBV Integer -> SBV Integer)| s0)) [GOOD] (define-fun s3 () Int (+ s1 s2)) [GOOD] (define-fun s4 () Bool (= s0 s3)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s4) [GOOD] (declare-fun s5 () Int)-[GOOD] (define-fun s6 () Int (bar s5))-[GOOD] (define-fun s7 () Int (foo s5))+[GOOD] (define-fun s6 () Int (|bar @(SBV Integer -> SBV Integer)| s5))+[GOOD] (define-fun s7 () Int (|foo @(SBV Integer -> SBV Integer)| s5)) [GOOD] (define-fun s8 () Int (+ s6 s7)) [GOOD] (define-fun s9 () Bool (= s5 s8)) [GOOD] (assert s9)
SBVTestSuite/GoldFiles/lambda55.gold view
@@ -16,28 +16,28 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; bar :: SInteger -> SInteger-[GOOD] (define-fun bar ((l2_s0 Int)) Int+[GOOD] ; |bar @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger+[GOOD] (define-fun |bar @(SBV Integer -> SBV Integer)| ((l2_s0 Int)) Int                                                  (let ((l2_s1 1))                                                  (let ((l2_s2 (+ l2_s0 l2_s1)))                                                  l2_s2)))-[GOOD] ; foo :: SInteger -> SInteger [Refers to: bar]-[GOOD] (define-fun foo ((l1_s0 Int)) Int+[GOOD] ; |foo @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger [Refers to: |bar @(SBV Integer -> SBV Integer)|]+[GOOD] (define-fun |foo @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int                                  (let ((l1_s2 1))-                                 (let ((l1_s1 (bar l1_s0)))+                                 (let ((l1_s1 (|bar @(SBV Integer -> SBV Integer)| l1_s0)))                                  (let ((l1_s3 (+ l1_s1 l1_s2)))                                  l1_s3)))) [GOOD] ; --- assignments ----[GOOD] (define-fun s1 () Int (foo s0))-[GOOD] (define-fun s2 () Int (bar s0))+[GOOD] (define-fun s1 () Int (|foo @(SBV Integer -> SBV Integer)| s0))+[GOOD] (define-fun s2 () Int (|bar @(SBV Integer -> SBV Integer)| s0)) [GOOD] (define-fun s3 () Int (+ s1 s2)) [GOOD] (define-fun s4 () Bool (= s0 s3)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s4) [GOOD] (declare-fun s5 () Int)-[GOOD] (define-fun s6 () Int (foo s5))-[GOOD] (define-fun s7 () Int (bar s5))+[GOOD] (define-fun s6 () Int (|foo @(SBV Integer -> SBV Integer)| s5))+[GOOD] (define-fun s7 () Int (|bar @(SBV Integer -> SBV Integer)| s5)) [GOOD] (define-fun s8 () Int (+ s6 s7)) [GOOD] (define-fun s9 () Bool (= s5 s8)) [GOOD] (assert s9)
SBVTestSuite/GoldFiles/lambda56.gold view
@@ -16,31 +16,31 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; bar :: SInteger -> SInteger, foo :: SInteger -> SInteger+[GOOD] ; |bar @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger, |foo @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger [GOOD] (define-funs-rec-         ((bar ((l2_s0 Int)) Int)-          (foo ((l1_s0 Int)) Int))-         (; Definition of: bar :: SInteger -> SInteger. [Refers to: foo]+         ((|bar @(SBV Integer -> SBV Integer)| ((l2_s0 Int)) Int)+          (|foo @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int))+         (; Definition of: |bar @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger. [Refers to: |foo @(SBV Integer -> SBV Integer)|]                                                   (let ((l2_s2 1))-                                                  (let ((l2_s1 (foo l2_s0)))+                                                  (let ((l2_s1 (|foo @(SBV Integer -> SBV Integer)| l2_s0)))                                                   (let ((l2_s3 (+ l2_s1 l2_s2)))                                                   l2_s3)))-          ; Definition of: foo :: SInteger -> SInteger. [Refers to: bar]+          ; Definition of: |foo @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger. [Refers to: |bar @(SBV Integer -> SBV Integer)|]                                   (let ((l1_s2 1))-                                  (let ((l1_s1 (bar l1_s0)))+                                  (let ((l1_s1 (|bar @(SBV Integer -> SBV Integer)| l1_s0)))                                   (let ((l1_s3 (+ l1_s1 l1_s2)))                                   l1_s3))))) [GOOD] ; --- assignments ----[GOOD] (define-fun s1 () Int (foo s0))-[GOOD] (define-fun s2 () Int (bar s0))+[GOOD] (define-fun s1 () Int (|foo @(SBV Integer -> SBV Integer)| s0))+[GOOD] (define-fun s2 () Int (|bar @(SBV Integer -> SBV Integer)| s0)) [GOOD] (define-fun s3 () Int (+ s1 s2)) [GOOD] (define-fun s4 () Bool (= s0 s3)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s4) [GOOD] (declare-fun s5 () Int)-[GOOD] (define-fun s6 () Int (foo s5))-[GOOD] (define-fun s7 () Int (bar s5))+[GOOD] (define-fun s6 () Int (|foo @(SBV Integer -> SBV Integer)| s5))+[GOOD] (define-fun s7 () Int (|bar @(SBV Integer -> SBV Integer)| s5)) [GOOD] (define-fun s8 () Int (+ s6 s7)) [GOOD] (define-fun s9 () Bool (= s5 s8)) [GOOD] (assert s9)
SBVTestSuite/GoldFiles/lambda57.gold view
@@ -16,72 +16,72 @@ [GOOD] ; --- non-constant tables --- [GOOD] ; --- uninterpreted constants --- [GOOD] ; --- user defined functions ----[GOOD] ; f1 :: SWord8 -> SWord8, f2 :: SWord8 -> SWord8, f3 :: SWord8 -> SWord8, f4 :: SWord8 -> SWord8+[GOOD] ; |f1 @(SBV Word8 -> SBV Word8)| :: SWord8 -> SWord8, |f2 @(SBV Word8 -> SBV Word8)| :: SWord8 -> SWord8, |f3 @(SBV Word8 -> SBV Word8)| :: SWord8 -> SWord8, |f4 @(SBV Word8 -> SBV Word8)| :: SWord8 -> SWord8 [GOOD] (define-funs-rec-         ((f1 ((l1_s0 (_ BitVec 8))) (_ BitVec 8))-          (f2 ((l2_s0 (_ BitVec 8))) (_ BitVec 8))-          (f3 ((l3_s0 (_ BitVec 8))) (_ BitVec 8))-          (f4 ((l4_s0 (_ BitVec 8))) (_ BitVec 8)))-         (; Definition of: f1 :: SWord8 -> SWord8. [Refers to: f1, f2]+         ((|f1 @(SBV Word8 -> SBV Word8)| ((l1_s0 (_ BitVec 8))) (_ BitVec 8))+          (|f2 @(SBV Word8 -> SBV Word8)| ((l2_s0 (_ BitVec 8))) (_ BitVec 8))+          (|f3 @(SBV Word8 -> SBV Word8)| ((l3_s0 (_ BitVec 8))) (_ BitVec 8))+          (|f4 @(SBV Word8 -> SBV Word8)| ((l4_s0 (_ BitVec 8))) (_ BitVec 8)))+         (; Definition of: |f1 @(SBV Word8 -> SBV Word8)| :: SWord8 -> SWord8. [Refers to: |f1 @(SBV Word8 -> SBV Word8)|, |f2 @(SBV Word8 -> SBV Word8)|]                                   (let ((l1_s1 #x00))                                   (let ((l1_s3 #x01))                                   (let ((l1_s6 #x02))                                   (let ((l1_s2 (= l1_s0 l1_s1)))                                   (let ((l1_s4 (bvsub l1_s0 l1_s3)))-                                  (let ((l1_s5 (f1 l1_s4)))+                                  (let ((l1_s5 (|f1 @(SBV Word8 -> SBV Word8)| l1_s4)))                                   (let ((l1_s7 (bvsub l1_s0 l1_s6)))-                                  (let ((l1_s8 (f2 l1_s7)))+                                  (let ((l1_s8 (|f2 @(SBV Word8 -> SBV Word8)| l1_s7)))                                   (let ((l1_s9 (bvadd l1_s5 l1_s8)))                                   (let ((l1_s10 (bvadd l1_s3 l1_s9)))                                   (let ((l1_s11 (ite l1_s2 l1_s1 l1_s10)))                                   l1_s11)))))))))))-          ; Definition of: f2 :: SWord8 -> SWord8. [Refers to: f2, f3]+          ; Definition of: |f2 @(SBV Word8 -> SBV Word8)| :: SWord8 -> SWord8. [Refers to: |f2 @(SBV Word8 -> SBV Word8)|, |f3 @(SBV Word8 -> SBV Word8)|]                                                   (let ((l2_s1 #x00))                                                   (let ((l2_s3 #x01))                                                   (let ((l2_s6 #x02))                                                   (let ((l2_s2 (= l2_s0 l2_s1)))                                                   (let ((l2_s4 (bvsub l2_s0 l2_s3)))-                                                  (let ((l2_s5 (f2 l2_s4)))+                                                  (let ((l2_s5 (|f2 @(SBV Word8 -> SBV Word8)| l2_s4)))                                                   (let ((l2_s7 (bvsub l2_s0 l2_s6)))-                                                  (let ((l2_s8 (f3 l2_s7)))+                                                  (let ((l2_s8 (|f3 @(SBV Word8 -> SBV Word8)| l2_s7)))                                                   (let ((l2_s9 (bvadd l2_s5 l2_s8)))                                                   (let ((l2_s10 (bvadd l2_s3 l2_s9)))                                                   (let ((l2_s11 (ite l2_s2 l2_s1 l2_s10)))                                                   l2_s11)))))))))))-          ; Definition of: f3 :: SWord8 -> SWord8. [Refers to: f3, f4]+          ; Definition of: |f3 @(SBV Word8 -> SBV Word8)| :: SWord8 -> SWord8. [Refers to: |f3 @(SBV Word8 -> SBV Word8)|, |f4 @(SBV Word8 -> SBV Word8)|]                                                                   (let ((l3_s1 #x00))                                                                   (let ((l3_s3 #x01))                                                                   (let ((l3_s6 #x02))                                                                   (let ((l3_s2 (= l3_s0 l3_s1)))                                                                   (let ((l3_s4 (bvsub l3_s0 l3_s3)))-                                                                  (let ((l3_s5 (f3 l3_s4)))+                                                                  (let ((l3_s5 (|f3 @(SBV Word8 -> SBV Word8)| l3_s4)))                                                                   (let ((l3_s7 (bvsub l3_s0 l3_s6)))-                                                                  (let ((l3_s8 (f4 l3_s7)))+                                                                  (let ((l3_s8 (|f4 @(SBV Word8 -> SBV Word8)| l3_s7)))                                                                   (let ((l3_s9 (bvadd l3_s5 l3_s8)))                                                                   (let ((l3_s10 (bvadd l3_s3 l3_s9)))                                                                   (let ((l3_s11 (ite l3_s2 l3_s1 l3_s10)))                                                                   l3_s11)))))))))))-          ; Definition of: f4 :: SWord8 -> SWord8. [Refers to: f1, f4]+          ; Definition of: |f4 @(SBV Word8 -> SBV Word8)| :: SWord8 -> SWord8. [Refers to: |f1 @(SBV Word8 -> SBV Word8)|, |f4 @(SBV Word8 -> SBV Word8)|]                                                                                   (let ((l4_s1 #x00))                                                                                   (let ((l4_s3 #x01))                                                                                   (let ((l4_s6 #x02))                                                                                   (let ((l4_s2 (= l4_s0 l4_s1)))                                                                                   (let ((l4_s4 (bvsub l4_s0 l4_s3)))-                                                                                  (let ((l4_s5 (f4 l4_s4)))+                                                                                  (let ((l4_s5 (|f4 @(SBV Word8 -> SBV Word8)| l4_s4)))                                                                                   (let ((l4_s7 (bvsub l4_s0 l4_s6)))-                                                                                  (let ((l4_s8 (f1 l4_s7)))+                                                                                  (let ((l4_s8 (|f1 @(SBV Word8 -> SBV Word8)| l4_s7)))                                                                                   (let ((l4_s9 (bvadd l4_s5 l4_s8)))                                                                                   (let ((l4_s10 (bvadd l4_s3 l4_s9)))                                                                                   (let ((l4_s11 (ite l4_s2 l4_s1 l4_s10)))                                                                                   l4_s11))))))))))))) [GOOD] ; --- assignments ----[GOOD] (define-fun s1 () (_ BitVec 8) (f1 s0))+[GOOD] (define-fun s1 () (_ BitVec 8) (|f1 @(SBV Word8 -> SBV Word8)| s0)) [GOOD] (define-fun s2 () Bool (= s0 s1)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula --- [GOOD] (assert s2) [GOOD] (declare-fun s3 () (_ BitVec 8))-[GOOD] (define-fun s4 () (_ BitVec 8) (f1 s3))+[GOOD] (define-fun s4 () (_ BitVec 8) (|f1 @(SBV Word8 -> SBV Word8)| s3)) [GOOD] (define-fun s5 () Bool (= s3 s4)) [GOOD] (assert s5) [SEND] (check-sat)
SBVTestSuite/GoldFiles/lambda65.gold view
@@ -16,18 +16,18 @@ [GOOD] ; --- uninterpreted constants --- [GOOD] (declare-fun __internal_sbv_IsPartialOrder__poI_ (Int Int) Bool) [GOOD] ; --- user defined functions ----[GOOD] ; leq :: SInteger -> SInteger -> SBool-[GOOD] (define-fun leq ((l2_s0 Int) (l2_s1 Int)) Bool+[GOOD] ; |leq @(SBV Integer -> SBV Integer -> SBV Bool)| :: SInteger -> SInteger -> SBool+[GOOD] (define-fun |leq @(SBV Integer -> SBV Integer -> SBV Bool)| ((l2_s0 Int) (l2_s1 Int)) Bool          (<= l2_s0 l2_s1)) [GOOD] ; --- assignments --- [GOOD] (define-fun s0 () Bool (forall ((l1_s0 Int) (l1_s1 Int))-                                 (let ((l1_s2 (leq l1_s0 l1_s1)))+                                 (let ((l1_s2 (|leq @(SBV Integer -> SBV Integer -> SBV Bool)| l1_s0 l1_s1)))                                  (let ((l1_s3 (__internal_sbv_IsPartialOrder__poI_ l1_s0 l1_s1)))                                  (let ((l1_s4 (= l1_s2 l1_s3)))                                  l1_s4))))) [GOOD] (define-fun s1 () Bool (forall ((x Int) (y Int)) (= (__internal_sbv_IsPartialOrder__poI_ x y) ((_ partial-order 0) x y)))) [GOOD] (define-fun s2 () Bool (forall ((l1_s0 Int))-         (leq l1_s0 l1_s0)))+         (|leq @(SBV Integer -> SBV Integer -> SBV Bool)| l1_s0 l1_s0))) [GOOD] (define-fun s3 () Bool (=> s1 s2)) [GOOD] ; --- delayedEqualities --- [GOOD] ; --- formula ---
SBVTestSuite/GoldFiles/lambda71.gold view
@@ -1,13 +1,13 @@ ; Automatically generated by SBV. Do not modify!-; bar :: SInteger -> SInteger [Recursive]-(define-fun-rec bar ((l2_s0 Int)) Int+; |bar @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger [Recursive]+(define-fun-rec |bar @(SBV Integer -> SBV Integer)| ((l2_s0 Int)) Int                                           (let ((l2_s1 1))                                           (let ((l2_s2 (- l2_s0 l2_s1)))-                                          (let ((l2_s3 (bar l2_s2)))+                                          (let ((l2_s3 (|bar @(SBV Integer -> SBV Integer)| l2_s2)))                                           l2_s3))))-; foo :: SInteger -> SInteger [Refers to: bar]-(define-fun foo ((l1_s0 Int)) Int+; |foo @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger [Refers to: |bar @(SBV Integer -> SBV Integer)|]+(define-fun |foo @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int                           (let ((l1_s1 1))                           (let ((l1_s2 (- l1_s0 l1_s1)))-                          (let ((l1_s3 (bar l1_s2)))+                          (let ((l1_s3 (|bar @(SBV Integer -> SBV Integer)| l1_s2)))                           l1_s3))))
SBVTestSuite/GoldFiles/lambda72.gold view
@@ -1,7 +1,7 @@ ; Automatically generated by SBV. Do not modify!-; bar :: SInteger -> SInteger [Recursive]-(define-fun-rec bar ((l1_s0 Int)) Int+; |bar @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger [Recursive]+(define-fun-rec |bar @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int                           (let ((l1_s1 1))                           (let ((l1_s2 (- l1_s0 l1_s1)))-                          (let ((l1_s3 (bar l1_s2)))+                          (let ((l1_s3 (|bar @(SBV Integer -> SBV Integer)| l1_s2)))                           l1_s3))))
SBVTestSuite/GoldFiles/lambda73.gold view
@@ -1,6 +1,6 @@ ; Automatically generated by SBV. Do not modify!-; baz :: SInteger -> SInteger-(define-fun baz ((l1_s0 Int)) Int+; |baz @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger+(define-fun |baz @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int                           (let ((l1_s1 1))                           (let ((l1_s2 (+ l1_s0 l1_s1)))                           l1_s2)))
SBVTestSuite/GoldFiles/lambda74.gold view
@@ -1,15 +1,15 @@ ; Automatically generated by SBV. Do not modify!-; e :: SInteger -> SInteger, o :: SInteger -> SInteger+; |e @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger, |o @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger (define-funs-rec-  ((e ((l1_s0 Int)) Int)-   (o ((l2_s0 Int)) Int))-  (; Definition of: e :: SInteger -> SInteger. [Refers to: o]+  ((|e @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int)+   (|o @(SBV Integer -> SBV Integer)| ((l2_s0 Int)) Int))+  (; Definition of: |e @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger. [Refers to: |o @(SBV Integer -> SBV Integer)|]                            (let ((l1_s1 1))                            (let ((l1_s2 (- l1_s0 l1_s1)))-                           (let ((l1_s3 (o l1_s2)))+                           (let ((l1_s3 (|o @(SBV Integer -> SBV Integer)| l1_s2)))                            l1_s3)))-   ; Definition of: o :: SInteger -> SInteger. [Refers to: e]+   ; Definition of: |o @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger. [Refers to: |e @(SBV Integer -> SBV Integer)|]                                            (let ((l2_s1 1))                                            (let ((l2_s2 (- l2_s0 l2_s1)))-                                           (let ((l2_s3 (e l2_s2)))+                                           (let ((l2_s3 (|e @(SBV Integer -> SBV Integer)| l2_s2)))                                            l2_s3)))))
SBVTestSuite/GoldFiles/lambda75.gold view
@@ -1,15 +1,15 @@ ; Automatically generated by SBV. Do not modify!-; e :: SInteger -> SInteger, o :: SInteger -> SInteger+; |e @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger, |o @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger (define-funs-rec-  ((e ((l2_s0 Int)) Int)-   (o ((l1_s0 Int)) Int))-  (; Definition of: e :: SInteger -> SInteger. [Refers to: o]+  ((|e @(SBV Integer -> SBV Integer)| ((l2_s0 Int)) Int)+   (|o @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int))+  (; Definition of: |e @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger. [Refers to: |o @(SBV Integer -> SBV Integer)|]                                            (let ((l2_s1 1))                                            (let ((l2_s2 (- l2_s0 l2_s1)))-                                           (let ((l2_s3 (o l2_s2)))+                                           (let ((l2_s3 (|o @(SBV Integer -> SBV Integer)| l2_s2)))                                            l2_s3)))-   ; Definition of: o :: SInteger -> SInteger. [Refers to: e]+   ; Definition of: |o @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger. [Refers to: |e @(SBV Integer -> SBV Integer)|]                            (let ((l1_s1 1))                            (let ((l1_s2 (- l1_s0 l1_s1)))-                           (let ((l1_s3 (e l1_s2)))+                           (let ((l1_s3 (|e @(SBV Integer -> SBV Integer)| l1_s2)))                            l1_s3)))))
SBVTestSuite/GoldFiles/lambda79.gold view
@@ -1,6 +1,6 @@ ; Automatically generated by SBV. Do not modify!-; foo :: SInteger -> SWord32-(define-fun foo ((l1_s0 Int)) (_ BitVec 32)+; |foo @(SBV Integer -> SBV Word32)| :: SInteger -> SWord32+(define-fun |foo @(SBV Integer -> SBV Word32)| ((l1_s0 Int)) (_ BitVec 32)                           (let ((l1_s1 #x00000001))                           (let ((l1_s2 #x00000002))                           (let ((l1_s3 #x00000003))
SBVTestSuite/GoldFiles/lambda80.gold view
@@ -1,6 +1,6 @@ ; Automatically generated by SBV. Do not modify!-; foo :: SInteger -> SInteger-(define-fun foo ((l1_s0 Int)) Int+; |foo @(SBV Integer -> SBV Integer)| :: SInteger -> SInteger+(define-fun |foo @(SBV Integer -> SBV Integer)| ((l1_s0 Int)) Int                           (let ((l1_s1 1))                           (let ((l1_s3 2))                           (let ((l1_s5 3))
SBVTestSuite/GoldFiles/lambda81.gold view
@@ -1,10 +1,73 @@-CAUGHT EXCEPTION-+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-option :pp.max_depth      4294967295)+[GOOD] (set-option :pp.min_alias_size 4294967295)+[GOOD] (set-option :model.inline_def  true      )+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq Int))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.filter @(SBV Integer -> SBV Bool)_f7406d70a9 @(SBV [Integer] -> SBV [Integer])| :: [SInteger] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.filter @(SBV Integer -> SBV Bool)_f7406d70a9 @(SBV [Integer] -> SBV [Integer])| ((l1_s0 (Seq Int))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s6 4))+                                 (let ((l1_s9 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (> l1_s5 l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s5)))+                                 (let ((l1_s10 (- l1_s1 l1_s9)))+                                 (let ((l1_s11 (seq.extract l1_s0 l1_s9 l1_s10)))+                                 (let ((l1_s12 (|sbv.filter @(SBV Integer -> SBV Bool)_f7406d70a9 @(SBV [Integer] -> SBV [Integer])| l1_s11)))+                                 (let ((l1_s13 (seq.++ l1_s8 l1_s12)))+                                 (let ((l1_s14 (ite l1_s7 l1_s13 l1_s12)))+                                 (let ((l1_s15 (ite l1_s3 l1_s4 l1_s14)))+                                 l1_s15))))))))))))))))+[GOOD] ; |sbv.filter @(SBV Integer -> SBV Bool)_2611d6a22d @(SBV [Integer] -> SBV [Integer])| :: [SInteger] -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.filter @(SBV Integer -> SBV Bool)_2611d6a22d @(SBV [Integer] -> SBV [Integer])| ((l1_s0 (Seq Int))) (Seq Int)+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq Int))))+                                 (let ((l1_s9 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s6 (seq.nth s0 l1_s2)))+                                 (let ((l1_s7 (> l1_s5 l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s5)))+                                 (let ((l1_s10 (- l1_s1 l1_s9)))+                                 (let ((l1_s11 (seq.extract l1_s0 l1_s9 l1_s10)))+                                 (let ((l1_s12 (|sbv.filter @(SBV Integer -> SBV Bool)_2611d6a22d @(SBV [Integer] -> SBV [Integer])| l1_s11)))+                                 (let ((l1_s13 (seq.++ l1_s8 l1_s12)))+                                 (let ((l1_s14 (ite l1_s7 l1_s13 l1_s12)))+                                 (let ((l1_s15 (ite l1_s3 l1_s4 l1_s14)))+                                 l1_s15))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () (Seq Int) (|sbv.filter @(SBV Integer -> SBV Bool)_2611d6a22d @(SBV [Integer] -> SBV [Integer])| s0))+[GOOD] (define-fun s2 () (Seq Int) (|sbv.filter @(SBV Integer -> SBV Bool)_f7406d70a9 @(SBV [Integer] -> SBV [Integer])| s0))+[GOOD] (define-fun s3 () Bool (distinct s1 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s3)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (seq.unit 5)))+*** Solver   : Z3+*** Exit code: ExitSuccess -*** Data.SBV.Lambda: Detected nested lambda-definitions.-***-*** SBV uses firstification to deal-with lambdas, and SMTLib's first-order nature does not allow-*** for easy translation of nested lambdas. As SMTLib gets higher-order features, SBV will eventually-*** relax this restriction. In the mean-time, please rewrite your program without using nested-lambdas-*** if possible. If this workaround isn't applicable, please report this as a use-case for further-*** possible enhancements.+ FINAL:"  s0 = [5] :: [Integer]"+DONE!
+ SBVTestSuite/GoldFiles/lambda82.gold view
@@ -0,0 +1,81 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-option :pp.max_depth      4294967295)+[GOOD] (set-option :pp.min_alias_size 4294967295)+[GOOD] (set-option :model.inline_def  true      )+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5)))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq Int))+[GOOD] (declare-fun s1 () (Seq (Seq Int)))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.map @(SBV Integer -> SBV [Integer])_136c80b6a3 @(SBV [Integer] -> SBV [[Integer]])| :: [SInteger] -> [[SInteger]] [Recursive]+[GOOD] (define-fun-rec |sbv.map @(SBV Integer -> SBV [Integer])_136c80b6a3 @(SBV [Integer] -> SBV [[Integer]])| ((l1_s0 (Seq Int))) (Seq (Seq Int))+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq (Seq Int)))))+                                 (let ((l1_s6 4))+                                 (let ((l1_s9 5))+                                 (let ((l1_s12 6))+                                 (let ((l1_s15 (as seq.empty (Seq Int))))+                                 (let ((l1_s20 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (+ l1_s5 l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s7)))+                                 (let ((l1_s10 (+ l1_s5 l1_s9)))+                                 (let ((l1_s11 (seq.unit l1_s10)))+                                 (let ((l1_s13 (+ l1_s5 l1_s12)))+                                 (let ((l1_s14 (seq.unit l1_s13)))+                                 (let ((l1_s16 (seq.++ l1_s14 l1_s15)))+                                 (let ((l1_s17 (seq.++ l1_s11 l1_s16)))+                                 (let ((l1_s18 (seq.++ l1_s8 l1_s17)))+                                 (let ((l1_s19 (seq.unit l1_s18)))+                                 (let ((l1_s21 (- l1_s1 l1_s20)))+                                 (let ((l1_s22 (seq.extract l1_s0 l1_s20 l1_s21)))+                                 (let ((l1_s23 (|sbv.map @(SBV Integer -> SBV [Integer])_136c80b6a3 @(SBV [Integer] -> SBV [[Integer]])| l1_s22)))+                                 (let ((l1_s24 (seq.++ l1_s19 l1_s23)))+                                 (let ((l1_s25 (ite l1_s3 l1_s4 l1_s24)))+                                 l1_s25))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s3 () Bool (= s0 s2))+[GOOD] (define-fun s4 () (Seq (Seq Int)) (|sbv.map @(SBV Integer -> SBV [Integer])_136c80b6a3 @(SBV [Integer] -> SBV [[Integer]])| s0))+[GOOD] (define-fun s5 () Bool (= s1 s4))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s3)+[GOOD] (assert s5)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s1))+[RECV] ((s1 (seq.++ (seq.unit (seq.++ (seq.unit 5) (seq.unit 6) (seq.unit 7)))+               (seq.unit (seq.++ (seq.unit 6) (seq.unit 7) (seq.unit 8)))+               (seq.unit (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9)))+               (seq.unit (seq.++ (seq.unit 8) (seq.unit 9) (seq.unit 10)))+               (seq.unit (seq.++ (seq.unit 9) (seq.unit 10) (seq.unit 11))))))+[SEND] (get-value (s0))+[RECV] ((s0 (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5))))+[SEND] (get-value (s1))+[RECV] ((s1 (seq.++ (seq.unit (seq.++ (seq.unit 5) (seq.unit 6) (seq.unit 7)))+               (seq.unit (seq.++ (seq.unit 6) (seq.unit 7) (seq.unit 8)))+               (seq.unit (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9)))+               (seq.unit (seq.++ (seq.unit 8) (seq.unit 9) (seq.unit 10)))+               (seq.unit (seq.++ (seq.unit 9) (seq.unit 10) (seq.unit 11))))))+*** Solver   : Z3+*** Exit code: ExitSuccess++RESULT:+  s0 =                                  [1,2,3,4,5] :: [Integer]+  s1 = [[5,6,7],[6,7,8],[7,8,9],[8,9,10],[9,10,11]] :: [[Integer]]
+ SBVTestSuite/GoldFiles/lambda83.gold view
@@ -0,0 +1,32 @@+CAUGHT EXCEPTION+++*** Data.SBV.Lambda: Detected free variables passed to a lambda.+***+***  Free vars : args0+***  Definition: (lambda ((s0 Int))+***                (+ args0 s0))+***+*** SBV currently does not support lambda-functions that capture variables. For+*** instance, consider:+***+***     map (\x -> map (\y -> x + y))+***+*** where the inner 'map' uses 'x', bound by the outer 'map'. Instead, create+*** a closure instead:+***+***     map (\x -> map (Closure { closureEnv = x+***                             , closureFun = \env y -> env + y+***                             }))+***+*** which will explicitly create the closure before calling 'map'. The environment can+*** be any symbolic value: You can use a tuple to support multiple free variables.+***+*** (SBV firstifies higher-order functions via a simple translation to make it fit with+*** SMTLib's first-order logic. This translation does not currently support free+*** variables. In technical terms, we would need to do closure conversion and lambda-lifting.+*** SBV isn't capable of doing the closure-conversion part, relying on the user to do so.)+***+*** Please rewrite your program to create a closure and use that as an argument.+*** If this solution isn't applicable, or if you'd like help doing so, please get in+*** touch for further possible enhancements.
+ SBVTestSuite/GoldFiles/lambda84.gold view
@@ -0,0 +1,32 @@+CAUGHT EXCEPTION+++*** Data.SBV.Lambda: Detected free variables passed to a lambda.+***+***  Free vars : args0+***  Definition: (lambda ((s0 (Seq Int)))+***                (seq.++ s0 args0))+***+*** SBV currently does not support lambda-functions that capture variables. For+*** instance, consider:+***+***     map (\x -> map (\y -> x + y))+***+*** where the inner 'map' uses 'x', bound by the outer 'map'. Instead, create+*** a closure instead:+***+***     map (\x -> map (Closure { closureEnv = x+***                             , closureFun = \env y -> env + y+***                             }))+***+*** which will explicitly create the closure before calling 'map'. The environment can+*** be any symbolic value: You can use a tuple to support multiple free variables.+***+*** (SBV firstifies higher-order functions via a simple translation to make it fit with+*** SMTLib's first-order logic. This translation does not currently support free+*** variables. In technical terms, we would need to do closure conversion and lambda-lifting.+*** SBV isn't capable of doing the closure-conversion part, relying on the user to do so.)+***+*** Please rewrite your program to create a closure and use that as an argument.+*** If this solution isn't applicable, or if you'd like help doing so, please get in+*** touch for further possible enhancements.
+ SBVTestSuite/GoldFiles/lambda85.gold view
@@ -0,0 +1,99 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-option :pp.max_depth      4294967295)+[GOOD] (set-option :pp.min_alias_size 4294967295)+[GOOD] (set-option :model.inline_def  true      )+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5) (seq.unit 6) (seq.unit 7) (seq.unit 8) (seq.unit 9) (seq.unit 10)))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq Int))+[GOOD] (declare-fun s1 () (SBVTuple2 (Seq Int) (Seq Int)))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.partition @(SBV Integer -> SBV Bool)_72b7bf5d4c @(SBV [Integer] -> SBV ([Integer],[Integer]))| :: [SInteger] -> ([SInteger], [SInteger]) [Recursive]+[GOOD] (define-fun-rec |sbv.partition @(SBV Integer -> SBV Bool)_72b7bf5d4c @(SBV [Integer] -> SBV ([Integer],[Integer]))| ((l1_s0 (Seq Int))) (SBVTuple2 (Seq Int) (Seq Int))+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (mkSBVTuple2 (as seq.empty (Seq Int)) (as seq.empty (Seq Int)))))+                                 (let ((l1_s6 2))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (mod l1_s5 l1_s6)))+                                 (let ((l1_s8 (= l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.unit l1_s5)))+                                 (let ((l1_s11 (- l1_s1 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s0 l1_s10 l1_s11)))+                                 (let ((l1_s13 (|sbv.partition @(SBV Integer -> SBV Bool)_72b7bf5d4c @(SBV [Integer] -> SBV ([Integer],[Integer]))| l1_s12)))+                                 (let ((l1_s14 (proj_1_SBVTuple2 l1_s13)))+                                 (let ((l1_s15 (seq.++ l1_s9 l1_s14)))+                                 (let ((l1_s16 (proj_2_SBVTuple2 l1_s13)))+                                 (let ((l1_s17 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) l1_s15 l1_s16)))+                                 (let ((l1_s18 (seq.++ l1_s9 l1_s16)))+                                 (let ((l1_s19 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) l1_s14 l1_s18)))+                                 (let ((l1_s20 (ite l1_s8 l1_s17 l1_s19)))+                                 (let ((l1_s21 (ite l1_s3 l1_s4 l1_s20)))+                                 l1_s21))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s3 () Bool (= s0 s2))+[GOOD] (define-fun s4 () (SBVTuple2 (Seq Int) (Seq Int)) (|sbv.partition @(SBV Integer -> SBV Bool)_72b7bf5d4c @(SBV [Integer] -> SBV ([Integer],[Integer]))| s0))+[GOOD] (define-fun s5 () Bool (= s1 s4))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s3)+[GOOD] (assert s5)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s1))+[RECV] ((s1 (mkSBVTuple2 (seq.++ (seq.unit 2)+                            (seq.unit 4)+                            (seq.unit 6)+                            (seq.unit 8)+                            (seq.unit 10))+                    (seq.++ (seq.unit 1)+                            (seq.unit 3)+                            (seq.unit 5)+                            (seq.unit 7)+                            (seq.unit 9)))))+[SEND] (get-value (s0))+[RECV] ((s0 (seq.++ (seq.unit 1)+               (seq.unit 2)+               (seq.unit 3)+               (seq.unit 4)+               (seq.unit 5)+               (seq.unit 6)+               (seq.unit 7)+               (seq.unit 8)+               (seq.unit 9)+               (seq.unit 10))))+[SEND] (get-value (s1))+[RECV] ((s1 (mkSBVTuple2 (seq.++ (seq.unit 2)+                            (seq.unit 4)+                            (seq.unit 6)+                            (seq.unit 8)+                            (seq.unit 10))+                    (seq.++ (seq.unit 1)+                            (seq.unit 3)+                            (seq.unit 5)+                            (seq.unit 7)+                            (seq.unit 9)))))+*** Solver   : Z3+*** Exit code: ExitSuccess++RESULT:+  s0 =     [1,2,3,4,5,6,7,8,9,10] :: [Integer]+  s1 = ([2,4,6,8,10],[1,3,5,7,9]) :: ([Integer], [Integer])
+ SBVTestSuite/GoldFiles/lambda86.gold view
@@ -0,0 +1,99 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-option :pp.max_depth      4294967295)+[GOOD] (set-option :pp.min_alias_size 4294967295)+[GOOD] (set-option :model.inline_def  true      )+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s2 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3) (seq.unit 4) (seq.unit 5) (seq.unit 6) (seq.unit 7) (seq.unit 8) (seq.unit 9) (seq.unit 10)))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq Int))+[GOOD] (declare-fun s1 () (SBVTuple2 (Seq Int) (Seq Int)))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.partition @(SBV Integer -> SBV Bool)_cb04f986c4 @(SBV [Integer] -> SBV ([Integer],[Integer]))| :: [SInteger] -> ([SInteger], [SInteger]) [Recursive]+[GOOD] (define-fun-rec |sbv.partition @(SBV Integer -> SBV Bool)_cb04f986c4 @(SBV [Integer] -> SBV ([Integer],[Integer]))| ((l1_s0 (Seq Int))) (SBVTuple2 (Seq Int) (Seq Int))+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (mkSBVTuple2 (as seq.empty (Seq Int)) (as seq.empty (Seq Int)))))+                                 (let ((l1_s6 2))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s7 (mod l1_s5 l1_s6)))+                                 (let ((l1_s8 (distinct l1_s2 l1_s7)))+                                 (let ((l1_s9 (seq.unit l1_s5)))+                                 (let ((l1_s11 (- l1_s1 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s0 l1_s10 l1_s11)))+                                 (let ((l1_s13 (|sbv.partition @(SBV Integer -> SBV Bool)_cb04f986c4 @(SBV [Integer] -> SBV ([Integer],[Integer]))| l1_s12)))+                                 (let ((l1_s14 (proj_1_SBVTuple2 l1_s13)))+                                 (let ((l1_s15 (seq.++ l1_s9 l1_s14)))+                                 (let ((l1_s16 (proj_2_SBVTuple2 l1_s13)))+                                 (let ((l1_s17 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) l1_s15 l1_s16)))+                                 (let ((l1_s18 (seq.++ l1_s9 l1_s16)))+                                 (let ((l1_s19 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq Int))) l1_s14 l1_s18)))+                                 (let ((l1_s20 (ite l1_s8 l1_s17 l1_s19)))+                                 (let ((l1_s21 (ite l1_s3 l1_s4 l1_s20)))+                                 l1_s21))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s3 () Bool (= s0 s2))+[GOOD] (define-fun s4 () (SBVTuple2 (Seq Int) (Seq Int)) (|sbv.partition @(SBV Integer -> SBV Bool)_cb04f986c4 @(SBV [Integer] -> SBV ([Integer],[Integer]))| s0))+[GOOD] (define-fun s5 () Bool (= s1 s4))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s3)+[GOOD] (assert s5)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s1))+[RECV] ((s1 (mkSBVTuple2 (seq.++ (seq.unit 1)+                            (seq.unit 3)+                            (seq.unit 5)+                            (seq.unit 7)+                            (seq.unit 9))+                    (seq.++ (seq.unit 2)+                            (seq.unit 4)+                            (seq.unit 6)+                            (seq.unit 8)+                            (seq.unit 10)))))+[SEND] (get-value (s0))+[RECV] ((s0 (seq.++ (seq.unit 1)+               (seq.unit 2)+               (seq.unit 3)+               (seq.unit 4)+               (seq.unit 5)+               (seq.unit 6)+               (seq.unit 7)+               (seq.unit 8)+               (seq.unit 9)+               (seq.unit 10))))+[SEND] (get-value (s1))+[RECV] ((s1 (mkSBVTuple2 (seq.++ (seq.unit 1)+                            (seq.unit 3)+                            (seq.unit 5)+                            (seq.unit 7)+                            (seq.unit 9))+                    (seq.++ (seq.unit 2)+                            (seq.unit 4)+                            (seq.unit 6)+                            (seq.unit 8)+                            (seq.unit 10)))))+*** Solver   : Z3+*** Exit code: ExitSuccess++RESULT:+  s0 =     [1,2,3,4,5,6,7,8,9,10] :: [Integer]+  s1 = ([1,3,5,7,9],[2,4,6,8,10]) :: ([Integer], [Integer])
+ SBVTestSuite/GoldFiles/lambda87.gold view
@@ -0,0 +1,114 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-option :pp.max_depth      4294967295)+[GOOD] (set-option :pp.min_alias_size 4294967295)+[GOOD] (set-option :model.inline_def  true      )+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3)))+[GOOD] (define-fun s5 () (Seq Int) (seq.++ (seq.unit 6) (seq.unit 7) (seq.unit 8)))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq Int))+[GOOD] (declare-fun s1 () (Seq Int))+[GOOD] (declare-fun s2 () (Seq (Seq Int)))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.closureMap @(SBV Integer -> SBV Integer -> SBV Integer)_d8dc9e6fbd @(SBV (Integer,[Integer]) -> SBV [Integer])| :: (SInteger, [SInteger]) -> [SInteger] [Recursive]+[GOOD] (define-fun-rec |sbv.closureMap @(SBV Integer -> SBV Integer -> SBV Integer)_d8dc9e6fbd @(SBV (Integer,[Integer]) -> SBV [Integer])| ((l1_s0 (SBVTuple2 Int (Seq Int)))) (Seq Int)+                                 (let ((l1_s3 0))+                                 (let ((l1_s5 (as seq.empty (Seq Int))))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s6 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s7 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s8 (+ l1_s6 l1_s7)))+                                 (let ((l1_s9 (seq.unit l1_s8)))+                                 (let ((l1_s11 (- l1_s2 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s1 l1_s10 l1_s11)))+                                 (let ((l1_s13 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s6 l1_s12)))+                                 (let ((l1_s14 (|sbv.closureMap @(SBV Integer -> SBV Integer -> SBV Integer)_d8dc9e6fbd @(SBV (Integer,[Integer]) -> SBV [Integer])| l1_s13)))+                                 (let ((l1_s15 (seq.++ l1_s9 l1_s14)))+                                 (let ((l1_s16 (ite l1_s4 l1_s5 l1_s15)))+                                 l1_s16)))))))))))))))))+[GOOD] ; |sbv.map @(SBV Integer -> SBV [Integer])_8a19cac1b3 @(SBV [Integer] -> SBV [[Integer]])| :: [SInteger] -> [[SInteger]] [Recursive] [Refers to: |sbv.closureMap @(SBV Integer -> SBV Integer -> SBV Integer)_d8dc9e6fbd @(SBV (Integer,[Integer]) -> SBV [Integer])|]+[GOOD] (define-fun-rec |sbv.map @(SBV Integer -> SBV [Integer])_8a19cac1b3 @(SBV [Integer] -> SBV [[Integer]])| ((l1_s0 (Seq Int))) (Seq (Seq Int))+                                 (let ((l1_s2 0))+                                 (let ((l1_s4 (as seq.empty (Seq (Seq Int)))))+                                 (let ((l1_s9 1))+                                 (let ((l1_s1 (seq.len l1_s0)))+                                 (let ((l1_s3 (= l1_s1 l1_s2)))+                                 (let ((l1_s5 (seq.nth l1_s0 l1_s2)))+                                 (let ((l1_s6 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) l1_s5 s0)))+                                 (let ((l1_s7 (|sbv.closureMap @(SBV Integer -> SBV Integer -> SBV Integer)_d8dc9e6fbd @(SBV (Integer,[Integer]) -> SBV [Integer])| l1_s6)))+                                 (let ((l1_s8 (seq.unit l1_s7)))+                                 (let ((l1_s10 (- l1_s1 l1_s9)))+                                 (let ((l1_s11 (seq.extract l1_s0 l1_s9 l1_s10)))+                                 (let ((l1_s12 (|sbv.map @(SBV Integer -> SBV [Integer])_8a19cac1b3 @(SBV [Integer] -> SBV [[Integer]])| l1_s11)))+                                 (let ((l1_s13 (seq.++ l1_s8 l1_s12)))+                                 (let ((l1_s14 (ite l1_s3 l1_s4 l1_s13)))+                                 l1_s14)))))))))))))))+[GOOD] ; |sbv.closureMap @(SBV Integer -> SBV Integer -> SBV Integer)_3339bda50c @(SBV (Integer,[Integer]) -> SBV [Integer])| :: (SInteger, [SInteger]) -> [SInteger] [Refers to: |sbv.closureMap @(SBV Integer -> SBV Integer -> SBV Integer)_d8dc9e6fbd @(SBV (Integer,[Integer]) -> SBV [Integer])|]+[GOOD] (define-fun |sbv.closureMap @(SBV Integer -> SBV Integer -> SBV Integer)_3339bda50c @(SBV (Integer,[Integer]) -> SBV [Integer])| ((s0 (SBVTuple2 Int (Seq Int)))) (Seq Int)+                 (let ((s3 0))+                 (let ((s5 (as seq.empty (Seq Int))))+                 (let ((s10 1))+                 (let ((s1 (proj_2_SBVTuple2 s0)))+                 (let ((s2 (seq.len s1)))+                 (let ((s4 (= s2 s3)))+                 (let ((s6 (proj_1_SBVTuple2 s0)))+                 (let ((s7 (seq.nth s1 s3)))+                 (let ((s8 (+ s6 s7)))+                 (let ((s9 (seq.unit s8)))+                 (let ((s11 (- s2 s10)))+                 (let ((s12 (seq.extract s1 s10 s11)))+                 (let ((s13 ((as mkSBVTuple2 (SBVTuple2 Int (Seq Int))) s6 s12)))+                 (let ((s14 (|sbv.closureMap @(SBV Integer -> SBV Integer -> SBV Integer)_d8dc9e6fbd @(SBV (Integer,[Integer]) -> SBV [Integer])| s13)))+                 (let ((s15 (seq.++ s9 s14)))+                 (let ((s16 (ite s4 s5 s15)))+                 s16)))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Bool (= s0 s3))+[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s7 () (Seq (Seq Int)) (|sbv.map @(SBV Integer -> SBV [Integer])_8a19cac1b3 @(SBV [Integer] -> SBV [[Integer]])| s1))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s4)+[GOOD] (assert s6)+[GOOD] (assert s8)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s2))+[RECV] ((s2 (seq.++ (seq.unit (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9)))+               (seq.unit (seq.++ (seq.unit 8) (seq.unit 9) (seq.unit 10)))+               (seq.unit (seq.++ (seq.unit 9) (seq.unit 10) (seq.unit 11))))))+[SEND] (get-value (s0))+[RECV] ((s0 (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3))))+[SEND] (get-value (s1))+[RECV] ((s1 (seq.++ (seq.unit 6) (seq.unit 7) (seq.unit 8))))+[SEND] (get-value (s2))+[RECV] ((s2 (seq.++ (seq.unit (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9)))+               (seq.unit (seq.++ (seq.unit 8) (seq.unit 9) (seq.unit 10)))+               (seq.unit (seq.++ (seq.unit 9) (seq.unit 10) (seq.unit 11))))))+*** Solver   : Z3+*** Exit code: ExitSuccess++RESULT:+  s0 =                      [1,2,3] :: [Integer]+  s1 =                      [6,7,8] :: [Integer]+  s2 = [[7,8,9],[8,9,10],[9,10,11]] :: [[Integer]]
+ SBVTestSuite/GoldFiles/lambda88.gold view
@@ -0,0 +1,90 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-option :pp.max_depth      4294967295)+[GOOD] (set-option :pp.min_alias_size 4294967295)+[GOOD] (set-option :model.inline_def  true      )+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+                                           ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+                                                         (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () (Seq (Seq Int)) (seq.++ (seq.unit (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3))) (seq.unit (seq.++ (seq.unit 4) (seq.unit 5) (seq.unit 6)))))+[GOOD] (define-fun s5 () (Seq Int) (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9)))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (Seq Int)))+[GOOD] (declare-fun s1 () (Seq Int))+[GOOD] (declare-fun s2 () (Seq (Seq Int)))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |sbv.closureMap @(SBV [Integer] -> SBV [Integer] -> SBV [Integer])_24b5487d7f @(SBV ([Integer],[[Integer]]) -> SBV [[Integer]])| :: ([SInteger], [[SInteger]]) -> [[SInteger]] [Recursive]+[GOOD] (define-fun-rec |sbv.closureMap @(SBV [Integer] -> SBV [Integer] -> SBV [Integer])_24b5487d7f @(SBV ([Integer],[[Integer]]) -> SBV [[Integer]])| ((l1_s0 (SBVTuple2 (Seq Int) (Seq (Seq Int))))) (Seq (Seq Int))+                                 (let ((l1_s3 0))+                                 (let ((l1_s5 (as seq.empty (Seq (Seq Int)))))+                                 (let ((l1_s10 1))+                                 (let ((l1_s1 (proj_2_SBVTuple2 l1_s0)))+                                 (let ((l1_s2 (seq.len l1_s1)))+                                 (let ((l1_s4 (= l1_s2 l1_s3)))+                                 (let ((l1_s6 (seq.nth l1_s1 l1_s3)))+                                 (let ((l1_s7 (proj_1_SBVTuple2 l1_s0)))+                                 (let ((l1_s8 (seq.++ l1_s6 l1_s7)))+                                 (let ((l1_s9 (seq.unit l1_s8)))+                                 (let ((l1_s11 (- l1_s2 l1_s10)))+                                 (let ((l1_s12 (seq.extract l1_s1 l1_s10 l1_s11)))+                                 (let ((l1_s13 ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq (Seq Int)))) l1_s7 l1_s12)))+                                 (let ((l1_s14 (|sbv.closureMap @(SBV [Integer] -> SBV [Integer] -> SBV [Integer])_24b5487d7f @(SBV ([Integer],[[Integer]]) -> SBV [[Integer]])| l1_s13)))+                                 (let ((l1_s15 (seq.++ l1_s9 l1_s14)))+                                 (let ((l1_s16 (ite l1_s4 l1_s5 l1_s15)))+                                 l1_s16)))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Bool (= s0 s3))+[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s7 () (SBVTuple2 (Seq Int) (Seq (Seq Int))) ((as mkSBVTuple2 (SBVTuple2 (Seq Int) (Seq (Seq Int)))) s1 s0))+[GOOD] (define-fun s8 () (Seq (Seq Int)) (|sbv.closureMap @(SBV [Integer] -> SBV [Integer] -> SBV [Integer])_24b5487d7f @(SBV ([Integer],[[Integer]]) -> SBV [[Integer]])| s7))+[GOOD] (define-fun s9 () Bool (= s2 s8))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s4)+[GOOD] (assert s6)+[GOOD] (assert s9)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s2))+[RECV] ((s2 (seq.++ (seq.unit (seq.++ (seq.unit 1)+                                 (seq.unit 2)+                                 (seq.unit 3)+                                 (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9))))+               (seq.unit (seq.++ (seq.unit 4)+                                 (seq.unit 5)+                                 (seq.unit 6)+                                 (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9)))))))+[SEND] (get-value (s0))+[RECV] ((s0 (seq.++ (seq.unit (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3)))+               (seq.unit (seq.++ (seq.unit 4) (seq.unit 5) (seq.unit 6))))))+[SEND] (get-value (s1))+[RECV] ((s1 (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9))))+[SEND] (get-value (s2))+[RECV] ((s2 (seq.++ (seq.unit (seq.++ (seq.unit 1)+                                 (seq.unit 2)+                                 (seq.unit 3)+                                 (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9))))+               (seq.unit (seq.++ (seq.unit 4)+                                 (seq.unit 5)+                                 (seq.unit 6)+                                 (seq.++ (seq.unit 7) (seq.unit 8) (seq.unit 9)))))))+*** Solver   : Z3+*** Exit code: ExitSuccess++RESULT:+  s0 =             [[1,2,3],[4,5,6]] :: [[Integer]]+  s1 =                       [7,8,9] :: [Integer]+  s2 = [[1,2,3,7,8,9],[4,5,6,7,8,9]] :: [[Integer]]
SBVTestSuite/GoldFiles/nonlinear_cvc5.gold view
@@ -4,7 +4,7 @@ [GOOD] (set-option :global-declarations true) [GOOD] (set-option :diagnostic-output-channel "stdout") [GOOD] (set-option :produce-models true)-[GOOD] (set-logic ALL) ; has algebraic reals, using catch-all.+[GOOD] (set-logic HO_ALL) ; has algebraic reals, using catch-all. [GOOD] ; --- uninterpreted sorts --- [GOOD] ; --- tuples --- [GOOD] ; --- sums ---
SBVTestSuite/GoldFiles/query1.gold view
@@ -73,7 +73,7 @@ [SEND] (get-info :reason-unknown) [RECV] (:reason-unknown "state of the most recent check-sat command is not known") [SEND] (get-info :version)-[RECV] (:version "4.15.1")+[RECV] (:version "4.15.3") [SEND] (get-info :status) [RECV] (:status sat) [GOOD] (define-fun s16 () Int 4)@@ -104,7 +104,7 @@ [SEND] (get-info :reason-unknown) [RECV] (:reason-unknown "unknown") [SEND] (get-info :version)-[RECV] (:version "4.15.1")+[RECV] (:version "4.15.3") [SEND] (get-info :memory) [RECV] unsupported [SEND] (get-info :time)
SBVTestSuite/SBVHLint.hs view
@@ -22,8 +22,6 @@     , "SBVTestSuite"     , "Documentation"     , "-i", "Use otherwise"-    , "-i", "Parse error"-    , "--cpp-simple"     ]  main :: IO ()
SBVTestSuite/SBVTest.hs view
@@ -24,6 +24,7 @@ import qualified TestSuite.Basics.AllSat import qualified TestSuite.Basics.ArbFloats import qualified TestSuite.Basics.ArithNoSolver+import qualified TestSuite.Basics.ArithNoSolver2 import qualified TestSuite.Basics.ArithSolver import qualified TestSuite.Basics.Assert import qualified TestSuite.Basics.BasicTests@@ -135,6 +136,7 @@                       , TestSuite.Basics.AllSat.tests                       , TestSuite.Basics.ArbFloats.tests                       , TestSuite.Basics.ArithNoSolver.tests+                      , TestSuite.Basics.ArithNoSolver2.tests                       , TestSuite.Basics.ArithSolver.tests                       , TestSuite.Basics.Assert.tests                       , TestSuite.Basics.BarrelRotate.tests
SBVTestSuite/TestSuite/Arrays/Query.hs view
@@ -68,7 +68,7 @@          setLogic QF_UFBV -        query $ do constrain $ i .== select [0 .. 255] 0 i+        query $ do constrain $ i .== select (map literal [0 .. 255]) 0 i                    _ <- checkSat                    getValue i @@ -87,10 +87,10 @@          setLogic QF_UFBV -        query $ do constrain $ i .== select [0 .. 255] 0 i+        query $ do constrain $ i .== select (map literal [0 .. 255]) 0 i                    _ <- checkSat                    iv <- getValue i-                   constrain $ j .== select [0 .. 255] 0 j+                   constrain $ j .== select (map literal [0 .. 255]) 0 j                    constrain $ i .== literal iv                    constrain $ j .== i+1                    _ <- checkSat
SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs view
@@ -11,6 +11,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE CPP              #-}+{-# LANGUAGE DataKinds        #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types       #-} {-# LANGUAGE TupleSections    #-}@@ -26,14 +27,11 @@ import Data.SBV.Internals import Utils.SBVTestFramework -import Data.Maybe (fromJust, isJust, fromMaybe)+import Data.Maybe (fromJust, fromMaybe) -import Data.List (genericIndex, isInfixOf, isPrefixOf, isSuffixOf, genericTake, genericDrop, genericLength)+import qualified Data.Char     as C -import qualified Data.Char       as C-import qualified Data.SBV.Char   as SC-import qualified Data.SBV.String as SS-import qualified Data.SBV.List   as SL+import qualified Data.SBV.Char () -- instances only  -- Test suite tests :: TestTree@@ -57,26 +55,6 @@         ++ genBoolTest           "/="            (/=) (./=)         ++ genBinTest            "xor"           xor         ++ genUnTest             "complement"    complement-        ++ genIntTest      False "setBit"        setBit-        ++ genIntTest      False "clearBit"      clearBit-        ++ genIntTest      False "complementBit" complementBit-        ++ genIntTest      True  "shift"         shift-        ++ genIntTest      True  "shiftL"        shiftL-        ++ genIntTest      True  "shiftR"        shiftR-        ++ genIntTest      True  "rotate"        rotate-        ++ genIntTest      True  "rotateL"       rotateL-        ++ genIntTest      True  "rotateR"       rotateR-        ++ genShiftRotTest       "shiftL_gen"    sShiftLeft-        ++ genShiftRotTest       "shiftR_gen"    sShiftRight-        ++ genShiftRotTest       "rotateL_gen"   sRotateLeft-        ++ genShiftRotTest       "rotateR_gen"   sRotateRight-        ++ genShiftMixSize-        ++ genBlasts-        ++ genCounts-        ++ genIntCasts-        ++ genChars-        ++ genStrings-        ++ genLists  genBinTest :: String -> (forall a. (Num a, Bits a) => a -> a -> a) -> [TestTree] genBinTest nm op = map mkTest $@@ -127,130 +105,6 @@   where pair (x, a) b = (x, show (fromIntegral a `asTypeOf` b) == show b)         mkTest (x, s) = testCase ("arithCF-" ++ nm ++ "." ++ x) (s `showsAs` "True") -genIntTest :: Bool -> String -> (forall a. (Num a, Bits a) => (a -> Int -> a)) -> [TestTree]-genIntTest overSized nm op = map mkTest $-        zipWith pair [("u8",  show x, show y, x `op` y) | x <- w8s,  y <- is (intSizeOf x)] [x `op` y | x <- sw8s,  y <- is (intSizeOf x)]-     ++ zipWith pair [("u16", show x, show y, x `op` y) | x <- w16s, y <- is (intSizeOf x)] [x `op` y | x <- sw16s, y <- is (intSizeOf x)]-     ++ zipWith pair [("u32", show x, show y, x `op` y) | x <- w32s, y <- is (intSizeOf x)] [x `op` y | x <- sw32s, y <- is (intSizeOf x)]-     ++ zipWith pair [("u64", show x, show y, x `op` y) | x <- w64s, y <- is (intSizeOf x)] [x `op` y | x <- sw64s, y <- is (intSizeOf x)]-     ++ zipWith pair [("s8",  show x, show y, x `op` y) | x <- i8s,  y <- is (intSizeOf x)] [x `op` y | x <- si8s,  y <- is (intSizeOf x)]-     ++ zipWith pair [("s16", show x, show y, x `op` y) | x <- i16s, y <- is (intSizeOf x)] [x `op` y | x <- si16s, y <- is (intSizeOf x)]-     ++ zipWith pair [("s32", show x, show y, x `op` y) | x <- i32s, y <- is (intSizeOf x)] [x `op` y | x <- si32s, y <- is (intSizeOf x)]-     ++ zipWith pair [("s64", show x, show y, x `op` y) | x <- i64s, y <- is (intSizeOf x)] [x `op` y | x <- si64s, y <- is (intSizeOf x)]-     ++ zipWith pair [("iUB", show x, show y, x `op` y) | x <- iUBs, y <- [0..10]]          [x `op` y | x <- siUBs, y <- [0..10]]-  where is sz = [0 .. sz - 1] ++ extras-          where extras-                 | overSized = map (sz +) ([0 .. 1] ++ [sz, sz+1])-                 | True      = []-        pair (t, x, y, a) b       = (t, x, y, show a, show b, show (fromIntegral a `asTypeOf` b) == show b)-        mkTest (t, x, y, a, b, s) = testCase ("arithCF-" ++ nm ++ "." ++ t ++ "_" ++ x ++ "_" ++ y ++ "_" ++ a ++ "_" ++ b) (s `showsAs` "True")--genShiftRotTest :: String -> (forall a. (SIntegral a, SDivisible (SBV a)) => (SBV a -> SBV a -> SBV a)) -> [TestTree]-genShiftRotTest nm op = map mkTest $-        zipWith pair [("u8",  show x, show y, literal x `op` y) | x <- w8s,  y <- is (intSizeOf x)] [x `op` y | x <- sw8s,  y <- is (intSizeOf x)]-     ++ zipWith pair [("u16", show x, show y, literal x `op` y) | x <- w16s, y <- is (intSizeOf x)] [x `op` y | x <- sw16s, y <- is (intSizeOf x)]-     ++ zipWith pair [("u32", show x, show y, literal x `op` y) | x <- w32s, y <- is (intSizeOf x)] [x `op` y | x <- sw32s, y <- is (intSizeOf x)]-     ++ zipWith pair [("u64", show x, show y, literal x `op` y) | x <- w64s, y <- is (intSizeOf x)] [x `op` y | x <- sw64s, y <- is (intSizeOf x)]-     ++ zipWith pair [("s8",  show x, show y, literal x `op` y) | x <- i8s,  y <- is (intSizeOf x)] [x `op` y | x <- si8s,  y <- is (intSizeOf x)]-     ++ zipWith pair [("s16", show x, show y, literal x `op` y) | x <- i16s, y <- is (intSizeOf x)] [x `op` y | x <- si16s, y <- is (intSizeOf x)]-     ++ zipWith pair [("s32", show x, show y, literal x `op` y) | x <- i32s, y <- is (intSizeOf x)] [x `op` y | x <- si32s, y <- is (intSizeOf x)]-     ++ zipWith pair [("s64", show x, show y, literal x `op` y) | x <- i64s, y <- is (intSizeOf x)] [x `op` y | x <- si64s, y <- is (intSizeOf x)]-     -- NB. No generic shift/rotate for SMTLib unbounded integers-  where is sz = let b :: Word32-                    b = fromIntegral sz-                in map (sFromIntegral . literal) $ [0 .. b - 1] ++ [b, b+1, 2*b, 2*b+1]-        pair (t, x, y, a) b       = (t, x, y, show a, show b, isJust (unliteral a) && isJust (unliteral b) && unliteral a == unliteral b)-        mkTest (t, x, y, a, b, s) = testCase ("arithCF-" ++ nm ++ "." ++ t ++ "_" ++ x ++ "_" ++ y ++ "_" ++ a ++ "_" ++ b) (s `showsAs` "True")---- A few tests for mixed-size shifts-genShiftMixSize :: [TestTree]-genShiftMixSize = map mkTest $-           [pair (show x, show y, "shl_w8_w16", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- w8s,  y <- yw16s]-        ++ [pair (show x, show y, "shr_w8_w16", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- w8s,  y <- yw16s]-        ++ [pair (show x, show y, "shl_w16_w8", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- w16s, y <- w8s]-        ++ [pair (show x, show y, "shr_w16_w8", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- w16s, y <- w8s]-        ++ [pair (show x, show y, "shl_i8_i16", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- i8s,  y <- yi16s]-        ++ [pair (show x, show y, "shr_i8_i16", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- i8s,  y <- yi16s]-        ++ [pair (show x, show y, "shl_i16_i8", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- i16s, y <- i8s, y >= 0]-        ++ [pair (show x, show y, "shr_i16_i8", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- i16s, y <- i8s, y >= 0]-        ++ [pair (show x, show y, "shl_w8_i16", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- w8s,  y <- yi16s]-        ++ [pair (show x, show y, "shr_w8_i16", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- w8s,  y <- yi16s]-        ++ [pair (show x, show y, "shl_w16_i8", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- w16s, y <- i8s, y >= 0]-        ++ [pair (show x, show y, "shr_w16_i8", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- w16s, y <- i8s, y >= 0]-        ++ [pair (show x, show y, "shl_i8_w16", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- i8s,  y <- yw16s]-        ++ [pair (show x, show y, "shr_i8_w16", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- i8s,  y <- yw16s]-        ++ [pair (show x, show y, "shl_i16_w8", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- i16s, y <- w8s]-        ++ [pair (show x, show y, "shr_i16_w8", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- i16s, y <- w8s]-   where pair :: (Eq a, SymVal a, Show a) => (String, String, String, SBV a, a) -> (String, Bool)-         pair (x, y, l, sr, lr) = (l ++ "." ++ x ++ "_" ++ y ++ "_" ++  show (unliteral sr) ++ "_" ++ show lr, isJust (unliteral sr) && unliteral sr == Just lr)-         mkTest (l, s) = testCase ("arithCF-genShiftMixSize" ++ l) (s `showsAs` "True")--         yi16s :: [Int16]-         yi16s = [0, 255, 256, 257, maxBound]--         yw16s :: [Word16]-         yw16s = [0, 255, 256, 257, maxBound]---genBlasts :: [TestTree]-genBlasts = map mkTest $-             [(show x, fromBitsLE (blastLE x) .== x) | x <- sw8s ]-          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- sw8s ]-          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- si8s ]-          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- si8s ]-          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- sw16s]-          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- sw16s]-          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- si16s]-          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- si16s]-          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- sw32s]-          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- sw32s]-          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- si32s]-          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- si32s]-          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- sw64s]-          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- sw64s]-          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- si64s]-          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- si64s]-  where mkTest (x, r) = testCase ("blast-" ++ x) (r `showsAs` "True")--genCounts :: [TestTree]-genCounts = map mkTest $-             [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SWord8 )) | x <- sw8s ]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SWord8 )) | x <- sw8s ]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SInt8  )) | x <- si8s ]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SInt8  )) | x <- si8s ]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SWord16)) | x <- sw16s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SWord16)) | x <- sw16s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SInt16 )) | x <- si16s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SInt16 )) | x <- si16s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SWord32)) | x <- sw32s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SWord32)) | x <- sw32s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SInt32 )) | x <- si32s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SInt32 )) | x <- si32s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SWord64)) | x <- sw64s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SWord64)) | x <- sw64s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SInt64 )) | x <- si64s]-          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SInt64 )) | x <- si64s]-  where mkTest (x, r) = testCase ("count-" ++ x) (r `showsAs` "True")--genIntCasts :: [TestTree]-genIntCasts = map mkTest $  cast w8s ++ cast w16s ++ cast w32s ++ cast w64s-                         ++ cast i8s ++ cast i16s ++ cast i32s ++ cast i64s-                         ++ cast iUBs-   where mkTest (x, r) = testCase ("intCast-" ++ x) (r `showsAs` "True")-         lhs x = sFromIntegral (literal x)-         rhs x = literal (fromIntegral x)-         cast :: forall a. (Show a, Integral a, SymVal a) => [a] -> [(String, SBool)]-         cast xs = toWords xs ++ toInts xs-         toWords xs =  [(show x, lhs x .== (rhs x :: SWord8 ))  | x <- xs]-                    ++ [(show x, lhs x .== (rhs x :: SWord16))  | x <- xs]-                    ++ [(show x, lhs x .== (rhs x :: SWord32))  | x <- xs]-                    ++ [(show x, lhs x .== (rhs x :: SWord64))  | x <- xs]-         toInts  xs =  [(show x, lhs x .== (rhs x :: SInt8 ))   | x <- xs]-                    ++ [(show x, lhs x .== (rhs x :: SInt16))   | x <- xs]-                    ++ [(show x, lhs x .== (rhs x :: SInt32))   | x <- xs]-                    ++ [(show x, lhs x .== (rhs x :: SInt64))   | x <- xs]-                    ++ [(show x, lhs x .== (rhs x :: SInteger)) | x <- xs]- genQRems :: [TestTree] genQRems = map mkTest $         zipWith pair [("divMod",  show x, show y, x `divMod0`  y) | x <- w8s,  y <- w8s ] [x `sDivMod`  y | x <- sw8s,  y <- sw8s ]@@ -459,204 +313,6 @@                      , ("fpIsPoint",        fpIsPoint,         \x -> not (isNaN x || isInfinite x))                      ] -genChars :: [TestTree]-genChars = map mkTest $  [("ord",           show c, check SC.ord             cord            c) | c <- cs]-                      ++ [("toLower",       show c, check SC.toLowerL1       C.toLower       c) | c <- cs]-                      ++ [("toUpper",       show c, check SC.toUpperL1       C.toUpper       c) | c <- cs]-                      ++ [("digitToInt",    show c, check SC.digitToInt      dig2Int         c) | c <- cs, digitToIntRange c]-                      ++ [("intToDigit",    show c, check SC.intToDigit      int2Dig         c) | c <- [0 .. 15]]-                      ++ [("isControl",     show c, check SC.isControlL1     C.isControl     c) | c <- cs]-                      ++ [("isSpace",       show c, check SC.isSpaceL1       C.isSpace       c) | c <- cs]-                      ++ [("isLower",       show c, check SC.isLowerL1       C.isLower       c) | c <- cs]-                      ++ [("isUpper",       show c, check SC.isUpperL1       C.isUpper       c) | c <- cs]-                      ++ [("isAlpha",       show c, check SC.isAlphaL1       C.isAlpha       c) | c <- cs]-                      ++ [("isAlphaNum",    show c, check SC.isAlphaNumL1    C.isAlphaNum    c) | c <- cs]-                      ++ [("isPrint",       show c, check SC.isPrintL1       C.isPrint       c) | c <- cs]-                      ++ [("isDigit",       show c, check SC.isDigit         C.isDigit       c) | c <- cs]-                      ++ [("isOctDigit",    show c, check SC.isOctDigit      C.isOctDigit    c) | c <- cs]-                      ++ [("isHexDigit",    show c, check SC.isHexDigit      C.isHexDigit    c) | c <- cs]-                      ++ [("isLetter",      show c, check SC.isLetterL1      C.isLetter      c) | c <- cs]-                      ++ [("isMark",        show c, check SC.isMarkL1        C.isMark        c) | c <- cs]-                      ++ [("isNumber",      show c, check SC.isNumberL1      C.isNumber      c) | c <- cs]-                      ++ [("isPunctuation", show c, check SC.isPunctuationL1 C.isPunctuation c) | c <- cs]-                      ++ [("isSymbol",      show c, check SC.isSymbolL1      C.isSymbol      c) | c <- cs]-                      ++ [("isSeparator",   show c, check SC.isSeparatorL1   C.isSeparator   c) | c <- cs]-                      ++ [("isAscii",       show c, check SC.isAscii         C.isAscii       c) | c <- cs]-                      ++ [("isLatin1",      show c, check SC.isLatin1        C.isLatin1      c) | c <- cs]-                      ++ [("isAsciiUpper",  show c, check SC.isAsciiUpper    C.isAsciiUpper  c) | c <- cs]-                      ++ [("isAsciiLower",  show c, check SC.isAsciiLower    C.isAsciiLower  c) | c <- cs]-  where digitToIntRange   = (`elem` "0123456789abcdefABCDEF")-        cord :: Char -> Integer-        cord = fromIntegral . C.ord-        dig2Int :: Char -> Integer-        dig2Int = fromIntegral . C.digitToInt-        int2Dig :: Integer -> Char-        int2Dig = C.intToDigit . fromIntegral-        mkTest (nm, x, t) = testCase ("genChars-" ++ nm ++ "." ++ x) (assert t)-        check sop cop arg = case unliteral (sop (literal arg)) of-                              Nothing -> False-                              Just x  -> x == cop arg--genStrings :: [TestTree]-genStrings = map mkTest1 (  [("length",        show s,                   check1 SS.length        strLen        s      ) | s <- ss                                                       ]-                         ++ [("null",          show s,                   check1 SS.null          null          s      ) | s <- ss                                                       ]-                         ++ [("head",          show s,                   check1 SS.head          head          s      ) | s <- ss, not (null s)                                         ]-                         ++ [("tail",          show s,                   check1 SS.tail          tail          s      ) | s <- ss, not (null s)                                         ]-                         ++ [("singleton",     show c,                   check1 SS.singleton     (: [])        c      ) | c <- cs                                                       ]-                         ++ [("implode",       show s,                   checkI SS.implode                     s      ) | s <- ss                                                       ]-                         ++ [("strToNat",      show s,                   check1 SS.strToNat      strToNat      s      ) | s <- ss                                                       ]-                         ++ [("natToStr",      show i,                   check1 SS.natToStr      natToStr      i      ) | i <- iUBs                                                     ])-          ++ map mkTest2 (  [("strToStrAt",    show s, show i,           check2 SS.strToStrAt    strToStrAt    s i    ) | s <- ss, i  <- range s                                        ]-                         ++ [("strToCharAt",   show s, show i,           check2 SS.strToCharAt   strToCharAt   s i    ) | s <- ss, i  <- range s                                        ]-                         ++ [("concat",        show s, show s1,          check2 SS.concat        (++)          s s1   ) | s <- ss, s1 <- ss                                             ]-                         ++ [("isInfixOf",     show s, show s1,          check2 SS.isInfixOf     isInfixOf     s s1   ) | s <- ss, s1 <- ss                                             ]-                         ++ [("isSuffixOf",    show s, show s1,          check2 SS.isSuffixOf    isSuffixOf    s s1   ) | s <- ss, s1 <- ss                                             ]-                         ++ [("isPrefixOf",    show s, show s1,          check2 SS.isPrefixOf    isPrefixOf    s s1   ) | s <- ss, s1 <- ss                                             ]-                         ++ [("take",          show s, show i,           check2 SS.take          genericTake   i s    ) | s <- ss, i <- iUBs                                            ]-                         ++ [("drop",          show s, show i,           check2 SS.drop          genericDrop   i s    ) | s <- ss, i <- iUBs                                            ]-                         ++ [("indexOf",       show s, show s1,          check2 SS.indexOf       indexOf       s s1   ) | s <- ss, s1 <- ss                                             ])-          ++ map mkTest3 (  [("subStr",        show s, show  i, show j,  check3 SS.subStr        subStr        s i  j ) | s <- ss, i  <- range s, j <- range s, i + j <= genericLength s]-                         ++ [("replace",       show s, show s1, show s2, check3 SS.replace       replace       s s1 s2) | s <- ss, s1 <- ss, s2 <- ss                                   ]-                         ++ [("offsetIndexOf", show s, show s1, show i,  check3 SS.offsetIndexOf offsetIndexOf s s1 i ) | s <- ss, s1 <- ss, i <- range s                               ])-  where strLen :: String -> Integer-        strLen = fromIntegral . length--        strToNat :: String -> Integer-        strToNat s-          | all C.isDigit s && not (null s) = read s-          | True                            = -1--        natToStr :: Integer -> String-        natToStr i-          | i >= 0 = show i-          | True   = ""--        range :: String -> [Integer]-        range s = map fromIntegral [0 .. length s - 1]--        indexOf :: String -> String -> Integer-        indexOf s1 s2 = go 0 s1-          where go i x-                 | s2 `isPrefixOf` x = i-                 | True              = case x of-                                          "" -> -1-                                          (_:r) -> go (i+1) r--        strToStrAt :: String -> Integer -> String-        s `strToStrAt` i = [s `strToCharAt` i]--        strToCharAt :: String -> Integer -> Char-        s `strToCharAt` i = s `genericIndex` i--        subStr :: String -> Integer -> Integer -> String-        subStr s i j = genericTake j (genericDrop i s)--        replace :: String -> String -> String -> String-        replace s "" y = y ++ s-        replace s x  y = go s-          where go "" = ""-                go h@(c:rest) | x `isPrefixOf` h = y ++ drop (length x) h-                              | True             = c : go rest--        offsetIndexOf :: String -> String -> Integer -> Integer-        offsetIndexOf x y i = case indexOf (genericDrop i x) y of-                                -1 -> -1-                                r  -> r+i--        mkTest1 (nm, x, t)       = testCase ("genStrings-" ++ nm ++ "." ++ x)                         (assert t)-        mkTest2 (nm, x, y, t)    = testCase ("genStrings-" ++ nm ++ "." ++ x ++ "_" ++ y)             (assert t)-        mkTest3 (nm, x, y, z, t) = testCase ("genStrings-" ++ nm ++ "." ++ x ++ "_" ++ y ++ "_" ++ z) (assert t)--        checkI sop s = case unliteral (sop (map literal s)) of-                         Nothing -> False-                         Just x  -> s == x--        check1 sop cop arg            = case unliteral (sop (literal arg)) of-                                          Nothing -> False-                                          Just x  -> x == cop arg-        check2 sop cop arg1 arg2      = case unliteral (sop (literal arg1) (literal arg2)) of-                                          Nothing -> False-                                          Just x  -> x == cop arg1 arg2-        check3 sop cop arg1 arg2 arg3 = case unliteral (sop (literal arg1) (literal arg2) (literal arg3)) of-                                          Nothing -> False-                                          Just x  -> x == cop arg1 arg2 arg3--genLists :: [TestTree]-genLists = map mkTest1 (   [("length",        show l,                   check1 SL.length        llen          l      ) | l <- sl                                                       ]-                        ++ [("null",          show l,                   check1 SL.null          null          l      ) | l <- sl                                                       ]-                        ++ [("head",          show l,                   check1 SL.head          head          l      ) | l <- sl, not (null l)                                         ]-                        ++ [("tail",          show l,                   check1 SL.tail          tail          l      ) | l <- sl, not (null l)                                         ]-                        ++ [("singleton",     show i,                   check1 SL.singleton     (: [])        i      ) | i <- iUBs                                                     ]-                        ++ [("implode",       show l,                   checkI SL.implode       id            l      ) | l <- sl                                                       ]-                        ++ [("concat",        show l,                   check1 SL.concat        concat        l      ) | l <- sll                                                      ]-                       )-        ++ map mkTest2 (   [("listToListAt",  show l, show i,           check2 SL.listToListAt  listToListAt  l i    ) | l <- sl, i  <- range l                                        ]-                        ++ [("elemAt",        show l, show i,           check2 SL.elemAt        elemAt        l i    ) | l <- sl, i  <- range l                                        ]-                        ++ [("append",        show l, show l1,          check2 (SL.++)          (++)          l l1   ) | l <- sl, l1 <- sl                                             ]-                        ++ [("isInfixOf",     show l, show l1,          check2 SL.isInfixOf     isInfixOf     l l1   ) | l <- sl, l1 <- sl                                             ]-                        ++ [("isSuffixOf",    show l, show l1,          check2 SL.isSuffixOf    isSuffixOf    l l1   ) | l <- sl, l1 <- sl                                             ]-                        ++ [("isPrefixOf",    show l, show l1,          check2 SL.isPrefixOf    isPrefixOf    l l1   ) | l <- sl, l1 <- sl                                             ]-                        ++ [("take",          show l, show i,           check2 SL.take          genericTake   i l    ) | l <- sl, i <- iUBs                                            ]-                        ++ [("drop",          show l, show i,           check2 SL.drop          genericDrop   i l    ) | l <- sl, i <- iUBs                                            ]-                        ++ [("indexOf",       show l, show l1,          check2 SL.indexOf       indexOf       l l1   ) | l <- sl, l1 <- sl                                             ])-        ++ map mkTest3 (   [("subList",       show l, show  i, show j,  check3 SL.subList       subList       l i  j ) | l <- sl, i  <- range l, j <- range l, i + j <= genericLength l]-                        ++ [("replace",       show l, show l1, show l2, check3 SL.replace       replace       l l1 l2) | l <- sl, l1 <- sl, l2 <- sl                                   ]-                        ++ [("offsetIndexOf", show l, show l1, show i,  check3 SL.offsetIndexOf offsetIndexOf l l1 i ) | l <- sl, l1 <- sl, i <- range l                               ])-  where llen :: [Integer] -> Integer-        llen = fromIntegral . length--        range :: [Integer] -> [Integer]-        range l = map fromIntegral [0 .. length l - 1]--        indexOf :: [Integer] -> [Integer] -> Integer-        indexOf s1 s2 = go 0 s1-          where go i x-                 | s2 `isPrefixOf` x = i-                 | True              = case x of-                                          []    -> -1-                                          (_:r) -> go (i+1) r--        listToListAt :: [Integer] -> Integer -> [Integer]-        s `listToListAt` i = [s `elemAt` i]--        elemAt :: [Integer] -> Integer -> Integer-        l `elemAt` i = l `genericIndex` i--        subList :: [Integer] -> Integer -> Integer -> [Integer]-        subList s i j = genericTake j (genericDrop i s)--        replace :: [Integer] -> [Integer] -> [Integer] -> [Integer]-        replace s [] y = y ++ s-        replace s x  y = go s-          where go [] = []-                go h@(c:rest) | x `isPrefixOf` h = y ++ drop (length x) h-                              | True             = c : go rest--        offsetIndexOf :: [Integer] -> [Integer] -> Integer -> Integer-        offsetIndexOf x y i = case indexOf (genericDrop i x) y of-                                -1 -> -1-                                r  -> r+i--        mkTest1 (nm, x, t)       = testCase ("genLists-" ++ nm ++ "." ++ x)                         (assert t)-        mkTest2 (nm, x, y, t)    = testCase ("genLists-" ++ nm ++ "." ++ x ++ "_" ++ y)             (assert t)-        mkTest3 (nm, x, y, z, t) = testCase ("genLists-" ++ nm ++ "." ++ x ++ "_" ++ y ++ "_" ++ z) (assert t)--        checkI sop cop arg = case unliteral (sop (map literal arg)) of-                               Nothing -> False-                               Just x  -> x == cop arg--        check1 sop cop arg            = case unliteral (sop (literal arg)) of-                                          Nothing -> False-                                          Just x  -> x == cop arg--        check2 sop cop arg1 arg2      = case unliteral (sop (literal arg1) (literal arg2)) of-                                          Nothing -> False-                                          Just x  -> x == cop arg1 arg2--        check3 sop cop arg1 arg2 arg3 = case unliteral (sop (literal arg1) (literal arg2) (literal arg3)) of-                                          Nothing -> False-                                          Just x  -> x == cop arg1 arg2 arg3- -- Concrete test data xsUnsigned :: (Num a, Bounded a) => [a] xsUnsigned = take 5 (iterate (1+) minBound) ++ take 5 (iterate (\x -> x-1) maxBound)@@ -668,49 +324,49 @@ w8s = xsUnsigned  sw8s :: [SWord8]-sw8s = xsUnsigned+sw8s = map literal xsUnsigned  w16s :: [Word16] w16s = xsUnsigned  sw16s :: [SWord16]-sw16s = xsUnsigned+sw16s = map literal xsUnsigned  w32s :: [Word32] w32s = xsUnsigned  sw32s :: [SWord32]-sw32s = xsUnsigned+sw32s = map literal xsUnsigned  w64s :: [Word64] w64s = xsUnsigned  sw64s :: [SWord64]-sw64s = xsUnsigned+sw64s = map literal xsUnsigned  i8s :: [Int8] i8s = xsSigned  si8s :: [SInt8]-si8s = xsSigned+si8s = map literal xsSigned  i16s :: [Int16] i16s = xsSigned  si16s :: [SInt16]-si16s = xsSigned+si16s = map literal xsSigned  i32s :: [Int32] i32s = xsSigned  si32s :: [SInt32]-si32s = xsSigned+si32s = map literal xsSigned  i64s :: [Int64] i64s = xsSigned  si64s :: [SInt64]-si64s = xsSigned+si64s = map literal xsSigned  iUBs :: [Integer] iUBs = [-1000000 .. -999995] ++ [-5 .. 5] ++ [999995 ..  1000000]@@ -740,12 +396,8 @@ sds :: [SDouble] sds = map literal ds --- Currently we test over all latin-1 characters. Maybe we should add some unicode here. Oh well.-cs :: String-cs = map C.chr [0..255]- -- For pair character ops, just take a subset-iCs :: String+iCs :: [Char] iCs = map C.chr $ [0..5] ++ [98..102] ++ [250..255]  siCs :: [SChar]@@ -761,10 +413,6 @@ -- Lists are the worst in coverage! sl :: [[Integer]] sl = [[], [0], [-1, 1], [-10, 0, 10], [3, 4, 5, 4, 5, 3]]---- Like wise, list of lists-sll :: [[[Integer]]]-sll = [[x, x, x] | x <- [[], [0], [-1, 1], [-10, 0, 10], [3, 4, 5, 4, 5, 3]]]  -- Lists are the worst in coverage! ssl :: [SList Integer]
+ SBVTestSuite/TestSuite/Basics/ArithNoSolver2.hs view
@@ -0,0 +1,543 @@+-----------------------------------------------------------------------------+-- |+-- Module    : TestSuite.Basics.ArithNoSolver2+-- Copyright : (c) Levent Erkok+-- License   : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Spill over from ArithNoSolver. To aid faster GHC compilation.+-- the constant folding based arithmetic implementation in SBV+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                #-}+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE Rank2Types         #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TupleSections      #-}+{-# LANGUAGE TypeApplications   #-}+{-# LANGUAGE QuasiQuotes        #-}++#if MIN_VERSION_base(4,19,0)+{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-}+#else+{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+#endif++module TestSuite.Basics.ArithNoSolver2(tests) where++import Data.SBV.Internals+import Utils.SBVTestFramework++import Data.Maybe (isJust)++import Data.List (genericIndex, isInfixOf, isPrefixOf, isSuffixOf, genericTake, genericDrop, genericLength)++import qualified Data.Char       as C+import qualified Data.SBV.Char   as SC+import qualified Data.SBV.List   as SL++data Day = Mon | Tue | Wed | Thu | Fri | Sat | Sun deriving (Bounded, Enum, Eq)+mkSymbolicEnumeration  ''Day++-- Test suite+tests :: TestTree+tests = testGroup "Arith.NoSolver2" $+           genIntTest      False "setBit"        setBit+        ++ genIntTest      False "clearBit"      clearBit+        ++ genIntTest      False "complementBit" complementBit+        ++ genIntTest      True  "shift"         shift+        ++ genIntTest      True  "shiftL"        shiftL+        ++ genIntTest      True  "shiftR"        shiftR+        ++ genIntTest      True  "rotate"        rotate+        ++ genIntTest      True  "rotateL"       rotateL+        ++ genIntTest      True  "rotateR"       rotateR+        ++ genShiftRotTest       "shiftL_gen"    sShiftLeft+        ++ genShiftRotTest       "shiftR_gen"    sShiftRight+        ++ genShiftRotTest       "rotateL_gen"   sRotateLeft+        ++ genShiftRotTest       "rotateR_gen"   sRotateRight+        ++ genShiftMixSize+        ++ genBlasts+        ++ genCounts+        ++ genIntCasts+        ++ genChars+        ++ genStrings+        ++ genLists+        ++ genEnums++genIntTest :: Bool -> String -> (forall a. (Num a, Bits a) => (a -> Int -> a)) -> [TestTree]+genIntTest overSized nm op = map mkTest $+        zipWith pair [("u8",  show x, show y, x `op` y) | x <- w8s,  y <- is (intSizeOf x)] [x `op` y | x <- sw8s,  y <- is (intSizeOf x)]+     ++ zipWith pair [("u16", show x, show y, x `op` y) | x <- w16s, y <- is (intSizeOf x)] [x `op` y | x <- sw16s, y <- is (intSizeOf x)]+     ++ zipWith pair [("u32", show x, show y, x `op` y) | x <- w32s, y <- is (intSizeOf x)] [x `op` y | x <- sw32s, y <- is (intSizeOf x)]+     ++ zipWith pair [("u64", show x, show y, x `op` y) | x <- w64s, y <- is (intSizeOf x)] [x `op` y | x <- sw64s, y <- is (intSizeOf x)]+     ++ zipWith pair [("s8",  show x, show y, x `op` y) | x <- i8s,  y <- is (intSizeOf x)] [x `op` y | x <- si8s,  y <- is (intSizeOf x)]+     ++ zipWith pair [("s16", show x, show y, x `op` y) | x <- i16s, y <- is (intSizeOf x)] [x `op` y | x <- si16s, y <- is (intSizeOf x)]+     ++ zipWith pair [("s32", show x, show y, x `op` y) | x <- i32s, y <- is (intSizeOf x)] [x `op` y | x <- si32s, y <- is (intSizeOf x)]+     ++ zipWith pair [("s64", show x, show y, x `op` y) | x <- i64s, y <- is (intSizeOf x)] [x `op` y | x <- si64s, y <- is (intSizeOf x)]+     ++ zipWith pair [("iUB", show x, show y, x `op` y) | x <- iUBs, y <- [0..10]]          [x `op` y | x <- siUBs, y <- [0..10]]+  where is sz = [0 .. sz - 1] ++ extras+          where extras+                 | overSized = map (sz +) ([0 .. 1] ++ [sz, sz+1])+                 | True      = []+        pair (t, x, y, a) b       = (t, x, y, show a, show b, show (fromIntegral a `asTypeOf` b) == show b)+        mkTest (t, x, y, a, b, s) = testCase ("arithCF-" ++ nm ++ "." ++ t ++ "_" ++ x ++ "_" ++ y ++ "_" ++ a ++ "_" ++ b) (s `showsAs` "True")++genShiftRotTest :: String -> (forall a. (SIntegral a, SDivisible (SBV a)) => (SBV a -> SBV a -> SBV a)) -> [TestTree]+genShiftRotTest nm op = map mkTest $+        zipWith pair [("u8",  show x, show y, literal x `op` y) | x <- w8s,  y <- is (intSizeOf x)] [x `op` y | x <- sw8s,  y <- is (intSizeOf x)]+     ++ zipWith pair [("u16", show x, show y, literal x `op` y) | x <- w16s, y <- is (intSizeOf x)] [x `op` y | x <- sw16s, y <- is (intSizeOf x)]+     ++ zipWith pair [("u32", show x, show y, literal x `op` y) | x <- w32s, y <- is (intSizeOf x)] [x `op` y | x <- sw32s, y <- is (intSizeOf x)]+     ++ zipWith pair [("u64", show x, show y, literal x `op` y) | x <- w64s, y <- is (intSizeOf x)] [x `op` y | x <- sw64s, y <- is (intSizeOf x)]+     ++ zipWith pair [("s8",  show x, show y, literal x `op` y) | x <- i8s,  y <- is (intSizeOf x)] [x `op` y | x <- si8s,  y <- is (intSizeOf x)]+     ++ zipWith pair [("s16", show x, show y, literal x `op` y) | x <- i16s, y <- is (intSizeOf x)] [x `op` y | x <- si16s, y <- is (intSizeOf x)]+     ++ zipWith pair [("s32", show x, show y, literal x `op` y) | x <- i32s, y <- is (intSizeOf x)] [x `op` y | x <- si32s, y <- is (intSizeOf x)]+     ++ zipWith pair [("s64", show x, show y, literal x `op` y) | x <- i64s, y <- is (intSizeOf x)] [x `op` y | x <- si64s, y <- is (intSizeOf x)]+     -- NB. No generic shift/rotate for SMTLib unbounded integers+  where is sz = let b :: Word32+                    b = fromIntegral sz+                in map (sFromIntegral . literal) $ [0 .. b - 1] ++ [b, b+1, 2*b, 2*b+1]+        pair (t, x, y, a) b       = (t, x, y, show a, show b, isJust (unliteral a) && isJust (unliteral b) && unliteral a == unliteral b)+        mkTest (t, x, y, a, b, s) = testCase ("arithCF-" ++ nm ++ "." ++ t ++ "_" ++ x ++ "_" ++ y ++ "_" ++ a ++ "_" ++ b) (s `showsAs` "True")++-- A few tests for mixed-size shifts+genShiftMixSize :: [TestTree]+genShiftMixSize = map mkTest $+           [pair (show x, show y, "shl_w8_w16", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- w8s,  y <- yw16s]+        ++ [pair (show x, show y, "shr_w8_w16", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- w8s,  y <- yw16s]+        ++ [pair (show x, show y, "shl_w16_w8", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- w16s, y <- w8s]+        ++ [pair (show x, show y, "shr_w16_w8", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- w16s, y <- w8s]+        ++ [pair (show x, show y, "shl_i8_i16", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- i8s,  y <- yi16s]+        ++ [pair (show x, show y, "shr_i8_i16", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- i8s,  y <- yi16s]+        ++ [pair (show x, show y, "shl_i16_i8", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- i16s, y <- i8s, y >= 0]+        ++ [pair (show x, show y, "shr_i16_i8", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- i16s, y <- i8s, y >= 0]+        ++ [pair (show x, show y, "shl_w8_i16", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- w8s,  y <- yi16s]+        ++ [pair (show x, show y, "shr_w8_i16", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- w8s,  y <- yi16s]+        ++ [pair (show x, show y, "shl_w16_i8", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- w16s, y <- i8s, y >= 0]+        ++ [pair (show x, show y, "shr_w16_i8", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- w16s, y <- i8s, y >= 0]+        ++ [pair (show x, show y, "shl_i8_w16", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- i8s,  y <- yw16s]+        ++ [pair (show x, show y, "shr_i8_w16", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- i8s,  y <- yw16s]+        ++ [pair (show x, show y, "shl_i16_w8", literal x `sShiftLeft`  literal y,  x `shiftL` fromIntegral y) | x <- i16s, y <- w8s]+        ++ [pair (show x, show y, "shr_i16_w8", literal x `sShiftRight` literal y,  x `shiftR` fromIntegral y) | x <- i16s, y <- w8s]+   where pair :: (Eq a, SymVal a, Show a) => (String, String, String, SBV a, a) -> (String, Bool)+         pair (x, y, l, sr, lr) = (l ++ "." ++ x ++ "_" ++ y ++ "_" ++  show (unliteral sr) ++ "_" ++ show lr, isJust (unliteral sr) && unliteral sr == Just lr)+         mkTest (l, s) = testCase ("arithCF-genShiftMixSize" ++ l) (s `showsAs` "True")++         yi16s :: [Int16]+         yi16s = [0, 255, 256, 257, maxBound]++         yw16s :: [Word16]+         yw16s = [0, 255, 256, 257, maxBound]+++genBlasts :: [TestTree]+genBlasts = map mkTest $+             [(show x, fromBitsLE (blastLE x) .== x) | x <- sw8s ]+          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- sw8s ]+          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- si8s ]+          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- si8s ]+          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- sw16s]+          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- sw16s]+          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- si16s]+          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- si16s]+          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- sw32s]+          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- sw32s]+          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- si32s]+          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- si32s]+          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- sw64s]+          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- sw64s]+          ++ [(show x, fromBitsLE (blastLE x) .== x) | x <- si64s]+          ++ [(show x, fromBitsBE (blastBE x) .== x) | x <- si64s]+  where mkTest (x, r) = testCase ("blast-" ++ x) (r `showsAs` "True")++genCounts :: [TestTree]+genCounts = map mkTest $+             [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SWord8 )) | x <- sw8s ]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SWord8 )) | x <- sw8s ]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SInt8  )) | x <- si8s ]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SInt8  )) | x <- si8s ]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SWord16)) | x <- sw16s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SWord16)) | x <- sw16s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SInt16 )) | x <- si16s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SInt16 )) | x <- si16s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SWord32)) | x <- sw32s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SWord32)) | x <- sw32s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SInt32 )) | x <- si32s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SInt32 )) | x <- si32s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SWord64)) | x <- sw64s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SWord64)) | x <- sw64s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsBE (blastLE x) :: SInt64 )) | x <- si64s]+          ++ [(show x, sCountTrailingZeros x .== sCountLeadingZeros (fromBitsLE (blastBE x) :: SInt64 )) | x <- si64s]+  where mkTest (x, r) = testCase ("count-" ++ x) (r `showsAs` "True")++genIntCasts :: [TestTree]+genIntCasts = map mkTest $  cast w8s ++ cast w16s ++ cast w32s ++ cast w64s+                         ++ cast i8s ++ cast i16s ++ cast i32s ++ cast i64s+                         ++ cast iUBs+   where mkTest (x, r) = testCase ("intCast-" ++ x) (r `showsAs` "True")+         lhs x = sFromIntegral (literal x)+         rhs x = literal (fromIntegral x)+         cast :: forall a. (Show a, Integral a, SymVal a) => [a] -> [(String, SBool)]+         cast xs = toWords xs ++ toInts xs+         toWords xs =  [(show x, lhs x .== (rhs x :: SWord8 ))  | x <- xs]+                    ++ [(show x, lhs x .== (rhs x :: SWord16))  | x <- xs]+                    ++ [(show x, lhs x .== (rhs x :: SWord32))  | x <- xs]+                    ++ [(show x, lhs x .== (rhs x :: SWord64))  | x <- xs]+         toInts  xs =  [(show x, lhs x .== (rhs x :: SInt8 ))   | x <- xs]+                    ++ [(show x, lhs x .== (rhs x :: SInt16))   | x <- xs]+                    ++ [(show x, lhs x .== (rhs x :: SInt32))   | x <- xs]+                    ++ [(show x, lhs x .== (rhs x :: SInt64))   | x <- xs]+                    ++ [(show x, lhs x .== (rhs x :: SInteger)) | x <- xs]++genChars :: [TestTree]+genChars = map mkTest $  [("ord",           show c, check SC.ord             cord            c) | c <- cs]+                      ++ [("toLower",       show c, check SC.toLowerL1       C.toLower       c) | c <- cs]+                      ++ [("toUpper",       show c, check SC.toUpperL1       C.toUpper       c) | c <- cs]+                      ++ [("digitToInt",    show c, check SC.digitToInt      dig2Int         c) | c <- cs, digitToIntRange c]+                      ++ [("intToDigit",    show c, check SC.intToDigit      int2Dig         c) | c <- [0 .. 15]]+                      ++ [("isControl",     show c, check SC.isControlL1     C.isControl     c) | c <- cs]+                      ++ [("isSpace",       show c, check SC.isSpaceL1       C.isSpace       c) | c <- cs]+                      ++ [("isLower",       show c, check SC.isLowerL1       C.isLower       c) | c <- cs]+                      ++ [("isUpper",       show c, check SC.isUpperL1       C.isUpper       c) | c <- cs]+                      ++ [("isAlpha",       show c, check SC.isAlphaL1       C.isAlpha       c) | c <- cs]+                      ++ [("isAlphaNum",    show c, check SC.isAlphaNumL1    C.isAlphaNum    c) | c <- cs]+                      ++ [("isPrint",       show c, check SC.isPrintL1       C.isPrint       c) | c <- cs]+                      ++ [("isDigit",       show c, check SC.isDigit         C.isDigit       c) | c <- cs]+                      ++ [("isOctDigit",    show c, check SC.isOctDigit      C.isOctDigit    c) | c <- cs]+                      ++ [("isHexDigit",    show c, check SC.isHexDigit      C.isHexDigit    c) | c <- cs]+                      ++ [("isLetter",      show c, check SC.isLetterL1      C.isLetter      c) | c <- cs]+                      ++ [("isMark",        show c, check SC.isMarkL1        C.isMark        c) | c <- cs]+                      ++ [("isNumber",      show c, check SC.isNumberL1      C.isNumber      c) | c <- cs]+                      ++ [("isPunctuation", show c, check SC.isPunctuationL1 C.isPunctuation c) | c <- cs]+                      ++ [("isSymbol",      show c, check SC.isSymbolL1      C.isSymbol      c) | c <- cs]+                      ++ [("isSeparator",   show c, check SC.isSeparatorL1   C.isSeparator   c) | c <- cs]+                      ++ [("isAscii",       show c, check SC.isAscii         C.isAscii       c) | c <- cs]+                      ++ [("isLatin1",      show c, check SC.isLatin1        C.isLatin1      c) | c <- cs]+                      ++ [("isAsciiUpper",  show c, check SC.isAsciiUpper    C.isAsciiUpper  c) | c <- cs]+                      ++ [("isAsciiLower",  show c, check SC.isAsciiLower    C.isAsciiLower  c) | c <- cs]+  where digitToIntRange   = (`elem` "0123456789abcdefABCDEF")+        cord :: Char -> Integer+        cord = fromIntegral . C.ord+        dig2Int :: Char -> Integer+        dig2Int = fromIntegral . C.digitToInt+        int2Dig :: Integer -> Char+        int2Dig = C.intToDigit . fromIntegral+        mkTest (nm, x, t) = testCase ("genChars-" ++ nm ++ "." ++ x) (assert t)+        check sop cop arg = case unliteral (sop (literal arg)) of+                              Nothing -> False+                              Just x  -> x == cop arg++genStrings :: [TestTree]+genStrings = map mkTest1 (  [("length",        show s,                   check1 SL.length        strLen        s      ) | s <- ss                                                       ]+                         ++ [("null",          show s,                   check1 SL.null          null          s      ) | s <- ss                                                       ]+                         ++ [("head",          show s,                   check1 SL.head          head          s      ) | s <- ss, not (null s)                                         ]+                         ++ [("tail",          show s,                   check1 SL.tail          tail          s      ) | s <- ss, not (null s)                                         ]+                         ++ [("singleton",     show c,                   check1 SL.singleton     (: [])        c      ) | c <- cs                                                       ]+                         ++ [("implode",       show s,                   checkI SL.implode                     s      ) | s <- ss                                                       ]+                         ++ [("strToNat",      show s,                   check1 SL.strToNat      strToNat      s      ) | s <- ss                                                       ]+                         ++ [("natToStr",      show i,                   check1 SL.natToStr      natToStr      i      ) | i <- iUBs                                                     ])+          ++ map mkTest2 (  [("strToCharAt",   show s, show i,           check2 SL.elemAt        strToCharAt   s i    ) | s <- ss, i  <- range s                                        ]+                         ++ [("concat",        show s, show s1,          check2 (SL.++)          (++)          s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isInfixOf",     show s, show s1,          check2 SL.isInfixOf     isInfixOf     s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isSuffixOf",    show s, show s1,          check2 SL.isSuffixOf    isSuffixOf    s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isPrefixOf",    show s, show s1,          check2 SL.isPrefixOf    isPrefixOf    s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("take",          show s, show i,           check2 SL.take          genericTake   i s    ) | s <- ss, i <- iUBs                                            ]+                         ++ [("drop",          show s, show i,           check2 SL.drop          genericDrop   i s    ) | s <- ss, i <- iUBs                                            ]+                         ++ [("indexOf",       show s, show s1,          check2 SL.indexOf       indexOf       s s1   ) | s <- ss, s1 <- ss                                             ])+          ++ map mkTest3 (  [("subStr",        show s, show  i, show j,  check3 SL.subList       subStr        s i  j ) | s <- ss, i  <- range s, j <- range s, i + j <= genericLength s]+                         ++ [("replace",       show s, show s1, show s2, check3 SL.replace       replace       s s1 s2) | s <- ss, s1 <- ss, s2 <- ss                                   ]+                         ++ [("offsetIndexOf", show s, show s1, show i,  check3 SL.offsetIndexOf offsetIndexOf s s1 i ) | s <- ss, s1 <- ss, i <- range s                               ])+  where strLen :: String -> Integer+        strLen = fromIntegral . length++        strToNat :: String -> Integer+        strToNat s+          | all C.isDigit s && not (null s) = read s+          | True                            = -1++        natToStr :: Integer -> String+        natToStr i+          | i >= 0 = show i+          | True   = ""++        range :: String -> [Integer]+        range s = map fromIntegral [0 .. length s - 1]++        indexOf :: String -> String -> Integer+        indexOf s1 s2 = go 0 s1+          where go i x+                 | s2 `isPrefixOf` x = i+                 | True              = case x of+                                          "" -> -1+                                          (_:r) -> go (i+1) r++        strToCharAt :: String -> Integer -> Char+        s `strToCharAt` i = s `genericIndex` i++        subStr :: String -> Integer -> Integer -> String+        subStr s i j = genericTake j (genericDrop i s)++        replace :: String -> String -> String -> String+        replace s "" y = y ++ s+        replace s x  y = go s+          where go "" = ""+                go h@(c:rest) | x `isPrefixOf` h = y ++ drop (length x) h+                              | True             = c : go rest++        offsetIndexOf :: String -> String -> Integer -> Integer+        offsetIndexOf x y i = case indexOf (genericDrop i x) y of+                                -1 -> -1+                                r  -> r+i++        mkTest1 (nm, x, t)       = testCase ("genStrings-" ++ nm ++ "." ++ x)                         (assert t)+        mkTest2 (nm, x, y, t)    = testCase ("genStrings-" ++ nm ++ "." ++ x ++ "_" ++ y)             (assert t)+        mkTest3 (nm, x, y, z, t) = testCase ("genStrings-" ++ nm ++ "." ++ x ++ "_" ++ y ++ "_" ++ z) (assert t)++        checkI sop s = case unliteral (sop (map literal s)) of+                         Nothing -> False+                         Just x  -> s == x++        check1 sop cop arg            = case unliteral (sop (literal arg)) of+                                          Nothing -> False+                                          Just x  -> x == cop arg+        check2 sop cop arg1 arg2      = case unliteral (sop (literal arg1) (literal arg2)) of+                                          Nothing -> False+                                          Just x  -> x == cop arg1 arg2+        check3 sop cop arg1 arg2 arg3 = case unliteral (sop (literal arg1) (literal arg2) (literal arg3)) of+                                          Nothing -> False+                                          Just x  -> x == cop arg1 arg2 arg3++genLists :: [TestTree]+genLists = map mkTest1 (   [("length",        show l,                   check1 SL.length        llen          l      ) | l <- sl                                                       ]+                        ++ [("null",          show l,                   check1 SL.null          null          l      ) | l <- sl                                                       ]+                        ++ [("head",          show l,                   check1 SL.head          head          l      ) | l <- sl, not (null l)                                         ]+                        ++ [("tail",          show l,                   check1 SL.tail          tail          l      ) | l <- sl, not (null l)                                         ]+                        ++ [("singleton",     show i,                   check1 SL.singleton     (: [])        i      ) | i <- iUBs                                                     ]+                        ++ [("implode",       show l,                   checkI SL.implode       id            l      ) | l <- sl                                                       ]+                        ++ [("concat",        show l,                   check1 SL.concat        concat        l      ) | l <- sll                                                      ]+                       )+        ++ map mkTest2 (   [("listToListAt",  show l, show i,           check2 SL.listToListAt  listToListAt  l i    ) | l <- sl, i  <- range l                                        ]+                        ++ [("elemAt",        show l, show i,           check2 SL.elemAt        elemAt        l i    ) | l <- sl, i  <- range l                                        ]+                        ++ [("append",        show l, show l1,          check2 (SL.++)          (++)          l l1   ) | l <- sl, l1 <- sl                                             ]+                        ++ [("isInfixOf",     show l, show l1,          check2 SL.isInfixOf     isInfixOf     l l1   ) | l <- sl, l1 <- sl                                             ]+                        ++ [("isSuffixOf",    show l, show l1,          check2 SL.isSuffixOf    isSuffixOf    l l1   ) | l <- sl, l1 <- sl                                             ]+                        ++ [("isPrefixOf",    show l, show l1,          check2 SL.isPrefixOf    isPrefixOf    l l1   ) | l <- sl, l1 <- sl                                             ]+                        ++ [("take",          show l, show i,           check2 SL.take          genericTake   i l    ) | l <- sl, i <- iUBs                                            ]+                        ++ [("drop",          show l, show i,           check2 SL.drop          genericDrop   i l    ) | l <- sl, i <- iUBs                                            ]+                        ++ [("indexOf",       show l, show l1,          check2 SL.indexOf       indexOf       l l1   ) | l <- sl, l1 <- sl                                             ])+        ++ map mkTest3 (   [("subList",       show l, show  i, show j,  check3 SL.subList       subList       l i  j ) | l <- sl, i  <- range l, j <- range l, i + j <= genericLength l]+                        ++ [("replace",       show l, show l1, show l2, check3 SL.replace       replace       l l1 l2) | l <- sl, l1 <- sl, l2 <- sl                                   ]+                        ++ [("offsetIndexOf", show l, show l1, show i,  check3 SL.offsetIndexOf offsetIndexOf l l1 i ) | l <- sl, l1 <- sl, i <- range l                               ])+  where llen :: [Integer] -> Integer+        llen = fromIntegral . length++        range :: [Integer] -> [Integer]+        range l = map fromIntegral [0 .. length l - 1]++        indexOf :: [Integer] -> [Integer] -> Integer+        indexOf s1 s2 = go 0 s1+          where go i x+                 | s2 `isPrefixOf` x = i+                 | True              = case x of+                                          []    -> -1+                                          (_:r) -> go (i+1) r++        listToListAt :: [Integer] -> Integer -> [Integer]+        s `listToListAt` i = [s `elemAt` i]++        elemAt :: [Integer] -> Integer -> Integer+        l `elemAt` i = l `genericIndex` i++        subList :: [Integer] -> Integer -> Integer -> [Integer]+        subList s i j = genericTake j (genericDrop i s)++        replace :: [Integer] -> [Integer] -> [Integer] -> [Integer]+        replace s [] y = y ++ s+        replace s x  y = go s+          where go [] = []+                go h@(c:rest) | x `isPrefixOf` h = y ++ drop (length x) h+                              | True             = c : go rest++        offsetIndexOf :: [Integer] -> [Integer] -> Integer -> Integer+        offsetIndexOf x y i = case indexOf (genericDrop i x) y of+                                -1 -> -1+                                r  -> r+i++        mkTest1 (nm, x, t)       = testCase ("genLists-" ++ nm ++ "." ++ x)                         (assert t)+        mkTest2 (nm, x, y, t)    = testCase ("genLists-" ++ nm ++ "." ++ x ++ "_" ++ y)             (assert t)+        mkTest3 (nm, x, y, z, t) = testCase ("genLists-" ++ nm ++ "." ++ x ++ "_" ++ y ++ "_" ++ z) (assert t)++        checkI sop cop arg = case unliteral (sop (map literal arg)) of+                               Nothing -> False+                               Just x  -> x == cop arg++        check1 sop cop arg            = case unliteral (sop (literal arg)) of+                                          Nothing -> False+                                          Just x  -> x == cop arg++        check2 sop cop arg1 arg2      = case unliteral (sop (literal arg1) (literal arg2)) of+                                          Nothing -> False+                                          Just x  -> x == cop arg1 arg2++        check3 sop cop arg1 arg2 arg3 = case unliteral (sop (literal arg1) (literal arg2) (literal arg3)) of+                                          Nothing -> False+                                          Just x  -> x == cop arg1 arg2 arg3++-- Test these with make test TGT=enum_+genEnums :: [TestTree]+genEnums =+    -- Only bounded for from, otherwise infinite (or too big for chars)+    [mkTest1 "from"       s     (eq [s..    ] [sEnum|literal s..                    |]) | s <- univ @(WordN 4)]+ ++ [mkTest1 "from"       s     (eq [s..    ] [sEnum|literal s..                    |]) | s <- univ @(IntN  4)]+ ++ [mkTest1 "from"       s     (eq [s..    ] [sEnum|literal s..                    |]) | s <- univ @Day]+ ++ [mkTest1 "from"       s     (eq [s..    ] [sEnum|literal s..                    |]) | s <- w8s]+ ++ [mkTest1 "from"       s     (eq [s..    ] [sEnum|literal s..                    |]) | s <- i8s]++ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- univ @(WordN 4), t <- univ @(WordN 4)]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- univ @(IntN  4), t <- univ @(IntN  4)]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- univ @Day      , t <- univ @Day      ]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- w8s            , t <- w8s            ]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- i8s            , t <- i8s            ]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- ints           , t <- ints           ]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- floats         , t <- floats         ]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- doubles        , t <- doubles        ]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- fps            , t <- fps            ]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- lcs            , t <- lcs            ]+ ++ [mkTest2 "fromTo"     s t   (eq [s..t   ] [sEnum|literal s..literal t           |]) | s <- rs             , t <- rs             ]++    -- Only bounded for fromThen, otherwise infinite (or too big for chars)+ ++ [mkTest2 "fromThen"   s t   (eq [s, t.. ] [sEnum|literal s, literal t..         |]) | s <- univ @(WordN 4), t <- univ @(WordN 4), s /= t]+ ++ [mkTest2 "fromThen"   s t   (eq [s, t.. ] [sEnum|literal s, literal t..         |]) | s <- univ @(IntN  4), t <- univ @(IntN  4), s /= t]+ ++ [mkTest2 "fromThen"   s t   (eq [s, t.. ] [sEnum|literal s, literal t..         |]) | s <- univ @Day      , t <- univ @Day      , s /= t]+ ++ [mkTest2 "fromThen"   s t   (eq [s, t.. ] [sEnum|literal s, literal t..         |]) | s <- w8s            , t <- w8s            , s /= t]+ ++ [mkTest2 "fromThen"   s t   (eq [s, t.. ] [sEnum|literal s, literal t..         |]) | s <- i8s            , t <- i8s            , s /= t]++ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- univ @(WordN 4), t <- univ @(WordN 4), s /= t, u <- univ @(WordN 4)]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- univ @(IntN  4), t <- univ @(IntN  4), s /= t, u <- univ @(IntN  4)]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- univ @Day      , t <- univ @Day      , s /= t, u <- univ @Day      ]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- w8s            , t <- w8s            , s /= t, u <- w8s            ]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- i8s            , t <- i8s            , s /= t, u <- i8s            ]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- ints           , t <- ints           , s /= t, u <- ints           ]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- floats         , t <- floats         , s /= t, u <- floats         ]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- doubles        , t <- doubles        , s /= t, u <- doubles        ]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- fps            , t <- fps            , s /= t, u <- fps            ]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- lcs            , t <- lcs            , s /= t, u <- lcs            ]+ ++ [mkTest3 "fromThenTo" s t u (eq [s, t..u] [sEnum|literal s, literal t..literal u|]) | s <- rs             , t <- rs             , s /= t, u <- rs             ]++  where mkTest1 pre a     = testCase ("enum_" ++ pre ++ "_|" ++ show (kindOf a) ++ "|_" ++ show a)+        mkTest2 pre a b   = testCase ("enum_" ++ pre ++ "_|" ++ show (kindOf a) ++ "|_" ++ show (a, b))+        mkTest3 pre a b c = testCase ("enum_" ++ pre ++ "_|" ++ show (kindOf a) ++ "|_" ++ show (a, b, c))++        eq c s = assert (Just c == unliteral s)++        univ :: (Enum n, Bounded n) => [n]+        univ = [minBound .. maxBound]++        ints :: [Integer]+        ints = [-3 .. 3]++        floats :: [Float]+        floats = [-3.4, -3.2 .. 3.5]++        doubles :: [Double]+        doubles = [-3.4, -3.2 .. 3.5]++        -- NB. Precision here is important. If you pick too small of a significand+        -- size then you can turn this enumeration into an infinite list, busting the tests.+        -- For details see: https://gitlab.haskell.org/ghc/ghc/-/issues/15081+        fps :: [FloatingPoint 5 8]+        fps = [-3.4, -3.2 .. 3.5]++        rs :: [AlgReal]+        rs = [-3.4, -3.2 .. 3.5]++        -- don't add min/max bounds here. causes too big lists.+        lcs :: [Char]+        lcs = map C.chr [5, 10, 30, 40, 41, 42, 43, 90, 100]++-- Concrete test data+xsUnsigned :: (Num a, Bounded a) => [a]+xsUnsigned = take 5 (iterate (1+) minBound) ++ take 5 (iterate (\x -> x-1) maxBound)++xsSigned :: (Num a, Enum a, Bounded a) => [a]+xsSigned   = xsUnsigned ++ [-5 .. 5]++w8s :: [Word8]+w8s = xsUnsigned++sw8s :: [SWord8]+sw8s = xsUnsigned++w16s :: [Word16]+w16s = xsUnsigned++sw16s :: [SWord16]+sw16s = xsUnsigned++w32s :: [Word32]+w32s = xsUnsigned++sw32s :: [SWord32]+sw32s = xsUnsigned++w64s :: [Word64]+w64s = xsUnsigned++sw64s :: [SWord64]+sw64s = xsUnsigned++i8s :: [Int8]+i8s = xsSigned++si8s :: [SInt8]+si8s = map literal xsSigned++i16s :: [Int16]+i16s = xsSigned++si16s :: [SInt16]+si16s = map literal xsSigned++i32s :: [Int32]+i32s = xsSigned++si32s :: [SInt32]+si32s = map literal xsSigned++i64s :: [Int64]+i64s = xsSigned++si64s :: [SInt64]+si64s = map literal xsSigned++iUBs :: [Integer]+iUBs = [-1000000 .. -999995] ++ [-5 .. 5] ++ [999995 ..  1000000]++siUBs :: [SInteger]+siUBs = map literal iUBs++-- Currently we test over all latin-1 characters. Maybe we should add some unicode here. Oh well.+cs :: String+cs = map C.chr [0..255]++-- Ditto for strings, just a few things+ss :: [String]+ss = ["", "palTRY", "teSTing", "SBV", "sTRIngs", "123", "surely", "thIS", "hI", "ly", "0"]++-- Lists are the worst in coverage!+sl :: [[Integer]]+sl = [[], [0], [-1, 1], [-10, 0, 10], [3, 4, 5, 4, 5, 3]]++-- Like wise, list of lists+sll :: [[[Integer]]]+sll = [[x, x, x] | x <- [[], [0], [-1, 1], [-10, 0, 10], [3, 4, 5, 4, 5, 3]]]++-- Quiet GHC about unused enum elts+_unused :: SDay+_unused = undefined sMon sTue sWed sThu sFri sSat sSun++{- HLint ignore module "Reduce duplication" -}
SBVTestSuite/TestSuite/Basics/ArithSolver.hs view
@@ -12,10 +12,16 @@ -----------------------------------------------------------------------------  {-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE QuasiQuotes         #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}  #if MIN_VERSION_base(4,19,0) {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-}@@ -32,11 +38,13 @@  import qualified Data.Char       as C import qualified Data.SBV.Char   as SC-import qualified Data.SBV.String as SS import qualified Data.SBV.List   as SL  import Data.SBV.Rational +data Day = Mon | Tue | Wed | Thu | Fri | Sat | Sun deriving (Bounded, Enum, Eq)+mkSymbolicEnumeration  ''Day+ -- Test suite tests :: TestTree tests =@@ -84,6 +92,7 @@      ++ genChars      ++ genStrings      ++ genLists+     ++ genEnums      ++ misc      ) @@ -332,16 +341,16 @@                                       return $ literal res .== sFromIntegral a  genReals :: [TestTree]-genReals = map mkTest $  [("+",  show x, show y, mkThm2 (+)   x y (x +  y)) | x <- rs, y <- rs        ]-                      ++ [("-",  show x, show y, mkThm2 (-)   x y (x -  y)) | x <- rs, y <- rs        ]-                      ++ [("*",  show x, show y, mkThm2 (*)   x y (x *  y)) | x <- rs, y <- rs        ]-                      ++ [("/",  show x, show y, mkThm2 (/)   x y (x /  y)) | x <- rs, y <- rs, y /= 0]-                      ++ [("<",  show x, show y, mkThm2 (.<)  x y (x <  y)) | x <- rs, y <- rs        ]-                      ++ [("<=", show x, show y, mkThm2 (.<=) x y (x <= y)) | x <- rs, y <- rs        ]-                      ++ [(">",  show x, show y, mkThm2 (.>)  x y (x >  y)) | x <- rs, y <- rs        ]-                      ++ [(">=", show x, show y, mkThm2 (.>=) x y (x >= y)) | x <- rs, y <- rs        ]-                      ++ [("==", show x, show y, mkThm2 (.==) x y (x == y)) | x <- rs, y <- rs        ]-                      ++ [("/=", show x, show y, mkThm2 (./=) x y (x /= y)) | x <- rs, y <- rs        ]+genReals = map mkTest $  [("+",  show x, show y, mkThm2 (+)   x y (x +  y)) | x <- ars, y <- ars        ]+                      ++ [("-",  show x, show y, mkThm2 (-)   x y (x -  y)) | x <- ars, y <- ars        ]+                      ++ [("*",  show x, show y, mkThm2 (*)   x y (x *  y)) | x <- ars, y <- ars        ]+                      ++ [("/",  show x, show y, mkThm2 (/)   x y (x /  y)) | x <- ars, y <- ars, y /= 0]+                      ++ [("<",  show x, show y, mkThm2 (.<)  x y (x <  y)) | x <- ars, y <- ars        ]+                      ++ [("<=", show x, show y, mkThm2 (.<=) x y (x <= y)) | x <- ars, y <- ars        ]+                      ++ [(">",  show x, show y, mkThm2 (.>)  x y (x >  y)) | x <- ars, y <- ars        ]+                      ++ [(">=", show x, show y, mkThm2 (.>=) x y (x >= y)) | x <- ars, y <- ars        ]+                      ++ [("==", show x, show y, mkThm2 (.==) x y (x == y)) | x <- ars, y <- ars        ]+                      ++ [("/=", show x, show y, mkThm2 (./=) x y (x /= y)) | x <- ars, y <- ars        ]   where mkTest (nm, x, y, t) = testCase ("genReals.arithmetic-" ++ nm ++ "." ++ x ++ "_" ++ y) (assert t)         mkThm2 op x y r = isTheorem $ do [a, b] <- mapM free ["x", "y"]                                          constrain $ a .== literal x@@ -465,7 +474,7 @@                  ++  [("toFP_Float_ToFloat",    show x, mkThm1 (m toSFloat) x                           x  ) | x <- fs  ]                  ++  [("toFP_Double_ToFloat",   show x, mkThm1 (m toSFloat) x (                   fp2fp x )) | x <- ds  ]                  ++  [("toFP_Integer_ToFloat",  show x, mkThmC (m toSFloat) x (fromRational (toRational x))) | x <- iUBs]-                 ++  [("toFP_Real_ToFloat",     show x, mkThmC (m toSFloat) x (fromRational (toRational x))) | x <- rs  ]+                 ++  [("toFP_Real_ToFloat",     show x, mkThmC (m toSFloat) x (fromRational (toRational x))) | x <- ars ]                   ++  [("toFP_Int8_ToDouble",    show x, mkThmC (m toSDouble) x (fromRational (toRational x))) | x <- i8s ]                  ++  [("toFP_Int16_ToDouble",   show x, mkThmC (m toSDouble) x (fromRational (toRational x))) | x <- i16s]@@ -478,7 +487,7 @@                  ++  [("toFP_Float_ToDouble",   show x, mkThm1 (m toSDouble) x (                   fp2fp x )) | x <- fs  ]                  ++  [("toFP_Double_ToDouble",  show x, mkThm1 (m toSDouble) x                           x )  | x <- ds  ]                  ++  [("toFP_Integer_ToDouble", show x, mkThmC (m toSDouble) x (fromRational (toRational x))) | x <- iUBs]-                 ++  [("toFP_Real_ToDouble",    show x, mkThmC (m toSDouble) x (fromRational (toRational x))) | x <- rs  ]+                 ++  [("toFP_Real_ToDouble",    show x, mkThmC (m toSDouble) x (fromRational (toRational x))) | x <- ars ]                   -- Conversions from floats are only well-defined if the input is in-bounds. So we just check round-trip for these.                  -- Also note that we clamp Int32/Word32/Int64/Word64 conversions further as floats become too sparse to handle those.@@ -622,26 +631,25 @@         int2Dig = C.intToDigit . fromIntegral  genStrings :: [TestTree]-genStrings = map mkTest1 (  [("length",        show s,                   mkThm1 SS.length        strLen        s      ) | s <- ss                                                       ]-                         ++ [("null",          show s,                   mkThm1 SS.null          null          s      ) | s <- ss                                                       ]-                         ++ [("head",          show s,                   mkThm1 SS.head          head          s      ) | s <- ss, not (null s)                                         ]-                         ++ [("tail",          show s,                   mkThm1 SS.tail          tail          s      ) | s <- ss, not (null s)                                         ]-                         ++ [("singleton",     show c,                   mkThm1 SS.singleton     (: [])        c      ) | c <- cs                                                       ]-                         ++ [("implode",       show s,                   mkThmI SS.implode                     s      ) | s <- ss                                                       ]-                         ++ [("strToNat",      show s,                   mkThm1 SS.strToNat      strToNat      s      ) | s <- ss                                                       ]-                         ++ [("natToStr",      show i,                   mkThm1 SS.natToStr      natToStr      i      ) | i <- iUBs                                                     ])-          ++ map mkTest2 (  [("strToStrAt",    show s, show i,           mkThm2 SS.strToStrAt    strToStrAt    s i    ) | s <- ss, i  <- range s                                        ]-                         ++ [("strToCharAt",   show s, show i,           mkThm2 SS.strToCharAt   strToCharAt   s i    ) | s <- ss, i  <- range s                                        ]-                         ++ [("concat",        show s, show s1,          mkThm2 SS.concat        (++)          s s1   ) | s <- ss, s1 <- ss                                             ]-                         ++ [("isInfixOf",     show s, show s1,          mkThm2 SS.isInfixOf     isInfixOf     s s1   ) | s <- ss, s1 <- ss                                             ]-                         ++ [("isSuffixOf",    show s, show s1,          mkThm2 SS.isSuffixOf    isSuffixOf    s s1   ) | s <- ss, s1 <- ss                                             ]-                         ++ [("isPrefixOf",    show s, show s1,          mkThm2 SS.isPrefixOf    isPrefixOf    s s1   ) | s <- ss, s1 <- ss                                             ]-                         ++ [("take",          show s, show i,           mkThm2 SS.take          genericTake   i s    ) | s <- ss, i <- iUBs                                            ]-                         ++ [("drop",          show s, show i,           mkThm2 SS.drop          genericDrop   i s    ) | s <- ss, i <- iUBs                                            ]-                         ++ [("indexOf",       show s, show s1,          mkThm2 SS.indexOf       indexOf       s s1   ) | s <- ss, s1 <- ss                                             ])-          ++ map mkTest3 (  [("subStr",        show s, show  i, show j,  mkThm3 SS.subStr        subStr        s i  j ) | s <- ss, i  <- range s, j <- range s, i + j <= genericLength s]-                         ++ [("replace",       show s, show s1, show s2, mkThm3 SS.replace       replace       s s1 s2) | s <- ss, s1 <- ss, s2 <- ss                                   ]-                         ++ [("offsetIndexOf", show s, show s1, show i,  mkThm3 SS.offsetIndexOf offsetIndexOf s s1 i ) | s <- ss, s1 <- ss, i <- range s                               ])+genStrings = map mkTest1 (  [("length",        show s,                   mkThm1 SL.length        strLen        s      ) | s <- ss                                                       ]+                         ++ [("null",          show s,                   mkThm1 SL.null          null          s      ) | s <- ss                                                       ]+                         ++ [("head",          show s,                   mkThm1 SL.head          head          s      ) | s <- ss, not (null s)                                         ]+                         ++ [("tail",          show s,                   mkThm1 SL.tail          tail          s      ) | s <- ss, not (null s)                                         ]+                         ++ [("singleton",     show c,                   mkThm1 SL.singleton     (: [])        c      ) | c <- cs                                                       ]+                         ++ [("implode",       show s,                   mkThmI SL.implode                     s      ) | s <- ss                                                       ]+                         ++ [("strToNat",      show s,                   mkThm1 SL.strToNat      strToNat      s      ) | s <- ss                                                       ]+                         ++ [("natToStr",      show i,                   mkThm1 SL.natToStr      natToStr      i      ) | i <- iUBs                                                     ])+          ++ map mkTest2 (  [("strToCharAt",   show s, show i,           mkThm2 SL.elemAt        strToCharAt   s i    ) | s <- ss, i  <- range s                                        ]+                         ++ [("++",            show s, show s1,          mkThm2 (SL.++)          (++)          s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isInfixOf",     show s, show s1,          mkThm2 SL.isInfixOf     isInfixOf     s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isSuffixOf",    show s, show s1,          mkThm2 SL.isSuffixOf    isSuffixOf    s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isPrefixOf",    show s, show s1,          mkThm2 SL.isPrefixOf    isPrefixOf    s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("take",          show s, show i,           mkThm2 SL.take          genericTake   i s    ) | s <- ss, i <- iUBs                                            ]+                         ++ [("drop",          show s, show i,           mkThm2 SL.drop          genericDrop   i s    ) | s <- ss, i <- iUBs                                            ]+                         ++ [("indexOf",       show s, show s1,          mkThm2 SL.indexOf       indexOf       s s1   ) | s <- ss, s1 <- ss                                             ])+          ++ map mkTest3 (  [("subStr",        show s, show  i, show j,  mkThm3 SL.subList       subStr        s i  j ) | s <- ss, i  <- range s, j <- range s, i + j <= genericLength s]+                         ++ [("replace",       show s, show s1, show s2, mkThm3 SL.replace       replace       s s1 s2) | s <- ss, s1 <- ss, s2 <- ss                                   ]+                         ++ [("offsetIndexOf", show s, show s1, show i,  mkThm3 SL.offsetIndexOf offsetIndexOf s s1 i ) | s <- ss, s1 <- ss, i <- range s                               ])   where strLen :: String -> Integer         strLen = fromIntegral . length @@ -666,9 +674,6 @@                                           "" -> -1                                           (_:r) -> go (i+1) r -        strToStrAt :: String -> Integer -> String-        s `strToStrAt` i = [s `strToCharAt` i]-         strToCharAt :: String -> Integer -> Char         s `strToCharAt` i = s `genericIndex` i @@ -837,8 +842,8 @@ iUBs :: [Integer] iUBs = [-1000000] ++ [-1 .. 1] ++ [1000000] -rs :: [AlgReal]-rs = [fromRational (i % d) | i <- is, d <- dens]+ars :: [AlgReal]+ars = [fromRational (i % d) | i <- is, d <- dens]  where is   = [-1000000] ++ [-1 .. 1] ++ [10000001]        dens = [5,100,1000000] @@ -888,5 +893,123 @@  where -- https://stackoverflow.com/questions/69033969/trivial-rationals-problems-without-variables-in-sbv-solver-in-haskell        t1 = do _xs <- sRationals []                constrain $ (5.%1:: SRational) .<= (5.%1:: SRational)++-- Test these with make test TGT=sEnum_+genEnums :: [TestTree]+genEnums =+    -- Only bounded for from, otherwise infinite (or too big for chars)+    [mkTest1 "from"       s     (from [s..    ] s) | s <- univ @(WordN 4)]+ ++ [mkTest1 "from"       s     (from [s..    ] s) | s <- univ @(IntN  4)]+ ++ [mkTest1 "from"       s     (from [s..    ] s) | s <- univ @Day]+ ++ [mkTest1 "from"       s     (from [s..    ] s) | s <- w8s]+ ++ [mkTest1 "from"       s     (from [s..    ] s) | s <- i8s]++ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- univ @(WordN 4), t <- univ @(WordN 4)]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- univ @(IntN  4), t <- univ @(IntN  4)]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- univ @Day      , t <- univ @Day      ]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- w8s            , t <- w8s            ]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- i8s            , t <- i8s            ]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- ints           , t <- ints           ]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- floats         , t <- floats         ]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- doubles        , t <- doubles        ]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- fps            , t <- fps            ]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- lcs            , t <- lcs            ]+ ++ [mkTest2 "fromTo"     s t   (fromTo [s..t   ] s t) | s <- rs             , t <- rs             ]++    -- Only bounded for fromThen, otherwise infinite (or too big for chars)+ ++ [mkTest2 "fromThen"   s t   (fromThen [s, t.. ] s t) | s <- univ @(WordN 4), t <- univ @(WordN 4), s /= t]+ ++ [mkTest2 "fromThen"   s t   (fromThen [s, t.. ] s t) | s <- univ @(IntN  4), t <- univ @(IntN  4), s /= t]+ ++ [mkTest2 "fromThen"   s t   (fromThen [s, t.. ] s t) | s <- univ @Day      , t <- univ @Day      , s /= t]+ ++ [mkTest2 "fromThen"   s t   (fromThen [s, t.. ] s t) | s <- w8s            , t <- w8s            , s /= t]+ ++ [mkTest2 "fromThen"   s t   (fromThen [s, t.. ] s t) | s <- i8s            , t <- i8s            , s /= t]++ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- univ @(WordN 4), t <- univ @(WordN 4), s /= t, u <- univ @(WordN 4)]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- univ @(IntN  4), t <- univ @(IntN  4), s /= t, u <- univ @(IntN  4)]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- univ @Day      , t <- univ @Day      , s /= t, u <- univ @Day      ]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- w8s            , t <- w8s            , s /= t, u <- w8s            ]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- i8s            , t <- i8s            , s /= t, u <- i8s            ]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- ints           , t <- ints           , s /= t, u <- ints           ]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- floats         , t <- floats         , s /= t, u <- floats         ]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- doubles        , t <- doubles        , s /= t, u <- doubles        ]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- fps            , t <- fps            , s /= t, u <- fps            ]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- lcs            , t <- lcs            , s /= t, u <- lcs            ]+ ++ [mkTest3 "fromThenTo" s t u (fromThenTo [s, t..u] s t u) | s <- rs             , t <- rs             , s /= t, u <- rs             ]++  where mkTest1 pre a     = testCase ("sEnum_" ++ pre ++ "_|" ++ show (kindOf a) ++ "|_" ++ show a)+        mkTest2 pre a b   = testCase ("sEnum_" ++ pre ++ "_|" ++ show (kindOf a) ++ "|_" ++ show (a, b))+        mkTest3 pre a b c = testCase ("sEnum_" ++ pre ++ "_|" ++ show (kindOf a) ++ "|_" ++ show (a, b, c))++        from cr a1 = assert $ isTheorem $ do+                        sa1 <- free_+                        constrain $ sa1 .== literal a1++                        pure $ [sEnum|sa1..|] .== literal cr++        fromTo cr a1 a2 = assert $ isTheorem $ do+                            sa1 <- free_+                            constrain $ sa1 .== literal a1++                            sa2 <- free_+                            constrain $ sa2 .== literal a2++                            pure $ [sEnum|sa1..sa2|] .== literal cr++        fromThen cr a1 a2 = assert $ isTheorem $ do+                              sa1 <- free_+                              constrain $ sa1 .== literal a1++                              sa2 <- free_+                              constrain $ sa2 .== literal a2++                              pure $ [sEnum|sa1, sa2 ..|] .== literal cr++        fromThenTo cr a1 a2 a3 = assert $ isTheorem $ do+                                   sa1 <- free_+                                   constrain $ sa1 .== literal a1++                                   sa2 <- free_+                                   constrain $ sa2 .== literal a2++                                   sa3 <- free_+                                   constrain $ sa3 .== literal a3++                                   pure $ [sEnum|sa1, sa2 .. sa3|] .== literal cr++        univ :: (Enum n, Bounded n) => [n]+        univ = [minBound .. maxBound]++        ints :: [Integer]+        ints = [-3 .. 3]++        -- Floats create too big a problem for z3, even though we have ground terms. So, skip+        floats :: [Float]+        -- floats = [-3.4, -3.2 .. 3.5]+        floats = []++        -- Ditto here+        doubles :: [Double]+        -- doubles = [-3.4, -3.2 .. 3.5]+        doubles = []++        -- NB. Precision here is important. If you pick too small of a significand+        -- size then you can turn this enumeration into an infinite list, busting the tests.+        -- For details see: https://gitlab.haskell.org/ghc/ghc/-/issues/15081+        -- And likewise, constant folding doesn't happen, too difficult for z3+        fps :: [FloatingPoint 5 8]+        -- fps = [-3.4, -3.2 .. 3.5]+        fps = []++        -- This one works, but is way too slow. So we further reduce the range+        rs :: [AlgReal]+        -- rs = [-3.4, -3.2 .. 3.5]+        rs = [-0.4, -0.2 .. 0.4]++        -- don't add min/max bounds here. causes too big lists.+        lcs :: [Char]+        lcs = map C.chr [5, 10, 30, 40, 41, 42, 43, 90, 100]++-- Quiet GHC about unused enum elts+_unused :: SDay+_unused = undefined sMon sTue sWed sThu sFri sSat sSun  {- HLint ignore module "Reduce duplication" -}
SBVTestSuite/TestSuite/Basics/Lambda.hs view
@@ -14,6 +14,7 @@ {-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE QuasiQuotes         #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving  #-}@@ -24,9 +25,11 @@  module TestSuite.Basics.Lambda(tests)  where -import Prelude hiding((++), map, foldl, foldr, sum, length, zip, zipWith, all, any, concat, filter)+import Prelude hiding((++), map, foldl, foldr, sum, length, zip, zipWith, all, any, concat, filter, head) import qualified Prelude as P +import qualified Data.List as P (partition)+ import Control.Monad (unless, void) import qualified Control.Exception as C @@ -58,62 +61,57 @@       , goldenCapturedIO "lambda02" $ record $ \st -> show <$> lambdaStr st TopLevel (kindOf (Proxy @SInteger)) (\x   -> x+1   :: SInteger)       , goldenCapturedIO "lambda03" $ record $ \st -> show <$> lambdaStr st TopLevel (kindOf (Proxy @SInteger)) (\x y -> x+y*2 :: SInteger) -      , goldenCapturedIO "lambda04" $ eval1 [1 .. 3 :: Integer] (map (const sFalse),  P.map (const False))-      , goldenCapturedIO "lambda05" $ eval1 [1 .. 5 :: Integer] (map (+1) . map (+2), P.map (+1) . P.map (+2))+      , goldenCapturedIO "lambda04" $ eval1 [1 .. 3 :: Integer] (mapl (const sFalse),  P.map (const False))+      , goldenCapturedIO "lambda05" $ eval1 [1 .. 5 :: Integer] (mapl (+1) . mapl (+2), P.map (+1) . P.map (+2))       , goldenCapturedIO "lambda06" $ eval1 [1 .. 5 :: Integer]-                                            ( map   (\x -> P.sum [x .^ literal i | i <- [1..10 :: Integer]])+                                            ( mapl  (\x -> P.sum [x .^ literal i | i <- [1..10 :: Integer]])                                             , P.map (\x -> P.sum [x  ^ i         | i <- [1..10 :: Integer]])                                             ) -      -- no nested lambda's alas; the "map sum" term leads to a nested-lambda, and our current-      -- lambda handler isn't smart enough to take care of such nestedness due to firstification-      -- We can (hopefully) lift this when SMTLib starts officially supporting higher-order functions-      -- and solvers get better at it.-      , goldenCapturedIO "lambda07" $ eval1Err ([[1..5], [1..10], [1..20]] :: [[Integer]])-                                               ( let sum = foldl (+) 0 in   sum .   map   sum-                                               ,                          P.sum . P.map P.sum-                                               )+      , goldenCapturedIO "lambda07" $ eval1 ([[1..5], [1..10], [1..20]] :: [[Integer]]) (   sum .   map   sum+                                                                                        , P.sum . P.map P.sum+                                                                                        ) -      , goldenCapturedIO "lambda08" $ eval1 [1 .. 5 :: Float]   (map (+1), P.map (+1))-      , goldenCapturedIO "lambda09" $ eval1 [1 .. 5 :: Int8]    (map (+1), P.map (+1))-      , goldenCapturedIO "lambda10" $ eval1 [1 .. 5 :: Integer] (map (+1), P.map (+1))-      , goldenCapturedIO "lambda11" $ eval1 [1 .. 5 :: Word8]   (map (+1), P.map (+1))+      , goldenCapturedIO "lambda08" $ eval1 [1 .. 5 :: Float]   (mapl (+1), P.map (+1))+      , goldenCapturedIO "lambda09" $ eval1 [1 .. 5 :: Int8]    (mapl (+1), P.map (+1))+      , goldenCapturedIO "lambda10" $ eval1 [1 .. 5 :: Integer] (mapl (+1), P.map (+1))+      , goldenCapturedIO "lambda11" $ eval1 [1 .. 5 :: Word8]   (mapl (+1), P.map (+1))        , goldenCapturedIO "lambda12" $ eval1 [1 .. 3 :: Integer] (map singleton, P.map (: []))        , goldenCapturedIO "lambda13" $ eval1 [(x, y) | x <- [1..3], y <- [4..6 :: Integer]]                                             (map (\t -> t^._1 + t^._2), P.map (uncurry (+))) -      , goldenCapturedIO "lambda14" $ eval1 [1 .. 5 :: Integer] (zipWith (+) [10..15], P.zipWith (+) [10..15])+      , goldenCapturedIO "lambda14" $ eval1 [1 .. 5 :: Integer] (zipWithL (+) [sEnum|10..15|], P.zipWith (+) [10..15]) -      , goldenCapturedIO "lambda15" $ eval1 [1 .. 5 :: Integer] (foldl (+) 0, P.sum)-      , goldenCapturedIO "lambda16" $ eval1 [1 .. 5 :: Integer] (foldl (*) 1, P.product)+      , goldenCapturedIO "lambda15" $ eval1 [1 .. 5 :: Integer] (foldlL (+) 0, P.sum)+      , goldenCapturedIO "lambda16" $ eval1 [1 .. 5 :: Integer] (foldlL (*) 1, P.product)       , goldenCapturedIO "lambda17" $ eval1 [1 .. 5 :: Integer]-                                           (   foldl (\soFar elt -> singleton elt ++ soFar) []-                                           , P.foldl (\soFar elt ->           elt :  soFar) []+                                           (   foldlL (\soFar elt -> singleton elt ++ soFar) []+                                           , P.foldl  (\soFar elt ->           elt :  soFar) []                                            )        , goldenCapturedIO "lambda18" $ eval1 [1 .. 5 :: Integer]-                                            (   foldl (\b t      -> t^._1 + b + t^._2) 0 .   zip [10..15]-                                            , P.foldl (\b (i, a) -> i     + b + a)     0 . P.zip [10..15]+                                            (   foldlL (\b t      -> t^._1 + b + t^._2) 0 .   zip [sEnum|10..15|]+                                            , P.foldl  (\b (i, a) -> i     + b + a)     0 . P.zip [      10..15 ]                                             ) -      , goldenCapturedIO "lambda19" $ eval1 [1 .. 5 :: Integer] (foldr (+) 0, P.foldr (+) 0)-      , goldenCapturedIO "lambda20" $ eval1 [1 .. 5 :: Integer] (foldr (*) 1, P.foldr (*) 1)+      , goldenCapturedIO "lambda19" $ eval1 [1 .. 5 :: Integer] (foldrL (+) 0, P.foldr (+) 0)+      , goldenCapturedIO "lambda20" $ eval1 [1 .. 5 :: Integer] (foldrL (*) 1, P.foldr (*) 1)       , goldenCapturedIO "lambda21" $ eval1 [1 .. 5 :: Integer]-                                           (   foldr (\elt soFar -> soFar   ++ singleton elt) []-                                           , P.foldr (\elt soFar -> soFar P.++ [elt])         []+                                           (   foldrL (\elt soFar -> soFar   ++ singleton elt) []+                                           , P.foldr  (\elt soFar -> soFar P.++ [elt])         []                                            )        , goldenCapturedIO "lambda22" $ eval2 [1 .. 10 :: Integer] [11..20 :: Integer] (zip, P.zip)       , goldenCapturedIO "lambda23" $ eval2 [1 .. 10 :: Integer] [10, 9 .. 1 :: Integer]-                                            ( \a b ->   foldr (+) 0 (  map (\t -> t^._1+t^._2::SInteger) (  zip a b))-                                            , \a b -> P.foldr (+) 0 (P.map (\t -> fst t+snd t::Integer ) (P.zip a b))+                                            ( \a b ->   foldrL (+) 0 (  map (\t -> t^._1+t^._2::SInteger) (  zip a b))+                                            , \a b -> P.foldr  (+) 0 (P.map (\t -> fst t+snd t::Integer ) (P.zip a b))                                             )-      , goldenCapturedIO "lambda24" $ eval2 [1 .. 10 :: Integer] [11..20 :: Integer] (zipWith (+), P.zipWith (+))+      , goldenCapturedIO "lambda24" $ eval2 [1 .. 10 :: Integer] [11..20 :: Integer] (zipWithL (+), P.zipWith (+))       , goldenCapturedIO "lambda25" $ eval2 [1 .. 10 :: Integer] [10, 9 .. 1 :: Integer]-                                            ( \a b ->   foldr (+) 0 (  zipWith (+) a b)-                                            , \a b -> P.foldr (+) 0 (P.zipWith (+) a b)+                                            ( \a b ->   foldrL (+) 0 (  zipWithL (+) a b)+                                            , \a b -> P.foldr  (+) 0 (P.zipWith  (+) a b)                                             )        , goldenCapturedIO "lambda26" $ eval1 ([[1..5], [1..10], [1..20]] :: [[Integer]]) (concat, P.concat)@@ -124,8 +122,8 @@       , goldenCapturedIO "lambda29" $ eval1 [2, 4, 6,    8, 10 :: Integer] (any (\x -> x `sMod` 2 ./= 0), P.any (\x -> x `mod` 2 /= 0))       , goldenCapturedIO "lambda30" $ eval1 [2, 4, 6, 1, 8, 10 :: Integer] (any (\x -> x `sMod` 2 .== 0), P.any (\x -> x `mod` 2 == 0)) -      , goldenCapturedIO "lambda31" $ eval1 [1 .. 10 :: Integer] (filter (\x -> x `sMod` 2 .== 0), P.filter (\x -> x `mod` 2 == 0))-      , goldenCapturedIO "lambda32" $ eval1 [1 .. 10 :: Integer] (filter (\x -> x `sMod` 2 ./= 0), P.filter (\x -> x `mod` 2 /= 0))+      , goldenCapturedIO "lambda31" $ eval1 [1 .. 10 :: Integer] (filterL (\x -> x `sMod` 2 .== 0), P.filter (\x -> x `mod` 2 == 0))+      , goldenCapturedIO "lambda32" $ eval1 [1 .. 10 :: Integer] (filterL (\x -> x `sMod` 2 ./= 0), P.filter (\x -> x `mod` 2 /= 0))        , goldenCapturedIO "lambda33" $ record $ \st -> show <$> lambdaStr st TopLevel (kindOf (Proxy @SInt8)) (0           :: SInt8)       , goldenCapturedIO "lambda34" $ record $ \st -> show <$> lambdaStr st TopLevel (kindOf (Proxy @SInt8)) (\x   -> x+1 :: SInt8)@@ -135,21 +133,21 @@       , goldenCapturedIO "lambda37" $ record $ \st -> constraintStr st $ \(Forall b)             -> sNot b       , goldenCapturedIO "lambda38" $ record $ \st -> constraintStr st $ \(Forall x) (Forall y) -> x .== (0 :: SInteger) .|| y -      , goldenCapturedIO "lambda40" $ record $ \st -> namedLambdaStr TopLevel st "lambda40" t_i    (0           :: SInteger)-      , goldenCapturedIO "lambda41" $ record $ \st -> namedLambdaStr TopLevel st "lambda41" t_i2i  (\x   -> x+1 :: SInteger)-      , goldenCapturedIO "lambda42" $ record $ \st -> namedLambdaStr TopLevel st "lambda42" t_ii2i (\x y -> x+y :: SInteger)+      , goldenCapturedIO "lambda40" $ record $ \st -> show <$> lambdaStr st TopLevel KUnbounded (0           :: SInteger)+      , goldenCapturedIO "lambda41" $ record $ \st -> show <$> lambdaStr st TopLevel KUnbounded (\x   -> x+1 :: SInteger)+      , goldenCapturedIO "lambda42" $ record $ \st -> show <$> lambdaStr st TopLevel KUnbounded (\x y -> x+y :: SInteger) -      , goldenCapturedIO "lambda43" $ record $ \st -> namedLambdaStr TopLevel st "lambda43" t_w32         (0           :: SWord32)-      , goldenCapturedIO "lambda44" $ record $ \st -> namedLambdaStr TopLevel st "lambda44" t_w32_w32     (\x   -> x+1 :: SWord32)-      , goldenCapturedIO "lambda45" $ record $ \st -> namedLambdaStr TopLevel st "lambda45" t_w32_w32_w32 (\x y -> x+y :: SWord32)+      , goldenCapturedIO "lambda43" $ record $ \st -> show <$> lambdaStr st TopLevel (KBounded False 32) (0           :: SWord32)+      , goldenCapturedIO "lambda44" $ record $ \st -> show <$> lambdaStr st TopLevel (KBounded False 32) (\x   -> x+1 :: SWord32)+      , goldenCapturedIO "lambda45" $ record $ \st -> show <$> lambdaStr st TopLevel (KBounded False 32) (\x y -> x+y :: SWord32)        , goldenCapturedIO "lambda46" $ runSat ((.== 5) . add1)        , goldenCapturedIO "lambda47"   $ runSat2 (\a r -> a .== 5 .&& sumToN a .== r)       , goldenCapturedIO "lambda47_c" $ runSat  (sumToN 5 .==) -      , goldenCapturedIO "lambda48"   $ runSat2 (\a r -> a .== [1,2,3::Integer] .&& len a .== r)-      , goldenCapturedIO "lambda48_c" $ runSat  (len [1,2,3::Integer] .==)+      , goldenCapturedIO "lambda48"   $ runSat2 (\a r -> a .== [1,2,3::SInteger] .&& len a .== r)+      , goldenCapturedIO "lambda48_c" $ runSat  (len [1,2,3::SInteger] .==)        , goldenCapturedIO "lambda49"   $ runSat2 (\a r -> a .== 20 .&& isEven a .== r)       , goldenCapturedIO "lambda49_c" $ runSat  (isEven 20 .==)@@ -163,6 +161,7 @@       , goldenCapturedIO "lambda52"   $ runSat2 (\a r -> a .== 21 .&& isOdd  a .== r)       , goldenCapturedIO "lambda52_c" $ runSat  (isOdd  21 .==) +      -- make sure we can pass globals       , goldenCapturedIO "lambda53" $ runSat $ \x -> x .== smtFunction "foo" (+(x::SInteger)) x        -- Make sure we can handle dependency orders@@ -190,8 +189,8 @@        -- Quantified booleans       , goldenCapturedIO "lambda62" $ \rf -> do m <- proveWith z3{verbose=True, redirectVerbose=Just rf} drinker-                                                appendFile rf ("\nRESULT:\n" P.++ show m P.++ "\n")-                                                `C.catch` (\(e :: C.SomeException) -> appendFile rf ("\nEXCEPTION CAUGHT:\n" P.++ show e P.++ "\n"))+                                                appendFile rf ("\nRESULT:\n" <> show m <> "\n")+                                                `C.catch` (\(e :: C.SomeException) -> appendFile rf ("\nEXCEPTION CAUGHT:\n" <> show e <> "\n"))        -- Special relations (kind of lambda related)       , goldenCapturedIO "lambda63" $ runP $         quantifiedBool (\(Forall x) -> rel (x, x))@@ -235,20 +234,42 @@        , goldenCapturedIO "lambda79" $ \f -> sbv2smt def_t1 >>= writeFile f       , goldenCapturedIO "lambda80" $ \f -> sbv2smt def_t2 >>= writeFile f-      , goldenCapturedIO "lambda81" $ errorOut freeVar1++      , goldenCapturedIO "lambda81" $ regularRun filterHead++      , goldenCapturedIO "lambda82" $ eval1 [1 .. 5 :: Integer] (   mapl (\x ->   map (\y -> x + y) (literal [4, 5, 6]))+                                                                , P.map  (\x -> P.map (\y -> x + y)          [4, 5, 6])+                                                                )++      , goldenCapturedIO "lambda83" $ errorOut noFreeVars1+      , goldenCapturedIO "lambda84" $ errorOut noFreeVars2++      , goldenCapturedIO "lambda85" $ eval1 [1 .. 10 :: Integer] (partitionL (\x -> x `sMod` 2 .== 0), P.partition (\x -> x `mod` 2 == 0))+      , goldenCapturedIO "lambda86" $ eval1 [1 .. 10 :: Integer] (partitionL (\x -> x `sMod` 2 ./= 0), P.partition (\x -> x `mod` 2 /= 0))++      , let cls :: SInteger -> Closure SInteger (SInteger -> SInteger)+            cls x = Closure { closureEnv = x+                            , closureFun = \env y -> env + y+                            }+        in goldenCapturedIO "lambda87" $ eval2 [1 .. 3 :: Integer] [6 .. 8 :: Integer]+                                               ( \xs ys ->   map (\x ->   map (cls x)       xs) ys+                                               , \xs ys -> P.map (\x -> P.map (\y -> x + y) xs) ys+                                               )++      , let cls :: SList Integer -> Closure (SList Integer) (SList Integer -> SList Integer)+            cls ys = Closure { closureEnv = ys+                             , closureFun = \env xs -> xs ++ env+                             }+        in goldenCapturedIO "lambda88" $ eval2 [[1 .. 3 :: Integer], [4 .. 6 :: Integer]] [7 .. 9 :: Integer]+                                               ( \xss ys ->   map (cls  ys) xss+                                               , \xss ys -> P.map (P.++ ys) xss+                                               )       ]-   P.++ qc1 "lambdaQC1" P.sum (foldr (+) (0::SInteger))+   P.++ qc1 "lambdaQC1" P.sum (foldr ((+) @SInteger) (0::SInteger))    P.++ qc2 "lambdaQC2" (+)  (smtFunction "sadd" ((+) :: SInteger -> SInteger -> SInteger))    P.++ qc1 "lambdaQC3" (\n -> let pn = abs n in (pn * (pn+1)) `sDiv` 2)                         (let ssum = smtFunction "ssum" $ \(n :: SInteger) -> let pn = abs n in ite (pn .== 0) 0 (pn + ssum (pn - 1)) in ssum)-  where t_i           = SBVType [kindOf (Proxy @SInteger)]-        t_i2i         = SBVType [kindOf (Proxy @SInteger), kindOf (Proxy @SInteger)]-        t_ii2i        = SBVType [kindOf (Proxy @SInteger), kindOf (Proxy @SInteger), kindOf (Proxy @SInteger)]-        t_w32         = SBVType [kindOf (Proxy @SWord32)]-        t_w32_w32     = SBVType [kindOf (Proxy @SWord32), kindOf (Proxy @SWord32)]-        t_w32_w32_w32 = SBVType [kindOf (Proxy @SWord32), kindOf (Proxy @SWord32), kindOf (Proxy @SWord32)]--        def_foo, def_bar, def_baz, def_e, def_o :: SInteger -> SInteger+  where def_foo, def_bar, def_baz, def_e, def_o :: SInteger -> SInteger         def_foo = smtFunction "foo" $ \x -> def_bar (x-1)         def_bar = smtFunction "bar" $ \x -> def_bar (x-1)         def_baz = smtFunction "baz" $ \x -> x+1@@ -257,12 +278,33 @@         def_t1 = smtFunction "foo" (\x -> select [1,2,3]       (0 :: SWord32)  (x::SInteger))         def_t2 = smtFunction "foo" (\x -> select [x+1,x+2,x+3] (0 :: SInteger) (x::SInteger)) +        mapl :: (SymVal a, SymVal b) => (SBV a -> SBV b) -> SList a -> SList b+        mapl = map++        foldlL :: (SymVal a, SymVal b) => (SBV b -> SBV a -> SBV b) -> SBV b -> SList a -> SBV b+        foldlL = foldl++        foldrL :: (SymVal a, SymVal b) => (SBV a -> SBV b -> SBV b) -> SBV b -> SList a -> SBV b+        foldrL = foldr++        zipWithL :: (SymVal a, SymVal b, SymVal c) => (SBV a -> SBV b -> SBV c) -> SList a -> SList b -> SList c+        zipWithL = zipWith++        filterL :: SymVal a => (SBV a -> SBool) -> SList a -> SList a+        filterL = filter++        partitionL :: SymVal a => (SBV a -> SBool) -> SList a -> STuple [a] [a]+        partitionL = partition+         rel, leq :: Relation Integer         rel = uninterpret "R"         leq = uncurry $ smtFunction "leq" (.<=)         po  = isPartialOrder "poR" rel         poI = isPartialOrder "poI" leq +        regularRun tc goldFile = do r <- runSMTWith defaultSMTCfg{verbose=True, redirectVerbose=Just goldFile} tc+                                    appendFile goldFile ("\n FINAL:" <> show r <> "\nDONE!\n")+         record :: (State -> IO String) -> FilePath -> IO ()         record gen rf = do st <- mkNewState defaultSMTCfg (LambdaGen (Just 0))                            appendFile rf . (P.++ "\n") =<< gen st@@ -320,11 +362,6 @@ eval1 :: (SymVal a, SymVal b, Show a, Show b, Eq b) => a -> (SBV a -> SBV b, a -> b) -> FilePath -> IO () eval1 cArg sf rf = eval1Gen cArg sf rf z3{verbose=True, redirectVerbose=Just rf} -eval1Err :: (SymVal a, SymVal b, Show a, Show b, Eq b) => a -> (SBV a -> SBV b, a -> b) -> FilePath -> IO ()-eval1Err cArg sf rf = void (eval1Gen cArg sf rf z3{verbose=True, redirectVerbose=Just rf})-                      `C.catch` \(e::C.SomeException) -> do appendFile rf "CAUGHT EXCEPTION\n\n"-                                                            appendFile rf (show e)- eval1Gen :: (SymVal a, SymVal b, Show a, Show b, Eq b) => a -> (SBV a -> SBV b, a -> b) -> FilePath -> SMTConfig -> IO () eval1Gen cArg (sFun, cFun) rf cfg = do m <- runSMTWith cfg run                                        appendFile rf ("\nRESULT:\n" P.++ showModel z3 m P.++ "\n")@@ -382,13 +419,36 @@                     `C.catch` \(e::C.SomeException) -> do appendFile rf "CAUGHT EXCEPTION\n\n"                                                           appendFile rf (show e) --- Don't allow free variables in higher-order functions. Firstification can't handle these.-freeVar1 :: SMTConfig -> IO SatResult-freeVar1 cfg = satWith cfg $ do-        zs <- free_-        xs <- free_+-- No free vars+noFreeVars1 :: SMTConfig -> IO SatResult+noFreeVars1 cfg = satWith cfg $ do+        zs :: SList [Integer] <- free_+        xs :: SList Integer   <- free_+        ys :: SList Integer   <- free_         constrain $ xs .== literal [1,2,3::Integer]-        pure $ zs .== map (\x -> map (\y -> x+y) (literal [3,4,5])) xs+        constrain $ ys .== literal [3,4,5::Integer]+        pure $ zs .== map (\(x :: SInteger) -> map (\(y :: SInteger) -> x+y) ys) xs++-- No free vars+noFreeVars2 :: SMTConfig -> IO ThmResult+noFreeVars2 cfg = proveWith cfg $ do+   let ae :: SList [Integer] -> SList Integer -> SList [Integer]+       ae xs ys = map (++ ys) xs++   xs <- free_+   ys <- free_+   pure $ map (ae xs) ys .== nil++-- This one is ok, because we're using the global xs. (i.e., no free vars)+filterHead :: Symbolic String+filterHead = do+        xs :: SList Integer <- free_+        constrain $ filter (.> (head xs :: SInteger)) xs ./= filter (.> (4 :: SInteger)) xs+        query $ do cs <- checkSat+                   case cs of+                     Sat -> showModel z3 <$> getModel+                     _   -> pure $ "Unexpected result: " <> show cs+  {- HLint ignore module "Use map once"   -} {- HLint ignore module "Use sum"        -}
SBVTestSuite/TestSuite/Basics/List.hs view
@@ -10,6 +10,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE QuasiQuotes         #-} {-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -Wall -Werror #-}@@ -60,10 +61,10 @@                        Unk    -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" P.++ show r  seqConcatSat :: Symbolic ()-seqConcatSat = constrain $ [1..3] ++ [4..6] .== ([1..6] :: SList Integer)+seqConcatSat = constrain $ [sEnum|1..3|] ++ [sEnum|4..6|] .== ([sEnum|1..6|] :: SList Integer)  seqConcatUnsat :: Symbolic ()-seqConcatUnsat = constrain $ [1..3] ++ [4..6] .== ([1..7] :: SList Integer)+seqConcatUnsat = constrain $ [sEnum|1..3|] ++ [sEnum|4..6|] .== ([sEnum|1..7|] :: SList Integer)  seqIndexOfSat :: Symbolic () seqIndexOfSat = constrain $ L.indexOf ([1,2,3,1,2,3] :: SList Integer) [1] .== 0@@ -90,15 +91,15 @@ seqExamples3 :: Symbolic () seqExamples3 = do   [a, b, c :: SList Integer] <- sLists ["a", "b", "c"]-  constrain $ a ++ b .== [1..4]-  constrain $ b ++ c .== [3..6]+  constrain $ a ++ b .== [sEnum|1..4|]+  constrain $ b ++ c .== [sEnum|3..6|]   constrain $ sNot $ b .== []  -- There is a solution to a of length at most 2. seqExamples4 :: Symbolic () seqExamples4 = do   [a, b :: SList Integer] <- sLists ["a", "b"]-  constrain $ [1..3] ++ a .== b ++ [3..5]+  constrain $ [sEnum|1..3|] ++ a .== b ++ [sEnum|3..5|]   constrain $ L.length a .<= 2  -- There is a solution to a that is not a sequence of 1's.
SBVTestSuite/TestSuite/Basics/Set.hs view
@@ -28,7 +28,7 @@  import Utils.SBVTestFramework hiding (complement) -data E = A | B | C+data E = A | B | C deriving (Bounded, Enum, Ord, Eq) mkSymbolicEnumeration ''E  __unused :: SE
SBVTestSuite/TestSuite/Basics/String.hs view
@@ -21,8 +21,8 @@ import Prelude hiding ((!!), (++)) import qualified Prelude as P ((++)) -import Data.SBV.String ((!!), (++))-import qualified Data.SBV.String as S+import Data.SBV.List ((!!), (++))+import qualified Data.SBV.List   as S import qualified Data.SBV.Char   as SC import qualified Data.SBV.RegExp as R @@ -69,24 +69,24 @@                        Unk    -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" P.++ show r  strConcatSat :: Symbolic ()-strConcatSat = constrain $ "abc" ++ "def" .== "abcdef"+strConcatSat = constrain $ "abc" ++ "def" .== ("abcdef" :: SString)  strConcatUnsat :: Symbolic ()-strConcatUnsat = constrain $ "abc" ++ "def" .== "abcdefg"+strConcatUnsat = constrain $ "abc" ++ "def" .== ("abcdefg" :: SString)  strIndexOfSat :: Symbolic ()-strIndexOfSat = constrain $ S.indexOf "abcabc" "a" .== 0+strIndexOfSat = constrain $ S.indexOf "abcabc" ("a" :: SString) .== 0  strIndexOfUnsat :: Symbolic ()-strIndexOfUnsat = constrain $ S.indexOf "abcabc" "a" ./= 0+strIndexOfUnsat = constrain $ S.indexOf "abcabc" ("a" :: SString) ./= 0  -- Basic string operations strExamples1 :: Symbolic () strExamples1 = constrain $ sAnd-  [ S.singleton ("abc" !! 1) ++ S.singleton ("abc" !! 0) .== "ba"-  , "abcabc" `S.indexOf` "a"                              .== 0-  , S.offsetIndexOf "abcabc" "a" 1                        .== 3-  , S.subStr "xxabcyy" 2 3                                .== "abc"+  [ S.singleton ("abc" !! 1) ++ S.singleton ("abc" !! 0) .== ("ba" :: SString)+  , "abcabc" `S.indexOf` ("a" :: SString)                .== 0+  , S.offsetIndexOf "abcabc" ("a" :: SString) 1          .== 3+  , S.subList "xxabcyy" 2 3                              .== ("abc" :: SString)   ]  -- A string cannot overlap with two different characters.
SBVTestSuite/TestSuite/Basics/Tuple.hs view
@@ -31,7 +31,7 @@  import Utils.SBVTestFramework -data E = A | B | C+data E = A | B | C deriving (Bounded, Enum) mkSymbolicEnumeration ''E  __unused :: SE
SBVTestSuite/TestSuite/Overflows/Arithmetic.hs view
@@ -22,7 +22,7 @@  import Data.SBV import Data.SBV.Dynamic-import Data.SBV.Internals (unSBV, SBV(..))+import Data.SBV.Internals (unSBV, SBV(..), SymVal(minMaxBound))  import Data.SBV.Tools.Overflow @@ -160,8 +160,13 @@                           extResult :: SLarge                           extResult = toLarge x `op` toLarge y -                      return $ overflowHappens `exactlyWhen` (      (extResult `svGreaterThan` toLarge (maxBound :: SBV a))-                                                             `svOr` (extResult `svLessThan`    toLarge (minBound :: SBV a))+                          minb, maxb :: a+                          (minb, maxb) = case minMaxBound of+                                           Nothing -> error "overflow on type that doesn't support bounded"+                                           Just ab -> ab++                      return $ overflowHappens `exactlyWhen` (      (extResult `svGreaterThan` toLarge (literal maxb))+                                                             `svOr` (extResult `svLessThan`    toLarge (literal minb))                                                              )  overflow1 :: forall a. (Integral a, Bounded a, SymVal a) => (SLarge -> SLarge) -> (SBV a -> SBool) -> Predicate@@ -172,8 +177,13 @@                            extResult :: SLarge                            extResult = op $ toLarge x -                       return $ overflowHappens `exactlyWhen` (       (extResult `svGreaterThan` toLarge (maxBound :: SBV a))-                                                               `svOr` (extResult `svLessThan`    toLarge (minBound :: SBV a)))+                           minb, maxb :: a+                           (minb, maxb) = case minMaxBound of+                                            Nothing -> error "overflow on type that doesn't support bounded"+                                            Just ab -> ab++                       return $ overflowHappens `exactlyWhen` (       (extResult `svGreaterThan` toLarge (literal maxb))+                                                               `svOr` (extResult `svLessThan`    toLarge (literal minb)))  -- Custom checker for signedMulOverflow smulCheck :: forall proxy n. ( KnownNat n,          BVIsNonZero n
SBVTestSuite/TestSuite/Queries/Enums.hs view
@@ -23,7 +23,7 @@  import Utils.SBVTestFramework -data BinOp  = Plus | Minus | Times+data BinOp  = Plus | Minus | Times deriving (Enum, Bounded, Ord, Eq) mkSymbolicEnumeration ''BinOp  -- Test suite
SBVTestSuite/TestSuite/Queries/FreshVars.hs view
@@ -25,7 +25,7 @@  import Utils.SBVTestFramework -data BinOp  = Plus | Minus | Times+data BinOp  = Plus | Minus | Times deriving (Enum, Bounded) mkSymbolicEnumeration ''BinOp  _unused :: a
SBVTestSuite/TestSuite/Queries/Lists.hs view
@@ -10,6 +10,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE QuasiQuotes         #-} {-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -Wall -Werror #-}@@ -35,7 +36,7 @@ queryLists1 :: Symbolic [Integer] queryLists1 = do a :: SList Integer <- sList "a" -                 constrain $ a .== [1..5]+                 constrain $ a .== [sEnum|1..5|]                   query $ do _ <- checkSat
SBVTestSuite/TestSuite/Queries/Uninterpreted.hs view
@@ -22,7 +22,7 @@ import Data.SBV.Control import Utils.SBVTestFramework -data L = A | B+data L = A | B deriving (Enum, Bounded) mkSymbolicEnumeration ''L  -- Test suite
sbv.cabal view
@@ -1,7 +1,7 @@ Cabal-Version: 2.2  Name        : sbv-Version     : 11.7+Version     : 12.0 Category    : Formal Methods, Theorem Provers, Bit vectors, Symbolic Computation, Math, SMT Synopsis    : SMT Based Verification: Symbolic Haskell theorem prover using SMT solving. Description : Express properties about Haskell programs and automatically prove them using SMT@@ -43,6 +43,7 @@                      DeriveDataTypeable                      DeriveFunctor                      DeriveGeneric+                     DeriveLift                      DeriveTraversable                      DerivingStrategies                      ExistentialQuantification@@ -72,9 +73,11 @@                      ScopedTypeVariables                      StandaloneDeriving                      TemplateHaskell+                     TemplateHaskellQuotes                      TupleSections                      TypeApplications                      TypeFamilies+                     TypeFamilyDependencies                      TypeOperators                      UndecidableInstances                      ViewPatterns@@ -94,15 +97,17 @@   default-language: Haskell2010   build-depends   : QuickCheck                   , array-                  , async               >= 2.2.5-                  , bytestring+                  , async                   , base16-bytestring+                  , bytestring                   , cryptohash-sha512                   , containers                   , deepseq                   , directory                   , filepath-                  , libBF               >= 0.6.8+                  , haskell-src-exts+                  , haskell-src-meta+                  , libBF                   , mtl                   , pretty                   , process@@ -125,16 +130,15 @@                   , Data.SBV.Rational                   , Data.SBV.Set                   , Data.SBV.Char-                  , Data.SBV.String                   , Data.SBV.Tuple                   , Data.SBV.RegExp+                  , Data.SBV.TP+                  , Data.SBV.TP.List                   , Data.SBV.Tools.BMC                   , Data.SBV.Tools.BVOptimize                   , Data.SBV.Tools.Induction                   , Data.SBV.Tools.CodeGen                   , Data.SBV.Tools.GenTest-                  , Data.SBV.Tools.KnuckleDragger-                  , Data.SBV.Tools.NaturalInduction                   , Data.SBV.Tools.Overflow                   , Data.SBV.Tools.Polynomial                   , Data.SBV.Tools.Range@@ -163,19 +167,6 @@                   , Documentation.SBV.Examples.Lists.Fibonacci                   , Documentation.SBV.Examples.Lists.BoundedMutex                   , Documentation.SBV.Examples.Lists.CountOutAndTransfer-                  , Documentation.SBV.Examples.KnuckleDragger.Basics-                  , Documentation.SBV.Examples.KnuckleDragger.BinarySearch-                  , Documentation.SBV.Examples.KnuckleDragger.CaseSplit-                  , Documentation.SBV.Examples.KnuckleDragger.InsertionSort-                  , Documentation.SBV.Examples.KnuckleDragger.Kleene-                  , Documentation.SBV.Examples.KnuckleDragger.Lists-                  , Documentation.SBV.Examples.KnuckleDragger.MergeSort-                  , Documentation.SBV.Examples.KnuckleDragger.Numeric-                  , Documentation.SBV.Examples.KnuckleDragger.QuickSort-                  , Documentation.SBV.Examples.KnuckleDragger.ShefferStroke-                  , Documentation.SBV.Examples.KnuckleDragger.Sqrt2IsIrrational-                  , Documentation.SBV.Examples.KnuckleDragger.StrongInduction-                  , Documentation.SBV.Examples.KnuckleDragger.Tao                   , Documentation.SBV.Examples.Misc.Definitions                   , Documentation.SBV.Examples.Misc.Enumerate                   , Documentation.SBV.Examples.Misc.FirstOrderLogic@@ -244,6 +235,26 @@                   , Documentation.SBV.Examples.Queries.Concurrency                   , Documentation.SBV.Examples.Strings.RegexCrossword                   , Documentation.SBV.Examples.Strings.SQLInjection+                  , Documentation.SBV.Examples.TP.Basics+                  , Documentation.SBV.Examples.TP.BinarySearch+                  , Documentation.SBV.Examples.TP.CaseSplit+                  , Documentation.SBV.Examples.TP.Fibonacci+                  , Documentation.SBV.Examples.TP.InsertionSort+                  , Documentation.SBV.Examples.TP.Kleene+                  , Documentation.SBV.Examples.TP.McCarthy91+                  , Documentation.SBV.Examples.TP.Majority+                  , Documentation.SBV.Examples.TP.MergeSort+                  , Documentation.SBV.Examples.TP.Numeric+                  , Documentation.SBV.Examples.TP.PowerMod+                  , Documentation.SBV.Examples.TP.QuickSort+                  , Documentation.SBV.Examples.TP.RevAcc+                  , Documentation.SBV.Examples.TP.Reverse+                  , Documentation.SBV.Examples.TP.ShefferStroke+                  , Documentation.SBV.Examples.TP.SortHelpers+                  , Documentation.SBV.Examples.TP.Sqrt2IsIrrational+                  , Documentation.SBV.Examples.TP.StrongInduction+                  , Documentation.SBV.Examples.TP.SumReverse+                  , Documentation.SBV.Examples.TP.Tao                   , Documentation.SBV.Examples.Transformers.SymbolicEval                   , Documentation.SBV.Examples.Uninterpreted.AUF                   , Documentation.SBV.Examples.Uninterpreted.Deduce@@ -271,6 +282,7 @@                   , Data.SBV.Compilers.C                   , Data.SBV.Compilers.CodeGen                   , Data.SBV.Lambda+                  , Data.SBV.SEnum                   , Data.SBV.SMT.SMT                   , Data.SBV.SMT.SMTLib                   , Data.SBV.SMT.SMTLib2@@ -287,9 +299,6 @@                   , Data.SBV.Provers.OpenSMT                   , Data.SBV.Provers.Yices                   , Data.SBV.Provers.Z3-                  , Data.SBV.Tools.KD.Kernel-                  , Data.SBV.Tools.KD.KnuckleDragger-                  , Data.SBV.Tools.KD.Utils                   , Data.SBV.Utils.CrackNum                   , Data.SBV.Utils.ExtractIO                   , Data.SBV.Utils.Numeric@@ -297,6 +306,9 @@                   , Data.SBV.Utils.Lib                   , Data.SBV.Utils.PrettyNum                   , Data.SBV.Utils.SExpr+                  , Data.SBV.TP.Kernel+                  , Data.SBV.TP.TP+                  , Data.SBV.TP.Utils  Test-Suite SBVTest   import           : common-settings@@ -326,6 +338,7 @@                   , TestSuite.Basics.AllSat                   , TestSuite.Basics.ArbFloats                   , TestSuite.Basics.ArithNoSolver+                  , TestSuite.Basics.ArithNoSolver2                   , TestSuite.Basics.ArithSolver                   , TestSuite.Basics.Assert                   , TestSuite.Basics.BarrelRotate