sbv 9.0 → 14.5
raw patch · 1463 files changed
This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.
Files
- CHANGES.md +3298/−2346
- COPYRIGHT +1/−1
- Data/SBV.hs +572/−176
- Data/SBV/Char.hs +39/−12
- Data/SBV/Client.hs +698/−96
- Data/SBV/Client/BaseIO.hs +73/−329
- Data/SBV/Compilers/C.hs +117/−90
- Data/SBV/Compilers/CodeGen.hs +15/−21
- Data/SBV/Control.hs +11/−27
- Data/SBV/Control/BaseIO.hs +42/−39
- Data/SBV/Control/Query.hs +124/−260
- Data/SBV/Control/Types.hs +21/−39
- Data/SBV/Control/Utils.hs +2173/−1823
- Data/SBV/Core/AlgReals.hs +52/−16
- Data/SBV/Core/Concrete.hs +222/−209
- Data/SBV/Core/Data.hs +648/−239
- Data/SBV/Core/Floating.hs +78/−71
- Data/SBV/Core/Kind.hs +213/−210
- Data/SBV/Core/Model.hs +4982/−2722
- Data/SBV/Core/Operations.hs +2064/−1426
- Data/SBV/Core/Sized.hs +69/−197
- Data/SBV/Core/SizedFloats.hs +310/−53
- Data/SBV/Core/Symbolic.hs +2326/−2112
- Data/SBV/Core/TH.hs +142/−0
- Data/SBV/Dynamic.hs +40/−28
- Data/SBV/Either.hs +48/−136
- Data/SBV/Internals.hs +38/−14
- Data/SBV/Lambda.hs +485/−0
- Data/SBV/List.hs +1536/−403
- Data/SBV/Maybe.hs +57/−99
- Data/SBV/Provers/ABC.hs +20/−19
- Data/SBV/Provers/Bitwuzla.hs +21/−20
- Data/SBV/Provers/Boolector.hs +20/−19
- Data/SBV/Provers/CVC4.hs +30/−24
- Data/SBV/Provers/CVC5.hs +31/−25
- Data/SBV/Provers/DReal.hs +20/−21
- Data/SBV/Provers/MathSAT.hs +20/−21
- Data/SBV/Provers/OpenSMT.hs +54/−0
- Data/SBV/Provers/Prover.hs +484/−516
- Data/SBV/Provers/Yices.hs +20/−21
- Data/SBV/Provers/Z3.hs +24/−25
- Data/SBV/Rational.hs +247/−5
- Data/SBV/RegExp.hs +38/−37
- Data/SBV/SCase.hs +1409/−0
- Data/SBV/SEnum.hs +203/−0
- Data/SBV/SMT/SMT.hs +315/−287
- Data/SBV/SMT/SMTLib.hs +7/−33
- Data/SBV/SMT/SMTLib2.hs +1382/−1388
- Data/SBV/SMT/SMTLibNames.hs +6/−2
- Data/SBV/SMT/Utils.hs +178/−74
- Data/SBV/Set.hs +57/−92
- Data/SBV/String.hs +0/−442
- Data/SBV/TP.hs +84/−0
- Data/SBV/TP/Kernel.hs +379/−0
- Data/SBV/TP/TP.hs +1583/−0
- Data/SBV/TP/Utils.hs +707/−0
- Data/SBV/Tools/BMC.hs +76/−30
- Data/SBV/Tools/BVOptimize.hs +126/−0
- Data/SBV/Tools/BoundedFix.hs +0/−88
- Data/SBV/Tools/BoundedList.hs +0/−149
- Data/SBV/Tools/CodeGen.hs +1/−1
- Data/SBV/Tools/GenTest.hs +75/−55
- Data/SBV/Tools/Induction.hs +26/−20
- Data/SBV/Tools/Overflow.hs +98/−251
- Data/SBV/Tools/Polynomial.hs +13/−10
- Data/SBV/Tools/Range.hs +24/−19
- Data/SBV/Tools/STree.hs +1/−1
- Data/SBV/Tools/WeakestPreconditions.hs +54/−54
- Data/SBV/Trans.hs +18/−24
- Data/SBV/Trans/Control.hs +5/−8
- Data/SBV/Tuple.hs +63/−5
- Data/SBV/Utils/CrackNum.hs +64/−30
- Data/SBV/Utils/ExtractIO.hs +5/−5
- Data/SBV/Utils/Lib.hs +168/−9
- Data/SBV/Utils/Numeric.hs +68/−7
- Data/SBV/Utils/PrettyNum.hs +170/−193
- Data/SBV/Utils/SExpr.hs +287/−110
- Data/SBV/Utils/TDiff.hs +34/−1
- Documentation/SBV/Examples/ADT/Expr.hs +172/−0
- Documentation/SBV/Examples/ADT/Param.hs +191/−0
- Documentation/SBV/Examples/ADT/Types.hs +131/−0
- Documentation/SBV/Examples/BitPrecise/Adders.hs +185/−0
- Documentation/SBV/Examples/BitPrecise/BitTricks.hs +1/−2
- Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs +12/−8
- Documentation/SBV/Examples/BitPrecise/Legato.hs +14/−14
- Documentation/SBV/Examples/BitPrecise/MergeSort.hs +11/−4
- Documentation/SBV/Examples/BitPrecise/MultMask.hs +0/−64
- Documentation/SBV/Examples/BitPrecise/PEXT_PDEP.hs +163/−0
- Documentation/SBV/Examples/BitPrecise/PrefixSum.hs +14/−13
- Documentation/SBV/Examples/CodeGeneration/Fibonacci.hs +15/−8
- Documentation/SBV/Examples/CodeGeneration/GCD.hs +7/−4
- Documentation/SBV/Examples/CodeGeneration/PopulationCount.hs +5/−2
- Documentation/SBV/Examples/CodeGeneration/Uninterpreted.hs +5/−1
- Documentation/SBV/Examples/Crypto/AES.hs +380/−68
- Documentation/SBV/Examples/Crypto/Prince.hs +267/−0
- Documentation/SBV/Examples/Crypto/RC4.hs +4/−6
- Documentation/SBV/Examples/Crypto/SHA.hs +21/−5
- Documentation/SBV/Examples/Existentials/CRCPolynomial.hs +0/−89
- Documentation/SBV/Examples/Existentials/Diophantine.hs +68/−37
- Documentation/SBV/Examples/Lists/BoundedMutex.hs +55/−67
- Documentation/SBV/Examples/Lists/Nested.hs +0/−45
- Documentation/SBV/Examples/Misc/Auxiliary.hs +1/−3
- Documentation/SBV/Examples/Misc/Definitions.hs +160/−37
- Documentation/SBV/Examples/Misc/Enumerate.hs +10/−17
- Documentation/SBV/Examples/Misc/FirstOrderLogic.hs +470/−0
- Documentation/SBV/Examples/Misc/Floating.hs +60/−60
- Documentation/SBV/Examples/Misc/LambdaArray.hs +70/−0
- Documentation/SBV/Examples/Misc/ModelExtract.hs +3/−3
- Documentation/SBV/Examples/Misc/NestedArray.hs +2/−2
- Documentation/SBV/Examples/Misc/Newtypes.hs +21/−16
- Documentation/SBV/Examples/Misc/Polynomials.hs +2/−2
- Documentation/SBV/Examples/Misc/ProgramPaths.hs +83/−0
- Documentation/SBV/Examples/Misc/SetAlgebra.hs +8/−22
- Documentation/SBV/Examples/Misc/SoftConstrain.hs +1/−1
- Documentation/SBV/Examples/Misc/Tuple.hs +5/−5
- Documentation/SBV/Examples/Optimization/Enumerate.hs +16/−13
- Documentation/SBV/Examples/Optimization/ExtField.hs +5/−2
- Documentation/SBV/Examples/Optimization/LinearOpt.hs +5/−2
- Documentation/SBV/Examples/Optimization/Production.hs +5/−2
- Documentation/SBV/Examples/Optimization/VM.hs +5/−2
- Documentation/SBV/Examples/ProofTools/AddHorn.hs +108/−0
- Documentation/SBV/Examples/ProofTools/BMC.hs +28/−28
- Documentation/SBV/Examples/ProofTools/Fibonacci.hs +12/−24
- Documentation/SBV/Examples/ProofTools/Strengthen.hs +17/−17
- Documentation/SBV/Examples/ProofTools/Sum.hs +11/−15
- Documentation/SBV/Examples/Puzzles/AOC_2021_24.hs +15/−6
- Documentation/SBV/Examples/Puzzles/Birthday.hs +49/−67
- Documentation/SBV/Examples/Puzzles/Coins.hs +9/−6
- Documentation/SBV/Examples/Puzzles/Counts.hs +4/−4
- Documentation/SBV/Examples/Puzzles/DieHard.hs +113/−0
- Documentation/SBV/Examples/Puzzles/Drinker.hs +6/−35
- Documentation/SBV/Examples/Puzzles/Euler185.hs +2/−2
- Documentation/SBV/Examples/Puzzles/Fish.hs +12/−12
- Documentation/SBV/Examples/Puzzles/Garden.hs +13/−33
- Documentation/SBV/Examples/Puzzles/HexPuzzle.hs +11/−13
- Documentation/SBV/Examples/Puzzles/KnightsAndKnaves.hs +134/−0
- Documentation/SBV/Examples/Puzzles/MagicSquare.hs +2/−2
- Documentation/SBV/Examples/Puzzles/Murder.hs +19/−15
- Documentation/SBV/Examples/Puzzles/NQueens.hs +1/−1
- Documentation/SBV/Examples/Puzzles/Newspaper.hs +104/−0
- Documentation/SBV/Examples/Puzzles/Orangutans.hs +117/−0
- Documentation/SBV/Examples/Puzzles/Rabbits.hs +64/−0
- Documentation/SBV/Examples/Puzzles/SquareBirthday.hs +202/−0
- Documentation/SBV/Examples/Puzzles/Sudoku.hs +118/−181
- Documentation/SBV/Examples/Puzzles/Tower.hs +153/−0
- Documentation/SBV/Examples/Puzzles/U2Bridge.hs +31/−25
- Documentation/SBV/Examples/Queries/Abducts.hs +50/−0
- Documentation/SBV/Examples/Queries/AllSat.hs +2/−2
- Documentation/SBV/Examples/Queries/CaseSplit.hs +4/−4
- Documentation/SBV/Examples/Queries/Concurrency.hs +11/−11
- Documentation/SBV/Examples/Queries/Enums.hs +6/−6
- Documentation/SBV/Examples/Queries/FourFours.hs +28/−29
- Documentation/SBV/Examples/Queries/GuessNumber.hs +11/−12
- Documentation/SBV/Examples/Queries/Interpolants.hs +11/−8
- Documentation/SBV/Examples/Queries/UnsatCore.hs +2/−2
- Documentation/SBV/Examples/Strings/RegexCrossword.hs +11/−13
- Documentation/SBV/Examples/Strings/SQLInjection.hs +5/−5
- Documentation/SBV/Examples/TP/Ackermann.hs +279/−0
- Documentation/SBV/Examples/TP/Adder.hs +395/−0
- Documentation/SBV/Examples/TP/Basics.hs +427/−0
- Documentation/SBV/Examples/TP/BinarySearch.hs +269/−0
- Documentation/SBV/Examples/TP/CaseSplit.hs +48/−0
- Documentation/SBV/Examples/TP/Coins.hs +114/−0
- Documentation/SBV/Examples/TP/Collatz.hs +119/−0
- Documentation/SBV/Examples/TP/ConstFold.hs +1523/−0
- Documentation/SBV/Examples/TP/Countdown.hs +135/−0
- Documentation/SBV/Examples/TP/Fibonacci.hs +86/−0
- Documentation/SBV/Examples/TP/GCD.hs +1063/−0
- Documentation/SBV/Examples/TP/InsertionSort.hs +225/−0
- Documentation/SBV/Examples/TP/Kadane.hs +175/−0
- Documentation/SBV/Examples/TP/Kleene.hs +140/−0
- Documentation/SBV/Examples/TP/Lists.hs +2064/−0
- Documentation/SBV/Examples/TP/Majority.hs +157/−0
- Documentation/SBV/Examples/TP/McCarthy91.hs +94/−0
- Documentation/SBV/Examples/TP/MergeSort.hs +314/−0
- Documentation/SBV/Examples/TP/MutualCorecursion.hs +187/−0
- Documentation/SBV/Examples/TP/NatStream.hs +121/−0
- Documentation/SBV/Examples/TP/Numeric.hs +370/−0
- Documentation/SBV/Examples/TP/Peano.hs +926/−0
- Documentation/SBV/Examples/TP/PigeonHole.hs +53/−0
- Documentation/SBV/Examples/TP/PowerMod.hs +507/−0
- Documentation/SBV/Examples/TP/Primes.hs +522/−0
- Documentation/SBV/Examples/TP/Queue.hs +197/−0
- Documentation/SBV/Examples/TP/QuickSort.hs +698/−0
- Documentation/SBV/Examples/TP/RevAcc.hs +81/−0
- Documentation/SBV/Examples/TP/Reverse.hs +176/−0
- Documentation/SBV/Examples/TP/RunLength.hs +198/−0
- Documentation/SBV/Examples/TP/ShefferStroke.hs +689/−0
- Documentation/SBV/Examples/TP/SortHelpers.hs +195/−0
- Documentation/SBV/Examples/TP/Sqrt2IsIrrational.hs +111/−0
- Documentation/SBV/Examples/TP/StrongInduction.hs +336/−0
- Documentation/SBV/Examples/TP/SumReverse.hs +85/−0
- Documentation/SBV/Examples/TP/Tao.hs +58/−0
- Documentation/SBV/Examples/TP/TautologyChecker.hs +1124/−0
- Documentation/SBV/Examples/TP/UpDown.hs +114/−0
- Documentation/SBV/Examples/TP/VM.hs +448/−0
- Documentation/SBV/Examples/Transformers/SymbolicEval.hs +13/−16
- Documentation/SBV/Examples/Uninterpreted/AUF.hs +11/−20
- Documentation/SBV/Examples/Uninterpreted/Deduce.hs +10/−37
- Documentation/SBV/Examples/Uninterpreted/EUFLogic.hs +340/−0
- Documentation/SBV/Examples/Uninterpreted/Function.hs +4/−1
- Documentation/SBV/Examples/Uninterpreted/Multiply.hs +18/−19
- Documentation/SBV/Examples/Uninterpreted/Shannon.hs +1/−1
- Documentation/SBV/Examples/Uninterpreted/Sort.hs +8/−11
- Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs +27/−28
- Documentation/SBV/Examples/WeakestPreconditions/Append.hs +17/−28
- Documentation/SBV/Examples/WeakestPreconditions/Basics.hs +11/−9
- Documentation/SBV/Examples/WeakestPreconditions/Fib.hs +12/−17
- Documentation/SBV/Examples/WeakestPreconditions/GCD.hs +14/−31
- Documentation/SBV/Examples/WeakestPreconditions/IntDiv.hs +11/−11
- Documentation/SBV/Examples/WeakestPreconditions/IntSqrt.hs +11/−11
- Documentation/SBV/Examples/WeakestPreconditions/Length.hs +21/−34
- Documentation/SBV/Examples/WeakestPreconditions/Sum.hs +27/−26
- INSTALL +1/−1
- LICENSE +1/−1
- README.md +282/−4
- SBVBenchSuite/BenchSuite/Bench/Bench.hs +9/−9
- SBVBenchSuite/BenchSuite/BitPrecise/MultMask.hs +0/−31
- SBVBenchSuite/BenchSuite/CodeGeneration/Uninterpreted.hs +2/−0
- SBVBenchSuite/BenchSuite/Crypto/AES.hs +2/−0
- SBVBenchSuite/BenchSuite/Existentials/CRCPolynomial.hs +0/−23
- SBVBenchSuite/BenchSuite/Existentials/Diophantine.hs +1/−1
- SBVBenchSuite/BenchSuite/Lists/Nested.hs +0/−25
- SBVBenchSuite/BenchSuite/Misc/Enumerate.hs +6/−6
- SBVBenchSuite/BenchSuite/Misc/NoDiv0.hs +1/−1
- SBVBenchSuite/BenchSuite/Misc/SetAlgebra.hs +2/−0
- SBVBenchSuite/BenchSuite/Optimization/Instances.hs +1/−1
- SBVBenchSuite/BenchSuite/ProofTools/BMC.hs +1/−1
- SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs +1/−1
- SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs +1/−1
- SBVBenchSuite/BenchSuite/ProofTools/Sum.hs +2/−2
- SBVBenchSuite/BenchSuite/Puzzles/Coins.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/Counts.hs +1/−2
- SBVBenchSuite/BenchSuite/Puzzles/Garden.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/MagicSquare.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/NQueens.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/Sudoku.hs +6/−8
- SBVBenchSuite/BenchSuite/Puzzles/U2Bridge.hs +1/−1
- SBVBenchSuite/BenchSuite/Queries/Enums.hs +1/−1
- SBVBenchSuite/BenchSuite/Queries/GuessNumber.hs +1/−1
- SBVBenchSuite/BenchSuite/Transformers/SymbolicEval.hs +1/−1
- SBVBenchSuite/BenchSuite/Uninterpreted/AUF.hs +2/−2
- SBVBenchSuite/BenchSuite/Uninterpreted/Deduce.hs +7/−4
- SBVBenchSuite/BenchSuite/Uninterpreted/Multiply.hs +2/−0
- SBVBenchSuite/BenchSuite/Uninterpreted/Shannon.hs +3/−1
- SBVBenchSuite/BenchSuite/Uninterpreted/Sort.hs +3/−3
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Append.hs +2/−2
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Fib.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/GCD.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Instances.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/IntDiv.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/IntSqrt.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Length.hs +1/−5
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Sum.hs +1/−1
- SBVBenchSuite/SBVBench.hs +5/−7
- SBVBenchSuite/Utils/SBVBenchFramework.hs +15/−3
- SBVTestSuite/GoldFiles/adt00.gold +94/−0
- SBVTestSuite/GoldFiles/adt01.gold +102/−0
- SBVTestSuite/GoldFiles/adt02.gold +96/−0
- SBVTestSuite/GoldFiles/adt03.gold +95/−0
- SBVTestSuite/GoldFiles/adt04.gold +180/−0
- SBVTestSuite/GoldFiles/adt05.gold +130/−0
- SBVTestSuite/GoldFiles/adt06.gold +103/−0
- SBVTestSuite/GoldFiles/adt_chk01.gold +40/−0
- SBVTestSuite/GoldFiles/adt_expr00.gold +219/−0
- SBVTestSuite/GoldFiles/adt_expr00c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr01.gold +219/−0
- SBVTestSuite/GoldFiles/adt_expr01c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr02.gold +219/−0
- SBVTestSuite/GoldFiles/adt_expr02c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr03.gold +219/−0
- SBVTestSuite/GoldFiles/adt_expr03c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr04.gold +30/−0
- SBVTestSuite/GoldFiles/adt_expr05.gold +30/−0
- SBVTestSuite/GoldFiles/adt_expr06.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr06c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr07.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr07c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr08.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr08c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr09.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr09c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr10.gold +454/−0
- SBVTestSuite/GoldFiles/adt_expr10c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr11.gold +102/−0
- SBVTestSuite/GoldFiles/adt_expr11c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr12.gold +319/−0
- SBVTestSuite/GoldFiles/adt_expr12c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr13.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr13c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr14.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr14c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr15.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr15c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr16.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr16c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr17.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr17c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_expr18.gold +75/−0
- SBVTestSuite/GoldFiles/adt_expr18c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_gen00.gold +277/−0
- SBVTestSuite/GoldFiles/adt_gen01.gold +83/−0
- SBVTestSuite/GoldFiles/adt_gen02.gold +85/−0
- SBVTestSuite/GoldFiles/adt_gen03.gold +85/−0
- SBVTestSuite/GoldFiles/adt_gen04.gold +85/−0
- SBVTestSuite/GoldFiles/adt_gen05.gold +85/−0
- SBVTestSuite/GoldFiles/adt_gen06.gold +85/−0
- SBVTestSuite/GoldFiles/adt_gen07.gold +85/−0
- SBVTestSuite/GoldFiles/adt_gen08.gold +85/−0
- SBVTestSuite/GoldFiles/adt_gen09.gold +85/−0
- SBVTestSuite/GoldFiles/adt_gen10.gold +85/−0
- SBVTestSuite/GoldFiles/adt_gen11.gold +83/−0
- SBVTestSuite/GoldFiles/adt_gen12.gold +82/−0
- SBVTestSuite/GoldFiles/adt_lit00.gold +240/−0
- SBVTestSuite/GoldFiles/adt_lit00c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_lit01.gold +240/−0
- SBVTestSuite/GoldFiles/adt_lit01c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_lit02.gold +241/−0
- SBVTestSuite/GoldFiles/adt_lit02c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_lit03.gold +241/−0
- SBVTestSuite/GoldFiles/adt_lit03c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_lit04.gold +241/−0
- SBVTestSuite/GoldFiles/adt_lit04c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_lit05.gold +240/−0
- SBVTestSuite/GoldFiles/adt_lit05c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_mr00.gold +69/−0
- SBVTestSuite/GoldFiles/adt_mr01.gold +73/−0
- SBVTestSuite/GoldFiles/adt_mr02.gold +50/−0
- SBVTestSuite/GoldFiles/adt_mr03.gold +47/−0
- SBVTestSuite/GoldFiles/adt_mr04.gold +51/−0
- SBVTestSuite/GoldFiles/adt_nested00.gold +80/−0
- SBVTestSuite/GoldFiles/adt_nested00c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested01.gold +80/−0
- SBVTestSuite/GoldFiles/adt_nested01c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested02.gold +80/−0
- SBVTestSuite/GoldFiles/adt_nested02c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested03.gold +80/−0
- SBVTestSuite/GoldFiles/adt_nested03c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested04.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested04c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested05.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested05c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested06.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested06c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested07.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested07c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested08.gold +80/−0
- SBVTestSuite/GoldFiles/adt_nested08c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested09.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested09c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested10.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested10c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested11.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested11c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested12.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested12c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested13.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested13c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested14.gold +80/−0
- SBVTestSuite/GoldFiles/adt_nested14c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested15.gold +114/−0
- SBVTestSuite/GoldFiles/adt_nested15c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested16.gold +113/−0
- SBVTestSuite/GoldFiles/adt_nested16c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested17.gold +114/−0
- SBVTestSuite/GoldFiles/adt_nested17c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested18.gold +252/−0
- SBVTestSuite/GoldFiles/adt_nested19.gold +80/−0
- SBVTestSuite/GoldFiles/adt_nested19c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested20.gold +79/−0
- SBVTestSuite/GoldFiles/adt_nested20c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested21.gold +80/−0
- SBVTestSuite/GoldFiles/adt_nested21c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested22.gold +80/−0
- SBVTestSuite/GoldFiles/adt_nested22c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested23.gold +253/−0
- SBVTestSuite/GoldFiles/adt_nested24.gold +253/−0
- SBVTestSuite/GoldFiles/adt_nested25.gold +71/−0
- SBVTestSuite/GoldFiles/adt_nested25c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested26.gold +71/−0
- SBVTestSuite/GoldFiles/adt_nested26c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested27.gold +70/−0
- SBVTestSuite/GoldFiles/adt_nested27c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested28.gold +70/−0
- SBVTestSuite/GoldFiles/adt_nested28c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested29.gold +243/−0
- SBVTestSuite/GoldFiles/adt_nested30.gold +108/−0
- SBVTestSuite/GoldFiles/adt_nested30c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested31.gold +108/−0
- SBVTestSuite/GoldFiles/adt_nested31c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested32.gold +108/−0
- SBVTestSuite/GoldFiles/adt_nested32c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested33.gold +108/−0
- SBVTestSuite/GoldFiles/adt_nested33c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_nested34.gold +157/−0
- SBVTestSuite/GoldFiles/adt_pchk01.gold +40/−0
- SBVTestSuite/GoldFiles/adt_pexpr00.gold +219/−0
- SBVTestSuite/GoldFiles/adt_pexpr00c.gold +25/−0
- SBVTestSuite/GoldFiles/adt_pexpr01.gold +219/−0
- SBVTestSuite/GoldFiles/adt_pexpr01c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr02.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr02c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr03.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr03c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr04.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr05.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr06.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr06c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr07.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr07c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr08.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr08c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr09.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr09c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr10.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr10c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr11.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr11c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr12.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr12c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr13.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr13c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr14.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr14c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr15.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr15c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr16.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr16c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr17.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr17c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr18.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr18c.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr19.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr20.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pexpr21.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen00.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen01.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen02.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen03.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen04.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen05.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen06.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen07.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen08.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen09.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen10.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen11.gold too large to diff
- SBVTestSuite/GoldFiles/adt_pgen12.gold too large to diff
- SBVTestSuite/GoldFiles/aes128Lib.gold too large to diff
- SBVTestSuite/GoldFiles/allSat1.gold too large to diff
- SBVTestSuite/GoldFiles/allSat2.gold too large to diff
- SBVTestSuite/GoldFiles/allSat6.gold too large to diff
- SBVTestSuite/GoldFiles/allSat7.gold too large to diff
- SBVTestSuite/GoldFiles/allSat8.gold too large to diff
- SBVTestSuite/GoldFiles/arbFp_opt_1.gold too large to diff
- SBVTestSuite/GoldFiles/arrayGetValTest1.gold too large to diff
- SBVTestSuite/GoldFiles/array_caching_01.gold too large to diff
- SBVTestSuite/GoldFiles/array_caching_02.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_1.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_11.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_12.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_13.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_14.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_15.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_16.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_17.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_18.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_19.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_2.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_20.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_21.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_22.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_23.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_24.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_25.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_26.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_27.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_28.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_29.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_3.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_30.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_31.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_5.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_7.gold too large to diff
- SBVTestSuite/GoldFiles/array_misc_9.gold too large to diff
- SBVTestSuite/GoldFiles/auf-1.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int16_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int16_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int16_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int16_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int32_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int32_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int32_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int32_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int64_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int64_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int64_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int64_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int8_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int8_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int8_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Int8_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word16_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word16_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word16_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word16_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word32_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word32_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word32_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word32_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word64_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word64_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word64_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word64_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word8_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word8_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word8_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Left_Word8_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int16_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int16_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int16_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int16_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int32_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int32_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int32_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int32_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int64_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int64_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int64_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int64_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int8_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int8_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int8_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Int8_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word16_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word16_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word16_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word16_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word32_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word32_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word32_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word32_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word64_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word64_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word64_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word64_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word8_Word16.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word8_Word32.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word8_Word64.gold too large to diff
- SBVTestSuite/GoldFiles/barrelRotate_Right_Word8_Word8.gold too large to diff
- SBVTestSuite/GoldFiles/basic-2_1.gold too large to diff
- SBVTestSuite/GoldFiles/basic-2_2.gold too large to diff
- SBVTestSuite/GoldFiles/basic-2_3.gold too large to diff
- SBVTestSuite/GoldFiles/basic-2_4.gold too large to diff
- SBVTestSuite/GoldFiles/basic-3_1.gold too large to diff
- SBVTestSuite/GoldFiles/basic-3_2.gold too large to diff
- SBVTestSuite/GoldFiles/basic-3_3.gold too large to diff
- SBVTestSuite/GoldFiles/basic-3_4.gold too large to diff
- SBVTestSuite/GoldFiles/basic-3_5.gold too large to diff
- SBVTestSuite/GoldFiles/basic-4_1.gold too large to diff
- SBVTestSuite/GoldFiles/basic-4_2.gold too large to diff
- SBVTestSuite/GoldFiles/basic-4_3.gold too large to diff
- SBVTestSuite/GoldFiles/basic-4_4.gold too large to diff
- SBVTestSuite/GoldFiles/basic-4_5.gold too large to diff
- SBVTestSuite/GoldFiles/basic-5_1.gold too large to diff
- SBVTestSuite/GoldFiles/basic-5_2.gold too large to diff
- SBVTestSuite/GoldFiles/basic-5_3.gold too large to diff
- SBVTestSuite/GoldFiles/basic-5_4.gold too large to diff
- SBVTestSuite/GoldFiles/basic-5_5.gold too large to diff
- SBVTestSuite/GoldFiles/ccitt.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr00.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr01.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr02.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr03.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr04.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr05.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr06.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr07.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr08.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr09.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr10.gold too large to diff
- SBVTestSuite/GoldFiles/charConstr11.gold too large to diff
- SBVTestSuite/GoldFiles/check1.gold too large to diff
- SBVTestSuite/GoldFiles/check2.gold too large to diff
- SBVTestSuite/GoldFiles/coins.gold too large to diff
- SBVTestSuite/GoldFiles/concreteFoldl.gold too large to diff
- SBVTestSuite/GoldFiles/concreteFoldr.gold too large to diff
- SBVTestSuite/GoldFiles/concreteReverse.gold too large to diff
- SBVTestSuite/GoldFiles/concreteSort.gold too large to diff
- SBVTestSuite/GoldFiles/constArr2_SArray.gold too large to diff
- SBVTestSuite/GoldFiles/constArr_SArray.gold too large to diff
- SBVTestSuite/GoldFiles/counts.gold too large to diff
- SBVTestSuite/GoldFiles/crcPolyExist.gold too large to diff
- SBVTestSuite/GoldFiles/doctest_sanity.gold too large to diff
- SBVTestSuite/GoldFiles/dsat01.gold too large to diff
- SBVTestSuite/GoldFiles/exceptionLocal1.gold too large to diff
- SBVTestSuite/GoldFiles/exceptionLocal2.gold too large to diff
- SBVTestSuite/GoldFiles/exceptionRemote1.gold too large to diff
- SBVTestSuite/GoldFiles/foldlABC1.gold too large to diff
- SBVTestSuite/GoldFiles/foldlABC2.gold too large to diff
- SBVTestSuite/GoldFiles/foldlABC3.gold too large to diff
- SBVTestSuite/GoldFiles/foldrAB1.gold too large to diff
- SBVTestSuite/GoldFiles/foldrAB2.gold too large to diff
- SBVTestSuite/GoldFiles/foldrAB3.gold too large to diff
- SBVTestSuite/GoldFiles/freshVars.gold too large to diff
- SBVTestSuite/GoldFiles/genBenchMark1.gold too large to diff
- SBVTestSuite/GoldFiles/genBenchMark2.gold too large to diff
- SBVTestSuite/GoldFiles/iteTest1.gold too large to diff
- SBVTestSuite/GoldFiles/iteTest2.gold too large to diff
- SBVTestSuite/GoldFiles/iteTest3.gold too large to diff
- SBVTestSuite/GoldFiles/lambda01.gold too large to diff
- SBVTestSuite/GoldFiles/lambda02.gold too large to diff
- SBVTestSuite/GoldFiles/lambda03.gold too large to diff
- SBVTestSuite/GoldFiles/lambda04.gold too large to diff
- SBVTestSuite/GoldFiles/lambda05.gold too large to diff
- SBVTestSuite/GoldFiles/lambda06.gold too large to diff
- SBVTestSuite/GoldFiles/lambda07.gold too large to diff
- SBVTestSuite/GoldFiles/lambda08.gold too large to diff
- SBVTestSuite/GoldFiles/lambda09.gold too large to diff
- SBVTestSuite/GoldFiles/lambda10.gold too large to diff
- SBVTestSuite/GoldFiles/lambda11.gold too large to diff
- SBVTestSuite/GoldFiles/lambda12.gold too large to diff
- SBVTestSuite/GoldFiles/lambda13.gold too large to diff
- SBVTestSuite/GoldFiles/lambda14.gold too large to diff
- SBVTestSuite/GoldFiles/lambda15.gold too large to diff
- SBVTestSuite/GoldFiles/lambda16.gold too large to diff
- SBVTestSuite/GoldFiles/lambda17.gold too large to diff
- SBVTestSuite/GoldFiles/lambda18.gold too large to diff
- SBVTestSuite/GoldFiles/lambda19.gold too large to diff
- SBVTestSuite/GoldFiles/lambda20.gold too large to diff
- SBVTestSuite/GoldFiles/lambda21.gold too large to diff
- SBVTestSuite/GoldFiles/lambda22.gold too large to diff
- SBVTestSuite/GoldFiles/lambda23.gold too large to diff
- SBVTestSuite/GoldFiles/lambda24.gold too large to diff
- SBVTestSuite/GoldFiles/lambda25.gold too large to diff
- SBVTestSuite/GoldFiles/lambda26.gold too large to diff
- SBVTestSuite/GoldFiles/lambda27.gold too large to diff
- SBVTestSuite/GoldFiles/lambda28.gold too large to diff
- SBVTestSuite/GoldFiles/lambda29.gold too large to diff
- SBVTestSuite/GoldFiles/lambda30.gold too large to diff
- SBVTestSuite/GoldFiles/lambda31.gold too large to diff
- SBVTestSuite/GoldFiles/lambda32.gold too large to diff
- SBVTestSuite/GoldFiles/lambda33.gold too large to diff
- SBVTestSuite/GoldFiles/lambda34.gold too large to diff
- SBVTestSuite/GoldFiles/lambda35.gold too large to diff
- SBVTestSuite/GoldFiles/lambda36.gold too large to diff
- SBVTestSuite/GoldFiles/lambda37.gold too large to diff
- SBVTestSuite/GoldFiles/lambda38.gold too large to diff
- SBVTestSuite/GoldFiles/lambda40.gold too large to diff
- SBVTestSuite/GoldFiles/lambda41.gold too large to diff
- SBVTestSuite/GoldFiles/lambda42.gold too large to diff
- SBVTestSuite/GoldFiles/lambda43.gold too large to diff
- SBVTestSuite/GoldFiles/lambda44.gold too large to diff
- SBVTestSuite/GoldFiles/lambda45.gold too large to diff
- SBVTestSuite/GoldFiles/lambda46.gold too large to diff
- SBVTestSuite/GoldFiles/lambda47.gold too large to diff
- SBVTestSuite/GoldFiles/lambda47_c.gold too large to diff
- SBVTestSuite/GoldFiles/lambda48.gold too large to diff
- SBVTestSuite/GoldFiles/lambda48_c.gold too large to diff
- SBVTestSuite/GoldFiles/lambda49.gold too large to diff
- SBVTestSuite/GoldFiles/lambda49_c.gold too large to diff
- SBVTestSuite/GoldFiles/lambda50.gold too large to diff
- SBVTestSuite/GoldFiles/lambda50_c.gold too large to diff
- SBVTestSuite/GoldFiles/lambda51.gold too large to diff
- SBVTestSuite/GoldFiles/lambda51_c.gold too large to diff
- SBVTestSuite/GoldFiles/lambda52.gold too large to diff
- SBVTestSuite/GoldFiles/lambda52_c.gold too large to diff
- SBVTestSuite/GoldFiles/lambda53.gold too large to diff
- SBVTestSuite/GoldFiles/lambda54.gold too large to diff
- SBVTestSuite/GoldFiles/lambda55.gold too large to diff
- SBVTestSuite/GoldFiles/lambda56.gold too large to diff
- SBVTestSuite/GoldFiles/lambda57.gold too large to diff
- SBVTestSuite/GoldFiles/lambda57a.gold too large to diff
- SBVTestSuite/GoldFiles/lambda57b.gold too large to diff
- SBVTestSuite/GoldFiles/lambda57c.gold too large to diff
- SBVTestSuite/GoldFiles/lambda58.gold too large to diff
- SBVTestSuite/GoldFiles/lambda59.gold too large to diff
- SBVTestSuite/GoldFiles/lambda60.gold too large to diff
- SBVTestSuite/GoldFiles/lambda61.gold too large to diff
- SBVTestSuite/GoldFiles/lambda62.gold too large to diff
- SBVTestSuite/GoldFiles/lambda63.gold too large to diff
- SBVTestSuite/GoldFiles/lambda64.gold too large to diff
- SBVTestSuite/GoldFiles/lambda65.gold too large to diff
- SBVTestSuite/GoldFiles/lambda66.gold too large to diff
- SBVTestSuite/GoldFiles/lambda67.gold too large to diff
- SBVTestSuite/GoldFiles/lambda68.gold too large to diff
- SBVTestSuite/GoldFiles/lambda69.gold too large to diff
- SBVTestSuite/GoldFiles/lambda70.gold too large to diff
- SBVTestSuite/GoldFiles/lambda71.gold too large to diff
- SBVTestSuite/GoldFiles/lambda72.gold too large to diff
- SBVTestSuite/GoldFiles/lambda73.gold too large to diff
- SBVTestSuite/GoldFiles/lambda74.gold too large to diff
- SBVTestSuite/GoldFiles/lambda75.gold too large to diff
- SBVTestSuite/GoldFiles/lambda76.gold too large to diff
- SBVTestSuite/GoldFiles/lambda77.gold too large to diff
- SBVTestSuite/GoldFiles/lambda78.gold too large to diff
- SBVTestSuite/GoldFiles/lambda79.gold too large to diff
- SBVTestSuite/GoldFiles/lambda80.gold too large to diff
- SBVTestSuite/GoldFiles/lambda81.gold too large to diff
- SBVTestSuite/GoldFiles/lambda82.gold too large to diff
- SBVTestSuite/GoldFiles/lambda83.gold too large to diff
- SBVTestSuite/GoldFiles/lambda84.gold too large to diff
- SBVTestSuite/GoldFiles/lambda85.gold too large to diff
- SBVTestSuite/GoldFiles/lambda86.gold too large to diff
- SBVTestSuite/GoldFiles/lambda87.gold too large to diff
- SBVTestSuite/GoldFiles/lambda88.gold too large to diff
- SBVTestSuite/GoldFiles/legato.gold too large to diff
- SBVTestSuite/GoldFiles/legato_c.gold too large to diff
- SBVTestSuite/GoldFiles/listFloat1.gold too large to diff
- SBVTestSuite/GoldFiles/listFloat2.gold too large to diff
- SBVTestSuite/GoldFiles/listFloat3.gold too large to diff
- SBVTestSuite/GoldFiles/mapNoFailure.gold too large to diff
- SBVTestSuite/GoldFiles/mapWithFailure.gold too large to diff
- SBVTestSuite/GoldFiles/maxlWithFailure.gold too large to diff
- SBVTestSuite/GoldFiles/maxrWithFailure.gold too large to diff
- SBVTestSuite/GoldFiles/nested1.gold too large to diff
- SBVTestSuite/GoldFiles/nested2.gold too large to diff
- SBVTestSuite/GoldFiles/nested3.gold too large to diff
- SBVTestSuite/GoldFiles/nested4.gold too large to diff
- SBVTestSuite/GoldFiles/noOpt1.gold too large to diff
- SBVTestSuite/GoldFiles/noOpt2.gold too large to diff
- SBVTestSuite/GoldFiles/nonlinear_cvc4.gold too large to diff
- SBVTestSuite/GoldFiles/nonlinear_cvc5.gold too large to diff
- SBVTestSuite/GoldFiles/nonlinear_z3.gold too large to diff
- SBVTestSuite/GoldFiles/optBasicsRange_08_signed_max.gold too large to diff
- SBVTestSuite/GoldFiles/optBasicsRange_08_signed_min.gold too large to diff
- SBVTestSuite/GoldFiles/optBasicsRange_16_signed_max.gold too large to diff
- SBVTestSuite/GoldFiles/optBasicsRange_16_signed_min.gold too large to diff
- SBVTestSuite/GoldFiles/optBasicsRange_32_signed_max.gold too large to diff
- SBVTestSuite/GoldFiles/optBasicsRange_32_signed_min.gold too large to diff
- SBVTestSuite/GoldFiles/optBasicsRange_64_signed_max.gold too large to diff
- SBVTestSuite/GoldFiles/optBasicsRange_64_signed_min.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat1a.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat1b.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat1c.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat1d.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat2a.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat2b.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat2c.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat2d.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat3.gold too large to diff
- SBVTestSuite/GoldFiles/optFloat4.gold too large to diff
- SBVTestSuite/GoldFiles/optQuant1.gold too large to diff
- SBVTestSuite/GoldFiles/optQuant5.gold too large to diff
- SBVTestSuite/GoldFiles/pareto1.gold too large to diff
- SBVTestSuite/GoldFiles/pareto2.gold too large to diff
- SBVTestSuite/GoldFiles/pbAtLeast.gold too large to diff
- SBVTestSuite/GoldFiles/pbAtMost.gold too large to diff
- SBVTestSuite/GoldFiles/pbEq.gold too large to diff
- SBVTestSuite/GoldFiles/pbEq2.gold too large to diff
- SBVTestSuite/GoldFiles/pbExactly.gold too large to diff
- SBVTestSuite/GoldFiles/pbGe.gold too large to diff
- SBVTestSuite/GoldFiles/pbLe.gold too large to diff
- SBVTestSuite/GoldFiles/pbMutexed.gold too large to diff
- SBVTestSuite/GoldFiles/pbStronglyMutexed.gold too large to diff
- SBVTestSuite/GoldFiles/qEnum1.gold too large to diff
- SBVTestSuite/GoldFiles/qOpt_1.gold too large to diff
- SBVTestSuite/GoldFiles/qOpt_2.gold too large to diff
- SBVTestSuite/GoldFiles/qUninterp1.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_0.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_1.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_2.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_3.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_4.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_5.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_6.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_7.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_8.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_9.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_A.gold too large to diff
- SBVTestSuite/GoldFiles/quantifiedB_B.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsexists_contradiction_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsexists_contradiction_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsexists_satisfiable_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsexists_satisfiable_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsexists_thm_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsexists_thm_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsforall_contradiction_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsforall_contradiction_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsforall_satisfiable_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsforall_satisfiable_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsforall_thm_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_existsforall_thm_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallexists_contradiction_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallexists_contradiction_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallexists_satisfiable_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallexists_satisfiable_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallexists_thm_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallexists_thm_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallforall_contradiction_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallforall_contradiction_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallforall_satisfiable_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallforall_satisfiable_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallforall_thm_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_prove_forallforall_thm_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsexists_contradiction_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsexists_contradiction_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsexists_satisfiable_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsexists_satisfiable_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsexists_thm_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsexists_thm_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsforall_contradiction_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsforall_contradiction_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsforall_satisfiable_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsforall_satisfiable_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsforall_thm_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_existsforall_thm_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallexists_contradiction_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallexists_contradiction_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallexists_satisfiable_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallexists_satisfiable_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallexists_thm_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallexists_thm_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallforall_contradiction_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallforall_contradiction_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallforall_satisfiable_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallforall_satisfiable_p.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallforall_thm_c.gold too large to diff
- SBVTestSuite/GoldFiles/quantified_sat_forallforall_thm_p.gold too large to diff
- SBVTestSuite/GoldFiles/query1.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays1.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays10.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays11.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays12.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays13.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays14.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays15.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays16.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays17.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays2.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays3.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays4.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays5.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays6.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays7.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays8.gold too large to diff
- SBVTestSuite/GoldFiles/queryArrays9.gold too large to diff
- SBVTestSuite/GoldFiles/queryTables.gold too large to diff
- SBVTestSuite/GoldFiles/query_Chars1.gold too large to diff
- SBVTestSuite/GoldFiles/query_Interpolant1.gold too large to diff
- SBVTestSuite/GoldFiles/query_Interpolant2.gold too large to diff
- SBVTestSuite/GoldFiles/query_Interpolant3.gold too large to diff
- SBVTestSuite/GoldFiles/query_Interpolant4.gold too large to diff
- SBVTestSuite/GoldFiles/query_ListOfMaybe.gold too large to diff
- SBVTestSuite/GoldFiles/query_ListOfSum.gold too large to diff
- SBVTestSuite/GoldFiles/query_Lists1.gold too large to diff
- SBVTestSuite/GoldFiles/query_Maybe.gold too large to diff
- SBVTestSuite/GoldFiles/query_Strings1.gold too large to diff
- SBVTestSuite/GoldFiles/query_SumMaybeBoth.gold too large to diff
- SBVTestSuite/GoldFiles/query_Sums.gold too large to diff
- SBVTestSuite/GoldFiles/query_Tuples1.gold too large to diff
- SBVTestSuite/GoldFiles/query_Tuples2.gold too large to diff
- SBVTestSuite/GoldFiles/query_abc.gold too large to diff
- SBVTestSuite/GoldFiles/query_badOption.gold too large to diff
- SBVTestSuite/GoldFiles/query_bitwuzla.gold too large to diff
- SBVTestSuite/GoldFiles/query_boolector.gold too large to diff
- SBVTestSuite/GoldFiles/query_cvc4.gold too large to diff
- SBVTestSuite/GoldFiles/query_cvc5.gold too large to diff
- SBVTestSuite/GoldFiles/query_mathsat.gold too large to diff
- SBVTestSuite/GoldFiles/query_sumMergeEither1.gold too large to diff
- SBVTestSuite/GoldFiles/query_sumMergeEither2.gold too large to diff
- SBVTestSuite/GoldFiles/query_sumMergeMaybe1.gold too large to diff
- SBVTestSuite/GoldFiles/query_sumMergeMaybe2.gold too large to diff
- SBVTestSuite/GoldFiles/query_uiSat_test1.gold too large to diff
- SBVTestSuite/GoldFiles/query_uiSat_test2.gold too large to diff
- SBVTestSuite/GoldFiles/query_uisatex1.gold too large to diff
- SBVTestSuite/GoldFiles/query_uisatex2.gold too large to diff
- SBVTestSuite/GoldFiles/query_uisatex3.gold too large to diff
- SBVTestSuite/GoldFiles/query_yices.gold too large to diff
- SBVTestSuite/GoldFiles/query_z3.gold too large to diff
- SBVTestSuite/GoldFiles/recursive10_mutual.gold too large to diff
- SBVTestSuite/GoldFiles/recursive11_chain.gold too large to diff
- SBVTestSuite/GoldFiles/recursive12_badMutual.gold too large to diff
- SBVTestSuite/GoldFiles/recursive13_mutualMeasure.gold too large to diff
- SBVTestSuite/GoldFiles/recursive14_badMutualMeasure.gold too large to diff
- SBVTestSuite/GoldFiles/recursive15_mixedMutualMeasure.gold too large to diff
- SBVTestSuite/GoldFiles/recursive16_badMixedMutualMeasure.gold too large to diff
- SBVTestSuite/GoldFiles/recursive17_chainMeasure.gold too large to diff
- SBVTestSuite/GoldFiles/recursive19_selfAndMutual.gold too large to diff
- SBVTestSuite/GoldFiles/recursive1_ack.gold too large to diff
- SBVTestSuite/GoldFiles/recursive20_mutualTP.gold too large to diff
- SBVTestSuite/GoldFiles/recursive21_allSelfBadCross.gold too large to diff
- SBVTestSuite/GoldFiles/recursive22_allSelfGoodCross.gold too large to diff
- SBVTestSuite/GoldFiles/recursive23_mutualProductive.gold too large to diff
- SBVTestSuite/GoldFiles/recursive24_badMutualProductive.gold too large to diff
- SBVTestSuite/GoldFiles/recursive25_contractMutualRejected.gold too large to diff
- SBVTestSuite/GoldFiles/recursive26_selfAndMutualProductive.gold too large to diff
- SBVTestSuite/GoldFiles/recursive27_mutualProductive3.gold too large to diff
- SBVTestSuite/GoldFiles/recursive28_noTermCheck.gold too large to diff
- SBVTestSuite/GoldFiles/recursive2_enum.gold too large to diff
- SBVTestSuite/GoldFiles/recursive3_badMeasure.gold too large to diff
- SBVTestSuite/GoldFiles/recursive4_mcCarthy91.gold too large to diff
- SBVTestSuite/GoldFiles/recursive5_badContract.gold too large to diff
- SBVTestSuite/GoldFiles/recursive6_uselessContract.gold too large to diff
- SBVTestSuite/GoldFiles/recursive7_productive.gold too large to diff
- SBVTestSuite/GoldFiles/recursive8_badProductive.gold too large to diff
- SBVTestSuite/GoldFiles/recursive9_productive2.gold too large to diff
- SBVTestSuite/GoldFiles/reverse.gold too large to diff
- SBVTestSuite/GoldFiles/reverseAlt10.gold too large to diff
- SBVTestSuite/GoldFiles/safe1.gold too large to diff
- SBVTestSuite/GoldFiles/safe2.gold too large to diff
- SBVTestSuite/GoldFiles/seqConcat.gold too large to diff
- SBVTestSuite/GoldFiles/seqConcatBad.gold too large to diff
- SBVTestSuite/GoldFiles/seqExamples1.gold too large to diff
- SBVTestSuite/GoldFiles/seqExamples2.gold too large to diff
- SBVTestSuite/GoldFiles/seqExamples3.gold too large to diff
- SBVTestSuite/GoldFiles/seqExamples4.gold too large to diff
- SBVTestSuite/GoldFiles/seqExamples5.gold too large to diff
- SBVTestSuite/GoldFiles/seqExamples6.gold too large to diff
- SBVTestSuite/GoldFiles/seqExamples7.gold too large to diff
- SBVTestSuite/GoldFiles/seqExamples8.gold too large to diff
- SBVTestSuite/GoldFiles/seqIndexOf.gold too large to diff
- SBVTestSuite/GoldFiles/seqIndexOfBad.gold too large to diff
- SBVTestSuite/GoldFiles/set_compl1.gold too large to diff
- SBVTestSuite/GoldFiles/set_delete1.gold too large to diff
- SBVTestSuite/GoldFiles/set_diff1.gold too large to diff
- SBVTestSuite/GoldFiles/set_disj1.gold too large to diff
- SBVTestSuite/GoldFiles/set_empty1.gold too large to diff
- SBVTestSuite/GoldFiles/set_full1.gold too large to diff
- SBVTestSuite/GoldFiles/set_insert1.gold too large to diff
- SBVTestSuite/GoldFiles/set_intersect1.gold too large to diff
- SBVTestSuite/GoldFiles/set_member1.gold too large to diff
- SBVTestSuite/GoldFiles/set_notMember1.gold too large to diff
- SBVTestSuite/GoldFiles/set_psubset1.gold too large to diff
- SBVTestSuite/GoldFiles/set_subset1.gold too large to diff
- SBVTestSuite/GoldFiles/set_tupleSet.gold too large to diff
- SBVTestSuite/GoldFiles/set_uninterp1.gold too large to diff
- SBVTestSuite/GoldFiles/set_uninterp2.gold too large to diff
- SBVTestSuite/GoldFiles/set_union1.gold too large to diff
- SBVTestSuite/GoldFiles/smtFuncUniq_captureConflict.gold too large to diff
- SBVTestSuite/GoldFiles/smtFuncUniq_captureTagged.gold too large to diff
- SBVTestSuite/GoldFiles/smtFuncUniq_conflict.gold too large to diff
- SBVTestSuite/GoldFiles/smtFuncUniq_recursiveConflict.gold too large to diff
- SBVTestSuite/GoldFiles/smtFuncUniq_recursiveOk.gold too large to diff
- SBVTestSuite/GoldFiles/smtFuncUniq_sameOk.gold too large to diff
- SBVTestSuite/GoldFiles/sort.gold too large to diff
- SBVTestSuite/GoldFiles/strConcat.gold too large to diff
- SBVTestSuite/GoldFiles/strConcatBad.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples1.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples10.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples11.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples12.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples13.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples2.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples3.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples4.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples5.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples6.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples7.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples8.gold too large to diff
- SBVTestSuite/GoldFiles/strExamples9.gold too large to diff
- SBVTestSuite/GoldFiles/strIndexOf.gold too large to diff
- SBVTestSuite/GoldFiles/strIndexOfBad.gold too large to diff
- SBVTestSuite/GoldFiles/sumBimapPlus.gold too large to diff
- SBVTestSuite/GoldFiles/sumEitherSat.gold too large to diff
- SBVTestSuite/GoldFiles/sumLiftEither.gold too large to diff
- SBVTestSuite/GoldFiles/sumLiftMaybe.gold too large to diff
- SBVTestSuite/GoldFiles/sumMaybe.gold too large to diff
- SBVTestSuite/GoldFiles/sumMaybeBoth.gold too large to diff
- SBVTestSuite/GoldFiles/sumMergeEither1.gold too large to diff
- SBVTestSuite/GoldFiles/sumMergeEither2.gold too large to diff
- SBVTestSuite/GoldFiles/sumMergeMaybe1.gold too large to diff
- SBVTestSuite/GoldFiles/sumMergeMaybe2.gold too large to diff
- SBVTestSuite/GoldFiles/tgen_c.gold too large to diff
- SBVTestSuite/GoldFiles/tgen_forte.gold too large to diff
- SBVTestSuite/GoldFiles/tgen_haskell.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_alias.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_barFail.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_calcCollapse.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_fooFail.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_hit.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_miss.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_nested.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_recallFail.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_statsHit.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_statsMiss.gold too large to diff
- SBVTestSuite/GoldFiles/tpCache_statsNested.gold too large to diff
- SBVTestSuite/GoldFiles/tuple_enum.gold too large to diff
- SBVTestSuite/GoldFiles/tuple_list.gold too large to diff
- SBVTestSuite/GoldFiles/tuple_nested.gold too large to diff
- SBVTestSuite/GoldFiles/tuple_swap.gold too large to diff
- SBVTestSuite/GoldFiles/tuple_twoTwo.gold too large to diff
- SBVTestSuite/GoldFiles/tuple_unequal.gold too large to diff
- SBVTestSuite/GoldFiles/uiSat_test1.gold too large to diff
- SBVTestSuite/GoldFiles/uiSat_test2.gold too large to diff
- SBVTestSuite/GoldFiles/uiSat_test3.gold too large to diff
- SBVTestSuite/GoldFiles/unint-axioms-empty.gold too large to diff
- SBVTestSuite/GoldFiles/unint-axioms-query.gold too large to diff
- SBVTestSuite/GoldFiles/unint-axioms.gold too large to diff
- SBVTestSuite/GoldFiles/unint-sort01.gold too large to diff
- SBVTestSuite/GoldFiles/uninterpreted-1a.gold too large to diff
- SBVTestSuite/GoldFiles/uninterpreted-3.gold too large to diff
- SBVTestSuite/GoldFiles/uninterpreted-3a.gold too large to diff
- SBVTestSuite/GoldFiles/uninterpreted-4.gold too large to diff
- SBVTestSuite/GoldFiles/uninterpreted-4a.gold too large to diff
- SBVTestSuite/GoldFiles/validate_0.gold too large to diff
- SBVTestSuite/GoldFiles/validate_1.gold too large to diff
- SBVTestSuite/GoldFiles/validate_2.gold too large to diff
- SBVTestSuite/GoldFiles/validate_3.gold too large to diff
- SBVTestSuite/GoldFiles/validate_4.gold too large to diff
- SBVTestSuite/GoldFiles/validate_5.gold too large to diff
- SBVTestSuite/GoldFiles/validate_6.gold too large to diff
- SBVTestSuite/GoldFiles/validate_7.gold too large to diff
- SBVTestSuite/SBVConnectionTest.hs too large to diff
- SBVTestSuite/SBVDocTest.hs too large to diff
- SBVTestSuite/SBVHLint.hs too large to diff
- SBVTestSuite/SBVTest.hs too large to diff
- SBVTestSuite/TestSuite/ADT/ADT.hs too large to diff
- SBVTestSuite/TestSuite/ADT/Expr.hs too large to diff
- SBVTestSuite/TestSuite/ADT/MutRec.hs too large to diff
- SBVTestSuite/TestSuite/ADT/PExpr.hs too large to diff
- SBVTestSuite/TestSuite/Arrays/Caching.hs too large to diff
- SBVTestSuite/TestSuite/Arrays/InitVals.hs too large to diff
- SBVTestSuite/TestSuite/Arrays/Memory.hs too large to diff
- SBVTestSuite/TestSuite/Arrays/Query.hs too large to diff
- SBVTestSuite/TestSuite/Basics/AllSat.hs too large to diff
- SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs too large to diff
- SBVTestSuite/TestSuite/Basics/ArithNoSolver2.hs too large to diff
- SBVTestSuite/TestSuite/Basics/ArithSolver.hs too large to diff
- SBVTestSuite/TestSuite/Basics/BarrelRotate.hs too large to diff
- SBVTestSuite/TestSuite/Basics/BasicTests.hs too large to diff
- SBVTestSuite/TestSuite/Basics/BoundedList.hs too large to diff
- SBVTestSuite/TestSuite/Basics/EqSym.hs too large to diff
- SBVTestSuite/TestSuite/Basics/Exceptions.hs too large to diff
- SBVTestSuite/TestSuite/Basics/GenBenchmark.hs too large to diff
- SBVTestSuite/TestSuite/Basics/Index.hs too large to diff
- SBVTestSuite/TestSuite/Basics/IteTest.hs too large to diff
- SBVTestSuite/TestSuite/Basics/Lambda.hs too large to diff
- SBVTestSuite/TestSuite/Basics/List.hs too large to diff
- SBVTestSuite/TestSuite/Basics/ModelValidate.hs too large to diff
- SBVTestSuite/TestSuite/Basics/Nonlinear.hs too large to diff
- SBVTestSuite/TestSuite/Basics/ProofTests.hs too large to diff
- SBVTestSuite/TestSuite/Basics/PseudoBoolean.hs too large to diff
- SBVTestSuite/TestSuite/Basics/Quantifiers.hs too large to diff
- SBVTestSuite/TestSuite/Basics/Recursive.hs too large to diff
- SBVTestSuite/TestSuite/Basics/Set.hs too large to diff
- SBVTestSuite/TestSuite/Basics/SmtFunctionUnique.hs too large to diff
- SBVTestSuite/TestSuite/Basics/String.hs too large to diff
- SBVTestSuite/TestSuite/Basics/Sum.hs too large to diff
- SBVTestSuite/TestSuite/Basics/TPCaching.hs too large to diff
- SBVTestSuite/TestSuite/Basics/Tuple.hs too large to diff
- SBVTestSuite/TestSuite/Basics/UISat.hs too large to diff
- SBVTestSuite/TestSuite/BitPrecise/Legato.hs too large to diff
- SBVTestSuite/TestSuite/CRC/CCITT.hs too large to diff
- SBVTestSuite/TestSuite/CRC/CCITT_Unidir.hs too large to diff
- SBVTestSuite/TestSuite/CRC/GenPoly.hs too large to diff
- SBVTestSuite/TestSuite/CRC/USB5.hs too large to diff
- SBVTestSuite/TestSuite/CantTypeCheck/Misc.hs too large to diff
- SBVTestSuite/TestSuite/Char/Char.hs too large to diff
- SBVTestSuite/TestSuite/CodeGeneration/Floats.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/Expr.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase01.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase01.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase02.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase02.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase03.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase03.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase04.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase04.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase05.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase05.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase06.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase06.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase07.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase07.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase08.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase08.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase09.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase09.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase10.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase10.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase11.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase11.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase12.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase12.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase13.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase13.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase14.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase14.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase15.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase15.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase16.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase16.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase18.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase18.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase19.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase19.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase20.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase20.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase21.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase21.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase22.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase22.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase23.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase23.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase24.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase24.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase25.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase25.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase26.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase26.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase27.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase27.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase28.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase28.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase29.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase29.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase30.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase30.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase31.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase31.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase32.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase32.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase33.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase33.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase34.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase34.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase35.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase35.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase36.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase36.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase37.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase37.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase39.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase39.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase40.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase40.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase41.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase41.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase42.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase42.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase43.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase43.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase44.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase44.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase45.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase45.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase46.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase46.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase47.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase47.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase48.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase48.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase49.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase49.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase50.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase50.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase51.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase51.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase52.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase52.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase53.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase53.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase54.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase54.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase55.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase55.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase56.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase56.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase57.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase57.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase58.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase58.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase59.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase59.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase60.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase60.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase61.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase61.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase62.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase62.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase63.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase63.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase64.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase64.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase65.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase65.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase66.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase66.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase67.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase67.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase68.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase68.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase69.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase69.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase70.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase70.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase71.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase71.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase72.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase72.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase73.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase73.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase74.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase74.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase75.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase75.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase76.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase76.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/Expr.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase01.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase01.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase02.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase02.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase03.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase03.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase04.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase04.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase05.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase05.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase06.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase06.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase07.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase07.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase08.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase08.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase09.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase09.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase10.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase10.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase100.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase100.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase102.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase102.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase103.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase103.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase104.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase104.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase105.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase105.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase106.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase106.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase11.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase11.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase12.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase12.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase13.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase13.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase14.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase14.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase15.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase15.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase16.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase16.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase17.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase17.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase18.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase18.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase19.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase19.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase20.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase20.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase21.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase21.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase22.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase22.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase23.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase23.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase24.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase24.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase25.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase25.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase26.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase26.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase27.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase27.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase28.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase28.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase29.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase29.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase30.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase30.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase31.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase31.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase32.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase32.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase33.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase33.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase34.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase34.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase35.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase35.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase36.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase36.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase37.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase37.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase38.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase38.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase39.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase39.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase40.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase40.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase41.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase41.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase42.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase42.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase43.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase43.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase44.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase44.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase45.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase45.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase46.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase46.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase47.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase47.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase48.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase48.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase49.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase49.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase50.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase50.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase51.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase51.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase52.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase52.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase53.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase53.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase54.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase54.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase55.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase55.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase56.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase56.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase57.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase57.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase58.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase58.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase60.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase60.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase61.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase61.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase62.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase62.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase63.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase63.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase64.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase64.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase65.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase65.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase67.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase67.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase68.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase68.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase69.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase69.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase70.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase70.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase71.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase71.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase72.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase72.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase73.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase73.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase74.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase74.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase75.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase75.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase76.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase76.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase77.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase77.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase78.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase78.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase79.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase79.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase80.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase80.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase81.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase81.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase82.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase82.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase83.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase83.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase84.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase84.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase85.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase85.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase86.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase86.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase87.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase87.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase88.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase88.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase90.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase90.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase91.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase91.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase92.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase92.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase93.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase93.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase94.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase94.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase95.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase95.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase96.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase96.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase97.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase97.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase98.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase98.stderr too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase99.hs too large to diff
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase99.stderr too large to diff
- SBVTestSuite/TestSuite/Crypto/AES.hs too large to diff
- SBVTestSuite/TestSuite/Existentials/CRCPolynomial.hs too large to diff
- SBVTestSuite/TestSuite/Optimization/AssertWithPenalty.hs too large to diff
- SBVTestSuite/TestSuite/Optimization/Basics.hs too large to diff
- SBVTestSuite/TestSuite/Optimization/Combined.hs too large to diff
- SBVTestSuite/TestSuite/Optimization/ExtensionField.hs too large to diff
- SBVTestSuite/TestSuite/Optimization/Floats.hs too large to diff
- SBVTestSuite/TestSuite/Optimization/NoOpt.hs too large to diff
- SBVTestSuite/TestSuite/Optimization/Quantified.hs too large to diff
- SBVTestSuite/TestSuite/Optimization/Reals.hs too large to diff
- SBVTestSuite/TestSuite/Optimization/Tuples.hs too large to diff
- SBVTestSuite/TestSuite/Overflows/Arithmetic.hs too large to diff
- SBVTestSuite/TestSuite/Overflows/Casts.hs too large to diff
- SBVTestSuite/TestSuite/Puzzles/Coins.hs too large to diff
- SBVTestSuite/TestSuite/Puzzles/Counts.hs too large to diff
- SBVTestSuite/TestSuite/Puzzles/MagicSquare.hs too large to diff
- SBVTestSuite/TestSuite/Puzzles/NQueens.hs too large to diff
- SBVTestSuite/TestSuite/Puzzles/Sudoku.hs too large to diff
- SBVTestSuite/TestSuite/Puzzles/Temperature.hs too large to diff
- SBVTestSuite/TestSuite/Puzzles/U2Bridge.hs too large to diff
- SBVTestSuite/TestSuite/Queries/ArrayGetVal.hs too large to diff
- SBVTestSuite/TestSuite/Queries/Enums.hs too large to diff
- SBVTestSuite/TestSuite/Queries/FreshVars.hs too large to diff
- SBVTestSuite/TestSuite/Queries/Interpolants.hs too large to diff
- SBVTestSuite/TestSuite/Queries/Lists.hs too large to diff
- SBVTestSuite/TestSuite/Queries/Sums.hs too large to diff
- SBVTestSuite/TestSuite/Queries/Tables.hs too large to diff
- SBVTestSuite/TestSuite/Queries/Tuples.hs too large to diff
- SBVTestSuite/TestSuite/Queries/UISatEx.hs too large to diff
- SBVTestSuite/TestSuite/Queries/Uninterpreted.hs too large to diff
- SBVTestSuite/TestSuite/QuickCheck/QC.hs too large to diff
- SBVTestSuite/TestSuite/Transformers/SymbolicEval.hs too large to diff
- SBVTestSuite/TestSuite/Uninterpreted/AUF.hs too large to diff
- SBVTestSuite/TestSuite/Uninterpreted/Axioms.hs too large to diff
- SBVTestSuite/TestSuite/Uninterpreted/EUFLogic.hs too large to diff
- SBVTestSuite/TestSuite/Uninterpreted/Function.hs too large to diff
- SBVTestSuite/TestSuite/Uninterpreted/Sort.hs too large to diff
- SBVTestSuite/TestSuite/Uninterpreted/Uninterpreted.hs too large to diff
- SBVTestSuite/Utils/SBVTestFramework.hs too large to diff
- sbv.cabal too large to diff
CHANGES.md view
@@ -1,2350 +1,3302 @@ * Hackage: <http://hackage.haskell.org/package/sbv>-* GitHub: <http://leventerkok.github.io/sbv/>--* Latest Hackage released version: 9.0, 2022-04-27--### Version 9.0-- * Changes required to compile cleanly with GHC 9.2 series.-- * In future versions, GHC will make `forall` a reserved word, which will create a conflict with SBV's use of the same.- To accommodate for these changes and to be consistent, following identifiers were renamed:-- - `forall` --> `sbvForall`- - `forall_` --> `sbvForall_`- - `exists` --> `sbvExists`- - `exists_` --> `sbvExists_`- - `forAll` --> `universal`- - `forAll_` --> `universal_`- - `forSome` --> `existential`- - `forSome_` --> `existential_`-- * Add support for `reverse` on symbolic lists and strings. Note that this definition uses a recursive function- declaration in SMTLib, so any proof involving inductive reasoning will likely not-terminate. However, it- should be usable at ground-level and for simpler non-inductive properties. Of course, as SMT-solvers mature- this can change in the future.-- * Changed the String/List versions of `.++/.!!` to directly use the names `++/!!`. Since these modules- are intended to be used qualified only, there's no reason to add the dots.-- * Added function `addSMTDefinition`, which allows users to give direct definitions of SMTLib functions. This- is useful for defining recursive functions that are not symbolically terminating.-- * Added `Documentation.SBV.Examples.Lists.CountOutAndTransfer` example, proving that the so-called- coating card trick works correctly.-- * Added `Documentation.SBV.Examples.Puzzles.Jugs` example, solving the water-jug transfer puzzle.-- * Added `Documentation.SBV.Examples.Puzzles.AOC_2021_24` example, showing how to model an EDSL in SBV,- solving the advent-of-code, 2021, day 24 problem.-- * Added `Documentation.SBV.Examples.Puzzles.Drinker` example, proving the famous Drinker paradox of- Raymond Smullyan.-- * Added concrete type instances of Mergeable class.-- * Fixed a bug in the implementation of the concrete-path for sPopCount- - * Added complement, power, and difference operators for regular expressions. Also added `everything`, `nothing`,- `anyChar` as new recognizers.-- * Fixed the semantics of `All` regular expressions to recognize all-strings, and added `AllChar` as a- new regular-expression constructor to match any single regular expression. Thanks to Matt Torrence for- the patch.-- * Fixed a bug in the concrete implementation of bit-vector join, which didn't handle signed quantities- correctly. Thanks to Sirui Lu for the report and test cases.--### Version 8.17, 2021-10-25-- * SBV now supports cvc5; the latest incarnation of CVC. See https://github.com/cvc5/cvc5- for details.-- * SBV now supports bitwuzla; the latest incarnation of Boolector. See https://github.com/bitwuzla/bitwuzla- for details.-- * Fixed handling of CRational values in constant folding, which was missing a case.- Thanks to Jaro Reinders for reporting.-- * Fixed calls to distinct for floating-point values, causing SBV to throw an exception.-- * Add missing instances of SatModel for Char and String. Thanks to eax- on github- for the contribution.-- * Add support for symbolic comparison of regular expressions.-- * Export svToSV from Data.SBV.Dynamic. Thanks to Matt Parker for the PR.--### Version 8.16, 2021-08-18-- * Put extra annotations on data-type constructors, which makes- SBV generate problems that z3 can parse more easily. Thanks to- Greg Sullivan for reporting the issue in the first place.--### Version 8.15, 2021-05-30-- * Remove support for SFunArray abstraction. Turns out that the caching- mechanisms SBV used for SFunArray weren't entirely safe, and the code- has become unmaintainable over-time. Instead you should simply use- SArray, which has the exact same API. Thanks to frenchFrog42 on- github for reporting some of the problems.-- * Fix the cmd line params for invocations of Boolector. You need- Boolector 3.2.2 to work with this version of SBV.-- * NB. Recent releases of z3 no longer support optimization of real-valued- goals in the presence of strict inequalities, i.e., .>, .<, and ./= operators.- So, you might get a bogus result if you are using optimization with- SReal parameters that have strict inequalities. See https://github.com/Z3Prover/z3/issues/5314- for details. There is not much SBV can do to prevent these, unfortunately,- as z3 optimization engine goals seem to have changed. Note that use of- non-strict inequalities (i.e., .>=, .<=) should be fine. Also, this- only impacts the optimize calls: regular sat/prove invocations are not- impacted.--### Version 8.14, 2021-03-29-- * Improve the fast all-sat algorithm to also support uninterpreted values.-- * Generalize svTestBit to work on floats, returning the respecting bit in the- representation of the float.-- * Fixes to crack-num facility of how we display floats in detail.--### Version 8.13, 2021-03-21-- * Generalized floating point: Add support for brain-floats, with- type `SFPBFloat`, which has 8-bits of exponent and 8-bits of- significand. This format is affectionately called "brain-float"- because it's often used in modeling neural networks machine-learning- applications, offering a wider-range than IEEE's half-float, at the- exponse of reduced precision. It has 8-exponent bits and 8-significand- bits, including the hidden bit.-- * Add support for SRational type, rational values built out of the ratio- of two integers. Use the module "Data.SBV.Rational", which exports the- constructor .% to build rationals. Note that you cannot take numerator- and denominator of rationals apart, since SMTLib has no way of storing- the rational in a canonical way. Otherwise, symbolic rationals follow- the same rules as Haskell's Rational type.-- * SBV now implements a faster allSat algorithm, which applies in most common- use cases. (Essentially, when there are no uninterpreted values or sorts present.)- The new algorithm has been measured to be at least an order of magnitude- faster or more in common cases as it splits the search space into disjoint- models, reducing the burden of accummulated lemmas over multiple calls. (See- http://theory.stanford.edu/%7Enikolaj/programmingz3.html#sec-blocking-evaluations- for details.)--### Version 8.12, 2021-03-09-- * Fix a bug in crackNum for unsigned-integer values, which incorrectly- showed a negation sign for values with msb set to 1.--### Version 8.11, 2021-03-09-- * SBV now supports floating-point numbers with arbitrary exponent and- significand sizes. The type is `SFloatingPoint eb sb`, where `eb`- and `sb` are type-level naturals. In particular, SBV can now reason about- half-floats, which are used much more frequently in ML applications. Through- the LibBF binding, you can also use these concretely, so if you have a use- case for computing with floats, you can use SBV as a vehicle for doing so.- The exponent/significand sizes are limited to those supported by the LibBF- bindings, though the allowed range is rather large and should not be a limitation- in practice. (In particular, you'll most likely run out of memory before you- hit precision limits!)-- * We now support a separate `crackNum` parameter in model display. If set to True- (default is False), SBV will display numeric values of bounded integers, words,- and all floats (SDouble, SFloat, and the new SFloatingPoint) in models in detail,- showing how they are laid out in memory. Numbers follow the usual 2's-complement- notation if they are signed, bit-vectors if they are not signed, and the floats- follow the usual IEEE754 binary layout rules. Similarly, there's now a function- crack :: SBV a -> String that does the same for non-model printing contexts.-- * Changed the isNonModelVar config param to take a String (instead of Text).- Simplifies programming.-- * Changes to make SBV compile with GHC9.0. Thanks to Ryan Scott for the patch.--### Version 8.10, 2021-02-13-- * Add "Documentation/SBV/Examples/Misc/NestedArray.hs" to demonstrate how- to model multi-dimensional arrays in SBV.-- * Add "Documentation/SBV/Examples/Puzzles/Murder.hs" as another puzzle example.-- * Performance updates: Thanks to Jeff Young, SBV now uses better underlying- data structures, performing better for heavy use-case scenarios.-- * SBV now tracks constants more closely in query mode, providing more support- for constant arrays in a seamless way. (See #574 for details.)-- * Pop-calls are now support for Yices and Boolector. (#577)-- * Changes required to make SBV work with latest version of z3 regarding- String and Characters, which now allow for unicode characters. This required- renaming of certain recognizers in 'Data.SBV.Char' to restrict them to the- Latin1 subset. Otherwise, the changes should be transparent to the end user.- Please report any issues you might run into when you use SChar and SString types.--### Version 8.9, 2020-10-28-- * Rename 'sbvAvailableSolvers' to 'getAvailableSolvers'.-- * Use SMTLib's int2bv if supported by the backend solver. If not, we still- do a manual translation. (CVC4 and z3 support it natively, Yices and- MathSAT does not, for which we do the manual translation. ABC and dReal- doesn't support the coversion at all, since former doesn't support integers- and the latter doesn't support bit-vectors.) Thanks to Martin Lundfall- for the initial pull request.-- * Add `sym` as a synonym for `uninterpret`. This allows us to write expressions- of the form `sat $ sym "a" - sym "b" .== (0::SInteger)`, without resorting to lambda- expressions or having to explicitly be in the Symbolic monad.-- * Added missing instances for overflow-checking arithmetic of arbitrary- sized signed and unsigned bitvectors.-- * In a sat (or allSat) call, also return the values of the uninterpreted values, along with- all the explicitly named inputs. Strictly speaking, this is backwards-incompatible,- but it the new behavior is consistent with how we handle uninterpreted values in general.-- * Improve SMTLib logic-detection code to use generics.--### Version 8.8, 2020-09-04-- * Reworked uninterpreted sorts. Added new function `mkUninterpretedSort` to make- declaration of completely uninterpreted sorts easier. In particular, we now- automatically introduce the symbolic variant of the type (by prefixing the- underlying type with `S`) so it becomes automatically available, both for uninterpreted- sorts and enumerations. In the latter case, we also automatically introduce the value `sX`- for each enumeration constant `X`, defined to be precisely `literal X`.-- * Handle incremental mode table-declarations that depend on freshly declared variables. Thanks- to Gergő Érdi for reporting.-- * Fix a soundness bug in SFunArray caching. Thanks to Gergő Érdi for reporting. See- https://github.com/LeventErkok/sbv/issues/541 for details.-- * Add support for the dReal solver, and introduce the notion of delta-satisfiability,- where you can now check properties to be satisfiable against delta-perturbations.- See "Documentation.SBV.Examples.DeltaSat.DeltaSat" for a basic example.-- * Add "extraArgs" parameter to SMTConfig to simplify passing extra command line- arguments to the solver.-- * Add a method -- sListArray :: (HasKind a, SymVal b) => b -> [(SBV a, SBV b)] -> array a b-- to the `SymArray` class, which allows for creation of arrays from lists of constant or - symbolic lists of pairs. The first argument is the value to use for uninitialized entries.- Note that the initializer must be a known constant, i.e., it cannot be symbolic. Latter- elements of the list will overwrite the earlier ones, if there are repeated keys.-- * Thanks to Jan Hrcek, a whole bunch of typos were fixed in the documentation and- the source code. Much appreciated!--### Version 8.7, 2020-06-30-- * Add support for concurrent versions of solvers for query problems. Similar to- `satWithAny`, `proveWithAny` etc., except when we have queries. Thanks to Jeffrey Young- for the idea and the implementation.-- * Add "Documentation.SBV.Examples.Misc.Newtypes", demonstrating how to use newtypes- over existing symbolic types as symbolic quantities themselves. Thanks to Curran McConnell- for the example.-- * Added new predicate `sNotElem`, negating `sElem`.-- * Added new predicate `distinctExcept`. This is same as `distinct`- except you can also provide an ignore list. The elements in- the first list will be checked to be distinct from each other,- or belong to the second list. This is good for writing constraints- that either require a default value or if picked be different- from each other for a set of variables. This sort of constraint- can be coded in user space, but SBV generates efficient code- instead of the obvious quadratic number of constraints.-- * Add function 'algRealToRational' that can convert an algebraic-real- to a Haskell rational. We get an either value: If the algebraic real- is exact, then it returns a 'Left' value that represents the value- precisely. Otherwise, it returns a 'Right' value, which is only- an approximation. Note: Setting 'printRealPrec' in SMTConfig- to a higher value will increase the precision at the cost of more- computation by the SMT solver.-- * Removed the 'SMTValue' class. It's functionality was not really- needed. If you ever used this class, removing it from your- type signatures should fix the issue. (You might have to- add SymVal constraint if you did not already have it.) Please- get in touch if you used this class in some cunning way and you- need its functionality back.-- * Reworked SBVBenchSuite api, Phase 1 of BenchSuite completed.- - * Add support for addAxiom command to work in the interactive mode.- Thanks to Martin Lundfall for the feedback.-- * Fixed `proveWithAny` and `satWithAny` functions so they properly- kill the solvers that did not terminate first. Previously, they- became zombies if they didn't end up quickly. Thanks to- Robert Dockins for the investigation and the fix.-- * Fixed a bug where resetAssertions call was forgetting to restore the- array and table contexts. Thanks to Martin Lundfall for reporting.--### Version 8.6, 2020-02-08-- * Fix typo in error message. Thanks to Oliver Charles- for the patch.-- * Fix parsing of sequence counter-examples to accommodate- recent changes in z3.-- * Add missing exports related to N-bit words. Thanks to- Markus Barenhoff for the patch.-- * Generalized code-generation functions to accept a function- with an arbitrary return type, which was previously just unit.- This allows for complicated code-generation scenarios where- one code-gen run can produce input to the next.-- * Scalability improvements for internal data structures. Thanks- to Brian Huffman for the patch.-- * Add interpolation support for Z3, following changes to that- solver. Note that SBV now supports two different APIs for- interpolation extraction, one for Z3 and the other for- MathSAT. This is unfortunate, but necessary since interpolant- extraction isn't quite standardized amongst solvers and- MathSAT and Z3 use sufficiently different calling mechanisms- to warrant their own calls. See 'Documentation.SBV.Examples.Queries.Interpolants'- for examples that illustrate both cases.-- * Add a new argument to `displayModels` function to allow rearranging- of the results in an 'allSat` call. Strictly speaking this is- a backwards breaking change, but substituting `id` for the- new argument gives you old functionality, so easy to work-around.---### Version 8.5, 2019-10-16-- * Changes to compile with GHC 8.8. Thanks to Oliver Charles- for the patch.-- * Minor fix to how kinds are shown for non-standard sizes.-- * Thanks to Jeffrey Young, SBV now has a performance benchmark- test-suite. The framework still new, but should help- in the long run to make sure SBV performance doesn't regress- on its test-suite, and by extension in general usage.--### Version 8.4, 2019-08-31-- * SBV now supports arbitrary-size bit-vectors, i.e.,- SWord 17, SInt 9, SWord 128 etc. These work like any- other bit-vector, using the `DataKinds` feature of- GHC. Thanks to Ben Blaxill for the idea and the initial- implementation. Note that SBV still supports the traditional- fixed-size bit-vectors, SInt8, SWord16 etc. Support for- these will not be removed; so existing programs will- continue to work.-- * To convert between arbitrary sized bit-vectors and- the old style equivalents, use `fromSized` and `toSized`- functions. The behavior is controlled with a closed- type-family so you will get a (hopefully not too- horrendous) type error message if you try to convert,- say, a SInt16 to SInt 22; or vice versa.-- * Added arbitrary-sized bit vector operations: extraction,- extension, and joining; these use proxy arguments to- determine precise size info, and are much better suited- for type safety. Consequently, removed the Splittable- class which provided similar operations but only on- predefined types. There is a new class called ByteConverter- to convert to-and-from bytes for suitable bit-vector- sizes up to 512.-- * Tuple construction functions are given new types to strengthen- type checking. Previously the tuple argument was ignored,- causing things to be marked as tuples when they actually- cannot be. (NB. The system was always type-safe, it just- didn't produce helpful type-error messages before.)-- * Model validator: In the presence of universally quantified- variables, SBV used to refuse to validate given models. This- is the right thing to do since we would have to validate- the model for all possible values of all the universally- quantified variables. Obviously this is not useful. Instead,- SBV now simply assumes any universally quantified variable- is zero during model validation. This severely limits the- validation result, but it is better than nothing. (In the- verbose mode, a message to this effect will be printed.)-- * Model validator: SBV can now validate models returned from- the backend solver for regular-expression match problems.- We also constant fold matches against constant strings without- calling the solver at all, less useful perhaps but more inline- with the general SBV methodology.-- * Add implementation of SHA-2 family of functions as an example- algorithm. These are good for code-generation purposes as- opposed to actual verification tasks as it is hard to state- any properties of these algorithms. But the SBV generated- code can be quite useful in other development and verification- environments. See 'Documentation.SBV.Examples.Crypto.SHA' for- details.-- * Add 'cgShowU8UsingHex function, which controls if we print unsigned-8 bit- values in code generation driver code in hex or not. Previously we were- using decimal, but in crypto code hex is always better. Default is 'False'- to keep backwards compatibility.-- * Add `sObserve` from: `SymWord a => String -> SBV a -> Symbolic ()` which- comes in handy in symbolic contexts, especially with quick-check uses.-- * Ramped up travis-appveyor build infrastructure. However, we no- longer test on the CI, since build-times are prohibitively long- and myriad issues cause instability. If you can help out regarding- testing on CI, please reach out!--### Version 8.3, 2019-06-08-- * Increment base dependency to 4.11.-- * Add support for `Data.Set.hasSize`.-- * Add `supportsFP` to CVC4 capabilities list. (#469)-- * Fix a glitch in allSat computations that incorrectly- used values of internal variables in model construction.-- * SBV now directly uses the new `seq.nth` function from z3- for sequence element access, instead of implementing it- internally.--### Version 8.2, 2019-04-07-- * Fixed minor issue with getting observables in quantified contexts.-- * Simplify data-type constructor usage and accessor formats. See- http://github.com/Z3Prover/z3/issues/2135 for a discussion.-- * Add support for model validation in optimization problems. Use the- config parameter: `optimizeValidateConstraints`. Default: False. This- feature nicely complements the `validateModel` option, which works- for `sat` and `prove` calls. Note that when we validate the model- for an optimization problem, we only make sure that the given result- satisfies the constraints not that it is minimum (or maximum) such- model. (And hence the new configuration variable.) Validating optimality- is beyond the scope of SBV.--### Version 8.1, 2019-03-09-- * Added support for `SEither` and `SMaybe` types: symbolic sums and symbolic- optional values. These can be accessed by importing `Data.SBV.Either` and- `Data.SBV.Maybe` respectively. They translate to SMTLib's data-type syntax,- and thus require a solver capable of handling datatypes. (Currently z3 and- cvc4 are the only solvers that do.) All the typical introduction and- elimination functions are provided, and these types integrate with all- other symbolic types. (So you can have a list of SMaybe of SEither- values, or at any nesting level.) Thanks to Joel Burget for the initial- implementation of this idea and his contributions.-- * Added support for symbolic sets. The API closely follows that of `Data.Set`- of Haskell, with some major differences: Symbolic sets can be co-finite.- (That is, we can represent not only finite sets, but also sets whose complements- are finite.) The distinction shows up in the `complement` operation, which- is not supported in Haskell. All SBV sets can be complemented. On the flip- side, SBV sets do not support a size operation (as they can be infinite),- nor they can be converted to lists. See 'Data.SBV.Set' for the API documentation- and "Documentation/SBV/Examples/Misc/SetAlgebra.hs" for an example that proves- many familiar set properties.-- * SBV models now contain values for uninterpreted functions. This was a long- requested feature, but there was no previous support since SMTLib does not- have a standard way of querying such values. We now support this for z3 and- cvc4: Note that SBV tries its best to interpret the output from these- solvers, but it may give up if the response is too complicated (or something- I haven't seen before!) due to non-standard format. Barring these details,- the calls to `sat` now include function models, and you can also get them- via `getFunction` in a query.-- For an example use case demonstrating how to use UF-models to synthesize a- simple multiplier, see "Documentation/SBV/Examples/Uninterpreted/Multiply.hs".-- * SBV now comes with a model validator. In a 'sat', 'prove', or 'allSat' call,- you can pass the configuration parameter 'z3{validateModel = True}' (or whichever- solver you're using), and z3 will attempt to validate the returned model- from the solver. Note that validation only works if there are no uninterpreted- kinds of functions, and also in quantifier-free problems only. Please report- your experiences, as there's room for improvement in validation, always!-- * [BACKWARDS COMPATIBILITY] The `allSat` function is similarly modified to- return uninterpreted-function models. There are a few technical restrictions,- however: Only the values of uninterpreted functions without any uninterpreted- arguments will participate in `allSat` computation. (For instance,- `uninterpret "f" :: SInteger -> SInteger` is OK, but- `uninterpret "f" :: MyType -> SInteger` is not, where `MyType` itself- is uninterpreted.) The reason for this is again there is no SMTLib way of- reflecting uninterpreted model values back into the solver. This restriction- should not cause much trouble in practice, but do get in touch if it is a- use-case for you.-- * Added configuration option `allSatPrintAlong`. If set to True, calls to- allSat will print their models as they are found. The default is False.-- * Added configuration parameter `satTrackUFs` (defaulting to True) to control- if SBV should try to extract models for uninterpreted functions. In theory,- this should always be True, but for most practical problems we typically- don't care about the function values itself but that it exists. Set to 'False'- if this is the case for your problem. Note that this setting is also respected- in 'allSat' calls.-- * Added function `registerUISMTFunction`, which can be used to directly register uninterpreted- functions. This is typically not necessary as uses of UI-functions do register them- automatically, but it can come in handy in certain scenarios where there are no- constraints on a UI-function other than its existence.-- * Added `Data.SBV.Tools.WeakestPreconditions` module, which provides a toy imperative- language and an engine for checking partial and total correctness of imperative programs.- It uses Dijkstra's weakest preconditions methodology to establish correctness claims.- Loop invariants are required and must be supplied by the user. For total correctness,- user must also provide termination measure functions. However, if desired, these can- be skipped (by passing 'Nothing'), in which case partial correctness will be proven.- Checking input parameters for no-change is supported via stability checks. For example- use cases, see the `Documentation.SBV.Examples.WeakestPreconditions` directory.-- * Added functions `elem`/`notElem` to `Data.SBV.List`.-- * Added `snoc` (appending a single element at the end) to `Data.SBV.List` and `Data.SBV.String`.-- * Rework the 'Queriable' class to allow projection/embedding pairs. Also- added a new 'Fresh' class, which is more usable in simpler scenarios- where the default projection/embedding definitions are suitable.-- * Added strong-equality (.===) and inequality (./==) to the 'EqSymbolic' class. This- method is equivalent to the usual (.==) and (./=) for all types except 'SFloat' and- 'SDouble'. For the floating types, it is object equality, that is 'NaN .=== Nan'- and '0 ./== -0'. Use the regular equality for float/double's as they follow the- IEEE754 rules, but occasionally we need to express object equality in a polymorphic- way. Essentially this method is the polymorphic equivalent of 'fpIsEqualObject'- except it works on all types.-- * Removed the redundant 'SDivisible' constraint on rotate-left and rotate-right operations.-- * Added unnamed equivalents of 'sBool', 'sWord8' etc; with a following underscore, i.e.,- 'sBool_', 'sWord8_'. The new functions are supported for all base types, chars,- strings, lists, and tuples.-- * SBV now supports implicit constraints in the query mode, which were previously only- available before user queries started.-- * Fixed a bug where hash-consing might reuse an expression even though the request might- have been made at a different type. This is a rare case in SBV to happen due to types,- but it was possible to exploit it in the Dynamic interface. Thanks to Brian Huffman- for reporting and diagnosing the issue.-- * Fixed a bug where SBV was reporting incorrect "elapsed" time values, which are- printed when the 'timing' configuration parameter is specified.-- * Documentation: Jan Path kindly fixed module headers of all the files to produce- much better looking Haddock documents. Thanks Jan!-- * Added barrel-rotations (sBarrelRotateLeft-Right, svBarrelRotateLeft-Right) which- can produce better code for verification by bit-blasting the rotation amount.- It accepts bit-vectors as arguments and an unsigned rotation quantity to keep- things simple.-- * Added new configuration option 'allowQuantifiedQueries', default is set to False.- SBV normally doesn't allow quantifiers in a query context, because there are- issues surrounding 'getValue'. However, Joel Burget pointed out this check- is too strict for certain scenarios. So, as an escape hatch, you can define- 'allowQuantifiedQueries' to be 'True' and SBV will bypass this check. Of course,- if you do this, then you are on your own regarding calls to `getValue` with- quantified parameters! See http://github.com/LeventErkok/sbv/issues/459- for details.-- * [BACKWARDS COMPATIBILITY] Renamed the class `IEEEFloatConvertable` to- `IEEEFloatConvertible`. (Typo in name!) Matt Peddie pointed out issues- regarding conversion of out-of-bounds float and double values to integral- types. Unfortunately SMTLib does not support these conversions, and we- had issues in getting Haskell, SMTLib, and C to agree. Summary: These conversions- are only guaranteed to work if they are done on numbers that lie within the- representable range of the target type. Thanks to Matt Peddie for pointing out- the out-of-bounds problem, his help in figuring out the issues.-- * [BACKWARDS COMPATIBILITY] The 'AllSat' result now tracks if search has stopped- because the solver returned 'Unknown'. Previously this information was not- displayed.-- * [BACKWARDS COMPATIBILITY, Internal] Several constraints on internal- classes (such as SymVal, EqSymbolic, OrdSymbolic) were reworked to- reflect the dependencies better. Strictly speaking this is a backwards- compatibility breaking change, but I doubt it'll impact any user- code; though you might have to add some extra constraints if you were- writing sufficiently polymorphic SBV code. Yell if you find otherwise!-- * [BACKWARDS COMPATIBILITY] SBV now allows user-given names to be duplicated.- It will implicitly add a suffix to them to distinguish without complaining. (In- previous versions, we would error out.) The reason for this change is that- sometimes it's nice to be able to simply give a prefix for a class of names- and not worry about the actual name itself. (Note that this will cause issues- if you use model-extraction-via-maps method if we ever make a name unique- and store it under a different name, but that's hardly ever used feature and- arguably the right thing to do anyway.) Thanks to Joel Burget for suggesting- the idea.-- * [BACKWARDS COMPATIBILITY, Internal] SBV is now more strict in how user-queries- are used, performing certain extra-checks that were not done before. (For instance,- previously it was possible to mix prove-sat with a query call, which should- not have been allowed.) If you have any code that breaks for this reason, you- probably should've written it in some other way to start with. Please get- in touch if that is the case.-- * [BACKWARDS COMPATIBILITY] You need at least GHC 8.4.1 to compile SBV.- If you're stuck with an older version, let me know and we'll see if- we can create a custom version for you; though I'd much rather avoid this- if at all possible.-- * SBV now supports optimization of goals of SDouble and SFloat types. This is- done using the lexicographic ordering on floats, and adds on the additional- constraint that the resulting float is not a NaN. If you use this feature,- then your float value will be minimized as the corresponding 32 (or 64 for- doubles) bit word. Note that this methods supports infinities properly, and- does not distinguish between -0 and +0.-- * Optimization routines have been generalized to work over arbitrary metric-spaces,- with user-definable mappings. The simplest instance we have added is optimization- over booleans, by the obvious numeric mapping. Tuples are also supported with- the usual lexicographic ordering. In addition, SBV can now optimize over- user-defined enumerations. See "Documentation.SBV.Examples.Optimization.Enumerate" for- an example.-- * Improved the internal representation of constraints to address performance- issues See http://github.com/LeventErkok/sbv/issues/460 for details. Thanks to- Thanks Jeffrey Young for reporting.--### Version 8.0, 2019-01-14-- * This is a major release of SBV, with several BACKWARDS COMPATIBILITY breaking- changes. Lots of reworking of the internals to modernize the SBV code base.- A few external API changes happened as well, mainly in terms of renamed- types/operators to reflect the current state of things. I expect most end user- programs to carry over unchanged, perhaps needing a bunch of renames. See below- for details.-- * Transformer stack and `SymbolicT`: This major internal revamping was contributed- by Brian Schroeder. Brian reworked the internals of SBV to allow for custom monad- stacks. In particular, there is now a `SymbolicT` monad transformer, which- generalizes the `Symbolic` monad over an arbitrary base type, allowing users to- build SBV based symbolic execution engines on top of their own monad infrastructure.-- Brian took the pains to ensure existing users (or those who do not have their- own monad stack), the transformer capabilities remain transparent. That is,- your existing code should recompile as is, or perhaps with minor aesthetic- changes. Please report if you find otherwise, or need help.-- See `Documentation.SBV.Examples.Transformers.SymbolicEval` for an example of- how to use the transformer based code.-- Thanks to Brian Schroeder for this massive effort to modernize the SBV code-base!-- * Support for tuples: Thanks to Joel Burget, SBV now supports tuple types (up-to- 8-tuples), and allows mixing and matching of lists and tuples arbitrarily- as symbolic values. For instance `SBV [(Integer, String)]` is a valid type as- is `SBV [(Integer, [(Char, (Float, String))])]`, with each component symbolically- represented. Along with `STuple` for regular 2-tuples, there are new types- for `STupleN` for `N` between 2 to 8, along with `untuple` destructor, and field- accessors similar to lens: For instance `p^._4` would project the 4th element of- a tuple that has at least 4 fields. The mixing and matching of field types and- nesting allows for very rich symbolic value representations. See- `Documentation.SBV.Examples.Misc.Tuple` for an example.-- * [BACKWARDS COMPATIBILITY] The `Boolean` class is removed, which used to abstract- over logical connectives. Previously, this class handled 'SBool' and 'Bool', but- the generality was hardly ever used and caused typing ambiguities. The new- implementation simplifies boolean operators to simply operate on the `SBool`- type. Also changed the operator names to fit with all the others by starting- them with dots. A simple conversion guide:-- * Literal True : true became sTrue- * Literal False: false became sFalse- * Negation : bNot became sNot- * Conjunction : &&& became .&&- * Disjunction : ||| became .||- * XOr : <+> became .<+>- * Nand : ~& became .~&- * Nor : ~| became .~|- * Implication : ==> became .=>- * Iff : <=> became .<=>- * Aggregate and: bAnd became sAnd- * Aggregate or : bOr became sOr- * Existential : bAny became sAny- * Universal : bAll became sAll-- * [BACKWARDS COMPATIBILITY, INTERNAL] Historically, SBV focused on bit-vectors and machine- words, which meant lots of internal types were named suggestive of this heritage.- With the addition of `SInteger`, `SReal`, `SFloat`, `SDouble` we have expanded- this, but still remained focused on atomic types. But, thanks largely to- Joel Burget, SBV now supports symbolic characters, strings, lists, and now- tuples, and nested tuples/lists, which makes this word-oriented naming confusing.- To reflect, we made the following internal renamings:-- * SymWord became SymVal- * SW became SV- * CW became CV- * CWVal became CVal-- Along with these, many of the internal constructor/variable names also changed in- a similar fashion.-- For most casual users, these changes should not require any changes. But if you were- developing libraries on top of SBV, then you will have to adapt to the new schema.- Please report if there are any gotchas we have forgotten about.-- * [BACKWARDS COMPATIBILITY] When user queries are present, SBV now picks the logic- "ALL" (as opposed to a suitable variant of bit-vectors as in the past versions).- This can be overridden by the 'setLogic' command as usual of course. While the new- choice breaks backwards compatibility, I expect the impact will be minimal, and- the new behavior matches better with user expectations on how external queries are- usually employed.-- * [BACKWARDS COMPATIBILITY] Renamed the module `Data.SBV.List.Bounded` to- `Data.SBV.Tools.BoundedList`.-- * Introduced a `Queriable` class, which simplifies symbolic programming with composite- user types. See `Documentation.SBV.Examples.ProofTools` directory for several- use cases and examples.-- * Added function `observeIf`, companion to `observe`. Allows observing of values- if they satisfy a given predicate.-- * Added function `ensureSat`, which makes sure the solver context is satisfiable- when called in the query mode. If not, an error will be thrown. Simplifies- programming when we expect a satisfiable result and want to bail out if otherwise.-- * Added `nil` to `Data.SBV.List`. Added `nil` and `uncons` to `Data.SBV.String`.- These were inadvertently left out previously.-- * Add `Data.SBV.Tools.BMC` module, which provides a BMC (bounded-model- checking engine) for traditional state transition systems. See- `Documentation.SBV.Examples.ProofTools.BMC` for example uses.-- * Add `Data.SBV.Tools.Induction` module, which provides an induction engine- for traditional state transition systems. Also added several example use- cases in the directory `Documentation.SBV.Examples.ProofTools`.--### Version 7.13, 2018-12-16-- * Generalize the types of `bminimum` and `bmaximum` by removing the `Num`- constraint.-- * Change the type of `observe` from: `SymWord a => String -> SBV a -> Symbolic ()`- to `SymWord a => String -> SBV a -> SBV a`. This allows for more concise observables,- like this:-- prove $ \x -> observe "lhs" (x+x) .== observe "rhs" (2*x+1)- Falsifiable. Counter-example:- s0 = 0 :: Integer- lhs = 0 :: Integer- rhs = 1 :: Integer-- * Add `Data.SBV.Tools.Range` module which defines `ranges` and `rangesWith` functions: They- compute the satisfying contiguous ranges for predicates with a single variable. See- `Data.SBV.Tools.Range` for examples.-- * Add `Data.SBV.Tools.BoundedFix` module, which defines the operator `bfix` that can be used- as a bounded fixed-point operator for use in bounded-model-checking like algorithms. See- `Data.SBV.Tools.BoundedFix` for some example use cases.-- * Fix list-element extraction code, which asserted too strong a constraint. See issue #421- for details. Thanks to Joel Burget for reporting.-- * New bounded list functions: `breverse`, `bsort`, `bfoldrM`, `bfoldlM`, and `bmapM`.- Contributed by Joel Burget.-- * Add two new puzzle examples:- * `Documentation.SBV.Examples.Puzzles.LadyAndTigers`- * `Documentation.SBV.Examples.Puzzles.Garden`--### Version 7.12, 2018-09-23-- * Modifications to make SBV compile with GHC 8.6.1. (SBV should- now compile fine with all versions of GHC since 8.0.1; and- possibly earlier. Please report if you are using a version- in this range and have issues.)-- * Improve the BoundedMutex example to show a non-fair trace.- See `Documentation/SBV/Examples/Lists/BoundedMutex.hs`.-- * Improve Haddock documentation links throughout.--### Version 7.11, 2018-09-20-- * Add support for symbolic lists. (That is, arbitrary but fixed length symbolic- lists of integers, floats, reals, etc. Nested lists are allowed as well.)- This is building on top of Joel Burget's initial work for supporting symbolic- strings and sequences, as supported by Z3. Note that the list theory solvers- are incomplete, so some queries might receive an unknown answer. See- `Documentation/SBV/Examples/Lists/Fibonacci.hs` for an example, and the- module `Data.SBV.List` for details.-- * A new module `Data.SBV.List.Bounded` provides extra functions to manipulate- lists with given concrete bounds. Note that SMT solvers cannot deal with- recursive functions/inductive proofs in general, so the utilities in this- file can come in handy when expressing bounded-model-checking style- algorithms. See `Documentation/SBV/Examples/Lists/BoundedMutex.hs` for a- simple mutex algorithm proof.-- * Remove dependency on data-binary-ieee754 package; which is no longer- supported.--### Version 7.10, 2018-07-20- * [BACKWARDS COMPATIBILITY] '==' and '/=' now always throw an error instead of- only throwing an error for non-concrete values.- http://github.com/LeventErkok/sbv/issues/301-- * [BACKWARDS COMPATIBILITY] Array declarations are reworked to take- an initial value. The call 'newArray' now accepts an optional default- value, which itself can be symbolic. If provided, the array will return- the given value for all reads from uninitialized locations. If not given,- then reads from unwritten locations produce uninterpreted constants. The- behavior of 'SFunArray' and 'SArray' is exactly the same in this regard.- Note that this is a backwards-compatibility breaking change, as you need- to pass a 'Nothing' argument to 'newArray' to get the old behavior.- (Solver note: If you use 'SFunArray', then defaults are fully supported- by SBV since these are internally handled, concrete or symbolic. If you- use 'SArray', which gets translated to SMTLib, then MathSAT and Z3 supports- default values with both concrete and symbolic cases, CVC4 only supports- if they are constants. Boolector and Yices don't support default values- at this point in time, and ABC doesn't support arrays at all.)-- * [BACKWARDS COMPATIBILITY] SMTException type has been renamed to- SBVException. SBV now throws this exception in more cases to aid in- building tools on top of SBV that might want to deal with exceptions- in different ways. (Previously, we used to call 'error' instead.)-- * [BACKWARDS COMPATIBILITY] Rename 'assertSoft' to 'assertWithPenalty', which- better reflects the nature of this function. Also add extra checks to warn- the user if optimization constraints are present in a regular sat/prove call.-- * Implement `softConstrain`: Similar to 'constrain', except the solver is- free to leave it unsatisfied (i.e., leave it false) if necessary to- find a satisfying solution. Useful in modeling conditions that are- "nice-to-have" but not "required." Note that this is similar to- 'assertWithPenalty', except it works in non-optimization contexts.- See `Documentation.SBV.Examples.Misc.SoftConstrain` for a simple example.-- * Add 'CheckedArithmetic' class, which provides bit-vector arithmetic- operations that do automatic underflow/overflow checking. The operations- follow their regular counter-parts, with an exclamation mark added at- the end: +!, -!, *!, /!. There is also negateChecked, for the same- function on unary negation. If you program using these functions,- then you can call 'safe' on the resulting programs to make sure- these operations never cause underflow and overflow conditions.-- * Similar to above, add 'sFromIntegralChecked', providing overflow/underflow- checks for cast operations.-- * Add `Documentation.SBV.Examples.BitPrecise.BrokenSearch` module to show the- use of overflow checking utilities, using the classic broken binary search- example from http://ai.googleblog.com/2006/06/extra-extra-read-all-about-it-nearly.html-- * Fix an issue where SBV was not sending array declarations to the SMT-solver- if there were no explicit constraints. Thanks to Oliver Charles for reporting.-- * Rework 'SFunArray' implementation, addressing performance issues. We now- carefully memoize elements as we do the look-ups. This addresses several- performance issues that came up; hopefully providing some relief. The- function 'mkSFunArray' is also removed, which used to lift Haskell- functions to such arrays, often used to implement initial values. Now,- if a read is done on an unwritten element of 'SFunArray' we get an- uninterpreted constant. This is inline with how 'SArray' works, and- is consistent. The old 'SFunArray' implementation based on functions- is no longer available, though it is easy to implement it in user-space- if needed. Please get in contact if this proves to be an issue.-- * Add 'freshArray' to allow for creation of existential fresh arrays in the query mode.- This is similar to 'newArray' which works in the Symbolic mode, and is analogous to- 'freshVar'. Most users shouldn't need this as 'newArray' calls should suffice. Only- use if you need a brand new array after switching to query mode.-- * SBV now rejects queries if universally quantified inputs are present. Previously- these were allowed to go through, but in general skolemization makes the corresponding- variables unusable in the query context. See http://github.com/LeventErkok/sbv/issues/407- for details. If you have an actual use case for such a feature, please get in- touch. Thanks to Brian Schroeder for reporting this anomaly.-- * Export 'addSValOptGoal' from 'Data.SBV.Internals', to help with 'Metric' class- instantiations. Requested by Dan Rosen.-- * Export 'registerKind' from 'Data.SBV.Internals', to help with custom array declarations.- Thanks to Brian Schroeder for the patch.-- * If an asynchronous exception is caught, SBV now throws it back without further processing.- (For instance, if the backend solver gets killed. Previously we were turning these into- synchronous errors.) Thanks to Oliver Charles for pointing out this corner case.--### Version 7.9, 2018-06-15-- * Add support for bit-vector arithmetic underflow/overflow detection. The new- 'ArithmeticOverflow' class captures conditions under which addition, subtraction,- multiplication, division, and negation can underflow/overflow for- both signed and unsigned bit-vector values. The implementation is based on- http://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/z3prefix.pdf,- and can be used to detect overflow caused bugs in machine arithmetic.- See `Data.SBV.Tools.Overflow` for details.-- * Add 'sFromIntegralO', which is the overflow/underflow detecting variant- of 'sFromIntegral'. This function returns (along with the converted- result), a pair of booleans showing whether the conversion underflowed- or overflowed.-- * Change the function 'getUnknownReason' to return a proper data-type- ('SMTReasonUnknown') as opposed to a mere string. This is at the- query level. Similarly, change `Unknown` result to return the same- data-type at the sat/prove level.-- * Interpolants: With Z3 4.8.0 release, Z3 folks have dropped support- for producing interpolants. If you need interpolants, you will have- to use the MathSAT backend now. Also, the MathSAT API is slightly- different from how Z3 supported interpolants as well, which means- your old code will need some modifications. See the example in- Documentation.SBV.Examples.Queries.Interpolants for the new usage.-- * Add 'constrainWithAttribute' call, which can be used to attach- arbitrary attribute to a constraint. Main use case is in interpolant- generation with MathSAT.-- * C code generation: SBV now spits out linker flag -lm if needed.- Thanks to Matt Peddie for reporting.-- * Code reorg: Simplify constant mapping table, by properly accounting- for negative-zero floats.-- * Export 'sexprToVal' for the class SMTValue, which allows for custom- definitions of value extractions. Thanks to Brian Schroeder for the- patch.-- * Export 'Logic' directly from Data.SBV. (Previously was from Control.)-- * Fix a long standing issue (ever since we introduced queries) where- 'sAssert' calls were run in the context of the final output boolean,- which is simply the wrong thing to do.--### Version 7.8, Released 2018-05-18-- * Fix printing of min-bounds for signed 32/64 bit numbers in C- code generation: These are tricky since C does not allow- -min_value as a valid literal! Instead we use the macros provided in- stdint.h. Thanks to Matt Peddie for reporting this corner case.-- * Fix translation of the `abs` function in C code generation, making- sure we use the correct variant. Thanks to Matt Peddie for reporting.-- * Fix handling of tables and arrays in pushed-contexts. Previously,- we used initializers to get table/array values stored properly.- However, this trick does not work if we are in a pushed-context;- since a pop can forget the corresponding assignments. SBV now- handles this corner case properly, by using tracker assertions- to keep track of what array values must be restored at each pop.- Thanks to Martin Brain on the SMTLib mailing list for the- suggestion. (See http://github.com/LeventErkok/sbv/issues/374- for details.)-- * Fix corner case in ite branch equality with float/double arguments,- where we were previously confusing +/-0 as equal to each other.- Thanks to Matt Peddie for reporting.-- * Add a call 'cgOverwriteFiles', which suppresses code-generation- prompts for overwriting files and quiets the prompts during- code generation. Thanks to Matt Peddie for the suggestion.-- * Add support for uninterpreted function introductions in the query- mode. Previously, this was only allowed before the query started,- now we fully support uninterpreted functions in all modes.-- * New example: Documentation/SBV/Examples/Puzzles/HexPuzzle.hs,- showing how to code cover properties using SBV, using a form- of bounded model checking.--### Version 7.7, Released 2018-04-29-- * Add support for Symbolic characters ('SChar') and strings ('SString'.)- Thanks to Joel Burget for the initial implementation.-- The 'SChar' type currently corresponds to the Latin-1 character- set, and is thus a subset of the Haskell 'Char' type. This is- due to the current limitations in SMT-solvers. However, there- is a pending SMTLib proposal to support unicode, and SBV will track- these changes to have full unicode support: For further details- see: http://smtlib.cs.uiowa.edu/theories-UnicodeStrings.shtml-- The 'SString' type is the type of symbolic strings, consisting- of characters from the Latin-1 character set currently, just- like the planned 'SChar' improvements. Note that an 'SString'- is *not* simply a list of 'SChar' values: It is a symbolic- type of its own and is processed as a single item. Conversions- from list of characters is possible (via the 'implode' function).- In the other direction, one cannot generally 'explode' a string,- since it may be of arbitrary length and thus we would not know- what concrete list to map it to. This is a bit unlike Haskell,- but the differences dissipate quickly in general, and the power- of being able to deal with a string as a symbolic entity on its- own opens up many verification possibilities.-- Note that currently only Z3 and CVC4 has support for this logic,- and they do differ in some details. Various character/string- operations are supported, including length, concatenation,- regular-expression matching, substrig operations, recognizers, etc.- If you use this logic, you are likely to find bugs in solvers themselves- as support is rather new: Please report.-- * If unsat-core extraction is enabled, SBV now returns the unsat-core- directly with in a solver result. Thanks to Ara Adkins for the- suggestion.-- * Add 'observe'. This function allows internal expressions to be- given values, which will be part of the satisfying model or- the counter-example upon model construction. Useful for tracking- expected/returned values. Also works with quickCheck.-- * Revamp Haddock documentation, hopefully easier to follow now.-- * Slightly modify the generated-C headers by removing whitespace.- This allows for certain "lint" rules to pass when SBV generated- code is used in conjunction with a larger code base. Thanks- to Greg Horn for the pull request.-- * Improve implementation of 'svExp' to match that of '.^', making- it more defined when the exponent is constant. Thanks to Brian- Huffman for the patch.-- * Export the underlying polynomial representation for algorithmic- reals from the Internals module for further user processing.- Thanks to Jan Path for the patch.--### Version 7.6, Released 2018-03-18-- * GHC 8.4.1 compatibility: Work around compilation issues. SBV- now compiles cleanly with GHC 8.4.1.-- * Define and export sWordN, sWordN_, sIntN_, from the Dynamic- interface, which simplifies creation of variables of arbitrary- bit sizes. These are similar to sWord8, sInt8, etc.; except- they create dynamic counterparts that can be of arbitrary bit size.--### Version 7.5, Released 2018-01-13-- * Remove obsolete references to tactics in a few haddock comments. Thanks- to Matthew Pickering for reporting.-- * Added logic Logic_NONE, to be used in cases where SBV should not- try to set the logic. This is useful when there is no viable value to- set, and the back-end solver doesn't understand the SMT-Lib convention- of using "ALL" as the logic name. (One example of this is the Yices- solver.)-- * SBV now returns SMTException (instead of just calling error) in case- the backend solver responds with error message. The type SMTException- can be caught by the user programs, and it includes many fields as an- indication of what went wrong. (The command sent, what was expected,- what was seen, etc.) Note that if this exception is ever caught, the- backend solver is no longer alive: You should either just throw it,- or perform proper clean-up on your user code as required to set up- a new context. The provided show instance formats the exception nicely- for display purposes. See http://github.com/LeventErkok/sbv/issues/335- for details and thanks to Brian Huffman for reporting.-- * SIntegral class now has Integral as a super-class, which ensures the- base-type it's used at is Integral. This was already true for all instances,- so we are just making it more explicit.-- * Improve the implementation of .^ (exponentiation) to cover more cases,- in particular signed exponents are now OK so long as they are concrete- and positive, following Haskell convention.-- * Removed the 'FromBits' class. Its functionality is now merged with the- new 'SFiniteBits' class, see below.-- * Introduce 'SFiniteBits' class, which only incorporates finite-words in it,- i.e., SWord/SInt for 8-16-32-64. In particular it leaves out SInteger,- SFloat, SDouble, and SReal. Important in recognizing bit-vectors of- finite size, essentially. Here are the methods:-- class (SymWord a, Num a, Bits a) => SFiniteBits a where- sFiniteBitSize :: SBV a -> Int -- ^ Bit size- lsb :: SBV a -> SBool -- ^ Least significant bit of a word, always stored at index 0.- msb :: SBV a -> SBool -- ^ Most significant bit of a word, always stored at the last position.- blastBE :: SBV a -> [SBool] -- ^ Big-endian blasting of a word into its bits. Also see the 'FromBits' class.- blastLE :: SBV a -> [SBool] -- ^ Little-endian blasting of a word into its bits. Also see the 'FromBits' class.- fromBitsBE :: [SBool] -> SBV a -- ^ Reconstruct from given bits, given in little-endian- fromBitsLE :: [SBool] -> SBV a -- ^ Reconstruct from given bits, given in little-endian- sTestBit :: SBV a -> Int -> SBool -- ^ Replacement for 'testBit', returning 'SBool' instead of 'Bool'- sExtractBits :: SBV a -> [Int] -> [SBool] -- ^ Variant of 'sTestBit', where we want to extract multiple bit positions.- sPopCount :: SBV a -> SWord8 -- ^ Variant of 'popCount', returning a symbolic value.- setBitTo :: SBV a -> Int -> SBool -> SBV a -- ^ A combo of 'setBit' and 'clearBit', when the bit to be set is symbolic.- fullAdder :: SBV a -> SBV a -> (SBool, SBV a) -- ^ Full adder, returns carry-out from the addition. Only for unsigned quantities.- fullMultiplier :: SBV a -> SBV a -> (SBV a, SBV a) -- ^ Full multiplier, returns both high and low-order bits. Only for unsigned quantities.- sCountLeadingZeros :: SBV a -> SWord8 -- ^ Count leading zeros in a word, big-endian interpretation- sCountTrailingZeros :: SBV a -> SWord8 -- ^ Count trailing zeros in a word, big-endian interpretation-- Note that the functions 'sFiniteBitSize', 'sCountLeadingZeros', and 'sCountTrailingZeros' are- new. Others have existed in SBV before, we are just grouping them together now in this new class.-- * Tightened certain signatures where SBV was too liberal, using the SFiniteBits class. New signatures are:-- sSignedShiftArithRight :: (SFiniteBits a, SIntegral b) => SBV a -> SBV b -> SBV a- crc :: (SFiniteBits a, SFiniteBits b) => Int -> SBV a -> SBV b -> SBV b- readSTree :: (SFiniteBits i, SymWord e) => STree i e -> SBV i -> SBV e- writeSTree :: (SFiniteBits i, SymWord e) => STree i e -> SBV i -> SBV e -> STree i e-- Thanks to Thomas DuBuisson for reporting.--### Version 7.4, 2017-11-03-- * Export queryDebug from the Control module, allowing custom queries to print- debugging messages with the verbose flag is set.-- * Relax value-parsing to allow for non-standard output from solvers. For- instance, MathSAT/Yices prints reals as integers when they do not have a- fraction. We now support such cases, relaxing the standard slightly. Thanks- to Geoffrey Ramseyer for reporting.-- * Fix optimization routines when applied to signed-bitvector goals. Thanks- to Anders Kaseorg for reporting. Since SMT-Lib does not distinguish between- signed and unsigned bit-vectors, we have to be careful when expressing goals- that are over signed values. See http://github.com/LeventErkok/sbv/issues/333- for details.--### Version 7.3, 2017-09-06-- * Query mode: Add support for arrays in query mode. Thanks to Brad Hardy for- providing the use-case and debugging help.-- * Query mode: Add support for tables. (As used by 'select' calls.)--### Version 7.2, 2017-08-29-- * Reworked implementation of shifts and rotates: When a signed quantity was- being shifted right by more than its size, SBV used to return 0. Robert Dockins pointed- out that the correct answer is actually -1 in such cases. The new implementation- merges the dynamic and typed interfaces, and drops support for non-constant shifts- of unbounded integers, which is not supported by SMTLib. Thanks to Robert for- reporting the issue and identifying the root cause.-- * Rework how quantifiers are handled: We now generate separate asserts for- prefix-existentials. This allows for better (smaller) quantified code, while- preserving semantics.-- * Rework the interaction between quantifiers and optimization routines.- Optimization routines now properly handle quantified formulas, so long as the- quantified metric does not involve any universal quantification itself. Thanks- to Matthew Danish for reporting the issue.-- * Development/Infrastructure: Lots of work around the continuous integration- for SBV. We now build/test on Linux/Mac/Windows on every commit. Thanks to- Travis/Appveyor for providing free remote infrastructure. There are still- gotchas and some reductions in tests due to host capacity issues. If you- would like to be involved and improve the test suite, please get in touch!--### Version 7.1, 2017-07-29-- * Add support for 'getInterpolant' in Query mode.-- * Support for SMT-results that can contain multi-line strings, which- is rare but it does happen. Previously SBV incorrectly interpreted such- responses to be erroneous.-- * Many improvements to build infrastructure and code clean-up.-- * Fix a bug in the implementation of `svSetBit`. Thanks to Robert Dockins- for the report.--### Version 7.0, 2017-07-19-- * NB. SBV now requires GHC >= 8.0.1 to compile. If you are stuck with an older- version of GHC, please get in contact.-- * This is a major rewrite of the internals of SBV, and is a backwards compatibility- breaking release. While we kept the top-level and most commonly used APIs the- same (both types and semantics), much of the internals and advanced features- have been rewritten to move SBV to a new model of execution: SBV no longer- runs your program symbolically and calls the SMT solver afterwards. Instead,- the interaction with the solver happens interleaved with the actual program execution.- The motivation is to allow the end-users to send/receive arbitrary SMTLib- commands to the solver, instead of the cooked-up recipes. SBV still provides- all the recipes for its existing functionality, but users can now interact- with the solver directly. See the module `Data.SBV.Control` for the main- API, together with the new functions 'runSMT' and 'runSMTWith'.-- * The 'Tactic' based solver control (introduced in v6.0) is completely removed, and- is replaced by the above described mechanism which gives the user a lot of- flexibility instead. Use queries for anything that required a tactic before.-- * The call 'allSat' has been reworked so it performs only one call to the underlying- solver and repeatedly issues check-sat to get new assignments. This differs from the- previous implementation where we spun off a new call to the executable for each- successive model. While this is more efficient and much more preferable, it also- means that the results are no longer lazily computed: If there is an infinite number- of solutions (or a very large number), you can no longer merely do a 'take' on the result.- While this is inconvenient, it fits better with our new methodology of query based- interaction. Note that the old behavior can be modeled, if required, by the user; by explicitly- interleaving the calls to 'sat.' Furthermore, we now provide a new configuration- parameter named 'allSatMaxModelCount' which can be used to limit the number models we- seek. The default is to get all models, however long that might take.-- * The Bridge modules (`Data.SBV.Bridge.Yices`, `Data.SBV.Bridge.Z3`) etc. are- all removed. The bridge functionality was hardly used, where different solvers- were much easier to access using the `with` functions. (Such as `proveWith`,- `satWith` etc.) This should result in no loss of functionality, except for- occasional explicit mention of solvers in your code, if you were using- bridge modules to start with.-- * Optimization routines have been changed to take a priority as an argument, (i.e.,- Lexicographic, Independent, etc.). The old method of supplying the priority- via tactics is no longer supported.-- * Pareto-front extraction has been reworked, reflecting the changes in Z3 for- this functionality. Since pareto-fronts can be infinite in number, the user- is now allowed to specify a "limit" to stop the solver from querying ad- infinitum. If the limit is not specified, then sbv will query till it- exhausts all the pareto-fronts, or till it runs out of memory in case there- is an infinite number of them.-- * Extraction of unsat-cores has changed. To use this feature, we now use- custom queries. See `Data.SBV.Examples.Misc.UnsatCore` for an example.- Old style of unsat-core extraction is no longer supported.-- * The 'timing' option of SMTConfig has been reworked. Since we now start the- solver immediately, it is no longer sensible to distinguish between "SBV" time,- "translation" time etc. Instead, we print one simple "Elapsed" time if requested.- If you need a detailed timing analysis, use the new 'transcript' option to- SMTConfig: It will produce a file with precise timing intervals for each- command issued to help you figure out how long each step took.-- * The following functions have been reworked, so they now also return- the time-elapsed for each solver:-- satWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, NominalDiffTime, SatResult)]- satWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, NominalDiffTime, SatResult)- proveWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, NominalDiffTime, ThmResult)]- proveWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, NominalDiffTime, ThmResult)-- * Changed the way `satWithAny` and `proveWithAny` works. Previously, these- two functions ran multiple solvers, and took the result of the first- one to finish, killing all the others. In addition, they *waited* for- the still-running solvers to finish cleaning-up, as sending a 'ThreadKilled'- is usually not instantaneous. Furthermore, a solver might simply take- its time! We now send the interrupt but do not wait for the process to- actually terminate. In rare occasions this could create zombie processes- if you use a solver that is not cooperating, but we have seen not insignificant- speed-ups for regular usage due to ThreadKilled wait times being rather long.-- * Configuration option `useLogic` is removed. If required, this should- be done by a call to the new 'setLogic' function:-- setLogic QF_NRA-- * Configuration option `timeOut` is removed. This was rarely used, and the solver- support was rather sketchy. We now have a better mechanism in the query mode- for timeouts, where it really matters. Please get in touch if you relied on- this old mechanism. Correspondingly, the functions `isTheorem`, `isSatisfiable`,- `isTheoremWith` and `isSatisfiableWith` had their time-out arguments removed- and return types simplified.-- * The function 'isSatisfiableInCurrentPath' is removed. Proper queries should be used- for what this function tentatively attempted to provide. Please get in touch- if you relied on this function and want to restructure your code to use proper queries.-- * Configuration option 'smtFile' is removed. Instead use 'transcript' now, which- provides a much more detailed output that is directly loadable to a solver- and has an accurate account of precisely what SBV sent.-- * Enumerations are now much easier to use symbolically, with the addition- of the template-haskell splice mkSymbolicEnumeration. See `Data/SBV/Examples/Misc/Enumerate.hs`- for an example.-- * Thanks to Kanishka Azimi, our external test suite is now run by- Tasty! Kanishka modernized the test suite, and reworked the- infrastructure that was showing its age. Thanks!-- * The function pConstrain and the Data.SBV.Tools.ExpectedValue are- removed. Probabilistic constraints were rarely used, and if- necessary can be implemented outside of SBV. If you were using- this feature, please get in contact.-- * SArray and SFunArray has been reworked, and they no longer take- and initial value. Similarly resetArray has been removed, as it- did not really do what it advertised. If an initial value is needed,- it is best to code this explicitly in your model.--### Version 6.1, 2017-05-26-- * Add support for unsat-core extraction. To use this feature, use- the `namedConstraint` function:-- namedConstraint :: String -> SBool -> Symbolic ()-- to associate a label to a constrain or a boolean term that- can later be labeled by the backend solver as belonging to the- unsat-core.-- Unsat-cores are not enabled by default since they can be- expensive; to use:-- satWith z3{getUnsatCore=True} $ do ...-- In the programmatic API, the function:-- extractUnsatCore :: Modelable a => a -> Maybe [String]-- can be used to programmatically extract the unsat-core. Note that- backend solvers will only include the named expressions in the unsat-core,- i.e., any unnamed yet part-of-the-core-unsat expressions will be missing;- as speculated in the SMT-Lib document itself.-- Currently, Z3, MathSAT, and CVC4 backends support unsat-cores.-- (Thanks to Rohit Ramesh for the suggestion leading to this feature.)-- * Added function `distinct`, which returns true if all the elements of the- given list are different. This function replaces the old `allDifferent`- function, which is now removed. The difference is that `distinct` will produce- much better code for SMT-Lib. If you used `allDifferent` before, simply- replacing it with `distinct` should work.-- * Add support for pseudo-boolean operations:-- pbAtMost :: [SBool] -> Int -> SBool- pbAtLeast :: [SBool] -> Int -> SBool- pbExactly :: [SBool] -> Int -> SBool- pbLe :: [(Int, SBool)] -> Int -> SBool- pbGe :: [(Int, SBool)] -> Int -> SBool- pbEq :: [(Int, SBool)] -> Int -> SBool- pbMutexed :: [SBool] -> SBool- pbStronglyMutexed :: [SBool] -> SBool-- These functions, while can be directly coded in SBV, produce better- translations to SMTLib for more efficient solving of cardinality constraints.- Currently, only Z3 supports pseudo-booleans directly. For all other solvers,- SBV will translate these to equivalent terms that do not require special- functions.-- * The function getModel has been renamed to getAssignment. (The former name is- now available as a query command.)-- * Export `SolverCapabilities` from `Data.SBV.Internals`, in case users want access.-- * Move code-generation facilities to `Data.SBV.Tools.CodeGen`, no longer exporting- the relevant functions directly from `Data.SBV`. This could break existing code,- but the fix should be as simple as `import Data.SBV.Tools.CodeGen`.-- * Move the following two functions to `Data.SBV.Internals`:-- compileToSMTLib- generateSMTBenchmarks-- If you use them, please `import Data.SBV.Internals`.-- * Reorganized `EqSymbolic` and `EqOrd` classes to collect some of the- similarly named function together. Users should see no impact due to this change.---### Version 6.0, 2017-05-07-- * This is a backwards compatibility breaking release, hence the major version- bump from 5.15 to 6.0:-- - Most of existing code should work with no changes.- - Old code relying on some features might require extra imports,- since we no longer export some functionality directly from `Data.SBV`.- This was done in order to reduce the number of exported items to- avoid extra clutter.- - Old optimization features are removed, as the new and much improved- capabilities should be used instead.-- * The next two bullets cover new features in SBV regarding optimization, based- on the capabilities of the z3 SMT solver. With this release SBV gains the- capability optimize objectives, and solve MaxSAT problems; by appropriately- employing the corresponding capabilities in z3. A good review of these features- as implemented by Z3, and thus what is available in SBV is given in this- paper: http://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/nbjorner-scss2014.pdf-- * SBV now allows for real or integral valued metrics. Goals can be lexicographically- (default), independently, or pareto-front optimized. Currently, only the z3 backend- supports optimization routines.-- Optimization can be done over bit-vector, real, and integer goals. The relevant- functions are:-- - `minimize`: Minimize a given arithmetic goal- - `maximize`: Minimize a given arithmetic goal-- For instance, a call of the form-- minimize "name-of-goal" $ x + 2*y-- Minimizes the arithmetic goal x+2*y, where x and y can be bit-vectors, reals,- or integers. Such goals will be lexicographically optimized, i.e., in the order- given. If there are multiple goals, then user can also ask for independent- optimization results, or pareto-fronts.-- Once the objectives are given, a top level call to `optimize` (similar to `prove`- and `sat`) performs the optimization.-- * SBV now implements soft-asserts. A soft assertion is a hint to the SMT solver that- we would like a particular condition to hold if *possible*. That is, if there is- a solution satisfying it, then we would like it to hold. However, if the set of- constraints is unsatisfiable, then a soft-assertion can be violated by incurring- a user-given numeric penalty to satisfy the remaining constraints. The solver then- tries to minimize the penalty, i.e., satisfy as many of the soft-asserts as possible- such that the total penalty for those that are not satisfied is minimized.-- Note that `assertSoft` works well with optimization goals (minimize/maximize etc.),- and are most useful when we are optimizing a metric and thus some of the constraints- can be relaxed with a penalty to obtain a good solution.-- * SBV no longer provides the old optimization routines, based on iterative and quantifier- based methods. Those methods were rarely used, and are now superseded by the above- mechanism. If the old code is needed, please contact for help: They can be resurrected- in your own code if absolutely necessary.-- * (NB. This feature is deprecated in 7.0, see above for its replacement.)- SBV now implements tactics, which allow the user to navigate the proof process.- This is an advanced feature that most users will have no need of, but can become- handy when dealing with complicated problems. Users can, for instance, implement- case-splitting in a proof to guide the underlying solver through. Here is the list- of tactics implemented:-- - `CaseSplit` : Case-split, with implicit coverage. Bool says whether we should be verbose.- - `CheckCaseVacuity` : Should the case-splits be checked for vacuity? (Default: True.)- - `ParallelCase` : Run case-splits in parallel. (Default: Sequential.)- - `CheckConstrVacuity`: Should constraints be checked for vacuity? (Default: False.)- - `StopAfter` : Time-out given to solver, in seconds.- - `CheckUsing` : Invoke with check-sat-using command, instead of check-sat- - `UseLogic` : Use this logic, a custom one can be specified too- - `UseSolver` : Use this solver (z3, yices, etc.)- - `OptimizePriority` : Specify priority for optimization: Lexicographic (default), Independent, or Pareto.-- * Name-space clean-up. The following modules are no longer automatically exported- from Data.SBV:-- - `Data.SBV.Tools.ExpectedValue` (computing with expected values)- - `Data.SBV.Tools.GenTest` (test case generation)- - `Data.SBV.Tools.Polynomial` (polynomial arithmetic, CRCs etc.)- - `Data.SBV.Tools.STree` (full symbolic binary trees)-- To use the functionality of these modules, users must now explicitly import the corresponding- module. Not other changes should be needed other than the explicit import.-- * Changed the signatures of:-- isSatisfiableInCurrentPath :: SBool -> Symbolic Bool- svIsSatisfiableInCurrentPath :: SVal -> Symbolic Bool-- to:-- isSatisfiableInCurrentPath :: SBool -> Symbolic (Maybe SatResult)- svIsSatisfiableInCurrentPath :: SVal -> Symbolic (Maybe SatResult)-- which returns the result in case of SAT. This is more useful than before. This is- backwards-compatibility breaking, but is more useful. (Requested by Jared Ziegler.)-- * Add instance `Provable (Symbolic ())`, which simply stands for returning true- for proof/sat purposes. This allows for simpler coding, as constrain/minimize/maximize- calls (which return unit) can now be directly sat/prove processed, without needing- a final call to return at the end.-- * Add type synonym `Goal` (for `Symbolic ()`), in order to simplify type signatures-- * SBV now properly adds check-sat commands and other directives in debugging output.-- * New examples:- - Data.SBV.Examples.Optimization.LinearOpt: Simple linear-optimization example.- - Data.SBV.Examples.Optimization.Production: Scheduling machines in a shop- - Data.SBV.Examples.Optimization.VM: Scheduling virtual-machines in a data-center--### Version 5.15, 2017-01-30-- * Bump up dependency on CrackNum >= 1.9, to get access to hexadecimal floats.- * Improve time/tracking-print code. Thanks to Iavor Diatchki for the patch.--### Version 5.14, 2017-01-12-- * Bump up QuickCheck dependency to >= 2.9.2 to avoid the following quick-check- bug <http://github.com/nick8325/quickcheck/issues/113>, which transitively impacted- the quick-check as implemented by SBV.-- * Generalize casts between integral-floats, using the rounding mode round-nearest-ties-to-even.- Previously calls to sFromIntegral did not support conversion to floats since it needed- a rounding mode. But it does make sense to support them with the default mode. If a different- mode is needed, use the function 'toSFloat' as before, which takes an explicit rounding mode.--### Version 5.13, 2016-10-29-- * Fix broken links, thanks to Stephan Renatus for the patch.-- * Code generation: Create directory path if it does not exist. Thanks to Robert Dockins- for the patch.-- * Generalize the type of sFromIntegral, dropping the Bits requirement. In turn, this- allowed us to remove sIntegerToSReal, since sFromIntegral can be used instead.-- * Add support for sRealToSInteger. (Essentially the floor function for SReal.)-- * Several space-leaks fixed for better performance. Patch contributed by Robert Dockins.-- * Improved Random instance for Rational. Thanks to Joe Leslie-Hurd for the idea.--### Version 5.12, 2016-06-06-- * Fix GHC8.0 compilation issues, and warning clean-up. Thanks to Adam Foltzer for the bulk- of the work and Tom Sydney Kerckhove for the initial patch for 8.0 compatibility.-- * Minor fix to printing models with floats when the base is 2/16, making sure the alignment- is done properly accommodating for the crackNum output.-- * Wait for external process to die on exception, to avoid spawning zombies. Thanks to- Daniel Wagner for the patch.-- * Fix hash-consed arrays: Previously we were caching based only on elements, which is not- sufficient as you can have conflicts differing only on the address type, but same contents.- Thanks to Brian Huffman for reporting and the corresponding patch.--### Version 5.11, 2016-01-15-- * Fix documentation issue; no functional changes--### Version 5.10, 2016-01-14-- * Documentation: Fix a bunch of dead http links. Thanks to Andres Sicard-Ramirez- for reporting.-- * Additions to the Dynamic API:-- * svSetBit : set a given bit- * svBlastLE, svBlastBE : Bit-blast to big/little endian- * svWordFromLE, svWordFromBE: Unblast from big/little endian- * svAddConstant : Add a constant to an SVal- * svIncrement, svDecrement : Add/subtract 1 from an SVal--### Version 5.9, 2016-01-05-- * Default definition for 'symbolicMerge', which allows types that are- instances of 'Generic' to have an automatically derivable merge (i.e.,- ite) instance. Thanks to Christian Conkle for the patch.-- * Add support for "non-model-vars," where we can now tell SBV not- to take into account certain variables from a model-building- perspective. This comes handy in doing an `allSat` calls where- there might be witness variables that we do not care the uniqueness- for. See `Data/SBV/Examples/Misc/Auxiliary.hs` for an example, and- the discussion in http://github.com/LeventErkok/sbv/issues/208 for- motivation.-- * Yices interface: If Reals are used, then pick the logic QF_UFLRA, instead- of QF_AUFLIA. Unfortunately, logic selection remains tricky since the SMTLib- story for logic selection is rather messy. Other solvers are not impacted- by this change.--### Version 5.8, 2016-01-01-- * Fix some typos- * Add 'svEnumFromThenTo' to the Dynamic interface, allowing dynamic construction- of [x, y .. z] and [x .. y] when the involved values are concrete.- * Add 'svExp' to the Dynamic interface, implementing exponentiation--### Version 5.7, 2015-12-21-- * Export `HasKind(..)` from the Dynamic interface. Thanks to Adam Foltzer for the patch.- * More careful handling of SMT-Lib reserved names.- * Update tested version of MathSAT to 5.3.9- * Generalize `sShiftLeft`/`sShiftRight`/`sRotateLeft`/`sRotateRight` to work with signed- shift/rotate amounts, where negative values revert the direction. Similar- generalizations are also done for the dynamic variants.--### Version 5.6, 2015-12-06-- * Minor changes to how we print models:- * Align by the type- * Always print the type (previously we were skipping for Bool)-- * Rework how SBV properties are quick-checked; much more usable and robust-- * Provide a function `sbvQuickCheck`, which is essentially the same as- quickCheck, except it also returns a boolean. Useful for the- programmable API. (The dynamic version is called `svQuickCheck`.)-- * Several changes/additions in support of the sbvPlugin development:- * Data.SBV.Dynamic: Define/export `svFloat`/`svDouble`/`sReal`/`sNumerator`/`sDenominator`- * Data.SBV.Internals: Export constructors of `Result`, `SMTModel`,- and the function `showModel`- * Simplify how Uninterpreted-types are internally represented.--### Version 5.5, 2015-11-10-- * This is essentially the same release as 5.4 below, except to allow SBV compile- with GHC 7.8 series. Thanks to Adam Foltzer for the patch.--### Version 5.4, 2015-11-09-- * Add 'sAssert', which allows users to pepper their code with boolean conditions, much like- the usual ASSERT calls. Note that the semantics of an 'sAssert' is that it is a NOOP, i.e.,- it simply returns its final argument. Use in coordination with 'safe' and 'safeWith', see below.-- * Implement 'safe' and 'safeWith', which statically determine all calls to 'sAssert'- being safe to execute. Any violations will be flagged.-- * SBV->C: Translate 'sAssert' calls to dynamic checks in the generated C code. If this is- not desired, use the 'cgIgnoreSAssert' function to turn it off.-- * Add 'isSafe': Which converts a 'SafeResult' to a 'Bool', when we are only interested- in a boolean result.-- * Add Data/SBV/Examples/Misc/NoDiv0 to demonstrate the use of the 'safe' function.--### Version 5.3, 2015-10-20-- * Main point of this release to make SBV compile with GHC 7.8 again, to accommodate mainly- for Cryptol. As Cryptol moves to GHC >= 7.10, we intend to remove the "compatibility" changes- again. Thanks to Adam Foltzer for the patch.-- * Minor mods to how bitvector equality/inequality are translated to SMTLib. No user visible- impact.--### Version 5.2, 2015-10-12-- * Regression on 5.1: Fix a minor bug in base 2/16 printing where uninterpreted constants were- not handled correctly.--### Version 5.1, 2015-10-10-- * fpMin, fpMax: If these functions receive +0/-0 as their two arguments, i.e., both- zeros but alternating signs in any order, then SMTLib requires the output to be- nondeterministically chosen. Previously, we fixed this result as +0 following the- interpretation in Z3, but Z3 recently changed and now incorporates the nondeterministic- output. SBV similarly changed to allow for non-determinism here.-- * Change the types of the following Floating-point operations:-- * sFloatAsSWord32, sFloatAsSWord32, blastSFloat, blastSDouble-- These were previously coded as relations, since NaN values were not representable- in the target domain uniquely. While it was OK, it was hard to use them. We now- simply implement these as functions, and they are underspecified if the inputs- are NaNs: In those cases, we simply get a symbolic output. The new types are:-- * sFloatAsSWord32 :: SFloat -> SWord32- * sDoubleAsSWord64 :: SDouble -> SWord64- * blastSFloat :: SFloat -> (SBool, [SBool], [SBool])- * blastSDouble :: SDouble -> (SBool, [SBool], [SBool])-- * MathSAT backend: Use the SMTLib interpretation of fp.min/fp.max by passing the- "-theory.fp.minmax_zero_mode=4" argument explicitly.-- * Fix a bug in hash-consing of floating-point constants, where we were confusing +0 and- -0 since we were using them as keys into the map though they compare equal. We now- explicitly keep track of the negative-zero status to make sure this confusion does- not arise. Note that this bug only exhibited itself in rare occurrences of both- constants being present in a benchmark; a true corner case. Note that @NaN@ values- are also interesting in this context: Since NaN /= NaN, we never hash-cons floating- point constants that have the value NaN. But that is actually OK; it is a bit wasteful- in case you have a lot of NaN constants around, but there is no soundness issue: We- just waste a little bit of space.-- * Remove the functions `allSatWithAny` and `allSatWithAll`. These two variants do *not*- make sense when run with multiple solvers, as they internally sequentialize the solutions- due to the nature of `allSat`. Not really needed anyhow; so removed. The variants- `satWithAny/All` and `proveWithAny/All` are still available.-- * Export SMTLibVersion from the library, forgotten export needed by Cryptol. Thanks to Adam- Foltzer for the patch.-- * Slightly modify model-outputs so the variables are aligned vertically. (Only matters- if we have model-variable names that are of differing length.)-- * Move to Travis-CI "docker" based infrastructure for builds-- * Enable local builds to use the Herbie plugin. Currently SBV does not have any- expressions that can benefit from Herbie, but it is nice to have this support in general.--### Version 5.0, 2015-09-22-- * Note: This is a backwards-compatibility breaking release, see below for details.-- * SBV now requires GHC 7.10.1 or newer to be compiled, taking advantage of newer features/bug-fixes- in GHC. If you really need SBV to compile with older GHCs, please get in touch.-- * SBV no longer supports SMTLib1. We now exclusively use SMTLib2 for communicating with backend- solvers. Strictly speaking, this means some loss in functionality: Uninterpreted-function models- that we supported via Yices-1 are no longer available. In practice this facility was not really- used, and required a very old version of Yices that was no longer supported by SRI and has- lacked in other features. So, in reality this change should hardly matter for end-users.-- * Added function `label`, which is useful in emitting comments around expressions. It is essentially- a no-op, but does generate a comment with the given text in the SMT-Lib and C output, for diagnostic- purposes.-- * Added `sFromIntegral`: Conversions from all integral types (SInteger, SWord/SInts) between- each other. Similar to the `fromIntegral` function of Haskell. These generate simple casts when- used in code-generation to C, and thus are very efficient.-- * SBV no longer supports the functions sBranch/sAssert, as we realized these functions can cause- soundness issues under certain conditions. While the triggering scenarios are not common use-cases- for these functions, we are opting for safety, and thus removing support. See- http://github.com/LeventErkok/sbv/issues/180 for details; and see below for the new function- 'isSatisfiableInCurrentPath'.-- * A new function 'isSatisfiableInCurrentPath' is added, which checks for satisfiability during a- symbolic simulation run. This function can be used as the basis of sBranch/sAssert like functionality- if needed. The difference is that this is a much lower level call, and also exposes the fact that- the result is in the 'Symbolic' monad (which avoids the soundness issue). Of course, the new type- makes it less useful as it will not be a drop-in replacement for if-then-else like structure. Intended- to be used by tools built on top of SBV, as opposed to end-users.-- * SBV no longer implements the 'SignCast' class, as its functionality is replaced by the 'sFromIntegral'- function. Programs using the functions 'signCast' and 'unsignCast' should simply replace both- with calls to 'sFromIntegral'. (Note that extra type-annotations might be necessary, similar to- the uses of the 'fromIntegral' function in Haskell.)-- * Backend solver related changes:-- * Yices: Upgraded to work with Yices release 2.4.1. Note that earlier versions of Yices- are *not* supported.-- * Boolector: Upgraded to work with new Boolector release 2.0.7. Note that earlier versions- of Boolector are *not* supported.-- * MathSAT: Upgraded to work with latest release 5.3.7. Note that earlier versions of MathSAT- are *not* supported (due to a buffering issue in MathSAT itself.)-- * MathSAT: Enabled floating-point support in MathSAT.-- * New examples:-- * Add Data.SBV.Examples.Puzzles.Birthday, which solves the Cheryl-Birthday problem that- went viral in April 2015. Turns out really easy to solve for SMT, but the formalization- of the problem is still interesting as an exercise in formal reasoning.-- * Add Data.SBV.Examples.Puzzles.SendMoreMoney, which solves the classic send + more = money- problem. Really a trivial example, but included since it is pretty much the hello-world for- basic constraint solving.-- * Add Data.SBV.Examples.Puzzles.Fish, which solves a typical logic puzzle; finding the unique- solution to a set of assertions made about a bunch of people, their pets, beverage choices,- etc. Not particularly interesting, but could be fun to play around with for modeling purposes.-- * Add Data.SBV.Examples.BitPrecise.MultMask, which demonstrates the use of the bitvector- solver to an interesting bit-shuffling problem.-- * Rework floating-point arithmetic, and add missing floating-point operations:-- * fpRem : remainder- * fpRoundToIntegral: truncating round- * fpMin : min- * fpMax : max- * fpIsEqualObject : FP equality as object (i.e., NaN equals NaN, +0 does not equal -0, etc.)-- This brings SBV up-to par with everything supported by the SMT-Lib FP theory.-- * Add the IEEEFloatConvertable class, which provides conversions to/from Floats and other types. (i.e.,- value conversions from all other types to Floats and Doubles; and back.)-- * Add SWord32/SWord64 to/from SFloat/SDouble conversions, as bit-pattern reinterpretation; using the- IEEE754 interchange format. The functions are: sWord32AsSFloat, sWord64AsSDouble, sFloatAsSWord32,- sDoubleAsSWord64. Note that the sWord32AsSFloat and sWord64ToSDouble are regular functions, but- sFloatToSWord32 and sDoubleToSWord64 are "relations", since NaN values are not uniquely convertible.-- * Add 'sExtractBits', which takes a list of indices to extract bits from, essentially- equivalent to 'map sTestBit'.-- * Rename a set of symbolic functions for consistency. Here are the old/new names:-- * sbvTestBit --> sTestBit- * sbvPopCount --> sPopCount- * sbvShiftLeft --> sShiftLeft- * sbvShiftRight --> sShiftRight- * sbvRotateLeft --> sRotateLeft- * sbvRotateRight --> sRotateRight- * sbvSignedShiftArithRight --> sSignedShiftArithRight-- * Rename all FP recognizers to be in sync with FP operations. Here are the old/new names:-- * isNormalFP --> fpIsNormal- * isSubnormalFP --> fpIsSubnormal- * isZeroFP --> fpIsZero- * isInfiniteFP --> fpIsInfinite- * isNaNFP --> fpIsNaN- * isNegativeFP --> fpIsNegative- * isPositiveFP --> fpIsPositive- * isNegativeZeroFP --> fpIsNegativeZero- * isPositiveZeroFP --> fpIsPositiveZero- * isPointFP --> fpIsPoint-- * Lots of other work around floating-point, test cases, reorg, etc.-- * Introduce shorter variants for rounding modes: sRNE, sRNA, sRTP, sRTN, sRTZ;- aliases for sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive,- sRoundTowardNegative, and sRoundTowardZero; respectively.--### Version 4.4, 2015-04-13-- * Hook-up crackNum package; so counter-examples involving floats and- doubles can be printed in detail when the printBase is chosen to be- 2 or 16. (With base 10, we still get the simple output.)-- ```- Prelude Data.SBV> satWith z3{printBase=2} $ \x -> x .== (2::SFloat)- Satisfiable. Model:- s0 = 2.0 :: Float- 3 2 1 0- 1 09876543 21098765432109876543210- S ---E8--- ----------F23----------- Binary: 0 10000000 00000000000000000000000- Hex: 4000 0000- Precision: SP- Sign: Positive- Exponent: 1 (Stored: 128, Bias: 127)- Value: +2.0 (NORMAL)- ```-- * Change how we print type info; for models instead of SType just print Type (i.e.,- for SWord8, instead print Word8) which makes more sense and is more consistent.- This change should be mostly relevant as how we see the counter-example output.-- * Fix long standing bug #75, where we now support arrays with Boolean source/targets.- This is not a very commonly used case, but by letting the solver pick the logic,- we now allow arrays to be uniformly supported.--### Version 4.3, 2015-04-10-- * Introduce Data.SBV.Dynamic, by Brian Huffman. This is mostly an internal- reorg of the SBV codebase, and end-users should not be impacted by the- changes. The introduction of the Dynamic SBV variant (i.e., one that does- not mandate a phantom type as in `SBV Word8` etc. allows library writers- more flexibility as they deal with arbitrary bit-vector sizes. The main- customer of these changes are the Cryptol language and the associated- toolset, but other developers building on top of SBV can find it useful- as well. NB: The "strongly-typed" aspect of SBV is still the main way- end-users should interact with SBV, and nothing changed in that respect!-- * Add symbolic variants of floating-point rounding-modes for convenience-- * Rename toSReal to sIntegerToSReal, which captures the intent more clearly-- * Code clean-up: remove mbMinBound/mbMaxBound thus allowing less calls to- unliteral. Contributed by Brian Huffman.-- * Introduce FP conversion functions:-- * Between SReal and SFloat/SDouble- * fpToSReal- * sRealToSFloat- * sRealToSDouble- * Between SWord32 and SFloat- * sWord32ToSFloat- * sFloatToSWord32- * Between SWord64 and SDouble. (Relational, due to non-unique NaNs)- * sWord64ToSDouble- * sDoubleToSWord64- * From float to sign/exponent/mantissa fields: (Relational, due to non-unique NaNs)- * blastSFloat- * blastSDouble-- * Rework floating point classifiers. Remove isSNaN and isFPPoint (both renamed),- and add the following new recognizers:-- * isNormalFP- * isSubnormalFP- * isZeroFP- * isInfiniteFP- * isNaNFP- * isNegativeFP- * isPositiveFP- * isNegativeZeroFP- * isPositiveZeroFP- * isPointFP (corresponds to a real number, i.e., neither NaN nor infinity)-- * Re-implement sbvTestBit, by Brian Huffman. This version is much faster at large- word sizes, as it avoids the costly mask generation.-- * Code changes to suppress warnings with GHC7.10. General clean-up.--### Version 4.2, 2015-03-17-- * Add exponentiation (.^). Thanks to Daniel Wagner for contributing the code!-- * Better handling of SBV_$SOLVER_OPTIONS, in particular keeping track of- proper quoting in environment variables. Thanks to Adam Foltzer for- the patch!-- * Silence some hlint/ghci warnings. Thanks to Trevor Elliott for the patch!-- * Haddock documentation fixes, improvements, etc.-- * Change ABC default option string to %blast; "&sweep -C 5000; &syn4; &cec -s -m -C 2000"- which seems to give good results. Use SBV_ABC_OPTIONS environment variable (or- via abc.rc file and a combination of SBV_ABC_OPTIONS) to experiment.--### Version 4.1, 2015-03-06-- * Add support for the ABC solver from Berkeley. Thanks to Adam Foltzer- for the required infrastructure! See: http://www.eecs.berkeley.edu/~alanmi/abc/- And Alan Mishchenko for adding infrastructure to ABC to work with SBV.-- * Upgrade the Boolector connection to use a SMT-Lib2 based interaction. NB. You- need at least Boolector 2.0.6 installed!-- * Tracking changes in the SMT-Lib floating-point theory. If you are- using symbolic floating-point types (i.e., SFloat and SDouble), then- you should upgrade to this version and also get a very latest (unstable)- Z3 release. See http://smtlib.cs.uiowa.edu/theories-FloatingPoint.shtml- for details.-- * Introduce a new class, 'RoundingFloat', which supports floating-point- operations with arbitrary rounding-modes. Note that Haskell only allows- RoundNearestTiesToAway, but with SBV, we get all 5 IEEE754 rounding-modes- and all the basic operations ('fpAdd', 'fpMul', 'fpDiv', etc.) with these- modes.-- * Allow Floating-Point RoundingMode to be symbolic as well-- * Improve the example `Data/SBV/Examples/Misc/Floating.hs` to include- rounding-mode based addition example.-- * Changes required to make SBV compile with GHC 7.10; mostly around instance- NFData declarations. Thanks to Iavor Diatchki for the patch.-- * Export a few extra symbols from the Internals module (mainly for- Cryptol usage.)--### Version 4.0, 2015-01-22--This release mainly contains contributions from Brian Huffman, allowing-end-users to define new symbolic types, such as Word4, that SBV does not-natively support. When GHC gets type-level literals, we shall most likely-incorporate arbitrary bit-sized vectors and ints using this mechanism,-but in the interim, this release provides a means for the users to introduce-individual instances.-- * Modifications to support arbitrary bit-sized vectors;- These changes have been contributed by Brian Huffman- of Galois. Thanks Brian.- * A new example `Data/SBV/Examples/Misc/Word4.hs` showing- how users can add new symbolic types.- * Support for rotate-left/rotate-right with variable- rotation amounts. (From Brian Huffman.)--### Version 3.5, 2015-01-15--This release is mainly adding support for enumerated types in Haskell being-translated to their symbolic counterparts; instead of going completely-uninterpreted.-- * Keep track of data-type details for uninterpreted sorts.- * Rework the U2Bridge example to use enumerated types.- * The "Uninterpreted" name no longer makes sense with this change, so- rework the relevant names to ensure proper internal naming.- * Add Data/SBV/Examples/Misc/Enumerate.hs as an example for demonstrating- how enumerations are translated.- * Fix a long-standing bug in the implementation of select when- translated as SMT-Lib tables. (Github issue #103.) Thanks to- Brian Huffman for reporting.--### Version 3.4, 2014-12-21-- * This release is mainly addressing floating-point changes in SMT-Lib.-- * Track changes in the QF_FPA logic standard; new constants and alike. If you are- using the floating-point logic, then you need a relatively new version of Z3- installed (4.3.3 or newer).-- * Add unary-negation as an explicit operator. Previously, we merely used the "0-x"- semantics; but with floating point, this does not hold as 0-0 is 0, and is not -0!- (Note that negative-zero is a valid floating point value, that is different than- positive-zero; yet it compares equal to it. Sigh..)-- * Similarly, add abs as a native method; to make sure we map it to fp.abs for- floating point values.-- * Test suite improvements--### Version 3.3, 2014-12-05-- * Implement 'safe' and 'safeWith', which statically determine all calls to 'sAssert'- being safe to execute. This way, users can pepper their programs with liberal- calls to 'sAssert' and check they are all safe in one go without further worry.-- * Robustify the interface to external solvers, by making sure we catch cases where- the external solver might exist but not be runnable (library dependency missing,- for example). It is impossible to be absolutely foolproof, but we now catch a- few more cases and fail gracefully.--### Version 3.2, 2014-11-18-- * Implement 'sAssert'. This adds conditional symbolic simulation, by ensuring arbitrary- boolean conditions hold during simulation; similar to ASSERT calls in other languages.- Note that failures will be detected at symbolic-simulation time, i.e., each assert will- generate a call to the external solver to ensure that the condition is never violated.- If violation is possible the user will get an error, indicating the failure conditions.-- * Also implement 'sAssertCont' which allows for a programmatic way to extract/display results- for consumers of 'sAssert'. While the latter simply calls 'error' in case of an assertion- violation, the 'sAssertCont' variant takes a continuation which can be used to program- how the results should be interpreted/displayed. (This is useful for libraries built on top of- SBV.) Note that the type of the continuation is such that execution should still stop, i.e.,- once an assertion violation is detected, symbolic simulation will never continue.-- * Rework/simplify the 'Mergeable' class to make sure 'sBranch' is sufficiently lazy- in case of structural merges. The original implementation was only- lazy at the Word instance, but not at lists/tuples etc. Thanks to Brian Huffman- for reporting this bug.-- * Add a few constant-folding optimizations for 'sDiv' and 'sRem'-- * Boolector: Modify output parser to conform to the new Boolector output format. This- means that you need at least v2.0.0 of Boolector installed if you want to use that- particular solver.-- * Fix long-standing translation bug regarding boolean Ord class comparisons. (i.e.,- 'False > True' etc.) While Haskell allows for this, SMT-Lib does not; and hence- we have to be careful in translating. Thanks to Brian Huffman for reporting.-- * C code generation: Correctly translate square-root and fusedMA functions to C.--### Version 3.1, 2014-07-12-- NB: GHC 7.8.1 and 7.8.2 has a serious bug <http://ghc.haskell.org/trac/ghc/ticket/9078>- that causes SBV to crash under heavy/repeated calls. The bug is addressed- in GHC 7.8.3; so upgrading to GHC 7.8.3 is essential for using SBV!-- New features/bug-fixes in v3.1:-- * Using multiple-SMT solvers in parallel:- * Added functions that let the user run multiple solvers, using asynchronous- threads. All results can be obtained (proveWithAll, proveWithAny, satWithAll),- or SBV can return the fastest result (satWithAny, allSatWithAll, allSatWithAny).- These functions are good for playing with multiple-solvers, especially on- machines with multiple-cores.- * Add function: sbvAvailableSolvers; which returns the list of solvers currently- available, as installed on the machine we are running. (Not the list that SBV- supports, but those that are actually available at run-time.) This function- is useful with the multi-solve API.- * Implement sBranch:- * sBranch is a variant of 'ite' that consults the external- SMT solver to see if a given branch condition is satisfiable- before evaluating it. This can make certain otherwise recursive- and thus not-symbolically-terminating inputs amenable to symbolic- simulation, if termination can be established this way. Needless- to say, this problem is always decidable as far as SBV programs- are concerned, but it does not mean the decision procedure is cheap!- Use with care.- * sBranchTimeOut config parameter can be used to curtail long runs when- sBranch is used. Of course, if time-out happens, SBV will- assume the branch is feasible, in which case symbolic-termination- may come back to bite you.)- * New API:- * Add predicate 'isSNaN' which allows testing 'SFloat'/'SDouble' values- for nan-ness. This is similar to the Prelude function 'isNaN', except- the Prelude version requires a RealFrac instance, which unfortunately is- not currently implementable for cases. (Requires trigonometric functions etc.)- Thus, we provide 'isSNaN' separately (along with the already existing- 'isFPPoint') to simplify reasoning with floating-point.- * Examples:- * Add Data/SBV/Examples/Misc/SBranch.hs, to illustrate the use of sBranch.- * Bug fixes:- * Fix pipe-blocking issue, which exhibited itself in the presence of- large numbers of variables (> 10K or so). See github issue #86. Thanks- to Philipp Meyer for the fine report.- * Misc:- * Add missing SFloat/SDouble instances for SatModel class- * Explicitly support KBool as a kind, separating it from `KUnbounded False 1`.- Thanks to Brian Huffman for contributing the changes. This should have no- user-visible impact, but comes in handy for internal reasons.--### Version 3.0, 2014-02-16-- * Support for floating-point numbers:- * Preliminary support for IEEE-floating point arithmetic, introducing- the types `SFloat` and `SDouble`. The support is still quite new,- and Z3 is the only solver that currently features a solver for- this logic. Likely to have bugs, both at the SBV level, and at the- Z3 level; so any bug reports are welcome!- * New backend solvers:- * SBV now supports MathSAT from Fondazione Bruno Kessler and- DISI-University of Trento. See: http://mathsat.fbk.eu/- * Support all-sat calls in the presence of uninterpreted sorts:- * Implement better support for `allSat` in the presence of uninterpreted- sorts. Previously, SBV simply rejected running `allSat` queries- in the presence of uninterpreted sorts, since it was not possible- to generate a refuting model. The model returned by the SMT solver- is simply not usable, since it names constants that is not visible- in a subsequent run. Eric Seidel came up with the idea that we can- actually compute equivalence classes based on a produced model, and- assert the constraint that the new model should disallow the previously- found equivalence classes instead. The idea seems to work well- in practice, and there is also an example program demonstrating- the functionality: Examples/Uninterpreted/UISortAllSat.hs- * Programmable model extraction improvements:- * Add functions `getModelDictionary` and `getModelDictionaries`, which- provide low-level access to models returned from SMT solvers. Former- for `sat` and `prove` calls, latter for `allSat` calls. Together with- the exported utils from the `Data.SBV.Internals` module, this should- allow for expert users to dissect the models returned and do fancier- programming on top of SBV.- * Add `getModelValue`, `getModelValues`, `getModelUninterpretedValue`, and- `getModelUninterpretedValues`; which further aid in model value- extraction.- * Other:- * Allow users to specify the SMT-Lib logic to use, if necessary. SBV will- still pick the logic automatically, but users can now override that choice.- Comes in handy when playing with custom logics.- * Bug fixes:- * Address allsat-laziness issue (#78 in github issue tracker). Essentially,- simplify how all-sat is called so we can avoid calling the solver for- solutions that are not needed. Thanks to Eric Seidel for reporting.- * Examples:- * Add Data/SBV/Examples/Misc/ModelExtract.hs as a simple example for- programmable model extraction and usage.- * Add Data/SBV/Examples/Misc/Floating.hs for some FP examples.- * Use the AUFLIA logic in Examples.Existentials.Diophantine which helps- z3 complete the proof quickly. (The BV logics take too long for this problem.)--### Version 2.10, 2013-03-22-- * Add support for the Boolector SMT solver- * See: http://fmv.jku.at/boolector/- * Use `import Data.SBV.Bridge.Boolector` to use Boolector from SBV- * Boolector supports QF_BV (with an without arrays). In the last- SMT-Lib competition it won both bit-vector categories. It is definitely- worth trying it out for bitvector problems.- * Changes to the library:- * Generalize types of `allDifferent` and `allEqual` to take- arbitrary EqSymbolic values. (Previously was just over SBV values.)- * Add `inRange` predicate, which checks if a value is bounded within- two others.- * Add `sElem` predicate, which checks for symbolic membership- * Add `fullAdder`: Returns the carry-over as a separate boolean bit.- * Add `fullMultiplier`: Returns both the lower and higher bits resulting- from multiplication.- * Use the SMT-Lib Bool sort to represent SBool, instead of bit-vectors of length 1.- While this is an under-the-hood mechanism that should be user-transparent, it- turns out that one can no longer write axioms that return booleans in a direct- way due to this translation. This change makes it easier to write axioms that- utilize booleans as there is now a 1-to-1 match. (Suggested by Thomas DuBuisson.)- * Solvers changes:- * Z3: Update to the new parameter naming schema of Z3. This implies that- you need to have a really recent version of Z3 installed, something- in the Z3-4.3 series.- * Examples:- * Add Examples/Uninterpreted/Shannon.hs: Demonstrating Shannon expansion,- boolean derivatives, etc.- * Bug-fixes:- * Gracefully handle the case if the backend-SMT solver does not put anything- in stdout. (Reported by Thomas DuBuisson.)- * Handle uninterpreted sort values, if they happen to be only created via- function calls, as opposed to being inputs. (Reported by Thomas DuBuisson.)--### Version 2.9, 2013-01-02-- * Add support for the CVC4 SMT solver from Stanford: <https://cvc4.github.io/>- NB. Z3 remains the default solver for SBV. To use CVC4, use the- *With variants of the interface (i.e., proveWith, satWith, ..)- by passing cvc4 as the solver argument. (Similarly, use 'yices'- as the argument for the *With functions for invoking yices.)- * Latest release of Yices calls the SMT-Lib based solver executable- yices-smt. Updated the default value of the executable to have this- name for ease of use.- * Add an extra boolean flag to compileToSMTLib and generateSMTBenchmarks- functions to control if the translation should keep the query as is- (for SAT cases), or negate it (for PROVE cases). Previously, this value- was hard-coded to do the PROVE case only.- * Add bridge modules, to simplify use of different solvers. You can now say:-- import Data.SBV.Bridge.CVC4- import Data.SBV.Bridge.Yices- import Data.SBV.Bridge.Z3-- to pick the appropriate default solver. if you simply 'import Data.SBV', then- you will get the default SMT solver, which is currently Z3. The value- 'defaultSMTSolver' refers to z3 (currently), and 'sbvCurrentSolver' refers- to the chosen solver as determined by the imported module. (The latter is- useful for modifying options to the SMT solver in an solver-agnostic way.)- * Various improvements to Z3 model parsing routines.- * New web page for SBV: http://leventerkok.github.io/sbv/ is now online.--### Version 2.8, 2012-11-29-- * Rename the SNum class to SIntegral, and make it index over regular- types. This makes it much more useful, simplifying coding of- polymorphic symbolic functions over integral types, which is- the common case.- * Add the functions:- * sbvShiftLeft- * sbvShiftRight- which can accommodate unsigned symbolic shift amounts. Note that- one cannot use the Haskell shiftL/shiftR functions from the Bits class since- they are hard-wired to take 'Int' values as the shift amounts only.- * Add a new function 'sbvArithShiftRight', which is the same as- a shift-right, except it uses the MSB of the input as the bit to fill- in (instead of always filling in with 0 bits). Note that this is- the same as shiftRight for signed values, but differs from a shiftRight- when the input is unsigned. (There is no Haskell analogue of this- function, as Haskell shiftR is always arithmetic for signed- types and logical for unsigned ones.) This variant is designed for- use cases when one uses the underlying unsigned SMT-Lib representation- to implement custom signed operations, for instance.- * Several typo fixes.--### Version 2.7, 2012-10-21-- * Add missing QuickCheck instance for SReal- * When dealing with concrete SReals, make sure to operate- only on exact algebraic reals on the Haskell side, leaving- true algebraic reals (i.e., those that are roots of polynomials- that cannot be expressed as a rational) symbolic. This avoids- issues with functions that we cannot implement directly on- the Haskell side, like exact square-roots.- * Documentation tweaks, typo fixes etc.- * Rename BVDivisible class to SDivisible; since SInteger- is also an instance of this class, and SDivisible is a- more appropriate name to start with. Also add sQuot and sRem- methods; along with sDivMod, sDiv, and sMod, with usual- semantics.- * Improve test suite, adding many constant-folding tests- and start using cabal based tests (--enable-tests option.)--### Versions 2.4, 2.5, and 2.6: Around mid October 2012-- * Workaround issues related hackage compilation, in particular to the- problem with the new containers package release, which does provide- an NFData instance for sequences.- * Add explicit Num requirements when necessary, as the Bits class- no longer does this.- * Remove dependency on the hackage package strict-concurrency, as- hackage can no longer compile it due to some dependency mismatch.- * Add forgotten Real class instance for the type 'AlgReal'- * Stop putting bounds on hackage dependencies, as they cause- more trouble then they actually help. (See the discussion- here: <http://www.haskell.org/pipermail/haskell-cafe/2012-July/102352.html>.)--### Version 2.3, 2012-07-20-- * Maintenance release, no new features.- * Tweak cabal dependencies to avoid using packages that are newer- than those that come with ghc-7.4.2. Apparently this is a no-no- that breaks many things, see the discussion in this thread:- http://www.haskell.org/pipermail/haskell-cafe/2012-July/102352.html- In particular, the use of containers >= 0.5 is *not* OK until we have- a version of GHC that comes with that version.--### Version 2.2, 2012-07-17-- * Maintenance release, no new features.- * Update cabal dependencies, in particular fix the- regression with respect to latest version of the- containers package.--### Version 2.1, 2012-05-24-- * Library:- * Add support for uninterpreted sorts, together with user defined- domain axioms. See Data.SBV.Examples.Uninterpreted.Sort- and Data.SBV.Examples.Uninterpreted.Deduce for basic examples of- this feature.- * Add support for C code-generation with SReals. The user picks- one of 3 possible C types for the SReal type: CgFloat, CgDouble- or CgLongDouble, using the function cgSRealType. Naturally, the- resulting C program will suffer a loss of precision, as it will- be subject to IEE-754 rounding as implied by the underlying type.- * Add toSReal :: SInteger -> SReal, which can be used to promote- symbolic integers to reals. Comes handy in mixed integer/real- computations.- * Examples:- * Recast the dog-cat-mouse example to use the solver over reals.- * Add Data.SBV.Examples.Uninterpreted.Sort, and- Data.SBV.Examples.Uninterpreted.Deduce- for illustrating uninterpreted sorts and axioms.--### Version 2.0, 2012-05-10-- This is a major release of SBV, adding support for symbolic algebraic reals: SReal.- See http://en.wikipedia.org/wiki/Algebraic_number for details. In brief, algebraic- reals are solutions to univariate polynomials with rational coefficients. The arithmetic- on algebraic reals is precise, with no approximation errors. Note that algebraic reals- are a proper subset of all reals, in particular transcendental numbers are not- representable in this way. (For instance, "sqrt 2" is algebraic, but pi, e are not.)- However, algebraic reals is a superset of rationals, so SBV now also supports symbolic- rationals as well.-- You *should* use Z3 v4.0 when working with real numbers. While the interface will- work with older versions of Z3 (or other SMT solvers in general), it uses Z3- root-obj construct to retrieve and query algebraic reals.-- While SReal values have infinite precision, printing such values is not trivial since- we might need an infinite number of digits if the result happens to be irrational. The- user controls printing precision, by specifying how many digits after the decimal point- should be printed. The default number of decimal digits to print is 10. (See the- 'printRealPrec' field of SMT-solver configuration.)-- The acronym SBV used to stand for Symbolic Bit Vectors. However, SBV has grown beyond- bit-vectors, especially with the addition of support for SInteger and SReal types and- other code-generation utilities. Therefore, "SMT Based Verification" is now a better fit- for the expansion of the acronym SBV.-- Other notable changes in the library:-- * Add functions s[TYPE] and s[TYPE]s for each symbolic type we support (i.e.,- sBool, sBools, sWord8, sWord8s, etc.), to create symbolic variables of the- right kind. Strictly speaking these are just synonyms for 'free'- and 'mapM free' (plural versions), so they are not adding any additional- power. Except, they are specialized at their respective types, and might be- easier to remember.- * Add function solve, which is merely a synonym for (return . bAnd), but- it simplifies expressing problems.- * Add class SNum, which simplifies writing polymorphic code over symbolic values- * Increase haddock coverage metrics- * Major code refactoring around symbolic kinds- * SMTLib2: Emit ":produce-models" call before setting the logic, as required- by the SMT-Lib2 standard. [Patch provided by arrowdodger on github, thanks!]-- Bugs fixed:-- * [Performance] Use a much simpler default definition for "select": While the- older version (based on binary search on the bits of the indexer) was correct,- it created unnecessarily big expressions. Since SBV does not have a notion- of concrete subwords, the binary-search trick was not bringing any advantage- in any case. Instead, we now simply use a linear walk over the elements.-- Examples:-- * Change dog-cat-mouse example to use SInteger for the counts- * Add merge-sort example: Data.SBV.Examples.BitPrecise.MergeSort- * Add diophantine solver example: Data.SBV.Examples.Existentials.Diophantine--### Version 1.4, 2012-05-10-- * Interim release for test purposes--### Version 1.3, 2012-02-25-- * Workaround cabal/hackage issue, functionally the same as release- 1.2 below--### Version 1.2, 2012-02-25-- Library:-- * 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+* GitHub: <http://github.com/LeventErkok/sbv>++### Version 14.5, 2026-07-26++ * Add `sRationalToSReal` and `sRealToSRational`, converting between symbolic rationals and+ reals. The rational-to-real direction is always exact. The real-to-rational direction is+ exact for reals that are rational (introducing a defining constraint for symbolic inputs);+ note that applying it to an irrational value renders the problem unsatisfiable.++ * Add the `smtLib2Compliant` field to `SMTConfig` (default: `True`), controlling whether SBV+ asks the solver to be strictly SMTLib2 compliant. Turning it off can help with solvers (e.g.,+ z3) that otherwise mishandle overloaded operators when integers and reals are mixed in the+ same problem.++ * Add `sRealToSIntegerRM` and `sRationalToSIntegerRM`, which convert a real/rational to an+ integer using a symbolic rounding-mode argument, along with the helper `sCaseRoundingMode`+ for dispatching on a symbolic `SRoundingMode`. Thanks to Ryan Scott for the implementation.++ * [BACKWARDS COMPATIBILITY] The real-to-integer flooring function `sRealToSInteger` has been+ renamed to `sRealToSIntegerFloor`, for consistency with the new `sRealToSIntegerCeiling`,+ `sRealToSIntegerTruncate`, etc. (and with the rational counterparts below). If you use+ `sRealToSInteger`, simply replace it with `sRealToSIntegerFloor`; the behavior is unchanged.++ * Export the individual real-to-integer and rational-to-integer rounding functions, in addition+ to the rounding-mode-dispatched versions above: `sRealToSIntegerFloor`, `sRealToSIntegerCeiling`,+ `sRealToSIntegerTruncate`, `sRealToSIntegerRoundAway`, `sRealToSIntegerRoundToEven`, and the+ rational counterparts `sRationalToSIntegerFloor`, `sRationalToSIntegerCeiling`,+ `sRationalToSIntegerTruncate`, `sRationalToSIntegerRoundAway`, and `sRationalToSIntegerRoundToEven`.++ * Fix `svDivide` (i.e., `/` on unbounded integers in `Data.SBV.Dynamic`), which used flooring+ (`div`) on concrete integers instead of the Euclidean division that its symbolic counterpart+ (and `svQuot`) implements. The two now agree, always yielding a non-negative remainder.+ Thanks to Ryan Scott for the report.++ * Improve the Haddocks for `sQuot`, `sDiv`, `sRem`, `sMod`, and related functions, clarifying+ the truncating- vs. flooring-division distinction and documenting that the `Data.SBV.Dynamic`+ operations `svQuot`, `svRem`, and `svQuotRem` behave differently from their `s`-prefixed+ counterparts on unbounded integers. Thanks to Ryan Scott for the implementation.++### Version 14.4, 2026-07-03++ * Add `curry` and `uncurry` (for symbolic 2-tuples) and `curry3` and `uncurry3` (for+ symbolic 3-tuples) to `Data.SBV.Tuple`, mirroring `Prelude.curry`/`Prelude.uncurry`.++ * New example `Documentation.SBV.Examples.BitPrecise.Adders`, building ripple-carry and+ carry-lookahead adders out of logic gates and proving them correct (equal to bit-vector+ addition, equal to each other, and the carry-out equal to the overflow flag) fully+ automatically by bit-blasting.++ * New example `Documentation.SBV.Examples.TP.Adder`, the inductive companion to the above:+ it models the operands as arbitrary-length symbolic bit lists and proves, for all widths+ at once, that a ripple-carry adder computes the integer value of the bits, and that a+ parallel-prefix (carry-lookahead) tree computes the same carry as the ripple---resting on+ the associativity of the generate/propagate carry operator.++ * Use str.to_re (instead of str.to.re) in regular-expression construction, which is the standard+ naming in SMTLib2. Thanks to May Torrence for reporting the discrepancy.++### Version 14.3, 2026-06-19++ * Improve fpRoundToIntegralH to remove redundant internal check. Thanks to Ryan Scott for the report.++ * Add support for arctan/arcsin/arccos in CVC5. Thanks to Ryan Scott for pointing out support for it.++ * Improved backend-solver communication so that if a solver returns an error message SBV now makes+ sure it gets captured and displayed properly before the solver-process itself terminates.++ * Drop support for pi as an SReal: The whole premise of SReal is it represents algebraic-reals+ (i.e., those that are roots of polynomials) exactly. But pi is not representable as such, since+ it's transcendental. Older versions of SBV used an approximation, but that's confusing to say+ the least, and downright wrong. Note that you can still use pi at floating-point types, where+ precision loss is built into the semantics.++ * Fix the enumeration quasi-quoter for a zero step: `[sEnum| 1, 1 .. 5 |]` is now the+ (semantically infinite) list of 1's, instead of the empty list.++ * Soundness fix for termination measures: a real-valued measure is now rejected at compile+ time. The reals are not well-ordered (an infinite descending chain like 1, 1/2, 1/4, ...+ never reaches a minimum), so a non-negative, strictly-decreasing real measure does not+ imply termination. Use an integer-valued measure instead.++ * Termination measures may now be given over the bounded bit-vector types (`Word8`..`Word64`,+ `Int8`..`Int64`, `WordN n`, `IntN n`), in addition to the integer/float types supported before.++### Version 14.2, 2026-06-05++ * Fix float to integer conversions, which were ignoring the rounding mode previously. Thanks to+ Ryan Scott for the report.++ * Fix the implementation of properFraction for arbitrary-sized floats. Thanks to Ryan Scott+ for the report and the fix.++ * Fix a bug in pCase, where SBV was over-approximating the bound variables, causing the+ unused-variable warning checker to flag branches unnecessarily in generated code.++ * New TP example: Run-length encoding roundtrip (`Documentation.SBV.Examples.TP.RunLength`).+ Proves that `decode (encode xs) == xs` for a run-length encode/decode pair.++ * New TP example: Two-stack queue (`Documentation.SBV.Examples.TP.Queue`).+ Proves that a queue implemented with two lists (front/back) correctly implements+ FIFO semantics via an abstraction function.++ * New cabal flag `compile_examples` (default: True) controls whether the+ `Documentation.SBV.Examples.*` modules are built as part of the library.+ Disable with `-f-compile_examples` when using SBV as a dependency to skip+ compiling the example modules. Thanks to Robin Webbers for the contribution.++ * Add more floating-point operations to `Data.SBV.Dynamic`. Thanks to Ryan Scott for the patch.++### Version 14.1, 2026-05-04++ * [BACKWARDS COMPATIBILITY] Removed `tpRibbon`. The ribbon length for TP proof+ output is now auto-computed from the proof structure via a lightweight dry-run+ pass. Users no longer need to manually set it.++ * New TP combinators `whenDryRun` and `unlessDryRun` allow user code to guard+ actions (e.g., proof tree printing) that should only run during the real pass of a TP+ based proof.++ * TP `pCase` now supports nested `case` expressions as proof case-splits,+ mirroring how `sCase` treats nested `case` as symbolic cases.++ * Consolidated internal solver IPC timeouts into named constants.+ Set the environment variable `SBV_COMM_TIMEOUT_FACTOR` to scale them (e.g., `2` to double).++ * Better handling of logic-strings, accommodating solver differences. Thanks to Ryan Scott for the report.++ * Fixed a bug in fpRemH, which calculates the floating point reminder for concrete values. The result+ was rounded twice, which is against the specification. Thanks to Ryan Scott for the report and the fix.++ * Simplify how floating-point literals are printed. The older method worked for Z3/CVC5, but not for Bitwuzla.+ Thanks to Ryan Scott for the report and the fix.++ * Fix the definition of sRealToSIntegerTruncate to do proper truncation. Thanks to Ryan Scott for the+ report and the fix.++### Version 14.0, 2026-04-01++ * [BACKWARDS COMPATIBILITY] The most important change in this release is how SBV treats+ function definitions via `smtFunction` and its variants. In prior versions, these definitions were+ directly translated to SMT-lib, without checking that they actually terminate. Starting with+ this release, SBV now requires all functions to terminate (with an escape hatch where the user+ explicitly opts out), and it proves it for all functions involved in a proof. SBV guesses+ and verifies a termination measure, and in case it can't do so will tell the user to supply+ their own version. This major departure from the old style of ignoring termination is a step+ towards incorporating a better architecture for much improved (semi-)automated theorem proving+ in SBV. See below for more details.++ * [BACKWARDS COMPATIBILITY] Major improvements to the `sCase` and `pCase` quasi-quoters:+ - Type prefix is no longer required; the type is inferred automatically+ from the patterns. Old syntax: `[sCase|Expr e of ...]`. New syntax: `[sCase| e of ...]`.++ - Wildcard-only patterns are now supported. An unguarded wildcard generates the rhs directly,+ while guarded wildcards produce an `ite`-chain (for `sCase`) or proof obligations (for `pCase`).++ - Built-in types are now supported: `Maybe`, `Either`, `List`, and `Tuple2` through `Tuple8`.+ Nested patterns across built-in types are also supported (e.g., `Just (x:_)`, `Left (a, b)`).+ For single-constructor types, the generated code omits the redundant constructor tester guard.++ - Primitive types are now supported: `Bool`, `Integer`, `Char`, and `String`. Patterns can use+ `True`/`False`, integer literals, character literals, string literals, variable bindings,+ and wildcards.++ ```haskell+ [sCase| m of [sCase| x of [sCase| xs of [sCase| c of+ Nothing -> 0 0 -> sTrue [] -> 0 'a' -> 1+ Just x -> x + 1 _ -> sFalse x : xs' -> x + f xs' 'b' -> 2+ |] |] |] _ -> 0+ |]++ [sCase| x of [sCase| x of+ _ | x .> 0 -> x 0 -> y+ | sTrue -> -x _ | x .> y -> x+ |] | sTrue -> y+ |]+ ```++ - As-patterns (`x@pat`) are now supported in both top-level and nested positions.+ The as-name is bound to the scrutinee (top-level) or accessor (nested) via a+ let-binding, which is elided when the name is unused. This works with all pattern+ types: constructors, tuples, lists, wildcards, and in combination with nested `case`+ expressions.++ ```haskell+ [sCase| xs of+ a : tl@(_ : _) -> a + case tl of+ b : _ -> b+ [] -> 0+ _ : _ -> 0+ [] -> 0+ |]+ ```++ - Plain `case` expressions inside `[sCase|...|]` and `[pCase|...|]` are now automatically+ treated as symbolic case-splits. This works around GHC's quasi-quoter nesting limitation+ (`[sCase|` cannot contain `|]`), and makes nested symbolic case expressions natural:++ ```haskell+ [sCase| e of+ Zero -> case m of+ Nothing -> 0+ Just v -> v+ Num k -> k+ Add a b -> t a m + t b m+ |]+ ```++ All `case` expressions inside `sCase` and `pCase` become symbolic; use a `let` or helper+ function for regular Haskell case expressions.++ * Improved documentation for `lambdaArray`, explaining the model-theoretic distinction+ between the pure array theory (`select`/`store`/`const`) and the richer setting where+ arrays are identified with function spaces.++ * [BACKWARDS COMPATIBILITY] `recall` and `recallWith` no longer take a `String` argument.+ A recalled proof is now automatically cached and reused if the same proposition is+ encountered again. `tpNoCache` has been removed.++ * SBV now detects conflicting `smtFunction` definitions: if two calls use the same SMT+ name but have different bodies, an error is raised. Identical re-registrations (which+ happen naturally with recursive functions) remain allowed.++ * SBV now automatically checks termination of recursive functions defined via `smtFunction`.+ A measure (a non-negative expression that strictly decreases at each recursive call) is+ guessed automatically from argument types when possible. For functions that need an explicit+ measure, use `smtFunctionWithMeasure`:++ ```haskell+ ld = smtFunctionWithMeasure "ld" (\k n -> (n - k) `smax` 0, [])+ $ \k n -> ite (n `sMod` k .== 0) k (ld (k+1) n)+ ```++ When the measure requires inductive properties to verify, supply TP proof actions as helpers+ via `measureLemma`/`measureLemmaWith`:++ ```haskell+ normalize = smtFunctionWithMeasure "normalize"+ ( \f -> tuple (ifComplexity f, ifDepth f)+ , [measureLemma ifDepthNonNeg, measureLemma ifComplexityPos]+ )+ $ \f -> ...+ ```++ * For nested recursive functions (like McCarthy's 91 function) where the termination argument+ depends on the function's return value at smaller inputs, use `smtFunctionWithContract`. This+ takes a measure and a contract (post-condition) that are verified simultaneously via well-founded+ induction:++ ```haskell+ mcCarthy91 = smtFunctionWithContract "mcCarthy91"+ ( \n -> 0 `smax` (101 - n)+ , \n r -> n .<= 100 .=> r .== 91+ , []+ )+ $ \n -> ite (n .> 100) (n - 10) (mcCarthy91 (mcCarthy91 (n + 11)))+ ```++ * Productive (corecursive) functions can now be defined via `smtProductiveFunction`. Unlike+ terminating functions, productive functions need not have a base case — they may produce+ infinite output, so long as every recursive call is guarded by a data constructor.++ * New function `smtFunctionNoTermination` for defining recursive SMT functions without any+ termination check. The function is emitted as `define-fun-rec` and the user takes+ responsibility for well-definedness. Use this for functions where termination is believed+ but cannot be proven. Any TP proof that depends on such a function will be marked as+ `[Modulo: <name> termination]` instead of `[Proven]` in its root of trust.++ * New example `Documentation.SBV.Examples.TP.Countdown`, proving properties of a+ list-building countdown function using induction.++ * New example `Documentation.SBV.Examples.TP.NatStream`, demonstrating `smtProductiveFunction`+ with the infinite stream `nats n = [n, n+1, n+2, ...]` and proofs about its head, length, and+ element access.++ * New example `Documentation.SBV.Examples.TP.MutualCorecursion`, demonstrating mutually+ corecursive productive functions. Two functions `ping` and `pong` take turns producing+ elements of a stream, and we prove elementwise equality and that the k-th element of+ `ping n` is `n + k`.++ * New example `Documentation.SBV.Examples.TP.Collatz`, using `smtFunctionNoTermination` to+ define the Collatz function (whose termination is a famous open problem) and proving that+ all powers of two reach 1.++### Version 13.6, 2026-03-02++ * The `sCase` quasi-quoter now supports nested constructor patterns. Sub-patterns+ in a constructor match can themselves be constructors, including nullary ones. For example:++ ```haskell+ normalize f = smtFunction "normalize" $ \f ->+ [sCase|Formula f of+ If (If p q r) left right -> normalize (sIf p (sIf q left right) (sIf r left right))+ If c left right -> sIf c (normalize left) (normalize right)+ _ -> f+ |]+ ```++ Nested patterns generate appropriate `isCstr`/`getCstr_i` guards and let-bindings+ automatically. Pattern guards (`, e1, e2`) may also be used alongside nested patterns.+ Additionally, `| True` is now accepted as a synonym for `| sTrue` in guards.++ * The `sCase` quasi-quoter now supports integer and string literal patterns in nested+ positions (and at the top level inside a constructor). For example:++ ```haskell+ p e = [sCase|Formula e of+ Val 0 -> 100 -- fires when the Val field equals 0+ Val 1 -> 200 -- fires when the Val field equals 1+ Add (Val 0) r -> eval r -- nested literal: fires when left child is Val 0+ _ -> eval e+ |]+ ```++ A literal sub-pattern desugars to a symbolic equality guard (`getC_i e .== lit`),+ so the exhaustiveness checker correctly requires a fallback for any constructor+ that only appears with literal sub-patterns.++ * Add the `pCase` quasi-quoter for proof case-splits. Same syntax as `sCase`, but+ generates `cases [cond ==> proof, ...]` instead of `ite` chains. Wildcards are+ allowed as the last arm (with or without guards), generating a negated disjunction+ of all prior guards to do fall-thru proofs.++ * Add minimum and maximum to Data.SBV.List. If they receive empty list as argument,+ then the result is underspecified, i.e., can be any value of the element type.++ * Add mapConcat to Documentation.SBV.Examples.TP.Lists, which proves the theorem+ `map f . concat = concat . map (map f)`.++ * Add Documentation.SBV.Examples.TP.Kadane, proving the correctness of Kadane's algorithm+ for computing the maximum segment sum. The proof uses a generalized invariant lemma to relate+ the accumulator-based implementation to the specification. (This proof was completed with+ assistance from Claude, in particular the part where we had to come up with the invariant+ about the helper function.)++ * Add Documentation.SBV.Examples.TP.Coins, proving the classic coin change theorem: for any+ amount n >= 8, you can make exact change using only 3-cent and 5-cent coins. Inspired by+ an Imandra example at <https://github.com/imandra-ai/imandrax-examples/blob/main/src/coins.iml>.++ * Add Documentation.SBV.Examples.TP.Ackermann, proving the relationship between Ackermann's+ original function and R. Peter's version (1935). Inspired by an Imandra example at+ <https://github.com/imandra-ai/imandrax-examples/blob/main/src/ackermann.iml>. This proof+ was developed by Claude with minimal user prompting and guidance.++ * Add Documentation.SBV.Examples.TP.PigeonHole, proving the pigeonhole principle: If a list+ of numbers sum up to more than the length of the list, then some cell must have a value+ greater than one.++ * Add Documentation.SBV.Examples.TP.TautologyChecker, a verified tautology checker for+ propositional formulas using an unordered BDD-style SAT solver approach. The proof establishes+ both soundness (if the checker says a formula is a tautology, it evaluates to true under all+ bindings) and completeness (if the checker says a formula is not a tautology, falsify returns+ a counterexample binding). Inspired by an Imandra example at+ <https://github.com/imandra-ai/imandrax-examples/blob/main/src/tautology.iml>, originally+ based on Boyer-Moore '79. This proof was developed with Claude's assistance.++ * Add Documentation.SBV.Examples.TP.ConstFold, proving the correctness of a constant-folding+ optimizer for a simple expression language with variables, constants, arithmetic, and let-bindings.+ The optimizer performs bottom-up simplification including arithmetic identities (e.g., addition/+ multiplication by 0 or 1, constant propagation) and let-folding (inlining `Let x (Con v) b` via+ capture-avoiding substitution).++### Version 13.5, 2026-01-26++ * Replace internal SMT-lib program representation from plain String to Text. This+ should improve performance and memory behavior in certain cases. Since solver time+ dominates for most cases, this is not going to be noticeable by end-users, except+ for very large programs. In any case, it should at least improve memory usage.+ NB. Historical note: Most of these transformations were done by Claude code; the+ era of AI coding had its first contributions to SBV. I' duly impressed by Claude's+ ability to understand and manipulate Haskell. (I also tried Gemini, which was less+ successful, compared to Claude.) I, for one, welcome our new computer overlords.++ * Added Documentation.SBV.Examples.TP.UpDown.hs, demonstrating proof of a a couple of+ list-processing functions together with naturals using TP. The problem itself is inspired+ by a midterm exam question for an ACL2-class taught by J Moore at UT Austin back in 2011;+ a minor tribute to J's amazing legacy.++### Version 13.4, 2026-01-09++ * Remove Eq constraint on readArray, generalizing it to arbitrary types for array-reads.++ * Added 'freeArray', which creates an array with no constraints at all. (Compare to 'constArray'.)+ Note that this is useful for expression contexts. If you're in a symbolic context (i.e., in+ the Symbolic monad), you can just use 'free' or 'sArray' as usual.)++ * Add missing instance of SatModel for Arrays. Thanks to Robin Webbers for the patch.++ * Export ArrayModel, so it can be programmatically processed after a call.++ * Moved Data/SBV/TP/List.hs to Documentation/SBV/Examples/TP/Lists.hs, which aligns better with the+ haddock documentation.++ * Fixed closure-version implementations of list functions filter, partition, takeWhile, and dropWhile.+ Thanks to amigalemming on github for the bug report.++ * Query mode now works with optimization directives. In this case, we perform lexicographic+ optimization. (Let me know if you need other methods.) The advantage of this is that calls+ to getValue works in this mode, so it is easier to access optimized model values. In case+ the optimal value is in an extension field (i.e., involves epsilon or infinity values),+ then calls to getValue will throw an error and alert the user. In this latter case, you+ should resort back to using the regular optimize calls.++ * Added new puzzle example: Documentation.SBV.Examples.Puzzles.SquareBirthday++ * Add recallWith to Data.SBV.TP, which allows you to change the solver in a recalled proof.++### Version 13.3, 2025-12-05++ * Added 'constArray', which allows creation of constant valued symbolic arrays. The definition+ is semantically equivalent to 'lambdaArray . const', but we generate simpler SMTLib code+ for it. For the general case of initializing an array with arbitrary functions, continue+ using 'lambdaArray'. Thanks to Robin Webbers for the patch.++ * Improved the infinite-number-of-primes theorem statement slightly.++### Version 13.2, 2025-12-02++ * Improve support for SMTDefinable class, allowing support for on-the-fly generated functions.+ Thanks to Eddy Westbrook for the patch. This should have no impact on existing code or usage,+ just allowing new use cases. Let us know if it breaks anything.++ * SBV now supports uninterpreted functions of arbitrary arities. (Previously, we had support for upto+ 12 args; Eddy's work above generalized this to arbitrary arity.)++ * Added Documentation.SBV.Examples.TP.Primes, which formalizes prime numbers and proves that there are+ an infinite number of primes.++### Version 13.1, 2025-10-31++ * Tweaks to make sure SBV compiles with GHC 9.8.4. No other changes on top of 13.0 below.++### Version 13.0, 2025-10-31++ * SBV now supports algebraic data-types. A new function 'mkSymbolic' is introduced, which take a list of types+ and turns them into types that you can symbolically process. Clearly, Haskell ADTs are extremely rich:+ Parameterized, self-referential, and mutually-recursive datatypes are supported. GADTs and more complicated+ forms of data-types (with higher-order fields, for instance) are not supported. What SBV covers should handle+ most use cases, please get in touch if you have a use case that is currently not supported.++ * Introduced a new quasiquoter, named sCase, which allows writing case-expressions over symbolic ADTs. It supports+ wildcards and guards. It does not support pattern guards, nor complex patterns. (Each pattern is either a+ variable or an underscore.) Symbolic-boolean guards allow for concise expressions. This construct makes+ symbolic programming with ADTs easier.++ * Added examples under Documentation.SBV.Examples.ADT, demonstrating the use of basic ADTs and a case study+ of modeling type-checking constraints.++ * Added Documentation.SBV.Examples.TP.Peano, modeling peano numbers using an ADT and demonstrating many proofs.++ * Added Documentation.SBV.Examples.TP.VM demonstrating the correctness of a simple interpreter over an expression+ language with respect to a version that compiles the expression and runs the instructions over a virtual machine.++ * [BACKWARDS COMPATIBILITY] The old functions 'mkSymbolicEnumeration' and 'mkUninterpretedSort' are now removed,+ since their functionality is subsumed by 'mkSymbolic'.++ * [BACKWARDS COMPATIBILITY] Strong-induction now takes extra proof objects that can be used to establish that+ the measure provided is non-negative. This is usually not needed, so simply pass []. However, in case of strong+ induction over ADTs in particular, it can come in handy to aid the solver in establishing the given measure+ is valid.++### Version 12.2, 2025-08-15++ * Fix floating-point constant-folding code, which inadvertently constant-folded for symbolic rounding modes.++ * Euclidian modulus/division does not restrict division by 0. Following SMTLib, we allow sEDiv and sEMod+ to underconstrain the value if the divisor is 0. The main motivation for this is to allow for direct translation+ to SMTLib for these operations where solvers perform much better. Fixed the code to avoid unintended constant+ folding for the euclidian case.++ * Add missing Num instance for SRational and beef up test suite. Thanks to Jan Grant for reporting.++ * [BACKWARDS COMPATIBILITY] Reworked OrdSymbolic and Numeric instances, making them more robust. While this should+ be mostly invisible to end-users, you might have to add an extra 'FlexibleInstances' pragma that wasn't needed+ before. Please get in touch if you see inadvertent effects due to uses of symbolic ordering.++ * TP: Add tpAsms, which explicitly prints the assumption-proving step for each proof transition. Default is False,+ as assumptions are typically simple to prove. But if you use complicated booleans, this step can come in handy+ in seeing where a proof gets stuck.++ * TP: Add 'recall': Which turns of printing for a TP computation. This allows for non-verbose output in proof-scripts+ when we reuse an old proof. Note that this is safe: We still run the proof mentioned so any failures in it will+ be caught; it's just that we do it quietly to reduce verbosity in the re-calling proof.++ * TP: Add '|->': This is similar to '|-', except it applies to a boolean-chain of reasoning where each step is+ equivalent to the conjunction of the previous and the next. This allows for concise expression of boolean+ reasoning steps. See gcdAdd in Documentation.SBV.Examples.TP.GCD for an example.++ * Added Documentation.SBV.Examples.TP.GCD, which proves correctness and several other properties of Euclidian+ GCD algorithm. We also prove subtraction based and the so-called binary-GCD algorithms correct.++### Version 12.1, 2025-07-11++ * Add missing instances for strong-equality, extending it to lists/Maybe etc. (Only impacts floats and structures+ that contain floats.)++ * Be more careful about applications of equality when floats are involved. Previously, we were using regular SMTLib+ equality for structures. (i.e., lists of values or any other container that have a float element stored somewhere.)+ Unfortunately the IEEE-754 semantics for equality does not correspond to SMTLib's notion of equality in these+ cases, causing semantic differences. Now we are more careful, and we also warn the user about performance+ implications and ask them to use custom-functions instead.++### 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 accumulating 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.++ * KnuckleDragger: Add methods 'getProofTree' and 'kdShowDepsHTML' to collect and render+ the proof as a dependency tree, unicode or as HTML. Useful for programming+ methods/tactics on top of knuckle-dragger provided facilities.++### Version 11.6, 2025-05-10++ * Make SBV compile cleanly with GHC 9.8.4. This is really as far back a GHC you should be using,+ unless you can't use anything newer.++ * KnuckleDragger:+ - Simplify and generalize inductive proofs. You can now do proofs with user-specified measure functions.+ - Tweak proof-traces to print user given hints (aids in debugging).+ - Add a proof of correctness for the binary-search algorithm.++### Version 11.5, 2025-04-25++ * Documentation updates++ * KnuckleDragger: Add support for case-splitting, trivial proofs, and other improvements.++ * KnuckleDragger: Add support for strong-induction principle over integers and lists.++### Version 11.4, 2025-03-12++ * Generalize the strong-induction principle to use lexicographic order for simultaneous+ induction over two lists.++ * Added a proof of correctness for the merge-sort algorithm using KnuckleDragger++ * More exports from Data.SBV.Internals to enable compilation of SBVPlugin.++### Version 11.3, 2025-03-10++ * Fix various haddock documentation links++ * KD: Clean-up proofs using the cases tactic++### Version 11.2, 2025-03-08++ * Renamed the all-sat partitioning function from 'partition' to 'allSatPartiton'++ * Added support for 'partition' and 'splitAt' to Data.SBV.List++ * KnuckleDragger:+ - Renamed ? to ?? (which aligns better), and added unicode equivalent of it, named ⁇+ - Added strong-induction as a proof-method, with examples for both numeric and list examples+ - Added a double-induction principle, allowing inductive proofs over two lists simultaneously+ - Added a case-splitting tactic for calculational style proofs+ - Added many other example KD proofs, for lists in particular+ - Added a proof of the (functional) insertion sort algorithm++### Version 11.1, 2025-02-21++ * Completely reworked KnuckleDragger interfaces and proof styles, adding calculational and induction+ based proof strategies. SBV can now prove many inductive theorems in this mode, where the user guides+ the SMT solver to find tricky proofs. See Documentation/SBV/Examples/KnuckleDragger directory for many+ examples demonstrating the new features.++ * Generalize support for polymorphic and higher-order functions. These are still experimental, as SMTLib's+ higher-order function support is nascent. (Version 3 of SMTLib will have proper support for such functions, which+ is not released yet.) Currently, SBV can handle polymorphic and higher-order usage of: 'reverse', 'any', 'all',+ 'filter', 'map', 'foldl', 'foldr', 'zip', and 'zipWith'; all exported from the 'Data.SBV.List' module.+ These functions are supported polymorphically, and (except reverse and zip) all take a function as+ an argument. SBV firstifies these functions, and the resulting code is compatible with Z3 and CVC5.+ (Firstification might change in the future, as SMTLib gains support for more higher-order+ features itself.) Proof-support in backend solvers for higher-order functions is still quite weak,+ though KnuckleDragger makes things easier.++ * Generalize the signatures of the default project-embed implementations of the Queriable class.++ * [BACKWARDS COMPATIBILITY] Removed rarely used functions mapi, foldli, foldri from Data.SBV.List. These+ can now be defined by the user as we have proper support for fold and map using lambdas.++ * [BACKWARDS COMPATIBILITY] Removed "Data/SBV/Tools/BoundedFix.hs", and "Data/SBV/Tools/BoundedList.hs", which+ were relatively unused and are more or less obsolete with SBV's new support for sequences and recursive+ functions. If you were using these functions you could easily recreate them. Please get in touch if you+ need this old functionality.++ * [BACKWARDS COMPATIBILITY] Data.SBV no longer exports the class SatModel, which is more directed+ towards internal SBV purposes. If you need it, you can now import it from Data.SBV.Internals.++ * [BACKWARDS COMPATIBILITY] Added 'registerFunction' which comes in handy for telling SBV about functions+ that are used in query mode. This is typically not necessary as SBV will register them automatically, but+ there are certain scenarios where explicit control is needed. This function also generalizes the old+ 'registerUISMTFunction', which was a special case of this function and is now removed.++ * [BACKWARDS COMPATIBILITY] The function 'registerSMTType' is renamed to 'registerType'.++ * Fix the time-out limit setting for CVC4/5. Thanks to Daniel Matichuk for reporting.++ * Fix a performance issue with nested-lambda/quantifiers. Thanks to Blake C. Rawlings for reporting and+ Jeff Young for analysis.++### Version 11.0, 2024-11-06++ * [BACKWARDS COMPATIBILITY] SBV now handles arrays in a much more uniform way, unifying+ their use with all the other symbolic types. This required some back-wards compatibility+ changes, mostly around replacing calls to newArray with sArray. I expect there to be+ no semantic changes, only syntactic ones. Please do get in touch if you have trouble+ porting your old code using arrays to the new API.++ * Turn on support for floats and uninterpreted sorts/functions in Bitwuzla.++ * Add Data.SBV.Tools.KnuckleDragger, inspired by and modeled after Philip Zucker's tool+ (https://github.com/philzook58/knuckledragger) by the same name.++ * Added several KnuckleDragger proof examples, see Documentation.SBV.Examples.KnuckleDragger modules.+ Amongst the proofs are the irrationality of square-root of 2, several list lemmas, and a few+ inductive proofs over naturals, amongst others.++ * Add sDivides, which takes a concrete integer and a (possibly symbolic), and returns sTrue+ if the first argument divides the second. It is essentially equivalent to @a `sMod` n .== 0`,+ but it translates to the built-in divisibility predicate in SMTLib, which (might) perform better.+ Note that the @n@ argument is concrete, and must be > 0.++ * Clarified SSet, SList, and SArray: keys/contents: In SMTLib, the semantics of these containers+ use object-equality. In Haskell, they use instances of the Eq class. Usually this is just fine,+ except when it isn't: Floats! Since NaN /= NaN, and +0 is distinguished from -0, what holds+ in Haskell doesn't in the SMTLib logic. So, we define the semantics of equality to follow+ the SMTLib semantics. If you are not using floats, then this doesn't matter. If you do, bear+ in mind that the values will be treated with object equality; which (honestly) is easier to understand.++ * SBV now prints the elements of uninterpreted sorts more simply for z3. Previously, we simply used the+ name z3 produced, which looked like @T!val!i@ for the uninterpreted type @T@, we know convert it to @T_i@.++ * Added Documentation/SBV/Examples/Puzzles/DieHard.hs, which solves the die-hard jug-water problem using+ a BMC style search.++ * [BACKWARDS COMPATIBILITY] Changed the signature of the functions bmc (and bmcWith), induct (and inductWith)+ functions, so they take the transition as a relation, instead of a function returning multiple values. This+ generalizes the use cases, and it is easy to translate from existing applications. Simply change your old+ 'State -> [State]' function to 'State -> State -> SBool', which can be achieved by+ 'newTrans s1 s2 = s2 `sElem` oldTrans s1', though you probably want to code this in a more readable way+ depending on the actual transition relation you want to model. Furthermore, the function bmc is now+ split into two bmcRefute and bmcCover, to indicate use cases more clearly.++ * [BACKWARDS COMPATIBILITY] Removed the Fresh class, which was used as a proxy for the Queriable class as+ an easier to instantiate version. The extra functionality unfortunately made writing custom Queriable+ instances harder, and it is usually not harder to write Queriable in the first place.+ If you were using the Fresh class, instead define Queriable, the definition should be fairly+ simple. Please contact if you have difficulty using the Queriable interface.++### Version 10.12, 2024-08-11++ * Fix a few custom-floating-point format conversion bugs. Thanks to Sirui Lu for the patch.++ * Add a few OVERLAPPABLE pragmas to generic Queriable instances to make them easily overridable by+ user programs. Thanks to Marco Zocca for reporting.++ * Add signedMulOverflow, which checks whether multiplication of two signed-bitvectors can overflow.+ SBV already had a method (bvMulO) that served this purpose, translating to the corresponding predicate+ in SMTLib. Unfortunately not all solvers support this predicate efficiently. In particular, as of Aug 2024,+ bitwuzla has a performant checker for this overflow, but z3 does not. In case you cannot use bitwuzla for+ some reason, you might want to use the new signedMulOverflow function for better performance.++### Version 10.11, 2024-07-26++ * Add Documentation.SBV.Examples.Puzzles.Tower module, solving the visible towers puzzle.++ * Fix several representation bugs related to arbitrary-precision floats. Thanks to Sirui+ Lu for the reports and patches.++ * Removed the generic Num a => Num (SBV a) instance. When used at a non-standard type, this+ created type-checking but invalid SBV programs. See https://github.com/LeventErkok/sbv/issues/706+ for details.++ * Add functions optLexicographic, optLexicographicWith, optPareto, optParetoWith, optIndependent, optIndependentWith+ which makes using optimization functions easier. These are simple wrappers over the existing optimization routines,+ simplifying their interface.++ * Change how optimization results are presented when the underlying metric space is different from the type+ being optimized. As noted in https://github.com/LeventErkok/sbv/issues/716, the format SBV used was confusing.+ We now be more explicit, and print the original value in its own right, along with the metric-space value.+ Thanks to Andrew Anderson for reporting.++### Version 10.10, 2024-05-11++ * Add EqSymbolic, OrdSymbolic and Mergeable instances for NonEmpty type++ * Better handling of spawned processes, avoiding zombies. Thanks to Sirui Lu for the patch.++### Version 10.9, 2024-04-05++ * Fix printing of floats to be more consistent, using lowercase letters++### Version 10.8, 2024-04-05++ * Increase the number of digits used in printing floats in decimal base, which leads to+ better output in most cases.++### Version 10.7, 2024-03-23++ * Fix SMTDefinable instances for functions of arity 8-12. Thanks to Nick Lewchenko for the patch.++### Version 10.6, 2024-03-16++ * Added Data.SBV.Tools.BVOptimize module, which implements a custom optimizer for unsigned bit-vector+ values. See 'minBV' and 'maxBV' methods. These algorithms use the incremental solver instead of+ the optimizer engines, and they can be more performant in certain cases. (For instance, z3's+ optimization engine isn't incremental, which makes it perform poorly on certain BV-optimization+ problems.) These algorithms scan the bits from most to least significant bit, and individually+ set/unset them in an incremental fashion to optimize quickly.++ * SBV web-page is no longer maintained. The info is put into the README.md instead.++### Version 10.5, 2024-02-20++ * Export svFloatingPointAsSWord through Data.SBV.Internals++ * crackNum: if verbose, alert the user if surface value of a NaN doesn't match its calculated value+ due to the redundancy in NaN representations.++### Version 10.4, 2024-02-15++ * Before issuing a get-value, make sure there are no outstanding assert calls.+ See: https://github.com/LeventErkok/sbv/issues/682 for details.++ * crackNum mode now displays the surface form of NaNs more faithfully, if provided+ with the input string. This functionality is used by the crackNum executable.++### Version 10.3, 2024-01-05++ * Clean-up GHC extensions required in the cabal file, and changes required to compile cleanly with GHC 9.8 series.++ * Added 'partition', which allows for partitioning all-sat search spaces when models are generated.++ * Added 'sSetBitTo', variant of 'setBitTo', but allows symbolic indexes.++ * Added 'uninterpretWithArgs', which allows for user given argument names for uninterpreted functions. These+ names come in handy when displaying models of uninterpreted functions.++ * Added `Documentation.SBV.Examples.Misc.ProgramPaths`, showing an example use of all-sat partitioning.++ * Added `Documentation.SBV.Examples.BitPrecise.PEXT_PDEP`, modeling x86 instructions PDEP and PEXT.++ * Added `Documentation.SBV.Examples.Puzzles.Newspaper`, another puzzle example.++ * Added `Documentation.SBV.Examples.ProofTools.AddHorn`, demonstrating the use of the horn-clause solver for+ invariant generation.++ * Add 'sbv2smt', which renders the given sbv definition as an SMTLib definition. Mainly useful for debugging purposes.+ It can render both ground definitions and functions, and the latter can be handy in producing SMTLib functions to+ be used in other settings.++ * Add support for OpenSMT from Università della Svizzera italiana https://verify.inf.usi.ch/opensmt++ * Fix a bug in bit-vector rotation that manifested itself in small-bv sizes. Thanks to Sirui Lu for reporting.++ * [BACKWARDS COMPATIBILITY] Change the overflow detection API to match the new SMTLib predicates. These predicates+ do not distinguish between over/underflow, so strictly speaking the new API is less powerful than the old one. However,+ we choose to follow SMTLib here for portability purposes. If you need separate overflow/underflow checking you can+ use the encodings from earlier implementations, please get in touch if this proves problematic.++ * [BACKWARDS COMPATIBILITY] Dropped hasSize, which checked cardinality of sets. This call hasn't been supported by+ z3 for some time, and its uses were thus limited, and behavior was problematic even when supported due to finiteness+ issues.++ * Removed a few examples, which were causing regression failures with changes in z3. These are trickier examples, and+ new releases of z3 had varying performance issues, making them not suitable regression and documentation purposes. In+ particular, 'Documentation.SBV.Examples.Existentials.CRCPolynomial', 'Documentation.SBV.Examples.Lists.Nested', and+ 'Documentation.SBV.Examples.BitPrecise.MultMask' were removed.++ * SBV now keeps track of contexts, thus avoiding rare (but unsound) cases of incorrect API usage where contexts+ are mixed. We now issue a run-time error. See https://github.com/LeventErkok/sbv/issues/71 for details.++ * Improve the getFunction signature, to return more detailed info on the produced SMT functions, including the parse-tree.++ * SBV now tracks whether a declared uninterpreted function is curried or not. This helps in more precise printing of+ satisfying models with uninterpreted functions. (Previously all UI functions were displayed as if they were curried.)++### Version 10.2, 2023-06-09++ * Improve HLint pragmas. Thanks to George Thomas for the patch.++ * Added an implementation of the Prince encryption algorithm. See Documentation/SBV/Examples/Crypto/Prince.hs.++ * Added on-the-fly decryption mode for AES. See Documentation/SBV/Examples/Crypto/AES.hs for details.++ * Added functions `sEDivMod`, `sEDiv`, and `sEMod` which perform euclidian division over symbolic integers.++ * Added 'Data.SBV.Tools.NaturalInduction' which provides a proof method to perform induction over natural numbers. See the functions 'inductNat' and 'inductNatWith'.++### Version 10.1, 2023-04-14++ * [BACKWARDS COMPATIBILITY] SBV now handles quantifiers in a much more disciplined way. All of the previous+ ways of creating quantified variables (i.e., the functions sbvForall, sbvExists, universal, existential) are+ removed. Instead, we can now express quantifiers in a much straightforward way, by passing them to+ 'constrain' directly. A simple example is:++ constrain $ \(Forall x) (Exists y) -> y .> (x :: SInteger)++ You can nest quantifiers as you wish, and the quantified parameters can be of arbitrary symbolic type.+ Additionally, you can convert such a quantified formula to a regular boolean, via a call to 'quantifiedBool'+ function, essentially performing quantifier elimination:++ other_condition .&& quantifiedBool (\(Forall x) (Exists y) -> y .> (x :: SInteger))++ Or you can prove/sat quantified formulas directly:++ prove $ \(Forall x) (Exists y) -> y .> (x :: SInteger)++ This facility makes quantifiers part of the regular SBV language, allowing them to be mixed/matched with all+ your other symbolic computations.++ SBV also supports the constructors ExistsUnique to create unique existentials, in addition to+ ForallN and ExistsN for creating multiple variables at the same time.++ The new function skolemize can be used to skolemize quantified formulas: The skolemized version of a+ formula has no existential (replaced by uninterpreted functions), and is equisatisfiable to the original.++ See the following files demonstrating reasoning with quantifiers:++ * Documentation/SBV/Examples/Puzzles/Birthday.hs+ * Documentation/SBV/Examples/Puzzles/KnightsAndKnaves.hs+ * Documentation/SBV/Examples/Puzzles/Rabbits.hs+ * Documentation/SBV/Examples/Misc/FirstOrderLogic.hs++ * You can now define new functions in the generated SMTLib output, via an smtFunction call. Typically, we simply+ unroll all definitions, but there are certain cases where we would like the functions+ remain intact in the output. This is especially true of recursive functions, where the termination would+ depend on a symbolic variable, which cannot be symbolically-simulated. By translating these to SMTLib+ functions, we can now handle such definitions. Note that such definitions will no longer be constant-folded+ on the Haskell side, and each call will induce a call in the solver instead. The new method smtFunction+ can handle both recursive and non-recursive functions. See "Documentation/SBV/Examples/Misc/Definitions.hs"+ for examples.++ * Added new SList functions: map, mapi, foldl, foldr, foldli, foldri, zip, zipWith, filter, all, any.+ Note that these work on arbitrary--but finite--length lists, with all terminating elements, per+ usual SBV interpretation. These functions map to the underlying solver's fold and map functions,+ via lambda-abstractions. Note that the SMT engines remain incomplete with respect to sequence+ theories. (That is, any property that requires induction for its proof will cause unknown+ answers, or will not terminate.) However, basic properties, especially when the solver can determine the+ shape of the sequence arguments (i.e., number of elements), should go through.++ * New function 'lambdaAsArray' allows creation of array values out of lambda-expressions. See+ "Documentation/SBV/Examples/Misc/LambdaArray.hs" for an example use. This adds expressive power,+ as we can now specify arrays with index dependent contents much more easily.++ * Added support for abduct-generation, as supported by CVC5. See "Documentation/SBV/Examples/Queries/Abducts.hs"+ for a basic example.++ * Added support for special-relations. You can now check if a relation is partial, linear, tree,+ or piecewise-linear orders in SBV. (Or you can constrain relations to satisfy the corresponding laws, thus+ creating relations with these properties.) Additionally, you can create transitive-closures of relations.+ See Documentation/SBV/Examples/Misc/FirstOrderLogic.hs for several examples.++ * [BACKWARDS COMPATIBILITY] The signature of Data.SBV.List's concat has changed. In previous releases+ this was a synonym for appending two lists, now it takes a list-of-lists and flattens it, matching the+ Haskell list function with the same name.++ * [BACKWARDS COMPATIBILITY] The function addAxiom is removed. Instead use quantified-constraints, as described+ above.++ * [BACKWARDS COMPATIBILITY] Renamed the Uninterpreted class to SMTDefinable, since its task has changed, handling+ both kinds of definitions. Unless you were referring to the name Uninterpreted in your code, this should not+ impact you. Otherwise, simply rename it to SMTDefinable.++ * [BACKWARDS COMPATIBILITY] The configuration variable 'allowQuantifiedQueries' is removed. It is no+ longer relevant with our new quantification strategy described above.++ * [BACKWARDS COMPATIBILITY] The function 'isVacuous' is renamed to 'isVacuousProof' (and 'isVacuousWith'+ became 'isVacuousProofWith') to better reflect this function applies to checking vacuity in a proof context.++ * [BACKWARDS COMPATIBILITY] Satisfiability and proof checks are now put in different classes, instead of sharing+ the same class. This should not have any impact on user-level code, unless you were building libraries+ on top of SBV. See the 'ProvableM' and 'SatisfiableM' classes.++ * [BACKWARDS COMPATIBILITY] Renamed 'Goal' to 'ConstraintSet' which is more indicative of its purpose. A set+ of constraints can be satisfied, but proving them does not make sense. The name goal, however, suggested+ something we can prove.++ * [BACKWARDS COMPATIBILITY] SBV is now more lenient in returning function-interpretations, returning the SMTLib+ string in complicated cases in case of bailing out. Note that we still don't support complicated function+ values in allSat calls, as there's no way to reject existing interpretations. Consequently, the+ parameter 'satTrackUFs' is renamed to 'allSatTrackUFs' to better capture its new role.++ * Addressed an issue on Windows where solver synchronization fails due to unmapped diagnostic-challenge.+ (See issue #644 for details.) Thanks to Ryan Scott for reporting and helping with debugging.++ * Add missing Arbitrary instances for WordN and IntN types, enabling quickcheck on these types.++ * Rewrote some of the older examples to use more modern SBV idioms.++ * Changes needed to compile with upcoming GHC 9.6. Thanks to Lars Kuhtz and Ryan Scott for several patches.++### Version 9.2, 2023-1-16++ * Handle uninterpreted sorts better, avoiding kind-registration issue.+ See #634 for details. Thanks to Nick Lewchenko for the report.++### Version 9.1, 2023-01-09++ * CVC5: Add support for algebraic reals in CVC5 models++ * Export more solvers from Trans/Dynamic interfaces. Thanks to Ryan Scott for the patch.++### Version 9.0, 2022-04-27++ * Changes required to compile cleanly with GHC 9.2 series.++ * In future versions, GHC will make `forall` a reserved word, which will create a conflict with SBV's use of the same.+ To accommodate for these changes and to be consistent, following identifiers were renamed:++ - `forall` --> `sbvForall`+ - `forall_` --> `sbvForall_`+ - `exists` --> `sbvExists`+ - `exists_` --> `sbvExists_`+ - `forAll` --> `universal`+ - `forAll_` --> `universal_`+ - `forSome` --> `existential`+ - `forSome_` --> `existential_`++ * Add support for `reverse` on symbolic lists and strings. Note that this definition uses a recursive function+ declaration in SMTLib, so any proof involving inductive reasoning will likely not-terminate. However, it+ should be usable at ground-level and for simpler non-inductive properties. Of course, as SMT-solvers mature+ this can change in the future.++ * Changed the String/List versions of `.++/.!!` to directly use the names `++/!!`. Since these modules+ are intended to be used qualified only, there's no reason to add the dots.++ * Added function `addSMTDefinition`, which allows users to give direct definitions of SMTLib functions. This+ is useful for defining recursive functions that are not symbolically terminating.++ * Added `Documentation.SBV.Examples.Lists.CountOutAndTransfer` example, proving that the so-called+ coating card trick works correctly.++ * Added `Documentation.SBV.Examples.Puzzles.Jugs` example, solving the water-jug transfer puzzle.++ * Added `Documentation.SBV.Examples.Puzzles.AOC_2021_24` example, showing how to model an EDSL in SBV,+ solving the advent-of-code, 2021, day 24 problem.++ * Added `Documentation.SBV.Examples.Puzzles.Drinker` example, proving the famous Drinker paradox of+ Raymond Smullyan.++ * Added concrete type instances of Mergeable class.++ * Fixed a bug in the implementation of the concrete-path for sPopCount++ * Added complement, power, and difference operators for regular expressions. Also added `everything`, `nothing`,+ `anyChar` as new recognizers.++ * Fixed the semantics of `All` regular expressions to recognize all-strings, and added `AllChar` as a+ new regular-expression constructor to match any single regular expression. Thanks to Matt Torrence for+ the patch.++ * Fixed a bug in the concrete implementation of bit-vector join, which didn't handle signed quantities+ correctly. Thanks to Sirui Lu for the report and test cases.++### Version 8.17, 2021-10-25++ * SBV now supports cvc5; the latest incarnation of CVC. See https://github.com/cvc5/cvc5+ for details.++ * SBV now supports bitwuzla; the latest incarnation of Boolector. See https://bitwuzla.github.io+ for details.++ * Fixed handling of CRational values in constant folding, which was missing a case.+ Thanks to Jaro Reinders for reporting.++ * Fixed calls to distinct for floating-point values, causing SBV to throw an exception.++ * Add missing instances of SatModel for Char and String. Thanks to eax- on github+ for the contribution.++ * Add support for symbolic comparison of regular expressions.++ * Export svToSV from Data.SBV.Dynamic. Thanks to Matt Parker for the PR.++### Version 8.16, 2021-08-18++ * Put extra annotations on data-type constructors, which makes+ SBV generate problems that z3 can parse more easily. Thanks to+ Greg Sullivan for reporting the issue in the first place.++### Version 8.15, 2021-05-30++ * Remove support for SFunArray abstraction. Turns out that the caching+ mechanisms SBV used for SFunArray weren't entirely safe, and the code+ has become unmaintainable over-time. Instead you should simply use+ SArray, which has the exact same API. Thanks to frenchFrog42 on+ github for reporting some of the problems.++ * Fix the cmd line params for invocations of Boolector. You need+ Boolector 3.2.2 to work with this version of SBV.++ * NB. Recent releases of z3 no longer support optimization of real-valued+ goals in the presence of strict inequalities, i.e., .>, .<, and ./= operators.+ So, you might get a bogus result if you are using optimization with+ SReal parameters that have strict inequalities. See https://github.com/Z3Prover/z3/issues/5314+ for details. There is not much SBV can do to prevent these, unfortunately,+ as z3 optimization engine goals seem to have changed. Note that use of+ non-strict inequalities (i.e., .>=, .<=) should be fine. Also, this+ only impacts the optimize calls: regular sat/prove invocations are not+ impacted.++### Version 8.14, 2021-03-29++ * Improve the fast all-sat algorithm to also support uninterpreted values.++ * Generalize svTestBit to work on floats, returning the respecting bit in the+ representation of the float.++ * Fixes to crack-num facility of how we display floats in detail.++### Version 8.13, 2021-03-21++ * Generalized floating point: Add support for brain-floats, with+ type `SFPBFloat`, which has 8-bits of exponent and 8-bits of+ significand. This format is affectionately called "brain-float"+ because it's often used in modeling neural networks machine-learning+ applications, offering a wider-range than IEEE's half-float, at the+ expense of reduced precision. It has 8-exponent bits and 8-significand+ bits, including the hidden bit.++ * Add support for SRational type, rational values built out of the ratio+ of two integers. Use the module "Data.SBV.Rational", which exports the+ constructor .% to build rationals. Note that you cannot take numerator+ and denominator of rationals apart, since SMTLib has no way of storing+ the rational in a canonical way. Otherwise, symbolic rationals follow+ the same rules as Haskell's Rational type.++ * SBV now implements a faster allSat algorithm, which applies in most common+ use cases. (Essentially, when there are no uninterpreted values or sorts present.)+ The new algorithm has been measured to be at least an order of magnitude+ faster or more in common cases as it splits the search space into disjoint+ models, reducing the burden of accumulated lemmas over multiple calls. (See+ http://theory.stanford.edu/%7Enikolaj/programmingz3.html#sec-blocking-evaluations+ for details.)++### Version 8.12, 2021-03-09++ * Fix a bug in crackNum for unsigned-integer values, which incorrectly+ showed a negation sign for values with msb set to 1.++### Version 8.11, 2021-03-09++ * SBV now supports floating-point numbers with arbitrary exponent and+ significand sizes. The type is `SFloatingPoint eb sb`, where `eb`+ and `sb` are type-level naturals. In particular, SBV can now reason about+ half-floats, which are used much more frequently in ML applications. Through+ the LibBF binding, you can also use these concretely, so if you have a use+ case for computing with floats, you can use SBV as a vehicle for doing so.+ The exponent/significand sizes are limited to those supported by the LibBF+ bindings, though the allowed range is rather large and should not be a limitation+ in practice. (In particular, you'll most likely run out of memory before you+ hit precision limits!)++ * We now support a separate `crackNum` parameter in model display. If set to True+ (default is False), SBV will display numeric values of bounded integers, words,+ and all floats (SDouble, SFloat, and the new SFloatingPoint) in models in detail,+ showing how they are laid out in memory. Numbers follow the usual 2's-complement+ notation if they are signed, bit-vectors if they are not signed, and the floats+ follow the usual IEEE754 binary layout rules. Similarly, there's now a function+ crack :: SBV a -> String that does the same for non-model printing contexts.++ * Changed the isNonModelVar config param to take a String (instead of Text).+ Simplifies programming.++ * Changes to make SBV compile with GHC9.0. Thanks to Ryan Scott for the patch.++### Version 8.10, 2021-02-13++ * Add "Documentation/SBV/Examples/Misc/NestedArray.hs" to demonstrate how+ to model multi-dimensional arrays in SBV.++ * Add "Documentation/SBV/Examples/Puzzles/Murder.hs" as another puzzle example.++ * Performance updates: Thanks to Jeff Young, SBV now uses better underlying+ data structures, performing better for heavy use-case scenarios.++ * SBV now tracks constants more closely in query mode, providing more support+ for constant arrays in a seamless way. (See #574 for details.)++ * Pop-calls are now supported for Yices and Boolector. (#577)++ * Changes required to make SBV work with latest version of z3 regarding+ String and Characters, which now allow for unicode characters. This required+ renaming of certain recognizers in 'Data.SBV.Char' to restrict them to the+ Latin1 subset. Otherwise, the changes should be transparent to the end user.+ Please report any issues you might run into when you use SChar and SString types.++### Version 8.9, 2020-10-28++ * Rename 'sbvAvailableSolvers' to 'getAvailableSolvers'.++ * Use SMTLib's int2bv if supported by the backend solver. If not, we still+ do a manual translation. (CVC4 and z3 support it natively, Yices and+ MathSAT does not, for which we do the manual translation. ABC and dReal+ doesn't support the conversion at all, since former doesn't support integers+ and the latter doesn't support bit-vectors.) Thanks to Martin Lundfall+ for the initial pull request.++ * Add `sym` as a synonym for `uninterpret`. This allows us to write expressions+ of the form `sat $ sym "a" - sym "b" .== (0::SInteger)`, without resorting to lambda+ expressions or having to explicitly be in the Symbolic monad.++ * Added missing instances for overflow-checking arithmetic of arbitrary+ sized signed and unsigned bitvectors.++ * In a sat (or allSat) call, also return the values of the uninterpreted values, along with+ all the explicitly named inputs. Strictly speaking, this is backwards-incompatible,+ but it the new behavior is consistent with how we handle uninterpreted values in general.++ * Improve SMTLib logic-detection code to use generics.++### Version 8.8, 2020-09-04++ * Reworked uninterpreted sorts. Added new function `mkUninterpretedSort` to make+ declaration of completely uninterpreted sorts easier. In particular, we now+ automatically introduce the symbolic variant of the type (by prefixing the+ underlying type with `S`) so it becomes automatically available, both for uninterpreted+ sorts and enumerations. In the latter case, we also automatically introduce the value `sX`+ for each enumeration constant `X`, defined to be precisely `literal X`.++ * Handle incremental mode table-declarations that depend on freshly declared variables. Thanks+ to Gergő Érdi for reporting.++ * Fix a soundness bug in SFunArray caching. Thanks to Gergő Érdi for reporting. See+ https://github.com/LeventErkok/sbv/issues/541 for details.++ * Add support for the dReal solver, and introduce the notion of delta-satisfiability,+ where you can now check properties to be satisfiable against delta-perturbations.+ See "Documentation.SBV.Examples.DeltaSat.DeltaSat" for a basic example.++ * Add "extraArgs" parameter to SMTConfig to simplify passing extra command line+ arguments to the solver.++ * Add a method++ sListArray :: (HasKind a, SymVal b) => b -> [(SBV a, SBV b)] -> array a b++ to the `SymArray` class, which allows for creation of arrays from lists of constant or+ symbolic lists of pairs. The first argument is the value to use for uninitialized entries.+ Note that the initializer must be a known constant, i.e., it cannot be symbolic. Latter+ elements of the list will overwrite the earlier ones, if there are repeated keys.++ * Thanks to Jan Hrcek, a whole bunch of typos were fixed in the documentation and+ the source code. Much appreciated!++### Version 8.7, 2020-06-30++ * Add support for concurrent versions of solvers for query problems. Similar to+ `satWithAny`, `proveWithAny` etc., except when we have queries. Thanks to Jeffrey Young+ for the idea and the implementation.++ * Add "Documentation.SBV.Examples.Misc.Newtypes", demonstrating how to use newtypes+ over existing symbolic types as symbolic quantities themselves. Thanks to Curran McConnell+ for the example.++ * Added new predicate `sNotElem`, negating `sElem`.++ * Added new predicate `distinctExcept`. This is same as `distinct`+ except you can also provide an ignore list. The elements in+ the first list will be checked to be distinct from each other,+ or belong to the second list. This is good for writing constraints+ that either require a default value or if picked be different+ from each other for a set of variables. This sort of constraint+ can be coded in user space, but SBV generates efficient code+ instead of the obvious quadratic number of constraints.++ * Add function 'algRealToRational' that can convert an algebraic-real+ to a Haskell rational. We get an either value: If the algebraic real+ is exact, then it returns a 'Left' value that represents the value+ precisely. Otherwise, it returns a 'Right' value, which is only+ an approximation. Note: Setting 'printRealPrec' in SMTConfig+ to a higher value will increase the precision at the cost of more+ computation by the SMT solver.++ * Removed the 'SMTValue' class. It's functionality was not really+ needed. If you ever used this class, removing it from your+ type signatures should fix the issue. (You might have to+ add SymVal constraint if you did not already have it.) Please+ get in touch if you used this class in some cunning way and you+ need its functionality back.++ * Reworked SBVBenchSuite api, Phase 1 of BenchSuite completed.++ * Add support for addAxiom command to work in the interactive mode.+ Thanks to Martin Lundfall for the feedback.++ * Fixed `proveWithAny` and `satWithAny` functions so they properly+ kill the solvers that did not terminate first. Previously, they+ became zombies if they didn't end up quickly. Thanks to+ Robert Dockins for the investigation and the fix.++ * Fixed a bug where resetAssertions call was forgetting to restore the+ array and table contexts. Thanks to Martin Lundfall for reporting.++### Version 8.6, 2020-02-08++ * Fix typo in error message. Thanks to Oliver Charles+ for the patch.++ * Fix parsing of sequence counter-examples to accommodate+ recent changes in z3.++ * Add missing exports related to N-bit words. Thanks to+ Markus Barenhoff for the patch.++ * Generalized code-generation functions to accept a function+ with an arbitrary return type, which was previously just unit.+ This allows for complicated code-generation scenarios where+ one code-gen run can produce input to the next.++ * Scalability improvements for internal data structures. Thanks+ to Brian Huffman for the patch.++ * Add interpolation support for Z3, following changes to that+ solver. Note that SBV now supports two different APIs for+ interpolation extraction, one for Z3 and the other for+ MathSAT. This is unfortunate, but necessary since interpolant+ extraction isn't quite standardized amongst solvers and+ MathSAT and Z3 use sufficiently different calling mechanisms+ to warrant their own calls. See 'Documentation.SBV.Examples.Queries.Interpolants'+ for examples that illustrate both cases.++ * Add a new argument to `displayModels` function to allow rearranging+ of the results in an 'allSat` call. Strictly speaking this is+ a backwards breaking change, but substituting `id` for the+ new argument gives you old functionality, so easy to work-around.+++### Version 8.5, 2019-10-16++ * Changes to compile with GHC 8.8. Thanks to Oliver Charles+ for the patch.++ * Minor fix to how kinds are shown for non-standard sizes.++ * Thanks to Jeffrey Young, SBV now has a performance benchmark+ test-suite. The framework still new, but should help+ in the long run to make sure SBV performance doesn't regress+ on its test-suite, and by extension in general usage.++### Version 8.4, 2019-08-31++ * SBV now supports arbitrary-size bit-vectors, i.e.,+ SWord 17, SInt 9, SWord 128 etc. These work like any+ other bit-vector, using the `DataKinds` feature of+ GHC. Thanks to Ben Blaxill for the idea and the initial+ implementation. Note that SBV still supports the traditional+ fixed-size bit-vectors, SInt8, SWord16 etc. Support for+ these will not be removed; so existing programs will+ continue to work.++ * To convert between arbitrary sized bit-vectors and+ the old style equivalents, use `fromSized` and `toSized`+ functions. The behavior is controlled with a closed+ type-family so you will get a (hopefully not too+ horrendous) type error message if you try to convert,+ say, a SInt16 to SInt 22; or vice versa.++ * Added arbitrary-sized bit vector operations: extraction,+ extension, and joining; these use proxy arguments to+ determine precise size info, and are much better suited+ for type safety. Consequently, removed the Splittable+ class which provided similar operations but only on+ predefined types. There is a new class called ByteConverter+ to convert to-and-from bytes for suitable bit-vector+ sizes up to 512.++ * Tuple construction functions are given new types to strengthen+ type checking. Previously the tuple argument was ignored,+ causing things to be marked as tuples when they actually+ cannot be. (NB. The system was always type-safe, it just+ didn't produce helpful type-error messages before.)++ * Model validator: In the presence of universally quantified+ variables, SBV used to refuse to validate given models. This+ is the right thing to do since we would have to validate+ the model for all possible values of all the universally+ quantified variables. Obviously this is not useful. Instead,+ SBV now simply assumes any universally quantified variable+ is zero during model validation. This severely limits the+ validation result, but it is better than nothing. (In the+ verbose mode, a message to this effect will be printed.)++ * Model validator: SBV can now validate models returned from+ the backend solver for regular-expression match problems.+ We also constant fold matches against constant strings without+ calling the solver at all, less useful perhaps but more inline+ with the general SBV methodology.++ * Add implementation of SHA-2 family of functions as an example+ algorithm. These are good for code-generation purposes as+ opposed to actual verification tasks as it is hard to state+ any properties of these algorithms. But the SBV generated+ code can be quite useful in other development and verification+ environments. See 'Documentation.SBV.Examples.Crypto.SHA' for+ details.++ * Add 'cgShowU8UsingHex function, which controls if we print unsigned-8 bit+ values in code generation driver code in hex or not. Previously we were+ using decimal, but in crypto code hex is always better. Default is 'False'+ to keep backwards compatibility.++ * Add `sObserve` from: `SymWord a => String -> SBV a -> Symbolic ()` which+ comes in handy in symbolic contexts, especially with quick-check uses.++ * Ramped up travis-appveyor build infrastructure. However, we no+ longer test on the CI, since build-times are prohibitively long+ and myriad issues cause instability. If you can help out regarding+ testing on CI, please reach out!++### Version 8.3, 2019-06-08++ * Increment base dependency to 4.11.++ * Add support for `Data.Set.hasSize`.++ * Add `supportsFP` to CVC4 capabilities list. (#469)++ * Fix a glitch in allSat computations that incorrectly+ used values of internal variables in model construction.++ * SBV now directly uses the new `seq.nth` function from z3+ for sequence element access, instead of implementing it+ internally.++### Version 8.2, 2019-04-07++ * Fixed minor issue with getting observables in quantified contexts.++ * Simplify data-type constructor usage and accessor formats. See+ http://github.com/Z3Prover/z3/issues/2135 for a discussion.++ * Add support for model validation in optimization problems. Use the+ config parameter: `optimizeValidateConstraints`. Default: False. This+ feature nicely complements the `validateModel` option, which works+ for `sat` and `prove` calls. Note that when we validate the model+ for an optimization problem, we only make sure that the given result+ satisfies the constraints not that it is minimum (or maximum) such+ model. (And hence the new configuration variable.) Validating optimality+ is beyond the scope of SBV.++### Version 8.1, 2019-03-09++ * Added support for `SEither` and `SMaybe` types: symbolic sums and symbolic+ optional values. These can be accessed by importing `Data.SBV.Either` and+ `Data.SBV.Maybe` respectively. They translate to SMTLib's data-type syntax,+ and thus require a solver capable of handling datatypes. (Currently z3 and+ cvc4 are the only solvers that do.) All the typical introduction and+ elimination functions are provided, and these types integrate with all+ other symbolic types. (So you can have a list of SMaybe of SEither+ values, or at any nesting level.) Thanks to Joel Burget for the initial+ implementation of this idea and his contributions.++ * Added support for symbolic sets. The API closely follows that of `Data.Set`+ of Haskell, with some major differences: Symbolic sets can be co-finite.+ (That is, we can represent not only finite sets, but also sets whose complements+ are finite.) The distinction shows up in the `complement` operation, which+ is not supported in Haskell. All SBV sets can be complemented. On the flip+ side, SBV sets do not support a size operation (as they can be infinite),+ nor they can be converted to lists. See 'Data.SBV.Set' for the API documentation+ and "Documentation/SBV/Examples/Misc/SetAlgebra.hs" for an example that proves+ many familiar set properties.++ * SBV models now contain values for uninterpreted functions. This was a long+ requested feature, but there was no previous support since SMTLib does not+ have a standard way of querying such values. We now support this for z3 and+ cvc4: Note that SBV tries its best to interpret the output from these+ solvers, but it may give up if the response is too complicated (or something+ I haven't seen before!) due to non-standard format. Barring these details,+ the calls to `sat` now include function models, and you can also get them+ via `getFunction` in a query.++ For an example use case demonstrating how to use UF-models to synthesize a+ simple multiplier, see "Documentation/SBV/Examples/Uninterpreted/Multiply.hs".++ * SBV now comes with a model validator. In a 'sat', 'prove', or 'allSat' call,+ you can pass the configuration parameter 'z3{validateModel = True}' (or whichever+ solver you're using), and z3 will attempt to validate the returned model+ from the solver. Note that validation only works if there are no uninterpreted+ kinds of functions, and also in quantifier-free problems only. Please report+ your experiences, as there's room for improvement in validation, always!++ * [BACKWARDS COMPATIBILITY] The `allSat` function is similarly modified to+ return uninterpreted-function models. There are a few technical restrictions,+ however: Only the values of uninterpreted functions without any uninterpreted+ arguments will participate in `allSat` computation. (For instance,+ `uninterpret "f" :: SInteger -> SInteger` is OK, but+ `uninterpret "f" :: MyType -> SInteger` is not, where `MyType` itself+ is uninterpreted.) The reason for this is again there is no SMTLib way of+ reflecting uninterpreted model values back into the solver. This restriction+ should not cause much trouble in practice, but do get in touch if it is a+ use-case for you.++ * Added configuration option `allSatPrintAlong`. If set to True, calls to+ allSat will print their models as they are found. The default is False.++ * Added configuration parameter `satTrackUFs` (defaulting to True) to control+ if SBV should try to extract models for uninterpreted functions. In theory,+ this should always be True, but for most practical problems we typically+ don't care about the function values itself but that it exists. Set to 'False'+ if this is the case for your problem. Note that this setting is also respected+ in 'allSat' calls.++ * Added function `registerUISMTFunction`, which can be used to directly register uninterpreted+ functions. This is typically not necessary as uses of UI-functions do register them+ automatically, but it can come in handy in certain scenarios where there are no+ constraints on a UI-function other than its existence.++ * Added `Data.SBV.Tools.WeakestPreconditions` module, which provides a toy imperative+ language and an engine for checking partial and total correctness of imperative programs.+ It uses Dijkstra's weakest preconditions methodology to establish correctness claims.+ Loop invariants are required and must be supplied by the user. For total correctness,+ user must also provide termination measure functions. However, if desired, these can+ be skipped (by passing 'Nothing'), in which case partial correctness will be proven.+ Checking input parameters for no-change is supported via stability checks. For example+ use cases, see the `Documentation.SBV.Examples.WeakestPreconditions` directory.++ * Added functions `elem`/`notElem` to `Data.SBV.List`.++ * Added `snoc` (appending a single element at the end) to `Data.SBV.List` and `Data.SBV.String`.++ * Rework the 'Queriable' class to allow projection/embedding pairs. Also+ added a new 'Fresh' class, which is more usable in simpler scenarios+ where the default projection/embedding definitions are suitable.++ * Added strong-equality (.===) and inequality (./==) to the 'EqSymbolic' class. This+ method is equivalent to the usual (.==) and (./=) for all types except 'SFloat' and+ 'SDouble'. For the floating types, it is object equality, that is 'NaN .=== Nan'+ and '0 ./== -0'. Use the regular equality for float/double's as they follow the+ IEEE754 rules, but occasionally we need to express object equality in a polymorphic+ way. Essentially this method is the polymorphic equivalent of 'fpIsEqualObject'+ except it works on all types.++ * Removed the redundant 'SDivisible' constraint on rotate-left and rotate-right operations.++ * Added unnamed equivalents of 'sBool', 'sWord8' etc; with a following underscore, i.e.,+ 'sBool_', 'sWord8_'. The new functions are supported for all base types, chars,+ strings, lists, and tuples.++ * SBV now supports implicit constraints in the query mode, which were previously only+ available before user queries started.++ * Fixed a bug where hash-consing might reuse an expression even though the request might+ have been made at a different type. This is a rare case in SBV to happen due to types,+ but it was possible to exploit it in the Dynamic interface. Thanks to Brian Huffman+ for reporting and diagnosing the issue.++ * Fixed a bug where SBV was reporting incorrect "elapsed" time values, which are+ printed when the 'timing' configuration parameter is specified.++ * Documentation: Jan Path kindly fixed module headers of all the files to produce+ much better looking Haddock documents. Thanks Jan!++ * Added barrel-rotations (sBarrelRotateLeft-Right, svBarrelRotateLeft-Right) which+ can produce better code for verification by bit-blasting the rotation amount.+ It accepts bit-vectors as arguments and an unsigned rotation quantity to keep+ things simple.++ * Added new configuration option 'allowQuantifiedQueries', default is set to False.+ SBV normally doesn't allow quantifiers in a query context, because there are+ issues surrounding 'getValue'. However, Joel Burget pointed out this check+ is too strict for certain scenarios. So, as an escape hatch, you can define+ 'allowQuantifiedQueries' to be 'True' and SBV will bypass this check. Of course,+ if you do this, then you are on your own regarding calls to `getValue` with+ quantified parameters! See http://github.com/LeventErkok/sbv/issues/459+ for details.++ * [BACKWARDS COMPATIBILITY] Renamed the class `IEEEFloatConvertable` to+ `IEEEFloatConvertible`. (Typo in name!) Matt Peddie pointed out issues+ regarding conversion of out-of-bounds float and double values to integral+ types. Unfortunately SMTLib does not support these conversions, and we+ had issues in getting Haskell, SMTLib, and C to agree. Summary: These conversions+ are only guaranteed to work if they are done on numbers that lie within the+ representable range of the target type. Thanks to Matt Peddie for pointing out+ the out-of-bounds problem, his help in figuring out the issues.++ * [BACKWARDS COMPATIBILITY] The 'AllSat' result now tracks if search has stopped+ because the solver returned 'Unknown'. Previously this information was not+ displayed.++ * [BACKWARDS COMPATIBILITY, Internal] Several constraints on internal+ classes (such as SymVal, EqSymbolic, OrdSymbolic) were reworked to+ reflect the dependencies better. Strictly speaking this is a backwards+ compatibility breaking change, but I doubt it'll impact any user+ code; though you might have to add some extra constraints if you were+ writing sufficiently polymorphic SBV code. Yell if you find otherwise!++ * [BACKWARDS COMPATIBILITY] SBV now allows user-given names to be duplicated.+ It will implicitly add a suffix to them to distinguish without complaining. (In+ previous versions, we would error out.) The reason for this change is that+ sometimes it's nice to be able to simply give a prefix for a class of names+ and not worry about the actual name itself. (Note that this will cause issues+ if you use model-extraction-via-maps method if we ever make a name unique+ and store it under a different name, but that's hardly ever used feature and+ arguably the right thing to do anyway.) Thanks to Joel Burget for suggesting+ the idea.++ * [BACKWARDS COMPATIBILITY, Internal] SBV is now more strict in how user-queries+ are used, performing certain extra-checks that were not done before. (For instance,+ previously it was possible to mix prove-sat with a query call, which should+ not have been allowed.) If you have any code that breaks for this reason, you+ probably should've written it in some other way to start with. Please get+ in touch if that is the case.++ * [BACKWARDS COMPATIBILITY] You need at least GHC 8.4.1 to compile SBV.+ If you're stuck with an older version, let me know and we'll see if+ we can create a custom version for you; though I'd much rather avoid this+ if at all possible.++ * SBV now supports optimization of goals of SDouble and SFloat types. This is+ done using the lexicographic ordering on floats, and adds on the additional+ constraint that the resulting float is not a NaN. If you use this feature,+ then your float value will be minimized as the corresponding 32 (or 64 for+ doubles) bit word. Note that this methods supports infinities properly, and+ does not distinguish between -0 and +0.++ * Optimization routines have been generalized to work over arbitrary metric-spaces,+ with user-definable mappings. The simplest instance we have added is optimization+ over booleans, by the obvious numeric mapping. Tuples are also supported with+ the usual lexicographic ordering. In addition, SBV can now optimize over+ user-defined enumerations. See "Documentation.SBV.Examples.Optimization.Enumerate" for+ an example.++ * Improved the internal representation of constraints to address performance+ issues See http://github.com/LeventErkok/sbv/issues/460 for details. Thanks to+ Thanks Jeffrey Young for reporting.++### Version 8.0, 2019-01-14++ * This is a major release of SBV, with several BACKWARDS COMPATIBILITY breaking+ changes. Lots of reworking of the internals to modernize the SBV code base.+ A few external API changes happened as well, mainly in terms of renamed+ types/operators to reflect the current state of things. I expect most end user+ programs to carry over unchanged, perhaps needing a bunch of renames. See below+ for details.++ * Transformer stack and `SymbolicT`: This major internal revamping was contributed+ by Brian Schroeder. Brian reworked the internals of SBV to allow for custom monad+ stacks. In particular, there is now a `SymbolicT` monad transformer, which+ generalizes the `Symbolic` monad over an arbitrary base type, allowing users to+ build SBV based symbolic execution engines on top of their own monad infrastructure.++ Brian took the pains to ensure existing users (or those who do not have their+ own monad stack), the transformer capabilities remain transparent. That is,+ your existing code should recompile as is, or perhaps with minor aesthetic+ changes. Please report if you find otherwise, or need help.++ See `Documentation.SBV.Examples.Transformers.SymbolicEval` for an example of+ how to use the transformer based code.++ Thanks to Brian Schroeder for this massive effort to modernize the SBV code-base!++ * Support for tuples: Thanks to Joel Burget, SBV now supports tuple types (up-to+ 8-tuples), and allows mixing and matching of lists and tuples arbitrarily+ as symbolic values. For instance `SBV [(Integer, String)]` is a valid type as+ is `SBV [(Integer, [(Char, (Float, String))])]`, with each component symbolically+ represented. Along with `STuple` for regular 2-tuples, there are new types+ for `STupleN` for `N` between 2 to 8, along with `untuple` destructor, and field+ accessors similar to lens: For instance `p^._4` would project the 4th element of+ a tuple that has at least 4 fields. The mixing and matching of field types and+ nesting allows for very rich symbolic value representations. See+ `Documentation.SBV.Examples.Misc.Tuple` for an example.++ * [BACKWARDS COMPATIBILITY] The `Boolean` class is removed, which used to abstract+ over logical connectives. Previously, this class handled 'SBool' and 'Bool', but+ the generality was hardly ever used and caused typing ambiguities. The new+ implementation simplifies boolean operators to simply operate on the `SBool`+ type. Also changed the operator names to fit with all the others by starting+ them with dots. A simple conversion guide:++ * Literal True : true became sTrue+ * Literal False: false became sFalse+ * Negation : bNot became sNot+ * Conjunction : &&& became .&&+ * Disjunction : ||| became .||+ * XOr : <+> became .<+>+ * Nand : ~& became .~&+ * Nor : ~| became .~|+ * Implication : ==> became .=>+ * Iff : <=> became .<=>+ * Aggregate and: bAnd became sAnd+ * Aggregate or : bOr became sOr+ * Existential : bAny became sAny+ * Universal : bAll became sAll++ * [BACKWARDS COMPATIBILITY, INTERNAL] Historically, SBV focused on bit-vectors and machine+ words, which meant lots of internal types were named suggestive of this heritage.+ With the addition of `SInteger`, `SReal`, `SFloat`, `SDouble` we have expanded+ this, but still remained focused on atomic types. But, thanks largely to+ Joel Burget, SBV now supports symbolic characters, strings, lists, and now+ tuples, and nested tuples/lists, which makes this word-oriented naming confusing.+ To reflect, we made the following internal renamings:++ * SymWord became SymVal+ * SW became SV+ * CW became CV+ * CWVal became CVal++ Along with these, many of the internal constructor/variable names also changed in+ a similar fashion.++ For most casual users, these changes should not require any changes. But if you were+ developing libraries on top of SBV, then you will have to adapt to the new schema.+ Please report if there are any gotchas we have forgotten about.++ * [BACKWARDS COMPATIBILITY] When user queries are present, SBV now picks the logic+ "ALL" (as opposed to a suitable variant of bit-vectors as in the past versions).+ This can be overridden by the 'setLogic' command as usual of course. While the new+ choice breaks backwards compatibility, I expect the impact will be minimal, and+ the new behavior matches better with user expectations on how external queries are+ usually employed.++ * [BACKWARDS COMPATIBILITY] Renamed the module `Data.SBV.List.Bounded` to+ `Data.SBV.Tools.BoundedList`.++ * Introduced a `Queriable` class, which simplifies symbolic programming with composite+ user types. See `Documentation.SBV.Examples.ProofTools` directory for several+ use cases and examples.++ * Added function `observeIf`, companion to `observe`. Allows observing of values+ if they satisfy a given predicate.++ * Added function `ensureSat`, which makes sure the solver context is satisfiable+ when called in the query mode. If not, an error will be thrown. Simplifies+ programming when we expect a satisfiable result and want to bail out if otherwise.++ * Added `nil` to `Data.SBV.List`. Added `nil` and `uncons` to `Data.SBV.String`.+ These were inadvertently left out previously.++ * Add `Data.SBV.Tools.BMC` module, which provides a BMC (bounded-model+ checking engine) for traditional state transition systems. See+ `Documentation.SBV.Examples.ProofTools.BMC` for example uses.++ * Add `Data.SBV.Tools.Induction` module, which provides an induction engine+ for traditional state transition systems. Also added several example use+ cases in the directory `Documentation.SBV.Examples.ProofTools`.++### Version 7.13, 2018-12-16++ * Generalize the types of `bminimum` and `bmaximum` by removing the `Num`+ constraint.++ * Change the type of `observe` from: `SymWord a => String -> SBV a -> Symbolic ()`+ to `SymWord a => String -> SBV a -> SBV a`. This allows for more concise observables,+ like this:++ prove $ \x -> observe "lhs" (x+x) .== observe "rhs" (2*x+1)+ Falsifiable. Counter-example:+ s0 = 0 :: Integer+ lhs = 0 :: Integer+ rhs = 1 :: Integer++ * Add `Data.SBV.Tools.Range` module which defines `ranges` and `rangesWith` functions: They+ compute the satisfying contiguous ranges for predicates with a single variable. See+ `Data.SBV.Tools.Range` for examples.++ * Add `Data.SBV.Tools.BoundedFix` module, which defines the operator `bfix` that can be used+ as a bounded fixed-point operator for use in bounded-model-checking like algorithms. See+ `Data.SBV.Tools.BoundedFix` for some example use cases.++ * Fix list-element extraction code, which asserted too strong a constraint. See issue #421+ for details. Thanks to Joel Burget for reporting.++ * New bounded list functions: `breverse`, `bsort`, `bfoldrM`, `bfoldlM`, and `bmapM`.+ Contributed by Joel Burget.++ * Add two new puzzle examples:+ * `Documentation.SBV.Examples.Puzzles.LadyAndTigers`+ * `Documentation.SBV.Examples.Puzzles.Garden`++### Version 7.12, 2018-09-23++ * Modifications to make SBV compile with GHC 8.6.1. (SBV should+ now compile fine with all versions of GHC since 8.0.1; and+ possibly earlier. Please report if you are using a version+ in this range and have issues.)++ * Improve the BoundedMutex example to show a non-fair trace.+ See `Documentation/SBV/Examples/Lists/BoundedMutex.hs`.++ * Improve Haddock documentation links throughout.++### Version 7.11, 2018-09-20++ * Add support for symbolic lists. (That is, arbitrary but fixed length symbolic+ lists of integers, floats, reals, etc. Nested lists are allowed as well.)+ This is building on top of Joel Burget's initial work for supporting symbolic+ strings and sequences, as supported by Z3. Note that the list theory solvers+ are incomplete, so some queries might receive an unknown answer. See+ `Documentation/SBV/Examples/Lists/Fibonacci.hs` for an example, and the+ module `Data.SBV.List` for details.++ * A new module `Data.SBV.List.Bounded` provides extra functions to manipulate+ lists with given concrete bounds. Note that SMT solvers cannot deal with+ recursive functions/inductive proofs in general, so the utilities in this+ file can come in handy when expressing bounded-model-checking style+ algorithms. See `Documentation/SBV/Examples/Lists/BoundedMutex.hs` for a+ simple mutex algorithm proof.++ * Remove dependency on data-binary-ieee754 package; which is no longer+ supported.++### Version 7.10, 2018-07-20+ * [BACKWARDS COMPATIBILITY] '==' and '/=' now always throw an error instead of+ only throwing an error for non-concrete values.+ http://github.com/LeventErkok/sbv/issues/301++ * [BACKWARDS COMPATIBILITY] Array declarations are reworked to take+ an initial value. The call 'newArray' now accepts an optional default+ value, which itself can be symbolic. If provided, the array will return+ the given value for all reads from uninitialized locations. If not given,+ then reads from unwritten locations produce uninterpreted constants. The+ behavior of 'SFunArray' and 'SArray' is exactly the same in this regard.+ Note that this is a backwards-compatibility breaking change, as you need+ to pass a 'Nothing' argument to 'newArray' to get the old behavior.+ (Solver note: If you use 'SFunArray', then defaults are fully supported+ by SBV since these are internally handled, concrete or symbolic. If you+ use 'SArray', which gets translated to SMTLib, then MathSAT and Z3 supports+ default values with both concrete and symbolic cases, CVC4 only supports+ if they are constants. Boolector and Yices don't support default values+ at this point in time, and ABC doesn't support arrays at all.)++ * [BACKWARDS COMPATIBILITY] SMTException type has been renamed to+ SBVException. SBV now throws this exception in more cases to aid in+ building tools on top of SBV that might want to deal with exceptions+ in different ways. (Previously, we used to call 'error' instead.)++ * [BACKWARDS COMPATIBILITY] Rename 'assertSoft' to 'assertWithPenalty', which+ better reflects the nature of this function. Also add extra checks to warn+ the user if optimization constraints are present in a regular sat/prove call.++ * Implement `softConstrain`: Similar to 'constrain', except the solver is+ free to leave it unsatisfied (i.e., leave it false) if necessary to+ find a satisfying solution. Useful in modeling conditions that are+ "nice-to-have" but not "required." Note that this is similar to+ 'assertWithPenalty', except it works in non-optimization contexts.+ See `Documentation.SBV.Examples.Misc.SoftConstrain` for a simple example.++ * Add 'CheckedArithmetic' class, which provides bit-vector arithmetic+ operations that do automatic underflow/overflow checking. The operations+ follow their regular counter-parts, with an exclamation mark added at+ the end: +!, -!, *!, /!. There is also negateChecked, for the same+ function on unary negation. If you program using these functions,+ then you can call 'safe' on the resulting programs to make sure+ these operations never cause underflow and overflow conditions.++ * Similar to above, add 'sFromIntegralChecked', providing overflow/underflow+ checks for cast operations.++ * Add `Documentation.SBV.Examples.BitPrecise.BrokenSearch` module to show the+ use of overflow checking utilities, using the classic broken binary search+ example from http://ai.googleblog.com/2006/06/extra-extra-read-all-about-it-nearly.html++ * Fix an issue where SBV was not sending array declarations to the SMT-solver+ if there were no explicit constraints. Thanks to Oliver Charles for reporting.++ * Rework 'SFunArray' implementation, addressing performance issues. We now+ carefully memoize elements as we do the look-ups. This addresses several+ performance issues that came up; hopefully providing some relief. The+ function 'mkSFunArray' is also removed, which used to lift Haskell+ functions to such arrays, often used to implement initial values. Now,+ if a read is done on an unwritten element of 'SFunArray' we get an+ uninterpreted constant. This is inline with how 'SArray' works, and+ is consistent. The old 'SFunArray' implementation based on functions+ is no longer available, though it is easy to implement it in user-space+ if needed. Please get in contact if this proves to be an issue.++ * Add 'freshArray' to allow for creation of existential fresh arrays in the query mode.+ This is similar to 'newArray' which works in the Symbolic mode, and is analogous to+ 'freshVar'. Most users shouldn't need this as 'newArray' calls should suffice. Only+ use if you need a brand new array after switching to query mode.++ * SBV now rejects queries if universally quantified inputs are present. Previously+ these were allowed to go through, but in general skolemization makes the corresponding+ variables unusable in the query context. See http://github.com/LeventErkok/sbv/issues/407+ for details. If you have an actual use case for such a feature, please get in+ touch. Thanks to Brian Schroeder for reporting this anomaly.++ * Export 'addSValOptGoal' from 'Data.SBV.Internals', to help with 'Metric' class+ instantiations. Requested by Dan Rosen.++ * Export 'registerKind' from 'Data.SBV.Internals', to help with custom array declarations.+ Thanks to Brian Schroeder for the patch.++ * If an asynchronous exception is caught, SBV now throws it back without further processing.+ (For instance, if the backend solver gets killed. Previously we were turning these into+ synchronous errors.) Thanks to Oliver Charles for pointing out this corner case.++### Version 7.9, 2018-06-15++ * Add support for bit-vector arithmetic underflow/overflow detection. The new+ 'ArithmeticOverflow' class captures conditions under which addition, subtraction,+ multiplication, division, and negation can underflow/overflow for+ both signed and unsigned bit-vector values. The implementation is based on+ http://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/z3prefix.pdf,+ and can be used to detect overflow caused bugs in machine arithmetic.+ See `Data.SBV.Tools.Overflow` for details.++ * Add 'sFromIntegralO', which is the overflow/underflow detecting variant+ of 'sFromIntegral'. This function returns (along with the converted+ result), a pair of booleans showing whether the conversion underflowed+ or overflowed.++ * Change the function 'getUnknownReason' to return a proper data-type+ ('SMTReasonUnknown') as opposed to a mere string. This is at the+ query level. Similarly, change `Unknown` result to return the same+ data-type at the sat/prove level.++ * Interpolants: With Z3 4.8.0 release, Z3 folks have dropped support+ for producing interpolants. If you need interpolants, you will have+ to use the MathSAT backend now. Also, the MathSAT API is slightly+ different from how Z3 supported interpolants as well, which means+ your old code will need some modifications. See the example in+ Documentation.SBV.Examples.Queries.Interpolants for the new usage.++ * Add 'constrainWithAttribute' call, which can be used to attach+ arbitrary attribute to a constraint. Main use case is in interpolant+ generation with MathSAT.++ * C code generation: SBV now spits out linker flag -lm if needed.+ Thanks to Matt Peddie for reporting.++ * Code reorg: Simplify constant mapping table, by properly accounting+ for negative-zero floats.++ * Export 'sexprToVal' for the class SMTValue, which allows for custom+ definitions of value extractions. Thanks to Brian Schroeder for the+ patch.++ * Export 'Logic' directly from Data.SBV. (Previously was from Control.)++ * Fix a long standing issue (ever since we introduced queries) where+ 'sAssert' calls were run in the context of the final output boolean,+ which is simply the wrong thing to do.++### Version 7.8, 2018-05-18++ * Fix printing of min-bounds for signed 32/64 bit numbers in C+ code generation: These are tricky since C does not allow+ -min_value as a valid literal! Instead we use the macros provided in+ stdint.h. Thanks to Matt Peddie for reporting this corner case.++ * Fix translation of the `abs` function in C code generation, making+ sure we use the correct variant. Thanks to Matt Peddie for reporting.++ * Fix handling of tables and arrays in pushed-contexts. Previously,+ we used initializers to get table/array values stored properly.+ However, this trick does not work if we are in a pushed-context;+ since a pop can forget the corresponding assignments. SBV now+ handles this corner case properly, by using tracker assertions+ to keep track of what array values must be restored at each pop.+ Thanks to Martin Brain on the SMTLib mailing list for the+ suggestion. (See http://github.com/LeventErkok/sbv/issues/374+ for details.)++ * Fix corner case in ite branch equality with float/double arguments,+ where we were previously confusing +/-0 as equal to each other.+ Thanks to Matt Peddie for reporting.++ * Add a call 'cgOverwriteFiles', which suppresses code-generation+ prompts for overwriting files and quiets the prompts during+ code generation. Thanks to Matt Peddie for the suggestion.++ * Add support for uninterpreted function introductions in the query+ mode. Previously, this was only allowed before the query started,+ now we fully support uninterpreted functions in all modes.++ * New example: Documentation/SBV/Examples/Puzzles/HexPuzzle.hs,+ showing how to code cover properties using SBV, using a form+ of bounded model checking.++### Version 7.7, 2018-04-29++ * Add support for Symbolic characters ('SChar') and strings ('SString'.)+ Thanks to Joel Burget for the initial implementation.++ The 'SChar' type currently corresponds to the Latin-1 character+ set, and is thus a subset of the Haskell 'Char' type. This is+ due to the current limitations in SMT-solvers. However, there+ is a pending SMTLib proposal to support unicode, and SBV will track+ these changes to have full unicode support: For further details+ see: https://smt-lib.org/theories-UnicodeStrings.shtml++ The 'SString' type is the type of symbolic strings, consisting+ of characters from the Latin-1 character set currently, just+ like the planned 'SChar' improvements. Note that an 'SString'+ is *not* simply a list of 'SChar' values: It is a symbolic+ type of its own and is processed as a single item. Conversions+ from list of characters is possible (via the 'implode' function).+ In the other direction, one cannot generally 'explode' a string,+ since it may be of arbitrary length and thus we would not know+ what concrete list to map it to. This is a bit unlike Haskell,+ but the differences dissipate quickly in general, and the power+ of being able to deal with a string as a symbolic entity on its+ own opens up many verification possibilities.++ Note that currently only Z3 and CVC4 has support for this logic,+ and they do differ in some details. Various character/string+ operations are supported, including length, concatenation,+ regular-expression matching, substring operations, recognizers, etc.+ If you use this logic, you are likely to find bugs in solvers themselves+ as support is rather new: Please report.++ * If unsat-core extraction is enabled, SBV now returns the unsat-core+ directly with in a solver result. Thanks to Ara Adkins for the+ suggestion.++ * Add 'observe'. This function allows internal expressions to be+ given values, which will be part of the satisfying model or+ the counter-example upon model construction. Useful for tracking+ expected/returned values. Also works with quickCheck.++ * Revamp Haddock documentation, hopefully easier to follow now.++ * Slightly modify the generated-C headers by removing whitespace.+ This allows for certain "lint" rules to pass when SBV generated+ code is used in conjunction with a larger code base. Thanks+ to Greg Horn for the pull request.++ * Improve implementation of 'svExp' to match that of '.^', making+ it more defined when the exponent is constant. Thanks to Brian+ Huffman for the patch.++ * Export the underlying polynomial representation for algorithmic+ reals from the Internals module for further user processing.+ Thanks to Jan Path for the patch.++### Version 7.6, 2018-03-18++ * GHC 8.4.1 compatibility: Work around compilation issues. SBV+ now compiles cleanly with GHC 8.4.1.++ * Define and export sWordN, sWordN_, sIntN_, from the Dynamic+ interface, which simplifies creation of variables of arbitrary+ bit sizes. These are similar to sWord8, sInt8, etc.; except+ they create dynamic counterparts that can be of arbitrary bit size.++### Version 7.5, 2018-01-13++ * Remove obsolete references to tactics in a few haddock comments. Thanks+ to Matthew Pickering for reporting.++ * Added logic Logic_NONE, to be used in cases where SBV should not+ try to set the logic. This is useful when there is no viable value to+ set, and the back-end solver doesn't understand the SMT-Lib convention+ of using "ALL" as the logic name. (One example of this is the Yices+ solver.)++ * SBV now returns SMTException (instead of just calling error) in case+ the backend solver responds with error message. The type SMTException+ can be caught by the user programs, and it includes many fields as an+ indication of what went wrong. (The command sent, what was expected,+ what was seen, etc.) Note that if this exception is ever caught, the+ backend solver is no longer alive: You should either just throw it,+ or perform proper clean-up on your user code as required to set up+ a new context. The provided show instance formats the exception nicely+ for display purposes. See http://github.com/LeventErkok/sbv/issues/335+ for details and thanks to Brian Huffman for reporting.++ * SIntegral class now has Integral as a super-class, which ensures the+ base-type it's used at is Integral. This was already true for all instances,+ so we are just making it more explicit.++ * Improve the implementation of .^ (exponentiation) to cover more cases,+ in particular signed exponents are now OK so long as they are concrete+ and positive, following Haskell convention.++ * Removed the 'FromBits' class. Its functionality is now merged with the+ new 'SFiniteBits' class, see below.++ * Introduce 'SFiniteBits' class, which only incorporates finite-words in it,+ i.e., SWord/SInt for 8-16-32-64. In particular it leaves out SInteger,+ SFloat, SDouble, and SReal. Important in recognizing bit-vectors of+ finite size, essentially. Here are the methods:++ class (SymWord a, Num a, Bits a) => SFiniteBits a where+ sFiniteBitSize :: SBV a -> Int -- ^ Bit size+ lsb :: SBV a -> SBool -- ^ Least significant bit of a word, always stored at index 0.+ msb :: SBV a -> SBool -- ^ Most significant bit of a word, always stored at the last position.+ blastBE :: SBV a -> [SBool] -- ^ Big-endian blasting of a word into its bits. Also see the 'FromBits' class.+ blastLE :: SBV a -> [SBool] -- ^ Little-endian blasting of a word into its bits. Also see the 'FromBits' class.+ fromBitsBE :: [SBool] -> SBV a -- ^ Reconstruct from given bits, given in little-endian+ fromBitsLE :: [SBool] -> SBV a -- ^ Reconstruct from given bits, given in little-endian+ sTestBit :: SBV a -> Int -> SBool -- ^ Replacement for 'testBit', returning 'SBool' instead of 'Bool'+ sExtractBits :: SBV a -> [Int] -> [SBool] -- ^ Variant of 'sTestBit', where we want to extract multiple bit positions.+ sPopCount :: SBV a -> SWord8 -- ^ Variant of 'popCount', returning a symbolic value.+ setBitTo :: SBV a -> Int -> SBool -> SBV a -- ^ A combo of 'setBit' and 'clearBit', when the bit to be set is symbolic.+ fullAdder :: SBV a -> SBV a -> (SBool, SBV a) -- ^ Full adder, returns carry-out from the addition. Only for unsigned quantities.+ fullMultiplier :: SBV a -> SBV a -> (SBV a, SBV a) -- ^ Full multiplier, returns both high and low-order bits. Only for unsigned quantities.+ sCountLeadingZeros :: SBV a -> SWord8 -- ^ Count leading zeros in a word, big-endian interpretation+ sCountTrailingZeros :: SBV a -> SWord8 -- ^ Count trailing zeros in a word, big-endian interpretation++ Note that the functions 'sFiniteBitSize', 'sCountLeadingZeros', and 'sCountTrailingZeros' are+ new. Others have existed in SBV before, we are just grouping them together now in this new class.++ * Tightened certain signatures where SBV was too liberal, using the SFiniteBits class. New signatures are:++ sSignedShiftArithRight :: (SFiniteBits a, SIntegral b) => SBV a -> SBV b -> SBV a+ crc :: (SFiniteBits a, SFiniteBits b) => Int -> SBV a -> SBV b -> SBV b+ readSTree :: (SFiniteBits i, SymWord e) => STree i e -> SBV i -> SBV e+ writeSTree :: (SFiniteBits i, SymWord e) => STree i e -> SBV i -> SBV e -> STree i e++ Thanks to Thomas DuBuisson for reporting.++### Version 7.4, 2017-11-03++ * Export queryDebug from the Control module, allowing custom queries to print+ debugging messages with the verbose flag is set.++ * Relax value-parsing to allow for non-standard output from solvers. For+ instance, MathSAT/Yices prints reals as integers when they do not have a+ fraction. We now support such cases, relaxing the standard slightly. Thanks+ to Geoffrey Ramseyer for reporting.++ * Fix optimization routines when applied to signed-bitvector goals. Thanks+ to Anders Kaseorg for reporting. Since SMT-Lib does not distinguish between+ signed and unsigned bit-vectors, we have to be careful when expressing goals+ that are over signed values. See http://github.com/LeventErkok/sbv/issues/333+ for details.++### Version 7.3, 2017-09-06++ * Query mode: Add support for arrays in query mode. Thanks to Brad Hardy for+ providing the use-case and debugging help.++ * Query mode: Add support for tables. (As used by 'select' calls.)++### Version 7.2, 2017-08-29++ * Reworked implementation of shifts and rotates: When a signed quantity was+ being shifted right by more than its size, SBV used to return 0. Robert Dockins pointed+ out that the correct answer is actually -1 in such cases. The new implementation+ merges the dynamic and typed interfaces, and drops support for non-constant shifts+ of unbounded integers, which is not supported by SMTLib. Thanks to Robert for+ reporting the issue and identifying the root cause.++ * Rework how quantifiers are handled: We now generate separate asserts for+ prefix-existentials. This allows for better (smaller) quantified code, while+ preserving semantics.++ * Rework the interaction between quantifiers and optimization routines.+ Optimization routines now properly handle quantified formulas, so long as the+ quantified metric does not involve any universal quantification itself. Thanks+ to Matthew Danish for reporting the issue.++ * Development/Infrastructure: Lots of work around the continuous integration+ for SBV. We now build/test on Linux/Mac/Windows on every commit. Thanks to+ Travis/Appveyor for providing free remote infrastructure. There are still+ gotchas and some reductions in tests due to host capacity issues. If you+ would like to be involved and improve the test suite, please get in touch!++### Version 7.1, 2017-07-29++ * Add support for 'getInterpolant' in Query mode.++ * Support for SMT-results that can contain multi-line strings, which+ is rare but it does happen. Previously SBV incorrectly interpreted such+ responses to be erroneous.++ * Many improvements to build infrastructure and code clean-up.++ * Fix a bug in the implementation of `svSetBit`. Thanks to Robert Dockins+ for the report.++### Version 7.0, 2017-07-19++ * NB. SBV now requires GHC >= 8.0.1 to compile. If you are stuck with an older+ version of GHC, please get in contact.++ * This is a major rewrite of the internals of SBV, and is a backwards compatibility+ breaking release. While we kept the top-level and most commonly used APIs the+ same (both types and semantics), much of the internals and advanced features+ have been rewritten to move SBV to a new model of execution: SBV no longer+ runs your program symbolically and calls the SMT solver afterwards. Instead,+ the interaction with the solver happens interleaved with the actual program execution.+ The motivation is to allow the end-users to send/receive arbitrary SMTLib+ commands to the solver, instead of the cooked-up recipes. SBV still provides+ all the recipes for its existing functionality, but users can now interact+ with the solver directly. See the module `Data.SBV.Control` for the main+ API, together with the new functions 'runSMT' and 'runSMTWith'.++ * The 'Tactic' based solver control (introduced in v6.0) is completely removed, and+ is replaced by the above described mechanism which gives the user a lot of+ flexibility instead. Use queries for anything that required a tactic before.++ * The call 'allSat' has been reworked so it performs only one call to the underlying+ solver and repeatedly issues check-sat to get new assignments. This differs from the+ previous implementation where we spun off a new call to the executable for each+ successive model. While this is more efficient and much more preferable, it also+ means that the results are no longer lazily computed: If there is an infinite number+ of solutions (or a very large number), you can no longer merely do a 'take' on the result.+ While this is inconvenient, it fits better with our new methodology of query based+ interaction. Note that the old behavior can be modeled, if required, by the user; by explicitly+ interleaving the calls to 'sat.' Furthermore, we now provide a new configuration+ parameter named 'allSatMaxModelCount' which can be used to limit the number models we+ seek. The default is to get all models, however long that might take.++ * The Bridge modules (`Data.SBV.Bridge.Yices`, `Data.SBV.Bridge.Z3`) etc. are+ all removed. The bridge functionality was hardly used, where different solvers+ were much easier to access using the `with` functions. (Such as `proveWith`,+ `satWith` etc.) This should result in no loss of functionality, except for+ occasional explicit mention of solvers in your code, if you were using+ bridge modules to start with.++ * Optimization routines have been changed to take a priority as an argument, (i.e.,+ Lexicographic, Independent, etc.). The old method of supplying the priority+ via tactics is no longer supported.++ * Pareto-front extraction has been reworked, reflecting the changes in Z3 for+ this functionality. Since pareto-fronts can be infinite in number, the user+ is now allowed to specify a "limit" to stop the solver from querying ad+ infinitum. If the limit is not specified, then sbv will query till it+ exhausts all the pareto-fronts, or till it runs out of memory in case there+ is an infinite number of them.++ * Extraction of unsat-cores has changed. To use this feature, we now use+ custom queries. See `Data.SBV.Examples.Misc.UnsatCore` for an example.+ Old style of unsat-core extraction is no longer supported.++ * The 'timing' option of SMTConfig has been reworked. Since we now start the+ solver immediately, it is no longer sensible to distinguish between "SBV" time,+ "translation" time etc. Instead, we print one simple "Elapsed" time if requested.+ If you need a detailed timing analysis, use the new 'transcript' option to+ SMTConfig: It will produce a file with precise timing intervals for each+ command issued to help you figure out how long each step took.++ * The following functions have been reworked, so they now also return+ the time-elapsed for each solver:++ satWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, NominalDiffTime, SatResult)]+ satWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, NominalDiffTime, SatResult)+ proveWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, NominalDiffTime, ThmResult)]+ proveWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, NominalDiffTime, ThmResult)++ * Changed the way `satWithAny` and `proveWithAny` works. Previously, these+ two functions ran multiple solvers, and took the result of the first+ one to finish, killing all the others. In addition, they *waited* for+ the still-running solvers to finish cleaning-up, as sending a 'ThreadKilled'+ is usually not instantaneous. Furthermore, a solver might simply take+ its time! We now send the interrupt but do not wait for the process to+ actually terminate. In rare occasions this could create zombie processes+ if you use a solver that is not cooperating, but we have seen not insignificant+ speed-ups for regular usage due to ThreadKilled wait times being rather long.++ * Configuration option `useLogic` is removed. If required, this should+ be done by a call to the new 'setLogic' function:++ setLogic QF_NRA++ * Configuration option `timeOut` is removed. This was rarely used, and the solver+ support was rather sketchy. We now have a better mechanism in the query mode+ for timeouts, where it really matters. Please get in touch if you relied on+ this old mechanism. Correspondingly, the functions `isTheorem`, `isSatisfiable`,+ `isTheoremWith` and `isSatisfiableWith` had their time-out arguments removed+ and return types simplified.++ * The function 'isSatisfiableInCurrentPath' is removed. Proper queries should be used+ for what this function tentatively attempted to provide. Please get in touch+ if you relied on this function and want to restructure your code to use proper queries.++ * Configuration option 'smtFile' is removed. Instead use 'transcript' now, which+ provides a much more detailed output that is directly loadable to a solver+ and has an accurate account of precisely what SBV sent.++ * Enumerations are now much easier to use symbolically, with the addition+ of the template-haskell splice mkSymbolicEnumeration. See `Data/SBV/Examples/Misc/Enumerate.hs`+ for an example.++ * Thanks to Kanishka Azimi, our external test suite is now run by+ Tasty! Kanishka modernized the test suite, and reworked the+ infrastructure that was showing its age. Thanks!++ * The function pConstrain and the Data.SBV.Tools.ExpectedValue are+ removed. Probabilistic constraints were rarely used, and if+ necessary can be implemented outside of SBV. If you were using+ this feature, please get in contact.++ * SArray and SFunArray has been reworked, and they no longer take+ and initial value. Similarly resetArray has been removed, as it+ did not really do what it advertised. If an initial value is needed,+ it is best to code this explicitly in your model.++### Version 6.1, 2017-05-26++ * Add support for unsat-core extraction. To use this feature, use+ the `namedConstraint` function:++ namedConstraint :: String -> SBool -> Symbolic ()++ to associate a label to a constrain or a boolean term that+ can later be labeled by the backend solver as belonging to the+ unsat-core.++ Unsat-cores are not enabled by default since they can be+ expensive; to use:++ satWith z3{getUnsatCore=True} $ do ...++ In the programmatic API, the function:++ extractUnsatCore :: Modelable a => a -> Maybe [String]++ can be used to programmatically extract the unsat-core. Note that+ backend solvers will only include the named expressions in the unsat-core,+ i.e., any unnamed yet part-of-the-core-unsat expressions will be missing;+ as speculated in the SMT-Lib document itself.++ Currently, Z3, MathSAT, and CVC4 backends support unsat-cores.++ (Thanks to Rohit Ramesh for the suggestion leading to this feature.)++ * Added function `distinct`, which returns true if all the elements of the+ given list are different. This function replaces the old `allDifferent`+ function, which is now removed. The difference is that `distinct` will produce+ much better code for SMT-Lib. If you used `allDifferent` before, simply+ replacing it with `distinct` should work.++ * Add support for pseudo-boolean operations:++ pbAtMost :: [SBool] -> Int -> SBool+ pbAtLeast :: [SBool] -> Int -> SBool+ pbExactly :: [SBool] -> Int -> SBool+ pbLe :: [(Int, SBool)] -> Int -> SBool+ pbGe :: [(Int, SBool)] -> Int -> SBool+ pbEq :: [(Int, SBool)] -> Int -> SBool+ pbMutexed :: [SBool] -> SBool+ pbStronglyMutexed :: [SBool] -> SBool++ These functions, while can be directly coded in SBV, produce better+ translations to SMTLib for more efficient solving of cardinality constraints.+ Currently, only Z3 supports pseudo-booleans directly. For all other solvers,+ SBV will translate these to equivalent terms that do not require special+ functions.++ * The function getModel has been renamed to getAssignment. (The former name is+ now available as a query command.)++ * Export `SolverCapabilities` from `Data.SBV.Internals`, in case users want access.++ * Move code-generation facilities to `Data.SBV.Tools.CodeGen`, no longer exporting+ the relevant functions directly from `Data.SBV`. This could break existing code,+ but the fix should be as simple as `import Data.SBV.Tools.CodeGen`.++ * Move the following two functions to `Data.SBV.Internals`:++ compileToSMTLib+ generateSMTBenchmarks++ If you use them, please `import Data.SBV.Internals`.++ * Reorganized `EqSymbolic` and `EqOrd` classes to collect some of the+ similarly named function together. Users should see no impact due to this change.+++### Version 6.0, 2017-05-07++ * This is a backwards compatibility breaking release, hence the major version+ bump from 5.15 to 6.0:++ - Most of existing code should work with no changes.+ - Old code relying on some features might require extra imports,+ since we no longer export some functionality directly from `Data.SBV`.+ This was done in order to reduce the number of exported items to+ avoid extra clutter.+ - Old optimization features are removed, as the new and much improved+ capabilities should be used instead.++ * The next two bullets cover new features in SBV regarding optimization, based+ on the capabilities of the z3 SMT solver. With this release SBV gains the+ capability optimize objectives, and solve MaxSAT problems; by appropriately+ employing the corresponding capabilities in z3. A good review of these features+ as implemented by Z3, and thus what is available in SBV is given in this+ paper: http://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/nbjorner-scss2014.pdf++ * SBV now allows for real or integral valued metrics. Goals can be lexicographically+ (default), independently, or pareto-front optimized. Currently, only the z3 backend+ supports optimization routines.++ Optimization can be done over bit-vector, real, and integer goals. The relevant+ functions are:++ - `minimize`: Minimize a given arithmetic goal+ - `maximize`: Minimize a given arithmetic goal++ For instance, a call of the form++ minimize "name-of-goal" $ x + 2*y++ Minimizes the arithmetic goal x+2*y, where x and y can be bit-vectors, reals,+ or integers. Such goals will be lexicographically optimized, i.e., in the order+ given. If there are multiple goals, then user can also ask for independent+ optimization results, or pareto-fronts.++ Once the objectives are given, a top level call to `optimize` (similar to `prove`+ and `sat`) performs the optimization.++ * SBV now implements soft-asserts. A soft assertion is a hint to the SMT solver that+ we would like a particular condition to hold if *possible*. That is, if there is+ a solution satisfying it, then we would like it to hold. However, if the set of+ constraints is unsatisfiable, then a soft-assertion can be violated by incurring+ a user-given numeric penalty to satisfy the remaining constraints. The solver then+ tries to minimize the penalty, i.e., satisfy as many of the soft-asserts as possible+ such that the total penalty for those that are not satisfied is minimized.++ Note that `assertSoft` works well with optimization goals (minimize/maximize etc.),+ and are most useful when we are optimizing a metric and thus some of the constraints+ can be relaxed with a penalty to obtain a good solution.++ * SBV no longer provides the old optimization routines, based on iterative and quantifier+ based methods. Those methods were rarely used, and are now superseded by the above+ mechanism. If the old code is needed, please contact for help: They can be resurrected+ in your own code if absolutely necessary.++ * (NB. This feature is deprecated in 7.0, see above for its replacement.)+ SBV now implements tactics, which allow the user to navigate the proof process.+ This is an advanced feature that most users will have no need of, but can become+ handy when dealing with complicated problems. Users can, for instance, implement+ case-splitting in a proof to guide the underlying solver through. Here is the list+ of tactics implemented:++ - `CaseSplit` : Case-split, with implicit coverage. Bool says whether we should be verbose.+ - `CheckCaseVacuity` : Should the case-splits be checked for vacuity? (Default: True.)+ - `ParallelCase` : Run case-splits in parallel. (Default: Sequential.)+ - `CheckConstrVacuity`: Should constraints be checked for vacuity? (Default: False.)+ - `StopAfter` : Time-out given to solver, in seconds.+ - `CheckUsing` : Invoke with check-sat-using command, instead of check-sat+ - `UseLogic` : Use this logic, a custom one can be specified too+ - `UseSolver` : Use this solver (z3, yices, etc.)+ - `OptimizePriority` : Specify priority for optimization: Lexicographic (default), Independent, or Pareto.++ * Name-space clean-up. The following modules are no longer automatically exported+ from Data.SBV:++ - `Data.SBV.Tools.ExpectedValue` (computing with expected values)+ - `Data.SBV.Tools.GenTest` (test case generation)+ - `Data.SBV.Tools.Polynomial` (polynomial arithmetic, CRCs etc.)+ - `Data.SBV.Tools.STree` (full symbolic binary trees)++ To use the functionality of these modules, users must now explicitly import the corresponding+ module. Not other changes should be needed other than the explicit import.++ * Changed the signatures of:++ isSatisfiableInCurrentPath :: SBool -> Symbolic Bool+ svIsSatisfiableInCurrentPath :: SVal -> Symbolic Bool++ to:++ isSatisfiableInCurrentPath :: SBool -> Symbolic (Maybe SatResult)+ svIsSatisfiableInCurrentPath :: SVal -> Symbolic (Maybe SatResult)++ which returns the result in case of SAT. This is more useful than before. This is+ backwards-compatibility breaking, but is more useful. (Requested by Jared Ziegler.)++ * Add instance `Provable (Symbolic ())`, which simply stands for returning true+ for proof/sat purposes. This allows for simpler coding, as constrain/minimize/maximize+ calls (which return unit) can now be directly sat/prove processed, without needing+ a final call to return at the end.++ * Add type synonym `Goal` (for `Symbolic ()`), in order to simplify type signatures++ * SBV now properly adds check-sat commands and other directives in debugging output.++ * New examples:+ - Data.SBV.Examples.Optimization.LinearOpt: Simple linear-optimization example.+ - Data.SBV.Examples.Optimization.Production: Scheduling machines in a shop+ - Data.SBV.Examples.Optimization.VM: Scheduling virtual-machines in a data-center++### Version 5.15, 2017-01-30++ * Bump up dependency on CrackNum >= 1.9, to get access to hexadecimal floats.+ * Improve time/tracking-print code. Thanks to Iavor Diatchki for the patch.++### Version 5.14, 2017-01-12++ * Bump up QuickCheck dependency to >= 2.9.2 to avoid the following quick-check+ bug <http://github.com/nick8325/quickcheck/issues/113>, which transitively impacted+ the quick-check as implemented by SBV.++ * Generalize casts between integral-floats, using the rounding mode round-nearest-ties-to-even.+ Previously calls to sFromIntegral did not support conversion to floats since it needed+ a rounding mode. But it does make sense to support them with the default mode. If a different+ mode is needed, use the function 'toSFloat' as before, which takes an explicit rounding mode.++### Version 5.13, 2016-10-29++ * Fix broken links, thanks to Stephan Renatus for the patch.++ * Code generation: Create directory path if it does not exist. Thanks to Robert Dockins+ for the patch.++ * Generalize the type of sFromIntegral, dropping the Bits requirement. In turn, this+ allowed us to remove sIntegerToSReal, since sFromIntegral can be used instead.++ * Add support for sRealToSInteger. (Essentially the floor function for SReal.)++ * Several space-leaks fixed for better performance. Patch contributed by Robert Dockins.++ * Improved Random instance for Rational. Thanks to Joe Leslie-Hurd for the idea.++### Version 5.12, 2016-06-06++ * Fix GHC8.0 compilation issues, and warning clean-up. Thanks to Adam Foltzer for the bulk+ of the work and Tom Sydney Kerckhove for the initial patch for 8.0 compatibility.++ * Minor fix to printing models with floats when the base is 2/16, making sure the alignment+ is done properly accommodating for the crackNum output.++ * Wait for external process to die on exception, to avoid spawning zombies. Thanks to+ Daniel Wagner for the patch.++ * Fix hash-consed arrays: Previously we were caching based only on elements, which is not+ sufficient as you can have conflicts differing only on the address type, but same contents.+ Thanks to Brian Huffman for reporting and the corresponding patch.++### Version 5.11, 2016-01-15++ * Fix documentation issue; no functional changes++### Version 5.10, 2016-01-14++ * Documentation: Fix a bunch of dead http links. Thanks to Andres Sicard-Ramirez+ for reporting.++ * Additions to the Dynamic API:++ * svSetBit : set a given bit+ * svBlastLE, svBlastBE : Bit-blast to big/little endian+ * svWordFromLE, svWordFromBE: Unblast from big/little endian+ * svAddConstant : Add a constant to an SVal+ * svIncrement, svDecrement : Add/subtract 1 from an SVal++### Version 5.9, 2016-01-05++ * Default definition for 'symbolicMerge', which allows types that are+ instances of 'Generic' to have an automatically derivable merge (i.e.,+ ite) instance. Thanks to Christian Conkle for the patch.++ * Add support for "non-model-vars," where we can now tell SBV not+ to take into account certain variables from a model-building+ perspective. This comes handy in doing an `allSat` calls where+ there might be witness variables that we do not care the uniqueness+ for. See `Data/SBV/Examples/Misc/Auxiliary.hs` for an example, and+ the discussion in http://github.com/LeventErkok/sbv/issues/208 for+ motivation.++ * Yices interface: If Reals are used, then pick the logic QF_UFLRA, instead+ of QF_AUFLIA. Unfortunately, logic selection remains tricky since the SMTLib+ story for logic selection is rather messy. Other solvers are not impacted+ by this change.++### Version 5.8, 2016-01-01++ * Fix some typos+ * Add 'svEnumFromThenTo' to the Dynamic interface, allowing dynamic construction+ of [x, y .. z] and [x .. y] when the involved values are concrete.+ * Add 'svExp' to the Dynamic interface, implementing exponentiation++### Version 5.7, 2015-12-21++ * Export `HasKind(..)` from the Dynamic interface. Thanks to Adam Foltzer for the patch.+ * More careful handling of SMT-Lib reserved names.+ * Update tested version of MathSAT to 5.3.9+ * Generalize `sShiftLeft`/`sShiftRight`/`sRotateLeft`/`sRotateRight` to work with signed+ shift/rotate amounts, where negative values revert the direction. Similar+ generalizations are also done for the dynamic variants.++### Version 5.6, 2015-12-06++ * Minor changes to how we print models:+ * Align by the type+ * Always print the type (previously we were skipping for Bool)++ * Rework how SBV properties are quick-checked; much more usable and robust++ * Provide a function `sbvQuickCheck`, which is essentially the same as+ quickCheck, except it also returns a boolean. Useful for the+ programmable API. (The dynamic version is called `svQuickCheck`.)++ * Several changes/additions in support of the sbvPlugin development:+ * Data.SBV.Dynamic: Define/export `svFloat`/`svDouble`/`sReal`/`sNumerator`/`sDenominator`+ * Data.SBV.Internals: Export constructors of `Result`, `SMTModel`,+ and the function `showModel`+ * Simplify how Uninterpreted-types are internally represented.++### Version 5.5, 2015-11-10++ * This is essentially the same release as 5.4 below, except to allow SBV compile+ with GHC 7.8 series. Thanks to Adam Foltzer for the patch.++### Version 5.4, 2015-11-09++ * Add 'sAssert', which allows users to pepper their code with boolean conditions, much like+ the usual ASSERT calls. Note that the semantics of an 'sAssert' is that it is a NOOP, i.e.,+ it simply returns its final argument. Use in coordination with 'safe' and 'safeWith', see below.++ * Implement 'safe' and 'safeWith', which statically determine all calls to 'sAssert'+ being safe to execute. Any violations will be flagged.++ * SBV->C: Translate 'sAssert' calls to dynamic checks in the generated C code. If this is+ not desired, use the 'cgIgnoreSAssert' function to turn it off.++ * Add 'isSafe': Which converts a 'SafeResult' to a 'Bool', when we are only interested+ in a boolean result.++ * Add Data/SBV/Examples/Misc/NoDiv0 to demonstrate the use of the 'safe' function.++### Version 5.3, 2015-10-20++ * Main point of this release to make SBV compile with GHC 7.8 again, to accommodate mainly+ for Cryptol. As Cryptol moves to GHC >= 7.10, we intend to remove the "compatibility" changes+ again. Thanks to Adam Foltzer for the patch.++ * Minor mods to how bitvector equality/inequality are translated to SMTLib. No user visible+ impact.++### Version 5.2, 2015-10-12++ * Regression on 5.1: Fix a minor bug in base 2/16 printing where uninterpreted constants were+ not handled correctly.++### Version 5.1, 2015-10-10++ * fpMin, fpMax: If these functions receive +0/-0 as their two arguments, i.e., both+ zeros but alternating signs in any order, then SMTLib requires the output to be+ nondeterministically chosen. Previously, we fixed this result as +0 following the+ interpretation in Z3, but Z3 recently changed and now incorporates the nondeterministic+ output. SBV similarly changed to allow for non-determinism here.++ * Change the types of the following Floating-point operations:++ * sFloatAsSWord32, sFloatAsSWord32, blastSFloat, blastSDouble++ These were previously coded as relations, since NaN values were not representable+ in the target domain uniquely. While it was OK, it was hard to use them. We now+ simply implement these as functions, and they are underspecified if the inputs+ are NaNs: In those cases, we simply get a symbolic output. The new types are:++ * sFloatAsSWord32 :: SFloat -> SWord32+ * sDoubleAsSWord64 :: SDouble -> SWord64+ * blastSFloat :: SFloat -> (SBool, [SBool], [SBool])+ * blastSDouble :: SDouble -> (SBool, [SBool], [SBool])++ * MathSAT backend: Use the SMTLib interpretation of fp.min/fp.max by passing the+ "-theory.fp.minmax_zero_mode=4" argument explicitly.++ * Fix a bug in hash-consing of floating-point constants, where we were confusing +0 and+ -0 since we were using them as keys into the map though they compare equal. We now+ explicitly keep track of the negative-zero status to make sure this confusion does+ not arise. Note that this bug only exhibited itself in rare occurrences of both+ constants being present in a benchmark; a true corner case. Note that @NaN@ values+ are also interesting in this context: Since NaN /= NaN, we never hash-cons floating+ point constants that have the value NaN. But that is actually OK; it is a bit wasteful+ in case you have a lot of NaN constants around, but there is no soundness issue: We+ just waste a little bit of space.++ * Remove the functions `allSatWithAny` and `allSatWithAll`. These two variants do *not*+ make sense when run with multiple solvers, as they internally sequentialize the solutions+ due to the nature of `allSat`. Not really needed anyhow; so removed. The variants+ `satWithAny/All` and `proveWithAny/All` are still available.++ * Export SMTLibVersion from the library, forgotten export needed by Cryptol. Thanks to Adam+ Foltzer for the patch.++ * Slightly modify model-outputs so the variables are aligned vertically. (Only matters+ if we have model-variable names that are of differing length.)++ * Move to Travis-CI "docker" based infrastructure for builds++ * Enable local builds to use the Herbie plugin. Currently SBV does not have any+ expressions that can benefit from Herbie, but it is nice to have this support in general.++### Version 5.0, 2015-09-22++ * Note: This is a backwards-compatibility breaking release, see below for details.++ * SBV now requires GHC 7.10.1 or newer to be compiled, taking advantage of newer features/bug-fixes+ in GHC. If you really need SBV to compile with older GHCs, please get in touch.++ * SBV no longer supports SMTLib1. We now exclusively use SMTLib2 for communicating with backend+ solvers. Strictly speaking, this means some loss in functionality: Uninterpreted-function models+ that we supported via Yices-1 are no longer available. In practice this facility was not really+ used, and required a very old version of Yices that was no longer supported by SRI and has+ lacked in other features. So, in reality this change should hardly matter for end-users.++ * Added function `label`, which is useful in emitting comments around expressions. It is essentially+ a no-op, but does generate a comment with the given text in the SMT-Lib and C output, for diagnostic+ purposes.++ * Added `sFromIntegral`: Conversions from all integral types (SInteger, SWord/SInts) between+ each other. Similar to the `fromIntegral` function of Haskell. These generate simple casts when+ used in code-generation to C, and thus are very efficient.++ * SBV no longer supports the functions sBranch/sAssert, as we realized these functions can cause+ soundness issues under certain conditions. While the triggering scenarios are not common use-cases+ for these functions, we are opting for safety, and thus removing support. See+ http://github.com/LeventErkok/sbv/issues/180 for details; and see below for the new function+ 'isSatisfiableInCurrentPath'.++ * A new function 'isSatisfiableInCurrentPath' is added, which checks for satisfiability during a+ symbolic simulation run. This function can be used as the basis of sBranch/sAssert like functionality+ if needed. The difference is that this is a much lower level call, and also exposes the fact that+ the result is in the 'Symbolic' monad (which avoids the soundness issue). Of course, the new type+ makes it less useful as it will not be a drop-in replacement for if-then-else like structure. Intended+ to be used by tools built on top of SBV, as opposed to end-users.++ * SBV no longer implements the 'SignCast' class, as its functionality is replaced by the 'sFromIntegral'+ function. Programs using the functions 'signCast' and 'unsignCast' should simply replace both+ with calls to 'sFromIntegral'. (Note that extra type-annotations might be necessary, similar to+ the uses of the 'fromIntegral' function in Haskell.)++ * Backend solver related changes:++ * Yices: Upgraded to work with Yices release 2.4.1. Note that earlier versions of Yices+ are *not* supported.++ * Boolector: Upgraded to work with new Boolector release 2.0.7. Note that earlier versions+ of Boolector are *not* supported.++ * MathSAT: Upgraded to work with latest release 5.3.7. Note that earlier versions of MathSAT+ are *not* supported (due to a buffering issue in MathSAT itself.)++ * MathSAT: Enabled floating-point support in MathSAT.++ * New examples:++ * Add Data.SBV.Examples.Puzzles.Birthday, which solves the Cheryl-Birthday problem that+ went viral in April 2015. Turns out really easy to solve for SMT, but the formalization+ of the problem is still interesting as an exercise in formal reasoning.++ * Add Data.SBV.Examples.Puzzles.SendMoreMoney, which solves the classic send + more = money+ problem. Really a trivial example, but included since it is pretty much the hello-world for+ basic constraint solving.++ * Add Data.SBV.Examples.Puzzles.Fish, which solves a typical logic puzzle; finding the unique+ solution to a set of assertions made about a bunch of people, their pets, beverage choices,+ etc. Not particularly interesting, but could be fun to play around with for modeling purposes.++ * Add Data.SBV.Examples.BitPrecise.MultMask, which demonstrates the use of the bitvector+ solver to an interesting bit-shuffling problem.++ * Rework floating-point arithmetic, and add missing floating-point operations:++ * fpRem : remainder+ * fpRoundToIntegral: truncating round+ * fpMin : min+ * fpMax : max+ * fpIsEqualObject : FP equality as object (i.e., NaN equals NaN, +0 does not equal -0, etc.)++ This brings SBV up-to par with everything supported by the SMT-Lib FP theory.++ * Add the IEEEFloatConvertable class, which provides conversions to/from Floats and other types. (i.e.,+ value conversions from all other types to Floats and Doubles; and back.)++ * Add SWord32/SWord64 to/from SFloat/SDouble conversions, as bit-pattern reinterpretation; using the+ IEEE754 interchange format. The functions are: sWord32AsSFloat, sWord64AsSDouble, sFloatAsSWord32,+ sDoubleAsSWord64. Note that the sWord32AsSFloat and sWord64ToSDouble are regular functions, but+ sFloatToSWord32 and sDoubleToSWord64 are "relations", since NaN values are not uniquely convertible.++ * Add 'sExtractBits', which takes a list of indices to extract bits from, essentially+ equivalent to 'map sTestBit'.++ * Rename a set of symbolic functions for consistency. Here are the old/new names:++ * sbvTestBit --> sTestBit+ * sbvPopCount --> sPopCount+ * sbvShiftLeft --> sShiftLeft+ * sbvShiftRight --> sShiftRight+ * sbvRotateLeft --> sRotateLeft+ * sbvRotateRight --> sRotateRight+ * sbvSignedShiftArithRight --> sSignedShiftArithRight++ * Rename all FP recognizers to be in sync with FP operations. Here are the old/new names:++ * isNormalFP --> fpIsNormal+ * isSubnormalFP --> fpIsSubnormal+ * isZeroFP --> fpIsZero+ * isInfiniteFP --> fpIsInfinite+ * isNaNFP --> fpIsNaN+ * isNegativeFP --> fpIsNegative+ * isPositiveFP --> fpIsPositive+ * isNegativeZeroFP --> fpIsNegativeZero+ * isPositiveZeroFP --> fpIsPositiveZero+ * isPointFP --> fpIsPoint++ * Lots of other work around floating-point, test cases, reorg, etc.++ * Introduce shorter variants for rounding modes: sRNE, sRNA, sRTP, sRTN, sRTZ;+ aliases for sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive,+ sRoundTowardNegative, and sRoundTowardZero; respectively.++### Version 4.4, 2015-04-13++ * Hook-up crackNum package; so counter-examples involving floats and+ doubles can be printed in detail when the printBase is chosen to be+ 2 or 16. (With base 10, we still get the simple output.)++ ```+ Prelude Data.SBV> satWith z3{printBase=2} $ \x -> x .== (2::SFloat)+ Satisfiable. Model:+ s0 = 2.0 :: Float+ 3 2 1 0+ 1 09876543 21098765432109876543210+ S ---E8--- ----------F23----------+ Binary: 0 10000000 00000000000000000000000+ Hex: 4000 0000+ Precision: SP+ Sign: Positive+ Exponent: 1 (Stored: 128, Bias: 127)+ Value: +2.0 (NORMAL)+ ```++ * Change how we print type info; for models instead of SType just print Type (i.e.,+ for SWord8, instead print Word8) which makes more sense and is more consistent.+ This change should be mostly relevant as how we see the counter-example output.++ * Fix long standing bug #75, where we now support arrays with Boolean source/targets.+ This is not a very commonly used case, but by letting the solver pick the logic,+ we now allow arrays to be uniformly supported.++### Version 4.3, 2015-04-10++ * Introduce Data.SBV.Dynamic, by Brian Huffman. This is mostly an internal+ reorg of the SBV codebase, and end-users should not be impacted by the+ changes. The introduction of the Dynamic SBV variant (i.e., one that does+ not mandate a phantom type as in `SBV Word8` etc. allows library writers+ more flexibility as they deal with arbitrary bit-vector sizes. The main+ customer of these changes are the Cryptol language and the associated+ toolset, but other developers building on top of SBV can find it useful+ as well. NB: The "strongly-typed" aspect of SBV is still the main way+ end-users should interact with SBV, and nothing changed in that respect!++ * Add symbolic variants of floating-point rounding-modes for convenience++ * Rename toSReal to sIntegerToSReal, which captures the intent more clearly++ * Code clean-up: remove mbMinBound/mbMaxBound thus allowing less calls to+ unliteral. Contributed by Brian Huffman.++ * Introduce FP conversion functions:++ * Between SReal and SFloat/SDouble+ * fpToSReal+ * sRealToSFloat+ * sRealToSDouble+ * Between SWord32 and SFloat+ * sWord32ToSFloat+ * sFloatToSWord32+ * Between SWord64 and SDouble. (Relational, due to non-unique NaNs)+ * sWord64ToSDouble+ * sDoubleToSWord64+ * From float to sign/exponent/mantissa fields: (Relational, due to non-unique NaNs)+ * blastSFloat+ * blastSDouble++ * Rework floating point classifiers. Remove isSNaN and isFPPoint (both renamed),+ and add the following new recognizers:++ * isNormalFP+ * isSubnormalFP+ * isZeroFP+ * isInfiniteFP+ * isNaNFP+ * isNegativeFP+ * isPositiveFP+ * isNegativeZeroFP+ * isPositiveZeroFP+ * isPointFP (corresponds to a real number, i.e., neither NaN nor infinity)++ * Re-implement sbvTestBit, by Brian Huffman. This version is much faster at large+ word sizes, as it avoids the costly mask generation.++ * Code changes to suppress warnings with GHC7.10. General clean-up.++### Version 4.2, 2015-03-17++ * Add exponentiation (.^). Thanks to Daniel Wagner for contributing the code!++ * Better handling of SBV_$SOLVER_OPTIONS, in particular keeping track of+ proper quoting in environment variables. Thanks to Adam Foltzer for+ the patch!++ * Silence some hlint/ghci warnings. Thanks to Trevor Elliott for the patch!++ * Haddock documentation fixes, improvements, etc.++ * Change ABC default option string to %blast; "&sweep -C 5000; &syn4; &cec -s -m -C 2000"+ which seems to give good results. Use SBV_ABC_OPTIONS environment variable (or+ via abc.rc file and a combination of SBV_ABC_OPTIONS) to experiment.++### Version 4.1, 2015-03-06++ * Add support for the ABC solver from Berkeley. Thanks to Adam Foltzer+ for the required infrastructure! See: https://github.com/berkeley-abc/abc+ And Alan Mishchenko for adding infrastructure to ABC to work with SBV.++ * Upgrade the Boolector connection to use a SMT-Lib2 based interaction. NB. You+ need at least Boolector 2.0.6 installed!++ * Tracking changes in the SMT-Lib floating-point theory. If you are+ using symbolic floating-point types (i.e., SFloat and SDouble), then+ you should upgrade to this version and also get a very latest (unstable)+ Z3 release. See https://smt-lib.org/theories-FloatingPoint.shtml+ for details.++ * Introduce a new class, 'RoundingFloat', which supports floating-point+ operations with arbitrary rounding-modes. Note that Haskell only allows+ RoundNearestTiesToAway, but with SBV, we get all 5 IEEE754 rounding-modes+ and all the basic operations ('fpAdd', 'fpMul', 'fpDiv', etc.) with these+ modes.++ * Allow Floating-Point RoundingMode to be symbolic as well++ * Improve the example `Data/SBV/Examples/Misc/Floating.hs` to include+ rounding-mode based addition example.++ * Changes required to make SBV compile with GHC 7.10; mostly around instance+ NFData declarations. Thanks to Iavor Diatchki for the patch.++ * Export a few extra symbols from the Internals module (mainly for+ Cryptol usage.)++### Version 4.0, 2015-01-22++This release mainly contains contributions from Brian Huffman, allowing+end-users to define new symbolic types, such as Word4, that SBV does not+natively support. When GHC gets type-level literals, we shall most likely+incorporate arbitrary bit-sized vectors and ints using this mechanism,+but in the interim, this release provides a means for the users to introduce+individual instances.++ * Modifications to support arbitrary bit-sized vectors;+ These changes have been contributed by Brian Huffman+ of Galois. Thanks Brian.+ * A new example `Data/SBV/Examples/Misc/Word4.hs` showing+ how users can add new symbolic types.+ * Support for rotate-left/rotate-right with variable+ rotation amounts. (From Brian Huffman.)++### Version 3.5, 2015-01-15++This release is mainly adding support for enumerated types in Haskell being+translated to their symbolic counterparts; instead of going completely+uninterpreted.++ * Keep track of data-type details for uninterpreted sorts.+ * Rework the U2Bridge example to use enumerated types.+ * The "Uninterpreted" name no longer makes sense with this change, so+ rework the relevant names to ensure proper internal naming.+ * Add Data/SBV/Examples/Misc/Enumerate.hs as an example for demonstrating+ how enumerations are translated.+ * Fix a long-standing bug in the implementation of select when+ translated as SMT-Lib tables. (Github issue #103.) Thanks to+ Brian Huffman for reporting.++### Version 3.4, 2014-12-21++ * This release is mainly addressing floating-point changes in SMT-Lib.++ * Track changes in the QF_FPA logic standard; new constants and alike. If you are+ using the floating-point logic, then you need a relatively new version of Z3+ installed (4.3.3 or newer).++ * Add unary-negation as an explicit operator. Previously, we merely used the "0-x"+ semantics; but with floating point, this does not hold as 0-0 is 0, and is not -0!+ (Note that negative-zero is a valid floating point value, that is different than+ positive-zero; yet it compares equal to it. Sigh..)++ * Similarly, add abs as a native method; to make sure we map it to fp.abs for+ floating point values.++ * Test suite improvements++### Version 3.3, 2014-12-05++ * Implement 'safe' and 'safeWith', which statically determine all calls to 'sAssert'+ being safe to execute. This way, users can pepper their programs with liberal+ calls to 'sAssert' and check they are all safe in one go without further worry.++ * Robustify the interface to external solvers, by making sure we catch cases where+ the external solver might exist but not be runnable (library dependency missing,+ for example). It is impossible to be absolutely foolproof, but we now catch a+ few more cases and fail gracefully.++### Version 3.2, 2014-11-18++ * Implement 'sAssert'. This adds conditional symbolic simulation, by ensuring arbitrary+ boolean conditions hold during simulation; similar to ASSERT calls in other languages.+ Note that failures will be detected at symbolic-simulation time, i.e., each assert will+ generate a call to the external solver to ensure that the condition is never violated.+ If violation is possible the user will get an error, indicating the failure conditions.++ * Also implement 'sAssertCont' which allows for a programmatic way to extract/display results+ for consumers of 'sAssert'. While the latter simply calls 'error' in case of an assertion+ violation, the 'sAssertCont' variant takes a continuation which can be used to program+ how the results should be interpreted/displayed. (This is useful for libraries built on top of+ SBV.) Note that the type of the continuation is such that execution should still stop, i.e.,+ once an assertion violation is detected, symbolic simulation will never continue.++ * Rework/simplify the 'Mergeable' class to make sure 'sBranch' is sufficiently lazy+ in case of structural merges. The original implementation was only+ lazy at the Word instance, but not at lists/tuples etc. Thanks to Brian Huffman+ for reporting this bug.++ * Add a few constant-folding optimizations for 'sDiv' and 'sRem'++ * Boolector: Modify output parser to conform to the new Boolector output format. This+ means that you need at least v2.0.0 of Boolector installed if you want to use that+ particular solver.++ * Fix long-standing translation bug regarding boolean Ord class comparisons. (i.e.,+ 'False > True' etc.) While Haskell allows for this, SMT-Lib does not; and hence+ we have to be careful in translating. Thanks to Brian Huffman for reporting.++ * C code generation: Correctly translate square-root and fusedMA functions to C.++### Version 3.1, 2014-07-12++ New features/bug-fixes in v3.1:++ * Using multiple-SMT solvers in parallel:+ * Added functions that let the user run multiple solvers, using asynchronous+ threads. All results can be obtained (proveWithAll, proveWithAny, satWithAll),+ or SBV can return the fastest result (satWithAny, allSatWithAll, allSatWithAny).+ These functions are good for playing with multiple-solvers, especially on+ machines with multiple-cores.+ * Add function: sbvAvailableSolvers; which returns the list of solvers currently+ available, as installed on the machine we are running. (Not the list that SBV+ supports, but those that are actually available at run-time.) This function+ is useful with the multi-solve API.+ * Implement sBranch:+ * sBranch is a variant of 'ite' that consults the external+ SMT solver to see if a given branch condition is satisfiable+ before evaluating it. This can make certain otherwise recursive+ and thus not-symbolically-terminating inputs amenable to symbolic+ simulation, if termination can be established this way. Needless+ to say, this problem is always decidable as far as SBV programs+ are concerned, but it does not mean the decision procedure is cheap!+ Use with care.+ * sBranchTimeOut config parameter can be used to curtail long runs when+ sBranch is used. Of course, if time-out happens, SBV will+ assume the branch is feasible, in which case symbolic-termination+ may come back to bite you.)+ * New API:+ * Add predicate 'isSNaN' which allows testing 'SFloat'/'SDouble' values+ for nan-ness. This is similar to the Prelude function 'isNaN', except+ the Prelude version requires a RealFrac instance, which unfortunately is+ not currently implementable for cases. (Requires trigonometric functions etc.)+ Thus, we provide 'isSNaN' separately (along with the already existing+ 'isFPPoint') to simplify reasoning with floating-point.+ * Examples:+ * Add Data/SBV/Examples/Misc/SBranch.hs, to illustrate the use of sBranch.+ * Bug fixes:+ * Fix pipe-blocking issue, which exhibited itself in the presence of+ large numbers of variables (> 10K or so). See github issue #86. Thanks+ to Philipp Meyer for the fine report.+ * Misc:+ * Add missing SFloat/SDouble instances for SatModel class+ * Explicitly support KBool as a kind, separating it from `KUnbounded False 1`.+ Thanks to Brian Huffman for contributing the changes. This should have no+ user-visible impact, but comes in handy for internal reasons.++### Version 3.0, 2014-02-16++ * Support for floating-point numbers:+ * Preliminary support for IEEE-floating point arithmetic, introducing+ the types `SFloat` and `SDouble`. The support is still quite new,+ and Z3 is the only solver that currently features a solver for+ this logic. Likely to have bugs, both at the SBV level, and at the+ Z3 level; so any bug reports are welcome!+ * New backend solvers:+ * SBV now supports MathSAT from Fondazione Bruno Kessler and+ DISI-University of Trento. See: http://mathsat.fbk.eu/+ * Support all-sat calls in the presence of uninterpreted sorts:+ * Implement better support for `allSat` in the presence of uninterpreted+ sorts. Previously, SBV simply rejected running `allSat` queries+ in the presence of uninterpreted sorts, since it was not possible+ to generate a refuting model. The model returned by the SMT solver+ is simply not usable, since it names constants that is not visible+ in a subsequent run. Eric Seidel came up with the idea that we can+ actually compute equivalence classes based on a produced model, and+ assert the constraint that the new model should disallow the previously+ found equivalence classes instead. The idea seems to work well+ in practice, and there is also an example program demonstrating+ the functionality: Examples/Uninterpreted/UISortAllSat.hs+ * Programmable model extraction improvements:+ * Add functions `getModelDictionary` and `getModelDictionaries`, which+ provide low-level access to models returned from SMT solvers. Former+ for `sat` and `prove` calls, latter for `allSat` calls. Together with+ the exported utils from the `Data.SBV.Internals` module, this should+ allow for expert users to dissect the models returned and do fancier+ programming on top of SBV.+ * Add `getModelValue`, `getModelValues`, `getModelUninterpretedValue`, and+ `getModelUninterpretedValues`; which further aid in model value+ extraction.+ * Other:+ * Allow users to specify the SMT-Lib logic to use, if necessary. SBV will+ still pick the logic automatically, but users can now override that choice.+ Comes in handy when playing with custom logics.+ * Bug fixes:+ * Address allsat-laziness issue (#78 in github issue tracker). Essentially,+ simplify how all-sat is called so we can avoid calling the solver for+ solutions that are not needed. Thanks to Eric Seidel for reporting.+ * Examples:+ * Add Data/SBV/Examples/Misc/ModelExtract.hs as a simple example for+ programmable model extraction and usage.+ * Add Data/SBV/Examples/Misc/Floating.hs for some FP examples.+ * Use the AUFLIA logic in Examples.Existentials.Diophantine which helps+ z3 complete the proof quickly. (The BV logics take too long for this problem.)++### Version 2.10, 2013-03-22++ * Add support for the Boolector SMT solver+ * See: https://boolector.github.io+ * Use `import Data.SBV.Bridge.Boolector` to use Boolector from SBV+ * Boolector supports QF_BV (with an without arrays). In the last+ SMT-Lib competition it won both bit-vector categories. It is definitely+ worth trying it out for bitvector problems.+ * Changes to the library:+ * Generalize types of `allDifferent` and `allEqual` to take+ arbitrary EqSymbolic values. (Previously was just over SBV values.)+ * Add `inRange` predicate, which checks if a value is bounded within+ two others.+ * Add `sElem` predicate, which checks for symbolic membership+ * Add `fullAdder`: Returns the carry-over as a separate boolean bit.+ * Add `fullMultiplier`: Returns both the lower and higher bits resulting+ from multiplication.+ * Use the SMT-Lib Bool sort to represent SBool, instead of bit-vectors of length 1.+ While this is an under-the-hood mechanism that should be user-transparent, it+ turns out that one can no longer write axioms that return booleans in a direct+ way due to this translation. This change makes it easier to write axioms that+ utilize booleans as there is now a 1-to-1 match. (Suggested by Thomas DuBuisson.)+ * Solvers changes:+ * Z3: Update to the new parameter naming schema of Z3. This implies that+ you need to have a really recent version of Z3 installed, something+ in the Z3-4.3 series.+ * Examples:+ * Add Examples/Uninterpreted/Shannon.hs: Demonstrating Shannon expansion,+ boolean derivatives, etc.+ * Bug-fixes:+ * Gracefully handle the case if the backend-SMT solver does not put anything+ in stdout. (Reported by Thomas DuBuisson.)+ * Handle uninterpreted sort values, if they happen to be only created via+ function calls, as opposed to being inputs. (Reported by Thomas DuBuisson.)++### Version 2.9, 2013-01-02++ * Add support for the CVC4 SMT solver from Stanford: <https://cvc4.github.io/>+ NB. Z3 remains the default solver for SBV. To use CVC4, use the+ *With variants of the interface (i.e., proveWith, satWith, ..)+ by passing cvc4 as the solver argument. (Similarly, use 'yices'+ as the argument for the *With functions for invoking yices.)+ * Latest release of Yices calls the SMT-Lib based solver executable+ yices-smt. Updated the default value of the executable to have this+ name for ease of use.+ * Add an extra boolean flag to compileToSMTLib and generateSMTBenchmarks+ functions to control if the translation should keep the query as is+ (for SAT cases), or negate it (for PROVE cases). Previously, this value+ was hard-coded to do the PROVE case only.+ * Add bridge modules, to simplify use of different solvers. You can now say:++ import Data.SBV.Bridge.CVC4+ import Data.SBV.Bridge.Yices+ import Data.SBV.Bridge.Z3++ to pick the appropriate default solver. if you simply 'import Data.SBV', then+ you will get the default SMT solver, which is currently Z3. The value+ 'defaultSMTSolver' refers to z3 (currently), and 'sbvCurrentSolver' refers+ to the chosen solver as determined by the imported module. (The latter is+ useful for modifying options to the SMT solver in an solver-agnostic way.)+ * Various improvements to Z3 model parsing routines.++### Version 2.8, 2012-11-29++ * Rename the SNum class to SIntegral, and make it index over regular+ types. This makes it much more useful, simplifying coding of+ polymorphic symbolic functions over integral types, which is+ the common case.+ * Add the functions:+ * sbvShiftLeft+ * sbvShiftRight+ which can accommodate unsigned symbolic shift amounts. Note that+ one cannot use the Haskell shiftL/shiftR functions from the Bits class since+ they are hard-wired to take 'Int' values as the shift amounts only.+ * Add a new function 'sbvArithShiftRight', which is the same as+ a shift-right, except it uses the MSB of the input as the bit to fill+ in (instead of always filling in with 0 bits). Note that this is+ the same as shiftRight for signed values, but differs from a shiftRight+ when the input is unsigned. (There is no Haskell analogue of this+ function, as Haskell shiftR is always arithmetic for signed+ types and logical for unsigned ones.) This variant is designed for+ use cases when one uses the underlying unsigned SMT-Lib representation+ to implement custom signed operations, for instance.+ * Several typo fixes.++### Version 2.7, 2012-10-21++ * Add missing QuickCheck instance for SReal+ * When dealing with concrete SReals, make sure to operate+ only on exact algebraic reals on the Haskell side, leaving+ true algebraic reals (i.e., those that are roots of polynomials+ that cannot be expressed as a rational) symbolic. This avoids+ issues with functions that we cannot implement directly on+ the Haskell side, like exact square-roots.+ * Documentation tweaks, typo fixes etc.+ * Rename BVDivisible class to SDivisible; since SInteger+ is also an instance of this class, and SDivisible is a+ more appropriate name to start with. Also add sQuot and sRem+ methods; along with sDivMod, sDiv, and sMod, with usual+ semantics.+ * Improve test suite, adding many constant-folding tests+ and start using cabal based tests (--enable-tests option.)++### Versions 2.4, 2.5, and 2.6: Around mid October 2012++ * Workaround issues related hackage compilation, in particular to the+ problem with the new containers package release, which does provide+ an NFData instance for sequences.+ * Add explicit Num requirements when necessary, as the Bits class+ no longer does this.+ * Remove dependency on the hackage package strict-concurrency, as+ hackage can no longer compile it due to some dependency mismatch.+ * Add forgotten Real class instance for the type 'AlgReal'+ * Stop putting bounds on hackage dependencies, as they cause+ more trouble then they actually help. (See the discussion+ here: <http://www.haskell.org/pipermail/haskell-cafe/2012-July/102352.html>.)++### Version 2.3, 2012-07-20++ * Maintenance release, no new features.+ * Tweak cabal dependencies to avoid using packages that are newer+ than those that come with ghc-7.4.2. Apparently this is a no-no+ that breaks many things, see the discussion in this thread:+ http://www.haskell.org/pipermail/haskell-cafe/2012-July/102352.html+ In particular, the use of containers >= 0.5 is *not* OK until we have+ a version of GHC that comes with that version.++### Version 2.2, 2012-07-17++ * Maintenance release, no new features.+ * Update cabal dependencies, in particular fix the+ regression with respect to latest version of the+ containers package.++### Version 2.1, 2012-05-24++ * Library:+ * Add support for uninterpreted sorts, together with user defined+ domain axioms. See Data.SBV.Examples.Uninterpreted.Sort+ and Data.SBV.Examples.Uninterpreted.Deduce for basic examples of+ this feature.+ * Add support for C code-generation with SReals. The user picks+ one of 3 possible C types for the SReal type: CgFloat, CgDouble+ or CgLongDouble, using the function cgSRealType. Naturally, the+ resulting C program will suffer a loss of precision, as it will+ be subject to IEE-754 rounding as implied by the underlying type.+ * Add toSReal :: SInteger -> SReal, which can be used to promote+ symbolic integers to reals. Comes handy in mixed integer/real+ computations.+ * Examples:+ * Recast the dog-cat-mouse example to use the solver over reals.+ * Add Data.SBV.Examples.Uninterpreted.Sort, and+ Data.SBV.Examples.Uninterpreted.Deduce+ for illustrating uninterpreted sorts and axioms.++### Version 2.0, 2012-05-10++ This is a major release of SBV, adding support for symbolic algebraic reals: SReal.+ See http://en.wikipedia.org/wiki/Algebraic_number for details. In brief, algebraic+ reals are solutions to univariate polynomials with rational coefficients. The arithmetic+ on algebraic reals is precise, with no approximation errors. Note that algebraic reals+ are a proper subset of all reals, in particular transcendental numbers are not+ representable in this way. (For instance, "sqrt 2" is algebraic, but pi, e are not.)+ However, algebraic reals is a superset of rationals, so SBV now also supports symbolic+ rationals as well.++ You *should* use Z3 v4.0 when working with real numbers. While the interface will+ work with older versions of Z3 (or other SMT solvers in general), it uses Z3+ root-obj construct to retrieve and query algebraic reals.++ While SReal values have infinite precision, printing such values is not trivial since+ we might need an infinite number of digits if the result happens to be irrational. The+ user controls printing precision, by specifying how many digits after the decimal point+ should be printed. The default number of decimal digits to print is 10. (See the+ 'printRealPrec' field of SMT-solver configuration.)++ The acronym SBV used to stand for Symbolic Bit Vectors. However, SBV has grown beyond+ bit-vectors, especially with the addition of support for SInteger and SReal types and+ other code-generation utilities. Therefore, "SMT Based Verification" is now a better fit+ for the expansion of the acronym SBV.++ Other notable changes in the library:++ * Add functions s[TYPE] and s[TYPE]s for each symbolic type we support (i.e.,+ sBool, sBools, sWord8, sWord8s, etc.), to create symbolic variables of the+ right kind. Strictly speaking these are just synonyms for 'free'+ and 'mapM free' (plural versions), so they are not adding any additional+ power. Except, they are specialized at their respective types, and might be+ easier to remember.+ * Add function solve, which is merely a synonym for (return . bAnd), but+ it simplifies expressing problems.+ * Add class SNum, which simplifies writing polymorphic code over symbolic values+ * Increase haddock coverage metrics+ * Major code refactoring around symbolic kinds+ * SMTLib2: Emit ":produce-models" call before setting the logic, as required+ by the SMT-Lib2 standard. [Patch provided by arrowdodger on github, thanks!]++ Bugs fixed:++ * [Performance] Use a much simpler default definition for "select": While the+ older version (based on binary search on the bits of the indexer) was correct,+ it created unnecessarily big expressions. Since SBV does not have a notion+ of concrete subwords, the binary-search trick was not bringing any advantage+ in any case. Instead, we now simply use a linear walk over the elements.++ Examples:++ * Change dog-cat-mouse example to use SInteger for the counts+ * Add merge-sort example: Data.SBV.Examples.BitPrecise.MergeSort+ * Add diophantine solver example: Data.SBV.Examples.Existentials.Diophantine++### Version 1.4, 2012-05-10++ * Interim release for test purposes++### Version 1.3, 2012-02-25++ * Workaround cabal/hackage issue, functionally the same as release+ 1.2 below++### Version 1.2, 2012-02-25++ Library:++ * 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. 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
COPYRIGHT view
@@ -1,4 +1,4 @@-Copyright (c) 2010-2022, Levent Erkok (erkokl@gmail.com)+Copyright (c) 2010-2026, Levent Erkok (erkokl@gmail.com) All rights reserved. The sbv library is distributed with the BSD3 license. See the LICENSE file
Data/SBV.hs view
@@ -21,17 +21,20 @@ -- Falsifiable. Counter-example: -- s0 = 64 :: Word8 ----- The function 'prove' has the following type:+-- And similarly, 'sat' finds a satisfying instance. The types involved are: -- -- @--- 'prove' :: 'Provable' a => a -> 'IO' 'ThmResult'+-- 'prove' :: 'Provable' a => a -> 'IO' t'ThmResult'+-- 'sat' :: 'Data.SBV.Provers.Satisfiable' a => a -> 'IO' t'SatResult' -- @ ----- The class 'Provable' comes with instances for n-ary predicates, for arbitrary n.+-- The classes 'Provable' and 'Data.SBV.Provers.Satisfiable' come with instances for n-ary predicates, for arbitrary n. -- The predicates are just regular Haskell functions over symbolic types listed below. -- Functions for checking satisfiability ('sat' and 'allSat') are also -- provided. --+-- __Symbolic Types__+-- -- The sbv library introduces the following symbolic types: -- -- * 'SBool': Symbolic Booleans (bits).@@ -78,6 +81,14 @@ -- -- * Uninterpreted sorts, and proofs over such sorts, potentially with axioms. --+-- * Algebraic data types, including recursive fields..+--+-- * Ability to define SMTLib functions, generated directly from Haskell versions,+-- including support for recursive and mutually recursive functions.+--+-- * Express quantified formulas (both universals and existentials, including+-- alternating quantifiers), covering first-order logic.+-- -- * Model validation: SBV can validate models returned by solvers, which allows -- for protection against bugs in SMT solvers and SBV itself. (See the 'validateModel' -- parameter.)@@ -105,8 +116,11 @@ -- return a satisfying assignment, if there is one. The 'allSat' function returns -- all satisfying assignments. --+--+-- __Solvers__+-- -- The sbv library uses third-party SMT solvers via the standard SMT-Lib interface:--- <http://smtlib.cs.uiowa.edu/>+-- <https://smt-lib.org> -- -- The SBV library is designed to work with any SMT-Lib compliant SMT-solver. -- Currently, we support the following SMT-Solvers out-of-the box:@@ -115,15 +129,17 @@ -- -- * CVC4, and CVC5 from Stanford University and the University of Iowa. <https://cvc4.github.io/> and <https://cvc5.github.io> ----- * Boolector from Johannes Kepler University: <http://fmv.jku.at/boolector/> and its successor Bitwuzla from Stanford--- university: <https://github.com/bitwuzla/bitwuzla>+-- * Boolector from Johannes Kepler University: <https://boolector.github.io> and its successor Bitwuzla from Stanford+-- university: <https://bitwuzla.github.io> -- -- * 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/> --+-- * OpenSMT from Università della Svizzera italiana <https://verify.inf.usi.ch/opensmt>+-- -- * Z3 from Microsoft: <http://github.com/Z3Prover/z3/wiki> -- -- SBV requires recent versions of these solvers; please see the file@@ -134,14 +150,50 @@ -- -- Support for other compliant solvers can be added relatively easily, please -- get in touch if there is a solver you'd like to see included.+--+--+-- __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 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.TP.BinarySearch"+-- - "Documentation.SBV.Examples.TP.GCD"+-- - "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 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 TP proof should be considered true so long as all functions+-- used in the property are terminating. ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -161,7 +213,7 @@ , SWord8, SWord16, SWord32, SWord64, SWord, WordN -- *** Signed bit-vectors , SInt8, SInt16, SInt32, SInt64, SInt, IntN- -- *** Converting between fixed-size and arbitrary bitvectors+ -- *** Converting between fixed-size and arbitrary bit-vectors , BVIsNonZero, FromSized, ToSized, fromSized, toSized -- ** Unbounded integers -- $unboundedLimitations@@ -175,26 +227,35 @@ , SFPSingle, FPSingle , SFPDouble, FPDouble , SFPQuad, FPQuad+ , fpFromInteger -- ** Rationals- , SRational+ , SRational, (.%)+ , sRationalToSIntegerFloor, sRationalToSIntegerCeiling, sRationalToSIntegerTruncate+ , sRationalToSIntegerRoundAway, sRationalToSIntegerRoundToEven, sRationalToSIntegerRM+ , sRationalToSReal, sRealToSRational -- ** Algebraic reals -- $algReals- , SReal, AlgReal(..), sRealToSInteger, algRealToRational, RealPoint(..), realPoint, RationalCV(..)+ , SReal, AlgReal(..)+ , sRealToSIntegerFloor, sRealToSIntegerCeiling, sRealToSIntegerTruncate+ , sRealToSIntegerRoundAway, sRealToSIntegerRoundToEven, sRealToSIntegerRM+ , algRealToRational, RealPoint(..), realPoint, RationalCV(..) -- ** Characters, Strings and Regular Expressions -- $strings , SChar, SString -- ** Symbolic lists -- $lists- , SList+ , SList, (.:)+ -- ** Symbolic enumerators+ , EnumSymbolic(..), sEnum+ -- ** Symbolic case-expressions+ , sCase, pCase -- ** Tuples -- $tuples , SymTuple, STuple, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, STuple8- -- ** Sum types- , SMaybe, SEither -- ** Sets , RCSet(..), SSet -- * Arrays of symbolic values- , SymArray(readArray, writeArray, mergeArrays, sListArray), newArray_, newArray, SArray+ , SArray, sArray, sArray_, sArrays, readArray, writeArray, lambdaArray, constArray, freeArray, listArray, ArrayModel(..) -- * Creating symbolic values -- ** Single value@@ -217,10 +278,14 @@ , sString, sString_ , sList, sList_ , sTuple, sTuple_- , sEither, sEither_- , sMaybe, sMaybe_ , sSet, sSet_ + -- * Symbolic 'Maybe'+ , SMaybe, sMaybe, sMaybe_, sMaybes++ -- * Symbolic 'Either'+ , SEither, sEither, sEither_, sEithers+ -- ** List of values -- $createSyms , sBools@@ -241,13 +306,11 @@ , sStrings , sLists , sTuples- , sEithers- , sMaybes , sSets -- * Symbolic Equality and Comparisons -- $distinctNote- , EqSymbolic(..), OrdSymbolic(..), Equality(..)+ , EqSymbolic(..), OrdSymbolic(..), Zero(..), MeasureOf, Equality(..) -- * Conditionals: Mergeable values , Mergeable(..), ite, iteLazy @@ -255,6 +318,8 @@ , SIntegral -- * Division and Modulus , SDivisible(..)+ -- $euclidianNote+ , sEDivMod, sEDiv, sEMod, sDivides -- * Bit-vector operations -- ** Conversions , sFromIntegral@@ -270,7 +335,7 @@ -- * IEEE-floating point numbers , IEEEFloating(..), RoundingMode(..), SRoundingMode, nan, infinity, sNaN, sInfinity -- ** Rounding modes- , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero, sRNE, sRNA, sRTP, sRTN, sRTZ+ , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero, sRNE, sRNA, sRTP, sRTN, sRTZ, sCaseRoundingMode -- ** Conversion to/from floats -- $conversionNote , IEEEFloatConvertible(..)@@ -288,40 +353,53 @@ -- ** Showing values in detail , crack - -- * Enumerations- -- $enumerations- , mkSymbolicEnumeration+ -- * Symbolic data types+ -- $symbolicADT+ , mkSymbolic - -- * Uninterpreted sorts, axioms, constants, and functions- -- $uninterpreted- , mkUninterpretedSort, Uninterpreted(..), addAxiom+ -- * Stopping unrolling: Defined functions+ , SMTDefinable(..)+ , smtFunction+ , smtFunctionWithMeasure+ , smtFunctionWithContract+ , smtProductiveFunction+ , smtFunctionNoTermination+ , ContractOf, MeasureHelper(..)+ , smtHOFunction, smtHOFunctionWithMeasure, Closure(..), registerType - -- * Adding SMT functions- , addSMTDefinition+ -- * Special relations+ -- $specialRels+ , Relation, isPartialOrder, isLinearOrder, isTreeOrder, isPiecewiseLinearOrder, mkTransitiveClosure -- * Properties, proofs, and satisfiability -- $proveIntro- -- $noteOnNestedQuantifiers -- $multiIntro- , Predicate, Goal- , Provable, universal_, universal, existential_, existential+ , Predicate, ConstraintSet, Provable, Satisfiable , prove, proveWith , dprove, dproveWith , sat, satWith , dsat, dsatWith , allSat, allSatWith- , optimize, optimizeWith, isVacuous- , isVacuousWith, isTheorem, isTheoremWith, isSatisfiable, isSatisfiableWith- , proveWithAll, proveWithAny, satWithAll- , proveConcurrentWithAny, proveConcurrentWithAll, satConcurrentWithAny, satConcurrentWithAll- , satWithAny, generateSMTBenchmark+ , isVacuousProof, isVacuousProofWith+ , isTheorem, isTheoremWith, isSatisfiable, isSatisfiableWith+ , proveWithAny, proveWithAll, proveConcurrentWithAny, proveConcurrentWithAll+ , satWithAny, satWithAll, satConcurrentWithAny, satConcurrentWithAll+ , generateSMTBenchmarkSat, generateSMTBenchmarkProof , solve- -- * Constraints+ -- ** Partitioning result space+ -- $partitionIntro+ , allSatPartition++ -- * Constraints and Quantifiers -- $constrainIntro -- ** General constraints -- $generalConstraints , constrain, softConstrain + -- ** Quantified constraints, quantifier elimination, and skolemization+ -- $quantifiers+ , QuantifiedBool, quantifiedBool, Forall(..), Exists(..), ExistsUnique(..), ForallN(..), ExistsN(..), QNot(..), Skolemize(..)+ -- ** Constraint Vacuity -- $constraintVacuity @@ -338,13 +416,17 @@ -- * Checking safety -- $safeIntro- , sAssert, isSafe, SExecutable, sName_, sName, safe, safeWith+ , sAssert, isSafe, SExecutable, sName, safe, safeWith -- * Quick-checking , sbvQuickCheck -- * Optimization -- $optiIntro+ , optimize, optimizeWith+ , optLexicographic, optLexicographicWith+ , optPareto, optParetoWith+ , optIndependent, optIndependentWith -- ** Multiple optimization goals -- $multiOpt@@ -356,7 +438,7 @@ -- $softAssertions , assertWithPenalty , Penalty(..) -- ** Field extensions- -- | If an optimization results in an infinity/epsilon value, the returned `CV` value will be in the corresponding extension field.+ -- | If an optimization results in an infinity/epsilon value, the returned t'CV' value will be in the corresponding extension field. , ExtCV(..), GeneralizedCV(..) -- * Model extraction@@ -372,16 +454,16 @@ -- ** Programmable model extraction -- $programmableExtraction- , SatModel(..), Modelable(..), displayModels, extractModels- , getModelDictionaries, getModelValues, getModelUninterpretedValues+ , Modelable(..), displayModels, extractModels+ , getModelDictionaries, getModelValues -- * SMT Interface- , SMTConfig(..), Timing(..), SMTLibVersion(..), Solver(..), SMTSolver(..)+ , SMTConfig(..), TPOptions(..), Timing(..), SMTLibVersion(..), Solver(..), SMTSolver(..) -- ** Controlling verbosity -- $verbosity -- ** Solvers- , boolector, bitwuzla, cvc4, cvc5, yices, dReal, z3, mathSAT, abc+ , boolector, bitwuzla, cvc4, cvc5, yices, dReal, z3, mathSAT, abc, openSMT -- ** Configurations , defaultSolverConfig, defaultSMTCfg, defaultDeltaSMTCfg, sbvCheckSolverInstallation, getAvailableSolvers , setLogic, Logic(..), setOption, setInfo, setTimeOut@@ -390,11 +472,14 @@ -- * Abstract SBV type , SBV, HasKind(..), Kind(..)- , SymVal, sbvForall, sbvForall_, mkForallVars, sbvExists, sbvExists_, mkExistVars, free- , free_, mkFreeVars, symbolic, symbolics, literal, unliteral, fromCV+ , SymVal, free, free_, mkFreeVars, symbolic, symbolics, literal, unliteral, fromCV , isConcrete, isSymbolic, isConcretely, mkSymVal , MonadSymbolic(..), Symbolic, SymbolicT, label, output, runSMT, runSMTWith+ , some + -- * Queriable values+ , Queriable(..), freshVar, freshVar_+ -- * Module exports -- $moduleExportIntro @@ -404,14 +489,16 @@ , module Data.Ratio ) where +import Control.Monad (unless)+import Control.Monad.Trans (MonadIO)++import qualified Data.Text as T+ import Data.SBV.Core.AlgReals-import Data.SBV.Core.Data hiding (sbvForall, sbvForall_,- mkForallVars, sbvExists, sbvExists_,- mkExistVars, free, free_, mkFreeVars,+import Data.SBV.Core.Data hiding (free, free_, mkFreeVars, output, symbolic, symbolics, mkSymVal,- newArray, newArray_)+ bvExtract, bvDrop, bvTake, (#)) import Data.SBV.Core.Model hiding (assertWithPenalty, minimize, maximize,- sbvForall, sbvForall_, sbvExists, sbvExists_, solve, sBool, sBool_, sBools, sChar, sChar_, sChars, sDouble, sDouble_, sDoubles, sFloat, sFloat_, sFloats, sFloatingPoint, sFloatingPoint_, sFloatingPoints,@@ -419,35 +506,42 @@ sFPDouble, sFPDouble_, sFPDoubles, sFPQuad, sFPQuad_, sFPQuads, sInt8, sInt8_, sInt8s, sInt16, sInt16_, sInt16s, sInt32, sInt32_, sInt32s, sInt64, sInt64_, sInt64s, sInteger, sInteger_, sIntegers,+ sWord, sWords, sWord_, sInt, sInts, sInt_, sList, sList_, sLists, sTuple, sTuple_, sTuples, sReal, sReal_, sReals, sString, sString_, sStrings, sRational, sRational_, sRationals, sWord8, sWord8_, sWord8s, sWord16, sWord16_, sWord16s, sWord32, sWord32_, sWord32s, sWord64, sWord64_, sWord64s,- sMaybe, sMaybe_, sMaybes, sEither, sEither_, sEithers, sSet, sSet_, sSets,- sBarrelRotateLeft, sBarrelRotateRight)--import qualified Data.SBV.Core.Model as M (sBarrelRotateLeft, sBarrelRotateRight)+ sSet, sSet_, sSets,+ sArray, sArray_, sArrays,+ sBarrelRotateLeft, sBarrelRotateRight, zeroExtend, signExtend, sObserve) -import Data.SBV.Core.Sized hiding (sWord, sWord_, sWords, sInt, sInt_, sInts, bvExtract, (#), zeroExtend, signExtend, bvDrop, bvTake)-import qualified Data.SBV.Core.Sized as CS+import qualified Data.SBV.Core.Model as M (sBarrelRotateLeft, sBarrelRotateRight, zeroExtend, signExtend)+import qualified Data.SBV.Core.Data as CD (bvExtract, (#), bvDrop, bvTake) import Data.SBV.Core.Kind import Data.SBV.Core.SizedFloats +import Data.SBV.Maybe hiding (map)+import Data.SBV.Either+ import Data.SBV.Core.Floating-import Data.SBV.Core.Symbolic (MonadSymbolic(..), SymbolicT)+import Data.SBV.Core.Symbolic ( MonadSymbolic(..), SymbolicT, registerKind+ , ProgInfo(..), rProgInfo, SpecialRelOp(..), UICodeKind(UINone)+ , getRootState, UIName(UIGiven)+ ) -import Data.SBV.Provers.Prover hiding (universal_, universal, existential_, existential,- prove, proveWith, sat, satWith, allSat,+import Data.SBV.Provers.Prover hiding (prove, proveWith, sat, satWith, allSat, dsat, dsatWith, dprove, dproveWith, allSatWith, optimize, optimizeWith,- isVacuous, isVacuousWith, isTheorem,- isTheoremWith, isSatisfiable,+ isVacuousProof, isVacuousProofWith,+ isTheorem, isTheoremWith, isSatisfiable, isSatisfiableWith, runSMT, runSMTWith,- sName_, sName, safe, safeWith)+ sName, safe, safeWith) +import Data.IORef (modifyIORef', readIORef)+ import Data.SBV.Client import Data.SBV.Client.BaseIO @@ -459,25 +553,34 @@ import Data.Word import Data.SBV.SMT.Utils (SBVException(..))+ import Data.SBV.Control.Types (SMTReasonUnknown(..), Logic(..))+import Data.SBV.Control.Utils (getValue, freshVar, freshVar_) import qualified Data.SBV.Utils.CrackNum as CN import Data.Proxy (Proxy(..))-import GHC.TypeLits+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)+import Data.SBV.SCase (sCase, pCase) +import Data.SBV.Rational++#ifdef DOCTEST --- $setup---- >>> -- For doctest purposes only:---- >>> :set -XDataKinds+--- >>> :set -XDataKinds -XFlexibleContexts -XTypeApplications -XRankNTypes --- >>> import Data.Proxy+#endif -- | Show a value in detailed (cracked) form, if possible. -- This makes most sense with numbers, and especially floating-point types.-crack :: SBV a -> String-crack (SBV (SVal _ (Left cv))) | Just s <- CN.crackNum cv = s-crack (SBV sv) = show sv+crack :: Bool -> SBV a -> String+crack verb (SBV (SVal _ (Left cv))) | Just s <- CN.crackNum cv verb Nothing = s+crack _ (SBV sv) = show sv -- Haddock section documentation {- $progIntro@@ -514,7 +617,7 @@ design goal is to let SMT solvers be used without any knowledge of how SMT solvers work or how different logics operate. The details are hidden behind the SBV framework, providing Haskell programmers with a clean API that is unencumbered by the details of individual solvers.-To that end, we use the SMT-Lib standard (<http://smtlib.cs.uiowa.edu/>)+To that end, we use the SMT-Lib standard (<https://smt-lib.org>) to communicate with arbitrary SMT solvers. -} @@ -593,7 +696,7 @@ Goals can be lexicographically (default), independently, or pareto-front optimized. The relevant functions are: * 'minimize': Minimize a given arithmetic goal- * 'maximize': Minimize a given arithmetic goal+ * 'maximize': Maximize a given arithmetic goal Goals can be optimized at a regular or an extended value: An extended value is either positive or negative infinity (for unbounded integers and reals) or positive or negative epsilon differential from a real value (for reals).@@ -686,8 +789,8 @@ @ 'assertWithPenalty' "bounded_x" (x .< 5) 'DefaultPenalty'- 'assertWithPenalty' "bounded_x" (x .< 5) ('Penalty' 2.3 Nothing)- 'assertWithPenalty' "bounded_x" (x .< 5) ('Penalty' 4.7 (Just "group-1")) @+ 'assertWithPenalty' "bounded_x" (x .< 5) $ v'Penalty' 2.3 Nothing+ 'assertWithPenalty' "bounded_x" (x .< 5) $ v'Penalty' 4.7 (Just "group-1") @ In the first form, we are saying that the constraint @x .< 5@ must be satisfied, if possible, but if this constraint can not be satisfied to find a model, it can be violated with the default penalty of 1.@@ -708,7 +811,7 @@ -} {- $resultTypes-'ThmResult', 'SatResult', and 'AllSatResult' are simple newtype wrappers over 'SMTResult'. Their+t'ThmResult', t'SatResult', and t'AllSatResult' are simple newtype wrappers over t'SMTResult'. Their main purpose is so that we can provide custom 'Show' instances to print results accordingly. -} @@ -739,7 +842,7 @@ overflow/underflow as it is the case with the bounded types, such as 'SWord8', 'SInt16', etc. However, some bit-vector based operations are /not/ supported for the 'SInteger' type while in the verification mode. That is, you can use these operations on 'SInteger' values during normal programming/simulation.-but the SMT translation will not support these operations since there corresponding operations are not supported in SMT-Lib.+but the SMT translation will not support these operations since their corresponding operations are not supported in SMT-Lib. Note that this should rarely be a problem in practice, as these operations are mostly meaningful on fixed-size bit-vectors. The operations that are restricted to bounded word/int sizes are: @@ -749,7 +852,7 @@ * Extraction and concatenation: 'bvExtract', '#', 'zeroExtend', 'signExtend', 'bvDrop', and 'bvTake' -Usual arithmetic ('+', '-', '*', 'sQuotRem', 'sQuot', 'sRem', 'sDivMod', 'sDiv', 'sMod') and logical operations ('.<', '.<=', '.>', '.>=', '.==', './=') operations are+Usual arithmetic ('Prelude.+', 'Prelude.-', '*', 'sQuotRem', 'sQuot', 'sRem', 'sDivMod', 'sDiv', 'sMod') and logical operations ('.<', '.<=', '.>', '.>=', '.==', './=') operations are supported for 'SInteger' fully, both in programming and verification modes. -} @@ -761,7 +864,7 @@ others are not (such as pi and e). SBV can deal with real numbers just fine, since the theory of reals is decidable. (See-<http://smtlib.cs.uiowa.edu/theories-Reals.shtml>.) In addition, by leveraging backend+<https://smt-lib.org/theories-Reals.shtml>.) In addition, by leveraging backend solver capabilities, SBV can also represent and solve non-linear equations involving real-variables. (For instance, the Z3 SMT solver, supports polynomial constraints on reals starting with v4.0.) -}@@ -774,9 +877,9 @@ {- $strings Support for characters, strings, and regular expressions (initial version contributed by Joel Burget)-adds support for QF_S logic, described here: <http://smtlib.cs.uiowa.edu/theories-UnicodeStrings.shtml>+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@@ -795,20 +898,81 @@ specialized type-signatures since Haskell insists on an 'Int' second argument for them. -} +{- $partitionIntro+The function 'allSatPartition' allows one to restrict the results returned by calls to 'Data.SBV.allSat'.+In certain cases, we might consider certain models to be "equivalent," i.e., we might want to+create equivalence classes over the search space when it comes to what we consider all satisfying+solutions. In these cases, we can use 'allSatPartition' to tell SBV what classes of solutions to consider+as unique. Consider:++>>> :{+allSat $ do+ x <- sInteger "x"+ y <- sInteger "y"+ allSatPartition "p1" $ x .>= 0+ allSatPartition "p2" $ y .>= 0+:}+Solution #1:+ x = -1 :: Integer+ y = 0 :: Integer+ p1 = False :: Bool+ p2 = True :: Bool+Solution #2:+ x = 0 :: Integer+ y = 0 :: Integer+ p1 = True :: Bool+ p2 = True :: Bool+Solution #3:+ x = 0 :: Integer+ y = -1 :: Integer+ p1 = True :: Bool+ p2 = False :: Bool+Solution #4:+ x = -1 :: Integer+ y = -1 :: Integer+ p1 = False :: Bool+ p2 = False :: Bool+Found 4 different solutions.++Without the call to 'allSatPartition' the above example, 'allSat' would return all possible combinations of @x@ and @y@ subject to the constraints. (Since we have none here,+the call would try to enumerate the infinite set of all integer tuples!) But 'allSatPartition' allows us to restrict our attention to the examples that satisfy the partitioning+constraints. The first argument to 'allSatPartition' is simply a name, for diagnostic purposes. Note that the conditions given by 'allSatPartition' are /not/ imposed on the search+space at all: They're only used when we construct the search space. In the above example, we pick one example from each quadrant. Furthermore, while it is typical to pass+a boolean as a partitioning argument, it is not required: Any expression is OK, whose value creates the equivalence class:++>>> :{+allSat $ do+ x <- sInteger "x"+ allSatPartition "p" $ x `sMod` 3+:}+Solution #1:+ x = 2 :: Integer+ p = 2 :: Integer+Solution #2:+ x = 1 :: Integer+ p = 1 :: Integer+Solution #3:+ x = 0 :: Integer+ p = 0 :: Integer+Found 3 different solutions.++In the above, we get three examples, as the expression @x mod 3@ can take only three different values.+-}+ {- $constrainIntro A constraint is a means for restricting the input domain of a formula. Here's a simple example: @- do x <- 'sbvExists' \"x\"- y <- 'sbvExists' \"y\"+ do x <- 'free' \"x\"+ y <- 'free' \"y\" 'constrain' $ x .> y 'constrain' $ x + y .>= 12 'constrain' $ y .>= 3 ... @ -The first constraint requires @x@ to be larger than @y@. The scond one says that+The first constraint requires @x@ to be larger than @y@. The second one says that sum of @x@ and @y@ must be at least @12@, and the final one says that @y@ to be at least @3@. Constraints provide an easy way to assert additional properties on the input domain, right at the point of the introduction of variables.@@ -839,7 +1003,7 @@ {- $generalConstraints A good use case (in fact the motivating use case) for 'constrain' is attaching a-constraint to a universally or existentially quantified variable at the time of its creation.+constraint to a variable at the time of its creation. Also, the conjunctive semantics for 'sat' and the implicative semantics for 'prove' simplify programming by choosing the correct interpretation automatically. However, one should be aware of the semantic difference. For instance, in@@ -847,7 +1011,7 @@ /satisfiable/. To wit, consider: @- do x <- 'sbvExists' \"x\"+ do x <- 'free' \"x\" 'constrain' $ x .< x return $ x .< (x :: 'SWord8') @@@ -855,17 +1019,68 @@ This predicate is unsatisfiable since no element of 'SWord8' is less than itself. But it's (vacuously) true, since it excludes the entire domain of values, thus making the proof trivial. Hence, this predicate is provable, but is not satisfiable. To make sure the given-constraints are not vacuous, the functions 'isVacuous' (and 'isVacuousWith') can be used.+constraints are not vacuous, the functions 'isVacuousProof' (and 'isVacuousProofWith') can be used. Also note that this semantics imply that test case generation ('Data.SBV.Tools.GenTest.genTest') and quick-check can take arbitrarily long in the presence of constraints, if the random input values generated rarely satisfy the constraints. (As an extreme case, consider @'constrain' 'sFalse'@.) -} +{- $quantifiers+You can write quantified formulas, and reason with them as in first-order logic. Here is a simple example:++@+ constrain $ \\(Forall x) (Exists y) -> y .> (x :: SInteger)+@++You can nest quantifiers as you wish, and the quantified parameters can be of arbitrary symbolic type.+Additionally, you can convert such a quantified formula to a regular boolean, via a call to 'quantifiedBool'+function, essentially performing quantifier elimination:++@+ other_condition .&& quantifiedBool (\\(Forall x) (Exists y) -> y .> (x :: SInteger))+@++Or you can prove/sat quantified formulas directly:++@+ prove $ \\(Forall x) (Exists y) -> y .> (x :: SInteger)+@++This facility makes quantifiers part of the regular SBV language, allowing them to be mixed/matched with all+your other symbolic computations. See the following files demonstrating reasoning with quantifiers:++ * "Documentation.SBV.Examples.Puzzles.Birthday"+ * "Documentation.SBV.Examples.Puzzles.KnightsAndKnaves"+ * "Documentation.SBV.Examples.Puzzles.Rabbits"+ * "Documentation.SBV.Examples.Misc.FirstOrderLogic"++SBV also supports the constructors t'ExistsUnique' to create unique existentials, in addition+to t'ForallN' and t'ExistsN' for creating multiple variables at the same time.++In general, SBV will not display the values of quantified variables for a satisfying instance.+For a satisfiability problem, you can apply skolemization manually to have these values+computed by the backend solver. Note that skolemization will produce functions for+existentials under universals, and SBV generally cannot translate function values back+to Haskell, except in certain simple cases. However, for prefix existentials, the manual+transformation can pay off. As an example, compare:++>>> sat $ \(Exists x) (Forall y) -> x .<= (y :: SWord8)+Satisfiable++to:++>>> sat $ do { x <- free "x"; pure (quantifiedBool (\(Forall y) -> x .<= (y :: SWord8))) }+Satisfiable. Model:+ x = 0 :: Word8++where we have skolemized the top-level existential out, and received a witness value for it.+-}+ {- $constraintVacuity When adding constraints, one has to be careful about-making sure they are not inconsistent. The function 'isVacuous' can be use for this purpose.+making sure they are not inconsistent. The function 'isVacuousProof' can be used for this purpose. Here is an example. Consider the following predicate: >>> let pred = do { x <- free "x"; constrain $ x .< x; return $ x .>= (5 :: SWord8) }@@ -877,9 +1092,9 @@ >>> prove pred Q.E.D. -We can use 'isVacuous' to make sure to see that the pass was vacuous:+We can use 'isVacuousProof' to make sure to see that the pass was vacuous: - >>> isVacuous pred+ >>> isVacuousProof pred True While the above example is trivial, things can get complicated if there are multiple constraints with@@ -895,7 +1110,7 @@ And the proof is not vacuous: - >>> isVacuous pred'+ >>> isVacuousProof pred' False -} @@ -918,90 +1133,76 @@ See 'Data.SBV.Control.getUnsatCore' for details and "Documentation.SBV.Examples.Queries.UnsatCore" for an example use case. -} -{- $uninterpreted+{- $symbolicADT Users can introduce new uninterpreted sorts simply by defining an empty data-type in Haskell and registering it as such. The following example demonstrates: @ data B- mkUninterpretedSort ''B+ mkSymbolic [''B] @ -(Note that you'll also need to use pragmas @TemplateHaskell@, @StandAloneDeriving@, @DeriveDataTypeable@, and @DeriveAnyClass@ for this to work, follow GHC's error messages!)- This is all it takes to introduce @B@ as an uninterpreted sort in SBV, which makes the type @SBV B@ automagically become available as the type of symbolic values that ranges over @B@ values. Note that this will also introduce the type @SB@ into your environment, which is a synonym for @SBV B@. --Uninterpreted functions over both uninterpreted and regular sorts can be declared using the facilities introduced by-the 'Data.SBV.Core.Model.Uninterpreted' class.--}--{- $enumerations-If the uninterpreted sort definition takes the form of an enumeration (i.e., a simple data type with all nullary constructors), then -tou can use the 'mkSymbolicEnumeration' functio to turn it into an enumeration in SMTLib.-A simple example is:+If the uninterpreted sort definition takes the form of an enumeration (i.e., a simple data type with all nullary constructors), then+it will turn into an enumeration in SMTLib. A simple example is: @ data X = A | B | C- mkSymbolicEnumeration ''X+ mkSymbolic [''X] @ -Note the magic incantation @mkSymbolicEnumeration ''X@. For this to work, you need to have the following-options turned on:--> LANGUAGE TemplateHaskell-> LANGUAGE StandaloneDeriving-> LANGUAGE DeriveDataTypeable-> LANGUAGE DeriveAnyClass+Note the magic incantation @mkSymbolic [''X]@, requires the following extensions:+@TemplateHaskell@, @TypeApplications@, and @FlexibleInstances@.+Parametric data-types also require @ScopedTypeVariables@. -The declaration will automatically introduce the type:+SBV also supports good old ADT's as well, with fields. The support for this is similar, where SBV will create the+corresponding datatype in a symbolic manner: @- type SX = SBV X+-- | A basic arithmetic expression type.+data Expr = Num Integer+ | Var String+ | Add Expr Expr+ | Mul Expr Expr+ | Let String Expr Expr++-- | Create a symbolic version of expressions.+mkSymbolic [''Expr] @ -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@.+These types can also be parameterized, per usual Haskell usage. -A simple query would look like:+We also support a symbolic case-expression quasi-quoter, allowing us to write: @- allSat $ \x -> x .== (x :: SX)-@--which would list all three elements of this domain as satisfying solutions.+eval :: SExpr -> SInteger+eval = go []+ where go :: SList (String, Integer) -> SExpr -> SInteger+ go = smtFunction "eval"+ $ \env expr -> [sCase| expr of+ Num i -> i+ Var s -> get env s+ Add l r -> go env l + go env r+ Mul l r -> go env l * go env r+ Let s e r -> go (tuple (s, go env e) SL..: env) r+ |] -@- Solution #1:- s0 = A :: X- Solution #2:- s0 = B :: X- Solution #3:- s0 = C :: X- Found 3 different solutions.+ get :: SList (String, Integer) -> SString -> SInteger+ get = smtFunction "get"+ $ \env s -> ite (SL.null env) 0+ $ let (k, v) = untuple (SL.head env)+ in ite (s .== k) v (get (SL.tail env) s) @ -Note that the result is properly typed as @X@ elements; these are not mere strings.--See "Documentation.SBV.Examples.Misc.Enumerate" for an extended example on how to use symbolic enumerations.--}--{- $noteOnNestedQuantifiers-=== A note on reasoning in the presence of quantifiers #noteOnNested#+which defines an interpreter for this data-type. Such definitions also come with an induction principle+to perform TP based proofs on. These can be accessed using the 'Data.SBV.TP.inductiveLemma' function. -Note that SBV allows reasoning with quantifiers: Inputs can be existentially or universally quantified. Predicates can be built-with arbitrary nesting of such quantifiers as well. However, SBV always /assumes/ that the input is in-prenex-normal form: <http://en.wikipedia.org/wiki/Prenex_normal_form>. That is,-all the input declarations are treated as happening at the beginning of a predicate, followed by the actual formula. Unfortunately,-the way predicates are written can be misleading at times, since symbolic inputs can be created at arbitrary points; interleaving them-with other code. The rule is simple, however: All inputs are assumed at the top, in the order declared, regardless of their quantifiers.-SBV will apply skolemization to get rid of existentials before sending predicates to backend solvers. However, if you do want nested-quantification, you will manually have to first convert to prenex-normal form (which produces an equisatisfiable but not necessarily-equivalent formula), and code that explicitly in SBV. See [Issue 256](http://github.com/LeventErkok/sbv/issues/256) and [Issue 623](https://github.com/LeventErkok/sbv/issues/623) for a detailed discussion-of this issue.+The argument to @mkSymbolic@ is typically a list of types. The requirement is that if the types you pass on+are mutually recursively defined, you should give them as a list. Otherwise, you can give them all together,+or one at a time. -} {- $cardIntro@@ -1030,7 +1231,7 @@ {- $verbosity -SBV provides various levels of verbosity to aid in debugging, by using the 'SMTConfig' fields:+SBV provides various levels of verbosity to aid in debugging, by using the t'SMTConfig' fields: * ['verbose'] Print on stdout a shortened account of what is sent/received. This is specifically trimmed to reduce noise and is good for quick debugging. The output is not supposed to be machine-readable.@@ -1059,10 +1260,10 @@ return $ observe "Expected" spec .== observe "Result" res :} Falsifiable. Counter-example:- Expected = 34 :: Word8- Result = 1 :: Word8 i1 = 12 :: Word8 i2 = 22 :: Word8+ Expected = 34 :: Word8+ Result = 1 :: Word8 The 'observeIf' variant allows the user to specify a boolean condition when the value is interesting to observe. Useful when you have lots of "debugging" points, but not all are of interest. Use the 'sObserve' variant when you are at the 'Symbolic'@@ -1085,13 +1286,39 @@ Q.E.D. -} +{- $euclidianNote+=== Euclidian division and modulus++Euclidian division and modulus for integers differ from regular division modulus when+the divisor is negative. It satisfies the following desirable property: For any @m@, @n@, we have:++@+ Given @m@, @n@, s.t., n /= 0+ Let (q, r) = m `sEDivMod` n+ Then: m = n * q + r+ and 0 <= r <= |n| - 1+@++That is, the modulus is always positive.+There's no standard Haskell function that performs this operation. The main reason to prefer this+function is that SMT solvers can deal with them better.+Compare:++>>> sDivMod @SInteger 3 (-2)+(-2 :: SInteger,-1 :: SInteger)+>>> sEDivMod 3 (-2)+(-1 :: SInteger,1 :: SInteger)+>>> prove $ \x y -> y .> 0 .=> x `sDivMod` y .== x `sEDivMod` y+Q.E.D.+-}+ {- $conversionNote Capture convertability from/to FloatingPoint representations. Conversions to float: 'toSFloat' and 'toSDouble' simply return the nearest representable float from the given type based on the rounding mode provided. Similarly, 'toSFloatingPoint' converts to a generalized-floating-point number with specified exponent and significand bith widths.+floating-point number with specified exponent and significand bit widths. Conversions from float: 'fromSFloat', 'fromSDouble', 'fromSFloatingPoint' functions do the reverse conversion. However some care is needed when given values@@ -1120,7 +1347,7 @@ same thing! Same goes for Haskell, which seems to convert via Int64, but we do not model that behavior in SBV as it doesn't seem to be intentional nor well documented. -You can check for @NaN@, @oo@ and @-oo@, using the predicates 'fpIsNaN', 'fpIsInfinite',+You can check for @NaN@, @oo@ and @-oo@, using the predicates 'Data.SBV.Core.Floating.fpIsNaN', 'Data.SBV.Core.Floating.fpIsInfinite', and 'fpIsPositive', 'fpIsNegative' predicates, respectively; and do the proper conversion based on your needs. (0 is a good choice, as are min/max bounds of the target type.) @@ -1147,15 +1374,15 @@ Q.E.D. >>> prove $ roundTrip @Int32 Falsifiable. Counter-example:- s0 = RoundNearestTiesToEven :: RoundingMode- s1 = -156765620 :: Int32+ s0 = RoundNearestTiesToAway :: RoundingMode+ s1 = 22049281 :: Int32 Note how we get a failure on `Int32`. The counter-example value is not representable exactly as a single precision float: ->>> toRational (-156765620 :: Float)-(-156765616) % 1+>>> toRational (22049281 :: Float)+22049280 % 1 -Note how the numerator is different, it is off by 4. This is hardly surprising, since floats become sparser as+Note how the numerator is different, it is off by 1. This is hardly surprising, since floats become sparser as the magnitude increases to be able to cover all the integer values representable. >>> :{@@ -1177,20 +1404,20 @@ Q.E.D. >>> prove $ roundTrip @Int64 Falsifiable. Counter-example:- s0 = RoundTowardNegative :: RoundingMode- s1 = 9007199254740995 :: Int64+ s0 = RoundNearestTiesToEven :: RoundingMode+ s1 = 2305843026393563113 :: Int64 Just like in the `SFloat` case, once we reach 64-bits, we no longer can exactly represent the integer value for all possible values: ->>> toRational (9007199254740995 :: Double)-9007199254740996 % 1+>>> toRational (fromIntegral (2305843026393563113 :: Int64) :: Double)+2305843026393563136 % 1 -In this case the numerator is off by 1.+In this case the numerator is off by 23. -} -- | An implementation of rotate-left, using a barrel shifter like design. Only works when both--- arguments are finite bitvectors, and furthermore when the second argument is unsigned.+-- arguments are finite bit-vectors, and furthermore when the second argument is unsigned. -- The first condition is enforced by the type, but the second is dynamically checked. -- We provide this implementation as an alternative to `sRotateLeft` since SMTLib logic -- does not support variable argument rotates (as opposed to shifts), and thus this@@ -1223,9 +1450,9 @@ -> proxy j -- ^ @j@: End position, numbered from @n-1@ to @0@, @j <= i@ must hold -> SBV (bv n) -- ^ Input bit vector of size @n@ -> SBV (bv (i - j + 1)) -- ^ Output is of size @i - j + 1@-bvExtract = CS.bvExtract+bvExtract = CD.bvExtract --- | Join two bitvectors.+-- | Join two bit-vectors. -- -- >>> prove $ \x y -> x .== bvExtract (Proxy @79) (Proxy @71) ((x :: SWord 9) # (y :: SWord 71)) -- Q.E.D.@@ -1234,7 +1461,7 @@ ) => SBV (bv n) -- ^ First input, of size @n@, becomes the left side -> SBV (bv m) -- ^ Second input, of size @m@, becomes the right side -> SBV (bv (n + m)) -- ^ Concatenation, of size @n+m@-(#) = (CS.#)+(#) = (CD.#) infixr 5 # -- | Zero extend a bit-vector.@@ -1248,7 +1475,7 @@ , BVIsNonZero (m - n) ) => SBV (bv n) -- ^ Input, of size @n@ -> SBV (bv m) -- ^ Output, of size @m@. @n < m@ must hold-zeroExtend = CS.zeroExtend+zeroExtend = M.zeroExtend -- | Sign extend a bit-vector. --@@ -1261,10 +1488,10 @@ , n + 1 <= m , SFiniteBits (bv n) , SIntegral (bv (m - n))- , BVIsNonZero (m - n)+ , BVIsNonZero (m - n) ) => SBV (bv n) -- ^ Input, of size @n@ -> SBV (bv m) -- ^ Output, of size @m@. @n < m@ must hold-signExtend = CS.signExtend+signExtend = M.signExtend -- | Drop bits from the top of a bit-vector. --@@ -1280,7 +1507,7 @@ ) => proxy i -- ^ @i@: Number of bits to drop. @i < n@ must hold. -> SBV (bv n) -- ^ Input, of size @n@ -> SBV (bv m) -- ^ Output, of size @m@. @m = n - i@ holds.-bvDrop = CS.bvDrop+bvDrop = CD.bvDrop -- | Take bits from the top of a bit-vector. --@@ -1296,7 +1523,7 @@ ) => proxy i -- ^ @i@: Number of bits to take. @0 < i <= n@ must hold. -> SBV (bv n) -- ^ Input, of size @n@ -> SBV (bv i) -- ^ Output, of size @i@-bvTake = CS.bvTake+bvTake = CD.bvTake -- | A helper class to convert sized bit-vectors to/from bytes. class ByteConverter a where@@ -1465,4 +1692,173 @@ = error $ "fromBytes:SWord 1024: Incorrect number of bytes: " ++ show l where l = length as -{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}+{- $specialRels+A special relation is a binary relation that has additional properties. SBV allows for the checking of various kinds+of special relations respecting various axioms, and allows for creating transitive closures.+See "Documentation.SBV.Examples.Misc.FirstOrderLogic" for several examples.+-}++-- | A type synonym for binary relations.+type Relation a = (SBV a, SBV a) -> SBool++-- | Check if a relation is a partial order. The string argument must uniquely identify this order.+isPartialOrder :: SymVal a => String -> Relation a -> SBool+isPartialOrder = checkSpecialRelation . IsPartialOrder++-- | Check if a relation is a linear order. The string argument must uniquely identify this order.+isLinearOrder :: SymVal a => String -> Relation a -> SBool+isLinearOrder = checkSpecialRelation . IsLinearOrder++-- | Check if a relation is a tree order. The string argument must uniquely identify this order.+isTreeOrder :: SymVal a => String -> Relation a -> SBool+isTreeOrder = checkSpecialRelation . IsTreeOrder++-- | Check if a relation is a piece-wise linear order. The string argument must uniquely identify this order.+isPiecewiseLinearOrder :: SymVal a => String -> Relation a -> SBool+isPiecewiseLinearOrder = checkSpecialRelation . IsPiecewiseLinearOrder++-- | Make sure it's internally acceptable+sanitizeRelName :: String -> String+sanitizeRelName s = "__internal_sbv_" ++ map sanitize s+ where sanitize c | isSpace c || isPunctuation c = '_'+ | True = c++-- | Create the transitive closure of a given relation. The string argument must uniquely identify the newly created relation.+mkTransitiveClosure :: forall a. SymVal a => String -> Relation a -> Relation a+mkTransitiveClosure nm rel = res+ where ka = kindOf (Proxy @a)++ -- The internal name of this relation+ inm = sanitizeRelName $ "_TransitiveClosure_" ++ nm ++ "_"+ key = (inm, nm)++ res (a, b) = SBV $ SVal KBool $ Right $ cache result+ where result st = do -- Is this new? If so create it, otherwise reuse+ ProgInfo{progTransClosures = curProgTransClosures} <- readIORef (rProgInfo st)++ unless (key `elem` curProgTransClosures) $ do++ registerKind st ka++ -- Add to the end so if we get incremental ones the order doesn't change for old ones!+ modifyIORef' (rProgInfo st) (\u -> u{progTransClosures = curProgTransClosures ++ [key]})++ -- Equate it to the relation we are given. We want to do this in the root state+ let SBV eq = quantifiedBool $ \(Forall x) (Forall y) -> rel (x, y) .== uninterpret inm x y+ internalConstraint (getRootState st) False [] eq++ sa <- sbvToSV st a+ sb <- sbvToSV st b++ newExpr st KBool $ SBVApp (Uninterpreted (T.pack nm)) [sa, sb]++-- | Check if the given relation satisfies the required axioms+checkSpecialRelation :: forall a. SymVal a => SpecialRelOp -> Relation a -> SBool+checkSpecialRelation op rel = SBV $ SVal KBool $ Right $ cache result+ where ka = kindOf (Proxy @a)++ internalize nm = case op of+ IsPartialOrder _ -> IsPartialOrder nm+ IsLinearOrder _ -> IsLinearOrder nm+ IsTreeOrder _ -> IsTreeOrder nm+ IsPiecewiseLinearOrder _ -> IsPiecewiseLinearOrder nm++ result st = do -- The internal name of this relation+ let nm = sanitizeRelName (show op)+ iop = internalize nm++ -- Is this new? If so create it, otherwise reuse+ ProgInfo{progSpecialRels = curSpecialRels} <- readIORef (rProgInfo st)++ unless (op `elem` curSpecialRels) $ do++ registerKind st ka+ uop <- newUninterpreted st (UIGiven nm) Nothing (SBVType [ka, ka, KBool]) (UINone True)++ let nm' = case uop of+ Uninterpreted s -> T.unpack s+ _ -> error $ "Data.SBV: Impossible happened: checkSpecialRelation received: " ++ show op++ -- Add to the end so if we get incremental ones the order doesn't change for old ones!+ modifyIORef' (rProgInfo st) (\u -> u{progSpecialRels = curSpecialRels ++ [iop]})++ -- Equate it to the relation we are given. We want to do this in the parent state+ let SBV eq = quantifiedBool $ \(Forall x) (Forall y) -> rel (x, y) .== uninterpret nm' x y+ internalConstraint (getRootState st) False [] eq++ newExpr st KBool $ SBVApp (SpecialRelOp ka iop) []++-- | Optimize lexicographically, with the default solver.+optLexicographic :: Satisfiable a => a -> IO SMTResult+optLexicographic = optLexicographicWith defaultSMTCfg++-- | Optimize lexicographically, using the given solver.+optLexicographicWith :: Satisfiable a => SMTConfig -> a -> IO SMTResult+optLexicographicWith config p = do+ res <- optimizeWith config Lexicographic p+ case res of+ LexicographicResult r -> pure r+ _ -> error $ "A lexicographic optimization call resulted in a bad result:"+ ++ "\n" ++ show res++-- | Pareto front optimization, with the default solver.+optPareto :: Satisfiable a => Maybe Int -> a -> IO (Bool, [SMTResult])+optPareto = optParetoWith defaultSMTCfg++-- | Pareto front optimization, with the given solver. The optional integer argument is the number of fronts to return. If 'Nothing', then+-- we will return all pareto fronts. If the first component of the result is 'True' then we reached the pareto-query limit specified by+-- the user, so there might be more unqueried results remaining. If 'False', it means that all the pareto fronts are returned.+optParetoWith :: Satisfiable a => SMTConfig -> Maybe Int -> a -> IO (Bool, [SMTResult])+optParetoWith config mbLim p = do+ res <- optimizeWith config (Pareto mbLim) p+ case res of+ ParetoResult r -> pure r+ _ -> error $ "A pareto optimization call resulted in a bad result:"+ ++ "\n" ++ show res++-- | Independent optimization, with the default solver. In each result, string is the name of the objective optimized given by the user.+optIndependent :: Satisfiable a => a -> IO [(String, SMTResult)]+optIndependent = optIndependentWith defaultSMTCfg++-- | Independent optimization, with the given solver. In each result, string is the name of the objective optimized given by the user.+optIndependentWith :: Satisfiable a => SMTConfig -> a -> IO [(String, SMTResult)]+optIndependentWith config p = do+ res <- optimizeWith config Independent p+ case res of+ IndependentResult r -> pure r+ _ -> error $ "An independent optimization call resulted in a bad result:"+ ++ "\n" ++ show res++-- | An queriable value: Mapping between concrete/symbolic values. If your type is traversable and simply embeds+-- symbolic equivalents for one type, then you can simply define 'create'. (Which is the most common case.)+class Queriable m a where+ type QueryResult a :: Type++ -- | ^ Create a new symbolic value of type @a@+ create :: QueryT m a++ -- | ^ Extract the current value in a SAT context+ project :: a -> QueryT m (QueryResult a)++ -- | ^ Create a literal value. Morally, 'embed' and 'project' are inverses of each other+ -- via the t'QueryT' monad transformer.+ embed :: QueryResult a -> QueryT m a++ default project :: (a ~ t e, QueryResult (t e) ~ t (QueryResult e), Traversable t, Monad m, Queriable m e) => a -> QueryT m (QueryResult a)+ project = mapM project++ default embed :: (a ~ t e, QueryResult (t e) ~ t (QueryResult e), Traversable t, Monad m, Queriable m e) => QueryResult a -> QueryT m a+ embed = mapM embed+ {-# MINIMAL create #-}++-- | Generic 'Queriable' instance for 'SymVal' values. This provides the base case for the generic definitions for project and embed+-- when we automatically derive them. We make this instance overlappable should the user have a different mapping in mind, for instance+-- mapping a symbolic boolean to a concrete integer for whatever reason.+instance {-# OVERLAPPABLE #-} (MonadIO m, SymVal a) => Queriable m (SBV a) where+ type QueryResult (SBV a) = a++ create = freshVar_+ project = getValue+ embed = pure . literal++{- HLint ignore module "Use import/export shortcut" -}
Data/SBV/Char.hs view
@@ -14,18 +14,19 @@ -- and strings. -- -- 'SChar' type only covers all unicode characters, following the specification--- in <http://smtlib.cs.uiowa.edu/theories-UnicodeStrings.shtml>.+-- in <https://smt-lib.org/theories-UnicodeStrings.shtml>. -- However, some of the recognizers only support the Latin1 subset, suffixed -- by @L1@. The reason for this is that there is no performant way of performing -- these functions for the entire unicode set. As SMTLib's capabilities increase, -- we will provide full unicode versions as well. ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Char ( -- * Occurrence in a string@@ -43,7 +44,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@@ -51,19 +52,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--- >>> -- For doctest purposes only: -- >>> 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.@@ -74,7 +78,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? --@@ -208,7 +212,7 @@ isPrintL1 :: SChar -> SBool isPrintL1 = liftPredL1 C.isPrint --- | Is this an ASCII digit, i.e., one of @0@..@9@. Note that this is a subset of 'isNumberL1' +-- | Is this an ASCII digit, i.e., one of @0@..@9@. Note that this is a subset of 'isNumberL1'. -- -- >>> prove $ \c -> isDigit c .=> isNumberL1 c -- Q.E.D.@@ -286,3 +290,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
@@ -10,44 +10,71 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PackageImports #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wall -Werror #-}+#if MIN_VERSION_template_haskell(2,22,1)+-- No need for newer versions of TH+#else+{-# LANGUAGE FlexibleInstances #-}+#endif +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}+ module Data.SBV.Client ( sbvCheckSolverInstallation , defaultSolverConfig , getAvailableSolvers- , mkSymbolicEnumeration- , mkUninterpretedSort+ , mkSymbolic+ , getConstructors ) where -import Control.Monad (filterM)+import Data.SBV.Core.TH (getConstructors, bad, report)+ import Data.Generics +import Control.Monad (filterM, mapAndUnzipM, zipWithM)+import Data.Function (fix)+import Test.QuickCheck (Arbitrary(..), elements)+ import qualified Control.Exception as C +import Data.Char+import Data.Word+import Data.Int+import Data.Ratio+ import qualified "template-haskell" Language.Haskell.TH as TH-#if MIN_VERSION_template_haskell(2,18,0) import qualified "template-haskell" Language.Haskell.TH.Syntax as TH-#endif +import Language.Haskell.TH.ExpandSyns as TH++import Data.SBV.Core.Concrete (cvRank) import Data.SBV.Core.Data import Data.SBV.Core.Model+import Data.SBV.Core.SizedFloats+import Data.SBV.Core.Symbolic (registerKind)+ import Data.SBV.Provers.Prover+import qualified Data.SBV.List as SL +import Data.List (genericLength)++import Data.SBV.TP.Kernel+ -- | Check whether the given solver is installed and is ready to go. This call does a -- simple call to the solver to ensure all is well. sbvCheckSolverInstallation :: SMTConfig -> IO Bool-sbvCheckSolverInstallation cfg = check `C.catch` (\(_ :: C.SomeException) -> return False)+sbvCheckSolverInstallation cfg = check `C.catch` (\(_ :: C.SomeException) -> pure False) where check = do ThmResult r <- proveWith cfg $ \x -> sNot (sNot x) .== (x :: SBool) case r of- Unsatisfiable{} -> return True- _ -> return False+ Unsatisfiable{} -> pure True+ _ -> pure False -- | The default configs corresponding to supported SMT solvers defaultSolverConfig :: Solver -> SMTConfig@@ -58,6 +85,7 @@ defaultSolverConfig CVC5 = cvc5 defaultSolverConfig DReal = dReal defaultSolverConfig MathSAT = mathSAT+defaultSolverConfig OpenSMT = openSMT defaultSolverConfig Yices = yices defaultSolverConfig Z3 = z3 @@ -65,111 +93,685 @@ 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.-declareSymbolic :: Bool -> TH.Name -> TH.Q [TH.Dec]-declareSymbolic isEnum typeName = do- let typeCon = TH.conT typeName+#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+deriving instance TH.Lift TH.Type+deriving instance TH.Lift TH.Specificity+deriving instance TH.Lift (TH.TyVarBndr TH.Specificity)+deriving instance TH.Lift (TH.TyVarBndr ())+deriving instance TH.Lift TH.TyLit+#endif - cstrs <- if isEnum then ensureEnumeration typeName- else ensureEmptyData typeName+-- A few other things we need to TH lift+deriving instance TH.Lift Kind - deriveEqOrds <- if isEnum- then [d| deriving instance Eq $typeCon- deriving instance Ord $typeCon- |]- else pure []+data ADTKind = ADTUninterpreted -- Completely uninterpreted+ | ADTEnum -- Enumeration+ | ADTFull -- A full datatype - 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- |]+-- | Create a mutually recursive group of ADTs.+mkSymbolic :: [TH.Name] -> TH.Q [TH.Dec]+mkSymbolic ts = concat <$> mapM mkSymbolicADT ts +-- | Create a symbolic ADT.+mkSymbolicADT :: TH.Name -> TH.Q [TH.Dec]+mkSymbolicADT typeName = do - sType <- TH.conT ''SBV `TH.appT` typeCon+ (tKind, params, cstrs) <- dissect typeName+ ds <- mkADT tKind typeName params cstrs - let declConstructor c = ((nm, bnm), [sig, def])- where bnm = TH.nameBase c- nm = TH.mkName $ 's' : bnm- def = TH.FunD nm [TH.Clause [] (TH.NormalB body) []]- body = TH.AppE (TH.VarE 'literal) (TH.ConE c)- sig = TH.SigD nm sType+ -- declare an "undefiner" so we don't have stray names+ nm <- TH.newName $ "_undefiner_" ++ TH.nameBase typeName+ addDoc "Autogenerated definition to avoid unused-variable warnings from GHC." nm - (constrNames, cdecls) = unzip (map declConstructor cstrs)+ -- undefiner must be careful in putting ascriptions+ aVar <- TH.newName "a"+ let undefine n+ | base == "sCase" ++ tbase = wrap 1 -- Needs an extra param+ | True = wrap 0+ where tbase = TH.nameBase typeName+ base = TH.nameBase n+ wrap c = foldl TH.AppTypeE (TH.VarE n) (replicate (c + length params) (TH.ConT ''Integer)) + names = [undefine n | TH.FunD n _ <- ds]+ body = foldl TH.AppE (TH.VarE 'undefined)+ (names ++ [TH.SigE (TH.VarE 'undefined)+ (foldl TH.AppT (TH.ConT (TH.mkName ('S' : TH.nameBase typeName)))+ (map (const (TH.ConT ''Integer)) params))])++ undefSig = TH.SigD nm (TH.ForallT [] [] (TH.VarT aVar))+ undefBody = TH.FunD nm [TH.Clause [] (TH.NormalB body) []]++ pure $ ds ++ [undefSig, undefBody]++-- | Add document to a generated declaration for the declaration+addDeclDocs :: (TH.Name, String) -> [(TH.Name, String)] -> TH.Q ()+addDeclDocs (tnm, ts) cnms = do add True (tnm, ts)+ mapM_ (add False) cnms+ where add True (cnm, cs) = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc cnm) $ "Symbolic version of the type t'" ++ cs ++ "'."+ add False (cnm, cs) = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc cnm) $ "Symbolic version of the constructor v'" ++ cs ++ "'."++-- | Add document to a generated function+addDoc :: String -> TH.Name -> TH.Q ()+addDoc what tnm = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc tnm) what++-- | Symbolic version of a type+mkSBV :: TH.Type -> TH.Type+mkSBV a = TH.ConT ''SBV `TH.AppT` a++-- | Saturate the type with its parameters+saturate :: TH.Type -> [TH.Name] -> TH.Type+saturate t ps = foldr (\p b -> TH.AppT b (TH.VarT p)) t (reverse ps)++-- | Create a symbolic ADT+mkADT :: ADTKind -- What kind of ADT are we generating?+ -> TH.Name -- type name+ -> [TH.Name] -- parameters+ -> [(TH.Name, [(Maybe TH.Name, TH.Type, Kind)])] -- constructors+ -> TH.Q [TH.Dec] -- declarations+mkADT adtKind typeName params cstrs = do++ let typeCon = saturate (TH.ConT typeName) params+ sType = mkSBV typeCon++ inSymValContext = TH.ForallT [] [TH.AppT (TH.ConT ''SymVal) (TH.VarT n) | n <- params]++ isEnum = case adtKind of+ ADTUninterpreted -> False+ ADTEnum -> True+ ADTFull -> False++ -- Given Cstr f1 f2 f3, generate the clause:+ -- inp@(Cstr [f1, f2, f3]) = case sequenceA [unlitCV (literal f1), unlitCV (literal f2), unlitCV (literal f3)] of+ -- Just c -> let k = kindOf inp+ -- in SBV $ SVal k (Left (CV k (CADT (Cstr, c))))+ -- Nothing -> sCstr (literal f1)+ --+ mkLitClause (n, fs) = do+ as <- mapM (const (TH.newName "a")) fs+ inp <- TH.newName "inp"+ c <- TH.newName "c"++ let app a b = [| $a (literal $b) |]++ TH.clause [TH.asP inp (TH.conP n (map TH.varP as))]+ (TH.normalB+ (TH.caseE [| sequenceA $(TH.listE [ [| unlitCV (literal $(TH.varE a)) |] | a <- as ]) |]+ [ TH.match [p|Just $(TH.varP c)|]+ (TH.normalB [| let k = kindOf $(TH.varE inp)+ in SBV $ SVal k (Left (CV k (CADT (TH.nameBase n, $(TH.varE c)))))+ |])+ []+ , TH.match [p|Nothing|]+ (TH.normalB (foldl app (TH.varE (TH.mkName ('s' : TH.nameBase n))) (map TH.varE as)))+ []+ ]))+ []++ litFun <- case adtKind of+ ADTUninterpreted -> do noLit <- [| error $ unlines [ "Data.SBV: unexpected call to derived literal implementation"+ , "***"+ , "*** Type: " ++ show typeName+ , ""+ , "***Please report this as a bug!"+ ]+ |]+ pure $ TH.FunD 'literal [TH.Clause [TH.WildP] (TH.NormalB noLit) []]++ ADTEnum -> TH.FunD 'literal <$> mapM mkLitClause cstrs+ ADTFull -> TH.FunD 'literal <$> mapM mkLitClause cstrs++ fromCVFunName <- TH.newName ("cv2" ++ TH.nameBase typeName)+ addDoc ("Conversion from SMT values to " ++ TH.nameBase typeName ++ " values.") fromCVFunName++ let fromCVSig = TH.SigD fromCVFunName+ (inSymValContext (foldr (TH.AppT . TH.AppT TH.ArrowT) typeCon+ [TH.ConT ''String, TH.AppT TH.ListT (TH.ConT ''CV)]))++ fromCVCls :: (TH.Name, [(Maybe TH.Name, TH.Type, Kind)]) -> TH.Q TH.Clause+ fromCVCls (nm, args) = do+ ns <- mapM (\(i, _) -> TH.newName ("a" ++ show i)) (zip [(1::Int)..] args)+ let pat = foldr ((\p acc -> TH.ConP '(:) [] [p, acc]) . TH.VarP) (TH.ConP '[] [] []) ns+ pure $ TH.Clause [TH.LitP (TH.StringL (TH.nameBase nm)), pat]+ (TH.NormalB (foldl TH.AppE (TH.ConE nm)+ [TH.AppE (TH.VarE 'fromCV) (TH.VarE n) | n <- ns]))+ []++ catchAll <- do s <- TH.newName "s"+ l <- TH.newName "l"+ let errStr = TH.LitE (TH.StringL ("fromCV " ++ TH.nameBase typeName ++ ": Unexpected constructor/arity: "))+ tup = TH.TupE [Just (TH.VarE s), Just (TH.AppE (TH.VarE 'length) (TH.VarE l))]+ showCall = TH.AppE (TH.VarE 'show) tup+ errMsg = TH.InfixE (Just errStr) (TH.VarE '(++)) (Just showCall)+ pure $ TH.Clause [TH.VarP s, TH.VarP l] (TH.NormalB (TH.AppE (TH.VarE 'error) errMsg)) []++ fromCVFun <- do clss <- mapM fromCVCls cstrs+ pure $ TH.FunD fromCVFunName (clss ++ [catchAll])++ getFromCV <- [| let unexpected w = error $ "fromCV: " ++ show typeName ++ ": " ++ w+ kindName (KADT n _ _) = n+ kindName (KApp n _) = n+ kindName k = unexpected $ "An ADT kind was expected, but got: " ++ show k+ in \case CV k (CADT (c, kvs)) | kindName k == unmod typeName+ -> $(TH.varE fromCVFunName) c (map (uncurry CV) kvs)+ CV k e -> unexpected $ "Was expecting a CADT value, but got kind: " ++ show k ++ " (rank: " ++ show (cvRank e) ++ ")"+ |]++ symCtx <- TH.cxt [TH.appT (TH.conT ''SymVal) (TH.varT n) | n <- params]++ mmBound <- if isEnum+ then let universe = [TH.conE con | (con, _) <- cstrs]+ (minb, maxb) = case (universe, reverse universe) of+ (x:_, y:_) -> (x, y)+ _ -> error $ "Impossible: Ran out of elements in determining bounds: " ++ show cstrs+ in [| Just ($minb, $maxb) |]+ else [| Nothing |]++ -- make the initializer to get the subtypes registered+ st <- TH.newName "_st" -- Get an underscored name here, since st might go unused if there're no subtypes+ register <- do let concretize b@TH.ConT{} = b+ concretize TH.VarT{} = TH.ConT ''Integer+ concretize (TH.AppT l arg) = TH.AppT (concretize l) (concretize arg)+ concretize r = r++ end <- TH.noBindS [| pure () |]+ pure $ TH.DoE Nothing $ [TH.NoBindS (TH.AppE (TH.AppE (TH.VarE 'registerKind) (TH.VarE st))+ (TH.AppE (TH.VarE 'kindOf)+ (TH.AppTypeE (TH.ConE 'Proxy) (concretize t))))+ | (_, fts) <- cstrs, (_, t, KApp n _) <- fts, n /= TH.nameBase typeName+ ] ++ [end]++ let regFun = TH.FunD 'mkSymValInit [TH.Clause [TH.VarP st, TH.WildP] (TH.NormalB register) []]++ let symVal = TH.InstanceD+ Nothing+ symCtx+ (TH.AppT (TH.ConT ''SymVal) typeCon)+ [ litFun+ , regFun+ , TH.FunD 'minMaxBound [TH.Clause [] (TH.NormalB mmBound) []]+ , TH.FunD 'fromCV [TH.Clause [] (TH.NormalB getFromCV) []]+ ]++ defCstrs <- [| [(unmod n, map (\(_, _, t) -> t) ntks) | (n, ntks) <- cstrs] |]++ kindCtx <- TH.cxt [TH.appT (TH.conT ''HasKind) (TH.varT p) | p <- params]++ let mkPair a b = TH.TupE [Just a, Just b]+ kindDef = foldl1 TH.AppE [ TH.ConE 'KADT+ , TH.LitE (TH.StringL (unmod typeName))+ , TH.ListE [ mkPair (TH.LitE (TH.StringL (TH.nameBase p)))+ (TH.AppE (TH.VarE 'kindOf) (TH.AppTypeE (TH.ConE 'Proxy) (TH.VarT p)))+ | p <- params+ ]+ , defCstrs+ ]++ kindDecl = TH.InstanceD+ Nothing+ kindCtx+ (TH.AppT (TH.ConT ''HasKind) typeCon)+ [TH.FunD 'kindOf [TH.Clause [TH.WildP] (TH.NormalB kindDef) []]]++ hasArbitrary <- TH.isInstance ''Arbitrary [typeCon]+ arbDecl <- case () of+ () | hasArbitrary -> pure []+ | isEnum -> let universe = TH.listE [TH.conE con | (con, _) <- cstrs]+ in [d|instance Arbitrary $(pure typeCon) where+ arbitrary = elements $universe+ |]+ | True -> [d|instance {-# OVERLAPPABLE #-} Arbitrary $(pure 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."+ ]+ |]++ -- Declare constructors+ let declConstructor :: (TH.Name, [(Maybe TH.Name, TH.Type, Kind)]) -> TH.Q ((TH.Name, String), [TH.Dec])+ declConstructor (n, ntks) = do+ let ats = map (mkSBV . (\(_, t, _) -> t)) ntks+ ty = inSymValContext $ foldr (TH.AppT . TH.AppT TH.ArrowT) sType ats+ bnm = TH.nameBase n+ nm = TH.mkName $ 's' : bnm++ as <- mapM (const (TH.newName "a")) ntks+ c <- TH.newName "c"++ cls <- TH.clause (map TH.varP as)+ (TH.normalB+ (TH.caseE [| sequenceA $(TH.listE [ [| unlitCV $(TH.varE a) |] | a <- as ]) |]+ [ TH.match [p|Just $(TH.varP c)|]+ -- We need the kind of the result type to build the value, but the+ -- result type can only be recovered from the (signature-pinned) result+ -- itself: a parametric type may carry the parameter in a phantom+ -- position (e.g. the @a@ in @Right :: b -> Either a b@) that no argument+ -- mentions. We tie the kind to the result via 'fix'. Crucially, 'fix'+ -- binds @res@ as a /lambda-bound/ variable, which is always monomorphic;+ -- a plain @let@ group would be generalized when the monomorphism+ -- restriction is off (as it is at the GHCi prompt), yielding a spurious+ -- ambiguous @HasKind@. ('kindOf' ignores its argument, so 'fix' is safe.)+ (TH.normalB [| fix (\res -> let k = kindOf res+ in SBV $ SVal k (Left (CV k (CADT (bnm, $(TH.varE c)))))) |])+ []+ , TH.match [p|Nothing|]+ (TH.normalB (foldl (\a b -> [| $a $b |]) [| mkADTConstructor bnm |] (map TH.varE as)))+ []+ ]))+ []++ pure ((nm, bnm), [TH.SigD nm ty, TH.FunD nm [cls]])++ (constrNames, cdecls) <- mapAndUnzipM declConstructor cstrs+ let btname = TH.nameBase typeName tname = TH.mkName ('S' : btname)- tdecl = TH.TySynD tname [] sType+ tdecl = TH.TySynD tname [TH.PlainTV p TH.BndrReq | p <- params] sType - addDocs (tname, btname) constrNames+ addDeclDocs (tname, btname) constrNames - pure $ deriveEqOrds ++ derives ++ [tdecl] ++ concat cdecls+ -- Declare accessors+ let -- NB. field count starts at 1!+ declAccessor :: TH.Name -> (Maybe TH.Name, TH.Type, Kind) -> Int -> TH.Q [((TH.Name, String), [TH.Dec])]+ declAccessor c (mbUN, ft, _) i = do+ let bnm = TH.nameBase c+ anm = "get" ++ bnm ++ "_" ++ show i+ nm = TH.mkName anm+ ty = inSymValContext $ TH.AppT (TH.AppT TH.ArrowT sType) (mkSBV ft) - where addDocs :: (TH.Name, String) -> [(TH.Name, String)] -> TH.Q ()-#if MIN_VERSION_template_haskell(2,18,0)- addDocs (tnm, ts) cnms = do addDoc True (tnm, ts)- mapM_ (addDoc False) cnms- where addDoc True (cnm, cs) = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc cnm) $ "Symbolic version of the type '" ++ cs ++ "'."- addDoc False (cnm, cs) = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc cnm) $ "Symbolic version of the constructor '" ++ cs ++ "'."-#else- addDocs _ _ = pure ()-#endif+ cls <- do inp <- TH.newName "inp"+ TH.clause [TH.varP inp]+ (TH.normalB+ (TH.caseE [| unlitCV $(TH.varE inp) |]+ [ TH.match [p|Just (_, CADT (got, kv))|]+ (TH.guardedB [do g <- TH.normalG [| got == bnm |]+ e <- [| let (k, v) = (kv !! (i-1))+ in SBV $ SVal k (Left (CV k v))+ |]+ pure (g, e)+ ])+ []+ , TH.match [p|_|]+ (TH.normalB [| mkADTAccessor anm $(TH.varE inp) |])+ []+ ]))+ [] --- | Make an enumeration a symbolic type.-mkSymbolicEnumeration :: TH.Name -> TH.Q [TH.Dec]-mkSymbolicEnumeration = declareSymbolic True+ -- If there's a custom accessor given, declare that here too+ extras <- case mbUN of+ Nothing -> pure []+ Just un -> do let sun = TH.mkName $ 's' : TH.nameBase un+ pure [((sun, bnm), [TH.SigD sun ty, TH.FunD sun [cls]])] --- | Make an uninterpred sort.-mkUninterpretedSort :: TH.Name -> TH.Q [TH.Dec]-mkUninterpretedSort = declareSymbolic False+ pure $ ((nm, bnm), [TH.SigD nm ty, TH.FunD nm [cls]]) : extras --- | Make sure the given type is an enumeration-ensureEnumeration :: TH.Name -> TH.Q [TH.Name]-ensureEnumeration nm = do- c <- TH.reify nm- case c of- TH.TyConI d -> case d of- TH.DataD _ _ _ _ cons _ -> case cons of- [] -> bad "The datatype given has no constructors."- xs -> concat <$> mapM check xs- _ -> bad "The name given is not a datatype."+ allDefs <- sequence [zipWithM (declAccessor c) fs [(1::Int) ..] | (c, fs) <- cstrs]+ let (accessorNames, accessorDecls) = unzip $ concat (concat allDefs) - _ -> bad "The name given is not a datatype."- where n = TH.nameBase nm+ mapM_ (addDoc "Field accessor function." . fst) accessorNames - check (TH.NormalC c xs) = case xs of- [] -> pure [c]- _ -> bad $ "Constructor " ++ show c ++ " has arguments."+ testerDecls <- mkTesters sType inSymValContext cstrs - check c = bad $ "Constructor " ++ show c ++ " is not an enumeration value."+ -- Get the case analyzer+ caseSigFuns <- mkCaseAnalyzer adtKind typeName params cstrs - bad m = do TH.reportError $ unlines [ "Data.SBV.mkSymbolicEnumeration: Invalid argument " ++ show n- , ""- , " Expected an enumeration. " ++ m- , ""- , " To create an enumerated sort, use a simple Haskell enumerated type."- ]- pure []+ -- Get the induction schema, upto 5 extra args. Only for enums and adts+ indDecs <- do let schemas = mapM (mkInductionSchema typeName params cstrs) [0 .. 5]+ case adtKind of+ ADTUninterpreted -> pure []+ ADTEnum -> schemas+ ADTFull -> schemas --- | Make sure the given type is an empty data-ensureEmptyData :: TH.Name -> TH.Q [TH.Name]-ensureEmptyData nm = do- c <- TH.reify nm- case c of- TH.TyConI d -> case d of- TH.DataD _ _ _ _ cons _ -> case cons of- [] -> pure []- _ -> bad "The datatype given has constructors."- _ -> bad "The name given is not a datatype."+ -- If this is an enumeration get EnumSymbolic and OrSymbolic instances+ symEnum <- case adtKind of+ ADTUninterpreted -> pure []+ ADTFull -> pure []+ ADTEnum ->+ let universe = TH.listE [TH.conE con | (con, _) <- cstrs]+ universeS = TH.listE [TH.litE (TH.stringL (TH.nameBase con)) | (con, _) <- cstrs]+ in [d| instance SatModel $(TH.conT typeName) where+ parseCVs (CV _ (CADT (s, [])) : r)+ | Just v <- s `lookup` zip $universeS $universe+ = Just (v, r)+ parseCVs _ = Nothing - _ -> bad "The name given is not a datatype."- where n = TH.nameBase nm- bad m = do TH.reportError $ unlines [ "Data.SBV.mkUninterpretedSort: Invalid argument " ++ show n- , ""- , " Expected an empty datatype. " ++ m- , ""- , " To create an uninterpreted sort, use an empty datatype declaration."- ]- pure []+ instance SL.EnumSymbolic $(TH.conT typeName) where+ succ x = go (zip $universe (drop 1 $universe))+ where go [] = some ("succ_" ++ show typeName ++ "_maximal") (const sTrue)+ go ((c, s) : rest) = ite (x .== literal c) (literal s) (go rest)++ pred x = go (zip (drop 1 $universe) $universe)+ where go [] = some ("pred_" ++ show typeName ++ "_minimal") (const sTrue)+ go ((c, s) : rest) = ite (x .== literal c) (literal s) (go rest)++ toEnum x = go (zip $universe [0..])+ where go [] = some ("toEnum_" ++ show typeName ++ "_out_of_range") (const sTrue)+ go ((c, i) : rest) = ite (x .== literal i) (literal c) (go rest)++ fromEnum x = go 0 $universe+ where go _ [] = error "fromEnum: Impossible happened, ran out of elements."+ go i [_] = i+ go i (c:cs) = ite (x .== literal c) i (go (i+1) cs)++ enumFrom n = SL.map SL.toEnum (SL.enumFromTo (SL.fromEnum n) (genericLength $universe - 1))++ 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 (genericLength $universe - 1))+ (SL.enumFromThenTo i_n1 i_n2 0))++ 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))++ instance OrdSymbolic (SBV $(TH.conT typeName)) where+ a .< b = SL.fromEnum a .< SL.fromEnum b+ a .<= b = SL.fromEnum a .<= SL.fromEnum b+ a .> b = SL.fromEnum a .> SL.fromEnum b+ a .>= b = SL.fromEnum a .>= SL.fromEnum b+ |]++ pure $ [tdecl, symVal, kindDecl]+ ++ arbDecl+ ++ concat cdecls+ ++ testerDecls+ ++ concat accessorDecls+ ++ symEnum+ ++ [fromCVSig, fromCVFun]+ ++ caseSigFuns+ ++ concat indDecs++-- | Make a case analyzer for the type. Works for ADTs and enums. Returns sig and defn+mkCaseAnalyzer :: ADTKind -> TH.Name -> [TH.Name] -> [(TH.Name, [(Maybe TH.Name, TH.Type, Kind)])] -> TH.Q [TH.Dec]+mkCaseAnalyzer kind typeName params cstrs = case kind of+ ADTUninterpreted -> pure [] -- no case analyzer for fully uninterpreted types+ ADTEnum -> mk+ ADTFull -> mk+ where mk = do let typeCon = saturate (TH.ConT typeName) params+ sType = mkSBV typeCon++ bnm = TH.nameBase typeName+ cnm = TH.mkName $ "sCase" ++ bnm++ se <- TH.newName ('s' : bnm)+ fs <- mapM (\(nm, _) -> TH.newName ('f' : TH.nameBase nm)) cstrs+ res <- TH.newName "result"++ let def = TH.FunD cnm [TH.Clause (map TH.VarP (fs ++ [se])) (TH.NormalB (iteChain (zipWith (mkCase se) fs cstrs))) []]++ iteChain :: [(TH.Exp, TH.Exp)] -> TH.Exp+ iteChain [] = error $ unlines [ "Data.SBV.mkADT: Impossible happened!"+ , ""+ , " Received an empty list for: " ++ show typeName+ , ""+ , "While building the case-analyzer."+ , "Please report this as a bug."+ ]+ iteChain [(_, l)] = l+ iteChain ((t, e) : rest) = foldl TH.AppE (TH.VarE 'ite) [TH.AppE t (TH.VarE se), e, iteChain rest]++ mkCase :: TH.Name -> TH.Name -> (TH.Name, [(Maybe TH.Name, TH.Type, Kind)]) -> (TH.Exp, TH.Exp)+ mkCase cexpr func (c, fields) = (TH.VarE (TH.mkName ("is" ++ TH.nameBase c)), foldl TH.AppE (TH.VarE func) args)+ where getters = [TH.mkName ("get" ++ TH.nameBase c ++ "_" ++ show i) | (i, _) <- zip [(1 :: Int) ..] fields]+ args = map (\g -> TH.AppE (TH.VarE g) (TH.VarE cexpr)) getters++ rvar = TH.VarT res+ mkFun = foldr (TH.AppT . TH.AppT TH.ArrowT) rvar+ fTypes = [mkFun (map (mkSBV . (\(_, t, _) -> t)) ftks) | (_, ftks) <- cstrs]+ sig = TH.SigD cnm (TH.ForallT []+ (TH.AppT (TH.ConT ''Mergeable) (TH.VarT res)+ : [TH.AppT (TH.ConT ''SymVal) (TH.VarT p) | p <- params]+ )+ (mkFun (fTypes ++ [sType])))++ addDoc ("Case analyzer for the type " ++ bnm ++ ".") cnm+ pure [sig, def]++-- | Declare testers+mkTesters :: TH.Type -> (TH.Type -> TH.Type) -> [(TH.Name, [(Maybe TH.Name, TH.Type, Kind)])] -> TH.Q [TH.Dec]+mkTesters sType inSymValContext cstrs = do+ let declTester :: (TH.Name, [(Maybe TH.Name, TH.Type, Kind)]) -> TH.Q ((TH.Name, String), [TH.Dec])+ declTester (c, _) = do+ let ty = inSymValContext $ TH.AppT (TH.AppT TH.ArrowT sType) (TH.ConT ''SBool)+ bnm = TH.nameBase c+ nm = TH.mkName $ "is" ++ bnm++ inp <- TH.newName "inp"+ cls <- TH.clause [TH.varP inp]+ (TH.normalB+ (TH.caseE [| unlitCV $(TH.varE inp) |]+ [ TH.match [p|Just (_, CADT (got, _))|]+ (TH.normalB [| literal (got == bnm) |])+ []+ , TH.match [p|Nothing|]+ (TH.normalB [| mkADTTester ("is-" ++ bnm) $(TH.varE inp) |])+ []+ ]))+ []+ pure ((nm, bnm), [TH.SigD nm ty, TH.FunD nm [cls]])++ (testerNames, testerDecls) <- mapAndUnzipM declTester cstrs++ mapM_ (addDoc "Field recognizer predicate." . fst) testerNames++ pure $ concat testerDecls++-- We'll just drop the modules to keep this simple+-- If you use multiple expressions named the same (coming from different modules), oh well.+unmod :: TH.Name -> String+unmod = reverse . takeWhile (/= '.') . reverse . show++-- | Given a type name, determine what kind of a data-type it is.+dissect :: TH.Name -> TH.Q (ADTKind, [TH.Name], [(TH.Name, [(Maybe TH.Name, TH.Type, Kind)])])+dissect typeName = do+ (args, tcs) <- getConstructors typeName++ let mk n (mbfn, t) = do k <- expandSyns t >>= toSBV typeName n+ pure (mbfn, t, k)++ cs <- mapM (\(n, ts) -> (n,) <$> mapM (mk n) ts) tcs++ let k | null cs = ADTUninterpreted+ | all (null . snd) cs = ADTEnum+ | True = ADTFull++ pure (k, args, cs)++-- | Find the SBV kind for this type+toSBV :: TH.Name -> TH.Name -> TH.Type -> TH.Q Kind+toSBV typeName constructorName = go+ where hasArrows (TH.AppT TH.ArrowT _) = True+ hasArrows (TH.AppT lhs rhs) = hasArrows lhs || hasArrows rhs+ hasArrows _ = False++ -- Handle type variables (parameters)+ go (TH.VarT v) = pure $ KVar (TH.nameBase v)++ -- tuples+ go t | Just ps <- getTuple t = KTuple <$> mapM go ps++ -- recognize strings, since we don't (yet) support chars+ go (TH.AppT TH.ListT (TH.ConT t)) | t == ''Char = pure KString++ -- lists+ go (TH.AppT TH.ListT t) = KList <$> go t++ -- arbitrary words/ints+ go (TH.AppT (TH.ConT nm) (TH.LitT (TH.NumTyLit n)))+ | nm == ''WordN = pure $ KBounded False (fromIntegral n)+ | nm == ''IntN = pure $ KBounded True (fromIntegral n)++ -- arbitrary floats+ go (TH.AppT (TH.AppT (TH.ConT nm) (TH.LitT (TH.NumTyLit eb))) (TH.LitT (TH.NumTyLit sb)))+ | nm == ''FloatingPoint = pure $ KFP (fromIntegral eb) (fromIntegral sb)++ -- Rational+ go (TH.AppT (TH.ConT nm) (TH.ConT i))+ | nm == ''Ratio && i == ''Integer+ = pure KRational++ -- deal with base types+ go t@(TH.ConT constr)+ | Just base <- getBase constr+ = case base of+ Left (w, r) -> bad w $ [ "Datatype : " ++ show typeName+ , "Constructor: " ++ show constructorName+ , "Kind : " ++ TH.pprint t+ , ""+ ] ++ r+ Right k -> pure k++ -- deal with constructors+ go t+ | Just (c, ps) <- getConApp t+ = KApp (TH.nameBase c) <$> mapM go ps++ -- giving up+ go t = bad "Unsupported constructor kind" [ "Datatype : " ++ TH.nameBase typeName+ , "Constructor: " ++ TH.nameBase constructorName+ , "Kind : " ++ TH.pprint t+ , ""+ , if hasArrows t+ then "Higher order fields (i.e., function values) are not supported."+ else report+ ]++ -- Extract application of a constructor to some type-variables+ getConApp t = locate t []+ where locate (TH.ConT c) sofar = Just (c, sofar)+ locate (TH.AppT l arg) sofar = locate l (arg : sofar)+ locate _ _ = Nothing++ -- Extract an N-tuple+ getTuple = tup []+ where tup sofar (TH.TupleT _) = Just sofar+ tup sofar (TH.AppT t p) = tup (p : sofar) t+ tup _ _ = Nothing++ -- Given the name of a base type, what's the equivalent in the SBV domain (if we have it)+ getBase :: TH.Name -> Maybe (Either (String, [String]) Kind)+ getBase t+ | t == ''Bool = Just $ Right KBool+ | t == ''Integer = Just $ Right KUnbounded+ | t == ''Float = Just $ Right KFloat+ | t == ''Double = Just $ Right KDouble+ | t == ''Char = Just $ Right KChar+ | t == ''String = Just $ Right KString+ | t == ''AlgReal = Just $ Right KReal+ | t == ''Rational = Just $ Right KRational+ | t == ''Word8 = Just $ Right $ KBounded False 8+ | t == ''Word16 = Just $ Right $ KBounded False 16+ | t == ''Word32 = Just $ Right $ KBounded False 32+ | t == ''Word64 = Just $ Right $ KBounded False 64+ | t == ''Int8 = Just $ Right $ KBounded True 8+ | t == ''Int16 = Just $ Right $ KBounded True 16+ | t == ''Int32 = Just $ Right $ KBounded True 32+ | t == ''Int64 = Just $ Right $ KBounded True 64++ -- Platform specific, flag:+ | t == ''Int+ || t == ''Word = Just $ Left ( "Platform specific type: " ++ show t+ , [ "Please pick a more specific type, such as"+ , "Integer, Word8, WordN 32, IntN 16 etc."+ ])++ -- Otherwise, can't translate+ | True = Nothing++-- | Make an induction schema for the type, with n extra arguments.+mkInductionSchema :: TH.Name -> [TH.Name] -> [(TH.Name, [(Maybe TH.Name, TH.Type, Kind)])] -> Int -> TH.Q [TH.Dec]+mkInductionSchema typeName params cstrs extraArgCnt = do+ let btype = TH.nameBase typeName+ nm = "induct" ++ btype ++ if extraArgCnt == 0 then "" else show extraArgCnt++ pf <- TH.newName "pf"++ extraNames <- mapM (const (TH.newName "extraN")) [0 .. extraArgCnt-1]+ extraSyms <- mapM (const (TH.newName "extraS")) [0 .. extraArgCnt-1]+ extraTypes <- mapM (const (TH.newName "extraT")) [0 .. extraArgCnt-1]++ let mkLam = TH.lamE . map (\a -> TH.conP 'Forall [TH.varP a])++ let mkIndCase :: (TH.Name, [(Maybe TH.Name, TH.Type, Kind)]) -> TH.Q TH.Exp+ mkIndCase (cstr, flds)+ | null flds && null extraNames+ = [| $(TH.varE pf) $(scstr) |]+ | True+ = do as <- mapM (const (TH.newName "a")) flds+ let -- When can we have the inductive hypothesis?+ -- (1) same type+ -- (2) applied at exactly the same types+ isRecursive (_, _, k) = case k of+ KApp t ps -> t == btype && ps == map (KVar . TH.nameBase) params+ _ -> False+ recFields = [a | (a, f) <- zip as flds, isRecursive f]++ TH.appE (TH.varE 'quantifiedBool)+ (mkLam (as ++ extraNames)+ (mkImp recFields (foldl TH.appE+ (TH.appE (TH.varE pf) (foldl TH.appE scstr (map TH.varE as)))+ (map TH.varE extraNames))))+ where cnm = TH.nameBase cstr+ lcnm = map toLower cnm+ scstr = TH.varE (TH.mkName ('s' : cnm))++ mkImp [] e = e+ mkImp [i] e = foldl1 TH.appE [TH.varE '(.=>), assume i, e]+ mkImp is e = foldl1 TH.appE [TH.varE '(.=>), foldl1 TH.appE [TH.varE 'sAnd, TH.listE (map assume is)], e]++ assume :: TH.Name -> TH.Q TH.Exp+ assume n = do en <- mapM (const (TH.newName (lcnm ++ "_extraN"))) [0 .. extraArgCnt-1]+ TH.appE (TH.varE 'quantifiedBool)+ (mkLam en (foldl TH.appE (TH.varE pf) (map TH.varE (n : en))))++ cases <- mapM mkIndCase cstrs+ post <- do a <- TH.newName "recVal"+ TH.appE (TH.varE 'quantifiedBool)+ (mkLam (a : extraNames) $ foldl TH.appE (TH.varE pf) (map TH.varE (a : extraNames)))++ propName <- TH.newName "prop"+ argName <- TH.newName "a"+ taName <- TH.newName "ta"++ let pre = foldl1 TH.AppE [TH.VarE 'sAnd, TH.ListE cases]+ schema = foldl1 TH.AppE [TH.VarE '(.=>), pre, post]+ ihB = TH.AppE (TH.VarE 'proofOf) (foldl1 TH.AppE [TH.VarE 'internalAxiom, TH.LitE (TH.StringL nm), schema])++ instHead = TH.AppT (TH.ConT ''HasInductionSchema)+ (foldr (TH.AppT . TH.AppT TH.ArrowT)+ (TH.ConT ''SBool)+ [ TH.AppT (TH.ConT ''Forall) (TH.VarT es) `TH.AppT` et+ | (es, et) <- zip (taName : extraSyms)+ (saturate (TH.ConT typeName) params : map TH.VarT extraTypes)+ ])++ pfFun = TH.FunD pf [TH.Clause (map TH.VarP (argName : extraNames))+ (TH.NormalB (foldl TH.AppE+ (TH.VarE propName)+ [TH.AppE (TH.ConE 'Forall) (TH.VarE a) | a <- argName : extraNames]))+ []+ ]++ method = TH.FunD 'inductionSchema+ [TH.Clause [TH.VarP propName]+ (TH.NormalB (TH.LetE [pfFun] ihB))+ []+ ]++ context <- TH.cxt [TH.appT (TH.conT ''SymVal) (TH.varT n) | n <- params ++ extraTypes]++ pure [TH.InstanceD Nothing context instHead [method]]
Data/SBV/Client/BaseIO.hs view
@@ -11,106 +11,37 @@ -- @Data.SBV@, where we restrict the underlying monad to be IO. ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Client.BaseIO where -import Data.SBV.Core.Data (HasKind, Kind, Outputtable, Penalty, SymArray,- SymVal, SBool, SBV, SChar, SDouble, SFloat,+import Data.SBV.Core.Data (Kind, Outputtable, Penalty,+ SymVal, SBool, SBV, SChar, SDouble, SFloat, SWord, SInt, SFPHalf, SFPBFloat, SFPSingle, SFPDouble, SFPQuad, SFloatingPoint, SInt8, SInt16, SInt32, SInt64, SInteger, SList, SReal, SString, SV, SWord8, SWord16, SWord32,- SWord64, SEither, SRational, SMaybe, SSet)-import Data.SBV.Core.Sized (SInt, SWord, IntN, WordN)+ SWord64, SRational, SSet, SArray, constrain, (.==)) 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, SVal)+import Data.SBV.Core.Symbolic (Objective, OptimizeStyle, Result, VarContext, Symbolic, SBVRunMode, SMTConfig,+ SVal, symbolicEnv, rPartitionVars, State(..)) import Data.SBV.Control.Types (SMTOption)-import Data.SBV.Provers.Prover (Provable, SExecutable, ThmResult)-import Data.SBV.SMT.SMT (AllSatResult, SafeResult, SatResult,- OptimizeResult)+import Data.SBV.Provers.Prover (Provable, Satisfiable, SExecutable, ThmResult)+import Data.SBV.SMT.SMT (AllSatResult, SafeResult, SatResult, OptimizeResult) -import GHC.TypeLits-import Data.Kind+import GHC.TypeLits (KnownNat) -import Data.Int-import Data.Word+import Data.IORef(readIORef, modifyIORef') import qualified Data.SBV.Core.Data as Trans-import qualified Data.SBV.Core.Sized as Trans import qualified Data.SBV.Core.Model as Trans import qualified Data.SBV.Core.Symbolic as Trans import qualified Data.SBV.Provers.Prover as Trans --- Data.SBV.Provers.Prover:---- | Turns a value into a universally quantified predicate, internally naming the inputs.--- In this case the sbv library will use names of the form @s1, s2@, etc. to name these variables--- Example:------ > universal_ $ \(x::SWord8) y -> x `shiftL` 2 .== y------ is a predicate with two arguments, captured using an ordinary Haskell function. Internally,--- @x@ will be named @s0@ and @y@ will be named @s1@.------ Remember that SBV assumes that the input is in prenex-normal form.--- That is, all quantifiers are at the beginning of the predicate. See--- [note on reasoning in the presence of--- quantifiers]("Data.SBV#noteOnNested") for more information.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.universal_'-universal_ :: Provable a => a -> Symbolic SBool-universal_ = Trans.universal_---- | Turns a value into a predicate, allowing users to provide names for the inputs.--- If the user does not provide enough number of names for the variables, the remaining ones--- will be internally generated. Note that the names are only used for printing models and has no--- other significance; in particular, we do not check that they are unique. Example:------ > universal ["x", "y"] $ \(x::SWord8) y -> x `shiftL` 2 .== y------ This is the same as above, except the variables will be named @x@ and @y@ respectively,--- simplifying the counter-examples when they are printed.------ Remember that SBV assumes that the input is in prenex-normal form.--- That is, all quantifiers are at the beginning of the predicate. See--- [note on reasoning in the presence of--- quantifiers]("Data.SBV#noteOnNested") for more information.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.universal'-universal :: Provable a => [String] -> a -> Symbolic SBool-universal = Trans.universal---- | Turns a value into an existentially quantified predicate.------ Remember that SBV assumes that the input is in prenex-normal form.--- That is, all quantifiers are at the beginning of the predicate. See--- [note on reasoning in the presence of--- quantifiers]("Data.SBV#noteOnNested") for more information.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.existential_'-existential_ :: Provable a => a -> Symbolic SBool-existential_ = Trans.existential_---- | Version of 'existential_' that allows user defined names.------ Remember that SBV assumes that the input is in prenex-normal form.--- That is, all quantifiers are at the beginning of the predicate. See--- [note on reasoning in the presence of--- quantifiers]("Data.SBV#noteOnNested") for more information.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.existential'-existential :: Provable a => [String] -> a -> Symbolic SBool-existential = Trans.existential+import Control.Monad.Trans (liftIO) -- | Prove a predicate, using the default solver. --@@ -139,32 +70,32 @@ -- | Find a satisfying assignment for a predicate, using the default solver. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sat'-sat :: Provable a => a -> IO SatResult+sat :: Satisfiable a => a -> IO SatResult sat = Trans.sat -- | Find a satisfying assignment using the given SMT-solver. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.satWith'-satWith :: Provable a => SMTConfig -> a -> IO SatResult+satWith :: Satisfiable a => SMTConfig -> a -> IO SatResult satWith = Trans.satWith -- | Find a delta-satisfying assignment for a predicate, using the default solver for delta-satisfiability. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.dsat'-dsat :: Provable a => a -> IO SatResult+dsat :: Satisfiable a => a -> IO SatResult dsat = Trans.dsat -- | Find a satisfying assignment using the given SMT-solver. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.satWith'-dsatWith :: Provable a => SMTConfig -> a -> IO SatResult+dsatWith :: Satisfiable a => SMTConfig -> a -> IO SatResult dsatWith = Trans.dsatWith -- | Find all satisfying assignments, using the default solver. -- Equivalent to @'allSatWith' 'Data.SBV.defaultSMTCfg'@. See 'allSatWith' for details. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.allSat'-allSat :: Provable a => a -> IO AllSatResult+allSat :: Satisfiable a => a -> IO AllSatResult allSat = Trans.allSat -- | Return all satisfying assignments for a predicate.@@ -180,32 +111,32 @@ -- Find all satisfying assignments using the given SMT-solver -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.allSatWith'-allSatWith :: Provable a => SMTConfig -> a -> IO AllSatResult+allSatWith :: Satisfiable a => SMTConfig -> a -> IO AllSatResult allSatWith = Trans.allSatWith -- | Optimize a given collection of `Objective`s. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.optimize'-optimize :: Provable a => OptimizeStyle -> a -> IO OptimizeResult+optimize :: Satisfiable a => OptimizeStyle -> a -> IO OptimizeResult optimize = Trans.optimize -- | Optimizes the objectives using the given SMT-solver. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.optimizeWith'-optimizeWith :: Provable a => SMTConfig -> OptimizeStyle -> a -> IO OptimizeResult+optimizeWith :: Satisfiable a => SMTConfig -> OptimizeStyle -> a -> IO OptimizeResult optimizeWith = Trans.optimizeWith --- | Check if the constraints given are consistent, using the default solver.+-- | Check if the constraints given are consistent in a prove call using the default solver. ----- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.isVacuous'-isVacuous :: Provable a => a -> IO Bool-isVacuous = Trans.isVacuous+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.isVacuousProof'+isVacuousProof :: Provable a => a -> IO Bool+isVacuousProof = Trans.isVacuousProof --- | Determine if the constraints are vacuous using the given SMT-solver.+-- | Determine if the constraints are vacuous in a SAT call using the given SMT-solver. ----- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.isVacuousWith'-isVacuousWith :: Provable a => SMTConfig -> a -> IO Bool-isVacuousWith = Trans.isVacuousWith+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.isVacuousProofWith'+isVacuousProofWith :: Provable a => SMTConfig -> a -> IO Bool+isVacuousProofWith = Trans.isVacuousProofWith -- | Checks theoremhood using the default solver. --@@ -222,13 +153,13 @@ -- | Checks satisfiability using the default solver. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.isSatisfiable'-isSatisfiable :: Provable a => a -> IO Bool+isSatisfiable :: Satisfiable a => a -> IO Bool isSatisfiable = Trans.isSatisfiable -- | Check whether a given property is satisfiable. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.isSatisfiableWith'-isSatisfiableWith :: Provable a => SMTConfig -> a -> IO Bool+isSatisfiableWith :: Satisfiable a => SMTConfig -> a -> IO Bool isSatisfiableWith = Trans.isSatisfiableWith -- | Run an arbitrary symbolic computation, equivalent to @'runSMTWith' 'Data.SBV.defaultSMTCfg'@@@ -243,12 +174,10 @@ runSMTWith :: SMTConfig -> Symbolic a -> IO a runSMTWith = Trans.runSMTWith --- | NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sName_'-sName_ :: SExecutable IO a => a -> Symbolic ()-sName_ = Trans.sName_---- | NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sName'-sName :: SExecutable IO a => [String] -> a -> Symbolic ()+-- | Create an argument for a name used in a safety-checking call.+--+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sName_'+sName :: SExecutable IO a => a -> Symbolic () sName = Trans.sName -- | Check safety using the default solver.@@ -284,41 +213,23 @@ output :: Outputtable a => a -> Symbolic a output = Trans.output --- | Create a user named input (universal)------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sbvForall'-sbvForall :: SymVal a => String -> Symbolic (SBV a)-sbvForall = Trans.sbvForall---- | Create an automatically named input------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sbvForall_'-sbvForall_ :: SymVal a => Symbolic (SBV a)-sbvForall_ = Trans.sbvForall_---- | Get a bunch of new words------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.mkForallVars'-mkForallVars :: SymVal a => Int -> Symbolic [SBV a]-mkForallVars = Trans.mkForallVars---- | Create an existential variable------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sbvExists'-sbvExists :: SymVal a => String -> Symbolic (SBV a)-sbvExists = Trans.sbvExists+-- | Create a partitioning constraint, for all-sat calls.+allSatPartition :: SymVal a => String -> SBV a -> Symbolic ()+allSatPartition nm term = do+ State{rPartitionVars} <- symbolicEnv --- | Create an automatically named existential variable------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sbvExists_'-sbvExists_ :: SymVal a => Symbolic (SBV a)-sbvExists_ = Trans.sbvExists_+ -- Generate a unique variable with the prefix nm if necessary and+ -- add it to partitions+ fresh <- liftIO $ do olds <- readIORef rPartitionVars+ let new = case filter (`notElem` olds) (nm : [nm ++ "_" ++ show i | i <- [(1 :: Int) ..]]) of+ h:_ -> h+ [] -> error $ "Impossible: Can't get a fresh variable from infinite list in partition." ++ show (nm, term)+ modifyIORef' rPartitionVars (++ [new])+ pure new --- | Create a bunch of existentials------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.mkExistVars'-mkExistVars :: SymVal a => Int -> Symbolic [SBV a]-mkExistVars = Trans.mkExistVars+ -- declare and constrain+ v <- free fresh+ constrain $ v .== term -- | Create a free variable, universal in a proof, existential in sat --@@ -356,18 +267,6 @@ mkSymVal :: SymVal a => VarContext -> Maybe String -> Symbolic (SBV a) mkSymVal = Trans.mkSymVal --- | Create a new anonymous array, possibly with a default initial value.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.newArray_'-newArray_ :: (SymArray array, HasKind a, HasKind b) => Maybe (SBV b) -> Symbolic (array a b)-newArray_ = Trans.newArray_---- | Create a named new array, possibly with a default initial value.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.newArray'-newArray :: (SymArray array, HasKind a, HasKind b) => String -> Maybe (SBV b) -> Symbolic (array a b)-newArray = Trans.newArray- -- Data.SBV.Core.Model: -- | Generically make a symbolic var@@ -826,24 +725,6 @@ sTuples :: (SymTuple tup, SymVal tup) => [String] -> Symbolic [SBV tup] sTuples = Trans.sTuples --- | Declare a named 'Data.SBV.SEither'.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sEither'-sEither :: (SymVal a, SymVal b) => String -> Symbolic (SEither a b)-sEither = Trans.sEither---- | Declare an unnamed 'Data.SBV.SEither'.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sEither_'-sEither_ :: (SymVal a, SymVal b) => Symbolic (SEither a b)-sEither_ = Trans.sEither_---- | Declare a list of 'Data.SBV.SEither' values.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sEithers'-sEithers :: (SymVal a, SymVal b) => [String] -> Symbolic [SEither a b]-sEithers = Trans.sEithers- -- | Declare a named 'Data.SBV.SRational'. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sRational'@@ -862,24 +743,6 @@ sRationals :: [String] -> Symbolic [SRational] sRationals = Trans.sRationals --- | Declare a named 'Data.SBV.SMaybe'.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sMaybe'-sMaybe :: SymVal a => String -> Symbolic (SMaybe a)-sMaybe = Trans.sMaybe---- | Declare an unnamed 'Data.SBV.SMaybe'.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sMaybe_'-sMaybe_ :: SymVal a => Symbolic (SMaybe a)-sMaybe_ = Trans.sMaybe_---- | Declare a list of 'Data.SBV.SMaybe' values.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sMaybes'-sMaybes :: SymVal a => [String] -> Symbolic [SMaybe a]-sMaybes = Trans.sMaybes- -- | Declare a named 'Data.SBV.SSet'. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sSet'@@ -898,6 +761,24 @@ sSets :: (Ord a, SymVal a) => [String] -> Symbolic [SSet a] sSets = Trans.sSets +-- | Declare a named 'SArray'+--+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sArray'+sArray :: (SymVal a, SymVal b) => String -> Symbolic (SArray a b)+sArray = Trans.sArray++-- | Declare an unnamed 'SArray'+--+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sArray_'+sArray_ :: (SymVal a, SymVal b) => Symbolic (SArray a b)+sArray_ = Trans.sArray_++-- | Declare a list of 'SArray' values.+--+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sArrays'+sArrays :: (SymVal a, SymVal b) => [String] -> Symbolic [SArray a b]+sArrays = Trans.sArrays+ -- | Form the symbolic conjunction of a given list of boolean conditions. Useful in expressing -- problems with constraints, like the following: --@@ -939,7 +820,7 @@ -- | Run a symbolic computation, and return a extra value paired up with the 'Result' -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.runSymbolic'-runSymbolic :: SBVRunMode -> Symbolic a -> IO (a, Result)+runSymbolic :: SMTConfig -> SBVRunMode -> Symbolic a -> IO (a, Result) runSymbolic = Trans.runSymbolic -- | Add a new option@@ -967,145 +848,8 @@ outputSVal :: SVal -> Symbolic () outputSVal = Trans.outputSVal --- | 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"+-- | A variant of observe that you can use at the top-level. This is useful with quick-check, for instance.+--+-- 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 = Trans.sObserve m (Trans.unSBV x)
Data/SBV/Compilers/C.hs view
@@ -9,8 +9,7 @@ -- Compilation of symbolic programs to C ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} @@ -22,14 +21,18 @@ import Data.Maybe (isJust, isNothing, fromJust) import qualified Data.Foldable as F (toList) import qualified Data.Set as Set (member, union, unions, empty, toList, singleton, fromList)+import qualified Data.Text as T import System.FilePath (takeBaseName, replaceExtension) import System.Random +import Data.SBV.Core.Symbolic (ResultInp(..), ProgInfo(..))+ -- Work around the fact that GHC 8.4.1 started exporting <>.. Hmm.. import Text.PrettyPrint.HughesPJ import qualified Text.PrettyPrint.HughesPJ as P ((<>)) import Data.SBV.Core.Data+import Data.SBV.Core.Kind (kRoundingMode) import Data.SBV.Compilers.CodeGen import Data.SBV.Utils.PrettyNum (chex, showCFloat, showCDouble)@@ -57,11 +60,11 @@ compileToC :: Maybe FilePath -> String -> SBVCodeGen a -> IO a compileToC mbDirName nm f = do (retVal, cfg, bundle) <- compileToC' nm f renderCgPgmBundle mbDirName (cfg, bundle)- return retVal+ pure retVal --- | Lower level version of 'compileToC', producing a 'CgPgmBundle'+-- | Lower level version of 'compileToC', producing a t'CgPgmBundle' compileToC' :: String -> SBVCodeGen a -> IO (a, CgConfig, CgPgmBundle)-compileToC' nm f = do rands <- randoms `fmap` newStdGen+compileToC' nm f = do rands <- randoms <$> newStdGen codeGen SBVToC (defaultCgConfig { cgDriverVals = rands }) nm f -- | Create code to generate a library archive (.a) from given symbolic functions. Useful when generating code@@ -77,13 +80,13 @@ compileToCLib :: Maybe FilePath -> String -> [(String, SBVCodeGen a)] -> IO [a] compileToCLib mbDirName libName comps = do (retVal, cfg, pgm) <- compileToCLib' libName comps renderCgPgmBundle mbDirName (cfg, pgm)- return retVal+ pure retVal --- | Lower level version of 'compileToCLib', producing a 'CgPgmBundle'+-- | Lower level version of 'compileToCLib', producing a t'CgPgmBundle' compileToCLib' :: String -> [(String, SBVCodeGen a)] -> IO ([a], CgConfig, CgPgmBundle) compileToCLib' libName comps = do resCfgBundles <- mapM (uncurry compileToC') comps let (finalCfg, finalPgm) = mergeToLib libName [(c, b) | (_, c, b) <- resCfgBundles]- return ([r | (r, _, _) <- resCfgBundles], finalCfg, finalPgm)+ pure ([r | (r, _, _) <- resCfgBundles], finalCfg, finalPgm) --------------------------------------------------------------------------- -- * Implementation@@ -94,7 +97,7 @@ instance CgTarget SBVToC where targetName _ = "C"- translate _ = cgen+ translate _ = cgen -- Unexpected input, or things we will probably never support die :: String -> a@@ -184,7 +187,9 @@ pprCWord cnst v = (if cnst then text "const" else empty) <+> text (showCType v) -- | Almost a "show", but map "SWord1" to "SBool"--- which is used for extracting one-bit words.+-- which is used for extracting one-bit words. This is OK since C's bool type+-- handles arithmetic fine, and maps nicely to our `SWord 1`. (Same isn't true for `SInt 1`, which+-- doesn't have an easy counter-part on the C side. showCType :: HasKind a => a -> String showCType i = case kindOf i of KBounded False 1 -> "SBool"@@ -193,6 +198,7 @@ -- | The printf specifier for the type specifier :: CgConfig -> SV -> Doc specifier cfg sv = case kindOf sv of+ KVar{} -> die $ "variable sort: " ++ show (kindOf sv) KBool -> spec (False, 1) KBounded b i -> spec (b, i) KUnbounded -> spec (True, fromJust (cgInteger cfg))@@ -203,12 +209,12 @@ KChar -> text "%c" KRational -> die "rational sort" KFP{} -> die "arbitrary float sort"- KList k -> die $ "list sort: " ++ show k- KSet k -> die $ "set sort: " ++ show k- KUserSort s _ -> die $ "user sort: " ++ s- KTuple k -> die $ "tuple sort: " ++ show k- KMaybe k -> die $ "maybe sort: " ++ show k- KEither k1 k2 -> die $ "either sort: " ++ show (k1, k2)+ KList k -> die $ "list sort: " ++ show k+ KSet k -> die $ "set sort: " ++ show k+ KApp s _ -> die $ "ADT app: " ++ s+ KADT s _ _ -> die $ "ADT: " ++ s+ KTuple k -> die $ "tuple sort: " ++ show k+ KArray k1 k2 -> die $ "array sort: " ++ show (k1, k2) where u8InHex = cgShowU8InHex cfg spec :: (Bool, Int) -> Doc@@ -250,16 +256,15 @@ showSizedConst :: Bool -> Integer -> (Bool, Int) -> Doc showSizedConst _ i (False, 1) = text (if i == 0 then "false" else "true") showSizedConst u8h i t@(False, 8)- | u8h = text (chex False True t i)+ | u8h = text $ T.unpack (chex False True t i) | True = integer i showSizedConst _ i (True, 8) = integer i-showSizedConst _ i t@(False, 16) = text $ chex False True t i-showSizedConst _ i t@(True, 16) = text $ chex False True t i-showSizedConst _ i t@(False, 32) = text $ chex False True t i-showSizedConst _ i t@(True, 32) = text $ chex False True t i-showSizedConst _ i t@(False, 64) = text $ chex False True t i-showSizedConst _ i t@(True, 64) = text $ chex False True t i-showSizedConst _ i (True, 1) = die $ "Signed 1-bit value " ++ show i+showSizedConst _ i t@(False, 16) = text $ T.unpack $ chex False True t i+showSizedConst _ i t@(True, 16) = text $ T.unpack $ chex False True t i+showSizedConst _ i t@(False, 32) = text $ T.unpack $ chex False True t i+showSizedConst _ i t@(True, 32) = text $ T.unpack $ chex False True t i+showSizedConst _ i t@(False, 64) = text $ T.unpack $ chex False True t i+showSizedConst _ i t@(True, 64) = text $ T.unpack $ chex False True t i showSizedConst _ i (s, sz) = die $ "Constant " ++ show i ++ " at type " ++ (if s then "SInt" else "SWord") ++ show sz -- | Generate a makefile. The first argument is True if we have a driver.@@ -444,47 +449,53 @@ -- | Generate the C program genCProg :: CgConfig -> String -> Doc -> Result -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SV -> Doc -> ([Doc], [String])-genCProg cfg fn proto (Result kindInfo _tvals _ovals cgs ins (_, preConsts) tbls arrs _uis _axioms (SBVPgm asgns) cstrs origAsserts _) inVars outVars mbRet extDecls+genCProg cfg fn proto (Result pinfo kindInfo _tvals _ovals cgs topInps (_, preConsts) tbls _uis axioms (SBVPgm asgns) cstrs origAsserts _) inVars outVars mbRet extDecls | isNothing (cgInteger cfg) && KUnbounded `Set.member` kindInfo = error $ "SBV->C: Unbounded integers are not supported by the C compiler." ++ "\nUse 'cgIntegerSize' to specify a fixed size for SInteger representation." | KString `Set.member` kindInfo- = error "SBV->C: Strings are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"+ = notyet "Strings" | KChar `Set.member` kindInfo- = error "SBV->C: Characters are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"+ = notyet "Characters" | any isSet kindInfo- = error "SBV->C: Sets (SSet) are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"+ = notyet "Sets (SSet)" | any isList kindInfo- = error "SBV->C: Lists (SList) are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"+ = notyet "Lists (SList)" | any isTuple kindInfo- = error "SBV->C: Tuples (STupleN) are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"- | any isMaybe kindInfo- = error "SBV->C: Optional (SMaybe) values are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"- | any isEither kindInfo- = error "SBV->C: Either (SEither) values are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"+ = notyet "Tuples (STupleN)" | isNothing (cgReal cfg) && KReal `Set.member` kindInfo = error $ "SBV->C: SReal values are not supported by the C compiler." ++ "\nUse 'cgSRealType' to specify a custom type for SReal representation."+ | not (null unsupportedBVs)+ = error $ "SBV->C: Unsupported bit-vector type(s): " ++ intercalate ", " (map show unsupportedBVs) | not (null usorts) = error $ "SBV->C: Cannot compile functions with uninterpreted sorts: " ++ intercalate ", " usorts+ | hasQuants pinfo+ = error "SBV->C: Cannot compile in the presence of quantified variables."+ | not $ null (progSpecialRels pinfo)+ = error "SBV->C: Cannot compile in the presence of special relations."+ | not (null axioms)+ = error "SBV->C: Cannot compile in the presence of 'smtFunction' definitions, use 'compileToCLib' instead." | not (null cstrs) = tbd "Explicit constraints"- | not (null arrs)- = tbd "User specified arrays"- | needsExistentials (map fst (fst ins))- = error "SBV->C: Cannot compile functions with existentially quantified variables." | True = ([pre, header, post], flagsNeeded)- where asserts | cgIgnoreAsserts cfg = []+ where notyet m = error $ "SBV->C: " ++ m ++ " are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"++ asserts | cgIgnoreAsserts cfg = [] | True = origAsserts - usorts = [s | KUserSort s _ <- Set.toList kindInfo, s /= "RoundingMode"] -- No support for any sorts other than RoundingMode!+ usorts = [s | k@(KADT s _ _) <- Set.toList kindInfo, isADT k && not (isRoundingMode k)] -- No support for any sorts other than RoundingMode! pre = text "/* File:" <+> doubleQuotes (nm P.<> text ".c") P.<> text ". Automatically generated by SBV. Do not edit! */" $$ text "" header = text "#include" <+> doubleQuotes (nm P.<> text ".h") + unsupportedBVs = [k | k@(KBounded sg sz) <- Set.toList kindInfo, (not . supported) (sg, sz)]+ where supported (False, sz) = sz `elem` [1, 8, 16, 32, 64]+ supported (True, sz) = sz `elem` [ 8, 16, 32, 64]+ post = text "" $$ vcat (map codeSeg cgs) $$ extDecls@@ -494,7 +505,7 @@ $$ nest 2 ( vcat (concatMap (genIO True . (\v -> (isAlive v, v))) inVars) $$ vcat (merge (map genTbl tbls) (map genAsgn assignments) (map genAssert asserts)) $$ sepIf (not (null assignments) || not (null tbls))- $$ vcat (concatMap (genIO False) (zip (repeat True) outVars))+ $$ vcat (concatMap (genIO False . (True,)) outVars) $$ maybe empty mkRet mbRet ) $$ text "}"@@ -512,8 +523,14 @@ $$ vcat (map text ls) $$ text "" - typeWidth = getMax 0 $ [len (kindOf s) | (s, _) <- assignments] ++ [len (kindOf s) | (_, NamedSymVar s _) <- fst ins]- where len KReal{} = 5+ ins = case topInps of+ ResultTopInps (is, []) -> is+ ResultTopInps is -> die $ "Unexpected trackers: " ++ show is+ ResultLamInps is -> die $ "Unexpected inputs : " ++ show is++ typeWidth = getMax 0 $ [len (kindOf s) | (s, _) <- assignments] ++ [len (kindOf s) | NamedSymVar s _ <- ins]+ where len (KVar s) = die $ "Variable: " ++ s+ len KReal{} = 5 len KFloat{} = 6 -- SFloat len KDouble{} = 7 -- SDouble len KString{} = 7 -- SString@@ -524,12 +541,12 @@ len (KBounded True n) = 4 + length (show n) -- SIntN len KRational{} = die "Rational." len KFP{} = die "Arbitrary float."- len (KList s) = die $ "List sort: " ++ show s- len (KSet s) = die $ "Set sort: " ++ show s- len (KTuple s) = die $ "Tuple sort: " ++ show s- len (KMaybe k) = die $ "Maybe sort: " ++ show k- len (KEither k1 k2) = die $ "Either sort: " ++ show (k1, k2)- len (KUserSort s _) = die $ "Uninterpreted sort: " ++ s+ len (KList s) = die $ "List sort: " ++ show s+ len (KSet s) = die $ "Set sort: " ++ show s+ len (KTuple s) = die $ "Tuple sort: " ++ show s+ len (KArray k1 k2) = die $ "Array sort: " ++ show (k1, k2)+ len (KApp s _) = die $ "Uninterpreted ADT app: " ++ s+ len (KADT s _ _) = die $ "Uninterpreted ADT: " ++ s getMax 8 _ = 8 -- 8 is the max we can get with SInteger, so don't bother looking any further getMax m [] = m@@ -574,8 +591,8 @@ where static = if location == -1 then text "static" else empty location = maximum (-1 : map getNodeId elts) - getNodeId s@(SV _ (NodeId n)) | isConst s = -1- | True = n+ getNodeId s@(SV _ (NodeId (_, _, n))) | isConst s = -1+ | True = n genAsgn :: (SV, SBVExpr) -> (Int, Doc) genAsgn (sv, n) = (getNodeId sv, ppExpr cfg consts n (declSV typeWidth sv) (declSVNoConst typeWidth sv) P.<> semi)@@ -592,7 +609,7 @@ genAssert (msg, cs, sv) = (getNodeId sv, doc) where doc = text "/* ASSERTION:" <+> text msg- $$ maybe empty (vcat . map text) (locInfo (getCallStack `fmap` cs))+ $$ maybe empty (vcat . map text) (locInfo (getCallStack <$> cs)) $$ text " */" $$ text "if" P.<> parens (showSV cfg consts sv) $$ text "{"@@ -674,21 +691,21 @@ -- grab the rounding-mode, if present, and make sure it's RoundNearestTiesToEven. Otherwise skip. fpArgs = case as of [] -> []- ((m, _):args) -> case kindOf m of- KUserSort "RoundingMode" _ -> case checkRM (m `lookup` consts) of- Nothing -> args- Just (Left msg) -> die msg- Just (Right msg) -> tbd msg- _ -> as+ ((m, _):args)+ | isRoundingMode m -> case checkRM (m `lookup` consts) of+ Nothing -> args+ Just (Left msg) -> die msg+ Just (Right msg) -> tbd msg+ | True -> as -- Check that the RM is RoundNearestTiesToEven. -- If we start supporting other rounding-modes, this would be the point where we'd insert the rounding-mode set/reset code -- instead of merely returning OK or not- checkRM (Just cv@(CV (KUserSort "RoundingMode" _) v)) =- case v of- CUserSort (_, "RoundNearestTiesToEven") -> Nothing- CUserSort (_, s) -> Just (Right $ "handleIEEE: Unsupported rounding-mode: " ++ show s ++ " for: " ++ show w)- _ -> Just (Left $ "handleIEEE: Unexpected value for rounding-mode: " ++ show cv ++ " for: " ++ show w)+ checkRM (Just cv@(CV k v))+ | k == kRoundingMode = case v of+ CADT ("RoundNearestTiesToEven", []) -> Nothing+ CADT (s, []) -> Just (Right $ "handleIEEE: Unsupported rounding-mode: " ++ show s ++ " for: " ++ show w)+ _ -> Just (Left $ "handleIEEE: Unexpected value for rounding-mode: " ++ show cv ++ " for: " ++ show w) checkRM (Just cv) = Just (Left $ "handleIEEE: Expected rounding-mode, but got: " ++ show cv ++ " for: " ++ show w) checkRM Nothing = Just (Right $ "handleIEEE: Non-constant rounding-mode for: " ++ show w) @@ -705,11 +722,11 @@ -- In C, the second argument is returned. (I think, might depend on the architecture, optimizations etc.). -- We'll translate it so that we deterministically return +0. -- There's really no good choice here.- wrapMinMax k a b s = parens cond <+> text "?" <+> zero <+> text ":" <+> s- where zero = text $ if k == KFloat then showCFloat 0 else showCDouble 0- cond = parens (text "FP_ZERO == fpclassify" P.<> parens a) -- a is zero- <+> text "&&" <+> parens (text "FP_ZERO == fpclassify" P.<> parens b) -- b is zero- <+> text "&&" <+> parens (text "signbit" P.<> parens a <+> text "!=" <+> text "signbit" P.<> parens b) -- a and b differ in sign+ wrapMinMax k a b s = parens cond <+> text "?" <+> fzero <+> text ":" <+> s+ where fzero = text $ if k == KFloat then showCFloat 0 else showCDouble 0+ cond = parens (text "FP_ZERO == fpclassify" P.<> parens a) -- a is zero+ <+> text "&&" <+> parens (text "FP_ZERO == fpclassify" P.<> parens b) -- b is zero+ <+> text "&&" <+> parens (text "signbit" P.<> parens a <+> text "!=" <+> text "signbit" P.<> parens b) -- a and b differ in sign ppExpr :: CgConfig -> [(SV, CV)] -> SBVExpr -> Doc -> (Doc, Doc) -> Doc ppExpr cfg consts (SBVApp op opArgs) lhs (typ, var)@@ -725,7 +742,8 @@ rtc = cgRTC cfg cBinOps = [ (Plus, "+"), (Times, "*"), (Minus, "-")- , (Equal, "=="), (NotEqual, "!="), (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=")+ , (Equal False, "==") -- no strong equality!+ , (NotEqual, "!="), (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=") , (And, "&"), (Or, "|"), (XOr, "^") ] @@ -735,23 +753,26 @@ _ -> def getShiftAmnt def _ = def + hd _ (h:_) = h+ hd w [] = error $ "Data.SBV.C.ppExpr: Impossible happened: " ++ w ++ ", received empty list!"+ p :: Op -> [Doc] -> Doc- p (ArrRead _) _ = tbd "User specified arrays (ArrRead)"- p (ArrEq _ _) _ = tbd "User specified arrays (ArrEq)"+ p ReadArray{} _ = tbd "User specified arrays (ReadArray)"+ p WriteArray{} _ = tbd "User specified arrays (WriteArray)" p (Label s) [a] = a <+> text "/*" <+> text s <+> text "*/" p (IEEEFP w) as = handleIEEE w consts (zip opArgs as) var p (PseudoBoolean pb) as = handlePB pb as p (OverflowOp o) _ = tbd $ "Overflow operations" ++ show o p (KindCast _ to) [a] = parens (text (show to)) <+> a- p (Uninterpreted s) [] = text "/* Uninterpreted constant */" <+> text s- p (Uninterpreted s) as = text "/* Uninterpreted function */" <+> text s P.<> parens (fsep (punctuate comma as))- p (Extract i j) [a] = extract i j (head opArgs) a+ p (Uninterpreted s) [] = text "/* Uninterpreted constant */" <+> text (T.unpack s)+ p (Uninterpreted s) as = text "/* Uninterpreted function */" <+> text (T.unpack s) P.<> parens (fsep (punctuate comma as))+ p (Extract i j) [a] = extract i j (hd "Extract" opArgs) a p Join [a, b] = join (let (s1 : s2 : _) = opArgs in (s1, s2, a, b))- p (Rol i) [a] = rotate True i a (head opArgs)- p (Ror i) [a] = rotate False i a (head opArgs)+ p (Rol i) [a] = rotate True i a (hd "Rol" opArgs)+ p (Ror i) [a] = rotate False i a (hd "Ror" opArgs) p Shl [a, i] = shift True (getShiftAmnt i opArgs) a -- The order of i/a being reversed here is p Shr [a, i] = shift False (getShiftAmnt i opArgs) a -- intentional and historical (from the days when Shl/Shr had a constant parameter.)- p Not [a] = case kindOf (head opArgs) of+ p Not [a] = case kindOf (hd "Not" opArgs) of -- be careful about booleans, bitwise complement is not correct for them! KBool -> text "!" P.<> a _ -> text "~" P.<> a@@ -775,6 +796,7 @@ canOverflow False sz = (2::Integer)^sz -1 >= fromIntegral len (needsCheckL, needsCheckR) = case k of+ KVar{} -> die $ "array index with variable: " ++ show k KBool -> (False, canOverflow False (1::Int)) KBounded sg sz -> (sg, canOverflow sg sz) KReal -> die "array index with real value"@@ -787,20 +809,20 @@ KUnbounded -> case cgInteger cfg of Nothing -> (True, True) -- won't matter, it'll be rejected later Just i -> (True, canOverflow True i)- KList s -> die $ "List sort " ++ show s- KSet s -> die $ "Set sort " ++ show s- KTuple s -> die $ "Tuple sort " ++ show s- KMaybe ek -> die $ "Maybe sort " ++ show ek- KEither k1 k2 -> die $ "Either sort " ++ show (k1, k2)- KUserSort s _ -> die $ "Uninterpreted sort: " ++ s+ KList s -> die $ "List sort " ++ show s+ KSet s -> die $ "Set sort " ++ show s+ KTuple s -> die $ "Tuple sort " ++ show s+ KArray k1 k2 -> die $ "Array sort " ++ show (k1, k2)+ KApp s _ -> die $ "ADT app: " ++ s+ KADT s _ _ -> die $ "ADT: " ++ s -- Div/Rem should be careful on 0, in the SBV world x `div` 0 is 0, x `rem` 0 is x -- NB: Quot is supposed to truncate toward 0; Not clear to me if C guarantees this behavior. -- Brief googling suggests C99 does indeed truncate toward 0, but other C compilers might differ.- p Quot [a, b] = let k = kindOf (head opArgs)+ p Quot [a, b] = let k = kindOf (hd "Quot" opArgs) z = mkConst cfg $ mkConstCV k (0::Integer) in protectDiv0 k "/" z a b- p Rem [a, b] = protectDiv0 (kindOf (head opArgs)) "%" a a b+ p Rem [a, b] = protectDiv0 (kindOf (hd "Rem" opArgs)) "%" a a b p UNeg [a] = parens (text "-" <+> a) p Abs [a] = let f KFloat = text "fabsf" P.<> parens a f KDouble = text "fabs" P.<> parens a@@ -816,13 +838,16 @@ Just CgDouble -> f KDouble Just CgLongDouble -> text "fabsl" P.<> parens a f _ = text "abs" P.<> parens a- in f (kindOf (head opArgs))+ in f (kindOf (hd "Abs" opArgs)) -- for And/Or, translate to boolean versions if on boolean kind- p And [a, b] | kindOf (head opArgs) == KBool = a <+> text "&&" <+> b- p Or [a, b] | kindOf (head opArgs) == KBool = a <+> text "||" <+> b+ p And [a, b] | kindOf (hd "And" opArgs) == KBool = a <+> text "&&" <+> b+ p Or [a, b] | kindOf (hd "Or" opArgs) == KBool = a <+> text "||" <+> b p o [a, b] | Just co <- lookup o cBinOps = a <+> text co <+> b++ p Implies [a, b] | kindOf (hd "Implies" opArgs) == KBool = parens (text "!" P.<> a <+> text "||" <+> b)+ p NotEqual xs = mkDistinct xs p o args = die $ "Received operator " ++ show o ++ " applied to " ++ show args @@ -936,7 +961,9 @@ where bundles = map snd cfgBundles kinds = [k | CgPgmBundle k _ <- bundles] nubKinds = nub kinds- bundleKind = head nubKinds+ bundleKind = case nubKinds of+ bk:_ -> bk+ [] -> error "Data.SBV.C: Impossible happened: mergeLibs: kinds ended up being empty!" files = concat [fs | CgPgmBundle _ fs <- bundles] sigs = concat [ss | (_, (CgHeader ss, _)) <- files] anyMake = not (null [() | (_, (CgMakefile{}, _)) <- files])@@ -1054,4 +1081,4 @@ , FP_IsZero ] -{-# ANN module ("HLint: ignore Redundant lambda" :: String) #-}+{- HLint ignore module "Redundant lambda" -}
Data/SBV/Compilers/CodeGen.hs view
@@ -9,8 +9,6 @@ -- Code generation utilities ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wall -Werror #-}@@ -57,9 +55,7 @@ import Data.SBV.Core.Data import Data.SBV.Core.Symbolic (MonadSymbolic(..), svToSymSV, svMkSymVar, outputSVal, VarContext(..)) -#if MIN_VERSION_base(4,11,0)-import Control.Monad.Fail as Fail-#endif+import Data.SBV.Provers.Prover(defaultSMTCfg) -- | Abstract over code generation for different languages class CgTarget a where@@ -125,9 +121,7 @@ newtype SBVCodeGen a = SBVCodeGen (StateT CgState Symbolic a) deriving ( Applicative, Functor, Monad, MonadIO, MonadState CgState , MonadSymbolic-#if MIN_VERSION_base(4,11,0)- , Fail.MonadFail-#endif+ , MonadFail ) -- | Reach into symbolic monad from code-generation@@ -219,7 +213,7 @@ svCgInput k nm = do r <- symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar (Just ALL)) k Nothing sv <- svToSymSV r modify' (\s -> s { cgInputs = (nm, CgAtomic sv) : cgInputs s })- return r+ pure r -- | Creates an array input in the generated code. svCgInputArr :: Kind -> Int -> String -> SBVCodeGen [SVal]@@ -228,7 +222,7 @@ | True = do rs <- symbolicEnv >>= liftIO . replicateM sz . svMkSymVar (NonQueryVar (Just ALL)) k Nothing sws <- mapM svToSymSV rs modify' (\s -> s { cgInputs = (nm, CgArray sws) : cgInputs s })- return rs+ pure rs -- | Creates an atomic output in the generated code. svCgOutput :: String -> SVal -> SBVCodeGen ()@@ -262,19 +256,19 @@ -- | Creates an atomic input in the generated code. cgInput :: SymVal a => String -> SBVCodeGen (SBV a)-cgInput nm = do r <- sbvForall_+cgInput nm = do r <- free_ sv <- sbvToSymSV r modify' (\s -> s { cgInputs = (nm, CgAtomic sv) : cgInputs s })- return r+ pure r -- | Creates an array input in the generated code. cgInputArr :: SymVal a => Int -> String -> SBVCodeGen [SBV a] cgInputArr sz nm | sz < 1 = error $ "SBV.cgInputArr: Array inputs must have at least one element, given " ++ show sz ++ " for " ++ show nm- | True = do rs <- mapM (const sbvForall_) [1..sz]+ | True = do rs <- mapM (const free_) [1..sz] sws <- mapM sbvToSymSV rs modify' (\s -> s { cgInputs = (nm, CgArray sws) : cgInputs s })- return rs+ pure rs -- | Creates an atomic output in the generated code. cgOutput :: String -> SBV a -> SBVCodeGen ()@@ -337,16 +331,16 @@ -- of makefiles, source code, headers, etc. codeGen :: CgTarget l => l -> CgConfig -> String -> SBVCodeGen a -> IO (a, CgConfig, CgPgmBundle) codeGen l cgConfig nm (SBVCodeGen comp) = do- ((retVal, st'), res) <- runSymbolic CodeGen $ runStateT comp initCgState { cgFinalConfig = cgConfig }- let st = st' { cgInputs = reverse (cgInputs st')- , cgOutputs = reverse (cgOutputs st')+ ((retVal, st'), res) <- runSymbolic defaultSMTCfg CodeGen $ runStateT comp initCgState { cgFinalConfig = cgConfig }+ let st = st' { cgInputs = reverse (cgInputs st')+ , cgOutputs = reverse (cgOutputs st') } allNamedVars = map fst (cgInputs st ++ cgOutputs st) dupNames = allNamedVars \\ nub allNamedVars unless (null dupNames) $ error $ "SBV.codeGen: " ++ show nm ++ " has following argument names duplicated: " ++ unwords dupNames - return (retVal, cgFinalConfig st, translate l (cgFinalConfig st) nm st res)+ pure (retVal, cgFinalConfig st, translate l (cgFinalConfig st) nm st res) -- | Render a code-gen bundle to a directory or to stdout renderCgPgmBundle :: Maybe FilePath -> (CgConfig, CgPgmBundle) -> IO ()@@ -360,14 +354,14 @@ dups <- filterM (\fn -> doesFileExist (dirName </> fn)) (map fst files) goOn <- case (overWrite, dups) of- (True, _) -> return True- (_, []) -> return True+ (True, _) -> pure True+ (_, []) -> pure True _ -> do putStrLn $ "Code generation would overwrite the following " ++ (if length dups == 1 then "file:" else "files:") mapM_ (\fn -> putStrLn ('\t' : fn)) dups putStr "Continue? [yn] " hFlush stdout resp <- getLine- return $ map toLower resp `isPrefixOf` "yes"+ pure $ map toLower resp `isPrefixOf` "yes" if goOn then do mapM_ renderFile files unless overWrite $ putStrLn "Done."
Data/SBV/Control.hs view
@@ -9,38 +9,36 @@ -- Control sublanguage for interacting with SMT solvers. ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-}- {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Control ( -- $queryIntro -- * User queries- ExtractIO(..), MonadQuery(..), Queriable(..), Fresh(..), Query, query-- -- * Create a fresh variable- , freshVar_, freshVar-- -- * Create a fresh array- , freshArray_, freshArray+ ExtractIO(..), MonadQuery(..), Query, query -- * Checking satisfiability , CheckSatResult(..), checkSat, ensureSat, checkSatUsing, checkSatAssuming, checkSatAssumingWithUnsatisfiableSet -- * Querying the solver -- ** Extracting values- , getValue, registerUISMTFunction, getFunction, getUninterpretedValue, getModel, getAssignment, getSMTResult, getUnknownReason, getObservables+ , getFunction, getModel, getAssignment, getSMTResult, getUnknownReason, getObservables -- ** Extracting the unsat core , getUnsatCore + -- ** Getting the model value for a symbolic variable+ , getValue+ -- ** Extracting a proof , getProof -- ** Extracting interpolants , getInterpolantMathSAT, getInterpolantZ3 + -- ** Getting abducts+ , getAbduct, getAbductNext+ -- ** Extracting assertions , getAssertions @@ -76,25 +74,11 @@ , SMTOption(..) ) where -import Data.SBV.Core.Symbolic (MonadQuery(..), Query, Queriable(..), Fresh(..), Symbolic, QueryContext(..))+import Data.SBV.Core.Symbolic (Symbolic, QueryContext(..), Query, MonadQuery(..), SMTConfig(..)) import Data.SBV.Control.BaseIO-import Data.SBV.Control.Query hiding ( getInfo, getOption, getUnknownReason, getObservables- , getSMTResult, getLexicographicOptResults- , getIndependentOptResults- , getParetoOptResults, getModel- , checkSatAssuming- , checkSatAssumingWithUnsatisfiableSet- , getAssertionStackDepth- , inNewAssertionStack, push, pop- , caseSplit, resetAssertions, echo, exit- , getUnsatCore, getProof, getInterpolantMathSAT, getInterpolantZ3- , getAssertions, getAssignment- , mkSMTResult, freshVar_, freshVar- , freshArray, freshArray_, checkSat, ensureSat- , checkSatUsing, getValue- , getUninterpretedValue, timeout, io)-import Data.SBV.Control.Utils (registerUISMTFunction)+import Data.SBV.Control.Types+import Data.SBV.Control.Query ((|->)) import Data.SBV.Utils.ExtractIO (ExtractIO(..))
Data/SBV/Control/BaseIO.hs view
@@ -18,13 +18,15 @@ import Data.SBV.Control.Query (Assignment) import Data.SBV.Control.Types (CheckSatResult, SMTInfoFlag, SMTInfoResponse, SMTOption, SMTReasonUnknown) import Data.SBV.Core.Concrete (CV)-import Data.SBV.Core.Data (HasKind, Symbolic, SymArray, SymVal, SBool, SBV, SBVType)+import Data.SBV.Core.Data (Symbolic, SymVal, SBool, SBV, SBVType) import Data.SBV.Core.Symbolic (Query, QueryContext, QueryState, State, SMTModel, SMTResult, SV, Name) +import Data.Text (Text)+ import qualified Data.SBV.Control.Query as Trans import qualified Data.SBV.Control.Utils as Trans --- Data.SBV.Control.Query+import Data.SBV.Utils.SExpr (SExpr) -- | Ask solver for info. --@@ -57,7 +59,7 @@ -- | Get the uninterpreted constants/functions recorded during a run. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.getUIs'-getUIs :: Query [(String, SBVType)]+getUIs :: Query [(String, (Bool, Maybe [String], SBVType))] getUIs = Trans.getUIs -- | Issue check-sat and get an SMT Result out.@@ -189,7 +191,8 @@ -- 'Data.SBV.setOption' $ 'Data.SBV.Control.ProduceUnsatCores' 'True' -- @ ----- for this call to not error out!+-- for this call to not error out! Furthermore, unsat-cores require for the user to name the+-- constraints to be considered as part of the set, which is done via 'Data.SBV.namedConstraint'. -- -- NB. There is no notion of a minimal unsat-core, in case unsatisfiability can be derived -- in multiple ways. Furthermore, Z3 does not guarantee that the generated unsat@@ -237,7 +240,7 @@ -- for this call to not error out! -- -- To get an interpolant for a pair of formulas @A@ and @B@, use a 'Data.SBV.constrainWithAttribute' call to attach--- interplation groups to @A@ and @B@. Then call 'getInterpolantMathSAT' @[\"A\"]@, assuming those are the names+-- interpolation groups to @A@ and @B@. Then call 'getInterpolantMathSAT' @[\"A\"]@, assuming those are the names -- you gave to the formulas in the @A@ group. -- -- An interpolant for @A@ and @B@ is a formula @I@ such that:@@ -299,6 +302,27 @@ getInterpolantZ3 :: [SBool] -> Query String getInterpolantZ3 = Trans.getInterpolantZ3 +-- | Get an abduct. The first argument is a conjecture. The return value will be an assertion+-- such that in addition with the existing assertions you have, will imply this conjecture.+-- The second argument is the grammar which guides the synthesis of this abduct, if given.+-- Note that SBV doesn't do any checking on the grammar. See the relevant documentation on CVC5+-- for details.+--+-- NB. Before you use this function, make sure to call+--+-- @+-- setOption $ ProduceAbducts True+-- @+--+-- to enable abduct generation.+getAbduct :: Maybe String -> String -> SBool -> Query String+getAbduct = Trans.getAbduct++-- | Get the next abduct. Only call this after the first call to 'getAbduct' goes through. You can call+-- it repeatedly to get a different abduct.+getAbductNext :: Query String+getAbductNext = Trans.getAbductNext+ -- | Retrieve assertions. Note you must have arranged for -- assertions to be available first via --@@ -366,50 +390,33 @@ -- | Create a fresh variable in query mode. You should prefer -- creating input variables using 'Data.SBV.sBool', 'Data.SBV.sInt32', etc., which act--- as primary inputs to the model and can be existential or universal.--- Use 'freshVar' only in query mode for anonymous temporary variables.--- Such variables are always existential. Note that 'freshVar' should hardly be--- needed: Your input variables and symbolic expressions should suffice for--- most major use cases.+-- as primary inputs to the model. Use 'freshVar' only in query mode for anonymous temporary variables.+-- Note that 'freshVar' should hardly be needed: Your input variables and symbolic expressions+-- should suffice for -- most major use cases. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.freshVar' freshVar :: SymVal a => String -> Query (SBV a) freshVar = Trans.freshVar --- | Similar to 'freshArray', except creates unnamed array.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.freshArray_'-freshArray_ :: (SymArray array, HasKind a, HasKind b) => Maybe (SBV b) -> Query (array a b)-freshArray_ = Trans.freshArray_---- | Create a fresh array in query mode. Again, you should prefer--- creating arrays before the queries start using 'Data.SBV.newArray', but this--- method can come in handy in occasional cases where you need a new array--- after you start the query based interaction.------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.freshArray'-freshArray :: (SymArray array, HasKind a, HasKind b) => String -> Maybe (SBV b) -> Query (array a b)-freshArray = Trans.freshArray- -- | If 'Data.SBV.verbose' is 'True', print the message, useful for debugging messages -- in custom queries. Note that 'Data.SBV.redirectVerbose' will be respected: If a -- file redirection is given, the output will go to the file. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.queryDebug'-queryDebug :: [String] -> Query ()+queryDebug :: [Text] -> Query () queryDebug = Trans.queryDebug -- | Send a string to the solver, and return the response -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.ask'-ask :: String -> Query String+ask :: Text -> Query String ask = Trans.ask -- | Send a string to the solver. If the first argument is 'True', we will require -- a "success" response as well. Otherwise, we'll fire and forget. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.send'-send :: Bool -> String -> Query ()+send :: Bool -> Text -> Query () send = Trans.send -- | Retrieve a responses from the solver until it produces a synchronization tag. We make the tag@@ -429,16 +436,12 @@ getValue :: SymVal a => SBV a -> Query a getValue = Trans.getValue --- | Get the value of an uninterpreted sort, as a String------ NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.getUninterpretedValue'-getUninterpretedValue :: HasKind a => SBV a -> Query String-getUninterpretedValue = Trans.getUninterpretedValue- -- | Get the value of an uninterpreted function, as a list of domain, value pairs. -- The final value is the "else" clause, i.e., what the function maps values outside--- of the domain of the first list.-getFunction :: (SymVal a, SymVal r, Trans.SMTFunction fun a r) => fun -> Query ([(a, r)], r)+-- of the domain of the first list. If the result is not a value-association, then we get a string+-- representation and the triple of whether it's curried, the argument list given by the user, and the s-expression as parsed+-- by SBV from the SMT solver.+getFunction :: (SymVal a, SymVal r, Trans.SMTFunction fun a r) => fun -> Query (Either (String, (Bool, Maybe [String], SExpr)) ([(a, r)], r)) getFunction = Trans.getFunction -- | Get the value of a term. If the kind is Real and solver supports decimal approximations,@@ -449,13 +452,13 @@ getValueCV = Trans.getValueCV -- | Get the value of an uninterpreted value-getUICVal :: Maybe Int -> (String, SBVType) -> Query CV+getUICVal :: Maybe Int -> (String, (Bool, Maybe [String], SBVType)) -> Query CV getUICVal = Trans.getUICVal -- | Get the value of an uninterpreted function as an association list -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.getUIFunCVAssoc'-getUIFunCVAssoc :: Maybe Int -> (String, SBVType) -> Query ([([CV], CV)], CV)+getUIFunCVAssoc :: Maybe Int -> (String, (Bool, Maybe [String], SBVType)) -> Query (Either String ([([CV], CV)], CV)) getUIFunCVAssoc = Trans.getUIFunCVAssoc -- | Check for satisfiability.@@ -505,7 +508,7 @@ -- | Bail out if we don't get what we expected -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.unexpected'-unexpected :: String -> String -> String -> Maybe [String] -> String -> Maybe [String] -> Query a+unexpected :: String -> Text -> String -> Maybe [String] -> String -> Maybe [String] -> Query a unexpected = Trans.unexpected -- | Execute a query.
Data/SBV/Control/Query.hs view
@@ -9,21 +9,19 @@ -- Querying a solver interactively. ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Control.Query ( send, ask, retrieveResponse , CheckSatResult(..), checkSat, checkSatUsing, checkSatAssuming, checkSatAssumingWithUnsatisfiableSet- , getUnsatCore, getProof, getInterpolantMathSAT, getInterpolantZ3, getAssignment, getOption, freshVar, freshVar_, freshArray, freshArray_, push, pop, getAssertionStackDepth- , inNewAssertionStack, echo, caseSplit, resetAssertions, exit, getAssertions, getValue, getUninterpretedValue, getModel, getSMTResult+ , getUnsatCore, getProof, getInterpolantMathSAT, getInterpolantZ3, getAbduct, getAbductNext, getAssignment, getOption+ , push, pop, getAssertionStackDepth+ , inNewAssertionStack, echo, caseSplit, resetAssertions, exit, getAssertions, getModel, getSMTResult , getLexicographicOptResults, getIndependentOptResults, getParetoOptResults, getAllSatResult, getUnknownReason, getObservables, ensureSat , SMTOption(..), SMTInfoFlag(..), SMTErrorBehavior(..), SMTReasonUnknown(..), SMTInfoResponse(..), getInfo , Logic(..), Assignment(..)@@ -38,50 +36,31 @@ import Data.IORef (readIORef) -import qualified Data.Map.Strict as M-import qualified Data.IntMap.Strict as IM-import qualified Data.Sequence as S-import qualified Data.Text as T+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified Data.Foldable as F import Data.Char (toLower)-import Data.List (intercalate, nubBy, sortOn)-import Data.Maybe (listToMaybe, catMaybes)+import Data.List (intercalate, nubBy)+import Data.Maybe (fromMaybe) import Data.Function (on)-import Data.Bifunctor (first)-import Data.Foldable (toList) import Data.SBV.Core.Data -import Data.SBV.Core.Symbolic ( MonadQuery(..), State(..)- , incrementInternalCounter, validationRequested- , prefixExistentials, prefixUniversals- , namedSymVar, getSV, lookupInput, userInputsToList- )+import Data.SBV.Core.Symbolic (MonadQuery(..), State(..), incrementInternalCounter, getSV) import Data.SBV.Utils.SExpr import Data.SBV.Control.Types import Data.SBV.Control.Utils +import Data.SBV.Utils.Lib (showText, unBar) import Data.SBV.Utils.PrettyNum (showNegativeNumber) -- | An Assignment of a model binding data Assignment = Assign SVal CV --- Remove one pair of surrounding 'c's, if present-noSurrounding :: Char -> String -> String-noSurrounding c (c':cs@(_:_)) | c == c' && c == last cs = init cs-noSurrounding _ s = s---- Remove a pair of surrounding quotes-unQuote :: String -> String-unQuote = noSurrounding '"'---- Remove a pair of surrounding bars-unBar :: String -> String-unBar = noSurrounding '|'- -- Is this a string? If so, return it, otherwise fail in the Maybe monad. fromECon :: SExpr -> Maybe String fromECon (ECon s) = Just s@@ -90,7 +69,7 @@ -- Collect strings appearing, used in 'getOption' only stringsOf :: SExpr -> [String] stringsOf (ECon s) = [s]-stringsOf (ENum (i, _)) = [show i]+stringsOf (ENum (i, _, _)) = [show i] stringsOf (EReal r) = [show r] stringsOf (EFloat f) = [show f] stringsOf (EFloatingPoint f) = [show f]@@ -101,10 +80,10 @@ serialize :: Bool -> SExpr -> String serialize removeQuotes = go where go (ECon s) = if removeQuotes then unQuote s else s- go (ENum (i, _)) = showNegativeNumber i- go (EReal r) = showNegativeNumber r- go (EFloat f) = showNegativeNumber f- go (EDouble d) = showNegativeNumber d+ go (ENum (i, _, _)) = T.unpack (showNegativeNumber i)+ go (EReal r) = T.unpack (showNegativeNumber r)+ go (EFloat f) = T.unpack (showNegativeNumber f)+ go (EDouble d) = T.unpack (showNegativeNumber d) go (EFloatingPoint f) = show f go (EApp [x]) = go x go (EApp ss) = "(" ++ unwords (map go ss) ++ ")"@@ -112,7 +91,7 @@ -- | Generalization of 'Data.SBV.Control.getInfo' getInfo :: (MonadIO m, MonadQuery m) => SMTInfoFlag -> m SMTInfoResponse getInfo flag = do- let cmd = "(get-info " ++ show flag ++ ")"+ let cmd = "(get-info " <> showText flag <> ")" bad = unexpected "getInfo" cmd "a valid get-info response" Nothing isAllStatistics AllStatistics = True@@ -134,17 +113,17 @@ parse r bad $ \pe -> if isAllStat- then return $ Resp_AllStatistics $ grabAllStats pe+ then pure $ Resp_AllStatistics $ grabAllStats pe else case pe of- ECon "unsupported" -> return Resp_Unsupported- EApp [ECon ":assertion-stack-levels", ENum (i, _)] -> return $ Resp_AssertionStackLevels i- EApp (ECon ":authors" : ns) -> return $ Resp_Authors (map render ns)- EApp [ECon ":error-behavior", ECon "immediate-exit"] -> return $ Resp_Error ErrorImmediateExit- EApp [ECon ":error-behavior", ECon "continued-execution"] -> return $ Resp_Error ErrorContinuedExecution- EApp (ECon ":name" : o) -> return $ Resp_Name (render (EApp o))- EApp (ECon ":reason-unknown" : o) -> return $ Resp_ReasonUnknown (unk o)- EApp (ECon ":version" : o) -> return $ Resp_Version (render (EApp o))- EApp (ECon s : o) -> return $ Resp_InfoKeyword s (map render o)+ ECon "unsupported" -> pure Resp_Unsupported+ EApp [ECon ":assertion-stack-levels", ENum (i, _, _)] -> pure $ Resp_AssertionStackLevels i+ EApp (ECon ":authors" : ns) -> pure $ Resp_Authors (map render ns)+ EApp [ECon ":error-behavior", ECon "immediate-exit"] -> pure $ Resp_Error ErrorImmediateExit+ EApp [ECon ":error-behavior", ECon "continued-execution"] -> pure $ Resp_Error ErrorContinuedExecution+ EApp (ECon ":name" : o) -> pure $ Resp_Name (render (EApp o))+ EApp (ECon ":reason-unknown" : o) -> pure $ Resp_ReasonUnknown (unk o)+ EApp (ECon ":version" : o) -> pure $ Resp_Version (render (EApp o))+ EApp (ECon s : o) -> pure $ Resp_InfoKeyword s (map render o) _ -> bad r Nothing where render = serialize True@@ -161,7 +140,7 @@ , ("timeout", UnknownTimeOut) ] --- | Generalization of 'Data.SBV.Control.getInfo'+-- | Generalization of 'Data.SBV.Control.getOption' getOption :: (MonadIO m, MonadQuery m) => (a -> SMTOption) -> m (Maybe SMTOption) getOption f = case f undefined of DiagnosticOutputChannel{} -> askFor "DiagnosticOutputChannel" ":diagnostic-output-channel" $ string DiagnosticOutputChannel@@ -171,42 +150,44 @@ ProduceInterpolants{} -> askFor "ProduceInterpolants" ":produce-interpolants" $ bool ProduceInterpolants ProduceUnsatAssumptions{} -> askFor "ProduceUnsatAssumptions" ":produce-unsat-assumptions" $ bool ProduceUnsatAssumptions ProduceUnsatCores{} -> askFor "ProduceUnsatCores" ":produce-unsat-cores" $ bool ProduceUnsatCores+ ProduceAbducts{} -> askFor "ProduceAbducts" ":produce-abducts" $ bool ProduceAbducts RandomSeed{} -> askFor "RandomSeed" ":random-seed" $ integer RandomSeed ReproducibleResourceLimit{} -> askFor "ReproducibleResourceLimit" ":reproducible-resource-limit" $ integer ReproducibleResourceLimit SMTVerbosity{} -> askFor "SMTVerbosity" ":verbosity" $ integer SMTVerbosity OptionKeyword nm _ -> askFor ("OptionKeyword" ++ nm) nm $ stringList (OptionKeyword nm)- SetLogic{} -> error "Data.SBV.Query: SMTLib does not allow querying value of the logic!"+ SetLogic{} -> error "Data.SBV.Query: SMTLib does not allow querying the value of logic!"+ SetTimeOut{} -> error "Data.SBV.Query: SMTLib does not allow querying the timeout value!" -- Not to be confused by getInfo, which is totally irrelevant! SetInfo{} -> error "Data.SBV.Query: SMTLib does not allow querying value of meta-info!" where askFor sbvName smtLibName continue = do- let cmd = "(get-option " ++ smtLibName ++ ")"+ let cmd = "(get-option " <> T.pack smtLibName <> ")" bad = unexpected ("getOption " ++ sbvName) cmd "a valid option value" Nothing r <- ask cmd - parse r bad $ \case ECon "unsupported" -> return Nothing+ parse r bad $ \case ECon "unsupported" -> pure Nothing e -> continue e (bad r) - string c (ECon s) _ = return $ Just $ c s+ string c (ECon s) _ = pure $ Just $ c s string _ e k = k $ Just ["Expected string, but got: " ++ show (serialize False e)] - bool c (ENum (0, _)) _ = return $ Just $ c False- bool c (ENum (1, _)) _ = return $ Just $ c True- bool _ e k = k $ Just ["Expected boolean, but got: " ++ show (serialize False e)]+ bool c (ENum (0, _, True)) _ = pure $ Just $ c False+ bool c (ENum (1, _, True)) _ = pure $ Just $ c True+ bool _ e k = k $ Just ["Expected boolean, but got: " ++ show (serialize False e)] - integer c (ENum (i, _)) _ = return $ Just $ c i- integer _ e k = k $ Just ["Expected integer, but got: " ++ show (serialize False e)]+ integer c (ENum (i, _, _)) _ = pure $ Just $ c i+ integer _ e k = k $ Just ["Expected integer, but got: " ++ show (serialize False e)] -- free format, really- stringList c e _ = return $ Just $ c $ stringsOf e+ stringList c e _ = pure $ Just $ c $ stringsOf e -- | Generalization of 'Data.SBV.Control.getUnknownReason' getUnknownReason :: (MonadIO m, MonadQuery m) => m SMTReasonUnknown getUnknownReason = do ru <- getInfo ReasonUnknown case ru of- Resp_Unsupported -> return $ UnknownOther "Solver responded: Unsupported."- Resp_ReasonUnknown r -> return r+ Resp_Unsupported -> pure $ UnknownOther "Solver responded: Unsupported."+ Resp_ReasonUnknown r -> pure r -- Shouldn't happen, but just in case: _ -> error $ "Unexpected reason value received: " ++ show ru @@ -215,8 +196,8 @@ ensureSat = do cfg <- getConfig cs <- checkSatUsing $ satCmd cfg case cs of- Sat -> return ()- DSat{} -> return ()+ Sat -> pure ()+ DSat{} -> pure () Unk -> do s <- getUnknownReason error $ unlines [ "" , "*** Data.SBV.ensureSat: Solver reported Unknown!"@@ -252,7 +233,7 @@ Unk -> Unknown cfg <$> getUnknownReason where getModelWithObjectives = do objectiveValues <- getObjectiveValues m <- getModel- return m {modelObjectives = objectiveValues}+ pure m {modelObjectives = objectiveValues} -- | Generalization of 'Data.SBV.Control.getIndependentOptResults' getIndependentOptResults :: forall m. (MonadIO m, MonadQuery m) => [String] -> m [(String, SMTResult)]@@ -260,181 +241,48 @@ cs <- checkSat case cs of- Unsat -> getUnsatCoreIfRequested >>= \mbUC -> return [(nm, Unsatisfiable cfg mbUC) | nm <- objNames]+ Unsat -> getUnsatCoreIfRequested >>= \mbUC -> pure [(nm, Unsatisfiable cfg mbUC) | nm <- objNames] Sat -> continue (classifyModel cfg) DSat{} -> continue (classifyModel cfg) Unk -> do ur <- Unknown cfg <$> getUnknownReason- return [(nm, ur) | nm <- objNames]+ pure [(nm, ur) | nm <- objNames] where continue classify = do objectiveValues <- getObjectiveValues nms <- zipWithM getIndependentResult [0..] objNames- return [(n, classify (m {modelObjectives = objectiveValues})) | (n, m) <- nms]+ pure [(n, classify (m {modelObjectives = objectiveValues})) | (n, m) <- nms] getIndependentResult :: Int -> String -> m (String, SMTModel) getIndependentResult i s = do m <- getModelAtIndex (Just i)- return (s, m)+ pure (s, m) -- | Generalization of 'Data.SBV.Control.getParetoOptResults' getParetoOptResults :: (MonadIO m, MonadQuery m) => Maybe Int -> m (Bool, [SMTResult]) getParetoOptResults (Just i)- | i <= 0 = return (True, [])+ | i <= 0 = pure (True, []) getParetoOptResults mbN = do cfg <- getConfig cs <- checkSat case cs of- Unsat -> return (False, [])+ Unsat -> pure (False, []) Sat -> continue (classifyModel cfg) DSat{} -> continue (classifyModel cfg) Unk -> do ur <- getUnknownReason- return (False, [ProofError cfg [show ur] Nothing])+ pure (False, [ProofError cfg [show ur] Nothing]) where continue classify = do m <- getModel (limReached, fronts) <- getParetoFronts (subtract 1 <$> mbN) [m]- return (limReached, reverse (map classify fronts))+ pure (limReached, reverse (map classify fronts)) getParetoFronts :: (MonadIO m, MonadQuery m) => Maybe Int -> [SMTModel] -> m (Bool, [SMTModel])- getParetoFronts (Just i) sofar | i <= 0 = return (True, sofar)+ getParetoFronts (Just i) sofar | i <= 0 = pure (True, sofar) getParetoFronts mbi sofar = do cs <- checkSat let more = getModel >>= \m -> getParetoFronts (subtract 1 <$> mbi) (m : sofar) case cs of- Unsat -> return (False, sofar)+ Unsat -> pure (False, sofar) Sat -> more DSat{} -> more Unk -> more --- | Generalization of 'Data.SBV.Control.getModel'-getModel :: (MonadIO m, MonadQuery m) => m SMTModel-getModel = getModelAtIndex Nothing---- | Get a model stored at an index. This is likely very Z3 specific!-getModelAtIndex :: (MonadIO m, MonadQuery m) => Maybe Int -> m SMTModel-getModelAtIndex mbi = do- State{runMode} <- queryState- rm <- io $ readIORef runMode- case rm of- m@CodeGen -> error $ "SBV.getModel: Model is not available in mode: " ++ show m- m@Concrete{} -> error $ "SBV.getModel: Model is not available in mode: " ++ show m- SMTMode _ _ isSAT _ -> do- cfg <- getConfig- qinps <- getQuantifiedInputs- uis <- getUIs-- -- for "sat", display the prefix existentials. for "proof", display the prefix universals- let allModelInputs = if isSAT then prefixExistentials qinps- else prefixUniversals qinps-- -- Add on observables only if we're not in a quantified context- grabObservables = S.length allModelInputs == S.length qinps -- i.e., we didn't drop anything-- obsvs <- if grabObservables- then getObservables- else do queryDebug ["*** In a quantified context, obvservables will not be printed."]- return mempty-- let grab (NamedSymVar sv nm) = wrap <$> getValueCV mbi sv- where- wrap !c = (sv, (nm, c))-- inputAssocs <- mapM (grab . namedSymVar) allModelInputs-- let name = fst . snd- removeSV = snd- prepare = S.unstableSort . S.filter (not . isNonModelVar cfg . T.unpack . name)- assocs = S.fromList (sortOn fst obsvs) <> fmap removeSV (prepare inputAssocs)-- -- collect UIs, and UI functions if requested- let uiFuns = [ui | ui@(nm, SBVType as) <- uis, length as > 1, satTrackUFs cfg, not (isNonModelVar cfg nm)] -- functions have at least two things in their type!- uiRegs = [ui | ui@(nm, SBVType as) <- uis, length as == 1, not (isNonModelVar cfg nm)]-- -- If there are uninterpreted functions, arrange so that z3's pretty-printer flattens things out- -- as cex's tend to get larger- unless (null uiFuns) $- let solverCaps = capabilities (solver cfg)- in case supportsFlattenedModels solverCaps of- Nothing -> return ()- Just cmds -> mapM_ (send True) cmds-- bindings <- let get i@(ALL, _) = return (i, Nothing)- get i@(EX, getSV -> sv) = case lookupInput fst sv inputAssocs of- Just (_, (_, cv)) -> return (i, Just cv)- Nothing -> do cv <- getValueCV mbi sv- return (i, Just cv)-- flipQ i@(q, sv) = case (isSAT, q) of- (True, _ ) -> i- (False, EX) -> (ALL, sv)- (False, ALL) -> (EX, sv)-- in if validationRequested cfg- then Just <$> mapM (get . flipQ) qinps- else return Nothing-- uiFunVals <- mapM (\ui@(nm, t) -> (\a -> (nm, (t, a))) <$> getUIFunCVAssoc mbi ui) uiFuns-- uiVals <- mapM (\ui@(nm, _) -> (nm,) <$> getUICVal mbi ui) uiRegs-- return SMTModel { modelObjectives = []- , modelBindings = toList <$> bindings- , modelAssocs = uiVals ++ toList (first T.unpack <$> assocs)- , modelUIFuns = uiFunVals- }---- | Just after a check-sat is issued, collect objective values. Used--- internally only, not exposed to the user.-getObjectiveValues :: forall m. (MonadIO m, MonadQuery m) => m [(String, GeneralizedCV)]-getObjectiveValues = do let cmd = "(get-objectives)"-- bad = unexpected "getObjectiveValues" cmd "a list of objective values" Nothing-- r <- ask cmd-- inputs <- toList . fmap namedSymVar <$> getQuantifiedInputs-- parse r bad $ \case EApp (ECon "objectives" : es) -> catMaybes <$> mapM (getObjValue (bad r) inputs) es- _ -> bad r Nothing-- where -- | Parse an objective value out.- getObjValue :: (forall a. Maybe [String] -> m a) -> [NamedSymVar] -> SExpr -> m (Maybe (String, GeneralizedCV))- getObjValue bailOut inputs expr =- case expr of- EApp [_] -> return Nothing -- Happens when a soft-assertion has no associated group.- EApp [ECon nm, v] -> locate nm v -- Regular case- _ -> dontUnderstand (show expr)-- where locate nm v = case listToMaybe [p | p@(NamedSymVar sv _) <- inputs, show sv == nm] of- Nothing -> return Nothing -- Happens when the soft assertion has a group-id that's not one of the input names- Just (NamedSymVar sv actualName) -> grab sv v >>= \val -> return $ Just (T.unpack actualName, val)-- dontUnderstand s = bailOut $ Just [ "Unable to understand solver output."- , "While trying to process: " ++ s- ]-- grab :: SV -> SExpr -> m GeneralizedCV- grab s topExpr- | Just v <- recoverKindedValue k topExpr = return $ RegularCV v- | True = ExtendedCV <$> cvt (simplify topExpr)- where k = kindOf s-- -- Convert to an extended expression. Hopefully complete!- cvt :: SExpr -> m ExtCV- cvt (ECon "oo") = return $ Infinite k- cvt (ECon "epsilon") = return $ Epsilon k- cvt (EApp [ECon "interval", x, y]) = Interval <$> cvt x <*> cvt y- cvt (ENum (i, _)) = return $ BoundedCV $ mkConstCV k i- cvt (EReal r) = return $ BoundedCV $ CV k $ CAlgReal r- cvt (EFloat f) = return $ BoundedCV $ CV k $ CFloat f- cvt (EDouble d) = return $ BoundedCV $ CV k $ CDouble d- cvt (EApp [ECon "+", x, y]) = AddExtCV <$> cvt x <*> cvt y- cvt (EApp [ECon "*", x, y]) = MulExtCV <$> cvt x <*> cvt y- -- Nothing else should show up, hopefully!- cvt e = dontUnderstand (show e)-- -- drop the pesky to_real's that Z3 produces.. Cool but useless.- simplify :: SExpr -> SExpr- simplify (EApp [ECon "to_real", n]) = n- simplify (EApp xs) = EApp (map simplify xs)- simplify e = e- -- | Generalization of 'Data.SBV.Control.checkSatAssuming' checkSatAssuming :: (MonadIO m, MonadQuery m) => [SBool] -> m CheckSatResult checkSatAssuming sBools = fst <$> checkSatAssumingHelper False sBools@@ -448,14 +296,14 @@ checkSatAssumingHelper getAssumptions sBools = do -- sigh.. SMT-Lib requires the values to be literals only. So, create proxies. let mkAssumption st = do swsOriginal <- mapM (\sb -> do sv <- sbvToSV st sb- return (sv, sb)) sBools+ pure (sv, sb)) sBools -- drop duplicates and trues let swbs = [p | p@(sv, _) <- nubBy ((==) `on` fst) swsOriginal, sv /= trueSV] -- get a unique proxy name for each uniqueSWBs <- mapM (\(sv, sb) -> do unique <- incrementInternalCounter st- return (sv, (unique, sb))) swbs+ pure (sv, (unique, sb))) swbs let translate (sv, (unique, sb)) = (nm, decls, (proxy, sb)) where nm = show sv@@ -464,13 +312,13 @@ , "(assert (= " ++ proxy ++ " " ++ nm ++ "))" ] - return $ map translate uniqueSWBs+ pure $ map translate uniqueSWBs assumptions <- inNewContext mkAssumption let (origNames, declss, proxyMap) = unzip3 assumptions - let cmd = "(check-sat-assuming (" ++ unwords (map fst proxyMap) ++ "))"+ let cmd = "(check-sat-assuming (" <> T.pack (unwords (map fst proxyMap)) <> "))" bad = unexpected "checkSatAssuming" cmd "one of sat/unsat/unknown" $ Just [ "Make sure you use:" , ""@@ -479,17 +327,17 @@ , "to tell the solver to produce unsat assumptions." ] - mapM_ (send True) $ concat declss+ mapM_ (send True . T.pack) $ concat declss r <- ask cmd let grabUnsat | getAssumptions = do as <- getUnsatAssumptions origNames proxyMap- return (Unsat, Just as)- | True = return (Unsat, Nothing)+ pure (Unsat, Just as)+ | True = pure (Unsat, Nothing) - parse r bad $ \case ECon "sat" -> return (Sat, Nothing)+ parse r bad $ \case ECon "sat" -> pure (Sat, Nothing) ECon "unsat" -> grabUnsat- ECon "unknown" -> return (Unk, Nothing)+ ECon "unknown" -> pure (Unk, Nothing) _ -> bad r Nothing -- | Generalization of 'Data.SBV.Control.getAssertionStackDepth'@@ -501,30 +349,27 @@ restoreTablesAndArrays = do st <- queryState tCount <- M.size <$> (io . readIORef) (rtblMap st)- aCount <- IM.size <$> (io . readIORef) (rArrayMap st) - let tInits = [ "table" ++ show i ++ "_initializer" | i <- [0 .. tCount - 1]]- aInits = [ "array_" ++ show i ++ "_initializer" | i <- [0 .. aCount - 1]]- inits = tInits ++ aInits+ let inits = [ "table" ++ show i ++ "_initializer" | i <- [0 .. tCount - 1]] case inits of- [] -> return () -- Nothing to do- [x] -> send True $ "(assert " ++ x ++ ")"- xs -> send True $ "(assert (and " ++ unwords xs ++ "))"+ [] -> pure () -- Nothing to do+ [x] -> send True $ "(assert " <> T.pack x <> ")"+ xs -> send True $ "(assert (and " <> T.pack (unwords xs) <> "))" -- | Generalization of 'Data.SBV.Control.inNewAssertionStack' inNewAssertionStack :: (MonadIO m, MonadQuery m) => m a -> m a inNewAssertionStack q = do push 1 r <- q pop 1- return r+ pure r -- | Generalization of 'Data.SBV.Control.push' push :: (MonadIO m, MonadQuery m) => Int -> m () push i | i <= 0 = error $ "Data.SBV: push requires a strictly positive level argument, received: " ++ show i | True = do depth <- getAssertionStackDepth- send True $ "(push " ++ show i ++ ")"+ send True $ "(push " <> showText i <> ")" modifyQueryState $ \s -> s{queryAssertionStackDepth = depth + i} -- | Generalization of 'Data.SBV.Control.pop'@@ -542,7 +387,7 @@ , "***" , "*** Request this as a feature for the underlying solver!" ]- else do send True $ "(pop " ++ show i ++ ")"+ else do send True $ "(pop " <> showText i <> ")" restoreTablesAndArrays modifyQueryState $ \s -> s{queryAssertionStackDepth = depth - i} where shl 1 = "one level"@@ -554,7 +399,7 @@ go cfg (cases ++ [("Coverage", sNot (sOr (map snd cases)))]) where msg = when printCases . io . putStrLn - go _ [] = return Nothing+ go _ [] = pure Nothing go cfg ((n,c):ncs) = do let notify s = msg $ "Case " ++ n ++ ": " ++ s notify "Starting"@@ -566,15 +411,15 @@ Sat -> do notify "Satisfiable" res <- Satisfiable cfg <$> getModel- return $ Just (n, res)+ pure $ Just (n, res) DSat mbP -> do notify $ "Delta satisfiable" ++ maybe "" (" (precision: " ++) mbP res <- DeltaSat cfg mbP <$> getModel- return $ Just (n, res)+ pure $ Just (n, res) Unk -> do notify "Unknown" res <- Unknown cfg <$> getUnknownReason- return $ Just (n, res)+ pure $ Just (n, res) -- | Generalization of 'Data.SBV.Control.resetAssertions' resetAssertions :: (MonadIO m, MonadQuery m) => m ()@@ -586,7 +431,7 @@ -- | Generalization of 'Data.SBV.Control.echo' echo :: (MonadIO m, MonadQuery m) => String -> m ()-echo s = do let cmd = "(echo \"" ++ concatMap sanitize s ++ "\")"+echo s = do let cmd = "(echo \"" <> T.pack (concatMap sanitize s) <> "\")" -- we send the command, but otherwise ignore the response -- note that 'send True/False' would be incorrect here. 'send True' would@@ -595,7 +440,7 @@ -- and forgets about it immediately. _ <- ask cmd - return ()+ pure () where sanitize '"' = "\"\"" -- quotes need to be duplicated sanitize c = [c] @@ -607,7 +452,7 @@ -- | Generalization of 'Data.SBV.Control.getUnsatCore' getUnsatCore :: (MonadIO m, MonadQuery m) => m [String] getUnsatCore = do- let cmd = "(get-unsat-core)"+ let cmd = "(get-unsat-core)" :: T.Text bad = unexpected "getUnsatCore" cmd "an unsat-core response" $ Just [ "Make sure you use:" , ""@@ -629,7 +474,7 @@ r <- ask cmd parse r bad $ \case- EApp es | Just xs <- mapM fromECon es -> return $ map unBar xs+ EApp es | Just xs <- mapM fromECon es -> pure $ map unBar xs _ -> bad r Nothing -- | Retrieve the unsat core if it was asked for in the configuration@@ -638,12 +483,12 @@ cfg <- getConfig if or [b | ProduceUnsatCores b <- solverSetOptions cfg] then Just <$> getUnsatCore- else return Nothing+ else pure Nothing -- | Generalization of 'Data.SBV.Control.getProof' getProof :: (MonadIO m, MonadQuery m) => m String getProof = do- let cmd = "(get-proof)"+ let cmd = "(get-proof)" :: T.Text bad = unexpected "getProof" cmd "a get-proof response" $ Just [ "Make sure you use:" , ""@@ -658,7 +503,7 @@ -- we only care about the fact that we can parse the output, so the -- result of parsing is ignored.- parse r bad $ \_ -> return r+ parse r bad $ \_ -> pure r -- | Generalization of 'Data.SBV.Control.getInterpolantMathSAT'. Use this version with MathSAT. getInterpolantMathSAT :: (MonadIO m, MonadQuery m) => [String] -> m String@@ -667,7 +512,7 @@ = error "SBV.getInterpolantMathSAT requires at least one marked constraint, received none!" | True = do let bar s = '|' : s ++ "|"- cmd = "(get-interpolant (" ++ unwords (map bar fs) ++ "))"+ cmd = "(get-interpolant (" <> T.pack (unwords (map bar fs)) <> "))" bad = unexpected "getInterpolant" cmd "a get-interpolant response" $ Just [ "Make sure you use:" , ""@@ -680,31 +525,52 @@ r <- ask cmd - parse r bad $ \e -> return $ serialize False e+ parse r bad $ \e -> pure $ serialize False e +-- | Generalization of 'Data.SBV.Control.getAbduct'.+getAbduct :: (SolverContext m, MonadIO m, MonadQuery m) => Maybe String -> String -> SBool -> m String+getAbduct mbGrammar defName b = do+ s <- inNewContext (`sbvToSV` b)+ let cmd = "(get-abduct " <> T.pack defName <> " " <> showText s <> T.pack (fromMaybe "" mbGrammar) <> ")"+ bad = unexpected "getAbduct" cmd "a get-abduct response" Nothing++ r <- ask cmd++ parse r bad $ \e -> pure $ serialize False e++-- | Generalization of 'Data.SBV.Control.getAbductNext'.+getAbductNext :: (MonadIO m, MonadQuery m) => m String+getAbductNext = do+ let cmd = "(get-abduct-next)" :: T.Text+ bad = unexpected "getAbductNext" cmd "a get-abduct-next response" Nothing++ r <- ask cmd++ parse r bad $ \e -> pure $ serialize False e+ -- | Generalization of 'Data.SBV.Control.getInterpolantZ3'. Use this version with Z3. getInterpolantZ3 :: (MonadIO m, MonadQuery m) => [SBool] -> m String getInterpolantZ3 fs | length fs < 2 = error $ "SBV.getInterpolantZ3 requires at least two booleans, received: " ++ show fs | True- = do ss <- let fAll [] sofar = return $ reverse sofar+ = do ss <- let fAll [] sofar = pure $ reverse sofar fAll (b:bs) sofar = do sv <- inNewContext (`sbvToSV` b) fAll bs (sv : sofar) in fAll fs [] - let cmd = "(get-interpolant " ++ unwords (map show ss) ++ ")"+ let cmd = "(get-interpolant " <> T.pack (unwords (map show ss)) <> ")" bad = unexpected "getInterpolant" cmd "a get-interpolant response" Nothing r <- ask cmd - parse r bad $ \e -> return $ serialize False e+ parse r bad $ \e -> pure $ serialize False e -- | Generalization of 'Data.SBV.Control.getAssertions' getAssertions :: (MonadIO m, MonadQuery m) => m [String] getAssertions = do- let cmd = "(get-assertions)"+ let cmd = "(get-assertions)" :: T.Text bad = unexpected "getAssertions" cmd "a get-assertions response" $ Just [ "Make sure you use:" , ""@@ -718,13 +584,13 @@ r <- ask cmd parse r bad $ \pe -> case pe of- EApp xs -> return $ map render xs- _ -> return [render pe]+ EApp xs -> pure $ map render xs+ _ -> pure [render pe] -- | Generalization of 'Data.SBV.Control.getAssignment' getAssignment :: (MonadIO m, MonadQuery m) => m [(String, Bool)] getAssignment = do- let cmd = "(get-assignment)"+ let cmd = "(get-assignment)" :: T.Text bad = unexpected "getAssignment" cmd "a get-assignment response" $ Just [ "Make sure you use:" , ""@@ -735,13 +601,13 @@ ] -- we're expecting boolean assignment to labels, essentially- grab (EApp [ECon s, ENum (0, _)]) = Just (unQuote s, False)- grab (EApp [ECon s, ENum (1, _)]) = Just (unQuote s, True)- grab _ = Nothing+ grab (EApp [ECon s, ENum (0, _, _)]) = Just (unQuote s, False)+ grab (EApp [ECon s, ENum (1, _, _)]) = Just (unQuote s, True)+ grab _ = Nothing r <- ask cmd - parse r bad $ \case EApp ps | Just vs <- mapM grab ps -> return vs+ parse r bad $ \case EApp ps | Just vs <- mapM grab ps -> pure vs _ -> bad r Nothing -- | Make an assignment. The type 'Assignment' is abstract, the result is typically passed@@ -769,9 +635,9 @@ mkSMTResult :: (MonadIO m, MonadQuery m) => [Assignment] -> m SMTResult mkSMTResult asgns = do QueryState{queryConfig} <- getQueryState- inps <- userInputsToList <$> getQuantifiedInputs+ inps <- F.toList <$> getTopLevelInputs - let grabValues st = do let extract (Assign s n) = sbvToSV st (SBV s) >>= \sv -> return (sv, n)+ let grabValues st = do let extract (Assign s n) = sbvToSV st (SBV s) >>= \sv -> pure (sv, n) modelAssignment <- mapM extract asgns @@ -782,8 +648,8 @@ let userSS = map fst modelAssignment missing, extra, dup :: [String]- missing = [T.unpack n | (EX, NamedSymVar s n) <- inps, s `notElem` userSS]- extra = [show s | s <- userSS, s `notElem` map (getSV . namedSymVar) inps]+ missing = [T.unpack n | NamedSymVar s n <- inps, s `notElem` userSS]+ extra = [show s | s <- userSS, s `notElem` map getSV inps] dup = let walk [] = [] walk (n:ns) | n `elem` ns = show n : walk (filter (/= n) ns)@@ -814,7 +680,7 @@ , "*** Data.SBV: Check your query result construction!" ] - let findName s = case [T.unpack nm | (_, NamedSymVar i nm) <- inps, s == i] of+ let findName s = case [T.unpack nm | NamedSymVar i nm <- inps, s == i] of [nm] -> nm [] -> error "*** Data.SBV: Impossible happened: Cannot find " ++ show s ++ " in the input list" nms -> error $ unlines [ ""@@ -822,7 +688,7 @@ , "*** Candidates: " ++ unwords nms ] - return [(findName s, n) | (s, n) <- modelAssignment]+ pure [(findName s, n) | (s, n) <- modelAssignment] assocs <- inNewContext grabValues @@ -832,6 +698,4 @@ , modelUIFuns = [] } - return $ Satisfiable queryConfig m--{-# ANN getModelAtIndex ("HLint: ignore Use forM_" :: String) #-}+ pure $ Satisfiable queryConfig m
Data/SBV/Control/Types.hs view
@@ -9,12 +9,15 @@ -- Types related to interactive queries ----------------------------------------------------------------------------- +{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Control.Types ( CheckSatResult(..) , Logic(..)- , SMTOption(..), isStartModeOption, isOnlyOnceOption, setSMTOption+ , SMTOption(..), isStartModeOption, isOnlyOnceOption , SMTInfoFlag(..) , SMTErrorBehavior(..) , SMTReasonUnknown(..)@@ -22,13 +25,14 @@ ) where import Control.DeepSeq (NFData(..))+import GHC.Generics (Generic) -- | Result of a 'Data.SBV.Control.checkSat' or 'Data.SBV.Control.checkSatAssuming' call. data CheckSatResult = Sat -- ^ Satisfiable: A model is available, which can be queried with 'Data.SBV.Control.getValue'. | DSat (Maybe String) -- ^ Delta-satisfiable: A delta-sat model is available. String is the precision info, if available. | Unsat -- ^ Unsatisfiable: No model is available. Unsat cores might be obtained via 'Data.SBV.Control.getUnsatCore'. | Unk -- ^ Unknown: Use 'Data.SBV.Control.getUnknownReason' to obtain an explanation why this might be the case.- deriving (Eq, Show)+ deriving (Eq, Show, NFData, Generic) -- | Collectable information from the solver. data SMTInfoFlag = AllStatistics@@ -84,7 +88,7 @@ show Version = ":version" show (InfoKeyword s) = s --- | Option values that can be set in the solver, following the SMTLib specification <http://smtlib.cs.uiowa.edu/language.shtml>.+-- | Option values that can be set in the solver, following the SMTLib specification <https://smt-lib.org/language.shtml>. -- -- Note that not all solvers may support all of these! --@@ -105,12 +109,14 @@ | ProduceInterpolants Bool | ProduceUnsatAssumptions Bool | ProduceUnsatCores Bool+ | ProduceAbducts Bool | RandomSeed Integer | ReproducibleResourceLimit Integer | SMTVerbosity Integer | OptionKeyword String [String] | SetLogic Logic | SetInfo String [String]+ | SetTimeOut Integer deriving Show -- | Can this command only be run at the very beginning? If 'True' then@@ -124,12 +130,14 @@ isStartModeOption ProduceInterpolants{} = True isStartModeOption ProduceUnsatAssumptions{} = True isStartModeOption ProduceUnsatCores{} = True+isStartModeOption ProduceAbducts{} = True isStartModeOption RandomSeed{} = True isStartModeOption ReproducibleResourceLimit{} = False isStartModeOption SMTVerbosity{} = False isStartModeOption OptionKeyword{} = True -- Conservative. isStartModeOption SetLogic{} = True isStartModeOption SetInfo{} = False+isStartModeOption SetTimeOut{} = True -- | Can this option be set multiple times? I'm only making a guess here. -- If this returns True, then we'll only send the last instance we see.@@ -141,6 +149,7 @@ isOnlyOnceOption ProduceProofs{} = True isOnlyOnceOption ProduceInterpolants{} = True isOnlyOnceOption ProduceUnsatAssumptions{} = True+isOnlyOnceOption ProduceAbducts{} = False isOnlyOnceOption ProduceUnsatCores{} = True isOnlyOnceOption RandomSeed{} = False isOnlyOnceOption ReproducibleResourceLimit{} = False@@ -148,48 +157,21 @@ isOnlyOnceOption OptionKeyword{} = False -- This is really hard to determine. Just being permissive isOnlyOnceOption SetLogic{} = True isOnlyOnceOption SetInfo{} = False---- SMTLib's True/False is spelled differently than Haskell's.-smtBool :: Bool -> String-smtBool True = "true"-smtBool False = "false"---- | Translate an option setting to SMTLib. Note the SetLogic/SetInfo discrepancy.-setSMTOption :: SMTOption -> String-setSMTOption = cvt- where cvt (DiagnosticOutputChannel f) = opt [":diagnostic-output-channel", show f]- cvt (ProduceAssertions b) = opt [":produce-assertions", smtBool b]- cvt (ProduceAssignments b) = opt [":produce-assignments", smtBool b]- cvt (ProduceProofs b) = opt [":produce-proofs", smtBool b]- cvt (ProduceInterpolants b) = opt [":produce-interpolants", smtBool b]- cvt (ProduceUnsatAssumptions b) = opt [":produce-unsat-assumptions", smtBool b]- cvt (ProduceUnsatCores b) = opt [":produce-unsat-cores", smtBool b]- cvt (RandomSeed i) = opt [":random-seed", show i]- cvt (ReproducibleResourceLimit i) = opt [":reproducible-resource-limit", show i]- cvt (SMTVerbosity i) = opt [":verbosity", show i]- cvt (OptionKeyword k as) = opt (k : as)- cvt (SetLogic l) = logic l- cvt (SetInfo k as) = info (k : as)-- opt xs = "(set-option " ++ unwords xs ++ ")"- info xs = "(set-info " ++ unwords xs ++ ")"-- logic Logic_NONE = "; NB. not setting the logic per user request of Logic_NONE"- logic l = "(set-logic " ++ show l ++ ")"+isOnlyOnceOption SetTimeOut{} = False -- | SMT-Lib logics. If left unspecified SBV will pick the logic based on what it determines is needed. However, the -- user can override this choice using a call to 'Data.SBV.setLogic' This is especially handy if one is experimenting with custom--- logics that might be supported on new solvers. See <http://smtlib.cs.uiowa.edu/logics.shtml> for the official list.+-- logics that might be supported on new solvers. See <https://smt-lib.org/logics.shtml> for the official list. data Logic = AUFLIA -- ^ Formulas over the theory of linear integer arithmetic and arrays extended with free sort and function symbols but restricted to arrays with integer indices and values.- | AUFLIRA -- ^ Linear formulas with free sort and function symbols over one- and two-dimentional arrays of integer index and real value.+ | AUFLIRA -- ^ Linear formulas with free sort and function symbols over one- and two-dimensional arrays of integer index and real value. | AUFNIRA -- ^ Formulas with free function and predicate symbols over a theory of arrays of arrays of integer index and real value. | LRA -- ^ Linear formulas in linear real arithmetic.- | QF_ABV -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays.- | QF_AUFBV -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays extended with free sort and function symbols.+ | QF_ABV -- ^ Quantifier-free formulas over the theory of bit-vectors and bit-vector arrays.+ | QF_AUFBV -- ^ Quantifier-free formulas over the theory of bit-vectors and bit-vector arrays extended with free sort and function symbols. | QF_AUFLIA -- ^ Quantifier-free linear formulas over the theory of integer arrays extended with free sort and function symbols. | QF_AX -- ^ Quantifier-free formulas over the theory of arrays with extensionality.- | QF_BV -- ^ Quantifier-free formulas over the theory of fixed-size bitvectors.+ | QF_BV -- ^ Quantifier-free formulas over the theory of fixed-size bit-vectors. | QF_IDL -- ^ Difference Logic over the integers. Boolean combinations of inequations of the form x - y < b where x and y are integer variables and b is an integer constant. | QF_LIA -- ^ Unquantified linear integer arithmetic. In essence, Boolean combinations of inequations between linear polynomials over integer variables. | QF_LRA -- ^ Unquantified linear real arithmetic. In essence, Boolean combinations of inequations between linear polynomials over real variables.@@ -197,7 +179,7 @@ | QF_NRA -- ^ Quantifier-free real arithmetic. | QF_RDL -- ^ Difference Logic over the reals. In essence, Boolean combinations of inequations of the form x - y < b where x and y are real variables and b is a rational constant. | QF_UF -- ^ Unquantified formulas built over a signature of uninterpreted (i.e., free) sort and function symbols.- | QF_UFBV -- ^ Unquantified formulas over bitvectors with uninterpreted sort function and symbols.+ | QF_UFBV -- ^ Unquantified formulas over bit-vectors with uninterpreted sort function and symbols. | QF_UFIDL -- ^ Difference Logic over the integers (in essence) but with uninterpreted sort and function symbols. | QF_UFLIA -- ^ Unquantified linear integer arithmetic with uninterpreted sort and function symbols. | QF_UFLRA -- ^ Unquantified linear real arithmetic with uninterpreted sort and function symbols.@@ -247,5 +229,5 @@ show Logic_NONE = "Logic_NONE" show (CustomLogic l) = l -{-# ANN type SMTInfoResponse ("HLint: ignore Use camelCase" :: String) #-}-{-# ANN type Logic ("HLint: ignore Use camelCase" :: String) #-}+{- HLint ignore type SMTInfoResponse "Use camelCase" -}+{- HLint ignore type Logic "Use camelCase" -}
Data/SBV/Control/Utils.hs view
@@ -10,1826 +10,2176 @@ ----------------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}--module Data.SBV.Control.Utils (- io- , ask, send, getValue, getFunction, getUninterpretedValue- , getValueCV, getUICVal, getUIFunCVAssoc, getUnsatAssumptions- , SMTFunction(..), registerUISMTFunction- , getQueryState, modifyQueryState, getConfig, getObjectives, getUIs- , getSBVAssertions, getSBVPgm, getQuantifiedInputs, getObservables- , checkSat, checkSatUsing, getAllSatResult- , inNewContext, freshVar, freshVar_, freshArray, freshArray_- , parse- , unexpected- , timeout- , queryDebug- , retrieveResponse- , recoverKindedValue- , runProofOn- , executeQuery- ) where--import Data.List (sortBy, sortOn, elemIndex, partition, groupBy, tails, intercalate, nub, sort)--import Data.Char (isPunctuation, isSpace, isDigit)-import Data.Function (on)-import Data.Bifunctor (first)--import Data.Proxy--import qualified Data.Foldable as F (toList)-import qualified Data.Map.Strict as Map-import qualified Data.IntMap.Strict as IMap-import qualified Data.Sequence as S-import qualified Data.Text as T--import Control.Monad (join, unless, zipWithM, when, replicateM, forM_)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans (lift)-import Control.Monad.Reader (runReaderT)--import Data.Maybe (isNothing, isJust)--import Data.IORef (readIORef, writeIORef, IORef, newIORef, modifyIORef')--import Data.Time (getZonedTime)-import Data.Ratio--import Data.SBV.Core.Data ( SV(..), trueSV, falseSV, CV(..), trueCV, falseCV, SBV, sbvToSV, kindOf, Kind(..)- , HasKind(..), mkConstCV, CVal(..), SMTResult(..)- , NamedSymVar, SMTConfig(..), SMTModel(..)- , QueryState(..), SVal(..), Quantifier(..), cache- , newExpr, SBVExpr(..), Op(..), FPOp(..), SBV(..), SymArray(..)- , SolverContext(..), SBool, Objective(..), SolverCapabilities(..), capabilities- , Result(..), SMTProblem(..), trueSV, SymVal(..), SBVPgm(..), SMTSolver(..), SBVRunMode(..)- , SBVType(..), forceSVArg, RoundingMode(RoundNearestTiesToEven), (.=>)- , RCSet(..)- )--import Data.SBV.Core.Symbolic ( IncState(..), withNewIncState, State(..), svToSV, symbolicEnv, SymbolicT- , MonadQuery(..), QueryContext(..), Queriable(..), Fresh(..), VarContext(..)- , registerLabel, svMkSymVar, validationRequested- , isSafetyCheckingIStage, isSetupIStage, isRunIStage, IStage(..), QueryT(..)- , extractSymbolicSimulationState, MonadSymbolic(..), newUninterpreted- , UserInputs, getInputs, prefixExistentials, getSV, quantifier, getUserName- , namedSymVar, NamedSymVar(..), lookupInput, userInputs, userInputsToList- , getUserName', Name, CnstMap- )--import Data.SBV.Core.AlgReals (mergeAlgReals, AlgReal(..), RealPoint(..))-import Data.SBV.Core.SizedFloats (fpZero, fpFromInteger, fpFromFloat, fpFromDouble)-import Data.SBV.Core.Kind (smtType, hasUninterpretedSorts)-import Data.SBV.Core.Operations (svNot, svNotEqual, svOr, svEqual)--import Data.SBV.SMT.SMT (showModel, parseCVs, SatModel, AllSatResult(..))-import Data.SBV.SMT.SMTLib (toIncSMTLib, toSMTLib)-import Data.SBV.SMT.Utils (showTimeoutValue, addAnnotations, alignPlain, debug, mergeSExpr, SBVException(..))--import Data.SBV.Utils.ExtractIO-import Data.SBV.Utils.Lib (qfsToString)-import Data.SBV.Utils.SExpr-import Data.SBV.Utils.PrettyNum (cvToSMTLib)--import Data.SBV.Control.Types--import qualified Data.Set as Set (empty, fromList, toAscList)--import qualified Control.Exception as C--import GHC.Stack---- | 'Data.SBV.Trans.Control.QueryT' as a 'SolverContext'.-instance MonadIO m => SolverContext (QueryT m) where- constrain = addQueryConstraint False []- softConstrain = addQueryConstraint True []- namedConstraint nm = addQueryConstraint False [(":named", nm)]- constrainWithAttribute = addQueryConstraint False- addAxiom = addQueryAxiom- contextState = queryState-- setOption o- | isStartModeOption o = error $ unlines [ ""- , "*** Data.SBV: '" ++ show o ++ "' can only be set at start-up time."- , "*** Hint: Move the call to 'setOption' before the query."- ]- | True = send True $ setSMTOption o-- addSMTDefinition nm _ = error $ unlines [ ""- , "*** Data.SBV: '" ++ show nm ++ "' must be defined in regular (non-query) mode."- , "*** Hint: Define all functions before starting the query."- ]---- | Adding a constraint, possibly with attributes and possibly soft. Only used internally.--- Use 'constrain' and 'namedConstraint' from user programs.-addQueryConstraint :: (MonadIO m, MonadQuery m) => Bool -> [(String, String)] -> SBool -> m ()-addQueryConstraint isSoft atts b = do sv <- inNewContext (\st -> liftIO $ do mapM_ (registerLabel "Constraint" st) [nm | (":named", nm) <- atts]- sbvToSV st b)-- unless (null atts && sv == trueSV) $- send True $ "(" ++ asrt ++ " " ++ addAnnotations atts (show sv) ++ ")"- where asrt | isSoft = "assert-soft"- | True = "assert"--addQueryAxiom :: (MonadIO m, MonadQuery m) => String -> [String] -> m ()-addQueryAxiom nm ls = do send True $ "; -- user given axiom: " ++ nm- send True $ intercalate "\n" ls---- | Get the current configuration-getConfig :: (MonadIO m, MonadQuery m) => m SMTConfig-getConfig = queryConfig <$> getQueryState---- | Get the objectives-getObjectives :: (MonadIO m, MonadQuery m) => m [Objective (SV, SV)]-getObjectives = do State{rOptGoals} <- queryState- io $ reverse <$> readIORef rOptGoals---- | Get the program-getSBVPgm :: (MonadIO m, MonadQuery m) => m SBVPgm-getSBVPgm = do State{spgm} <- queryState- io $ readIORef spgm---- | Get the assertions put in via 'Data.SBV.sAssert'-getSBVAssertions :: (MonadIO m, MonadQuery m) => m [(String, Maybe CallStack, SV)]-getSBVAssertions = do State{rAsserts} <- queryState- io $ reverse <$> readIORef rAsserts---- | Generalization of 'Data.SBV.Control.io'-io :: MonadIO m => IO a -> m a-io = liftIO---- | Sync-up the external solver with new context we have generated-syncUpSolver :: (MonadIO m, MonadQuery m) => IORef CnstMap -> IncState -> m ()-syncUpSolver rGlobalConsts is = do- cfg <- getConfig-- -- update global consts to have the new ones- (newConsts, allConsts) <- liftIO $ do nc <- readIORef (rNewConsts is)- oc <- readIORef rGlobalConsts- let allConsts = Map.union nc oc- writeIORef rGlobalConsts allConsts- pure (nc, allConsts)-- ls <- io $ do let swap (a, b) = (b, a)- cmp (a, _) (b, _) = a `compare` b- arrange (i, (at, rt, es)) = ((i, at, rt), es)- inps <- reverse <$> readIORef (rNewInps is)- ks <- readIORef (rNewKinds is)- arrs <- IMap.toAscList <$> readIORef (rNewArrs is)- tbls <- map arrange . sortBy cmp . map swap . Map.toList <$> readIORef (rNewTbls is)- uis <- Map.toAscList <$> readIORef (rNewUIs is)- as <- readIORef (rNewAsgns is)- constraints <- readIORef (rNewConstraints is)-- let cnsts = sortBy cmp . map swap . Map.toList $ newConsts-- return $ toIncSMTLib cfg inps ks (allConsts, cnsts) arrs tbls uis as constraints cfg- mapM_ (send True) $ mergeSExpr ls---- | Retrieve the query context-getQueryState :: (MonadIO m, MonadQuery m) => m QueryState-getQueryState = do state <- queryState- mbQS <- io $ readIORef (rQueryState state)- case mbQS of- Nothing -> error $ unlines [ ""- , "*** Data.SBV: Impossible happened: Query context required in a non-query mode."- , "Please report this as a bug!"- ]- Just qs -> return qs---- | Generalization of 'Data.SBV.Control.modifyQueryState'-modifyQueryState :: (MonadIO m, MonadQuery m) => (QueryState -> QueryState) -> m ()-modifyQueryState f = do state <- queryState- mbQS <- io $ readIORef (rQueryState state)- case mbQS of- Nothing -> error $ unlines [ ""- , "*** Data.SBV: Impossible happened: Query context required in a non-query mode."- , "Please report this as a bug!"- ]- Just qs -> let fqs = f qs- in fqs `seq` io $ writeIORef (rQueryState state) $ Just fqs---- | Generalization of 'Data.SBV.Control.inNewContext'-inNewContext :: (MonadIO m, MonadQuery m) => (State -> IO a) -> m a-inNewContext act = do st@State{rconstMap} <- queryState- (is, r) <- io $ withNewIncState st act- syncUpSolver rconstMap is- return r---- | Generic 'Queriable' instance for 'SymVal' values-instance (MonadIO m, SymVal a) => Queriable m (SBV a) a where- create = freshVar_- project = getValue- embed = return . literal---- | Generic 'Queriable' instance for things that are 'Fresh' and look like containers:-instance (MonadIO m, SymVal a, Foldable t, Traversable t, Fresh m (t (SBV a))) => Queriable m (t (SBV a)) (t a) where- create = fresh- project = mapM getValue- embed = return . fmap literal---- | Generalization of 'Data.SBV.Control.freshVar_'-freshVar_ :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => m (SBV a)-freshVar_ = inNewContext $ fmap SBV . svMkSymVar QueryVar k Nothing- where k = kindOf (Proxy @a)---- | Generalization of 'Data.SBV.Control.freshVar'-freshVar :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => String -> m (SBV a)-freshVar nm = inNewContext $ fmap SBV . svMkSymVar QueryVar k (Just nm)- where k = kindOf (Proxy @a)---- | Generalization of 'Data.SBV.Control.freshArray_'-freshArray_ :: (MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) => Maybe (SBV b) -> m (array a b)-freshArray_ = mkFreshArray Nothing---- | Generalization of 'Data.SBV.Control.freshArray'-freshArray :: (MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) => String -> Maybe (SBV b) -> m (array a b)-freshArray nm = mkFreshArray (Just nm)---- | Creating arrays, internal use only.-mkFreshArray :: (MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) => Maybe String -> Maybe (SBV b) -> m (array a b)-mkFreshArray mbNm mbVal = inNewContext $ newArrayInState mbNm mbVal---- | Generalization of 'Data.SBV.Control.queryDebug'-queryDebug :: (MonadIO m, MonadQuery m) => [String] -> m ()-queryDebug msgs = do QueryState{queryConfig} <- getQueryState- io $ debug queryConfig msgs---- | Generalization of 'Data.SBV.Control.ask'-ask :: (MonadIO m, MonadQuery m) => String -> m String-ask s = do QueryState{queryAsk, queryTimeOutValue} <- getQueryState-- case queryTimeOutValue of- Nothing -> queryDebug ["[SEND] " `alignPlain` s]- Just i -> queryDebug ["[SEND, TimeOut: " ++ showTimeoutValue i ++ "] " `alignPlain` s]- r <- io $ queryAsk queryTimeOutValue s- queryDebug ["[RECV] " `alignPlain` r]-- return r---- | Send a string to the solver, and return the response. Except, if the response--- is one of the "ignore" ones, keep querying.-askIgnoring :: (MonadIO m, MonadQuery m) => String -> [String] -> m String-askIgnoring s ignoreList = do-- QueryState{queryAsk, queryRetrieveResponse, queryTimeOutValue} <- getQueryState-- case queryTimeOutValue of- Nothing -> queryDebug ["[SEND] " `alignPlain` s]- Just i -> queryDebug ["[SEND, TimeOut: " ++ showTimeoutValue i ++ "] " `alignPlain` s]- r <- io $ queryAsk queryTimeOutValue s- queryDebug ["[RECV] " `alignPlain` r]-- let loop currentResponse- | currentResponse `notElem` ignoreList- = return currentResponse- | True- = do queryDebug ["[WARN] Previous response is explicitly ignored, beware!"]- newResponse <- io $ queryRetrieveResponse queryTimeOutValue- queryDebug ["[RECV] " `alignPlain` newResponse]- loop newResponse-- loop r---- | Generalization of 'Data.SBV.Control.send'-send :: (MonadIO m, MonadQuery m) => Bool -> String -> m ()-send requireSuccess s = do-- QueryState{queryAsk, querySend, queryConfig, queryTimeOutValue} <- getQueryState-- if requireSuccess && supportsCustomQueries (capabilities (solver queryConfig))- then do r <- io $ queryAsk queryTimeOutValue s-- case words r of- ["success"] -> queryDebug ["[GOOD] " `alignPlain` s]- _ -> do case queryTimeOutValue of- Nothing -> queryDebug ["[FAIL] " `alignPlain` s]- Just i -> queryDebug [("[FAIL, TimeOut: " ++ showTimeoutValue i ++ "] ") `alignPlain` s]--- let cmd = case words (dropWhile (\c -> isSpace c || isPunctuation c) s) of- (c:_) -> c- _ -> "Command"-- unexpected cmd s "success" Nothing r Nothing-- else do -- fire and forget. if you use this, you're on your own!- queryDebug ["[FIRE] " `alignPlain` s]- io $ querySend queryTimeOutValue s---- | Generalization of 'Data.SBV.Control.retrieveResponse'-retrieveResponse :: (MonadIO m, MonadQuery m) => String -> Maybe Int -> m [String]-retrieveResponse userTag mbTo = do- ts <- io (show <$> getZonedTime)-- let synchTag = show $ userTag ++ " (at: " ++ ts ++ ")"- cmd = "(echo " ++ synchTag ++ ")"-- queryDebug ["[SYNC] Attempting to synchronize with tag: " ++ synchTag]-- send False cmd-- QueryState{queryRetrieveResponse} <- getQueryState-- let loop sofar = do- s <- io $ queryRetrieveResponse mbTo-- -- strictly speaking SMTLib requires solvers to print quotes around- -- echo'ed strings, but they don't always do. Accommodate for that- -- here, though I wish we didn't have to.- if s == synchTag || show s == synchTag- then do queryDebug ["[SYNC] Synchronization achieved using tag: " ++ synchTag]- return $ reverse sofar- else do queryDebug ["[RECV] " `alignPlain` s]- loop (s : sofar)-- loop []---- | Generalization of 'Data.SBV.Control.getValue'-getValue :: (MonadIO m, MonadQuery m, SymVal a) => SBV a -> m a-getValue s = do sv <- inNewContext (`sbvToSV` s)- cv <- getValueCV Nothing sv- return $ fromCV cv---- | A class which allows for sexpr-conversion to functions-class (HasKind r, SatModel r) => SMTFunction fun a r | fun -> a r where- sexprToArg :: fun -> [SExpr] -> Maybe a- smtFunName :: (MonadIO m, SolverContext m, MonadSymbolic m) => fun -> m String- smtFunSaturate :: fun -> SBV r- smtFunType :: fun -> SBVType- smtFunDefault :: fun -> Maybe r- sexprToFun :: (MonadIO m, SolverContext m, MonadQuery m, MonadSymbolic m, SymVal r) => fun -> SExpr -> m (Maybe ([(a, r)], r))-- {-# MINIMAL sexprToArg, smtFunSaturate, smtFunType #-}-- -- Given the function, figure out a default "return value"- smtFunDefault _- | Just v <- defaultKindedValue (kindOf (Proxy @r)), Just (res, []) <- parseCVs [v]- = Just res- | True- = Nothing-- -- Given the function, determine what its name is and do some sanity checks- smtFunName f = do st@State{rUIMap} <- contextState- uiMap <- liftIO $ readIORef rUIMap- findName st uiMap- where findName st@State{spgm} uiMap = do- r <- liftIO $ sbvToSV st (smtFunSaturate f)- liftIO $ forceSVArg r- SBVPgm asgns <- liftIO $ readIORef spgm-- let cantFind = error $ unlines $ [ ""- , "*** Data.SBV.getFunction: Must be called on an uninterpreted function!"- , "***"- , "*** Expected to receive a function created by \"uninterpret\""- ]- ++ tag- ++ [ "***"- , "*** Make sure to call getFunction on uninterpreted functions only!"- , "*** If that is already the case, please report this as a bug."- ]- where tag = case map fst (Map.toList uiMap) of- [] -> [ "*** But, there are no matching uninterpreted functions in the context." ]- [x] -> [ "*** The only possible candidate is: " ++ x ]- cands -> [ "*** Candidates are:"- , "*** " ++ intercalate ", " cands- ]-- case S.findIndexR ((== r) . fst) asgns of- Nothing -> cantFind- Just i -> case asgns `S.index` i of- (sv, SBVApp (Uninterpreted nm) _) | r == sv -> return nm- _ -> cantFind-- sexprToFun f e = do nm <- smtFunName f- case parseSExprFunction e of- Just (Left nm') -> case (nm == nm', smtFunDefault f) of- (True, Just v) -> return $ Just ([], v)- _ -> bailOut nm- Just (Right v) -> return $ convert v- Nothing -> do mbPVS <- pointWiseExtract nm (smtFunType f)- return $ mbPVS >>= convert- where convert (vs, d) = (,) <$> mapM sexprPoint vs <*> sexprToVal d- sexprPoint (as, v) = (,) <$> sexprToArg f as <*> sexprToVal v-- bailOut nm = error $ unlines [ ""- , "*** Data.SBV.getFunction: Unable to extract an interpretation for function " ++ show nm- , "***"- , "*** Failed while trying to extract a pointwise interpretation."- , "***"- , "*** This could be a bug with SBV or the backend solver. Please report!"- ]---- | Registering an uninterpreted SMT function. This is typically not necessary as uses of the UI--- function itself will register it automatically. But there are cases where doing this explicitly can--- come in handy.-registerUISMTFunction :: (MonadIO m, SolverContext m, MonadSymbolic m) => SMTFunction fun a r => fun -> m ()-registerUISMTFunction f = do st <- contextState- nm <- smtFunName f- io $ newUninterpreted st nm (smtFunType f) Nothing---- | Pointwise function value extraction. If we get unlucky and can't parse z3's output (happens--- when we have all booleans and z3 decides to spit out an expression), just brute force our--- way out of it. Note that we only do this if we have a pure boolean type, as otherwise we'd blow--- up. And I think it'll only be necessary then, I haven't seen z3 try anything smarter in other scenarios.-pointWiseExtract :: forall m. (MonadIO m, MonadQuery m) => String -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))-pointWiseExtract nm typ- | isBoolFunc- = tryPointWise- | True- = error $ unlines [ ""- , "*** Data.SBV.getFunction: Unsupported: Extracting interpretation for function:"- , "***"- , "*** " ++ nm ++ " :: " ++ show typ- , "***"- , "*** At this time, the expression returned by the solver is too complicated for SBV!"- , "***"- , "*** You can ignore uninterpreted function models for sat models using the 'satTrackUFs' parameter:"- , "***"- , "*** satWith z3{satTrackUFs = False}"- , "*** allSatWith z3{satTrackUFs = False}"- , "***"- , "*** You can see the response from the solver by running with '{verbose = True}' option."- , "***"- , "*** NB. If this is a use case you'd like SBV to support, please get in touch!"- ]- where trueSExpr = ENum (1, Nothing)- falseSExpr = ENum (0, Nothing)-- isTrueSExpr (ENum (1, Nothing)) = True- isTrueSExpr (ENum (0, Nothing)) = False- isTrueSExpr s = error $ "Data.SBV.pointWiseExtract: Impossible happened: Received: " ++ show s-- (nArgs, isBoolFunc) = case typ of- SBVType ts -> (length ts - 1, all (== KBool) ts)-- getBVal :: [SExpr] -> m ([SExpr], SExpr)- getBVal args = do let shc c | isTrueSExpr c = "true"- | True = "false"-- as = unwords $ map shc args-- cmd = "(get-value ((" ++ nm ++ " " ++ as ++ ")))"-- bad = unexpected "get-value" cmd ("pointwise value of boolean function " ++ nm ++ " on " ++ show as) Nothing-- r <- ask cmd-- parse r bad $ \case EApp [EApp [_, e]] -> return (args, e)- _ -> bad r Nothing-- getBVals :: m [([SExpr], SExpr)]- getBVals = mapM getBVal $ replicateM nArgs [falseSExpr, trueSExpr]-- tryPointWise- | not isBoolFunc- = return Nothing- | nArgs < 1- = error $ "Data.SBV.pointWiseExtract: Impossible happened, nArgs < 1: " ++ show nArgs ++ " type: " ++ show typ- | True- = do vs <- getBVals- -- Pick the value that will give us the fewer entries- let (trues, falses) = partition (\(_, v) -> isTrueSExpr v) vs- return $ Just $ if length trues <= length falses- then (trues, falseSExpr)- else (falses, trueSExpr)---- | For saturation purposes, get a proper argument. The forall quantification--- is safe here since we only use in smtFunSaturate calls, which looks at the--- kind stored inside only.-mkArg :: forall a. Kind -> SBV a-mkArg k = case defaultKindedValue k of- Nothing -> error $ unlines [ ""- , "*** Data.SBV.smtFunSaturate: Impossible happened!"- , "*** Unable to create a valid parameter for kind: " ++ show k- , "*** Please report this as an SBV bug!"- ]- Just c -> SBV $ SVal k (Left c)---- | Functions of arity 1-instance ( SymVal a, HasKind a- , SatModel r, HasKind r- ) => SMTFunction (SBV a -> SBV r) a r- where- sexprToArg _ [a0] = sexprToVal a0- sexprToArg _ _ = Nothing-- smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @r)]-- smtFunSaturate f = f $ mkArg (kindOf (Proxy @a))---- | Functions of arity 2-instance ( SymVal a, HasKind a- , SymVal b, HasKind b- , SatModel r, HasKind r- ) => SMTFunction (SBV a -> SBV b -> SBV r) (a, b) r- where- sexprToArg _ [a0, a1] = (,) <$> sexprToVal a0 <*> sexprToVal a1- sexprToArg _ _ = Nothing-- smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @r)]-- smtFunSaturate f = f (mkArg (kindOf (Proxy @a)))- (mkArg (kindOf (Proxy @b)))---- | Functions of arity 3-instance ( SymVal a, HasKind a- , SymVal b, HasKind b- , SymVal c, HasKind c- , SatModel r, HasKind r- ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV r) (a, b, c) r- where- sexprToArg _ [a0, a1, a2] = (,,) <$> sexprToVal a0 <*> sexprToVal a1 <*> sexprToVal a2- sexprToArg _ _ = Nothing-- smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @r)]-- smtFunSaturate f = f (mkArg (kindOf (Proxy @a)))- (mkArg (kindOf (Proxy @b)))- (mkArg (kindOf (Proxy @c)))---- | Functions of arity 4-instance ( SymVal a, HasKind a- , SymVal b, HasKind b- , SymVal c, HasKind c- , SymVal d, HasKind d- , SatModel r, HasKind r- ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV r) (a, b, c, d) r- where- sexprToArg _ [a0, a1, a2, a3] = (,,,) <$> sexprToVal a0 <*> sexprToVal a1 <*> sexprToVal a2 <*> sexprToVal a3- sexprToArg _ _ = Nothing-- smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @r)]-- smtFunSaturate f = f (mkArg (kindOf (Proxy @a)))- (mkArg (kindOf (Proxy @b)))- (mkArg (kindOf (Proxy @c)))- (mkArg (kindOf (Proxy @d)))---- | Functions of arity 5-instance ( SymVal a, HasKind a- , SymVal b, HasKind b- , SymVal c, HasKind c- , SymVal d, HasKind d- , SymVal e, HasKind e- , SatModel r, HasKind r- ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r) (a, b, c, d, e) r- where- sexprToArg _ [a0, a1, a2, a3, a4] = (,,,,) <$> sexprToVal a0 <*> sexprToVal a1 <*> sexprToVal a2 <*> sexprToVal a3 <*> sexprToVal a4- sexprToArg _ _ = Nothing-- smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @r)]-- smtFunSaturate f = f (mkArg (kindOf (Proxy @a)))- (mkArg (kindOf (Proxy @b)))- (mkArg (kindOf (Proxy @c)))- (mkArg (kindOf (Proxy @d)))- (mkArg (kindOf (Proxy @e)))---- | Functions of arity 6-instance ( SymVal a, HasKind a- , SymVal b, HasKind b- , SymVal c, HasKind c- , SymVal d, HasKind d- , SymVal e, HasKind e- , SymVal f, HasKind f- , SatModel r, HasKind r- ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r) (a, b, c, d, e, f) r- where- sexprToArg _ [a0, a1, a2, a3, a4, a5] = (,,,,,) <$> sexprToVal a0 <*> sexprToVal a1 <*> sexprToVal a2 <*> sexprToVal a3 <*> sexprToVal a4 <*> sexprToVal a5- sexprToArg _ _ = Nothing-- smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @r)]-- smtFunSaturate f = f (mkArg (kindOf (Proxy @a)))- (mkArg (kindOf (Proxy @b)))- (mkArg (kindOf (Proxy @c)))- (mkArg (kindOf (Proxy @d)))- (mkArg (kindOf (Proxy @e)))- (mkArg (kindOf (Proxy @f)))---- | Functions of arity 7-instance ( SymVal a, HasKind a- , SymVal b, HasKind b- , SymVal c, HasKind c- , SymVal d, HasKind d- , SymVal e, HasKind e- , SymVal f, HasKind f- , SymVal g, HasKind g- , SatModel r, HasKind r- ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r) (a, b, c, d, e, f, g) r- where- sexprToArg _ [a0, a1, a2, a3, a4, a5, a6] = (,,,,,,) <$> sexprToVal a0 <*> sexprToVal a1 <*> sexprToVal a2 <*> sexprToVal a3 <*> sexprToVal a4 <*> sexprToVal a5 <*> sexprToVal a6- sexprToArg _ _ = Nothing-- smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @g), kindOf (Proxy @r)]-- smtFunSaturate f = f (mkArg (kindOf (Proxy @a)))- (mkArg (kindOf (Proxy @b)))- (mkArg (kindOf (Proxy @c)))- (mkArg (kindOf (Proxy @d)))- (mkArg (kindOf (Proxy @e)))- (mkArg (kindOf (Proxy @f)))- (mkArg (kindOf (Proxy @g)))---- | Functions of arity 8-instance ( SymVal a, HasKind a- , SymVal b, HasKind b- , SymVal c, HasKind c- , SymVal d, HasKind d- , SymVal e, HasKind e- , SymVal f, HasKind f- , SymVal g, HasKind g- , SymVal h, HasKind h- , SatModel r, HasKind r- ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV h -> SBV r) (a, b, c, d, e, f, g, h) r- where- sexprToArg _ [a0, a1, a2, a3, a4, a5, a6, a7] = (,,,,,,,) <$> sexprToVal a0 <*> sexprToVal a1 <*> sexprToVal a2 <*> sexprToVal a3 <*> sexprToVal a4 <*> sexprToVal a5 <*> sexprToVal a6 <*> sexprToVal a7- sexprToArg _ _ = Nothing-- smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @g), kindOf (Proxy @h), kindOf (Proxy @r)]-- smtFunSaturate f = f (mkArg (kindOf (Proxy @a)))- (mkArg (kindOf (Proxy @b)))- (mkArg (kindOf (Proxy @c)))- (mkArg (kindOf (Proxy @d)))- (mkArg (kindOf (Proxy @e)))- (mkArg (kindOf (Proxy @f)))- (mkArg (kindOf (Proxy @g)))- (mkArg (kindOf (Proxy @h)))---- | Generalization of 'Data.SBV.Control.getFunction'-getFunction :: (MonadIO m, MonadQuery m, SolverContext m, MonadSymbolic m, SymVal a, SymVal r, SMTFunction fun a r) => fun -> m ([(a, r)], r)-getFunction f = do nm <- smtFunName f-- let cmd = "(get-value (" ++ nm ++ "))"- bad = unexpected "getFunction" cmd "a function value" Nothing-- r <- ask cmd-- parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> do mbAssocs <- sexprToFun f e- case mbAssocs of- Just assocs -> return assocs- Nothing -> do mbPVS <- pointWiseExtract nm (smtFunType f)- case mbPVS >>= convert of- Just x -> return x- Nothing -> bad r Nothing- _ -> bad r Nothing- where convert (vs, d) = (,) <$> mapM sexprPoint vs <*> sexprToVal d- sexprPoint (as, v) = (,) <$> sexprToArg f as <*> sexprToVal v---- | Generalization of 'Data.SBV.Control.getUninterpretedValue'-getUninterpretedValue :: (MonadIO m, MonadQuery m, HasKind a) => SBV a -> m String-getUninterpretedValue s =- case kindOf s of- KUserSort _ Nothing -> do sv <- inNewContext (`sbvToSV` s)-- let nm = show sv- cmd = "(get-value (" ++ nm ++ "))"- bad = unexpected "getValue" cmd "a model value" Nothing-- r <- ask cmd-- parse r bad $ \case EApp [EApp [ECon o, ECon v]] | o == show sv -> return v- _ -> bad r Nothing-- k -> error $ unlines [""- , "*** SBV.getUninterpretedValue: Called on an 'interpreted' kind"- , "*** "- , "*** Kind: " ++ show k- , "*** Hint: Use 'getValue' to extract value for interpreted kinds."- , "*** "- , "*** Only truly uninterpreted sorts should be used with 'getUninterpretedValue.'"- ]---- | Get the value of a term, but in CV form. Used internally. The model-index, in particular is extremely Z3 specific!-getValueCVHelper :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV-getValueCVHelper mbi s- | s == trueSV- = return trueCV- | s == falseSV- = return falseCV- | True- = extractValue mbi (show s) (kindOf s)---- | "Make up" a CV for this type. Like zero, but smarter.-defaultKindedValue :: Kind -> Maybe CV-defaultKindedValue k = CV k <$> cvt k- where cvt :: Kind -> Maybe CVal- cvt KBool = Just $ CInteger 0- cvt KBounded{} = Just $ CInteger 0- cvt KUnbounded = Just $ CInteger 0- cvt KReal = Just $ CAlgReal 0- cvt (KUserSort _ ui) = uninterp ui- cvt KFloat = Just $ CFloat 0- cvt KDouble = Just $ CDouble 0- cvt KRational = Just $ CRational 0- cvt (KFP eb sb) = Just $ CFP (fpZero False eb sb)- cvt KChar = Just $ CChar '\NUL' -- why not?- cvt KString = Just $ CString ""- cvt (KList _) = Just $ CList []- cvt (KSet _) = Just $ CSet $ RegularSet Set.empty -- why not? Arguably, could be the universal set- cvt (KTuple ks) = CTuple <$> mapM cvt ks- cvt (KMaybe _) = Just $ CMaybe Nothing- cvt (KEither k1 _) = CEither . Left <$> cvt k1 -- why not?-- -- Tricky case of uninterpreted- uninterp (Just (c:_)) = Just $ CUserSort (Just 1, c)- uninterp (Just []) = Nothing -- I don't think this can actually happen, but just in case- uninterp Nothing = Nothing -- Out of luck, truly uninterpreted; we don't even know if it's inhabited.---- | Go from an SExpr directly to a value-sexprToVal :: forall a. SymVal a => SExpr -> Maybe a-sexprToVal e = fromCV <$> recoverKindedValue (kindOf (Proxy @a)) e---- | Recover a given solver-printed value with a possible interpretation-recoverKindedValue :: Kind -> SExpr -> Maybe CV-recoverKindedValue k e = case k of- KBool | ENum (i, _) <- e -> Just $ mkConstCV k i- | True -> Nothing-- KBounded{} | ENum (i, _) <- e -> Just $ mkConstCV k i- | True -> Nothing-- KUnbounded | ENum (i, _) <- e -> Just $ mkConstCV k i- | True -> Nothing-- KReal | ENum (i, _) <- e -> Just $ mkConstCV k i- | EReal i <- e -> Just $ CV KReal (CAlgReal i)- | True -> interpretInterval e-- KUserSort{} | ECon s <- e -> Just $ CV k $ CUserSort (getUIIndex k s, s)- | True -> Nothing-- KFloat | ENum (i, _) <- e -> Just $ mkConstCV k i- | EFloat i <- e -> Just $ CV KFloat (CFloat i)- | True -> Nothing-- KDouble | ENum (i, _) <- e -> Just $ mkConstCV k i- | EDouble i <- e -> Just $ CV KDouble (CDouble i)- | True -> Nothing-- KFP eb sb | ENum (i, _) <- e -> Just $ CV k $ CFP $ fpFromInteger eb sb i- | EFloat f <- e -> Just $ CV k $ CFP $ fpFromFloat eb sb f- | EDouble d <- e -> Just $ CV k $ CFP $ fpFromDouble eb sb d- | EFloatingPoint c <- e -> Just $ CV k $ CFP c- | True -> Nothing-- KChar | ECon s <- e -> Just $ CV KChar $ CChar $ interpretChar s- | True -> Nothing-- KString | ECon s <- e -> Just $ CV KString $ CString $ interpretString s- | True -> Nothing-- KRational -> Just $ CV k $ CRational $ interpretRational e-- KList ek -> Just $ CV k $ CList $ interpretList ek e-- KSet ek -> Just $ CV k $ CSet $ interpretSet ek e-- KTuple{} -> Just $ CV k $ CTuple $ interpretTuple e-- KMaybe{} -> Just $ CV k $ CMaybe $ interpretMaybe k e-- KEither{} -> Just $ CV k $ CEither $ interpretEither k e-- where getUIIndex (KUserSort _ (Just xs)) i = i `elemIndex` xs- getUIIndex _ _ = Nothing-- stringLike xs = length xs >= 2 && head xs == '"' && last xs == '"'-- -- Make sure strings are really strings- interpretString xs- | not (stringLike xs)- = error $ "Expected a string constant with quotes, received: <" ++ xs ++ ">"- | True- = qfsToString $ tail (init xs)-- interpretChar xs = case interpretString xs of- [c] -> c- _ -> error $ "Expected a singleton char constant, received: <" ++ xs ++ ">"-- interpretRational (EApp [ECon "SBV.Rational", v1, v2])- | Just (CV _ (CInteger n)) <- recoverKindedValue KUnbounded v1- , Just (CV _ (CInteger d)) <- recoverKindedValue KUnbounded v2- = n % d- interpretRational xs = error $ "Expected a rational constant, received: <" ++ show xs ++ ">"-- interpretList ek topExpr = walk topExpr- where walk (EApp [ECon "as", ECon "seq.empty", _]) = []- walk (EApp [ECon "seq.unit", v]) = case recoverKindedValue ek v of- Just w -> [cvVal w]- Nothing -> error $ "Cannot parse a sequence item of kind " ++ show ek ++ " from: " ++ show v ++ extra v- walk (EApp (ECon "seq.++" : rest)) = concatMap walk rest- walk cur = error $ "Expected a sequence constant, but received: " ++ show cur ++ extra cur-- extra cur | show cur == t = ""- | True = "\nWhile parsing: " ++ t- where t = show topExpr-- -- Essentially treat sets as functions, since we do allow for store associations- interpretSet ke setExpr- | isUniversal setExpr = ComplementSet Set.empty- | isEmpty setExpr = RegularSet Set.empty- | Just (Right assocs) <- mbAssocs = decode assocs- | True = tbd "Expected a set value, but couldn't decipher the solver output."-- where tbd w = error $ unlines [ ""- , "*** Data.SBV.interpretSet: Unable to process solver output."- , "***"- , "*** Kind : " ++ show (KSet ke)- , "*** Received: " ++ show setExpr- , "*** Reason : " ++ w- , "***"- , "*** This is either a bug or something SBV currently does not support."- , "*** Please report this as a feature request!"- ]--- isTrue (ENum (1, Nothing)) = True- isTrue (ENum (0, Nothing)) = False- isTrue bad = tbd $ "Non-boolean membership value seen: " ++ show bad-- isUniversal (EApp [EApp [ECon "as", ECon "const", EApp [ECon "Array", _, ECon "Bool"]], r]) = isTrue r- isUniversal _ = False-- isEmpty (EApp [EApp [ECon "as", ECon "const", EApp [ECon "Array", _, ECon "Bool"]], r]) = not $ isTrue r- isEmpty _ = False-- mbAssocs = parseSExprFunction setExpr-- decode (args, r) | isTrue r = ComplementSet $ Set.fromList [x | (x, False) <- concatMap (contents True) args] -- deletions from universal- | True = RegularSet $ Set.fromList [x | (x, True) <- concatMap (contents False) args] -- additions to empty-- contents cvt ([v], r) = let t = isTrue r in map (, t) (element cvt v)- contents _ bad = tbd $ "Multi-valued set member seen: " ++ show bad-- element cvt x = case (cvt, ke) of- (True, KChar) -> case recoverKindedValue KString x of- Just v -> case cvVal v of- CString [c] -> [CChar c]- CString _ -> []- _ -> tbd $ "Unexpected value for kind: " ++ show (x, ke)- Nothing -> tbd $ "Unexpected value for kind: " ++ show (x, ke)- _ -> case recoverKindedValue ke x of- Just v -> [cvVal v]- Nothing -> tbd $ "Unexpected value for kind: " ++ show (x, ke)-- interpretTuple te = walk (1 :: Int) (zipWith recoverKindedValue ks args) []- where (ks, n) = case k of- KTuple eks -> (eks, length eks)- _ -> error $ unlines [ "Impossible: Expected a tuple kind, but got: " ++ show k- , "While trying to parse: " ++ show te- ]-- -- | Convert a sexpr of n-tuple to constituent sexprs. Z3 and CVC4 differ here on how they- -- present tuples, so we accommodate both:- args = try te- where -- Z3 way- try (EApp (ECon f : as)) = case splitAt (T.length "mkSBVTuple") f of- ("mkSBVTuple", c) | all isDigit c && read c == n && length as == n -> as- _ -> bad- -- CVC4 way- try (EApp (EApp [ECon "as", ECon f, _] : as)) = try (EApp (ECon f : as))- try _ = bad- bad = error $ "Data.SBV.sexprToTuple: Impossible: Expected a constructor for " ++ show n ++ " tuple, but got: " ++ show te-- walk _ [] sofar = reverse sofar- walk i (Just el:es) sofar = walk (i+1) es (cvVal el : sofar)- walk i (Nothing:_) _ = error $ unlines [ "Couldn't parse a tuple element at position " ++ show i- , "Kind: " ++ show k- , "Expr: " ++ show te- ]-- -- SMaybe- interpretMaybe (KMaybe _) (ECon "nothing_SBVMaybe") = Nothing- interpretMaybe (KMaybe ek) (EApp [ECon "just_SBVMaybe", a]) = case recoverKindedValue ek a of- Just (CV _ v) -> Just v- Nothing -> error $ unlines [ "Couldn't parse a maybe just value"- , "Kind: " ++ show ek- , "Expr: " ++ show a- ]- -- CVC4 puts in full ascriptions, handle those:- interpretMaybe _ ( EApp [ECon "as", ECon "nothing_SBVMaybe", _]) = Nothing- interpretMaybe mk (EApp [EApp [ECon "as", ECon "just_SBVMaybe", _], a]) = interpretMaybe mk (EApp [ECon "just_SBVMaybe", a])-- interpretMaybe _ other = error $ "Expected an SMaybe sexpr, but received: " ++ show (k, other)-- -- SEither- interpretEither (KEither k1 _) (EApp [ECon "left_SBVEither", a]) = case recoverKindedValue k1 a of- Just (CV _ v) -> Left v- Nothing -> error $ unlines [ "Couldn't parse an either value on the left"- , "Kind: " ++ show k1- , "Expr: " ++ show a- ]- interpretEither (KEither _ k2) (EApp [ECon "right_SBVEither", b]) = case recoverKindedValue k2 b of- Just (CV _ v) -> Right v- Nothing -> error $ unlines [ "Couldn't parse an either value on the right"- , "Kind: " ++ show k2- , "Expr: " ++ show b- ]-- -- CVC4 puts full ascriptions:- interpretEither ek (EApp [EApp [ECon "as", ECon "left_SBVEither", _], a]) = interpretEither ek (EApp [ECon "left_SBVEither", a])- interpretEither ek (EApp [EApp [ECon "as", ECon "right_SBVEither", _], b]) = interpretEither ek (EApp [ECon "right_SBVEither", b])-- interpretEither _ other = error $ "Expected an SEither sexpr, but received: " ++ show (k, other)-- -- Intervals, for dReal- interpretInterval expr = case expr of- EApp [ECon "interval", lo, hi] -> do vlo <- getBorder lo- vhi <- getBorder hi- pure $ CV KReal (CAlgReal (AlgInterval vlo vhi))- _ -> Nothing- where getBorder (EApp [ECon "open", v]) = recoverKindedValue KReal v >>= border OpenPoint- getBorder (EApp [ECon "closed", v]) = recoverKindedValue KReal v >>= border ClosedPoint- getBorder _ = Nothing-- border b (CV KReal (CAlgReal (AlgRational True v))) = pure $ b v- border _ other = error $ "Data.SBV.interpretInterval.border: Expected a real-valued sexp, but received: " ++ show other----- | Generalization of 'Data.SBV.Control.getValueCV'-getValueCV :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV-getValueCV mbi s- | kindOf s /= KReal- = getValueCVHelper mbi s- | True- = do cfg <- getConfig- if not (supportsApproxReals (capabilities (solver cfg)))- then getValueCVHelper mbi s- else do send True "(set-option :pp.decimal false)"- rep1 <- getValueCVHelper mbi s- send True "(set-option :pp.decimal true)"- send True $ "(set-option :pp.decimal_precision " ++ show (printRealPrec cfg) ++ ")"- rep2 <- getValueCVHelper mbi s-- let bad = unexpected "getValueCV" "get-value" ("a real-valued binding for " ++ show s) Nothing (show (rep1, rep2)) Nothing-- case (rep1, rep2) of- (CV KReal (CAlgReal a), CV KReal (CAlgReal b)) -> return $ CV KReal (CAlgReal (mergeAlgReals ("Cannot merge real-values for " ++ show s) a b))- _ -> bad---- | Retrieve value from the solver-extractValue :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> String -> Kind -> m CV-extractValue mbi nm k = do- let modelIndex = case mbi of- Nothing -> ""- Just i -> " :model_index " ++ show i-- cmd = "(get-value (" ++ nm ++ ")" ++ modelIndex ++ ")"-- bad = unexpected "getModel" cmd ("a value binding for kind: " ++ show k) Nothing-- r <- ask cmd-- let recover val = case recoverKindedValue k val of- Just cv -> return cv- Nothing -> bad r Nothing-- parse r bad $ \case EApp [EApp [ECon v, val]] | v == nm -> recover val- _ -> bad r Nothing---- | Generalization of 'Data.SBV.Control.getUICVal'-getUICVal :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> (String, SBVType) -> m CV-getUICVal mbi (nm, t) = case t of- SBVType [k] -> extractValue mbi nm k- _ -> error $ "SBV.getUICVal: Expected to be called on an uninterpeted value of a base type, received something else: " ++ show (nm, t)---- | Generalization of 'Data.SBV.Control.getUIFunCVAssoc'-getUIFunCVAssoc :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> (String, SBVType) -> m ([([CV], CV)], CV)-getUIFunCVAssoc mbi (nm, typ) = do- let modelIndex = case mbi of- Nothing -> ""- Just i -> " :model_index " ++ show i-- cmd = "(get-value (" ++ nm ++ ")" ++ modelIndex ++ ")"-- bad = unexpected "get-value" cmd "a function value" Nothing-- r <- ask cmd-- let (ats, rt) = case typ of- SBVType as | length as > 1 -> (init as, last as)- _ -> error $ "Data.SBV.getUIFunCVAssoc: Expected a function type, got: " ++ show typ-- let convert (vs, d) = (,) <$> mapM toPoint vs <*> toRes d- toPoint (as, v)- | length as == length ats = (,) <$> zipWithM recoverKindedValue ats as <*> toRes v- | True = error $ "Data.SBV.getUIFunCVAssoc: Mismatching type/value arity, got: " ++ show (as, ats)-- toRes :: SExpr -> Maybe CV- toRes = recoverKindedValue rt-- -- In case we end up in the pointwise scenario, boolify the result- -- as that's the only type we support here.- tryPointWise bailOut = do mbSExprs <- pointWiseExtract nm typ- case mbSExprs of- Nothing -> bailOut- Just sExprs -> maybe bailOut return (convert sExprs)-- parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> let bailOut = bad r Nothing- in case parseSExprFunction e of- Just (Right assocs) | Just res <- convert assocs -> return res- | True -> tryPointWise bailOut-- Just (Left nm') | nm == nm', Just res <- defaultKindedValue rt -> return ([], res)- | True -> bad r Nothing-- Nothing -> tryPointWise bailOut-- _ -> bad r Nothing---- | Generalization of 'Data.SBV.Control.checkSat'-checkSat :: (MonadIO m, MonadQuery m) => m CheckSatResult-checkSat = do cfg <- getConfig- checkSatUsing $ satCmd cfg---- | Generalization of 'Data.SBV.Control.checkSatUsing'-checkSatUsing :: (MonadIO m, MonadQuery m) => String -> m CheckSatResult-checkSatUsing cmd = do let bad = unexpected "checkSat" cmd "one of sat/unsat/unknown" Nothing-- -- Sigh.. Ignore some of the pesky warnings. We only do it as an exception here.- ignoreList = ["WARNING: optimization with quantified constraints is not supported"]-- r <- askIgnoring cmd ignoreList-- -- query for the precision if supported- let getPrecision = do cfg <- getConfig- case supportsDeltaSat (capabilities (solver cfg)) of- Nothing -> pure Nothing- Just o -> Just <$> ask o-- parse r bad $ \case ECon "sat" -> return Sat- ECon "unsat" -> return Unsat- ECon "unknown" -> return Unk- ECon "delta-sat" -> DSat <$> getPrecision- _ -> bad r Nothing---- | What are the top level inputs? Trackers are returned as top level existentials-getQuantifiedInputs :: (MonadIO m, MonadQuery m) => m UserInputs-getQuantifiedInputs = do State{rinps} <- queryState- (rQinps, rTrackers) <- liftIO $ getInputs <$> readIORef rinps-- let trackers = (EX,) <$> rTrackers- -- separate the existential prefix, which will go first- (preQs, postQs) = S.spanl (\(q, _) -> q == EX) rQinps-- return $ preQs <> trackers <> postQs---- | Get observables, i.e., those explicitly labeled by the user with a call to 'Data.SBV.observe'.-getObservables :: (MonadIO m, MonadQuery m) => m [(Name, CV)]-getObservables = do State{rObservables} <- queryState-- rObs <- liftIO $ readIORef rObservables-- -- This intentionally reverses the result; since 'rObs' stores in reversed order- let walk [] !sofar = return sofar- walk ((n, f, s):os) !sofar = do cv <- getValueCV Nothing s- if f cv- then walk os ((n, cv) : sofar)- else walk os sofar-- walk (F.toList rObs) []---- | Get UIs, both constants and functions. This call returns both the before and after query ones.--- Generalization of 'Data.SBV.Control.getUIs'. Note that if we have an defined axiom, then it--- is not really a UI, so we drop those.-getUIs :: forall m. (MonadIO m, MonadQuery m) => m [(String, SBVType)]-getUIs = do State{rUIMap, raxioms, rIncState} <- queryState- -- NB. no need to worry about new-defines, because we don't allow definitions once query mode starts- defines <- do allAxs <- io $ readIORef raxioms- pure [nm | (True, nm, _) <- allAxs]-- prior <- io $ readIORef rUIMap- new <- io $ readIORef rIncState >>= readIORef . rNewUIs- return $ nub $ sort [p | p@(n, _) <- Map.toList prior ++ Map.toList new, n `notElem` defines]---- | Return all satisfying models.-getAllSatResult :: forall m. (MonadIO m, MonadQuery m, SolverContext m) => m AllSatResult-getAllSatResult = do queryDebug ["*** Checking Satisfiability, all solutions.."]-- cfg <- getConfig- unless (supportsCustomQueries (capabilities (solver cfg))) $- error $ unlines [ ""- , "*** Data.SBV: Backend solver " ++ show (name (solver cfg)) ++ " does not support custom queries."- , "***"- , "*** Custom query support is needed for allSat functionality."- , "*** Please use a solver that supports this feature."- ]-- topState@State{rUsedKinds} <- queryState-- ki <- liftIO $ readIORef rUsedKinds- qinps <- getQuantifiedInputs-- allUninterpreteds <- getUIs-- -- Functions have at least two kinds in their type and all components must be "interpreted"- let allUiFuns = [u | satTrackUFs cfg -- config says consider UIFs- , u@(nm, SBVType as) <- allUninterpreteds, length as > 1 -- get the function ones- , not (isNonModelVar cfg nm) -- make sure they aren't explicitly ignored- ]-- allUiRegs = [u | u@(nm, SBVType as) <- allUninterpreteds, length as == 1 -- non-function ones- , not (isNonModelVar cfg nm) -- make sure not ignored- ]-- -- We can only "allSat" if all component types themselves are interpreted. (Otherwise- -- there is no way to reflect back the values to the solver.)- collectAcceptable [] sofar = return sofar- collectAcceptable ((nm, t@(SBVType ats)):rest) sofar- | not (any hasUninterpretedSorts ats)- = collectAcceptable rest (nm : sofar)- | True- = do queryDebug [ "*** SBV.allSat: Uninterpreted function: " ++ nm ++ " :: " ++ show t- , "*** Will *not* be used in allSat considerations since its type"- , "*** has uninterpreted sorts present."- ]- collectAcceptable rest sofar-- uiFuns <- reverse <$> collectAcceptable allUiFuns []- _ <- collectAcceptable allUiRegs [] -- only done to get the queryDebug output. Actual result not needed/used-- -- If there are uninterpreted functions, arrange so that z3's pretty-printer flattens things out- -- as cex's tend to get larger- unless (null uiFuns) $- let solverCaps = capabilities (solver cfg)- in case supportsFlattenedModels solverCaps of- Nothing -> return ()- Just cmds -> mapM_ (send True) cmds-- let usorts = [s | us@(KUserSort s _) <- Set.toAscList ki, isFree us]-- unless (null usorts) $ queryDebug [ "*** SBV.allSat: Uninterpreted sorts present: " ++ unwords usorts- , "*** SBV will use equivalence classes to generate all-satisfying instances."- ]-- let allModelInputs = prefixExistentials qinps- -- Add on observables only if we're not in a quantified context:- hasQuantifiers = S.length allModelInputs /= S.length qinps -- i.e., we dropped something- grabObservables = not hasQuantifiers-- vars :: S.Seq (SVal, NamedSymVar)- vars = let mkSVal :: NamedSymVar -> (SVal, NamedSymVar)- mkSVal nm@(getSV -> sv) = (SVal (kindOf sv) (Right (cache (const (return sv)))), nm)-- ignored n = isNonModelVar cfg (T.unpack n) || "__internal_sbv" `T.isPrefixOf` n-- in fmap (mkSVal . namedSymVar)- . S.filter (not . ignored . getUserName . namedSymVar)- $ allModelInputs-- -- If we have any universals, then the solutions are unique upto prefix existentials.- w = ALL `elem` F.toList (quantifier <$> qinps)--- -- We can go fast using the disjoint model trick if things are simple enough:- -- - No quantifiers- -- - No uninterpreted functions (uninterpreted values are OK)- -- - No uninterpreted sorts- --- -- Why can't we support the above?- -- - Uninterpreted functions: There is no (standard) way to define a function as a literal in SMTLib.- -- Some solvers support lambda, but this isn't common/reliable yet.- -- - Uninterpreted sort: There's no way to access the value the solver assigns to an uninterpreted sort.- --- -- So, if these two things are present, we go the "slow" route, by repeatedly rejecting the- -- previous model and asking for a new one. If they don't exist (which is the common case anyhow)- -- we use an idea due to z3 folks <http://theory.stanford.edu/%7Enikolaj/programmingz3.html#sec-blocking-evaluations>- -- which splits the search space into disjoint models and can produce results much more quickly.- let isSimple = null allUiFuns && null usorts && not hasQuantifiers-- start = AllSatResult { allSatMaxModelCountReached = False- , allSatHasPrefixExistentials = w- , allSatSolverReturnedUnknown = False- , allSatSolverReturnedDSat = False- , allSatResults = []- }-- if isSimple- then do let mkVar :: (String, SBVType) -> IO (SVal, NamedSymVar)- mkVar (nm, SBVType [k]) = do sv <- newExpr topState k (SBVApp (Uninterpreted nm) [])- let sval = SVal k $ Right $ cache $ \_ -> pure sv- nsv = NamedSymVar sv (T.pack nm)- pure (sval, nsv)- mkVar nmt = error $ "Data.SBV: Impossible happened; allSat.mkVar. Unexpected: " ++ show nmt- uiVars <- io $ S.fromList <$> mapM mkVar allUiRegs- fastAllSat grabObservables qinps (uiVars S.>< vars) cfg start- else loop grabObservables topState (allUiFuns, uiFuns) allUiRegs qinps vars cfg start-- where isFree (KUserSort _ Nothing) = True- isFree _ = False-- finalize cnt cfg sofar extra- = when (allSatPrintAlong cfg && not (null (allSatResults sofar))) $ do- let msg 0 = "No solutions found."- msg 1 = "This is the only solution."- msg n = "Found " ++ show n ++ " different solutions."- io . putStrLn $ msg (cnt - 1)- case extra of- Nothing -> pure ()- Just m -> io $ putStrLn m-- fastAllSat :: Bool -> S.Seq (Quantifier, NamedSymVar) -> S.Seq (SVal, NamedSymVar) -> SMTConfig -> AllSatResult -> m AllSatResult- fastAllSat grabObservables qinps vars cfg start = do- result <- io $ newIORef (0, start, False, Nothing)- go result vars- (found, sofar, _, extra) <- io $ readIORef result- finalize (found+1) cfg sofar extra- pure sofar-- where haveEnough have = case allSatMaxModelCount cfg of- Just maxModels -> have >= maxModels- _ -> False-- go :: IORef (Int, AllSatResult, Bool, Maybe String) -> S.Seq (SVal, NamedSymVar) -> m ()- go finalResult = walk True- where shouldContinue = do (have, _, exitLoop, _) <- io $ readIORef finalResult- pure $ not (exitLoop || haveEnough have)-- walk :: Bool -> S.Seq (SVal, NamedSymVar) -> m ()- walk firstRun terms- | not firstRun && S.null terms- = pure ()- | True- = do mbCont <- do (have, sofar, exitLoop, _) <- io $ readIORef finalResult- if exitLoop- then pure Nothing- else case allSatMaxModelCount cfg of- Just maxModels- | have >= maxModels -> do unless (allSatMaxModelCountReached sofar) $ do- queryDebug ["*** Maximum model count request of " ++ show maxModels ++ " reached, stopping the search."]- when (allSatPrintAlong cfg) $ io $ putStrLn "Search stopped since model count request was reached."- io $ modifyIORef' finalResult $ \(h, s, _, m) -> (h, s{ allSatMaxModelCountReached = True }, True, m)- pure Nothing- _ -> pure $ Just $ have+1-- case mbCont of- Nothing -> pure ()- Just cnt -> do- queryDebug ["Fast allSat, Looking for solution " ++ show cnt]-- cs <- checkSat-- case cs of- Unsat -> pure ()-- Unk -> do let m = "Solver returned unknown, terminating query."- queryDebug ["*** " ++ m]- io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedUnknown = True}, True, Just ("[" ++ m ++ "]"))-- DSat _ -> do let m = "Solver returned delta-sat, terminating query."- queryDebug ["*** " ++ m]- io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedDSat = True}, True, Just ("[" ++ m ++ "]"))-- Sat -> do assocs <- mapM (\(sval, NamedSymVar sv n) -> do !cv <- getValueCV Nothing sv- return (sv, (n, (sval, cv)))) vars-- bindings <- let grab i@(ALL, _) = return (i, Nothing)- grab i@(EX, getSV -> sv) = case lookupInput fst sv assocs of- Just (_, (_, (_, cv))) -> return (i, Just cv)- Nothing -> do !cv <- getValueCV Nothing sv- return (i, Just cv)- in if validationRequested cfg- then Just <$> mapM grab qinps- else return Nothing-- -- Add on observables if we're asked to do so:- obsvs <- if grabObservables- then getObservables- else do queryDebug ["*** In a quantified context, observables will not be printed."]- return mempty-- let lassocs = F.toList assocs- model = SMTModel { modelObjectives = []- , modelBindings = F.toList <$> bindings- , modelAssocs = (first T.unpack <$> sortOn fst obsvs)- <> [(T.unpack n, cv) | (_, (n, (_, cv))) <- lassocs]- , modelUIFuns = []- }- currentResult = Satisfiable cfg model-- io $ modifyIORef' finalResult $ \(h, s, e, m) -> let h' = h+1 in h' `seq` (h', s{allSatResults = currentResult : allSatResults s}, e, m)-- when (allSatPrintAlong cfg) $ do- io $ putStrLn $ "Solution #" ++ show cnt ++ ":"- io $ putStrLn $ showModel cfg model-- let findVal :: (SVal, NamedSymVar) -> (SVal, CV)- findVal (_, NamedSymVar sv nm) = case F.toList (S.filter (\(sv', _) -> sv == sv') assocs) of- [(_, (_, scv))] -> scv- _ -> error $ "Data.SBV: Cannot uniquely determine " ++ show nm ++ " in " ++ show assocs-- cstr :: Bool -> (SVal, CV) -> m ()- cstr shouldReject (sv, cv) = constrain $ SBV $ mkEq (kindOf sv) sv (SVal (kindOf sv) (Left cv))- where mkEq :: Kind -> SVal -> SVal -> SVal- mkEq k a b- | isDouble k || isFloat k || isFP k- = if shouldReject- then svNot (a `fpEq` b)- else a `fpEq` b- | True- = if shouldReject- then a `svNotEqual` b- else a `svEqual` b-- fpEq a b = SVal KBool $ Right $ cache r- where r st = do sva <- svToSV st a- svb <- svToSV st b- newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sva, svb])-- reject, accept :: (SVal, NamedSymVar) -> m ()- reject = cstr True . findVal- accept = cstr False . findVal-- scope :: (SVal, NamedSymVar) -> S.Seq (SVal, NamedSymVar) -> m () -> m ()- scope cur pres c = do- send True "(push 1)"- reject cur- mapM_ accept pres- r <- c- send True "(pop 1)"- pure r-- forM_ [0 .. length terms - 1] $ \i -> do- sc <- shouldContinue- when sc $ do case S.splitAt i terms of- (pre, rest@(cur S.:<| _)) -> scope cur pre $ walk False rest- _ -> error "Data.SBV.allSat: Impossible happened, ran out of terms!"-- -- All sat loop. This is slower, as it implements the reject-the-previous model and loop around logic. But- -- it can handle uninterpreted sorts; so we keep it here as a fall-back.- loop grabObservables topState (allUiFuns, uiFunsToReject) allUiRegs qinps vars cfg = go (1::Int)- where go :: Int -> AllSatResult -> m AllSatResult- go !cnt !sofar- | Just maxModels <- allSatMaxModelCount cfg, cnt > maxModels- = do queryDebug ["*** Maximum model count request of " ++ show maxModels ++ " reached, stopping the search."]- when (allSatPrintAlong cfg) $ io $ putStrLn "Search stopped since model count request was reached."- return $! sofar { allSatMaxModelCountReached = True }- | True- = do queryDebug ["Looking for solution " ++ show cnt]-- cs <- checkSat-- let endMsg = finalize cnt cfg sofar-- case cs of- Unsat -> do endMsg Nothing- return sofar-- Unk -> do let m = "Solver returned unknown, terminating query."- queryDebug ["*** " ++ m]- endMsg $ Just $ "[" ++ m ++ "]"- return sofar{ allSatSolverReturnedUnknown = True }-- DSat _ -> do let m = "Solver returned delta-sat, terminating query."- queryDebug ["*** " ++ m]- endMsg $ Just $ "[" ++ m ++ "]"- return sofar{ allSatSolverReturnedDSat = True }-- Sat -> do assocs <- mapM (\(sval, NamedSymVar sv n) -> do !cv <- getValueCV Nothing sv- return (sv, (n, (sval, cv)))) vars-- let getUIFun ui@(nm, t) = do cvs <- getUIFunCVAssoc Nothing ui- return (nm, (t, cvs))- uiFunVals <- mapM getUIFun allUiFuns-- uiRegVals <- mapM (\ui@(nm, _) -> (nm,) <$> getUICVal Nothing ui) allUiRegs-- -- Add on observables if we're asked to do so:- obsvs <- if grabObservables- then getObservables- else do queryDebug ["*** In a quantified context, observables will not be printed."]- return mempty-- bindings <- let grab i@(ALL, _) = return (i, Nothing)- grab i@(EX, getSV -> sv) = case lookupInput fst sv assocs of- Just (_, (_, (_, cv))) -> return (i, Just cv)- Nothing -> do !cv <- getValueCV Nothing sv- return (i, Just cv)- in if validationRequested cfg- then Just <$> mapM grab qinps- else return Nothing-- let model = SMTModel { modelObjectives = []- , modelBindings = F.toList <$> bindings- , modelAssocs = uiRegVals- <> (first T.unpack <$> sortOn fst obsvs)- <> [(T.unpack n, cv) | (_, (n, (_, cv))) <- F.toList assocs]- , modelUIFuns = uiFunVals- }- m = Satisfiable cfg model-- (interpreteds, uninterpreteds) = S.partition (not . isFree . kindOf . fst) (fmap (snd . snd) assocs)-- interpretedRegUis = filter (not . isFree . kindOf . snd) uiRegVals-- interpretedRegUiSVs = [(cvt n (kindOf cv), cv) | (n, cv) <- interpretedRegUis]- where cvt :: String -> Kind -> SVal- cvt nm k = SVal k $ Right $ cache r- where r st = newExpr st k (SBVApp (Uninterpreted nm) [])-- -- For each interpreted variable, figure out the model equivalence- -- NB. When the kind is floating, we *have* to be careful, since +/- zero, and NaN's- -- and equality don't get along!- interpretedEqs :: [SVal]- interpretedEqs = [mkNotEq (kindOf sv) sv (SVal (kindOf sv) (Left cv)) | (sv, cv) <- interpretedRegUiSVs <> F.toList interpreteds]- where mkNotEq k a b- | isDouble k || isFloat k || isFP k- = svNot (a `fpEq` b)- | True- = a `svNotEqual` b-- fpEq a b = SVal KBool $ Right $ cache r- where r st = do sva <- svToSV st a- svb <- svToSV st b- newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sva, svb])-- -- For each uninterpreted constant, use equivalence class- uninterpretedEqs :: [SVal]- uninterpretedEqs = concatMap pwDistinct -- Assert that they are pairwise distinct- . filter (\l -> length l > 1) -- Only need this class if it has at least two members- . map (map fst) -- throw away values, we only need svals- . groupBy ((==) `on` snd) -- make sure they belong to the same sort and have the same value- . sortOn snd -- sort them according to their CV (i.e., sort/value)- $ F.toList uninterpreteds- where pwDistinct :: [SVal] -> [SVal]- pwDistinct ss = [x `svNotEqual` y | (x:ys) <- tails ss, y <- ys]-- -- For each uninterpreted function, create a disqualifying equation- -- We do this rather brute-force, since we need to create a new function- -- and do an existential assertion.- uninterpretedReject :: Maybe [String]- uninterpretedFuns :: [String]- (uninterpretedReject, uninterpretedFuns) = (uiReject, concat defs)- where uiReject = case rejects of- [] -> Nothing- xs -> Just xs-- (rejects, defs) = unzip [mkNotEq ui | ui@(nm, _) <- uiFunVals, nm `elem` uiFunsToReject]-- -- Otherwise, we have things to refute, go for it:- mkNotEq (nm, (SBVType ts, vs)) = (reject, def ++ dif)- where nm' = nm ++ "_model" ++ show cnt-- reject = nm' ++ "_reject"-- -- rounding mode doesn't matter here, just pick one- scv = cvToSMTLib RoundNearestTiesToEven-- (ats, rt) = (init ts, last ts)-- args = unwords ["(x!" ++ show i ++ " " ++ smtType t ++ ")" | (t, i) <- zip ats [(0::Int)..]]- res = smtType rt-- params = ["x!" ++ show i | (_, i) <- zip ats [(0::Int)..]]-- uparams = unwords params-- chain (vals, fallThru) = walk vals- where walk [] = [" " ++ scv fallThru ++ replicate (length vals) ')']- walk ((as, r) : rest) = (" (ite " ++ cond as ++ " " ++ scv r ++ "") : walk rest-- cond as = "(and " ++ unwords (zipWith eq params as) ++ ")"- eq p a = "(= " ++ p ++ " " ++ scv a ++ ")"-- def = ("(define-fun " ++ nm' ++ " (" ++ args ++ ") " ++ res)- : chain vs- ++ [")"]-- pad = replicate (1 + length nm' - length nm) ' '-- dif = [ "(define-fun " ++ reject ++ " () Bool"- , " (exists (" ++ args ++ ")"- , " (distinct (" ++ nm ++ pad ++ uparams ++ ")"- , " (" ++ nm' ++ " " ++ uparams ++ "))))"- ]-- eqs = interpretedEqs ++ uninterpretedEqs-- disallow = case eqs of- [] -> Nothing- _ -> Just $ SBV $ foldr1 svOr eqs-- when (allSatPrintAlong cfg) $ do- io $ putStrLn $ "Solution #" ++ show cnt ++ ":"- io $ putStrLn $ showModel cfg model-- let resultsSoFar = sofar { allSatResults = m : allSatResults sofar }-- -- This is clunky, but let's not generate a rejector unless we really need it- needMoreIterations- | Just maxModels <- allSatMaxModelCount cfg, (cnt+1) > maxModels = False- | True = True-- -- Send function disequalities, if any:- if not needMoreIterations- then go (cnt+1) resultsSoFar- else do let uiFunRejector = "uiFunRejector_model_" ++ show cnt- header = "define-fun " ++ uiFunRejector ++ " () Bool "-- defineRejector [] = return ()- defineRejector [x] = send True $ "(" ++ header ++ x ++ ")"- defineRejector (x:xs) = mapM_ (send True) $ mergeSExpr $ ("(" ++ header)- : (" (or " ++ x)- : [" " ++ e | e <- xs]- ++ [" ))"]- rejectFuncs <- case uninterpretedReject of- Nothing -> return Nothing- Just fs -> do mapM_ (send True) $ mergeSExpr uninterpretedFuns- defineRejector fs- return $ Just uiFunRejector-- -- send the disallow clause and the uninterpreted rejector:- case (disallow, rejectFuncs) of- (Nothing, Nothing) -> pure resultsSoFar- (Just d, Nothing) -> do constrain d- go (cnt+1) resultsSoFar- (Nothing, Just f) -> do send True $ "(assert " ++ f ++ ")"- go (cnt+1) resultsSoFar- (Just d, Just f) -> -- This is where it gets ugly. We have an SBV and a string and we need to "or" them.- -- But we need a way to force 'd' to be produced. So, go ahead and force it:- do constrain $ d .=> d -- NB: Redundant, but it makes sure the corresponding constraint gets shown- svd <- io $ svToSV topState (unSBV d)- send True $ "(assert (or " ++ f ++ " " ++ show svd ++ "))"- go (cnt+1) resultsSoFar---- | Generalization of 'Data.SBV.Control.getUnsatAssumptions'-getUnsatAssumptions :: (MonadIO m, MonadQuery m) => [String] -> [(String, a)] -> m [a]-getUnsatAssumptions originals proxyMap = do- let cmd = "(get-unsat-assumptions)"-- bad = unexpected "getUnsatAssumptions" cmd "a list of unsatisfiable assumptions"- $ Just [ "Make sure you use:"- , ""- , " setOption $ ProduceUnsatAssumptions True"- , ""- , "to make sure the solver is ready for producing unsat assumptions,"- , "and that there is a model by first issuing a 'checkSat' call."- ]-- fromECon (ECon s) = Just s- fromECon _ = Nothing-- r <- ask cmd-- -- If unsat-cores are enabled, z3 might end-up printing an assumption that wasn't- -- in the original list of assumptions for `check-sat-assuming`. So, we walk over- -- and ignore those that weren't in the original list, and put a warning for those- -- we couldn't find.- let walk [] sofar = return $ reverse sofar- walk (a:as) sofar = case a `lookup` proxyMap of- Just v -> walk as (v:sofar)- Nothing -> do queryDebug [ "*** In call to 'getUnsatAssumptions'"- , "***"- , "*** Unexpected assumption named: " ++ show a- , "*** Was expecting one of : " ++ show originals- , "***"- , "*** This can happen if unsat-cores are also enabled. Ignoring."- ]- walk as sofar-- parse r bad $ \case- EApp es | Just xs <- mapM fromECon es -> walk xs []- _ -> bad r Nothing---- | Generalization of 'Data.SBV.Control.timeout'-timeout :: (MonadIO m, MonadQuery m) => Int -> m a -> m a-timeout n q = do modifyQueryState (\qs -> qs {queryTimeOutValue = Just n})- r <- q- modifyQueryState (\qs -> qs {queryTimeOutValue = Nothing})- return r---- | Bail out if a parse goes bad-parse :: String -> (String -> Maybe [String] -> a) -> (SExpr -> a) -> a-parse r fCont sCont = case parseSExpr r of- Left e -> fCont r (Just [e])- Right res -> sCont res---- | Generalization of 'Data.SBV.Control.unexpected'-unexpected :: (MonadIO m, MonadQuery m) => String -> String -> String -> Maybe [String] -> String -> Maybe [String] -> m a-unexpected ctx sent expected mbHint received mbReason = do- -- empty the response channel first- extras <- retrieveResponse "terminating upon unexpected response" (Just 5000000)-- cfg <- getConfig-- let exc = SBVException { sbvExceptionDescription = "Unexpected response from the solver, context: " ++ ctx- , sbvExceptionSent = Just sent- , sbvExceptionExpected = Just expected- , sbvExceptionReceived = Just received- , sbvExceptionStdOut = Just $ unlines extras- , sbvExceptionStdErr = Nothing- , sbvExceptionExitCode = Nothing- , sbvExceptionConfig = cfg- , sbvExceptionReason = mbReason- , sbvExceptionHint = mbHint- }-- io $ C.throwIO exc---- | Convert a query result to an SMT Problem-runProofOn :: SBVRunMode -> QueryContext -> [String] -> Result -> SMTProblem-runProofOn rm context comments res@(Result ki _qcInfo _observables _codeSegs is consts tbls arrs uis axs pgm cstrs _assertions outputs) =- let (config, isSat, isSafe, isSetup) = case rm of- SMTMode _ stage s c -> (c, s, isSafetyCheckingIStage stage, isSetupIStage stage)- _ -> error $ "runProofOn: Unexpected run mode: " ++ show rm-- flipQ (ALL, x) = (EX, x)- flipQ (EX, x) = (ALL, x)-- skolemize :: [(Quantifier, NamedSymVar)] -> [Either SV (SV, [SV])]- skolemize quants = go quants ([], [])- where go [] (_, sofar) = reverse sofar- go ((ALL, getSV -> v) :rest) (us, sofar) = go rest (v:us, Left v : sofar)- go ((EX, getSV -> v) :rest) (us, sofar) = go rest (us, Right (v, reverse us) : sofar)-- qinps = if isSat then fst is else map flipQ (fst is)- skolemMap = skolemize qinps-- o | isSafe = trueSV- | True = case outputs of- [] | isSetup -> trueSV- [so] -> case so of- SV KBool _ -> so- _ -> error $ unlines [ "Impossible happened, non-boolean output: " ++ show so- , "Detected while generating the trace:\n" ++ show res- ]- os -> error $ unlines [ "User error: Multiple output values detected: " ++ show os- , "Detected while generating the trace:\n" ++ show res- , "*** Check calls to \"output\", they are typically not needed!"- ]-- in SMTProblem { smtLibPgm = toSMTLib config context ki isSat comments is skolemMap consts tbls arrs uis axs pgm cstrs o }---- | Generalization of 'Data.SBV.Control.executeQuery'-executeQuery :: forall m a. ExtractIO m => QueryContext -> QueryT m a -> SymbolicT m a-executeQuery queryContext (QueryT userQuery) = do- st <- symbolicEnv- rm <- liftIO $ readIORef (runMode st)-- -- Make sure the phases match:- () <- liftIO $ case (queryContext, rm) of- (QueryInternal, _) -> return () -- no worries, internal- (QueryExternal, SMTMode QueryExternal ISetup _ _) -> return () -- legitimate runSMT call- _ -> invalidQuery rm-- -- If we're doing an external query, then we cannot allow quantifiers to be present. Why?- -- Consider:- --- -- issue = do x :: SBool <- sbvForall_- -- y :: SBool <- sbvExists_- -- constrain y- -- query $ do checkSat- -- (,) <$> getValue x <*> getValue y- --- -- This is the (simplified/annotated SMTLib we would generate:)- --- -- (declare-fun s1 (Bool) Bool) ; s1 is the function that corresponds to the skolemized 'y'- -- (assert (forall ((s0 Bool)) ; s0 is 'x'- -- (s1 s0))) ; s1 applied to s0 is the actual 'y'- -- (check-sat)- -- (get-value (s0)) ; s0 simply not visible here- -- (get-value (s1)) ; s1 is visible, but only via 's1 s0', so it is also not available.- --- -- And that would be terrible! The scoping rules of our "quantified" variables and how they map to- -- SMTLib is just not compatible. This is a historical design issue, but too late at this point. (We- -- should've never allowed general quantification like this, but only in limited contexts.)- --- -- So, we check if this is an external-query, and if there are quantified variables. If so, we- -- cowardly refuse to continue. For details, see: <http://github.com/LeventErkok/sbv/issues/407>- --- -- However, as discussed in <https://github.com/LeventErkok/sbv/issues/459>, we'll allow for this- -- if the user explicitly asks as to do so. In that case, all bets are off!-- let allowQQs = case rm of- SMTMode _ _ _ cfg -> allowQuantifiedQueries cfg- CodeGen -> False -- doesn't matter in these two- Concrete{} -> False -- cases, but we're being careful-- () <- unless allowQQs $ liftIO $- case queryContext of- QueryInternal -> return () -- we're good, internal usages don't mess with scopes- QueryExternal -> do- userInps <- userInputsToList . userInputs <$> readIORef (rinps st)- let badInps = reverse [n | (ALL, getUserName' -> n) <- userInps]- case badInps of- [] -> return ()- _ -> let plu | length badInps > 1 = "s require"- | True = " requires"- in error $ unlines [ ""- , "*** Data.SBV: Unsupported query call in the presence of quantified inputs."- , "***"- , "*** The following variable" ++ plu ++ " explicit quantification: "- , "***"- , "*** " ++ intercalate ", " badInps- , "***"- , "*** While quantification and queries can co-exist in principle, SBV currently"- , "*** does not support this scenario. Avoid using quantifiers with user queries"- , "*** if possible. Please do get in touch if your use case does require such"- , "*** a feature to see how we can accommodate such scenarios."- ]-- case rm of- -- Transitioning from setup- SMTMode qc stage isSAT cfg | not (isRunIStage stage) -> do-- let slvr = solver cfg- backend = engine slvr-- -- make sure if we have dsat precision, then solver supports it- let dsatOK = isNothing (dsatPrecision cfg)- || isJust (supportsDeltaSat (capabilities slvr))-- unless dsatOK $ error $ unlines- [ ""- , "*** Data.SBV: Delta-sat precision is specified."- , "*** But the chosen solver (" ++ show (name slvr) ++ ") does not support"- , "*** delta-satisfiability."- ]-- res <- liftIO $ extractSymbolicSimulationState st- setOpts <- liftIO $ reverse <$> readIORef (rSMTOptions st)-- let SMTProblem{smtLibPgm} = runProofOn rm queryContext [] res- cfg' = cfg { solverSetOptions = solverSetOptions cfg ++ setOpts }- pgm = smtLibPgm cfg'-- liftIO $ writeIORef (runMode st) $ SMTMode qc IRun isSAT cfg-- lift $ join $ liftIO $ backend cfg' st (show pgm) $ extractIO . runReaderT userQuery-- -- Already in a query, in theory we can just continue, but that causes use-case issues- -- so we reject it. TODO: Review if we should actually support this. The issue arises with- -- expressions like this:- --- -- In the following t0's output doesn't get recorded, as the output call is too late when we get- -- here. (The output field isn't "incremental.") So, t0/t1 behave differently!- --- -- t0 = satWith z3{verbose=True, transcript=Just "t.smt2"} $ query (return (false::SBool))- -- t1 = satWith z3{verbose=True, transcript=Just "t.smt2"} $ ((return (false::SBool)) :: Predicate)- --- -- Also, not at all clear what it means to go in an out of query mode:- --- -- r = runSMTWith z3{verbose=True} $ do- -- a' <- sInteger "a"- --- -- (a, av) <- query $ do _ <- checkSat- -- av <- getValue a'- -- return (a', av)- --- -- liftIO $ putStrLn $ "Got: " ++ show av- -- -- constrain $ a .> literal av + 1 -- Can't do this since we're "out" of query. Sigh.- --- -- bv <- query $ do constrain $ a .> literal av + 1- -- _ <- checkSat- -- getValue a- --- -- return $ a' .== a' + 1- --- -- This would be one possible implementation, alas it has the problems above:- --- -- SMTMode IRun _ _ -> liftIO $ evalStateT userQuery st- --- -- So, we just reject it.-- SMTMode _ IRun _ _ -> error $ unlines [ ""- , "*** Data.SBV: Unsupported nested query is detected."- , "***"- , "*** Please group your queries into one block. Note that this"- , "*** can also arise if you have a call to 'query' not within 'runSMT'"- , "*** For instance, within 'sat'/'prove' calls with custom user queries."- , "*** The solution is to do the sat/prove part in the query directly."- , "***"- , "*** While multiple/nested queries should not be necessary in general,"- , "*** please do get in touch if your use case does require such a feature,"- , "*** to see how we can accommodate such scenarios."- ]-- -- Otherwise choke!- _ -> invalidQuery rm-- where invalidQuery rm = error $ unlines [ ""- , "*** Data.SBV: Invalid query call."- , "***"- , "*** Current mode: " ++ show rm- , "***"- , "*** Query calls are only valid within runSMT/runSMTWith calls,"- , "*** and each call to runSMT should have only one query call inside."- ]--{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN getAllSatResult ("HLint: ignore Use forM_" :: String) #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}++module Data.SBV.Control.Utils (+ io+ , ask, send, getValue, getFunction+ , getValueCV, getUICVal, getUIFunCVAssoc, getUnsatAssumptions+ , SMTFunction(..), getQueryState, modifyQueryState, getConfig, getObjectives, getUIs+ , getSBVAssertions, getObservables+ , checkSat, checkSatUsing, getAllSatResult+ , inNewContext, freshVar, freshVar_+ , getTopLevelInputs, parse, unexpected+ , timeout, queryDebug, retrieveResponse, runProofOn, executeQuery+ , startOptimizer, getObjectiveValues, getModel, getModelAtIndex+ ) where++import Data.List (sortOn, partition, groupBy, tails, intercalate, isPrefixOf, isSuffixOf)++import Data.Char (isPunctuation, isSpace, isDigit)+import Data.Function (on)+import Data.Bifunctor (first)++import Data.Proxy++import qualified Data.Foldable as F (toList, for_)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set (empty, fromList, toAscList)+import qualified Data.Sequence as S+import qualified Data.Text as T++import Control.Monad (join, unless, zipWithM, when, replicateM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans (lift)+import Control.Monad.Reader (runReaderT)++import Data.Maybe (isNothing, isJust, catMaybes, listToMaybe)++import Data.IORef (readIORef, writeIORef, IORef, newIORef, modifyIORef')++import Data.Time (getZonedTime)+import Data.Ratio++import Data.SBV.Core.Data ( SV(..), trueSV, falseSV, CV(..), trueCV, falseCV, SBV, sbvToSV, kindOf, Kind(..)+ , HasKind(..), mkConstCV, CVal(..), SMTResult(..)+ , NamedSymVar, SMTConfig(..), SMTModel(..)+ , QueryState(..), SVal(..), cache+ , newExpr, SBVExpr(..), Op(..), FPOp(..), SBV(..)+ , SolverContext(..), SBool, Objective(..), SolverCapabilities(..), capabilities+ , Result(..), SMTProblem(..), trueSV, SymVal(..), SBVPgm(..), SMTSolver(..), SBVRunMode(..)+ , SBVType(..), forceSVArg, (.=>)+ , RCSet(..), QuantifiedBool(..), ArrayModel(..), SInfo(..), getSInfo+ , OptimizeStyle(..), GeneralizedCV(..), ExtCV(..)+ )++import Data.SBV.Core.Symbolic ( IncState(..), withNewIncState, State(..), svToSV, symbolicEnv, SymbolicT+ , MonadQuery(..), QueryContext(..), VarContext(..)+ , registerLabel, svMkSymVar, validationRequested+ , isSafetyCheckingIStage, isSetupIStage, isRunIStage, IStage(..), QueryT(..)+ , extractSymbolicSimulationState, MonadSymbolic(..)+ , UserInputs, getSV, NamedSymVar(..), lookupInput, getUserName, getUserName'+ , Name, CnstMap, Inputs(..), ProgInfo(..)+ , mustIgnoreVar, newInternalVariable, Penalty(..), smtLibPgmText+ )++import Data.SBV.Core.AlgReals (mergeAlgReals, AlgReal(..), RealPoint(..))+import Data.SBV.Core.SizedFloats (fpZero, fpFromInteger, fpFromFloat, fpFromDouble)+import Data.SBV.Core.Kind (smtType, hasUninterpretedSorts, expandKinds, isSomeKindOfFloat, substituteADTVars)+import Data.SBV.Core.Operations (svNot, svNotEqual, svOr, svEqual)++import Data.SBV.SMT.SMT (showModel, parseCVs, SatModel, AllSatResult(..), OptimizeResult(..))+import Data.SBV.SMT.SMTLib (toIncSMTLib, toSMTLib)+import Data.SBV.SMT.SMTLib2 (setSMTOption)+import Data.SBV.SMT.Utils ( showTimeoutValue, addAnnotations, alignPlain, debug+ , mergeSExpr, SBVException(..), recordTranscript, TranscriptMsg(..)+ )++import Data.SBV.Utils.ExtractIO+import Data.SBV.Utils.Lib (qfsToString, unBar, mapToSortedList, showText)+import Data.SBV.Utils.SExpr+import Data.SBV.Utils.PrettyNum (cvToSMTLib)++import Data.SBV.Control.Types++import qualified Control.Exception as C++import GHC.Stack++-- | 'Data.SBV.Trans.Control.QueryT' as a 'SolverContext'.+instance MonadIO m => SolverContext (QueryT m) where+ constrain = addQueryConstraint False [] . quantifiedBool+ softConstrain = addQueryConstraint True [] . quantifiedBool+ namedConstraint nm = addQueryConstraint False [(":named", nm)] . quantifiedBool+ constrainWithAttribute attr = addQueryConstraint False attr . quantifiedBool++ contextState = queryState++ internalVariable :: forall a. Kind -> QueryT m (SBV a)+ internalVariable k = contextState >>= \st -> liftIO $ do+ sv <- newInternalVariable st k+ pure $ SBV $ SVal k (Right (cache (const (pure sv))))++ setOption o+ | isStartModeOption o = error $ unlines [ ""+ , "*** Data.SBV: '" ++ show o ++ "' can only be set at start-up time."+ , "*** Hint: Move the call to 'setOption' before the query."+ ]+ | True = do State{stCfg} <- contextState+ send True $ setSMTOption stCfg o++-- | Adding a constraint, possibly with attributes and possibly soft. Only used internally.+-- Use 'constrain' and 'namedConstraint' from user programs.+addQueryConstraint :: (MonadIO m, MonadQuery m) => Bool -> [(String, String)] -> SBool -> m ()+addQueryConstraint isSoft atts b = do sv <- inNewContext (\st -> liftIO $ do mapM_ (registerLabel "Constraint" st) [nm | (":named", nm) <- atts]+ sbvToSV st b)++ unless (null atts && sv == trueSV) $+ send True $ "(" <> T.pack asrt <> " " <> addAnnotations atts (showText sv) <> ")"+ where asrt | isSoft = "assert-soft"+ | True = "assert"++-- | Get the current configuration+getConfig :: (MonadIO m, MonadQuery m) => m SMTConfig+getConfig = queryConfig <$> getQueryState++-- | Get the objectives+getObjectives :: (MonadIO m, MonadQuery m) => m [Objective (SV, SV)]+getObjectives = do State{rOptGoals} <- queryState+ io $ reverse <$> readIORef rOptGoals++-- | Get the assertions put in via 'Data.SBV.sAssert'+getSBVAssertions :: (MonadIO m, MonadQuery m) => m [(String, Maybe CallStack, SV)]+getSBVAssertions = do State{rAsserts} <- queryState+ io $ reverse <$> readIORef rAsserts++-- | Generalization of 'Data.SBV.Control.io'+io :: MonadIO m => IO a -> m a+io = liftIO++-- | Sync-up the external solver with new context we have generated+syncUpSolver :: (MonadIO m, MonadQuery m) => ProgInfo -> IORef CnstMap -> IncState -> m ()+syncUpSolver progInfo rGlobalConsts is = do+ cfg <- getConfig++ -- update global consts to have the new ones+ (newConsts, allConsts) <- liftIO $ do nc <- readIORef (rNewConsts is)+ oc <- readIORef rGlobalConsts+ let !allConsts = Map.union nc oc+ writeIORef rGlobalConsts allConsts+ pure (nc, allConsts)++ ls <- io $ do let arrange (i, (at, rt, es)) = ((i, at, rt), es)+ inps <- reverse <$> readIORef (rNewInps is)+ ks <- readIORef (rNewKinds is)+ tbls <- map arrange . mapToSortedList <$> readIORef (rNewTbls is)+ uis <- Map.toAscList <$> readIORef (rNewUIs is)+ as <- readIORef (rNewAsgns is)+ constraints <- readIORef (rNewConstraints is)++ let cnsts = mapToSortedList newConsts++ pure $ toIncSMTLib cfg progInfo inps ks (allConsts, cnsts) tbls uis as constraints cfg++ mapM_ (send True) $ mergeSExpr ls++-- | Retrieve the query context+getQueryState :: (MonadIO m, MonadQuery m) => m QueryState+getQueryState = do state <- queryState+ mbQS <- io $ readIORef (rQueryState state)+ case mbQS of+ Nothing -> error $ unlines [ ""+ , "*** Data.SBV: Impossible happened: Query context required in a non-query mode."+ , "Please report this as a bug!"+ ]+ Just qs -> pure qs++-- | Generalization of 'Data.SBV.Control.modifyQueryState'+modifyQueryState :: (MonadIO m, MonadQuery m) => (QueryState -> QueryState) -> m ()+modifyQueryState f = do state <- queryState+ mbQS <- io $ readIORef (rQueryState state)+ case mbQS of+ Nothing -> error $ unlines [ ""+ , "*** Data.SBV: Impossible happened: Query context required in a non-query mode."+ , "Please report this as a bug!"+ ]+ Just qs -> let fqs = f qs+ in fqs `seq` io $ writeIORef (rQueryState state) $ Just fqs++-- | Generalization of 'Data.SBV.Control.inNewContext'+inNewContext :: (MonadIO m, MonadQuery m) => (State -> IO a) -> m a+inNewContext act = do st@State{rconstMap, rProgInfo} <- queryState+ (is, r) <- io $ withNewIncState st act+ progInfo <- io $ readIORef rProgInfo+ syncUpSolver progInfo rconstMap is+ pure r++-- | Generalization of 'Data.SBV.Control.freshVar_'+freshVar_ :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => m (SBV a)+freshVar_ = inNewContext $ fmap SBV . svMkSymVar QueryVar k Nothing+ where k = kindOf (Proxy @a)++-- | Generalization of 'Data.SBV.Control.freshVar'+freshVar :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => String -> m (SBV a)+freshVar nm = inNewContext $ fmap SBV . svMkSymVar QueryVar k (Just nm)+ where k = kindOf (Proxy @a)++-- | Generalization of 'Data.SBV.Control.queryDebug'+queryDebug :: (MonadIO m, MonadQuery m) => [T.Text] -> m ()+queryDebug msgs = do QueryState{queryConfig} <- getQueryState+ io $ do debug queryConfig msgs+ recordTranscript (transcript queryConfig) (DebugMsg (T.unlines msgs))++-- | We need to track sent asserts/check-sat calls so we can issue an extra check-sat call if needed+trackAsserts :: (MonadIO m, MonadQuery m) => T.Text -> m ()+trackAsserts s+ | isCheckSat || isAssert+ = do State{rOutstandingAsserts} <- queryState+ liftIO $ writeIORef rOutstandingAsserts isAssert+ | True+ = pure ()+ where trimmedS = T.dropWhile isSpace s+ isCheckSat = "(check-sat" `T.isPrefixOf` trimmedS+ isAssert = "(assert" `T.isPrefixOf` trimmedS++-- | Generalization of 'Data.SBV.Control.ask'+ask :: (MonadIO m, MonadQuery m) => T.Text -> m String+ask s = askIgnoring s []++-- | Send a string to the solver, and return the response. Except, if the response+-- is one of the "ignore" ones, keep querying.+askIgnoring :: (MonadIO m, MonadQuery m) => T.Text -> [String] -> m String+askIgnoring s ignoreList = do++ trackAsserts s++ QueryState{queryAsk, queryRetrieveResponse, queryTimeOutValue} <- getQueryState++ case queryTimeOutValue of+ Nothing -> queryDebug ["[SEND] " `alignPlain` s]+ Just i -> queryDebug ["[SEND, TimeOut: " <> showTimeoutValue i <> "] " `alignPlain` s]+ r <- io $ queryAsk queryTimeOutValue s+ queryDebug ["[RECV] " `alignPlain` T.pack r]++ let loop currentResponse+ | currentResponse `notElem` ignoreList+ = pure currentResponse+ | True+ = do queryDebug ["[WARN] Previous response is explicitly ignored, beware!"]+ newResponse <- io $ queryRetrieveResponse queryTimeOutValue+ queryDebug ["[RECV] " `alignPlain` T.pack newResponse]+ loop newResponse++ loop r++-- | Generalization of 'Data.SBV.Control.send'+send :: (MonadIO m, MonadQuery m) => Bool -> T.Text -> m ()+send requireSuccess s = do++ trackAsserts s++ QueryState{queryAsk, querySend, queryConfig, queryTimeOutValue} <- getQueryState++ if requireSuccess && supportsCustomQueries (capabilities (solver queryConfig))+ then do r <- io $ queryAsk queryTimeOutValue s++ case words r of+ ["success"] -> queryDebug ["[GOOD] " `alignPlain` s]+ _ -> do case queryTimeOutValue of+ Nothing -> queryDebug ["[FAIL] " `alignPlain` s]+ Just i -> queryDebug ["[FAIL, TimeOut: " <> showTimeoutValue i <> "] " `alignPlain` s]+++ let cmd = case T.words (T.dropWhile (\c -> isSpace c || isPunctuation c) s) of+ (c:_) -> T.unpack c+ _ -> "Command"++ unexpected cmd s "success" Nothing r Nothing++ else do -- fire and forget. if you use this, you're on your own!+ queryDebug ["[FIRE] " `alignPlain` s]+ io $ querySend queryTimeOutValue s++-- | Generalization of 'Data.SBV.Control.retrieveResponse'+retrieveResponse :: (MonadIO m, MonadQuery m) => String -> Maybe Int -> m [String]+retrieveResponse userTag mbTo = do+ ts <- io (show <$> getZonedTime)++ let synchTag = show $ userTag ++ " (at: " ++ ts ++ ")"+ cmd = "(echo " ++ synchTag ++ ")"++ queryDebug ["[SYNC] Attempting to synchronize with tag: " <> T.pack synchTag]++ send False (T.pack cmd)++ QueryState{queryRetrieveResponse} <- getQueryState++ let loop sofar = do+ s <- io $ queryRetrieveResponse mbTo++ -- strictly speaking SMTLib requires solvers to print quotes around+ -- echo'ed strings, but they don't always do. Accommodate for that+ -- here, though I wish we didn't have to.+ if s == synchTag || show s == synchTag+ then do queryDebug ["[SYNC] Synchronization achieved using tag: " <> T.pack synchTag]+ pure $ reverse sofar+ else do queryDebug ["[RECV] " `alignPlain` T.pack s]+ loop (s : sofar)++ loop []++-- | Generalization of 'Data.SBV.Control.getValue'+getValue :: (MonadIO m, MonadQuery m, SymVal a) => SBV a -> m a+getValue s = do++ sv <- inNewContext (`sbvToSV` s)++ -- If we're issuing get-value, we gotta make sure there are no outstanding asserts+ -- This can happen if we sent some ourselves. See https://github.com/LeventErkok/sbv/issues/682+ outstandingAsserts <- do State{rOutstandingAsserts} <- queryState+ liftIO $ readIORef rOutstandingAsserts++ when outstandingAsserts $ do+ queryDebug ["[NOTE] getValue: There are outstanding asserts. Ensuring we're still sat."]+ r <- checkSat+ let bad = unexpected "checkSat" "check-sat" "one of sat/unsat/unknown" Nothing (show r) Nothing+ case r of+ Sat -> pure ()+ DSat{} -> pure ()+ Unk -> bad+ Unsat -> bad++ -- Are we in an optimization context? If so, we must ensure that the model is not in an extended field+ objs <- getObjectives+ unless (null objs) $ do+ ovs <- getObjectiveValues+ case [() | (_, ExtendedCV _) <- ovs] of+ [] -> pure () -- We're good, all objectives are within the domain+ _ -> do cfg <- getConfig+ m <- getModel+ ov <- getObjectiveValues++ let mdl = LexicographicResult (SatExtField cfg m{modelObjectives = ov})++ align "" = "***"+ align l = "*** " ++ l++ error $ unlines $ "" : map align ([+ "Data.SBV.getValue: The current solver state is satisfiable in an extension field."+ , "That is, the optimized values assume epsilon/infinity values."+ , ""+ , "Calls to getValue is not supported in this context. Instead, use the 'optimize' method"+ , "directly and inspect the objective values explicitly."+ , ""+ , "The current model is:"+ , ""+ ] ++ map (" " ++) (lines (show mdl)))++ cv <- getValueCV Nothing sv+ pure $ fromCV cv++-- | A class which allows for sexpr-conversion to functions+class (HasKind r, SatModel r) => SMTFunction fun a r | fun -> a r where+ sexprToArg :: (MonadIO m, SolverContext m) => fun -> [SExpr] -> m (Maybe a)+ smtFunName :: (MonadIO m, SolverContext m) => fun -> m ((String, Maybe [String]), Bool)+ smtFunSaturate :: fun -> SBV r+ smtFunType :: fun -> SBVType+ smtFunDefault :: fun -> Maybe r+ sexprToFun :: (MonadIO m, SolverContext m, MonadQuery m, MonadSymbolic m, SymVal r) => fun -> (String, SExpr) -> m (Either String ([(a, r)], r))++ {-# MINIMAL sexprToArg, smtFunSaturate, smtFunType #-}++ -- Given the function, figure out a default "return value"+ smtFunDefault _+ | let v = defaultKindedValue (kindOf (Proxy @r)), Just (res, []) <- parseCVs [v]+ = Just res+ | True+ = Nothing++ -- Given the function, determine what its name is and do some sanity checks+ smtFunName f = do st@State{rUIMap} <- contextState+ uiMap <- liftIO $ readIORef rUIMap+ nm <- findName st uiMap++ -- Read the uiMap again here. Why? Because the act of finding the name might've+ -- introduced it as an uninterpreted name!+ newUIMap <- liftIO $ readIORef rUIMap+ case nm `Map.lookup` newUIMap of+ Nothing -> cantFind newUIMap+ Just (isCurried, mbArgs, _) -> pure ((nm, mbArgs), isCurried)+ where cantFind uiMap = error $ unlines $ [ ""+ , "*** Data.SBV.getFunction: Must be called on an uninterpreted function!"+ , "***"+ , "*** Expected to receive a function created by \"uninterpret\""+ ]+ ++ tag+ ++ [ "***"+ , "*** Make sure to call getFunction on uninterpreted functions only!"+ , "*** If that is already the case, please report this as a bug."+ ]+ where tag = case map fst (Map.toList uiMap) of+ [] -> [ "*** But, there are no matching uninterpreted functions in the context." ]+ [x] -> [ "*** The only possible candidate is: " ++ x ]+ cands -> [ "*** Candidates are:"+ , "*** " ++ intercalate ", " cands+ ]++ findName st@State{spgm} uiMap = do+ r <- liftIO $ sbvToSV st (smtFunSaturate f)+ liftIO $ forceSVArg r+ SBVPgm asgns <- liftIO $ readIORef spgm+++ case S.findIndexR ((== r) . fst) asgns of+ Nothing -> cantFind uiMap+ Just i -> case asgns `S.index` i of+ (sv, SBVApp (Uninterpreted nm) _) | r == sv -> pure (T.unpack nm)+ _ -> cantFind uiMap++ sexprToFun f (s, e) = do nm <- fst . fst <$> smtFunName f+ si <- contextState >>= getSInfo+ mbRes <- case parseSExprFunction e of+ Just (Left nm') -> case (nm == nm', smtFunDefault f) of+ (True, Just v) -> pure $ Just ([], v)+ _ -> bailOut nm+ Just (Right v) -> convert si v+ Nothing -> do mbPVS <- pointWiseExtract nm (smtFunType f)+ case mbPVS of+ Nothing -> pure Nothing+ Just pts -> convert si pts+ pure $ maybe (Left s) Right mbRes+ where convert st (vs, d) = do ps <- mapM (sexprPoint st) vs+ pure $ (,) <$> sequenceA ps <*> sexprToVal st d++ sexprPoint st (as, v) = do mbA <- sexprToArg f as+ pure $ (,) <$> mbA <*> sexprToVal st v++ bailOut nm = error $ unlines [ ""+ , "*** Data.SBV.getFunction: Unable to extract an interpretation for function " ++ show nm+ , "***"+ , "*** Failed while trying to extract a pointwise interpretation."+ , "***"+ , "*** This could be a bug with SBV or the backend solver. Please report!"+ ]++-- | Pointwise function value extraction. If we get unlucky and can't parse z3's output (happens+-- when we have all booleans and z3 decides to spit out an expression), just brute force our+-- way out of it. Note that we only do this if we have a pure boolean type, as otherwise we'd blow+-- up. And I think it'll only be necessary then, I haven't seen z3 try anything smarter in other scenarios.+pointWiseExtract :: forall m. (MonadIO m, MonadQuery m) => String -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))+pointWiseExtract nm typ = tryPointWise+ where trueSExpr = ENum (1, Nothing, True)+ falseSExpr = ENum (0, Nothing, True)++ isTrueSExpr (ENum (1, Nothing, True)) = True+ isTrueSExpr (ENum (0, Nothing, True)) = False+ isTrueSExpr s = error $ "Data.SBV.pointWiseExtract: Impossible happened: Received: " ++ show s++ (nArgs, isBoolFunc) = case typ of+ SBVType ts -> (length ts - 1, all (== KBool) ts)++ getBVal :: [SExpr] -> m ([SExpr], SExpr)+ getBVal args = do let shc c | isTrueSExpr c = "true"+ | True = "false"++ as = unwords $ map shc args++ cmd = "(get-value ((" <> T.pack nm <> " " <> T.pack as <> ")))"++ bad = unexpected "get-value" cmd ("pointwise value of boolean function " ++ nm ++ " on " ++ show as) Nothing++ r <- ask cmd++ parse r bad $ \case EApp [EApp [_, e]] -> pure (args, e)+ _ -> bad r Nothing++ getBVals :: m [([SExpr], SExpr)]+ getBVals = mapM getBVal $ replicateM nArgs [falseSExpr, trueSExpr]++ tryPointWise+ | not isBoolFunc+ = pure Nothing+ | nArgs < 1+ = error $ "Data.SBV.pointWiseExtract: Impossible happened, nArgs < 1: " ++ show nArgs ++ " type: " ++ show typ+ | True+ = do vs <- getBVals+ -- Pick the value that will give us the fewer entries+ let (trues, falses) = partition (\(_, v) -> isTrueSExpr v) vs+ pure $ Just $ if length trues <= length falses+ then (trues, falseSExpr)+ else (falses, trueSExpr)++-- | For saturation purposes, get a proper argument. The forall quantification+-- is safe here since we only use in smtFunSaturate calls, which looks at the+-- kind stored inside only.+mkSaturatingArg :: forall a. Kind -> SBV a+mkSaturatingArg k = SBV $ SVal k (Left (defaultKindedValue k))++-- | Functions of arity 1+instance ( SymVal a, HasKind a+ , SatModel r, HasKind r+ ) => SMTFunction (SBV a -> SBV r) a r+ where+ sexprToArg _ [a0] = contextState >>= getSInfo >>= \si -> pure $ sexprToVal si a0+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @r)]++ smtFunSaturate f = f $ mkSaturatingArg (kindOf (Proxy @a))++-- | Functions of arity 2+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SatModel r, HasKind r+ ) => SMTFunction (SBV a -> SBV b -> SBV r) (a, b) r+ where+ sexprToArg _ [a0, a1] = contextState >>= getSInfo >>= \si -> pure $ (,) <$> sexprToVal si a0 <*> sexprToVal si a1+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @r)]++ smtFunSaturate f = f (mkSaturatingArg (kindOf (Proxy @a)))+ (mkSaturatingArg (kindOf (Proxy @b)))++-- | Functions of arity 3+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SatModel r, HasKind r+ ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV r) (a, b, c) r+ where+ sexprToArg _ [a0, a1, a2] = contextState >>= getSInfo >>= \si -> pure $ (,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @r)]++ smtFunSaturate f = f (mkSaturatingArg (kindOf (Proxy @a)))+ (mkSaturatingArg (kindOf (Proxy @b)))+ (mkSaturatingArg (kindOf (Proxy @c)))++-- | Functions of arity 4+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SatModel r, HasKind r+ ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV r) (a, b, c, d) r+ where+ sexprToArg _ [a0, a1, a2, a3] = contextState >>= getSInfo >>= \si -> pure $ (,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @r)]++ smtFunSaturate f = f (mkSaturatingArg (kindOf (Proxy @a)))+ (mkSaturatingArg (kindOf (Proxy @b)))+ (mkSaturatingArg (kindOf (Proxy @c)))+ (mkSaturatingArg (kindOf (Proxy @d)))++-- | Functions of arity 5+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SymVal e, HasKind e+ , SatModel r, HasKind r+ ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r) (a, b, c, d, e) r+ where+ sexprToArg _ [a0, a1, a2, a3, a4] = contextState >>= getSInfo >>= \si -> pure $ (,,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3 <*> sexprToVal si a4+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @r)]++ smtFunSaturate f = f (mkSaturatingArg (kindOf (Proxy @a)))+ (mkSaturatingArg (kindOf (Proxy @b)))+ (mkSaturatingArg (kindOf (Proxy @c)))+ (mkSaturatingArg (kindOf (Proxy @d)))+ (mkSaturatingArg (kindOf (Proxy @e)))++-- | Functions of arity 6+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SymVal e, HasKind e+ , SymVal f, HasKind f+ , SatModel r, HasKind r+ ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r) (a, b, c, d, e, f) r+ where+ sexprToArg _ [a0, a1, a2, a3, a4, a5] = contextState >>= getSInfo >>= \si -> pure $ (,,,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3 <*> sexprToVal si a4 <*> sexprToVal si a5+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @r)]++ smtFunSaturate f = f (mkSaturatingArg (kindOf (Proxy @a)))+ (mkSaturatingArg (kindOf (Proxy @b)))+ (mkSaturatingArg (kindOf (Proxy @c)))+ (mkSaturatingArg (kindOf (Proxy @d)))+ (mkSaturatingArg (kindOf (Proxy @e)))+ (mkSaturatingArg (kindOf (Proxy @f)))++-- | Functions of arity 7+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SymVal e, HasKind e+ , SymVal f, HasKind f+ , SymVal g, HasKind g+ , SatModel r, HasKind r+ ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r) (a, b, c, d, e, f, g) r+ where+ sexprToArg _ [a0, a1, a2, a3, a4, a5, a6] = contextState >>= getSInfo >>= \si -> pure $ (,,,,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3 <*> sexprToVal si a4 <*> sexprToVal si a5 <*> sexprToVal si a6+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @g), kindOf (Proxy @r)]++ smtFunSaturate f = f (mkSaturatingArg (kindOf (Proxy @a)))+ (mkSaturatingArg (kindOf (Proxy @b)))+ (mkSaturatingArg (kindOf (Proxy @c)))+ (mkSaturatingArg (kindOf (Proxy @d)))+ (mkSaturatingArg (kindOf (Proxy @e)))+ (mkSaturatingArg (kindOf (Proxy @f)))+ (mkSaturatingArg (kindOf (Proxy @g)))++-- | Functions of arity 8+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SymVal e, HasKind e+ , SymVal f, HasKind f+ , SymVal g, HasKind g+ , SymVal h, HasKind h+ , SatModel r, HasKind r+ ) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV h -> SBV r) (a, b, c, d, e, f, g, h) r+ where+ sexprToArg _ [a0, a1, a2, a3, a4, a5, a6, a7] = contextState >>= getSInfo >>= \si -> pure $ (,,,,,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3 <*> sexprToVal si a4 <*> sexprToVal si a5 <*> sexprToVal si a6 <*> sexprToVal si a7+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @g), kindOf (Proxy @h), kindOf (Proxy @r)]++ smtFunSaturate f = f (mkSaturatingArg (kindOf (Proxy @a)))+ (mkSaturatingArg (kindOf (Proxy @b)))+ (mkSaturatingArg (kindOf (Proxy @c)))+ (mkSaturatingArg (kindOf (Proxy @d)))+ (mkSaturatingArg (kindOf (Proxy @e)))+ (mkSaturatingArg (kindOf (Proxy @f)))+ (mkSaturatingArg (kindOf (Proxy @g)))+ (mkSaturatingArg (kindOf (Proxy @h)))++-- | Curried functions of arity 2+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SatModel r, HasKind r+ ) => SMTFunction ((SBV a, SBV b) -> SBV r) (a, b) r+ where+ sexprToArg _ [a0, a1] = contextState >>= getSInfo >>= \si -> pure $ (,) <$> sexprToVal si a0 <*> sexprToVal si a1+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @r)]++ smtFunSaturate f = f ( mkSaturatingArg (kindOf (Proxy @a))+ , mkSaturatingArg (kindOf (Proxy @b))+ )++-- | Curried functions of arity 3+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SatModel r, HasKind r+ ) => SMTFunction ((SBV a, SBV b, SBV c) -> SBV r) (a, b, c) r+ where+ sexprToArg _ [a0, a1, a2] = contextState >>= getSInfo >>= \si -> pure $ (,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @r)]++ smtFunSaturate f = f ( mkSaturatingArg (kindOf (Proxy @a))+ , mkSaturatingArg (kindOf (Proxy @b))+ , mkSaturatingArg (kindOf (Proxy @c))+ )++-- | Curried functions of arity 4+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SatModel r, HasKind r+ ) => SMTFunction ((SBV a, SBV b, SBV c, SBV d) -> SBV r) (a, b, c, d) r+ where+ sexprToArg _ [a0, a1, a2, a3] = contextState >>= getSInfo >>= \si -> pure $ (,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @r)]++ smtFunSaturate f = f ( mkSaturatingArg (kindOf (Proxy @a))+ , mkSaturatingArg (kindOf (Proxy @b))+ , mkSaturatingArg (kindOf (Proxy @c))+ , mkSaturatingArg (kindOf (Proxy @d))+ )++-- | Curried functions of arity 5+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SymVal e, HasKind e+ , SatModel r, HasKind r+ ) => SMTFunction ((SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r) (a, b, c, d, e) r+ where+ sexprToArg _ [a0, a1, a2, a3, a4] = contextState >>= getSInfo >>= \si -> pure $ (,,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3 <*> sexprToVal si a4+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @r)]++ smtFunSaturate f = f ( mkSaturatingArg (kindOf (Proxy @a))+ , mkSaturatingArg (kindOf (Proxy @b))+ , mkSaturatingArg (kindOf (Proxy @c))+ , mkSaturatingArg (kindOf (Proxy @d))+ , mkSaturatingArg (kindOf (Proxy @e))+ )++-- | Curried functions of arity 6+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SymVal e, HasKind e+ , SymVal f, HasKind f+ , SatModel r, HasKind r+ ) => SMTFunction ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r) (a, b, c, d, e, f) r+ where+ sexprToArg _ [a0, a1, a2, a3, a4, a5] = contextState >>= getSInfo >>= \si -> pure $ (,,,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3 <*> sexprToVal si a4 <*> sexprToVal si a5+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @r)]++ smtFunSaturate f = f ( mkSaturatingArg (kindOf (Proxy @a))+ , mkSaturatingArg (kindOf (Proxy @b))+ , mkSaturatingArg (kindOf (Proxy @c))+ , mkSaturatingArg (kindOf (Proxy @d))+ , mkSaturatingArg (kindOf (Proxy @e))+ , mkSaturatingArg (kindOf (Proxy @f))+ )++-- | Curried functions of arity 7+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SymVal e, HasKind e+ , SymVal f, HasKind f+ , SymVal g, HasKind g+ , SatModel r, HasKind r+ ) => SMTFunction ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r) (a, b, c, d, e, f, g) r+ where+ sexprToArg _ [a0, a1, a2, a3, a4, a5, a6] = contextState >>= getSInfo >>= \si -> pure $ (,,,,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3 <*> sexprToVal si a4 <*> sexprToVal si a5 <*> sexprToVal si a6+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @g), kindOf (Proxy @r)]++ smtFunSaturate f = f ( mkSaturatingArg (kindOf (Proxy @a))+ , mkSaturatingArg (kindOf (Proxy @b))+ , mkSaturatingArg (kindOf (Proxy @c))+ , mkSaturatingArg (kindOf (Proxy @d))+ , mkSaturatingArg (kindOf (Proxy @e))+ , mkSaturatingArg (kindOf (Proxy @f))+ , mkSaturatingArg (kindOf (Proxy @g))+ )++-- | Curried functions of arity 8+instance ( SymVal a, HasKind a+ , SymVal b, HasKind b+ , SymVal c, HasKind c+ , SymVal d, HasKind d+ , SymVal e, HasKind e+ , SymVal f, HasKind f+ , SymVal g, HasKind g+ , SymVal h, HasKind h+ , SatModel r, HasKind r+ ) => SMTFunction ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r) (a, b, c, d, e, f, g, h) r+ where+ sexprToArg _ [a0, a1, a2, a3, a4, a5, a6, a7] = contextState >>= getSInfo >>= \si -> pure $ (,,,,,,,) <$> sexprToVal si a0 <*> sexprToVal si a1 <*> sexprToVal si a2 <*> sexprToVal si a3 <*> sexprToVal si a4 <*> sexprToVal si a5 <*> sexprToVal si a6 <*> sexprToVal si a7+ sexprToArg _ _ = pure Nothing++ smtFunType _ = SBVType [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @g), kindOf (Proxy @h), kindOf (Proxy @r)]++ smtFunSaturate f = f ( mkSaturatingArg (kindOf (Proxy @a))+ , mkSaturatingArg (kindOf (Proxy @b))+ , mkSaturatingArg (kindOf (Proxy @c))+ , mkSaturatingArg (kindOf (Proxy @d))+ , mkSaturatingArg (kindOf (Proxy @e))+ , mkSaturatingArg (kindOf (Proxy @f))+ , mkSaturatingArg (kindOf (Proxy @g))+ , mkSaturatingArg (kindOf (Proxy @h))+ )++-- Turn "((F (lambda ((x!1 Int)) (+ 3 (* 2 x!1)))))"+-- into something more palatable.+-- If we can't do that, we simply return the input unchanged+trimFunctionResponse :: String -> String -> Bool -> Maybe [String] -> String+trimFunctionResponse resp nm isCurried mbArgs+ | Just parsed <- makeHaskellFunction resp nm isCurried mbArgs+ = parsed+ | True+ = def $ case trim resp of+ '(':'(':rest | nm `isPrefixOf` rest -> butLast2 $ trim (drop (length nm) rest)+ _ -> resp+ where trim = dropWhile isSpace+ butLast2 = reverse . drop 2 . reverse+ def x = nm ++ " = fromSMTLib " ++ x++-- | Generalization of 'Data.SBV.Control.getFunction'+getFunction :: (MonadIO m, MonadQuery m, SolverContext m, MonadSymbolic m, SymVal a, SymVal r, SMTFunction fun a r)+ => fun -> m (Either (String, (Bool, Maybe [String], SExpr)) ([(a, r)], r))+getFunction f = do ((nm, args), isCurried) <- smtFunName f++ let cmd = "(get-value (" <> T.pack nm <> "))"+ bad = unexpected "getFunction" cmd "a function value" Nothing++ r <- ask cmd++ si <- contextState >>= getSInfo++ parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> do+ mbAssocs <- sexprToFun f (trimFunctionResponse r nm isCurried args, e)+ case mbAssocs of+ Right assocs -> pure $ Right assocs+ Left raw -> do+ let rawRes = Left (raw, (isCurried, args, e))+ mbPVS <- pointWiseExtract nm (smtFunType f)+ case mbPVS of+ Just ps -> do rs <- convert si ps+ case rs of+ Just x -> pure $ Right x+ Nothing -> pure rawRes+ Nothing -> pure rawRes+ _ -> bad r Nothing+ where convert si (vs, d) = do ps <- mapM (sexprPoint si) vs+ pure $ (,) <$> sequenceA ps <*> sexprToVal si d++ sexprPoint si (as, v) = do mbA <- sexprToArg f as+ pure $ (,) <$> mbA <*> sexprToVal si v++-- | Get the value of a term, but in CV form. Used internally. The model-index, in particular is extremely Z3 specific!+getValueCVHelper :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV+getValueCVHelper mbi s+ | s == trueSV+ = pure trueCV+ | s == falseSV+ = pure falseCV+ | True+ = extractValue mbi (show s) (kindOf s)++-- | "Make up" a CV for this type. Like zero, but smarter.+defaultKindedValue :: Kind -> CV+defaultKindedValue k = CV k $ cvt k+ where cvt :: Kind -> CVal+ cvt (KVar s) = error ("defaultKindedValue: Unexpected kind: " ++ s)+ cvt KBool = CInteger 0+ cvt KBounded{} = CInteger 0+ cvt KUnbounded = CInteger 0+ cvt KReal = CAlgReal 0+ cvt KFloat = CFloat 0+ cvt KDouble = CDouble 0+ cvt KRational = CRational 0+ cvt (KFP eb sb) = CFP (fpZero False eb sb)+ cvt KChar = CChar '\NUL' -- why not?+ cvt KString = CString ""+ cvt (KList _) = CList []+ cvt (KSet _) = CSet $ RegularSet Set.empty -- why not? Arguably, could be the universal set+ cvt (KTuple ks) = CTuple $ map cvt ks+ cvt (KArray _ k2) = CArray $ ArrayModel [] (cvt k2)++ cvt (KApp s _) = error ("defaultKindedValue not supported for ADT app: " ++ s) -- tough luck++ -- For ADTs, just return the first element if there's any+ cvt (KADT s _ cstrs) = case cstrs of+ [] -> error ("defaultKindedValue not supported for ADT: " ++ s) -- tough luck+ ((c, ks) : _) -> CADT (c, [(k, cvt fk) | fk <- ks])++-- | Go from an SExpr directly to a value+sexprToVal :: forall a. SymVal a => SInfo -> SExpr -> Maybe a+sexprToVal si e = fromCV <$> recoverKindedValue si (kindOf (Proxy @a)) e++-- | Recover a given solver-printed value with a possible interpretation+recoverKindedValue :: SInfo -> Kind -> SExpr -> Maybe CV+recoverKindedValue si k e =+ case k of+ KVar{} -> error $ "Data.SBV.recoverKindedValue: Unexpected var kind: " ++ show k++ KApp n ks -> case [(s, ps, cstrs) | KADT s ps cstrs <- sInfoKinds si, s == n] of+ [(s, ps, cstr)]+ | length ks == length ps -> recoverKindedValue si (KADT s (zip (map fst ps) ks) cstr) e+ xs -> error $ unlines [ "Data.SBV.recoverKindedValue: Can't uniquely locate reference to ADT: "+ , "***"+ , "*** ADT : " ++ show n+ , "*** Params : " ++ show ks+ , "*** Matched: " ++ show xs+ , "*** Expr : " ++ show e+ , "***"+ , "*** Please report this as a bug."+ ]++ KBool | ENum (i, _, _) <- e -> Just $ mkConstCV k i+ | True -> Nothing++ KBounded{} | ENum (i, _, _) <- e -> Just $ mkConstCV k i+ | True -> Nothing++ KUnbounded | ENum (i, _, _) <- e -> Just $ mkConstCV k i+ | True -> Nothing++ KReal | ENum (i, _, _) <- e -> Just $ mkConstCV k i+ | EReal i <- e -> Just $ CV KReal (CAlgReal i)+ | True -> interpretInterval e++ KADT nm dict def -> let k' = KADT nm dict [(c, map (substituteADTVars nm dict) ks) | (c, ks) <- def]+ in Just $ CV k' $ CADT $ interpretADT k' e++ KFloat | ENum (i, _, _) <- e -> Just $ mkConstCV k i+ | EFloat i <- e -> Just $ CV KFloat (CFloat i)+ | True -> Nothing++ KDouble | ENum (i, _, _) <- e -> Just $ mkConstCV k i+ | EDouble i <- e -> Just $ CV KDouble (CDouble i)+ | True -> Nothing++ KFP eb sb | ENum (i, _, _) <- e -> Just $ CV k $ CFP $ fpFromInteger eb sb i+ | EFloat f <- e -> Just $ CV k $ CFP $ fpFromFloat eb sb f+ | EDouble d <- e -> Just $ CV k $ CFP $ fpFromDouble eb sb d+ | EFloatingPoint c <- e -> Just $ CV k $ CFP c+ | True -> Nothing++ KChar | ECon s <- e -> Just $ CV KChar $ CChar $ interpretChar s+ | True -> Nothing++ KString | ECon s <- e -> Just $ CV KString $ CString $ interpretString s+ | True -> Nothing++ KRational -> Just $ CV k $ CRational $ interpretRational e+ KList ek -> Just $ CV k $ CList $ interpretList ek e+ KSet ek -> Just $ CV k $ CSet $ interpretSet ek e+ KTuple{} -> Just $ CV k $ CTuple $ interpretTuple e+ KArray k1 k2 -> Just $ CV k $ CArray $ interpretArray k1 k2 e++ where stringLike xs = length xs >= 2 && "\"" `isPrefixOf` xs && "\"" `isSuffixOf` xs++ -- Make sure strings are really strings+ interpretString xs+ | not (stringLike xs)+ = error $ "Expected a string constant with quotes, received: <" ++ xs ++ ">"+ | True+ = qfsToString $ drop 1 (init xs)++ interpretChar xs = case interpretString xs of+ [c] -> c+ _ -> error $ "Expected a singleton char constant, received: <" ++ xs ++ ">"++ interpretRational (EApp [ECon "SBV.Rational", v1, v2])+ | Just (CV _ (CInteger n)) <- recoverKindedValue si KUnbounded v1+ , Just (CV _ (CInteger d)) <- recoverKindedValue si KUnbounded v2+ = n % d+ interpretRational xs = error $ "Expected a rational constant, received: <" ++ show xs ++ ">"++ interpretList ek topExpr = walk topExpr+ where walk (EApp [ECon "as", v, _]) = walk v+ walk (ECon "seq.empty") = []+ walk (EApp [ECon "seq.unit", v]) = case recoverKindedValue si ek v of+ Just w -> [cvVal w]+ Nothing -> error $ "Cannot parse a sequence item of kind " ++ show ek ++ " from: " ++ show v ++ extra v+ walk (EApp (ECon "seq.++" : rest)) = concatMap walk rest+ walk cur = error $ "Expected a sequence constant, but received: " ++ show cur ++ extra cur++ extra cur | show cur == t = ""+ | True = "\nWhile parsing: " ++ t+ where t = show topExpr++ -- Essentially treat sets as functions, since we do allow for store associations+ interpretSet ke setExpr+ | isUniversal setExpr = ComplementSet Set.empty+ | isEmpty setExpr = RegularSet Set.empty+ | Just (Right assocs) <- mbAssocs = decode assocs+ | True = tbd "Expected a set value, but couldn't decipher the solver output."++ where tbd :: String -> a+ tbd w = error $ unlines [ ""+ , "*** Data.SBV.interpretSet: Unable to process solver output."+ , "***"+ , "*** Kind : " ++ show (KSet ke)+ , "*** Received: " ++ show setExpr+ , "*** Reason : " ++ w+ , "***"+ , "*** This is either a bug or something SBV currently does not support."+ , "*** Please report this as a feature request!"+ ]+++ isTrue (ENum (1, Nothing, True)) = True+ isTrue (ENum (0, Nothing, True)) = False+ isTrue bad = tbd $ "Non-boolean membership value seen: " ++ show bad++ isUniversal (EApp [EApp [ECon "as", ECon "const", EApp [ECon "Array", _, ECon "Bool"]], r]) = isTrue r+ isUniversal _ = False++ isEmpty (EApp [EApp [ECon "as", ECon "const", EApp [ECon "Array", _, ECon "Bool"]], r]) = not $ isTrue r+ isEmpty _ = False++ mbAssocs = parseSExprFunction setExpr++ decode (args, r) | isTrue r = ComplementSet $ Set.fromList [x | (x, False) <- concatMap (contents True) args] -- deletions from universal+ | True = RegularSet $ Set.fromList [x | (x, True) <- concatMap (contents False) args] -- additions to empty++ contents cvt ([v], r) = let t = isTrue r in map (, t) (element cvt v)+ contents _ bad = tbd $ "Multi-valued set member seen: " ++ show bad++ element cvt x = case (cvt, ke) of+ (True, KChar) -> case recoverKindedValue si KString x of+ Just v -> case cvVal v of+ CString [c] -> [CChar c]+ CString _ -> []+ _ -> tbd $ "Unexpected value for kind: " ++ show (x, ke)+ Nothing -> tbd $ "Unexpected value for kind: " ++ show (x, ke)+ _ -> case recoverKindedValue si ke x of+ Just v -> [cvVal v]+ Nothing -> tbd $ "Unexpected value for kind: " ++ show (x, ke)++ interpretTuple te = walk (1 :: Int) (zipWith (recoverKindedValue si) ks args) []+ where (ks, n) = case k of+ KTuple eks -> (eks, length eks)+ _ -> error $ unlines [ "Impossible: Expected a tuple kind, but got: " ++ show k+ , "While trying to parse: " ++ show te+ ]++ -- | Convert a sexpr of n-tuple to constituent sexprs. Z3 and CVC4 differ here on how they+ -- present tuples, so we accommodate both:+ args = try te+ where -- Z3 way+ try (EApp (ECon f : as)) = case splitAt (T.length "mkSBVTuple") f of+ ("mkSBVTuple", c) | all isDigit c && read c == n && length as == n -> as+ _ -> bad+ -- CVC4 way+ try (EApp (EApp [ECon "as", ECon f, _] : as)) = try (EApp (ECon f : as))+ try _ = bad+ bad = error $ "Data.SBV.sexprToTuple: Impossible: Expected a constructor for " ++ show n ++ " tuple, but got: " ++ show te++ walk _ [] sofar = reverse sofar+ walk i (Just el:es) sofar = walk (i+1) es (cvVal el : sofar)+ walk i (Nothing:_) _ = error $ unlines [ "Couldn't parse a tuple element at position " ++ show i+ , "Kind: " ++ show k+ , "Expr: " ++ show te+ ]++ -- Intervals, for dReal+ interpretInterval expr = case expr of+ EApp [ECon "interval", lo, hi] -> do vlo <- getBorder lo+ vhi <- getBorder hi+ pure $ CV KReal (CAlgReal (AlgInterval vlo vhi))+ _ -> Nothing+ where getBorder (EApp [ECon "open", v]) = recoverKindedValue si KReal v >>= border OpenPoint+ getBorder (EApp [ECon "closed", v]) = recoverKindedValue si KReal v >>= border ClosedPoint+ getBorder _ = Nothing++ border b (CV KReal (CAlgReal (AlgRational True v))) = pure $ b v+ border _ other = error $ "Data.SBV.interpretInterval.border: Expected a real-valued sexp, but received: " ++ show other++ -- Essentially treat sets as functions, since we do allow for store associations+ interpretArray k1 k2 expr = case parseSExprFunction expr of+ Just (Right ascs) -> decode ascs+ _ -> tbd "Expected a set value, but couldn't decipher the solver output."++ where tbd :: String -> a+ tbd w = error $ unlines [ ""+ , "*** Data.SBV.interpretArray: Unable to process solver output."+ , "***"+ , "*** Kind : " ++ show k+ , "*** Received: " ++ show e+ , "*** Reason : " ++ w+ , "***"+ , "*** This is either a bug or something SBV currently does not support."+ , "*** Please report this as a feature request!"+ ]++ decode (args, d) = ArrayModel [(cvt k1 l, cvt k2 [r]) | (l, r) <- args] (cvt k2 [d])+ where cvt ek [v] = case recoverKindedValue si ek v of+ Just (CV _ x) -> x+ _ -> tbd $ "Cannot convert value: " ++ show v+ cvt _ vs = tbd $ "Unexpected function-like-value as array index" ++ show vs++ interpretADT :: Kind -> SExpr -> (String, [(Kind, CVal)])+ interpretADT adtK@(KADT _ _ cks) expr+ | isUninterpreted adtK+ = case expr of+ ECon s -> (simplifyECon s, [])+ _ -> bad ["Unexpected expression value for uninterpreted kind."]+ | Just ks <- cstr `lookup` cks+ = if length fs == length ks+ then (cstr, zipWith convert (zip [1..] ks) fs)+ else bad ["Mismatching field count: " ++ show (fs, ks)]+ | True+ = bad ["Cannot find constructor in the kind: " ++ show (cstr, adtK)]+ where (cstr, fs) = case removeAS expr of+ ECon c -> (c, [])+ EApp (ECon c : cs) -> (c, cs)+ _ -> bad ["Unexpected expression value; does not start with a constructor."]++ removeAS :: SExpr -> SExpr+ removeAS (EApp [ECon "as", i, _]) = removeAS i+ removeAS (EApp xs) = EApp $ map removeAS xs+ removeAS ae = ae++ bad :: [String] -> a+ bad extras = error $ unlines $ [ "Data.SBV.interpretADT: Cannot recover ADT value from solver output."+ , " Kind: " ++ show adtK+ , " Expr: " ++ show expr+ ] ++ extras++ convert :: (Int, Kind) -> SExpr -> (Kind, CVal)+ convert (i, fk) f = case recoverKindedValue si fk f of+ Just (CV kv v) -> (kv, v)+ Nothing -> bad ["Couldn't convert field " ++ show i ++ ": " ++ show (fk, f)]++ interpretADT someK expr = error $ unlines [ "Data.SBV.interpretADT: Expected an ADT kind, but got something else."+ , " Expr: " ++ show expr+ , " Kind: " ++ show someK+ ]++-- | Generalization of 'Data.SBV.Control.getValueCV'+getValueCV :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV+getValueCV mbi s+ | kindOf s /= KReal+ = getValueCVHelper mbi s+ | True+ = do cfg <- getConfig+ if not (supportsApproxReals (capabilities (solver cfg)))+ then getValueCVHelper mbi s+ else do send True "(set-option :pp.decimal false)"+ rep1 <- getValueCVHelper mbi s+ send True "(set-option :pp.decimal true)"+ send True $ "(set-option :pp.decimal_precision " <> showText (printRealPrec cfg) <> ")"+ rep2 <- getValueCVHelper mbi s++ let bad = unexpected "getValueCV" "get-value" ("a real-valued binding for " ++ show s) Nothing (show (rep1, rep2)) Nothing++ case (rep1, rep2) of+ (CV KReal (CAlgReal a), CV KReal (CAlgReal b)) -> pure $ CV KReal (CAlgReal (mergeAlgReals ("Cannot merge real-values for " ++ show s) a b))+ _ -> bad++-- | Retrieve value from the solver+extractValue :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> String -> Kind -> m CV+extractValue mbi nm k = do+ let modelIndex = case mbi of+ Nothing -> ""+ Just i -> " :model_index " ++ show i++ cmd = "(get-value (" <> T.pack nm <> ")" <> T.pack modelIndex <> ")"++ bad = unexpected "get-value" cmd ("a value binding for kind: " ++ show k) Nothing++ r <- ask cmd++ si <- queryState >>= getSInfo++ let recover val = case recoverKindedValue si k val of+ Just cv -> pure cv+ Nothing -> bad r Nothing++ parse r bad $ \case EApp [EApp [ECon v, val]] | v == nm -> recover val+ _ -> bad r Nothing++-- | Generalization of 'Data.SBV.Control.getUICVal'+getUICVal :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> (String, (Bool, Maybe [String], SBVType)) -> m CV+getUICVal mbi (nm, (_, _, t)) = case t of+ SBVType [k] -> extractValue mbi nm k+ _ -> error $ "SBV.getUICVal: Expected to be called on an uninterpreted value of a base type, received something else: " ++ show (nm, t)++-- | Generalization of 'Data.SBV.Control.getUIFunCVAssoc'+getUIFunCVAssoc :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> (String, (Bool, Maybe [String], SBVType)) -> m (Either String ([([CV], CV)], CV))+getUIFunCVAssoc mbi (nm, (isCurried, mbArgs, typ)) = do+ let modelIndex = case mbi of+ Nothing -> ""+ Just i -> " :model_index " ++ show i++ cmd = "(get-value (" <> T.pack nm <> ")" <> T.pack modelIndex <> ")"++ bad = unexpected "get-value" cmd "a function value" Nothing++ r <- ask cmd++ si <- queryState >>= getSInfo++ let (ats, rt) = case typ of+ SBVType as | length as > 1 -> (init as, last as)+ _ -> error $ "Data.SBV.getUIFunCVAssoc: Expected a function type, got: " ++ show typ++ let convert (vs, d) = (,) <$> mapM toPoint vs <*> toRes d+ toPoint (as, v)+ | length as == length ats = (,) <$> zipWithM (recoverKindedValue si) ats as <*> toRes v+ | True = error $ "Data.SBV.getUIFunCVAssoc: Mismatching type/value arity, got: " ++ show (as, ats)++ toRes :: SExpr -> Maybe CV+ toRes = recoverKindedValue si rt++ -- if we fail to parse, we'll return this answer as the string+ fallBack = trimFunctionResponse r nm isCurried mbArgs++ -- In case we end up in the pointwise scenario, boolify the result+ -- as that's the only type we support here.+ tryPointWise = do mbSExprs <- pointWiseExtract nm typ+ case mbSExprs of+ Nothing -> pure $ Left fallBack+ Just sExprs -> pure $ maybe (Left fallBack) Right (convert sExprs)++ parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> case parseSExprFunction e of+ Just (Right assocs) | Just res <- convert assocs -> pure (Right res)+ | True -> tryPointWise++ Just (Left nm') | nm == nm', let res = defaultKindedValue rt -> pure (Right ([], res))+ | True -> bad r Nothing++ Nothing -> tryPointWise++ _ -> bad r Nothing++-- | Generalization of 'Data.SBV.Control.checkSat'+checkSat :: (MonadIO m, MonadQuery m) => m CheckSatResult+checkSat = do cfg <- getConfig+ checkSatUsing $ satCmd cfg++-- | Generalization of 'Data.SBV.Control.checkSatUsing'+checkSatUsing :: (MonadIO m, MonadQuery m) => String -> m CheckSatResult+checkSatUsing cmd = do let bad = unexpected "checkSat" (T.pack cmd) "one of sat/unsat/unknown" Nothing++ -- Sigh.. Ignore some of the pesky warnings. We only do it as an exception here.+ ignoreList = ["WARNING: optimization with quantified constraints is not supported"]++ r <- askIgnoring (T.pack cmd) ignoreList++ -- query for the precision if supported+ let getPrecision = do cfg <- getConfig+ case supportsDeltaSat (capabilities (solver cfg)) of+ Nothing -> pure Nothing+ Just o -> Just <$> ask (T.pack o)++ parse r bad $ \case ECon "sat" -> pure Sat+ ECon "unsat" -> pure Unsat+ ECon "unknown" -> pure Unk+ ECon "delta-sat" -> DSat <$> getPrecision+ _ -> bad r Nothing++-- | What are the top level inputs? Trackers are returned as top level existentials+getTopLevelInputs :: (MonadIO m, MonadQuery m) => m UserInputs+getTopLevelInputs = do State{rinps} <- queryState+ Inputs{userInputs, internInputs} <- liftIO $ readIORef rinps++ pure $ userInputs <> internInputs++-- | Get observables, i.e., those explicitly labeled by the user with a call to 'Data.SBV.observe'.+getObservables :: (MonadIO m, MonadQuery m) => m [(Name, CV)]+getObservables = do State{rObservables} <- queryState++ rObs <- liftIO $ readIORef rObservables++ -- This intentionally reverses the result; since 'rObs' stores in reversed order+ let walk [] !sofar = pure sofar+ walk ((n, f, s):os) !sofar = do cv <- getValueCV Nothing s+ if f cv+ then walk os ((n, cv) : sofar)+ else walk os sofar++ walk (F.toList rObs) []++-- | Get UIs, both constants and functions. This call returns both the before and after query ones.+-- Generalization of 'Data.SBV.Control.getUIs'.+getUIs :: forall m. (MonadIO m, MonadQuery m) => m [(String, (Bool, Maybe [String], SBVType))]+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+ defineSet <- Map.keysSet <$> io (readIORef rDefns)++ prior <- io $ readIORef rUIMap+ new <- io $ readIORef rIncState >>= readIORef . rNewUIs+ pure $ Map.toList $ Map.withoutKeys (Map.union prior new) defineSet++-- | Return all satisfying models.+getAllSatResult :: forall m. (MonadIO m, MonadQuery m, SolverContext m) => m AllSatResult+getAllSatResult = do queryDebug ["*** Checking Satisfiability, all solutions.."]++ cfg <- getConfig+ unless (supportsCustomQueries (capabilities (solver cfg))) $+ error $ unlines [ ""+ , "*** Data.SBV: Backend solver " ++ show (name (solver cfg)) ++ " does not support custom queries."+ , "***"+ , "*** Custom query support is needed for allSat functionality."+ , "*** Please use a solver that supports this feature."+ ]++ topState@State{rUsedKinds, rPartitionVars, rProgInfo} <- queryState++ progInfo <- liftIO $ readIORef rProgInfo+ ki <- liftIO $ readIORef rUsedKinds++ allModelInputs <- getTopLevelInputs+ allUninterpreteds <- getUIs+ partitionVars <- liftIO $ readIORef rPartitionVars++ -- Functions have at least two kinds in their type and all components must be "interpreted"+ let allUiFuns = [u | allSatTrackUFs cfg -- config says consider UIFs+ , u@(nm, (_, _, SBVType as)) <- allUninterpreteds, length as > 1 -- get the function ones+ , not (mustIgnoreVar cfg (T.pack nm)) -- make sure they aren't explicitly ignored+ ]++ allUiRegs = [u | u@(nm, (_, _, SBVType as)) <- allUninterpreteds, length as == 1 -- non-function ones+ , not (mustIgnoreVar cfg (T.pack nm)) -- make sure they aren't explicitly ignored+ ]++ -- We can only "allSat" if all component types themselves are interpreted. (Otherwise+ -- there is no way to reflect back the values to the solver.)+ collectAcceptable [] sofar = pure sofar+ collectAcceptable ((nm, (_, _, t@(SBVType ats))):rest) sofar+ | not (any hasUninterpretedSorts ats)+ = collectAcceptable rest (nm : sofar)+ | True+ = do queryDebug [ "*** SBV.allSat: Uninterpreted function: " <> T.pack nm <> " :: " <> showText t+ , "*** Will *not* be used in allSat considerations since its type"+ , "*** has uninterpreted sorts present."+ ]+ collectAcceptable rest sofar++ uiFuns <- reverse <$> collectAcceptable allUiFuns []+ _ <- collectAcceptable allUiRegs [] -- only done to get the queryDebug output. Actual result not needed/used++ -- If there are uninterpreted functions, arrange so that z3's pretty-printer flattens things out+ -- as cex's tend to get larger+ unless (null uiFuns) $+ let solverCaps = capabilities (solver cfg)+ in F.for_ (supportsFlattenedModels solverCaps) (mapM_ (send True . T.pack))++ let usorts = [s | us@(KADT s _ _) <- Set.toAscList ki, isUninterpreted us]++ unless (null usorts) $ queryDebug [ "*** SBV.allSat: Uninterpreted sorts present: " <> T.pack (unwords usorts)+ , "*** SBV will use equivalence classes to generate all-satisfying instances."+ ]++ -- Drop the things that are not model vars or internal+ let mkSVal nm@(getSV -> sv) = (SVal (kindOf sv) (Right (cache (const (pure sv)))), nm)+ let extractVars :: S.Seq (SVal, NamedSymVar)+ extractVars = mkSVal <$> S.filter (not . mustIgnoreVar cfg . getUserName) allModelInputs++ vars :: S.Seq (SVal, NamedSymVar)+ vars = case partitionVars of+ [] -> extractVars+ pv -> mkSVal <$> S.filter (\k -> getUserName' k `elem` pv) allModelInputs++ -- We can go fast using the disjoint model trick if things are simple enough:+ -- - No uninterpreted functions (uninterpreted values are OK)+ -- - No uninterpreted sorts+ -- - No quantifiers+ --+ -- Why can't we support the above?+ -- - Uninterpreted functions: There is no (standard) way to define a function as a literal in SMTLib.+ -- Some solvers support lambda, but this isn't common/reliable yet.+ -- - Uninterpreted sort: There's no way to access the value the solver assigns to an uninterpreted sort.+ -- - Quantifiers: Too complicated!+ --+ -- So, if these two things are present, we go the "slow" route, by repeatedly rejecting the+ -- previous model and asking for a new one. If they don't exist (which is the common case anyhow)+ -- we use an idea due to z3 folks <http://theory.stanford.edu/%7Enikolaj/programmingz3.html#sec-blocking-evaluations>+ -- which splits the search space into disjoint models and can produce results much more quickly.+ let isSimple = null allUiFuns && null usorts && not (hasQuants progInfo)++ start = AllSatResult { allSatMaxModelCountReached = False+ , allSatSolverReturnedUnknown = False+ , allSatSolverReturnedDSat = False+ , allSatResults = []+ }++ -- partition-variables are only supported if simple+ case partitionVars of+ [] -> pure ()+ xs -> unless isSimple $ error $ unlines [ ""+ , "Data.SBV: Unsupported complex allSat call in the presence of partition-variables"+ , ""+ , "Partition variables are only supported when there are no uninterpreted"+ , "functions or uninterpreted sorts."+ , ""+ , "Saw parition vars: " ++ unwords xs+ ]++ if isSimple+ then do let mkVar :: (String, (Bool, Maybe [String], SBVType)) -> IO (SVal, NamedSymVar)+ mkVar (nm, (_, _, SBVType [k])) = do sv <- newExpr topState k (SBVApp (Uninterpreted (T.pack nm)) [])+ let sval = SVal k $ Right $ cache $ \_ -> pure sv+ nsv = NamedSymVar sv (T.pack nm)+ pure (sval, nsv)+ mkVar nmt = error $ "Data.SBV: Impossible happened; allSat.mkVar. Unexpected: " ++ show nmt+ uiVars <- io $ S.fromList <$> mapM mkVar allUiRegs+ fastAllSat allModelInputs (uiVars S.>< extractVars) (uiVars S.>< vars) cfg start+ else loop topState (allUiFuns, uiFuns) allUiRegs allModelInputs vars cfg start++ where finalize cnt cfg sofar extra+ = when (allSatPrintAlong cfg && not (null (allSatResults sofar))) $ do+ let msg 0 = "No solutions found."+ msg 1 = "This is the only solution."+ msg n = "Found " ++ show n ++ " different solutions."+ io . putStrLn $ msg (cnt - 1)+ case extra of+ Nothing -> pure ()+ Just m -> io $ putStrLn m++ fastAllSat :: S.Seq NamedSymVar -> S.Seq (SVal, NamedSymVar) -> S.Seq (SVal, NamedSymVar) -> SMTConfig -> AllSatResult -> m AllSatResult+ fastAllSat allInputs extractVars vars cfg start = do+ result <- io $ newIORef (0, start, False, Nothing)+ go result vars+ (found, sofar, _, extra) <- io $ readIORef result+ finalize (found+1) cfg sofar extra+ pure sofar++ where haveEnough have = case allSatMaxModelCount cfg of+ Just maxModels -> have >= maxModels+ _ -> False++ go :: IORef (Int, AllSatResult, Bool, Maybe String) -> S.Seq (SVal, NamedSymVar) -> m ()+ go finalResult = walk True+ where shouldContinue = do (have, _, exitLoop, _) <- io $ readIORef finalResult+ pure $ not (exitLoop || haveEnough have)++ walk :: Bool -> S.Seq (SVal, NamedSymVar) -> m ()+ walk firstRun terms+ | not firstRun && S.null terms+ = pure ()+ | True+ = do mbCont <- do (have, sofar, exitLoop, _) <- io $ readIORef finalResult+ if exitLoop+ then pure Nothing+ else case allSatMaxModelCount cfg of+ Just maxModels+ | have >= maxModels -> do unless (allSatMaxModelCountReached sofar) $ do+ queryDebug ["*** Maximum model count request of " <> showText maxModels <> " reached, stopping the search."]+ when (allSatPrintAlong cfg) $ io $ putStrLn "Search stopped since model count request was reached."+ io $ modifyIORef' finalResult $ \(h, s, _, m) -> (h, s{ allSatMaxModelCountReached = True }, True, m)+ pure Nothing+ _ -> pure $ Just $ have+1++ case mbCont of+ Nothing -> pure ()+ Just cnt -> do+ queryDebug ["Fast allSat, Looking for solution " <> showText cnt]++ cs <- checkSat++ case cs of+ Unsat -> pure ()++ Unk -> do queryDebug ["*** Solver returned unknown, terminating query."]+ io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedUnknown = True}, True, Just "[Solver returned unknown, terminating query.]")++ DSat _ -> do queryDebug ["*** Solver returned delta-sat, terminating query."]+ io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedDSat = True}, True, Just "[Solver returned delta-sat, terminating query.]")++ Sat -> do assocs <- mapM (\(sval, NamedSymVar sv n) -> do !cv <- getValueCV Nothing sv+ pure (sv, (n, (sval, cv)))) extractVars++ bindings <- let grab i@(getSV -> sv) = case lookupInput fst sv assocs of+ Just (_, (_, (_, cv))) -> pure (i, cv)+ Nothing -> do !cv <- getValueCV Nothing sv+ pure (i, cv)+ in if validationRequested cfg+ then Just <$> mapM grab allInputs+ else pure Nothing++ obsvs <- getObservables++ let lassocs = F.toList assocs+ model = SMTModel { modelObjectives = []+ , modelBindings = F.toList <$> bindings+ , modelAssocs = (first T.unpack <$> sortOn fst obsvs)+ <> [(T.unpack n, cv) | (_, (n, (_, cv))) <- lassocs]+ , modelUIFuns = []+ }+ currentResult = Satisfiable cfg model++ io $ modifyIORef' finalResult $ \(h, s, e, m) -> let h' = h+1 in h' `seq` (h', s{allSatResults = currentResult : allSatResults s}, e, m)++ when (allSatPrintAlong cfg) $ do+ io $ putStrLn $ "Solution #" ++ show cnt ++ ":"+ io $ putStrLn $ showModel cfg model++ let findVal :: (SVal, NamedSymVar) -> (SVal, CV)+ findVal (_, NamedSymVar sv nm) = case F.toList (S.filter (\(sv', _) -> sv == sv') assocs) of+ [(_, (_, scv))] -> scv+ _ -> error $ "Data.SBV: Cannot uniquely determine " ++ show nm ++ " in " ++ show assocs++ cstr :: Bool -> (SVal, CV) -> m ()+ cstr shouldReject (sv, cv) = constrain (SBV $ mkEq (kindOf sv) sv (SVal (kindOf sv) (Left cv)) :: SBool)+ where mkEq :: Kind -> SVal -> SVal -> SVal+ mkEq k a b+ | any isSomeKindOfFloat (expandKinds k)+ = if shouldReject+ then svNot (a `fpEq` b)+ else a `fpEq` b+ | True+ = if shouldReject+ then a `svNotEqual` b+ else a `svEqual` b++ fpEq a b = SVal KBool $ Right $ cache r+ where r st = do sva <- svToSV st a+ svb <- svToSV st b+ newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sva, svb])++ reject, accept :: (SVal, NamedSymVar) -> m ()+ reject = cstr True . findVal+ accept = cstr False . findVal++ scope :: (SVal, NamedSymVar) -> S.Seq (SVal, NamedSymVar) -> m () -> m ()+ scope cur pres c = do+ send True "(push 1)"+ reject cur+ mapM_ accept pres+ r <- c+ send True "(pop 1)"+ pure r++ F.for_ [0 .. length terms - 1] $ \i -> do+ sc <- shouldContinue+ when sc $ do case S.splitAt i terms of+ (pre, rest@(cur S.:<| _)) -> scope cur pre $ walk False rest+ _ -> error "Data.SBV.allSat: Impossible happened, ran out of terms!"++ -- All sat loop. This is slower, as it implements the reject-the-previous model and loop around logic. But+ -- it can handle uninterpreted sorts; so we keep it here as a fall-back.+ loop topState (allUiFuns, uiFunsToReject) allUiRegs allInputs vars cfg = go (1::Int)+ where go :: Int -> AllSatResult -> m AllSatResult+ go !cnt !sofar+ | Just maxModels <- allSatMaxModelCount cfg, cnt > maxModels+ = do queryDebug ["*** Maximum model count request of " <> showText maxModels <> " reached, stopping the search."]+ when (allSatPrintAlong cfg) $ io $ putStrLn "Search stopped since model count request was reached."+ pure $! sofar { allSatMaxModelCountReached = True }+ | True+ = do queryDebug ["Looking for solution " <> showText cnt]++ cs <- checkSat++ let endMsg = finalize cnt cfg sofar++ case cs of+ Unsat -> do endMsg Nothing+ pure sofar++ Unk -> do queryDebug ["*** Solver returned unknown, terminating query."]+ endMsg $ Just "[Solver returned unknown, terminating query.]"+ pure sofar{ allSatSolverReturnedUnknown = True }++ DSat _ -> do queryDebug ["*** Solver returned delta-sat, terminating query."]+ endMsg $ Just "[Solver returned delta-sat, terminating query.]"+ pure sofar{ allSatSolverReturnedDSat = True }++ Sat -> do assocs <- mapM (\(sval, NamedSymVar sv n) -> do !cv <- getValueCV Nothing sv+ pure (sv, (n, (sval, cv)))) vars++ let getUIFun ui@(nm, (isCurried, _, t)) = do cvs <- getUIFunCVAssoc Nothing ui+ pure (nm, (isCurried, t, cvs))+ uiFunVals <- mapM getUIFun allUiFuns++ uiRegVals <- mapM (\ui@(nm, _) -> (nm,) <$> getUICVal Nothing ui) allUiRegs++ obsvs <- getObservables++ bindings <- let grab i@(getSV -> sv) = case lookupInput fst sv assocs of+ Just (_, (_, (_, cv))) -> pure (i, cv)+ Nothing -> do !cv <- getValueCV Nothing sv+ pure (i, cv)+ in if validationRequested cfg+ then Just <$> mapM grab allInputs+ else pure Nothing++ let model = SMTModel { modelObjectives = []+ , modelBindings = F.toList <$> bindings+ , modelAssocs = uiRegVals+ <> (first T.unpack <$> sortOn fst obsvs)+ <> [(T.unpack n, cv) | (_, (n, (_, cv))) <- F.toList assocs]+ , modelUIFuns = uiFunVals+ }+ m = Satisfiable cfg model++ (interpreteds, uninterpreteds) = S.partition (not . isUninterpreted . kindOf . fst) (snd . snd <$> assocs)++ interpretedRegUis = filter (not . isUninterpreted . kindOf . snd) uiRegVals++ interpretedRegUiSVs = [(cvt n (kindOf cv), cv) | (n, cv) <- interpretedRegUis]+ where cvt :: String -> Kind -> SVal+ cvt nm k = SVal k $ Right $ cache r+ where r st = newExpr st k (SBVApp (Uninterpreted (T.pack nm)) [])++ -- For each interpreted variable, figure out the model equivalence+ -- NB. When the kind is floating, we *have* to be careful, since +/- zero, and NaN's+ -- and equality don't get along!+ interpretedEqs :: [SVal]+ interpretedEqs = [mkNotEq (kindOf sv) sv (SVal (kindOf sv) (Left cv)) | (sv, cv) <- interpretedRegUiSVs <> F.toList interpreteds]+ where mkNotEq k a b+ | isDouble k || isFloat k || isFP k+ = svNot (a `fpEq` b)+ | True+ = a `svNotEqual` b++ fpEq a b = SVal KBool $ Right $ cache r+ where r st = do sva <- svToSV st a+ svb <- svToSV st b+ newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sva, svb])++ -- For each uninterpreted constant, use equivalence class+ uninterpretedEqs :: [SVal]+ uninterpretedEqs = concatMap pwDistinct -- Assert that they are pairwise distinct+ . filter (\l -> length l > 1) -- Only need this class if it has at least two members+ . map (map fst) -- throw away values, we only need svals+ . groupBy ((==) `on` snd) -- make sure they belong to the same sort and have the same value+ . sortOn snd -- sort them according to their CV (i.e., sort/value)+ $ F.toList uninterpreteds+ where pwDistinct :: [SVal] -> [SVal]+ pwDistinct ss = [x `svNotEqual` y | (x:ys) <- tails ss, y <- ys]++ -- For each uninterpreted function, create a disqualifying equation+ -- We do this rather brute-force, since we need to create a new function+ -- and do an existential assertion.+ uninterpretedReject :: Maybe [T.Text]+ uninterpretedFuns :: [T.Text]+ (uninterpretedReject, uninterpretedFuns) = (uiReject, concat defs)+ where uiReject = case rejects of+ [] -> Nothing+ xs -> Just xs++ (rejects, defs) = unzip [mkNotEq ui | ui@(nm, _) <- uiFunVals, nm `elem` uiFunsToReject]++ -- Otherwise, we have things to refute, go for it if we have a good interpretation for it+ mkNotEq (nm, (_, typ, Left def)) =+ error $ unlines [+ ""+ , "*** allSat: Unsupported: Building a rejecting instance for:"+ , "***"+ , "*** " ++ nm ++ " :: " ++ show typ+ , "*** " ++ def+ , "***"+ , "*** At this time, SBV cannot compute allSat when the model has a non-table definition."+ , "***"+ , "*** You can ignore specific functions via the 'isNonModelVar' filter:"+ , "***"+ , "*** allSatWith z3{isNonModelVar = (`elem` [" ++ show nm ++ "])} ..."+ , "***"+ , "*** Or you can ignore all uninterpreted functions for all-sat purposes using the 'allSatTrackUFs' parameter:"+ , "***"+ , "*** allSatWith z3{allSatTrackUFs = False} ..."+ , "***"+ , "*** You can see the response from the solver by running with the '{verbose = True}' option."+ , "***"+ , "*** NB. If this is a use case you'd like SBV to support, please get in touch!"+ ]+ mkNotEq (nm, (_, SBVType ts, Right vs)) = (reject, def ++ dif)+ where nm' = T.pack nm <> "_model" <> showText cnt++ reject = nm' <> "_reject"++ -- convert a constant+ scv = cvToSMTLib++ (ats, rt) = (init ts, last ts)++ args = T.unwords ["(x!" <> showText i <> " " <> smtType t <> ")" | (t, i) <- zip ats [(0::Int)..]]+ res = smtType rt++ params = ["x!" <> showText i | (_, i) <- zip ats [(0::Int)..]]++ uparams = T.unwords params++ chain (vals, fallThru) = walk vals+ where walk [] = [" " <> scv fallThru <> T.replicate (length vals) ")"]+ walk ((as, r) : rest) = (" (ite " <> cond as <> " " <> scv r) : walk rest++ cond as = "(and " <> T.unwords (zipWith eq params as) <> ")"+ eq p a = "(= " <> p <> " " <> scv a <> ")"++ def = ("(define-fun " <> nm' <> " (" <> args <> ") " <> res)+ : chain vs+ ++ [")"]++ pad = T.replicate (1 + T.length nm' - length nm) " "++ dif = [ "(define-fun " <> reject <> " () Bool"+ , " (exists (" <> args <> ")"+ , " (distinct (" <> T.pack nm <> pad <> uparams <> ")"+ , " (" <> nm' <> " " <> uparams <> "))))"+ ]++ eqs = interpretedEqs ++ uninterpretedEqs++ disallow = case eqs of+ [] -> Nothing+ _ -> Just $ SBV $ foldr1 svOr eqs++ when (allSatPrintAlong cfg) $ do+ io $ putStrLn $ "Solution #" ++ show cnt ++ ":"+ io $ putStrLn $ showModel cfg model++ let resultsSoFar = sofar { allSatResults = m : allSatResults sofar }++ -- This is clunky, but let's not generate a rejector unless we really need it+ needMoreIterations+ | Just maxModels <- allSatMaxModelCount cfg, (cnt+1) > maxModels = False+ | True = True++ -- Send function disequalities, if any:+ if not needMoreIterations+ then go (cnt+1) resultsSoFar+ else do let uiFunRejector = "uiFunRejector_model_" ++ show cnt+ header = "define-fun " ++ uiFunRejector ++ " () Bool "++ defineRejector [] = pure ()+ defineRejector [x] = send True $ "(" <> T.pack header <> x <> ")"+ defineRejector (x:xs) = mapM_ (send True) $ mergeSExpr+ $ T.pack ("(" ++ header)+ : (" (or " <> x)+ : [" " <> e | e <- xs]+ ++ [" ))"]+ rejectFuncs <- case uninterpretedReject of+ Nothing -> pure Nothing+ Just fs -> do mapM_ (send True) $ mergeSExpr uninterpretedFuns+ defineRejector fs+ pure $ Just uiFunRejector++ -- send the disallow clause and the uninterpreted rejector:+ case (disallow, rejectFuncs) of+ (Nothing, Nothing) -> pure resultsSoFar+ (Just d, Nothing) -> do constrain d+ go (cnt+1) resultsSoFar+ (Nothing, Just f) -> do send True $ "(assert " <> T.pack f <> ")"+ go (cnt+1) resultsSoFar+ (Just d, Just f) -> -- This is where it gets ugly. We have an SBV and a string and we need to "or" them.+ -- But we need a way to force 'd' to be produced. So, go ahead and force it:+ do constrain $ d .=> d -- NB: Redundant, but it makes sure the corresponding constraint gets shown+ svd <- io $ svToSV topState (unSBV d)+ send True $ "(assert (or " <> T.pack f <> " " <> showText svd <> "))"+ go (cnt+1) resultsSoFar++-- | Generalization of 'Data.SBV.Control.getUnsatAssumptions'+getUnsatAssumptions :: (MonadIO m, MonadQuery m) => [String] -> [(String, a)] -> m [a]+getUnsatAssumptions originals proxyMap = do+ let cmd = "(get-unsat-assumptions)" :: T.Text++ bad = unexpected "getUnsatAssumptions" cmd "a list of unsatisfiable assumptions"+ $ Just [ "Make sure you use:"+ , ""+ , " setOption $ ProduceUnsatAssumptions True"+ , ""+ , "to make sure the solver is ready for producing unsat assumptions,"+ , "and that there is a model by first issuing a 'checkSat' call."+ ]++ fromECon (ECon s) = Just s+ fromECon _ = Nothing++ r <- ask cmd++ -- If unsat-cores are enabled, z3 might end-up printing an assumption that wasn't+ -- in the original list of assumptions for `check-sat-assuming`. So, we walk over+ -- and ignore those that weren't in the original list, and put a warning for those+ -- we couldn't find.+ let walk [] sofar = pure $ reverse sofar+ walk (a:as) sofar = case a `lookup` proxyMap of+ Just v -> walk as (v:sofar)+ Nothing -> do queryDebug [ "*** In call to 'getUnsatAssumptions'"+ , "***"+ , "*** Unexpected assumption named: " <> showText a+ , "*** Was expecting one of : " <> showText originals+ , "***"+ , "*** This can happen if unsat-cores are also enabled. Ignoring."+ ]+ walk as sofar++ parse r bad $ \case+ EApp es | Just xs <- mapM fromECon es -> walk xs []+ _ -> bad r Nothing++-- | Timeout a query action, typically a command call to the underlying SMT solver.+-- The duration is in microseconds (@1\/10^6@ seconds). If the duration+-- is negative, then no timeout is imposed. When specifying long timeouts, be careful not to exceed+-- @maxBound :: Int@. (On a 64 bit machine, this bound is practically infinite. But on a 32 bit+-- machine, it corresponds to about 36 minutes!)+--+-- Semantics: The call @timeout n q@ causes the timeout value to be applied to all interactive calls that take place+-- as we execute the query @q@. That is, each call that happens during the execution of @q@ gets a separate+-- time-out value, as opposed to one timeout value that limits the whole query. This is typically the intended behavior.+-- It is advisable to apply this combinator to calls that involve a single call to the solver for+-- finer control, as opposed to an entire set of interactions. However, different use cases might call for different scenarios.+--+-- If the solver responds within the time-out specified, then we continue as usual. However, if the backend solver times-out+-- using this mechanism, there is no telling what the state of the solver will be. Thus, we raise an error in this case.+timeout :: (MonadIO m, MonadQuery m) => Int -> m a -> m a+timeout n q = do modifyQueryState (\qs -> qs {queryTimeOutValue = Just n})+ r <- q+ modifyQueryState (\qs -> qs {queryTimeOutValue = Nothing})+ pure r++-- | Bail out if a parse goes bad+parse :: String -> (String -> Maybe [String] -> a) -> (SExpr -> a) -> a+parse r fCont sCont = case parseSExpr r of+ Left e -> fCont r (Just [e])+ Right res -> sCont res++-- | Generalization of 'Data.SBV.Control.unexpected'+unexpected :: (MonadIO m, MonadQuery m) => String -> T.Text -> String -> Maybe [String] -> String -> Maybe [String] -> m a+unexpected ctx sent expected mbHint received mbReason = do+ -- empty the response channel first+ extras <- retrieveResponse "terminating upon unexpected response" (Just 5000000)++ cfg <- getConfig++ let exc = SBVException { sbvExceptionDescription = "Unexpected response from the solver, context: " ++ ctx+ , sbvExceptionSent = Just (T.unpack sent)+ , sbvExceptionExpected = Just expected+ , sbvExceptionReceived = Just received+ , sbvExceptionStdOut = Just $ unlines extras+ , sbvExceptionStdErr = Nothing+ , sbvExceptionExitCode = Nothing+ , sbvExceptionConfig = cfg+ , sbvExceptionReason = mbReason+ , sbvExceptionHint = mbHint+ }++ io $ C.throwIO exc++-- | Convert a query result to an SMT Problem+runProofOn :: SBVRunMode -> QueryContext -> [String] -> Result -> SMTProblem+runProofOn rm context comments res@(Result progInfo ki _qcInfo _observables _codeSegs is consts tbls uis defns pgm cstrs _assertions outputs) =+ let (config, isSat, isSafe, isSetup) = case rm of+ SMTMode _ stage s c -> (c, s, isSafetyCheckingIStage stage, isSetupIStage stage)+ _ -> error $ "runProofOn: Unexpected run mode: " ++ show rm++ o | isSafe = trueSV+ | True = case outputs of+ [] | isSetup -> trueSV+ [so] -> case so of+ SV KBool _ -> so+ _ -> error $ unlines [ "Impossible happened, non-boolean output: " ++ show so+ , "Detected while generating the trace:\n" ++ show res+ ]+ os -> error $ unlines [ "User error: Multiple output values detected: " ++ show os+ , "Detected while generating the trace:\n" ++ show res+ , "*** Check calls to \"output\", they are typically not needed!"+ ]++ in SMTProblem { smtLibPgm = toSMTLib config context progInfo ki isSat comments is consts tbls uis defns pgm cstrs o }++-- | Generalization of 'Data.SBV.Control.executeQuery'+executeQuery :: forall m a. ExtractIO m => QueryContext -> QueryT m a -> SymbolicT m a+executeQuery queryContext originalQuery = do+ st <- symbolicEnv+ rm <- liftIO $ readIORef (runMode st)++ -- Make sure the phases match:+ () <- liftIO $ case (queryContext, rm) of+ (QueryInternal, _) -> pure () -- no worries, internal+ (QueryExternal, SMTMode QueryExternal ISetup _ _) -> pure () -- legitimate runSMT call+ _ -> invalidQuery rm++ case rm of+ -- Transitioning from setup+ SMTMode qc stage isSAT cfg | not (isRunIStage stage) -> do++ let slvr = solver cfg+ backend = engine slvr++ -- make sure if we have dsat precision, then solver supports it+ let dsatOK = isNothing (dsatPrecision cfg)+ || isJust (supportsDeltaSat (capabilities slvr))++ unless dsatOK $ error $ unlines+ [ ""+ , "*** Data.SBV: Delta-sat precision is specified."+ , "*** But the chosen solver (" ++ show (name slvr) ++ ") does not support"+ , "*** delta-satisfiability."+ ]++ res <- liftIO $ extractSymbolicSimulationState st+ setOpts <- liftIO $ reverse <$> readIORef (rSMTOptions st)++ -- Run any registered measure checks (termination/productivity verification)+ liftIO $ do skip <- readIORef (rSkipMeasureChecks st)+ unless skip $ do+ checks <- readIORef (rMeasureChecks st)+ unless (null checks) $ do+ let nms = map (\(n, _, _) -> n) checks+ debug cfg ["[MEASURE] Verifying termination measures for: " <> T.pack (intercalate ", " nms)]+ mapM_ (\(nm, isProductive, check) -> do+ debug cfg ["[MEASURE] Checking: " <> T.pack nm]+ check cfg+ let tag = if isProductive then "productive" else "terminating"+ debug cfg ["[MEASURE] Passed (" <> tag <> "): " <> T.pack nm]+ ) checks++ let SMTProblem{smtLibPgm} = runProofOn rm queryContext [] res+ cfg' = cfg { solverSetOptions = solverSetOptions cfg ++ setOpts }+ pgm = smtLibPgm cfg'++ liftIO $ writeIORef (runMode st) $ SMTMode qc IRun isSAT cfg++ let terminateSolver maybeForwardedException = do+ qs <- readIORef $ rQueryState st+ case qs of+ Nothing -> pure ()+ Just QueryState{queryTerminate} -> queryTerminate maybeForwardedException++ -- If this is an external query and there are objectives, let's add those to the list before we run+ -- Here we only allow Lexicographic; we might want to make that configurable later.+ let userQuery = case queryContext of+ QueryInternal -> originalQuery+ QueryExternal -> do mbDirs <- startOptimizer cfg Lexicographic+ case mbDirs of+ Nothing -> pure ()+ Just (_, cmds) -> mapM_ (send True . T.pack) cmds+ originalQuery++ lift $ join $ liftIO $ C.mask $ \restore -> do+ r <- restore (extractIO $ join $ liftIO $ backend cfg' st (smtLibPgmText pgm) $ extractIO . runReaderT (runQueryT userQuery))+ `C.catch` \e -> terminateSolver (Just e) >> C.throwIO (e :: C.SomeException)+ terminateSolver Nothing+ pure r++ -- Already in a query, in theory we can just continue, but that causes use-case issues+ -- so we reject it. TODO: Review if we should actually support this. The issue arises with+ -- expressions like this:+ --+ -- In the following t0's output doesn't get recorded, as the output call is too late when we get+ -- here. (The output field isn't "incremental.") So, t0/t1 behave differently!+ --+ -- t0 = satWith z3{verbose=True, transcript=Just "t.smt2"} $ query (return (false::SBool))+ -- t1 = satWith z3{verbose=True, transcript=Just "t.smt2"} $ ((return (false::SBool)) :: Predicate)+ --+ -- Also, not at all clear what it means to go in an out of query mode:+ --+ -- r = runSMTWith z3{verbose=True} $ do+ -- a' <- sInteger "a"+ --+ -- (a, av) <- query $ do _ <- checkSat+ -- av <- getValue a'+ -- return (a', av)+ --+ -- liftIO $ putStrLn $ "Got: " ++ show av+ -- -- constrain $ a .> literal av + 1 -- Can't do this since we're "out" of query. Sigh.+ --+ -- bv <- query $ do constrain $ a .> literal av + 1+ -- _ <- checkSat+ -- getValue a+ --+ -- return $ a' .== a' + 1+ --+ -- This would be one possible implementation, alas it has the problems above:+ --+ -- SMTMode IRun _ _ -> liftIO $ evalStateT userQuery st+ --+ -- So, we just reject it.++ SMTMode _ IRun _ _ -> error $ unlines [ ""+ , "*** Data.SBV: Unsupported nested query is detected."+ , "***"+ , "*** Please group your queries into one block. Note that this"+ , "*** can also arise if you have a call to 'query' not within 'runSMT'"+ , "*** For instance, within 'sat'/'prove' calls with custom user queries."+ , "*** The solution is to do the sat/prove part in the query directly."+ , "***"+ , "*** While multiple/nested queries should not be necessary in general,"+ , "*** please do get in touch if your use case does require such a feature,"+ , "*** to see how we can accommodate such scenarios."+ ]++ -- Otherwise choke!+ _ -> invalidQuery rm++ where invalidQuery rm = error $ unlines [ ""+ , "*** Data.SBV: Invalid query call."+ , "***"+ , "*** Current mode: " ++ show rm+ , "***"+ , "*** Query calls are only valid within runSMT/runSMTWith calls,"+ , "*** and each call to runSMT should have only one query call inside."+ ]++-- | Preparing for optimization. If we have objectives, returns the directives for the solver. If not, it returns nothing.+startOptimizer :: (MonadIO m, MonadQuery m) => SMTConfig -> OptimizeStyle -> m (Maybe ([Objective (SV, SV)], [String]))+startOptimizer config style = do+ objectives <- getObjectives++ if null objectives+ then pure Nothing+ else do unless (supportsOptimization (capabilities (solver config))) $+ error $ unlines [ ""+ , "*** Data.SBV: The backend solver " ++ show (name (solver config)) ++ "does not support optimization goals."+ , "*** Please use a solver that has support, such as z3"+ ]++ when (validateModel config && not (optimizeValidateConstraints config)) $+ error $ unlines [ ""+ , "*** Data.SBV: Model validation is not supported in optimization calls."+ , "***"+ , "*** Instead, use `cfg{optimizeValidateConstraints = True}`"+ , "***"+ , "*** which checks that the results satisfy the constraints but does"+ , "*** NOT ensure that they are optimal."+ ]+++ let optimizerDirectives = concatMap minmax objectives ++ priority style+ where mkEq (x, y) = "(assert (= " ++ show x ++ " " ++ show y ++ "))"++ minmax (Minimize _ xy@(_, v)) = [mkEq xy, "(minimize " ++ show v ++ ")"]+ minmax (Maximize _ xy@(_, v)) = [mkEq xy, "(maximize " ++ show v ++ ")"]+ minmax (AssertWithPenalty nm xy@(_, v) mbp) = [mkEq xy, "(assert-soft " ++ show v ++ penalize mbp ++ ")"]+ where penalize DefaultPenalty = ""+ penalize (Penalty w mbGrp)+ | w <= 0 = error $ unlines [ "SBV.AssertWithPenalty: Goal " ++ show nm ++ " is assigned a non-positive penalty: " ++ shw+ , "All soft goals must have > 0 penalties associated."+ ]+ | True = " :weight " ++ shw ++ maybe "" group mbGrp+ where shw = show (fromRational w :: Double)++ group g = " :id " ++ g++ priority Lexicographic = [] -- default, no option needed+ priority Independent = ["(set-option :opt.priority box)"]+ priority (Pareto _) = ["(set-option :opt.priority pareto)"]++ pure $ Just (objectives, optimizerDirectives)++-- | Just after a check-sat is issued, collect objective values. Used+-- internally only, not exposed to the user.+getObjectiveValues :: forall m. (MonadIO m, MonadQuery m) => m [(String, GeneralizedCV)]+getObjectiveValues = do let cmd = "(get-objectives)" :: T.Text++ bad = unexpected "getObjectiveValues" cmd "a list of objective values" Nothing++ r <- ask cmd++ si <- queryState >>= getSInfo++ inputs <- F.toList <$> getTopLevelInputs++ parse r bad $ \case EApp (ECon "objectives" : es) -> catMaybes <$> mapM (getObjValue si (bad r) inputs) es+ _ -> bad r Nothing++ where -- | Parse an objective value out.+ getObjValue :: SInfo -> (forall a. Maybe [String] -> m a) -> [NamedSymVar] -> SExpr -> m (Maybe (String, GeneralizedCV))+ getObjValue si bailOut inputs expr =+ case expr of+ EApp [_] -> pure Nothing -- Happens when a soft-assertion has no associated group.+ EApp [ECon nm, v] -> locate nm v -- Regular case+ _ -> dontUnderstand (show expr)++ where locate nm v = case listToMaybe [p | p@(NamedSymVar sv _) <- inputs, show sv == nm] of+ Nothing -> pure Nothing -- Happens when the soft assertion has a group-id that's not one of the input names+ Just (NamedSymVar sv actualName) -> grab sv v >>= \val -> pure $ Just (T.unpack actualName, val)++ dontUnderstand s = bailOut $ Just [ "Unable to understand solver output."+ , "While trying to process: " ++ s+ ]++ grab :: SV -> SExpr -> m GeneralizedCV+ grab s topExpr+ | Just v <- recoverKindedValue si k topExpr = pure $ RegularCV v+ | True = ExtendedCV <$> cvt (simplify topExpr)+ where k = kindOf s++ -- Convert to an extended expression. Hopefully complete!+ cvt :: SExpr -> m ExtCV+ cvt (ECon "oo") = pure $ Infinite k+ cvt (ECon "epsilon") = pure $ Epsilon k+ cvt (EApp [ECon "interval", x, y]) = Interval <$> cvt x <*> cvt y+ cvt (ENum (i, _, _)) = pure $ BoundedCV $ mkConstCV k i+ cvt (EReal r) = pure $ BoundedCV $ CV k $ CAlgReal r+ cvt (EFloat f) = pure $ BoundedCV $ CV k $ CFloat f+ cvt (EDouble d) = pure $ BoundedCV $ CV k $ CDouble d+ cvt (EApp [ECon "+", x, y]) = AddExtCV <$> cvt x <*> cvt y+ cvt (EApp [ECon "*", x, y]) = MulExtCV <$> cvt x <*> cvt y+ -- Nothing else should show up, hopefully!+ cvt e = dontUnderstand (show e)++ -- drop the pesky to_real's that Z3 produces.. Cool but useless.+ simplify :: SExpr -> SExpr+ simplify (EApp [ECon "to_real", n]) = n+ simplify (EApp xs) = EApp (map simplify xs)+ simplify e = e++-- | Generalization of 'Data.SBV.Control.getModel'+getModel :: (MonadIO m, MonadQuery m) => m SMTModel+getModel = getModelAtIndex Nothing++-- | Get a model stored at an index. This is likely very Z3 specific!+getModelAtIndex :: (MonadIO m, MonadQuery m) => Maybe Int -> m SMTModel+getModelAtIndex mbi = do+ State{runMode} <- queryState+ rm <- io $ readIORef runMode+ case rm of+ m@CodeGen -> error $ "SBV.getModel: Model is not available in mode: " ++ show m+ m@LambdaGen{} -> error $ "SBV.getModel: Model is not available in mode: " ++ show m+ m@Concrete{} -> error $ "SBV.getModel: Model is not available in mode: " ++ show m+ SMTMode{} -> do+ cfg <- getConfig+ uis <- getUIs++ allModelInputs <- getTopLevelInputs+ obsvs <- getObservables++ inputAssocs <- let grab (NamedSymVar sv nm) = let wrap !c = (sv, (nm, c)) in wrap <$> getValueCV mbi sv+ in mapM grab allModelInputs++ let name = fst . snd+ removeSV = snd+ prepare = S.unstableSort . S.filter (not . mustIgnoreVar cfg . name)+ assocs = (removeSV <$> prepare inputAssocs) <> S.fromList (sortOn fst obsvs)++ -- collect UIs, and UI functions if requested+ let uiFuns = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as > 1, allSatTrackUFs cfg, not (mustIgnoreVar cfg (T.pack nm))] -- functions have at least two things in their type!+ uiRegs = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as == 1, not (mustIgnoreVar cfg (T.pack nm))]++ -- If there are uninterpreted functions, arrange so that z3's pretty-printer flattens things out+ -- as cex's tend to get larger+ unless (null uiFuns) $+ let solverCaps = capabilities (solver cfg)+ in F.for_ (supportsFlattenedModels solverCaps) (mapM_ (send True . T.pack))++ bindings <- let get i@(getSV -> sv) = case lookupInput fst sv inputAssocs of+ Just (_, (_, cv)) -> pure (i, cv)+ Nothing -> do cv <- getValueCV mbi sv+ pure (i, cv)++ in if validationRequested cfg+ then Just <$> mapM get allModelInputs+ else pure Nothing++ uiFunVals <- mapM (\ui@(nm, (c, _, t)) -> (\a -> (nm, (c, t, a))) <$> getUIFunCVAssoc mbi ui) uiFuns++ uiVals <- mapM (\ui@(nm, (_, _, _)) -> (nm,) <$> getUICVal mbi ui) uiRegs++ pure $ unBarModel $ SMTModel { modelObjectives = []+ , modelBindings = F.toList <$> bindings+ , modelAssocs = uiVals ++ F.toList (first T.unpack <$> assocs)+ , modelUIFuns = uiFunVals+ }++-- | Remove the bars from model names; these are (mostly!) automatically inserted+unBarModel :: SMTModel -> SMTModel+unBarModel SMTModel {modelObjectives, modelBindings, modelAssocs, modelUIFuns}+ = SMTModel { modelObjectives = ubf <$> modelObjectives+ , modelBindings = (ubn <$>) <$> modelBindings+ , modelAssocs = ubf <$> modelAssocs+ , modelUIFuns = ubf <$> modelUIFuns+ }+ where ubf (n, a) = (unBar n, a)+ ubn (NamedSymVar sv nm, a) = (NamedSymVar sv (unBarT nm), a)++ unBarT t = case T.uncons t of+ Just ('|', rest) | not (T.null rest) && T.last rest == '|' -> T.init rest+ _ -> t++{- HLint ignore module "Reduce duplication" -}+{- HLint ignore getAllSatResult "Use forM_" -}+{- HLint ignore getModelAtIndex "Use forM_" -}
Data/SBV/Core/AlgReals.hs view
@@ -9,9 +9,13 @@ -- Algebraic reals in Haskell. ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.AlgReals ( AlgReal(..)@@ -29,20 +33,26 @@ ) where +import Control.DeepSeq (NFData) 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(..)) import Numeric (readSigned, readFloat) +import Text.Read(readMaybe)++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 | ClosedPoint a -- ^ closed: i.e., includes the point- deriving (Show, Eq, Ord)+ deriving (Show, Eq, Ord, G.Data, NFData, Generic) -- | Extract the point associated with the open-closed point realPoint :: RealPoint a -> a@@ -55,6 +65,7 @@ data AlgReal = AlgRational Bool Rational -- ^ bool says it's exact (i.e., SMT-solver did not return it with ? at the end.) | AlgPolyRoot (Integer, AlgRealPoly) (Maybe String) -- ^ which root of this polynomial and an approximate decimal representation with given precision, if available | AlgInterval (RealPoint Rational) (RealPoint Rational) -- ^ interval, with low and high bounds+ deriving (G.Data, Generic, NFData) -- | Check whether a given argument is an exact rational isExactRational :: AlgReal -> Bool@@ -65,7 +76,7 @@ -- coefficient list. For instance, "5x^3 + 2x - 5" is -- represented as [(5, 3), (2, 1), (-5, 0)] newtype AlgRealPoly = AlgRealPoly [(Integer, Integer)]- deriving (Eq, Ord)+ deriving (Eq, Ord, G.Data, NFData, Generic) -- | Construct a poly-root real with a given approximate value (either as a decimal, or polynomial-root) mkPolyReal :: Either (Bool, String) (Integer, [(Integer, Integer)]) -> AlgReal@@ -74,12 +85,16 @@ ("", _) -> AlgRational exact 0 (_, (x, '.':y)) | all isDigit (x ++ y) -> AlgRational exact (read (x++y) % (10 ^ length y)) (_, (x, "")) | all isDigit x -> AlgRational exact (read x % 1)- _ -> error $ unlines [ "*** Data.SBV.mkPolyReal: Unable to read a number from:"- , "***"- , "*** " ++ str- , "***"- , "*** Please report this as a bug."- ]+ _ ->+ -- CVC5 prints in division-rational form:+ case readMaybe (filter (/= ',') (map (\c -> if c == '/' then '%' else c) str)) :: Maybe Rational of+ Just r -> AlgRational exact r+ Nothing -> error $ unlines [ "*** Data.SBV.mkPolyReal: Unable to read a number from:"+ , "***"+ , "*** " ++ str+ , "***"+ , "*** Please report this as a bug."+ ] mkPolyReal (Right (k, coeffs)) = AlgPolyRoot (k, AlgRealPoly (normalize coeffs)) Nothing where normalize :: [(Integer, Integer)] -> [(Integer, Integer)]@@ -87,12 +102,15 @@ merge [] = [] merge [x] = [x] merge ((a, b):r@((c, d):xs))- | b == d = merge ((a+c, b):xs)+ | b == d = let !s = a+c in merge ((s, b):xs) | True = (a, b) : merge r instance Show AlgRealPoly where show (AlgRealPoly xs) = chkEmpty (join (concat [term p | p@(_, x) <- xs, x /= 0])) ++ " = " ++ show c- where c = -1 * head ([k | (k, 0) <- xs] ++ [0])+ where c = case [k | (k, 0) <- xs] of+ h:_ -> -h+ _ -> 0+ term ( 0, _) = [] term ( 1, 1) = [ "x"] term ( 1, p) = [ "x^" ++ show p]@@ -112,8 +130,8 @@ instance Show AlgReal where show (AlgRational exact a) = showRat exact a show (AlgPolyRoot (i, p) mbApprox) = "root(" ++ show i ++ ", " ++ show p ++ ")" ++ maybe "" app mbApprox- where app v | last v == '?' = " = " ++ init v ++ "..."- | True = " = " ++ v+ where app v | not (null v) && last v == '?' = " = " ++ init v ++ "..."+ | True = " = " ++ v show (AlgInterval a b) = case (a, b) of (OpenPoint l, OpenPoint h) -> "(" ++ show l ++ ", " ++ show h ++ ")" (OpenPoint l, ClosedPoint h) -> "(" ++ show l ++ ", " ++ show h ++ "]"@@ -179,6 +197,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 denominator instance Random Rational where random g = (a % b', g'') where (a, g') = random g@@ -193,11 +212,28 @@ 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 algRealToSMTLib2 (AlgRational True r)@@ -313,4 +349,4 @@ -- Quickcheck instance instance Arbitrary AlgReal where- arbitrary = AlgRational True `fmap` arbitrary+ arbitrary = AlgRational True <$> arbitrary
Data/SBV/Core/Concrete.hs view
@@ -9,23 +9,26 @@ -- Operations on concrete values ----------------------------------------------------------------------------- +{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE Rank2Types #-} {-# OPTIONS_GHC -Wall -Werror #-} -module Data.SBV.Core.Concrete- ( module Data.SBV.Core.Concrete- ) where+module Data.SBV.Core.Concrete where import Control.Monad (replicateM) +import Control.DeepSeq (NFData)+ import Data.Bits import System.Random (randomIO, randomRIO) import Data.Char (chr, isSpace)-import Data.List (isPrefixOf, intercalate)+import Data.List (intercalate)+import qualified Data.Text as T import Data.SBV.Core.Kind import Data.SBV.Core.AlgReals@@ -38,10 +41,22 @@ import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Generics as G++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@@ -70,22 +85,36 @@ instance HasKind a => HasKind (RCSet a) where kindOf _ = KSet (kindOf (Proxy @a)) --- | A constant value-data CVal = CAlgReal !AlgReal -- ^ Algebraic real- | CInteger !Integer -- ^ Bit-vector/unbounded integer- | CFloat !Float -- ^ Float- | CDouble !Double -- ^ Double- | CFP !FP -- ^ Arbitrary float- | CRational Rational -- ^ Rational- | CChar !Char -- ^ Character- | CString !String -- ^ String- | CList ![CVal] -- ^ List- | CSet !(RCSet CVal) -- ^ Set. Can be regular or complemented.- | CUserSort !(Maybe Int, String) -- ^ Value of an uninterpreted/user kind. The Maybe Int shows index position for enumerations- | CTuple ![CVal] -- ^ Tuple- | CMaybe !(Maybe CVal) -- ^ Maybe- | CEither !(Either CVal CVal) -- ^ Disjoint union+-- | Underlying type for SMTLib arrays, as a list of key-value pairs, with a default for unmapped+-- elements. Note that this type matches the typical models returned by SMT-solvers.+-- When we store the array, we do not bother removing earlier writes, so there might be duplicates.+-- That is, we store the history of the writes. The earlier a pair is in the list, the "later" it+-- is done, i.e., it takes precedence over the latter entries.+data ArrayModel a b = ArrayModel [(a, b)] b+ deriving (G.Data, Generic, NFData, Show) +-- | The kind of an ArrayModel+instance (HasKind a, HasKind b) => HasKind (ArrayModel a b) where+ kindOf _ = KArray (kindOf (Proxy @a)) (kindOf (Proxy @b))++-- | A constant value.+-- Note: If you add a new constructor here, make sure you add the+-- corresponding equality in the instance "Eq CVal" and "Ord CVal"!+data CVal = CAlgReal !AlgReal -- ^ Algebraic real+ | CInteger !Integer -- ^ Bit-vector/unbounded integer+ | CFloat !Float -- ^ Float+ | CDouble !Double -- ^ Double+ | CFP !FP -- ^ Arbitrary float+ | CRational !Rational -- ^ Rational+ | CChar !Char -- ^ Character+ | CString !String -- ^ String+ | CList ![CVal] -- ^ List+ | CSet !(RCSet CVal) -- ^ Set. Can be regular or complemented.+ | CADT !(String, [(Kind, CVal)]) -- ^ ADT: Constructor, and fields+ | CTuple ![CVal] -- ^ Tuple+ | CArray !(ArrayModel CVal CVal) -- ^ Arrays are backed by look-up tables concretely+ deriving (G.Data, Generic, NFData)+ -- | Assign a rank to constant values, this is structural and helps with ordering cvRank :: CVal -> Int cvRank CAlgReal {} = 0@@ -98,12 +127,11 @@ cvRank CString {} = 7 cvRank CList {} = 8 cvRank CSet {} = 9-cvRank CUserSort {} = 10+cvRank CADT {} = 10 cvRank CTuple {} = 11-cvRank CMaybe {} = 12-cvRank CEither {} = 13+cvRank CArray {} = 12 --- | Eq instance for CVVal. Note that we cannot simply derive Eq/Ord, since CVAlgReal doesn't have proper+-- | Eq instance for CVal. Note that we cannot simply derive Eq/Ord, since CVAlgReal doesn't have proper -- instances for these when values are infinitely precise reals. However, we do -- need a structural eq/ord for Map indexes; so define custom ones here: instance Eq CVal where@@ -112,14 +140,17 @@ CFloat a == CFloat b = a `fpIsEqualObjectH` b -- We don't want +0/-0 to be confused; and also we want NaN = NaN here! CDouble a == CDouble b = a `fpIsEqualObjectH` b -- ditto CRational a == CRational b = a == b+ CFP a == CFP b = a `arbFPIsEqualObjectH` b CChar a == CChar b = a == b CString a == CString b = a == b CList a == CList b = a == b CSet a == CSet b = a `eqRCSet` b- CUserSort a == CUserSort b = a == b CTuple a == CTuple b = a == b- CMaybe a == CMaybe b = a == b- CEither a == CEither b = a == b+ CADT a == CADT b = a == b++ -- This is legit since we don't use this equality for actual semantic" equality, but rather as an index into maps+ CArray (ArrayModel a1 d1) == CArray (ArrayModel a2 d2) = (a1, d1) == (a2, d2)+ a == b = if cvRank a == cvRank b then error $ unlines [ "" , "*** Data.SBV.Eq.CVal: Impossible happened: same rank in comparison fallthru"@@ -130,22 +161,24 @@ ] else False --- | Ord instance for VWVal. Same comments as the 'Eq' instance why this cannot be derived.+-- | Ord instance for CVal. Same comments as the 'Eq' instance why this cannot be derived. instance Ord CVal where CAlgReal a `compare` CAlgReal b = a `algRealStructuralCompare` b CInteger a `compare` CInteger b = a `compare` b CFloat a `compare` CFloat b = a `fpCompareObjectH` b CDouble a `compare` CDouble b = a `fpCompareObjectH` b CRational a `compare` CRational b = a `compare` b- CFP a `compare` CFP b = a `fprCompareObject` b+ CFP a `compare` CFP b = a `arbFPCompareObjectH` b CChar a `compare` CChar b = a `compare` b CString a `compare` CString b = a `compare` b CList a `compare` CList b = a `compare` b CSet a `compare` CSet b = a `compareRCSet` b- CUserSort a `compare` CUserSort b = a `compare` b CTuple a `compare` CTuple b = a `compare` b- CMaybe a `compare` CMaybe b = a `compare` b- CEither a `compare` CEither b = a `compare` b+ CADT a `compare` CADT b = a `compare` b++ -- This is legit since we don't use this equality for actual semantic order, but rather as an index into maps+ CArray (ArrayModel a1 d1) `compare` CArray (ArrayModel a2 d2) = (a1, d1) `compare` (a2, d2)+ a `compare` b = let ra = cvRank a rb = cvRank b in if ra == rb@@ -158,12 +191,12 @@ ] else cvRank a `compare` cvRank b --- | 'CV' represents a concrete word of a fixed size:+-- | A t'CV' represents a concrete word of a fixed size: -- For signed words, the most significant digit is considered to be the sign.-data CV = CV { _cvKind :: !Kind- , cvVal :: !CVal+data CV = CV { cvKind :: !Kind+ , cvVal :: !CVal }- deriving (Eq, Ord)+ deriving (Eq, Ord, G.Data, NFData, Generic) -- | A generalized CV allows for expressions involving infinite and epsilon values/intervals Used in optimization problems. data GeneralizedCV = ExtendedCV ExtCV@@ -210,13 +243,12 @@ where par v | parens = '(' : v ++ ")" | True = v withKind isInterval v | not shk = v- | isInterval = v ++ " :: [" ++ showBaseKind (kindOf extCV) ++ "]"- | True = v ++ " :: " ++ showBaseKind (kindOf extCV)+ | isInterval = v ++ " :: [" ++ T.unpack (showBaseKind (kindOf extCV)) ++ "]"+ | True = v ++ " :: " ++ T.unpack (showBaseKind (kindOf extCV)) add :: String -> String -> String- add n v- | "-" `isPrefixOf` v = n ++ " - " ++ tail v- | True = n ++ " + " ++ v+ add n ('-':v) = n ++ " - " ++ v+ add n v = n ++ " + " ++ v mul :: String -> String -> String mul n v = n ++ " * " ++ v@@ -267,139 +299,67 @@ normCV c = c {-# INLINE normCV #-} --- | Constant False as a 'CV'. We represent it using the integer value 0.+-- | Constant False as a t'CV'. We represent it using the integer value 0. falseCV :: CV falseCV = CV KBool (CInteger 0) --- | Constant True as a 'CV'. We represent it using the integer value 1.+-- | Constant True as a t'CV'. We represent it using the integer value 1. trueCV :: CV trueCV = CV KBool (CInteger 1) --- | Lift a unary function through a 'CV'.-liftCV :: (AlgReal -> b)- -> (Integer -> b)- -> (Float -> b)- -> (Double -> b)- -> (FP -> b)- -> (Rational -> b)- -> (Char -> b)- -> (String -> b)- -> ((Maybe Int, String) -> b)- -> ([CVal] -> b)- -> (RCSet CVal -> b)- -> ([CVal] -> b)- -> (Maybe CVal -> b)- -> (Either CVal CVal -> b)- -> CV- -> b-liftCV f _ _ _ _ _ _ _ _ _ _ _ _ _ (CV _ (CAlgReal v)) = f v-liftCV _ f _ _ _ _ _ _ _ _ _ _ _ _ (CV _ (CInteger v)) = f v-liftCV _ _ f _ _ _ _ _ _ _ _ _ _ _ (CV _ (CFloat v)) = f v-liftCV _ _ _ f _ _ _ _ _ _ _ _ _ _ (CV _ (CDouble v)) = f v-liftCV _ _ _ _ f _ _ _ _ _ _ _ _ _ (CV _ (CFP v)) = f v-liftCV _ _ _ _ _ f _ _ _ _ _ _ _ _ (CV _ (CRational v)) = f v-liftCV _ _ _ _ _ _ f _ _ _ _ _ _ _ (CV _ (CChar v)) = f v-liftCV _ _ _ _ _ _ _ f _ _ _ _ _ _ (CV _ (CString v)) = f v-liftCV _ _ _ _ _ _ _ _ f _ _ _ _ _ (CV _ (CUserSort v)) = f v-liftCV _ _ _ _ _ _ _ _ _ f _ _ _ _ (CV _ (CList v)) = f v-liftCV _ _ _ _ _ _ _ _ _ _ f _ _ _ (CV _ (CSet v)) = f v-liftCV _ _ _ _ _ _ _ _ _ _ _ f _ _ (CV _ (CTuple v)) = f v-liftCV _ _ _ _ _ _ _ _ _ _ _ _ f _ (CV _ (CMaybe v)) = f v-liftCV _ _ _ _ _ _ _ _ _ _ _ _ _ f (CV _ (CEither v)) = f v---- | Lift a binary function through a 'CV'.-liftCV2 :: (AlgReal -> AlgReal -> b)- -> (Integer -> Integer -> b)- -> (Float -> Float -> b)- -> (Double -> Double -> b)- -> (FP -> FP -> b)- -> (Rational -> Rational -> b)- -> (Char -> Char -> b)- -> (String -> String -> b)- -> ([CVal] -> [CVal] -> b)- -> ([CVal] -> [CVal] -> b)- -> (Maybe CVal -> Maybe CVal -> b)- -> (Either CVal CVal -> Either CVal CVal -> b)- -> ((Maybe Int, String) -> (Maybe Int, String) -> b)- -> CV -> CV -> b-liftCV2 r i f d af ra c s u v m e w x y = case (cvVal x, cvVal y) of- (CAlgReal a, CAlgReal b) -> r a b- (CInteger a, CInteger b) -> i a b- (CFloat a, CFloat b) -> f a b- (CDouble a, CDouble b) -> d a b- (CFP a, CFP b) -> af a b- (CRational a, CRational b) -> ra a b- (CChar a, CChar b) -> c a b- (CString a, CString b) -> s a b- (CList a, CList b) -> u a b- (CTuple a, CTuple b) -> v a b- (CMaybe a, CMaybe b) -> m a b- (CEither a, CEither b) -> e a b- (CUserSort a, CUserSort b) -> w a b- _ -> error $ "SBV.liftCV2: impossible, incompatible args received: " ++ show (x, y)---- | Map a unary function through a 'CV'.+-- | Map a unary function through a t'CV'. mapCV :: (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> (FP -> FP) -> (Rational -> Rational)- -> (Char -> Char)- -> (String -> String)- -> ((Maybe Int, String) -> (Maybe Int, String))- -> CV- -> CV-mapCV r i f d af ra c s u x = normCV $ CV (kindOf x) $ case cvVal x of- CAlgReal a -> CAlgReal (r a)- CInteger a -> CInteger (i a)- CFloat a -> CFloat (f a)- CDouble a -> CDouble (d a)- CFP a -> CFP (af a)- CRational a -> CRational (ra a)- CChar a -> CChar (c a)- CString a -> CString (s a)- CUserSort a -> CUserSort (u a)- CList{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with lists!"- CSet{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with sets!"- CTuple{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with tuples!"- CMaybe{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with maybe!"- CEither{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with either!"+ -> CV -> CV+mapCV r i f d af ra x = normCV $ CV (kindOf x) $ case cvVal x of+ CAlgReal a -> CAlgReal (r a)+ CInteger a -> CInteger (i a)+ CFloat a -> CFloat (f a)+ CDouble a -> CDouble (d a)+ CFP a -> CFP (af a)+ CRational a -> CRational (ra a)+ CChar{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with chars!"+ CString{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with strings!"+ CADT{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with ADTs!"+ CList{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with lists!"+ CSet{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with sets!"+ CTuple{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with tuples!"+ CArray{} -> error "Data.SBV.mapCV: Unexpected call through mapCV with arrays!" --- | Map a binary function through a 'CV'.+-- | Map a binary function through a t'CV'. mapCV2 :: (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> (FP -> FP -> FP) -> (Rational -> Rational -> Rational)- -> (Char -> Char -> Char)- -> (String -> String -> String)- -> ((Maybe Int, String) -> (Maybe Int, String) -> (Maybe Int, String))- -> CV- -> CV- -> CV-mapCV2 r i f d af ra c s u x y = case (cvSameType x y, cvVal x, cvVal y) of- (True, CAlgReal a, CAlgReal b) -> normCV $ CV (kindOf x) (CAlgReal (r a b))- (True, CInteger a, CInteger b) -> normCV $ CV (kindOf x) (CInteger (i a b))- (True, CFloat a, CFloat b) -> normCV $ CV (kindOf x) (CFloat (f a b))- (True, CDouble a, CDouble b) -> normCV $ CV (kindOf x) (CDouble (d a b))- (True, CFP a, CFP b) -> normCV $ CV (kindOf x) (CFP (af a b))- (True, CRational a, CRational b) -> normCV $ CV (kindOf x) (CRational (ra a b))- (True, CChar a, CChar b) -> normCV $ CV (kindOf x) (CChar (c a b))- (True, CString a, CString b) -> normCV $ CV (kindOf x) (CString (s a b))- (True, CUserSort a, CUserSort b) -> normCV $ CV (kindOf x) (CUserSort (u a b))- (True, CList{}, CList{}) -> error "Data.SBV.mapCV2: Unexpected call through mapCV2 with lists!"- (True, CTuple{}, CTuple{}) -> error "Data.SBV.mapCV2: Unexpected call through mapCV2 with tuples!"- (True, CMaybe{}, CMaybe{}) -> error "Data.SBV.mapCV2: Unexpected call through mapCV2 with maybes!"- (True, CEither{}, CEither{}) -> error "Data.SBV.mapCV2: Unexpected call through mapCV2 with eithers!"- _ -> error $ "Data.SBV.mapCV2: impossible, incompatible args received: " ++ show (x, y)+ -> CV -> CV -> CV+mapCV2 r i f d af ra x y = case (cvSameType x y, cvVal x, cvVal y) of+ (True, CAlgReal a, CAlgReal b) -> normCV $ CV (kindOf x) (CAlgReal (r a b))+ (True, CInteger a, CInteger b) -> normCV $ CV (kindOf x) (CInteger (i a b))+ (True, CFloat a, CFloat b) -> normCV $ CV (kindOf x) (CFloat (f a b))+ (True, CDouble a, CDouble b) -> normCV $ CV (kindOf x) (CDouble (d a b))+ (True, CFP a, CFP b) -> normCV $ CV (kindOf x) (CFP (af a b))+ (True, CRational a, CRational b) -> normCV $ CV (kindOf x) (CRational (ra a b))+ (True, CChar{}, CChar{}) -> unexpected "chars!"+ (True, CString{}, CString{}) -> unexpected "strings!"+ (True, CList{}, CList{}) -> unexpected "lists!"+ (True, CTuple{}, CTuple{}) -> unexpected "tuples!"+ _ -> unexpected $ "incompatible args: " ++ show (x, y)+ where unexpected w = error $ unlines [ ""+ , "*** Data.SBV.mapCV2: Unexpected call through mapCV2 with " ++ w+ , "*** Please report this as a bug!"+ ] --- | Show instance for 'CV'.+-- | Show instance for t'CV'. instance Show CV where show = showCV True --- | Show instance for Generalized 'CV'+-- | Show instance for Generalized t'CV' instance Show GeneralizedCV where show (ExtendedCV k) = showExtCV True k show (RegularCV c) = showCV True c@@ -407,78 +367,122 @@ -- | Show a CV, with kind info if bool is True showCV :: Bool -> CV -> String showCV shk w | isBoolean w = show (cvToBool w) ++ (if shk then " :: Bool" else "")-showCV shk w = liftCV show show show show show show show show snd shL shS shT shMaybe shEither w ++ kInfo- where kw = kindOf w+showCV shk w = sh (cvVal w) ++ kInfo+ where kInfo | shk = " :: " ++ T.unpack (showBaseKind wk)+ | True = "" - kInfo | shk = " :: " ++ showBaseKind kw- | True = ""+ wk = kindOf w - shL xs = "[" ++ intercalate "," (map (showCV False . CV ke) xs) ++ "]"- where ke = case kw of- KList k -> k- _ -> error $ "Data.SBV.showCV: Impossible happened, expected list, got: " ++ show kw+ sh (CAlgReal v) = show v+ sh (CInteger v) = show v+ sh (CFloat v) = show v+ sh (CDouble v) = show v+ sh (CFP v) = show v+ sh (CRational v) = show v+ sh (CChar v) = show v+ sh (CString v) = show v+ sh (CADT c) = shADT c+ sh (CList v) = shL v+ sh (CSet v) = shS v+ sh (CTuple v) = shT v+ sh (CArray v) = shA v - -- we represent complements as @U - set@. This might be confusing, but is utterly cute!- shS :: RCSet CVal -> String- shS eru = case eru of- RegularSet e -> sh e- ComplementSet e | Set.null e -> "U"- | True -> "U - " ++ sh e- where sh xs = "{" ++ intercalate "," (map (showCV False . CV ke) (Set.toList xs)) ++ "}"- ke = case kw of- KSet k -> k- _ -> error $ "Data.SBV.showCV: Impossible happened, expected set, got: " ++ show kw+ shL xs = "[" ++ intercalate "," (map (showCV False . CV ke) xs) ++ "]"+ where ke = case wk of+ KList k -> k+ _ -> error $ "Data.SBV.showCV: Impossible happened, expected list, got: " ++ show wk - shT :: [CVal] -> String- shT xs = "(" ++ intercalate "," xs' ++ ")"- where xs' = case kw of- KTuple ks | length ks == length xs -> zipWith (\k x -> showCV False (CV k x)) ks xs- _ -> error $ "Data.SBV.showCV: Impossible happened, expected tuple (of length " ++ show (length xs) ++ "), got: " ++ show kw+ -- we represent complements as @U - set@. This might be confusing, but is utterly cute!+ shS :: RCSet CVal -> String+ shS eru = case eru of+ RegularSet e -> set e+ ComplementSet e | Set.null e -> "U"+ | True -> "U - " ++ set e+ where set xs = "{" ++ intercalate "," (map (showCV False . CV ke) (Set.toList xs)) ++ "}"+ ke = case wk of+ KSet k -> k+ _ -> error $ "Data.SBV.showCV: Impossible happened, expected set, got: " ++ show wk - shMaybe :: Maybe CVal -> String- shMaybe c = case (c, kw) of- (Nothing, KMaybe{}) -> "Nothing"- (Just x, KMaybe k) -> "Just " ++ paren (showCV False (CV k x))- _ -> error $ "Data.SBV.showCV: Impossible happened, expected maybe, got: " ++ show kw+ shT :: [CVal] -> String+ shT xs = "(" ++ intercalate "," xs' ++ ")"+ where xs' = case wk of+ KTuple ks | length ks == length xs -> zipWith (\k x -> showCV False (CV k x)) ks xs+ _ -> error $ "Data.SBV.showCV: Impossible happened, expected tuple (of length " ++ show (length xs) ++ "), got: " ++ show wk - shEither :: Either CVal CVal -> String- shEither val- | KEither k1 k2 <- kw = case val of- Left x -> "Left " ++ paren (showCV False (CV k1 x))- Right y -> "Right " ++ paren (showCV False (CV k2 y))- | True = error $ "Data.SBV.showCV: Impossible happened, expected sum, got: " ++ show kw+ shA :: ArrayModel CVal CVal -> String+ shA (ArrayModel assocs def)+ | KArray k1 k2 <- wk = "([" ++ intercalate "," [showCV False (CV (KTuple [k1, k2]) (CTuple [a, b])) | (a, b) <- assocs] ++ "], " ++ showCV False (CV k2 def) ++ ")"+ | True = error $ "Data.SBV.showCV: Impossible happened, expected array, got: " ++ show wk - -- kind of crude, but works ok- paren v- | needsParen = '(' : v ++ ")"- | True = v- where needsParen = case dropWhile isSpace v of- [] -> False- rest@(x:_) -> any isSpace rest && x `notElem` "{[("+ shADT (c, kvs)+ | null @[] flds = c+ | True = unwords (c : map wrap flds)+ where wrap v+ | take 1 v `elem` ["(", "[", "{"] = v+ | any isSpace v || take 1 v == "-" = '(' : v ++ ")"+ | True = v + flds = map (\(k, v) -> showCV False (CV k v)) kvs+ -- | Create a constant word from an integral. mkConstCV :: Integral a => Kind -> a -> CV+mkConstCV k@KVar{} _ = error $ "mkConstCV: Unexpected kind: " ++ show k mkConstCV KBool a = normCV $ CV KBool (CInteger (toInteger a)) mkConstCV k@KBounded{} a = normCV $ CV k (CInteger (toInteger a)) mkConstCV KUnbounded a = normCV $ CV KUnbounded (CInteger (toInteger a)) mkConstCV KReal a = normCV $ CV KReal (CAlgReal (fromInteger (toInteger a))) mkConstCV KFloat a = normCV $ CV KFloat (CFloat (fromInteger (toInteger a))) mkConstCV KDouble a = normCV $ CV KDouble (CDouble (fromInteger (toInteger a)))-mkConstCV k@KFP{} a = normCV $ CV k (CFP (fromInteger (toInteger a)))+mkConstCV k@(KFP eb sb) a = normCV $ CV k (CFP (fpFromInteger eb sb (toInteger a))) mkConstCV KRational a = normCV $ CV KRational (CRational (fromInteger (toInteger a))) mkConstCV KChar a = error $ "Unexpected call to mkConstCV (Char) with value: " ++ show (toInteger a) mkConstCV KString a = error $ "Unexpected call to mkConstCV (String) with value: " ++ show (toInteger a)-mkConstCV (KUserSort s _) a = error $ "Unexpected call to mkConstCV with user kind: " ++ s ++ " with value: " ++ show (toInteger a)+mkConstCV (KApp s _) a = error $ "Unexpected call to mkConstCV with kind: " ++ s ++ " with value: " ++ show (toInteger a)+mkConstCV (KADT s _ _) a = error $ "Unexpected call to mkConstCV with ADT: " ++ s ++ " with value: " ++ show (toInteger a) mkConstCV k@KList{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a) mkConstCV k@KSet{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a) mkConstCV k@KTuple{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)-mkConstCV k@KMaybe{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)-mkConstCV k@KEither{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)+mkConstCV k@KArray{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a) --- | Generate a random constant value ('CVal') of the correct kind.+-- | Create a constant value from a floating-point value.+fpConstCV ::+ -- | Must be 'KFloat', 'KDouble', or 'KFP'.+ Kind ->+ -- | The constant to use when the kind is 'KFloat'.+ Float ->+ -- | The constant to use when the kind is 'KDouble'.+ Double ->+ -- | The constant to make when the kind is 'KFP', where the 'Int's represent+ -- the exponent and significand sizes.+ (Int -> Int -> FP) ->+ CV+fpConstCV k cf cd cfp =+ case k of+ KFloat -> CV k $ CFloat cf+ KDouble -> CV k $ CDouble cd+ KFP eb sb -> CV k $ CFP $ cfp eb sb++ KVar{} -> unexpected+ KBool{} -> unexpected+ KBounded{} -> unexpected+ KUnbounded{} -> unexpected+ KReal{} -> unexpected+ KRational{} -> unexpected+ KChar{} -> unexpected+ KString{} -> unexpected+ KApp{} -> unexpected+ KADT{} -> unexpected+ KList{} -> unexpected+ KSet{} -> unexpected+ KTuple{} -> unexpected+ KArray{} -> unexpected+ where unexpected = error $ "Data.SBV.fpConstCV: Unexpected kind: " ++ show k++-- | Generate a random constant value ('CVal') of the correct kind. We error out for a completely uninterpreted type. randomCVal :: Kind -> IO CVal randomCVal k = case k of+ KVar{} -> error $ "randomCVal: Unexpected kind: " ++ show k KBool -> CInteger <$> randomRIO (0, 1) KBounded s w -> CInteger <$> randomRIO (bounds s w) KUnbounded -> CInteger <$> randomIO@@ -498,29 +502,38 @@ KString -> do l <- randomRIO (0, 100) CString <$> replicateM l (chr <$> randomRIO (0, 255)) KChar -> CChar . chr <$> randomRIO (0, 255)- KUserSort s _ -> error $ "Unexpected call to randomCVal with user kind: " ++ s++ -- TODO: Can we do something here?+ KApp s _ -> error $ "randomCVal: Not supported for KApp: " ++ s++ KADT _ _ cstrs@(_:_) -> do i <- randomRIO (0, length cstrs - 1)+ let (c, fks) = cstrs !! i+ vs <- mapM randomCVal fks+ pure $ CADT (c, zip fks vs)+ KADT s _ _ -> error $ "randomCVal: Not supported for ADT: " ++ 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+ pure $ 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)+ def <- randomCVal k2+ pure $ CArray $ ArrayModel (zip ks vs) def where bounds :: Bool -> Int -> (Integer, Integer) bounds False w = (0, 2^w - 1) bounds True w = (-x, x-1) where x = 2^(w-1) --- | Generate a random constant value ('CV') of the correct kind.+-- | Generate a random constant value (i.e., t'CV') of the correct kind. randomCV :: Kind -> IO CV randomCV k = CV k <$> randomCVal k -{-# ANN module ("HLint: ignore Redundant if" :: String) #-}+{- HLint ignore module "Redundant if" -}
Data/SBV/Core/Data.hs view
@@ -16,75 +16,81 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Data ( SBool, SWord8, SWord16, SWord32, SWord64 , SInt8, SInt16, SInt32, SInt64, SInteger, SReal, SFloat, SDouble , SFloatingPoint, SFPHalf, SFPBFloat, SFPSingle, SFPDouble, SFPQuad+ , SWord, SInt, WordN, IntN , SRational- , SChar, SString, SList- , SEither, SMaybe+ , SChar, SString, SList, (.:), nil+ , SArray, ArrayModel(..) , STuple, STuple2, STuple3, STuple4, STuple5, STuple6, STuple7, STuple8 , RCSet(..), SSet , nan, infinity, sNaN, sInfinity, RoundingMode(..), SRoundingMode- , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero- , sRNE, sRNA, sRTP, sRTN, sRTZ- , SymVal(..)+ , SymVal(..), SymValInsts(..), symValKinds, SymVals(..) , CV(..), CVal(..), AlgReal(..), AlgRealPoly(..), ExtCV(..), GeneralizedCV(..), isRegularCV, cvSameType, cvToBool- , mkConstCV ,liftCV2, mapCV, mapCV2+ , mkConstCV , mapCV, mapCV2 , SV(..), trueSV, falseSV, trueCV, falseCV, normCV , SVal(..) , sTrue, sFalse, sNot, (.&&), (.||), (.<+>), (.~&), (.~|), (.=>), (.<=>), sAnd, sOr, sAny, sAll, fromBool , SBV(..), NodeId(..), mkSymSBV- , ArrayContext(..), ArrayInfo, SymArray(..), SArray(..) , sbvToSV, sbvToSymSV, forceSVArg+ , RList(..), RNil, (:>), rlist2list+ , SBVs(..), mapMSBVs, foldlSymSBVs , SBVExpr(..), newExpr- , cache, Cached, uncache, uncacheAI, HasKind(..)- , Op(..), PBOp(..), FPOp(..), StrOp(..), RegExOp(..), SeqOp(..), RegExp(..), NamedSymVar(..), getTableIndex- , SBVPgm(..), Symbolic, runSymbolic, State, getPathCondition, extendPathCondition+ , cache, Cached, uncache, HasKind(..)+ , Op(..), PBOp(..), FPOp(..), StrOp(..), RegExOp(..), SeqOp(..), RegExp(..), NamedSymVar(..), OvOp(..), getTableIndex+ , SBVPgm(..), Symbolic, runSymbolic, State, SInfo(..), getSInfo, getPathCondition , inSMTMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..)- , SolverContext(..), internalVariable, internalConstraint, isCodeGenMode+ , SolverContext(..), internalConstraint, isCodeGenMode , SBVType(..), newUninterpreted , Quantifier(..), needsExistentials- , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension, smtLibReservedNames+ , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension , SolverCapabilities(..) , extractSymbolicSimulationState- , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..)+ , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), TPOptions(..) , OptimizeStyle(..), Penalty(..), Objective(..)- , QueryState(..), QueryT(..), SMTProblem(..)+ , QueryState(..), QueryT(..), SMTProblem(..), Constraint(..), Lambda(..), Forall(..), Exists(..), ExistsUnique(..), ForallN(..), ExistsN(..)+ , QuantifiedBool(..), EqSymbolic(..), QNot(..), Skolemize(SkolemsTo, skolemize, taggedSkolemize)+ , bvExtract, (#), bvDrop, bvTake+ , registerType ) where -import GHC.TypeLits--import GHC.Generics (Generic)-import GHC.Exts (IsList(..))+import GHC.TypeLits (KnownNat, Nat, Symbol, KnownSymbol, symbolVal, AppendSymbol, type (+), type (-), type (<=), natVal) import Control.DeepSeq (NFData(..))-import Control.Monad.Trans (liftIO)+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 import Data.Typeable (Typeable) -import qualified Data.Generics as G (Data(..))+import Data.IORef+import qualified Data.Set as Set (toList) -import qualified Data.IORef as R (readIORef)-import qualified Data.IntMap.Strict as IMap (size, insert)+import GHC.Generics (Generic, U1(..), M1(..), (:*:)(..), K1(..), (:+:)(..))+import qualified GHC.Generics as G +import GHC.Exts (IsList(..))+ import System.Random import Data.SBV.Core.AlgReals+import Data.SBV.Core.Sized import Data.SBV.Core.SizedFloats import Data.SBV.Core.Kind import Data.SBV.Core.Concrete@@ -93,18 +99,15 @@ import Data.SBV.Control.Types -import Data.SBV.SMT.SMTLibNames- import Data.SBV.Utils.Lib+import Data.SBV.Utils.Numeric (RoundingMode(..)) +import Test.QuickCheck (Arbitrary(..))+ -- | Get the current path condition getPathCondition :: State -> SBool getPathCondition st = SBV (getSValPathCondition st) --- | Extend the path condition with the given test value.-extendPathCondition :: State -> (SBool -> SBool) -> State-extendPathCondition st f = extendSValPathCondition st (unSBV . f . SBV)- -- | The "Symbolic" value. The parameter @a@ is phantom, but is -- extremely important in keeping the user interface strongly typed. newtype SBV a = SBV { unSBV :: SVal }@@ -167,8 +170,14 @@ -- | A symbolic quad-precision float type SFPQuad = SBV FPQuad +-- | A symbolic unsigned bit-vector carrying its size info+type SWord (n :: Nat) = SBV (WordN n)++-- | A symbolic signed bit-vector carrying its size info+type SInt (n :: Nat) = SBV (IntN n)+ -- | A symbolic character. Note that this is the full unicode character set.--- see: <http://smtlib.cs.uiowa.edu/theories-UnicodeStrings.shtml>+-- see: <https://smt-lib.org/theories-UnicodeStrings.shtml> -- for details. type SChar = SBV Char @@ -188,15 +197,57 @@ -- Note that lists can be nested, i.e., we do allow lists of lists of ... items. type SList a = SBV [a] --- | Symbolic 'Either'-type SEither a b = SBV (Either a b)+-- | Prepend an element, the traditional @cons@.+--+-- >>> 1 .: 2 .: 3 .: [4, 5, 6 :: SInteger]+-- [1,2,3,4,5,6] :: [SInteger]+infixr 5 .:+(.:) :: forall a. (SymVal a, SymVal [a]) => SBV a -> SList a -> SList a+a .: as+ | Just av <- unliteral a+ , Just asv <- unliteral as+ = literal (av : asv)+ | Just asv <- unliteral as, null asv -- singleton: skip the concat with empty+ = SBV $ SVal kl $ Right $ cache $ \st -> do+ sva <- sbvToSV st a+ newExpr st kl (SBVApp (SeqOp (SeqUnit ka)) [sva])+ | True+ = SBV $ SVal kl $ Right $ cache r+ where ka = kindOf (Proxy @a)+ kl = kindOf (Proxy @[a])+ r st = do sva <- sbvToSV st a+ svs <- newExpr st kl (SBVApp (SeqOp (SeqUnit ka)) [sva])+ svas <- sbvToSV st as+ newExpr st kl (SBVApp (SeqOp (SeqConcat kl)) [svs, svas]) --- | Symbolic 'Maybe'-type SMaybe a = SBV (Maybe 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 @[]@.+nil :: SymVal [a] => SList a+nil = literal [] +-- | 'IsList' instance allows list literals to be written compactly.+instance (SymVal a, SymVal [a]) => IsList (SList a) where+ type Item (SList a) = SBV a++ fromList = 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 -> map literal xs++-- | Symbolic arrays. A symbolic array is more akin to a function in SMTLib (and thus in SBV),+-- as opposed to contagious-storage with a finite range as found in many programming languages.+-- Additionally, the domain uses object-equality in the SMTLib semantics. Object equality is+-- the same as regular equality for most types, except for IEEE-Floats, where @NaN@ doesn't compare+-- equal to itself and @+0@ and @-0@ are not distinguished. So, if your index type is a float,+-- then @NaN@ can be stored correctly, and @0@ and @-0@ will be distinguished. If you don't use+-- floats, then you can treat this the same as regular equality in Haskell.+type SArray a b = SBV (ArrayModel a b)+ -- | Symbolic 'Data.Set'. Note that we use 'RCSet', which supports -- both regular sets and complements, i.e., those obtained from the--- universal set (of the right type) by removing elements.+-- universal set (of the right type) by removing elements. Similar to 'SArray'+-- the contents are stored with object equality, which makes a difference if the+-- underlying type contains IEEE Floats. type SSet a = SBV (RCSet a) -- | Symbolic 2-tuple. NB. 'STuple' and 'STuple2' are equivalent.@@ -223,12 +274,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@@ -292,7 +337,7 @@ -- | Symbolic implication infixr 1 .=> (.=>) :: SBool -> SBool -> SBool-x .=> y = sNot x .|| y+SBV x .=> SBV y = SBV (x `svImplies` y) -- NB. Do *not* try to optimize @x .=> x = True@ here! If constants go through, it'll get simplified. -- The case "x .=> x" can hit is extremely rare, and the getAllSatResult function relies on this -- trick to generate constraints in the unlucky case of ui-function models.@@ -300,7 +345,7 @@ -- | Symbolic boolean equivalence infixr 1 .<=> (.<=>) :: SBool -> SBool -> SBool-x .<=> y = (x .&& y) .|| (sNot x .&& sNot y)+SBV x .<=> SBV y = SBV (x `svEqual` y) -- | Conversion from 'Bool' to 'SBool' fromBool :: Bool -> SBool@@ -323,65 +368,15 @@ sAll :: (a -> SBool) -> [a] -> SBool sAll f = sAnd . map f --- | 'RoundingMode' can be used symbolically-instance SymVal RoundingMode- -- | The symbolic variant of 'RoundingMode' type SRoundingMode = SBV RoundingMode --- | Symbolic variant of 'RoundNearestTiesToEven'-sRoundNearestTiesToEven :: SRoundingMode-sRoundNearestTiesToEven = literal RoundNearestTiesToEven---- | Symbolic variant of 'RoundNearestTiesToAway'-sRoundNearestTiesToAway :: SRoundingMode-sRoundNearestTiesToAway = literal RoundNearestTiesToAway---- | Symbolic variant of 'RoundTowardPositive'-sRoundTowardPositive :: SRoundingMode-sRoundTowardPositive = literal RoundTowardPositive---- | Symbolic variant of 'RoundTowardNegative'-sRoundTowardNegative :: SRoundingMode-sRoundTowardNegative = literal RoundTowardNegative---- | Symbolic variant of 'RoundTowardZero'-sRoundTowardZero :: SRoundingMode-sRoundTowardZero = literal RoundTowardZero---- | Alias for 'sRoundNearestTiesToEven'-sRNE :: SRoundingMode-sRNE = sRoundNearestTiesToEven---- | Alias for 'sRoundNearestTiesToAway'-sRNA :: SRoundingMode-sRNA = sRoundNearestTiesToAway---- | Alias for 'sRoundTowardPositive'-sRTP :: SRoundingMode-sRTP = sRoundTowardPositive---- | Alias for 'sRoundTowardNegative'-sRTN :: SRoundingMode-sRTN = sRoundTowardNegative---- | Alias for 'sRoundTowardZero'-sRTZ :: SRoundingMode-sRTZ = sRoundTowardZero- -- | A 'Show' instance is not particularly "desirable," when the value is symbolic, -- but we do need this instance as otherwise we cannot simply evaluate Haskell functions -- that return symbolic values and have their constant values printed easily! instance Show (SBV a) where show (SBV sv) = show sv --- | This instance is only defined so that we can define an instance for--- 'Data.Bits.Bits'. '==' and '/=' simply throw an error. Use--- 'Data.SBV.EqSymbolic' instead.-instance Eq (SBV a) where- SBV a == SBV b = a == b- SBV a /= SBV b = a /= b- instance HasKind a => HasKind (SBV a) where kindOf _ = kindOf (Proxy @a) @@ -389,6 +384,51 @@ sbvToSV :: State -> SBV a -> IO SV sbvToSV st (SBV s) = svToSV st s +-- | A datakind for lists with cons on the right+data RList a = RNil | (RList a) :> a++-- | Convert an 'RList' into a reversed standard list+rlist2listRev :: RList a -> [a]+rlist2listRev RNil = []+rlist2listRev (as :> a) = a : rlist2listRev as++-- | Convert an 'RList' into a standard list+rlist2list :: RList a -> [a]+rlist2list = reverse . rlist2listRev++-- | Helper for writing types containing @RNil@+type RNil = 'RNil++-- | Helper for writing types containing @:>@+type (:>) = '(:>)++-- | A sequence of elements of types @SBV a1,...,SBV an@ given the list+-- @[a1,...,an]@ of Haskell types+data SBVs as where+ SBVsNil :: SBVs RNil+ SBVsCons :: SBVs as -> SBV a -> SBVs (as :> a)++-- | Fold a function over each SBV value in an SBVs sequence in a manner similar+-- to 'foldr' for lists, except backwards because the lists are stored in+-- reverse order+foldlSBVs :: (forall a. r -> SBV a -> r) -> r -> SBVs as -> r+foldlSBVs _ r SBVsNil = r+foldlSBVs f r (SBVsCons args arg) = f (foldlSBVs f r args) arg++-- | Map a monadic function over the SBV values in an SBVs sequence in a+-- manner similar to 'mapM' for lists+mapMSBVs :: Monad m => (forall a. SBV a -> m r) -> SBVs as -> m (RList r)+mapMSBVs f = foldlSBVs (\m arg -> (:>) <$> m <*> f arg) (pure RNil)++-- | Fold a function over each SBV value in an SBVs sequence in a manner similar+-- to 'foldr' for lists (but backwards because SBVs have cons on the right),+-- using 'SymVal' instances for each value+foldlSymSBVs :: (forall a. SymVal a => r -> SBV a -> r) -> r ->+ SymValInsts as -> SBVs as -> r+foldlSymSBVs _ r _ SBVsNil = r+foldlSymSBVs f r (SymValsCons symvs) (SBVsCons args arg) =+ f (foldlSymSBVs f r symvs args) arg+ ------------------------------------------------------------------------- -- * Symbolic Computations -------------------------------------------------------------------------@@ -403,51 +443,162 @@ st <- symbolicEnv liftIO $ sbvToSV st sbv +-- | Values that we can turn into a constraint+class MonadSymbolic m => Constraint m a where+ mkConstraint :: State -> a -> m ()++-- | Base case: simple booleans+instance MonadSymbolic m => Constraint m SBool where+ mkConstraint _ out = void $ output out++-- | An existential symbolic variable, used in building quantified constraints. The name+-- attached via the symbol is used during skolemization to create a skolem-function name+-- when this variable is eliminated.+newtype Exists (nm :: Symbol) a = Exists (SBV a)++-- | An existential unique symbolic variable, used in building quantified constraints. The name+-- attached via the symbol is used during skolemization. It's split into two extra names, suffixed+-- @_eu1@ and @_eu2@, to name the universals in the equivalent formula:+-- \(\exists! x\,P(x)\Leftrightarrow \exists x\,P(x) \land \forall x_{eu1} \forall x_{eu2} (P(x_{eu1}) \land P(x_{eu2}) \Rightarrow x_{eu1} = x_{eu2}) \)+newtype ExistsUnique (nm :: Symbol) a = ExistsUnique (SBV a)++-- | A universal symbolic variable, used in building quantified constraints. The name attached via the symbol is used+-- during skolemization. It names the corresponding argument to the skolem-functions within the scope of this quantifier.+newtype Forall (nm :: Symbol) a = Forall (SBV a)++-- | Exactly @n@ existential symbolic variables, used in building quantified constraints. The name attached+-- will be prefixed in front of @_1@, @_2@, ..., @_n@ to form the names of the variables.+newtype ExistsN (n :: Nat) (nm :: Symbol) a = ExistsN [SBV a]++-- | Exactly @n@ universal symbolic variables, used in building quantified constraints. The name attached+-- will be prefixed in front of @_1@, @_2@, ..., @_n@ to form the names of the variables.+newtype ForallN (n :: Nat) (nm :: Symbol) a = ForallN [SBV a]++-- | make a quantifier argument in the given state+mkQArg :: forall m a. (HasKind a, MonadIO m) => State -> Quantifier -> m (SBV a)+mkQArg st q = do let k = kindOf (Proxy @a)+ sv <- liftIO $ quantVar q st k+ pure $ SBV $ SVal k (Right (cache (const (pure sv))))++-- | Functions of a single existential+instance (SymVal a, Constraint m r) => Constraint m (Exists nm a -> r) where+ mkConstraint st fn = mkQArg st EX >>= mkConstraint st . fn . Exists++-- | Functions of a unique single existential+instance (SymVal a, Constraint m r, EqSymbolic (SBV a), QuantifiedBool r) => Constraint m (ExistsUnique nm a -> r) where+ mkConstraint st = mkConstraint st . rewriteExistsUnique++-- | Functions of a number of existentials+instance (KnownNat n, SymVal a, Constraint m r) => Constraint m (ExistsN n nm a -> r) where+ mkConstraint st fn = replicateM (intOfProxy (Proxy @n)) (mkQArg st EX) >>= mkConstraint st . fn . ExistsN++-- | Functions of a single universal+instance (SymVal a, Constraint m r) => Constraint m (Forall nm a -> r) where+ mkConstraint st fn = mkQArg st ALL >>= mkConstraint st . fn . Forall++-- | Functions of a number of universals+instance (KnownNat n, SymVal a, Constraint m r) => Constraint m (ForallN n nm a -> r) where+ mkConstraint st fn = replicateM (intOfProxy (Proxy @n)) (mkQArg st ALL) >>= mkConstraint st . fn . ForallN++-- | Functions of a pair of universals+instance (SymVal a, SymVal b, Constraint m r) => Constraint m ((Forall na a, Forall nb b) -> r) where+ mkConstraint st fn = do a <- mkQArg st ALL+ b <- mkQArg st ALL+ mkConstraint st $ fn (Forall a, Forall b)++-- | Values that we can turn into a lambda abstraction+class MonadSymbolic m => Lambda m a where+ mkLambda :: State -> a -> m ()++-- | Base case, simple values+instance MonadSymbolic m => Lambda m (SBV a) where+ mkLambda _ out = void $ output out++-- | Functions+instance (SymVal a, Lambda m r) => Lambda m (SBV a -> r) where+ mkLambda st fn = mkArg >>= mkLambda st . fn+ where mkArg = do let k = kindOf (Proxy @a)+ sv <- liftIO $ lambdaVar st k+ pure $ SBV $ SVal k (Right (cache (const (pure sv))))++-- | A value that can be used as a quantified boolean+class QuantifiedBool a where+ -- | Turn a quantified boolean into a regular boolean. That is, this function turns an exists/forall quantified+ -- formula to a simple boolean that can be used as a regular boolean value. An example is:+ --+ -- @+ -- quantifiedBool $ \\(Forall x) (Exists y) -> y .> (x :: SInteger)+ -- @+ --+ -- is equivalent to `sTrue`. You can think of this function as performing quantifier-elimination: It takes+ -- a quantified formula, and reduces it to a simple boolean that is equivalent to it, but has no quantifiers.+ quantifiedBool :: a -> SBool++-- | Base case of quantification, simple booleans+instance {-# OVERLAPPING #-} QuantifiedBool SBool where+ quantifiedBool = id+ -- | Actions we can do in a context: Either at problem description -- time or while we are dynamically querying. 'Symbolic' and 'Query' are -- two instances of this class. Note that we use this mechanism -- internally and do not export it from SBV. class SolverContext m where -- | Add a constraint, any satisfying instance must satisfy this condition.- constrain :: SBool -> m ()+ constrain :: QuantifiedBool a => a -> m ()+ -- | Add a soft constraint. The solver will try to satisfy this condition if possible, but won't if it cannot.- softConstrain :: SBool -> m ()+ softConstrain :: QuantifiedBool a => a -> m ()+ -- | Add a named constraint. The name is used in unsat-core extraction.- namedConstraint :: String -> SBool -> m ()+ namedConstraint :: QuantifiedBool a => String -> a -> m ()+ -- | Add a constraint, with arbitrary attributes.- constrainWithAttribute :: [(String, String)] -> SBool -> m ()+ constrainWithAttribute :: QuantifiedBool a => [(String, String)] -> a -> m ()+ -- | Set info. Example: @setInfo ":status" ["unsat"]@. setInfo :: String -> [String] -> m ()+ -- | Set an option. setOption :: SMTOption -> m ()+ -- | Set the logic. setLogic :: Logic -> m ()- -- | Add a user specified axiom to the generated SMT-Lib file. The first argument is a mere- -- string, use for commenting purposes. The second argument is intended to hold the multiple-lines- -- of the axiom text as expressed in SMT-Lib notation. Note that we perform no checks on the axiom- -- itself, to see whether it's actually well-formed or is sensible by any means.- -- A separate formalization of SMT-Lib would be very useful here.- addAxiom :: String -> [String] -> m ()- -- | Add a user-defined SMTLib function. You should define the name given here as an uninterpreted- -- value as well. SBV performs no checks on the SMTLib definition you give, so if it doesn't match- -- the required type, or is malformed in any way, the call will fail at run-time.- addSMTDefinition :: String -> [String] -> m ()+ -- | Set a solver time-out value, in milli-seconds. This function -- essentially translates to the SMTLib call @(set-info :timeout val)@, -- and your backend solver may or may not support it! The amount given -- is in milliseconds. Also see the function 'Data.SBV.Control.timeOut' for finer level -- control of time-outs, directly from SBV. setTimeOut :: Integer -> m ()+ -- | Get the state associated with this context contextState :: m State - {-# MINIMAL constrain, softConstrain, namedConstraint, constrainWithAttribute, setOption, addAxiom, addSMTDefinition, contextState #-}+ -- | Get an internal-variable+ internalVariable :: Kind -> m (SBV a) + {-# MINIMAL constrain, softConstrain, namedConstraint, constrainWithAttribute, setOption, contextState, internalVariable #-}+ -- time-out, logic, and info are simply options in our implementation, so default implementation suffices- setTimeOut t = setOption $ OptionKeyword ":timeout" [show t]+ setTimeOut = setOption . SetTimeOut setLogic = setOption . SetLogic setInfo k = setOption . SetInfo k +-- | Register a type with the solver. Like 'Data.SBV.Core.Model.registerFunction', This is typically not necessary+-- since SBV will register types as it encounters them automatically. But there are cases+-- where doing this can explicitly can come handy, typically in query contexts.+registerType :: forall a m. (MonadIO m, SolverContext m, HasKind a) => Proxy a -> m ()+registerType _ = do st <- contextState+ liftIO $ registerKind st (kindOf (Proxy @a))++-- | Various info we use in recoverKinded value+newtype SInfo = SInfo { sInfoKinds :: [Kind] }++-- | Turn state into SInfo+getSInfo :: MonadIO m => State -> m SInfo+getSInfo st = do rk <- liftIO $ readIORef (rUsedKinds st)+ pure $ SInfo { sInfoKinds = Set.toList rk }+ -- | A class representing what can be returned from a symbolic computation. class Outputtable a where -- | Generalization of 'Data.SBV.output'@@ -456,13 +607,13 @@ instance Outputtable (SBV a) where output i = do outputSVal (unSBV i)- return i+ pure i instance Outputtable a => Outputtable [a] where output = mapM output instance Outputtable () where- output = return+ output = pure instance (Outputtable a, Outputtable b) => Outputtable (a, b) where output = mlift2 (,) output output@@ -489,71 +640,42 @@ -- * 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)++ -- | Certain types (ADTs) might need to do further initialization.+ mkSymValInit :: State -> SBV a -> IO ()+ mkSymValInit _ _ = pure ()+ -- | Turn a literal constant to symbolic literal :: a -> SBV a+ -- | Extract a literal, from a CV representation fromCV :: CV -> a+ -- | Does it concretely satisfy the given predicate? isConcretely :: SBV a -> (a -> Bool) -> Bool - -- 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+ -- | 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) - default mkSymVal :: (MonadSymbolic m, Read a, G.Data a) => VarContext -> Maybe String -> m (SBV a)- mkSymVal vc mbNm = SBV <$> (symbolicEnv >>= liftIO . svMkSymVar vc k mbNm)- where -- NB.A call of the form- -- constructUKind (Proxy @a)- -- would be wrong here, as it would uninterpret the Proxy datatype!- -- So, we have to use the dreaded undefined value in this case.- k = constructUKind (undefined :: a)+ {-# MINIMAL literal, fromCV #-} - default literal :: Show a => a -> SBV a- literal x = let k = kindOf x- sx = show x- conts = case k of- KUserSort _ cts -> cts- _ -> Nothing- mbIdx = case conts of- Just xs -> sx `elemIndex` xs- Nothing -> Nothing- in SBV $ SVal k (Left (CV k (CUserSort (mbIdx, sx))))+ default mkSymVal :: MonadSymbolic m => VarContext -> Maybe String -> m (SBV a)+ mkSymVal vc mbNm = do st <- symbolicEnv+ liftIO $ do v <- SBV <$> svMkSymVar vc (kindOf (undefined :: a)) mbNm st+ mkSymValInit st v+ pure v - default fromCV :: Read a => CV -> a- 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 - -- | Generalization of 'Data.SBV.sbvForall'- sbvForall :: MonadSymbolic m => String -> m (SBV a)- sbvForall = mkSymVal (NonQueryVar (Just ALL)) . Just-- -- | Generalization of 'Data.SBV.sbvForall_'- sbvForall_ :: MonadSymbolic m => m (SBV a)- sbvForall_ = mkSymVal (NonQueryVar (Just ALL)) Nothing-- -- | Generalization of 'Data.SBV.mkForallVars'- mkForallVars :: MonadSymbolic m => Int -> m [SBV a]- mkForallVars n = mapM (const sbvForall_) [1 .. n]-- -- | Generalization of 'Data.SBV.sbvExists'- sbvExists :: MonadSymbolic m => String -> m (SBV a)- sbvExists = mkSymVal (NonQueryVar (Just EX)) . Just-- -- | Generalization of 'Data.SBV.sbvExists_'- sbvExists_ :: MonadSymbolic m => m (SBV a)- sbvExists_ = mkSymVal (NonQueryVar (Just EX)) Nothing-- -- | Generalization of 'Data.SBV.mkExistVars'- mkExistVars :: MonadSymbolic m => Int -> m [SBV a]- mkExistVars n = mapM (const sbvExists_) [1 .. n]- -- | Generalization of 'Data.SBV.free' free :: MonadSymbolic m => String -> m (SBV a) free = mkSymVal (NonQueryVar Nothing) . Just@@ -579,6 +701,11 @@ unliteral (SBV (SVal _ (Left c))) = Just $ fromCV c unliteral _ = Nothing + -- | Get the underlying CV, if available+ unlitCV :: SBV a -> Maybe (Kind, CVal)+ unlitCV (SBV (SVal _ (Left (CV k v)))) = Just (k, v)+ unlitCV _ = Nothing+ -- | Is the symbolic word concrete? isConcrete :: SBV a -> Bool isConcrete (SBV (SVal _ (Left _))) = True@@ -588,99 +715,381 @@ isSymbolic :: SBV a -> Bool isSymbolic = not . isConcrete +-- | A sequence of instance dictionaries for each type @ai@ in the type list+-- @[a1,...,an]@+data SymValInsts as where+ SymValsNil :: SymValInsts RNil+ SymValsCons :: SymVal a => SymValInsts as -> SymValInsts (as :> a)++-- | Get the 'Kind' of each type in the type list of a 'SymValInsts' sequence+symValKinds :: SymValInsts as -> [Kind]+symValKinds = rlist2list . helper where+ helper :: SymValInsts as -> RList Kind+ helper SymValsNil = RNil+ helper insts@(SymValsCons insts') = helper insts' :> kindOf (headPrx insts)+ headPrx :: SymValInsts (bs :> b) -> Proxy b+ headPrx _ = Proxy++-- | A 'SymVals' is a list of types that all satisfy 'SymVal'+class SymVals as where+ symValInsts :: SymValInsts as++instance SymVals RNil where+ symValInsts = SymValsNil++instance (SymVal a, SymVals as) => SymVals (as :> a) where+ symValInsts = SymValsCons symValInsts+ instance (Random a, SymVal a) => Random (SBV a) where randomR (l, h) g = case (unliteral l, unliteral h) of (Just lb, Just hb) -> let (v, g') = randomR (lb, hb) g in (literal (v :: a), g') _ -> error "SBV.Random: Cannot generate random values with symbolic bounds" random g = let (v, g') = random g in (literal (v :: a) , g') ------------------------------------------------------------------------------------- * Symbolic Arrays-------------------------------------------------------------------------------------- | Arrays of symbolic values--- An @array a b@ is an array indexed by the type @'SBV' a@, with elements of type @'SBV' b@.+-- | Symbolic Equality. Note that we can't use Haskell's 'Eq' class since Haskell insists on returning Bool+-- Comparing symbolic values will necessarily return a symbolic value. ----- If a default value is supplied, then all the array elements will be initialized to this value.--- Otherwise, they will be left unspecified, i.e., a read from an unwritten location will produce--- an uninterpreted constant.+-- NB. Equality is a built-in notion in SMTLib, and is object-equality. While this mostly matches Haskell's+-- notion of equality, the correspondence isn't exact. This mostly shows up in containers with floats inside,+-- such as sequences of floats, sets of doubles, and arrays of doubles. While SBV tries to maintain Haskell+-- semantics, it does resort to container equality for compound types. For instance, for an IEEE-float,+-- -0 == 0. But for an SMTLib sequence, equals is done over objects. i.e., @[0] == [-0]@ in Haskell, but+-- @literal [0] ./= literal [-0]@ when used as SMTLib sequences. The rabbit-hole goes deep here, especially+-- when @NaN@ is involved, which does not compare equal to itself per IEEE-semantics. ----- The reason for this class is rather historic. In the past, SBV provided two different kinds of--- arrays: an `SArray` abstraction that mapped directly to SMTLib arrays (which is still available--- today), and a functional notion of arrays that used internal caching, called @SFunArray@. The latter--- has been removed as the code turned out to be rather tricky and hard to maintain; so we only--- have one instance of this class. But end users can add their own instances, if needed.+-- If you are not using floats, then you can ignore all this. If you do, then SBV will do the right thing for+-- them when checking equality directly, but not when you use containers with floating-point elements. In the+-- latter case, object-equality will be used. ----- NB. 'sListArray' insists on a concrete initializer, because not having one would break--- referential transparency. See https://github.com/LeventErkok/sbv/issues/553 for details.-class SymArray array where- -- | Generalization of 'Data.SBV.newArray_'- newArray_ :: (MonadSymbolic m, HasKind a, HasKind b) => Maybe (SBV b) -> m (array a b)- -- | Generalization of 'Data.SBV.newArray'- newArray :: (MonadSymbolic m, HasKind a, HasKind b) => String -> Maybe (SBV b) -> m (array a b)- -- | Create a literal array- sListArray :: (HasKind a, SymVal b) => b -> [(SBV a, SBV b)] -> array a b- -- | Read the array element at @a@- readArray :: array a b -> SBV a -> SBV b- -- | Update the element at @a@ to be @b@- writeArray :: SymVal b => array a b -> SBV a -> SBV b -> array a b- -- | Merge two given arrays on the symbolic condition- -- Intuitively: @mergeArrays cond a b = if cond then a else b@.- -- Merging pushes the if-then-else choice down on to elements- mergeArrays :: SymVal b => SBV Bool -> array a b -> array a b -> array a b- -- | Internal function, not exported to the user- newArrayInState :: (HasKind a, HasKind b) => Maybe String -> Maybe (SBV b) -> State -> IO (array a b)+-- Minimal complete definition: None, if the type is instance of @Generic@. Otherwise '(.==)'.+infix 4 .==, ./=, .===, ./==+class EqSymbolic a where+ -- | Symbolic equality.+ (.==) :: a -> a -> SBool - {-# MINIMAL readArray, writeArray, mergeArrays, ((newArray_, newArray) | newArrayInState), sListArray #-}- newArray_ mbVal = symbolicEnv >>= liftIO . newArrayInState Nothing mbVal- newArray nm mbVal = symbolicEnv >>= liftIO . newArrayInState (Just nm) mbVal+ -- | Symbolic inequality.+ (./=) :: a -> a -> SBool - -- Despite our MINIMAL pragma and default implementations for newArray_ and- -- newArray, we must provide a dummy implementation for newArrayInState:- newArrayInState = error "undefined: newArrayInState"+ -- | Strong equality. On floats ('SFloat'/'SDouble'), strong equality is object equality; that+ -- is @NaN == NaN@ holds, but @+0 == -0@ doesn't. On other types, (.===) is simply (.==).+ -- Note that (.==) is the /right/ notion of equality for floats per IEEE754 specs, since by+ -- definition @+0 == -0@ and @NaN@ equals no other value including itself. But occasionally+ -- we want to be stronger and state @NaN@ equals @NaN@ and @+0@ and @-0@ are different from+ -- each other. In a context where your type is concrete, simply use `Data.SBV.fpIsEqualObject`. But in+ -- a polymorphic context, use the strong equality instead.+ --+ -- NB. If you do not care about or work with floats, simply use (.==) and (./=).+ (.===) :: a -> a -> SBool --- | Arrays implemented in terms of SMT-arrays: <http://smtlib.cs.uiowa.edu/theories-ArraysEx.shtml>------ * Maps directly to SMT-lib arrays------ * Reading from an uninitialized value is OK. If the default value is given in 'newArray', it will--- be the result. Otherwise, the read yields an uninterpreted constant.------ * Can check for equality of these arrays------ * Cannot be used in code-generation (i.e., compilation to C)------ * Cannot quick-check theorems using @SArray@ values-newtype SArray a b = SArray { unSArray :: SArr }+ -- | Negation of strong equality. Equaivalent to negation of (.===) on all types.+ (./==) :: a -> a -> SBool -instance (HasKind a, HasKind b) => Show (SArray a b) where- show SArray{} = "SArray<" ++ showType (Proxy @a) ++ ":" ++ showType (Proxy @b) ++ ">"+ -- | Returns (symbolic) 'sTrue' if all the elements of the given list are different.+ distinct :: [a] -> SBool -instance SymArray SArray where- readArray (SArray arr) (SBV a) = SBV (readSArr arr a)- writeArray (SArray arr) (SBV a) (SBV b) = SArray (writeSArr arr a b)- mergeArrays (SBV t) (SArray a) (SArray b) = SArray (mergeSArr t a b)+ -- | Returns (symbolic) `sTrue` if all the elements of the given list are different. The second+ -- list contains exceptions, i.e., if an element belongs to that set, it will be considered+ -- distinct regardless of repetition.+ distinctExcept :: [a] -> [a] -> SBool - sListArray :: forall a b. (HasKind a, SymVal b) => b -> [(SBV a, SBV b)] -> SArray a b- sListArray initializer = foldl (uncurry . writeArray) arr- where arr = SArray $ SArr ks $ cache r- where ks = (kindOf (Proxy @a), kindOf (Proxy @b))- r st = do amap <- R.readIORef (rArrayMap st)+ -- | Returns (symbolic) 'sTrue' if all the elements of the given list are the same.+ allEqual :: [a] -> SBool - let k = ArrayIndex $ IMap.size amap- iVal = literal initializer+ -- | Symbolic membership test.+ sElem :: a -> [a] -> SBool - iSV <- sbvToSV st iVal+ -- | Symbolic negated membership test.+ sNotElem :: a -> [a] -> SBool - let upd = IMap.insert (unArrayIndex k) ("array_" ++ show k, ks, ArrayFree (Just iSV))+ x ./= y = sNot (x .== y)+ x .=== y = x .== y+ x ./== y = sNot (x .=== y) - k `seq` modifyState st rArrayMap upd $ modifyIncState st rNewArrs upd- return k+ allEqual [] = sTrue+ allEqual (x:xs) = sAll (x .==) xs - newArrayInState :: forall a b. (HasKind a, HasKind b) => Maybe String -> Maybe (SBV b) -> State -> IO (SArray a b)- newArrayInState mbNm mbVal st = do mapM_ (registerKind st) [aknd, bknd]- SArray <$> newSArr st (aknd, bknd) (mkNm mbNm) (unSBV <$> mbVal)- where mkNm Nothing t = "array_" ++ show t- mkNm (Just nm) _ = nm- aknd = kindOf (Proxy @a)- bknd = kindOf (Proxy @b)+ -- Default implementation of 'distinct'. Note that we override+ -- this method for the base types to generate better code.+ distinct [] = sTrue+ distinct (x:xs) = sAll (x ./=) xs .&& distinct xs++ -- Default implementation of 'distinctExcept'. Note that we override+ -- this method for the base types to generate better code.+ distinctExcept es ignored = go es+ where isIgnored = (`sElem` ignored)++ go [] = sTrue+ go (x:xs) = let xOK = isIgnored x .|| sAll (\y -> isIgnored y .|| x ./= y) xs+ in xOK .&& go xs++ x `sElem` xs = sAny (.== x) xs+ x `sNotElem` xs = sNot (x `sElem` xs)++ -- Default implementation for '(.==)' if the type is 'Generic'+ default (.==) :: (G.Generic a, GEqSymbolic (G.Rep a)) => a -> a -> SBool+ (.==) = symbolicEqDefault++-- | Default implementation of symbolic equality, when the underlying type is generic+-- Not exported, used with automatic deriving.+symbolicEqDefault :: (G.Generic a, GEqSymbolic (G.Rep a)) => a -> a -> SBool+symbolicEqDefault x y = symbolicEq (G.from x) (G.from y)++-- | Not exported, used for implementing generic equality.+class GEqSymbolic f where+ symbolicEq :: f a -> f a -> SBool++{-+ - N.B. A V1 instance like the below would be wrong!+ - Why? Because in SBV, we use empty data to mean "uninterpreted" sort; not+ - something that has no constructors. Perhaps that was a bad design+ - decision. So, do not allow equality checking of such values.+instance GEqSymbolic V1 where+ symbolicEq _ _ = sTrue+-}++instance GEqSymbolic U1 where+ symbolicEq _ _ = sTrue++instance (EqSymbolic c) => GEqSymbolic (K1 i c) where+ symbolicEq (K1 x) (K1 y) = x .== y++instance (GEqSymbolic f) => GEqSymbolic (M1 i c f) where+ symbolicEq (M1 x) (M1 y) = symbolicEq x y++instance (GEqSymbolic f, GEqSymbolic g) => GEqSymbolic (f :*: g) where+ symbolicEq (x1 :*: y1) (x2 :*: y2) = symbolicEq x1 x2 .&& symbolicEq y1 y2++instance (GEqSymbolic f, GEqSymbolic g) => GEqSymbolic (f :+: g) where+ symbolicEq (L1 l) (L1 r) = symbolicEq l r+ symbolicEq (R1 l) (R1 r) = symbolicEq l r+ symbolicEq (L1 _) (R1 _) = sFalse+ symbolicEq (R1 _) (L1 _) = sFalse++-- We don't want to do a generic Num a => Num (SBV a) instance; since that would be dangerous. Liftings+-- would only work for types we already handle. If a user defines his own type and makes an instance+-- of it, it would do the wrong thing. See https://github.com/LeventErkok/sbv/issues/706 for a discussion.+-- 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; \+}++-- Derive basic instances we need. NB. We don't give the SRational instance here. It's handled+-- in Data/SBV/Rational due to representation issues.+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)+ , KnownNat i+ , KnownNat j+ , i + 1 <= n+ , j <= i+ , BVIsNonZero (i - j + 1)+ ) => proxy i -- ^ @i@: Start position, numbered from @n-1@ to @0@+ -> proxy j -- ^ @j@: End position, numbered from @n-1@ to @0@, @j <= i@ must hold+ -> SBV (bv n) -- ^ Input bit vector of size @n@+ -> SBV (bv (i - j + 1)) -- ^ Output is of size @i - j + 1@+bvExtract start end = SBV . svExtract i j . unSBV+ where i = fromIntegral (natVal start)+ j = fromIntegral (natVal end)++-- | Join two bit-vectors.+(#) :: ( KnownNat n, BVIsNonZero n, SymVal (bv n)+ , KnownNat m, BVIsNonZero m, SymVal (bv m)+ ) => SBV (bv n) -- ^ First input, of size @n@, becomes the left side+ -> SBV (bv m) -- ^ Second input, of size @m@, becomes the right side+ -> SBV (bv (n + m)) -- ^ Concatenation, of size @n+m@+n # m = SBV $ svJoin (unSBV n) (unSBV m)+infixr 5 #++-- | Drop bits from the top of a bit-vector.+bvDrop :: forall i n m bv proxy. ( KnownNat n, BVIsNonZero n+ , KnownNat i+ , i + 1 <= n+ , i + m - n <= 0+ , BVIsNonZero (n - i)+ ) => proxy i -- ^ @i@: Number of bits to drop. @i < n@ must hold.+ -> SBV (bv n) -- ^ Input, of size @n@+ -> SBV (bv m) -- ^ Output, of size @m@. @m = n - i@ holds.+bvDrop i = SBV . svExtract start 0 . unSBV+ where nv = intOfProxy (Proxy @n)+ start = nv - fromIntegral (natVal i) - 1++-- | Take bits from the top of a bit-vector.+bvTake :: forall i n bv proxy. ( KnownNat n, BVIsNonZero n+ , KnownNat i, BVIsNonZero i+ , i <= n+ ) => proxy i -- ^ @i@: Number of bits to take. @0 < i <= n@ must hold.+ -> SBV (bv n) -- ^ Input, of size @n@+ -> SBV (bv i) -- ^ Output, of size @i@+bvTake i = SBV . svExtract start end . unSBV+ where nv = intOfProxy (Proxy @n)+ start = nv - 1+ end = start - fromIntegral (natVal i) + 1++-- | A class of values that can be skolemized. Note that we don't export this class. Use+-- the 'skolemize' function instead.+class Skolemize a where+ type SkolemsTo a :: Type+ skolem :: String -> [(SVal, String)] -> a -> SkolemsTo a++ -- | Skolemization. For any formula, skolemization gives back an equisatisfiable formula that+ -- has no existential quantifiers in it. You have to provide enough names for all the+ -- existentials in the argument. (Extras OK, so you can pass an infinite list if you like.)+ -- The names should be distinct, and also different from any other uninterpreted name+ -- you might have elsewhere.+ skolemize :: (Constraint Symbolic (SkolemsTo a), Skolemize a) => a -> SkolemsTo a+ skolemize = skolem "" []++ -- | If you use the same names for skolemized arguments in different functions, they will+ -- collide; which is undesirable. Unfortunately there's no easy way for SBV to detect this.+ -- In such cases, use 'taggedSkolemize' to add a scope to the skolem-function names generated.+ taggedSkolemize :: (Constraint Symbolic (SkolemsTo a), Skolemize a) => String -> a -> SkolemsTo a+ taggedSkolemize scope = skolem (scope ++ "_") []++-- | Base case; pure symbolic values+instance Skolemize (SBV a) where+ type SkolemsTo (SBV a) = SBV a+ skolem _ _ = id++-- | Skolemize over a universal quantifier+instance (KnownSymbol nm, Skolemize r) => Skolemize (Forall nm a -> r) where+ type SkolemsTo (Forall nm a -> r) = Forall nm a -> SkolemsTo r+ skolem scope args f arg@(Forall a) = skolem scope (args ++ [(unSBV a, symbolVal (Proxy @nm))]) (f arg)++-- | Skolemize over a o pair universal quantifier+instance (KnownSymbol na, KnownSymbol nb, Skolemize r) => Skolemize ((Forall na a, Forall nb b) -> r) where+ type SkolemsTo ((Forall na a, Forall nb b) -> r) = (Forall na a, Forall nb b) -> SkolemsTo r+ skolem scope args f = uncurry (skolem scope args (curry f))++-- | Skolemize over a number of universal quantifiers+instance (KnownSymbol nm, Skolemize r) => Skolemize (ForallN n nm a -> r) where+ type SkolemsTo (ForallN n nm a -> r) = ForallN n nm a -> SkolemsTo r+ skolem scope args f arg@(ForallN xs) = skolem scope (args ++ zipWith grab xs [(1::Int)..]) (f arg)+ where pre = symbolVal (Proxy @nm)+ grab x i = (unSBV x, pre ++ "_" ++ show i)++-- | Skolemize over an existential quantifier+instance (HasKind a, KnownSymbol nm, Skolemize r) => Skolemize (Exists nm a -> r) where+ type SkolemsTo (Exists nm a -> r) = SkolemsTo r+ skolem scope args f = skolem scope args (f (Exists skolemized))+ where skolemized = SBV $ svUninterpretedNamedArgs (kindOf (Proxy @a)) (UIGiven (scope ++ symbolVal (Proxy @nm))) (UINone True) args++-- | Skolemize over a o pair existential quantifier+instance (HasKind a, HasKind b, KnownSymbol na, KnownSymbol nb, Skolemize r) => Skolemize ((Exists na a, Exists nb b) -> r) where+ type SkolemsTo ((Exists na a, Exists nb b) -> r) = SkolemsTo r+ skolem scope args = skolem scope args . curry++-- | Skolemize over a number of existential quantifiers+instance (HasKind a, KnownNat n, KnownSymbol nm, Skolemize r) => Skolemize (ExistsN n nm a -> r) where+ type SkolemsTo (ExistsN n nm a -> r) = SkolemsTo r+ skolem scope args f = skolem scope args (f (ExistsN skolemized))+ where need = intOfProxy (Proxy @n)+ prefix = symbolVal (Proxy @nm)+ fs = [prefix ++ "_" ++ show i | i <- [1 .. need]]+ skolemized = [SBV $ svUninterpretedNamedArgs (kindOf (Proxy @a)) (UIGiven (scope ++ n)) (UINone True) args | n <- fs]++-- | Skolemize over a unique existential quantifier+instance ( HasKind a+ , EqSymbolic (SBV a)+ , KnownSymbol nm+ , QuantifiedBool r+ , Skolemize (Forall (AppendSymbol nm "_eu1") a -> Forall (AppendSymbol nm "_eu2") a -> SBool)+ ) => Skolemize (ExistsUnique nm a -> r) where+ type SkolemsTo (ExistsUnique nm a -> r) = Forall (AppendSymbol nm "_eu1") a+ -> Forall (AppendSymbol nm "_eu2") a+ -> SBool+ skolem scope args f = skolem scope args (rewriteExistsUnique f (Exists skolemized))+ where skolemized = SBV $ svUninterpretedNamedArgs (kindOf (Proxy @a)) (UIGiven (scope ++ symbolVal (Proxy @nm))) (UINone True) args++-- | Class of things that we can logically negate+class QNot a where+ type NegatesTo a :: Type+ -- | Negation of a quantified formula. This operation essentially lifts 'sNot' to quantified formulae.+ -- Note that you can achieve the same using @'sNot' . 'quantifiedBool'@, but that will hide the+ -- quantifiers, so prefer this version if you want to keep them around.+ qNot :: a -> NegatesTo a++-- | Base case; pure symbolic boolean+instance QNot SBool where+ type NegatesTo SBool = SBool+ qNot = sNot++-- | Negate over a universal quantifier. Switches to existential.+instance QNot r => QNot (Forall nm a -> r) where+ type NegatesTo (Forall nm a -> r) = Exists nm a -> NegatesTo r+ qNot f (Exists a) = qNot (f (Forall a))++-- | Negate over a number of universal quantifiers+instance QNot r => QNot (ForallN nm n a -> r) where+ type NegatesTo (ForallN nm n a -> r) = ExistsN nm n a -> NegatesTo r+ qNot f (ExistsN xs) = qNot (f (ForallN xs))++-- | Negate over an existential quantifier. Switches to universal.+instance QNot r => QNot (Exists nm a -> r) where+ type NegatesTo (Exists nm a -> r) = Forall nm a -> NegatesTo r+ qNot f (Forall a) = qNot (f (Exists a))++-- | Negate over a number of existential quantifiers+instance QNot r => QNot (ExistsN nm n a -> r) where+ type NegatesTo (ExistsN nm n a -> r) = ForallN nm n a -> NegatesTo r+ qNot f (ForallN xs) = qNot (f (ExistsN xs))++-- | Negate over a unique existential quantifier+instance (QNot r, QuantifiedBool r, EqSymbolic (SBV a)) => QNot (ExistsUnique nm a -> r) where+ type NegatesTo (ExistsUnique nm a -> r) = Forall nm a+ -> Exists (AppendSymbol nm "_eu1") a+ -> Exists (AppendSymbol nm "_eu2") a+ -> SBool+ qNot = qNot . rewriteExistsUnique++-- | Negate over a pair of universals+instance QNot r => QNot ((Forall na a, Forall nb b) -> r) where+ type NegatesTo ((Forall na a, Forall nb b) -> r) = (Exists na a, Exists nb b) -> NegatesTo r+ qNot f (Exists a, Exists b) = qNot (f (Forall a, Forall b))++-- | Negate over a pair of existentials+instance QNot r => QNot ((Exists na a, Exists nb b) -> r) where+ type NegatesTo ((Exists na a, Exists nb b) -> r) = (Forall na a, Forall nb b) -> NegatesTo r+ qNot f (Forall a, Forall b) = qNot (f (Exists a, Exists b))++-- | Get rid of exists unique.+rewriteExistsUnique :: ( QuantifiedBool b -- If b can be turned into a boolean+ , EqSymbolic (SBV a) -- If we can do equality on symbolic a's+ ) -- THEN+ => (ExistsUnique nm a -> b) -- Given an unique-existential, we can+ -> Exists nm a -- Turn it into an existential+ -> Forall (AppendSymbol nm "_eu1") a -- A universal+ -> Forall (AppendSymbol nm "_eu2") a -- Another universal+ -> SBool -- Making sure given holds, and if both univers hold, they're the same+rewriteExistsUnique f (Exists x) (Forall x1) (Forall x2) = fx .&& unique+ where fx = quantifiedBool $ f (ExistsUnique x)+ fx1 = f (ExistsUnique x1)+ fx2 = f (ExistsUnique x2)++ bothHolds = quantifiedBool fx1 .&& quantifiedBool fx2+ mustEqual = x1 .== x2+ unique = bothHolds .=> mustEqual
Data/SBV/Core/Floating.hs view
@@ -11,15 +11,14 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Floating ( IEEEFloating(..), IEEEFloatConvertible(..)@@ -28,8 +27,11 @@ , blastSFloat, blastSDouble, blastSFloatingPoint , sFloatAsComparableSWord32, sDoubleAsComparableSWord64, sFloatingPointAsComparableSWord , sComparableSWord32AsSFloat, sComparableSWord64AsSDouble, sComparableSWordAsSFloatingPoint+ , svFloatingPointAsSWord ) where +import Control.Monad (when, guard)+ import Data.Bits (testBit) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64)@@ -38,7 +40,7 @@ import Data.SBV.Core.AlgReals (isExactRational) import Data.SBV.Core.Sized-import Data.SBV.Core.SizedFloats+import Data.SBV.Core.SizedFloats hiding (fpIsNaN, fpIsZero) import Data.SBV.Core.Data import Data.SBV.Core.Kind@@ -47,8 +49,6 @@ import Data.SBV.Utils.Numeric -import Data.Ratio- import GHC.TypeLits import LibBF@@ -294,7 +294,7 @@ instance IEEEFloatConvertible AlgReal where toSFloat = genericToFloat (onlyWhenRNE convertWhenExactRational) toSDouble = genericToFloat (onlyWhenRNE convertWhenExactRational)- toSFloatingPoint = genericToFloat (const convertWhenExactRational)+ toSFloatingPoint = genericToFloat (onlyWhenRNE convertWhenExactRational) -- Arbitrary floats can handle all rounding modes in concrete mode instance ValidFloat eb sb => IEEEFloatConvertible (FloatingPoint eb sb) where@@ -330,45 +330,46 @@ where ei = intOfProxy (Proxy @eb) si = intOfProxy (Proxy @sb) + toSFloatingPoint :: forall eb1 sb1. (ValidFloat eb sb, ValidFloat eb1 sb1) => SRoundingMode -> SBV (FloatingPoint eb sb) -> SFloatingPoint eb1 sb1 toSFloatingPoint rm i | Just (FloatingPoint (FP _ _ v)) <- unliteral i, Just brm <- rmToRM rm = literal $ FloatingPoint $ FP ei si $ fst (bfRoundFloat (mkBFOpts ei si brm) v) | True = genericToFloat (\_ _ -> Nothing) rm i- where ei = intOfProxy (Proxy @eb)- si = intOfProxy (Proxy @sb)+ where ei = intOfProxy (Proxy @eb1)+ si = intOfProxy (Proxy @sb1) -- From and To are the same when the source is an arbitrary float! fromSFloatingPoint = toSFloatingPoint +-- | Is this RM safe to concretely calculate with? OK if there's no RM for this op, or if it is RNE+safeRM :: Maybe SRoundingMode -> Bool+safeRM Nothing = True+safeRM (Just srm) | Just RoundNearestTiesToEven <- unliteral srm = True+ | True = False+ -- | Concretely evaluate one arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data concEval1 :: SymVal a => Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> Maybe (SBV a) concEval1 mbOp mbRm a = do op <- mbOp v <- unliteral a- case unliteral =<< mbRm of- Nothing -> (Just . literal) (op v)- Just RoundNearestTiesToEven -> (Just . literal) (op v)- _ -> Nothing+ guard (safeRM mbRm)+ pure $ literal (op v) -- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data concEval2 :: SymVal a => Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe (SBV a) concEval2 mbOp mbRm a b = do op <- mbOp v1 <- unliteral a v2 <- unliteral b- case unliteral =<< mbRm of- Nothing -> (Just . literal) (v1 `op` v2)- Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2)- _ -> Nothing+ guard (safeRM mbRm)+ pure $ literal (v1 `op` v2) -- | Concretely evaluate a bool producing two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data concEval2B :: SymVal a => Maybe (a -> a -> Bool) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe SBool concEval2B mbOp mbRm a b = do op <- mbOp v1 <- unliteral a v2 <- unliteral b- case unliteral =<< mbRm of- Nothing -> (Just . literal) (v1 `op` v2)- Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2)- _ -> Nothing+ guard (safeRM mbRm)+ pure $ literal (v1 `op` v2) -- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data concEval3 :: SymVal a => Maybe (a -> a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -> Maybe (SBV a)@@ -376,16 +377,14 @@ v1 <- unliteral a v2 <- unliteral b v3 <- unliteral c- case unliteral =<< mbRm of- Nothing -> (Just . literal) (op v1 v2 v3)- Just RoundNearestTiesToEven -> (Just . literal) (op v1 v2 v3)- _ -> Nothing+ guard (safeRM mbRm)+ pure $ literal (op v1 v2 v3) -- | Add the converted rounding mode if given as an argument addRM :: State -> Maybe SRoundingMode -> [SV] -> IO [SV]-addRM _ Nothing as = return as+addRM _ Nothing as = pure as addRM st (Just rm) as = do svm <- sbvToSV st rm- return (svm : as)+ pure (svm : as) -- | Lift a 1 arg FP-op lift1 :: SymVal a => FPOp -> Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a@@ -528,12 +527,17 @@ -- and it works as long as you do not have a @NaN@. sFloatAsComparableSWord32 :: SFloat -> SWord32 sFloatAsComparableSWord32 f = ite (fpIsNegativeZero f) (sFloatAsComparableSWord32 0) (fromBitsBE $ sNot sb : ite sb (map sNot rest) rest)- where (sb : rest) = blastBE $ sFloatAsSWord32 f+ where (sb, rest) = case blastBE $ sFloatAsSWord32 f of+ b : bs -> (b, bs)+ [] -> error "sFloatAsComparableSWord32: impossible, blastBE produced empty list" -- | Inverse transformation to 'sFloatAsComparableSWord32'. sComparableSWord32AsSFloat :: SWord32 -> SFloat sComparableSWord32AsSFloat w = sWord32AsSFloat $ ite sb (fromBitsBE $ sFalse : rest) (fromBitsBE $ map sNot allBits)- where allBits@(sb : rest) = blastBE w+ where allBits = blastBE w+ (sb, rest) = case allBits of+ b : bs -> (b, bs)+ [] -> error "sComparableSWord32AsSFloat: impossible, blastBE produced empty list" -- | Convert a double to a comparable 'SWord64'. The trick is to ignore the -- sign of -0, and if it's a negative value flip all the bits, and otherwise@@ -541,13 +545,18 @@ -- and it works as long as you do not have a @NaN@. sDoubleAsComparableSWord64 :: SDouble -> SWord64 sDoubleAsComparableSWord64 d = ite (fpIsNegativeZero d) (sDoubleAsComparableSWord64 0) (fromBitsBE $ sNot sb : ite sb (map sNot rest) rest)- where (sb : rest) = blastBE $ sDoubleAsSWord64 d+ where (sb, rest) = case blastBE $ sDoubleAsSWord64 d of+ b : bs -> (b, bs)+ [] -> error "sDoubleAsComparableSWord64: impossible, blastBE produced empty list" -- | Inverse transformation to 'sDoubleAsComparableSWord64'. Note that this isn't a perfect inverse, since @-0@ maps to @0@ and back to @0@. -- Otherwise, it's faithful: sComparableSWord64AsSDouble :: SWord64 -> SDouble sComparableSWord64AsSDouble w = sWord64AsSDouble $ ite sb (fromBitsBE $ sFalse : rest) (fromBitsBE $ map sNot allBits)- where allBits@(sb : rest) = blastBE w+ where allBits = blastBE w+ (sb, rest) = case allBits of+ b : bs -> (b, bs)+ [] -> error "sComparableSWord64AsSDouble: impossible, blastBE produced empty list" -- | 'Float' instance for 'Metric' goes through the lexicographic ordering on 'Word32'. -- It implicitly makes sure that the value is not @NaN@.@@ -558,11 +567,17 @@ fromMetricSpace = sComparableSWord32AsSFloat msMinimize nm o = do constrain $ sNot $ fpIsNaN o- addSValOptGoal $ unSBV `fmap` Minimize nm (toMetricSpace o)+ let nm' = annotateForMS (Proxy @Float) nm+ when (nm' /= nm) $ sObserve nm (unSBV o)+ addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) msMaximize nm o = do constrain $ sNot $ fpIsNaN o- addSValOptGoal $ unSBV `fmap` Maximize nm (toMetricSpace o)+ let nm' = annotateForMS (Proxy @Float) nm+ when (nm' /= nm) $ sObserve nm (unSBV o)+ addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) + annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"+ -- | 'Double' instance for 'Metric' goes through the lexicographic ordering on 'Word64'. -- It implicitly makes sure that the value is not @NaN@. instance Metric Double where@@ -572,30 +587,16 @@ fromMetricSpace = sComparableSWord64AsSDouble msMinimize nm o = do constrain $ sNot $ fpIsNaN o- addSValOptGoal $ unSBV `fmap` Minimize nm (toMetricSpace o)+ let nm' = annotateForMS (Proxy @Double) nm+ when (nm' /= nm) $ sObserve nm (unSBV o)+ addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) msMaximize nm o = do constrain $ sNot $ fpIsNaN o- addSValOptGoal $ unSBV `fmap` Maximize nm (toMetricSpace o)---- | 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+ let nm' = annotateForMS (Proxy @Double) nm+ when (nm' /= nm) $ sObserve nm (unSBV o)+ addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) --- | 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+ annotateForMS _ s = "toMetricSpace(" ++ s ++ ")" -- | 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@@ -622,13 +623,18 @@ sFloatingPointAsComparableSWord :: forall eb sb. (ValidFloat eb sb, KnownNat (eb + sb), BVIsNonZero (eb + sb)) => SFloatingPoint eb sb -> SWord (eb + sb) sFloatingPointAsComparableSWord f = ite (fpIsNegativeZero f) posZero (fromBitsBE $ sNot sb : ite sb (map sNot rest) rest) where posZero = sFloatingPointAsComparableSWord (0 :: SFloatingPoint eb sb)- (sb : rest) = blastBE (sFloatingPointAsSWord f :: SWord (eb + sb))+ (sb, rest) = case blastBE (sFloatingPointAsSWord f :: SWord (eb + sb)) of+ b : bs -> (b, bs)+ [] -> error "sFloatingPointAsComparableSWord: impossible, blastBE produced empty list" -- | Inverse transformation to 'sFloatingPointAsComparableSWord'. Note that this isn't a perfect inverse, since @-0@ maps to @0@ and back to @0@. -- Otherwise, it's faithful: sComparableSWordAsSFloatingPoint :: forall eb sb. (KnownNat (eb + sb), BVIsNonZero (eb + sb), ValidFloat eb sb) => SWord (eb + sb) -> SFloatingPoint eb sb sComparableSWordAsSFloatingPoint w = sWordAsSFloatingPoint $ ite signBit (fromBitsBE $ sFalse : rest) (fromBitsBE $ map sNot allBits)- where allBits@(signBit : rest) = blastBE w+ where allBits = blastBE w+ (signBit, rest) = case allBits of+ b : bs -> (b, bs)+ [] -> error "sComparableSWordAsSFloatingPoint: impossible, blastBE produced empty list" -- | Convert a word to an arbitrary float, by reinterpreting the bits of the word as the corresponding bits of the float. sWordAsSFloatingPoint :: forall eb sb. (KnownNat (eb + sb), BVIsNonZero (eb + sb), ValidFloat eb sb) => SWord (eb + sb) -> SFloatingPoint eb sb@@ -660,19 +666,20 @@ fromMetricSpace = sComparableSWordAsSFloatingPoint msMinimize nm o = do constrain $ sNot $ fpIsNaN o- addSValOptGoal $ unSBV `fmap` Minimize nm (toMetricSpace o)+ let nm' = annotateForMS (Proxy @(FloatingPoint eb sb)) nm+ when (nm' /= nm) $ sObserve nm (unSBV o)+ addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) msMaximize nm o = do constrain $ sNot $ fpIsNaN o- addSValOptGoal $ unSBV `fmap` Maximize nm (toMetricSpace o)+ let nm' = annotateForMS (Proxy @(FloatingPoint eb sb)) nm+ when (nm' /= nm) $ sObserve nm (unSBV o)+ addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) + annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"+ -- Map SBV's rounding modes to LibBF's rmToRM :: SRoundingMode -> Maybe RoundMode-rmToRM srm = cvt <$> unliteral srm- where cvt RoundNearestTiesToEven = NearEven- cvt RoundNearestTiesToAway = NearAway- cvt RoundTowardPositive = ToPosInf- cvt RoundTowardNegative = ToNegInf- cvt RoundTowardZero = ToZero+rmToRM srm = roundingModeToRoundMode <$> unliteral srm -- | Lift a 1 arg Big-float op lift1FP :: forall eb sb. ValidFloat eb sb =>@@ -730,12 +737,12 @@ -- Sized-floats have a special instance, since it can handle arbitrary rounding modes when it matters. instance ValidFloat eb sb => IEEEFloating (FloatingPoint eb sb) where- fpAdd = lift2FP bfAdd (lift2 FP_Add (Just (+)))- fpSub = lift2FP bfSub (lift2 FP_Sub (Just (-)))- fpMul = lift2FP bfMul (lift2 FP_Mul (Just (*)))- fpDiv = lift2FP bfDiv (lift2 FP_Div (Just (/)))- fpFMA = lift3FP bfFMA (lift3 FP_FMA Nothing)- fpSqrt = lift1FP bfSqrt (lift1 FP_Sqrt (Just sqrt))+ fpAdd = lift2FP bfAdd (lift2 FP_Add (Just (+)))+ fpSub = lift2FP bfSub (lift2 FP_Sub (Just (-)))+ fpMul = lift2FP bfMul (lift2 FP_Mul (Just (*)))+ fpDiv = lift2FP bfDiv (lift2 FP_Div (Just (/)))+ fpFMA = lift3FP bfFMA (lift3 FP_FMA Nothing)+ fpSqrt = lift1FP bfSqrt (lift1 FP_Sqrt (Just sqrt)) fpRoundToIntegral rm a | Just (FloatingPoint (FP ei si v)) <- unliteral a@@ -763,4 +770,4 @@ -- fpIsPositiveZero :: SBV a -> SBool -- fpIsPoint :: SBV a -> SBool -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore module "Reduce duplication" -}
Data/SBV/Core/Kind.hs view
@@ -11,75 +11,128 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Kind (- Kind(..), HasKind(..), constructUKind, smtType, hasUninterpretedSorts+ Kind(..), HasKind(..), smtType, hasUninterpretedSorts , BVIsNonZero, ValidFloat, intOfProxy- , showBaseKind, needsFlattening, RoundingMode(..), smtRoundingMode+ , showBaseKind, needsFlattening+ , eqCheckIsObjectEq, containsFloats, isSomeKindOfFloat, expandKinds+ , substituteADTVars+ , kRoundingMode ) where -import qualified Data.Generics as G (Data(..), DataType, dataTypeName, dataTypeOf, tyconUQname, dataTypeConstrs, constrFields)+import qualified Data.Generics as G (Data(..), DataType, dataTypeName, tyconUQname) import Data.Char (isSpace)- import Data.Int import Data.Word import Data.SBV.Core.AlgReals+import Data.Text (Text)+import qualified Data.Text as T import Data.Proxy import Data.Kind -import Data.List (isPrefixOf, intercalate)+import Data.List (intercalate, sort)+import Control.DeepSeq (NFData) +import Data.Containers.ListUtils (nubOrd)+ import Data.Typeable (Typeable) import Data.Type.Bool import Data.Type.Equality import GHC.TypeLits -import Data.SBV.Utils.Lib (isKString)+import Data.SBV.Utils.Lib (isKString, showText)+import Data.SBV.Utils.Numeric (RoundingMode) +import GHC.Generics+import qualified Data.Generics.Uniplate.Data as G+ -- | Kind of symbolic value-data Kind = KBool+data Kind =+ -- Base types+ KBool++ -- Word and Int. Boolean is True for Int. | KBounded !Bool !Int++ -- Unbounded integers | KUnbounded++ -- Reals | KReal- | KUserSort String (Maybe [String]) -- name. Uninterpreted, or enumeration constants.++ -- Floats, standard and generalized | KFloat | KDouble | KFP !Int !Int++ -- Rationals+ | KRational++ -- Chars and strings | KChar | KString++ -- Algebraic datatypes+ | KVar String -- only used temporarily during ADT construction+ | KApp String [Kind] -- Application of a constructor to a bunch of types+ | KADT String+ [(String, Kind)] -- Parameters, applied to these args+ [(String, [Kind])] -- Constructors, and their fields++ -- Collections | KList Kind | KSet Kind | KTuple [Kind]- | KMaybe Kind- | KRational- | KEither Kind Kind- deriving (Eq, Ord, G.Data) --- | The interesting about the show instance is that it can tell apart two kinds nicely; since it conveniently--- ignores the enumeration constructors. Also, when we construct a 'KUserSort', we make sure we don't use any of--- the reserved names; see 'constructUKind' for details.+ -- Arrays+ | KArray Kind Kind+ deriving (Eq, Ord, G.Data, NFData, Generic)++-- | Built in kind for rounding mode+kRoundingMode :: Kind+kRoundingMode = KADT "RoundingMode" [] (map (\r -> (show r, [])) [minBound .. maxBound :: RoundingMode])++-- | Expand such that the resulting list has all the kinds we touch+expandKinds :: Kind -> [Kind]+expandKinds = sort . nubOrd . G.universe++-- | For an ADT kind, substitute kinds for the variables.+substituteADTVars :: String -> [(String, Kind)] -> Kind -> Kind+substituteADTVars t dict = G.transform sub+ where sub :: Kind -> Kind+ sub (KVar v)+ | Just k <- v `lookup` dict = k+ | True = error $ "Data.SBV.ADT: Kind find variable in param subst: " ++ show (t, v, dict)+ sub k = k++-- | The interesting about the show instance is that it can tell apart two kinds nicely. Otherwise the string produced isn't parsed back. instance Show Kind where+ show (KVar s) = s show KBool = "SBool" show (KBounded False n) = pickType n "SWord" "SWord " ++ show n show (KBounded True n) = pickType n "SInt" "SInt " ++ show n show KUnbounded = "SInteger" show KReal = "SReal"- show (KUserSort s _) = s+ show (KApp c ks) = unwords (c : map (T.unpack . kindParen . showBaseKind ) ks)+ show (KADT s pks _) = unwords (s : map (T.unpack . kindParen . showBaseKind . snd) pks) show KFloat = "SFloat" show KDouble = "SDouble" show (KFP eb sb) = "SFloatingPoint " ++ show eb ++ " " ++ show sb@@ -88,69 +141,73 @@ show (KList e) = "[" ++ show e ++ "]" show (KSet e) = "{" ++ show e ++ "}" show (KTuple m) = "(" ++ intercalate ", " (show <$> m) ++ ")"- show (KMaybe k) = "SMaybe " ++ kindParen (showBaseKind k)- show (KEither k1 k2) = "SEither " ++ kindParen (showBaseKind k1) ++ " " ++ kindParen (showBaseKind k2) show KRational = "SRational"+ show (KArray k1 k2) = "SArray " ++ T.unpack (kindParen (showBaseKind k1)) ++ " " ++ T.unpack (kindParen (showBaseKind k2)) --- | A version of show for kinds that says Bool instead of SBool-showBaseKind :: Kind -> String+-- | A version of show for kinds that says Bool instead of SBool, Float instead of SFloat, etc.+showBaseKind :: Kind -> Text showBaseKind = sh- where sh k@KBool = noS (show k)- sh (KBounded False n) = pickType n "Word" "WordN " ++ show n- sh (KBounded True n) = pickType n "Int" "IntN " ++ show n- sh k@KUnbounded = noS (show k)- sh k@KReal = noS (show k)- sh k@KUserSort{} = show k -- Leave user-sorts untouched!- sh k@KFloat = noS (show k)- sh k@KDouble = noS (show k)- sh k@KFP{} = noS (show k)- sh k@KChar = noS (show k)- sh k@KString = noS (show k)+ where sh (KVar s) = T.pack s+ sh k@KBool = noS (showText k)+ sh (KBounded False n) = T.pack (pickType n "Word" "WordN ") <> showText n+ sh (KBounded True n) = T.pack (pickType n "Int" "IntN ") <> showText n+ sh (KApp s ks) = T.unwords (T.pack s : map (kindParen . sh) ks)+ sh k@KUnbounded = noS (showText k)+ sh k@KReal = noS (showText k)+ sh k@KADT{} = showText k -- Leave user-sorts untouched!+ sh k@KFloat = noS (showText k)+ sh k@KDouble = noS (showText k)+ sh k@KFP{} = noS (showText k)+ sh k@KChar = noS (showText k)+ sh k@KString = noS (showText k) sh KRational = "Rational"- sh (KList k) = "[" ++ sh k ++ "]"- sh (KSet k) = "{" ++ sh k ++ "}"- sh (KTuple ks) = "(" ++ intercalate ", " (map sh ks) ++ ")"- sh (KMaybe k) = "Maybe " ++ kindParen (sh k)- sh (KEither k1 k2) = "Either " ++ kindParen (sh k1) ++ " " ++ kindParen (sh k2)+ sh (KList k) = "[" <> sh k <> "]"+ sh (KSet k) = "{" <> sh k <> "}"+ sh (KTuple ks) = "(" <> T.intercalate ", " (map sh ks) <> ")"+ sh (KArray k1 k2) = "Array " <> kindParen (sh k1) <> " " <> kindParen (sh k2) -- Drop the initial S if it's there- noS ('S':s) = s- noS s = s+ noS s = case T.uncons s of+ Just ('S', rest) -> rest+ _ -> s --- For historical reasons, we show 8-16-32-64 bit values with no space; others with a space. +-- For historical reasons, we show 8-16-32-64 bit values with no space; others with a space. pickType :: Int -> String -> String -> String pickType i standard other | i `elem` [8, 16, 32, 64] = standard | True = other -- | Put parens if necessary. This test is rather crummy, but seems to work ok-kindParen :: String -> String-kindParen s@('[':_) = s-kindParen s@('(':_) = s-kindParen s | any isSpace s = '(' : s ++ ")"- | True = s+kindParen :: Text -> Text+kindParen s = case T.uncons s of+ Just ('[', _) -> s+ Just ('(', _) -> s+ _ -> if T.any isSpace s+ then T.singleton '(' <> s <> T.singleton ')'+ else s -- | How the type maps to SMT land-smtType :: Kind -> String+smtType :: Kind -> Text+smtType (KVar s) = T.pack s smtType KBool = "Bool"-smtType (KBounded _ sz) = "(_ BitVec " ++ show sz ++ ")"+smtType (KBounded _ sz) = "(_ BitVec " <> showText sz <> ")" smtType KUnbounded = "Int" smtType KReal = "Real" smtType KFloat = "(_ FloatingPoint 8 24)" smtType KDouble = "(_ FloatingPoint 11 53)"-smtType (KFP eb sb) = "(_ FloatingPoint " ++ show eb ++ " " ++ show sb ++ ")"+smtType (KFP eb sb) = "(_ FloatingPoint " <> showText eb <> " " <> showText sb <> ")" smtType KString = "String" smtType KChar = "String"-smtType (KList k) = "(Seq " ++ smtType k ++ ")"-smtType (KSet k) = "(Array " ++ smtType k ++ " Bool)"-smtType (KUserSort s _) = s+smtType (KList k) = "(Seq " <> smtType k <> ")"+smtType (KSet k) = "(Array " <> smtType k <> " Bool)"+smtType (KApp s ks) = kindParen $ T.unwords (T.pack s : map smtType ks)+smtType (KADT s pks _) = kindParen $ T.unwords (T.pack s : map (smtType . snd) pks) smtType (KTuple []) = "SBVTuple0"-smtType (KTuple kinds) = "(SBVTuple" ++ show (length kinds) ++ " " ++ unwords (smtType <$> kinds) ++ ")"+smtType (KTuple kinds) = "(SBVTuple" <> showText (length kinds) <> " " <> T.unwords (smtType <$> kinds) <> ")" smtType KRational = "SBVRational"-smtType (KMaybe k) = "(SBVMaybe " ++ smtType k ++ ")"-smtType (KEither k1 k2) = "(SBVEither " ++ smtType k1 ++ " " ++ smtType k2 ++ ")"+smtType (KArray k1 k2) = "(Array " <> smtType k1 <> " " <> smtType k2 <> ")" -instance Eq G.DataType where+instance Eq G.DataType where a == b = G.tyconUQname (G.dataTypeName a) == G.tyconUQname (G.dataTypeName b) instance Ord G.DataType where@@ -158,7 +215,8 @@ -- | Does this kind represent a signed quantity? kindHasSign :: Kind -> Bool-kindHasSign = \case KBool -> False+kindHasSign = \case KVar _ -> False+ KBool -> False KBounded b _ -> b KUnbounded -> True KReal -> True@@ -166,46 +224,14 @@ KDouble -> True KFP{} -> True KRational -> True- KUserSort{} -> False+ KApp{} -> False+ KADT{} -> False KString -> False KChar -> False KList{} -> False KSet{} -> False KTuple{} -> False- KMaybe{} -> False- KEither{} -> False---- | Construct an uninterpreted/enumerated kind from a piece of data; we distinguish simple enumerations as those--- are mapped to proper SMT-Lib2 data-types; while others go completely uninterpreted-constructUKind :: forall a. (Read a, G.Data a) => a -> Kind-constructUKind a- | any (`isPrefixOf` sortName) badPrefixes- = error $ unlines [ "*** Data.SBV: Cannot construct user-sort with name: " ++ show sortName- , "***"- , "*** Must not start with any of: " ++ intercalate ", " badPrefixes- ]- | True- = case (constrs, concatMap G.constrFields constrs) of- ([], _) -> KUserSort sortName Nothing- (cs, []) -> KUserSort sortName $ Just (map show cs)- _ -> error $ unlines [ "*** Data.SBV: " ++ sortName ++ " is not an enumeration."- , "***"- , "*** To declare an enumeration, constructors should not have any fields."- , "*** To declare an uninterpreted sort, use a datatype with no constructors."- ]-- where -- make sure we don't step on ourselves:- -- NB. The sort "RoundingMode" is special. It's treated by SBV as a user-defined- -- sort, even though it's internally handled differently. So, that name doesn't appear- -- below.- badPrefixes = [ "SBool", "SWord", "SInt", "SInteger", "SReal", "SFloat", "SDouble"- , "SString", "SChar", "[", "SSet", "STuple", "SMaybe", "SEither"- , "SRational"- ]-- dataType = G.dataTypeOf a- sortName = G.tyconUQname . G.dataTypeName $ dataType- constrs = G.dataTypeConstrs dataType+ KArray{} -> False -- | A class for capturing values that have a sign and a size (finite or infinite) -- minimal complete definition: kindOf, unless you can take advantage of the default@@ -213,30 +239,34 @@ -- a 'G.Data' instance; this is useful for creating uninterpreted sorts. So, in -- reality, end users should almost never need to define any methods. class HasKind a where- kindOf :: a -> Kind- hasSign :: a -> Bool- intSizeOf :: a -> Int- isBoolean :: a -> Bool- isBounded :: a -> Bool -- NB. This really means word/int; i.e., Real/Float will test False- isReal :: a -> Bool- isFloat :: a -> Bool- isDouble :: a -> Bool- isRational :: a -> Bool- isFP :: a -> Bool- isUnbounded :: a -> Bool- isUserSort :: a -> Bool- isChar :: a -> Bool- isString :: a -> Bool- isList :: a -> Bool- isSet :: a -> Bool- isTuple :: a -> Bool- isMaybe :: a -> Bool- isEither :: a -> Bool- showType :: a -> String+ kindOf :: a -> Kind+ hasSign :: a -> Bool+ intSizeOf :: a -> Int+ isBoolean :: a -> Bool+ isBounded :: a -> Bool -- NB. This really means word/int; i.e., Real/Float will test False+ isReal :: a -> Bool+ isFloat :: a -> Bool+ isDouble :: a -> Bool+ isRational :: a -> Bool+ isFP :: a -> Bool+ isUnbounded :: a -> Bool+ isADT :: a -> Bool+ isChar :: a -> Bool+ isString :: a -> Bool+ isList :: a -> Bool+ isSet :: a -> Bool+ isTuple :: a -> Bool+ isArray :: a -> Bool+ isRoundingMode :: a -> Bool+ isUninterpreted :: a -> Bool++ showType :: a -> String+ -- defaults hasSign x = kindHasSign (kindOf x) intSizeOf x = case kindOf x of+ KVar{} -> error "SBV.HasKind.intSizeOf(KVar)" KBool -> error "SBV.HasKind.intSizeOf((S)Bool)" KBounded _ s -> s KUnbounded -> error "SBV.HasKind.intSizeOf((S)Integer)"@@ -245,14 +275,14 @@ KDouble -> 64 KFP i j -> i + j KRational -> error "SBV.HasKind.intSizeOf((S)Rational)"- KUserSort s _ -> error $ "SBV.HasKind.intSizeOf: Uninterpreted sort: " ++ s+ KApp s _ -> error $ "SBV.HasKind.intSizeOf: Type application: " ++ s+ KADT s _ _ -> error $ "SBV.HasKind.intSizeOf: Algebraic data type: " ++ s KString -> error "SBV.HasKind.intSizeOf((S)Double)" KChar -> error "SBV.HasKind.intSizeOf((S)Char)"- KList ek -> error $ "SBV.HasKind.intSizeOf((S)List)" ++ show ek- KSet ek -> error $ "SBV.HasKind.intSizeOf((S)Set)" ++ show ek- KTuple tys -> error $ "SBV.HasKind.intSizeOf((S)Tuple)" ++ show tys- KMaybe k -> error $ "SBV.HasKind.intSizeOf((S)Maybe)" ++ show k- KEither k1 k2 -> error $ "SBV.HasKind.intSizeOf((S)Either)" ++ show (k1, k2)+ KList ek -> error $ "SBV.HasKind.intSizeOf((S)List)" ++ show ek+ KSet ek -> error $ "SBV.HasKind.intSizeOf((S)Set)" ++ show ek+ KTuple tys -> error $ "SBV.HasKind.intSizeOf((S)Tuple)" ++ show tys+ KArray k1 k2 -> error $ "SBV.HasKind.intSizeOf((S)Array)" ++ show (k1, k2) isBoolean (kindOf -> KBool{}) = True isBoolean _ = False@@ -278,8 +308,8 @@ isUnbounded (kindOf -> KUnbounded{}) = True isUnbounded _ = False - isUserSort (kindOf -> KUserSort{}) = True- isUserSort _ = False+ isADT (kindOf -> KADT{}) = True+ isADT _ = False isChar (kindOf -> KChar{}) = True isChar _ = False@@ -296,38 +326,40 @@ isTuple (kindOf -> KTuple{}) = True isTuple _ = False - isMaybe (kindOf -> KMaybe{}) = True- isMaybe _ = False+ isArray (kindOf -> KArray{}) = True+ isArray _ = False - isEither (kindOf -> KEither{}) = True- isEither _ = False+ -- Derived kinds+ isRoundingMode (kindOf -> k) = k == kRoundingMode+ isUninterpreted (kindOf -> k) = case k of+ KADT _ [] [] -> True+ _ -> False showType = show . kindOf - -- default signature for uninterpreted/enumerated kinds- default kindOf :: (Read a, G.Data a) => a -> Kind- kindOf = constructUKind+ {-# MINIMAL kindOf #-} -- | This instance allows us to use the `kindOf (Proxy @a)` idiom instead of -- the `kindOf (undefined :: a)`, which is safer and looks more idiomatic. instance HasKind a => HasKind (Proxy a) where kindOf _ = kindOf (undefined :: a) -instance HasKind Bool where kindOf _ = KBool-instance HasKind Int8 where kindOf _ = KBounded True 8-instance HasKind Word8 where kindOf _ = KBounded False 8-instance HasKind Int16 where kindOf _ = KBounded True 16-instance HasKind Word16 where kindOf _ = KBounded False 16-instance HasKind Int32 where kindOf _ = KBounded True 32-instance HasKind Word32 where kindOf _ = KBounded False 32-instance HasKind Int64 where kindOf _ = KBounded True 64-instance HasKind Word64 where kindOf _ = KBounded False 64-instance HasKind Integer where kindOf _ = KUnbounded-instance HasKind AlgReal where kindOf _ = KReal-instance HasKind Rational where kindOf _ = KRational-instance HasKind Float where kindOf _ = KFloat-instance HasKind Double where kindOf _ = KDouble-instance HasKind Char where kindOf _ = KChar+instance HasKind Bool where kindOf _ = KBool+instance HasKind Int8 where kindOf _ = KBounded True 8+instance HasKind Word8 where kindOf _ = KBounded False 8+instance HasKind Int16 where kindOf _ = KBounded True 16+instance HasKind Word16 where kindOf _ = KBounded False 16+instance HasKind Int32 where kindOf _ = KBounded True 32+instance HasKind Word32 where kindOf _ = KBounded False 32+instance HasKind Int64 where kindOf _ = KBounded True 64+instance HasKind Word64 where kindOf _ = KBounded False 64+instance HasKind Integer where kindOf _ = KUnbounded+instance HasKind AlgReal where kindOf _ = KReal+instance HasKind Rational where kindOf _ = KRational+instance HasKind Float where kindOf _ = KFloat+instance HasKind Double where kindOf _ = KDouble+instance HasKind Char where kindOf _ = KChar+instance HasKind RoundingMode where kindOf _ = kRoundingMode -- | Grab the bit-size from the proxy. If the nat is too large to fit in an int, -- we throw an error. (This would mean too big of a bit-size, that we can't@@ -349,25 +381,24 @@ r :: Int r = fromEnum iv +-- | Is this a type we can safely do equality on? Essentially it avoids floats (@NaN@ /= @NaN@, @+0 = -0@), and reals (due+-- to the possible presence of non-exact rationals. In short, this will return True if there are no floats/reals under the hood.+eqCheckIsObjectEq :: Kind -> Bool+eqCheckIsObjectEq = not . any bad . expandKinds+ where bad KReal = True+ bad k = isSomeKindOfFloat k++-- | Same as above, except only for floats+containsFloats :: Kind -> Bool+containsFloats = any isSomeKindOfFloat . expandKinds++-- | Is some sort of a float?+isSomeKindOfFloat :: Kind -> Bool+isSomeKindOfFloat k = isFloat k || isDouble k || isFP k+ -- | Do we have a completely uninterpreted sort lying around anywhere? hasUninterpretedSorts :: Kind -> Bool-hasUninterpretedSorts KBool = False-hasUninterpretedSorts KBounded{} = False-hasUninterpretedSorts KUnbounded = False-hasUninterpretedSorts KReal = False-hasUninterpretedSorts (KUserSort _ (Just _)) = False -- These are the enumerated sorts, and they are perfectly fine-hasUninterpretedSorts (KUserSort _ Nothing) = True -- These are the completely uninterpreted sorts, which we are looking for here-hasUninterpretedSorts KFloat = False-hasUninterpretedSorts KDouble = False-hasUninterpretedSorts KFP{} = False-hasUninterpretedSorts KRational = False-hasUninterpretedSorts KChar = False-hasUninterpretedSorts KString = False-hasUninterpretedSorts (KList k) = hasUninterpretedSorts k-hasUninterpretedSorts (KSet k) = hasUninterpretedSorts k-hasUninterpretedSorts (KTuple ks) = any hasUninterpretedSorts ks-hasUninterpretedSorts (KMaybe k) = hasUninterpretedSorts k-hasUninterpretedSorts (KEither k1 k2) = any hasUninterpretedSorts [k1, k2]+hasUninterpretedSorts = any isUninterpreted . expandKinds instance (Typeable a, HasKind a) => HasKind [a] where kindOf x | isKString @[a] x = KString@@ -400,33 +431,34 @@ instance (HasKind a, HasKind b, HasKind c, HasKind d, HasKind e, HasKind f, HasKind g, HasKind h) => HasKind (a, b, c, d, e, f, g, h) where kindOf _ = KTuple [kindOf (Proxy @a), kindOf (Proxy @b), kindOf (Proxy @c), kindOf (Proxy @d), kindOf (Proxy @e), kindOf (Proxy @f), kindOf (Proxy @g), kindOf (Proxy @h)] -instance (HasKind a, HasKind b) => HasKind (Either a b) where- kindOf _ = KEither (kindOf (Proxy @a)) (kindOf (Proxy @b))--instance HasKind a => HasKind (Maybe a) where- kindOf _ = KMaybe (kindOf (Proxy @a))+instance (HasKind a, HasKind b) => HasKind (a -> b) where+ kindOf _ = KArray (kindOf (Proxy @a)) (kindOf (Proxy @b)) -- | Should we ask the solver to flatten the output? This comes in handy so output is parseable -- Essentially, we're being conservative here and simply requesting flattening anything that has -- some structure to it. needsFlattening :: Kind -> Bool-needsFlattening KBool = False-needsFlattening KBounded{} = False-needsFlattening KUnbounded = False-needsFlattening KReal = False-needsFlattening KUserSort{} = False-needsFlattening KFloat = False-needsFlattening KDouble = False-needsFlattening KFP{} = False-needsFlattening KRational = False-needsFlattening KChar = False-needsFlattening KString = False-needsFlattening KList{} = True-needsFlattening KSet{} = True-needsFlattening KTuple{} = True-needsFlattening KMaybe{} = True-needsFlattening KEither{} = True+needsFlattening = any check . expandKinds+ where check KList{} = True+ check KSet{} = True+ check KTuple{} = True+ check KArray{} = True+ check KApp{} = True+ check k@KADT{} = not (isUninterpreted k || isRoundingMode k) + -- no need to expand bases+ check KVar{} = False+ check KBool = False+ check KBounded{} = False+ check KUnbounded = False+ check KReal = False+ check KFloat = False+ check KDouble = False+ check KFP{} = False+ check KChar = False+ check KString = False+ check KRational = False+ -- | Catch 0-width cases type BVZeroWidth = 'Text "Zero-width bit-vectors are not allowed." @@ -435,8 +467,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@@ -452,7 +482,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@@ -492,29 +521,3 @@ (() :: Constraint) (TypeError (InvalidFloat eb sb)) )---- | Rounding mode to be used for the IEEE floating-point operations.--- Note that Haskell's default is 'RoundNearestTiesToEven'. If you use--- a different rounding mode, then the counter-examples you get may not--- match what you observe in Haskell.-data RoundingMode = RoundNearestTiesToEven -- ^ Round to nearest representable floating point value.- -- If precisely at half-way, pick the even number.- -- (In this context, /even/ means the lowest-order bit is zero.)- | RoundNearestTiesToAway -- ^ Round to nearest representable floating point value.- -- If precisely at half-way, pick the number further away from 0.- -- (That is, for positive values, pick the greater; for negative values, pick the smaller.)- | RoundTowardPositive -- ^ Round towards positive infinity. (Also known as rounding-up or ceiling.)- | RoundTowardNegative -- ^ Round towards negative infinity. (Also known as rounding-down or floor.)- | RoundTowardZero -- ^ Round towards zero. (Also known as truncation.)- deriving (Eq, Ord, Show, Read, G.Data, Bounded, Enum)---- | 'RoundingMode' kind-instance HasKind RoundingMode---- | Convert a rounding mode to the format SMT-Lib2 understands.-smtRoundingMode :: RoundingMode -> String-smtRoundingMode RoundNearestTiesToEven = "roundNearestTiesToEven"-smtRoundingMode RoundNearestTiesToAway = "roundNearestTiesToAway"-smtRoundingMode RoundTowardPositive = "roundTowardPositive"-smtRoundingMode RoundTowardNegative = "roundTowardNegative"-smtRoundingMode RoundTowardZero = "roundTowardZero"
Data/SBV/Core/Model.hs view
@@ -9,2725 +9,4985 @@ -- Instance declarations for our symbolic world ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -Wno-incomplete-uni-patterns #-}--module Data.SBV.Core.Model (- Mergeable(..), Equality(..), EqSymbolic(..), OrdSymbolic(..), SDivisible(..), Uninterpreted(..), Metric(..), minimize, maximize, assertWithPenalty, SIntegral, SFiniteBits(..)- , ite, iteLazy, sFromIntegral, sShiftLeft, sShiftRight, sRotateLeft, sBarrelRotateLeft, sRotateRight, sBarrelRotateRight, sSignedShiftArithRight, (.^)- , oneIf, genVar, genVar_, sbvForall, sbvForall_, sbvExists, sbvExists_- , pbAtMost, pbAtLeast, pbExactly, pbLe, pbGe, pbEq, pbMutexed, pbStronglyMutexed- , sBool, sBool_, sBools, sWord8, sWord8_, sWord8s, sWord16, sWord16_, sWord16s, sWord32, sWord32_, sWord32s- , sWord64, sWord64_, sWord64s, sInt8, sInt8_, sInt8s, sInt16, sInt16_, sInt16s, sInt32, sInt32_, sInt32s, sInt64, sInt64_- , sInt64s, sInteger, sInteger_, sIntegers, sReal, sReal_, sReals, sFloat, sFloat_, sFloats, sDouble, sDouble_, sDoubles- , sFPHalf, sFPHalf_, sFPHalfs, sFPBFloat, sFPBFloat_, sFPBFloats, sFPSingle, sFPSingle_, sFPSingles, sFPDouble, sFPDouble_, sFPDoubles, sFPQuad, sFPQuad_, sFPQuads- , sFloatingPoint, sFloatingPoint_, sFloatingPoints- , sChar, sChar_, sChars, sString, sString_, sStrings, sList, sList_, sLists- , sRational, sRational_, sRationals- , SymTuple, sTuple, sTuple_, sTuples- , sEither, sEither_, sEithers, sMaybe, sMaybe_, sMaybes- , sSet, sSet_, sSets- , solve- , slet- , sRealToSInteger, label, observe, observeIf, sObserve- , sAssert- , liftQRem, liftDMod, symbolicMergeWithKind- , genLiteral, genFromCV, genMkSymVar- , sbvQuickCheck- )- where--import Control.Applicative (ZipList(ZipList))-import Control.Monad (when, unless, mplus)-import Control.Monad.Trans (liftIO)-import Control.Monad.IO.Class (MonadIO)--import GHC.Generics (U1(..), M1(..), (:*:)(..), K1(..))-import qualified GHC.Generics as G--import GHC.Stack--import Data.Array (Array, Ix, listArray, elems, bounds, rangeSize)-import Data.Bits (Bits(..))-import Data.Char (toLower, isDigit)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Kind (Type)-import Data.List (genericLength, genericIndex, genericTake, unzip4, unzip5, unzip6, unzip7, intercalate, isPrefixOf)-import Data.Maybe (fromMaybe, mapMaybe)-import Data.String (IsString(..))-import Data.Word (Word8, Word16, Word32, Word64)--import qualified Data.Set as Set--import Data.Proxy-import Data.Dynamic (fromDynamic, toDyn)--import Test.QuickCheck (Testable(..), Arbitrary(..))-import qualified Test.QuickCheck.Test as QC (isSuccess)-import qualified Test.QuickCheck as QC (quickCheckResult, counterexample)-import qualified Test.QuickCheck.Monadic as QC (monadicIO, run, assert, pre, monitor)--import qualified Data.Foldable as F (toList)--import Data.SBV.Core.AlgReals-import Data.SBV.Core.SizedFloats-import Data.SBV.Core.Data-import Data.SBV.Core.Symbolic-import Data.SBV.Core.Operations-import Data.SBV.Core.Kind--import Data.SBV.Provers.Prover (defaultSMTCfg, SafeResult(..), prove)-import Data.SBV.SMT.SMT (ThmResult, showModel)--import Data.SBV.Utils.Lib (isKString)-import Data.SBV.Utils.Numeric (fpIsEqualObjectH)---- Symbolic-Word class instances---- | Generate a finite symbolic bitvector, named-genVar :: MonadSymbolic m => VarContext -> Kind -> String -> m (SBV a)-genVar q k = mkSymSBV q k . Just---- | Generate a finite symbolic bitvector, unnamed-genVar_ :: MonadSymbolic m => VarContext -> Kind -> m (SBV a)-genVar_ q k = mkSymSBV q k Nothing---- | Generate a finite constant bitvector-genLiteral :: Integral a => Kind -> a -> SBV b-genLiteral k = SBV . SVal k . Left . mkConstCV k---- | Convert a constant to an integral value-genFromCV :: Integral a => CV -> a-genFromCV (CV _ (CInteger x)) = fromInteger x-genFromCV c = error $ "genFromCV: Unsupported non-integral value: " ++ show c---- | Generalization of 'Data.SBV.genMkSymVar'-genMkSymVar :: MonadSymbolic m => Kind -> VarContext -> Maybe String -> m (SBV a)-genMkSymVar k mbq Nothing = genVar_ mbq k-genMkSymVar k mbq (Just s) = genVar mbq k s--instance SymVal Bool where- mkSymVal = genMkSymVar KBool- literal = SBV . svBool- fromCV = cvToBool--instance SymVal Word8 where- mkSymVal = genMkSymVar (KBounded False 8)- literal = genLiteral (KBounded False 8)- fromCV = genFromCV--instance SymVal Int8 where- mkSymVal = genMkSymVar (KBounded True 8)- literal = genLiteral (KBounded True 8)- fromCV = genFromCV--instance SymVal Word16 where- mkSymVal = genMkSymVar (KBounded False 16)- literal = genLiteral (KBounded False 16)- fromCV = genFromCV--instance SymVal Int16 where- mkSymVal = genMkSymVar (KBounded True 16)- literal = genLiteral (KBounded True 16)- fromCV = genFromCV--instance SymVal Word32 where- mkSymVal = genMkSymVar (KBounded False 32)- literal = genLiteral (KBounded False 32)- fromCV = genFromCV--instance SymVal Int32 where- mkSymVal = genMkSymVar (KBounded True 32)- literal = genLiteral (KBounded True 32)- fromCV = genFromCV--instance SymVal Word64 where- mkSymVal = genMkSymVar (KBounded False 64)- literal = genLiteral (KBounded False 64)- fromCV = genFromCV--instance SymVal Int64 where- mkSymVal = genMkSymVar (KBounded True 64)- literal = genLiteral (KBounded True 64)- fromCV = genFromCV--instance SymVal Integer where- mkSymVal = genMkSymVar KUnbounded- literal = SBV . SVal KUnbounded . Left . mkConstCV KUnbounded- fromCV = genFromCV--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--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-- -- AlgReal needs its own definition of isConcretely- -- to make sure we avoid using unimplementable Haskell functions- isConcretely (SBV (SVal KReal (Left (CV KReal (CAlgReal v))))) p- | isExactRational v = p v- isConcretely _ _ = False--instance SymVal Float where- mkSymVal = genMkSymVar KFloat- literal = SBV . SVal KFloat . Left . CV KFloat . CFloat- fromCV (CV _ (CFloat a)) = a- fromCV c = error $ "SymVal.Float: Unexpected non-float value: " ++ show c-- -- 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,- -- and in the presence of NaN's it would be incorrect to do any optimization- isConcretely _ _ = False--instance SymVal Double where- mkSymVal = genMkSymVar KDouble- literal = SBV . SVal KDouble . Left . CV KDouble . CDouble- fromCV (CV _ (CDouble a)) = a- fromCV c = error $ "SymVal.Double: Unexpected non-double value: " ++ show c-- -- 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,- -- and in the presence of NaN's it would be incorrect to do any optimization- isConcretely _ _ = False--instance SymVal Char where- mkSymVal = genMkSymVar KChar- literal c = SBV . SVal KChar . Left . CV KChar $ CChar c- fromCV (CV _ (CChar a)) = a- fromCV c = error $ "SymVal.String: Unexpected non-char value: " ++ show c--instance SymVal a => SymVal [a] where- mkSymVal- | isKString @[a] undefined = genMkSymVar KString- | True = genMkSymVar (KList (kindOf (Proxy @a)))-- literal as- | isKString @[a] undefined = case fromDynamic (toDyn as) of- Just s -> SBV . SVal KString . Left . CV KString . CString $ s- Nothing -> error "SString: Cannot construct literal string!"- | True = let k = KList (kindOf (Proxy @a))- in SBV $ SVal k $ Left $ CV k $ CList $ map toCV as-- fromCV (CV _ (CString a)) = fromMaybe (error "SString: Cannot extract a literal string!")- (fromDynamic (toDyn a))- fromCV (CV _ (CList a)) = fromCV . CV (kindOf (Proxy @a)) <$> a- fromCV c = error $ "SymVal.fromCV: Unexpected non-list value: " ++ show c--instance ValidFloat eb sb => HasKind (FloatingPoint eb sb) where- kindOf _ = KFP (intOfProxy (Proxy @eb)) (intOfProxy (Proxy @sb))--instance ValidFloat eb sb => SymVal (FloatingPoint eb sb) where- mkSymVal = genMkSymVar (KFP (intOfProxy (Proxy @eb)) (intOfProxy (Proxy @sb)))- literal (FloatingPoint r) = let k = KFP (intOfProxy (Proxy @eb)) (intOfProxy (Proxy @sb))- 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--toCV :: SymVal a => a -> CVal-toCV a = case literal a of- SBV (SVal _ (Left cv)) -> cvVal cv- _ -> error "SymVal.toCV: Impossible happened, couldn't produce a concrete value"--mkCVTup :: Int -> Kind -> [CVal] -> SBV a-mkCVTup i k@(KTuple ks) cs- | lks == lcs && lks == i- = SBV $ SVal k $ Left $ CV k $ CTuple cs- | True- = error $ "SymVal.mkCVTup: Impossible happened. Malformed tuple received: " ++ show (i, k)- where lks = length ks- lcs = length cs-mkCVTup i k _- = error $ "SymVal.mkCVTup: Impossible happened. Non-tuple received: " ++ show (i, k)--fromCVTup :: Int -> CV -> [CV]-fromCVTup i inp@(CV (KTuple ks) (CTuple cs))- | lks == lcs && lks == i- = zipWith CV ks cs- | True- = error $ "SymVal.fromCTup: Impossible happened. Malformed tuple received: " ++ show (i, inp)- where lks = length ks- lcs = length cs-fromCVTup i inp = error $ "SymVal.fromCVTup: Impossible happened. Non-tuple received: " ++ show (i, inp)--instance (SymVal a, SymVal b) => SymVal (Either a b) where- mkSymVal = genMkSymVar (kindOf (Proxy @(Either a b)))-- literal s- | Left a <- s = mk $ Left (toCV a)- | Right b <- s = mk $ Right (toCV b)- where k = kindOf (Proxy @(Either a b))-- mk = SBV . SVal k . Left . CV k . CEither-- 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--instance SymVal a => SymVal (Maybe a) where- mkSymVal = genMkSymVar (kindOf (Proxy @(Maybe a)))-- literal s- | Nothing <- s = mk Nothing- | Just a <- s = mk $ Just (toCV a)- where k = kindOf (Proxy @(Maybe a))-- mk = SBV . SVal k . Left . CV k . CMaybe-- fromCV (CV (KMaybe _) (CMaybe Nothing)) = Nothing- fromCV (CV (KMaybe k) (CMaybe (Just x))) = Just $ fromCV $ CV k x- fromCV bad = error $ "SymVal.fromCV (Maybe): Malformed sum received: " ++ show bad--instance (Ord a, SymVal a) => SymVal (RCSet a) where- mkSymVal = genMkSymVar (kindOf (Proxy @(RCSet a)))-- literal eur = SBV $ SVal k $ Left $ CV k $ CSet $ dir $ Set.map toCV s- where (dir, s) = case eur of- RegularSet x -> (RegularSet, x)- ComplementSet x -> (ComplementSet, x)- k = kindOf (Proxy @(RCSet a))-- fromCV (CV (KSet a) (CSet (RegularSet s))) = RegularSet $ Set.map (fromCV . CV a) s- 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---- | SymVal for 0-tuple (i.e., unit)-instance SymVal () where- mkSymVal = genMkSymVar (KTuple [])- literal () = mkCVTup 0 (kindOf (Proxy @())) []- fromCV cv = fromCVTup 0 cv `seq` ()---- | SymVal for 2-tuples-instance (SymVal a, SymVal b) => SymVal (a, b) where- mkSymVal = genMkSymVar (kindOf (Proxy @(a, b)))- literal (v1, v2) = mkCVTup 2 (kindOf (Proxy @(a, b))) [toCV v1, toCV v2]- fromCV cv = let ~[v1, v2] = fromCVTup 2 cv- in (fromCV v1, fromCV v2)---- | 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)---- | SymVal for 4-tuples-instance (SymVal a, SymVal b, SymVal c, SymVal d) => SymVal (a, b, c, d) where- mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d)))- 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)---- | SymVal for 5-tuples-instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e) => SymVal (a, b, c, d, e) where- mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e)))- 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)---- | 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- mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f)))- 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)---- | 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- mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f, g)))- 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)---- | 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- mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f, g, h)))- 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)--instance IsString SString where- fromString = literal----------------------------------------------------------------------------------------- * Smart constructors for creating symbolic values. These are not strictly--- necessary, as they are mere aliases for 'symbolic' and 'symbolics', but--- they nonetheless make programming easier.----------------------------------------------------------------------------------------- | Generalization of 'Data.SBV.sBool'-sBool :: MonadSymbolic m => String -> m SBool-sBool = symbolic---- | Generalization of 'Data.SBV.sBool_'-sBool_ :: MonadSymbolic m => m SBool-sBool_ = free_---- | Generalization of 'Data.SBV.sBools'-sBools :: MonadSymbolic m => [String] -> m [SBool]-sBools = symbolics---- | Generalization of 'Data.SBV.sWord8'-sWord8 :: MonadSymbolic m => String -> m SWord8-sWord8 = symbolic---- | Generalization of 'Data.SBV.sWord8_'-sWord8_ :: MonadSymbolic m => m SWord8-sWord8_ = free_---- | Generalization of 'Data.SBV.sWord8s'-sWord8s :: MonadSymbolic m => [String] -> m [SWord8]-sWord8s = symbolics---- | Generalization of 'Data.SBV.sWord16'-sWord16 :: MonadSymbolic m => String -> m SWord16-sWord16 = symbolic---- | Generalization of 'Data.SBV.sWord16_'-sWord16_ :: MonadSymbolic m => m SWord16-sWord16_ = free_---- | Generalization of 'Data.SBV.sWord16s'-sWord16s :: MonadSymbolic m => [String] -> m [SWord16]-sWord16s = symbolics---- | Generalization of 'Data.SBV.sWord32'-sWord32 :: MonadSymbolic m => String -> m SWord32-sWord32 = symbolic---- | Generalization of 'Data.SBV.sWord32_'-sWord32_ :: MonadSymbolic m => m SWord32-sWord32_ = free_---- | Generalization of 'Data.SBV.sWord32s'-sWord32s :: MonadSymbolic m => [String] -> m [SWord32]-sWord32s = symbolics---- | Generalization of 'Data.SBV.sWord64'-sWord64 :: MonadSymbolic m => String -> m SWord64-sWord64 = symbolic---- | Generalization of 'Data.SBV.sWord64_'-sWord64_ :: MonadSymbolic m => m SWord64-sWord64_ = free_---- | Generalization of 'Data.SBV.sWord64s'-sWord64s :: MonadSymbolic m => [String] -> m [SWord64]-sWord64s = symbolics---- | Generalization of 'Data.SBV.sInt8'-sInt8 :: MonadSymbolic m => String -> m SInt8-sInt8 = symbolic---- | Generalization of 'Data.SBV.sInt8_'-sInt8_ :: MonadSymbolic m => m SInt8-sInt8_ = free_---- | Generalization of 'Data.SBV.sInt8s'-sInt8s :: MonadSymbolic m => [String] -> m [SInt8]-sInt8s = symbolics---- | Generalization of 'Data.SBV.sInt16'-sInt16 :: MonadSymbolic m => String -> m SInt16-sInt16 = symbolic---- | Generalization of 'Data.SBV.sInt16_'-sInt16_ :: MonadSymbolic m => m SInt16-sInt16_ = free_---- | Generalization of 'Data.SBV.sInt16s'-sInt16s :: MonadSymbolic m => [String] -> m [SInt16]-sInt16s = symbolics---- | Generalization of 'Data.SBV.sInt32'-sInt32 :: MonadSymbolic m => String -> m SInt32-sInt32 = symbolic---- | Generalization of 'Data.SBV.sInt32_'-sInt32_ :: MonadSymbolic m => m SInt32-sInt32_ = free_---- | Generalization of 'Data.SBV.sInt32s'-sInt32s :: MonadSymbolic m => [String] -> m [SInt32]-sInt32s = symbolics---- | Generalization of 'Data.SBV.sInt64'-sInt64 :: MonadSymbolic m => String -> m SInt64-sInt64 = symbolic---- | Generalization of 'Data.SBV.sInt64_'-sInt64_ :: MonadSymbolic m => m SInt64-sInt64_ = free_---- | Generalization of 'Data.SBV.sInt64s'-sInt64s :: MonadSymbolic m => [String] -> m [SInt64]-sInt64s = symbolics---- | Generalization of 'Data.SBV.sInteger'-sInteger:: MonadSymbolic m => String -> m SInteger-sInteger = symbolic---- | Generalization of 'Data.SBV.sInteger_'-sInteger_:: MonadSymbolic m => m SInteger-sInteger_ = free_---- | Generalization of 'Data.SBV.sIntegers'-sIntegers :: MonadSymbolic m => [String] -> m [SInteger]-sIntegers = symbolics---- | Generalization of 'Data.SBV.sReal'-sReal:: MonadSymbolic m => String -> m SReal-sReal = symbolic---- | Generalization of 'Data.SBV.sReal_'-sReal_:: MonadSymbolic m => m SReal-sReal_ = free_---- | Generalization of 'Data.SBV.sReals'-sReals :: MonadSymbolic m => [String] -> m [SReal]-sReals = symbolics---- | Generalization of 'Data.SBV.sFloat'-sFloat :: MonadSymbolic m => String -> m SFloat-sFloat = symbolic---- | Generalization of 'Data.SBV.sFloat_'-sFloat_ :: MonadSymbolic m => m SFloat-sFloat_ = free_---- | Generalization of 'Data.SBV.sFloats'-sFloats :: MonadSymbolic m => [String] -> m [SFloat]-sFloats = symbolics---- | Generalization of 'Data.SBV.sDouble'-sDouble :: MonadSymbolic m => String -> m SDouble-sDouble = symbolic---- | Generalization of 'Data.SBV.sDouble_'-sDouble_ :: MonadSymbolic m => m SDouble-sDouble_ = free_---- | Generalization of 'Data.SBV.sDoubles'-sDoubles :: MonadSymbolic m => [String] -> m [SDouble]-sDoubles = symbolics---- | Generalization of 'Data.SBV.sFPHalf'-sFPHalf :: String -> Symbolic SFPHalf-sFPHalf = symbolic---- | Generalization of 'Data.SBV.sFPHalf_'-sFPHalf_ :: Symbolic SFPHalf-sFPHalf_ = free_---- | Generalization of 'Data.SBV.sFPHalfs'-sFPHalfs :: [String] -> Symbolic [SFPHalf]-sFPHalfs = symbolics---- | Generalization of 'Data.SBV.sFPBFloat'-sFPBFloat :: String -> Symbolic SFPBFloat-sFPBFloat = symbolic---- | Generalization of 'Data.SBV.sFPBFloat_'-sFPBFloat_ :: Symbolic SFPBFloat-sFPBFloat_ = free_---- | Generalization of 'Data.SBV.sFPBFloats'-sFPBFloats :: [String] -> Symbolic [SFPBFloat]-sFPBFloats = symbolics---- | Generalization of 'Data.SBV.sFPSingle'-sFPSingle :: String -> Symbolic SFPSingle-sFPSingle = symbolic---- | Generalization of 'Data.SBV.sFPSingle_'-sFPSingle_ :: Symbolic SFPSingle-sFPSingle_ = free_---- | Generalization of 'Data.SBV.sFPSingles'-sFPSingles :: [String] -> Symbolic [SFPSingle]-sFPSingles = symbolics---- | Generalization of 'Data.SBV.sFPDouble'-sFPDouble :: String -> Symbolic SFPDouble-sFPDouble = symbolic---- | Generalization of 'Data.SBV.sFPDouble_'-sFPDouble_ :: Symbolic SFPDouble-sFPDouble_ = free_---- | Generalization of 'Data.SBV.sFPDoubles'-sFPDoubles :: [String] -> Symbolic [SFPDouble]-sFPDoubles = symbolics---- | Generalization of 'Data.SBV.sFPQuad'-sFPQuad :: String -> Symbolic SFPQuad-sFPQuad = symbolic---- | Generalization of 'Data.SBV.sFPQuad_'-sFPQuad_ :: Symbolic SFPQuad-sFPQuad_ = free_---- | Generalization of 'Data.SBV.sFPQuads'-sFPQuads :: [String] -> Symbolic [SFPQuad]-sFPQuads = symbolics---- | Generalization of 'Data.SBV.sFloatingPoint'-sFloatingPoint :: ValidFloat eb sb => String -> Symbolic (SFloatingPoint eb sb)-sFloatingPoint = symbolic---- | Generalization of 'Data.SBV.sFloatingPoint_'-sFloatingPoint_ :: ValidFloat eb sb => Symbolic (SFloatingPoint eb sb)-sFloatingPoint_ = free_---- | Generalization of 'Data.SBV.sFloatingPoints'-sFloatingPoints :: ValidFloat eb sb => [String] -> Symbolic [SFloatingPoint eb sb]-sFloatingPoints = symbolics---- | Generalization of 'Data.SBV.sChar'-sChar :: MonadSymbolic m => String -> m SChar-sChar = symbolic---- | Generalization of 'Data.SBV.sChar_'-sChar_ :: MonadSymbolic m => m SChar-sChar_ = free_---- | Generalization of 'Data.SBV.sChars'-sChars :: MonadSymbolic m => [String] -> m [SChar]-sChars = symbolics---- | Generalization of 'Data.SBV.sString'-sString :: MonadSymbolic m => String -> m SString-sString = symbolic---- | Generalization of 'Data.SBV.sString_'-sString_ :: MonadSymbolic m => m SString-sString_ = free_---- | Generalization of 'Data.SBV.sStrings'-sStrings :: MonadSymbolic m => [String] -> m [SString]-sStrings = symbolics---- | Generalization of 'Data.SBV.sList'-sList :: (SymVal a, MonadSymbolic m) => String -> m (SList a)-sList = symbolic---- | Generalization of 'Data.SBV.sList_'-sList_ :: (SymVal a, MonadSymbolic m) => m (SList a)-sList_ = free_---- | Generalization of 'Data.SBV.sLists'-sLists :: (SymVal a, MonadSymbolic m) => [String] -> m [SList a]-sLists = symbolics---- | Identify tuple like things. Note that there are no methods, just instances to control type inference-class SymTuple a-instance SymTuple ()-instance SymTuple (a, b)-instance SymTuple (a, b, c)-instance SymTuple (a, b, c, d)-instance SymTuple (a, b, c, d, e)-instance SymTuple (a, b, c, d, e, f)-instance SymTuple (a, b, c, d, e, f, g)-instance SymTuple (a, b, c, d, e, f, g, h)---- | Generalization of 'Data.SBV.sTuple'-sTuple :: (SymTuple tup, SymVal tup, MonadSymbolic m) => String -> m (SBV tup)-sTuple = symbolic---- | Generalization of 'Data.SBV.sTuple_'-sTuple_ :: (SymTuple tup, SymVal tup, MonadSymbolic m) => m (SBV tup)-sTuple_ = free_---- | Generalization of 'Data.SBV.sTuples'-sTuples :: (SymTuple tup, SymVal tup, MonadSymbolic m) => [String] -> m [SBV tup]-sTuples = symbolics---- | Generalization of 'Data.SBV.sRational'-sRational :: MonadSymbolic m => String -> m SRational-sRational = symbolic---- | Generalization of 'Data.SBV.sRational_'-sRational_ :: MonadSymbolic m => m SRational-sRational_ = free_---- | Generalization of 'Data.SBV.sRationals'-sRationals :: MonadSymbolic m => [String] -> m [SRational]-sRationals = symbolics---- | Generalization of 'Data.SBV.sEither'-sEither :: (SymVal a, SymVal b, MonadSymbolic m) => String -> m (SEither a b)-sEither = symbolic---- | Generalization of 'Data.SBV.sEither_'-sEither_ :: (SymVal a, SymVal b, MonadSymbolic m) => m (SEither a b)-sEither_ = free_---- | Generalization of 'Data.SBV.sEithers'-sEithers :: (SymVal a, SymVal b, MonadSymbolic m) => [String] -> m [SEither a b]-sEithers = symbolics---- | Generalization of 'Data.SBV.sMaybe'-sMaybe :: (SymVal a, MonadSymbolic m) => String -> m (SMaybe a)-sMaybe = symbolic---- | Generalization of 'Data.SBV.sMaybe_'-sMaybe_ :: (SymVal a, MonadSymbolic m) => m (SMaybe a)-sMaybe_ = free_---- | Generalization of 'Data.SBV.sMaybes'-sMaybes :: (SymVal a, MonadSymbolic m) => [String] -> m [SMaybe a]-sMaybes = symbolics---- | Generalization of 'Data.SBV.sSet'-sSet :: (Ord a, SymVal a, MonadSymbolic m) => String -> m (SSet a)-sSet = symbolic---- | Generalization of 'Data.SBV.sMaybe_'-sSet_ :: (Ord a, SymVal a, MonadSymbolic m) => m (SSet a)-sSet_ = free_---- | Generalization of 'Data.SBV.sMaybes'-sSets :: (Ord a, SymVal a, MonadSymbolic m) => [String] -> m [SSet a]-sSets = symbolics---- | Generalization of 'Data.SBV.solve'-solve :: MonadSymbolic m => [SBool] -> m SBool-solve = return . sAnd---- | Convert an SReal to an SInteger. That is, it computes the--- largest integer @n@ that satisfies @sIntegerToSReal n <= r@--- essentially giving us the @floor@.------ For instance, @1.3@ will be @1@, but @-1.3@ will be @-2@.-sRealToSInteger :: SReal -> SInteger-sRealToSInteger x- | Just i <- unliteral x, isExactRational i- = literal $ floor (toRational i)- | True- = SBV (SVal KUnbounded (Right (cache y)))- where y st = do xsv <- sbvToSV st x- newExpr st KUnbounded (SBVApp (KindCast KReal KUnbounded) [xsv])---- | 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.-label :: SymVal a => String -> SBV a -> SBV a-label m x- | Just _ <- unliteral x = x- | True = SBV $ SVal k $ Right $ cache r- where k = kindOf x- r st = do xsv <- sbvToSV st x- newExpr st k (SBVApp (Label m) [xsv])----- | Check if an observable name is good.-checkObservableName :: String -> Maybe String-checkObservableName lbl- | null lbl- = Just "SBV.observe: Bad empty name!"- | map toLower lbl `elem` smtLibReservedNames- = Just $ "SBV.observe: The name chosen is reserved, please change it!: " ++ show lbl- | "s" `isPrefixOf` lbl && all isDigit (drop 1 lbl)- = Just $ "SBV.observe: Names of the form sXXX are internal to SBV, please use a different name: " ++ show lbl- | True- = Nothing---- | Observe the value of an expression, if the given condition holds. Such values are useful in model construction, as they are printed part of a satisfying model, or a--- counter-example. The same works for quick-check as well. Useful when we want to see intermediate values, or expected/obtained--- pairs in a particular run. Note that an observed expression is always symbolic, i.e., it won't be constant folded. Compare this to 'label'--- which is used for putting a label in the generated SMTLib-C code.-observeIf :: SymVal a => (a -> Bool) -> String -> SBV a -> SBV a-observeIf cond m x- | Just bad <- checkObservableName m- = error bad- | True- = SBV $ SVal k $ Right $ cache r- where k = kindOf x- r st = do xsv <- sbvToSV st x- recordObservable st m (cond . fromCV) xsv- return xsv---- | Observe the value of an expression, unconditionally. See 'observeIf' for a generalized version.-observe :: SymVal a => String -> SBV a -> SBV a-observe = observeIf (const True)---- | A variant of observe that you can use at the top-level. This is useful with quick-check, for instance.-sObserve :: SymVal a => String -> SBV a -> Symbolic ()-sObserve m x- | Just bad <- checkObservableName m- = error bad- | True- = do st <- symbolicEnv- liftIO $ do xsv <- sbvToSV st x- recordObservable st m (const True) xsv---- | Symbolic Equality. Note that we can't use Haskell's 'Eq' class since Haskell insists on returning Bool--- Comparing symbolic values will necessarily return a symbolic value.-infix 4 .==, ./=, .===, ./==-class EqSymbolic a where- -- | Symbolic equality.- (.==) :: a -> a -> SBool- -- | Symbolic inequality.- (./=) :: a -> a -> SBool- -- | Strong equality. On floats ('SFloat'/'SDouble'), strong equality is object equality; that- -- is @NaN == NaN@ holds, but @+0 == -0@ doesn't. On other types, (.===) is simply (.==).- -- Note that (.==) is the /right/ notion of equality for floats per IEEE754 specs, since by- -- definition @+0 == -0@ and @NaN@ equals no other value including itself. But occasionally- -- we want to be stronger and state @NaN@ equals @NaN@ and @+0@ and @-0@ are different from- -- each other. In a context where your type is concrete, simply use `Data.SBV.fpIsEqualObject`. But in- -- a polymorphic context, use the strong equality instead.- --- -- NB. If you do not care about or work with floats, simply use (.==) and (./=).- (.===) :: a -> a -> SBool- -- | Negation of strong equality. Equaivalent to negation of (.===) on all types.- (./==) :: a -> a -> SBool-- -- | Returns (symbolic) 'sTrue' if all the elements of the given list are different.- distinct :: [a] -> SBool-- -- | Returns (symbolic) `sTrue` if all the elements of the given list are different. The second- -- list contains exceptions, i.e., if an element belongs to that set, it will be considered- -- distinct regardless of repetition.- distinctExcept :: [a] -> [a] -> SBool-- -- | Returns (symbolic) 'sTrue' if all the elements of the given list are the same.- allEqual :: [a] -> SBool-- -- | Symbolic membership test.- sElem :: a -> [a] -> SBool-- -- | Symbolic negated membership test.- sNotElem :: a -> [a] -> SBool-- {-# MINIMAL (.==) #-}-- x ./= y = sNot (x .== y)- x .=== y = x .== y- x ./== y = sNot (x .=== y)-- allEqual [] = sTrue- allEqual (x:xs) = sAll (x .==) xs-- -- Default implementation of distinct. Note that we override- -- this method for the base types to generate better code.- distinct [] = sTrue- distinct (x:xs) = sAll (x ./=) xs .&& distinct xs-- -- Default implementation of distinctExcept. Note that we override- -- this method for the base types to generate better code.- distinctExcept es ignored = go es- where isIgnored = (`sElem` ignored)-- go [] = sTrue- go (x:xs) = let xOK = isIgnored x .|| sAll (\y -> isIgnored y .|| x ./= y) xs- in xOK .&& go xs-- x `sElem` xs = sAny (.== x) xs- x `sNotElem` xs = sNot (x `sElem` xs)---- | Symbolic Comparisons. Similar to 'Eq', we cannot implement Haskell's 'Ord' class--- since there is no way to return an 'Ordering' value from a symbolic comparison.--- Furthermore, 'OrdSymbolic' requires 'Mergeable' to implement if-then-else, for the--- benefit of implementing symbolic versions of 'max' and 'min' functions.-infix 4 .<, .<=, .>, .>=-class (Mergeable a, EqSymbolic a) => OrdSymbolic a where- -- | Symbolic less than.- (.<) :: a -> a -> SBool- -- | Symbolic less than or equal to.- (.<=) :: a -> a -> SBool- -- | Symbolic greater than.- (.>) :: a -> a -> SBool- -- | Symbolic greater than or equal to.- (.>=) :: a -> a -> SBool- -- | Symbolic minimum.- smin :: a -> a -> a- -- | Symbolic maximum.- smax :: a -> a -> a- -- | Is the value within the allowed /inclusive/ range?- inRange :: a -> (a, a) -> SBool-- {-# MINIMAL (.<) #-}-- a .<= b = a .< b .|| a .== b- a .> b = b .< a- a .>= b = b .<= a-- a `smin` b = ite (a .<= b) a b- a `smax` b = ite (a .<= b) b a-- inRange x (y, z) = x .>= y .&& x .<= z---{- We can't have a generic instance of the form:--instance Eq a => EqSymbolic a where- x .== y = if x == y then true else sFalse--even if we're willing to allow Flexible/undecidable instances..-This is because if we allow this it would imply EqSymbolic (SBV a);-since (SBV a) has to be Eq as it must be a Num. But this wouldn't be-the right choice obviously; as the Eq instance is bogus for SBV-for natural reasons..--}---- It is tempting to put in an @Eq a@ superclass here. But doing so--- is complicated, as it requires all underlying types to have equality,--- which is at best shaky for algebraic reals and sets. So, leave it out.-instance EqSymbolic (SBV a) where- SBV x .== SBV y = SBV (svEqual x y)- SBV x ./= SBV y = SBV (svNotEqual x y)-- SBV x .=== SBV y = SBV (svStrongEqual x y)-- -- Custom version of distinct that generates better code for base types- distinct [] = sTrue- distinct [_] = sTrue- distinct xs | all isConc xs = checkDiff xs- | [SBV a, SBV b] <- xs, a `is` svBool True = SBV $ svNot b- | [SBV a, SBV b] <- xs, b `is` svBool True = SBV $ svNot a- | [SBV a, SBV b] <- xs, a `is` svBool False = SBV b- | [SBV a, SBV b] <- xs, b `is` svBool False = SBV a- | length xs > 2 && isBool (head xs) = sFalse- | True = SBV (SVal KBool (Right (cache r)))- where r st = do xsv <- mapM (sbvToSV st) xs- newExpr st KBool (SBVApp NotEqual xsv)-- -- We call this in case all are concrete, which will- -- reduce to a constant and generate no code at all!- -- Note that this is essentially the same as the default- -- definition, which unfortunately we can no longer call!- checkDiff [] = sTrue- checkDiff (a:as) = sAll (a ./=) as .&& checkDiff as-- -- Sigh, we can't use isConcrete since that requires SymVal- -- constraint that we don't have here. (To support SBools.)- isConc (SBV (SVal _ (Left _))) = True- isConc _ = False-- -- Likewise here; need to go lower.- SVal k1 (Left c1) `is` SVal k2 (Left c2) = (k1, c1) == (k2, c2)- _ `is` _ = False-- isBool (SBV (SVal KBool _)) = True- isBool _ = False-- -- Custom version of distinctExcept that generates better code for base types- -- We essentially keep track of an array and count cardinalities as we walk along.- distinctExcept [] _ = sTrue- distinctExcept [_] _ = sTrue- distinctExcept es ignored- | all isConc (es ++ ignored)- = distinct (filter ignoreConc es)- | True- = SBV (SVal KBool (Right (cache r)))- where ignoreConc x = case x `sElem` ignored of- SBV (SVal KBool (Left cv)) -> cvToBool cv- _ -> error $ "distinctExcept: Impossible happened, concrete sElem failed: " ++ show (es, ignored, x)-- ek = case head es of -- Head is safe here as we're guaranteed to have a non-empty es by pattern matching above. (Actually, there'll be at least two elements)- SBV (SVal k _) -> k-- r st = do let zero = 0 :: SInteger-- arr <- SArray <$> newSArr st (ek, KUnbounded) (\i -> "array_" ++ show i) (Just (unSBV zero))-- let incr x table = ite (x `sElem` ignored) zero (1 + readArray table x)-- finalArray = foldl (\table x -> writeArray table x (incr x table)) arr es-- sbvToSV st $ sAll (\e -> readArray finalArray e .<= 1) es-- -- Sigh, we can't use isConcrete since that requires SymVal- -- constraint that we don't have here. (To support SBools.)- isConc (SBV (SVal _ (Left _))) = True- isConc _ = False---- | If comparison is over something SMTLib can handle, just translate it. Otherwise desugar.-instance (Ord a, SymVal a) => OrdSymbolic (SBV a) where- a@(SBV x) .< b@(SBV y) | smtComparable "<" a b = SBV (svLessThan x y)- | True = SBV (svStructuralLessThan x y)-- a@(SBV x) .<= b@(SBV y) | smtComparable ".<=" a b = SBV (svLessEq x y)- | True = a .< b .|| a .== b-- a@(SBV x) .> b@(SBV y) | smtComparable ">" a b = SBV (svGreaterThan x y)- | True = b .< a-- a@(SBV x) .>= b@(SBV y) | smtComparable ">=" a b = SBV (svGreaterEq x y)- | True = b .<= a---- Is this a type that's comparable by underlying translation to SMTLib?--- Note that we allow concrete versions to go through unless the type is a set, as there's really no reason not to.-smtComparable :: (SymVal a, HasKind a) => String -> SBV a -> SBV a -> Bool-smtComparable op x y- | isConcrete x && isConcrete y && not (isSet k)- = True- | True- = case k of- KBool -> True- KBounded {} -> True- KUnbounded {} -> True- KReal {} -> True- KUserSort {} -> True- KFloat -> True- KDouble -> True- KRational {} -> True- KFP {} -> True- KChar -> True- KString -> True- KList {} -> nope -- Unfortunately, no way for us to desugar this- KSet {} -> nope -- Ditto here..- KTuple {} -> False- KMaybe {} -> False- KEither {} -> False- where k = kindOf x- nope = error $ "Data.SBV.OrdSymbolic: SMTLib does not support " ++ op ++ " for " ++ show k---- Bool-instance EqSymbolic Bool where- x .== y = fromBool $ x == y---- Lists-instance EqSymbolic a => EqSymbolic [a] where- [] .== [] = sTrue- (x:xs) .== (y:ys) = x .== y .&& xs .== ys- _ .== _ = sFalse--instance OrdSymbolic a => OrdSymbolic [a] where- [] .< [] = sFalse- [] .< _ = sTrue- _ .< [] = sFalse- (x:xs) .< (y:ys) = x .< y .|| (x .== y .&& xs .< ys)---- Maybe-instance EqSymbolic a => EqSymbolic (Maybe a) where- Nothing .== Nothing = sTrue- Just a .== Just b = a .== b- _ .== _ = sFalse--instance OrdSymbolic a => OrdSymbolic (Maybe a) where- Nothing .< Nothing = sFalse- Nothing .< _ = sTrue- Just _ .< Nothing = sFalse- Just a .< Just b = a .< b---- Either-instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (Either a b) where- Left a .== Left b = a .== b- Right a .== Right b = a .== b- _ .== _ = sFalse--instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (Either a b) where- Left a .< Left b = a .< b- Left _ .< Right _ = sTrue- Right _ .< Left _ = sFalse- Right a .< Right b = a .< b---- 2-Tuple-instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (a, b) where- (a0, b0) .== (a1, b1) = a0 .== a1 .&& b0 .== b1--instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (a, b) where- (a0, b0) .< (a1, b1) = a0 .< a1 .|| (a0 .== a1 .&& b0 .< b1)---- 3-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c) => EqSymbolic (a, b, c) where- (a0, b0, c0) .== (a1, b1, c1) = (a0, b0) .== (a1, b1) .&& c0 .== c1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c) => OrdSymbolic (a, b, c) where- (a0, b0, c0) .< (a1, b1, c1) = (a0, b0) .< (a1, b1) .|| ((a0, b0) .== (a1, b1) .&& c0 .< c1)---- 4-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d) => EqSymbolic (a, b, c, d) where- (a0, b0, c0, d0) .== (a1, b1, c1, d1) = (a0, b0, c0) .== (a1, b1, c1) .&& d0 .== d1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d) => OrdSymbolic (a, b, c, d) where- (a0, b0, c0, d0) .< (a1, b1, c1, d1) = (a0, b0, c0) .< (a1, b1, c1) .|| ((a0, b0, c0) .== (a1, b1, c1) .&& d0 .< d1)---- 5-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e) => EqSymbolic (a, b, c, d, e) where- (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .== (a1, b1, c1, d1) .&& e0 .== e1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e) => OrdSymbolic (a, b, c, d, e) where- (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .< (a1, b1, c1, d1) .|| ((a0, b0, c0, d0) .== (a1, b1, c1, d1) .&& e0 .< e1)---- 6-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f) => EqSymbolic (a, b, c, d, e, f) where- (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) .&& f0 .== f1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f) => OrdSymbolic (a, b, c, d, e, f) where- (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1)- .|| ((a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) .&& f0 .< f1)---- 7-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f, EqSymbolic g) => EqSymbolic (a, b, c, d, e, f, g) where- (a0, b0, c0, d0, e0, f0, g0) .== (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) .&& g0 .== g1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f, OrdSymbolic g) => OrdSymbolic (a, b, c, d, e, f, g) where- (a0, b0, c0, d0, e0, f0, g0) .< (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1)- .|| ((a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) .&& g0 .< g1)---- | Regular expressions can be compared for equality. Note that we diverge here from the equality--- in the concrete sense; i.e., the Eq instance does not match the symbolic case. This is a bit unfortunate,--- but unavoidable with the current design of how we "distinguish" operators. Hopefully shouldn't be a big deal,--- though one should be careful.-instance EqSymbolic RegExp where- r1 .== r2 = SBV $ SVal KBool $ Right $ cache r- where r st = newExpr st KBool $ SBVApp (RegExOp (RegExEq r1 r2)) []-- r1 ./= r2 = SBV $ SVal KBool $ Right $ cache r- where r st = newExpr st KBool $ SBVApp (RegExOp (RegExNEq r1 r2)) []---- | Symbolic Numbers. This is a simple class that simply incorporates all number like--- base types together, simplifying writing polymorphic type-signatures that work for all--- symbolic numbers, such as 'SWord8', 'SInt8' etc. For instance, we can write a generic--- list-minimum function as follows:------ @--- mm :: SIntegral a => [SBV a] -> SBV a--- mm = foldr1 (\a b -> ite (a .<= b) a b)--- @------ It is similar to the standard 'Integral' class, except ranging over symbolic instances.-class (SymVal a, Num a, Bits a, Integral a) => SIntegral a---- 'SIntegral' Instances, skips Real/Float/Bool-instance SIntegral Word8-instance SIntegral Word16-instance SIntegral Word32-instance SIntegral Word64-instance SIntegral Int8-instance SIntegral Int16-instance SIntegral Int32-instance SIntegral Int64-instance SIntegral Integer---- | Finite bit-length symbolic values. Essentially the same as 'SIntegral', but further leaves out 'Integer'. Loosely--- based on Haskell's @FiniteBits@ class, but with more methods defined and structured differently to fit into the--- symbolic world view. Minimal complete definition: 'sFiniteBitSize'.-class (Ord a, SymVal a, Num a, Bits a) => SFiniteBits a where- -- | Bit size.- sFiniteBitSize :: SBV a -> Int- -- | Least significant bit of a word, always stored at index 0.- lsb :: SBV a -> SBool- -- | Most significant bit of a word, always stored at the last position.- msb :: SBV a -> SBool- -- | Big-endian blasting of a word into its bits.- blastBE :: SBV a -> [SBool]- -- | Little-endian blasting of a word into its bits.- blastLE :: SBV a -> [SBool]- -- | Reconstruct from given bits, given in little-endian.- fromBitsBE :: [SBool] -> SBV a- -- | Reconstruct from given bits, given in little-endian.- fromBitsLE :: [SBool] -> SBV a- -- | Replacement for 'testBit', returning 'SBool' instead of 'Bool'.- sTestBit :: SBV a -> Int -> SBool- -- | Variant of 'sTestBit', where we want to extract multiple bit positions.- sExtractBits :: SBV a -> [Int] -> [SBool]- -- | Variant of 'popCount', returning a symbolic value.- sPopCount :: SBV a -> SWord8- -- | A combo of 'setBit' and 'clearBit', when the bit to be set is symbolic.- setBitTo :: SBV a -> Int -> SBool -> SBV a- -- | Full adder, returns carry-out from the addition. Only for unsigned quantities.- fullAdder :: SBV a -> SBV a -> (SBool, SBV a)- -- | Full multiplier, returns both high and low-order bits. Only for unsigned quantities.- fullMultiplier :: SBV a -> SBV a -> (SBV a, SBV a)- -- | Count leading zeros in a word, big-endian interpretation.- sCountLeadingZeros :: SBV a -> SWord8- -- | Count trailing zeros in a word, big-endian interpretation.- sCountTrailingZeros :: SBV a -> SWord8-- {-# MINIMAL sFiniteBitSize #-}-- -- Default implementations- lsb (SBV v) = SBV (svTestBit v 0)- msb x = sTestBit x (sFiniteBitSize x - 1)-- blastBE = reverse . blastLE- blastLE x = map (sTestBit x) [0 .. intSizeOf x - 1]-- fromBitsBE = fromBitsLE . reverse- fromBitsLE bs- | length bs /= w- = error $ "SBV.SFiniteBits.fromBitsLE/BE: Expected: " ++ show w ++ " bits, received: " ++ show (length bs)- | True- = result- where w = sFiniteBitSize result- result = go 0 0 bs-- go !acc _ [] = acc- go !acc !i (x:xs) = go (ite x (setBit acc i) acc) (i+1) xs-- sTestBit (SBV x) i = SBV (svTestBit x i)- sExtractBits x = map (sTestBit x)-- -- NB. 'sPopCount' returns an 'SWord8', which can overflow when used on quantities that have- -- more than 255 bits. For the regular interface, this suffices for all types we support.- -- For the Dynamic interface, if we ever implement this, this will fail for bit-vectors- -- larger than that many bits. The alternative would be to return SInteger here, but that- -- seems a total overkill for most use cases. If such is required, users are encouraged- -- to define their own variants, which is rather easy.- sPopCount x- | Just v <- unliteral x = go 0 v- | True = sum [ite b 1 0 | b <- blastLE x]- where -- concrete case- go !c 0 = c- go !c w = go (c+1) (w .&. (w-1))-- setBitTo x i b = ite b (setBit x i) (clearBit x i)-- fullAdder a b- | isSigned a = error "fullAdder: only works on unsigned numbers"- | True = (a .> s .|| b .> s, s)- where s = a + b-- -- N.B. The higher-order bits are determined using a simple shift-add multiplier,- -- thus involving bit-blasting. It'd be naive to expect SMT solvers to deal efficiently- -- with properties involving this function, at least with the current state of the art.- fullMultiplier a b- | isSigned a = error "fullMultiplier: only works on unsigned numbers"- | True = (go (sFiniteBitSize a) 0 a, a*b)- where go 0 p _ = p- go n p x = let (c, p') = ite (lsb x) (fullAdder p b) (sFalse, p)- (o, p'') = shiftIn c p'- (_, x') = shiftIn o x- in go (n-1) p'' x'- shiftIn k v = (lsb v, mask .|. (v `shiftR` 1))- where mask = ite k (bit (sFiniteBitSize v - 1)) 0-- -- See the note for 'sPopCount' for a comment on why we return 'SWord8'- sCountLeadingZeros x = fromIntegral m - go m- where m = sFiniteBitSize x - 1-- -- NB. When i is 0 below, which happens when x is 0 as we count all the way down,- -- we return -1, which is equal to 2^n-1, giving us: n-1-(2^n-1) = n-2^n = n, as required, i.e., the bit-size.- go :: Int -> SWord8- go i | i < 0 = i8- | True = ite (sTestBit x i) i8 (go (i-1))- where i8 = literal (fromIntegral i :: Word8)-- -- See the note for 'sPopCount' for a comment on why we return 'SWord8'- sCountTrailingZeros x = go 0- where m = sFiniteBitSize x-- go :: Int -> SWord8- go i | i >= m = i8- | True = ite (sTestBit x i) i8 (go (i+1))- where i8 = literal (fromIntegral i :: Word8)---- 'SFiniteBits' Instances, skips Real/Float/Bool/Integer-instance SFiniteBits Word8 where sFiniteBitSize _ = 8-instance SFiniteBits Word16 where sFiniteBitSize _ = 16-instance SFiniteBits Word32 where sFiniteBitSize _ = 32-instance SFiniteBits Word64 where sFiniteBitSize _ = 64-instance SFiniteBits Int8 where sFiniteBitSize _ = 8-instance SFiniteBits Int16 where sFiniteBitSize _ = 16-instance SFiniteBits Int32 where sFiniteBitSize _ = 32-instance SFiniteBits Int64 where sFiniteBitSize _ = 64---- | Returns 1 if the boolean is 'sTrue', otherwise 0.-oneIf :: (Ord a, Num a, SymVal a) => SBool -> SBV a-oneIf t = ite t 1 0---- | Lift a pseudo-boolean op, performing checks-liftPB :: String -> PBOp -> [SBool] -> SBool-liftPB w o xs- | Just e <- check o- = error $ "SBV." ++ w ++ ": " ++ e- | True- = result- where check (PB_AtMost k) = pos k- check (PB_AtLeast k) = pos k- check (PB_Exactly k) = pos k- check (PB_Le cs k) = pos k `mplus` match cs- check (PB_Ge cs k) = pos k `mplus` match cs- check (PB_Eq cs k) = pos k `mplus` match cs-- pos k- | k < 0 = Just $ "comparison value must be positive, received: " ++ show k- | True = Nothing-- match cs- | any (< 0) cs = Just $ "coefficients must be non-negative. Received: " ++ show cs- | lxs /= lcs = Just $ "coefficient length must match number of arguments. Received: " ++ show (lcs, lxs)- | True = Nothing- where lxs = length xs- lcs = length cs-- result = SBV (SVal KBool (Right (cache r)))- r st = do xsv <- mapM (sbvToSV st) xs- -- PseudoBoolean's implicitly require support for integers, so make sure to register that kind!- registerKind st KUnbounded- newExpr st KBool (SBVApp (PseudoBoolean o) xsv)---- | 'sTrue' if at most @k@ of the input arguments are 'sTrue'-pbAtMost :: [SBool] -> Int -> SBool-pbAtMost xs k- | k < 0 = error $ "SBV.pbAtMost: Non-negative value required, received: " ++ show k- | all isConcrete xs = literal $ sum (map (pbToInteger "pbAtMost" 1) xs) <= fromIntegral k- | True = liftPB "pbAtMost" (PB_AtMost k) xs---- | 'sTrue' if at least @k@ of the input arguments are 'sTrue'-pbAtLeast :: [SBool] -> Int -> SBool-pbAtLeast xs k- | k < 0 = error $ "SBV.pbAtLeast: Non-negative value required, received: " ++ show k- | all isConcrete xs = literal $ sum (map (pbToInteger "pbAtLeast" 1) xs) >= fromIntegral k- | True = liftPB "pbAtLeast" (PB_AtLeast k) xs---- | 'sTrue' if exactly @k@ of the input arguments are 'sTrue'-pbExactly :: [SBool] -> Int -> SBool-pbExactly xs k- | k < 0 = error $ "SBV.pbExactly: Non-negative value required, received: " ++ show k- | all isConcrete xs = literal $ sum (map (pbToInteger "pbExactly" 1) xs) == fromIntegral k- | True = liftPB "pbExactly" (PB_Exactly k) xs---- | 'sTrue' if the sum of coefficients for 'sTrue' elements is at most @k@. Generalizes 'pbAtMost'.-pbLe :: [(Int, SBool)] -> Int -> SBool-pbLe xs k- | k < 0 = error $ "SBV.pbLe: Non-negative value required, received: " ++ show k- | all (isConcrete . snd) xs = literal $ sum [pbToInteger "pbLe" c b | (c, b) <- xs] <= fromIntegral k- | True = liftPB "pbLe" (PB_Le (map fst xs) k) (map snd xs)---- | 'sTrue' if the sum of coefficients for 'sTrue' elements is at least @k@. Generalizes 'pbAtLeast'.-pbGe :: [(Int, SBool)] -> Int -> SBool-pbGe xs k- | k < 0 = error $ "SBV.pbGe: Non-negative value required, received: " ++ show k- | all (isConcrete . snd) xs = literal $ sum [pbToInteger "pbGe" c b | (c, b) <- xs] >= fromIntegral k- | True = liftPB "pbGe" (PB_Ge (map fst xs) k) (map snd xs)---- | 'sTrue' if the sum of coefficients for 'sTrue' elements is exactly least @k@. Useful for coding--- /exactly K-of-N/ constraints, and in particular mutex constraints.-pbEq :: [(Int, SBool)] -> Int -> SBool-pbEq xs k- | k < 0 = error $ "SBV.pbEq: Non-negative value required, received: " ++ show k- | all (isConcrete . snd) xs = literal $ sum [pbToInteger "pbEq" c b | (c, b) <- xs] == fromIntegral k- | True = liftPB "pbEq" (PB_Eq (map fst xs) k) (map snd xs)---- | 'sTrue' if there is at most one set bit-pbMutexed :: [SBool] -> SBool-pbMutexed xs = pbAtMost xs 1---- | 'sTrue' if there is exactly one set bit-pbStronglyMutexed :: [SBool] -> SBool-pbStronglyMutexed xs = pbExactly xs 1---- | Convert a concrete pseudo-boolean to given int; converting to integer-pbToInteger :: String -> Int -> SBool -> Integer-pbToInteger w c b- | c < 0 = error $ "SBV." ++ w ++ ": Non-negative coefficient required, received: " ++ show c- | Just v <- unliteral b = if v then fromIntegral c else 0- | True = error $ "SBV.pbToInteger: Received a symbolic boolean: " ++ show (c, b)---- | Predicate for optimizing word operations like (+) and (*).-isConcreteZero :: SBV a -> Bool-isConcreteZero (SBV (SVal _ (Left (CV _ (CInteger n))))) = n == 0-isConcreteZero (SBV (SVal KReal (Left (CV KReal (CAlgReal v))))) = isExactRational v && v == 0-isConcreteZero _ = False---- | Predicate for optimizing word operations like (+) and (*).-isConcreteOne :: SBV a -> Bool-isConcreteOne (SBV (SVal _ (Left (CV _ (CInteger 1))))) = True-isConcreteOne (SBV (SVal KReal (Left (CV KReal (CAlgReal v))))) = isExactRational v && v == 1-isConcreteOne _ = False---- Num instance for symbolic words.-instance (Ord a, Num a, SymVal a) => Num (SBV a) where- fromInteger = literal . fromIntegral- SBV x + SBV y = SBV (svPlus x y)- SBV x * SBV y = SBV (svTimes x y)- SBV x - SBV y = SBV (svMinus x y)- -- Abs is problematic for floating point, due to -0; case, so we carefully shuttle it down- -- to the solver to avoid the can of worms. (Alternative would be to do an if-then-else here.)- abs (SBV x) = SBV (svAbs x)- signum a- -- NB. The following "carefully" tests the number for == 0, as Float/Double's NaN and +/-0- -- cases would cause trouble with explicit equality tests.- | hasSign a = ite (a .> z) i- $ ite (a .< z) (negate i) a- | True = ite (a .> z) i a- where z = genLiteral (kindOf a) (0::Integer)- i = genLiteral (kindOf a) (1::Integer)- -- negate is tricky because on double/float -0 is different than 0; so we cannot- -- just rely on the default definition; which would be 0-0, which is not -0!- negate (SBV x) = SBV (svUNeg x)---- | Symbolic exponentiation using bit blasting and repeated squaring.------ N.B. The exponent must be unsigned/bounded if symbolic. Signed exponents will be rejected.-(.^) :: (Mergeable b, Num b, SIntegral e) => b -> SBV e -> b-b .^ e- | isConcrete e, Just (x :: Integer) <- unliteral (sFromIntegral e)- = if x >= 0 then let go n v- | n == 0 = 1- | even n = go (n `div` 2) (v * v)- | True = v * go (n `div` 2) (v * v)- in go x b- else error $ "(.^): exponentiation: negative exponent: " ++ show x- | not (isBounded e) || isSigned e- = error $ "(.^): exponentiation only works with unsigned bounded symbolic exponents, kind: " ++ show (kindOf e)- | True- = -- NB. We can't simply use sTestBit and blastLE since they have SFiniteBit requirement- -- but we want to have SIntegral here only.- let SBV expt = e- expBit i = SBV (svTestBit expt i)- blasted = map expBit [0 .. intSizeOf e - 1]- in product $ zipWith (\use n -> ite use n 1)- blasted- (iterate (\x -> x*x) b)--instance (Ord a, SymVal a, Fractional a) => Fractional (SBV a) where- fromRational = literal . fromRational- SBV x / sy@(SBV y) | div0 = ite (sy .== 0) 0 res- | True = res- where res = SBV (svDivide x y)- -- Identify those kinds where we have a div-0 equals 0 exception- div0 = case kindOf sy of- KFloat -> False- KDouble -> False- KFP{} -> False- KReal -> True- KRational -> True- -- Following cases should not happen since these types should *not* be instances of Fractional- k@KBounded{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KUnbounded -> error $ "Unexpected Fractional case for: " ++ show k- k@KBool -> error $ "Unexpected Fractional case for: " ++ show k- k@KString -> error $ "Unexpected Fractional case for: " ++ show k- k@KChar -> error $ "Unexpected Fractional case for: " ++ show k- k@KList{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KSet{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KUserSort{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KTuple{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KMaybe{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KEither{} -> error $ "Unexpected Fractional case for: " ++ show k---- | Define Floating instance on SBV's; only for base types that are already floating; i.e., 'SFloat', 'SDouble', and 'SReal'.--- (See the separate definition below for 'SFloatingPoint'.) Note that unless you use delta-sat via 'Data.SBV.Provers.dReal' on 'SReal', most--- of the fields are "undefined" for symbolic values. We will add methods as they are supported by SMTLib. Currently, the--- only symbolically available function in this class is 'sqrt' for 'SFloat', 'SDouble' and 'SFloatingPoint'.-instance (Ord a, SymVal a, Fractional a, Floating a) => Floating (SBV a) where- pi = fromRational . toRational $ (pi :: Double)- exp = lift1FNS "exp" exp- log = lift1FNS "log" log- sqrt = lift1F FP_Sqrt sqrt- sin = lift1FNS "sin" sin- cos = lift1FNS "cos" cos- tan = lift1FNS "tan" tan- asin = lift1FNS "asin" asin- acos = lift1FNS "acos" acos- atan = lift1FNS "atan" atan- sinh = lift1FNS "sinh" sinh- cosh = lift1FNS "cosh" cosh- tanh = lift1FNS "tanh" tanh- asinh = lift1FNS "asinh" asinh- acosh = lift1FNS "acosh" acosh- atanh = lift1FNS "atanh" atanh- (**) = lift2FNS "**" (**)- logBase = lift2FNS "logBase" logBase--unsupported :: String -> a-unsupported w = error $ "Data.SBV.FloatingPoint: Unsupported operation: " ++ w ++ ". Please request this as a feature!"---- | We give a specific instance for 'SFloatingPoint', because the underlying floating-point type doesn't support--- fromRational directly. The overlap with the above instance is unfortunate.-instance {-# OVERLAPPING #-} ValidFloat eb sb => Floating (SFloatingPoint eb sb) where- -- Try from double; if there's enough precision this'll work, otherwise will bail out.- pi- | ei > 11 || si > 53 = unsupported $ "Floating.SFloatingPoint.pi (not-enough-precision for " ++ show (ei, si) ++ ")"- | True = literal $ FloatingPoint $ fpFromRational ei si (toRational (pi :: Double))- where ei = intOfProxy (Proxy @eb)- si = intOfProxy (Proxy @sb)-- -- Likewise, exponentiation is again limited to precision of double- exp i- | ei > 11 || si > 53 = unsupported $ "Floating.SFloatingPoint.exp (not-enough-precision for " ++ show (ei, si) ++ ")"- | True = literal e ** i- where ei = intOfProxy (Proxy @eb)- si = intOfProxy (Proxy @sb)- e = FloatingPoint $ fpFromRational ei si (toRational (exp 1 :: Double))-- log = lift1FNS "log" log- sqrt = lift1F FP_Sqrt sqrt- sin = lift1FNS "sin" sin- cos = lift1FNS "cos" cos- tan = lift1FNS "tan" tan- asin = lift1FNS "asin" asin- acos = lift1FNS "acos" acos- atan = lift1FNS "atan" atan- sinh = lift1FNS "sinh" sinh- cosh = lift1FNS "cosh" cosh- tanh = lift1FNS "tanh" tanh- asinh = lift1FNS "asinh" asinh- acosh = lift1FNS "acosh" acosh- atanh = lift1FNS "atanh" atanh- (**) = lift2FNS "**" (**)- logBase = lift2FNS "logBase" logBase---- | Lift a 1 arg FP-op, using sRNE default-lift1F :: SymVal a => FPOp -> (a -> a) -> SBV a -> SBV a-lift1F w op a- | Just v <- unliteral a- = literal $ op v- | True- = SBV $ SVal k $ Right $ cache r- where k = kindOf a- r st = do swa <- sbvToSV st a- swm <- sbvToSV st sRNE- newExpr st k (SBVApp (IEEEFP w) [swm, swa])---- | Lift a float/double unary function, only over constants-lift1FNS :: (SymVal a, Floating a) => String -> (a -> a) -> SBV a -> SBV a-lift1FNS nm f sv- | Just v <- unliteral sv = literal $ f v- | True = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv)---- | Lift a float/double binary function, only over constants-lift2FNS :: (SymVal a, Floating a) => String -> (a -> a -> a) -> SBV a -> SBV a -> SBV a-lift2FNS nm f sv1 sv2- | Just v1 <- unliteral sv1- , Just v2 <- unliteral sv2 = literal $ f v1 v2- | True = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv1)---- | SReal Floating instance, used in conjunction with the dReal solver for delta-satisfiability. Note that--- we do not constant fold these values (except for pi), as Haskell doesn't really have any means of computing--- them for arbitrary rationals.-instance {-# OVERLAPPING #-} Floating SReal where- pi = fromRational . toRational $ (pi :: Double) -- Perhaps not good enough?- exp = lift1SReal NR_Exp- log = lift1SReal NR_Log- sqrt = lift1SReal NR_Sqrt- sin = lift1SReal NR_Sin- cos = lift1SReal NR_Cos- tan = lift1SReal NR_Tan- asin = lift1SReal NR_ASin- acos = lift1SReal NR_ACos- atan = lift1SReal NR_ATan- sinh = lift1SReal NR_Sinh- cosh = lift1SReal NR_Cosh- tanh = lift1SReal NR_Tanh- asinh = error "Data.SBV.SReal: asinh is currently not supported. Please request this as a feature!"- acosh = error "Data.SBV.SReal: acosh is currently not supported. Please request this as a feature!"- atanh = error "Data.SBV.SReal: atanh is currently not supported. Please request this as a feature!"- (**) = lift2SReal NR_Pow-- logBase x y = log y / log x---- | Lift an sreal unary function-lift1SReal :: NROp -> SReal -> SReal-lift1SReal w a = SBV $ SVal k $ Right $ cache r- where k = kindOf a- r st = do swa <- sbvToSV st a- newExpr st k (SBVApp (NonLinear w) [swa])---- | Lift an sreal binary function-lift2SReal :: NROp -> SReal -> SReal -> SReal-lift2SReal w a b = SBV $ SVal k $ Right $ cache r- where k = kindOf a- r st = do swa <- sbvToSV st a- swb <- sbvToSV st b- newExpr st k (SBVApp (NonLinear w) [swa, swb])---- NB. In the optimizations below, use of -1 is valid as--- -1 has all bits set to True for both signed and unsigned values--- | Using 'popCount' or 'testBit' on non-concrete values will result in an--- error. Use 'sPopCount' or 'sTestBit' instead.-instance (Ord a, Num a, Bits a, SymVal a) => Bits (SBV a) where- SBV x .&. SBV y = SBV (svAnd x y)- SBV x .|. SBV y = SBV (svOr x y)- SBV x `xor` SBV y = SBV (svXOr x y)- complement (SBV x) = SBV (svNot x)- bitSize x = intSizeOf x- bitSizeMaybe x = Just $ intSizeOf x- isSigned x = hasSign x- bit i = 1 `shiftL` i- setBit x i = x .|. genLiteral (kindOf x) (bit i :: Integer)- clearBit x i = x .&. genLiteral (kindOf x) (complement (bit i) :: Integer)- complementBit x i = x `xor` genLiteral (kindOf x) (bit i :: Integer)- shiftL (SBV x) i = SBV (svShl x i)- shiftR (SBV x) i = SBV (svShr x i)- rotateL (SBV x) i = SBV (svRol x i)- rotateR (SBV x) i = SBV (svRor x i)- -- NB. testBit is *not* implementable on non-concrete symbolic words- x `testBit` i- | SBV (SVal _ (Left (CV _ (CInteger n)))) <- x- = testBit n i- | True- = error $ "SBV.testBit: Called on symbolic value: " ++ show x ++ ". Use sTestBit instead."- -- NB. popCount is *not* implementable on non-concrete symbolic words- popCount x- | SBV (SVal _ (Left (CV (KBounded _ w) (CInteger n)))) <- x- = popCount (n .&. (bit w - 1))- | True- = error $ "SBV.popCount: Called on symbolic value: " ++ show x ++ ". Use sPopCount instead."---- | Conversion between integral-symbolic values, akin to Haskell's `fromIntegral`-sFromIntegral :: forall a b. (Integral a, HasKind a, Num a, SymVal a, HasKind b, Num b, SymVal b) => SBV a -> SBV b-sFromIntegral x- | kFrom == kTo- = SBV (unSBV x)- | isReal x- = error "SBV.sFromIntegral: Called on a real value" -- can't really happen due to types, but being overcautious- | Just v <- unliteral x- = literal (fromIntegral v)- | True- = result- where result = SBV (SVal kTo (Right (cache y)))- kFrom = kindOf x- kTo = kindOf (Proxy @b)- y st = do xsv <- sbvToSV st x- newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsv])---- | Lift a binary operation thru it's dynamic counterpart. Note that--- we still want the actual functions here as differ in their type--- compared to their dynamic counterparts, but the implementations--- are the same.-liftViaSVal :: (SVal -> SVal -> SVal) -> SBV a -> SBV b -> SBV c-liftViaSVal f (SBV a) (SBV b) = SBV $ f a b---- | Generalization of 'shiftL', when the shift-amount is symbolic. Since Haskell's--- 'shiftL' only takes an 'Int' as the shift amount, it cannot be used when we have--- a symbolic amount to shift with.-sShiftLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a-sShiftLeft = liftViaSVal svShiftLeft---- | Generalization of 'shiftR', when the shift-amount is symbolic. Since Haskell's--- 'shiftR' only takes an 'Int' as the shift amount, it cannot be used when we have--- a symbolic amount to shift with.------ NB. If the shiftee is signed, then this is an arithmetic shift; otherwise it's logical,--- following the usual Haskell convention. See 'sSignedShiftArithRight' for a variant--- that explicitly uses the msb as the sign bit, even for unsigned underlying types.-sShiftRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a-sShiftRight = liftViaSVal svShiftRight---- | Arithmetic shift-right with a symbolic unsigned shift amount. This is equivalent--- to 'sShiftRight' when the argument is signed. However, if the argument is unsigned,--- then it explicitly treats its msb as a sign-bit, and uses it as the bit that--- gets shifted in. Useful when using the underlying unsigned bit representation to implement--- custom signed operations. Note that there is no direct Haskell analogue of this function.-sSignedShiftArithRight:: (SFiniteBits a, SIntegral b) => SBV a -> SBV b -> SBV a-sSignedShiftArithRight x i- | isSigned i = error "sSignedShiftArithRight: shift amount should be unsigned"- | isSigned x = ssa x i- | True = ite (msb x)- (complement (ssa (complement x) i))- (ssa x i)- where ssa = liftViaSVal svShiftRight---- | Generalization of 'rotateL', when the shift-amount is symbolic. Since Haskell's--- 'rotateL' only takes an 'Int' as the shift amount, it cannot be used when we have--- a symbolic amount to shift with. The first argument should be a bounded quantity.-sRotateLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a-sRotateLeft = liftViaSVal svRotateLeft---- | An implementation of rotate-left, using a barrel shifter like design. Only works when both--- arguments are finite bitvectors, and furthermore when the second argument is unsigned.--- The first condition is enforced by the type, but the second is dynamically checked.--- We provide this implementation as an alternative to `sRotateLeft` since SMTLib logic--- does not support variable argument rotates (as opposed to shifts), and thus this--- implementation can produce better code for verification compared to `sRotateLeft`.-sBarrelRotateLeft :: (SFiniteBits a, SFiniteBits b) => SBV a -> SBV b -> SBV a-sBarrelRotateLeft = liftViaSVal svBarrelRotateLeft---- | Generalization of 'rotateR', when the shift-amount is symbolic. Since Haskell's--- 'rotateR' only takes an 'Int' as the shift amount, it cannot be used when we have--- a symbolic amount to shift with. The first argument should be a bounded quantity.-sRotateRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a-sRotateRight = liftViaSVal svRotateRight---- | An implementation of rotate-right, using a barrel shifter like design. See comments--- for `sBarrelRotateLeft` for details.-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, 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---- | 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---- | 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.--- However, 'quotRem' and 'divMod' both make perfect sense, and the 'SDivisible' class captures--- this operation. One issue is how division by 0 behaves. The verification--- technology requires total functions, and there are several design choices--- here. We follow Isabelle/HOL approach of assigning the value 0 for division--- by 0. Therefore, we impose the following pair of laws:------ @--- x `sQuotRem` 0 = (0, x)--- x `sDivMod` 0 = (0, x)--- @------ Note that our instances implement this law even when @x@ is @0@ itself.------ NB. 'quot' truncates toward zero, while 'div' truncates toward negative infinity.------ === C code generation of division operations------ In the case of division or modulo of a minimal signed value (e.g. @-128@ for--- 'SInt8') by @-1@, SMTLIB and Haskell agree on what the result should be.--- Unfortunately the result in C code depends on CPU architecture and compiler--- settings, as this is undefined behaviour in C. **SBV does not guarantee**--- what will happen in generated C code in this corner case.-class SDivisible a where- sQuotRem :: a -> a -> (a, a)- sDivMod :: a -> a -> (a, a)- sQuot :: a -> a -> a- sRem :: a -> a -> a- sDiv :: a -> a -> a- sMod :: a -> a -> a-- {-# MINIMAL sQuotRem, sDivMod #-}-- x `sQuot` y = fst $ x `sQuotRem` y- x `sRem` y = snd $ x `sQuotRem` y- x `sDiv` y = fst $ x `sDivMod` y- x `sMod` y = snd $ x `sDivMod` y--instance SDivisible Word64 where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y--instance SDivisible Int64 where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y--instance SDivisible Word32 where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y--instance SDivisible Int32 where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y--instance SDivisible Word16 where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y--instance SDivisible Int16 where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y--instance SDivisible Word8 where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y--instance SDivisible Int8 where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y--instance SDivisible Integer where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y--instance SDivisible CV where- sQuotRem a b- | CInteger x <- cvVal a, CInteger y <- cvVal b- = let (r1, r2) = sQuotRem x y in (normCV a{ cvVal = CInteger r1 }, normCV b{ cvVal = CInteger r2 })- sQuotRem a b = error $ "SBV.sQuotRem: impossible, unexpected args received: " ++ show (a, b)- sDivMod a b- | CInteger x <- cvVal a, CInteger y <- cvVal b- = let (r1, r2) = sDivMod x y in (normCV a{ cvVal = CInteger r1 }, normCV b{ cvVal = CInteger r2 })- sDivMod a b = error $ "SBV.sDivMod: impossible, unexpected args received: " ++ show (a, b)--instance SDivisible SWord64 where- sQuotRem = liftQRem- sDivMod = liftDMod--instance SDivisible SInt64 where- sQuotRem = liftQRem- sDivMod = liftDMod--instance SDivisible SWord32 where- sQuotRem = liftQRem- sDivMod = liftDMod--instance SDivisible SInt32 where- sQuotRem = liftQRem- sDivMod = liftDMod--instance SDivisible SWord16 where- sQuotRem = liftQRem- sDivMod = liftDMod--instance SDivisible SInt16 where- sQuotRem = liftQRem- sDivMod = liftDMod--instance SDivisible SWord8 where- sQuotRem = liftQRem- sDivMod = liftDMod--instance SDivisible SInt8 where- sQuotRem = liftQRem- sDivMod = liftDMod---- | Lift 'quotRem' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which--- holds even when @x@ is @0@ itself.-liftQRem :: (Eq a, SymVal a) => SBV a -> SBV a -> (SBV a, SBV a)-liftQRem x y- | isConcreteZero x- = (x, x)- | isConcreteOne y- = (x, z)-{-------------------------------- - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed;- - and also is problematic around the minBound.. So, we refrain from that optimization- | isConcreteOnes y- = (-x, z)---------------------------------}- | True- = ite (y .== z) (z, x) (qr x y)- where qr (SBV (SVal sgnsz (Left a))) (SBV (SVal _ (Left b))) = let (q, r) = sQuotRem a b in (SBV (SVal sgnsz (Left q)), SBV (SVal sgnsz (Left r)))- qr a@(SBV (SVal sgnsz _)) b = (SBV (SVal sgnsz (Right (cache (mk Quot)))), SBV (SVal sgnsz (Right (cache (mk Rem)))))- where mk o st = do sw1 <- sbvToSV st a- sw2 <- sbvToSV st b- mkSymOp o st sgnsz sw1 sw2- z = genLiteral (kindOf x) (0::Integer)---- | Lift 'divMod' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which--- holds even when @x@ is @0@ itself. Essentially, this is conversion from quotRem--- (truncate to 0) to divMod (truncate towards negative infinity)-liftDMod :: (Ord a, SymVal a, Num a, SDivisible (SBV a)) => SBV a -> SBV a -> (SBV a, SBV a)-liftDMod x y- | isConcreteZero x- = (x, x)- | isConcreteOne y- = (x, z)-{-------------------------------- - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed;- - and also is problematic around the minBound.. So, we refrain from that optimization- | isConcreteOnes y- = (-x, z)---------------------------------}- | True- = ite (y .== z) (z, x) $ ite (signum r .== negate (signum y)) (q-i, r+y) qr- where qr@(q, r) = x `sQuotRem` y- z = genLiteral (kindOf x) (0::Integer)- i = genLiteral (kindOf x) (1::Integer)---- SInteger instance for quotRem/divMod are tricky!--- SMT-Lib only has Euclidean operations, but Haskell--- 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- sQuotRem x y- | not (isSymbolic x || isSymbolic y)- = liftQRem x y- | True- = ite (y .== 0) (0, x) (qE+i, rE-i*y)- where (qE, rE) = liftQRem x y -- for integers, this is euclidean due to SMTLib semantics- i = ite (x .>= 0 .|| rE .== 0) 0- $ ite (y .> 0) 1 (-1)---- Quickcheck interface-instance (SymVal a, Arbitrary a) => Arbitrary (SBV a) where- arbitrary = literal `fmap` arbitrary---- | Symbolic conditionals are modeled by the 'Mergeable' class, describing--- how to merge the results of an if-then-else call with a symbolic test. SBV--- provides all basic types as instances of this class, so users only need--- to declare instances for custom data-types of their programs as needed.------ A 'Mergeable' instance may be automatically derived for a custom data-type--- with a single constructor where the type of each field is an instance of--- 'Mergeable', such as a record of symbolic values. Users only need to add--- 'G.Generic' and 'Mergeable' to the @deriving@ clause for the data-type. See--- 'Documentation.SBV.Examples.Puzzles.U2Bridge.Status' for an example and an--- illustration of what the instance would look like if written by hand.------ The function 'select' is a total-indexing function out of a list of choices--- with a default value, simulating array/list indexing. It's an n-way generalization--- of the 'ite' function.------ Minimal complete definition: None, if the type is instance of @Generic@. Otherwise--- 'symbolicMerge'. Note that most types subject to merging are likely to be--- trivial instances of @Generic@.-class Mergeable a where- -- | Merge two values based on the condition. The first argument states- -- whether we force the then-and-else branches before the merging, at the- -- word level. This is an efficiency concern; one that we'd rather not- -- make but unfortunately necessary for getting symbolic simulation- -- working efficiently.- symbolicMerge :: Bool -> SBool -> a -> a -> a- -- | Total indexing operation. @select xs default index@ is intuitively- -- the same as @xs !! index@, except it evaluates to @default@ if @index@- -- underflows/overflows.- select :: (Ord b, SymVal b, Num b) => [a] -> a -> SBV b -> a- -- NB. Earlier implementation of select used the binary-search trick- -- on the index to chop down the search space. While that is a good trick- -- in general, it doesn't work for SBV since we do not have any notion of- -- "concrete" subwords: If an index is symbolic, then all its bits are- -- symbolic as well. So, the binary search only pays off only if the indexed- -- list is really humongous, which is not very common in general. (Also,- -- for the case when the list is bit-vectors, we use SMT tables anyhow.)- select xs err ind- | isReal ind = bad "real"- | isFloat ind = bad "float"- | isDouble ind = bad "double"- | hasSign ind = ite (ind .< 0) err (walk xs ind err)- | True = walk xs ind err- where bad w = error $ "SBV.select: unsupported " ++ w ++ " valued select/index expression"- walk [] _ acc = acc- walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc)-- -- Default implementation for 'symbolicMerge' if the type is 'Generic'- default symbolicMerge :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a- symbolicMerge = symbolicMergeDefault---- | If-then-else. This is by definition 'symbolicMerge' with both--- branches forced. This is typically the desired behavior, but also--- see 'iteLazy' should you need more laziness.-ite :: Mergeable a => SBool -> a -> a -> a-ite t a b- | Just r <- unliteral t = if r then a else b- | True = symbolicMerge True t a b---- | A Lazy version of ite, which does not force its arguments. This might--- cause issues for symbolic simulation with large thunks around, so use with--- care.-iteLazy :: Mergeable a => SBool -> a -> a -> a-iteLazy t a b- | Just r <- unliteral t = if r then a else b- | True = symbolicMerge False t a b---- | Symbolic assert. Check that the given boolean condition is always 'sTrue' in the given path. The--- optional first argument can be used to provide call-stack info via GHC's location facilities.-sAssert :: HasKind a => Maybe CallStack -> String -> SBool -> SBV a -> SBV a-sAssert cs msg cond x- | Just mustHold <- unliteral cond- = if mustHold- then x- else error $ show $ SafeResult ((locInfo . getCallStack) `fmap` cs, msg, Satisfiable defaultSMTCfg (SMTModel [] Nothing [] []))- | True- = SBV $ SVal k $ Right $ cache r- where k = kindOf x- r st = do xsv <- sbvToSV st x- let pc = getPathCondition st- -- We're checking if there are any cases where the path-condition holds, but not the condition- -- Any violations of this, should be signaled, i.e., whenever the following formula is satisfiable- mustNeverHappen = pc .&& sNot cond- cnd <- sbvToSV st mustNeverHappen- addAssertion st cs msg cnd- return xsv-- locInfo ps = intercalate ",\n " (map loc ps)- where loc (f, sl) = concat [srcLocFile sl, ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f]---- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make--- sure they do not evaluate to the same result. This should only be used for internal purposes;--- as default definitions provided should suffice in many cases. (i.e., End users should--- only need to define 'symbolicMerge' when needed; which should be rare to start with.)-symbolicMergeWithKind :: Kind -> Bool -> SBool -> SBV a -> SBV a -> SBV a-symbolicMergeWithKind k force (SBV t) (SBV a) (SBV b) = SBV (svSymbolicMerge k force t a b)--instance SymVal a => Mergeable (SBV a) where- symbolicMerge force t x y- -- Carefully use the kindOf instance to avoid strictness issues.- | force = symbolicMergeWithKind (kindOf x) True t x y- | True = symbolicMergeWithKind (kindOf (Proxy @a)) False t x y- -- Custom version of select that translates to SMT-Lib tables at the base type of words- select xs err ind- | SBV (SVal _ (Left c)) <- ind = case cvVal c of- CInteger i -> if i < 0 || i >= genericLength xs- then err- else xs `genericIndex` i- _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"- select xsOrig err ind = xs `seq` SBV (SVal kElt (Right (cache r)))- where kInd = kindOf ind- kElt = kindOf err- -- Based on the index size, we need to limit the elements. For instance if the index is 8 bits, but there- -- are 257 elements, that last element will never be used and we can chop it of..- xs = case kindOf ind of- KBounded False i -> genericTake ((2::Integer) ^ (fromIntegral i :: Integer)) xsOrig- KBounded True i -> genericTake ((2::Integer) ^ (fromIntegral (i-1) :: Integer)) xsOrig- KUnbounded -> xsOrig- _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"- r st = do sws <- mapM (sbvToSV st) xs- swe <- sbvToSV st err- if all (== swe) sws -- off-chance that all elts are the same. Note that this also correctly covers the case when list is empty.- then return swe- else do idx <- getTableIndex st kInd kElt sws- swi <- sbvToSV st ind- let len = length xs- -- NB. No need to worry here that the index might be < 0; as the SMTLib translation takes care of that automatically- newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])---- | Construct a useful error message if we hit an unmergeable case.-cannotMerge :: String -> String -> String -> a-cannotMerge typ why hint = error $ unlines [ ""- , "*** Data.SBV.Mergeable: Cannot merge instances of " ++ typ ++ "."- , "*** While trying to do a symbolic if-then-else with incompatible branch results."- , "***"- , "*** " ++ why- , "*** "- , "*** Hint: " ++ hint- ]---- | Merge concrete values that can be checked for equality-concreteMerge :: Show a => String -> String -> (a -> a -> Bool) -> a -> a -> a-concreteMerge t st eq x y- | x `eq` y = x- | True = cannotMerge t- ("Concrete values can only be merged when equal. Got: " ++ show x ++ " vs. " ++ show y)- ("Use an " ++ st ++ " field if the values can differ.")---- Mergeable instances for List/Maybe/Either/Array are useful, but can--- throw exceptions if there is no structural matching of the results--- It's a question whether we should really keep them..---- Lists-instance Mergeable a => Mergeable [a] where- symbolicMerge f t xs ys- | lxs == lys = zipWith (symbolicMerge f t) xs ys- | True = cannotMerge "lists"- ("Branches produce different sizes: " ++ show lxs ++ " vs " ++ show lys ++ ". Must have the same length.")- "Use the 'SList' type (and Data.SBV.List routines) to model fully symbolic lists."- where (lxs, lys) = (length xs, length ys)---- ZipList-instance Mergeable a => Mergeable (ZipList a) where- symbolicMerge force test (ZipList xs) (ZipList ys)- = ZipList (symbolicMerge force test xs ys)---- Maybe-instance Mergeable a => Mergeable (Maybe a) where- symbolicMerge _ _ Nothing Nothing = Nothing- symbolicMerge f t (Just a) (Just b) = Just $ symbolicMerge f t a b- symbolicMerge _ _ a b = cannotMerge "'Maybe' values"- ("Branches produce different constructors: " ++ show (k a, k b))- "Instead of an option type, try using a valid bit to indicate when a result is valid."- where k Nothing = "Nothing"- k _ = "Just"---- Either-instance (Mergeable a, Mergeable b) => Mergeable (Either a b) where- symbolicMerge f t (Left a) (Left b) = Left $ symbolicMerge f t a b- symbolicMerge f t (Right a) (Right b) = Right $ symbolicMerge f t a b- symbolicMerge _ _ a b = cannotMerge "'Either' values"- ("Branches produce different constructors: " ++ show (k a, k b))- "Consider using a product type by a tag instead."- where k (Left _) = "Left"- k (Right _) = "Right"---- Arrays-instance (Ix a, Mergeable b) => Mergeable (Array a b) where- symbolicMerge f t a b- | ba == bb = listArray ba (zipWith (symbolicMerge f t) (elems a) (elems b))- | True = cannotMerge "'Array' values"- ("Branches produce different ranges: " ++ show (k ba, k bb))- "Consider using SBV's native 'SArray' abstraction."- where [ba, bb] = map bounds [a, b]- k = rangeSize---- Functions-instance Mergeable b => Mergeable (a -> b) where- symbolicMerge f t g h x = symbolicMerge f t (g x) (h x)- {- Following definition, while correct, is utterly inefficient. Since the- application is delayed, this hangs on to the inner list and all the- impending merges, even when ind is concrete. Thus, it's much better to- simply use the default definition for the function case.- -}- -- select xs err ind = \x -> select (map ($ x) xs) (err x) ind---- 2-Tuple-instance (Mergeable a, Mergeable b) => Mergeable (a, b) where- symbolicMerge f t (i0, i1) (j0, j1) = ( symbolicMerge f t i0 j0- , symbolicMerge f t i1 j1- )-- select xs (err1, err2) ind = ( select as err1 ind- , select bs err2 ind- )- where (as, bs) = unzip xs---- 3-Tuple-instance (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) where- symbolicMerge f t (i0, i1, i2) (j0, j1, j2) = ( symbolicMerge f t i0 j0- , symbolicMerge f t i1 j1- , symbolicMerge f t i2 j2- )-- select xs (err1, err2, err3) ind = ( select as err1 ind- , select bs err2 ind- , select cs err3 ind- )-- where (as, bs, cs) = unzip3 xs---- 4-Tuple-instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => Mergeable (a, b, c, d) where- symbolicMerge f t (i0, i1, i2, i3) (j0, j1, j2, j3) = ( symbolicMerge f t i0 j0- , symbolicMerge f t i1 j1- , symbolicMerge f t i2 j2- , symbolicMerge f t i3 j3- )-- select xs (err1, err2, err3, err4) ind = ( select as err1 ind- , select bs err2 ind- , select cs err3 ind- , select ds err4 ind- )- where (as, bs, cs, ds) = unzip4 xs---- 5-Tuple-instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => Mergeable (a, b, c, d, e) where- symbolicMerge f t (i0, i1, i2, i3, i4) (j0, j1, j2, j3, j4) = ( symbolicMerge f t i0 j0- , symbolicMerge f t i1 j1- , symbolicMerge f t i2 j2- , symbolicMerge f t i3 j3- , symbolicMerge f t i4 j4- )-- select xs (err1, err2, err3, err4, err5) ind = ( select as err1 ind- , select bs err2 ind- , select cs err3 ind- , select ds err4 ind- , select es err5 ind- )- where (as, bs, cs, ds, es) = unzip5 xs---- 6-Tuple-instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f) => Mergeable (a, b, c, d, e, f) where- symbolicMerge f t (i0, i1, i2, i3, i4, i5) (j0, j1, j2, j3, j4, j5) = ( symbolicMerge f t i0 j0- , symbolicMerge f t i1 j1- , symbolicMerge f t i2 j2- , symbolicMerge f t i3 j3- , symbolicMerge f t i4 j4- , symbolicMerge f t i5 j5- )-- select xs (err1, err2, err3, err4, err5, err6) ind = ( select as err1 ind- , select bs err2 ind- , select cs err3 ind- , select ds err4 ind- , select es err5 ind- , select fs err6 ind- )- where (as, bs, cs, ds, es, fs) = unzip6 xs---- 7-Tuple-instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f, Mergeable g) => Mergeable (a, b, c, d, e, f, g) where- symbolicMerge f t (i0, i1, i2, i3, i4, i5, i6) (j0, j1, j2, j3, j4, j5, j6) = ( symbolicMerge f t i0 j0- , symbolicMerge f t i1 j1- , symbolicMerge f t i2 j2- , symbolicMerge f t i3 j3- , symbolicMerge f t i4 j4- , symbolicMerge f t i5 j5- , symbolicMerge f t i6 j6- )-- select xs (err1, err2, err3, err4, err5, err6, err7) ind = ( select as err1 ind- , select bs err2 ind- , select cs err3 ind- , select ds err4 ind- , select es err5 ind- , select fs err6 ind- , select gs err7 ind- )- where (as, bs, cs, ds, es, fs, gs) = unzip7 xs---- Base types are mergeable so long as they are equal-instance Mergeable () where symbolicMerge _ _ = concreteMerge "()" "()" (==)-instance Mergeable Integer where symbolicMerge _ _ = concreteMerge "Integer" "SInteger" (==)-instance Mergeable Bool where symbolicMerge _ _ = concreteMerge "Bool" "SBool" (==)-instance Mergeable Char where symbolicMerge _ _ = concreteMerge "Char" "SChar" (==)-instance Mergeable Float where symbolicMerge _ _ = concreteMerge "Float" "SFloat" fpIsEqualObjectH-instance Mergeable Double where symbolicMerge _ _ = concreteMerge "Double" "SDouble" fpIsEqualObjectH-instance Mergeable Word8 where symbolicMerge _ _ = concreteMerge "Word8" "SWord8" (==)-instance Mergeable Word16 where symbolicMerge _ _ = concreteMerge "Word16" "SWord16" (==)-instance Mergeable Word32 where symbolicMerge _ _ = concreteMerge "Word32" "SWord32" (==)-instance Mergeable Word64 where symbolicMerge _ _ = concreteMerge "Word64" "SWord64" (==)-instance Mergeable Int8 where symbolicMerge _ _ = concreteMerge "Int8" "SInt8" (==)-instance Mergeable Int16 where symbolicMerge _ _ = concreteMerge "Int16" "SInt16" (==)-instance Mergeable Int32 where symbolicMerge _ _ = concreteMerge "Int32" "SInt32" (==)-instance Mergeable Int64 where symbolicMerge _ _ = concreteMerge "Int64" "SInt64" (==)---- Arbitrary product types, using GHC.Generics------ NB: Because of the way GHC.Generics works, the implementation of--- symbolicMerge' is recursive. The derived instance for @data T a = T a a a a@--- resembles that for (a, (a, (a, a))), not the flat 4-tuple (a, a, a, a). This--- difference should have no effect in practice. Note also that, unlike the--- hand-rolled tuple instances, the generic instance does not provide a custom--- 'select' implementation, and so does not benefit from the SMT-table--- implementation in the 'SBV a' instance.---- | Not exported. Symbolic merge using the generic representation provided by--- 'G.Generics'.-symbolicMergeDefault :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a-symbolicMergeDefault force t x y = G.to $ symbolicMerge' force t (G.from x) (G.from y)---- | Not exported. Used only in 'symbolicMergeDefault'. Instances are provided for--- the generic representations of product types where each element is Mergeable.-class GMergeable f where- symbolicMerge' :: Bool -> SBool -> f a -> f a -> f a--instance GMergeable U1 where- symbolicMerge' _ _ _ _ = U1--instance (Mergeable c) => GMergeable (K1 i c) where- symbolicMerge' force t (K1 x) (K1 y) = K1 $ symbolicMerge force t x y--instance (GMergeable f) => GMergeable (M1 i c f) where- symbolicMerge' force t (M1 x) (M1 y) = M1 $ symbolicMerge' force t x y--instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where- symbolicMerge' force t (x1 :*: y1) (x2 :*: y2) = symbolicMerge' force t x1 x2 :*: symbolicMerge' force t y1 y2---- Bounded instances-instance (SymVal a, Bounded a) => Bounded (SBV a) where- minBound = literal minBound- maxBound = literal maxBound---- Arrays---- SArrays are both "EqSymbolic" and "Mergeable"-instance EqSymbolic (SArray a b) where- SArray a .== SArray b = SBV (a `eqSArr` b)---- When merging arrays; we'll ignore the force argument. This is arguably--- the right thing to do as we've too many things and likely we want to keep it efficient.-instance SymVal b => Mergeable (SArray a b) where- symbolicMerge _ = mergeArrays---- | Uninterpreted constants and functions. An uninterpreted constant is--- a value that is indexed by its name. The only property the prover assumes--- about these values are that they are equivalent to themselves; i.e., (for--- functions) they return the same results when applied to same arguments.--- We support uninterpreted-functions as a general means of black-box'ing--- operations that are /irrelevant/ for the purposes of the proof; i.e., when--- the proofs can be performed without any knowledge about the function itself.------ Minimal complete definition: 'sbvUninterpret'. However, most instances in--- practice are already provided by SBV, so end-users should not need to define their--- own instances.-class Uninterpreted a where- -- | Uninterpret a value, receiving an object that can be used instead. Use this version- -- when you do not need to add an axiom about this value.- uninterpret :: String -> a- -- | Uninterpret a value, only for the purposes of code-generation. For execution- -- and verification the value is used as is. For code-generation, the alternate- -- definition is used. This is useful when we want to take advantage of native- -- libraries on the target languages.- cgUninterpret :: String -> [String] -> a -> a- -- | Most generalized form of uninterpretation, this function should not be needed- -- by end-user-code, but is rather useful for the library development.- sbvUninterpret :: Maybe ([String], a) -> String -> a- -- | A synonym for 'uninterpret'. Allows us to create variables without- -- having to call 'free' explicitly, i.e., without being in the symbolic monad.- sym :: String -> a-- {-# MINIMAL sbvUninterpret #-}-- -- defaults:- uninterpret = sbvUninterpret Nothing- cgUninterpret nm code v = sbvUninterpret (Just (code, v)) nm- sym = uninterpret---- Plain constants-instance HasKind a => Uninterpreted (SBV a) where- sbvUninterpret mbCgData nm- | Just (_, v) <- mbCgData = v- | True = SBV $ SVal ka $ Right $ cache result- where ka = kindOf (Proxy @a)- result st = do isSMT <- inSMTMode st- case (isSMT, mbCgData) of- (True, Just (_, v)) -> sbvToSV st v- _ -> do newUninterpreted st nm (SBVType [ka]) (fst `fmap` mbCgData)- newExpr st ka $ SBVApp (Uninterpreted nm) []---- Functions of one argument-instance (SymVal b, HasKind a) => Uninterpreted (SBV b -> SBV a) where- sbvUninterpret mbCgData nm = f- where f arg0- | Just (_, v) <- mbCgData, isConcrete arg0- = v arg0- | True- = SBV $ SVal ka $ Right $ cache result- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- result st = do isSMT <- inSMTMode st- case (isSMT, mbCgData) of- (True, Just (_, v)) -> sbvToSV st (v arg0)- _ -> do newUninterpreted st nm (SBVType [kb, ka]) (fst `fmap` mbCgData)- sw0 <- sbvToSV st arg0- mapM_ forceSVArg [sw0]- newExpr st ka $ SBVApp (Uninterpreted nm) [sw0]---- Functions of two arguments-instance (SymVal c, SymVal b, HasKind a) => Uninterpreted (SBV c -> SBV b -> SBV a) where- sbvUninterpret mbCgData nm = f- where f arg0 arg1- | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1- = v arg0 arg1- | True- = SBV $ SVal ka $ Right $ cache result- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- kc = kindOf (Proxy @c)- result st = do isSMT <- inSMTMode st- case (isSMT, mbCgData) of- (True, Just (_, v)) -> sbvToSV st (v arg0 arg1)- _ -> do newUninterpreted st nm (SBVType [kc, kb, ka]) (fst `fmap` mbCgData)- sw0 <- sbvToSV st arg0- sw1 <- sbvToSV st arg1- mapM_ forceSVArg [sw0, sw1]- newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1]---- Functions of three arguments-instance (SymVal d, SymVal c, SymVal b, HasKind a) => Uninterpreted (SBV d -> SBV c -> SBV b -> SBV a) where- sbvUninterpret mbCgData nm = f- where f arg0 arg1 arg2- | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2- = v arg0 arg1 arg2- | True- = SBV $ SVal ka $ Right $ cache result- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- kc = kindOf (Proxy @c)- kd = kindOf (Proxy @d)- result st = do isSMT <- inSMTMode st- case (isSMT, mbCgData) of- (True, Just (_, v)) -> sbvToSV st (v arg0 arg1 arg2)- _ -> do newUninterpreted st nm (SBVType [kd, kc, kb, ka]) (fst `fmap` mbCgData)- sw0 <- sbvToSV st arg0- sw1 <- sbvToSV st arg1- sw2 <- sbvToSV st arg2- mapM_ forceSVArg [sw0, sw1, sw2]- newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2]---- Functions of four arguments-instance (SymVal e, SymVal d, SymVal c, SymVal b, HasKind a) => Uninterpreted (SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where- sbvUninterpret mbCgData nm = f- where f arg0 arg1 arg2 arg3- | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3- = v arg0 arg1 arg2 arg3- | True- = SBV $ SVal ka $ Right $ cache result- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- kc = kindOf (Proxy @c)- kd = kindOf (Proxy @d)- ke = kindOf (Proxy @e)- result st = do isSMT <- inSMTMode st- case (isSMT, mbCgData) of- (True, Just (_, v)) -> sbvToSV st (v arg0 arg1 arg2 arg3)- _ -> do newUninterpreted st nm (SBVType [ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)- sw0 <- sbvToSV st arg0- sw1 <- sbvToSV st arg1- sw2 <- sbvToSV st arg2- sw3 <- sbvToSV st arg3- mapM_ forceSVArg [sw0, sw1, sw2, sw3]- newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3]---- Functions of five arguments-instance (SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, HasKind a) => Uninterpreted (SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where- sbvUninterpret mbCgData nm = f- where f arg0 arg1 arg2 arg3 arg4- | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4- = v arg0 arg1 arg2 arg3 arg4- | True- = SBV $ SVal ka $ Right $ cache result- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- kc = kindOf (Proxy @c)- kd = kindOf (Proxy @d)- ke = kindOf (Proxy @e)- kf = kindOf (Proxy @f)- result st = do isSMT <- inSMTMode st- case (isSMT, mbCgData) of- (True, Just (_, v)) -> sbvToSV st (v arg0 arg1 arg2 arg3 arg4)- _ -> do newUninterpreted st nm (SBVType [kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)- sw0 <- sbvToSV st arg0- sw1 <- sbvToSV st arg1- sw2 <- sbvToSV st arg2- sw3 <- sbvToSV st arg3- sw4 <- sbvToSV st arg4- mapM_ forceSVArg [sw0, sw1, sw2, sw3, sw4]- newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4]---- Functions of six arguments-instance (SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, HasKind a) => Uninterpreted (SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where- sbvUninterpret mbCgData nm = f- where f arg0 arg1 arg2 arg3 arg4 arg5- | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5- = v arg0 arg1 arg2 arg3 arg4 arg5- | True- = SBV $ SVal ka $ Right $ cache result- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- kc = kindOf (Proxy @c)- kd = kindOf (Proxy @d)- ke = kindOf (Proxy @e)- kf = kindOf (Proxy @f)- kg = kindOf (Proxy @g)- result st = do isSMT <- inSMTMode st- case (isSMT, mbCgData) of- (True, Just (_, v)) -> sbvToSV st (v arg0 arg1 arg2 arg3 arg4 arg5)- _ -> do newUninterpreted st nm (SBVType [kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)- sw0 <- sbvToSV st arg0- sw1 <- sbvToSV st arg1- sw2 <- sbvToSV st arg2- sw3 <- sbvToSV st arg3- sw4 <- sbvToSV st arg4- sw5 <- sbvToSV st arg5- mapM_ forceSVArg [sw0, sw1, sw2, sw3, sw4, sw5]- newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5]---- Functions of seven arguments-instance (SymVal h, SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, HasKind a)- => Uninterpreted (SBV h -> SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where- sbvUninterpret mbCgData nm = f- where f arg0 arg1 arg2 arg3 arg4 arg5 arg6- | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5, isConcrete arg6- = v arg0 arg1 arg2 arg3 arg4 arg5 arg6- | True- = SBV $ SVal ka $ Right $ cache result- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- kc = kindOf (Proxy @c)- kd = kindOf (Proxy @d)- ke = kindOf (Proxy @e)- kf = kindOf (Proxy @f)- kg = kindOf (Proxy @g)- kh = kindOf (Proxy @h)- result st = do isSMT <- inSMTMode st- case (isSMT, mbCgData) of- (True, Just (_, v)) -> sbvToSV st (v arg0 arg1 arg2 arg3 arg4 arg5 arg6)- _ -> do newUninterpreted st nm (SBVType [kh, kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)- sw0 <- sbvToSV st arg0- sw1 <- sbvToSV st arg1- sw2 <- sbvToSV st arg2- sw3 <- sbvToSV st arg3- sw4 <- sbvToSV st arg4- sw5 <- sbvToSV st arg5- sw6 <- sbvToSV st arg6- mapM_ forceSVArg [sw0, sw1, sw2, sw3, sw4, sw5, sw6]- newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5, sw6]---- Uncurried functions of two arguments-instance (SymVal c, SymVal b, HasKind a) => Uninterpreted ((SBV c, SBV b) -> SBV a) where- sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc2 `fmap` mbCgData) nm in uncurry f- where uc2 (cs, fn) = (cs, curry fn)---- Uncurried functions of three arguments-instance (SymVal d, SymVal c, SymVal b, HasKind a) => Uninterpreted ((SBV d, SBV c, SBV b) -> SBV a) where- sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc3 `fmap` mbCgData) nm in \(arg0, arg1, arg2) -> f arg0 arg1 arg2- where uc3 (cs, fn) = (cs, \a b c -> fn (a, b, c))---- Uncurried functions of four arguments-instance (SymVal e, SymVal d, SymVal c, SymVal b, HasKind a)- => Uninterpreted ((SBV e, SBV d, SBV c, SBV b) -> SBV a) where- sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc4 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3) -> f arg0 arg1 arg2 arg3- where uc4 (cs, fn) = (cs, \a b c d -> fn (a, b, c, d))---- Uncurried functions of five arguments-instance (SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, HasKind a)- => Uninterpreted ((SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where- sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc5 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4) -> f arg0 arg1 arg2 arg3 arg4- where uc5 (cs, fn) = (cs, \a b c d e -> fn (a, b, c, d, e))---- Uncurried functions of six arguments-instance (SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, HasKind a)- => Uninterpreted ((SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where- sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc6 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5) -> f arg0 arg1 arg2 arg3 arg4 arg5- where uc6 (cs, fn) = (cs, \a b c d e f -> fn (a, b, c, d, e, f))---- Uncurried functions of seven arguments-instance (SymVal h, SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, HasKind a)- => Uninterpreted ((SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where- sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc7 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5, arg6) -> f arg0 arg1 arg2 arg3 arg4 arg5 arg6- where uc7 (cs, fn) = (cs, \a b c d e f g -> fn (a, b, c, d, e, f, g))---- | Symbolic computations provide a context for writing symbolic programs.-instance MonadIO m => SolverContext (SymbolicT m) where- constrain (SBV c) = imposeConstraint False [] c- softConstrain (SBV c) = imposeConstraint True [] c- namedConstraint nm (SBV c) = imposeConstraint False [(":named", nm)] c- constrainWithAttribute atts (SBV c) = imposeConstraint False atts c- addAxiom = addSymAxiom False- addSMTDefinition = addSymAxiom True- contextState = symbolicEnv-- setOption o = addNewSMTOption o---- | Add an axiom. Only used internally, use `addAxiom` from user programs which works over--- both regular and query modes of usage.-addSymAxiom :: (SolverContext m, MonadIO m) => Bool -> String -> [String] -> m ()-addSymAxiom hasDefinition nm ax = do- st <- contextState- liftIO $ modifyState st raxioms ((hasDefinition, nm, ax) :) (return ())---- | Generalization of 'Data.SBV.assertWithPenalty'-assertWithPenalty :: MonadSymbolic m => String -> SBool -> Penalty -> m ()-assertWithPenalty nm o p = addSValOptGoal $ unSBV `fmap` AssertWithPenalty nm o p---- | Class of metrics we can optimize for. Currently, booleans,--- bounded signed/unsigned bit-vectors, unbounded integers,--- algebraic reals and floats can be optimized. You can add--- your instances, but bewared that the 'MetricSpace' should--- map your type to something the backend solver understands, which--- are limited to unsigned bit-vectors, reals, and unbounded integers--- for z3.------ A good reference on these features is given in the following paper:--- <http://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/nbjorner-scss2014.pdf>.------ Minimal completion: None. However, if @MetricSpace@ is not identical to the type, you want--- to define 'toMetricSpace' and possibly 'minimize'/'maximize' to add extra constraints as necessary.-class Metric a where- -- | The metric space we optimize the goal over. Usually the same as the type itself, but not always!- -- For instance, signed bit-vectors are optimized over their unsigned counterparts, floats are- -- optimized over their 'Word32' comparable counterparts, etc.- type MetricSpace a :: Type- type MetricSpace a = a-- -- | Compute the metric value to optimize.- toMetricSpace :: SBV a -> SBV (MetricSpace a)- -- | Compute the value itself from the metric corresponding to it.- fromMetricSpace :: SBV (MetricSpace a) -> SBV a-- -- | Minimizing a metric space- msMinimize :: (MonadSymbolic m, SolverContext m) => String -> SBV a -> m ()- msMinimize nm o = addSValOptGoal $ unSBV `fmap` Minimize nm (toMetricSpace o)-- -- | Maximizing a metric space- msMaximize :: (MonadSymbolic m, SolverContext m) => String -> SBV a -> m ()- msMaximize nm o = addSValOptGoal $ unSBV `fmap` Maximize nm (toMetricSpace o)-- -- if MetricSpace is the same, we can give a default definition- default toMetricSpace :: (a ~ MetricSpace a) => SBV a -> SBV (MetricSpace a)- toMetricSpace = id-- default fromMetricSpace :: (a ~ MetricSpace a) => SBV (MetricSpace a) -> SBV a- fromMetricSpace = id---- Booleans assume True is greater than False-instance Metric Bool where- type MetricSpace Bool = Word8- toMetricSpace t = ite t 1 0- fromMetricSpace w = w ./= 0---- | Generalization of 'Data.SBV.minimize'-minimize :: (Metric a, MonadSymbolic m, SolverContext m) => String -> SBV a -> m ()-minimize = msMinimize---- | Generalization of 'Data.SBV.maximize'-maximize :: (Metric a, MonadSymbolic m, SolverContext m) => String -> SBV a -> m ()-maximize = msMaximize---- Unsigned types, integers, and reals directly optimize-instance Metric Word8-instance Metric Word16-instance Metric Word32-instance Metric Word64-instance Metric Integer-instance Metric AlgReal---- To optimize signed bounded values, we have to adjust to the range-instance Metric Int8 where- type MetricSpace Int8 = Word8- toMetricSpace x = sFromIntegral x + 128 -- 2^7- fromMetricSpace x = sFromIntegral x - 128--instance Metric Int16 where- type MetricSpace Int16 = Word16- toMetricSpace x = sFromIntegral x + 32768 -- 2^15- fromMetricSpace x = sFromIntegral x - 32768--instance Metric Int32 where- type MetricSpace Int32 = Word32- toMetricSpace x = sFromIntegral x + 2147483648 -- 2^31- fromMetricSpace x = sFromIntegral x - 2147483648--instance Metric Int64 where- type MetricSpace Int64 = Word64- toMetricSpace x = sFromIntegral x + 9223372036854775808 -- 2^63- fromMetricSpace x = sFromIntegral x - 9223372036854775808---- Quickcheck interface on symbolic-booleans..-instance Testable SBool where- property (SBV (SVal _ (Left b))) = property (cvToBool b)- property _ = error "Quick-check: Constant folding produced a symbolic value! Perhaps used a non-reducible expression? Please report!"--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 (Concrete Nothing) prop-- let cval = fromMaybe (error "Cannot quick-check in the presence of uninterpeted constants!") . (`lookup` cs)- cond = and [cvToBool (cval v) | (False, _, v) <- F.toList cstrs] -- Only pick-up "hard" constraints, as indicated by False in the fist component-- getObservable (nm, f, v) = case v `lookup` cs of- Just cv -> if f cv then Just (nm, cv) else Nothing- Nothing -> error $ "Quick-check: Observable " ++ nm ++ " did not reduce to a constant!"-- case map fst unints of- [] -> case unliteral r of- Nothing -> error $ intercalate "\n" [ "Quick-check: Calls to 'observe' not supported in quick-check mode. Please use 'sObserve' for full support."- , " (If you haven't used 'observe', please report this as a bug!)"- ]- Just b -> return (cond, b, tvals ++ mapMaybe getObservable ovals)- us -> error $ "Cannot quick-check in the presence of uninterpreted constants: " ++ intercalate ", " us-- complain qcInfo = showModel defaultSMTCfg (SMTModel [] Nothing qcInfo [])---- | 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.-sbvQuickCheck :: Symbolic SBool -> IO Bool-sbvQuickCheck prop = QC.isSuccess `fmap` QC.quickCheckResult prop---- Quickcheck interface on dynamically-typed values. A run-time check--- ensures that the value has boolean type.-instance Testable (Symbolic SVal) where- property m = property $ do s <- m- when (kindOf s /= KBool) $ error "Cannot quickcheck non-boolean value"- return (SBV s :: SBool)---- | Explicit sharing combinator. The SBV library has internal caching/hash-consing mechanisms--- built in, based on Andy Gill's type-safe observable sharing technique (see: <http://ku-fpg.github.io/files/Gill-09-TypeSafeReification.pdf>).--- However, there might be times where being explicit on the sharing can help, especially in experimental code. The 'slet' combinator--- ensures that its first argument is computed once and passed on to its continuation, explicitly indicating the intent of sharing. Most--- use cases of the SBV library should simply use Haskell's @let@ construct for this purpose.-slet :: forall a b. (HasKind a, HasKind b) => SBV a -> (SBV a -> SBV b) -> SBV b-slet x f = SBV $ SVal k $ Right $ cache r- where k = kindOf (Proxy @b)- r st = do xsv <- sbvToSV st x- let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (return xsv))))- res = f xsbv- sbvToSV st res---- | Equality as a proof method. Allows for--- very concise construction of equivalence proofs, which is very typical in--- bit-precise proofs.-infix 4 ===-class Equality a where- (===) :: a -> a -> IO ThmResult--instance {-# OVERLAPPABLE #-} (SymVal a, EqSymbolic z) => Equality (SBV a -> z) where- k === l = prove $ \a -> k a .== l a--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, EqSymbolic z) => Equality (SBV a -> SBV b -> z) where- k === l = prove $ \a b -> k a b .== l a b--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, EqSymbolic z) => Equality ((SBV a, SBV b) -> z) where- k === l = prove $ \a b -> k (a, b) .== l (a, b)--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> z) where- k === l = prove $ \a b c -> k a b c .== l a b c--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c) -> z) where- k === l = prove $ \a b c -> k (a, b, c) .== l (a, b, c)--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> z) where- k === l = prove $ \a b c d -> k a b c d .== l a b c d--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d) -> z) where- k === l = prove $ \a b c d -> k (a, b, c, d) .== l (a, b, c, d)--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> z) where- k === l = prove $ \a b c d e -> k a b c d e .== l a b c d e--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e) -> z) where- k === l = prove $ \a b c d e -> k (a, b, c, d, e) .== l (a, b, c, d, e)--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> z) where- k === l = prove $ \a b c d e f -> k a b c d e f .== l a b c d e f--instance {-# OVERLAPPABLE #-}- (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> z) where- k === l = prove $ \a b c d e f -> k (a, b, c, d, e, f) .== l (a, b, c, d, e, f)--instance {-# OVERLAPPABLE #-}- (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> z) where- k === l = prove $ \a b c d e f g -> k a b c d e f g .== l a b c d e f g--instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> z) where- k === l = prove $ \a b c d e f g -> k (a, b, c, d, e, f, g) .== l (a, b, c, d, e, f, g)--{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}++module Data.SBV.Core.Model (+ Mergeable(..), Equality(..), EqSymbolic(..), OrdSymbolic(..)+ , Zero(..), MeasureOf, Measure(..), MeasureHelper(..)+ , ContractOf, smtFunction, smtFunctionWithMeasure, smtFunctionWithContract, smtProductiveFunction, smtFunctionNoTermination+ , checkMutualGroup+ , SDivisible(..), SMTDefinable(..), QSaturate, qSaturateSavingObservables+ , Metric(..), minimize, maximize, assertWithPenalty, SIntegral, SFiniteBits(..)+ , ite, iteLazy, sFromIntegral, sShiftLeft, sShiftRight, sRotateLeft, sBarrelRotateLeft, sRotateRight, sBarrelRotateRight, sSignedShiftArithRight, (.^)+ , some+ , oneIf, genVar, genVar_+ , pbAtMost, pbAtLeast, pbExactly, pbLe, pbGe, pbEq, pbMutexed, pbStronglyMutexed+ , sBool, sBool_, sBools, sWord8, sWord8_, sWord8s, sWord16, sWord16_, sWord16s, sWord32, sWord32_, sWord32s+ , sWord64, sWord64_, sWord64s, sInt8, sInt8_, sInt8s, sInt16, sInt16_, sInt16s, sInt32, sInt32_, sInt32s, sInt64, sInt64_+ , sInt64s, sInteger, sInteger_, sIntegers, sReal, sReal_, sReals, sFloat, sFloat_, sFloats, sDouble, sDouble_, sDoubles+ , sWord, sWord_, sWords, sInt, sInt_, sInts+ , sFPHalf, sFPHalf_, sFPHalfs, sFPBFloat, sFPBFloat_, sFPBFloats, sFPSingle, sFPSingle_, sFPSingles, sFPDouble, sFPDouble_, sFPDoubles, sFPQuad, sFPQuad_, sFPQuads, sArray, sArray_, sArrays+ , sFloatingPoint, sFloatingPoint_, sFloatingPoints+ , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero+ , sRNE, sRNA, sRTP, sRTN, sRTZ+ , sCaseRoundingMode+ , sChar, sChar_, sChars, sString, sString_, sStrings, sList, sList_, sLists+ , sRational, sRational_, sRationals+ , SymTuple, sTuple, sTuple_, sTuples+ , sSet, sSet_, sSets+ , sEDivMod, sEDiv, sEMod+ , sDivides+ , solve+ , slet+ , sRealToSIntegerFloor, sRealToSIntegerCeiling, sRealToSIntegerTruncate+ , sRealToSIntegerRoundAway, sRealToSIntegerRoundToEven, sRealToSIntegerRM+ , label, observe, observeIf, sObserve+ , sAssert+ , liftQRem, liftDMod, symbolicMergeWithKind+ , genLiteral, genFromCV, genMkSymVar+ , zeroExtend, signExtend+ , sbvQuickCheck+ , readArray, writeArray, constArray, freeArray, lambdaArray, listArray+ , FromSized, ToSized, FromSizedBV(..), ToSizedBV(..)+ , smtHOFunction, smtHOFunctionWithMeasure, Closure(..)+ )+ where++import Control.Applicative (ZipList(ZipList))+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++import GHC.Stack+import GHC.TypeLits hiding(SChar)++import Data.Array (Array, Ix, elems, bounds, rangeSize)+import qualified Data.Array as DA (listArray)++import Data.Bifunctor (first)++import Data.Bits (Bits(..))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Kind (Type, Constraint)+import Data.List (genericLength, genericIndex, genericTake, unzip4, unzip5, unzip6, unzip7+ , intercalate, dropWhileEnd, isPrefixOf, partition, nubBy+#if !MIN_VERSION_base(4,20,0)+ , foldl'+#endif+ )+import Data.Maybe (fromMaybe, mapMaybe, isJust)+import Data.String (IsString(..))+import Data.Word (Word8, Word16, Word32, Word64)++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE++import qualified Data.Set as Set+import qualified Data.Graph as DG++import Data.Proxy+import Data.Dynamic (fromDynamic, toDyn, Typeable)++import Test.QuickCheck (Testable(..), Arbitrary(..))+import qualified Test.QuickCheck.Test as QC (isSuccess)+import qualified Test.QuickCheck as QC (quickCheckResult, counterexample)+import qualified Test.QuickCheck.Monadic as QC (monadicIO, run, assert, pre, monitor)++import qualified Data.Foldable as F (toList, for_)+import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq+import qualified Data.Text as T++import Data.SBV.Core.AlgReals+import Data.SBV.Core.Sized+import Data.SBV.Core.SizedFloats+import Data.SBV.Core.Data hiding (Constraint)+import Data.SBV.Core.Symbolic+import Data.SBV.Core.Operations+import Data.SBV.Core.Kind+import Data.SBV.Lambda+import Data.SBV.Utils.ExtractIO (ExtractIO)++import Data.SBV.Provers.Prover (defaultSMTCfg, SafeResult(..), defs2smt, prove, proveWith)+import Data.SBV.SMT.SMT (ThmResult(..), showModel)+import Data.SBV.SMT.Utils (debug)++import Data.SBV.Utils.Numeric (fpIsEqualObjectH, roundAway)++import Data.IORef (readIORef, writeIORef, modifyIORef')+import System.Mem.StableName (makeStableName, hashStableName)+import Data.SBV.Utils.Lib++import Data.Char++import System.FilePath (dropExtension, takeExtension)++-- 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++-- | Generate an unnamed variable+genVar_ :: MonadSymbolic m => VarContext -> Kind -> m (SBV a)+genVar_ q k = mkSymSBV q k Nothing++-- | Generate a finite constant bitvector+genLiteral :: Integral a => Kind -> a -> SBV b+genLiteral k = SBV . SVal k . Left . mkConstCV k++-- | Convert a constant to an integral value+genFromCV :: Integral a => CV -> a+genFromCV (CV _ (CInteger x)) = fromInteger x+genFromCV c = error $ "genFromCV: Unsupported non-integral value: " ++ show c++-- | Generalization of 'Data.SBV.genMkSymVar'+genMkSymVar :: MonadSymbolic m => Kind -> VarContext -> Maybe String -> m (SBV a)+genMkSymVar k mbq Nothing = genVar_ mbq k+genMkSymVar k mbq (Just s) = genVar mbq k s++instance SymVal Bool where+ mkSymVal = genMkSymVar KBool+ literal = SBV . svBool+ fromCV = cvToBool++instance SymVal Word8 where+ mkSymVal = genMkSymVar (KBounded False 8)+ literal = genLiteral (KBounded False 8)+ fromCV = genFromCV++instance SymVal Int8 where+ mkSymVal = genMkSymVar (KBounded True 8)+ literal = genLiteral (KBounded True 8)+ fromCV = genFromCV++instance SymVal Word16 where+ mkSymVal = genMkSymVar (KBounded False 16)+ literal = genLiteral (KBounded False 16)+ fromCV = genFromCV++instance SymVal Int16 where+ mkSymVal = genMkSymVar (KBounded True 16)+ literal = genLiteral (KBounded True 16)+ fromCV = genFromCV++instance SymVal Word32 where+ mkSymVal = genMkSymVar (KBounded False 32)+ literal = genLiteral (KBounded False 32)+ fromCV = genFromCV++instance SymVal Int32 where+ mkSymVal = genMkSymVar (KBounded True 32)+ literal = genLiteral (KBounded True 32)+ fromCV = genFromCV++instance SymVal Word64 where+ mkSymVal = genMkSymVar (KBounded False 64)+ literal = genLiteral (KBounded False 64)+ fromCV = genFromCV++instance SymVal Int64 where+ mkSymVal = genMkSymVar (KBounded True 64)+ literal = genLiteral (KBounded True 64)+ fromCV = genFromCV++instance SymVal Integer where+ 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+ isConcretely (SBV (SVal KReal (Left (CV KReal (CAlgReal v))))) p+ | isExactRational v = p v+ isConcretely _ _ = False++instance SymVal Float where+ mkSymVal = genMkSymVar KFloat+ 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,+ -- and in the presence of NaN's it would be incorrect to do any optimization+ isConcretely _ _ = False++instance SymVal Double where+ mkSymVal = genMkSymVar KDouble+ 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,+ -- and in the presence of NaN's it would be incorrect to do any optimization+ isConcretely _ _ = False++instance SymVal RoundingMode where+ literal = SBV . svRoundingMode+ fromCV c =+ case cvAsRoundingMode c of+ Just mode -> mode+ Nothing -> error $ "SymVal.RoundingMode: Unexpected non-rounding mode value: " ++ show c++-- | Symbolic variant of 'RoundNearestTiesToEven'+sRoundNearestTiesToEven :: SRoundingMode+sRoundNearestTiesToEven = literal RoundNearestTiesToEven++-- | Symbolic variant of 'RoundNearestTiesToAway'+sRoundNearestTiesToAway :: SRoundingMode+sRoundNearestTiesToAway = literal RoundNearestTiesToAway++-- | Symbolic variant of 'RoundTowardPositive'+sRoundTowardPositive :: SRoundingMode+sRoundTowardPositive = literal RoundTowardPositive++-- | Symbolic variant of 'RoundTowardNegative'+sRoundTowardNegative :: SRoundingMode+sRoundTowardNegative = literal RoundTowardNegative++-- | Symbolic variant of 'RoundTowardZero'+sRoundTowardZero :: SRoundingMode+sRoundTowardZero = literal RoundTowardZero++-- | Alias for 'sRoundNearestTiesToEven'+sRNE :: SRoundingMode+sRNE = sRoundNearestTiesToEven++-- | Alias for 'sRoundNearestTiesToAway'+sRNA :: SRoundingMode+sRNA = sRoundNearestTiesToAway++-- | Alias for 'sRoundTowardPositive'+sRTP :: SRoundingMode+sRTP = sRoundTowardPositive++-- | Alias for 'sRoundTowardNegative'+sRTN :: SRoundingMode+sRTN = sRoundTowardNegative++-- | Alias for 'sRoundTowardZero'+sRTZ :: SRoundingMode+sRTZ = sRoundTowardZero++-- | Case analyzer for the type 'RoundingMode'.+sCaseRoundingMode ::+ Mergeable r => r -- ^ What to return in the 'sRoundNearestTiesToEven' case.+ -> r -- ^ What to return in the 'sRoundNearestTiesToAway' case.+ -> r -- ^ What to return in the 'sRoundTowardPositive' case.+ -> r -- ^ What to return in the 'sRoundTowardNegative' case.+ -> r -- ^ What to return in the 'sRoundTowardZero' case.+ -> SRoundingMode+ -> r+sCaseRoundingMode fRNE fRNA fRTP fRTN fRTZ rm =+ ite (rm .== sRNE) fRNE $+ ite (rm .== sRNA) fRNA $+ ite (rm .== sRTP) fRTP $+ ite (rm .== sRTN) fRTN+ fRTZ+++instance SymVal Char where+ mkSymVal = genMkSymVar KChar+ literal c = SBV . SVal KChar . Left . CV KChar $ CChar c+ fromCV (CV _ (CChar a)) = a+ fromCV c = error $ "SymVal.String: Unexpected non-char value: " ++ show c++instance SymVal a => SymVal [a] where+ mkSymVal+ | isKString @[a] undefined = genMkSymVar KString+ | True = genMkSymVar (KList (kindOf (Proxy @a)))++ literal as+ | isKString @[a] undefined = case fromDynamic (toDyn as) of+ Just s -> SBV . SVal KString . Left . CV KString . CString $ s+ Nothing -> error "SString: Cannot construct literal string!"+ | True = let k = KList (kindOf (Proxy @a))+ in SBV $ SVal k $ Left $ CV k $ CList $ map toCV as++ fromCV (CV _ (CString a)) = fromMaybe (error "SString: Cannot extract a literal string!")+ (fromDynamic (toDyn a))+ 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))++instance ValidFloat eb sb => SymVal (FloatingPoint eb sb) where+ mkSymVal = genMkSymVar (KFP (intOfProxy (Proxy @eb)) (intOfProxy (Proxy @sb)))+ literal (FloatingPoint r) = let k = KFP (intOfProxy (Proxy @eb)) (intOfProxy (Proxy @sb))+ 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+ literal x = genLiteral (kindOf x) x+ mkSymVal = genMkSymVar (kindOf (undefined :: WordN n))+ fromCV = genFromCV++-- | 'SymVal' instance for 'IntN'+instance (KnownNat n, BVIsNonZero n) => SymVal (IntN n) where+ literal x = genLiteral (kindOf x) x+ mkSymVal = genMkSymVar (kindOf (undefined :: IntN n))+ fromCV = genFromCV++toCV :: SymVal a => a -> CVal+toCV a = case literal a of+ SBV (SVal _ (Left cv)) -> cvVal cv+ _ -> error "SymVal.toCV: Impossible happened, couldn't produce a concrete value"++mkCVTup :: Int -> Kind -> [CVal] -> SBV a+mkCVTup i k@(KTuple ks) cs+ | lks == lcs && lks == i+ = SBV $ SVal k $ Left $ CV k $ CTuple cs+ | True+ = error $ "SymVal.mkCVTup: Impossible happened. Malformed tuple received: " ++ show (i, k)+ where lks = length ks+ lcs = length cs+mkCVTup i k _+ = error $ "SymVal.mkCVTup: Impossible happened. Non-tuple received: " ++ show (i, k)++fromCVTup :: Int -> CV -> [CV]+fromCVTup i inp@(CV (KTuple ks) (CTuple cs))+ | lks == lcs && lks == i+ = zipWith CV ks cs+ | True+ = error $ "SymVal.fromCTup: Impossible happened. Malformed tuple received: " ++ show (i, inp)+ where lks = length ks+ lcs = length cs+fromCVTup i inp = error $ "SymVal.fromCVTup: Impossible happened. Non-tuple received: " ++ show (i, inp)++instance (HasKind a, HasKind b, SymVal a, SymVal b) => SymVal (ArrayModel a b) where+ mkSymVal = genMkSymVar (KArray (kindOf (Proxy @a)) (kindOf (Proxy @b)))++ -- If the table has duplicate entries for keys, then the first one takes precedence.+ -- That is, [(a, v1), (a, v2)] is equivalent to [(a, v1)]. The best way to think about+ -- this is as a "stack" of writes. [(a, v1), (a, v2)] means we first "wrote" v2 at+ -- a, and then wrote v1 at the same address; so the first write of v2 got overwritten.+ literal (ArrayModel tbl def) = SBV . SVal knd . Left . CV knd $ CArray $ ArrayModel [(toCV k, toCV v) | (k, v) <- tbl] (toCV def)+ where knd = kindOf (Proxy @(ArrayModel a b))++ fromCV (CV (KArray k1 k2) (CArray (ArrayModel assocs def))) = ArrayModel [(fromCV (CV k1 a), fromCV (CV k2 b)) | (a, b) <- assocs]+ (fromCV (CV k2 def))++ 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)))++ literal eur = SBV $ SVal k $ Left $ CV k $ CSet $ dir $ Set.map toCV s+ where (dir, s) = case eur of+ RegularSet x -> (RegularSet, x)+ ComplementSet x -> (ComplementSet, x)+ k = kindOf (Proxy @(RCSet a))++ fromCV (CV (KSet a) (CSet (RegularSet s))) = RegularSet $ Set.map (fromCV . CV a) s+ 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 [])+ literal () = mkCVTup 0 (kindOf (Proxy @())) []+ fromCV cv = fromCVTup 0 cv `seq` ()++-- | SymVal for 2-tuples+instance (SymVal a, SymVal b) => SymVal (a, b) where+ mkSymVal = genMkSymVar (kindOf (Proxy @(a, b)))+ literal (v1, v2) = mkCVTup 2 (kindOf (Proxy @(a, b))) [toCV v1, toCV v2]+ fromCV cv = case fromCVTup 2 cv of+ [v1, v2] -> (fromCV v1, fromCV v2)+ res -> error $ "Data.SBV.SymVal-Tuple2: Unexpected result: " ++ show res++ 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 = case fromCVTup 3 cv of+ [v1, v2, v3] -> (fromCV v1, fromCV v2, fromCV v3)+ res -> error $ "Data.SBV.SymVal-Tuple3: Unexpected result: " ++ show res+ minMaxBound = Nothing++-- | SymVal for 4-tuples+instance (SymVal a, SymVal b, SymVal c, SymVal d) => SymVal (a, b, c, d) where+ mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d)))+ literal (v1, v2, v3, v4) = mkCVTup 4 (kindOf (Proxy @(a, b, c, d))) [toCV v1, toCV v2, toCV v3, toCV v4]+ fromCV cv = case fromCVTup 4 cv of+ [v1, v2, v3, v4] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4)+ res -> error $ "Data.SBV.SymVal-Tuple4: Unexpected result: " ++ show res+ minMaxBound = Nothing++-- | SymVal for 5-tuples+instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e) => SymVal (a, b, c, d, e) where+ mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e)))+ 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 = case fromCVTup 5 cv of+ [v1, v2, v3, v4, v5] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5)+ res -> error $ "Data.SBV.SymVal-Tuple5: Unexpected result: " ++ show res+ 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+ mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f)))+ 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 = case fromCVTup 6 cv of+ [v1, v2, v3, v4, v5, v6] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6)+ res -> error $ "Data.SBV.SymVal-Tuple6: Unexpected result: " ++ show res+ 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+ mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f, g)))+ 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 = case fromCVTup 7 cv of+ [v1, v2, v3, v4, v5, v6, v7] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7)+ res -> error $ "Data.SBV.SymVal-Tuple7: Unexpected result: " ++ show res+ 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+ mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f, g, h)))+ 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 = case fromCVTup 8 cv of+ [v1, v2, v3, v4, v5, v6, v7, v8] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7, fromCV v8)+ res -> error $ "Data.SBV.SymVal-Tuple8: Unexpected result: " ++ show res+ minMaxBound = Nothing++instance IsString SString where+ fromString = literal++------------------------------------------------------------------------------------+-- * Smart constructors for creating symbolic values. These are not strictly+-- necessary, as they are mere aliases for 'symbolic' and 'symbolics', but+-- they nonetheless make programming easier.+------------------------------------------------------------------------------------++-- | Generalization of 'Data.SBV.sBool'+sBool :: MonadSymbolic m => String -> m SBool+sBool = symbolic++-- | Generalization of 'Data.SBV.sBool_'+sBool_ :: MonadSymbolic m => m SBool+sBool_ = free_++-- | Generalization of 'Data.SBV.sBools'+sBools :: MonadSymbolic m => [String] -> m [SBool]+sBools = symbolics++-- | Generalization of 'Data.SBV.sWord8'+sWord8 :: MonadSymbolic m => String -> m SWord8+sWord8 = symbolic++-- | Generalization of 'Data.SBV.sWord8_'+sWord8_ :: MonadSymbolic m => m SWord8+sWord8_ = free_++-- | Generalization of 'Data.SBV.sWord8s'+sWord8s :: MonadSymbolic m => [String] -> m [SWord8]+sWord8s = symbolics++-- | Generalization of 'Data.SBV.sWord16'+sWord16 :: MonadSymbolic m => String -> m SWord16+sWord16 = symbolic++-- | Generalization of 'Data.SBV.sWord16_'+sWord16_ :: MonadSymbolic m => m SWord16+sWord16_ = free_++-- | Generalization of 'Data.SBV.sWord16s'+sWord16s :: MonadSymbolic m => [String] -> m [SWord16]+sWord16s = symbolics++-- | Generalization of 'Data.SBV.sWord32'+sWord32 :: MonadSymbolic m => String -> m SWord32+sWord32 = symbolic++-- | Generalization of 'Data.SBV.sWord32_'+sWord32_ :: MonadSymbolic m => m SWord32+sWord32_ = free_++-- | Generalization of 'Data.SBV.sWord32s'+sWord32s :: MonadSymbolic m => [String] -> m [SWord32]+sWord32s = symbolics++-- | Generalization of 'Data.SBV.sWord64'+sWord64 :: MonadSymbolic m => String -> m SWord64+sWord64 = symbolic++-- | Generalization of 'Data.SBV.sWord64_'+sWord64_ :: MonadSymbolic m => m SWord64+sWord64_ = free_++-- | Generalization of 'Data.SBV.sWord64s'+sWord64s :: MonadSymbolic m => [String] -> m [SWord64]+sWord64s = symbolics++-- | Generalization of 'Data.SBV.sInt8'+sInt8 :: MonadSymbolic m => String -> m SInt8+sInt8 = symbolic++-- | Generalization of 'Data.SBV.sInt8_'+sInt8_ :: MonadSymbolic m => m SInt8+sInt8_ = free_++-- | Generalization of 'Data.SBV.sInt8s'+sInt8s :: MonadSymbolic m => [String] -> m [SInt8]+sInt8s = symbolics++-- | Generalization of 'Data.SBV.sInt16'+sInt16 :: MonadSymbolic m => String -> m SInt16+sInt16 = symbolic++-- | Generalization of 'Data.SBV.sInt16_'+sInt16_ :: MonadSymbolic m => m SInt16+sInt16_ = free_++-- | Generalization of 'Data.SBV.sInt16s'+sInt16s :: MonadSymbolic m => [String] -> m [SInt16]+sInt16s = symbolics++-- | Generalization of 'Data.SBV.sInt32'+sInt32 :: MonadSymbolic m => String -> m SInt32+sInt32 = symbolic++-- | Generalization of 'Data.SBV.sInt32_'+sInt32_ :: MonadSymbolic m => m SInt32+sInt32_ = free_++-- | Generalization of 'Data.SBV.sInt32s'+sInt32s :: MonadSymbolic m => [String] -> m [SInt32]+sInt32s = symbolics++-- | Generalization of 'Data.SBV.sInt64'+sInt64 :: MonadSymbolic m => String -> m SInt64+sInt64 = symbolic++-- | Generalization of 'Data.SBV.sInt64_'+sInt64_ :: MonadSymbolic m => m SInt64+sInt64_ = free_++-- | Generalization of 'Data.SBV.sInt64s'+sInt64s :: MonadSymbolic m => [String] -> m [SInt64]+sInt64s = symbolics++-- | Generalization of 'Data.SBV.sInteger'+sInteger:: MonadSymbolic m => String -> m SInteger+sInteger = symbolic++-- | Generalization of 'Data.SBV.sInteger_'+sInteger_:: MonadSymbolic m => m SInteger+sInteger_ = free_++-- | Generalization of 'Data.SBV.sIntegers'+sIntegers :: MonadSymbolic m => [String] -> m [SInteger]+sIntegers = symbolics++-- | Generalization of 'Data.SBV.sReal'+sReal:: MonadSymbolic m => String -> m SReal+sReal = symbolic++-- | Generalization of 'Data.SBV.sReal_'+sReal_:: MonadSymbolic m => m SReal+sReal_ = free_++-- | Generalization of 'Data.SBV.sReals'+sReals :: MonadSymbolic m => [String] -> m [SReal]+sReals = symbolics++-- | Generalization of 'Data.SBV.sFloat'+sFloat :: MonadSymbolic m => String -> m SFloat+sFloat = symbolic++-- | Generalization of 'Data.SBV.sFloat_'+sFloat_ :: MonadSymbolic m => m SFloat+sFloat_ = free_++-- | Generalization of 'Data.SBV.sFloats'+sFloats :: MonadSymbolic m => [String] -> m [SFloat]+sFloats = symbolics++-- | Generalization of 'Data.SBV.sDouble'+sDouble :: MonadSymbolic m => String -> m SDouble+sDouble = symbolic++-- | Generalization of 'Data.SBV.sDouble_'+sDouble_ :: MonadSymbolic m => m SDouble+sDouble_ = free_++-- | Generalization of 'Data.SBV.sDoubles'+sDoubles :: MonadSymbolic m => [String] -> m [SDouble]+sDoubles = symbolics++-- | Generalization of 'Data.SBV.sFPHalf'+sFPHalf :: String -> Symbolic SFPHalf+sFPHalf = symbolic++-- | Generalization of 'Data.SBV.sFPHalf_'+sFPHalf_ :: Symbolic SFPHalf+sFPHalf_ = free_++-- | Generalization of 'Data.SBV.sFPHalfs'+sFPHalfs :: [String] -> Symbolic [SFPHalf]+sFPHalfs = symbolics++-- | Generalization of 'Data.SBV.sFPBFloat'+sFPBFloat :: String -> Symbolic SFPBFloat+sFPBFloat = symbolic++-- | Generalization of 'Data.SBV.sFPBFloat_'+sFPBFloat_ :: Symbolic SFPBFloat+sFPBFloat_ = free_++-- | Generalization of 'Data.SBV.sFPBFloats'+sFPBFloats :: [String] -> Symbolic [SFPBFloat]+sFPBFloats = symbolics++-- | Generalization of 'Data.SBV.sFPSingle'+sFPSingle :: String -> Symbolic SFPSingle+sFPSingle = symbolic++-- | Generalization of 'Data.SBV.sFPSingle_'+sFPSingle_ :: Symbolic SFPSingle+sFPSingle_ = free_++-- | Generalization of 'Data.SBV.sFPSingles'+sFPSingles :: [String] -> Symbolic [SFPSingle]+sFPSingles = symbolics++-- | Generalization of 'Data.SBV.sFPDouble'+sFPDouble :: String -> Symbolic SFPDouble+sFPDouble = symbolic++-- | Generalization of 'Data.SBV.sFPDouble_'+sFPDouble_ :: Symbolic SFPDouble+sFPDouble_ = free_++-- | Generalization of 'Data.SBV.sFPDoubles'+sFPDoubles :: [String] -> Symbolic [SFPDouble]+sFPDoubles = symbolics++-- | Generalization of 'Data.SBV.sFPQuad'+sFPQuad :: String -> Symbolic SFPQuad+sFPQuad = symbolic++-- | Generalization of 'Data.SBV.sFPQuad_'+sFPQuad_ :: Symbolic SFPQuad+sFPQuad_ = free_++-- | Generalization of 'Data.SBV.sFPQuads'+sFPQuads :: [String] -> Symbolic [SFPQuad]+sFPQuads = symbolics++-- | Generalization of 'Data.SBV.sFloatingPoint'+sFloatingPoint :: ValidFloat eb sb => String -> Symbolic (SFloatingPoint eb sb)+sFloatingPoint = symbolic++-- | Generalization of 'Data.SBV.sFloatingPoint_'+sFloatingPoint_ :: ValidFloat eb sb => Symbolic (SFloatingPoint eb sb)+sFloatingPoint_ = free_++-- | Generalization of 'Data.SBV.sFloatingPoints'+sFloatingPoints :: ValidFloat eb sb => [String] -> Symbolic [SFloatingPoint eb sb]+sFloatingPoints = symbolics++-- | Generalization of 'Data.SBV.sWord'+sWord :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => String -> m (SWord n)+sWord = symbolic++-- | Generalization of 'Data.SBV.sWord_'+sWord_ :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => m (SWord n)+sWord_ = free_++-- | Generalization of 'Data.SBV.sWord64s'+sWords :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => [String] -> m [SWord n]+sWords = symbolics++-- | Generalization of 'Data.SBV.sInt'+sInt :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => String -> m (SInt n)+sInt = symbolic++-- | Generalization of 'Data.SBV.sInt_'+sInt_ :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => m (SInt n)+sInt_ = free_++-- | Generalization of 'Data.SBV.sInts'+sInts :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => [String] -> m [SInt n]+sInts = symbolics++-- | Generalization of 'Data.SBV.sChar'+sChar :: MonadSymbolic m => String -> m SChar+sChar = symbolic++-- | Generalization of 'Data.SBV.sChar_'+sChar_ :: MonadSymbolic m => m SChar+sChar_ = free_++-- | Generalization of 'Data.SBV.sChars'+sChars :: MonadSymbolic m => [String] -> m [SChar]+sChars = symbolics++-- | Generalization of 'Data.SBV.sString'+sString :: MonadSymbolic m => String -> m SString+sString = symbolic++-- | Generalization of 'Data.SBV.sString_'+sString_ :: MonadSymbolic m => m SString+sString_ = free_++-- | Generalization of 'Data.SBV.sStrings'+sStrings :: MonadSymbolic m => [String] -> m [SString]+sStrings = symbolics++-- | Generalization of 'Data.SBV.sList'+sList :: (SymVal a, MonadSymbolic m) => String -> m (SList a)+sList = symbolic++-- | Generalization of 'Data.SBV.sList_'+sList_ :: (SymVal a, MonadSymbolic m) => m (SList a)+sList_ = free_++-- | Generalization of 'Data.SBV.sLists'+sLists :: (SymVal a, MonadSymbolic m) => [String] -> m [SList a]+sLists = symbolics++-- | Generalization of 'Data.SBV.sAray'+sArray :: (SymVal a, SymVal b, MonadSymbolic m) => String -> m (SArray a b)+sArray = symbolic++-- | Generalization of 'Data.SBV.sList_'+sArray_ :: (SymVal a, SymVal b, MonadSymbolic m) => m (SArray a b)+sArray_ = free_++-- | Generalization of 'Data.SBV.sLists'+sArrays :: (SymVal a, SymVal b, MonadSymbolic m) => [String] -> m [SArray a b]+sArrays = symbolics++-- | Identify tuple like things. Note that there are no methods, just instances to control type inference+class SymTuple a+instance SymTuple ()+instance SymTuple (a, b)+instance SymTuple (a, b, c)+instance SymTuple (a, b, c, d)+instance SymTuple (a, b, c, d, e)+instance SymTuple (a, b, c, d, e, f)+instance SymTuple (a, b, c, d, e, f, g)+instance SymTuple (a, b, c, d, e, f, g, h)++-- | Generalization of 'Data.SBV.sTuple'+sTuple :: (SymTuple tup, SymVal tup, MonadSymbolic m) => String -> m (SBV tup)+sTuple = symbolic++-- | Generalization of 'Data.SBV.sTuple_'+sTuple_ :: (SymTuple tup, SymVal tup, MonadSymbolic m) => m (SBV tup)+sTuple_ = free_++-- | Generalization of 'Data.SBV.sTuples'+sTuples :: (SymTuple tup, SymVal tup, MonadSymbolic m) => [String] -> m [SBV tup]+sTuples = symbolics++-- | Generalization of 'Data.SBV.sRational'+sRational :: MonadSymbolic m => String -> m SRational+sRational = symbolic++-- | Generalization of 'Data.SBV.sRational_'+sRational_ :: MonadSymbolic m => m SRational+sRational_ = free_++-- | Generalization of 'Data.SBV.sRationals'+sRationals :: MonadSymbolic m => [String] -> m [SRational]+sRationals = symbolics++-- | Generalization of 'Data.SBV.sSet'+sSet :: (Ord a, SymVal a, MonadSymbolic m) => String -> m (SSet a)+sSet = symbolic++-- | Generalization of 'Data.SBV.sMaybe_'+sSet_ :: (Ord a, SymVal a, MonadSymbolic m) => m (SSet a)+sSet_ = free_++-- | Generalization of 'Data.SBV.sMaybes'+sSets :: (Ord a, SymVal a, MonadSymbolic m) => [String] -> m [SSet a]+sSets = symbolics++-- | Generalization of 'Data.SBV.solve'+solve :: MonadSymbolic m => [SBool] -> m SBool+solve = pure . sAnd++-- | Convert an SReal to an SInteger, @floor@ version. That is, it computes the+-- largest integer @n@ that satisfies @sIntegerToSReal n <= r@.+--+-- For instance, @1.3@ will be @1@, but @-1.3@ will be @-2@.+--+-- See 'sRealToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRealToSIntegerFloor :: SReal -> SInteger+sRealToSIntegerFloor x+ | Just i <- unliteral x, isExactRational i+ = literal $ floor $ toRational i+ | True+ = SBV (SVal KUnbounded (Right (cache y)))+ where y st = do xsv <- sbvToSV st x+ newExpr st KUnbounded (SBVApp (KindCast KReal KUnbounded) [xsv])++-- | Convert an SReal to an SInteger, @ceiling@ version. That is, it computes+-- the smallest integer @n@ that satisfies @r <= sIntegerToSReal n@.+--+-- For instance, @1.3@ will be @2@, but @-1.3@ will be @-1@.+--+-- See 'sRealToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRealToSIntegerCeiling :: SReal -> SInteger+sRealToSIntegerCeiling x+ | Just i <- unliteral x, isExactRational i+ = literal $ ceiling $ toRational i+ | True+ = - sRealToSIntegerFloor (-x)++-- | Convert an SReal to an SInteger, truncating version. Truncate simply chops off the+-- fractional part, essentially rounding towards zero.+--+-- For instance, @1.3@ will be @1@, and @-1.3@ will be @-1@.+--+-- See 'sRealToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRealToSIntegerTruncate :: SReal -> SInteger+sRealToSIntegerTruncate x+ | Just i <- unliteral x, isExactRational i+ = literal $ truncate $ toRational i+ | True+ = ite (x .>= 0) (sRealToSIntegerFloor x) (sRealToSIntegerCeiling x)++-- | Convert an SReal to an SInteger by converting to the nearest integer. If+-- there is a tie (i.e., if the fractional component of the SReal is equal to+-- 0.5), then round away from zero.+--+-- For instance:+--+-- * @1.3@ will be @1@+-- * @1.5@ will be @2@ (because @abs 1 < abs 2@)+-- * @1.7@ will be @2@+-- * @2.3@ will be @2@+-- * @2.5@ will be @3@ (because @abs 2 < abs 3@)+-- * @2.7@ will be @3@+-- * @-1.3@ will be @-1@+-- * @-1.5@ will be @-2@ (because @abs (-1) < abs (-2)@)+-- * @-1.7@ will be @-2@+-- * @-2.3@ will be @-2@+-- * @-2.5@ will be @-3@ (because @abs (-2) < abs (-3)@)+-- * @-2.7@ will be @-3@+--+-- See 'sRealToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRealToSIntegerRoundAway :: SReal -> SInteger+sRealToSIntegerRoundAway x+ | Just i <- unliteral x, isExactRational i+ = literal $ roundAway (toRational i)+ | True+ = ite+ (x .>= 0)+ (sRealToSIntegerFloor (x + half))+ (sRealToSIntegerCeiling (x - half))+ where+ half :: SReal+ half = 0.5++-- | Convert an SReal to an SInteger by converting to the nearest integer. If+-- there is a tie (i.e., if the fractional component of the SReal is equal to+-- 0.5), then round to the nearest even integer.+--+-- For instance:+--+-- * @1.3@ will be @1@+-- * @1.5@ will be @2@ (because @2@ is even)+-- * @1.7@ will be @2@+-- * @2.3@ will be @2@+-- * @2.5@ will be @2@ (because @2@ is even)+-- * @2.7@ will be @3@+-- * @-1.3@ will be @-1@+-- * @-1.5@ will be @-2@ (because @-2@ is even)+-- * @-1.7@ will be @-2@+-- * @-2.3@ will be @-2@+-- * @-2.5@ will be @-2@ (because @-2@ is even)+-- * @-2.7@ will be @-3@+--+-- See 'sRealToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRealToSIntegerRoundToEven :: SReal -> SInteger+sRealToSIntegerRoundToEven x+ | Just i <- unliteral x, isExactRational i+ = literal $ round $ toRational i+ | True+ = ite (diff .< half) lo $+ ite (diff .> half) hi $+ ite (sDivides 2 lo) lo hi+ where+ half :: SReal+ half = 0.5++ lo, hi :: SInteger+ lo = sRealToSIntegerFloor x+ hi = lo+1++ diff :: SReal+ diff = x - sFromIntegral lo++-- | Convert an 'SReal' to an 'SInteger' according to the supplied+-- 'SRoundingMode'. This dispatches to 'sRealToSIntegerRoundToEven',+-- 'sRealToSIntegerRoundAway', 'sRealToSIntegerCeiling', 'sRealToSIntegerFloor',+-- and 'sRealToSIntegerTruncate' for the round-nearest-even, round-nearest-away,+-- round-toward-positive, round-toward-negative, and round-toward-zero modes+-- respectively.+--+-- Note that we re-use the 'SRoundingMode' type here, even though+-- 'SRoundingMode' is normally associated with floating-point operations. The+-- floating-point resemblance is superficial, as this function does not use any+-- floating-point functionality behind the scenes.+sRealToSIntegerRM :: SRoundingMode -> SReal -> SInteger+sRealToSIntegerRM rm x =+ sCaseRoundingMode+ (sRealToSIntegerRoundToEven x)+ (sRealToSIntegerRoundAway x)+ (sRealToSIntegerCeiling x)+ (sRealToSIntegerFloor x)+ (sRealToSIntegerTruncate x)+ rm++-- | 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.+label :: SymVal a => String -> SBV a -> SBV a+label m x+ | Just _ <- unliteral x = x+ | True = SBV $ SVal k $ Right $ cache r+ where k = kindOf x+ r st = do xsv <- sbvToSV st x+ newExpr st k (SBVApp (Label m) [xsv])+++-- | Observe the value of an expression, if the given condition holds. Such values are useful in model construction, as they are printed part of a satisfying model, or a+-- counter-example. The same works for quick-check as well. Useful when we want to see intermediate values, or expected/obtained+-- pairs in a particular run. Note that an observed expression is always symbolic, i.e., it won't be constant folded. Compare this to 'label'+-- which is used for putting a label in the generated SMTLib-C code.+--+-- NB. If the observed expression happens under a SBV-lambda expression, then it is silently ignored; since+-- there's no way to access the value of such a value.+observeIf :: SymVal a => (a -> Bool) -> String -> SBV a -> SBV a+observeIf cond m x+ | Just bad <- checkObservableName m+ = error bad+ | True+ = SBV $ SVal k $ Right $ cache r+ where k = kindOf x+ r st = do xsv <- sbvToSV st (label ("Observing: " ++ m) x)+ recordObservable st (T.pack m) (cond . fromCV) xsv+ pure xsv++-- | Observe the value of an expression, unconditionally. See 'observeIf' for a generalized version.+observe :: SymVal a => String -> SBV a -> SBV a+observe = observeIf (const True)++-- | Symbolic Comparisons. Similar to 'Eq', we cannot implement Haskell's 'Ord' class+-- since there is no way to return an 'Ordering' value from a symbolic comparison.+-- Furthermore, 'OrdSymbolic' requires 'Mergeable' to implement if-then-else, for the+-- benefit of implementing symbolic versions of 'max' and 'min' functions.+infix 4 .<, .<=, .>, .>=+class (Mergeable a, EqSymbolic a) => OrdSymbolic a where+ -- | Symbolic less than.+ (.<) :: a -> a -> SBool+ -- | Symbolic less than or equal to.+ (.<=) :: a -> a -> SBool+ -- | Symbolic greater than.+ (.>) :: a -> a -> SBool+ -- | Symbolic greater than or equal to.+ (.>=) :: a -> a -> SBool+ -- | Symbolic minimum.+ smin :: a -> a -> a+ -- | Symbolic maximum.+ smax :: a -> a -> a+ -- | Is the value within the allowed /inclusive/ range?+ inRange :: a -> (a, a) -> SBool++ {-# MINIMAL (.<) #-}++ a .<= b = a .< b .|| a .== b+ a .> b = b .< a+ a .>= b = b .<= a++ a `smin` b = ite (a .<= b) a b+ a `smax` b = ite (a .<= b) b a++ inRange x (y, z) = x .>= y .&& x .<= z+++{- We can't have a generic instance of the form:++instance Eq a => EqSymbolic a where+ x .== y = if x == y then true else sFalse++even if we're willing to allow Flexible/undecidable instances..+This is because if we allow this it would imply EqSymbolic (SBV a);+since (SBV a) has to be Eq as it must be a Num. But this wouldn't be+the right choice obviously; as the Eq instance is bogus for SBV+for natural reasons..+-}++-- It is tempting to put in an @Eq a@ superclass here. But doing so+-- is complicated, as it requires all underlying types to have equality,+-- which is at best shaky for algebraic reals and sets. So, leave it out.+instance (HasKind a, SymVal a) => EqSymbolic (SBV a) where+ SBV x .== SBV y = SBV (svEqual x y)+ SBV x ./= SBV y = SBV (svNotEqual x y)++ SBV x .=== SBV y = SBV (svStrongEqual x y)++ -- Custom version of distinct that generates better code for base types+ distinct [] = sTrue+ distinct [_] = sTrue+ distinct xs | all isConc xs = checkDiff xs+ | [SBV a, SBV b] <- xs, a `is` svBool True = SBV $ svNot b+ | [SBV a, SBV b] <- xs, b `is` svBool True = SBV $ svNot a+ | [SBV a, SBV b] <- xs, a `is` svBool False = SBV b+ | [SBV a, SBV b] <- xs, b `is` svBool False = SBV a+ -- 3 booleans can't be distinct!+ | (x : _ : _ : _) <- xs, isBool x = sFalse+ | True = SBV (SVal KBool (Right (cache r)))+ where r st = do xsv <- mapM (sbvToSV st) xs+ newExpr st KBool (SBVApp NotEqual xsv)++ -- We call this in case all are concrete, which will+ -- reduce to a constant and generate no code at all!+ -- Note that this is essentially the same as the default+ -- definition, which unfortunately we can no longer call!+ checkDiff [] = sTrue+ checkDiff (a:as) = sAll (a ./=) as .&& checkDiff as++ -- Sigh, we can't use isConcrete since that requires SymVal+ -- constraint that we don't have here. (To support SBools.)+ isConc (SBV (SVal _ (Left _))) = True+ isConc _ = False++ -- Likewise here; need to go lower.+ SVal k1 (Left c1) `is` SVal k2 (Left c2) = (k1, c1) == (k2, c2)+ _ `is` _ = False++ isBool (SBV (SVal KBool _)) = True+ isBool _ = False++ -- Custom version of distinctExcept that generates better code for base types+ distinctExcept [] _ = sTrue+ distinctExcept [_] _ = sTrue+ distinctExcept es ignored+ | all isConc (es ++ ignored)+ = distinct (filter ignoreConc es)+ | True+ = SBV (SVal KBool (Right (cache r)))+ where ignoreConc x = case x `sElem` ignored of+ SBV (SVal KBool (Left cv)) -> cvToBool cv+ _ -> error $ "distinctExcept: Impossible happened, concrete sElem failed: " ++ show (es, ignored, x)++ r st = do let incr x table = ite (x `sElem` ignored) (0 :: SInteger) (1 + readArrayNoEq table x)++ initArray :: SArray a Integer+ initArray = constArray 0++ finalArray = foldl' (\table x -> writeArrayNoKnd table x (incr x table)) initArray es++ sbvToSV st $ sAll (\e -> readArrayNoEq finalArray e .<= (1 :: SInteger)) es++ -- Sigh, we can't use isConcrete since that requires SymVal+ -- constraint that we don't have here. (To support SBools.)+ isConc (SBV (SVal _ (Left _))) = True+ isConc _ = False++ -- Version of readArray that doesn't have the Eq constraint, since we don't have it here+ readArrayNoEq array key = SBV . SVal KUnbounded . Right $ cache g+ where g st = do f <- sbvToSV st array+ k <- sbvToSV st key+ newExpr st KUnbounded (SBVApp ReadArray [f, k])++ writeArrayNoKnd :: forall key. HasKind key => SArray key Integer -> SBV key -> SInteger -> SArray key Integer+ writeArrayNoKnd array key value = SBV . SVal k . Right $ cache g+ where k = KArray (kindOf (Proxy @key)) KUnbounded++ g st = do arr <- sbvToSV st array+ keyVal <- sbvToSV st key+ val <- sbvToSV st value+ newExpr st k (SBVApp WriteArray [arr, keyVal, val])++-- We don't want to do a generic OrdSymbolic (SBV a) instance; since that would be dangerous, like the case+-- for Num. So, we explicitly define for each type we care about.++#define MKSORD(CSTR, TYPE) \+instance CSTR => OrdSymbolic TYPE where { \+ a@(SBV x) .< b@(SBV y) | smtComparable "<" a b = SBV (svLessThan x y) \+ | True = SBV (svStructuralLessThan x y); \+ \+ a@(SBV x) .<= b@(SBV y) | smtComparable ".<=" a b = SBV (svLessEq x y) \+ | True = a .< b .|| a .== b; \+ \+ a@(SBV x) .> b@(SBV y) | smtComparable ">" a b = SBV (svGreaterThan x y) \+ | True = b .< a; \+ \+ a@(SBV x) .>= b@(SBV y) | smtComparable ">=" a b = SBV (svGreaterEq x y) \+ | True = b .<= a; \+} \++-- Derive basic instances we need. NB. We don't give the SRational instance here. It's handled+-- in Data/SBV/Rational due to representation issues.+MKSORD((), SInteger)+MKSORD((), SWord8)+MKSORD((), SWord16)+MKSORD((), SWord32)+MKSORD((), SWord64)+MKSORD((), SInt8)+MKSORD((), SInt16)+MKSORD((), SInt32)+MKSORD((), SInt64)+MKSORD((), SFloat)+MKSORD((), SChar)+MKSORD((SymVal a), (SList a))+MKSORD((), SDouble)+MKSORD((), SReal)+MKSORD((KnownNat n, BVIsNonZero n), (SWord n))+MKSORD((KnownNat n, BVIsNonZero n), (SInt n))+MKSORD((ValidFloat eb sb), (SFloatingPoint eb sb))++-- Tuples+MKSORD((SymVal a, SymVal b), (SBV (a, b)))+MKSORD((SymVal a, SymVal b, SymVal c), (SBV (a, b, c)))+MKSORD((SymVal a, SymVal b, SymVal c, SymVal d), (SBV (a, b, c, d)))+MKSORD((SymVal a, SymVal b, SymVal c, SymVal d, SymVal e), (SBV (a, b, c, d, e)))+MKSORD((SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f), (SBV (a, b, c, d, e, f)))+MKSORD((SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g), (SBV (a, b, c, d, e, f, g)))+MKSORD((SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h), (SBV (a, b, c, d, e, f, g, h)))+#undef MKSORD++-- Is this a type that's comparable by underlying translation to SMTLib?+-- Note that we allow concrete versions to go through unless the type is a set, as there's really no reason not to.+smtComparable :: (SymVal a, HasKind a) => String -> SBV a -> SBV a -> Bool+smtComparable op x y+ | isConcrete x && isConcrete y && not (isSet k)+ = True+ | True+ = case k of+ KVar {} -> False+ KBool -> True+ KBounded {} -> True+ KUnbounded {} -> True+ KReal {} -> True+ KApp {} -> True+ KADT {} -> True+ KFloat -> True+ KDouble -> True+ KRational {} -> True+ KFP {} -> True+ KChar -> True+ KString -> True+ KList {} -> nope -- Unfortunately, no way for us to desugar this+ KSet {} -> nope -- Ditto here..+ KTuple {} -> False+ KArray {} -> True+ where k = kindOf x+ nope = error $ "Data.SBV.OrdSymbolic: SMTLib does not support " ++ op ++ " for " ++ show k++-- Bool+instance EqSymbolic Bool where+ x .== y = fromBool $ x == y++-- Lists+instance EqSymbolic a => EqSymbolic [a] where+ [] .== [] = sTrue+ (x:xs) .== (y:ys) = x .== y .&& xs .== ys+ _ .== _ = sFalse++ [] .=== [] = sTrue+ (x:xs) .=== (y:ys) = x .=== y .&& xs .=== ys+ _ .=== _ = sFalse++instance OrdSymbolic a => OrdSymbolic [a] where+ [] .< [] = sFalse+ [] .< _ = sTrue+ _ .< [] = sFalse+ (x:xs) .< (y:ys) = x .< y .|| (x .== y .&& xs .< ys)++-- NonEmpty+instance EqSymbolic a => EqSymbolic (NonEmpty a) where+ (x :| xs) .== (y :| ys) = x : xs .== y : ys+ (x :| xs) .=== (y :| ys) = x : xs .=== y : ys++instance OrdSymbolic a => OrdSymbolic (NonEmpty a) where+ (x :| xs) .< (y :| ys) = x : xs .< y : ys++-- Maybe+instance EqSymbolic a => EqSymbolic (Maybe a) where+ Nothing .== Nothing = sTrue+ Just a .== Just b = a .== b+ _ .== _ = sFalse++instance OrdSymbolic a => OrdSymbolic (Maybe a) where+ Nothing .< Nothing = sFalse+ Nothing .< _ = sTrue+ Just _ .< Nothing = sFalse+ Just a .< Just b = a .< b++-- Either+instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (Either a b) where+ Left a .== Left b = a .== b+ Right a .== Right b = a .== b+ _ .== _ = sFalse++ Left a .=== Left b = a .=== b+ Right a .=== Right b = a .=== b+ _ .=== _ = sFalse++instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (Either a b) where+ Left a .< Left b = a .< b+ Left _ .< Right _ = sTrue+ Right _ .< Left _ = sFalse+ Right a .< Right b = a .< b++-- 2-Tuple+instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (a, b) where+ (a0, b0) .== (a1, b1) = a0 .== a1 .&& b0 .== b1+ (a0, b0) .=== (a1, b1) = a0 .=== a1 .&& b0 .=== b1++instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (a, b) where+ (a0, b0) .< (a1, b1) = a0 .< a1 .|| (a0 .== a1 .&& b0 .< b1)++-- 3-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c) => EqSymbolic (a, b, c) where+ (a0, b0, c0) .== (a1, b1, c1) = (a0, b0) .== (a1, b1) .&& c0 .== c1+ (a0, b0, c0) .=== (a1, b1, c1) = (a0, b0) .=== (a1, b1) .&& c0 .=== c1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c) => OrdSymbolic (a, b, c) where+ (a0, b0, c0) .< (a1, b1, c1) = (a0, b0) .< (a1, b1) .|| ((a0, b0) .== (a1, b1) .&& c0 .< c1)++-- 4-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d) => EqSymbolic (a, b, c, d) where+ (a0, b0, c0, d0) .== (a1, b1, c1, d1) = (a0, b0, c0) .== (a1, b1, c1) .&& d0 .== d1+ (a0, b0, c0, d0) .=== (a1, b1, c1, d1) = (a0, b0, c0) .=== (a1, b1, c1) .&& d0 .=== d1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d) => OrdSymbolic (a, b, c, d) where+ (a0, b0, c0, d0) .< (a1, b1, c1, d1) = (a0, b0, c0) .< (a1, b1, c1) .|| ((a0, b0, c0) .== (a1, b1, c1) .&& d0 .< d1)++-- 5-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e) => EqSymbolic (a, b, c, d, e) where+ (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .== (a1, b1, c1, d1) .&& e0 .== e1+ (a0, b0, c0, d0, e0) .=== (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .=== (a1, b1, c1, d1) .&& e0 .=== e1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e) => OrdSymbolic (a, b, c, d, e) where+ (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .< (a1, b1, c1, d1) .|| ((a0, b0, c0, d0) .== (a1, b1, c1, d1) .&& e0 .< e1)++-- 6-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f) => EqSymbolic (a, b, c, d, e, f) where+ (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) .&& f0 .== f1+ (a0, b0, c0, d0, e0, f0) .=== (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .=== (a1, b1, c1, d1, e1) .&& f0 .=== f1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f) => OrdSymbolic (a, b, c, d, e, f) where+ (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1)+ .|| ((a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) .&& f0 .< f1)++-- 7-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f, EqSymbolic g) => EqSymbolic (a, b, c, d, e, f, g) where+ (a0, b0, c0, d0, e0, f0, g0) .== (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) .&& g0 .== g1+ (a0, b0, c0, d0, e0, f0, g0) .=== (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .=== (a1, b1, c1, d1, e1, f1) .&& g0 .=== g1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f, OrdSymbolic g) => OrdSymbolic (a, b, c, d, e, f, g) where+ (a0, b0, c0, d0, e0, f0, g0) .< (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1)+ .|| ((a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) .&& g0 .< g1)++-- | A class of values that capture the notion of a zero for measure values.+-- Used in termination checking for recursive SMT functions.+class OrdSymbolic (SBV a) => Zero a where+ zero :: SBV a+ -- | Component-wise non-negativity check. For scalars this is simply @>= 0@.+ -- For tuples, every component must be @>= 0@, which is stronger than+ -- lexicographic @>= (0, 0, ..)@. This is required for well-foundedness+ -- of the lexicographic ordering on the non-negative part.+ nonNeg :: SBV a -> SBool+ nonNeg x = x .>= zero++-- | An integer as a measure+instance Zero Integer where+ zero = literal 0++-- | Bounded bit-vectors as measures. These are all sound: each is a finite type, so a+-- non-negative, strictly-decreasing chain of values is necessarily finite. (The default+-- @nonNeg x = x .>= 0@ works for both the unsigned and signed cases.)+instance Zero Word8 where zero = literal 0+instance Zero Word16 where zero = literal 0+instance Zero Word32 where zero = literal 0+instance Zero Word64 where zero = literal 0+instance Zero Int8 where zero = literal 0+instance Zero Int16 where zero = literal 0+instance Zero Int32 where zero = literal 0+instance Zero Int64 where zero = literal 0+instance (KnownNat n, BVIsNonZero n) => Zero (WordN n) where zero = literal 0+instance (KnownNat n, BVIsNonZero n) => Zero (IntN n) where zero = literal 0++-- NB. We would like to use 'Data.SBV.Tuple.untuple' in the 'nonNeg' definitions below,+-- but 'Data.SBV.Tuple' imports 'Data.SBV.Core.Model', creating a circular dependency.+-- So we extract components at the SVal level using 'TupleAccess' directly.++-- | A tuple of integers as a measure+instance Zero (Integer, Integer) where+ zero = literal (0, 0)+ nonNeg = tupleNonNeg 2++-- | A triple of integers as a measure+instance Zero (Integer, Integer, Integer) where+ zero = literal (0, 0, 0)+ nonNeg = tupleNonNeg 3++-- | A quadruple of integers as a measure+instance Zero (Integer, Integer, Integer, Integer) where+ zero = literal (0, 0, 0, 0)+ nonNeg = tupleNonNeg 4++-- | A quintuple of integers as a measure+instance Zero (Integer, Integer, Integer, Integer, Integer) where+ zero = literal (0, 0, 0, 0, 0)+ nonNeg = tupleNonNeg 5++-- | A float as a measure+instance Zero Float where+ zero = literal 0++-- | A double as a measure+instance Zero Double where+ zero = literal 0++-- | Algebraic reals are /not/ permitted as measures, and we reject them at compile time.+-- The reals are dense, hence not well-ordered: a merely non-negative and strictly-decreasing+-- real measure does not imply termination (e.g. the chain @1, 1\/2, 1\/4, ...@ descends forever+-- without reaching a minimum). Use an integer-valued measure instead.+instance TypeError ( 'Text "A termination measure may not have a real-valued result."+ ':$$: 'Text ""+ ':$$: 'Text "The reals are not well-ordered: an infinite descending chain such as"+ ':$$: 'Text "1, 1/2, 1/4, ... has no least element, so a non-negative and strictly"+ ':$$: 'Text "decreasing real measure does not imply termination."+ ':$$: 'Text ""+ ':$$: 'Text "Use an integer-valued measure instead (e.g. a count of remaining steps)."+ ) => Zero AlgReal where+ zero = error "Data.SBV.Zero(AlgReal): unreachable"++-- | A floating-point as a measure+instance ValidFloat eb sb => Zero (FloatingPoint eb sb) where+ zero = literal 0++-- | Component-wise non-negativity for an n-tuple of integers.+-- Extracts each component via 'TupleAccess' and checks @>= 0@.+tupleNonNeg :: SymVal a => Int -> SBV a -> SBool+tupleNonNeg n t = sAll (.>= (0 :: SInteger)) [acc i | i <- [1..n]]+ where acc i = SBV $ SVal KUnbounded $ Right $ cache $ \st -> do+ sv <- sbvToSV st t+ newExpr st KUnbounded (SBVApp (TupleAccess i n) [sv])++-- | Type family that maps a function type to its corresponding measure type.+-- The measure function takes the same arguments but returns a different type.+type family MeasureOf f r where+ MeasureOf (SBV a -> r) r' = SBV a -> MeasureOf r r'+ MeasureOf (SBV a) r = SBV r++-- | Apply a measure function to a list of SVal arguments, producing the measure value.+-- This is used internally during measure verification.+class ApplyMeasure a r where+ applyMeasure :: MeasureOf a r -> [SVal] -> SBV r++instance ApplyMeasure (SBV a) r where+ applyMeasure m [] = m+ applyMeasure _ _ = error "Data.SBV.applyMeasure: too many arguments"++instance ApplyMeasure b r => ApplyMeasure (SBV a -> b) r where+ applyMeasure _ [] = error "Data.SBV.applyMeasure: not enough arguments"+ applyMeasure m (sv:svs) = applyMeasure @b @r (m (SBV sv)) svs++-- | Type family that maps a function type to its corresponding contract type.+-- A contract takes the same arguments as the function, plus the result, and returns 'SBool'.+-- For example, a contract for @SBV Integer -> SBV Integer@ has type @SBV Integer -> SBV Integer -> SBool@+-- (first arg is the input, second is the output).+type family ContractOf f where+ ContractOf (SBV a) = SBV a -> SBool+ ContractOf (SBV a -> r) = SBV a -> ContractOf r++-- | Apply a contract function to a list of input t'SVal' arguments and a result t'SVal'.+class ApplyContract a where+ applyContract :: ContractOf a -> [SVal] -> SVal -> SBool++instance ApplyContract (SBV a) where+ applyContract c [] sv = c (SBV sv)+ applyContract _ _ _ = error "Data.SBV.applyContract: too many arguments"++instance ApplyContract b => ApplyContract (SBV a -> b) where+ applyContract _ [] _ = error "Data.SBV.applyContract: not enough arguments"+ applyContract c (sv:svs) r = applyContract @b (c (SBV sv)) svs r++-- | An evaluated measure: captures the ability to apply the measure function+-- to a list of arguments, along with the ordering and zero constraints.+data MeasureEval where+ MeasureEval :: (Zero r, OrdSymbolic (SBV r), SymVal r) => ([SVal] -> SBV r) -> MeasureEval++-- | An evaluated contract: captures the ability to apply a contract predicate+-- to a list of input arguments and a result value. Used during measure verification+-- for nested recursive functions, where the inductive hypothesis provides the contract+-- on recursive call results.+data ContractEval where+ ContractEval :: ([SVal] -> SVal -> SBool) -> ContractEval++-- | A measure for a function, used to prove termination of recursive definitions.+--+-- * 'AutoMeasure': The function either doesn't need a measure (because it's not recursive),+-- or SBV will automatically guess one based on argument types.+-- * 'HasMeasure': The user provided an explicit measure function.+-- * 'HasContract': The user provided a measure and a contract. The contract is a predicate+-- on the function's inputs and output that is proven simultaneously with the measure decrease+-- via well-founded induction. This handles nested recursion (e.g., McCarthy 91) where the+-- termination argument depends on the function's return value at smaller inputs.+-- * 'Productive': The function is corecursive (productive). Instead of proving termination via a+-- measure, SBV checks that every recursive call is guarded by a data constructor (list cons,+-- ADT constructor, etc.), ensuring the function always produces output incrementally.+-- * 'Unverified': No termination or productivity check is performed. The function is emitted as+-- @define-fun-rec@ and the user takes responsibility for well-definedness. Use this for functions+-- where termination is believed but cannot be proven (e.g., Collatz).+data Measure f where+ AutoMeasure :: Measure f+ HasMeasure :: MeasureEval -> [MeasureHelper] -> Measure f+ HasContract :: MeasureEval -> ContractEval -> [MeasureHelper] -> Measure f+ Productive :: Measure f+ Unverified :: Measure f++-- | A helper axiom for measure verification. When a measure's correctness depends on+-- properties that require induction to prove (e.g., @ifComplexity f > 0@), the user+-- provides these properties along with their proofs. During the measure check, each+-- helper is run: the TP proof is executed to confirm the property holds, and the+-- proven property is asserted as an axiom in the measure verification session.+--+-- Use the 'Data.SBV.TP.measureLemma' smart constructor to create these from TP proofs.+newtype MeasureHelper = MeasureHelper { runMeasureHelper :: SMTConfig -> IO SBool }++-- | Verify that a measure decreases at each recursive call site.+-- Walks the expression DAG to find recursive calls, computes reaching conditions+-- via ITE analysis, and verifies the measure property in a separate solver session.+-- Throws an error with a detailed message if verification fails.+verifyMeasure :: SMTConfig -> String -> LambdaInfo -> MeasureEval -> [MeasureHelper] -> IO ()+verifyMeasure cfg funcNm info meval helpers = do+ -- Run each helper with funcNm added to measuresBeingVerified, preventing re-entrant verification.+ -- This is needed when a measureLemma proof uses the function whose measure is being checked+ -- (e.g., revPreservesLen proves length(rev xs) == length xs, using rev itself).+ let curVerifying = measuresBeingVerified (tpOptions cfg)+ cfg' = cfg{tpOptions = (tpOptions cfg){measuresBeingVerified = Set.insert funcNm curVerifying}}++ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": verifying with " <> showText (length helpers) <> " helper(s)"+ <> if Set.null curVerifying then "" else ", already verifying: " <> showText (Set.toList curVerifying)]+ axioms <- mapM (`runMeasureHelper` cfg') helpers+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> showText (length axioms) <> " helper axiom(s) collected, checking measure"]+ result <- checkMeasure cfg funcNm False info meval axioms+ let prettyNm = prettyFuncNm funcNm+ case result of+ MeasureOK -> pure ()+ MeasureNotNonNeg r -> error $ unlines $+ [ ""+ , "*** Data.SBV: Termination measure is not non-negative."+ , "***"+ , "*** Function: " ++ prettyNm+ , "***"+ ]+ ++ ["*** " ++ l | l <- lines (show r)]+ +++ [ "***"+ , "*** The measure must be non-negative for all inputs."+ ]+ MeasureNotDecreasing r -> error $ unlines $+ [ ""+ , "*** Data.SBV: Termination measure does not strictly decrease at a recursive call site."+ , "***"+ , "*** Function: " ++ prettyNm+ , "***"+ ]+ ++ ["*** " ++ l | l <- lines (show r)]+ +++ [ "***"+ , "*** The measure must strictly decrease at every recursive call."+ ]++-- | Result of checking a measure.+data MeasureCheckResult = MeasureOK -- ^ Measure is valid+ | MeasureNotNonNeg ThmResult -- ^ Measure can be negative+ | MeasureNotDecreasing ThmResult -- ^ Measure doesn't strictly decrease++-- | Check that a measure is valid: non-negative and strictly decreasing at each recursive call.+-- Returns 'MeasureOK' if valid, or the specific failure otherwise.+-- If @skipNonNeg@ is 'True', the non-negativity check is skipped (used for ADT size measures+-- where non-negativity is guaranteed by construction).+-- The @axioms@ list contains additional properties to assert in the verification session+-- (used for user-provided measures that depend on inductively-proven helper properties).+checkMeasure :: SMTConfig -> String -> Bool -> LambdaInfo -> MeasureEval -> [SBool] -> IO MeasureCheckResult+checkMeasure cfgIn funcNm skipNonNeg LambdaInfo{liAssignments, liParams, liOutput, liConsts} (MeasureEval applyM) axioms = do+ let -- Use a separate transcript for the measure check, so it doesn't clobber the main one+ addSuffix s fp = dropExtension fp ++ "_measure_" ++ map (\c -> if c == ' ' then '_' else c) funcNm ++ "_" ++ s ++ takeExtension fp+ cfgNonNeg = cfgIn{transcript = addSuffix "nonNeg" <$> transcript cfgIn}+ cfgDecrease = cfgIn{transcript = addSuffix "decrease" <$> transcript cfgIn}+ barFuncNm = barify funcNm+ recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == T.pack barFuncNm]++ if null recCalls+ then pure MeasureOK+ else do+ let reachConds = computeReachingConditions liAssignments liOutput+ paramSVs = map snd liParams++ -- Set up the proving environment: create fresh symbolic parameters,+ -- constrain any axioms (which may register function definitions in this+ -- session via the SVal cache mechanism), then replay the function body DAG.+ -- The order matters: axioms must be constrained BEFORE replaying the DAG,+ -- so that replayDAG knows which functions are available in this session.+ mkProveEnv = do+ st <- symbolicEnv+ liftIO $ writeIORef (rSkipMeasureChecks st) True++ let singleParam = length paramSVs == 1+ freshParams <- liftIO $ sequence [svToSV st =<< svMkSymVar (NonQueryVar Nothing) (kindOf sv) (Just (if singleParam then "arg" else "arg" ++ show i)) st+ | (i, sv) <- zip [(0::Int)..] paramSVs+ ]+ freshConsts <- liftIO $ mapM (\(_, cv) -> svToSV st (SVal (kindOf cv) (Left cv))) liConsts++ -- Constrain axioms first: forcing axiom SBools triggers newUninterpreted+ -- for any functions they reference, registering those definitions in this session.+ mapM_ constrain axioms++ -- Now read which functions are actually available in this session+ sessionDefns <- liftIO $ readIORef (rDefns st)+ let sessionFuncs = Map.keysSet sessionDefns++ let constMapping = zip (map fst liConsts) freshConsts+ paramMapping = zip paramSVs freshParams+ initMap = Map.fromList (constMapping ++ paramMapping)+ builtinMap = Map.fromList [(trueSV, trueSV), (falseSV, falseSV)]+ startMap = Map.union initMap builtinMap++ svMap <- liftIO $ replayDAG cfgIn st (Set.singleton barFuncNm) sessionFuncs startMap (F.toList liAssignments)++ let formalSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) freshParams+ mFormal = applyM formalSVals++ pure (svMap, mFormal)++ -- Check 1: Non-negativity (skipped for ADT size measures, which are non-negative by construction)+ nonNegOK <- if skipNonNeg+ then pure (Right ())+ else do nonNegResult <- proveWith cfgNonNeg (do+ (_, mFormal) <- mkProveEnv+ sObserve "measure" (unSBV mFormal)+ pure $ nonNeg mFormal :: Symbolic SBool)+ pure $ case nonNegResult of+ ThmResult Unsatisfiable{} -> Right ()+ _ -> Left nonNegResult++ case nonNegOK of+ Right () -> do+ -- Check 2: Strict decrease at each recursive call+ decResult <- proveWith cfgDecrease (do+ (svMap, mFormal) <- mkProveEnv++ -- When we have axioms from measure helpers that reference the function being+ -- verified (e.g., revPreservesLen references rev), the axioms register the+ -- function definition in this session via the SVal cache mechanism. We then+ -- connect the fresh variables (created by replayDAG for recursive calls) to+ -- actual function calls, so the axioms can reason about them.+ -- For example, the axiom len(rev(xs)) = len(xs) needs to know that fresh_1+ -- is actually rev(as) in order to derive len(fresh_1) = len(as).+ st <- symbolicEnv+ defns <- liftIO $ readIORef (rDefns st)+ let funcRegistered = Map.member barFuncNm defns+ when funcRegistered $+ liftIO $ mapM_ (\(rcSV, callArgSVs) -> do+ let freshSV = Map.findWithDefault rcSV rcSV svMap+ mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs+ k = kindOf rcSV+ -- Create the actual function call: f(mapped_args)+ actualSV <- newExpr st k (SBVApp (Uninterpreted (T.pack barFuncNm)) mappedArgs)+ -- Assert fresh_var == f(mapped_args)+ let freshSVal = SVal k (Right (cache (const (pure freshSV))))+ actualSVal = SVal k (Right (cache (const (pure actualSV))))+ internalConstraint st False [] (svEqual freshSVal actualSVal)+ ) recCalls++ let singleCall = length recCalls == 1+ mkObligation (i, (rcSV, callArgSVs)) = do+ let mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs+ argSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) mappedArgs+ mCall = applyM argSVals++ reachSVal = case Map.lookup rcSV reachConds of+ Just conds -> sAnd [ let sv' = Map.findWithDefault condSV condSV svMap+ s = SBV (SVal KBool (Right (cache (\_ -> pure sv'))))+ in if pol then s else sNot s+ | (condSV, pol) <- conds+ ]+ Nothing -> sTrue++ tag nm | singleCall = nm+ | True = nm ++ "[" ++ show (i :: Int) ++ "]"++ sObserve (tag "then") (unSBV mCall)+ pure $ reachSVal .=> mFormal .> mCall++ sObserve "before" (unSBV mFormal)+ obligations <- mapM mkObligation (zip [1..] recCalls)+ pure $ sAnd obligations :: Symbolic SBool)++ case decResult of+ ThmResult Unsatisfiable{} -> pure MeasureOK+ _ -> pure $ MeasureNotDecreasing decResult++ Left nonNegResult -> pure $ MeasureNotNonNeg nonNegResult++-- | Verify a measure with a contract for nested recursive functions.+-- Uses well-founded induction: the inductive hypothesis provides the contract+-- on recursive call results, and we prove both measure decrease and contract simultaneously.+-- One-step unfolding of the function body at each recursive call site gives the solver+-- information about base-case behavior without assuming totality.+verifyMeasureWithContract :: SMTConfig -> String -> LambdaInfo -> MeasureEval -> ContractEval -> [MeasureHelper] -> IO ()+verifyMeasureWithContract cfg funcNm info meval ceval helpers = do+ -- Run helpers with funcNm added to measuresBeingVerified, same as verifyMeasure+ let curVerifying = measuresBeingVerified (tpOptions cfg)+ cfg' = cfg{tpOptions = (tpOptions cfg){measuresBeingVerified = Set.insert funcNm curVerifying}}++ debug cfg ["[MEASURE] " <> T.pack funcNm <> " (contract): verifying with " <> showText (length helpers) <> " helper(s)"]+ axioms <- mapM (`runMeasureHelper` cfg') helpers+ debug cfg ["[MEASURE] " <> T.pack funcNm <> " (contract): " <> showText (length axioms) <> " helper axiom(s) collected, checking measure+contract"]+ result <- checkMeasureWithContract cfg funcNm False info meval ceval axioms+ let prettyNm = prettyFuncNm funcNm+ case result of+ MeasureOK -> pure ()+ MeasureNotNonNeg r -> error $ unlines $+ [ ""+ , "*** Data.SBV: Termination measure is not non-negative."+ , "***"+ , "*** Function: " ++ prettyNm+ , "***"+ ]+ ++ ["*** " ++ l | l <- lines (show r)]+ +++ [ "***"+ , "*** The measure must be non-negative for all inputs."+ ]+ MeasureNotDecreasing r -> error $ unlines $+ [ ""+ , "*** Data.SBV: Measure+contract verification failed."+ , "***"+ , "*** Function: " ++ prettyNm+ , "***"+ ]+ ++ ["*** " ++ l | l <- lines (show r)]+ +++ [ "***"+ , "*** The measure must strictly decrease at every recursive call,"+ , "*** and the contract must hold for the function's output."+ , "*** The inductive hypothesis provides the contract on recursive call"+ , "*** results for inputs with strictly smaller measure."+ ]++-- | Check a measure with contract: non-negative, strictly decreasing, and contract holds.+-- Uses one-step unfolding at each recursive call site to give the solver base-case behavior,+-- and assumes the inductive hypothesis (contract on recursive call results) to handle+-- nested recursion where a call's argument depends on another call's result.+checkMeasureWithContract :: SMTConfig -> String -> Bool -> LambdaInfo -> MeasureEval -> ContractEval -> [SBool] -> IO MeasureCheckResult+checkMeasureWithContract cfgIn funcNm skipNonNeg LambdaInfo{liAssignments, liParams, liOutput, liConsts} (MeasureEval applyM) (ContractEval applyC) axioms = do+ let addSuffix s fp = dropExtension fp ++ "_measure_" ++ map (\c -> if c == ' ' then '_' else c) funcNm ++ "_" ++ s ++ takeExtension fp+ cfgNonNeg = cfgIn{transcript = addSuffix "nonNeg" <$> transcript cfgIn}+ cfgDecrease = cfgIn{transcript = addSuffix "decrease" <$> transcript cfgIn}+ barFuncNm = barify funcNm+ recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == T.pack barFuncNm]++ if null recCalls+ then pure MeasureOK+ else do+ -- Non-negativity: same as checkMeasure+ nonNegOK <- if skipNonNeg+ then pure (Right ())+ else do nonNegResult <- proveWith cfgNonNeg (do+ st <- symbolicEnv+ liftIO $ writeIORef (rSkipMeasureChecks st) True++ let singleParam = length paramSVs == 1+ freshParams <- liftIO $ sequence [svToSV st =<< svMkSymVar (NonQueryVar Nothing) (kindOf sv) (Just (if singleParam then "arg" else "arg" ++ show i)) st+ | (i, sv) <- zip [(0::Int)..] paramSVs+ ]+ freshConsts <- liftIO $ mapM (\(_, cv) -> svToSV st (SVal (kindOf cv) (Left cv))) liConsts++ mapM_ constrain axioms+ sessionDefns <- liftIO $ readIORef (rDefns st)+ let sessionFuncs = Map.keysSet sessionDefns++ let constMapping = zip (map fst liConsts) freshConsts+ paramMapping = zip paramSVs freshParams+ initMap = Map.fromList (constMapping ++ paramMapping)+ builtinMap = Map.fromList [(trueSV, trueSV), (falseSV, falseSV)]+ startMap = Map.union initMap builtinMap++ _ <- liftIO $ replayDAG cfgIn st (Set.singleton barFuncNm) sessionFuncs startMap (F.toList liAssignments)++ let formalSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) freshParams+ mFormal = applyM formalSVals++ sObserve "measure" (unSBV mFormal)+ pure $ nonNeg mFormal :: Symbolic SBool)+ pure $ case nonNegResult of+ ThmResult Unsatisfiable{} -> Right ()+ _ -> Left nonNegResult++ case nonNegOK of+ Right () -> do+ -- Decrease + contract check+ decResult <- proveWith cfgDecrease (do+ st <- symbolicEnv+ liftIO $ writeIORef (rSkipMeasureChecks st) True++ let singleParam = length paramSVs == 1+ freshParams <- liftIO $ sequence [svToSV st =<< svMkSymVar (NonQueryVar Nothing) (kindOf sv) (Just (if singleParam then "arg" else "arg" ++ show i)) st+ | (i, sv) <- zip [(0::Int)..] paramSVs+ ]+ freshConsts <- liftIO $ mapM (\(_, cv) -> svToSV st (SVal (kindOf cv) (Left cv))) liConsts++ mapM_ constrain axioms+ sessionDefns <- liftIO $ readIORef (rDefns st)+ let sessionFuncs = Map.keysSet sessionDefns++ let constMapping = zip (map fst liConsts) freshConsts+ paramMapping = zip paramSVs freshParams+ initMap = Map.fromList (constMapping ++ paramMapping)+ builtinMap = Map.fromList [(trueSV, trueSV), (falseSV, falseSV)]+ startMap = Map.union initMap builtinMap++ svMap <- liftIO $ replayDAG cfgIn st (Set.singleton barFuncNm) sessionFuncs startMap (F.toList liAssignments)++ let formalSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) freshParams+ mFormal = applyM formalSVals++ -- One-step unfolding: for each recursive call, replay the function body+ -- with the call's arguments substituted for the formal parameters.+ -- This gives the solver base-case behavior without assuming totality.+ let dagList = F.toList liAssignments+ liftIO $ F.for_ recCalls $ \(rcSV, callArgSVs) -> do+ let -- Map the call's arguments through svMap to get the fresh session SVs+ mappedCallArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs+ -- Build the initial map for the unfolded body: formal params -> call args+ unfoldParamMapping = zip paramSVs mappedCallArgs+ unfoldConstMapping = zip (map fst liConsts) freshConsts+ unfoldInitMap = Map.fromList (unfoldConstMapping ++ unfoldParamMapping)+ unfoldStartMap = Map.union unfoldInitMap builtinMap++ -- Replay the entire function body with the call's args+ unfoldSvMap <- replayDAG cfgIn st (Set.singleton barFuncNm) sessionFuncs unfoldStartMap dagList++ -- The unfolded output SV+ let unfoldedOutputSV = Map.findWithDefault liOutput liOutput unfoldSvMap+ -- The fresh variable that was assigned to this recursive call+ freshCallSV = Map.findWithDefault rcSV rcSV svMap+ -- Assert: fresh_call = unfolded_output+ freshSVal = SVal (kindOf rcSV) (Right (cache (const (pure freshCallSV))))+ unfoldedSVal = SVal (kindOf rcSV) (Right (cache (const (pure unfoldedOutputSV))))+ internalConstraint st False [] (svEqual freshSVal unfoldedSVal)++ -- IH contract: for each recursive call, assume the contract holds on its result.+ -- This is sound because we also prove measure decrease at each call site.+ liftIO $ F.for_ recCalls $ \(rcSV, callArgSVs) -> do+ let mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs+ argSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) mappedArgs+ freshCallSV = Map.findWithDefault rcSV rcSV svMap+ freshResult = SVal (kindOf rcSV) (Right (cache (const (pure freshCallSV))))+ contractHolds = applyC argSVals freshResult+ internalConstraint st False [] (unSBV contractHolds)++ -- Proof obligations:+ -- 1. Measure strictly decreases at each reachable recursive call site+ let reachConds = computeReachingConditions liAssignments liOutput+ singleCall = length recCalls == 1+ mkDecreaseObligation (i, (rcSV, callArgSVs)) = do+ let mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs+ argSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) mappedArgs+ mCall = applyM argSVals++ reachSVal = case Map.lookup rcSV reachConds of+ Just conds -> sAnd [ let sv' = Map.findWithDefault condSV condSV svMap+ s = SBV (SVal KBool (Right (cache (\_ -> pure sv'))))+ in if pol then s else sNot s+ | (condSV, pol) <- conds+ ]+ Nothing -> sTrue++ tag nm | singleCall = nm+ | True = nm ++ "[" ++ show (i :: Int) ++ "]"++ sObserve (tag "then") (unSBV mCall)+ pure $ reachSVal .=> mFormal .> mCall++ sObserve "before" (unSBV mFormal)+ decreaseObligations <- mapM mkDecreaseObligation (zip [1..] recCalls)++ -- 2. Contract holds for the function's output+ let mappedOutput = Map.findWithDefault liOutput liOutput svMap+ resultSVal = SVal (kindOf liOutput) (Right (cache (const (pure mappedOutput))))+ contractObl = applyC formalSVals resultSVal++ pure $ sAnd decreaseObligations .&& contractObl :: Symbolic SBool)++ case decResult of+ ThmResult Unsatisfiable{} -> pure MeasureOK+ _ -> pure $ MeasureNotDecreasing decResult++ Left nonNegResult -> pure $ MeasureNotNonNeg nonNegResult+ where paramSVs = map snd liParams++-- | Verify that a function marked as productive is guarded-recursive:+-- every recursive call must be a direct argument to a data constructor.+verifyGuardedness :: SMTConfig -> String -> LambdaInfo -> IO ()+verifyGuardedness cfg funcNm info+ | isGuardedRecursive (Set.singleton (barify funcNm)) info+ = debug cfg ["[MEASURE] " <> T.pack funcNm <> ": productive (all recursive calls are guarded by constructors)"]+ | True+ = error $ unlines+ [ ""+ , "*** Data.SBV: Function marked as productive is not guarded-recursive."+ , "***"+ , "*** Function: " ++ prettyFuncNm funcNm+ , "***"+ , "*** Every recursive call must be a direct argument to a data constructor"+ , "*** (list cons, ADT constructor, etc.) to ensure productivity."+ ]++-- | Check if a recursive function is guarded: every recursive call's result+-- is consumed by a data constructor (list cons, ADT constructor, tuple constructor).+-- This ensures the function is productive — it always makes progress by producing+-- at least one constructor before recursing. The set of barified names covers+-- all functions in the mutual recursion group (or just the function itself for self-recursion).+isGuardedRecursive :: Set.Set String -> LambdaInfo -> Bool+isGuardedRecursive barFuncNms LambdaInfo{liAssignments} = all isGuarded recCallSVs+ where+ dagList = F.toList liAssignments+ recCallSVs = [sv | (sv, SBVApp (Uninterpreted nm) _) <- dagList, nm `Set.member` Set.map T.pack barFuncNms]++ -- Build a map from SV to the set of operations that consume it+ consumers :: Map.Map SV [(SV, Op)]+ consumers = foldl' addConsumers Map.empty dagList+ where addConsumers m (sv, SBVApp op args) =+ foldl' (\m' a -> Map.insertWith (\_ old -> (sv, op) : old) a [(sv, op)] m') m args++ -- A recursive call is guarded if at least one of its consumers is a constructor+ isGuarded sv = case Map.lookup sv consumers of+ Nothing -> False+ Just cons -> any (isConstructorOp . snd) cons++ isConstructorOp (SeqOp SeqConcat{}) = True+ isConstructorOp (ADTOp ADTConstructor{}) = True+ isConstructorOp (TupleConstructor _) = True+ isConstructorOp _ = False++-- | Generate candidate measures based on parameter kinds.+-- For list args, we use @length@. For integer args, we use @abs@. For recursive ADTs, we use @sbv.dt.size@.+-- ADT size measures are tried first (most likely to succeed for structural recursion).+-- If there are multiple scalar candidates, we also try their sum.+-- For two or more scalar candidates, we also try lexicographic (tuple) measures+-- using all pairs and triples, which handles functions like Ackermann that+-- decrease lexicographically.+guessMeasures :: [(Quantifier, SV)] -> [(String, MeasureEval, Maybe Int)]+guessMeasures params = map (\(d, f, mi) -> (d, MeasureEval f, mi)) (adtSingles ++ otherSingles ++ summed) ++ lexPairs ++ lexTriples+ where+ singles :: [(String, [SVal] -> SInteger, Maybe Int)]+ singles = concatMap mkCandidates (zip [0..] params)++ -- ADT size measures are most likely to succeed for ADT-recursive functions, so try them first+ (adtSingles, otherSingles) = partition (\(_, _, mi) -> isJust mi) singles++ mkCandidates :: (Int, (Quantifier, SV)) -> [(String, [SVal] -> SInteger, Maybe Int)]+ mkCandidates (i, (_, sv)) = case kindOf sv of+ KList elemK -> [("length arg" ++ show (i+1), \svs ->+ let listSVal = svs !! i+ in SBV $ SVal KUnbounded $ Right $ cache $ \st -> do+ s <- sbvToSV st (SBV listSVal)+ newExpr st KUnbounded (SBVApp (SeqOp (SeqLen elemK)) [s]), Nothing)]++ -- Strings are sequences of characters in SMTLib+ KString -> [("length arg" ++ show (i+1), \svs ->+ let strSVal = svs !! i+ in SBV $ SVal KUnbounded $ Right $ cache $ \st -> do+ s <- sbvToSV st (SBV strSVal)+ newExpr st KUnbounded (SBVApp (SeqOp (SeqLen KChar)) [s]), Nothing)]++ -- Unbounded integers: try abs and smax 0 as measures+ KUnbounded -> [ ("abs arg" ++ show (i+1), \svs -> abs (SBV (svs !! i)), Nothing)+ , ("smax 0 arg" ++ show (i+1), \svs -> 0 `smax` SBV (svs !! i), Nothing)+ ]++ -- Bounded bitvectors: cast to Integer for the measure. Unsigned values are+ -- already non-negative; signed values need abs to ensure non-negativity.+ KBounded False _ -> [("arg" ++ show (i+1), \svs -> SBV (svFromIntegral KUnbounded (svs !! i)), Nothing)]+ KBounded True _ -> [("abs arg" ++ show (i+1), \svs -> abs (SBV (svFromIntegral KUnbounded (svs !! i))), Nothing)]++ KTuple ks -> concatMap (mkTupleComponent i (length ks)) (zip [1..] ks)+ KADT adtName _ ctors+ | any (any (isRecKind adtName) . snd) ctors ->+ let sizeName = "sbv.dt.size." ++ adtName+ adtKind = kindOf sv+ in [(sizeName ++ " arg" ++ show (i+1), \svs ->+ SBV $ SVal KUnbounded $ Right $ cache $ \st -> do+ ensureADTSizeDefined st sizeName adtKind ctors+ s <- sbvToSV st (SBV (svs !! i))+ newExpr st KUnbounded (SBVApp (Uninterpreted (T.pack sizeName)) [s]), Just i)]+ _ -> []++ mkTupleComponent :: Int -> Int -> (Int, Kind) -> [(String, [SVal] -> SInteger, Maybe Int)]+ mkTupleComponent argIdx nFields (compIdx, compKind) = case compKind of+ KList elemK -> [("length arg" ++ show (argIdx+1) ++ "._" ++ show compIdx, \svs ->+ let comp = SBV $ SVal compKind $ Right $ cache $ \st -> do+ tupSV <- sbvToSV st (SBV (svs !! argIdx))+ newExpr st compKind (SBVApp (TupleAccess compIdx nFields) [tupSV])+ in SBV $ SVal KUnbounded $ Right $ cache $ \st -> do+ s <- sbvToSV st comp+ newExpr st KUnbounded (SBVApp (SeqOp (SeqLen elemK)) [s]), Nothing)]+ KUnbounded -> [("abs arg" ++ show (argIdx+1) ++ "._" ++ show compIdx, \svs ->+ abs $ SBV $ SVal KUnbounded $ Right $ cache $ \st -> do+ tupSV <- sbvToSV st (SBV (svs !! argIdx))+ newExpr st KUnbounded (SBVApp (TupleAccess compIdx nFields) [tupSV]), Nothing)]+ _ -> []++ summed | length singles > 1 = [( intercalate " + " [d | (d, _, _) <- singles]+ , \svs -> sum [f svs | (_, f, _) <- singles]+ , Nothing+ )]+ | True = []++ -- Lexicographic pair measures: try all ordered pairs from the scalar candidates+ lexPairs :: [(String, MeasureEval, Maybe Int)]+ lexPairs+ | length singles < 2 = []+ | True = [ ( "(" ++ d1 ++ ", " ++ d2 ++ ")"+ , MeasureEval (\svs -> mkPair (f1 svs) (f2 svs))+ , Nothing+ )+ | (d1, f1, _) <- singles+ , (d2, f2, _) <- singles+ , d1 /= d2+ ]++ -- Lexicographic triple measures: try all ordered triples from the scalar candidates+ lexTriples :: [(String, MeasureEval, Maybe Int)]+ lexTriples+ | length singles < 3 = []+ | True = [ ( "(" ++ d1 ++ ", " ++ d2 ++ ", " ++ d3 ++ ")"+ , MeasureEval (\svs -> mkTriple (f1 svs) (f2 svs) (f3 svs))+ , Nothing+ )+ | (d1, f1, _) <- singles+ , (d2, f2, _) <- singles+ , d1 /= d2+ , (d3, f3, _) <- singles+ , d1 /= d3, d2 /= d3+ ]++ -- Build an SBV (Integer, Integer) from two SIntegers+ mkPair :: SInteger -> SInteger -> SBV (Integer, Integer)+ mkPair a b = SBV $ SVal (KTuple [KUnbounded, KUnbounded]) $ Right $ cache $ \st -> do+ sa <- sbvToSV st a+ sb <- sbvToSV st b+ newExpr st (KTuple [KUnbounded, KUnbounded]) (SBVApp (TupleConstructor 2) [sa, sb])++ -- Build an SBV (Integer, Integer, Integer) from three SIntegers+ mkTriple :: SInteger -> SInteger -> SInteger -> SBV (Integer, Integer, Integer)+ mkTriple a b c = SBV $ SVal (KTuple [KUnbounded, KUnbounded, KUnbounded]) $ Right $ cache $ \st -> do+ sa <- sbvToSV st a+ sb <- sbvToSV st b+ sc <- sbvToSV st c+ newExpr st (KTuple [KUnbounded, KUnbounded, KUnbounded]) (SBVApp (TupleConstructor 3) [sa, sb, sc])++-- | Check if a kind refers back to a given ADT name (i.e., is a recursive field).+-- Recursive fields in constructor kinds use 'KApp', not 'KADT'.+isRecKind :: String -> Kind -> Bool+isRecKind adtName (KApp n _) = n == adtName+isRecKind adtName (KADT n _ _) = n == adtName+isRecKind _ _ = False++-- | Ensure that an ADT size function is defined in the given state. The size function+-- maps ADT values to non-negative integers, returning 0 for base constructors and+-- @1 + sum(sizes of recursive fields)@ for recursive constructors.+-- This is used as a termination measure for functions that recurse on ADT values.+ensureADTSizeDefined :: State -> String -> Kind -> [(String, [Kind])] -> IO ()+ensureADTSizeDefined st sizeName adtKind ctors = do+ defs <- readIORef (rDefns st)+ unless (Map.member sizeName defs) $ do+ let argNm = "x"+ smtArgType = T.unpack (smtType adtKind)++ -- Build the SMT-Lib body for the size function+ body = buildBody ctors++ buildBody [] = "0"+ buildBody [c] = caseExpr c+ buildBody (c:cs) = "(ite " ++ testerExpr c ++ " " ++ caseExpr c ++ " " ++ buildBody cs ++ ")"++ testerExpr (cName, _) = "(is-" ++ cName ++ " " ++ argNm ++ ")"++ caseExpr (cName, flds) =+ let recIdxs = [j | (j, k) <- zip [1::Int ..] flds, isRecKind (adtNameOf adtKind) k]+ in if null recIdxs+ then "0"+ else let recCalls = ["(" ++ sizeName ++ " (get" ++ cName ++ "_" ++ show j ++ " " ++ argNm ++ "))" | j <- recIdxs]+ in "(+ 1 " ++ smtSum recCalls ++ ")"++ smtSum [x] = x+ smtSum (x:xs) = "(+ " ++ x ++ " " ++ smtSum xs ++ ")"+ smtSum [] = "0"++ paramStr = T.pack $ "((" ++ argNm ++ " " ++ smtArgType ++ "))"+ smtDef = SMTDef KUnbounded [sizeName] (Just paramStr) (\n -> T.pack (replicate n ' ' ++ body))+ sbvTy = SBVType [adtKind, KUnbounded]++ modifyIORef' (rDefns st) (Map.insert sizeName (smtDef, sbvTy))+ modifyState st rUIMap (Map.insert sizeName (True, Nothing, sbvTy)) (pure ())++-- | Extract the ADT name from a KADT kind.+adtNameOf :: Kind -> String+adtNameOf (KADT n _ _) = n+adtNameOf _ = ""++-- | Check if a function is structurally recursive on a given parameter.+-- Returns 'True' if every recursive call passes a strict sub-term of the+-- formal parameter (obtained via one or more 'ADTAccessor' operations) as+-- the argument at that parameter position. Structural recursion on an ADT+-- guarantees termination by the well-foundedness of the datatype, so the+-- measure check can be skipped.+isStructurallyDecreasing :: String -> LambdaInfo -> Int -> Bool+isStructurallyDecreasing funcNm LambdaInfo{liAssignments, liParams} paramIdx =+ not (null recCalls) && all checkCall recCalls+ where+ barFuncNm = barify funcNm+ paramSV = snd (liParams !! paramIdx)+ asgns = F.toList liAssignments+ defMap = Map.fromList asgns++ recCalls = [args | (_, SBVApp (Uninterpreted nm) args) <- asgns, nm == T.pack barFuncNm]++ checkCall callArgs+ | paramIdx < length callArgs = isProperSubTerm (callArgs !! paramIdx)+ | True = False++ -- An SV is a proper sub-term of the parameter if it is obtained by applying+ -- one or more ADTAccessor operations to the parameter.+ isProperSubTerm sv = case Map.lookup sv defMap of+ Just (SBVApp (ADTOp (ADTAccessor _ _)) [parent]) ->+ parent == paramSV || isProperSubTerm parent+ _ -> False++-- | Try to auto-guess a termination measure for a recursive function. Generates candidates+-- based on parameter kinds and tries each one. Returns the first measure that passes both+-- non-negativity and strict decrease checks, or 'Nothing' if no guess works.+autoGuess :: SMTConfig -> String -> LambdaInfo -> IO (Maybe MeasureEval)+autoGuess cfg funcNm info = do+ let barFuncNm = barify funcNm+ recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList (liAssignments info), nm == T.pack barFuncNm]+ allUIs = [(nm, length args) | (_, SBVApp (Uninterpreted nm) args) <- F.toList (liAssignments info)]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": barified = " <> showText barFuncNm]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": Uninterpreted ops in DAG: " <> showText allUIs]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": recursive calls found = " <> showText (length recCalls)]+ go candidates+ where+ candidates = guessMeasures (liParams info)+ go [] = pure Nothing+ go ((desc, m, mbIdx):ms) = do let skipNonNeg = "sbv.dt.size." `isPrefixOf` desc+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": trying " <> T.pack desc]+ -- For ADT size measures, try syntactic sub-term check first.+ -- This avoids calling the solver, which can hang on recursive+ -- define-fun-rec definitions.+ result <- case mbIdx of+ Just idx | isStructurallyDecreasing funcNm info idx -> do+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " -> OK (structural recursion)"]+ pure MeasureOK+ _ -> checkMeasure cfg funcNm skipNonNeg info m []+ case result of+ MeasureOK -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " -> OK"]+ pure (Just m)+ MeasureNotNonNeg r -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " failed non-negativity: " <> showText r]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": trying next candidate.."]+ go ms+ MeasureNotDecreasing r -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " failed strict decrease: " <> showText r]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": trying next candidate.."]+ go ms++-- | Auto-guess a termination measure, or fail with a helpful error message.+autoGuessOrFail :: SMTConfig -> String -> LambdaInfo -> IO ()+autoGuessOrFail cfg funcNm info = do+ mbMeasure <- autoGuess cfg funcNm info+ case mbMeasure of+ Just _ -> pure ()+ Nothing -> error $ unlines $+ [ ""+ , "*** Data.SBV: Cannot determine a termination measure."+ , "***"+ , "*** Function: " ++ prettyFuncNm funcNm+ ]+ ++ guessLines+ +++ [ "***"+ , "*** Please use 'smtFunctionWithMeasure' to provide an explicit measure."+ ]+ where candidates = guessMeasures (liParams info)+ guessLines+ | null candidates = [ "***"+ , "*** No measure candidates could be derived from the argument types."+ ]+ | True = [ "***"+ , "*** Measures tried:"+ ]+ ++ [ "*** " ++ d | (d, _, _) <- candidates]++-- | Check mutual recursion for a function by computing the SCC from State.+-- This is called as a deferred closure from rMeasureChecks. It computes the SCC+-- of the function graph, finds the group containing the given function, and+-- verifies the whole group if it's a multi-member cycle. Multiple members of the+-- same group may register this check, but only the first execution does work;+-- after successful verification, verified members are removed from rFuncLambdaInfos,+-- so subsequent closures find insufficient infos and skip.+--+-- The optional t'MeasureEval' is a user-provided measure (from 'smtFunctionWithMeasure').+-- If given, it is tried first before falling back to auto-guessing.+checkMutualFromState :: SMTConfig -> String -> State -> Maybe MeasureEval -> IO ()+checkMutualFromState cfg funcNm st mbMeasure = do+ defns <- readIORef (rDefns st)+ funcInfos <- readIORef (rFuncLambdaInfos st)++ let barFuncNm = barify funcNm+ nodes = [(nm, nm, deps) | (nm, (SMTDef _ deps _ _, _)) <- Map.toList defns]+ sccs = DG.stronglyConnComp nodes++ -- Find the SCC containing our function (using barified name since rDefns keys are barified)+ mySCC = [members | DG.CyclicSCC members <- sccs, barFuncNm `elem` members]++ case mySCC of+ [members] | length members >= 2 -> do+ -- rFuncLambdaInfos uses plain names, so unbar the SCC member names for lookup.+ -- Build the infos map with plain names as keys (matching rFuncLambdaInfos convention).+ let plainMembers = map unBar members+ infos = Map.fromList [(pnm, v) | pnm <- plainMembers, Just v <- [Map.lookup pnm funcInfos]]+ if Map.size infos >= 2+ then do checkMutualGroup cfg infos mbMeasure+ -- Remove verified members from rFuncLambdaInfos so that subsequent closures+ -- for the same group (registered by other members) find insufficient infos and skip.+ modifyIORef' (rFuncLambdaInfos st) (\m -> foldl' (flip Map.delete) m plainMembers)+ else do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": mutual group already verified, skipping"]+ modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm)+ _ -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": not in a multi-member cycle, skipping mutual check"]+ modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm)++-- | Reject mutual recursion for contract-based functions. Deferred to SCC computation time+-- so that non-mutual cross-refs (helper functions, uninterpreted constants) don't cause false positives.+rejectMutualContractFromState :: SMTConfig -> String -> State -> IO ()+rejectMutualContractFromState cfg funcNm st = do+ defns <- readIORef (rDefns st)++ let barFuncNm = barify funcNm+ nodes = [(nm, nm, deps) | (nm, (SMTDef _ deps _ _, _)) <- Map.toList defns]+ sccs = DG.stronglyConnComp nodes+ mySCC = [members | DG.CyclicSCC members <- sccs, barFuncNm `elem` members]++ case mySCC of+ [members] | length members >= 2 ->+ error $ unlines [ ""+ , "*** Data.SBV: smtFunctionWithContract does not support mutual recursion."+ , "***"+ , "*** Function: " ++ prettyFuncNm funcNm+ , "***"+ , "*** Please use smtFunction or smtFunctionWithMeasure for mutual recursion groups."+ , ""+ ]+ _ -> debug cfg ["[MEASURE] " <> T.pack funcNm <> ": not in a multi-member cycle, skipping mutual contract check"]++-- | Check that all members of a mutual recursion group marked as productive are guarded-recursive,+-- considering cross-calls as well as self-calls.+checkMutualProductiveFromState :: SMTConfig -> String -> State -> IO ()+checkMutualProductiveFromState cfg funcNm st = do+ defns <- readIORef (rDefns st)+ funcInfos <- readIORef (rFuncLambdaInfos st)++ let barFuncNm = barify funcNm+ nodes = [(nm, nm, deps) | (nm, (SMTDef _ deps _ _, _)) <- Map.toList defns]+ sccs = DG.stronglyConnComp nodes+ mySCC = [members | DG.CyclicSCC members <- sccs, barFuncNm `elem` members]++ case mySCC of+ [members] | length members >= 2 -> do+ let plainMembers = map unBar members+ infos = Map.fromList [(pnm, v) | pnm <- plainMembers, Just v <- [Map.lookup pnm funcInfos]]+ if Map.size infos >= 2+ then do let barNames = Set.fromList members+ memberNamesStr = intercalate ", " (map prettyFuncNm plainMembers)+ debug cfg ["[MEASURE] Checking mutual productive group: {" <> T.pack memberNamesStr <> "}"]+ let failed = [(pnm, info) | (pnm, info) <- Map.toList infos, not (isGuardedRecursive barNames info)]+ case failed of+ [] -> do debug cfg ["[MEASURE] Mutual productive group: all members are guarded"]++ modifyIORef' (rFuncLambdaInfos st) (\m -> foldl' (flip Map.delete) m plainMembers)+ _ -> error $ unlines $+ [ ""+ , "*** Data.SBV: Mutual productive group has unguarded recursive calls."+ , "***"+ ]+ ++ groupLines (Map.toList infos)+ +++ [ "*** Unguarded: " ++ intercalate ", " (map (prettyFuncNm . fst) failed)+ , "***"+ , "*** Every recursive call (self or cross) must be a direct argument to a data constructor."+ , ""+ ]+ else do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": mutual productive group already verified, skipping"]+ modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm)+ _ -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": not in a multi-member cycle, skipping mutual productive check"]+ modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm)++-- | Check termination for a mutual recursion group. Each function in the group+-- gets an auto-guessed measure, and we verify that at every call edge (self or cross),+-- the caller's measure at formal parameters strictly exceeds the callee's measure at actual arguments.+--+-- If a user-provided measure is given ('Just'), it is tried first before auto-guessing.+checkMutualGroup :: SMTConfig -> Map.Map String LambdaInfo -> Maybe MeasureEval -> IO ()+checkMutualGroup cfg members mbMeasure = do+ let memberNames = Map.keys members+ memberNamesStr = intercalate ", " (map prettyFuncNm memberNames)+ debug cfg ["[MEASURE] Checking mutual recursion group: {" <> T.pack memberNamesStr <> "}"]++ -- If a user-provided measure is given, try it first+ let memberList = Map.toList members+ userOK <- case mbMeasure of+ Nothing -> pure False+ Just m -> do+ debug cfg ["[MEASURE] Mutual group: trying user-provided measure for all members"]+ ok <- checkMutualMeasure cfg memberList m+ if ok+ then do debug cfg ["[MEASURE] Mutual group: user-provided measure works for all members"]+ pure True+ else do debug cfg ["[MEASURE] Mutual group: user-provided measure failed, falling back to auto-guess"]+ pure False++ unless userOK $ do+ -- Auto-guess: for each function, generate measure candidates+ let memberCandidates = [(nm, info, guessMeasures (liParams info)) | (nm, info) <- memberList]++ -- Check if any member has no candidates at all+ case [(nm, info) | (nm, info, []) <- memberCandidates] of+ (nm, _):_ -> error $ unlines $+ [ ""+ , "*** Data.SBV: Cannot determine a termination measure for mutual recursion group."+ , "***"+ ]+ ++ groupLines memberList+ +++ [ "*** Function with no measure candidates: " ++ prettyFuncNm nm+ , "***"+ , if isJust mbMeasure+ then "*** The user-provided measure did not work, and no auto-guess candidates are available."+ else "*** Please use 'smtFunctionWithMeasure' to provide explicit measures."+ ]+ [] -> pure ()++ -- Try to find a working combination. For efficiency, when all members have the same+ -- parameter kinds, we try the same candidate for all. Otherwise we try combinations.+ let allCandidateLists = [(nm, info, cs) | (nm, info, cs) <- memberCandidates]+ tryMeasures allCandidateLists++ where+ tryMeasures :: [(String, LambdaInfo, [(String, MeasureEval, Maybe Int)])] -> IO ()+ tryMeasures memberInfos = do+ -- Collect all unique candidates from all members (by description).+ -- Different members may have different parameter kinds, yielding different candidates.+ let allCandidates = nubBy (\(d1,_,_) (d2,_,_) -> d1 == d2)+ $ concatMap (\(_, _, cs) -> cs) memberInfos++ result <- go allCandidates+ case result of+ Just _ -> pure ()+ Nothing -> do+ error $ unlines $+ [ ""+ , "*** Data.SBV: Cannot determine a termination measure for mutual recursion group."+ , "***"+ ]+ ++ groupLines (Map.toList members)+ +++ [ "***"+ , if isJust mbMeasure+ then "*** The user-provided measure did not work, and auto-guessing also failed."+ else "*** Please use 'smtFunctionWithMeasure' to provide explicit measures."+ ]++ where+ go [] = pure Nothing+ go ((desc, m, _mbIdx):rest) = do+ debug cfg ["[MEASURE] Mutual group: trying measure " <> T.pack desc <> " for all members"]+ -- Try the same measure for all members. Catch exceptions from kind mismatches+ -- (e.g., applying abs to a list parameter) and treat them as failure.+ let memberList = [(nm, info) | (nm, info, _) <- memberInfos]+ result <- C.try $ checkMutualMeasure cfg memberList m+ case result of+ Right True -> do debug cfg ["[MEASURE] Mutual group: measure " <> T.pack desc <> " works for all members"]+ pure (Just m)+ Right False -> do debug cfg ["[MEASURE] Mutual group: measure " <> T.pack desc <> " failed, trying next"]+ go rest+ Left (e :: C.SomeException) -> do+ debug cfg ["[MEASURE] Mutual group: measure " <> T.pack desc <> " incompatible: " <> showText e]+ go rest++-- | Verify that a given measure works for all functions in a mutual recursion group.+-- Uses the same measure for all members. For each function f, check that at every call+-- site to any function g in the group, measure(f's formals) > measure(g's actuals).+checkMutualMeasure :: SMTConfig -> [(String, LambdaInfo)] -> MeasureEval -> IO Bool+checkMutualMeasure cfgIn members (MeasureEval applyM) = go members+ where+ -- Set of barified names of all group members+ groupBarNames = Set.fromList [barify nm | (nm, _) <- members]++ go [] = pure True+ go ((funcNm, LambdaInfo{liAssignments, liParams, liOutput, liConsts}):rest) = do+ -- Find all calls to any member of the mutual group+ let allGroupCalls = [(sv, args)+ | (sv, SBVApp (Uninterpreted calleeNm) args) <- F.toList liAssignments+ , calleeNm `Set.member` Set.map T.pack groupBarNames+ ]++ if null allGroupCalls+ then go rest -- No calls to group members, no decrease needed+ else do+ let addSuffix s fp = dropExtension fp ++ "_measure_" ++ map (\c -> if c == ' ' then '_' else c) funcNm ++ "_" ++ s ++ takeExtension fp+ cfgDecrease = cfgIn{transcript = addSuffix "mutual_decrease" <$> transcript cfgIn}+ cfgNonNeg = cfgIn{transcript = addSuffix "mutual_nonNeg" <$> transcript cfgIn}+ paramSVs = map snd liParams+ reachConds = computeReachingConditions liAssignments liOutput++ mkProveEnv = do+ st <- symbolicEnv+ liftIO $ writeIORef (rSkipMeasureChecks st) True+ let singleParam = length paramSVs == 1+ freshParams <- liftIO $ sequence+ [svToSV st =<< svMkSymVar (NonQueryVar Nothing) (kindOf sv)+ (Just (if singleParam then "arg" else "arg" ++ show i)) st+ | (i, sv) <- zip [(0::Int)..] paramSVs+ ]+ freshConsts <- liftIO $ mapM (\(_, cv) -> svToSV st (SVal (kindOf cv) (Left cv))) liConsts+ sessionDefns <- liftIO $ readIORef (rDefns st)+ let sessionFuncs = Map.keysSet sessionDefns+ constMapping = zip (map fst liConsts) freshConsts+ paramMapping = zip paramSVs freshParams+ initMap = Map.fromList (constMapping ++ paramMapping)+ builtinMap = Map.fromList [(trueSV, trueSV), (falseSV, falseSV)]+ startMap = Map.union initMap builtinMap+ svMap <- liftIO $ replayDAG cfgIn st groupBarNames sessionFuncs startMap (F.toList liAssignments)+ let formalSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) freshParams+ mFormal = applyM formalSVals+ pure (svMap, mFormal)++ -- Check 1: Non-negativity of caller's measure+ nonNegResult <- proveWith cfgNonNeg (do+ (_, mFormal) <- mkProveEnv+ sObserve "measure" (unSBV mFormal)+ pure $ nonNeg mFormal :: Symbolic SBool)++ case nonNegResult of+ ThmResult Unsatisfiable{} -> do+ -- Check 2: Strict decrease at each call site+ decResult <- proveWith cfgDecrease (do+ (svMap, mFormal) <- mkProveEnv+ let singleCall = length allGroupCalls == 1+ mkObligation (i, (rcSV, callArgSVs)) = do+ let mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs+ argSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) mappedArgs+ mCall = applyM argSVals+ reachSVal = case Map.lookup rcSV reachConds of+ Just conds -> sAnd [ let sv' = Map.findWithDefault condSV condSV svMap+ s = SBV (SVal KBool (Right (cache (\_ -> pure sv'))))+ in if pol then s else sNot s+ | (condSV, pol) <- conds+ ]+ Nothing -> sTrue+ tag nm | singleCall = nm+ | True = nm ++ "[" ++ show (i :: Int) ++ "]"+ sObserve (tag "then") (unSBV mCall)+ pure $ reachSVal .=> mFormal .> mCall+ sObserve "before" (unSBV mFormal)+ obligations <- mapM mkObligation (zip [1..] allGroupCalls)+ pure $ sAnd obligations :: Symbolic SBool)+ case decResult of+ ThmResult Unsatisfiable{} -> do+ debug cfgIn ["[MEASURE] Mutual group: decrease verified for " <> T.pack funcNm]+ go rest+ _ -> do+ debug cfgIn ["[MEASURE] Mutual group: decrease failed for " <> T.pack funcNm <> ": " <> showText decResult]+ pure False+ _ -> do+ debug cfgIn ["[MEASURE] Mutual group: non-negativity failed for " <> T.pack funcNm]+ pure False++-- | Pretty-print a function name: turn @"insert @(SBV Integer -> SBV [Integer])"@ into @"insert :: SBV Integer -> SBV [Integer]"@+prettyFuncNm :: String -> String+prettyFuncNm m = case break (== '@') m of+ (nm, '@':'(':tp) | not (null tp) -> dropWhileEnd (== ' ') nm ++ " :: " ++ init tp+ _ -> m++-- | Format group members on separate lines, aligned on @::@.+groupLines :: [(String, LambdaInfo)] -> [String]+groupLines ms = case map (prettyFuncNm . fst) ms of+ [] -> []+ names -> let parts = [(nm, tp) | n <- names, let (nm, tp) = case break (== ':') n of+ (a, ':':':':b) -> (dropWhileEnd (== ' ') a, " ::" ++ b)+ _ -> (n, "")]+ maxNm = maximum (map (length . fst) parts)+ pad s = s ++ replicate (maxNm - length s) ' '+ fmt (n, t) = "*** " ++ pad n ++ " " ++ t+ in map fmt parts++-- | Replay the DAG in a new state, building up an SV mapping from old to new.+-- Recursive calls to the functions being verified are replaced with fresh variables.+-- Calls to other DEFINED functions (present in the parent state's rDefns) are replayed as actual calls.+-- All other Uninterpreted references (uninterpreted constants, free functions, sentinels)+-- are replaced with fresh variables since they aren't defined in the fresh proveWith session.+replayDAG :: SMTConfig -> State -> Set.Set String -> Set.Set String -> Map.Map SV SV -> [(SV, SBVExpr)] -> IO (Map.Map SV SV)+replayDAG cfg st recFuncNames definedFuncs startMap dag = do+ let n = length dag+ let nms = intercalate ", " (map unBar (Set.toList recFuncNames))+ debug cfg ["[MEASURE] replayDAG {" <> T.pack nms <> "}: replaying " <> showText n <> " node(s)"]+ go startMap dag+ where -- Map an SV through the svMap. If it's not found, it's an external captured variable+ -- (e.g., from a higher-order function's closure). Create a fresh unconstrained variable+ -- for it to avoid leaking foreign-context SVals into the current state.+ mapArg svMap a = case Map.lookup a svMap of+ Just a' -> pure (a', svMap)+ Nothing -> do fresh <- newInternalVariable st (kindOf a)+ pure (fresh, Map.insert a fresh svMap)++ mapArgs svMap [] = pure ([], svMap)+ mapArgs svMap (a:as) = do (a', svMap') <- mapArg svMap a+ (as', svMap'') <- mapArgs svMap' as+ pure (a':as', svMap'')++ go svMap [] = pure svMap+ go svMap ((sv, expr):rest) = do+ let SBVApp op args = expr+ (mappedArgs, svMap') <- mapArgs svMap args+ newSV' <- case op of+ -- For recursive calls (self or mutual), create a fresh uninterpreted value instead of replaying+ Uninterpreted nm | nm `Set.member` Set.map T.pack recFuncNames -> newInternalVariable st (kindOf sv)+ -- For calls to other defined functions (e.g., partition), replay properly+ Uninterpreted nm | nm `Set.member` Set.map T.pack definedFuncs -> do+ let mappedOp = mapOpSVs (\a -> Map.findWithDefault a a svMap') op+ newExpr st (kindOf sv) (SBVApp mappedOp mappedArgs)+ -- For everything else that's Uninterpreted (free functions, sentinels, etc.),+ -- create fresh values since they aren't defined in the proveWith session+ Uninterpreted{} -> newInternalVariable st (kindOf sv)+ -- For all other operations (arithmetic, list ops, etc.), replay properly+ _ -> do let mappedOp = mapOpSVs (\a -> Map.findWithDefault a a svMap') op+ newExpr st (kindOf sv) (SBVApp mappedOp mappedArgs)+ go (Map.insert sv newSV' svMap') rest++-- | Map any SVs embedded directly in an Op (e.g., in LkUp, FP_Cast)+mapOpSVs :: (SV -> SV) -> Op -> Op+mapOpSVs f (LkUp p sv1 sv2) = LkUp p (f sv1) (f sv2)+mapOpSVs f (IEEEFP (FP_Cast fk tk sv)) = IEEEFP (FP_Cast fk tk (f sv))+mapOpSVs _ (ArrayInit (Right (SMTLambda s))) = ArrayInit (Right (SMTLambda s)) -- Lambda strings don't contain SVs to map+mapOpSVs _ op = op++-- | Compute the reaching condition for each SV: under what boolean condition+-- does the SV's value contribute to the output? Propagates conditions top-down+-- through ITE, AND, and OR nodes. Each reaching condition is a list of+-- @(condSV, polarity)@ pairs; the actual condition is the conjunction: for each+-- pair, @condSV@ if polarity is 'True', @not condSV@ if polarity is 'False'.+computeReachingConditions :: Seq.Seq (SV, SBVExpr) -> SV -> Map.Map SV [(SV, Bool)]+computeReachingConditions asgns outSV = go initMap (reverse $ F.toList asgns)+ where+ -- The output's reaching condition is True (empty conjunction)+ initMap = Map.singleton outSV []++ go condMap [] = condMap+ go condMap ((sv, SBVApp op args) : rest) =+ case Map.lookup sv condMap of+ Nothing -> go condMap rest -- This SV doesn't contribute to the output+ Just rc ->+ let condMap' = case (op, args) of+ (Ite, [c, t, e]) ->+ let condMapT = addReach t ((c, True) : rc) condMap+ condMapE = addReach e ((c, False) : rc) condMapT+ in condMapE+ -- For AND: each arg is only relevant when the other is True+ (And, [a, b]) ->+ let condMapA = addReach a ((b, True) : rc) condMap+ condMapB = addReach b ((a, True) : rc) condMapA+ in condMapB+ -- For OR: each arg is only relevant when the other is False+ (Or, [a, b]) ->+ let condMapA = addReach a ((b, False) : rc) condMap+ condMapB = addReach b ((a, False) : rc) condMapA+ in condMapB+ _ -> foldl' (\m a -> addReach a rc m) condMap args+ in go condMap' rest++ -- Add a reaching condition to an SV. For shared nodes, keep the first condition found+ -- (most direct path from the output).+ addReach sv rc m = Map.insertWith (\_ old -> old) sv rc m++-- | Regular expressions can be compared for equality. Note that we diverge here from the equality+-- in the concrete sense; i.e., the Eq instance does not match the symbolic case. This is a bit unfortunate,+-- but unavoidable with the current design of how we "distinguish" operators. Hopefully shouldn't be a big deal,+-- though one should be careful.+instance EqSymbolic RegExp where+ r1 .== r2 = SBV $ SVal KBool $ Right $ cache r+ where r st = newExpr st KBool $ SBVApp (RegExOp (RegExEq r1 r2)) []++ r1 ./= r2 = SBV $ SVal KBool $ Right $ cache r+ where r st = newExpr st KBool $ SBVApp (RegExOp (RegExNEq r1 r2)) []++-- | Symbolic Numbers. This is a simple class that simply incorporates all number like+-- base types together, simplifying writing polymorphic type-signatures that work for all+-- symbolic numbers, such as 'SWord8', 'SInt8' etc. For instance, we can write a generic+-- list-minimum function as follows:+--+-- @+-- mm :: SIntegral a => [SBV a] -> SBV a+-- mm = foldr1 (\a b -> ite (a .<= b) a b)+-- @+--+-- It is similar to the standard 'Integral' class, except ranging over symbolic instances.+class (SymVal a, Num a, Num (SBV a), Bits a, Integral a) => SIntegral a++-- 'SIntegral' Instances, skips Real/Float/Bool+instance SIntegral Word8+instance SIntegral Word16+instance SIntegral Word32+instance SIntegral Word64+instance SIntegral Int8+instance SIntegral Int16+instance SIntegral Int32+instance SIntegral Int64+instance SIntegral Integer+instance (KnownNat n, BVIsNonZero n) => SIntegral (WordN n)+instance (KnownNat n, BVIsNonZero n) => SIntegral (IntN n)++-- | Zero extend a bit-vector.+zeroExtend :: forall n m bv. ( KnownNat n, BVIsNonZero n, SymVal (bv n)+ , KnownNat m, BVIsNonZero m, SymVal (bv m)+ , n + 1 <= m+ , SIntegral (bv (m - n))+ , BVIsNonZero (m - n)+ ) => SBV (bv n) -- ^ Input, of size @n@+ -> SBV (bv m) -- ^ Output, of size @m@. @n < m@ must hold+zeroExtend n = SBV $ svZeroExtend i (unSBV n)+ where nv = intOfProxy (Proxy @n)+ mv = intOfProxy (Proxy @m)+ i = fromIntegral (mv - nv)++-- | Sign extend a bit-vector.+signExtend :: forall n m bv. ( KnownNat n, BVIsNonZero n, SymVal (bv n)+ , KnownNat m, BVIsNonZero m, SymVal (bv m)+ , n + 1 <= m+ , SFiniteBits (bv n)+ , SIntegral (bv (m - n))+ , BVIsNonZero (m - n)+ ) => SBV (bv n) -- ^ Input, of size @n@+ -> SBV (bv m) -- ^ Output, of size @m@. @n < m@ must hold+signExtend n = SBV $ svSignExtend i (unSBV n)+ where nv = intOfProxy (Proxy @n)+ mv = intOfProxy (Proxy @m)+ i = fromIntegral (mv - nv)+++-- | Finite bit-length symbolic values. Essentially the same as 'SIntegral', but further leaves out 'Integer'. Loosely+-- based on Haskell's @FiniteBits@ class, but with more methods defined and structured differently to fit into the+-- symbolic world view. Minimal complete definition: 'sFiniteBitSize'.+class (Ord a, SymVal a, Num a, Num (SBV a), OrdSymbolic (SBV a), Bits a) => SFiniteBits a where+ -- | Bit size.+ sFiniteBitSize :: SBV a -> Int+ -- | Least significant bit of a word, always stored at index 0.+ lsb :: SBV a -> SBool+ -- | Most significant bit of a word, always stored at the last position.+ msb :: SBV a -> SBool+ -- | Big-endian blasting of a word into its bits.+ blastBE :: SBV a -> [SBool]+ -- | Little-endian blasting of a word into its bits.+ blastLE :: SBV a -> [SBool]+ -- | Reconstruct from given bits, given in little-endian.+ fromBitsBE :: [SBool] -> SBV a+ -- | Reconstruct from given bits, given in little-endian.+ fromBitsLE :: [SBool] -> SBV a+ -- | Replacement for 'testBit', returning 'SBool' instead of 'Bool'.+ sTestBit :: SBV a -> Int -> SBool+ -- | Variant of 'sTestBit', where we want to extract multiple bit positions.+ sExtractBits :: SBV a -> [Int] -> [SBool]+ -- | Variant of 'popCount', returning a symbolic value.+ sPopCount :: SBV a -> SWord8+ -- | A combo of 'setBit' and 'clearBit', when the bit to be set is symbolic.+ setBitTo :: SBV a -> Int -> SBool -> SBV a+ -- | Variant of 'setBitTo' when the index is symbolic. If the index it out-of-bounds,+ -- then the result is underspecified.+ sSetBitTo :: Integral a => SBV a -> SBV a -> SBool -> SBV a+ -- | Full adder, returns carry-out from the addition. Only for unsigned quantities.+ fullAdder :: SBV a -> SBV a -> (SBool, SBV a)+ -- | Full multiplier, returns both high and low-order bits. Only for unsigned quantities.+ fullMultiplier :: SBV a -> SBV a -> (SBV a, SBV a)+ -- | Count leading zeros in a word, big-endian interpretation.+ sCountLeadingZeros :: SBV a -> SWord8+ -- | Count trailing zeros in a word, big-endian interpretation.+ sCountTrailingZeros :: SBV a -> SWord8++ {-# MINIMAL sFiniteBitSize #-}++ -- Default implementations+ lsb (SBV v) = SBV (svTestBit v 0)+ msb x = sTestBit x (sFiniteBitSize x - 1)++ blastBE = reverse . blastLE+ blastLE x = map (sTestBit x) [0 .. intSizeOf x - 1]++ fromBitsBE = fromBitsLE . reverse+ fromBitsLE bs+ | length bs /= w+ = error $ "SBV.SFiniteBits.fromBitsLE/BE: Expected: " ++ show w ++ " bits, received: " ++ show (length bs)+ | True+ = result+ where w = sFiniteBitSize result+ result = go 0 0 bs++ go !acc _ [] = acc+ go !acc !i (x:xs) = go (ite x (setBit acc i) acc) (i+1) xs++ sTestBit (SBV x) i = SBV (svTestBit x i)+ sExtractBits x = map (sTestBit x)++ -- NB. 'sPopCount' returns an 'SWord8', which can overflow when used on quantities that have+ -- more than 255 bits. For the regular interface, this suffices for all types we support.+ -- For the Dynamic interface, if we ever implement this, this will fail for bit-vectors+ -- larger than that many bits. The alternative would be to return SInteger here, but that+ -- seems a total overkill for most use cases. If such is required, users are encouraged+ -- to define their own variants, which is rather easy.+ sPopCount x+ | Just v <- unliteral x = go 0 v+ | True = sum [ite b 1 0 | b <- blastLE x]+ where -- concrete case+ go !c 0 = c+ go !c w = go (c+1) (w .&. (w-1))++ setBitTo x i b = ite b (setBit x i) (clearBit x i)++ sSetBitTo x idx b+ | Just i <- unliteral idx, Just index <- safe i+ = setBitTo x index b+ | True+ = go x [0 .. sFiniteBitSize x - 1]+ where -- paranoia check: make sure index can fit in an int+ safe i = let asInteger = toInteger i+ asInt = fromIntegral asInteger+ backInteger = toInteger asInt+ in if backInteger == asInteger+ then Just asInt+ else Nothing++ go v [] = v+ go v (i:is) = go (ite (idx .== literal (fromIntegral i)) (setBitTo v (fromIntegral i) b) v) is++ fullAdder a b+ | isSigned a = error "fullAdder: only works on unsigned numbers"+ | True = (a .> s .|| b .> s, s)+ where s = a + b++ -- N.B. The higher-order bits are determined using a simple shift-add multiplier,+ -- thus involving bit-blasting. It'd be naive to expect SMT solvers to deal efficiently+ -- with properties involving this function, at least with the current state of the art.+ fullMultiplier a b+ | isSigned a = error "fullMultiplier: only works on unsigned numbers"+ | True = (go (sFiniteBitSize a) 0 a, a*b)+ where go 0 p _ = p+ go n p x = let (c, p') = ite (lsb x) (fullAdder p b) (sFalse, p)+ (o, p'') = shiftIn c p'+ (_, x') = shiftIn o x+ in go (n-1) p'' x'+ shiftIn k v = (lsb v, mask .|. (v `shiftR` 1))+ where mask = ite k (bit (sFiniteBitSize v - 1)) 0++ -- See the note for 'sPopCount' for a comment on why we return 'SWord8'+ sCountLeadingZeros x = fromIntegral m - go m+ where m = sFiniteBitSize x - 1++ -- NB. When i is 0 below, which happens when x is 0 as we count all the way down,+ -- we return -1, which is equal to 2^n-1, giving us: n-1-(2^n-1) = n-2^n = n, as required, i.e., the bit-size.+ go :: Int -> SWord8+ go i | i < 0 = i8+ | True = ite (sTestBit x i) i8 (go (i-1))+ where i8 = literal (fromIntegral i :: Word8)++ -- See the note for 'sPopCount' for a comment on why we return 'SWord8'+ sCountTrailingZeros x = go 0+ where m = sFiniteBitSize x++ go :: Int -> SWord8+ go i | i >= m = i8+ | True = ite (sTestBit x i) i8 (go (i+1))+ where i8 = literal (fromIntegral i :: Word8)++-- 'SFiniteBits' Instances, skips Real/Float/Bool/Integer+instance SFiniteBits Word8 where sFiniteBitSize _ = 8+instance SFiniteBits Word16 where sFiniteBitSize _ = 16+instance SFiniteBits Word32 where sFiniteBitSize _ = 32+instance SFiniteBits Word64 where sFiniteBitSize _ = 64+instance SFiniteBits Int8 where sFiniteBitSize _ = 8+instance SFiniteBits Int16 where sFiniteBitSize _ = 16+instance SFiniteBits Int32 where sFiniteBitSize _ = 32+instance SFiniteBits Int64 where sFiniteBitSize _ = 64+instance (KnownNat n, BVIsNonZero n) => SFiniteBits (WordN n) where sFiniteBitSize _ = intOfProxy (Proxy @n)+instance (KnownNat n, BVIsNonZero n) => SFiniteBits (IntN n) where sFiniteBitSize _ = intOfProxy (Proxy @n)++-- | Returns 1 if the boolean is 'sTrue', otherwise 0.+oneIf :: (Ord a, Num (SBV a), SymVal a) => SBool -> SBV a+oneIf t = ite t 1 0++-- | Lift a pseudo-boolean op, performing checks+liftPB :: String -> PBOp -> [SBool] -> SBool+liftPB w o xs+ | Just e <- check o+ = error $ "SBV." ++ w ++ ": " ++ e+ | True+ = result+ where check (PB_AtMost k) = pos k+ check (PB_AtLeast k) = pos k+ check (PB_Exactly k) = pos k+ check (PB_Le cs k) = pos k `mplus` match cs+ check (PB_Ge cs k) = pos k `mplus` match cs+ check (PB_Eq cs k) = pos k `mplus` match cs++ pos k+ | k < 0 = Just $ "comparison value must be positive, received: " ++ show k+ | True = Nothing++ match cs+ | any (< 0) cs = Just $ "coefficients must be non-negative. Received: " ++ show cs+ | lxs /= lcs = Just $ "coefficient length must match number of arguments. Received: " ++ show (lcs, lxs)+ | True = Nothing+ where lxs = length xs+ lcs = length cs++ result = SBV (SVal KBool (Right (cache r)))+ r st = do xsv <- mapM (sbvToSV st) xs+ -- PseudoBoolean's implicitly require support for integers, so make sure to register that kind!+ registerKind st KUnbounded+ newExpr st KBool (SBVApp (PseudoBoolean o) xsv)++-- | 'sTrue' if at most @k@ of the input arguments are 'sTrue'+pbAtMost :: [SBool] -> Int -> SBool+pbAtMost xs k+ | k < 0 = error $ "SBV.pbAtMost: Non-negative value required, received: " ++ show k+ | all isConcrete xs = literal $ sum (map (pbToInteger "pbAtMost" 1) xs) <= fromIntegral k+ | True = liftPB "pbAtMost" (PB_AtMost k) xs++-- | 'sTrue' if at least @k@ of the input arguments are 'sTrue'+pbAtLeast :: [SBool] -> Int -> SBool+pbAtLeast xs k+ | k < 0 = error $ "SBV.pbAtLeast: Non-negative value required, received: " ++ show k+ | all isConcrete xs = literal $ sum (map (pbToInteger "pbAtLeast" 1) xs) >= fromIntegral k+ | True = liftPB "pbAtLeast" (PB_AtLeast k) xs++-- | 'sTrue' if exactly @k@ of the input arguments are 'sTrue'+pbExactly :: [SBool] -> Int -> SBool+pbExactly xs k+ | k < 0 = error $ "SBV.pbExactly: Non-negative value required, received: " ++ show k+ | all isConcrete xs = literal $ sum (map (pbToInteger "pbExactly" 1) xs) == fromIntegral k+ | True = liftPB "pbExactly" (PB_Exactly k) xs++-- | 'sTrue' if the sum of coefficients for 'sTrue' elements is at most @k@. Generalizes 'pbAtMost'.+pbLe :: [(Int, SBool)] -> Int -> SBool+pbLe xs k+ | k < 0 = error $ "SBV.pbLe: Non-negative value required, received: " ++ show k+ | all (isConcrete . snd) xs = literal $ sum [pbToInteger "pbLe" c b | (c, b) <- xs] <= fromIntegral k+ | True = liftPB "pbLe" (PB_Le (map fst xs) k) (map snd xs)++-- | 'sTrue' if the sum of coefficients for 'sTrue' elements is at least @k@. Generalizes 'pbAtLeast'.+pbGe :: [(Int, SBool)] -> Int -> SBool+pbGe xs k+ | k < 0 = error $ "SBV.pbGe: Non-negative value required, received: " ++ show k+ | all (isConcrete . snd) xs = literal $ sum [pbToInteger "pbGe" c b | (c, b) <- xs] >= fromIntegral k+ | True = liftPB "pbGe" (PB_Ge (map fst xs) k) (map snd xs)++-- | 'sTrue' if the sum of coefficients for 'sTrue' elements is exactly least @k@. Useful for coding+-- /exactly K-of-N/ constraints, and in particular mutex constraints.+pbEq :: [(Int, SBool)] -> Int -> SBool+pbEq xs k+ | k < 0 = error $ "SBV.pbEq: Non-negative value required, received: " ++ show k+ | all (isConcrete . snd) xs = literal $ sum [pbToInteger "pbEq" c b | (c, b) <- xs] == fromIntegral k+ | True = liftPB "pbEq" (PB_Eq (map fst xs) k) (map snd xs)++-- | 'sTrue' if there is at most one set bit+pbMutexed :: [SBool] -> SBool+pbMutexed xs = pbAtMost xs 1++-- | 'sTrue' if there is exactly one set bit+pbStronglyMutexed :: [SBool] -> SBool+pbStronglyMutexed xs = pbExactly xs 1++-- | Convert a concrete pseudo-boolean to given int; converting to integer+pbToInteger :: String -> Int -> SBool -> Integer+pbToInteger w c b+ | c < 0 = error $ "SBV." ++ w ++ ": Non-negative coefficient required, received: " ++ show c+ | Just v <- unliteral b = if v then fromIntegral c else 0+ | True = error $ "SBV.pbToInteger: Received a symbolic boolean: " ++ show (c, b)++-- | Predicate for optimizing word operations like (+) and (*).+isConcreteZero :: SBV a -> Bool+isConcreteZero (SBV (SVal _ (Left (CV _ (CInteger n))))) = n == 0+isConcreteZero (SBV (SVal KReal (Left (CV KReal (CAlgReal v))))) = isExactRational v && v == 0+isConcreteZero _ = False++-- | Predicate for optimizing word operations like (+) and (*).+isConcreteOne :: SBV a -> Bool+isConcreteOne (SBV (SVal _ (Left (CV _ (CInteger 1))))) = True+isConcreteOne (SBV (SVal KReal (Left (CV KReal (CAlgReal v))))) = isExactRational v && v == 1+isConcreteOne _ = False++-- | Symbolic exponentiation using bit blasting and repeated squaring.+--+-- N.B. The exponent must be unsigned/bounded if symbolic. Signed exponents will be rejected.+(.^) :: (Mergeable b, Num b, SIntegral e) => b -> SBV e -> b+b .^ e+ | isConcrete e, Just (x :: Integer) <- unliteral (sFromIntegral e)+ = if x >= 0 then let go n v+ | n == 0 = 1+ | even n = go (n `div` 2) (v * v)+ | True = v * go (n `div` 2) (v * v)+ in go x b+ else error $ "(.^): exponentiation: negative exponent: " ++ show x+ | not (isBounded e) || isSigned e+ = error $ "(.^): exponentiation only works with unsigned bounded symbolic exponents, kind: " ++ show (kindOf e)+ | True+ = -- NB. We can't simply use sTestBit and blastLE since they have SFiniteBit requirement+ -- but we want to have SIntegral here only.+ let SBV expt = e+ expBit i = SBV (svTestBit expt i)+ blasted = map expBit [0 .. intSizeOf e - 1]+ in product $ zipWith (\use n -> ite use n 1)+ blasted+ (iterate (\x -> x*x) b)+infixr 8 .^++instance (Ord a, Num (SBV a), SymVal a, Fractional a) => Fractional (SBV a) where+ fromRational = literal . fromRational+ SBV x / sy@(SBV y) | div0 = ite (sy .== 0) 0 res+ | True = res+ where res = SBV (svDivide x y)+ -- Identify those kinds where we have a div-0 equals 0 exception+ div0 = case kindOf sy of+ KVar{} -> error $ "Unexpected Fractional case for: " ++ show (kindOf sy)+ KFloat -> False+ KDouble -> False+ KFP{} -> False+ KReal -> True+ KRational -> True+ -- Following cases should not happen since these types should *not* be instances of Fractional+ k@KBounded{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KUnbounded -> error $ "Unexpected Fractional case for: " ++ show k+ k@KBool -> error $ "Unexpected Fractional case for: " ++ show k+ k@KString -> error $ "Unexpected Fractional case for: " ++ show k+ k@KChar -> error $ "Unexpected Fractional case for: " ++ show k+ k@KList{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KSet{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KApp{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KADT{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KTuple{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KArray{} -> error $ "Unexpected Fractional case for: " ++ show k++-- | Define Floating instance on SBV's; only for base types that are already floating; i.e., 'SFloat', 'SDouble', and 'SReal'.+-- (See the separate definition below for 'SFloatingPoint'.) Note that unless you use delta-sat via 'Data.SBV.Provers.dReal' on 'SReal', most+-- of the fields are "undefined" for symbolic values. We will add methods as they are supported by SMTLib. Currently, the+-- only symbolically available function in this class is 'sqrt' for 'SFloat', 'SDouble' and 'SFloatingPoint'.+instance (Ord a, Num (SBV a), SymVal a, Fractional a, Floating a) => Floating (SBV a) where+ pi = fromRational . toRational $ (pi :: Double)+ exp = lift1FNS "exp" exp+ log = lift1FNS "log" log+ sqrt = lift1F FP_Sqrt sqrt+ sin = lift1FNS "sin" sin+ cos = lift1FNS "cos" cos+ tan = lift1FNS "tan" tan+ asin = lift1FNS "asin" asin+ acos = lift1FNS "acos" acos+ atan = lift1FNS "atan" atan+ sinh = lift1FNS "sinh" sinh+ cosh = lift1FNS "cosh" cosh+ tanh = lift1FNS "tanh" tanh+ asinh = lift1FNS "asinh" asinh+ acosh = lift1FNS "acosh" acosh+ atanh = lift1FNS "atanh" atanh+ (**) = lift2FNS "**" (**)+ logBase = lift2FNS "logBase" logBase++unsupported :: String -> a+unsupported w = error $ "Data.SBV.FloatingPoint: Unsupported operation: " ++ w ++ ". Please request this as a feature!"++-- | We give a specific instance for 'SFloatingPoint', because the underlying floating-point type doesn't support+-- fromRational directly. The overlap with the above instance is unfortunate.+instance {-# OVERLAPPING #-} ValidFloat eb sb => Floating (SFloatingPoint eb sb) where+ -- Try from double; if there's enough precision this'll work, otherwise will bail out.+ pi+ | ei > 11 || si > 53 = unsupported $ "Floating.SFloatingPoint.pi (not-enough-precision for " ++ show (ei, si) ++ ")"+ | True = literal $ FloatingPoint $ fpFromRational ei si (toRational (pi :: Double))+ where ei = intOfProxy (Proxy @eb)+ si = intOfProxy (Proxy @sb)++ -- Likewise, exponentiation is again limited to precision of double+ exp i+ | ei > 11 || si > 53 = unsupported $ "Floating.SFloatingPoint.exp (not-enough-precision for " ++ show (ei, si) ++ ")"+ | True = literal e ** i+ where ei = intOfProxy (Proxy @eb)+ si = intOfProxy (Proxy @sb)+ e = FloatingPoint $ fpFromRational ei si (toRational (exp 1 :: Double))++ log = lift1FNS "log" log+ sqrt = lift1F FP_Sqrt sqrt+ sin = lift1FNS "sin" sin+ cos = lift1FNS "cos" cos+ tan = lift1FNS "tan" tan+ asin = lift1FNS "asin" asin+ acos = lift1FNS "acos" acos+ atan = lift1FNS "atan" atan+ sinh = lift1FNS "sinh" sinh+ cosh = lift1FNS "cosh" cosh+ tanh = lift1FNS "tanh" tanh+ asinh = lift1FNS "asinh" asinh+ acosh = lift1FNS "acosh" acosh+ atanh = lift1FNS "atanh" atanh+ (**) = lift2FNS "**" (**)+ logBase = lift2FNS "logBase" logBase++-- | Lift a 1 arg FP-op, using sRNE default+lift1F :: SymVal a => FPOp -> (a -> a) -> SBV a -> SBV a+lift1F w op a+ | Just v <- unliteral a+ = literal $ op v+ | True+ = SBV $ SVal k $ Right $ cache r+ where k = kindOf a+ r st = do swa <- sbvToSV st a+ swm <- sbvToSV st sRNE+ newExpr st k (SBVApp (IEEEFP w) [swm, swa])++-- | Lift a float/double unary function, only over constants+lift1FNS :: (SymVal a, Floating a) => String -> (a -> a) -> SBV a -> SBV a+lift1FNS nm f sv+ | Just v <- unliteral sv = literal $ f v+ | True = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv)++-- | Lift a float/double binary function, only over constants+lift2FNS :: (SymVal a, Floating a) => String -> (a -> a -> a) -> SBV a -> SBV a -> SBV a+lift2FNS nm f sv1 sv2+ | Just v1 <- unliteral sv1+ , Just v2 <- unliteral sv2 = literal $ f v1 v2+ | True = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv1)++-- | SReal Floating instance, used in conjunction with the dReal solver for delta-satisfiability. Note that+-- we do not constant fold these values (except for pi), as Haskell doesn't really have any means of computing+-- them for arbitrary rationals.+instance {-# OVERLAPPING #-} Floating SReal where+ -- Should we support pi? It's a transcendental value, and our SReal type has no way of representing+ -- this quantity with the required fidelity. (SReal can only support roots of polynomials and rationals+ -- correctly, not transcendentals.) One option is to use an approximation here. But that goes against the+ -- whole idea of Real being infinitely precise. Another option is to see if the solver has support for it, such+ -- as CVC5, which has the constant real.pi. Alas, that has its problems: In models CVC5 uses real.pi as a+ -- model value, which we have no way of properly supporting back as a Haskell value. Worse: It uses it in+ -- expressions like 1 + real.pi, which we don't have an evaluator for. So, we simply say not supported.+ -- If you want it for reals, you'll have to plugin your own "approximation" for it, and thus be aware of the+ -- limitations of that choice.+ pi = error $ unlines [ ""+ , "*** Data.SBV.SReal: Cannot represent pi as an SReal value."+ , "***"+ , "*** Usual trick is to use an approximation if that suits your purpose,"+ , "*** or use solver-specific constants when applicable. Please get in touch"+ , "*** if you'd like to explore ideas here."+ ]++ exp = lift1SReal NR_Exp+ log = lift1SReal NR_Log+ sqrt = lift1SReal NR_Sqrt+ sin = lift1SReal NR_Sin+ cos = lift1SReal NR_Cos+ tan = lift1SReal NR_Tan+ asin = lift1SReal NR_ASin+ acos = lift1SReal NR_ACos+ atan = lift1SReal NR_ATan+ sinh = lift1SReal NR_Sinh+ cosh = lift1SReal NR_Cosh+ tanh = lift1SReal NR_Tanh+ asinh = error "Data.SBV.SReal: asinh is currently not supported. Please request this as a feature!"+ acosh = error "Data.SBV.SReal: acosh is currently not supported. Please request this as a feature!"+ atanh = error "Data.SBV.SReal: atanh is currently not supported. Please request this as a feature!"+ (**) = lift2SReal NR_Pow++ logBase x y = log y / log x++-- | Lift an sreal unary function+lift1SReal :: NROp -> SReal -> SReal+lift1SReal w a = SBV $ SVal k $ Right $ cache r+ where k = kindOf a+ r st = do swa <- sbvToSV st a+ newExpr st k (SBVApp (NonLinear w) [swa])++-- | Lift an sreal binary function+lift2SReal :: NROp -> SReal -> SReal -> SReal+lift2SReal w a b = SBV $ SVal k $ Right $ cache r+ where k = kindOf a+ r st = do swa <- sbvToSV st a+ swb <- sbvToSV st b+ newExpr st k (SBVApp (NonLinear w) [swa, swb])++-- Bail out nicely.+noEquals :: String -> String -> (String, String) -> a+noEquals o n (l, r) = error $ unlines [ ""+ , "*** Data.SBV: Comparing symbolic values using Haskell's Eq class!"+ , "***"+ , "*** Received: (" ++ l ++ ") " ++ o ++ " (" ++ r ++ ")"+ , "*** Instead use: (" ++ l ++ ") " ++ n ++ " (" ++ r ++ ")"+ , "***"+ , "*** The Eq instance for symbolic values are necessiated only because"+ , "*** of the Bits class requirement. You must use symbolic equality"+ , "*** operators instead. (And complain to Haskell folks that they"+ , "*** remove the 'Eq' superclass from 'Bits'!.)"+ ]++-- | This instance is only defined so that we can define an instance for+-- 'Data.Bits.Bits'. '==' and '/=' simply throw an error. Use+-- 'Data.SBV.EqSymbolic' instead.+instance SymVal a => Eq (SBV a) where+ a == b = fromMaybe (noEquals "==" ".==" (show a, show b)) (unliteral (a .== b))+ a /= b = fromMaybe (noEquals "/=" "./=" (show a, show b)) (unliteral (a ./= b))++-- NB. In the optimizations below, use of -1 is valid as+-- -1 has all bits set to True for both signed and unsigned values+-- | Using 'popCount' or 'testBit' on non-concrete values will result in an+-- error. Use 'sPopCount' or 'sTestBit' instead.+instance (Ord a, Num (SBV a), Num a, Bits a, SymVal a) => Bits (SBV a) where+ SBV x .&. SBV y = SBV (svAnd x y)+ SBV x .|. SBV y = SBV (svOr x y)+ SBV x `xor` SBV y = SBV (svXOr x y)+ complement (SBV x) = SBV (svNot x)+ bitSize x = intSizeOf x+ bitSizeMaybe x = Just $ intSizeOf x+ isSigned x = hasSign x+ bit i = 1 `shiftL` i+ setBit x i = x .|. genLiteral (kindOf x) (bit i :: Integer)+ clearBit x i = x .&. genLiteral (kindOf x) (complement (bit i) :: Integer)+ complementBit x i = x `xor` genLiteral (kindOf x) (bit i :: Integer)+ shiftL (SBV x) i = SBV (svShl x i)+ shiftR (SBV x) i = SBV (svShr x i)+ rotateL (SBV x) i = SBV (svRol x i)+ rotateR (SBV x) i = SBV (svRor x i)+ -- NB. testBit is *not* implementable on non-concrete symbolic words+ x `testBit` i+ | SBV (SVal _ (Left (CV _ (CInteger n)))) <- x+ = testBit n i+ | True+ = error $ "SBV.testBit: Called on symbolic value: " ++ show x ++ ". Use sTestBit instead."+ -- NB. popCount is *not* implementable on non-concrete symbolic words+ popCount x+ | SBV (SVal _ (Left (CV (KBounded _ w) (CInteger n)))) <- x+ = popCount (n .&. (bit w - 1))+ | True+ = error $ "SBV.popCount: Called on symbolic value: " ++ show x ++ ". Use sPopCount instead."++-- | Conversion between integral-symbolic values, akin to Haskell's `fromIntegral`+sFromIntegral :: forall a b. (Integral a, HasKind a, Num a, SymVal a, HasKind b, Num b, SymVal b) => SBV a -> SBV b+sFromIntegral x+ | kFrom == kTo+ = SBV (unSBV x)+ | isReal x+ = error "SBV.sFromIntegral: Called on a real value" -- can't really happen due to types, but being overcautious+ | Just v <- unliteral x+ = literal (fromIntegral v)+ | True+ = result+ where result = SBV (SVal kTo (Right (cache y)))+ kFrom = kindOf x+ kTo = kindOf (Proxy @b)+ y st = do xsv <- sbvToSV st x+ newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsv])++-- | Lift a binary operation thru its dynamic counterpart. Note that+-- we still want the actual functions here as differ in their type+-- compared to their dynamic counterparts, but the implementations+-- are the same.+liftViaSVal :: (SVal -> SVal -> SVal) -> SBV a -> SBV b -> SBV c+liftViaSVal f (SBV a) (SBV b) = SBV $ f a b++-- | Generalization of 'shiftL', when the shift-amount is symbolic. Since Haskell's+-- 'shiftL' only takes an 'Int' as the shift amount, it cannot be used when we have+-- a symbolic amount to shift with.+sShiftLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a+sShiftLeft = liftViaSVal svShiftLeft++-- | Generalization of 'shiftR', when the shift-amount is symbolic. Since Haskell's+-- 'shiftR' only takes an 'Int' as the shift amount, it cannot be used when we have+-- a symbolic amount to shift with.+--+-- NB. If the shiftee is signed, then this is an arithmetic shift; otherwise it's logical,+-- following the usual Haskell convention. See 'sSignedShiftArithRight' for a variant+-- that explicitly uses the msb as the sign bit, even for unsigned underlying types.+sShiftRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a+sShiftRight = liftViaSVal svShiftRight++-- | Arithmetic shift-right with a symbolic unsigned shift amount. This is equivalent+-- to 'sShiftRight' when the argument is signed. However, if the argument is unsigned,+-- then it explicitly treats its msb as a sign-bit, and uses it as the bit that+-- gets shifted in. Useful when using the underlying unsigned bit representation to implement+-- custom signed operations. Note that there is no direct Haskell analogue of this function.+sSignedShiftArithRight:: (SFiniteBits a, SIntegral b) => SBV a -> SBV b -> SBV a+sSignedShiftArithRight x i+ | isSigned i = error "sSignedShiftArithRight: shift amount should be unsigned"+ | isSigned x = ssa x i+ | True = ite (msb x)+ (complement (ssa (complement x) i))+ (ssa x i)+ where ssa = liftViaSVal svShiftRight++-- | Generalization of 'rotateL', when the shift-amount is symbolic. Since Haskell's+-- 'rotateL' only takes an 'Int' as the shift amount, it cannot be used when we have+-- a symbolic amount to shift with. The first argument should be a bounded quantity.+sRotateLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a+sRotateLeft = liftViaSVal svRotateLeft++-- | An implementation of rotate-left, using a barrel shifter like design. Only works when both+-- arguments are finite bit-vectors, and furthermore when the second argument is unsigned.+-- The first condition is enforced by the type, but the second is dynamically checked.+-- We provide this implementation as an alternative to `sRotateLeft` since SMTLib logic+-- does not support variable argument rotates (as opposed to shifts), and thus this+-- implementation can produce better code for verification compared to `sRotateLeft`.+sBarrelRotateLeft :: (SFiniteBits a, SFiniteBits b) => SBV a -> SBV b -> SBV a+sBarrelRotateLeft = liftViaSVal svBarrelRotateLeft++-- | Generalization of 'rotateR', when the shift-amount is symbolic. Since Haskell's+-- 'rotateR' only takes an 'Int' as the shift amount, it cannot be used when we have+-- a symbolic amount to shift with. The first argument should be a bounded quantity.+sRotateRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a+sRotateRight = liftViaSVal svRotateRight++-- | An implementation of rotate-right, using a barrel shifter like design. See comments+-- for `sBarrelRotateLeft` for details.+sBarrelRotateRight :: (SFiniteBits a, SFiniteBits b) => SBV a -> SBV b -> SBV a+sBarrelRotateRight = liftViaSVal svBarrelRotateRight++-- | 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 = 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.+-- However, 'quotRem' and 'divMod' both make perfect sense, and the 'SDivisible' class captures+-- this operation. One issue is how division by 0 behaves. The verification+-- technology requires total functions, and there are several design choices+-- here. We follow Isabelle/HOL approach of assigning the value 0 for division+-- by 0. Therefore, we impose the following pair of laws:+--+-- @+-- x `sQuotRem` 0 = (0, x)+-- x `sDivMod` 0 = (0, x)+-- @+--+-- Note that our instances implement this law even when @x@ is @0@ itself.+--+-- NB. 'sQuot' truncates toward zero (i.e., it implements truncating division),+-- while 'sDiv' truncates toward negative infinity (i.e., it implements+-- flooring division). These match the conventions of Haskell's 'quot' and+-- 'div' functions, respectively.+--+-- Similarly, 'sRem' and 'sMod' match the conventions of Haskell's 'rem' and+-- 'mod' functions, respectively. That is:+--+-- @+-- (x `sQuot` y)*y + (x `sRem` y) .== x+-- (x `sDiv` y)*y + (x `sMod` y) .== x+-- @+--+-- === C code generation of division operations+--+-- In the case of division or modulo of a minimal signed value (e.g. @-128@ for+-- 'SInt8') by @-1@, SMTLIB and Haskell agree on what the result should be.+-- Unfortunately the result in C code depends on CPU architecture and compiler+-- settings, as this is undefined behaviour in C. **SBV does not guarantee**+-- what will happen in generated C code in this corner case.+class SDivisible a where+ sQuotRem :: a -> a -> (a, a)+ sDivMod :: a -> a -> (a, a)+ sQuot :: a -> a -> a+ sRem :: a -> a -> a+ sDiv :: a -> a -> a+ sMod :: a -> a -> a++ {-# MINIMAL sQuotRem, sDivMod #-}++ x `sQuot` y = fst $ x `sQuotRem` y+ x `sRem` y = snd $ x `sQuotRem` y+ x `sDiv` y = fst $ x `sDivMod` y+ x `sMod` y = snd $ x `sDivMod` y++instance SDivisible Word64 where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++instance SDivisible Int64 where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++instance SDivisible Word32 where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++instance SDivisible Int32 where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++instance SDivisible Word16 where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++instance SDivisible Int16 where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++instance SDivisible Word8 where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++instance SDivisible Int8 where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++instance SDivisible Integer where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++instance SDivisible CV where+ sQuotRem a b+ | CInteger x <- cvVal a, CInteger y <- cvVal b+ = let (r1, r2) = sQuotRem x y in (normCV a{ cvVal = CInteger r1 }, normCV b{ cvVal = CInteger r2 })+ sQuotRem a b = error $ "SBV.sQuotRem: impossible, unexpected args received: " ++ show (a, b)+ sDivMod a b+ | CInteger x <- cvVal a, CInteger y <- cvVal b+ = let (r1, r2) = sDivMod x y in (normCV a{ cvVal = CInteger r1 }, normCV b{ cvVal = CInteger r2 })+ sDivMod a b = error $ "SBV.sDivMod: impossible, unexpected args received: " ++ show (a, b)++instance SDivisible SWord64 where {sQuotRem = liftQRem; sDivMod = liftDMod}+instance SDivisible SWord32 where {sQuotRem = liftQRem; sDivMod = liftDMod}+instance SDivisible SWord16 where {sQuotRem = liftQRem; sDivMod = liftDMod}+instance SDivisible SWord8 where {sQuotRem = liftQRem; sDivMod = liftDMod}+instance SDivisible SInt64 where {sQuotRem = liftQRem; sDivMod = liftDMod}+instance SDivisible SInt32 where {sQuotRem = liftQRem; sDivMod = liftDMod}+instance SDivisible SInt16 where {sQuotRem = liftQRem; sDivMod = liftDMod}+instance SDivisible SInt8 where {sQuotRem = liftQRem; sDivMod = liftDMod}++-- | 'SDivisible' instance for 'WordN'+instance (KnownNat n, BVIsNonZero n) => SDivisible (WordN n) where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++-- | 'SDivisible' instance for 'IntN'+instance (KnownNat n, BVIsNonZero n) => SDivisible (IntN n) where+ sQuotRem x 0 = (0, x)+ sQuotRem x y = x `quotRem` y+ sDivMod x 0 = (0, x)+ sDivMod x y = x `divMod` y++-- | 'SDivisible' instance for 'SWord'+instance (KnownNat n, BVIsNonZero n) => SDivisible (SWord n) where+ sQuotRem = liftQRem+ sDivMod = liftDMod++-- | 'SDivisible' instance for 'SInt'+instance (KnownNat n, BVIsNonZero n) => SDivisible (SInt n) where+ sQuotRem = liftQRem+ sDivMod = liftDMod++-- | Does the concrete positive number n divide the given integer?+sDivides :: Integer -> SInteger -> SBool+sDivides n v+ | n < 0+ = error $ "svDivides: First argument must be a strictly positive integer. Received: " ++ show n+ | Just x <- unliteral v+ = if x `mod` n == 0 then sTrue else sFalse+ | True+ = SBV $ svDivides n (unSBV v)++-- | Lift 'quotRem' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which+-- holds even when @x@ is @0@ itself.+liftQRem :: (Eq a, SymVal a) => SBV a -> SBV a -> (SBV a, SBV a)+liftQRem x y+ | isConcreteZero x+ = (x, x)+ | isConcreteOne y+ = (x, z)+{-------------------------------+ - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed;+ - and also is problematic around the minBound.. So, we refrain from that optimization+ | isConcreteOnes y+ = (-x, z)+--------------------------------}+ | True+ = ite (y .== z) (z, x) (qr x y)+ where qr (SBV (SVal sgnsz (Left a))) (SBV (SVal _ (Left b))) = let (q, r) = sQuotRem a b in (SBV (SVal sgnsz (Left q)), SBV (SVal sgnsz (Left r)))+ qr a@(SBV (SVal sgnsz _)) b = (SBV (SVal sgnsz (Right (cache (mk Quot)))), SBV (SVal sgnsz (Right (cache (mk Rem)))))+ where mk o st = do sw1 <- sbvToSV st a+ sw2 <- sbvToSV st b+ mkSymOp o st sgnsz sw1 sw2+ z = genLiteral (kindOf x) (0::Integer)++-- | Lift 'divMod' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which+-- holds even when @x@ is @0@ itself. Essentially, this is conversion from quotRem+-- (truncate to 0) to divMod (truncate towards negative infinity)+liftDMod :: (Ord a, SymVal a, Num a, Num (SBV a), SDivisible (SBV a)) => SBV a -> SBV a -> (SBV a, SBV a)+liftDMod x y+ | isConcreteZero x+ = (x, x)+ | isConcreteOne y+ = (x, z)+{-------------------------------+ - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed;+ - and also is problematic around the minBound.. So, we refrain from that optimization+ | isConcreteOnes y+ = (-x, z)+--------------------------------}+ | True+ = ite (y .== z) (z, x) $ ite (signum r .== negate (signum y)) (q-i, r+y) qr+ where qr@(q, r) = x `sQuotRem` y+ z = genLiteral (kindOf x) (0::Integer)+ i = genLiteral (kindOf x) (1::Integer)++-- SInteger instance for quotRem/divMod are tricky!+-- SMT-Lib only has Euclidean operations, but Haskell+-- 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 x y = ite (y .> 0) (sEDivMod x y) (liftDMod x y)+ sQuotRem x y+ | not (isSymbolic x || isSymbolic y)+ = liftQRem x y+ | True+ = ite (y .== 0) (0, x) (qE+i, rE-i*y)+ where (qE, rE) = liftQRem x y -- for integers, this is euclidean due to SMTLib semantics+ i = ite (x .>= 0 .|| rE .== 0) 0+ $ ite (y .> 0) 1 (-1)++-- | Euclidian division and modulus.+sEDivMod :: SInteger -> SInteger -> (SInteger, SInteger)+sEDivMod a b = (a `sEDiv` b, a `sEMod` b)++-- | Euclidian division. Note that unlike regular division, Euclidian division by @0@+-- is unconstrained. i.e., it can take any value whatsoever.+sEDiv :: SInteger -> SInteger -> SInteger+sEDiv (SBV a) (SBV b) = SBV $ a `svQuot` b++-- | Euclidian modulus. Note that unlike regular modulus, Euclidian division by @0@+-- is unconstrained. i.e., it can take any value whatsoever.+sEMod :: SInteger -> SInteger -> SInteger+sEMod (SBV a) (SBV b) = SBV $ a `svRem` b++-- Quickcheck interface+instance (SymVal a, Arbitrary a) => Arbitrary (SBV a) where+ arbitrary = literal <$> arbitrary++-- | Symbolic conditionals are modeled by the 'Mergeable' class, describing+-- how to merge the results of an if-then-else call with a symbolic test. SBV+-- provides all basic types as instances of this class, so users only need+-- to declare instances for custom data-types of their programs as needed.+--+-- A 'Mergeable' instance may be automatically derived for a custom data-type+-- with a single constructor where the type of each field is an instance of+-- 'Mergeable', such as a record of symbolic values. Users only need to add+-- 'G.Generic' and 'Mergeable' to the @deriving@ clause for the data-type. See+-- 'Documentation.SBV.Examples.Puzzles.U2Bridge.Status' for an example and an+-- illustration of what the instance would look like if written by hand.+--+-- The function 'select' is a total-indexing function out of a list of choices+-- with a default value, simulating array/list indexing. It's an n-way generalization+-- of the 'ite' function.+--+-- Minimal complete definition: None, if the type is instance of @Generic@. Otherwise+-- 'symbolicMerge'. Note that most types subject to merging are likely to be+-- trivial instances of @Generic@.+class Mergeable a where+ -- | Merge two values based on the condition. The first argument states+ -- whether we force the then-and-else branches before the merging, at the+ -- word level. This is an efficiency concern; one that we'd rather not+ -- make but unfortunately necessary for getting symbolic simulation+ -- working efficiently.+ symbolicMerge :: Bool -> SBool -> a -> a -> a++ -- | Total indexing operation. @select xs default index@ is intuitively+ -- the same as @xs !! index@, except it evaluates to @default@ if @index@+ -- underflows/overflows.+ select :: (Ord b, SymVal b, Num b, Num (SBV b), OrdSymbolic (SBV b)) => [a] -> a -> SBV b -> a++ -- NB. Earlier implementation of select used the binary-search trick+ -- on the index to chop down the search space. While that is a good trick+ -- in general, it doesn't work for SBV since we do not have any notion of+ -- "concrete" subwords: If an index is symbolic, then all its bits are+ -- symbolic as well. So, the binary search only pays off only if the indexed+ -- list is really humongous, which is not very common in general. (Also,+ -- for the case when the list is bit-vectors, we use SMT tables anyhow.)+ select xs err ind+ | isReal ind = bad "real"+ | isFloat ind = bad "float"+ | isDouble ind = bad "double"+ | hasSign ind = ite (ind .< 0) err (walk xs ind err)+ | True = walk xs ind err+ where bad w = error $ "SBV.select: unsupported " ++ w ++ " valued select/index expression"+ walk [] _ acc = acc+ walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc)++ -- Default implementation for 'symbolicMerge' if the type is 'Generic'+ default symbolicMerge :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a+ symbolicMerge = symbolicMergeDefault++-- | If-then-else. This is by definition 'symbolicMerge' with both+-- branches forced. This is typically the desired behavior, but also+-- see 'iteLazy' should you need more laziness.+ite :: Mergeable a => SBool -> a -> a -> a+ite t a b+ | Just r <- unliteral t = if r then a else b+ | True = symbolicMerge True t a b++-- | A Lazy version of ite, which does not force its arguments. This might+-- cause issues for symbolic simulation with large thunks around, so use with+-- care.+iteLazy :: Mergeable a => SBool -> a -> a -> a+iteLazy t a b+ | Just r <- unliteral t = if r then a else b+ | True = symbolicMerge False t a b++-- | Symbolic assert. Check that the given boolean condition is always 'sTrue' in the given path. The+-- optional first argument can be used to provide call-stack info via GHC's location facilities.+sAssert :: HasKind a => Maybe CallStack -> String -> SBool -> SBV a -> SBV a+sAssert cs msg cond x+ | Just mustHold <- unliteral cond+ = if mustHold+ then x+ else error $ show $ SafeResult (locInfo . getCallStack <$> cs, msg, Satisfiable defaultSMTCfg (SMTModel [] Nothing [] []))+ | True+ = SBV $ SVal k $ Right $ cache r+ where k = kindOf x+ r st = do xsv <- sbvToSV st x+ let pc = getPathCondition st+ -- We're checking if there are any cases where the path-condition holds, but not the condition+ -- Any violations of this, should be signaled, i.e., whenever the following formula is satisfiable+ mustNeverHappen = pc .&& sNot cond+ cnd <- sbvToSV st mustNeverHappen+ addAssertion st cs msg cnd+ pure xsv++ locInfo ps = intercalate ",\n " (map loc ps)+ where loc (f, sl) = concat [srcLocFile sl, ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f]++-- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make+-- sure they do not evaluate to the same result. This should only be used for internal purposes;+-- as default definitions provided should suffice in many cases. (i.e., End users should+-- only need to define 'symbolicMerge' when needed; which should be rare to start with.)+symbolicMergeWithKind :: Kind -> Bool -> SBool -> SBV a -> SBV a -> SBV a+symbolicMergeWithKind k force (SBV t) (SBV a) (SBV b) = SBV (svSymbolicMerge k force t a b)++instance SymVal a => Mergeable (SBV a) where+ symbolicMerge force t x y+ -- Carefully use the kindOf instance to avoid strictness issues.+ | force = symbolicMergeWithKind (kindOf x) True t x y+ | True = symbolicMergeWithKind (kindOf (Proxy @a)) False t x y+ -- Custom version of select that translates to SMT-Lib tables at the base type of words+ select xs err ind+ | SBV (SVal _ (Left c)) <- ind = case cvVal c of+ CInteger i -> if i < 0 || i >= genericLength xs+ then err+ else xs `genericIndex` i+ _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"+ select xsOrig err ind = xs `seq` SBV (SVal kElt (Right (cache r)))+ where kInd = kindOf ind+ kElt = kindOf err+ -- Based on the index size, we need to limit the elements. For instance if the index is 8 bits, but there+ -- are 257 elements, that last element will never be used and we can chop it of..+ xs = case kindOf ind of+ KBounded False i -> genericTake ((2::Integer) ^ (fromIntegral i :: Integer)) xsOrig+ KBounded True i -> genericTake ((2::Integer) ^ (fromIntegral (i-1) :: Integer)) xsOrig+ KUnbounded -> xsOrig+ _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"+ r st = do sws <- mapM (sbvToSV st) xs+ swe <- sbvToSV st err+ if all (== swe) sws -- off-chance that all elts are the same. Note that this also correctly covers the case when list is empty.+ then pure swe+ else do idx <- getTableIndex st kInd kElt sws+ swi <- sbvToSV st ind+ let len = length xs+ -- NB. No need to worry here that the index might be < 0; as the SMTLib translation takes care of that automatically+ newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])++-- | Construct a useful error message if we hit an unmergeable case.+cannotMerge :: String -> String -> String -> a+cannotMerge typ why hint = error $ unlines [ ""+ , "*** Data.SBV.Mergeable: Cannot merge instances of " ++ typ ++ "."+ , "*** While trying to do a symbolic if-then-else with incompatible branch results."+ , "***"+ , "*** " ++ why+ , "*** "+ , "*** Hint: " ++ hint+ ]++-- | Merge concrete values that can be checked for equality+concreteMerge :: Show a => String -> String -> (a -> a -> Bool) -> a -> a -> a+concreteMerge t st eq x y+ | x `eq` y = x+ | True = cannotMerge t+ ("Concrete values can only be merged when equal. Got: " ++ show x ++ " vs. " ++ show y)+ ("Use an " ++ st ++ " field if the values can differ.")++-- Mergeable instances for List/Maybe/Either/Array are useful, but can+-- throw exceptions if there is no structural matching of the results+-- It's a question whether we should really keep them..++-- Lists+instance Mergeable a => Mergeable [a] where+ symbolicMerge f t xs ys+ | lxs == lys = zipWith (symbolicMerge f t) xs ys+ | True = cannotMerge "lists"+ ("Branches produce different sizes: " ++ show lxs ++ " vs " ++ show lys ++ ". Must have the same length.")+ "Use the 'SList' type (and Data.SBV.List routines) to model fully symbolic lists."+ where (lxs, lys) = (length xs, length ys)++-- NonEmpty+instance Mergeable a => Mergeable (NonEmpty a) where+ symbolicMerge f t xs ys+ | lxs == lys = NE.zipWith (symbolicMerge f t) xs ys+ | True = cannotMerge "non-empty lists"+ ("Branches produce different sizes: " ++ show lxs ++ " vs " ++ show lys ++ ". Must have the same length.")+ "Use the 'SList' type (and Data.SBV.List routines) to model fully symbolic lists."+ where (lxs, lys) = (length xs, length ys)++-- ZipList+instance Mergeable a => Mergeable (ZipList a) where+ symbolicMerge force test (ZipList xs) (ZipList ys)+ = ZipList (symbolicMerge force test xs ys)++-- Maybe+instance Mergeable a => Mergeable (Maybe a) where+ symbolicMerge _ _ Nothing Nothing = Nothing+ symbolicMerge f t (Just a) (Just b) = Just $ symbolicMerge f t a b+ symbolicMerge _ _ a b = cannotMerge "'Maybe' values"+ ("Branches produce different constructors: " ++ show (k a, k b))+ "Instead of an option type, try using a valid bit to indicate when a result is valid."+ where k :: Maybe a -> String+ k Nothing = "Nothing"+ k _ = "Just"++-- Either+instance (Mergeable a, Mergeable b) => Mergeable (Either a b) where+ symbolicMerge f t (Left a) (Left b) = Left $ symbolicMerge f t a b+ symbolicMerge f t (Right a) (Right b) = Right $ symbolicMerge f t a b+ symbolicMerge _ _ a b = cannotMerge "'Either' values"+ ("Branches produce different constructors: " ++ show (k a, k b))+ "Consider using a product type by a tag instead."+ where k :: Either a b -> String+ k (Left _) = "Left"+ k (Right _) = "Right"++-- Arrays+instance (Ix a, Mergeable b) => Mergeable (Array a b) where+ symbolicMerge f t a b+ | ba == bb = DA.listArray ba (zipWith (symbolicMerge f t) (elems a) (elems b))+ | True = cannotMerge "'Array' values"+ ("Branches produce different ranges: " ++ show (k ba, k bb))+ "Consider using SBV's native 'SArray' abstraction."+ where ba = bounds a+ bb = bounds b+ k = rangeSize++-- Functions+instance Mergeable b => Mergeable (a -> b) where+ symbolicMerge f t g h x = symbolicMerge f t (g x) (h x)+ {- Following definition, while correct, is utterly inefficient. Since the+ application is delayed, this hangs on to the inner list and all the+ impending merges, even when ind is concrete. Thus, it's much better to+ simply use the default definition for the function case.+ -}+ -- select xs err ind = \x -> select (map ($ x) xs) (err x) ind++-- 2-Tuple+instance (Mergeable a, Mergeable b) => Mergeable (a, b) where+ symbolicMerge f t (i0, i1) (j0, j1) = ( symbolicMerge f t i0 j0+ , symbolicMerge f t i1 j1+ )++ select xs (err1, err2) ind = ( select as err1 ind+ , select bs err2 ind+ )+ where (as, bs) = unzip xs++-- 3-Tuple+instance (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) where+ symbolicMerge f t (i0, i1, i2) (j0, j1, j2) = ( symbolicMerge f t i0 j0+ , symbolicMerge f t i1 j1+ , symbolicMerge f t i2 j2+ )++ select xs (err1, err2, err3) ind = ( select as err1 ind+ , select bs err2 ind+ , select cs err3 ind+ )++ where (as, bs, cs) = unzip3 xs++-- 4-Tuple+instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => Mergeable (a, b, c, d) where+ symbolicMerge f t (i0, i1, i2, i3) (j0, j1, j2, j3) = ( symbolicMerge f t i0 j0+ , symbolicMerge f t i1 j1+ , symbolicMerge f t i2 j2+ , symbolicMerge f t i3 j3+ )++ select xs (err1, err2, err3, err4) ind = ( select as err1 ind+ , select bs err2 ind+ , select cs err3 ind+ , select ds err4 ind+ )+ where (as, bs, cs, ds) = unzip4 xs++-- 5-Tuple+instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => Mergeable (a, b, c, d, e) where+ symbolicMerge f t (i0, i1, i2, i3, i4) (j0, j1, j2, j3, j4) = ( symbolicMerge f t i0 j0+ , symbolicMerge f t i1 j1+ , symbolicMerge f t i2 j2+ , symbolicMerge f t i3 j3+ , symbolicMerge f t i4 j4+ )++ select xs (err1, err2, err3, err4, err5) ind = ( select as err1 ind+ , select bs err2 ind+ , select cs err3 ind+ , select ds err4 ind+ , select es err5 ind+ )+ where (as, bs, cs, ds, es) = unzip5 xs++-- 6-Tuple+instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f) => Mergeable (a, b, c, d, e, f) where+ symbolicMerge f t (i0, i1, i2, i3, i4, i5) (j0, j1, j2, j3, j4, j5) = ( symbolicMerge f t i0 j0+ , symbolicMerge f t i1 j1+ , symbolicMerge f t i2 j2+ , symbolicMerge f t i3 j3+ , symbolicMerge f t i4 j4+ , symbolicMerge f t i5 j5+ )++ select xs (err1, err2, err3, err4, err5, err6) ind = ( select as err1 ind+ , select bs err2 ind+ , select cs err3 ind+ , select ds err4 ind+ , select es err5 ind+ , select fs err6 ind+ )+ where (as, bs, cs, ds, es, fs) = unzip6 xs++-- 7-Tuple+instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f, Mergeable g) => Mergeable (a, b, c, d, e, f, g) where+ symbolicMerge f t (i0, i1, i2, i3, i4, i5, i6) (j0, j1, j2, j3, j4, j5, j6) = ( symbolicMerge f t i0 j0+ , symbolicMerge f t i1 j1+ , symbolicMerge f t i2 j2+ , symbolicMerge f t i3 j3+ , symbolicMerge f t i4 j4+ , symbolicMerge f t i5 j5+ , symbolicMerge f t i6 j6+ )++ select xs (err1, err2, err3, err4, err5, err6, err7) ind = ( select as err1 ind+ , select bs err2 ind+ , select cs err3 ind+ , select ds err4 ind+ , select es err5 ind+ , select fs err6 ind+ , select gs err7 ind+ )+ where (as, bs, cs, ds, es, fs, gs) = unzip7 xs++-- Base types are mergeable so long as they are equal+instance Mergeable () where symbolicMerge _ _ = concreteMerge "()" "()" (==)+instance Mergeable Integer where symbolicMerge _ _ = concreteMerge "Integer" "SInteger" (==)+instance Mergeable Bool where symbolicMerge _ _ = concreteMerge "Bool" "SBool" (==)+instance Mergeable Char where symbolicMerge _ _ = concreteMerge "Char" "SChar" (==)+instance Mergeable Float where symbolicMerge _ _ = concreteMerge "Float" "SFloat" fpIsEqualObjectH+instance Mergeable Double where symbolicMerge _ _ = concreteMerge "Double" "SDouble" fpIsEqualObjectH+instance Mergeable Word8 where symbolicMerge _ _ = concreteMerge "Word8" "SWord8" (==)+instance Mergeable Word16 where symbolicMerge _ _ = concreteMerge "Word16" "SWord16" (==)+instance Mergeable Word32 where symbolicMerge _ _ = concreteMerge "Word32" "SWord32" (==)+instance Mergeable Word64 where symbolicMerge _ _ = concreteMerge "Word64" "SWord64" (==)+instance Mergeable Int8 where symbolicMerge _ _ = concreteMerge "Int8" "SInt8" (==)+instance Mergeable Int16 where symbolicMerge _ _ = concreteMerge "Int16" "SInt16" (==)+instance Mergeable Int32 where symbolicMerge _ _ = concreteMerge "Int32" "SInt32" (==)+instance Mergeable Int64 where symbolicMerge _ _ = concreteMerge "Int64" "SInt64" (==)++-- Arbitrary product types, using GHC.Generics+--+-- NB: Because of the way GHC.Generics works, the implementation of+-- symbolicMerge' is recursive. The derived instance for @data T a = T a a a a@+-- resembles that for (a, (a, (a, a))), not the flat 4-tuple (a, a, a, a). This+-- difference should have no effect in practice. Note also that, unlike the+-- hand-rolled tuple instances, the generic instance does not provide a custom+-- 'select' implementation, and so does not benefit from the SMT-table+-- implementation in the 'SBV a' instance.++-- | Not exported. Symbolic merge using the generic representation provided by+-- 'G.Generics'.+symbolicMergeDefault :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a+symbolicMergeDefault force t x y = G.to $ symbolicMerge' force t (G.from x) (G.from y)++-- | Not exported. Used only in 'symbolicMergeDefault'. Instances are provided for+-- the generic representations of product types where each element is Mergeable.+class GMergeable f where+ symbolicMerge' :: Bool -> SBool -> f a -> f a -> f a++{-+ - N.B. A V1 instance like the below would be wrong!+ - Why? Because inSBV, we use empty data to mean "uninterpreted" sort; not+ - something that has no constructors. Perhaps that was a bad design+ - decision. So, do not allow merging of such values!+instance GMergeable V1 where+ symbolicMerge' _ _ x _ = x+-}++instance GMergeable U1 where+ symbolicMerge' _ _ _ _ = U1++instance (Mergeable c) => GMergeable (K1 i c) where+ symbolicMerge' force t (K1 x) (K1 y) = K1 $ symbolicMerge force t x y++instance (GMergeable f) => GMergeable (M1 i c f) where+ symbolicMerge' force t (M1 x) (M1 y) = M1 $ symbolicMerge' force t x y++instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where+ symbolicMerge' force t (x1 :*: y1) (x2 :*: y2) = symbolicMerge' force t x1 x2 :*: symbolicMerge' force t y1 y2++{- A mergeable instance for sum-types isn't possible. Why? It would something like:++instance (GMergeable f, GMergeable g) => GMergeable (f :+: g) where+ symbolicMerge' force t (L1 x) (L1 y) = L1 $ symbolicMerge' force t x y+ symbolicMerge' force t (R1 x) (R1 y) = R1 $ symbolicMerge' force t x y+ symbolicMerge' force t l r+ | Just tv <- unliteral t = if tv then l else r+ | True = ????++There's really no good code to put in ????. We have no way to ask the SMT solver to merge composite values that+have different constructors. Calling "error" here would pass the type-checker, but that simply postpones the problem+to run-time. If you need mergeable on sum-types, you better write one yourself, possibly using the SEither type yourself.+As we have it, you'll get a type-error; which can be hard to read, but is preferable.++NB. This isn't a problem with the generic version of symbolic equality; since we can simply return sFalse if we+see different constructors. Such isn't the case when merging.+-}++-- Bounded instances+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 inpName cond = mk f+ where mk = SBV . SVal k . Right . cache++ k = kindOf (Proxy @a)+++ f st = do ctr <- incrementFreshNameCounter st+ let pre = atProxy (Proxy @a) inpName+ nm | ctr == 0 = pre+ | True = pre ++ "_" ++ show ctr+ op <- newUninterpreted st (UIGiven nm) Nothing (SBVType [k]) (UINone False)+ chosen <- newExpr st k $ SBVApp op []+ let ifExists = quantifiedBool $ \(Exists ex) -> cond ex+ internalConstraint st False [] (unSBV (ifExists .=> cond (mk (pure (pure chosen)))))+ pure chosen++-- | Find the final part of a kind that looks like an array+resKind :: Kind -> Kind+resKind (KArray _ k) = resKind k+resKind k = k++-- | SMT definable constants and functions, which can also be uninterpreted.+-- This class captures functions that we can generate standalone-code for+-- in the SMT solver. Note that we also allow uninterpreted constants and+-- functions too. An uninterpreted constant is a value that is indexed by its name. The only+-- property the prover assumes -- about these values are that they are equivalent to themselves; i.e., (for+-- functions) they return the same results when applied to same arguments.+-- We support uninterpreted-functions as a general means of black-box'ing+-- operations that are /irrelevant/ for the purposes of the proof; i.e., when+-- the proofs can be performed without any knowledge about the function itself.+--+-- Minimal complete definition: 'sbvDefineValue'. However, most instances in+-- practice are already provided by SBV, so end-users should not need to define their+-- own instances.+class SMTDefinable a where+ -- | Generate the code for this value as an SMTLib function, instead of+ -- the usual unrolling semantics. This is useful for generating sub-functions+ -- in generated SMTLib problem, or handling recursive (and mutually-recursive)+ -- definitions that wouldn't terminate in an unrolling symbolic simulation context.+ --+ -- __IMPORTANT NOTE__ The string argument names this function. SBV identifies+ -- the function by this name: if you use this function twice (or use it recursively),+ -- it will simply assume this name uniquely identifies the function being defined.+ -- If two calls to 'smtFunction' (or its variants) use the same name but different+ -- bodies, SBV will raise an error at runtime.+ --+ -- Furthermore, if the call to 'smtFunction' happens in the scope of a parameter, you+ -- must make sure the string is chosen to keep it unique per parameter value. For instance,+ -- if you have:+ --+ -- @+ -- bar :: SInteger -> SInteger -> SInteger+ -- bar k = smtFunction "bar" (\x -> x+k) -- Note the capture of k!+ -- @+ --+ -- and you call @bar 2@ and @bar 3@, SBV will detect that the two bodies differ and+ -- raise an error. You should use a concrete argument to make the name unique:+ --+ -- @+ -- bar :: String -> SInteger -> SInteger -> SInteger+ -- bar tag k = smtFunction ("bar_" ++ tag) (\x -> x+k) -- Tag should make the name unique!+ -- @+ --+ -- Then, make sure you use @bar "two" 2@ and @bar "three" 3@ etc. to preserve the invariant.+ --+ -- Additionally, 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.+ smtFunctionDef :: (Typeable a, Lambda Symbolic a) => String -> Measure a -> 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)+ -- where the definition isn't used before query-mode starts, and SBV (for historical reasons)+ -- requires functions to be known before query-mode starts executing. In such cases, use this function+ -- to register them with the system.+ registerFunction :: a -> Symbolic ()++ -- | Uninterpret a value, i.e., add this value as a completely undefined value/function that+ -- the solver is free to instantiate to satisfy other constraints.+ --+ -- __Known issues__+ --+ -- Usually using an uninterpret function will register itself to the solver, but sometimes the laziness+ -- of the evaluation might render this unreliable.+ --+ -- For example, when working with quantifiers and uninterpreted functions with the following code:+ --+ -- > runSMTWith z3 $ do+ -- > let f = uninterpret "f" :: SInteger -> SInteger+ -- > query $ do+ -- > constrain $ \(Forall (b :: SInteger)) -> f b .== f b+ -- > checkSat+ --+ -- The solver will complain about the unknown constant @f (Int)@.+ --+ -- A workaround of this is to explicit register them with 'Data.SBV.Control.registerUISMTFunction':+ --+ -- > runSMTWith z3 $ do+ -- > let f = uninterpret "f" :: SInteger -> SInteger+ -- > registerUISMTFunction f+ -- > query $ do+ -- > constrain $ \(Forall (b :: SInteger)) -> f b .== f b+ -- > checkSat+ --+ -- See https://github.com/LeventErkok/sbv/issues/711 for more info.+ uninterpret :: String -> a++ -- | Uninterpret a value, with named arguments in case of functions. SBV will use these+ -- names when it shows the values for the arguments. If the given names are more than needed+ -- we ignore the excess. If not enough, we add from a stock set of variables.+ uninterpretWithArgs :: String -> [String] -> a++ -- | Uninterpret a value, only for the purposes of code-generation. For execution+ -- and verification the value is used as is. For code-generation, the alternate+ -- definition is used. This is useful when we want to take advantage of native+ -- libraries on the target languages.+ cgUninterpret :: String -> [String] -> a -> a++ -- | More generalized form of uninterpretation that wraps 'sbvDefineValueFun';+ -- this function should not be needed by end-user-code+ sbvDefineValue :: UIName -> Maybe [String] -> UIKind a -> a++ -- | The most generalized form of uninterpretation, that generates an+ -- uninterpreted function over a sequence of 'SBVs' values; this function is+ -- internal-only, and should not be needed by end-user-code+ sbvDefineValueFun :: UIName -> Maybe [String] -> SymValInsts as ->+ UIKind (SBVs as -> a) -> SBVs as -> a++ -- | A synonym for 'uninterpret'. Allows us to create variables without+ -- having to call 'free' explicitly, i.e., without being in the symbolic monad.+ sym :: String -> a++ -- | Like 'sym', but appends the type's kind to the name, ensuring uniqueness across+ -- different type instantiations of the same polymorphic definition. Used internally by sCase.+ symWithKind :: String -> a+ symWithKind = sym++ -- | Render an uninterpreted value as an SMTLib definition+ sbv2smt :: ExtractIO m => a -> m String++ -- | Render an uninterpreted value function as an SMTLib definition+ sbvFun2smt :: (SymVals as, ExtractIO m) => (SBVs as -> a) -> m String++ -- | Make this name a constructor, coming from an ADT. Only used internally+ mkADTConstructor :: HasKind a => String -> a+ mkADTTester :: HasKind a => String -> a+ mkADTAccessor :: HasKind a => String -> a++ {-# MINIMAL sbvDefineValueFun, sbvFun2smt, registerFunction #-}++ -- defaults:+ 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+ sbv2smt a = sbvFun2smt (\(_ :: SBVs RNil) -> a)++ sbvDefineValue nm mbArgs k =+ sbvDefineValueFun nm mbArgs SymValsNil (const <$> k) SBVsNil++ mkADTConstructor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTConstructor (T.pack nm) k)) Nothing $ UIFree True in v+ mkADTTester nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTTester (T.pack nm) k)) Nothing $ UIFree True in v+ mkADTAccessor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTAccessor (T.pack nm) k)) Nothing $ UIFree True in v++ smtFunctionDef nm msr v = sbvDefineValue (UIGiven (atProxy (Proxy @a) nm)) Nothing+ $ UIFun (v, \st fk -> do+ let funcNm = atProxy (Proxy @a) nm+ (def, info) <- lambdaWithInfo st TopLevel fk v+ -- Record LambdaInfo for SCC-aware mutual recursion checking+ modifyIORef' (rFuncLambdaInfos st) (Map.insert funcNm info)+ let barFuncNm = barify funcNm+ tBarFuncNm = T.pack barFuncNm+ isSelfRec = any (\(_, SBVApp op _) -> case op of+ Uninterpreted n -> n == tBarFuncNm+ _ -> False)+ (liAssignments info)+ hasCrossRefs = any (\(_, SBVApp op _) -> case op of+ Uninterpreted n -> n /= tBarFuncNm+ _ -> False)+ (liAssignments info)+ case msr of+ AutoMeasure -> do+ when isSelfRec $+ modifyIORef' (rMeasureChecks st)+ ((funcNm, False, \cfg -> autoGuessOrFail cfg funcNm info) :)+ when hasCrossRefs $+ modifyIORef' (rMeasureChecks st)+ ((funcNm, False, \cfg -> checkMutualFromState cfg funcNm st Nothing) :)+ pure def++ HasMeasure eval helpers -> do+ when isSelfRec $+ modifyIORef' (rMeasureChecks st)+ ((funcNm, False, \cfg -> verifyMeasure cfg funcNm info eval helpers) :)+ when hasCrossRefs $+ modifyIORef' (rMeasureChecks st)+ ((funcNm, False, \cfg -> checkMutualFromState cfg funcNm st (Just eval)) :)+ pure def++ HasContract eval ceval helpers -> do+ when hasCrossRefs $+ modifyIORef' (rMeasureChecks st)+ ((funcNm, False, \cfg -> rejectMutualContractFromState cfg funcNm st) :)+ modifyIORef' (rMeasureChecks st)+ ((funcNm, False, \cfg -> verifyMeasureWithContract cfg funcNm info eval ceval helpers) :)+ pure def++ Productive -> do+ when isSelfRec $+ modifyIORef' (rMeasureChecks st)+ ((funcNm, True, \cfg -> verifyGuardedness cfg funcNm info) :)+ when hasCrossRefs $+ modifyIORef' (rMeasureChecks st)+ ((funcNm, True, \cfg -> checkMutualProductiveFromState cfg funcNm st) :)+ pure def++ Unverified -> do modifyIORef' (rNoTermCheckFunctions st) (Set.insert nm)+ debug (stCfg st) ["[MEASURE] " <> T.pack funcNm <> ": no termination check (smtFunctionNoTermination)"]+ pure def)+++-- | Define an SMT function. If the function is recursive, SBV will automatically try to+-- prove termination by guessing a measure based on argument types. If the guess fails,+-- use 'smtFunctionWithMeasure' to provide an explicit measure.+smtFunction :: (SMTDefinable a, Typeable a, Lambda Symbolic a) => String -> a -> a+smtFunction nm = smtFunctionDef nm AutoMeasure++-- | Define an SMT function with an explicit termination measure. Use this when 'smtFunction'+-- cannot automatically determine a suitable measure. The measure function takes the same+-- arguments as the original function but returns a value that must be non-negative and+-- strictly decrease at each recursive call.+--+-- The pair @(measure, helpers)@ provides the measure function and a list of auxiliary+-- t'MeasureHelper' properties needed to verify the measure. Each helper is first proven+-- (by running its TP proof), then asserted as an axiom in the measure verification session.+-- Use 'Data.SBV.TP.measureLemma' to create helpers from TP proofs. Pass @[]@ when no helpers are needed.+smtFunctionWithMeasure :: forall f r. (SMTDefinable f, Typeable f, Lambda Symbolic f, Zero r, OrdSymbolic (SBV r), SymVal r, ApplyMeasure f r)+ => String -> (MeasureOf f r, [MeasureHelper]) -> f -> f+smtFunctionWithMeasure nm (mf, helpers) = smtFunctionDef nm (HasMeasure (MeasureEval (applyMeasure @f @r mf)) helpers)++-- | Define an SMT function with a termination measure and a contract (post-condition).+-- Use this for nested recursive functions (like McCarthy's 91 function) where the termination+-- argument depends on the function's return value at smaller inputs.+--+-- The triple @(measure, contract, helpers)@ provides:+--+-- * A measure function (same as 'smtFunctionWithMeasure')+-- * A contract: a predicate on the function's inputs and output that is proven simultaneously+-- with the measure decrease via well-founded induction. The inductive hypothesis provides+-- the contract for all inputs with strictly smaller measure.+-- * A list of auxiliary t'MeasureHelper' properties (pass @[]@ when none are needed)+--+-- For example, for McCarthy's 91 function:+--+-- @+-- mcCarthy91 = smtFunctionWithContract \"mcCarthy91\"+-- ( \\n -> 0 \`smax\` (101 - n)+-- , \\n r -> n .<= 100 .=> r .== 91+-- , []+-- )+-- $ \\n -> ite (n .> 100) (n - 10) (mcCarthy91 (mcCarthy91 (n + 11)))+-- @+--+-- Here the contract says \"for inputs ≤ 100, the result is 91\". This is needed because the outer+-- recursive call @mcCarthy91(mcCarthy91(n + 11))@ requires knowing what @mcCarthy91(n + 11)@ returns+-- in order to verify that the measure decreases.+smtFunctionWithContract :: forall f r. (SMTDefinable f, Typeable f, Lambda Symbolic f, Zero r, OrdSymbolic (SBV r), SymVal r, ApplyMeasure f r, ApplyContract f)+ => String -> (MeasureOf f r, ContractOf f, [MeasureHelper]) -> f -> f+smtFunctionWithContract nm (mf, cf, helpers) = smtFunctionDef nm (HasContract (MeasureEval (applyMeasure @f @r mf))+ (ContractEval (applyContract @f cf))+ helpers)++-- | Define a productive (corecursive) SMT function. Use this for functions that intentionally+-- don't terminate but produce output incrementally, such as infinite list generators.+-- SBV verifies that every recursive call is guarded by a data constructor (list cons, ADT+-- constructor, etc.), ensuring the function is productive.+--+-- @+-- go = smtProductiveFunction \"go\" $ \\start delta -> start .: go (start + delta) delta+-- @+smtProductiveFunction :: (SMTDefinable a, Typeable a, Lambda Symbolic a) => String -> a -> a+smtProductiveFunction nm = smtFunctionDef nm Productive++-- | Define a recursive SMT function without any termination check. The function+-- is emitted as @define-fun-rec@ and the user takes responsibility for well-definedness.+-- Use this for functions where termination is believed but cannot be proven, such as+-- the Collatz function. See "Documentation.SBV.Examples.TP.Collatz" for an example use case.+smtFunctionNoTermination :: (SMTDefinable a, Typeable a, Lambda Symbolic a) => String -> a -> a+smtFunctionNoTermination nm = smtFunctionDef nm Unverified++-- | Kind of uninterpretation+data UIKind a = UIFree Bool -- ^ completely uninterpreted. If Bool is true, then this is curried.+ | UIFun (a, State -> Kind -> IO SMTDef) -- ^ has code for SMTLib, with final type of kind (note this is the result+ -- , not the arguments), which can be generated by calling the function on the state.+ | UICodeC (a, [String]) -- ^ has code for code-generation, i.e., C+ deriving Functor++-- 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 (UIADT _) _ _ _ = pure $ UINone True+retrieveUICode (UIGiven nm) st fk (UIFun (_, f)) = do+ compilingFuncs <- readIORef (rCompilingFuncs st)+ if nm `Set.member` compilingFuncs+ then -- This name is currently being compiled, so this is a recursive (or mutually recursive) self-call.+ -- Break the cycle by skipping code generation.+ pure $ UINone True+ else do userFuncs <- readIORef (rUserFuncs st)+ sn <- hashStableName <$> makeStableName f+ case Map.lookup nm userFuncs of+ Just (knownHashes, origLevel)+ | sn `Set.member` knownHashes+ -> -- Same closure we've seen before; skip immediately.+ pure $ UINone True+ | True+ -> do -- New closure for an already-compiled name. Compile body in an isolated+ -- throwaway state (to avoid side-effects like duplicate measure registrations+ -- and context-dependent body differences), then compare with the existing definition.+ -- We use the SAME lambda level as the original compilation so that SV names+ -- in the body text match exactly; this avoids fragile string normalization.+ throwaway <- mkNewState ((stCfg st) {verbose = False}) (LambdaGen origLevel)+ modifyIORef' (rCompilingFuncs throwaway) (Set.insert nm)+ -- If the body captures SVals from the live state's context, the throwaway+ -- compilation will throw (e.g., context-mismatch). That is a definite conflict:+ -- the body references different state-bound variables.+ mbD <- C.try (f throwaway fk)+ case mbD of+ Left (_ :: C.SomeException)+ -> conflictError nm+ Right d+ -> do defs <- readIORef (rDefns st)+ case Map.lookup (barify nm) defs of+ Just (oldDef, _)+ | not (smtDefEq d oldDef)+ -> conflictError nm+ _ -> pure ()+ -- Body matches; memoize this StableName hash so future calls+ -- with the same closure skip instantly.+ modifyState st rUserFuncs (Map.adjust (first (Set.insert sn)) nm) (pure ())+ pure $ UINone True+ Nothing+ -> do -- First time seeing this name. Record lambda level for future comparison.+ ll <- readIORef (rLambdaLevel st)+ modifyState st rUserFuncs (Map.insert nm (Set.singleton sn, ll)) (pure ())+ modifyState st rCompilingFuncs (Set.insert nm) (pure ())+ d <- UISMT <$> f st fk+ modifyState st rCompilingFuncs (Set.delete nm) (pure ())+ pure d+retrieveUICode _ _ _ (UICodeC (_, c)) = pure $ UICgC c++-- Get the constant value associated with the UI+retrieveConstCode :: UIKind a -> Maybe a+retrieveConstCode UIFree{} = Nothing+retrieveConstCode (UIFun (v, _)) = Just v+retrieveConstCode (UICodeC (v, _)) = Just v++instance SymVal a => SMTDefinable (SBV a) where+ sbvFun2smt (fn :: SBVs as -> SBV a)+ | SymValsNil <- symValInsts :: SymValInsts as+ , a <- fn SBVsNil+ = do st <- mkNewState defaultSMTCfg (LambdaGen (Just 0))+ s <- lambdaStr st TopLevel (kindOf a) a+ pure $ intercalate "\n" [ "; Automatically generated by SBV. Do not modify!"+ , "; Type: " ++ T.unpack (smtType (kindOf a))+ , show s+ ]+ sbvFun2smt fn = defs2smt (\args -> fn args .== fn args)++ sbvDefineValueFun nm mbArgs insts uiKind args+ | Just v <- retrieveConstCode uiKind+ , foldlSymSBVs (\r x -> r && isConcrete x) True insts args+ = v args+ | ka <- kindOf (Proxy @a)+ = SBV $ SVal ka $ Right $ cache $ \st ->+ do isSMT <- inSMTMode st+ case (isSMT, uiKind) of+ (True, UICodeC (v, _)) -> sbvToSV st (v args)+ _ -> do let ks = symValKinds insts ++ [ka]+ ui <- retrieveUICode nm st ka uiKind+ op <- newUninterpreted st nm mbArgs (SBVType ks) ui+ svs <- rlist2list <$> mapMSBVs (sbvToSV st) args+ mapM_ forceSVArg svs+ newExpr st ka $ SBVApp op svs++ registerFunction x = constrain $ x .== x++ symWithKind nm = sym (nm ++ "_" ++ show (kindOf (Proxy @a)))+++instance (SymVal a, SMTDefinable b) => SMTDefinable (SBV a -> b) where+ sbvFun2smt (fn :: SBVs as -> SBV a -> b) =+ sbvFun2smt (\((SBVsCons as a) :: SBVs (as :> a)) -> fn as a)++ sbvDefineValueFun nm mbArgs insts uiKind args a =+ sbvDefineValueFun nm mbArgs (SymValsCons insts)+ ((\f (SBVsCons xs x) -> f xs x) <$> uiKind) (SBVsCons args a)++ registerFunction f = do let k = kindOf (Proxy @a)+ st <- symbolicEnv+ v <- liftIO $ newInternalVariable st k+ let a = SBV $ SVal k $ Right $ cache (const (pure v))+ registerFunction $ f a++-- Mark the UIKind as uncurried+mkUncurried :: UIKind a -> UIKind a+mkUncurried (UIFree _) = UIFree False+mkUncurried (UIFun a) = UIFun a+mkUncurried (UICodeC a) = UICodeC a+++uncurrySBVs2 :: (SBVs as -> (SBV c, SBV b) -> SBV a) ->+ (SBVs (as :> c :> b) -> SBV a)+uncurrySBVs2 fn (SBVsCons (SBVsCons as c) b) = fn as (c,b)++-- Uncurried functions of two arguments+instance (SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs2++ registerFunction = registerFunction . curry2+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry2 <$> sbvDefineValueFun nm mbArgs insts (fmap curry2 <$> mkUncurried uiKind)++-- Uncurried functions of three arguments+instance (SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs3+ where uncurrySBVs3 :: (SBVs as -> (SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> d :> c :> b) -> SBV a)+ uncurrySBVs3 fn (SBVsCons (SBVsCons (SBVsCons as d) c) b) = fn as (d,c,b)+ registerFunction = registerFunction . curry3+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry3 <$> sbvDefineValueFun nm mbArgs insts (fmap curry3 <$> mkUncurried uiKind)++-- Uncurried functions of four arguments+instance (SymVal e, SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV e, SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs4+ where uncurrySBVs4 :: (SBVs as -> (SBV e, SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> e :> d :> c :> b) -> SBV a)+ uncurrySBVs4 fn (SBVsCons (SBVsCons (SBVsCons (SBVsCons as e) d) c) b) = fn as (e,d,c,b)+ registerFunction = registerFunction . curry4+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry4 <$> sbvDefineValueFun nm mbArgs insts (fmap curry4 <$> mkUncurried uiKind)++-- Uncurried functions of five arguments+instance (SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs5+ where uncurrySBVs5 :: (SBVs as -> (SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> f :> e :> d :> c :> b) -> SBV a)+ uncurrySBVs5 fn (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons as f) e) d) c) b) = fn as (f,e,d,c,b)+ registerFunction = registerFunction . curry5+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry5 <$> sbvDefineValueFun nm mbArgs insts (fmap curry5 <$> mkUncurried uiKind)++-- Uncurried functions of six arguments+instance (SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs6+ where uncurrySBVs6 :: (SBVs as -> (SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> g :> f :> e :> d :> c :> b) -> SBV a)+ uncurrySBVs6 fn (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons as g) f) e) d) c) b) = fn as (g,f,e,d,c,b)++ registerFunction = registerFunction . curry6+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry6 <$> sbvDefineValueFun nm mbArgs insts (fmap curry6 <$> mkUncurried uiKind)++-- Uncurried functions of seven arguments+instance (SymVal h, SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs7+ where uncurrySBVs7 :: (SBVs as -> (SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> h :> g :> f :> e :> d :> c :> b) -> SBV a)+ uncurrySBVs7 fn (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons as h) g) f) e) d) c) b) = fn as (h,g,f,e,d,c,b)+ registerFunction = registerFunction . curry7+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry7 <$> sbvDefineValueFun nm mbArgs insts (fmap curry7 <$> mkUncurried uiKind)++-- Uncurried functions of eight arguments+instance (SymVal i, SymVal h, SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs8+ where uncurrySBVs8 :: (SBVs as -> (SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> i :> h :> g :> f :> e :> d :> c :> b) -> SBV a)+ uncurrySBVs8 fn (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons as i) h) g) f) e) d) c) b) = fn as (i,h,g,f,e,d,c,b)+ registerFunction = registerFunction . curry8+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry8 <$> sbvDefineValueFun nm mbArgs insts (fmap curry8 <$> mkUncurried uiKind)++-- Uncurried functions of nine arguments+instance (SymVal j, SymVal i, SymVal h, SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV j, SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs9+ where uncurrySBVs9 :: (SBVs as -> (SBV j, SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> j :> i :> h :> g :> f :> e :> d :> c :> b) -> SBV a)+ uncurrySBVs9 fn (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons as j) i) h) g) f) e) d) c) b) = fn as (j,i,h,g,f,e,d,c,b)+ registerFunction = registerFunction . curry9+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry9 <$> sbvDefineValueFun nm mbArgs insts (fmap curry9 <$> mkUncurried uiKind)++-- Uncurried functions of ten arguments+instance (SymVal k, SymVal j, SymVal i, SymVal h, SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV k, SBV j, SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs10+ where uncurrySBVs10 :: (SBVs as -> (SBV k, SBV j, SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> k :> j :> i :> h :> g :> f :> e :> d :> c :> b) -> SBV a)+ uncurrySBVs10 fn (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons as k) j) i) h) g) f) e) d) c) b) = fn as (k,j,i,h,g,f,e,d,c,b)+ registerFunction = registerFunction . curry10+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry10 <$> sbvDefineValueFun nm mbArgs insts (fmap curry10 <$> mkUncurried uiKind)++-- Uncurried functions of eleven arguments+instance (SymVal l, SymVal k, SymVal j, SymVal i, SymVal h, SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV l, SBV k, SBV j, SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs11+ where uncurrySBVs11 :: (SBVs as -> (SBV l, SBV k, SBV j, SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> l :> k :> j :> i :> h :> g :> f :> e :> d :> c :> b) -> SBV a)+ uncurrySBVs11 fn (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons as l) k) j) i) h) g) f) e) d) c) b) = fn as (l,k,j,i,h,g,f,e,d,c,b)+ registerFunction = registerFunction . curry11+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry11 <$> sbvDefineValueFun nm mbArgs insts (fmap curry11 <$> mkUncurried uiKind)++-- Uncurried functions of twelve arguments+instance (SymVal m, SymVal l, SymVal k, SymVal j, SymVal i, SymVal h, SymVal g, SymVal f, SymVal e, SymVal d, SymVal c, SymVal b, SymVal a, HasKind a) => SMTDefinable ((SBV m, SBV l, SBV k, SBV j, SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+ sbvFun2smt = sbvFun2smt . uncurrySBVs12+ where uncurrySBVs12 :: (SBVs as -> (SBV m, SBV l, SBV k, SBV j, SBV i, SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) -> (SBVs (as :> m :> l :> k :> j :> i :> h :> g :> f :> e :> d :> c :> b) -> SBV a)+ uncurrySBVs12 fn (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons (SBVsCons as m) l) k) j) i) h) g) f) e) d) c) b) = fn as (m,l,k,j,i,h,g,f,e,d,c,b)+ registerFunction = registerFunction . curry12+ sbvDefineValueFun nm mbArgs insts uiKind = uncurry12 <$> sbvDefineValueFun nm mbArgs insts (fmap curry12 <$> mkUncurried uiKind)++-- | Symbolic computations provide a context for writing symbolic programs.+instance MonadIO m => SolverContext (SymbolicT m) where+ constrain = imposeConstraint False [] . unSBV . quantifiedBool+ softConstrain = imposeConstraint True [] . unSBV . quantifiedBool+ namedConstraint nm = imposeConstraint False [(":named", nm)] . unSBV . quantifiedBool+ constrainWithAttribute atts = imposeConstraint False atts . unSBV . quantifiedBool++ contextState = symbolicEnv+ setOption o = addNewSMTOption o++ internalVariable k = contextState >>= \st -> liftIO $ do+ sv <- newInternalVariable st k+ pure $ SBV $ SVal k (Right (cache (const (pure sv))))++-- | Generalization of 'Data.SBV.assertWithPenalty'+assertWithPenalty :: MonadSymbolic m => String -> SBool -> Penalty -> m ()+assertWithPenalty nm o p = addSValOptGoal $ unSBV <$> AssertWithPenalty nm o p++-- | Class of metrics we can optimize for. Currently, booleans,+-- bounded signed/unsigned bit-vectors, unbounded integers,+-- algebraic reals and floats can be optimized. You can add+-- your instances, but bewared that the 'MetricSpace' should+-- map your type to something the backend solver understands, which+-- are limited to unsigned bit-vectors, reals, and unbounded integers+-- for z3.+--+-- A good reference on these features is given in the following paper:+-- <http://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/nbjorner-scss2014.pdf>.+--+-- Minimal completion: None. However, if @MetricSpace@ is not identical to the type, you want+-- to define 'toMetricSpace'/'annotateForMS', and possibly 'minimize'/'maximize' to add extra constraints as necessary.+class Metric a where+ -- | The metric space we optimize the goal over. Usually the same as the type itself, but not always!+ -- For instance, signed bit-vectors are optimized over their unsigned counterparts, floats are+ -- optimized over their 'Word32' comparable counterparts, etc.+ type MetricSpace a :: Type+ type MetricSpace a = a++ -- | Compute the metric value to optimize.+ toMetricSpace :: SBV a -> SBV (MetricSpace a)++ -- | Compute the value itself from the metric corresponding to it.+ fromMetricSpace :: SBV (MetricSpace a) -> SBV a++ -- | Annotate for the metric space, to clarify the new name. If this result is not identity,+ -- we will add an sObserve on the original.+ annotateForMS :: Proxy a -> String -> String++ -- | Minimizing a metric space+ msMinimize :: (MonadSymbolic m, SolverContext m) => String -> SBV a -> m ()+ msMinimize nm o = do let nm' = annotateForMS (Proxy @a) nm+ when (nm' /= nm) $ sObserve nm (unSBV o)+ addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o)++ -- | Maximizing a metric space+ msMaximize :: (MonadSymbolic m, SolverContext m) => String -> SBV a -> m ()+ msMaximize nm o = do let nm' = annotateForMS (Proxy @a) nm+ when (nm' /= nm) $ sObserve nm (unSBV o)+ addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o)++ -- if MetricSpace is the same, we can give a default definition+ default toMetricSpace :: (a ~ MetricSpace a) => SBV a -> SBV (MetricSpace a)+ toMetricSpace = id++ default fromMetricSpace :: (a ~ MetricSpace a) => SBV (MetricSpace a) -> SBV a+ fromMetricSpace = id++ -- Annotations to indicate if the metric space transition was needed+ default annotateForMS :: (a ~ MetricSpace a) => Proxy a -> String -> String+ annotateForMS _ s = s++-- Booleans assume True is greater than False+instance Metric Bool where+ type MetricSpace Bool = Word8+ toMetricSpace t = ite t 1 0+ fromMetricSpace w = w ./= 0+ annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"++-- | Generalization of 'Data.SBV.minimize'+minimize :: (Metric a, MonadSymbolic m, SolverContext m) => String -> SBV a -> m ()+minimize = msMinimize++-- | Generalization of 'Data.SBV.maximize'+maximize :: (Metric a, MonadSymbolic m, SolverContext m) => String -> SBV a -> m ()+maximize = msMaximize++-- Unsigned types, integers, and reals directly optimize+instance Metric Word8+instance Metric Word16+instance Metric Word32+instance Metric Word64+instance Metric Integer+instance Metric AlgReal++-- To optimize signed bounded values, we have to adjust to the range+instance Metric Int8 where+ type MetricSpace Int8 = Word8+ toMetricSpace x = sFromIntegral x + 128 -- 2^7+ fromMetricSpace x = sFromIntegral x - 128+ annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"++instance Metric Int16 where+ type MetricSpace Int16 = Word16+ toMetricSpace x = sFromIntegral x + 32768 -- 2^15+ fromMetricSpace x = sFromIntegral x - 32768+ annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"++instance Metric Int32 where+ type MetricSpace Int32 = Word32+ toMetricSpace x = sFromIntegral x + 2147483648 -- 2^31+ fromMetricSpace x = sFromIntegral x - 2147483648+ annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"++instance Metric Int64 where+ type MetricSpace Int64 = Word64+ toMetricSpace x = sFromIntegral x + 9223372036854775808 -- 2^63+ fromMetricSpace x = sFromIntegral x - 9223372036854775808+ annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"++-- | Optimizing 'WordN'+instance (KnownNat n, BVIsNonZero n) => Metric (WordN n)++-- | Optimizing 'IntN'+instance (KnownNat n, BVIsNonZero n) => Metric (IntN n) where+ type MetricSpace (IntN n) = WordN n+ toMetricSpace x = sFromIntegral x + 2 ^ (intOfProxy (Proxy @n) - 1)+ fromMetricSpace x = sFromIntegral x - 2 ^ (intOfProxy (Proxy @n) - 1)+ annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"++-- Quickcheck interface on symbolic-booleans..+instance Testable SBool where+ property (SBV (SVal _ (Left b))) = property (cvToBool b)+ 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}) <-+ C.catch (runSymbolic defaultSMTCfg (Concrete Nothing) prop)+ (\(e :: C.SomeException) -> cantQuickCheck (show e))+++ 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 "An observable did not evaluate to a concrete value"++ case map fst unints of+ [] -> case unliteral r of+ Nothing -> cantQuickCheck "The result did not evaluate to a concrete value"+ Just b -> pure (cond, b, tvals ++ mapMaybe getObservable ovals)+ 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 :: 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.+sbvQuickCheck :: Symbolic SBool -> IO Bool+sbvQuickCheck prop = QC.isSuccess <$> QC.quickCheckResult prop++-- Quickcheck interface on dynamically-typed values. A run-time check+-- ensures that the value has boolean type.+instance Testable (Symbolic SVal) where+ property m = property $ do s <- m+ when (kindOf s /= KBool) $ error "Cannot quickcheck non-boolean value"+ pure (SBV s :: SBool)++-- | Explicit sharing combinator. The SBV library has internal caching/hash-consing mechanisms+-- built in, based on Andy Gill's type-safe observable sharing technique (see: <http://ku-fpg.github.io/files/Gill-09-TypeSafeReification.pdf>).+-- However, there might be times where being explicit on the sharing can help, especially in experimental code. The 'slet' combinator+-- ensures that its first argument is computed once and passed on to its continuation, explicitly indicating the intent of sharing. Most+-- use cases of the SBV library should simply use Haskell's @let@ construct for this purpose.+slet :: forall a b. (HasKind a, HasKind b) => SBV a -> (SBV a -> SBV b) -> SBV b+slet x f = SBV $ SVal k $ Right $ cache r+ where k = kindOf (Proxy @b)+ r st = do xsv <- sbvToSV st x+ let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (pure xsv))))+ res = f xsbv+ sbvToSV st res++-- | Class of things that we can logically reduce to a boolean, by saturating and then asserting equivalence to itself+class QSaturate m a where+ qSaturate :: a -> m ()++-- | Base case; simple variable in the symbolic monad+instance SolverContext m => QSaturate m SBool where+ qSaturate b = constrain $ b .== b++-- | Saturate over a universal quantifier+instance (HasKind a, Monad m, SolverContext m, QSaturate m r) => QSaturate m (Forall nm a -> r) where+ qSaturate f = qSaturate . f . Forall =<< internalVariable (kindOf (Proxy @a))++-- | Saturate over a pair of universal quantifiers+instance (HasKind a, HasKind b, Monad m, SolverContext m, QSaturate m r) => QSaturate m ((Forall na a, Forall nb b) -> r) where+ qSaturate = qSaturate . curry++-- | Saturate over a pair of existential quantifiers+instance (HasKind a, HasKind b, Monad m, SolverContext m, QSaturate m r) => QSaturate m ((Exists na a, Exists nb b) -> r) where+ qSaturate = qSaturate . curry++-- | Saturate over a number of universal quantifiers+instance (KnownNat n, HasKind a, Monad m, SolverContext m, QSaturate m r) => QSaturate m (ForallN n nm a -> r) where+ qSaturate f = qSaturate . f . ForallN =<< replicateM (intOfProxy (Proxy @n)) (internalVariable (kindOf (Proxy @a)))++-- | Saturate over an existential quantifier+instance (HasKind a, Monad m, SolverContext m, QSaturate m r) => QSaturate m (Exists nm a -> r) where+ qSaturate f = qSaturate . f . Exists =<< internalVariable (kindOf (Proxy @a))++-- | Saturate over an a number of existential quantifiers+instance (KnownNat n, HasKind a, Monad m, SolverContext m, QSaturate m r) => QSaturate m (ExistsN n nm a -> r) where+ qSaturate f = qSaturate . f . ExistsN =<< replicateM (intOfProxy (Proxy @n)) (internalVariable (kindOf (Proxy @a)))++-- | Saturate over a unique-exists variable+instance (HasKind a, Monad m, SolverContext m, QSaturate m r) => QSaturate m (ExistsUnique nm a -> r) where+ qSaturate f = qSaturate . f . ExistsUnique =<< internalVariable (kindOf (Proxy @a))++-- | Saturate a predicate, but save/restore observables so they're not messed up.+qSaturateSavingObservables :: (Monad m, MonadIO m, SolverContext m, QSaturate m a) => a -> m ()+qSaturateSavingObservables p = do State{rObservables} <- contextState+ curObservables <- liftIO $ readIORef rObservables+ qSaturate p+ liftIO $ writeIORef rObservables curObservables++-- | Equality as a proof method. Allows for+-- very concise construction of equivalence proofs, which is very typical in+-- bit-precise proofs.+infix 4 ===+class Equality a where+ (===) :: a -> a -> IO ThmResult++instance {-# OVERLAPPABLE #-} (SymVal a, EqSymbolic z) => Equality (SBV a -> z) where+ k === l = prove $ \a -> k a .== l a++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, EqSymbolic z) => Equality (SBV a -> SBV b -> z) where+ k === l = prove $ \a b -> k a b .== l a b++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, EqSymbolic z) => Equality ((SBV a, SBV b) -> z) where+ k === l = prove $ \a b -> k (a, b) .== l (a, b)++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> z) where+ k === l = prove $ \a b c -> k a b c .== l a b c++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c) -> z) where+ k === l = prove $ \a b c -> k (a, b, c) .== l (a, b, c)++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> z) where+ k === l = prove $ \a b c d -> k a b c d .== l a b c d++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d) -> z) where+ k === l = prove $ \a b c d -> k (a, b, c, d) .== l (a, b, c, d)++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> z) where+ k === l = prove $ \a b c d e -> k a b c d e .== l a b c d e++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e) -> z) where+ k === l = prove $ \a b c d e -> k (a, b, c, d, e) .== l (a, b, c, d, e)++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> z) where+ k === l = prove $ \a b c d e f -> k a b c d e f .== l a b c d e f++instance {-# OVERLAPPABLE #-}+ (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> z) where+ k === l = prove $ \a b c d e f -> k (a, b, c, d, e, f) .== l (a, b, c, d, e, f)++instance {-# OVERLAPPABLE #-}+ (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> z) where+ k === l = prove $ \a b c d e f g -> k a b c d e f g .== l a b c d e f g++instance {-# OVERLAPPABLE #-} (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> z) where+ k === l = prove $ \a b c d e f g -> k (a, b, c, d, e, f, g) .== l (a, b, c, d, e, f, g)++-- | Reading a value from an array.+readArray :: forall key val. (SymVal key, SymVal val, HasKind val) => SArray key val -> SBV key -> SBV val+readArray array key+ | eqCheckIsObjectEq ka, Just (ArrayModel tbl def) <- unliteral array, Just _ <- unliteral key, Just r <- locate (unSBV key) def tbl+ = r+ | True+ = symRes+ where symRes = SBV . SVal kb . Right $ cache g+ ka = kindOf (Proxy @key)+ kb = kindOf (Proxy @val)+ g st = do f <- sbvToSV st array+ k <- sbvToSV st key+ newExpr st kb (SBVApp ReadArray [f, k])++ -- return the first value, since we don't bother deleting previous writes. Note that this might+ -- fail if we don't have equality; but that's OK; in that case we'll go symbolic.+ locate skey def vals = go vals+ where go [] = Just $ literal def+ go ((k, v) : rest) = case unliteral (SBV (svStrongEqual skey (unSBV (literal k)))) of+ Nothing -> Nothing+ Just True -> Just $ literal v+ Just False -> go rest++-- | Writing a value to an array. For the concrete case, we don't bother deleting earlier entries, we keep a history. The earlier a value is in the list, the "later" it happened; in a stack fashion.+writeArray :: forall key val. (HasKind key, SymVal key, SymVal val, HasKind val) => SArray key val -> SBV key -> SBV val -> SArray key val+writeArray array key value+ | Just (ArrayModel tbl def) <- unliteral array, Just keyVal <- unliteral key, Just val <- unliteral value+ = literal $ ArrayModel ((keyVal, val) : tbl) def -- It's important that we "cons" the value here, since it takes precedence in a read+ | True+ = SBV . SVal k . Right $ cache g+ where k = KArray (kindOf (Proxy @key)) (kindOf (Proxy @val))++ g st = do arr <- sbvToSV st array+ keyVal <- sbvToSV st key+ val <- sbvToSV st value+ newExpr st k (SBVApp WriteArray [arr, keyVal, val])++-- | Create a constant array. This is a special case of 'lambdaArray', but it creates a+-- simpler expression in the case of constants.+constArray :: forall key val. (SymVal key, SymVal val) => SBV val -> SArray key val+constArray v+ | Just v' <- unliteral v+ = literal $ ArrayModel [] v'+ | True+ = SBV . SVal k . Right $ cache g+ where ka = kindOf (Proxy @key)+ kb = kindOf (Proxy @val)+ k = KArray ka kb++ g st = do sv <- sbvToSV st v+ newExpr st k (SBVApp (ArrayInit (Left (ka, kb))) [sv])++-- | Create a completely free array, with no constraints on it, as an expression.+-- Note that you can create an array in the symbolic context with the regular 'free'+-- calls. (Or 'sArray' if you prefer.) This variant creates it as an expression, i.e.,+-- without having to be in the monadic context. We take a name identifier here as an+-- argument which uniquely identifies this array. Note that this is necessary, as otherwise+-- there would be no way to distinguish two different calls in the pure context. If you+-- use the same name, then you'll get the same array, much like uninterpreted functions.+freeArray :: forall key val. (SymVal key, SymVal val) => String -> SArray key val+freeArray = lambdaArray . uninterpret++-- | Using a lambda as an array. We can turn a function into an array, relating indexes+-- to their values. (That is, passing @f@ would create an array where entry @i@+-- is initialized to value @f i@.) For the special case of initializing with a constant+-- value, either pass @const val@, or use 'constArray'.+--+-- __Arrays vs. uninterpreted functions:__ The basic array theory provides only+-- @select@ ('readArray'), @store@ ('writeArray'), and @const@ ('constArray'). These operations+-- can only construct arrays that differ from a constant in finitely many positions. For instance,+-- the identity array (where @a[i] = i@ for every @i@) cannot be built from 'constArray' plus+-- finitely many 'writeArray' calls. The @lambdaArray@ function goes beyond this: it uses the+-- solver's ability to identify arrays with function spaces, allowing the creation of arrays like+-- @lambdaArray id@ that correspond to arbitrary functions.+--+-- This identification has a model-theoretic consequence. The pure array theory (with only+-- @select@\/@store@\/@const@) is a weaker theory: it admits models where the array sort does+-- not contain all functions, only those reachable by finitely many stores on constants. This means+-- certain formulas are satisfiable in the pure theory (because the solver has more freedom in choosing+-- what arrays exist) that become unsatisfiable when arrays are identified with functions (because the+-- richer array sort can provide counterexamples). In practice, modern solvers use the stronger+-- identification, so @lambdaArray@, 'constArray', and 'writeArray' all operate in this richer setting.+lambdaArray :: forall a b. (SymVal a, HasKind b) => (SBV a -> SBV b) -> SArray a b+lambdaArray f = SBV . SVal k . Right $ cache g+ where k = KArray (kindOf (Proxy @a)) (kindOf (Proxy @b))++ g st = do def <- lambdaStr st TopLevel (kindOf (Proxy @b)) f+ newExpr st k (SBVApp (ArrayInit (Right def)) [])++-- | Turn a constant association-list and a default into a symbolic array.+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 = smtHOFunctionGen nm f AutoMeasure++-- | Like 'smtHOFunction', but with an explicit termination measure. Use this when the+-- auto-guess measure doesn't work for a higher-order recursive function.+smtHOFunctionWithMeasure :: forall a b f r.+ ( SMTDefinable (a -> SBV b)+ , Lambda Symbolic f+ , Lambda Symbolic (a -> SBV b)+ , HasKind b+ , HasKind f+ , Typeable a+ , Typeable b+ , Typeable f+ , Zero r, OrdSymbolic (SBV r), SymVal r+ , ApplyMeasure (a -> SBV b) r+ ) => String -- ^ prefix to use+ -> f -- ^ The higher-order argument+ -> MeasureOf (a -> SBV b) r -- ^ Termination measure+ -> (a -> SBV b) -- ^ The ho-function we're modeling+ -> a -> SBV b -- ^ The resulting function+smtHOFunctionWithMeasure nm f msr = smtHOFunctionGen nm f (HasMeasure (MeasureEval (applyMeasure @(a -> SBV b) @r msr)) [])++-- | Common implementation for higher-order SMT function definitions.+smtHOFunctionGen :: 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+ -> Measure (a -> SBV b) -- ^ Termination measure+ -> (a -> SBV b) -- ^ The ho-function we're modeling+ -> a -> SBV b -- ^ The resulting function+smtHOFunctionGen nm f measure hof arg = SBV $ SVal (kindOf (Proxy @(SBV b))) $ Right $ cache r+ where r st = do SMTLambda lam <- lambdaStr st HigherOrderArg (arrayResultKind (kindOf (Proxy @f))) f+ let uniq = lambdaFingerprint st (T.unpack lam)+ sbvToSV st (smtFunctionDef (atProxy (Proxy @f) nm <> "_" <> uniq) measure hof arg)++-- | Chase through nested array kinds to find the final result kind. Higher-order+-- arguments are firstified into arrays, so we peel off the array wrappers.+arrayResultKind :: Kind -> Kind+arrayResultKind (KArray _ k) = arrayResultKind k+arrayResultKind k = k++-- | Generate a short fingerprint from a lambda body string, used to give+-- unique names to firstified higher-order function instantiations.+lambdaFingerprint :: State -> String -> String+lambdaFingerprint st lam = take uniqLen (BC.unpack (B.encode (hash (BC.pack (unwords (words lam))))))+ where uniqLen = firstifyUniqueLen $ stCfg st++{- HLint ignore module "Reduce duplication" -}+{- HLint ignore module "Eta reduce" -}+{- HLint ignore module "Avoid NonEmpty.unzip" -}+{- HLint ignore module "Redundant id" -}+{- HLint ignore module "Use second" -}
Data/SBV/Core/Operations.hs view
@@ -9,1429 +9,2067 @@ -- Constructors and basic operations on symbolic values ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.Core.Operations- (- -- ** Basic constructors- svTrue, svFalse, svBool- , svInteger, svFloat, svDouble, svFloatingPoint, svReal, svEnumFromThenTo, svString, svChar- -- ** Basic destructors- , svAsBool, svAsInteger, svNumerator, svDenominator- -- ** Basic operations- , svPlus, svTimes, svMinus, svUNeg, svAbs- , svDivide, svQuot, svRem, svQuotRem- , svEqual, svNotEqual, svStrongEqual, svSetEqual- , svLessThan, svGreaterThan, svLessEq, svGreaterEq, svStructuralLessThan- , svAnd, svOr, svXOr, svNot- , svShl, svShr, svRol, svRor- , svExtract, svJoin, svZeroExtend, svSignExtend- , svIte, svLazyIte, svSymbolicMerge- , svSelect- , svSign, svUnsign, svSetBit, svWordFromBE, svWordFromLE- , svExp, svFromIntegral- -- ** Overflows- , svMkOverflow- -- ** Derived operations- , svToWord1, svFromWord1, svTestBit- , svShiftLeft, svShiftRight- , svRotateLeft, svRotateRight- , svBarrelRotateLeft, svBarrelRotateRight- , svBlastLE, svBlastBE- , svAddConstant, svIncrement, svDecrement- , svFloatAsSWord32, svDoubleAsSWord64, svFloatingPointAsSWord - -- ** Basic array operations- , SArr(..), readSArr, writeSArr, mergeSArr, newSArr, eqSArr- -- Utils- , mkSymOp- )- where--import Data.Bits (Bits(..))-import Data.List (genericIndex, genericLength, genericTake, foldl')--import qualified Data.IORef as R (readIORef)-import qualified Data.IntMap.Strict as IMap (size, insert)--import Data.SBV.Core.AlgReals-import Data.SBV.Core.Kind-import Data.SBV.Core.Concrete-import Data.SBV.Core.Symbolic-import Data.SBV.Core.SizedFloats--import Data.Ratio--import Data.SBV.Utils.Numeric (fpIsEqualObjectH, floatToWord, doubleToWord)--import LibBF------------------------------------------------------------------------------------- Basic constructors---- | Boolean True.-svTrue :: SVal-svTrue = SVal KBool (Left trueCV)---- | Boolean False.-svFalse :: SVal-svFalse = SVal KBool (Left falseCV)---- | Convert from a Boolean.-svBool :: Bool -> SVal-svBool b = if b then svTrue else svFalse---- | Convert from an Integer.-svInteger :: Kind -> Integer -> SVal-svInteger k n = SVal k (Left $! mkConstCV k n)---- | Convert from a Float-svFloat :: Float -> SVal-svFloat f = SVal KFloat (Left $! CV KFloat (CFloat f))---- | Convert from a Double-svDouble :: Double -> SVal-svDouble d = SVal KDouble (Left $! CV KDouble (CDouble d))---- | Convert from a generalized floating point-svFloatingPoint :: FP -> SVal-svFloatingPoint f@(FP eb sb _) = SVal k (Left $! CV k (CFP f))- where k = KFP eb sb---- | Convert from a String-svString :: String -> SVal-svString s = SVal KString (Left $! CV KString (CString s))---- | Convert from a Char-svChar :: Char -> SVal-svChar c = SVal KChar (Left $! CV KChar (CChar c))---- | Convert from a Rational-svReal :: Rational -> SVal-svReal d = SVal KReal (Left $! CV KReal (CAlgReal (fromRational d)))------------------------------------------------------------------------------------- Basic destructors---- | Extract a bool, by properly interpreting the integer stored.-svAsBool :: SVal -> Maybe Bool-svAsBool (SVal _ (Left cv)) = Just (cvToBool cv)-svAsBool _ = Nothing---- | Extract an integer from a concrete value.-svAsInteger :: SVal -> Maybe Integer-svAsInteger (SVal _ (Left (CV _ (CInteger n)))) = Just n-svAsInteger _ = Nothing---- | Grab the numerator of an SReal, if available-svNumerator :: SVal -> Maybe Integer-svNumerator (SVal KReal (Left (CV KReal (CAlgReal (AlgRational True r))))) = Just $ numerator r-svNumerator _ = Nothing---- | Grab the denominator of an SReal, if available-svDenominator :: SVal -> Maybe Integer-svDenominator (SVal KReal (Left (CV KReal (CAlgReal (AlgRational True r))))) = Just $ denominator r-svDenominator _ = Nothing------------------------------------------------------------------------------------------ | Constructing [x, y, .. z] and [x .. y]. Only works when all arguments are concrete and integral and the result is guaranteed finite--- Note that the it isn't "obviously" clear why the following works; after all we're doing the construction over Integer's and mapping--- it back to other types such as SIntN/SWordN. The reason is that the values we receive are guaranteed to be in their domains; and thus--- the lifting to Integers preserves the bounds; and then going back is just fine. So, things like @[1, 5 .. 200] :: [SInt8]@ work just--- fine (end evaluate to empty list), since we see @[1, 5 .. -56]@ in the @Integer@ domain. Also note the explicit check for @s /= f@--- below to make sure we don't stutter and produce an infinite list.-svEnumFromThenTo :: SVal -> Maybe SVal -> SVal -> Maybe [SVal]-svEnumFromThenTo bf mbs bt- | Just bs <- mbs, Just f <- svAsInteger bf, Just s <- svAsInteger bs, Just t <- svAsInteger bt, s /= f = Just $ map (svInteger (kindOf bf)) [f, s .. t]- | Nothing <- mbs, Just f <- svAsInteger bf, Just t <- svAsInteger bt = Just $ map (svInteger (kindOf bf)) [f .. t]- | True = Nothing------------------------------------------------------------------------------------------ Basic operations---- | Addition.-svPlus :: SVal -> SVal -> SVal-svPlus x y- | isConcreteZero x = y- | isConcreteZero y = x- | True = liftSym2 (mkSymOp Plus) [rationalCheck] (+) (+) (+) (+) (+) (+) x y---- | Multiplication.-svTimes :: SVal -> SVal -> SVal-svTimes x y- | isConcreteZero x = x- | isConcreteZero y = y- | isConcreteOne x = y- | isConcreteOne y = x- | True = liftSym2 (mkSymOp Times) [rationalCheck] (*) (*) (*) (*) (*) (*) x y---- | Subtraction.-svMinus :: SVal -> SVal -> SVal-svMinus x y- | isConcreteZero y = x- | True = liftSym2 (mkSymOp Minus) [rationalCheck] (-) (-) (-) (-) (-) (-) x y---- | Unary minus. We handle arbitrary-FP's specially here, just for the negated literals.-svUNeg :: SVal -> SVal-svUNeg = liftSym1 (mkSymOp1 UNeg) negate negate negate negate negate negate---- | Absolute value.-svAbs :: SVal -> SVal-svAbs = liftSym1 (mkSymOp1 Abs) abs abs abs abs abs abs---- | Division.-svDivide :: SVal -> SVal -> SVal-svDivide = liftSym2 (mkSymOp Quot) [rationalCheck] (/) idiv (/) (/) (/) (/)- where idiv x 0 = x- idiv x y = x `div` y---- | Exponentiation.-svExp :: SVal -> SVal -> SVal-svExp b e- | Just x <- svAsInteger e- = if x >= 0 then let go n v- | n == 0 = one- | even n = go (n `div` 2) (svTimes v v)- | True = svTimes v $ go (n `div` 2) (svTimes v v)- in go x b- else error $ "svExp: exponentiation: negative exponent: " ++ show x- | not (isBounded e) || hasSign e- = error $ "svExp: exponentiation only works with unsigned bounded symbolic exponents, kind: " ++ show (kindOf e)- | True- = prod $ zipWith (\use n -> svIte use n one)- (svBlastLE e)- (iterate (\x -> svTimes x x) b)- where prod = foldr svTimes one- one = svInteger (kindOf b) 1---- | Bit-blast: Little-endian. Assumes the input is a bit-vector or a floating point type.-svBlastLE :: SVal -> [SVal]-svBlastLE x = map (svTestBit x) [0 .. intSizeOf x - 1]---- | Set a given bit at index-svSetBit :: SVal -> Int -> SVal-svSetBit x i = x `svOr` svInteger (kindOf x) (bit i :: Integer)---- | Bit-blast: Big-endian. Assumes the input is a bit-vector or a floating point type.-svBlastBE :: SVal -> [SVal]-svBlastBE = reverse . svBlastLE---- | Un-bit-blast from big-endian representation to a word of the right size.--- The input is assumed to be unsigned.-svWordFromLE :: [SVal] -> SVal-svWordFromLE bs = go zero 0 bs- where zero = svInteger (KBounded False (length bs)) 0- go !acc _ [] = acc- go !acc !i (x:xs) = go (svIte x (svSetBit acc i) acc) (i+1) xs---- | Un-bit-blast from little-endian representation to a word of the right size.--- The input is assumed to be unsigned.-svWordFromBE :: [SVal] -> SVal-svWordFromBE = svWordFromLE . reverse---- | Add a constant value:-svAddConstant :: Integral a => SVal -> a -> SVal-svAddConstant x i = x `svPlus` svInteger (kindOf x) (fromIntegral i)---- | Increment:-svIncrement :: SVal -> SVal-svIncrement x = svAddConstant x (1::Integer)---- | Decrement:-svDecrement :: SVal -> SVal-svDecrement x = svAddConstant x (-1 :: Integer)---- | Quotient: Overloaded operation whose meaning depends on the kind at which--- it is used: For unbounded integers, it corresponds to the SMT-Lib--- "div" operator ("Euclidean" division, which always has a--- non-negative remainder). For unsigned bitvectors, it is "bvudiv";--- and for signed bitvectors it is "bvsdiv", which rounds toward zero.--- Division by 0 is defined s.t. @x/0 = 0@, which holds even when @x@ itself is @0@.-svQuot :: SVal -> SVal -> SVal-svQuot x y- | isConcreteZero x = x- | isConcreteZero y = svInteger (kindOf x) 0- | isConcreteOne y = x- | True = liftSym2 (mkSymOp Quot) [nonzeroCheck]- (noReal "quot") quot' (noFloat "quot") (noDouble "quot") (noFP "quot") (noRat "quot") x y- where- quot' a b | kindOf x == KUnbounded = div a (abs b) * signum b- | otherwise = quot a b---- | Remainder: Overloaded operation whose meaning depends on the kind at which--- it is used: For unbounded integers, it corresponds to the SMT-Lib--- "mod" operator (always non-negative). For unsigned bitvectors, it--- is "bvurem"; and for signed bitvectors it is "bvsrem", which rounds--- toward zero (sign of remainder matches that of @x@). Division by 0 is--- defined s.t. @x/0 = 0@, which holds even when @x@ itself is @0@.-svRem :: SVal -> SVal -> SVal-svRem x y- | isConcreteZero x = x- | isConcreteZero y = x- | isConcreteOne y = svInteger (kindOf x) 0- | True = liftSym2 (mkSymOp Rem) [nonzeroCheck]- (noReal "rem") rem' (noFloat "rem") (noDouble "rem") (noFP "rem") (noRat "rem") x y- where- rem' a b | kindOf x == KUnbounded = mod a (abs b)- | otherwise = rem a b---- | Combination of quot and rem-svQuotRem :: SVal -> SVal -> (SVal, SVal)-svQuotRem x y = (x `svQuot` y, x `svRem` y)---- | Optimize away x == true and x /= false to x; otherwise just do eqOpt-eqOptBool :: Op -> SV -> SV -> SV -> Maybe SV-eqOptBool op w x y- | k == KBool && op == Equal && x == trueSV = Just y -- true .== y --> y- | k == KBool && op == Equal && y == trueSV = Just x -- x .== true --> x- | k == KBool && op == NotEqual && x == falseSV = Just y -- false ./= y --> y- | k == KBool && op == NotEqual && y == falseSV = Just x -- x ./= false --> x- | True = eqOpt w x y -- fallback- where k = swKind x---- | Equality.-svEqual :: SVal -> SVal -> SVal-svEqual a b- | isSet a && isSet b- = svSetEqual a b- | True- = liftSym2B (mkSymOpSC (eqOptBool Equal trueSV) Equal) rationalCheck (==) (==) (==) (==) (==) (==) (==) (==) (==) (==) (==) (==) (==) a b---- | Inequality.-svNotEqual :: SVal -> SVal -> SVal-svNotEqual a b- | isSet a && isSet b- = svNot $ svEqual a b- | True- = liftSym2B (mkSymOpSC (eqOptBool NotEqual falseSV) NotEqual) rationalCheck (/=) (/=) (/=) (/=) (/=) (/=) (/=) (/=) (/=) (/=) (/=) (/=) (/=) a b---- | Set equality. Note that we only do constant folding if we get both a regular or both a--- complement set. Otherwise we get a symbolic value even if they might be completely concrete.-svSetEqual :: SVal -> SVal -> SVal-svSetEqual sa sb- | not (isSet sa && isSet sb && kindOf sa == kindOf sb)- = error $ "Data.SBV.svSetEqual: Called on ill-typed args: " ++ show (kindOf sa, kindOf sb)- | Just (RegularSet a) <- getSet sa, Just (RegularSet b) <- getSet sb- = svBool (a == b)- | Just (ComplementSet a) <- getSet sa, Just (ComplementSet b) <- getSet sb- = svBool (a == b)- | True- = SVal KBool $ Right $ cache r- where getSet (SVal _ (Left (CV _ (CSet s)))) = Just s- getSet _ = Nothing-- r st = do sva <- svToSV st sa- svb <- svToSV st sb- newExpr st KBool $ SBVApp (SetOp SetEqual) [sva, svb]---- | Strong equality. Only matters on floats, where it says @NaN@ equals @NaN@ and @+0@ and @-0@ are different.--- Otherwise equivalent to `svEqual`.-svStrongEqual :: SVal -> SVal -> SVal-svStrongEqual x y | isFloat x, Just f1 <- getF x, Just f2 <- getF y = svBool $ f1 `fpIsEqualObjectH` f2- | isDouble x, Just f1 <- getD x, Just f2 <- getD y = svBool $ f1 `fpIsEqualObjectH` f2- | isFP x, Just f1 <- getFP x, Just f2 <- getFP y = svBool $ f1 `fpIsEqualObjectH` f2- | isFloat x || isDouble x || isFP x = SVal KBool $ Right $ cache r- | True = svEqual x y- where getF (SVal _ (Left (CV _ (CFloat f)))) = Just f- getF _ = Nothing-- getD (SVal _ (Left (CV _ (CDouble d)))) = Just d- getD _ = Nothing-- getFP (SVal _ (Left (CV _ (CFP f)))) = Just f- getFP _ = Nothing-- r st = do sx <- svToSV st x- sy <- svToSV st y- newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sx, sy])---- | Less than.-svLessThan :: SVal -> SVal -> SVal-svLessThan x y- | isConcreteMax x = svFalse- | isConcreteMin y = svFalse- | True = liftSym2B (mkSymOpSC (eqOpt falseSV) LessThan) rationalCheck (<) (<) (<) (<) (<) (<) (<) (<) (<) (<) (<) (<) (uiLift "<" (<)) x y---- | Greater than.-svGreaterThan :: SVal -> SVal -> SVal-svGreaterThan x y- | isConcreteMin x = svFalse- | isConcreteMax y = svFalse- | True = liftSym2B (mkSymOpSC (eqOpt falseSV) GreaterThan) rationalCheck (>) (>) (>) (>) (>) (>) (>) (>) (>) (>) (>) (>) (uiLift ">" (>)) x y---- | Less than or equal to.-svLessEq :: SVal -> SVal -> SVal-svLessEq x y- | isConcreteMin x = svTrue- | isConcreteMax y = svTrue- | True = liftSym2B (mkSymOpSC (eqOpt trueSV) LessEq) rationalCheck (<=) (<=) (<=) (<=) (<=) (<=) (<=) (<=) (<=) (<=) (<=) (<=) (uiLift "<=" (<=)) x y---- | Greater than or equal to.-svGreaterEq :: SVal -> SVal -> SVal-svGreaterEq x y- | isConcreteMax x = svTrue- | isConcreteMin y = svTrue- | True = liftSym2B (mkSymOpSC (eqOpt trueSV) GreaterEq) rationalCheck (>=) (>=) (>=) (>=) (>=) (>=) (>=) (>=) (>=) (>=) (>=) (>=) (uiLift ">=" (>=)) x y---- | Bitwise and.-svAnd :: SVal -> SVal -> SVal-svAnd x y- | isConcreteZero x = x- | isConcreteOnes x = y- | isConcreteZero y = y- | isConcreteOnes y = x- | True = liftSym2 (mkSymOpSC opt And) [] (noReal ".&.") (.&.) (noFloat ".&.") (noDouble ".&.") (noFP ".&.") (noRat ".&") x y- where opt a b- | a == falseSV || b == falseSV = Just falseSV- | a == trueSV = Just b- | b == trueSV = Just a- | True = Nothing---- | Bitwise or.-svOr :: SVal -> SVal -> SVal-svOr x y- | isConcreteZero x = y- | isConcreteOnes x = x- | isConcreteZero y = x- | isConcreteOnes y = y- | True = liftSym2 (mkSymOpSC opt Or) []- (noReal ".|.") (.|.) (noFloat ".|.") (noDouble ".|.") (noFP ".|.") (noRat ".|.") x y- where opt a b- | a == trueSV || b == trueSV = Just trueSV- | a == falseSV = Just b- | b == falseSV = Just a- | True = Nothing---- | Bitwise xor.-svXOr :: SVal -> SVal -> SVal-svXOr x y- | isConcreteZero x = y- | isConcreteOnes x = svNot y- | isConcreteZero y = x- | isConcreteOnes y = svNot x- | True = liftSym2 (mkSymOpSC opt XOr) []- (noReal "xor") xor (noFloat "xor") (noDouble "xor") (noFP "xor") (noRat "xor") x y- where opt a b- | a == b && swKind a == KBool = Just falseSV- | a == falseSV = Just b- | b == falseSV = Just a- | True = Nothing---- | Bitwise complement.-svNot :: SVal -> SVal-svNot = liftSym1 (mkSymOp1SC opt Not)- (noRealUnary "complement") complement- (noFloatUnary "complement") (noDoubleUnary "complement") (noFPUnary "complement") (noRatUnary "complement")- where opt a- | a == falseSV = Just trueSV- | a == trueSV = Just falseSV- | True = Nothing---- | Shift left by a constant amount. Translates to the "bvshl"--- operation in SMT-Lib.------ NB. Haskell spec says the behavior is undefined if the shift amount--- is negative. We arbitrarily return the value unchanged if this is the case.-svShl :: SVal -> Int -> SVal-svShl x i- | i <= 0- = x- | isBounded x, i >= intSizeOf x- = svInteger k 0- | True- = x `svShiftLeft` svInteger k (fromIntegral i)- where k = kindOf x---- | Shift right by a constant amount. Translates to either "bvlshr"--- (logical shift right) or "bvashr" (arithmetic shift right) in--- SMT-Lib, depending on whether @x@ is a signed bitvector.------ NB. Haskell spec says the behavior is undefined if the shift amount--- is negative. We arbitrarily return the value unchanged if this is the case.-svShr :: SVal -> Int -> SVal-svShr x i- | i <= 0- = x- | isBounded x, i >= intSizeOf x- = if not (hasSign x)- then z- else svIte (x `svLessThan` z) neg1 z- | True- = x `svShiftRight` svInteger k (fromIntegral i)- where k = kindOf x- z = svInteger k 0- neg1 = svInteger k (-1)---- | Rotate-left, by a constant.------ NB. Haskell spec says the behavior is undefined if the shift amount--- is negative. We arbitrarily return the value unchanged if this is the case.-svRol :: SVal -> Int -> SVal-svRol x i- | i <= 0- = x- | True- = case kindOf x of- KBounded _ sz -> liftSym1 (mkSymOp1 (Rol (i `mod` sz)))- (noRealUnary "rotateL") (rot True sz i)- (noFloatUnary "rotateL") (noDoubleUnary "rotateL") (noFPUnary "rotateL") (noRatUnary "rotateL") x- _ -> svShl x i -- for unbounded Integers, rotateL is the same as shiftL in Haskell---- | Rotate-right, by a constant.------ NB. Haskell spec says the behavior is undefined if the shift amount--- is negative. We arbitrarily return the value unchanged if this is the case.-svRor :: SVal -> Int -> SVal-svRor x i- | i <= 0- = x- | True- = case kindOf x of- KBounded _ sz -> liftSym1 (mkSymOp1 (Ror (i `mod` sz)))- (noRealUnary "rotateR") (rot False sz i)- (noFloatUnary "rotateR") (noDoubleUnary "rotateR") (noFPUnary "rotateR") (noRatUnary "rotateR") x- _ -> svShr x i -- for unbounded integers, rotateR is the same as shiftR in Haskell---- | Generic rotation. Since the underlying representation is just Integers, rotations has to be--- careful on the bit-size.-rot :: Bool -> Int -> Int -> Integer -> Integer-rot toLeft sz amt x- | sz < 2 = x- | True = norm x y' `shiftL` y .|. norm (x `shiftR` y') y- where (y, y') | toLeft = (amt `mod` sz, sz - y)- | True = (sz - y', amt `mod` sz)- norm v s = v .&. ((1 `shiftL` s) - 1)---- | Extract bit-sequences.-svExtract :: Int -> Int -> SVal -> SVal-svExtract i j x@(SVal (KBounded s _) _)- | i < j- = SVal k (Left $! CV k (CInteger 0))- | SVal _ (Left (CV _ (CInteger v))) <- x- = SVal k (Left $! normCV (CV k (CInteger (v `shiftR` j))))- | True- = SVal k (Right (cache y))- where k = KBounded s (i - j + 1)- y st = do sv <- svToSV st x- newExpr st k (SBVApp (Extract i j) [sv])-svExtract i j v@(SVal KFloat _) = svExtract i j (svFloatAsSWord32 v)-svExtract i j v@(SVal KDouble _) = svExtract i j (svDoubleAsSWord64 v)-svExtract i j v@(SVal KFP{} _) = svExtract i j (svFloatingPointAsSWord v)-svExtract _ _ _ = error "extract: non-bitvector/float type"---- | Join two words, by concatenating-svJoin :: SVal -> SVal -> SVal-svJoin x@(SVal (KBounded s i) a) y@(SVal (KBounded s' j) b)- | s /= s'- = error $ "svJoin: received differently signed values: " ++ show (x, y)- | i == 0 = y- | j == 0 = x- | Left (CV _ (CInteger m)) <- a, Left (CV _ (CInteger n)) <- b- = let val- | s -- signed, arithmetic doesn't work; blast and come back- = let xbits = [m `testBit` xi | xi <- [0 .. i-1]]- ybits = [n `testBit` yi | yi <- [0 .. j-1]]- rbits = zip [0..] (ybits ++ xbits)- in foldl' (\acc (idx, set) -> if set then setBit acc idx else acc) 0 rbits- | True -- unsigned, go fast- = m `shiftL` j .|. n- in SVal k (Left $! normCV (CV k (CInteger val)))- | True- = SVal k (Right (cache z))- where- k = KBounded s (i + j)- z st = do xsw <- svToSV st x- ysw <- svToSV st y- newExpr st k (SBVApp Join [xsw, ysw])-svJoin _ _ = error "svJoin: non-bitvector type"---- | Zero-extend by given number of bits.-svZeroExtend :: Int -> SVal -> SVal-svZeroExtend = svExtend True ZeroExtend---- | Sign-extend by given number of bits.-svSignExtend :: Int -> SVal -> SVal-svSignExtend = svExtend False SignExtend--svExtend :: Bool -> (Int -> Op) -> Int -> SVal -> SVal-svExtend isZeroExtend extender i x@(SVal (KBounded s sz) a)- | i < 0- = error $ "svExtend: Received negative extension amount: " ++ show i- | i == 0- = x- | Left (CV _ (CInteger cv)) <- a- = SVal k' (Left (normCV (CV k' (CInteger (replBit (not isZeroExtend && (cv `testBit` (sz-1))) cv)))))- | True- = SVal k' (Right (cache z))- where k' = KBounded s (sz+i)- z st = do xsw <- svToSV st x- newExpr st k' (SBVApp (extender i) [xsw])-- replBit :: Bool -> Integer -> Integer- replBit b = go sz- where stop = sz + i- go k v | k == stop = v- | b = go (k+1) (v `setBit` k)- | True = go (k+1) (v `clearBit` k)--svExtend _ _ _ _ = error "svExtend: non-bitvector type"---- | If-then-else. This one will force branches.-svIte :: SVal -> SVal -> SVal -> SVal-svIte t a b = svSymbolicMerge (kindOf a) True t a b---- | Lazy If-then-else. This one will delay forcing the branches unless it's really necessary.-svLazyIte :: Kind -> SVal -> SVal -> SVal -> SVal-svLazyIte k t a b = svSymbolicMerge k False t a b---- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make--- sure they do not evaluate to the same result.-svSymbolicMerge :: Kind -> Bool -> SVal -> SVal -> SVal -> SVal-svSymbolicMerge k force t a b- | Just r <- svAsBool t- = if r then a else b- | force, rationalSBVCheck a b, sameResult a b- = a- | True- = SVal k $ Right $ cache c- where sameResult (SVal _ (Left c1)) (SVal _ (Left c2)) = c1 == c2- sameResult _ _ = False-- c st = do swt <- svToSV st t- case () of- () | 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- 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"- under the incorrect assumptions. To wit, consider the following:-- foo x y = ite (y .== 0) k (k+1)- where k = ite (y .== 0) x (x+1)-- When we reduce the 'then' branch of the first ite, we'd record the assumption that y is 0. But while reducing the 'then' branch, we'd- like to share @k@, which would evaluate (correctly) to @x@ under the given assumption. When we backtrack and evaluate the 'else'- branch of the first ite, we'd see @k@ is needed again, and we'd look it up from our sharing map to find (incorrectly) that its value- is @x@, which was stored there under the assumption that y was 0, which no longer holds. Clearly, this is unsound.-- A sound implementation would have to precisely track which assumptions were active at the time expressions get shared. That is,- in the above example, we should record that the value of @k@ was cached under the assumption that @y@ is 0. While sound, this- approach unfortunately leads to significant loss of valid sharing when the value itself had nothing to do with the assumption itself.- To wit, consider:-- foo x y = ite (y .== 0) k (k+1)- where k = x+5-- If we tracked the assumptions, we would recompute @k@ twice, since the branch assumptions would differ. Clearly, there is no need to- re-compute @k@ in this case since its value is independent of @y@. Note that the whole SBV performance story is based on aggressive sharing,- and losing that would have other significant ramifications.-- The "proper" solution would be to track, with each shared computation, precisely which assumptions it actually *depends* on, rather- than blindly recording all the assumptions present at that time. SBV's symbolic simulation engine clearly has all the info needed to do this- properly, but the implementation is not straightforward at all. For each subexpression, we would need to chase down its dependencies- transitively, which can require a lot of scanning of the generated program causing major slow-down; thus potentially defeating the- whole purpose of sharing in the first place.-- Design choice: Keep it simple, and simply do not track the assumption at all. This will maximize sharing, at the cost of evaluating- unreachable branches. I think the simplicity is more important at this point than efficiency.-- Also note that the user can avoid most such issues by properly combining if-then-else's with common conditions together. That is, the- first program above should be written like this:-- foo x y = ite (y .== 0) x (x+2)-- In general, the following transformations should be done whenever possible:-- ite e1 (ite e1 e2 e3) e4 --> ite e1 e2 e4- ite e1 e2 (ite e1 e3 e4) --> ite e1 e2 e4-- This is in accordance with the general rule-of-thumb stating conditionals should be avoided as much as possible. However, we might prefer- the following:-- ite e1 (f e2 e4) (f e3 e5) --> f (ite e1 e2 e3) (ite e1 e4 e5)-- especially if this expression happens to be inside 'f's body itself (i.e., when f is recursive), since it reduces the number of- recursive calls. Clearly, programming with symbolic simulation in mind is another kind of beast altogether.- -}- let sta = st `extendSValPathCondition` svAnd t- let stb = st `extendSValPathCondition` svAnd (svNot t)- swa <- svToSV sta a -- evaluate 'then' branch- swb <- svToSV stb b -- evaluate 'else' branch-- -- merge, but simplify for certain boolean cases:- case () of- () | swa == swb -> return swa -- if t then a else a ==> a- () | swa == trueSV && swb == falseSV -> return swt -- if t then true else false ==> t- () | swa == falseSV && swb == trueSV -> newExpr st k (SBVApp Not [swt]) -- if t then false else true ==> not t- () | swa == trueSV -> newExpr st k (SBVApp Or [swt, swb]) -- if t then true else b ==> t OR b- () | swa == falseSV -> do swt' <- newExpr st KBool (SBVApp Not [swt])- newExpr st k (SBVApp And [swt', swb]) -- if t then false else b ==> t' AND b- () | swb == trueSV -> do swt' <- newExpr st KBool (SBVApp Not [swt])- newExpr st k (SBVApp Or [swt', swa]) -- if t then a else true ==> t' OR a- () | swb == falseSV -> newExpr st k (SBVApp And [swt, swa]) -- if t then a else false ==> t AND a- () -> newExpr st k (SBVApp Ite [swt, swa, swb])---- | Total indexing operation. @svSelect xs default index@ is--- intuitively the same as @xs !! index@, except it evaluates to--- @default@ if @index@ overflows. Translates to SMT-Lib tables.-svSelect :: [SVal] -> SVal -> SVal -> SVal-svSelect xs err ind- | SVal _ (Left c) <- ind =- case cvVal c of- CInteger i -> if i < 0 || i >= genericLength xs- then err- else xs `genericIndex` i- _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"-svSelect xsOrig err ind = xs `seq` SVal kElt (Right (cache r))- where- kInd = kindOf ind- kElt = kindOf err- -- Based on the index size, we need to limit the elements. For- -- instance if the index is 8 bits, but there are 257 elements,- -- that last element will never be used and we can chop it off.- xs = case kInd of- KBounded False i -> genericTake ((2::Integer) ^ i) xsOrig- KBounded True i -> genericTake ((2::Integer) ^ (i-1)) xsOrig- KUnbounded -> xsOrig- _ -> error $ "SBV.select: unsupported " ++ show kInd ++ " valued select/index expression"- r st = do sws <- mapM (svToSV st) xs- swe <- svToSV st err- if all (== swe) sws -- off-chance that all elts are the same- then return swe- else do idx <- getTableIndex st kInd kElt sws- swi <- svToSV st ind- let len = length xs- -- NB. No need to worry here that the index- -- might be < 0; as the SMTLib translation- -- takes care of that automatically- newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])---- Change the sign of a bit-vector quantity. Fails if passed a non-bv-svChangeSign :: Bool -> SVal -> SVal-svChangeSign s x- | not (isBounded x) = error $ "Data.SBV." ++ nm ++ ": Received non bit-vector kind: " ++ show (kindOf x)- | Just n <- svAsInteger x = svInteger k n- | True = SVal k (Right (cache y))- where- nm = if s then "svSign" else "svUnsign"-- k = KBounded s (intSizeOf x)- y st = do xsw <- svToSV st x- newExpr st k (SBVApp (Extract (intSizeOf x - 1) 0) [xsw])---- | Convert a symbolic bitvector from unsigned to signed.-svSign :: SVal -> SVal-svSign = svChangeSign True---- | Convert a symbolic bitvector from signed to unsigned.-svUnsign :: SVal -> SVal-svUnsign = svChangeSign False---- | Convert a symbolic bitvector from one integral kind to another.-svFromIntegral :: Kind -> SVal -> SVal-svFromIntegral kTo x- | Just v <- svAsInteger x- = svInteger kTo v- | True- = result- where result = SVal kTo (Right (cache y))- kFrom = kindOf x- y st = do xsw <- svToSV st x- newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw])------------------------------------------------------------------------------------- Derived operations---- | Convert an SVal from kind Bool to an unsigned bitvector of size 1.-svToWord1 :: SVal -> SVal-svToWord1 b = svSymbolicMerge k True b (svInteger k 1) (svInteger k 0)- where k = KBounded False 1---- | Convert an SVal from a bitvector of size 1 (signed or unsigned) to kind Bool.-svFromWord1 :: SVal -> SVal-svFromWord1 x = svNotEqual x (svInteger k 0)- where k = kindOf x---- | Test the value of a bit. Note that we do an extract here--- as opposed to masking and checking against zero, as we found--- extraction to be much faster with large bit-vectors.-svTestBit :: SVal -> Int -> SVal-svTestBit x i- | i < intSizeOf x = svFromWord1 (svExtract i i x)- | True = svFalse---- | Generalization of 'svShl', where the shift-amount is symbolic.-svShiftLeft :: SVal -> SVal -> SVal-svShiftLeft = svShift True---- | Generalization of 'svShr', where the shift-amount is symbolic.------ NB. If the shiftee is signed, then this is an arithmetic shift;--- otherwise it's logical.-svShiftRight :: SVal -> SVal -> SVal-svShiftRight = svShift False---- | Generic shifting of bounded quantities. The shift amount must be non-negative and within the bounds of the argument--- for bit vectors. For negative shift amounts, the result is returned unchanged. For overshifts, left-shift produces 0,--- right shift produces 0 or -1 depending on the result being signed.-svShift :: Bool -> SVal -> SVal -> SVal-svShift toLeft x i- | Just r <- constFoldValue- = r- | cannotOverShift- = svIte (i `svLessThan` svInteger ki 0) -- Negative shift, no change- x- regularShiftValue- | True- = svIte (i `svLessThan` svInteger ki 0) -- Negative shift, no change- x- $ svIte (i `svGreaterEq` svInteger ki (fromIntegral (intSizeOf x))) -- Overshift, by at least the bit-width of x- overShiftValue- regularShiftValue-- where nm | toLeft = "shiftLeft"- | True = "shiftRight"-- kx = kindOf x- ki = kindOf i-- -- Constant fold the result if possible. If either quantity is unbounded, then we only support constants- -- as there's no easy/meaningful way to map this combo to SMTLib. Should be rarely needed, if ever!- -- We also perform basic sanity check here so that if we go past here, we know we have bitvectors only.- constFoldValue- | Just iv <- getConst i, iv == 0- = Just x-- | Just xv <- getConst x, xv == 0- = Just x-- | Just xv <- getConst x, Just iv <- getConst i- = Just $ SVal kx . Left $! normCV $ CV kx (CInteger (xv `opC` shiftAmount iv))-- | isUnbounded x || isUnbounded i- = bailOut $ "Not yet implemented unbounded/non-constants shifts for " ++ show (kx, ki) ++ ", please file a request!"-- | not (isBounded x && isBounded i)- = bailOut $ "Unexpected kinds: " ++ show (kx, ki)-- | True- = Nothing-- where bailOut m = error $ "SBV." ++ nm ++ ": " ++ m-- getConst (SVal _ (Left (CV _ (CInteger val)))) = Just val- getConst _ = Nothing-- opC | toLeft = shiftL- | True = shiftR-- -- like fromIntegral, but more paranoid- shiftAmount :: Integer -> Int- shiftAmount iv- | iv <= 0 = 0- | isUnbounded i, iv > fromIntegral (maxBound :: Int) = bailOut $ "Unsupported constant unbounded shift with amount: " ++ show iv- | isUnbounded x = fromIntegral iv- | iv >= fromIntegral ub = ub- | not (isBounded x && isBounded i) = bailOut $ "Unsupported kinds: " ++ show (kx, ki)- | True = fromIntegral iv- where ub = intSizeOf x-- -- Overshift is not possible if the bit-size of x won't even fit into the bit-vector size- -- of i. Note that this is a *necessary* check, Consider for instance if we're shifting a- -- 32-bit value using a 1-bit shift amount (which can happen if the value is 1 with minimal- -- shift widths). We would compare 1 >= 32, but stuffing 32 into bit-vector of size 1 would- -- overflow. See http://github.com/LeventErkok/sbv/issues/323 for this case. Thus, we- -- make sure that the bit-vector would fit as a value.- cannotOverShift = maxRepresentable <= fromIntegral (intSizeOf x)- where maxRepresentable :: Integer- maxRepresentable- | hasSign i = bit (intSizeOf i - 1) - 1- | True = bit (intSizeOf i ) - 1-- -- An overshift occurs if we're shifting by more than or equal to the bit-width of x- -- For shift-left: this value is always 0- -- For shift-right:- -- If x is unsigned: 0- -- If x is signed and is less than 0, then -1 else 0- overShiftValue | toLeft = zx- | hasSign x = svIte (x `svLessThan` zx) neg1 zx- | True = zx- where zx = svInteger kx 0- neg1 = svInteger kx (-1)-- -- Regular shift, we know that the shift value fits into the bit-width of x, since it's between 0 and sizeOf x. So, we can just- -- turn it into a properly sized argument and ship it to SMTLib- regularShiftValue = SVal kx $ Right $ cache result- where result st = do sw1 <- svToSV st x- sw2 <- svToSV st i-- let op | toLeft = Shl- | True = Shr-- adjustedShift <- if kx == ki- then return sw2- else newExpr st kx (SBVApp (KindCast ki kx) [sw2])-- newExpr st kx (SBVApp op [sw1, adjustedShift])---- | Generalization of 'svRol', where the rotation amount is symbolic.--- If the first argument is not bounded, then the this is the same as shift.-svRotateLeft :: SVal -> SVal -> SVal-svRotateLeft x i- | not (isBounded x)- = svShiftLeft x i- | isBounded i && bit si <= toInteger sx -- wrap-around not possible- = svIte (svLessThan i zi)- (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z (svUNeg i))- (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z i)- | True- = svIte (svLessThan i zi)- (svSelect [x `svRor` k | k <- [0 .. sx - 1]] z (svUNeg i `svRem` n))- (svSelect [x `svRol` k | k <- [0 .. sx - 1]] z ( i `svRem` n))- where sx = intSizeOf x- si = intSizeOf i- z = svInteger (kindOf x) 0- zi = svInteger (kindOf i) 0- n = svInteger (kindOf i) (toInteger sx)---- | A variant of 'svRotateLeft' that uses a barrel-rotate design, which can lead to--- better verification code. Only works when both arguments are finite and the second--- argument is unsigned.-svBarrelRotateLeft :: SVal -> SVal -> SVal-svBarrelRotateLeft x i- | not (isBounded x && isBounded i && not (hasSign i))- = error $ "Data.SBV.Dynamic.svBarrelRotateLeft: Arguments must be bounded with second argument unsigned. Received: " ++ show (x, i)- | Just iv <- svAsInteger i- = svRol x $ fromIntegral (iv `rem` fromIntegral (intSizeOf x))- | True- = barrelRotate svRol x i---- | A variant of 'svRotateLeft' that uses a barrel-rotate design, which can lead to--- better verification code. Only works when both arguments are finite and the second--- argument is unsigned.-svBarrelRotateRight :: SVal -> SVal -> SVal-svBarrelRotateRight x i- | not (isBounded x && isBounded i && not (hasSign i))- = error $ "Data.SBV.Dynamic.svBarrelRotateRight: Arguments must be bounded with second argument unsigned. Received: " ++ show (x, i)- | Just iv <- svAsInteger i- = svRor x $ fromIntegral (iv `rem` fromIntegral (intSizeOf x))- | True- = barrelRotate svRor x i---- Barrel rotation, by bit-blasting the argument:-barrelRotate :: (SVal -> Int -> SVal) -> SVal -> SVal -> SVal-barrelRotate f a c = loop blasted a- where loop :: [(SVal, Integer)] -> SVal -> SVal- loop [] acc = acc- loop ((b, v) : rest) acc = loop rest (svIte b (f acc (fromInteger v)) acc)-- sa = toInteger $ intSizeOf a- n = svInteger (kindOf c) sa-- -- Reduce by the modulus amount, we need not care about the- -- any part larger than the value of the bit-size of the- -- argument as it is identity for rotations- reducedC = c `svRem` n-- -- blast little-endian, and zip with bit-position- blasted = takeWhile significant $ zip (svBlastLE reducedC) [2^i | i <- [(0::Integer)..]]-- -- Any term whose bit-position is larger than our input size- -- is insignificant, since the reduction would've put 0's in those- -- bits. For instance, if a is 32 bits, and c is 5 bits, then we- -- need not look at any position i s.t. 2^i > 32- significant (_, pos) = pos < sa---- | Generalization of 'svRor', where the rotation amount is symbolic.--- If the first argument is not bounded, then the this is the same as shift.-svRotateRight :: SVal -> SVal -> SVal-svRotateRight x i- | not (isBounded x)- = svShiftRight x i- | isBounded i && bit si <= toInteger sx -- wrap-around not possible- = svIte (svLessThan i zi)- (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z (svUNeg i))- (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z i)- | True- = svIte (svLessThan i zi)- (svSelect [x `svRol` k | k <- [0 .. sx - 1]] z (svUNeg i `svRem` n))- (svSelect [x `svRor` k | k <- [0 .. sx - 1]] z ( i `svRem` n))- where sx = intSizeOf x- si = intSizeOf i- z = svInteger (kindOf x) 0- zi = svInteger (kindOf i) 0- n = svInteger (kindOf i) (toInteger sx)------------------------------------------------------------------------------------- | Overflow detection.-svMkOverflow :: OvOp -> SVal -> SVal -> SVal-svMkOverflow o x y = SVal KBool (Right (cache r))- where r st = do sx <- svToSV st x- sy <- svToSV st y- newExpr st KBool $ SBVApp (OverflowOp o) [sx, sy]-------------------------------------------------------------------------------------- * Symbolic Arrays-------------------------------------------------------------------------------------- | Arrays in terms of SMT-Lib arrays-data SArr = SArr (Kind, Kind) (Cached ArrayIndex)---- | Read the array element at @a@-readSArr :: SArr -> SVal -> SVal-readSArr (SArr (_, bk) f) a = SVal bk $ Right $ cache r- where r st = do arr <- uncacheAI f st- i <- svToSV st a- newExpr st bk (SBVApp (ArrRead arr) [i])---- | Update the element at @a@ to be @b@-writeSArr :: SArr -> SVal -> SVal -> SArr-writeSArr (SArr ainfo f) a b = SArr ainfo $ cache g- where g st = do arr <- uncacheAI f st- addr <- svToSV st a- val <- svToSV st b- amap <- R.readIORef (rArrayMap st)-- let j = ArrayIndex $ IMap.size amap- upd = IMap.insert (unArrayIndex j) ("array_" ++ show j, ainfo, ArrayMutate arr addr val)-- j `seq` modifyState st rArrayMap upd $ modifyIncState st rNewArrs upd- return j---- | Merge two given arrays on the symbolic condition--- Intuitively: @mergeArrays cond a b = if cond then a else b@.--- Merging pushes the if-then-else choice down on to elements-mergeSArr :: SVal -> SArr -> SArr -> SArr-mergeSArr t (SArr ainfo a) (SArr _ b) = SArr ainfo $ cache h- where h st = do ai <- uncacheAI a st- bi <- uncacheAI b st- ts <- svToSV st t- amap <- R.readIORef (rArrayMap st)-- let k = ArrayIndex $ IMap.size amap- upd = IMap.insert (unArrayIndex k) ("array_" ++ show k, ainfo, ArrayMerge ts ai bi)-- k `seq` modifyState st rArrayMap upd $ modifyIncState st rNewArrs upd- return k---- | Create a named new array-newSArr :: State -> (Kind, Kind) -> (Int -> String) -> Maybe SVal -> IO SArr-newSArr st ainfo mkNm mbDef = do- amap <- R.readIORef $ rArrayMap st-- mbSWDef <- case mbDef of- Nothing -> return Nothing- Just sv -> Just <$> svToSV st sv-- let i = ArrayIndex $ IMap.size amap- nm = mkNm (unArrayIndex i)- upd = IMap.insert (unArrayIndex i) (nm, ainfo, ArrayFree mbSWDef)-- registerLabel "SArray declaration" st nm-- modifyState st rArrayMap upd $ modifyIncState st rNewArrs upd- return $ SArr ainfo $ cache $ const $ return i---- | Compare two arrays for equality-eqSArr :: SArr -> SArr -> SVal-eqSArr (SArr _ a) (SArr _ b) = SVal KBool $ Right $ cache c- where c st = do ai <- uncacheAI a st- bi <- uncacheAI b st- newExpr st KBool (SBVApp (ArrEq ai bi) [])------------------------------------------------------------------------------------- Utility functions--noUnint :: (Maybe Int, String) -> a-noUnint x = error $ "Unexpected operation called on uninterpreted/enumerated value: " ++ show x--noUnint2 :: (Maybe Int, String) -> (Maybe Int, String) -> a-noUnint2 x y = error $ "Unexpected binary operation called on uninterpreted/enumerated values: " ++ show (x, y)--noCharLift :: Char -> a-noCharLift x = error $ "Unexpected operation called on char: " ++ show x--noStringLift :: String -> a-noStringLift x = error $ "Unexpected operation called on string: " ++ show x--noCharLift2 :: Char -> Char -> a-noCharLift2 x y = error $ "Unexpected binary operation called on chars: " ++ show (x, y)--noStringLift2 :: String -> String -> a-noStringLift2 x y = error $ "Unexpected binary operation called on strings: " ++ show (x, y)--liftSym1 :: (State -> Kind -> SV -> IO SV) -> (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> (FP -> FP) ->(Rational -> Rational) -> SVal -> SVal-liftSym1 _ opCR opCI opCF opCD opFP opRA (SVal k (Left a)) = SVal k . Left $! mapCV opCR opCI opCF opCD opFP opRA noCharLift noStringLift noUnint a-liftSym1 opS _ _ _ _ _ _ a@(SVal k _) = SVal k $ Right $ cache c- where c st = do sva <- svToSV st a- opS st k sva--{- A note on constant folding.--There are cases where we miss out on certain constant foldings. On May 8 2018, Matt Peddie pointed this-out, as the C code he was getting had redundancies. I was aware that could be missing constant foldings-due to missed out optimizations, or some other code snafu, but till Matt pointed it out I haven't realized-that we could be hiding constants inside an if-then-else. The example is:-- proveWith z3{verbose=True} $ \x -> 0 .< ite (x .== (x::SWord8)) 1 (2::SWord8)--If you try this, you'll see that it generates (shortened):-- (define-fun s1 () (_ BitVec 8) #x00)- (define-fun s2 () (_ BitVec 8) #x01)- (define-fun s3 () Bool (bvult s1 s2))--But clearly we have all the info for s3 to be computed! The issue here is that the reduction of @x .== x@ to @true@-happens after we start computing the if-then-else, hence we are already committed to an SV at that point. The call-to ite eventually recognizes this, but at that point it picks up the now constants from SV's, missing the constant-folding opportunity.--We can fix this, by looking up the constants table in liftSV2, along the lines of:--- liftSV2 :: (CV -> CV -> Bool) -> (CV -> CV -> CV) -> (State -> Kind -> SV -> SV -> IO SV) -> Kind -> SVal -> SVal -> Cached SV- liftSV2 okCV opCV opS k a b = cache c- where c st = do sw1 <- svToSV st a- sw2 <- svToSV st b- cmap <- readIORef (rconstMap st)- let cv1 = [cv | ((_, cv), sv) <- M.toList cmap, sv == sv1]- cv2 = [cv | ((_, cv), sv) <- M.toList cmap, sv == sv2]- case (cv1, cv2) of- ([x], [y]) | okCV x y -> newConst st $ opCV x y- _ -> opS st k sv1 sv2--(with obvious modifications to call sites to get the proper arguments.)--But this means that we have to grab the constant list for every symbolically lifted operation, also do the-same for other places, etc.; for the rare opportunity of catching a @x .== x@ optimization. Even then, the-constants for the branches would still be generated. (i.e., in the above example we would still generate-@s1@ and @s2@, but would skip @s3@.)--It seems to me that the price to pay is rather high, as this is hardly the most common case; so we're opting-here to ignore these cases.--See http://github.com/LeventErkok/sbv/issues/379 for some further discussion.--}-liftSV2 :: (State -> Kind -> SV -> SV -> IO SV) -> Kind -> SVal -> SVal -> Cached SV-liftSV2 opS k a b = cache c- where c st = do sw1 <- svToSV st a- sw2 <- svToSV st b- opS st k sw1 sw2--liftSym2 :: (State -> Kind -> SV -> SV -> IO SV)- -> [CV -> CV -> Bool]- -> (AlgReal -> AlgReal -> AlgReal)- -> (Integer -> Integer -> Integer)- -> (Float -> Float -> Float)- -> (Double -> Double -> Double)- -> (FP -> FP -> FP)- -> (Rational -> Rational-> Rational)- -> SVal -> SVal -> SVal-liftSym2 _ okCV opCR opCI opCF opCD opFP opRA (SVal k (Left a)) (SVal _ (Left b)) | and [f a b | f <- okCV] = SVal k . Left $! mapCV2 opCR opCI opCF opCD opFP opRA noCharLift2 noStringLift2 noUnint2 a b-liftSym2 opS _ _ _ _ _ _ _ a@(SVal k _) b = SVal k $ Right $ liftSV2 opS k a b--liftSym2B :: (State -> Kind -> SV -> SV -> IO SV)- -> (CV -> CV -> Bool)- -> (AlgReal -> AlgReal -> Bool)- -> (Integer -> Integer -> Bool)- -> (Float -> Float -> Bool)- -> (Double -> Double -> Bool)- -> (FP -> FP -> Bool)- -> (Rational -> Rational -> Bool)- -> (Char -> Char -> Bool)- -> (String -> String -> Bool)- -> ([CVal] -> [CVal] -> Bool)- -> ([CVal] -> [CVal] -> Bool)- -> (Maybe CVal -> Maybe CVal -> Bool)- -> (Either CVal CVal -> Either CVal CVal -> Bool)- -> ((Maybe Int, String) -> (Maybe Int, String) -> Bool)- -> SVal -> SVal -> SVal-liftSym2B _ okCV opCR opCI opCF opCD opAF opAR opCC opCS opCSeq opCTup opCMaybe opCEither opUI (SVal _ (Left a)) (SVal _ (Left b)) | okCV a b = svBool (liftCV2 opCR opCI opCF opCD opAF opAR opCC opCS opCSeq opCTup opCMaybe opCEither opUI a b)-liftSym2B opS _ _ _ _ _ _ _ _ _ _ _ _ _ _ a b = SVal KBool $ Right $ liftSV2 opS KBool a b---- | Create a symbolic two argument operation; with shortcut optimizations-mkSymOpSC :: (SV -> SV -> Maybe SV) -> Op -> State -> Kind -> SV -> SV -> IO SV-mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b)---- | Create a symbolic two argument operation; no shortcut optimizations-mkSymOp :: Op -> State -> Kind -> SV -> SV -> IO SV-mkSymOp = mkSymOpSC (const (const Nothing))--mkSymOp1SC :: (SV -> Maybe SV) -> Op -> State -> Kind -> SV -> IO SV-mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) return (shortCut a)--mkSymOp1 :: Op -> State -> Kind -> SV -> IO SV-mkSymOp1 = mkSymOp1SC (const Nothing)---- | eqOpt says the references are to the same SV, thus we can optimize. Note that--- we explicitly disallow KFloat/KDouble/KFloat here. Why? Because it's *NOT* true that--- NaN == NaN, NaN >= NaN, and so-forth. So, we have to make sure we don't optimize--- floats and doubles, in case the argument turns out to be NaN.-eqOpt :: SV -> SV -> SV -> Maybe SV-eqOpt w x y = case swKind x of- KFloat -> Nothing- KDouble -> Nothing- KFP{} -> Nothing- _ -> if x == y then Just w else Nothing---- For uninterpreted/enumerated values, we carefully lift through the constructor index for comparisons:-uiLift :: String -> (Int -> Int -> Bool) -> (Maybe Int, String) -> (Maybe Int, String) -> Bool-uiLift _ cmp (Just i, _) (Just j, _) = i `cmp` j-uiLift w _ a b = error $ "Data.SBV.Core.Operations: Impossible happened while trying to lift " ++ w ++ " over " ++ show (a, b)---- | Predicate to check if a value is concrete-isConcrete :: SVal -> Bool-isConcrete (SVal _ Left{}) = True-isConcrete _ = False---- | Predicate for optimizing word operations like (+) and (*).--- NB. We specifically do *not* match for Double/Float; because--- FP-arithmetic doesn't obey traditional rules. For instance,--- 0 * x = 0 fails if x happens to be NaN or +/- Infinity. So,--- we merely return False when given a floating-point value here.-isConcreteZero :: SVal -> Bool-isConcreteZero (SVal _ (Left (CV _ (CInteger n)))) = n == 0-isConcreteZero (SVal KReal (Left (CV KReal (CAlgReal v)))) = isExactRational v && v == 0-isConcreteZero _ = False---- | Predicate for optimizing word operations like (+) and (*).--- NB. See comment on 'isConcreteZero' for why we don't match--- for Float/Double values here.-isConcreteOne :: SVal -> Bool-isConcreteOne (SVal _ (Left (CV _ (CInteger 1)))) = True-isConcreteOne (SVal KReal (Left (CV KReal (CAlgReal v)))) = isExactRational v && v == 1-isConcreteOne _ = False---- | Predicate for optimizing bitwise operations. The unbounded integer case of checking--- against -1 might look dubious, but that's how Haskell treats 'Integer' as a member--- of the Bits class, try @(-1 :: Integer) `testBit` i@ for any @i@ and you'll get 'True'.-isConcreteOnes :: SVal -> Bool-isConcreteOnes (SVal _ (Left (CV (KBounded b w) (CInteger n)))) = n == if b then -1 else bit w - 1-isConcreteOnes (SVal _ (Left (CV KUnbounded (CInteger n)))) = n == -1 -- see comment above-isConcreteOnes (SVal _ (Left (CV KBool (CInteger n)))) = n == 1-isConcreteOnes _ = False---- | Predicate for optimizing comparisons.-isConcreteMax :: SVal -> Bool-isConcreteMax (SVal _ (Left (CV (KBounded False w) (CInteger n)))) = n == bit w - 1-isConcreteMax (SVal _ (Left (CV (KBounded True w) (CInteger n)))) = n == bit (w - 1) - 1-isConcreteMax (SVal _ (Left (CV KBool (CInteger n)))) = n == 1-isConcreteMax _ = False---- | Predicate for optimizing comparisons.-isConcreteMin :: SVal -> Bool-isConcreteMin (SVal _ (Left (CV (KBounded False _) (CInteger n)))) = n == 0-isConcreteMin (SVal _ (Left (CV (KBounded True w) (CInteger n)))) = n == - bit (w - 1)-isConcreteMin (SVal _ (Left (CV KBool (CInteger n)))) = n == 0-isConcreteMin _ = False---- | Most operations on concrete rationals require a compatibility check to avoid faulting--- on algebraic reals.-rationalCheck :: CV -> CV -> Bool-rationalCheck a b = case (cvVal a, cvVal b) of- (CAlgReal x, CAlgReal y) -> isExactRational x && isExactRational y- _ -> True---- | Quot/Rem operations require a nonzero check on the divisor.-nonzeroCheck :: CV -> CV -> Bool-nonzeroCheck _ b = cvVal b /= CInteger 0---- | Same as rationalCheck, except for SBV's-rationalSBVCheck :: SVal -> SVal -> Bool-rationalSBVCheck (SVal KReal (Left a)) (SVal KReal (Left b)) = rationalCheck a b-rationalSBVCheck _ _ = True--noReal :: String -> AlgReal -> AlgReal -> AlgReal-noReal o a b = error $ "SBV.AlgReal." ++ o ++ ": Unexpected arguments: " ++ show (a, b)--noFloat :: String -> Float -> Float -> Float-noFloat o a b = error $ "SBV.Float." ++ o ++ ": Unexpected arguments: " ++ show (a, b)--noDouble :: String -> Double -> Double -> Double-noDouble o a b = error $ "SBV.Double." ++ o ++ ": Unexpected arguments: " ++ show (a, b)--noFP :: String -> FP -> FP -> FP-noFP o a b = error $ "SBV.FPR." ++ o ++ ": Unexpected arguments: " ++ show (a, b)--noRat:: String -> Rational -> Rational -> Rational-noRat o a b = error $ "SBV.Rational." ++ o ++ ": Unexpected arguments: " ++ show (a, b)--noRealUnary :: String -> AlgReal -> AlgReal-noRealUnary o a = error $ "SBV.AlgReal." ++ o ++ ": Unexpected argument: " ++ show a--noFloatUnary :: String -> Float -> Float-noFloatUnary o a = error $ "SBV.Float." ++ o ++ ": Unexpected argument: " ++ show a--noDoubleUnary :: String -> Double -> Double-noDoubleUnary o a = error $ "SBV.Double." ++ o ++ ": Unexpected argument: " ++ show a--noFPUnary :: String -> FP -> FP-noFPUnary o a = error $ "SBV.FPR." ++ o ++ ": Unexpected argument: " ++ show a--noRatUnary :: String -> Rational -> Rational-noRatUnary o a = error $ "SBV.Rational." ++ o ++ ": Unexpected argument: " ++ show a---- | Given a composite structure, figure out how to compare for less than-svStructuralLessThan :: SVal -> SVal -> SVal-svStructuralLessThan x y- | isConcrete x && isConcrete y- = x `svLessThan` y- | KTuple{} <- kx- = tupleLT x y- | KMaybe{} <- kx- = maybeLT x y- | KEither{} <- kx- = eitherLT x y- | True- = x `svLessThan` y- where kx = kindOf x---- | Structural less-than for tuples-tupleLT :: SVal -> SVal -> SVal-tupleLT x y = SVal KBool $ Right $ cache res- where ks = case kindOf x of- KTuple xs -> xs- k -> error $ "Data.SBV: Impossible happened, tupleLT called with: " ++ show (k, x, y)-- n = length ks-- res st = do sx <- svToSV st x- sy <- svToSV st y-- let chkElt i ek = let xi = SVal ek $ Right $ cache $ \_ -> newExpr st ek $ SBVApp (TupleAccess i n) [sx]- yi = SVal ek $ Right $ cache $ \_ -> newExpr st ek $ SBVApp (TupleAccess i n) [sy]- lt = xi `svStructuralLessThan` yi- eq = xi `svEqual` yi- in (lt, eq)-- walk [] = svFalse- walk [(lti, _)] = lti- walk ((lti, eqi) : rest) = lti `svOr` (eqi `svAnd` walk rest)-- svToSV st $ walk $ zipWith chkElt [1..] ks---- | Structural less-than for maybes-maybeLT :: SVal -> SVal -> SVal-maybeLT x y = sMaybeCase ( sMaybeCase svFalse (const svTrue) y)- (\jx -> sMaybeCase svFalse (jx `svStructuralLessThan`) y)- x- where ka = case kindOf x of- KMaybe k' -> k'- k -> error $ "Data.SBV: Impossible happened, maybeLT called with: " ++ show (k, x, y)-- sMaybeCase brNothing brJust s = SVal KBool $ Right $ cache res- where res st = do sv <- svToSV st s-- let justVal = SVal ka $ Right $ cache $ \_ -> newExpr st ka $ SBVApp MaybeAccess [sv]- justRes = brJust justVal-- br1 <- svToSV st brNothing- br2 <- svToSV st justRes-- -- Do we have a value?- noVal <- newExpr st KBool $ SBVApp (MaybeIs ka False) [sv]- newExpr st KBool $ SBVApp Ite [noVal, br1, br2]---- | Structural less-than for either-eitherLT :: SVal -> SVal -> SVal-eitherLT x y = sEitherCase (\lx -> sEitherCase (lx `svStructuralLessThan`) (const svTrue) y)- (\rx -> sEitherCase (const svFalse) (rx `svStructuralLessThan`) y)- x- where (ka, kb) = case kindOf x of- KEither k1 k2 -> (k1, k2)- k -> error $ "Data.SBV: Impossible happened, eitherLT called with: " ++ show (k, x, y)-- sEitherCase brA brB sab = SVal KBool $ Right $ cache res- where res st = do abv <- svToSV st sab-- let leftVal = SVal ka $ Right $ cache $ \_ -> newExpr st ka $ SBVApp (EitherAccess False) [abv]- rightVal = SVal kb $ Right $ cache $ \_ -> newExpr st kb $ SBVApp (EitherAccess True) [abv]-- leftRes = brA leftVal- rightRes = brB rightVal-- br1 <- svToSV st leftRes- br2 <- svToSV st rightRes-- -- Which branch are we in? Return the appropriate value:- onLeft <- newExpr st KBool $ SBVApp (EitherIs ka kb False) [abv]- newExpr st KBool $ SBVApp Ite [onLeft, br1, br2]---- | Convert an 'Data.SBV.SFloat' to an 'Data.SBV.SWord32', preserving the bit-correspondence. Note that since the--- representation for @NaN@s are not unique, this function will return a symbolic value when given a--- concrete @NaN@.------ Implementation note: Since there's no corresponding function in SMTLib for conversion to--- bit-representation due to partiality, we use a translation trick by allocating a new word variable,--- converting it to float, and requiring it to be equivalent to the input. In code-generation mode, we simply map--- it to a simple conversion.-svFloatAsSWord32 :: SVal -> SVal-svFloatAsSWord32 (SVal KFloat (Left (CV KFloat (CFloat f))))- | not (isNaN f)- = let w32 = KBounded False 32- in SVal w32 $ Left $ CV w32 $ CInteger (fromIntegral (floatToWord f))-svFloatAsSWord32 fVal@(SVal KFloat _)- = SVal w32 (Right (cache y))- where w32 = KBounded False 32- y st = do cg <- isCodeGenMode st- if cg- then do f <- svToSV st fVal- newExpr st w32 (SBVApp (IEEEFP (FP_Reinterpret KFloat w32)) [f])- else do n <- internalVariable st w32- ysw <- newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret w32 KFloat)) [n])- internalConstraint st False [] $ fVal `svStrongEqual` SVal KFloat (Right (cache (\_ -> return ysw)))- return n-svFloatAsSWord32 (SVal k _) = error $ "svFloatAsSWord32: non-float type: " ++ show k---- | Convert an 'Data.SBV.SDouble' to an 'Data.SBV.SWord64', preserving the bit-correspondence. Note that since the--- representation for @NaN@s are not unique, this function will return a symbolic value when given a--- concrete @NaN@.------ Implementation note: Since there's no corresponding function in SMTLib for conversion to--- bit-representation due to partiality, we use a translation trick by allocating a new word variable,--- converting it to float, and requiring it to be equivalent to the input. In code-generation mode, we simply map--- it to a simple conversion.-svDoubleAsSWord64 :: SVal -> SVal-svDoubleAsSWord64 (SVal KDouble (Left (CV KDouble (CDouble f))))- | not (isNaN f)- = let w64 = KBounded False 64- in SVal w64 $ Left $ CV w64 $ CInteger (fromIntegral (doubleToWord f))-svDoubleAsSWord64 fVal@(SVal KDouble _)- = SVal w64 (Right (cache y))- where w64 = KBounded False 64- y st = do cg <- isCodeGenMode st- if cg- then do f <- svToSV st fVal- newExpr st w64 (SBVApp (IEEEFP (FP_Reinterpret KDouble w64)) [f])- else do n <- internalVariable st w64- ysw <- newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret w64 KDouble)) [n])- internalConstraint st False [] $ fVal `svStrongEqual` SVal KDouble (Right (cache (\_ -> return ysw)))- return n-svDoubleAsSWord64 (SVal k _) = error $ "svDoubleAsSWord64: non-float type: " ++ show k---- | Convert a float to the word containing the corresponding bit pattern-svFloatingPointAsSWord :: SVal -> SVal-svFloatingPointAsSWord (SVal (KFP eb sb) (Left (CV _ (CFP f@(FP _ _ fpV)))))- | not (isNaN f)- = let wN = KBounded False (eb + sb)- in SVal wN $ Left $ CV wN $ CInteger $ bfToBits (mkBFOpts eb sb NearEven) fpV-svFloatingPointAsSWord fVal@(SVal kFrom@(KFP eb sb) _)- = SVal kTo (Right (cache y))- where kTo = KBounded False (eb + sb)- y st = do cg <- isCodeGenMode st- if cg- then do f <- svToSV st fVal- newExpr st kTo (SBVApp (IEEEFP (FP_Reinterpret kFrom kTo)) [f])- else do n <- internalVariable st kTo- ysw <- newExpr st kFrom (SBVApp (IEEEFP (FP_Reinterpret kTo kFrom)) [n])- internalConstraint st False [] $ fVal `svStrongEqual` SVal kFrom (Right (cache (\_ -> return ysw)))- return n-svFloatingPointAsSWord (SVal k _) = error $ "svFloatingPointAsSWord: non-float type: " ++ show k--{-# ANN svIte ("HLint: ignore Eta reduce" :: String) #-}-{-# ANN svLazyIte ("HLint: ignore Eta reduce" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Core.Operations+ (+ -- ** Basic constructors+ svTrue, svFalse, svBool+ , svInteger, svFloat, svDouble, svFloatingPoint, svRoundingMode+ , svReal, svEnumFromThenTo, svString, svChar+ -- ** Basic destructors+ , svAsBool, svAsInteger+ , svAsFloat, svAsDouble, svAsFP, svAsRoundingMode, cvAsRoundingMode+ , svNumerator, svDenominator+ -- ** Basic operations+ , svPlus, svTimes, svMinus, svUNeg, svAbs, svSignum+ , svDivide, svQuot, svRem, svQuotRem, svDivides+ , svEqual, svNotEqual, svStrongEqual, svImplies+ , svLessThan, svGreaterThan, svLessEq, svGreaterEq, svStructuralLessThan+ , svAnd, svOr, svXOr, svNot+ , svShl, svShr, svRol, svRor+ , svExtract, svJoin, svZeroExtend, svSignExtend+ , svIte, svLazyIte, svSymbolicMerge+ , svSelect+ , svSign, svUnsign, svSetBit, svWordFromBE, svWordFromLE+ , svExp, svFromIntegral+ , svFPNaN, svFPInf, svFPZero+ , svFPFromIntegerLit, svFPFromRationalLit+ , svFPIsZero, svFPIsInfinite, svFPIsNegative, svFPIsPositive+ , svFPIsNaN, svFPIsNormal, svFPIsSubnormal+ , svFPAdd, svFPSub, svFPMul, svFPDiv, svFPRem, svFPMin, svFPMax+ , svFPFMA, svFPAbs, svFPNeg, svFPRoundToIntegral, svFPSqrt+ , svCastToFP, svCastFromFP+ -- ** Overflows+ , svMkOverflow1, svMkOverflow2+ -- ** Derived operations+ , svToWord1, svFromWord1, svTestBit+ , svShiftLeft, svShiftRight+ , svRotateLeft, svRotateRight+ , svBarrelRotateLeft, svBarrelRotateRight+ , svBlastLE, svBlastBE+ , svAddConstant, svIncrement, svDecrement+ , svSWord32AsFloat, svSWord64AsDouble, svSWordAsFloatingPoint+ , svFloatAsSWord32, svDoubleAsSWord64, svFloatingPointAsSWord+ -- Utils+ , mkSymOp+ )+ where++import Prelude hiding (Foldable(..))+import Data.Bits (Bits(..))+import Data.List (genericIndex, genericLength, genericTake, foldr, length, foldl', elem, nub, sort, null, elemIndex)++import Data.Maybe (isNothing)++import Data.SBV.Core.AlgReals+import Data.SBV.Core.Kind+import Data.SBV.Core.Concrete+import Data.SBV.Core.Symbolic+import Data.SBV.Core.SizedFloats++import Data.Ratio++import Data.SBV.Utils.Numeric (RoundingMode(..), divEucl, modEucl, {-fp2fp,-} fpIsEqualObjectH, fpIsNormalizedH, fpMaxH, fpMinH, fpRemH, fpRoundToIntegralH, floatToWord, doubleToWord, wordToFloat, wordToDouble)++import LibBF++--------------------------------------------------------------------------------+-- Basic constructors++-- | Boolean True.+svTrue :: SVal+svTrue = SVal KBool (Left trueCV)++-- | Boolean False.+svFalse :: SVal+svFalse = SVal KBool (Left falseCV)++-- | Convert from a Boolean.+svBool :: Bool -> SVal+svBool b = if b then svTrue else svFalse++-- | Convert from an Integer.+svInteger :: Kind -> Integer -> SVal+svInteger k n = SVal k (Left $! mkConstCV k n)++-- | Convert from a Float+svFloat :: Float -> SVal+svFloat f = SVal KFloat (Left $! CV KFloat (CFloat f))++-- | Convert from a Double+svDouble :: Double -> SVal+svDouble d = SVal KDouble (Left $! CV KDouble (CDouble d))++-- | Convert from a generalized floating point+svFloatingPoint :: FP -> SVal+svFloatingPoint f@(FP eb sb _) = SVal k (Left $! CV k (CFP f))+ where k = KFP eb sb++-- | Convert from a rounding mode+svRoundingMode :: RoundingMode -> SVal+svRoundingMode s = SVal kRoundingMode $ Left $ CV kRoundingMode $ CADT (show s, [])++-- | Convert from a String+svString :: String -> SVal+svString s = SVal KString (Left $! CV KString (CString s))++-- | Convert from a Char+svChar :: Char -> SVal+svChar c = SVal KChar (Left $! CV KChar (CChar c))++-- | Convert from a Rational+svReal :: Rational -> SVal+svReal d = SVal KReal (Left $! CV KReal (CAlgReal (fromRational d)))++--------------------------------------------------------------------------------+-- Basic destructors++-- | Extract a bool, by properly interpreting the integer stored.+svAsBool :: SVal -> Maybe Bool+svAsBool (SVal _ (Left cv)) = Just (cvToBool cv)+svAsBool _ = Nothing++-- | Extract an integer from a concrete value.+svAsInteger :: SVal -> Maybe Integer+svAsInteger (SVal _ (Left (CV _ (CInteger n)))) = Just n+svAsInteger _ = Nothing++-- | Extract a float from a concrete value.+svAsFloat :: SVal -> Maybe Float+svAsFloat (SVal _ (Left (CV _ (CFloat f)))) = Just f+svAsFloat _ = Nothing++-- | Extract a double from a concrete value.+svAsDouble :: SVal -> Maybe Double+svAsDouble (SVal _ (Left (CV _ (CDouble d)))) = Just d+svAsDouble _ = Nothing++-- | Extract an t'FP' from a concrete value.+svAsFP :: SVal -> Maybe FP+svAsFP (SVal _ (Left (CV _ (CFP fp)))) = Just fp+svAsFP _ = Nothing++-- | Extract a rounding mode from an t'SVal'.+svAsRoundingMode :: SVal -> Maybe RoundingMode+svAsRoundingMode (SVal _ (Left cv)) = cvAsRoundingMode cv+svAsRoundingMode _ = Nothing++-- | Extract a rounding mode from a t'CV'.+cvAsRoundingMode :: CV -> Maybe RoundingMode+cvAsRoundingMode (CV k (CADT (s, [])))+ | k == kRoundingMode+ , mbMode <- s `lookup` [(show m, m) | m <- [minBound .. maxBound :: RoundingMode]]+ = mbMode+cvAsRoundingMode _+ = Nothing++-- | Grab the numerator of an SReal, if available+svNumerator :: SVal -> Maybe Integer+svNumerator (SVal KReal (Left (CV KReal (CAlgReal (AlgRational True r))))) = Just $ numerator r+svNumerator _ = Nothing++-- | Grab the denominator of an SReal, if available+svDenominator :: SVal -> Maybe Integer+svDenominator (SVal KReal (Left (CV KReal (CAlgReal (AlgRational True r))))) = Just $ denominator r+svDenominator _ = Nothing++-------------------------------------------------------------------------------------+-- | Constructing [x, y, .. z] and [x .. y]. Only works when all arguments are concrete and integral and the result is guaranteed finite+-- Note that the it isn't "obviously" clear why the following works; after all we're doing the construction over Integer's and mapping+-- it back to other types such as SIntN/SWordN. The reason is that the values we receive are guaranteed to be in their domains; and thus+-- the lifting to Integers preserves the bounds; and then going back is just fine. So, things like @[1, 5 .. 200] :: [SInt8]@ work just+-- fine (end evaluate to empty list), since we see @[1, 5 .. -56]@ in the @Integer@ domain. Also note the explicit check for @s /= f@+-- below to make sure we don't stutter and produce an infinite list.+svEnumFromThenTo :: SVal -> Maybe SVal -> SVal -> Maybe [SVal]+svEnumFromThenTo bf mbs bt+ | Just bs <- mbs, Just f <- svAsInteger bf, Just s <- svAsInteger bs, Just t <- svAsInteger bt, s /= f = Just $ map (svInteger (kindOf bf)) [f, s .. t]+ | Nothing <- mbs, Just f <- svAsInteger bf, Just t <- svAsInteger bt = Just $ map (svInteger (kindOf bf)) [f .. t]+ | True = Nothing++-------------------------------------------------------------------------------------+-- Basic operations++-- | Addition.+svPlus :: SVal -> SVal -> SVal+svPlus x y+ | isConcreteZero x = y+ | isConcreteZero y = x+ | True = liftSym2 (mkSymOp Plus) [rationalCheck] (+) (+) (+) (+) (+) (+) x y++-- | Multiplication.+svTimes :: SVal -> SVal -> SVal+svTimes x y+ | isConcreteZero x = x+ | isConcreteZero y = y+ | isConcreteOne x = y+ | isConcreteOne y = x+ | True = liftSym2 (mkSymOp Times) [rationalCheck] (*) (*) (*) (*) (*) (*) x y++-- | Subtraction.+svMinus :: SVal -> SVal -> SVal+svMinus x y+ | isConcreteZero y = x+ | True = liftSym2 (mkSymOp Minus) [rationalCheck] (-) (-) (-) (-) (-) (-) x y++-- | Unary minus. We handle arbitrary-FP's specially here, just for the negated literals.+svUNeg :: SVal -> SVal+svUNeg = liftSym1 (mkSymOp1 UNeg) negate negate negate negate negate negate++-- | Absolute value.+svAbs :: SVal -> SVal+svAbs = liftSym1 (mkSymOp1 Abs) abs abs abs abs abs abs++-- | Signum.+--+-- NB. The following "carefully" tests the number for == 0, as Float/Double's NaN and +/-0+-- cases would cause trouble with explicit equality tests.+svSignum :: SVal -> SVal+svSignum a+ | hasSign a = svIte (a `svGreaterThan` z) i+ $ svIte (a `svLessThan` z) (svUNeg i) a+ | True = svIte (a `svGreaterThan` z) i a+ where k = kindOf a+ z = SVal k $ Left $ mkConstCV k (0 :: Integer)+ i = SVal k $ Left $ mkConstCV k (1 :: Integer)++-- | Division. For integers, this behaves like 'svQuot', except that this+-- ensures @'svQuot' a 0 = a@.+svDivide :: SVal -> SVal -> SVal+svDivide x y = liftSym2 (mkSymOp Quot) [rationalCheck] (/) idiv (/) (/) (/) (/) x y+ where isInteger = kindOf x == KUnbounded++ idiv a 0 = a+ idiv a b | isInteger = a `divEucl` b+ | True = a `quot` b++-- | Divides predicate+svDivides :: Integer -> SVal -> SVal+svDivides n v+ | n <= 0 = error $ "svDivides: The first argument must be a strictly positive number, received: " ++ show n+ | True = case v of+ SVal KUnbounded (Left (CV KUnbounded (CInteger val))) -> svBool (val `mod` n == 0)+ _ -> SVal KBool $ Right $ cache c+ where c st = do sva <- svToSV st v+ newExpr st KBool (SBVApp (Divides n) [sva])++-- | Exponentiation.+svExp :: SVal -> SVal -> SVal+svExp b e+ | Just x <- svAsInteger e+ = if x >= 0 then let go n v+ | n == 0 = one+ | even n = go (n `div` 2) (svTimes v v)+ | True = svTimes v $ go (n `div` 2) (svTimes v v)+ in go x b+ else error $ "svExp: exponentiation: negative exponent: " ++ show x+ | not (isBounded e) || hasSign e+ = error $ "svExp: exponentiation only works with unsigned bounded symbolic exponents, kind: " ++ show (kindOf e)+ | True+ = prod $ zipWith (\use n -> svIte use n one)+ (svBlastLE e)+ (iterate (\x -> svTimes x x) b)+ where prod = foldr svTimes one+ one = svInteger (kindOf b) 1++-- | Bit-blast: Little-endian. Assumes the input is a bit-vector or a floating point type.+svBlastLE :: SVal -> [SVal]+svBlastLE x = map (svTestBit x) [0 .. intSizeOf x - 1]++-- | Set a given bit at index+svSetBit :: SVal -> Int -> SVal+svSetBit x i = x `svOr` svInteger (kindOf x) (bit i :: Integer)++-- | Bit-blast: Big-endian. Assumes the input is a bit-vector or a floating point type.+svBlastBE :: SVal -> [SVal]+svBlastBE = reverse . svBlastLE++-- | Un-bit-blast from big-endian representation to a word of the right size.+-- The input is assumed to be unsigned.+svWordFromLE :: [SVal] -> SVal+svWordFromLE bs = go zero 0 bs+ where zero = svInteger (KBounded False (length bs)) 0+ go !acc _ [] = acc+ go !acc !i (x:xs) = go (svIte x (svSetBit acc i) acc) (i+1) xs++-- | Un-bit-blast from little-endian representation to a word of the right size.+-- The input is assumed to be unsigned.+svWordFromBE :: [SVal] -> SVal+svWordFromBE = svWordFromLE . reverse++-- | Add a constant value:+svAddConstant :: Integral a => SVal -> a -> SVal+svAddConstant x i = x `svPlus` svInteger (kindOf x) (fromIntegral i)++-- | Increment:+svIncrement :: SVal -> SVal+svIncrement x = svAddConstant x (1::Integer)++-- | Decrement:+svDecrement :: SVal -> SVal+svDecrement x = svAddConstant x (-1 :: Integer)++-- | Quotient: Overloaded operation whose meaning depends on the kind at which+-- it is used: For unbounded integers, it corresponds to the SMT-Lib+-- "div" operator ("Euclidean" division, which always has a+-- non-negative remainder). For unsigned bitvectors, it is "bvudiv";+-- and for signed bitvectors it is "bvsdiv", which rounds toward zero.+-- Note that this variant does not respect the division/reminder by 0. That's handled at the SBV level.+--+-- Note that despite the similarities in their names, the semantics of 'svQuot'+-- are different from those of the higher-level 'Data.SBV.sQuot' function when dealing+-- with unbounded integers. 'svQuot' implements Euclidean division (which+-- always has a non-negative remainder), whereas 'Data.SBV.sQuot' implements truncating+-- division (which may have a negative remainder).+svQuot :: SVal -> SVal -> SVal+svQuot x y+ | not isInteger && isConcreteZero x = x+ | not isInteger && isConcreteZero y = svInteger (kindOf x) 0+ | not isInteger && isConcreteOne y = x+ | True+ = liftSym2 (mkSymOp Quot) [nonzeroCheck]+ (noReal "quot") quot' (noFloat "quot") (noDouble "quot") (noFP "quot") (noRat "quot") x y+ where+ isInteger = kindOf x == KUnbounded++ quot' a b | isInteger = divEucl a b+ | True = quot a b++-- | Remainder: Overloaded operation whose meaning depends on the kind at which+-- it is used: For unbounded integers, it corresponds to the SMT-Lib+-- "mod" operator ("Euclidean" modular division, which always has a+-- non-negative remainder). For unsigned bitvectors, it is "bvurem"; and for+-- signed bitvectors it is "bvsrem", which rounds toward zero (sign of+-- remainder matches that of @x@). Division by 0 is defined s.t. @x/0 = 0@,+-- which holds even when @x@ itself is @0@.+--+-- Note that despite the similarities in their names, the semantics of 'svRem'+-- are different from those of the higher-level 'Data.SBV.sRem' function when dealing+-- with unbounded integers. 'svRem' implements Euclidean modular division+-- (which always has a non-negative remainder), whereas 'Data.SBV.sRem' implements+-- truncating modular division (which may have a negative remainder).+svRem :: SVal -> SVal -> SVal+svRem x y+ | not isInteger && isConcreteZero x = x+ | not isInteger && isConcreteZero y = x+ | not isInteger && isConcreteOne y = svInteger (kindOf x) 0+ | True+ = liftSym2 (mkSymOp Rem) [nonzeroCheck]+ (noReal "rem") rem' (noFloat "rem") (noDouble "rem") (noFP "rem") (noRat "rem") x y+ where+ isInteger = kindOf x == KUnbounded++ rem' a b | isInteger = modEucl a b+ | True = rem a b++-- | Combination of 'svQuot' and 'svRem'+svQuotRem :: SVal -> SVal -> (SVal, SVal)+svQuotRem x y = (x `svQuot` y, x `svRem` y)++-- | Implication. Only for booleans.+svImplies :: SVal -> SVal -> SVal+svImplies a b+ | any (\x -> kindOf x /= KBool) [a, b] = error $ "Data.SBV.svImplies: Unexpected arguments: " ++ show (a, kindOf a, b, kindOf b)+ | isConcreteZero a = svTrue -- F -> _ = T+ | isConcreteOne b = svTrue -- _ -> T = T+ | isConcreteOne a && isConcreteZero b = svFalse -- T -> F = F+ | isConcreteOne a && isConcreteOne b = svTrue -- T -> T = T+ | True = SVal KBool $ Right $ cache c+ where c st = do sva <- svToSV st a+ svb <- svToSV st b+ -- One final optimization, equal args is just True!+ if sva == svb+ then pure trueSV+ else newExpr st KBool (SBVApp Implies [sva, svb])++-- | Strong equality. Only matters on floats, where it says @NaN@ equals @NaN@ and @+0@ and @-0@ are different.+-- Otherwise equivalent to `svEqual`.+svStrongEqual :: SVal -> SVal -> SVal+svStrongEqual x y | isFloat x, Just f1 <- getF x, Just f2 <- getF y = svBool $ f1 `fpIsEqualObjectH` f2+ | isDouble x, Just f1 <- getD x, Just f2 <- getD y = svBool $ f1 `fpIsEqualObjectH` f2+ | isFP x, Just f1 <- getFP x, Just f2 <- getFP y = svBool $ f1 `fpIsEqualObjectH` f2+ | isFloat x || isDouble x || isFP x = SVal KBool $ Right $ cache r+ | True = compareSV (Equal True) x y+ where getF (SVal _ (Left (CV _ (CFloat f)))) = Just f+ getF _ = Nothing++ getD (SVal _ (Left (CV _ (CDouble d)))) = Just d+ getD _ = Nothing++ getFP (SVal _ (Left (CV _ (CFP f)))) = Just f+ getFP _ = Nothing++ r st = do sx <- svToSV st x+ sy <- svToSV st y+ newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sx, sy])++-- Comparisons have to be careful in making sure we don't rely on CVal ord/eq instance.+compareSV :: Op -> SVal -> SVal -> SVal+compareSV op x y+ -- Make sure we don't get anything we can't handle or expect+ | op `notElem` [Equal True, Equal False, NotEqual, LessThan, GreaterThan, LessEq, GreaterEq]+ = error $ "Unexpected call to compareSV: " ++ show (op, x, y)+ | kx /= ky+ = error $ "Mismatched kinds in call to compareSV:" ++ show (op, x, kindOf x, kindOf y)+ | (isSet kx || isArray ky) && op `notElem` [Equal True, Equal False, NotEqual]+ = error $ "Unexpected Set/Array not-equal comparison: " ++ show (op, x, k)++ -- Boolean equality optimizations+ | k == KBool, Equal{} <- op, SVal _ (Left xv) <- x, xv == trueCV = y -- true .== y --> y+ | k == KBool, Equal{} <- op, SVal _ (Left yv) <- y, yv == trueCV = x -- x .== true --> x+ | k == KBool, Equal{} <- op, SVal _ (Left xv) <- x, xv == falseCV = svNot y -- false .== y --> svNot y+ | k == KBool, Equal{} <- op, SVal _ (Left yv) <- y, yv == falseCV = svNot x -- x .== false --> svNot x++ | k == KBool, op == NotEqual, SVal _ (Left xv) <- x, xv == trueCV = svNot y -- true ./= y --> svNot y+ | k == KBool, op == NotEqual, SVal _ (Left yv) <- y, yv == trueCV = svNot x -- x ./= true --> svNot x+ | k == KBool, op == NotEqual, SVal _ (Left xv) <- x, xv == falseCV = y -- false ./= y --> y+ | k == KBool, op == NotEqual, SVal _ (Left yv) <- y, yv == falseCV = x -- x ./= false --> x++ -- Comparison optimizations if one operand is min/max bit-vector+ | op == LessThan, isConcreteMax x = svFalse -- MAX < _+ | op == LessThan, isConcreteMin y = svFalse -- _ < MIN++ | op == GreaterThan, isConcreteMin x = svFalse -- MIN > _+ | op == GreaterThan, isConcreteMax y = svFalse -- _ > MAX++ | op == LessEq, isConcreteMin x = svTrue -- MIN <= _+ | op == LessEq, isConcreteMax y = svTrue -- _ <= MAX++ | op == GreaterEq, isConcreteMax x = svTrue -- MAX >= _+ | op == GreaterEq, isConcreteMin y = svTrue -- _ >= MIN++ -- General constant folding, but be careful not to be too smart here.+ | SVal _ (Left xv) <- x, SVal _ (Left yv) <- y+ = case cCompare k op (cvVal xv) (cvVal yv) of+ Nothing -> -- cCompare is conservative on floats. Give those one more chance, only at the top-level.+ -- (i.e., if stored under a Maybe/Either/List etc., we'll resort to a symbolic result.)+ case (k, cvVal xv, cvVal yv) of+ (KFloat, CFloat a, CFloat b) -> svBool (a `cFPOp` b)+ (KDouble, CDouble a, CDouble b) -> svBool (a `cFPOp` b)+ (KFP{} , CFP a, CFP b) -> svBool (a `cFPOp` b)+ _ -> symResult+ Just r -> svBool $ case op of+ Equal _ -> r == EQ+ NotEqual -> r /= EQ+ LessThan -> r == LT+ GreaterThan -> r == GT+ LessEq -> r `elem` [EQ, LT]+ GreaterEq -> r `elem` [EQ, GT]+ _ -> error $ "Unexpected call to compareSV: " ++ show (op, x, y)++ -- No constant folding opportunities, turn symbolic+ | True+ = symResult+ where kx = kindOf x+ ky = kindOf y+ k = kx -- only used after we ensured kx == ky++ -- Are there any floats embedded down from here? if so, we have to be careful due to presence of NaN+ safeEq = op == Equal True -- strong equality ok+ || isSomeKindOfFloat k -- top level OK+ || not (containsFloats k) -- has floats somewhere: not ok++ symResult+ | safeEq = symResultSafe+ | True = symResultFP++ -- This will go down to SMTLib's =. So only use it if we're safe to do so!+ symResultSafe = SVal KBool $ Right $ cache res+ where res st = do svx :: SV <- svToSV st x+ svy :: SV <- svToSV st y++ if svx == svy && eqCheckIsObjectEq k+ then case op of+ Equal{} -> pure trueSV+ LessEq -> pure trueSV+ GreaterEq -> pure trueSV+ NotEqual -> pure falseSV+ LessThan -> pure falseSV+ GreaterThan -> pure falseSV+ _ -> error $ "Unexpected call to compareSV, equal SV case: " ++ show (op, svx)+ else newExpr st KBool (SBVApp op [svx, svy])++ a `cFPOp` b = case op of+ Equal False -> a == b+ Equal True -> a `fpIsEqualObjectH` b+ NotEqual -> a /= b+ LessThan -> a < b+ GreaterThan -> a > b+ LessEq -> a <= b+ GreaterEq -> a >= b+ _ -> error $ "Unexpected call to cFPOp: " ++ show op++ -- OK, we have a result that has floats embedded in it. So comparison is problematic.+ -- Certain subsets of this is supported elsewhere. Here, we simply bail out.+ symResultFP = error $ unlines $ [ ""+ , "*** Data.SBV: Unsupported complicated comparison:"+ , "***"+ , "*** Op : " ++ show op+ , "*** Type: " ++ show k+ , "***"+ , "*** Due to the presence of NaN, comparisons over this type require"+ , "*** special support in SMTLib. And in general this can lead to"+ , "*** performance issues since the comparison is no longer a natively"+ , "*** supported operation in the logic."+ , "***"+ , "*** NB. If you want the semantics NaN == NaN, and +0 /= -0, then you can use .=== instead."+ , "***"+ ]+ ++ case alternative of+ Nothing -> ["*** Please report this as a feature request."]+ Just a -> [ "*** For this case, please use: " ++ a+ , "*** but beware of performance/decidability implications."+ ]++ where alternative = case (op, k) of+ (Equal False, KList f) | isFloat f || isDouble f || isFP f -> Just "Data.SBV.List.listEq"+ _ -> Nothing++-- Compare two CVals; if we can. We're being conservative here and deferring to a symbolic result if we get something complicated.+cCompare :: Kind -> Op -> CVal -> CVal -> Maybe Ordering+cCompare k op x y =+ case (x, y) of++ -- The presence of NaN's throw this off. Why? Because @NaN `compare` x = GT@ in Haskell. But that's just the wrong thing to do here.+ -- So protect against NaN's. And a similar story for -0/0.+ (CFloat a, CFloat b) | any (nanOrZero k) [x, y] -> Nothing+ | True -> Just $ a `compare` b++ (CDouble a, CDouble b) | any (nanOrZero k) [x, y] -> Nothing+ | True -> Just $ a `compare` b++ (CFP a, CFP b) | any (nanOrZero k) [x, y] -> Nothing+ | True -> Just $ a `compare` b++ -- Simple cases+ (CInteger a, CInteger b) -> Just $ a `compare` b+ (CRational a, CRational b) -> Just $ a `compare` b+ (CChar a, CChar b) -> Just $ a `compare` b+ (CString a, CString b) -> Just $ a `compare` b++ -- We can handle algreal, so long as they are exact-rationals+ (CAlgReal a, CAlgReal b) | isExactRational a && isExactRational b -> Just $ a `compare` b+ | True -> Nothing++ -- Lists and tuples use lexicographic ordering+ (CList a, CList b) -> case k of+ KList ke -> lexCmp (map (ke,) a) (map (ke,) b)+ _ -> error $ "cCompare: Unexpected kind in cCompare for List: " ++ show k++ (CTuple a, CTuple b) | length a == length b -> case k of+ KTuple ks | length ks == length a -> lexCmp (zip ks a) (zip ks b)+ _ -> error "cCompare: Unexpected kind in cCompare for tuples"+ | True -> error $ "cCompare: Received tuples of differing size: " ++ show (op, length a, length b, k)++ -- Arrays and sets only support equality/inequality. And they have object-equality semantics. So+ -- if there are any floats or non-exact-rationals down in the index or element kinds, we bail+ (CSet a, CSet b) | op `elem` [Equal True, Equal False, NotEqual]+ , KSet ke <- k+ -> case svSetEqual ke a b of+ Nothing -> Nothing -- We don't know+ Just True -> Just EQ -- They're equal+ Just False -> Just GT -- Pick GT; so equality test will fail, inequality will pass+ | True+ -> error $ "cCompare: Received unexpected set comparison: " ++ show (op, k)++ (CArray a, CArray b) | op `elem` [Equal True, Equal False, NotEqual]+ , KArray k1 k2 <- k+ -> case svArrEqual k1 k2 a b of+ Nothing -> Nothing -- We don't know+ Just True -> Just EQ -- They're equal+ Just False -> Just GT -- Pick GT; so equality test will fail, inequality will pass+ | True+ -> error $ "cCompare: Received unexpected array comparison: " ++ show (op, k)+++ -- ADTs. Only equal/inequal on full ADTs. Compares on enumerations.+ (CADT (s, fks), CADT (s', fks'))+ -> case k of+ -- Enumerations. We do a straight comparison on the constructor index+ KADT _ _ cstrs | all (null . snd) cstrs+ -> let cnms = map fst cstrs+ in case (s `elemIndex` cnms, s' `elemIndex` cnms) of+ (Just i, Just j) -> Just (i `compare` j)+ r -> error $ "cCompare: Unable to locate indexes for CADT: " ++ show (k, s, s', r)++ -- Arbitrary ADTs. Only allow equality/inequality+ _ | op `notElem` [Equal True, Equal False, NotEqual]+ -> error $ "cCompare: Received unexpected ADT comparison: " ++ show (op, k)++ -- Different constructor+ | s /= s'+ -> Just GT -- Pick GT; so equality test will fail, inequality will pass++ -- Same constructor+ | map fst fks /= map fst fks'+ -> error $ "cCompare: Mismatching ADT field kinds in comparison: " ++ show (op, k, map fst fks, map fst fks')+ | True+ -> let fmatch = zipWith (\(fk, v1) (_, v2) -> cCompare fk op v1 v2) fks fks'+ undecided = any isNothing fmatch -- Field comparison undecided+ allEq = all (== Just EQ) fmatch -- All fields Equal+ in if undecided+ then Nothing+ else if allEq+ then Just EQ+ else -- all compared fine, but not all equal+ Just GT -- Pick GT; so equality test will fail, inequality will pass++ -- Shouldn't happen:+ _ -> error $ unlines [ ""+ , "*** Data.SBV.cCompare: Bug in SBV: Unhandled rank in comparison fallthru"+ , "***"+ , "*** Ranks Received: " ++ show (cvRank x, cvRank y, op)+ , "***"+ , "*** Please report this as a bug!"+ ]+ where -- lexicographic+ lexCmp :: [(Kind, CVal)] -> [(Kind, CVal)] -> Maybe Ordering+ lexCmp [] [] = Just EQ+ lexCmp [] (_:_) = Just LT+ lexCmp (_:_) [] = Just GT+ lexCmp ((k1, a):as) ((k2, b):bs)+ | k1 == k2+ = case cCompare k1 op a b of+ Just EQ -> as `lexCmp` bs+ other -> other+ | True+ = error $ "Mismatching kinds in lexicographic comparison: " ++ show (k1, k2)++ nanOrZero KFloat (CFloat v) = isNaN v || v == 0+ nanOrZero KDouble (CDouble v) = isNaN v || v == 0+ nanOrZero (KFP eb sb) (CFP v) = isNaN v || v == fpFromInteger eb sb 0+ nanOrZero knd _ = error $ "Unexpected arguments to nanOrZero: " ++ show knd++ -- | Set equality. We return Nothing if the result is too complicated for us to concretely calculate.+ -- Why? Because the Eq instance of CVal is a bit iffy; it's designed to work as an index into maps, not as+ -- a means of checking this sort of equality+ svSetEqual :: Kind -> RCSet CVal -> RCSet CVal -> Maybe Bool+ svSetEqual ek sa sb+ | eqCheckIsObjectEq ek, RegularSet a <- sa, RegularSet b <- sb = Just $ a == b+ | eqCheckIsObjectEq ek, ComplementSet a <- sa, ComplementSet b <- sb = Just $ a == b+ | True = Nothing++ -- | Array equality. See above comments.+ svArrEqual :: Kind -> Kind -> ArrayModel CVal CVal -> ArrayModel CVal CVal -> Maybe Bool+ svArrEqual k1 k2 (ArrayModel asc1 def1) (ArrayModel asc2 def2)+ | not (all eqCheckIsObjectEq [k1, k2])+ = Nothing+ | True+ = let -- Use of lookup is safe here, because we already made sure equality is *not* problematic above+ keysMatch = and [key `lookup` asc1 == key `lookup` asc2 | key <- nub (sort (map fst (asc1 ++ asc2)))]+ defsMatch = def1 == def2++ -- Check if keys cover everything. Clearly, we can't do this for all kinds; but only finite ones+ -- For the time being, we're restricting ourselves to bool only. Might want to extend this later.+ complete = case k1 of+ KBool -> let bools = map cvVal [falseCV, trueCV]+ covered asc = all (`elem` map fst asc) bools+ in covered asc1 && covered asc2+ _ -> False++ in case (keysMatch, defsMatch, complete) of+ (False, _ , _) -> Just False -- keys mismatch. Nothing else matters.+ (True, True, _) -> Just True -- keys match, def matches; so all is good. Complete doesn't matter.+ (True, False, True) -> Just True -- keys match, but defs don't. But we keys are complete, so def mismatch is OK+ _ -> Nothing -- otherwise, we don't really know. So, remain symbolic.++-- | Equality. This is SMT object equality.+svEqual :: SVal -> SVal -> SVal+svEqual = compareSV (Equal False)++-- | Inequality.+svNotEqual :: SVal -> SVal -> SVal+svNotEqual = compareSV NotEqual++-- | Less than.+svLessThan :: SVal -> SVal -> SVal+svLessThan = compareSV LessThan++-- | Greater than.+svGreaterThan :: SVal -> SVal -> SVal+svGreaterThan = compareSV GreaterThan++-- | Less than or equal to.+svLessEq :: SVal -> SVal -> SVal+svLessEq = compareSV LessEq++-- | Greater than or equal to.+svGreaterEq :: SVal -> SVal -> SVal+svGreaterEq = compareSV GreaterEq++-- | Bitwise and.+svAnd :: SVal -> SVal -> SVal+svAnd x y+ | isConcreteZero x = x+ | isConcreteOnes x = y+ | isConcreteZero y = y+ | isConcreteOnes y = x+ | True = liftSym2 (mkSymOpSC opt And) [] (noReal ".&.") (.&.) (noFloat ".&.") (noDouble ".&.") (noFP ".&.") (noRat ".&") x y+ where opt a b+ | a == falseSV || b == falseSV = Just falseSV+ | a == trueSV = Just b+ | b == trueSV = Just a+ | a == b = Just a+ | True = Nothing++-- | Bitwise or.+svOr :: SVal -> SVal -> SVal+svOr x y+ | isConcreteZero x = y+ | isConcreteOnes x = x+ | isConcreteZero y = x+ | isConcreteOnes y = y+ | True = liftSym2 (mkSymOpSC opt Or) []+ (noReal ".|.") (.|.) (noFloat ".|.") (noDouble ".|.") (noFP ".|.") (noRat ".|.") x y+ where opt a b+ | a == trueSV || b == trueSV = Just trueSV+ | a == falseSV = Just b+ | b == falseSV = Just a+ | a == b = Just a+ | True = Nothing++-- | Bitwise xor.+svXOr :: SVal -> SVal -> SVal+svXOr x y+ | isConcreteZero x = y+ | isConcreteOnes x = svNot y+ | isConcreteZero y = x+ | isConcreteOnes y = svNot x+ | True = liftSym2 (mkSymOpSC opt XOr) []+ (noReal "xor") xor (noFloat "xor") (noDouble "xor") (noFP "xor") (noRat "xor") x y+ where opt a b+ | a == b && swKind a == KBool = Just falseSV+ | a == falseSV = Just b+ | b == falseSV = Just a+ | True = Nothing++-- | Bitwise complement.+svNot :: SVal -> SVal+svNot = liftSym1 (mkSymOp1SC opt Not)+ (noRealUnary "complement") complement+ (noFloatUnary "complement") (noDoubleUnary "complement") (noFPUnary "complement") (noRatUnary "complement")+ where opt a+ | a == falseSV = Just trueSV+ | a == trueSV = Just falseSV+ | True = Nothing++-- | Shift left by a constant amount. Translates to the "bvshl"+-- operation in SMT-Lib.+--+-- NB. Haskell spec says the behavior is undefined if the shift amount+-- is negative. We arbitrarily return the value unchanged if this is the case.+svShl :: SVal -> Int -> SVal+svShl x i+ | i <= 0+ = x+ | isBounded x, i >= intSizeOf x+ = svInteger k 0+ | True+ = x `svShiftLeft` svInteger k (fromIntegral i)+ where k = kindOf x++-- | Shift right by a constant amount. Translates to either "bvlshr"+-- (logical shift right) or "bvashr" (arithmetic shift right) in+-- SMT-Lib, depending on whether @x@ is a signed bitvector.+--+-- NB. Haskell spec says the behavior is undefined if the shift amount+-- is negative. We arbitrarily return the value unchanged if this is the case.+svShr :: SVal -> Int -> SVal+svShr x i+ | i <= 0+ = x+ | isBounded x, i >= intSizeOf x+ = if not (hasSign x)+ then z+ else svIte (x `svLessThan` z) neg1 z+ | True+ = x `svShiftRight` svInteger k (fromIntegral i)+ where k = kindOf x+ z = svInteger k 0+ neg1 = svInteger k (-1)++-- | Rotate-left, by a constant.+--+-- NB. Haskell spec says the behavior is undefined if the shift amount+-- is negative. We arbitrarily return the value unchanged if this is the case.+svRol :: SVal -> Int -> SVal+svRol x i+ | i <= 0+ = x+ | True+ = case kindOf x of+ KBounded _ sz -> liftSym1 (mkSymOp1 (Rol (i `mod` sz)))+ (noRealUnary "rotateL") (rot True sz i)+ (noFloatUnary "rotateL") (noDoubleUnary "rotateL") (noFPUnary "rotateL") (noRatUnary "rotateL") x+ _ -> svShl x i -- for unbounded Integers, rotateL is the same as shiftL in Haskell++-- | Rotate-right, by a constant.+--+-- NB. Haskell spec says the behavior is undefined if the shift amount+-- is negative. We arbitrarily return the value unchanged if this is the case.+svRor :: SVal -> Int -> SVal+svRor x i+ | i <= 0+ = x+ | True+ = case kindOf x of+ KBounded _ sz -> liftSym1 (mkSymOp1 (Ror (i `mod` sz)))+ (noRealUnary "rotateR") (rot False sz i)+ (noFloatUnary "rotateR") (noDoubleUnary "rotateR") (noFPUnary "rotateR") (noRatUnary "rotateR") x+ _ -> svShr x i -- for unbounded integers, rotateR is the same as shiftR in Haskell++-- | Generic rotation. Since the underlying representation is just Integers, rotations has to be+-- careful on the bit-size.+rot :: Bool -> Int -> Int -> Integer -> Integer+rot toLeft sz amt x+ | sz < 2 = x+ | True = norm x y' `shiftL` y .|. norm (x `shiftR` y') y+ where (y, y') | toLeft = (amt `mod` sz, sz - y)+ | True = (sz - y', amt `mod` sz)+ norm v s = v .&. ((1 `shiftL` s) - 1)++-- | Extract bit-sequences.+svExtract :: Int -> Int -> SVal -> SVal+svExtract i j x@(SVal (KBounded s _) _)+ | i < j+ = SVal k (Left $! CV k (CInteger 0))+ | SVal _ (Left (CV _ (CInteger v))) <- x+ = SVal k (Left $! normCV (CV k (CInteger (v `shiftR` j))))+ | True+ = SVal k (Right (cache y))+ where k = KBounded s (i - j + 1)+ y st = do sv <- svToSV st x+ newExpr st k (SBVApp (Extract i j) [sv])+svExtract i j v@(SVal KFloat _) = svExtract i j (svFloatAsSWord32 v)+svExtract i j v@(SVal KDouble _) = svExtract i j (svDoubleAsSWord64 v)+svExtract i j v@(SVal KFP{} _) = svExtract i j (svFloatingPointAsSWord v)+svExtract _ _ _ = error "extract: non-bitvector/float type"++-- | Join two words, by concatenating+svJoin :: SVal -> SVal -> SVal+svJoin x@(SVal (KBounded s i) a) y@(SVal (KBounded s' j) b)+ | s /= s'+ = error $ "svJoin: received differently signed values: " ++ show (x, y)+ | i == 0 = y+ | j == 0 = x+ | Left (CV _ (CInteger m)) <- a, Left (CV _ (CInteger n)) <- b+ = let val+ | s -- signed, arithmetic doesn't work; blast and come back+ = let xbits = [m `testBit` xi | xi <- [0 .. i-1]]+ ybits = [n `testBit` yi | yi <- [0 .. j-1]]+ rbits = zip [0..] (ybits ++ xbits)+ in foldl' (\acc (idx, set) -> if set then setBit acc idx else acc) 0 rbits+ | True -- unsigned, go fast+ = m `shiftL` j .|. n+ in SVal k (Left $! normCV (CV k (CInteger val)))+ | True+ = SVal k (Right (cache z))+ where+ k = KBounded s (i + j)+ z st = do xsw <- svToSV st x+ ysw <- svToSV st y+ newExpr st k (SBVApp Join [xsw, ysw])+svJoin _ _ = error "svJoin: non-bitvector type"++-- | Zero-extend by given number of bits.+svZeroExtend :: Int -> SVal -> SVal+svZeroExtend = svExtend True ZeroExtend++-- | Sign-extend by given number of bits.+svSignExtend :: Int -> SVal -> SVal+svSignExtend = svExtend False SignExtend++svExtend :: Bool -> (Int -> Op) -> Int -> SVal -> SVal+svExtend isZeroExtend extender i x@(SVal (KBounded s sz) a)+ | i < 0+ = error $ "svExtend: Received negative extension amount: " ++ show i+ | i == 0+ = x+ | Left (CV _ (CInteger cv)) <- a+ = SVal k' (Left (normCV (CV k' (CInteger (replBit (not isZeroExtend && (cv `testBit` (sz-1))) cv)))))+ | True+ = SVal k' (Right (cache z))+ where k' = KBounded s (sz+i)+ z st = do xsw <- svToSV st x+ newExpr st k' (SBVApp (extender i) [xsw])++ replBit :: Bool -> Integer -> Integer+ replBit b = go sz+ where stop = sz + i+ go k v | k == stop = v+ | b = go (k+1) (v `setBit` k)+ | True = go (k+1) (v `clearBit` k)++svExtend _ _ _ _ = error "svExtend: non-bitvector type"++-- | If-then-else. This one will force branches.+svIte :: SVal -> SVal -> SVal -> SVal+svIte t a b = svSymbolicMerge (kindOf a) True t a b++-- | Lazy If-then-else. This one will delay forcing the branches unless it's really necessary.+svLazyIte :: Kind -> SVal -> SVal -> SVal -> SVal+svLazyIte k t a b = svSymbolicMerge k False t a b++-- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make+-- sure they do not evaluate to the same result.+svSymbolicMerge :: Kind -> Bool -> SVal -> SVal -> SVal -> SVal+svSymbolicMerge k force t a b+ | Just r <- svAsBool t+ = if r then a else b+ | force, rationalSBVCheck a b, sameResult a b+ = a+ | True+ = SVal k $ Right $ cache c+ where sameResult (SVal _ (Left c1)) (SVal _ (Left c2)) = c1 == c2+ sameResult _ _ = False++ c st = do swt <- svToSV st t+ case () of+ () | 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+ 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"+ under the incorrect assumptions. To wit, consider the following:++ foo x y = ite (y .== 0) k (k+1)+ where k = ite (y .== 0) x (x+1)++ When we reduce the 'then' branch of the first ite, we'd record the assumption that y is 0. But while reducing the 'then' branch, we'd+ like to share @k@, which would evaluate (correctly) to @x@ under the given assumption. When we backtrack and evaluate the 'else'+ branch of the first ite, we'd see @k@ is needed again, and we'd look it up from our sharing map to find (incorrectly) that its value+ is @x@, which was stored there under the assumption that y was 0, which no longer holds. Clearly, this is unsound.++ A sound implementation would have to precisely track which assumptions were active at the time expressions get shared. That is,+ in the above example, we should record that the value of @k@ was cached under the assumption that @y@ is 0. While sound, this+ approach unfortunately leads to significant loss of valid sharing when the value itself had nothing to do with the assumption itself.+ To wit, consider:++ foo x y = ite (y .== 0) k (k+1)+ where k = x+5++ If we tracked the assumptions, we would recompute @k@ twice, since the branch assumptions would differ. Clearly, there is no need to+ re-compute @k@ in this case since its value is independent of @y@. Note that the whole SBV performance story is based on aggressive sharing,+ and losing that would have other significant ramifications.++ The "proper" solution would be to track, with each shared computation, precisely which assumptions it actually *depends* on, rather+ than blindly recording all the assumptions present at that time. SBV's symbolic simulation engine clearly has all the info needed to do this+ properly, but the implementation is not straightforward at all. For each subexpression, we would need to chase down its dependencies+ transitively, which can require a lot of scanning of the generated program causing major slow-down; thus potentially defeating the+ whole purpose of sharing in the first place.++ Design choice: Keep it simple, and simply do not track the assumption at all. This will maximize sharing, at the cost of evaluating+ unreachable branches. I think the simplicity is more important at this point than efficiency.++ Also note that the user can avoid most such issues by properly combining if-then-else's with common conditions together. That is, the+ first program above should be written like this:++ foo x y = ite (y .== 0) x (x+2)++ In general, the following transformations should be done whenever possible:++ ite e1 (ite e1 e2 e3) e4 --> ite e1 e2 e4+ ite e1 e2 (ite e1 e3 e4) --> ite e1 e2 e4++ This is in accordance with the general rule-of-thumb stating conditionals should be avoided as much as possible. However, we might prefer+ the following:++ ite e1 (f e2 e4) (f e3 e5) --> f (ite e1 e2 e3) (ite e1 e4 e5)++ especially if this expression happens to be inside 'f's body itself (i.e., when f is recursive), since it reduces the number of+ recursive calls. Clearly, programming with symbolic simulation in mind is another kind of beast altogether.+ -}+ let sta = st `extendSValPathCondition` svAnd t+ let stb = st `extendSValPathCondition` svAnd (svNot t)+ swa <- svToSV sta a -- evaluate 'then' branch+ swb <- svToSV stb b -- evaluate 'else' branch++ -- merge, but simplify for certain boolean cases:+ case () of+ () | swa == swb -> pure swa -- if t then a else a ==> a+ () | swa == trueSV && swb == falseSV -> pure swt -- if t then true else false ==> t+ () | swa == falseSV && swb == trueSV -> newExpr st k (SBVApp Not [swt]) -- if t then false else true ==> not t+ () | swa == trueSV -> newExpr st k (SBVApp Or [swt, swb]) -- if t then true else b ==> t OR b+ () | swa == falseSV -> do swt' <- newExpr st KBool (SBVApp Not [swt])+ newExpr st k (SBVApp And [swt', swb]) -- if t then false else b ==> t' AND b+ () | swb == trueSV -> do swt' <- newExpr st KBool (SBVApp Not [swt])+ newExpr st k (SBVApp Or [swt', swa]) -- if t then a else true ==> t' OR a+ () | swb == falseSV -> newExpr st k (SBVApp And [swt, swa]) -- if t then a else false ==> t AND a+ () -> newExpr st k (SBVApp Ite [swt, swa, swb])++-- | Total indexing operation. @svSelect xs default index@ is+-- intuitively the same as @xs !! index@, except it evaluates to+-- @default@ if @index@ overflows. Translates to SMT-Lib tables.+svSelect :: [SVal] -> SVal -> SVal -> SVal+svSelect xs err ind+ | SVal _ (Left c) <- ind =+ case cvVal c of+ CInteger i -> if i < 0 || i >= genericLength xs+ then err+ else xs `genericIndex` i+ _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"+svSelect xsOrig err ind = xs `seq` SVal kElt (Right (cache r))+ where+ kInd = kindOf ind+ kElt = kindOf err+ -- Based on the index size, we need to limit the elements. For+ -- instance if the index is 8 bits, but there are 257 elements,+ -- that last element will never be used and we can chop it off.+ xs = case kInd of+ KBounded False i -> genericTake ((2::Integer) ^ i) xsOrig+ KBounded True i -> genericTake ((2::Integer) ^ (i-1)) xsOrig+ KUnbounded -> xsOrig+ _ -> error $ "SBV.select: unsupported " ++ show kInd ++ " valued select/index expression"+ r st = do sws <- mapM (svToSV st) xs+ swe <- svToSV st err+ if all (== swe) sws -- off-chance that all elts are the same+ then pure swe+ else do idx <- getTableIndex st kInd kElt sws+ swi <- svToSV st ind+ let len = length xs+ -- NB. No need to worry here that the index+ -- might be < 0; as the SMTLib translation+ -- takes care of that automatically+ newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])++-- Change the sign of a bit-vector quantity. Fails if passed a non-bv+svChangeSign :: Bool -> SVal -> SVal+svChangeSign s x+ | not (isBounded x) = error $ "Data.SBV." ++ nm ++ ": Received non bit-vector kind: " ++ show (kindOf x)+ | Just n <- svAsInteger x = svInteger k n+ | True = SVal k (Right (cache y))+ where+ nm = if s then "svSign" else "svUnsign"++ k = KBounded s (intSizeOf x)+ y st = do xsw <- svToSV st x+ newExpr st k (SBVApp (Extract (intSizeOf x - 1) 0) [xsw])++-- | Convert a symbolic bitvector from unsigned to signed.+svSign :: SVal -> SVal+svSign = svChangeSign True++-- | Convert a symbolic bitvector from signed to unsigned.+svUnsign :: SVal -> SVal+svUnsign = svChangeSign False++-- | Convert a symbolic bitvector from one integral kind to another.+svFromIntegral :: Kind -> SVal -> SVal+svFromIntegral kTo x+ | Just v <- svAsInteger x+ = svInteger kTo v+ | True+ = result+ where result = SVal kTo (Right (cache y))+ kFrom = kindOf x+ y st = do xsw <- svToSV st x+ newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw])++-- | Create a NaN floating-point value of the given kind.+svFPNaN :: Kind -> SVal+svFPNaN k = SVal k $ Left $ fpConstCV k nan nan fpNaN+ where+ nan :: forall a. Floating a => a+ nan = 0/0++-- | Create an infinite floating-point value of the given kind. If the 'Bool'+-- argument is 'True', then use negative infinity; otherwise, use positive+-- infinity.+svFPInf :: Kind -> Bool -> SVal+svFPInf k neg = SVal k $ Left $ fpConstCV k signedInfinity signedInfinity (fpInf neg)+ where+ infinity :: forall a. Floating a => a+ infinity = 1/0++ signedInfinity :: forall a. Floating a => a+ signedInfinity = if neg then -infinity else infinity++-- | Create a signed zero value of the given kind. If the 'Bool' argument is+-- 'True', then use negative zero; otherwise, use positive zero.+svFPZero :: Kind -> Bool -> SVal+svFPZero k neg = SVal k $ Left $ fpConstCV k signedZero signedZero (fpZero neg)+ where+ signedZero :: forall a. Num a => a+ signedZero = if neg then -0 else 0++-- | Create a float-point value of the given kind from an 'Integer' literal.+svFPFromIntegerLit :: Kind -> Integer -> SVal+svFPFromIntegerLit k r = SVal k $ Left $ fpConstCV k (fromInteger r) (fromInteger r) (\eb sb -> fpFromInteger eb sb r)++-- | Create a float-point value of the given kind from a 'Rational' literal.+svFPFromRationalLit :: Kind -> Rational -> SVal+svFPFromRationalLit k r = SVal k $ Left $ fpConstCV k (fromRational r) (fromRational r) (\eb sb -> fpFromRational eb sb r)++-- | Is the given floating-point value a zero value?+svFPIsZero :: SVal -> SVal+svFPIsZero = liftFPPred (mkSymOp1 (IEEEFP FP_IsZero)) isZero isZero fpIsZero+ where+ isZero :: forall a. RealFloat a => a -> Bool+ isZero x = x == 0++-- | Is the given floating-point value infinite?+svFPIsInfinite :: SVal -> SVal+svFPIsInfinite = liftFPPred (mkSymOp1 (IEEEFP FP_IsInfinite)) isInfinite isInfinite fpIsInf++-- | Is the given floating-point value negative?+svFPIsNegative :: SVal -> SVal+svFPIsNegative = liftFPPred (mkSymOp1 (IEEEFP FP_IsNegative)) isNegative isNegative fpIsNeg+ where+ isNegative :: forall a. RealFloat a => a -> Bool+ isNegative x = x < 0 || isNegativeZero x++-- | Is the given floating-point value positive?+svFPIsPositive :: SVal -> SVal+svFPIsPositive = liftFPPred (mkSymOp1 (IEEEFP FP_IsPositive)) isPositive isPositive fpIsPos+ where+ isPositive :: forall a. RealFloat a => a -> Bool+ isPositive x = x >= 0 && not (isNegativeZero x)++-- | Is the given floating-point value a NaN value?+svFPIsNaN :: SVal -> SVal+svFPIsNaN = liftFPPred (mkSymOp1 (IEEEFP FP_IsNaN)) isNaN isNaN fpIsNaN++-- | Is the given floating-point value \"normal\"? That is, is the value not+-- zero, infinite, NaN, or subnormal?+svFPIsNormal :: SVal -> SVal+svFPIsNormal = liftFPPred (mkSymOp1 (IEEEFP FP_IsNormal)) fpIsNormalizedH fpIsNormalizedH fpIsNormal++-- | Is the given floating-point value subnormal (i.e., denormalized)?+svFPIsSubnormal :: SVal -> SVal+svFPIsSubnormal = liftFPPred (mkSymOp1 (IEEEFP FP_IsSubnormal)) isDenormalized isDenormalized fpIsSubnormal++-- | Floating-point addition.+svFPAdd :: SVal -- ^ Rounding mode+ -> SVal -> SVal -> SVal+svFPAdd = liftFPSymRM2 "add" (mkSymOp3 (IEEEFP FP_Add)) (+) (+) fpAdd++-- | Floating-point subtraction.+svFPSub :: SVal -- ^ Rounding mode+ -> SVal -> SVal -> SVal+svFPSub = liftFPSymRM2 "sub" (mkSymOp3 (IEEEFP FP_Sub)) (-) (-) fpSub++-- | Floating-point multiplication.+svFPMul :: SVal -- ^ Rounding mode+ -> SVal -> SVal -> SVal+svFPMul = liftFPSymRM2 "mul" (mkSymOp3 (IEEEFP FP_Mul)) (*) (*) fpMul++-- | Floating-point division.+svFPDiv :: SVal -- ^ Rounding mode+ -> SVal -> SVal -> SVal+svFPDiv = liftFPSymRM2 "div" (mkSymOp3 (IEEEFP FP_Div)) (/) (/) fpDiv++-- | Floating-point remainder.+svFPRem :: SVal -> SVal -> SVal+svFPRem = liftFPSym2 "rem" (mkSymOp (IEEEFP FP_Rem)) fpRemH fpRemH (fpRem RoundNearestTiesToEven)++-- | Floating-point minimum.+svFPMin :: SVal -> SVal -> SVal+svFPMin = liftFPSym2 "min" (mkSymOp (IEEEFP FP_Min)) fpMinH fpMinH fpMin++-- | Floating-point maximum.+svFPMax :: SVal -> SVal -> SVal+svFPMax = liftFPSym2 "max" (mkSymOp (IEEEFP FP_Max)) fpMaxH fpMaxH fpMax++-- | Floating-point fused-multiply-add (FMA).++-- Note that this operation is defined somewhat unusually because Haskell lacks+-- a native FMA operation to use for concrete evaluation of 'Float's and+-- 'Double's. See https://github.com/LeventErkok/sbv/issues/777 for more+-- discussion. As such, concrete FMA evaluation is only supported for t'FP'+-- values.+svFPFMA :: SVal -- ^ Rounding mode+ -> SVal -> SVal -> SVal -> SVal+svFPFMA (svAsRoundingMode -> Just rm)+ (SVal k (Left (cvVal -> CFP a)))+ (SVal _ (Left (cvVal -> CFP b)))+ (SVal _ (Left (cvVal -> CFP c))) =+ SVal k $ Left $ CV k $ CFP $ fpFMA rm a b c+svFPFMA rm a@(SVal k _) b c = SVal k $ Right $ cache ca+ where ca st = do svrm <- svToSV st rm+ sva <- svToSV st a+ svb <- svToSV st b+ svc <- svToSV st c+ newExpr st k (SBVApp (IEEEFP FP_FMA) [svrm, sva, svb, svc])++-- | Floating-point absolute value.+svFPAbs :: SVal -> SVal+svFPAbs = liftFPSym1 "abs" (mkSymOp1 (IEEEFP FP_Abs)) abs abs fpAbs++-- | Floating-point negation.+svFPNeg :: SVal -> SVal+svFPNeg = liftFPSym1 "negate" (mkSymOp1 (IEEEFP FP_Neg)) negate negate fpNeg++-- | Round the given floating-point value to the nearest integer (represented+-- as a float with a zero decimal component) using the given rounding mode.+svFPRoundToIntegral :: SVal -- ^ Rounding mode+ -> SVal -> SVal+svFPRoundToIntegral = liftFPSymRM1 "roundToIntegral" (mkSymOp (IEEEFP FP_RoundToIntegral)) fpRoundToIntegralH fpRoundToIntegralH fpRoundInt++-- | Floating-point square root.+svFPSqrt :: SVal -- ^ Rounding mode+ -> SVal -> SVal+svFPSqrt = liftFPSymRM1 "sqrt" (mkSymOp (IEEEFP FP_Sqrt)) sqrt sqrt fpSqrt++-- | Cast an t'FP' value to a t'CV' of the given floating-point 'Kind' using the+-- given 'RoundingMode'. This will error if given a non-floating-point 'Kind'.+cvCastFromFP :: Kind -> RoundingMode -> FP -> CV+cvCastFromFP kindTo rm fp =+ fpConstCV+ kindTo+ (fpToFloat rm (fpRoundFloat 8 24 rm fp))+ (fpToDouble rm (fpRoundFloat 11 53 rm fp))+ (\eb sb -> fpRoundFloat eb sb rm fp)++-- | Cast a 'Rational' value to a t'CV' of the given floating-point 'Kind'. This+-- will error if given a non-floating-point 'Kind'.+cvCastFromRational :: Kind -> Rational -> CV+cvCastFromRational kindTo r =+ fpConstCV+ kindTo+ (fromRational r)+ (fromRational r)+ (\eb sb -> fpFromRational eb sb r)++-- | Convert a 'CVal' to an t'FP' value of the appropriate size. This will error+-- if the 'CVal' is not a floating-point value.+cvalToFP :: CVal -> FP+cvalToFP (CFloat f) = fpFromFloat 8 24 f+cvalToFP (CDouble d) = fpFromDouble 11 53 d+cvalToFP (CFP fp) = fp+cvalToFP _ = error "cvalToFP: non-float value"++-- | Convert a value to a floating-point value. The type being converted from+-- must be one of 'KFloat', 'KDouble', 'KFP', 'KBounded', 'KUnbounded', or+-- 'KReal'.+--+-- Note that converting from a 'KBounded' value returns a float with the same+-- numeric value as the input bitvector. For a conversion that returns a float+-- with the same bit pattern as the input bitvector, see 'svSWord32AsFloat',+-- 'svSWord64AsDouble', and 'svSWordAsFloatingPoint'.+svCastToFP :: Kind -- ^ The kind to cast to. Must be a floating-point kind.+ -> SVal -- ^ Rounding mode+ -> SVal -- ^ The value to be casted.+ -> SVal+svCastToFP kindTo (svAsRoundingMode -> Just rm) x@(SVal kindFrom (Left (CV _ x')))+ | kindFrom == kindTo+ = x++ | KFloat {} <- kindFrom+ = fpCastFromFloat+ | KDouble {} <- kindFrom+ = fpCastFromFloat+ | KFP {} <- kindFrom+ = fpCastFromFloat++ | RoundNearestTiesToEven <- rm+ , KBounded {} <- kindFrom+ , CInteger w <- x'+ = fpCastFromIntegral w+ | RoundNearestTiesToEven <- rm+ , KUnbounded {} <- kindFrom+ , CInteger i <- x'+ = fpCastFromIntegral i++ | RoundNearestTiesToEven <- rm+ , CAlgReal r <- x'+ , isExactRational r+ = SVal kindTo $ Left $ cvCastFromRational kindTo $ toRational r+ where fpCastFromFloat :: SVal+ fpCastFromFloat = SVal kindTo $ Left $ cvCastFromFP kindTo rm $ cvalToFP x'++ fpCastFromIntegral :: forall a. Integral a => a -> SVal+ fpCastFromIntegral =+ SVal kindTo . Left . cvCastFromRational kindTo . fromIntegral+svCastToFP kindTo rm x@(SVal kindFrom _)+ = SVal kindTo $ Right $ cache y+ where y st = do svrm <- svToSV st rm+ svx <- svToSV st x+ mkSymOp (IEEEFP (FP_Cast kindFrom kindTo svrm)) st kindTo svrm svx++-- | Convert a floating-point value to a value of a different type. The type to+-- convert to must be one of 'KFloat', 'KDouble', 'KFP', 'KBounded',+-- 'KUnbounded', or 'KReal'.+--+-- Note that converting to 'KBounded' returns a bitvector with the same numeric+-- value as the input float (appropriately rounded). For a lossless conversion+-- that returns a bitvector with the same bit pattern as the input float, see+-- 'svFloatAsSWord32', 'svDoubleAsSWord64', and 'svFloatingPointAsSWord'.+svCastFromFP :: Kind -- ^ The kind to cast to.+ -> SVal -- ^ Rounding mode+ -> SVal -- ^ The value to be casted. Must be a floating-point value.+ -> SVal+svCastFromFP kindTo (svAsRoundingMode -> Just rm) x@(SVal kindFrom (Left (CV _ x')))+ | kindFrom == kindTo+ = x++ | KFloat {} <- kindTo+ = fpCastToFloat+ | KDouble {} <- kindTo+ = fpCastToFloat+ | KFP {} <- kindTo+ = fpCastToFloat+ -- No constant-folding for KBounded, KUnbounded, or KReal, as each of these+ -- conversions are partial. Rather than painstakingly check which inputs are+ -- valid, we simply defer to the underlying SMT-LIB operations.+ where fpCastToFloat :: SVal+ fpCastToFloat = SVal kindTo $ Left $ cvCastFromFP kindTo rm $ cvalToFP x'+svCastFromFP kindTo rm x@(SVal kindFrom _)+ = SVal kindTo $ Right $ cache y+ where y st = do svrm <- svToSV st rm+ svx <- svToSV st x+ mkSymOp (IEEEFP (FP_Cast kindFrom kindTo svrm)) st kindTo svrm svx++--------------------------------------------------------------------------------+-- Derived operations++-- | Convert an SVal from kind Bool to an unsigned bitvector of size 1.+svToWord1 :: SVal -> SVal+svToWord1 b = svSymbolicMerge k True b (svInteger k 1) (svInteger k 0)+ where k = KBounded False 1++-- | Convert an SVal from a bitvector of size 1 (signed or unsigned) to kind Bool.+svFromWord1 :: SVal -> SVal+svFromWord1 x = svNotEqual x (svInteger k 0)+ where k = kindOf x++-- | Test the value of a bit. Note that we do an extract here+-- as opposed to masking and checking against zero, as we found+-- extraction to be much faster with large bit-vectors.+svTestBit :: SVal -> Int -> SVal+svTestBit x i+ | i < intSizeOf x = svFromWord1 (svExtract i i x)+ | True = svFalse++-- | Generalization of 'svShl', where the shift-amount is symbolic.+svShiftLeft :: SVal -> SVal -> SVal+svShiftLeft = svShift True++-- | Generalization of 'svShr', where the shift-amount is symbolic.+--+-- NB. If the shiftee is signed, then this is an arithmetic shift;+-- otherwise it's logical.+svShiftRight :: SVal -> SVal -> SVal+svShiftRight = svShift False++-- | Generic shifting of bounded quantities. The shift amount must be non-negative and within the bounds of the argument+-- for bit vectors. For negative shift amounts, the result is returned unchanged. For overshifts, left-shift produces 0,+-- right shift produces 0 or -1 depending on the result being signed.+svShift :: Bool -> SVal -> SVal -> SVal+svShift toLeft x i+ | Just r <- constFoldValue+ = r+ | cannotOverShift+ = svIte (i `svLessThan` svInteger ki 0) -- Negative shift, no change+ x+ regularShiftValue+ | True+ = svIte (i `svLessThan` svInteger ki 0) -- Negative shift, no change+ x+ $ svIte (i `svGreaterEq` svInteger ki (fromIntegral (intSizeOf x))) -- Overshift, by at least the bit-width of x+ overShiftValue+ regularShiftValue++ where nm | toLeft = "shiftLeft"+ | True = "shiftRight"++ kx = kindOf x+ ki = kindOf i++ -- Constant fold the result if possible. If either quantity is unbounded, then we only support constants+ -- as there's no easy/meaningful way to map this combo to SMTLib. Should be rarely needed, if ever!+ -- We also perform basic sanity check here so that if we go past here, we know we have bitvectors only.+ constFoldValue+ | Just iv <- getConst i, iv == 0+ = Just x++ | Just xv <- getConst x, xv == 0+ = Just x++ | Just xv <- getConst x, Just iv <- getConst i+ = Just $ SVal kx . Left $! normCV $ CV kx (CInteger (xv `opC` shiftAmount iv))++ | isUnbounded x || isUnbounded i+ = bailOut $ "Not yet implemented unbounded/non-constants shifts for " ++ show (kx, ki) ++ ", please file a request!"++ | not (isBounded x && isBounded i)+ = bailOut $ "Unexpected kinds: " ++ show (kx, ki)++ | True+ = Nothing++ where bailOut m = error $ "SBV." ++ nm ++ ": " ++ m++ getConst (SVal _ (Left (CV _ (CInteger val)))) = Just val+ getConst _ = Nothing++ opC | toLeft = shiftL+ | True = shiftR++ -- like fromIntegral, but more paranoid+ shiftAmount :: Integer -> Int+ shiftAmount iv+ | iv <= 0 = 0+ | isUnbounded i, iv > fromIntegral (maxBound :: Int) = bailOut $ "Unsupported constant unbounded shift with amount: " ++ show iv+ | isUnbounded x = fromIntegral iv+ | iv >= fromIntegral ub = ub+ | not (isBounded x && isBounded i) = bailOut $ "Unsupported kinds: " ++ show (kx, ki)+ | True = fromIntegral iv+ where ub = intSizeOf x++ -- Overshift is not possible if the bit-size of x won't even fit into the bit-vector size+ -- of i. Note that this is a *necessary* check, Consider for instance if we're shifting a+ -- 32-bit value using a 1-bit shift amount (which can happen if the value is 1 with minimal+ -- shift widths). We would compare 1 >= 32, but stuffing 32 into bit-vector of size 1 would+ -- overflow. See http://github.com/LeventErkok/sbv/issues/323 for this case. Thus, we+ -- make sure that the bit-vector would fit as a value.+ cannotOverShift = maxRepresentable <= fromIntegral (intSizeOf x)+ where maxRepresentable :: Integer+ maxRepresentable+ | hasSign i = bit (intSizeOf i - 1) - 1+ | True = bit (intSizeOf i ) - 1++ -- An overshift occurs if we're shifting by more than or equal to the bit-width of x+ -- For shift-left: this value is always 0+ -- For shift-right:+ -- If x is unsigned: 0+ -- If x is signed and is less than 0, then -1 else 0+ overShiftValue | toLeft = zx+ | hasSign x = svIte (x `svLessThan` zx) neg1 zx+ | True = zx+ where zx = svInteger kx 0+ neg1 = svInteger kx (-1)++ -- Regular shift, we know that the shift value fits into the bit-width of x, since it's between 0 and sizeOf x. So, we can just+ -- turn it into a properly sized argument and ship it to SMTLib+ regularShiftValue = SVal kx $ Right $ cache result+ where result st = do sw1 <- svToSV st x+ sw2 <- svToSV st i++ let op | toLeft = Shl+ | True = Shr++ adjustedShift <- if kx == ki+ then pure sw2+ else newExpr st kx (SBVApp (KindCast ki kx) [sw2])++ newExpr st kx (SBVApp op [sw1, adjustedShift])++-- | A variant of 'svRotateLeft' that uses a barrel-rotate design, which can lead to+-- better verification code. Only works when both arguments are finite and the second+-- argument is unsigned.+svBarrelRotateLeft :: SVal -> SVal -> SVal+svBarrelRotateLeft x i+ | not (isBounded x && isBounded i && not (hasSign i))+ = error $ "Data.SBV.Dynamic.svBarrelRotateLeft: Arguments must be bounded with second argument unsigned. Received: " ++ show (x, i)+ | Just iv <- svAsInteger i+ = svRol x $ fromIntegral (iv `rem` fromIntegral (intSizeOf x))+ | True+ = barrelRotate svRol x i++-- | A variant of 'svRotateLeft' that uses a barrel-rotate design, which can lead to+-- better verification code. Only works when both arguments are finite and the second+-- argument is unsigned.+svBarrelRotateRight :: SVal -> SVal -> SVal+svBarrelRotateRight x i+ | not (isBounded x && isBounded i && not (hasSign i))+ = error $ "Data.SBV.Dynamic.svBarrelRotateRight: Arguments must be bounded with second argument unsigned. Received: " ++ show (x, i)+ | Just iv <- svAsInteger i+ = svRor x $ fromIntegral (iv `rem` fromIntegral (intSizeOf x))+ | True+ = barrelRotate svRor x i++-- Barrel rotation, by bit-blasting the argument:+barrelRotate :: (SVal -> Int -> SVal) -> SVal -> SVal -> SVal+barrelRotate f a c = loop blasted a+ where loop :: [(SVal, Integer)] -> SVal -> SVal+ loop [] acc = acc+ loop ((b, v) : rest) acc = loop rest (svIte b (f acc (fromInteger v)) acc)++ sa = toInteger $ intSizeOf a+ n = svInteger (kindOf c) sa++ -- Reduce by the modulus amount, we need not care about the+ -- any part larger than the value of the bit-size of the+ -- argument as it is identity for rotations+ reducedC = c `svRem` n++ -- blast little-endian, and zip with bit-position+ blasted = takeWhile significant $ zip (svBlastLE reducedC) [2^i | i <- [(0::Integer)..]]++ -- Any term whose bit-position is larger than our input size+ -- is insignificant, since the reduction would've put 0's in those+ -- bits. For instance, if a is 32 bits, and c is 5 bits, then we+ -- need not look at any position i s.t. 2^i > 32+ significant (_, pos) = pos < sa++-- | Generalization of 'svRol', where the rotation amount is symbolic.+-- If the first argument is not bounded, then the this is the same as shift.+svRotateLeft :: SVal -> SVal -> SVal+svRotateLeft = svRotate svShiftLeft svRor svRol++-- | Generalization of 'svRor', where the rotation amount is symbolic.+-- If the first argument is not bounded, then the this is the same as shift.+svRotateRight :: SVal -> SVal -> SVal+svRotateRight = svRotate svShiftRight svRol svRor++-- | Common implementation for rotations. This is more complicated than it might first seem, since SMTLib does+-- not allow for non-constant rotation amounts, and only defines rotations for bit-vectors. In SBV, we support+-- both finite/infinite combos, and also non-constant (i.e., symbolic) rotations. Furthermore, if the rotation+-- amount is negative, then the direction of the rotation is reversed.+--+-- Case 1. Infinite x. In this case, we call unbounded-shifter, since you can't rotate an unbounded integer value.+-- This is the Haskell semantics for rotates.+-- Case 2. Finite x.+-- Case 2.1. Infinite i, or finite i but i can contain a value > |x|. In this case, wrap-around can happen,+-- so we reduce by the size of |x|.+-- Case 2.2. Finite i, and it can't contain a value > |x|. In this case, no reduction is needed.+svRotate :: (SVal -> SVal -> SVal) -> (SVal -> Int -> SVal) -> (SVal -> Int -> SVal) -> SVal -> SVal -> SVal+svRotate unboundedShifter opRot curRot x i+ | not (isBounded x)+ = unboundedShifter x i+ | True+ = svSelect table (svInteger (kindOf x) 0) curRotate+ where sx = intSizeOf x+ si = intSizeOf i++ -- Is it the case that this rotation can never "wrap-around?" This happens if+ -- i is bounded and the max rotation it can represent is less than the bit-size of the input+ noWrapAround :: Bool+ noWrapAround = isBounded i && maxRotate <= toInteger sx+ where maxRotate :: Integer+ maxRotate+ | hasSign i = 2^(si-1)+ | True = 2^si-1++ ifNegRotate = svIte (svLessThan i (svInteger (kindOf i) 0))++ -- the lookup table has sx entries if index can wrap-around. Otherwise it is just as wide as it needs to be.+ table :: [SVal]+ table = map rotK vals+ where rotK k = ifNegRotate (x `opRot` k) (x `curRot` k)+ vals | noWrapAround = if hasSign i+ then -- If signed then bit (si-1) is the max abs value. (consider 3 bits, [-4..3] is the range)+ [0 .. bit (si - 1)]+ else [0 .. bit si - 1]+ | True -- If wrap-around can happen, then compute all rotations up to |x|+ = [0 .. sx - 1]++ -- What's the current rotation amount? Here we change the type of the+ -- index to make it one bit larger if the index is signed, since otherwise+ -- we run into (-(-1)) = -1 problem. See https://github.com/LeventErkok/sbv/issues/673#issuecomment-1782296700+ -- Note that curRotate is always non-negative.+ curRotate :: SVal+ curRotate+ | noWrapAround = ifNegRotate (svUNeg i' ) i'+ | True = ifNegRotate (svUNeg i' `svRem` n) (i' `svRem` n)++ where i' | hasSign i && isBounded i = toWord $ svAbs $ enlarge i+ | True = i++ -- Make sure sx can fit into this many bits+ si' = (si + 1) `max` bitsNeeded sx++ enlarge+ | isBounded i = svFromIntegral (KBounded True si') -- Increase bit size+ | True = id+ toWord+ | isBounded i = svFromIntegral (KBounded False si') -- Treat as word, after call to svAbs above+ | True = id++ n = svInteger (kindOf i') (toInteger sx)++ bitsNeeded :: Int -> Int+ bitsNeeded = go 0+ where go s 0 = s+ go s v = let s' = s + 1 in s' `seq` go s' (v `shiftR` 1)++--------------------------------------------------------------------------------+-- | Overflow detection.+svMkOverflow1 :: OvOp -> SVal -> SVal+svMkOverflow1 o x = SVal KBool (Right (cache r))+ where r st = do sx <- svToSV st x+ newExpr st KBool $ SBVApp (OverflowOp o) [sx]++svMkOverflow2 :: OvOp -> SVal -> SVal -> SVal+svMkOverflow2 o x y = SVal KBool (Right (cache r))+ where r st = do sx <- svToSV st x+ sy <- svToSV st y+ newExpr st KBool $ SBVApp (OverflowOp o) [sx, sy]++--------------------------------------------------------------------------------+-- Utility functions++liftSym1 :: (State -> Kind -> SV -> IO SV) -> (AlgReal -> AlgReal)+ -> (Integer -> Integer)+ -> (Float -> Float)+ -> (Double -> Double)+ -> (FP -> FP)+ -> (Rational -> Rational)+ -> SVal -> SVal+liftSym1 _ opCR opCI opCF opCD opFP opRA (SVal k (Left a)) = SVal k . Left $! mapCV opCR opCI opCF opCD opFP opRA a+liftSym1 opS _ _ _ _ _ _ a@(SVal k _) = SVal k $ Right $ cache c+ where c st = do sva <- svToSV st a+ opS st k sva++{- A note on constant folding.++There are cases where we miss out on certain constant foldings. On May 8 2018, Matt Peddie pointed this+out, as the C code he was getting had redundancies. I was aware that could be missing constant foldings+due to missed out optimizations, or some other code snafu, but till Matt pointed it out I haven't realized+that we could be hiding constants inside an if-then-else. The example is:++ proveWith z3{verbose=True} $ \x -> 0 .< ite (x .== (x::SWord8)) 1 (2::SWord8)++If you try this, you'll see that it generates (shortened):++ (define-fun s1 () (_ BitVec 8) #x00)+ (define-fun s2 () (_ BitVec 8) #x01)+ (define-fun s3 () Bool (bvult s1 s2))++But clearly we have all the info for s3 to be computed! The issue here is that the reduction of @x .== x@ to @true@+happens after we start computing the if-then-else, hence we are already committed to an SV at that point. The call+to ite eventually recognizes this, but at that point it picks up the now constants from SV's, missing the constant+folding opportunity.++We can fix this, by looking up the constants table in liftSV2, along the lines of:+++ liftSV2 :: (CV -> CV -> Bool) -> (CV -> CV -> CV) -> (State -> Kind -> SV -> SV -> IO SV) -> Kind -> SVal -> SVal -> Cached SV+ liftSV2 okCV opCV opS k a b = cache c+ where c st = do sw1 <- svToSV st a+ sw2 <- svToSV st b+ cmap <- readIORef (rconstMap st)+ let cv1 = [cv | ((_, cv), sv) <- M.toList cmap, sv == sv1]+ cv2 = [cv | ((_, cv), sv) <- M.toList cmap, sv == sv2]+ case (cv1, cv2) of+ ([x], [y]) | okCV x y -> newConst st $ opCV x y+ _ -> opS st k sv1 sv2++(with obvious modifications to call sites to get the proper arguments.)++But this means that we have to grab the constant list for every symbolically lifted operation, also do the+same for other places, etc.; for the rare opportunity of catching a @x .== x@ optimization. Even then, the+constants for the branches would still be generated. (i.e., in the above example we would still generate+@s1@ and @s2@, but would skip @s3@.)++It seems to me that the price to pay is rather high, as this is hardly the most common case; so we're opting+here to ignore these cases.++See http://github.com/LeventErkok/sbv/issues/379 for some further discussion.+-}+liftSV2 :: (State -> Kind -> SV -> SV -> IO SV) -> Kind -> SVal -> SVal -> Cached SV+liftSV2 opS k a b = cache c+ where c st = do sw1 <- svToSV st a+ sw2 <- svToSV st b+ opS st k sw1 sw2++liftSym2 :: (State -> Kind -> SV -> SV -> IO SV)+ -> [CV -> CV -> Bool]+ -> (AlgReal -> AlgReal -> AlgReal)+ -> (Integer -> Integer -> Integer)+ -> (Float -> Float -> Float)+ -> (Double -> Double -> Double)+ -> (FP -> FP -> FP)+ -> (Rational -> Rational-> Rational)+ -> SVal -> SVal -> SVal+liftSym2 _ okCV opCR opCI opCF opCD opFP opRA (SVal k (Left a)) (SVal _ (Left b)) | and [f a b | f <- okCV] = SVal k . Left $! mapCV2 opCR opCI opCF opCD opFP opRA a b+liftSym2 opS _ _ _ _ _ _ _ a@(SVal k _) b = SVal k $ Right $ liftSV2 opS k a b++-- | Lift a unary floating-point operation that can work over 'Float',+-- 'Double', and t'FP' values.+liftFPSym1 :: String+ -> (State -> Kind -> SV -> IO SV)+ -> (Float -> Float)+ -> (Double -> Double)+ -> (FP -> FP)+ -> SVal -> SVal+liftFPSym1 o _ opCF opCD opFP (SVal k (Left a))+ = SVal k . Left $! mapCV (noRealUnary o) (noIntUnary o) opCF opCD opFP (noRatUnary o) a+liftFPSym1 _ opS _ _ _ a@(SVal k _) = SVal k $ Right $ cache c+ where c st = do sva <- svToSV st a+ opS st k sva++-- | Like 'liftFPSym1', but with an explicit rounding mode. Note that concrete+-- evaluation of 'Float's or 'Double's is only supported when the+-- 'RoundNearestTiesToEven' rounding mode is used (see the Haddocks for+-- 'floatDoubleRneCheck').+liftFPSymRM1 :: String+ -> (State -> Kind -> SV -> SV -> IO SV)+ -> (Float -> Float)+ -> (Double -> Double)+ -> (RoundingMode -> FP -> FP)+ -> SVal -> SVal -> SVal+liftFPSymRM1 o _ opCF opCD opFP rm (SVal k (Left a))+ | Just rm'@RoundNearestTiesToEven <- svAsRoundingMode rm+ , floatDoubleRneCheck rm' a+ = SVal k . Left $! mapCV (noRealUnary o) (noIntUnary o) opCF opCD (opFP rm') (noRatUnary o) a+liftFPSymRM1 _ opS _ _ _ rm a@(SVal k _) = SVal k $ Right $ cache c+ where c st = do svrm <- svToSV st rm+ sva <- svToSV st a+ opS st k svrm sva++-- | Lift a binary floating-point operation that can work over 'Float',+-- 'Double', and t'FP' values.+liftFPSym2 :: String+ -> (State -> Kind -> SV -> SV -> IO SV)+ -> (Float -> Float -> Float)+ -> (Double -> Double -> Double)+ -> (FP -> FP -> FP)+ -> SVal -> SVal -> SVal+liftFPSym2 o _ opCF opCD opFP (SVal k (Left a)) (SVal _ (Left b))+ = SVal k . Left $! mapCV2 (noReal o) (noInt o) opCF opCD opFP (noRat o) a b+liftFPSym2 _ opS _ _ _ a@(SVal k _) b = SVal k $ Right $ cache c+ where c st = do sva <- svToSV st a+ svb <- svToSV st b+ opS st k sva svb++-- | Like 'liftFPSym2', but with an explicit rounding mode. Note that concrete+-- evaluation of 'Float's or 'Double's is only supported when the+-- 'RoundNearestTiesToEven' rounding mode is used (see the Haddocks for+-- 'floatDoubleRneCheck').+liftFPSymRM2 :: String+ -> (State -> Kind -> SV -> SV -> SV -> IO SV)+ -> (Float -> Float -> Float)+ -> (Double -> Double -> Double)+ -> (RoundingMode -> FP -> FP -> FP)+ -> SVal -> SVal -> SVal -> SVal+liftFPSymRM2 o _ opCF opCD opFP rm (SVal k (Left a)) (SVal _ (Left b))+ | Just rm'@RoundNearestTiesToEven <- svAsRoundingMode rm+ , floatDoubleRneCheck rm' a+ = SVal k . Left $! mapCV2 (noReal o) (noInt o) opCF opCD (opFP rm') (noRat o) a b+liftFPSymRM2 _ opS _ _ _ rm a@(SVal k _) b = SVal k $ Right $ cache c+ where c st = do svrm <- svToSV st rm+ sva <- svToSV st a+ svb <- svToSV st b+ opS st k svrm sva svb++-- | Lift a unary floating-point predicate that can work over 'Float',+-- 'Double', and t'FP' values.+liftFPPred :: (State -> Kind -> SV -> IO SV)+ -> (Float -> Bool)+ -> (Double -> Bool)+ -> (FP -> Bool)+ -> SVal -> SVal+liftFPPred _ opCF opCD opFP (SVal k (Left a)) =+ case cvVal a of+ CFloat f -> svBool $ opCF f+ CDouble d -> svBool $ opCD d+ CFP fp -> svBool $ opFP fp++ CAlgReal {} -> unexpected+ CInteger {} -> unexpected+ CRational {} -> unexpected+ CChar {} -> unexpected+ CString {} -> unexpected+ CList {} -> unexpected+ CSet {} -> unexpected+ CADT {} -> unexpected+ CTuple {} -> unexpected+ CArray {} -> unexpected+ where unexpected = error $ "Data.SBV.liftFPPred: Unexpected kind: " ++ show k+liftFPPred opS _ _ _ a = SVal KBool $ Right $ cache c+ where c st = do sva <- svToSV st a+ opS st KBool sva++-- | Create a symbolic two argument operation; with shortcut optimizations+mkSymOpSC :: (SV -> SV -> Maybe SV) -> Op -> State -> Kind -> SV -> SV -> IO SV+mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) pure (shortCut a b)++-- | Create a symbolic two argument operation; no shortcut optimizations+mkSymOp :: Op -> State -> Kind -> SV -> SV -> IO SV+mkSymOp = mkSymOpSC (const (const Nothing))++mkSymOp1SC :: (SV -> Maybe SV) -> Op -> State -> Kind -> SV -> IO SV+mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) pure (shortCut a)++mkSymOp1 :: Op -> State -> Kind -> SV -> IO SV+mkSymOp1 = mkSymOp1SC (const Nothing)++mkSymOp3 :: Op -> State -> Kind -> SV -> SV -> SV -> IO SV+mkSymOp3 op st k a b c = newExpr st k (SBVApp op [a, b, c])++-- | Predicate to check if a value is concrete+isConcrete :: SVal -> Bool+isConcrete (SVal _ Left{}) = True+isConcrete _ = False++-- | Predicate for optimizing word operations like (+) and (*).+-- NB. We specifically do *not* match for Double/Float; because+-- FP-arithmetic doesn't obey traditional rules. For instance,+-- 0 * x = 0 fails if x happens to be NaN or +/- Infinity. So,+-- we merely return False when given a floating-point value here.+isConcreteZero :: SVal -> Bool+isConcreteZero (SVal _ (Left (CV _ (CInteger n)))) = n == 0+isConcreteZero (SVal KReal (Left (CV KReal (CAlgReal v)))) = isExactRational v && v == 0+isConcreteZero _ = False++-- | Predicate for optimizing word operations like (+) and (*).+-- NB. See comment on 'isConcreteZero' for why we don't match+-- for Float/Double values here.+isConcreteOne :: SVal -> Bool+isConcreteOne (SVal _ (Left (CV _ (CInteger 1)))) = True+isConcreteOne (SVal KReal (Left (CV KReal (CAlgReal v)))) = isExactRational v && v == 1+isConcreteOne _ = False++-- | Predicate for optimizing bitwise operations. The unbounded integer case of checking+-- against -1 might look dubious, but that's how Haskell treats 'Integer' as a member+-- of the Bits class, try @(-1 :: Integer) `testBit` i@ for any @i@ and you'll get 'True'.+isConcreteOnes :: SVal -> Bool+isConcreteOnes (SVal _ (Left (CV (KBounded b w) (CInteger n)))) = n == if b then -1 else bit w - 1+isConcreteOnes (SVal _ (Left (CV KUnbounded (CInteger n)))) = n == -1 -- see comment above+isConcreteOnes (SVal _ (Left (CV KBool (CInteger n)))) = n == 1+isConcreteOnes _ = False++-- | Predicate for optimizing comparisons.+isConcreteMax :: SVal -> Bool+isConcreteMax (SVal _ (Left (CV (KBounded False w) (CInteger n)))) = n == bit w - 1+isConcreteMax (SVal _ (Left (CV (KBounded True w) (CInteger n)))) = n == bit (w - 1) - 1+isConcreteMax (SVal _ (Left (CV KBool (CInteger n)))) = n == 1+isConcreteMax _ = False++-- | Predicate for optimizing comparisons.+isConcreteMin :: SVal -> Bool+isConcreteMin (SVal _ (Left (CV (KBounded False _) (CInteger n)))) = n == 0+isConcreteMin (SVal _ (Left (CV (KBounded True w) (CInteger n)))) = n == - bit (w - 1)+isConcreteMin (SVal _ (Left (CV KBool (CInteger n)))) = n == 0+isConcreteMin _ = False++-- | Most operations on concrete rationals require a compatibility check to avoid faulting+-- on algebraic reals.+rationalCheck :: CV -> CV -> Bool+rationalCheck a b = case (cvVal a, cvVal b) of+ (CAlgReal x, CAlgReal y) -> isExactRational x && isExactRational y+ _ -> True++-- | Quot/Rem operations require a nonzero check on the divisor.+nonzeroCheck :: CV -> CV -> Bool+nonzeroCheck _ b = cvVal b /= CInteger 0++-- | Same as rationalCheck, except for SBV's+rationalSBVCheck :: SVal -> SVal -> Bool+rationalSBVCheck (SVal KReal (Left a)) (SVal KReal (Left b)) = rationalCheck a b+rationalSBVCheck _ _ = True++-- | Predicate to check if a concrete 'Float' or 'Double' value uses the+-- 'RoundNearestTiesToEven' rounding mode. This is necessary because we assume+-- this rounding mode when concretely evaluating 'Float's and 'Double's, so+-- concrete evaluation is not supported for other rounding modes.+--+-- Note that this check skips concrete t'FP' values, which support concrete+-- evaluation with any rounding mode.+floatDoubleRneCheck :: RoundingMode -> CV -> Bool+floatDoubleRneCheck rm cv =+ case cvKind cv of+ KFloat -> rmIsRne+ KDouble -> rmIsRne+ _ -> True+ where+ rmIsRne | RoundNearestTiesToEven <- rm = True+ | True = False++noInt :: String -> Integer -> Integer -> a+noInt o a b = error $ "SBV.Integer." ++ o ++ ": Unexpected arguments: " ++ show (a, b)++noReal :: String -> AlgReal -> AlgReal -> a+noReal o a b = error $ "SBV.AlgReal." ++ o ++ ": Unexpected arguments: " ++ show (a, b)++noFloat :: String -> Float -> Float -> a+noFloat o a b = error $ "SBV.Float." ++ o ++ ": Unexpected arguments: " ++ show (a, b)++noDouble :: String -> Double -> Double -> a+noDouble o a b = error $ "SBV.Double." ++ o ++ ": Unexpected arguments: " ++ show (a, b)++noFP :: String -> FP -> FP -> a+noFP o a b = error $ "SBV.FPR." ++ o ++ ": Unexpected arguments: " ++ show (a, b)++noRat:: String -> Rational -> Rational -> a+noRat o a b = error $ "SBV.Rational." ++ o ++ ": Unexpected arguments: " ++ show (a, b)++noIntUnary :: String -> Integer -> a+noIntUnary o a = error $ "SBV.Integer." ++ o ++ ": Unexpected argument: " ++ show a++noRealUnary :: String -> AlgReal -> a+noRealUnary o a = error $ "SBV.AlgReal." ++ o ++ ": Unexpected argument: " ++ show a++noFloatUnary :: String -> Float -> a+noFloatUnary o a = error $ "SBV.Float." ++ o ++ ": Unexpected argument: " ++ show a++noDoubleUnary :: String -> Double -> a+noDoubleUnary o a = error $ "SBV.Double." ++ o ++ ": Unexpected argument: " ++ show a++noFPUnary :: String -> FP -> a+noFPUnary o a = error $ "SBV.FPR." ++ o ++ ": Unexpected argument: " ++ show a++noRatUnary :: String -> Rational -> a+noRatUnary o a = error $ "SBV.Rational." ++ o ++ ": Unexpected argument: " ++ show a++-- | Given a composite structure, figure out how to compare for less than+svStructuralLessThan :: SVal -> SVal -> SVal+svStructuralLessThan x y+ | isConcrete x && isConcrete y+ = x `svLessThan` y+ | KTuple{} <- kx+ = tupleLT x y+ | True+ = x `svLessThan` y+ where kx = kindOf x++-- | Structural less-than for tuples+tupleLT :: SVal -> SVal -> SVal+tupleLT x y = SVal KBool $ Right $ cache res+ where ks = case kindOf x of+ KTuple xs -> xs+ k -> error $ "Data.SBV: Impossible happened, tupleLT called with: " ++ show (k, x, y)++ n = length ks++ res st = do sx <- svToSV st x+ sy <- svToSV st y++ let chkElt i ek = let xi = SVal ek $ Right $ cache $ \_ -> newExpr st ek $ SBVApp (TupleAccess i n) [sx]+ yi = SVal ek $ Right $ cache $ \_ -> newExpr st ek $ SBVApp (TupleAccess i n) [sy]+ lt = xi `svStructuralLessThan` yi+ eq = xi `svEqual` yi+ in (lt, eq)++ walk [] = svFalse+ walk [(lti, _)] = lti+ walk ((lti, eqi) : rest) = lti `svOr` (eqi `svAnd` walk rest)++ svToSV st $ walk $ zipWith chkElt [1..] ks++-- | Convert an 'Data.SBV.SWord32' to an 'Data.SBV.SFloat', preserving the+-- bit-correspondence. Note that since the representation for @NaN@s are not+-- unique, there are multiple word values for which this function will return a+-- single, distinguished @NaN@ value.+svSWord32AsFloat :: SVal -> SVal+svSWord32AsFloat w@(SVal kindFrom x)+ | KBounded _ 32 <- kindFrom+ = case x of+ Left (CV _ (CInteger w'))+ -> SVal kindTo $ Left $ CV kindTo $ CFloat $ wordToFloat $ fromInteger w'+ _ -> SVal kindTo $ Right $ cache y+ | True+ = error $ "svSWord32AsFloat: not a 32-bit word type: " ++ show kindFrom+ where kindTo = KFloat+ y st = do svw <- svToSV st w+ mkSymOp1 (IEEEFP (FP_Reinterpret kindFrom kindTo)) st kindTo svw++-- | Convert an 'Data.SBV.SWord64' to an 'Data.SBV.SDouble', preserving the+-- bit-correspondence. Note that since the representation for @NaN@s are not+-- unique, there are multiple word values for which this function will return a+-- single, distinguished @NaN@ value.+svSWord64AsDouble :: SVal -> SVal+svSWord64AsDouble w@(SVal kindFrom x)+ | KBounded _ 64 <- kindFrom+ = case x of+ Left (CV _ (CInteger w'))+ -> SVal kindTo $ Left $ CV kindTo $ CDouble $ wordToDouble $ fromInteger w'+ _ -> SVal kindTo $ Right $ cache y+ | True+ = error $ "svSWord64AsDouble: not a 64-bit word type: " ++ show kindFrom+ where kindTo = KDouble+ y st = do svw <- svToSV st w+ mkSymOp1 (IEEEFP (FP_Reinterpret kindFrom kindTo)) st kindTo svw++-- | Convert a word to a float (using the given exponent and significand sizes)+-- containing the word's corresponding bit pattern. Note that since the+-- representation for @NaN@s are not unique, there are multiple word values for+-- which this function will return a single, distinguished @NaN@ value.+svSWordAsFloatingPoint :: Int -- ^ Exponent size+ -> Int -- ^ Significand size+ -> SVal -> SVal+svSWordAsFloatingPoint eb sb w@(SVal kindFrom x)+ | KBounded _ _ <- kindFrom+ = case x of+ Left (CV _ (CInteger w'))+ -> SVal kindTo $ Left $ CV kindTo $ CFP $ fpFromBits eb sb $ fromInteger w'+ _ -> SVal kindTo $ Right $ cache y+ | True+ = error $ "svSWordAsFloatingPoint: non-word type: " ++ show kindFrom+ where kindTo = KFP eb sb+ y st = do svw <- svToSV st w+ mkSymOp1 (IEEEFP (FP_Reinterpret kindFrom kindTo)) st kindTo svw++-- | Convert an 'Data.SBV.SFloat' to an 'Data.SBV.SWord32', preserving the bit-correspondence. Note that since the+-- representation for @NaN@s are not unique, this function will return a symbolic value when given a+-- concrete @NaN@.+--+-- Implementation note: Since there's no corresponding function in SMTLib for conversion to+-- bit-representation due to partiality, we use a translation trick by allocating a new word variable,+-- converting it to float, and requiring it to be equivalent to the input. In code-generation mode, we simply map+-- it to a simple conversion.+svFloatAsSWord32 :: SVal -> SVal+svFloatAsSWord32 (SVal KFloat (Left (CV KFloat (CFloat f))))+ | not (isNaN f)+ = let w32 = KBounded False 32+ in SVal w32 $ Left $ CV w32 $ CInteger (fromIntegral (floatToWord f))+svFloatAsSWord32 fVal@(SVal KFloat _)+ = SVal w32 (Right (cache y))+ where w32 = KBounded False 32+ y st = do cg <- isCodeGenMode st+ if cg+ then do f <- svToSV st fVal+ newExpr st w32 (SBVApp (IEEEFP (FP_Reinterpret KFloat w32)) [f])+ else do n <- newInternalVariable st w32+ ysw <- newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret w32 KFloat)) [n])+ internalConstraint st False [] $ fVal `svStrongEqual` SVal KFloat (Right (cache (\_ -> pure ysw)))+ pure n+svFloatAsSWord32 (SVal k _) = error $ "svFloatAsSWord32: non-float type: " ++ show k++-- | Convert an 'Data.SBV.SDouble' to an 'Data.SBV.SWord64', preserving the bit-correspondence. Note that since the+-- representation for @NaN@s are not unique, this function will return a symbolic value when given a+-- concrete @NaN@.+--+-- Implementation note: Since there's no corresponding function in SMTLib for conversion to+-- bit-representation due to partiality, we use a translation trick by allocating a new word variable,+-- converting it to float, and requiring it to be equivalent to the input. In code-generation mode, we simply map+-- it to a simple conversion.+svDoubleAsSWord64 :: SVal -> SVal+svDoubleAsSWord64 (SVal KDouble (Left (CV KDouble (CDouble f))))+ | not (isNaN f)+ = let w64 = KBounded False 64+ in SVal w64 $ Left $ CV w64 $ CInteger (fromIntegral (doubleToWord f))+svDoubleAsSWord64 fVal@(SVal KDouble _)+ = SVal w64 (Right (cache y))+ where w64 = KBounded False 64+ y st = do cg <- isCodeGenMode st+ if cg+ then do f <- svToSV st fVal+ newExpr st w64 (SBVApp (IEEEFP (FP_Reinterpret KDouble w64)) [f])+ else do n <- newInternalVariable st w64+ ysw <- newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret w64 KDouble)) [n])+ internalConstraint st False [] $ fVal `svStrongEqual` SVal KDouble (Right (cache (\_ -> pure ysw)))+ pure n+svDoubleAsSWord64 (SVal k _) = error $ "svDoubleAsSWord64: non-float type: " ++ show k++-- | Convert a float to the word containing the corresponding bit pattern+svFloatingPointAsSWord :: SVal -> SVal+svFloatingPointAsSWord (SVal (KFP eb sb) (Left (CV _ (CFP f@(FP _ _ fpV)))))+ | not (isNaN f)+ = let wN = KBounded False (eb + sb)+ in SVal wN $ Left $ CV wN $ CInteger $ bfToBits (mkBFOpts eb sb NearEven) fpV+svFloatingPointAsSWord fVal@(SVal kFrom@(KFP eb sb) _)+ = SVal kTo (Right (cache y))+ where kTo = KBounded False (eb + sb)+ y st = do cg <- isCodeGenMode st+ if cg+ then do f <- svToSV st fVal+ newExpr st kTo (SBVApp (IEEEFP (FP_Reinterpret kFrom kTo)) [f])+ else do n <- newInternalVariable st kTo+ ysw <- newExpr st kFrom (SBVApp (IEEEFP (FP_Reinterpret kTo kFrom)) [n])+ internalConstraint st False [] $ fVal `svStrongEqual` SVal kFrom (Right (cache (\_ -> pure ysw)))+ pure n+svFloatingPointAsSWord (SVal k _) = error $ "svFloatingPointAsSWord: non-float type: " ++ show k++{- HLint ignore svIte "Eta reduce" -}+{- HLint ignore svLazyIte "Eta reduce" -}+{- HLint ignore module "Reduce duplication" -}
Data/SBV/Core/Sized.hs view
@@ -11,22 +11,18 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Core.Sized ( -- * Type-sized unsigned bit-vectors- SWord, WordN, sWord, sWord_, sWords+ WordN -- * Type-sized signed bit-vectors- , SInt, IntN, sInt, sInt_, sInts- -- * Bit-vector operations- , bvExtract, (#), zeroExtend, signExtend, bvDrop, bvTake+ , IntN ) where import Data.Bits@@ -34,55 +30,37 @@ import Data.Proxy (Proxy(..)) import GHC.TypeLits+import GHC.Real -import Data.SBV.Core.Data import Data.SBV.Core.Kind-import Data.SBV.Core.Model-import Data.SBV.Core.Operations import Data.SBV.Core.Symbolic+import Data.SBV.Core.Concrete+import Data.SBV.Core.Operations -import Data.SBV.SMT.SMT+import Test.QuickCheck(Arbitrary(..)) -- | An unsigned bit-vector carrying its size info newtype WordN (n :: Nat) = WordN Integer deriving (Eq, Ord) --- | A symbolic unsigned bit-vector carrying its size info-type SWord (n :: Nat) = SBV (WordN n)---- | Show instance for 'WordN'+-- | Show instance for t'WordN' instance Show (WordN n) where show (WordN v) = show v --- | 'WordN' has a kind+-- | t'WordN' has a kind instance (KnownNat n, BVIsNonZero n) => HasKind (WordN n) where kindOf _ = KBounded False (intOfProxy (Proxy @n)) --- | 'SymVal' instance for 'WordN'-instance (KnownNat n, BVIsNonZero n) => SymVal (WordN n) where- literal x = genLiteral (kindOf x) x- mkSymVal = genMkSymVar (kindOf (undefined :: WordN n))- fromCV = genFromCV- -- | A signed bit-vector carrying its size info newtype IntN (n :: Nat) = IntN Integer deriving (Eq, Ord) --- | A symbolic signed bit-vector carrying its size info-type SInt (n :: Nat) = SBV (IntN n)---- | Show instance for 'IntN'+-- | Show instance for t'IntN' instance Show (IntN n) where show (IntN v) = show v --- | 'IntN' has a kind+-- | t'IntN' has a kind instance (KnownNat n, BVIsNonZero n) => HasKind (IntN n) where kindOf _ = KBounded True (intOfProxy (Proxy @n)) --- | 'SymVal' instance for 'IntN'-instance (KnownNat n, BVIsNonZero n) => SymVal (IntN n) where- literal x = genLiteral (kindOf x) x- mkSymVal = genMkSymVar (kindOf (undefined :: IntN n))- fromCV = genFromCV- -- Lift a unary operation via SVal lift1 :: (KnownNat n, BVIsNonZero n, HasKind (bv n), Integral (bv n), Show (bv n)) => String -> (SVal -> SVal) -> bv n -> bv n lift1 nm op x = uc $ op (c x)@@ -115,17 +93,17 @@ uc (SVal _ (Left v)) = cvToBool v uc r = error $ "Impossible happened while lifting " ++ show nm ++ " over " ++ show (k, x, i, r) --- | 'Bounded' instance for 'WordN'+-- | 'Bounded' instance for t'WordN' instance (KnownNat n, BVIsNonZero n) => Bounded (WordN n) where minBound = WordN 0 maxBound = let sz = intOfProxy (Proxy @n) in WordN $ 2 ^ sz - 1 --- | 'Bounded' instance for 'IntN'+-- | 'Bounded' instance for t'IntN' instance (KnownNat n, BVIsNonZero n) => Bounded (IntN n) where minBound = let sz1 = intOfProxy (Proxy @n) - 1 in IntN $ - (2 ^ sz1) maxBound = let sz1 = intOfProxy (Proxy @n) - 1 in IntN $ 2 ^ sz1 - 1 --- | 'Num' instance for 'WordN'+-- | 'Num' instance for t'WordN' instance (KnownNat n, BVIsNonZero n) => Num (WordN n) where (+) = lift2 "(+)" svPlus (-) = lift2 "(*)" svMinus@@ -135,7 +113,7 @@ signum = WordN . signum . toInteger fromInteger = WordN . fromJust . svAsInteger . svInteger (kindOf (undefined :: WordN n)) --- | 'Num' instance for 'IntN'+-- | 'Num' instance for t'IntN' instance (KnownNat n, BVIsNonZero n) => Num (IntN n) where (+) = lift2 "(+)" svPlus (-) = lift2 "(*)" svMinus@@ -145,35 +123,65 @@ signum = IntN . signum . toInteger fromInteger = IntN . fromJust . svAsInteger . svInteger (kindOf (undefined :: IntN n)) --- | 'Enum' instance for 'WordN'+-- | '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 --- | 'Enum' instance for 'IntN'+ 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 --- | 'Real' instance for 'WordN'+ enumFrom = integralEnumFrom+ enumFromTo = integralEnumFromTo+ enumFromThen = integralEnumFromThen+ enumFromThenTo = integralEnumFromThenTo++-- | 'Real' instance for t'WordN' instance (KnownNat n, BVIsNonZero n) => Real (WordN n) where toRational (WordN x) = toRational x --- | 'Real' instance for 'IntN'+-- | 'Real' instance for t'IntN' instance (KnownNat n, BVIsNonZero n) => Real (IntN n) where toRational (IntN x) = toRational x --- | 'Integral' instance for 'WordN'+-- | 'Integral' instance for t'WordN' instance (KnownNat n, BVIsNonZero n) => Integral (WordN n) where toInteger (WordN x) = x quotRem (WordN x) (WordN y) = let (q, r) = quotRem x y in (WordN q, WordN r) --- | 'Integral' instance for 'IntN'+-- | 'Integral' instance for t'IntN' instance (KnownNat n, BVIsNonZero n) => Integral (IntN n) where toInteger (IntN x) = x quotRem (IntN x) (IntN y) = let (q, r) = quotRem x y in (IntN q, IntN r) --- 'Bits' instance for 'WordN'+-- 'Bits' instance for t'WordN' instance (KnownNat n, BVIsNonZero n) => Bits (WordN n) where (.&.) = lift2 "(.&.)" svAnd (.|.) = lift2 "(.|.)" svOr@@ -190,7 +198,7 @@ bit i = 1 `shiftL` i popCount = fromIntegral . popCount . toInteger --- 'Bits' instance for 'IntN'+-- 'Bits' instance for t'IntN' instance (KnownNat n, BVIsNonZero n) => Bits (IntN n) where (.&.) = lift2 "(.&.)" svAnd (.|.) = lift2 "(.|.)" svOr@@ -207,157 +215,21 @@ bit i = 1 `shiftL` i popCount = fromIntegral . popCount . toInteger --- | 'SIntegral' instance for 'WordN'-instance (KnownNat n, BVIsNonZero n) => SIntegral (WordN n)---- | 'SIntegral' instance for 'IntN'-instance (KnownNat n, BVIsNonZero n) => SIntegral (IntN n)---- | 'SDivisible' instance for 'WordN'-instance (KnownNat n, BVIsNonZero n) => SDivisible (WordN n) where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y---- | 'SDivisible' instance for 'IntN'-instance (KnownNat n, BVIsNonZero n) => SDivisible (IntN n) where- sQuotRem x 0 = (0, x)- sQuotRem x y = x `quotRem` y- sDivMod x 0 = (0, x)- sDivMod x y = x `divMod` y---- | 'SDivisible' instance for 'SWord'-instance (KnownNat n, BVIsNonZero n) => SDivisible (SWord n) where- sQuotRem = liftQRem- sDivMod = liftDMod---- | 'SDivisible' instance for 'SInt'-instance (KnownNat n, BVIsNonZero n) => SDivisible (SInt n) where- sQuotRem = liftQRem- sDivMod = liftDMod---- | 'SFiniteBits' instance for 'WordN'-instance (KnownNat n, BVIsNonZero n) => SFiniteBits (WordN n) where- sFiniteBitSize _ = intOfProxy (Proxy @n)---- | 'SFiniteBits' instance for 'IntN'-instance (KnownNat n, BVIsNonZero n) => SFiniteBits (IntN n) where- sFiniteBitSize _ = intOfProxy (Proxy @n)---- | Constructing models for 'WordN'-instance (KnownNat n, BVIsNonZero n) => SatModel (WordN n) where- parseCVs = genParse (kindOf (undefined :: WordN n))---- | Constructing models for 'IntN'-instance (KnownNat n, BVIsNonZero n) => SatModel (IntN n) where- parseCVs = genParse (kindOf (undefined :: IntN n))---- | Optimizing 'WordN'-instance (KnownNat n, BVIsNonZero n) => Metric (WordN n)---- | Optimizing 'IntN'-instance (KnownNat n, BVIsNonZero n) => Metric (IntN n) where- type MetricSpace (IntN n) = WordN n- toMetricSpace x = sFromIntegral x + 2 ^ (intOfProxy (Proxy @n) - 1)- fromMetricSpace x = sFromIntegral x - 2 ^ (intOfProxy (Proxy @n) - 1)---- | Generalization of 'Data.SBV.sWord'-sWord :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => String -> m (SWord n)-sWord = symbolic---- | Generalization of 'Data.SBV.sWord_'-sWord_ :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => m (SWord n)-sWord_ = free_---- | Generalization of 'Data.SBV.sWord64s'-sWords :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => [String] -> m [SWord n]-sWords = symbolics---- | Generalization of 'Data.SBV.sInt'-sInt :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => String -> m (SInt n)-sInt = symbolic---- | Generalization of 'Data.SBV.sInt_'-sInt_ :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => m (SInt n)-sInt_ = free_---- | Generalization of 'Data.SBV.sInts'-sInts :: (KnownNat n, BVIsNonZero n) => MonadSymbolic m => [String] -> m [SInt n]-sInts = symbolics---- | 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)- , KnownNat i- , KnownNat j- , i + 1 <= n- , j <= i- , BVIsNonZero (i - j + 1)- ) => proxy i -- ^ @i@: Start position, numbered from @n-1@ to @0@- -> proxy j -- ^ @j@: End position, numbered from @n-1@ to @0@, @j <= i@ must hold- -> SBV (bv n) -- ^ Input bit vector of size @n@- -> SBV (bv (i - j + 1)) -- ^ Output is of size @i - j + 1@-bvExtract start end = SBV . svExtract i j . unSBV- where i = fromIntegral (natVal start)- j = fromIntegral (natVal end)---- | Join two bitvectors.-(#) :: ( KnownNat n, BVIsNonZero n, SymVal (bv n)- , KnownNat m, BVIsNonZero m, SymVal (bv m)- ) => SBV (bv n) -- ^ First input, of size @n@, becomes the left side- -> SBV (bv m) -- ^ Second input, of size @m@, becomes the right side- -> SBV (bv (n + m)) -- ^ Concatenation, of size @n+m@-n # m = SBV $ svJoin (unSBV n) (unSBV m)-infixr 5 #---- | Zero extend a bit-vector.-zeroExtend :: forall n m bv. ( KnownNat n, BVIsNonZero n, SymVal (bv n)- , KnownNat m, BVIsNonZero m, SymVal (bv m)- , n + 1 <= m- , SIntegral (bv (m - n))- , BVIsNonZero (m - n)- ) => SBV (bv n) -- ^ Input, of size @n@- -> SBV (bv m) -- ^ Output, of size @m@. @n < m@ must hold-zeroExtend n = SBV $ svZeroExtend i (unSBV n)- where nv = intOfProxy (Proxy @n)- mv = intOfProxy (Proxy @m)- i = fromIntegral (mv - nv)+-- | Quickcheck instance for WordN+instance KnownNat n => Arbitrary (WordN n) where+ arbitrary = WordN . norm . abs <$> arbitrary+ where sz = intOfProxy (Proxy @n) --- | Sign extend a bit-vector.-signExtend :: forall n m bv. ( KnownNat n, BVIsNonZero n, SymVal (bv n)- , KnownNat m, BVIsNonZero m, SymVal (bv m)- , n + 1 <= m- , SFiniteBits (bv n)- , SIntegral (bv (m - n))- , BVIsNonZero (m - n)- ) => SBV (bv n) -- ^ Input, of size @n@- -> SBV (bv m) -- ^ Output, of size @m@. @n < m@ must hold-signExtend n = SBV $ svSignExtend i (unSBV n)- where nv = intOfProxy (Proxy @n)- mv = intOfProxy (Proxy @m)- i = fromIntegral (mv - nv)+ norm v | sz == 0 = 0+ | True = v .&. (((1 :: Integer) `shiftL` sz) - 1) --- | Drop bits from the top of a bit-vector.-bvDrop :: forall i n m bv proxy. ( KnownNat n, BVIsNonZero n- , KnownNat i- , i + 1 <= n- , i + m - n <= 0- , BVIsNonZero (n - i)- ) => proxy i -- ^ @i@: Number of bits to drop. @i < n@ must hold.- -> SBV (bv n) -- ^ Input, of size @n@- -> SBV (bv m) -- ^ Output, of size @m@. @m = n - i@ holds.-bvDrop i = SBV . svExtract start 0 . unSBV- where nv = intOfProxy (Proxy @n)- start = nv - fromIntegral (natVal i) - 1+-- | Quickcheck instance for IntN+instance KnownNat n => Arbitrary (IntN n) where+ arbitrary = IntN . norm <$> arbitrary+ where sz = intOfProxy (Proxy @n) --- | Take bits from the top of a bit-vector.-bvTake :: forall i n bv proxy. ( KnownNat n, BVIsNonZero n- , KnownNat i, BVIsNonZero i- , i <= n- ) => proxy i -- ^ @i@: Number of bits to take. @0 < i <= n@ must hold.- -> SBV (bv n) -- ^ Input, of size @n@- -> SBV (bv i) -- ^ Output, of size @i@-bvTake i = SBV . svExtract start end . unSBV- where nv = intOfProxy (Proxy @n)- start = nv - 1- end = start - fromIntegral (natVal i) + 1+ norm v | sz == 0 = 0+ | True = let rg = 2 ^ (sz - 1)+ in case divMod v rg of+ (a, b) | even a -> b+ (_, b) -> b - rg
Data/SBV/Core/SizedFloats.hs view
@@ -10,51 +10,93 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.SizedFloats ( -- * Type-sized floats FloatingPoint(..), FP(..), FPHalf, FPBFloat, FPSingle, FPDouble, FPQuad -- * Constructing values- , fpFromRawRep, fpFromBigFloat, fpNaN, fpInf, fpZero+ , fpFromRawRep, fpFromBigFloat, fpFromBits, fpNaN, fpInf, fpZero -- * Operations- , fpFromInteger, fpFromRational, fpFromFloat, fpFromDouble, fpEncodeFloat+ , fpFromInteger, fpFromRational, fpFromFloat, fpFromDouble+ , fpToFloat, fpToDouble+ , fpEncodeFloat+ , fpIsFinite, fpIsInf, fpIsZero, fpIsNaN+ , fpIsNormal, fpIsSubnormal, fpIsNeg, fpIsPos+ , fpNeg, fpAbs, fpSignum+ , fpAdd, fpSub, fpMul, fpDiv, fpPow, fpRem, fpSqrt, fpFMA+ , fpRoundFloat, fpRoundInt+ , fpMax, fpMin -- * Internal operations- , fprCompareObject, fprToSMTLib2, mkBFOpts, bfToString, bfRemoveRedundantExp+ , arbFPIsEqualObjectH, arbFPCompareObjectH, fprToSMTLib2, mkBFOpts, bfToString, bfRemoveRedundantExp+ , roundingModeToRoundMode ) where import Data.Char (intToDigit) 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 Data.SBV.Utils.Numeric (RoundingMode(..), floatToWord, fp2fp) -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@ -- DP is @FloatingPoint 11 53@ -- etc.-newtype FloatingPoint (eb :: Nat) (sb :: Nat) = FloatingPoint FP- deriving (Eq, Ord)+-- NB. Don't derive Ord for this type automatically, see notes below.+newtype FloatingPoint (eb :: Nat) (sb :: Nat) = FloatingPoint FP deriving Eq +-- NB. Refrain from letting GHC derive @>@ and @>=@ and define+-- it ourselves. Why? Because the default definition of @x > y@+-- is @not (x <= y)@. But when one of the arguments is NaN, this does+-- the wrong thing, since NaN doesn't compare to other values. (i.e., the+-- comparison should be always False, but the default will give+-- you the wrong result.)+instance Ord (FloatingPoint eb sb) where+ FloatingPoint f0 < FloatingPoint f1 = f0 < f1+ FloatingPoint f0 <= FloatingPoint f1 = f0 <= f1+ 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 @@ -67,7 +109,7 @@ -- | Abbreviation for IEEE double precision float, bit width 64 = 11 + 53. type FPDouble = FloatingPoint 11 53 --- | Abbreviation for IEEE quadruble precision float, bit width 128 = 15 + 113.+-- | Abbreviation for IEEE quadruple precision float, bit width 128 = 15 + 113. type FPQuad = FloatingPoint 15 113 -- | Show instance for Floats. By default we print in base 10, with standard scientific notation.@@ -80,12 +122,42 @@ -- then the total number of floats is 2^sb*(2^eb-1) + 3: All exponents except 11..11 -- is allowed. So we get, 2^eb-1, different combinations, each with a sign, giving -- us 2^sb*(2^eb-1) totals. Then we have two infinities, and one NaN, adding 3 more.-data FP = FP { fpExponentSize :: Int- , fpSignificandSize :: Int+data FP = FP { fpExponentSize :: !Int+ , fpSignificandSize :: !Int , fpValue :: BigFloat }- deriving (Ord, Eq)+ deriving (Eq, G.Data) +-- Not full, but good enough+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 compliant results.+--+-- NB. Refrain from letting GHC derive @>@ and @>=@ and define+-- it ourselves. Why? Because the default definition of @x > y@+-- is @not (x <= y)@. But when one of the arguments is NaN, this does+-- the wrong thing, since NaN doesn't compare to other values. (i.e., the+-- comparison should be always False, but the default will give+-- you the wrong result.)+instance Ord FP where+ FP eb0 sb0 v0 < FP eb1 sb1 v1 | (eb0, sb0) /= (eb1, sb1) = error $ "FP.<: comparing FPs with different precision: " <> show (eb0, sb0) <> show (eb1, sb1)+ | True = v0 < v1+ FP eb0 sb0 v0 <= FP eb1 sb1 v1 | (eb0, sb0) /= (eb1, sb1) = error $ "FP.<=: comparing FPs with different precision: " <> show (eb0, sb0) <> show (eb1, sb1)+ | True = v0 <= v1+ f0 > f1 = f1 < f0 -- See note above+ f0 >= f1 = f1 <= f0 -- See note above+ instance Show FP where show = bfRemoveRedundantExp . bfToString 10 False False @@ -109,14 +181,22 @@ | BF.bfIsNaN a = "NaN" | BF.bfIsInf a = if BF.bfIsPos a then "Infinity" else "-Infinity" | BF.bfIsZero a = if BF.bfIsPos a then "0.0" else "-0.0"- | True = trimZeros $ BF.bfToString b opts' a- where opts = BF.showRnd BF.NearEven <> BF.showFree (Just (fromIntegral sb))- opts' = case (withPrefix, forceExponent) of- (False, False) -> opts- (False, True ) -> BF.forceExp <> opts- (True, False) -> BF.addPrefix <> opts- (True, True ) -> BF.addPrefix <> BF.forceExp <> opts+ | True+ = trimZeros $ BF.bfToString b opts' a+ where opts = BF.showRnd BF.NearEven <> BF.showFree (Just (fromIntegral prec)) + -- For base 10, use a larger precision. It's really difficult to "pick"+ -- the correct value here; but 2*sb seems to work ok. Note that even picking+ -- sb is fine: The output isn't incorrect. It's just confusing.+ prec | b == 10 = 2*sb+ | True = sb++ opts'+ | withPrefix && forceExponent = BF.addPrefix <> BF.forceExp <> opts+ | withPrefix = BF.addPrefix <> opts+ | forceExponent = BF.forceExp <> opts+ | True = opts+ -- In base 10, exponent starts with 'e'. Otherwise (2, 8, 16) it starts with 'p' expChar = if b == 10 then 'e' else 'p' @@ -136,11 +216,15 @@ fpFromBigFloat :: Int -> Int -> BigFloat -> FP fpFromBigFloat eb sb r = FP eb sb $ fst $ BF.bfRoundFloat (mkBFOpts eb sb BF.NearEven) r +-- | Convert an integer to a big-float, preserving the bit-correspondence.+fpFromBits :: Int -> Int -> Integer -> FP+fpFromBits eb sb val = FP eb sb $ BF.bfFromBits (mkBFOpts eb sb BF.NearEven) val+ -- | Convert from an sign/exponent/mantissa representation to a float. The values are the integers -- representing the bit-patterns of these values, i.e., the raw representation. We assume that these -- integers fit into the ranges given, i.e., no overflow checking is done here. fpFromRawRep :: Bool -> (Integer, Int) -> (Integer, Int) -> FP-fpFromRawRep sign (e, eb) (s, sb) = FP eb sb $ BF.bfFromBits (mkBFOpts eb sb BF.NearEven) val+fpFromRawRep sign (e, eb) (s, sb) = fpFromBits eb sb val where es, val :: Integer es = (e `shiftL` (sb - 1)) .|. s val | sign = (1 `shiftL` (eb + sb - 1)) .|. es@@ -192,14 +276,27 @@ mkB sz val = "#b" ++ pad sz (showIntAtBase 2 intToDigit val "") pad l str = replicate (l - length str) '0' ++ str --- | Structural comparison only, for internal map indexes-fprCompareObject :: FP -> FP -> Ordering-fprCompareObject (FP eb sb a) (FP eb' sb' b) = case (eb, sb) `compare` (eb', sb') of- LT -> LT- GT -> GT- EQ -> a `BF.bfCompare` b-+-- | Check that two arbitrary floats are the exact same values, i.e., +0/-0 does not+-- compare equal, and NaN's compare equal to themselves+arbFPIsEqualObjectH :: FP -> FP -> Bool+arbFPIsEqualObjectH (FP eb sb a) (FP eb' sb' b) = case (eb, sb) `compare` (eb', sb') of+ LT -> False+ GT -> False+ EQ | BF.bfIsNaN a -> BF.bfIsNaN b+ | BF.bfIsZero a && BF.bfIsNeg a -> BF.bfIsZero b && BF.bfIsNeg b+ | BF.bfIsZero a && BF.bfIsPos a -> BF.bfIsZero b && BF.bfIsPos b+ | True -> a == b +-- | Ordering for arbitrary floats, avoiding the +0/-0/NaN issues. Note that this is+-- essentially used for indexing into a map, so we need to be total.+--+-- This function uses the bfCompare function provided by the libBF. As per the libBF's documentation,+-- it has the semantics: -0 < 0, NaN == NaN, and NaN is larger than all other numbers.+arbFPCompareObjectH :: FP -> FP -> Ordering+arbFPCompareObjectH (FP eb sb a) (FP eb' sb' b) = case (eb, sb) `compare` (eb', sb') of+ LT -> LT+ GT -> GT+ EQ -> BF.bfCompare a b -- | Compute the signum of a big float bfSignum :: BigFloat -> BigFloat bfSignum r | BF.bfIsNaN r = r@@ -209,23 +306,23 @@ -- | Num instance for big-floats instance Num FP where- (+) = lift2 BF.bfAdd- (-) = lift2 BF.bfSub- (*) = lift2 BF.bfMul- abs = lift1 BF.bfAbs- signum = lift1 bfSignum- fromInteger = error "FP.fromInteger: Not supported for arbitrary floats. Use fpFromInteger instead, specifying the precision"- negate = lift1 BF.bfNeg+ (+) = fpAdd RoundNearestTiesToEven+ (-) = fpSub RoundNearestTiesToEven+ (*) = fpMul RoundNearestTiesToEven+ abs = fpAbs+ signum = fpSignum+ fromInteger i = error $ "FP.fromInteger: Not supported for arbitrary floats. Use fpFromInteger instead, specifying the precision. Called on: " ++ show i+ negate = fpNeg -- | Fractional instance for big-floats instance Fractional FP where fromRational = error "FP.fromRational: Not supported for arbitrary floats. Use fpFromRational instead, specifying the precision"- (/) = lift2 BF.bfDiv+ (/) = fpDiv RoundNearestTiesToEven -- | Floating instance for big-floats instance Floating FP where- sqrt (FP eb sb a) = FP eb sb $ fst $ BF.bfSqrt (mkBFOpts eb sb BF.NearEven) a- FP eb sb a ** FP _ _ b = FP eb sb $ fst $ BF.bfPow (mkBFOpts eb sb BF.NearEven) a b+ sqrt = fpSqrt RoundNearestTiesToEven+ (**) = fpPow RoundNearestTiesToEven pi = unsupported "Floating.FP.pi" exp = unsupported "Floating.FP.exp"@@ -251,11 +348,11 @@ where v :: Integer v = 2 ^ ((fromIntegral eb :: Integer) - 1) - isNaN (FP _ _ r) = BF.bfIsNaN r- isInfinite (FP _ _ r) = BF.bfIsInf r- isDenormalized (FP eb sb r) = BF.bfIsSubnormal (mkBFOpts eb sb BF.NearEven) r- isNegativeZero (FP _ _ r) = BF.bfIsZero r && BF.bfIsNeg r- isIEEE _ = True+ isNaN = fpIsNaN+ isInfinite = fpIsInf+ isDenormalized = fpIsSubnormal+ isNegativeZero f = fpIsZero f && fpIsNeg f+ isIEEE _ = True decodeFloat i@(FP _ _ r) = case BF.bfToRep r of BF.BFNaN -> decodeFloat (0/0 :: Double)@@ -276,6 +373,123 @@ where n' :: Integer n' = (2 :: Integer) ^ abs (fromIntegral n :: Integer) +-- | Is a big-float finite?+fpIsFinite :: FP -> Bool+fpIsFinite (FP _ _ r) = BF.bfIsFinite r++-- | Is a big-float infinite?+fpIsInf :: FP -> Bool+fpIsInf (FP _ _ r) = BF.bfIsInf r++-- | Is a big-float a zero value?+fpIsZero :: FP -> Bool+fpIsZero (FP _ _ r) = BF.bfIsZero r++-- | Is a big-float a NaN value?+fpIsNaN :: FP -> Bool+fpIsNaN (FP _ _ r) = BF.bfIsNaN r++-- | Is a big-float \"normal\"? That is, is the value not zero, infinite, NaN,+-- or subnormal?+fpIsNormal :: FP -> Bool+fpIsNormal (FP eb sb r) = BF.bfIsNormal (mkBFOpts eb sb BF.NearEven) r++-- | Is a big-float subnormal (i.e., denormalized)?+fpIsSubnormal :: FP -> Bool+fpIsSubnormal (FP eb sb r) = BF.bfIsSubnormal (mkBFOpts eb sb BF.NearEven) r++-- | Is a big-float negative?+fpIsNeg :: FP -> Bool+fpIsNeg (FP _ _ r) = BF.bfIsNeg r++-- | Is a big-float positive?+fpIsPos :: FP -> Bool+fpIsPos (FP _ _ r) = BF.bfIsPos r++-- | Big-float negation.+fpNeg :: FP -> FP+fpNeg = lift1 BF.bfNeg++-- | Big-float absolute value.+fpAbs :: FP -> FP+fpAbs = lift1 BF.bfAbs++-- | Big-float signum.+fpSignum :: FP -> FP+fpSignum = lift1 bfSignum++-- | Big-float addition.+fpAdd :: RoundingMode -> FP -> FP -> FP+fpAdd = liftRM2 BF.bfAdd++-- | Big-float subtraction.+fpSub :: RoundingMode -> FP -> FP -> FP+fpSub = liftRM2 BF.bfSub++-- | Big-float multiplication.+fpMul :: RoundingMode -> FP -> FP -> FP+fpMul = liftRM2 BF.bfMul++-- | Big-float division.+fpDiv :: RoundingMode -> FP -> FP -> FP+fpDiv = liftRM2 BF.bfDiv++-- | Big-float exponentiation.+fpPow :: RoundingMode -> FP -> FP -> FP+fpPow = liftRM2 BF.bfPow++-- | Big-float remainder.+fpRem :: RoundingMode -> FP -> FP -> FP+fpRem = liftRM2 BF.bfRem++-- | Big-float square root.+fpSqrt :: RoundingMode -> FP -> FP+fpSqrt = liftRM1 BF.bfSqrt++-- | Big-float fused-multiply-add (FMA).+fpFMA :: RoundingMode -> FP -> FP -> FP -> FP+fpFMA = liftRM3 BF.bfFMA++-- | Round a big-float to a float of the given exponent and significand sizes+-- using the given rounding mode.+fpRoundFloat :: Int -> Int -> RoundingMode -> FP -> FP+fpRoundFloat eb sb rm (FP _ _ r) = FP eb sb $ fst $ BF.bfRoundFloat (mkBFOpts eb sb (roundingModeToRoundMode rm)) r++-- | Round a big-float to the nearest integer (represented as a big-float with+-- a zero decimal component) using the given rounding mode.+fpRoundInt :: RoundingMode -> FP -> FP+fpRoundInt rm (FP eb sa a) = FP eb sa $ fst $ BF.bfRoundInt (roundingModeToRoundMode rm) a++-- | SMTLib compliant definition for 'Data.SBV.fpMax'. This is very nearly+-- identical to 'Data.SBV.Utils.Numeric.fpMaxH', except that this uses+-- 'fpIsZero' instead of checking for equality against a @0@ literal. (The+-- latter is not supported for t'FP' values as t'FP' does not implement+-- 'fromInteger'.)+fpMax :: FP -> FP -> FP+fpMax x y+ | isNaN x = y+ | isNaN y = x+ | (isN0 x && isP0 y) || (isN0 y && isP0 x) = error "fpMax: Called with alternating-sign 0's. Not supported"+ | x > y = x+ | True = y+ where isN0 = isNegativeZero+ isP0 a = fpIsZero a && not (isN0 a)++-- | SMTLib compliant definition for 'Data.SBV.fpMin'. This is very nearly+-- identical to 'Data.SBV.Utils.Numeric.fpMinH', except that this uses+-- 'fpIsZero' instead of checking for equality against a @0@ literal. (The+-- latter is not supported for t'FP' values as t'FP' does not implement+-- 'fromInteger'.)+fpMin :: FP -> FP -> FP+fpMin x y+ | isNaN x = y+ | isNaN y = x+ | (isN0 x && isP0 y) || (isN0 y && isP0 x) = error "fpMin: Called with alternating-sign 0's. Not supported"+ | x < y = x+ | True = y+ where isN0 = isNegativeZero+ isP0 a = fpIsZero a && not (isN0 a)+ -- | Real instance for big-floats. Beware, not that well tested! instance Real FP where toRational i@@ -285,10 +499,9 @@ -- | Real-frac instance for big-floats. Beware, not that well tested! instance RealFrac FP where- properFraction (FP eb sb r) = case BF.bfRoundInt BF.ToNegInf r of- (r', BF.Ok) | BF.bfSign r == BF.bfSign r' -> (getInt r', FP eb sb r - FP eb sb r')- x -> error $ "RealFrac.FP.properFraction: Failed to convert: " ++ show (r, x)- where getInt x = case BF.bfToRep x of+ properFraction (FP eb sb r) = (getInt r', FP eb sb r - FP eb sb r')+ where (r', _) = BF.bfRoundInt BF.ToZero r+ getInt x = case BF.bfToRep x of BF.BFNaN -> error $ "Data.SBV.FloatingPoint.properFraction: Failed to convert: " ++ show (r, x) BF.BFRep s n -> case n of BF.Zero -> 0@@ -301,6 +514,26 @@ 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 FloatingPoint a + FloatingPoint b = FloatingPoint $ a + b@@ -347,18 +580,42 @@ lift1 :: (BigFloat -> BigFloat) -> FP -> FP lift1 f (FP eb sb a) = fpFromBigFloat eb sb $ f a --- Lift a binary operation. Here we don't call fpFromBigFloat, because the result is correctly rounded.-lift2 :: (BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)) -> FP -> FP -> FP-lift2 f (FP eb sb a) (FP _ _ b) = FP eb sb $ fst $ f (mkBFOpts eb sb BF.NearEven) a b+-- | Lift a unary operation that returns a big-float and a status.+liftRM1 :: (BFOpts -> BigFloat -> (BigFloat, Status)) -> RoundingMode -> FP -> FP+liftRM1 f rm (FP eb sb a) = FP eb sb $ fst $ f (mkBFOpts eb sb (roundingModeToRoundMode rm)) a +-- | Lift a binary operation that returns a big-float and a status.+liftRM2 :: (BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)) -> RoundingMode -> FP -> FP -> FP+liftRM2 f rm (FP eb sb a) (FP _ _ b) = FP eb sb $ fst $ f (mkBFOpts eb sb (roundingModeToRoundMode rm)) a b++-- | Lift a trinary operation that returns a big-float and a status.+liftRM3 :: (BFOpts -> BigFloat -> BigFloat -> BigFloat -> (BigFloat, Status)) -> RoundingMode -> FP -> FP -> FP -> FP+liftRM3 f rm (FP eb sb a) (FP _ _ b) (FP _ _ c) = FP eb sb $ fst $ f (mkBFOpts eb sb (roundingModeToRoundMode rm)) a b c+ -- | Convert from a IEEE float. fpFromFloat :: Int -> Int -> Float -> FP fpFromFloat 8 24 f = let fw = floatToWord f (sgn, e, s) = (fw `testBit` 31, fromIntegral (fw `shiftR` 23) .&. 0xFF, fromIntegral fw .&. 0x7FFFFF) in fpFromRawRep sgn (e, 8) (s, 24)-fpFromFloat eb sb f = error $ "SBV.fprFromFloat: Unexpected input: " ++ show (eb, sb, f)+fpFromFloat eb sb f = error $ "SBV.fpFromFloat: Unexpected input: " ++ show (eb, sb, f) -- | Convert from a IEEE double. fpFromDouble :: Int -> Int -> Double -> FP fpFromDouble 11 53 d = FP 11 54 $ BF.bfFromDouble d-fpFromDouble eb sb d = error $ "SBV.fprFromDouble: Unexpected input: " ++ show (eb, sb, d)+fpFromDouble eb sb d = error $ "SBV.fpFromDouble: Unexpected input: " ++ show (eb, sb, d)++-- | Convert to a IEEE float using the given rounding mode.+fpToFloat :: RoundingMode -> FP -> Float+fpToFloat rm (FP _ _ r) = fp2fp $ fst $ BF.bfToDouble (roundingModeToRoundMode rm) r++-- | Convert to a IEEE double using the given rounding mode.+fpToDouble :: RoundingMode -> FP -> Double+fpToDouble rm (FP _ _ r) = fst $ BF.bfToDouble (roundingModeToRoundMode rm) r++-- | Map SBV's rounding modes to LibBF's.+roundingModeToRoundMode :: RoundingMode -> RoundMode+roundingModeToRoundMode RoundNearestTiesToEven = BF.NearEven+roundingModeToRoundMode RoundNearestTiesToAway = BF.NearAway+roundingModeToRoundMode RoundTowardPositive = BF.ToPosInf+roundingModeToRoundMode RoundTowardNegative = BF.ToNegInf+roundingModeToRoundMode RoundTowardZero = BF.ToZero
Data/SBV/Core/Symbolic.hs view
@@ -10,2115 +10,2329 @@ ----------------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} -- for undetermined s in MonadState-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}--module Data.SBV.Core.Symbolic- ( NodeId(..)- , SV(..), swKind, trueSV, falseSV- , Op(..), PBOp(..), OvOp(..), FPOp(..), NROp(..), StrOp(..), RegExOp(..), SeqOp(..), SetOp(..)- , RegExp(..), regExpToSMTString- , Quantifier(..), needsExistentials, VarContext(..)- , RoundingMode(..)- , SBVType(..), svUninterpreted, newUninterpreted- , SVal(..)- , svMkSymVar, sWordN, sWordN_, sIntN, sIntN_- , ArrayContext(..), ArrayInfo- , svToSV, svToSymSV, forceSVArg- , SBVExpr(..), newExpr, isCodeGenMode, isSafetyCheckingIStage, isRunIStage, isSetupIStage- , Cached, cache, uncache, modifyState, modifyIncState- , ArrayIndex(..), uncacheAI- , NamedSymVar(..), Name, UserInputs, Inputs(..), getSV, swNodeId, namedNodeId, getUniversals- , prefixExistentials, prefixUniversals, onUserInputs, onInternInputs, onAllInputs- , addInternInput, addUserInput, getInputs, inputsFromListWith, userInputsToList- , getUserName', internInputsToList, inputsToList, quantifier, namedSymVar, getUserName- , lookupInput , getSValPathCondition, extendSValPathCondition- , getTableIndex- , SBVPgm(..), MonadSymbolic(..), SymbolicT, Symbolic, runSymbolic, State(..), withNewIncState, IncState(..), incrementInternalCounter- , inSMTMode, SBVRunMode(..), IStage(..), Result(..)- , registerKind, registerLabel, recordObservable- , addAssertion, addNewSMTOption, imposeConstraint, internalConstraint, internalVariable- , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension- , SolverCapabilities(..)- , extractSymbolicSimulationState, CnstMap- , OptimizeStyle(..), Objective(..), Penalty(..), objectiveName, addSValOptGoal- , MonadQuery(..), QueryT(..), Query, Queriable(..), Fresh(..), QueryState(..), QueryContext(..)- , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), SMTEngine- , validationRequested, outputSVal- ) where--import Control.Arrow ((***))-import Control.DeepSeq (NFData(..))-import Control.Monad (when)-import Control.Monad.Except (MonadError, ExceptT)-import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT,- mapReaderT)-import Control.Monad.State.Lazy (MonadState)-import Control.Monad.Trans (MonadIO(liftIO), MonadTrans(lift))-import Control.Monad.Trans.Maybe (MaybeT)-import Control.Monad.Writer.Strict (MonadWriter)-import Data.Char (isAlpha, isAlphaNum, toLower)-import Data.IORef (IORef, newIORef, readIORef)-import Data.List (intercalate, sortBy)-import Data.Maybe (isJust, fromJust, fromMaybe)-import Data.String (IsString(fromString))--import Data.Time (getCurrentTime, UTCTime)--import GHC.Stack-import GHC.Generics (Generic)--import qualified Control.Monad.State.Lazy as LS-import qualified Control.Monad.State.Strict as SS-import qualified Control.Monad.Writer.Lazy as LW-import qualified Control.Monad.Writer.Strict as SW-import qualified Data.IORef as R (modifyIORef')-import qualified Data.Generics as G (Data(..))-import qualified Data.IntMap.Strict as IMap (IntMap, empty, toAscList, lookup, insertWith)-import qualified Data.Map.Strict as Map (Map, empty, toList, lookup, insert, size)-import qualified Data.Set as Set (Set, empty, toList, insert, member)-import qualified Data.Foldable as F (toList)-import qualified Data.Sequence as S (Seq, empty, (|>), (<|), filter, takeWhileL, fromList, lookup, elemIndexL)-import qualified Data.Text as T--import System.Mem.StableName--import Data.SBV.Core.Kind-import Data.SBV.Core.Concrete-import Data.SBV.SMT.SMTLibNames-import Data.SBV.Utils.TDiff (Timing)-import Data.SBV.Utils.Lib (stringToQFS)--import Data.SBV.Control.Types--#if MIN_VERSION_base(4,11,0)-import Control.Monad.Fail as Fail-#endif---- | A symbolic node id-newtype NodeId = NodeId { getId :: Int }- deriving (Eq, Ord, G.Data)---- | A symbolic word, tracking it's signedness and size.-data SV = SV !Kind !NodeId- deriving G.Data---- | For equality, we merely use the node-id-instance Eq SV where- SV _ n1 == SV _ n2 = n1 == n2---- | Again, simply use the node-id for ordering-instance Ord SV where- SV _ n1 `compare` SV _ n2 = n1 `compare` n2--instance HasKind SV where- kindOf (SV k _) = k--instance Show SV where- show (SV _ (NodeId n)) = case n of- -2 -> "false"- -1 -> "true"- _ -> 's' : show n---- | Kind of a symbolic word.-swKind :: SV -> Kind-swKind (SV k _) = k---- | retrieve the node id of a symbolic word-swNodeId :: SV -> NodeId-swNodeId (SV _ nid) = nid---- | Forcing an argument; this is a necessary evil to make sure all the arguments--- to an uninterpreted function are evaluated before called; the semantics of uinterpreted--- functions is necessarily strict; deviating from Haskell's-forceSVArg :: SV -> IO ()-forceSVArg (SV k n) = k `seq` n `seq` return ()---- | Constant False as an 'SV'. Note that this value always occupies slot -2.-falseSV :: SV-falseSV = SV KBool $ NodeId (-2)---- | Constant True as an 'SV'. Note that this value always occupies slot -1.-trueSV :: SV-trueSV = SV KBool $ NodeId (-1)---- | Symbolic operations-data Op = Plus- | Times- | Minus- | UNeg- | Abs- | Quot- | Rem- | Equal- | NotEqual- | LessThan- | GreaterThan- | LessEq- | GreaterEq- | Ite- | And- | Or- | XOr- | Not- | Shl- | Shr- | Rol Int- | Ror Int- | Extract Int Int -- Extract i j: extract bits i to j. Least significant bit is 0 (big-endian)- | Join -- Concat two words to form a bigger one, in the order given- | ZeroExtend Int- | SignExtend Int- | LkUp (Int, Kind, Kind, Int) !SV !SV -- (table-index, arg-type, res-type, length of the table) index out-of-bounds-value- | ArrEq ArrayIndex ArrayIndex -- Array equality- | ArrRead ArrayIndex- | KindCast Kind Kind- | Uninterpreted String- | Label String -- Essentially no-op; useful for code generation to emit comments.- | IEEEFP FPOp -- Floating-point ops, categorized separately- | NonLinear NROp -- Non-linear ops (mostly trigonometric), categorized separately- | OverflowOp OvOp -- Overflow-ops, categorized separately- | PseudoBoolean PBOp -- Pseudo-boolean ops, categorized separately- | StrOp StrOp -- String ops, categorized separately- | RegExOp RegExOp -- RegEx operations, categorized separately- | SeqOp SeqOp -- Sequence ops, categorized separately- | SetOp SetOp -- Set operations, categorized separately- | TupleConstructor Int -- Construct an n-tuple- | TupleAccess Int Int -- Access element i of an n-tuple; second argument is n- | EitherConstructor Kind Kind Bool -- Construct a sum; False: left, True: right- | EitherIs Kind Kind Bool -- Either branch tester; False: left, True: right- | EitherAccess Bool -- Either branch access; False: left, True: right- | RationalConstructor -- Construct a rational. Note that there's no access to numerator or denumerator, since we cannot store rationals in canonical form- | MaybeConstructor Kind Bool -- Construct a maybe value; False: Nothing, True: Just- | MaybeIs Kind Bool -- Maybe tester; False: nothing, True: just- | MaybeAccess -- Maybe branch access; grab the contents of the just- deriving (Eq, Ord, G.Data)---- | Floating point operations-data FPOp = FP_Cast Kind Kind SV -- From-Kind, To-Kind, RoundingMode. This is "value" conversion- | FP_Reinterpret Kind Kind -- From-Kind, To-Kind. This is bit-reinterpretation using IEEE-754 interchange format- | FP_Abs- | FP_Neg- | FP_Add- | FP_Sub- | FP_Mul- | FP_Div- | FP_FMA- | FP_Sqrt- | FP_Rem- | FP_RoundToIntegral- | FP_Min- | FP_Max- | FP_ObjEqual- | FP_IsNormal- | FP_IsSubnormal- | FP_IsZero- | FP_IsInfinite- | FP_IsNaN- | FP_IsNegative- | FP_IsPositive- deriving (Eq, Ord, G.Data)---- Note that the show instance maps to the SMTLib names. We need to make sure--- this mapping stays correct through SMTLib changes. The only exception--- is FP_Cast; where we handle different source/origins explicitly later on.-instance Show FPOp where- show (FP_Cast f t r) = "(FP_Cast: " ++ show f ++ " -> " ++ show t ++ ", using RM [" ++ show r ++ "])"- show (FP_Reinterpret f t) = case t of- KFloat -> "(_ to_fp 8 24)"- KDouble -> "(_ to_fp 11 53)"- KFP eb sb -> "(_ to_fp " ++ show eb ++ " " ++ show sb ++ ")"- _ -> error $ "SBV.FP_Reinterpret: Unexpected conversion: " ++ show f ++ " to " ++ show t- show FP_Abs = "fp.abs"- show FP_Neg = "fp.neg"- show FP_Add = "fp.add"- show FP_Sub = "fp.sub"- show FP_Mul = "fp.mul"- show FP_Div = "fp.div"- show FP_FMA = "fp.fma"- show FP_Sqrt = "fp.sqrt"- show FP_Rem = "fp.rem"- show FP_RoundToIntegral = "fp.roundToIntegral"- show FP_Min = "fp.min"- show FP_Max = "fp.max"- show FP_ObjEqual = "="- show FP_IsNormal = "fp.isNormal"- show FP_IsSubnormal = "fp.isSubnormal"- show FP_IsZero = "fp.isZero"- show FP_IsInfinite = "fp.isInfinite"- show FP_IsNaN = "fp.isNaN"- show FP_IsNegative = "fp.isNegative"- show FP_IsPositive = "fp.isPositive"---- | Non-linear operations-data NROp = NR_Sin- | NR_Cos- | NR_Tan- | NR_ASin- | NR_ACos- | NR_ATan- | NR_Sqrt- | NR_Sinh- | NR_Cosh- | NR_Tanh- | NR_Exp- | NR_Log- | NR_Pow- deriving (Eq, Ord, G.Data)---- | The show instance carefully arranges for these to be printed as it can be understood by dreal-instance Show NROp where- show NR_Sin = "sin"- show NR_Cos = "cos"- show NR_Tan = "tan"- show NR_ASin = "asin"- show NR_ACos = "acos"- show NR_ATan = "atan"- show NR_Sinh = "sinh"- show NR_Cosh = "cosh"- show NR_Tanh = "tanh"- show NR_Sqrt = "sqrt"- show NR_Exp = "exp"- show NR_Log = "log"- show NR_Pow = "pow"---- | Pseudo-boolean operations-data PBOp = PB_AtMost Int -- ^ At most k- | PB_AtLeast Int -- ^ At least k- | PB_Exactly Int -- ^ Exactly k- | PB_Le [Int] Int -- ^ At most k, with coefficients given. Generalizes PB_AtMost- | PB_Ge [Int] Int -- ^ At least k, with coefficients given. Generalizes PB_AtLeast- | PB_Eq [Int] Int -- ^ Exactly k, with coefficients given. Generalized PB_Exactly- deriving (Eq, Ord, Show, G.Data)---- | Overflow operations-data OvOp = Overflow_SMul_OVFL -- ^ Signed multiplication overflow- | Overflow_SMul_UDFL -- ^ Signed multiplication underflow- | Overflow_UMul_OVFL -- ^ Unsigned multiplication overflow- deriving (Eq, Ord, G.Data)---- | Show instance. It's important that these follow the internal z3 names-instance Show OvOp where- show Overflow_SMul_OVFL = "bvsmul_noovfl"- show Overflow_SMul_UDFL = "bvsmul_noudfl"- show Overflow_UMul_OVFL = "bvumul_noovfl"---- | 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)- | StrNatToStr -- ^ Retrieve string encoded by integer @i@ (ground rewriting only)- | StrToCode -- ^ Equivalent to Haskell's ord- | StrFromCode -- ^ Equivalent to Haskell's chr- | StrInRe RegExp -- ^ Check if string is in the regular expression- deriving (Eq, Ord, G.Data)---- | Regular-expression operators. The only thing we can do is to compare for equality/disequality.-data RegExOp = RegExEq RegExp RegExp- | RegExNEq RegExp RegExp- deriving (Eq, Ord, G.Data)---- | Regular expressions. Note that regular expressions themselves are--- concrete, but the 'Data.SBV.RegExp.match' function from the 'Data.SBV.RegExp.RegExpMatchable' class--- can check membership against a symbolic string/character. Also, we--- are preferring a datatype approach here, as opposed to coming up with--- some string-representation; there are way too many alternatives--- already so inventing one isn't a priority. Please get in touch if you--- would like a parser for this type as it might be easier to use.-data RegExp = Literal String -- ^ Precisely match the given string- | All -- ^ Accept every string- | AllChar -- ^ Accept every single character- | None -- ^ Accept no strings- | Range Char Char -- ^ Accept range of characters- | Conc [RegExp] -- ^ Concatenation- | KStar RegExp -- ^ Kleene Star: Zero or more- | KPlus RegExp -- ^ Kleene Plus: One or more- | Opt RegExp -- ^ Zero or one- | Comp RegExp -- ^ Complement of regular expression- | Diff RegExp RegExp -- ^ Difference of regular expressions- | Loop Int Int RegExp -- ^ From @n@ repetitions to @m@ repetitions- | Power Int RegExp -- ^ Exactly @n@ repetitions, i.e., nth power- | Union [RegExp] -- ^ Union of regular expressions- | Inter RegExp RegExp -- ^ Intersection of regular expressions- deriving (Eq, Ord, G.Data)---- | With overloaded strings, we can have direct literal regular expressions.-instance IsString RegExp where- fromString = Literal---- | Regular expressions as a 'Num' instance. Note that only some operations make sense and--- not in the most obvious way. For instance, we would typically expect @a - b@ to be the--- same as @a + negate b@, but that equality does not hold in general. So, use the @Num@--- instance only as constructing syntax, not doing algebraic manipulations.-instance Num RegExp where- -- flatten the concats to make them simpler- Conc xs * y = Conc (xs ++ [y])- x * Conc ys = Conc (x : ys)- x * y = Conc [x, y]-- -- flatten the unions to make them simpler- Union xs + y = Union (xs ++ [y])- x + Union ys = Union (x : ys)- x + y = Union [x, y]-- x - y = Diff x y-- abs = error "Num.RegExp: no abs method"- signum = error "Num.RegExp: no signum method"-- fromInteger x- | x == 0 = None- | x == 1 = Literal "" -- Unit for concatenation is the empty string- | True = error $ "Num.RegExp: Only 0 and 1 makes sense as a reg-exp, no meaning for: " ++ show x-- negate = Comp---- | Convert a reg-exp to a Haskell-like string-instance Show RegExp where- show = regExpToString show---- | Convert a reg-exp to a SMT-lib acceptable representation-regExpToSMTString :: RegExp -> String-regExpToSMTString = regExpToString (\s -> '"' : stringToQFS s ++ "\"")---- | Convert a RegExp to a string, parameterized by how strings are converted-regExpToString :: (String -> String) -> RegExp -> String-regExpToString fs (Literal s) = "(str.to.re " ++ fs s ++ ")"-regExpToString _ All = "re.all"-regExpToString _ AllChar = "re.allchar"-regExpToString _ None = "re.nostr"-regExpToString fs (Range ch1 ch2) = "(re.range " ++ fs [ch1] ++ " " ++ fs [ch2] ++ ")"-regExpToString _ (Conc []) = show (1 :: Integer)-regExpToString fs (Conc [x]) = regExpToString fs x-regExpToString fs (Conc xs) = "(re.++ " ++ unwords (map (regExpToString fs) xs) ++ ")"-regExpToString fs (KStar r) = "(re.* " ++ regExpToString fs r ++ ")"-regExpToString fs (KPlus r) = "(re.+ " ++ regExpToString fs r ++ ")"-regExpToString fs (Opt r) = "(re.opt " ++ regExpToString fs r ++ ")"-regExpToString fs (Comp r) = "(re.comp " ++ regExpToString fs r ++ ")"-regExpToString fs (Diff r1 r2) = "(re.diff " ++ regExpToString fs r1 ++ " " ++ regExpToString fs r2 ++ ")"-regExpToString fs (Loop lo hi r)- | lo >= 0, hi >= lo = "((_ re.loop " ++ show lo ++ " " ++ show hi ++ ") " ++ regExpToString fs r ++ ")"- | True = error $ "Invalid regular-expression Loop with arguments: " ++ show (lo, hi)-regExpToString fs (Power n r)- | n >= 0 = regExpToString fs (Loop n n r)- | True = error $ "Invalid regular-expression Power with arguments: " ++ show n-regExpToString fs (Inter r1 r2) = "(re.inter " ++ regExpToString fs r1 ++ " " ++ regExpToString fs r2 ++ ")"-regExpToString _ (Union []) = "re.nostr"-regExpToString fs (Union [x]) = regExpToString fs x-regExpToString fs (Union xs) = "(re.union " ++ unwords (map (regExpToString fs) xs) ++ ")"---- | 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"- show StrFromCode = "str.from_code"- -- Note the breakage here with respect to argument order. We fix this explicitly later.- show (StrInRe s) = "str.in.re " ++ regExpToSMTString s---- | Show instance for @RegExOp@.-instance Show RegExOp where- show (RegExEq r1 r2) = "(= " ++ regExpToSMTString r1 ++ " " ++ regExpToSMTString r2 ++ ")"- show (RegExNEq r1 r2) = "(distinct " ++ regExpToSMTString r1 ++ " " ++ regExpToSMTString r2 ++ ")"---- | 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- | SBVReverse Kind -- ^ Reversal of sequences. NB. Also works for strings; hence the name.- deriving (Eq, Ord, G.Data)---- | 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: This isn't part of SMTLib, we explicitly handle it- show (SBVReverse k) = "sbv.reverse[" ++ show k ++ "]"---- | Set operations.-data SetOp = SetEqual- | SetMember- | SetInsert- | SetDelete- | SetIntersect- | SetUnion- | SetSubset- | SetDifference- | SetComplement- | SetHasSize- deriving (Eq, Ord, G.Data)---- The show instance for 'SetOp' is merely for debugging, we map them separately so--- the mapped strings are less important here.-instance Show SetOp where- show SetEqual = "=="- show SetMember = "Set.member"- show SetInsert = "Set.insert"- show SetDelete = "Set.delete"- show SetIntersect = "Set.intersect"- show SetUnion = "Set.union"- show SetSubset = "Set.subset"- show SetDifference = "Set.difference"- show SetComplement = "Set.complement"- show SetHasSize = "Set.setHasSize"---- Show instance for 'Op'. Note that this is largely for debugging purposes, not used--- for being read by any tool.-instance Show Op where- show Shl = "<<"- show Shr = ">>"-- show (Rol i) = "<<<" ++ show i- show (Ror i) = ">>>" ++ show i-- show (Extract i j) = "choose [" ++ show i ++ ":" ++ show j ++ "]"-- show (LkUp (ti, at, rt, l) i e)- = "lookup(" ++ tinfo ++ ", " ++ show i ++ ", " ++ show e ++ ")"- where tinfo = "table" ++ show ti ++ "(" ++ show at ++ " -> " ++ show rt ++ ", " ++ show l ++ ")"-- show (ArrEq i j) = "array_" ++ show i ++ " == array_" ++ show j- show (ArrRead i) = "select array_" ++ show i-- show (KindCast fr to) = "cast_" ++ show fr ++ "_" ++ show to- show (Uninterpreted i) = "[uninterpreted] " ++ i-- show (Label s) = "[label] " ++ s-- show (IEEEFP w) = show w-- show (NonLinear w) = show w-- show (PseudoBoolean p) = show p-- show (OverflowOp o) = show o-- show (StrOp s) = show s- show (RegExOp s) = show s- show (SeqOp s) = show s- show (SetOp s) = show s-- show (TupleConstructor 0) = "mkSBVTuple0"- show (TupleConstructor n) = "mkSBVTuple" ++ show n- show (TupleAccess i n) = "proj_" ++ show i ++ "_SBVTuple" ++ show n-- -- Remember, while we try to maintain SMTLib compabitibility here, these output- -- is merely for debugging purposes. For how we actually render these in SMTLib,- -- look at the file SBV/SMT/SMTLib2.hs for these constructors.- show (EitherConstructor k1 k2 False) = "(_ left_SBVEither " ++ show (KEither k1 k2) ++ ")"- show (EitherConstructor k1 k2 True ) = "(_ right_SBVEither " ++ show (KEither k1 k2) ++ ")"- show (EitherIs k1 k2 False) = "(_ is (left_SBVEither (" ++ show k1 ++ ") " ++ show (KEither k1 k2) ++ "))"- show (EitherIs k1 k2 True ) = "(_ is (right_SBVEither (" ++ show k2 ++ ") " ++ show (KEither k1 k2) ++ "))"- show (EitherAccess False) = "get_left_SBVEither"- show (EitherAccess True ) = "get_right_SBVEither"- show RationalConstructor = "SBV.Rational"- show (MaybeConstructor k False) = "(_ nothing_SBVMaybe " ++ show (KMaybe k) ++ ")"- show (MaybeConstructor k True) = "(_ just_SBVMaybe " ++ show (KMaybe k) ++ ")"- show (MaybeIs k False) = "(_ is (nothing_SBVMaybe () " ++ show (KMaybe k) ++ "))"- show (MaybeIs k True ) = "(_ is (just_SBVMaybe (" ++ show k ++ ") " ++ show (KMaybe k) ++ "))"- show MaybeAccess = "get_just_SBVMaybe"-- show op- | Just s <- op `lookup` syms = s- | True = error "impossible happened; can't find op!"- where syms = [ (Plus, "+"), (Times, "*"), (Minus, "-"), (UNeg, "-"), (Abs, "abs")- , (Quot, "quot")- , (Rem, "rem")- , (Equal, "=="), (NotEqual, "/=")- , (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=")- , (Ite, "if_then_else")- , (And, "&"), (Or, "|"), (XOr, "^"), (Not, "~")- , (Join, "#")- ]---- | Quantifiers: forall or exists. Note that we allow arbitrary nestings.-data Quantifier = ALL | EX deriving Eq---- | Show instance for 'Quantifier'-instance Show Quantifier where- show ALL = "Forall"- show EX = "Exists"---- | Which context is this variable being created?-data VarContext = NonQueryVar (Maybe Quantifier) -- in this case, it can be quantified- | QueryVar -- in this case, it is always existential---- | Are there any existential quantifiers?-needsExistentials :: [Quantifier] -> Bool-needsExistentials = (EX `elem`)---- | A simple type for SBV computations, used mainly for uninterpreted constants.--- We keep track of the signedness/size of the arguments. A non-function will--- have just one entry in the list.-newtype SBVType = SBVType [Kind]- deriving (Eq, Ord)--instance Show SBVType where- show (SBVType []) = error "SBV: internal error, empty SBVType"- show (SBVType xs) = intercalate " -> " $ map show xs---- | A symbolic expression-data SBVExpr = SBVApp !Op ![SV]- deriving (Eq, Ord, G.Data)---- | To improve hash-consing, take advantage of commutative operators by--- reordering their arguments.-reorder :: SBVExpr -> SBVExpr-reorder s = case s of- SBVApp op [a, b] | isCommutative op && a > b -> SBVApp op [b, a]- _ -> s- where isCommutative :: Op -> Bool- isCommutative o = o `elem` [Plus, Times, Equal, NotEqual, And, Or, XOr]---- Show instance for 'SBVExpr'. Again, only for debugging purposes.-instance Show SBVExpr where- show (SBVApp Ite [t, a, b]) = unwords ["if", show t, "then", show a, "else", show b]- show (SBVApp Shl [a, i]) = unwords [show a, "<<", show i]- show (SBVApp Shr [a, i]) = unwords [show a, ">>", show i]- show (SBVApp (Rol i) [a]) = unwords [show a, "<<<", show i]- show (SBVApp (Ror i) [a]) = unwords [show a, ">>>", show i]- show (SBVApp (PseudoBoolean pb) args) = unwords (show pb : map show args)- show (SBVApp (OverflowOp op) args) = unwords (show op : map show args)- show (SBVApp op [a, b]) = unwords [show a, show op, show b]- show (SBVApp op args) = unwords (show op : map show args)---- | A program is a sequence of assignments-newtype SBVPgm = SBVPgm {pgmAssignments :: S.Seq (SV, SBVExpr)}---- | Helper synonym for text, in case we switch to something else later.-type Name = T.Text---- | 'NamedSymVar' pairs symbolic values and user given/automatically generated names-data NamedSymVar = NamedSymVar !SV !Name- deriving (Show, Generic)---- | For comparison purposes, we simply use the SV and ignore the name-instance Eq NamedSymVar where- (==) (NamedSymVar l _) (NamedSymVar r _) = l == r--instance Ord NamedSymVar where- compare (NamedSymVar l _) (NamedSymVar r _) = compare l r---- | Convert to a named symvar, from string-toNamedSV' :: SV -> String -> NamedSymVar-toNamedSV' s = NamedSymVar s . T.pack---- | Convert to a named symvar, from text-toNamedSV :: SV -> Name -> NamedSymVar-toNamedSV = NamedSymVar---- | Get the node id from a named sym var-namedNodeId :: NamedSymVar -> NodeId-namedNodeId = swNodeId . getSV---- | Get the SV from a named sym var-getSV :: NamedSymVar -> SV-getSV (NamedSymVar s _) = s---- | Get the user-name typed value from named sym var-getUserName :: NamedSymVar -> Name-getUserName (NamedSymVar _ nm) = nm---- | Get the string typed value from named sym var-getUserName' :: NamedSymVar -> String-getUserName' = T.unpack . getUserName---- | Style of optimization. Note that in the pareto case the user is allowed--- to specify a max number of fronts to query the solver for, since there might--- potentially be an infinite number of them and there is no way to know exactly--- how many ahead of time. If 'Nothing' is given, SBV will possibly loop forever--- if the number is really infinite.-data OptimizeStyle = Lexicographic -- ^ Objectives are optimized in the order given, earlier objectives have higher priority.- | Independent -- ^ Each objective is optimized independently.- | Pareto (Maybe Int) -- ^ Objectives are optimized according to pareto front: That is, no objective can be made better without making some other worse.- deriving (Eq, Show)---- | Penalty for a soft-assertion. The default penalty is @1@, with all soft-assertions belonging--- to the same objective goal. A positive weight and an optional group can be provided by using--- the 'Penalty' constructor.-data Penalty = DefaultPenalty -- ^ Default: Penalty of @1@ and no group attached- | Penalty Rational (Maybe String) -- ^ Penalty with a weight and an optional group- deriving Show---- | Objective of optimization. We can minimize, maximize, or give a soft assertion with a penalty--- for not satisfying it.-data Objective a = Minimize String a -- ^ Minimize this metric- | Maximize String a -- ^ Maximize this metric- | AssertWithPenalty String a Penalty -- ^ A soft assertion, with an associated penalty- deriving (Show, Functor)---- | The name of the objective-objectiveName :: Objective a -> String-objectiveName (Minimize s _) = s-objectiveName (Maximize s _) = s-objectiveName (AssertWithPenalty s _ _) = s---- | The state we keep track of as we interact with the solver-data QueryState = QueryState { queryAsk :: Maybe Int -> String -> IO String- , querySend :: Maybe Int -> String -> IO ()- , queryRetrieveResponse :: Maybe Int -> IO String- , queryConfig :: SMTConfig- , queryTerminate :: IO ()- , queryTimeOutValue :: Maybe Int- , queryAssertionStackDepth :: Int- }---- | Computations which support query operations.-class Monad m => MonadQuery m where- queryState :: m State-- default queryState :: (MonadTrans t, MonadQuery m', m ~ t m') => m State- queryState = lift queryState--instance MonadQuery m => MonadQuery (ExceptT e m)-instance MonadQuery m => MonadQuery (MaybeT m)-instance MonadQuery m => MonadQuery (ReaderT r m)-instance MonadQuery m => MonadQuery (SS.StateT s m)-instance MonadQuery m => MonadQuery (LS.StateT s m)-instance (MonadQuery m, Monoid w) => MonadQuery (SW.WriterT w m)-instance (MonadQuery m, Monoid w) => MonadQuery (LW.WriterT w m)---- | 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 (Applicative, Functor, Monad, MonadIO, MonadTrans,- MonadError e, MonadState s, MonadWriter w)--instance Monad m => MonadQuery (QueryT m) where- queryState = QueryT ask--mapQueryT :: (ReaderT State m a -> ReaderT State n b) -> QueryT m a -> QueryT n b-mapQueryT f = QueryT . f . runQueryT-{-# INLINE mapQueryT #-}---- | Create a fresh variable of some type in the underlying query monad transformer.--- For further control on how these variables are projected and embedded, see the--- 'Queriable' class.-class Fresh m a where- fresh :: QueryT m a---- | An queriable value. This is a generalization of the 'Fresh' class, in case one needs--- to be more specific about how projections/embeddings are done.-class Queriable m a b | a -> b where- -- | ^ Create a new symbolic value of type @a@- create :: QueryT m a- -- | ^ Extract the current value in a SAT context- project :: a -> QueryT m b- -- | ^ Create a literal value. Morally, 'embed' and 'project' are inverses of each other- -- via the 'QueryT' monad transformer.- embed :: b -> QueryT m a---- Have to define this one by hand, because we use ReaderT in the implementation-instance MonadReader r m => MonadReader r (QueryT m) where- ask = lift ask- local f = mapQueryT $ mapReaderT $ local f---- | A query is a user-guided mechanism to directly communicate and extract--- results from the solver.-type Query = QueryT IO--instance MonadSymbolic Query where- symbolicEnv = queryState--instance NFData OptimizeStyle where- rnf x = x `seq` ()--instance NFData Penalty where- rnf DefaultPenalty = ()- rnf (Penalty p mbs) = rnf p `seq` rnf mbs--instance NFData a => NFData (Objective a) where- rnf (Minimize s a) = rnf s `seq` rnf a- rnf (Maximize s a) = rnf s `seq` rnf a- rnf (AssertWithPenalty s a p) = rnf s `seq` rnf a `seq` rnf p---- | Result of running a symbolic computation-data Result = Result { reskinds :: Set.Set Kind -- ^ kinds used in the program- , resTraces :: [(String, CV)] -- ^ quick-check counter-example information (if any)- , resObservables :: [(String, CV -> Bool, SV)] -- ^ observable expressions (part of the model)- , resUISegs :: [(String, [String])] -- ^ uninterpeted code segments- , resInputs :: ([(Quantifier, NamedSymVar)], [NamedSymVar]) -- ^ inputs (possibly existential) + tracker vars- , resConsts :: (CnstMap, [(SV, CV)]) -- ^ constants- , resTables :: [((Int, Kind, Kind), [SV])] -- ^ tables (automatically constructed) (tableno, index-type, result-type) elts- , resArrays :: [(Int, ArrayInfo)] -- ^ arrays (user specified)- , resUIConsts :: [(String, SBVType)] -- ^ uninterpreted constants- , resAxioms :: [(Bool, String, [String])] -- ^ axioms/definitions- , resAsgns :: SBVPgm -- ^ assignments- , resConstraints :: S.Seq (Bool, [(String, String)], SV) -- ^ additional constraints (boolean)- , resAssertions :: [(String, Maybe CallStack, SV)] -- ^ assertions- , resOutputs :: [SV] -- ^ outputs- }---- Show instance for 'Result'. Only for debugging purposes.-instance Show Result where- -- If there's nothing interesting going on, just print the constant. Note that the- -- definition of interesting here is rather subjective; but essentially if we reduced- -- the result to a single constant already, without any reference to anything.- show Result{resConsts=(_, cs), resOutputs=[r]}- | Just c <- r `lookup` cs- = show c- show (Result kinds _ _ cgs is (_, cs) ts as uis axs xs cstrs asserts os) = intercalate "\n" $- (if null usorts then [] else "SORTS" : map (" " ++) usorts)- ++ ["INPUTS"]- ++ map shn (fst is)- ++ (if null (snd is) then [] else "TRACKER VARS" : map (shn . (EX,)) (snd is))- ++ ["CONSTANTS"]- ++ concatMap shc cs- ++ ["TABLES"]- ++ map sht ts- ++ ["ARRAYS"]- ++ map sha as- ++ ["UNINTERPRETED CONSTANTS"]- ++ map shui uis- ++ ["USER GIVEN CODE SEGMENTS"]- ++ concatMap shcg cgs- ++ ["AXIOMS"]- ++ map shax axs- ++ ["DEFINE"]- ++ map (\(s, e) -> " " ++ shs s ++ " = " ++ show e) (F.toList (pgmAssignments xs))- ++ ["CONSTRAINTS"]- ++ map ((" " ++) . shCstr) (F.toList cstrs)- ++ ["ASSERTIONS"]- ++ map ((" "++) . shAssert) asserts- ++ ["OUTPUTS"]- ++ sh2 os- where sh2 :: Show a => [a] -> [String]- sh2 = map ((" "++) . show)-- usorts = [sh s t | KUserSort s t <- Set.toList kinds]- where sh s Nothing = s- sh s (Just es) = s ++ " (" ++ intercalate ", " es ++ ")"-- shs sv = show sv ++ " :: " ++ show (swKind sv)-- sht ((i, at, rt), es) = " Table " ++ show i ++ " : " ++ show at ++ "->" ++ show rt ++ " = " ++ show es-- shc (sv, cv)- | sv == falseSV || sv == trueSV- = []- | True- = [" " ++ show sv ++ " = " ++ show cv]-- shcg (s, ss) = ("Variable: " ++ s) : map (" " ++) ss-- shn (q, NamedSymVar sv nm) = " " <> ni <> " :: " ++ show (swKind sv) ++ ex ++ alias- where ni = show sv- ex | q == ALL = ""- | True = ", existential"-- alias | ni == T.unpack nm = ""- | True = ", aliasing " ++ show nm-- sha (i, (nm, (ai, bi), ctx)) = " " ++ ni ++ " :: " ++ show ai ++ " -> " ++ show bi ++ alias- ++ "\n Context: " ++ show ctx- where ni = "array_" ++ show i- alias | ni == nm = ""- | True = ", aliasing " ++ show nm-- shui (nm, t) = " [uninterpreted] " ++ nm ++ " :: " ++ show t-- shax (hasDefinition, nm, ss) = " -- user defined " ++ what ++ ": " ++ nm ++ "\n " ++ intercalate "\n " ss- where what | hasDefinition = "value"- | True = "axiom"-- shCstr (isSoft, [], c) = soft isSoft ++ show c- shCstr (isSoft, [(":named", nm)], c) = soft isSoft ++ nm ++ ": " ++ show c- shCstr (isSoft, attrs, c) = soft isSoft ++ show c ++ " (attributes: " ++ show attrs ++ ")"-- soft True = "[SOFT] "- soft False = ""-- shAssert (nm, stk, p) = " -- assertion: " ++ nm ++ " " ++ maybe "[No location]"-#if MIN_VERSION_base(4,9,0)- prettyCallStack-#else- showCallStack-#endif- stk ++ ": " ++ show p---- | The context of a symbolic array as created-data ArrayContext = ArrayFree (Maybe SV) -- ^ A new array, the contents are initialized with the given value, if any- | ArrayMutate ArrayIndex SV SV -- ^ An array created by mutating another array at a given cell- | ArrayMerge SV ArrayIndex ArrayIndex -- ^ An array created by symbolically merging two other arrays--instance Show ArrayContext where- show (ArrayFree Nothing) = " initialized with random elements"- show (ArrayFree (Just sv)) = " initialized with " ++ show sv- show (ArrayMutate i a b) = " cloned from array_" ++ show i ++ " with " ++ show a ++ " :: " ++ show (swKind a) ++ " |-> " ++ show b ++ " :: " ++ show (swKind b)- show (ArrayMerge s i j) = " merged arrays " ++ show i ++ " and " ++ show j ++ " on condition " ++ show s---- | Expression map, used for hash-consing-type ExprMap = Map.Map SBVExpr SV---- | Constants are stored in a map, for hash-consing.-type CnstMap = Map.Map CV SV---- | Kinds used in the program; used for determining the final SMT-Lib logic to pick-type KindSet = Set.Set Kind---- | Tables generated during a symbolic run-type TableMap = Map.Map (Kind, Kind, [SV]) Int---- | Representation for symbolic arrays-type ArrayInfo = (String, (Kind, Kind), ArrayContext)---- | SMT Arrays generated during a symbolic run-type ArrayMap = IMap.IntMap ArrayInfo---- | Functional Arrays generated during a symbolic run-type FArrayMap = IMap.IntMap (SVal -> SVal, IORef (IMap.IntMap SV))---- | Uninterpreted-constants generated during a symbolic run-type UIMap = Map.Map String SBVType---- | Code-segments for Uninterpreted-constants, as given by the user-type CgMap = Map.Map String [String]---- | Cached values, implementing sharing-type Cache a = IMap.IntMap [(StableName (State -> IO a), a)]---- | Stage of an interactive run-data IStage = ISetup -- Before we initiate contact.- | ISafe -- In the context of a safe/safeWith call- | IRun -- After the contact is started---- | Are we checking safety-isSafetyCheckingIStage :: IStage -> Bool-isSafetyCheckingIStage s = case s of- ISetup -> False- ISafe -> True- IRun -> False---- | Are we in setup?-isSetupIStage :: IStage -> Bool-isSetupIStage s = case s of- ISetup -> True- ISafe -> False- IRun -> True---- | Are we in a run?-isRunIStage :: IStage -> Bool-isRunIStage s = case s of- ISetup -> False- ISafe -> False- IRun -> True---- | Different means of running a symbolic piece of code-data SBVRunMode = SMTMode QueryContext IStage Bool SMTConfig -- ^ In regular mode, with a stage. Bool is True if this is SAT.- | CodeGen -- ^ Code generation mode.- | Concrete (Maybe (Bool, [((Quantifier, NamedSymVar), Maybe CV)])) -- ^ Concrete simulation mode, with given environment if any. If Nothing: Random.---- Show instance for SBVRunMode; debugging purposes only-instance Show SBVRunMode where- show (SMTMode qc ISetup True _) = "Satisfiability setup (" ++ show qc ++ ")"- show (SMTMode qc ISafe True _) = "Safety setup (" ++ show qc ++ ")"- show (SMTMode qc IRun True _) = "Satisfiability (" ++ show qc ++ ")"- show (SMTMode qc ISetup False _) = "Proof setup (" ++ show qc ++ ")"- show (SMTMode qc ISafe False _) = error $ "ISafe-False is not an expected/supported combination for SBVRunMode! (" ++ show qc ++ ")"- show (SMTMode qc IRun False _) = "Proof (" ++ show qc ++ ")"- show CodeGen = "Code generation"- show (Concrete Nothing) = "Concrete evaluation with random values"- show (Concrete (Just (True, _))) = "Concrete evaluation during model validation for sat"- show (Concrete (Just (False, _))) = "Concrete evaluation during model validation for prove"---- | Is this a CodeGen run? (i.e., generating code)-isCodeGenMode :: State -> IO Bool-isCodeGenMode State{runMode} = do rm <- readIORef runMode- return $ case rm of- Concrete{} -> False- SMTMode{} -> False- CodeGen -> True---- | The state in query mode, i.e., additional context-data IncState = IncState { rNewInps :: IORef [NamedSymVar] -- always existential!- , rNewKinds :: IORef KindSet- , rNewConsts :: IORef CnstMap- , rNewArrs :: IORef ArrayMap- , rNewTbls :: IORef TableMap- , rNewUIs :: IORef UIMap- , rNewAsgns :: IORef SBVPgm- , rNewConstraints :: IORef (S.Seq (Bool, [(String, String)], SV))- }---- | Get a new IncState-newIncState :: IO IncState-newIncState = do- is <- newIORef []- ks <- newIORef Set.empty- nc <- newIORef Map.empty- am <- newIORef IMap.empty- tm <- newIORef Map.empty- ui <- newIORef Map.empty- pgm <- newIORef (SBVPgm S.empty)- cstrs <- newIORef S.empty- return IncState { rNewInps = is- , rNewKinds = ks- , rNewConsts = nc- , rNewArrs = am- , rNewTbls = tm- , rNewUIs = ui- , rNewAsgns = pgm- , rNewConstraints = cstrs- }---- | Get a new IncState-withNewIncState :: State -> (State -> IO a) -> IO (IncState, a)-withNewIncState st cont = do- is <- newIncState- R.modifyIORef' (rIncState st) (const is)- r <- cont st- finalIncState <- readIORef (rIncState st)- return (finalIncState, r)---- | User defined, with proper quantifiers-type UserInputs = S.Seq (Quantifier, NamedSymVar)---- | Internally declared, always existential-type InternInps = S.Seq NamedSymVar---- | Entire set of names, for faster lookup-type AllInps = Set.Set Name---- | Inputs as a record of maps and sets. See above type-synonyms for their roles.-data Inputs = Inputs { userInputs :: !UserInputs- , internInputs :: !InternInps- , allInputs :: !AllInps- } deriving (Eq,Show)---- | Semigroup instance; combining according to indexes.-instance Semigroup Inputs where- (Inputs lui lii lai) <> (Inputs rui rii rai) = Inputs (lui <> rui) (lii <> rii) (lai <> rai)---- | Monoid instance, we start with no maps.-instance Monoid Inputs where- mempty = Inputs { userInputs = mempty- , internInputs = mempty- , allInputs = mempty- }---- | Get the quantifier-quantifier :: (Quantifier, NamedSymVar) -> Quantifier-quantifier = fst---- | Get the named symbolic variable-namedSymVar :: (Quantifier, NamedSymVar) -> NamedSymVar-namedSymVar = snd---- | Modify the user-inputs field-onUserInputs :: (UserInputs -> UserInputs) -> Inputs -> Inputs-onUserInputs f inp@Inputs{userInputs} = inp{userInputs = f userInputs}---- | Modify the internal-inputs field-onInternInputs :: (InternInps -> InternInps) -> Inputs -> Inputs-onInternInputs f inp@Inputs{internInputs} = inp{internInputs = f internInputs}---- | Modify the all-inputs field-onAllInputs :: (AllInps -> AllInps) -> Inputs -> Inputs-onAllInputs f inp@Inputs{allInputs} = inp{allInputs = f allInputs}---- | Add a new internal input-addInternInput :: SV -> Name -> Inputs -> Inputs-addInternInput sv nm = goAll . goIntern- where !new = toNamedSV sv nm- goIntern = onInternInputs (S.|> new)- goAll = onAllInputs (Set.insert nm)---- | Add a new user input-addUserInput :: Quantifier -> SV -> Name -> Inputs -> Inputs-addUserInput q sv nm = goAll . goUser- where new = toNamedSV sv nm- goUser = onUserInputs (S.|> (q, new)) -- add to the end of the sequence- goAll = onAllInputs (Set.insert nm)---- | Return user and internal inputs-getInputs :: Inputs -> (UserInputs, InternInps)-getInputs Inputs{userInputs, internInputs} = (userInputs, internInputs)---- | Find a user-input from its SV-lookupInput :: Eq a => (a -> SV) -> SV -> S.Seq a -> Maybe a-lookupInput f sv ns = res- where- i = getId (swNodeId sv)- svs = fmap f ns- res = case S.lookup i ns of -- Nothing on negative Int or Int > length seq- Nothing -> secondLookup- x@(Just e) -> if sv == f e then x else secondLookup- -- we try the fast lookup first, if the node ids don't match then- -- we use the more expensive O (n) to find the index and the elem- secondLookup = S.elemIndexL sv svs >>= flip S.lookup ns---- | Extract universals-getUniversals :: UserInputs -> S.Seq NamedSymVar-getUniversals = fmap namedSymVar . S.filter ((== ALL) . quantifier)---- | Get a prefix of the user inputs by a predicate. Note that we could not rely--- on fusion here but this is cheap and easy until there is an observable slow down from not fusing.-userInpsPrefixBy :: ((Quantifier, NamedSymVar) -> Bool) -> UserInputs -> UserInputs-userInpsPrefixBy = S.takeWhileL---- | Find prefix existentials, i.e., those that are at skolem positions and have valid model values.-prefixExistentials :: UserInputs -> UserInputs-prefixExistentials = userInpsPrefixBy ((/= ALL) . quantifier)---- | Find prefix universals. Corresponds to the above in a proof context.-prefixUniversals :: UserInputs -> UserInputs-prefixUniversals = userInpsPrefixBy ((== ALL) . quantifier)---- | Conversion from named-symvars to user-inputs-inputsFromListWith :: (NamedSymVar -> Quantifier) -> [NamedSymVar] -> UserInputs-inputsFromListWith f = S.fromList . fmap go- where go n = (f n, n)---- | Helper functions around inputs.--- TODO: remove these functions once lists have been pushed to edges of code base.-userInputsToList :: UserInputs -> [(Quantifier, NamedSymVar)]-userInputsToList = F.toList---- | Conversion from internal-inputs to list of named sym vars-internInputsToList :: InternInps -> [NamedSymVar]-internInputsToList = F.toList---- | Convert to regular lists-inputsToList :: Inputs -> ([(Quantifier, NamedSymVar)], [NamedSymVar])-inputsToList = (userInputsToList *** internInputsToList) . getInputs---- | The state of the symbolic interpreter-data State = State { pathCond :: SVal -- ^ kind KBool- , startTime :: UTCTime- , runMode :: IORef SBVRunMode- , rIncState :: IORef IncState- , rCInfo :: IORef [(String, CV)]- , rObservables :: IORef (S.Seq (Name, CV -> Bool, SV))- , rctr :: IORef Int- , rUsedKinds :: IORef KindSet- , rUsedLbls :: IORef (Set.Set String)- , rinps :: IORef Inputs- , rConstraints :: IORef (S.Seq (Bool, [(String, String)], SV))- , routs :: IORef [SV]- , rtblMap :: IORef TableMap- , spgm :: IORef SBVPgm- , rconstMap :: IORef CnstMap- , rexprMap :: IORef ExprMap- , rArrayMap :: IORef ArrayMap- , rFArrayMap :: IORef FArrayMap- , rUIMap :: IORef UIMap- , rCgMap :: IORef CgMap- , raxioms :: IORef [(Bool, String, [String])]- , rSMTOptions :: IORef [SMTOption]- , rOptGoals :: IORef [Objective (SV, SV)]- , rAsserts :: IORef [(String, Maybe CallStack, SV)]- , rSVCache :: IORef (Cache SV)- , rAICache :: IORef (Cache ArrayIndex)- , rQueryState :: IORef (Maybe QueryState)- }---- NFData is a bit of a lie, but it's sufficient, most of the content is iorefs that we don't want to touch-instance NFData State where- rnf State{} = ()---- | Get the current path condition-getSValPathCondition :: State -> SVal-getSValPathCondition = pathCond---- | Extend the path condition with the given test value.-extendSValPathCondition :: State -> (SVal -> SVal) -> State-extendSValPathCondition st f = st{pathCond = f (pathCond st)}---- | Are we running in proof mode?-inSMTMode :: State -> IO Bool-inSMTMode State{runMode} = do rm <- readIORef runMode- return $ case rm of- CodeGen -> False- Concrete{} -> False- SMTMode{} -> True---- | The "Symbolic" value. Either a constant (@Left@) or a symbolic--- value (@Right Cached@). Note that caching is essential for making--- sure sharing is preserved.-data SVal = SVal !Kind !(Either CV (Cached SV))--instance HasKind SVal where- kindOf (SVal k _) = k---- Show instance for 'SVal'. Not particularly "desirable", but will do if needed--- NB. We do not show the type info on constant KBool values, since there's no--- implicit "fromBoolean" applied to Booleans in Haskell; and thus a statement--- of the form "True :: SBool" is just meaningless. (There should be a fromBoolean!)-instance Show SVal where- show (SVal KBool (Left c)) = showCV False c- show (SVal k (Left c)) = showCV False c ++ " :: " ++ show k- show (SVal k (Right _)) = "<symbolic> :: " ++ show k---- | This instance is only defined so that we can define an instance for--- 'Data.Bits.Bits'. '==' and '/=' simply throw an error.--- We really don't want an 'Eq' instance for 'Data.SBV.Core.SBV' or 'SVal'. As it really makes no sense.--- But since we do want the 'Data.Bits.Bits' instance, we're forced to define equality. See--- <http://github.com/LeventErkok/sbv/issues/301>. We simply error out.-instance Eq SVal where- a == b = noEquals "==" ".==" (show a, show b)- a /= b = noEquals "/=" "./=" (show a, show b)---- Bail out nicely.-noEquals :: String -> String -> (String, String) -> a-noEquals o n (l, r) = error $ unlines [ ""- , "*** Data.SBV: Comparing symbolic values using Haskell's Eq class!"- , "***"- , "*** Received: " ++ l ++ " " ++ o ++ " " ++ r- , "*** Instead use: " ++ l ++ " " ++ n ++ " " ++ r- , "***"- , "*** The Eq instance for symbolic values are necessiated only because"- , "*** of the Bits class requirement. You must use symbolic equality"- , "*** operators instead. (And complain to Haskell folks that they"- , "*** remove the 'Eq' superclass from 'Bits'!.)"- ]---- | Things we do not support in interactive mode, at least for now!-noInteractive :: [String] -> a-noInteractive ss = error $ unlines $ ""- : "*** Data.SBV: Unsupported interactive/query mode feature."- : map ("*** " ++) ss- ++ ["*** Data.SBV: Please report this as a feature request!"]---- | Things we do not support in interactive mode, nor we ever intend to-noInteractiveEver :: [String] -> a-noInteractiveEver ss = error $ unlines $ ""- : "*** Data.SBV: Unsupported interactive/query mode feature."- : map ("*** " ++) ss---- | Modification of the state, but carefully handling the interactive tasks.--- Note that the state is always updated regardless of the mode, but we get--- to also perform extra operation in interactive mode. (Typically error out, but also simply--- ignore if it has no impact.)-modifyState :: State -> (State -> IORef a) -> (a -> a) -> IO () -> IO ()-modifyState st@State{runMode} field update interactiveUpdate = do- R.modifyIORef' (field st) update- rm <- readIORef runMode- case rm of- SMTMode _ IRun _ _ -> interactiveUpdate- _ -> return ()---- | Modify the incremental state-modifyIncState :: State -> (IncState -> IORef a) -> (a -> a) -> IO ()-modifyIncState State{rIncState} field update = do- incState <- readIORef rIncState- R.modifyIORef' (field incState) update---- | Add an observable--- notice that we cons like a list, we should build at the end of the seq, but cons to preserve semantics for now-recordObservable :: State -> String -> (CV -> Bool) -> SV -> IO ()-recordObservable st (T.pack -> nm) chk sv = modifyState st rObservables ((nm, chk, sv) S.<|) (return ())---- | Increment the variable counter-incrementInternalCounter :: State -> IO Int-incrementInternalCounter st = do ctr <- readIORef (rctr st)- modifyState st rctr (+1) (return ())- return ctr---- | Uninterpreted constants and functions. An uninterpreted constant is--- a value that is indexed by its name. The only property the prover assumes--- about these values are that they are equivalent to themselves; i.e., (for--- functions) they return the same results when applied to same arguments.--- We support uninterpreted-functions as a general means of black-box'ing--- operations that are /irrelevant/ for the purposes of the proof; i.e., when--- the proofs can be performed without any knowledge about the function itself.-svUninterpreted :: Kind -> String -> Maybe [String] -> [SVal] -> SVal-svUninterpreted k nm code args = SVal k $ Right $ cache result- where result st = do let ty = SBVType (map kindOf args ++ [k])- newUninterpreted st nm ty code- sws <- mapM (svToSV st) args- mapM_ forceSVArg sws- newExpr st k $ SBVApp (Uninterpreted nm) sws---- | Create a new uninterpreted symbol, possibly with user given code-newUninterpreted :: State -> String -> SBVType -> Maybe [String] -> IO ()-newUninterpreted st nm t mbCode- | null nm || not enclosed && (not (isAlpha (head nm)) || not (all validChar (tail nm)))- = error $ "Bad uninterpreted constant name: " ++ show nm ++ ". Must be a valid identifier."- | True = do uiMap <- readIORef (rUIMap st)- case nm `Map.lookup` uiMap of- Just t' -> checkType t' (return ())- Nothing -> do modifyState st rUIMap (Map.insert nm t)- $ modifyIncState st rNewUIs (\newUIs -> case nm `Map.lookup` newUIs of- Just t' -> checkType t' newUIs- Nothing -> Map.insert nm t newUIs)-- -- No need to record the code in interactive mode: CodeGen doesn't use interactive- when (isJust mbCode) $ modifyState st rCgMap (Map.insert nm (fromJust mbCode)) (return ())- where checkType :: SBVType -> r -> r- checkType t' cont- | t /= t' = error $ "Uninterpreted constant " ++ show nm ++ " used at incompatible types\n"- ++ " Current type : " ++ show t ++ "\n"- ++ " Previously used at: " ++ show t'- | True = cont-- validChar x = isAlphaNum x || x `elem` ("_" :: String)- enclosed = head nm == '|' && last nm == '|' && length nm > 2 && not (any (`elem` ("|\\" :: String)) (tail (init nm)))---- | Add a new sAssert based constraint-addAssertion :: State -> Maybe CallStack -> String -> SV -> IO ()-addAssertion st cs msg cond = modifyState st rAsserts ((msg, cs, cond):)- $ noInteractive [ "Named assertions (sAssert):"- , " Tag: " ++ msg- , " Loc: " ++ maybe "Unknown" show cs- ]---- | Create an internal variable, which acts as an input but isn't visible to the user.--- Such variables are existentially quantified in a SAT context, and universally quantified--- in a proof context.-internalVariable :: State -> Kind -> IO SV-internalVariable st k = do (NamedSymVar sv nm) <- newSV st k- rm <- readIORef (runMode st)- let q = case rm of- SMTMode _ _ True _ -> EX- SMTMode _ _ False _ -> ALL- CodeGen -> ALL- Concrete{} -> ALL- n = "__internal_sbv_" <> nm- v = NamedSymVar sv n- modifyState st rinps (addUserInput q sv n)- $ modifyIncState st rNewInps (\newInps -> case q of- EX -> v : newInps- -- I don't think the following can actually happen- -- but just be safe:- ALL -> noInteractive [ "Internal universally quantified variable creation:"- , " Named: " <> T.unpack nm- ])- return sv-{-# INLINE internalVariable #-}---- | Create a new SV-newSV :: State -> Kind -> IO NamedSymVar-newSV st k = do ctr <- incrementInternalCounter st- let sv = SV k (NodeId ctr)- registerKind st k- return $ NamedSymVar sv $ 's' `T.cons` T.pack (show ctr)-{-# INLINE newSV #-}---- | Register a new kind with the system, used for uninterpreted sorts.--- NB: Is it safe to have new kinds in query mode? It could be that--- the new kind might introduce a constraint that effects the logic. For--- instance, if we're seeing 'Double' for the first time and using a BV--- logic, then things would fall apart. But this should be rare, and hopefully--- the success-response checking mechanism will catch the rare cases where this--- is an issue. In either case, the user can always arrange for the right--- logic by calling 'Data.SBV.setLogic' appropriately, so it seems safe to just--- allow for this.-registerKind :: State -> Kind -> IO ()-registerKind st k- | KUserSort sortName _ <- k, map toLower sortName `elem` smtLibReservedNames- = error $ "SBV: " ++ show sortName ++ " is a reserved sort; please use a different name."- | True- = do -- Adding a kind to the incState is tricky; we only need to add it- -- * If it's an uninterpreted sort that's not already in the general state- -- * OR If it's a tuple-sort whose cardinality isn't already in the general state- -- * OR If it's a list that's not already in the general state (so we can send the flatten commands)-- existingKinds <- readIORef (rUsedKinds st)-- modifyState st rUsedKinds (Set.insert k) $ do-- -- Why do we discriminate here? Because the incremental context is sensitive to the- -- order: In particular, if an uninterpreted kind is already in there, we don't- -- want to re-add because double-declaration would be wrong. See 'cvtInc' for details.- let needsAdding = case k of- KUserSort{} -> k `notElem` existingKinds- KList{} -> k `notElem` existingKinds- KTuple nks -> length nks `notElem` [length oks | KTuple oks <- Set.toList existingKinds]- KMaybe{} -> k `notElem` existingKinds- KEither{} -> k `notElem` existingKinds- _ -> False-- when needsAdding $ modifyIncState st rNewKinds (Set.insert k)-- -- Don't forget to register subkinds!- case k of- KBool {} -> return ()- KBounded {} -> return ()- KUnbounded{} -> return ()- KReal {} -> return ()- KUserSort {} -> return ()- KFloat {} -> return ()- KDouble {} -> return ()- KFP {} -> return ()- KRational {} -> return ()- KChar {} -> return ()- KString {} -> return ()- KList ek -> registerKind st ek- KSet ek -> registerKind st ek- KTuple eks -> mapM_ (registerKind st) eks- KMaybe ke -> registerKind st ke- KEither k1 k2 -> mapM_ (registerKind st) [k1, k2]---- | Register a new label with the system, making sure they are unique and have no '|'s in them-registerLabel :: String -> State -> String -> IO ()-registerLabel whence st nm- | map toLower nm `elem` smtLibReservedNames- = err "is a reserved string; please use a different name."- | '|' `elem` nm- = err "contains the character `|', which is not allowed!"- | '\\' `elem` nm- = err "contains the character `\\', which is not allowed!"- | True- = do old <- readIORef $ rUsedLbls st- if nm `Set.member` old- then err "is used multiple times. Please do not use duplicate names!"- else modifyState st rUsedLbls (Set.insert nm) (return ())-- where err w = error $ "SBV (" ++ whence ++ "): " ++ show nm ++ " " ++ w---- | Create a new constant; hash-cons as necessary-newConst :: State -> CV -> IO SV-newConst st c = do- constMap <- readIORef (rconstMap st)- case c `Map.lookup` constMap of- -- NB. Unlike in 'newExpr', we don't have to make sure the returned sv- -- has the kind we asked for, because the constMap stores the full CV- -- which already has a kind field in it.- Just sv -> return sv- Nothing -> do (NamedSymVar sv _) <- newSV st (kindOf c)- let ins = Map.insert c sv- modifyState st rconstMap ins $ modifyIncState st rNewConsts ins- return sv-{-# INLINE newConst #-}---- | Create a new table; hash-cons as necessary-getTableIndex :: State -> Kind -> Kind -> [SV] -> IO Int-getTableIndex st at rt elts = do- let key = (at, rt, elts)- tblMap <- readIORef (rtblMap st)- case key `Map.lookup` tblMap of- Just i -> return i- _ -> do let i = Map.size tblMap- upd = Map.insert key i- modifyState st rtblMap upd $ modifyIncState st rNewTbls upd- return i---- | Create a new expression; hash-cons as necessary-newExpr :: State -> Kind -> SBVExpr -> IO SV-newExpr st k app = do- let e = reorder app- exprMap <- readIORef (rexprMap st)- case e `Map.lookup` exprMap of- -- NB. Check to make sure that the kind of the hash-consed value- -- is the same kind as we're requesting. This might look unnecessary,- -- at first, but `svSign` and `svUnsign` rely on this as we can- -- get the same expression but at a different type. See- -- <http://github.com/GaloisInc/cryptol/issues/566> as an example.- Just sv | kindOf sv == k -> return sv- _ -> do (NamedSymVar sv _) <- newSV st k- let append (SBVPgm xs) = SBVPgm (xs S.|> (sv, e))- modifyState st spgm append $ modifyIncState st rNewAsgns append- modifyState st rexprMap (Map.insert e sv) (return ())- return sv-{-# INLINE newExpr #-}---- | Convert a symbolic value to an internal SV-svToSV :: State -> SVal -> IO SV-svToSV st (SVal _ (Left c)) = newConst st c-svToSV st (SVal _ (Right f)) = uncache f st---- | Generalization of 'Data.SBV.svToSymSV'-svToSymSV :: MonadSymbolic m => SVal -> m SV-svToSymSV sbv = do st <- symbolicEnv- liftIO $ svToSV st sbv------------------------------------------------------------------------------ * Symbolic Computations----------------------------------------------------------------------------- | A Symbolic computation. Represented by a reader monad carrying the--- state of the computation, layered on top of IO for creating unique--- references to hold onto intermediate results.---- | Computations which support symbolic operations-class MonadIO m => MonadSymbolic m where- symbolicEnv :: m State-- default symbolicEnv :: (MonadTrans t, MonadSymbolic m', m ~ t m') => m State- symbolicEnv = lift symbolicEnv--instance MonadSymbolic m => MonadSymbolic (ExceptT e m)-instance MonadSymbolic m => MonadSymbolic (MaybeT m)-instance MonadSymbolic m => MonadSymbolic (ReaderT r m)-instance MonadSymbolic m => MonadSymbolic (SS.StateT s m)-instance MonadSymbolic m => MonadSymbolic (LS.StateT s m)-instance (MonadSymbolic m, Monoid w) => MonadSymbolic (SW.WriterT w m)-instance (MonadSymbolic m, Monoid w) => MonadSymbolic (LW.WriterT w m)---- | A generalization of 'Data.SBV.Symbolic'.-newtype SymbolicT m a = SymbolicT { runSymbolicT :: ReaderT State m a }- deriving ( Applicative, Functor, Monad, MonadIO, MonadTrans- , MonadError e, MonadState s, MonadWriter w-#if MIN_VERSION_base(4,11,0)- , Fail.MonadFail-#endif- )---- | `MonadSymbolic` instance for `SymbolicT m`-instance MonadIO m => MonadSymbolic (SymbolicT m) where- symbolicEnv = SymbolicT ask---- | Map a computation over the symbolic transformer.-mapSymbolicT :: (ReaderT State m a -> ReaderT State n b) -> SymbolicT m a -> SymbolicT n b-mapSymbolicT f = SymbolicT . f . runSymbolicT-{-# INLINE mapSymbolicT #-}---- Have to define this one by hand, because we use ReaderT in the implementation-instance MonadReader r m => MonadReader r (SymbolicT m) where- ask = lift ask- local f = mapSymbolicT $ mapReaderT $ local f---- | `Symbolic` is specialization of `SymbolicT` to the `IO` monad. Unless you are using--- transformers explicitly, this is the type you should prefer.-type Symbolic = SymbolicT IO---- | Create a symbolic value, based on the quantifier we have. If an--- explicit quantifier is given, we just use that. If not, then we--- pick the quantifier appropriately based on the run-mode.--- @randomCV@ is used for generating random values for this variable--- when used for @quickCheck@ or 'Data.SBV.Tools.GenTest.genTest' purposes.-svMkSymVar :: VarContext -> Kind -> Maybe String -> State -> IO SVal-svMkSymVar = svMkSymVarGen False---- | Create an existentially quantified tracker variable-svMkTrackerVar :: Kind -> String -> State -> IO SVal-svMkTrackerVar k nm = svMkSymVarGen True (NonQueryVar (Just EX)) k (Just nm)---- | Generalization of 'Data.SBV.sWordN'-sWordN :: MonadSymbolic m => Int -> String -> m SVal-sWordN w nm = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded False w) (Just nm)---- | Generalization of 'Data.SBV.sWordN_'-sWordN_ :: MonadSymbolic m => Int -> m SVal-sWordN_ w = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded False w) Nothing---- | Generalization of 'Data.SBV.sIntN'-sIntN :: MonadSymbolic m => Int -> String -> m SVal-sIntN w nm = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded True w) (Just nm)---- | Generalization of 'Data.SBV.sIntN_'-sIntN_ :: MonadSymbolic m => Int -> m SVal-sIntN_ w = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded True w) Nothing---- | Create a symbolic value, based on the quantifier we have. If an--- explicit quantifier is given, we just use that. If not, then we--- pick the quantifier appropriately based on the run-mode.--- @randomCV@ is used for generating random values for this variable--- when used for @quickCheck@ or 'Data.SBV.Tools.GenTest.genTest' purposes.-svMkSymVarGen :: Bool -> VarContext -> Kind -> Maybe String -> State -> IO SVal-svMkSymVarGen isTracker varContext k mbNm st = do- rm <- readIORef (runMode st)-- let varInfo = case mbNm of- Nothing -> ", of type " ++ show k- Just nm -> ", while defining " ++ nm ++ " :: " ++ show k-- disallow what = error $ "Data.SBV: Unsupported: " ++ what ++ varInfo ++ " in mode: " ++ show rm-- noUI cont- | isUserSort k = disallow "User defined sorts"- | True = cont-- (isQueryVar, mbQ) = case varContext of- NonQueryVar mq -> (False, mq)- QueryVar -> (True, Just EX)-- mkS q = do (NamedSymVar sv internalName) <- newSV st k- let nm = fromMaybe (T.unpack internalName) mbNm- introduceUserName st (isQueryVar, isTracker) nm k q sv-- mkC cv = do registerKind st k- modifyState st rCInfo ((fromMaybe "_" mbNm, cv):) (return ())- return $ SVal k (Left cv)-- case (mbQ, rm) of- (Just q, SMTMode{} ) -> mkS q- (Nothing, SMTMode _ _ isSAT _) -> mkS (if isSAT then EX else ALL)-- (Just EX, CodeGen{}) -> disallow "Existentially quantified variables"- (_ , CodeGen) -> noUI $ mkS ALL -- code generation, pick universal-- (Just EX, Concrete Nothing) -> disallow "Existentially quantified variables"- (_ , Concrete Nothing) -> noUI (randomCV k >>= mkC)-- -- Model validation:- (_ , Concrete (Just (_isSat, env))) -> do- let bad why conc = error $ unlines [ ""- , "*** Data.SBV: " ++ why- , "***"- , "*** To turn validation off, use `cfg{validateModel = False}`"- , "***"- , "*** " ++ conc- ]-- cant = "Validation engine is not capable of handling this case. Failed to validate."- report = "Please report this as a bug in SBV!"-- case () of- () | isUserSort k -> bad ("Cannot validate models in the presence of user defined kinds, saw: " ++ show k) cant-- _ -> do (NamedSymVar sv internalName) <- newSV st k-- let nm = fromMaybe (T.unpack internalName) mbNm- nsv = toNamedSV' sv nm-- cv = case [(q, v) | ((q, nsv'), v) <- env, nsv == nsv'] of- [] -> if isTracker- then -- The sole purpose of a tracker variable is to send the optimization- -- directive to the solver, so we can name "expressions" that are minimized- -- or maximized. There will be no constraints on these when we are doing- -- the validation; in fact they will not even be used anywhere during a- -- validation run. So, simply push a zero value that inhabits all metrics.- mkConstCV k (0::Integer)- else bad ("Cannot locate variable: " ++ show (nsv, k)) report- [(ALL, _)] -> -- We can stop here, as we can't really validate in the presence of a universal quantifier:- -- we'd have to validate for each possible value. But that's more or less useless. Instead,- -- just issue a warning and use 0 for this value.- mkConstCV k (0::Integer)- [(EX, Nothing)] -> bad ("Cannot locate model value of variable: " ++ show (getUserName' nsv)) report- [(EX, Just c)] -> c- r -> bad ( "Found multiple matching values for variable: " ++ show nsv- ++ "\n*** " ++ show r) report-- mkC cv---- | Introduce a new user name. We simply append a suffix if we have seen this variable before.-introduceUserName :: State -> (Bool, Bool) -> String -> Kind -> Quantifier -> SV -> IO SVal-introduceUserName st@State{runMode} (isQueryVar, isTracker) nmOrig k q sv = do- old <- allInputs <$> readIORef (rinps st)-- let nm = mkUnique (T.pack nmOrig) old-- -- If this is not a query variable and we're in a query, reject it.- -- See https://github.com/LeventErkok/sbv/issues/554 for the rationale.- -- In theory, it should be possible to support this, but fixing it is- -- rather costly as we'd have to track the regular updates and sync the- -- incremental state appropriately. Instead, we issue an error message- -- and ask the user to obey the query mode rules.- rm <- readIORef runMode- case rm of- SMTMode _ IRun _ _ | not isQueryVar -> noInteractiveEver [ "Adding a new input variable in query mode: " ++ show nm- , ""- , "Hint: Use freshVar/freshVar_ for introducing new inputs in query mode."- ]- _ -> pure ()-- if isTracker && q == ALL- then error $ "SBV: Impossible happened! A universally quantified tracker variable is being introduced: " ++ show nm- else do let newInp olds = case q of- EX -> toNamedSV sv nm : olds- ALL -> noInteractive [ "Adding a new universally quantified variable: "- , " Name : " ++ show nm- , " Kind : " ++ show k- , " Quantifier: Universal"- , " Node : " ++ show sv- , "Only existential variables are supported in query mode."- ]- if isTracker- then modifyState st rinps (addInternInput sv nm)- $ noInteractive ["Adding a new tracker variable in interactive mode: " ++ show nm]- else modifyState st rinps (addUserInput q sv nm)- $ modifyIncState st rNewInps newInp- return $ SVal k $ Right $ cache (const (return sv))-- where -- The following can be rather slow if we keep reusing the same prefix, but I doubt it'll be a problem in practice- -- Also, the following will fail if we span the range of integers without finding a match, but your computer would- -- die way ahead of that happening if that's the case!- mkUnique :: T.Text -> Set.Set Name -> T.Text- mkUnique prefix names = head $ dropWhile (`Set.member` names) (prefix : [prefix <> "_" <> T.pack (show i) | i <- [(0::Int)..]])---- | Generalization of 'Data.SBV.runSymbolic'-runSymbolic :: MonadIO m => SBVRunMode -> SymbolicT m a -> m (a, Result)-runSymbolic currentRunMode (SymbolicT c) = do- st <- liftIO $ do- currTime <- getCurrentTime- rm <- newIORef currentRunMode- ctr <- newIORef (-2) -- start from -2; False and True will always occupy the first two elements- cInfo <- newIORef []- observes <- newIORef mempty- pgm <- newIORef (SBVPgm S.empty)- emap <- newIORef Map.empty- cmap <- newIORef Map.empty- inps <- newIORef mempty- outs <- newIORef []- tables <- newIORef Map.empty- arrays <- newIORef IMap.empty- fArrays <- newIORef IMap.empty- uis <- newIORef Map.empty- cgs <- newIORef Map.empty- axioms <- newIORef []- swCache <- newIORef IMap.empty- aiCache <- newIORef IMap.empty- usedKinds <- newIORef Set.empty- usedLbls <- newIORef Set.empty- cstrs <- newIORef S.empty- smtOpts <- newIORef []- optGoals <- newIORef []- asserts <- newIORef []- istate <- newIORef =<< newIncState- qstate <- newIORef Nothing- pure $ State { runMode = rm- , startTime = currTime- , pathCond = SVal KBool (Left trueCV)- , rIncState = istate- , rCInfo = cInfo- , rObservables = observes- , rctr = ctr- , rUsedKinds = usedKinds- , rUsedLbls = usedLbls- , rinps = inps- , routs = outs- , rtblMap = tables- , spgm = pgm- , rconstMap = cmap- , rArrayMap = arrays- , rFArrayMap = fArrays- , rexprMap = emap- , rUIMap = uis- , rCgMap = cgs- , raxioms = axioms- , rSVCache = swCache- , rAICache = aiCache- , rConstraints = cstrs- , rSMTOptions = smtOpts- , rOptGoals = optGoals- , rAsserts = asserts- , rQueryState = qstate- }- _ <- liftIO $ newConst st falseCV -- s(-2) == falseSV- _ <- liftIO $ newConst st trueCV -- s(-1) == trueSV- r <- runReaderT c st- res <- liftIO $ extractSymbolicSimulationState st-- -- Clean-up after ourselves- qs <- liftIO $ readIORef $ rQueryState st- case qs of- Nothing -> return ()- Just QueryState{queryTerminate} -> liftIO queryTerminate-- return (r, res)---- | Grab the program from a running symbolic simulation state.-extractSymbolicSimulationState :: State -> IO Result-extractSymbolicSimulationState st@State{ spgm=pgm, rinps=inps, routs=outs, rtblMap=tables, rArrayMap=arrays, rUIMap=uis, raxioms=axioms- , rAsserts=asserts, rUsedKinds=usedKinds, rCgMap=cgs, rCInfo=cInfo, rConstraints=cstrs- , rObservables=observes- } = do- SBVPgm rpgm <- readIORef pgm- inpsO <- inputsToList <$> readIORef inps- outsO <- reverse <$> readIORef outs-- let swap (a, b) = (b, a)- cmp (a, _) (b, _) = a `compare` b- arrange (i, (at, rt, es)) = ((i, at, rt), es)-- constMap <- readIORef (rconstMap st)- let cnsts = sortBy cmp . map swap . Map.toList $ constMap-- tbls <- map arrange . sortBy cmp . map swap . Map.toList <$> readIORef tables- arrs <- IMap.toAscList <$> readIORef arrays- axs <- reverse <$> readIORef axioms- unint <- do unints <- Map.toList <$> readIORef uis- -- drop those that has an axiom associated with it- let defineds = [nm | (True, nm, _) <- axs]- pure [ui | ui@(nm, _) <- unints, nm `notElem` defineds]- knds <- readIORef usedKinds- cgMap <- Map.toList <$> readIORef cgs-- traceVals <- reverse <$> readIORef cInfo- observables <- reverse . fmap (\(n,f,sv) -> (T.unpack n, f, sv)) . F.toList- <$> readIORef observes- extraCstrs <- readIORef cstrs- assertions <- reverse <$> readIORef asserts-- return $ Result knds traceVals observables cgMap inpsO (constMap, cnsts) tbls arrs unint axs (SBVPgm rpgm) extraCstrs assertions outsO---- | Generalization of 'Data.SBV.addNewSMTOption'-addNewSMTOption :: MonadSymbolic m => SMTOption -> m ()-addNewSMTOption o = do st <- symbolicEnv- liftIO $ modifyState st rSMTOptions (o:) (return ())---- | Generalization of 'Data.SBV.imposeConstraint'-imposeConstraint :: MonadSymbolic m => Bool -> [(String, String)] -> SVal -> m ()-imposeConstraint isSoft attrs c = do st <- symbolicEnv- rm <- liftIO $ readIORef (runMode st)-- case rm of- CodeGen -> error "SBV: constraints are not allowed in code-generation"- _ -> liftIO $ do mapM_ (registerLabel "Constraint" st) [nm | (":named", nm) <- attrs]- internalConstraint st isSoft attrs c---- | Require a boolean condition to be true in the state. Only used for internal purposes.-internalConstraint :: State -> Bool -> [(String, String)] -> SVal -> IO ()-internalConstraint st isSoft attrs b = do v <- svToSV st b-- rm <- liftIO $ readIORef (runMode st)-- -- Are we running validation? If so, we always want to- -- add the constraint for debug purposes. Otherwie- -- we only add it if it's interesting; i.e., not directly- -- true or has some attributes.- let isValidating = case rm of- SMTMode _ _ _ cfg -> validationRequested cfg- CodeGen -> False- Concrete Nothing -> False- Concrete (Just _) -> True -- The case when we *are* running the validation-- let c = (isSoft, attrs, v)- interesting = v /= trueSV || not (null attrs)-- when (isValidating || interesting) $- modifyState st rConstraints (S.|> c)- $ modifyIncState st rNewConstraints (S.|> c)---- | Generalization of 'Data.SBV.addSValOptGoal'-addSValOptGoal :: MonadSymbolic m => Objective SVal -> m ()-addSValOptGoal obj = do st <- symbolicEnv-- -- create the tracking variable here for the metric- let mkGoal nm orig = liftIO $ do origSV <- svToSV st orig- track <- svMkTrackerVar (kindOf orig) nm st- trackSV <- svToSV st track- return (origSV, trackSV)-- let walk (Minimize nm v) = Minimize nm <$> mkGoal nm v- walk (Maximize nm v) = Maximize nm <$> mkGoal nm v- walk (AssertWithPenalty nm v mbP) = flip (AssertWithPenalty nm) mbP <$> mkGoal nm v-- !obj' <- walk obj- liftIO $ modifyState st rOptGoals (obj' :)- $ noInteractive [ "Adding an optimization objective:"- , " Objective: " ++ show obj- ]---- | Generalization of 'Data.SBV.outputSVal'-outputSVal :: MonadSymbolic m => SVal -> m ()-outputSVal (SVal _ (Left c)) = do- st <- symbolicEnv- sv <- liftIO $ newConst st c- liftIO $ modifyState st routs (sv:) (return ())-outputSVal (SVal _ (Right f)) = do- st <- symbolicEnv- sv <- liftIO $ uncache f st- liftIO $ modifyState st routs (sv:) (return ())-------------------------------------------------------------------------------------- * Cached values-------------------------------------------------------------------------------------- | We implement a peculiar caching mechanism, applicable to the use case in--- implementation of SBV's. Whenever we do a state based computation, we do--- not want to keep on evaluating it in the then-current state. That will--- produce essentially a semantically equivalent value. Thus, we want to run--- it only once, and reuse that result, capturing the sharing at the Haskell--- level. This is similar to the "type-safe observable sharing" work, but also--- takes into the account of how symbolic simulation executes.------ See Andy Gill's type-safe observable sharing trick for the inspiration behind--- this technique: <http://ku-fpg.github.io/files/Gill-09-TypeSafeReification.pdf>------ Note that this is *not* a general memo utility!-newtype Cached a = Cached (State -> IO a)---- | Cache a state-based computation-cache :: (State -> IO a) -> Cached a-cache = Cached---- | Uncache a previously cached computation-uncache :: Cached SV -> State -> IO SV-uncache = uncacheGen rSVCache---- | An SMT array index is simply an int value-newtype ArrayIndex = ArrayIndex { unArrayIndex :: Int } deriving (Eq, Ord, G.Data)---- | We simply show indexes as the underlying integer-instance Show ArrayIndex where- show (ArrayIndex i) = show i---- | Uncache, retrieving SMT array indexes-uncacheAI :: Cached ArrayIndex -> State -> IO ArrayIndex-uncacheAI = uncacheGen rAICache---- | Generic uncaching. Note that this is entirely safe, since we do it in the IO monad.-uncacheGen :: (State -> IORef (Cache a)) -> Cached a -> State -> IO a-uncacheGen getCache (Cached f) st = do- let rCache = getCache st- stored <- readIORef rCache- sn <- f `seq` makeStableName f- let h = hashStableName sn- case (h `IMap.lookup` stored) >>= (sn `lookup`) of- Just r -> return r- Nothing -> do r <- f st- r `seq` R.modifyIORef' rCache (IMap.insertWith (++) h [(sn, r)])- return r---- | Representation of SMTLib Program versions. As of June 2015, we're dropping support--- for SMTLib1, and supporting SMTLib2 only. We keep this data-type around in case--- SMTLib3 comes along and we want to support 2 and 3 simultaneously.-data SMTLibVersion = SMTLib2- deriving (Bounded, Enum, Eq, Show)---- | The extension associated with the version-smtLibVersionExtension :: SMTLibVersion -> String-smtLibVersionExtension SMTLib2 = "smt2"---- | Representation of an SMT-Lib program. In between pre and post goes the refuted models-data SMTLibPgm = SMTLibPgm SMTLibVersion [String]--instance NFData SMTLibVersion where rnf a = a `seq` ()-instance NFData SMTLibPgm where rnf (SMTLibPgm v p) = rnf v `seq` rnf p--instance Show SMTLibPgm where- show (SMTLibPgm _ pre) = intercalate "\n" pre---- Other Technicalities..-instance NFData CV where- rnf (CV x y) = x `seq` y `seq` ()--instance NFData GeneralizedCV where- rnf (ExtendedCV e) = e `seq` ()- rnf (RegularCV c) = c `seq` ()--#if MIN_VERSION_base(4,9,0)-#else--- Can't really force this, but not a big deal-instance NFData CallStack where- rnf _ = ()-#endif--instance NFData NamedSymVar where- rnf (NamedSymVar s n) = rnf s `seq` rnf n--instance NFData Result where- rnf (Result kindInfo qcInfo obs cgs inps consts tbls arrs uis axs pgm cstr asserts outs)- = rnf kindInfo `seq` rnf qcInfo `seq` rnf obs `seq` rnf cgs- `seq` rnf inps `seq` rnf consts `seq` rnf tbls- `seq` rnf arrs `seq` rnf uis `seq` rnf axs- `seq` rnf pgm `seq` rnf cstr `seq` rnf asserts- `seq` rnf outs-instance NFData Kind where rnf a = seq a ()-instance NFData ArrayContext where rnf a = seq a ()-instance NFData SV where rnf a = seq a ()-instance NFData SBVExpr where rnf a = seq a ()-instance NFData Quantifier where rnf a = seq a ()-instance NFData SBVType where rnf a = seq a ()-instance NFData SBVPgm where rnf a = seq a ()-instance NFData (Cached a) where rnf (Cached f) = f `seq` ()-instance NFData SVal where rnf (SVal x y) = rnf x `seq` rnf y--instance NFData SMTResult where- rnf (Unsatisfiable _ m ) = rnf m- rnf (Satisfiable _ m ) = rnf m- rnf (DeltaSat _ p m ) = rnf m `seq` rnf p- rnf (SatExtField _ m ) = rnf m- rnf (Unknown _ m ) = rnf m- rnf (ProofError _ m mr) = rnf m `seq` rnf mr--instance NFData SMTModel where- rnf (SMTModel objs bndgs assocs uifuns) = rnf objs `seq` rnf bndgs `seq` rnf assocs `seq` rnf uifuns--instance NFData SMTScript where- rnf (SMTScript b m) = rnf b `seq` rnf m---- | Translation tricks needed for specific capabilities afforded by each solver-data SolverCapabilities = SolverCapabilities {- supportsQuantifiers :: Bool -- ^ Supports SMT-Lib2 style quantifiers?- , supportsDefineFun :: Bool -- ^ Supports define-fun construct?- , supportsDistinct :: Bool -- ^ Supports calls to distinct?- , supportsBitVectors :: Bool -- ^ Supports bit-vectors?- , supportsUninterpretedSorts :: Bool -- ^ Supports SMT-Lib2 style uninterpreted-sorts- , supportsUnboundedInts :: Bool -- ^ Supports unbounded integers?- , supportsInt2bv :: Bool -- ^ Supports int2bv?- , supportsReals :: Bool -- ^ Supports reals?- , supportsApproxReals :: Bool -- ^ Supports printing of approximations of reals?- , supportsDeltaSat :: Maybe String -- ^ Supports delta-satisfiability? (With given precision query)- , supportsIEEE754 :: Bool -- ^ Supports floating point numbers?- , supportsSets :: Bool -- ^ Supports set operations?- , supportsOptimization :: Bool -- ^ Supports optimization routines?- , supportsPseudoBooleans :: Bool -- ^ Supports pseudo-boolean operations?- , supportsCustomQueries :: Bool -- ^ Supports interactive queries per SMT-Lib?- , supportsGlobalDecls :: Bool -- ^ Supports global declarations? (Needed for push-pop.)- , supportsDataTypes :: Bool -- ^ Supports datatypes?- , supportsDirectAccessors :: Bool -- ^ Supports data-type accessors without full ascription?- , supportsFlattenedModels :: Maybe [String] -- ^ Supports flattened model output? (With given config lines.)- }---- | Solver configuration. See also 'Data.SBV.z3', 'Data.SBV.yices', 'Data.SBV.cvc4', 'Data.SBV.boolector', 'Data.SBV.mathSAT', etc.--- which are instantiations of this type for those solvers, with reasonable defaults. In particular, custom configuration can be--- created by varying those values. (Such as @z3{verbose=True}@.)------ Most fields are self explanatory. The notion of precision for printing algebraic reals stems from the fact that such values does--- not necessarily have finite decimal representations, and hence we have to stop printing at some depth. It is important to--- emphasize that such values always have infinite precision internally. The issue is merely with how we print such an infinite--- precision value on the screen. The field 'printRealPrec' controls the printing precision, by specifying the number of digits after--- the decimal point. The default value is 16, but it can be set to any positive integer.------ When printing, SBV will add the suffix @...@ at the and of a real-value, if the given bound is not sufficient to represent the real-value--- exactly. Otherwise, the number will be written out in standard decimal notation. Note that SBV will always print the whole value if it--- is precise (i.e., if it fits in a finite number of digits), regardless of the precision limit. The limit only applies if the representation--- of the real value is not finite, i.e., if it is not rational.------ The 'printBase' field can be used to print numbers in base 2, 10, or 16.------ The 'crackNum' field can be used to display numbers in detail, all its bits and how they are laid out in memory. Works with all bounded number types--- (i.e., SWord and SInt), but also with floats. It is particularly useful with floating-point numbers, as it shows you how they are laid out in--- memory following the IEEE754 rules.-data SMTConfig = SMTConfig {- verbose :: Bool -- ^ Debug mode- , timing :: Timing -- ^ Print timing information on how long different phases took (construction, solving, etc.)- , printBase :: Int -- ^ Print integral literals in this base (2, 10, and 16 are supported.)- , printRealPrec :: Int -- ^ Print algebraic real values with this precision. (SReal, default: 16)- , crackNum :: Bool -- ^ For each numeric value, show it in detail in the model with its bits spliced out. Good for floats.- , satCmd :: String -- ^ Usually "(check-sat)". However, users might tweak it based on solver characteristics.- , allSatMaxModelCount :: Maybe Int -- ^ In a 'Data.SBV.allSat' call, return at most this many models. If nothing, return all.- , allSatPrintAlong :: Bool -- ^ In a 'Data.SBV.allSat' call, print models as they are found.- , satTrackUFs :: Bool -- ^ In a 'Data.SBV.sat' call, should we try to extract values of uninterpreted functions?- , isNonModelVar :: String -> Bool -- ^ When constructing a model, ignore variables whose name satisfy this predicate. (Default: (const False), i.e., don't ignore anything)- , validateModel :: Bool -- ^ If set, SBV will attempt to validate the model it gets back from the solver.- , optimizeValidateConstraints :: Bool -- ^ Validate optimization results. NB: Does NOT make sure the model is optimal, just checks they satisfy the constraints.- , transcript :: Maybe FilePath -- ^ If Just, the entire interaction will be recorded as a playable file (for debugging purposes mostly)- , smtLibVersion :: SMTLibVersion -- ^ What version of SMT-lib we use for the tool- , dsatPrecision :: Maybe Double -- ^ Delta-sat precision- , solver :: SMTSolver -- ^ The actual SMT solver.- , extraArgs :: [String] -- ^ Extra command line arguments to pass to the solver.- , allowQuantifiedQueries :: Bool -- ^ Should we permit use of quantifiers in the query mode? (Default: False. See <http://github.com/LeventErkok/sbv/issues/459> for why.)- , roundingMode :: RoundingMode -- ^ Rounding mode to use for floating-point conversions- , 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.- }---- | We show the name of the solver for the config. Arguably this is misleading, but better than nothing.-instance Show SMTConfig where- show = show . name . solver---- | Returns true if we have to perform validation-validationRequested :: SMTConfig -> Bool-validationRequested SMTConfig{validateModel, optimizeValidateConstraints} = validateModel || optimizeValidateConstraints---- We're just seq'ing top-level here, it shouldn't really matter. (i.e., no need to go deeper.)-instance NFData SMTConfig where- rnf SMTConfig{} = ()---- | A model, as returned by a solver-data SMTModel = SMTModel {- modelObjectives :: [(String, GeneralizedCV)] -- ^ Mapping of symbolic values to objective values.- , modelBindings :: Maybe [((Quantifier, NamedSymVar), Maybe CV)] -- ^ Mapping of input variables as reported by the solver. Only collected if model validation is requested.- , modelAssocs :: [(String, CV)] -- ^ Mapping of symbolic values to constants.- , modelUIFuns :: [(String, (SBVType, ([([CV], CV)], CV)))] -- ^ Mapping of uninterpreted functions to association lists in the model.- -- Note that an uninterpreted constant (function of arity 0) will be stored- -- in the 'modelAssocs' field.- }- deriving Show---- | The result of an SMT solver call. Each constructor is tagged with--- the 'SMTConfig' that created it so that further tools can inspect it--- and build layers of results, if needed. For ordinary uses of the library,--- this type should not be needed, instead use the accessor functions on--- it. (Custom Show instances and model extractors.)-data SMTResult = Unsatisfiable SMTConfig (Maybe [String]) -- ^ Unsatisfiable. If unsat-cores are enabled, they will be returned in the second parameter.- | Satisfiable SMTConfig SMTModel -- ^ Satisfiable with model- | DeltaSat SMTConfig (Maybe String) SMTModel -- ^ Delta satisfiable with queried string if available and model- | SatExtField SMTConfig SMTModel -- ^ Prover returned a model, but in an extension field containing Infinite/epsilon- | Unknown SMTConfig SMTReasonUnknown -- ^ Prover returned unknown, with the given reason- | ProofError SMTConfig [String] (Maybe SMTResult) -- ^ Prover errored out, with possibly a bogus result---- | A script, to be passed to the solver.-data SMTScript = SMTScript {- scriptBody :: String -- ^ Initial feed- , scriptModel :: [String] -- ^ Continuation script, to extract results- }---- | An SMT engine-type SMTEngine = forall res.- SMTConfig -- ^ current configuration- -> State -- ^ the state in which to run the engine- -> String -- ^ program- -> (State -> IO res) -- ^ continuation- -> IO res---- | Solvers that SBV is aware of-data Solver = ABC- | Boolector- | Bitwuzla- | CVC4- | CVC5- | DReal- | MathSAT- | Yices- | Z3- deriving (Show, Enum, Bounded)---- | An SMT solver-data SMTSolver = SMTSolver {- name :: Solver -- ^ The solver in use- , executable :: String -- ^ The path to its executable- , preprocess :: String -> String -- ^ Each line sent to the solver will be passed through this function (typically id)- , options :: SMTConfig -> [String] -- ^ Options to provide to the solver- , engine :: SMTEngine -- ^ The solver engine, responsible for interpreting solver output- , capabilities :: SolverCapabilities -- ^ Various capabilities of the solver- }---- | Query execution context-data QueryContext = QueryInternal -- ^ Triggered from inside SBV- | QueryExternal -- ^ Triggered from user code---- | Show instance for 'QueryContext', for debugging purposes-instance Show QueryContext where- show QueryInternal = "Internal Query"- show QueryExternal = "User Query"--{-# ANN type FPOp ("HLint: ignore Use camelCase" :: String) #-}-{-# ANN type PBOp ("HLint: ignore Use camelCase" :: String) #-}-{-# ANN type OvOp ("HLint: ignore Use camelCase" :: String) #-}-{-# ANN type NROp ("HLint: ignore Use camelCase" :: String) #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}++module Data.SBV.Core.Symbolic+ ( NodeId(..)+ , SV(..), swKind, trueSV, falseSV+ , Op(..), PBOp(..), OvOp(..), FPOp(..), NROp(..), StrOp(..), RegExOp(..), SeqOp(..), SetOp(..), SpecialRelOp(..), ADTOp(..)+ , RegExp(..), regExpToSMTString, SMTLambda(..)+ , Quantifier(..), needsExistentials, SBVContext(..), globalSBVContext, VarContext(..)+ , SBVType(..), svUninterpreted, svUninterpretedNamedArgs, newUninterpreted+ , SVal(..)+ , svMkSymVar, sWordN, sWordN_, sIntN, sIntN_+ , svToSV, svToSymSV, forceSVArg+ , SBVExpr(..), newExpr, isCodeGenMode, isSafetyCheckingIStage, isRunIStage, isSetupIStage+ , Cached, cache, uncache, modifyState, modifyIncState+ , NamedSymVar(..), Name, UserInputs, Inputs(..), getSV, swNodeId+ , getUserName', getUserName+ , lookupInput , getSValPathCondition, extendSValPathCondition+ , getTableIndex, sObserve+ , SBVPgm(..), MonadSymbolic(..), SymbolicT, Symbolic, runSymbolic, mkNewState, runSymbolicInState, State(..), SMTDef(..), smtDefEq, conflictError, withNewIncState, IncState(..), incrementInternalCounter, incrementFreshNameCounter+ , inSMTMode, SBVRunMode(..), IStage(..), Result(..), ResultInp(..), UICodeKind(..), UIName(..)+ , registerKind, registerLabel, recordObservable+ , addAssertion, addNewSMTOption, imposeConstraint, internalConstraint, newInternalVariable, lambdaVar, quantVar+ , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension, smtLibPgmText+ , SolverCapabilities(..)+ , extractSymbolicSimulationState, CnstMap+ , OptimizeStyle(..), Objective(..), Penalty(..), objectiveName, addSValOptGoal+ , MonadQuery(..), QueryT(..), Query, QueryState(..), QueryContext(..)+ , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), TPOptions(..), SMTEngine+ , validationRequested, outputSVal, ProgInfo(..), mustIgnoreVar, getRootState+ , LambdaInfo(..), showNROp+ ) where++import Control.DeepSeq (NFData(..))+import Control.Monad (when, unless)+import Control.Monad.Except (MonadError, ExceptT)+import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT,+ mapReaderT)+import Control.Monad.State.Lazy (MonadState)+import Control.Monad.Trans (MonadIO(liftIO), MonadTrans(lift))+import Control.Monad.Trans.Maybe (MaybeT)+import Control.Monad.Writer.Strict (MonadWriter)+import Data.IORef (IORef, newIORef, readIORef)+import Data.List (intercalate, isPrefixOf)+import Data.Maybe (fromMaybe)+import Data.String (IsString(fromString))++import Data.Time (getCurrentTime, UTCTime)++import Data.Int (Int64)++import GHC.Stack+import GHC.Stack.Types+import GHC.Generics (Generic)++import qualified Control.Exception as C+import qualified Control.Monad.State.Lazy as LS+import qualified Control.Monad.State.Strict as SS+import qualified Control.Monad.Writer.Lazy as LW+import qualified Control.Monad.Writer.Strict as SW+import qualified Data.IORef as R (modifyIORef')+import qualified Data.Generics as G (Data(..))+import qualified Data.Generics.Uniplate.Data as G+import qualified Data.IntMap.Strict as IMap (IntMap, empty, lookup, insertWith)+import qualified Data.Map.Strict as Map (Map, empty, toList, lookup, insert, size, keysSet)+import qualified Data.Set as Set (Set, empty, toList, insert, member, notMember)+import qualified Data.Foldable as F (toList)+import qualified Data.Sequence as S (Seq, empty, (|>), lookup, elemIndexL)+import qualified Data.Text as T+import Data.Text (Text)++import System.Mem.StableName+import System.Random++import Data.SBV.Core.Kind+import Data.SBV.Core.Concrete+import Data.SBV.SMT.SMTLibNames+import Data.SBV.Utils.TDiff (Timing)+import Data.SBV.Utils.Lib (stringToQFS, checkObservableName, barify, mapToSortedList, showText)+import Data.SBV.Utils.Numeric (RoundingMode)++import Data.Containers.ListUtils (nubOrd)++import Data.SBV.Control.Types+++-- | Context identifier. 0 is reserved global context+newtype SBVContext = SBVContext Int64 deriving (Eq, Ord, G.Data, Show)++instance NFData SBVContext where+ rnf (SBVContext i) = i `seq` ()++-- | Global context+globalSBVContext :: SBVContext+globalSBVContext = SBVContext 0++-- | Generate context. We make sure it isn't 0, i.e., the global context+-- The "hope" here is that each time we call this we get a different context number.+-- A random number doesn't necessarily have to do that, but I think the pseudo-generator+-- has a large enough period for this to go through OK.+genSBVContext :: IO SBVContext+genSBVContext = do ctx <- SBVContext <$> randomIO+ if ctx == globalSBVContext -- unlikely, but possible+ then genSBVContext+ else pure ctx++-- | A symbolic node id+newtype NodeId = NodeId { getId :: (SBVContext, Maybe Int, Int) } -- Lambda-level, and node-id+ deriving (Ord, G.Data)++-- Equality is pair-wise, except we accommodate for negative node-id; which is reserved for true/false+instance Eq NodeId where+ NodeId n1@(_, _, i) == NodeId n2@(_, _, j)+ | i < 0 && j < 0+ = i == j+ | True+ = n1 == n2++-- | A symbolic word, tracking its kind and node representing it+data SV = SV !Kind !NodeId+ deriving G.Data++-- | For equality, we merely use the lambda-level/node-id+instance Eq SV where+ SV _ n1 == SV _ n2 = n1 == n2++-- | Again, simply use the lambda-level/node-id for ordering+instance Ord SV where+ SV _ n1 `compare` SV _ n2 = n1 `compare` n2++instance HasKind SV where+ kindOf (SV k _) = k++instance Show SV where+ show (SV _ (NodeId (_, l, n))) = case n of+ -2 -> "false"+ -1 -> "true"+ _ -> prefix ++ 's' : show n+ where prefix = case l of+ Nothing -> "arg" -- top-level lambda+ Just 0 -> ""+ Just i -> 'l' : show i ++ "_"++-- | Kind of a symbolic word.+swKind :: SV -> Kind+swKind (SV k _) = k++-- | retrieve the node id of a symbolic word+swNodeId :: SV -> NodeId+swNodeId (SV _ nid) = nid++-- | Forcing an argument; this is a necessary evil to make sure all the arguments+-- to an uninterpreted function are evaluated before called; the semantics of uninterpreted+-- functions is necessarily strict; deviating from Haskell's+forceSVArg :: SV -> IO ()+forceSVArg (SV k n) = k `seq` n `seq` pure ()++-- | Constant False as an t'SV'. Note that this value always occupies slot -2 and level 0.+falseSV :: SV+falseSV = SV KBool $ NodeId (globalSBVContext, Just 0, -2)++-- | Constant True as an t'SV'. Note that this value always occupies slot -1 and level 0.+trueSV :: SV+trueSV = SV KBool $ NodeId (globalSBVContext, Just 0, -1)++-- | Symbolic operations+data Op = Plus+ | Times+ | Minus+ | UNeg+ | Abs+ | Quot+ | Rem+ | Equal Bool -- ^ If bool is True then this is strong (i.e., object equality). Matters for floats or structures containing them.+ | Implies+ | NotEqual+ | LessThan+ | GreaterThan+ | LessEq+ | GreaterEq+ | Ite+ | And+ | Or+ | XOr+ | Not+ | Shl+ | Shr+ | Rol Int+ | Ror Int+ | Divides Integer -- divides k n is True if k divides n. k must be > 0 constant+ | Extract Int Int -- Extract i j: extract bits i to j. Least significant bit is 0 (big-endian)+ | Join -- Concat two words to form a bigger one, in the order given+ | ZeroExtend Int+ | SignExtend Int+ | LkUp (Int, Kind, Kind, Int) !SV !SV -- (table-index, arg-type, res-type, length of the table) index out-of-bounds-value+ | KindCast Kind Kind+ | Uninterpreted T.Text+ | QuantifiedBool T.Text -- When we generate a forall/exists (nested etc.) boolean value. NB. This used to be "QuantifiedBool [Op] String", keeping track of Ops. That turned out to cause memory leaks. So avoid that.+ | SpecialRelOp Kind SpecialRelOp -- Generate the equality to the internal operation+ | Label String -- Essentially no-op; useful for code generation to emit comments.+ | IEEEFP FPOp -- Floating-point ops, categorized separately+ | NonLinear NROp -- Non-linear ops (mostly trigonometric), categorized separately+ | OverflowOp OvOp -- Overflow-ops, categorized separately+ | PseudoBoolean PBOp -- Pseudo-boolean ops, categorized separately+ | RegExOp RegExOp -- RegEx operations, categorized separately+ | StrOp StrOp -- String ops, categorized separately+ | SeqOp SeqOp -- Sequence ops, categorized separately+ | SetOp SetOp -- Set operations, categorized separately+ | TupleConstructor Int -- Construct an n-tuple+ | TupleAccess Int Int -- Access element i of an n-tuple; second argument is n+ | RationalConstructor -- Construct a rational. Note that there's no access to numerator or denominator, since we cannot store rationals in canonical form+ | ADTOp ADTOp -- ADT access/construction/testing++ -- Arrays+ | ArrayInit (Either (Kind, Kind) SMTLambda) -- An array value, created either from a lambda or a symbolic value. Kind is the+ | ReadArray -- Reading an array value+ | WriteArray -- Writing to an array+ deriving (Eq, Ord, Generic, G.Data, NFData)++-- | ADT operations+data ADTOp = ADTConstructor T.Text Kind -- Construct an ADT. Kind is the kind of the resulting ADT+ | ADTTester T.Text Kind -- Check if top-level constructor matches. Kind is the kind of the argument+ | ADTAccessor T.Text Kind -- Extract a field from an ADT value. Kind is the kind of the argument+ deriving (Eq, Ord, Generic, G.Data, NFData)++-- | Special relations supported by z3+data SpecialRelOp = IsPartialOrder String+ | IsLinearOrder String+ | IsTreeOrder String+ | IsPiecewiseLinearOrder String+ deriving (Eq, Ord, G.Data, Show)++instance NFData SpecialRelOp where+ rnf (IsPartialOrder n) = rnf n+ rnf (IsLinearOrder n) = rnf n+ rnf (IsTreeOrder n) = rnf n+ rnf (IsPiecewiseLinearOrder n) = rnf n++-- | Floating point operations+data FPOp = FP_Cast Kind Kind SV -- From-Kind, To-Kind, RoundingMode. This is "value" conversion+ | FP_Reinterpret Kind Kind -- From-Kind, To-Kind. This is bit-reinterpretation using IEEE-754 interchange format+ | FP_Abs+ | FP_Neg+ | FP_Add+ | FP_Sub+ | FP_Mul+ | FP_Div+ | FP_FMA+ | FP_Sqrt+ | FP_Rem+ | FP_RoundToIntegral+ | FP_Min+ | FP_Max+ | FP_ObjEqual+ | FP_IsNormal+ | FP_IsSubnormal+ | FP_IsZero+ | FP_IsInfinite+ | FP_IsNaN+ | FP_IsNegative+ | FP_IsPositive+ deriving (Eq, Ord, G.Data, NFData, Generic)++-- Note that the show instance maps to the SMTLib names. We need to make sure+-- this mapping stays correct through SMTLib changes. The only exception+-- is FP_Cast; where we handle different source/origins explicitly later on.+instance Show FPOp where+ show (FP_Cast f t r) = "(FP_Cast: " ++ show f ++ " -> " ++ show t ++ ", using RM [" ++ show r ++ "])"+ show (FP_Reinterpret f t) = case t of+ KFloat -> "(_ to_fp 8 24)"+ KDouble -> "(_ to_fp 11 53)"+ KFP eb sb -> "(_ to_fp " ++ show eb ++ " " ++ show sb ++ ")"+ _ -> error $ "SBV.FP_Reinterpret: Unexpected conversion: " ++ show f ++ " to " ++ show t+ show FP_Abs = "fp.abs"+ show FP_Neg = "fp.neg"+ show FP_Add = "fp.add"+ show FP_Sub = "fp.sub"+ show FP_Mul = "fp.mul"+ show FP_Div = "fp.div"+ show FP_FMA = "fp.fma"+ show FP_Sqrt = "fp.sqrt"+ show FP_Rem = "fp.rem"+ show FP_RoundToIntegral = "fp.roundToIntegral"+ show FP_Min = "fp.min"+ show FP_Max = "fp.max"+ show FP_ObjEqual = "="+ show FP_IsNormal = "fp.isNormal"+ show FP_IsSubnormal = "fp.isSubnormal"+ show FP_IsZero = "fp.isZero"+ show FP_IsInfinite = "fp.isInfinite"+ show FP_IsNaN = "fp.isNaN"+ show FP_IsNegative = "fp.isNegative"+ show FP_IsPositive = "fp.isPositive"++-- | Non-linear operations. We do *not* on purpose deriving Show here, nor give a show instance,+-- since different solvers call these functions with different names.+data NROp = NR_Sin+ | NR_Cos+ | NR_Tan+ | NR_ASin+ | NR_ACos+ | NR_ATan+ | NR_Sqrt+ | NR_Sinh+ | NR_Cosh+ | NR_Tanh+ | NR_Exp+ | NR_Log+ | NR_Pow+ deriving (Eq, Ord, G.Data, NFData, Generic)++-- | Show a non-linear op. Unfortunately this can't be generically done since different+-- solvers use different names for some of these ops.+showNROp :: Solver -> NROp -> String+showNROp slvr = sh+ where sh NR_Sin = "sin"+ sh NR_Cos = "cos"+ sh NR_Tan = "tan"+ sh NR_ASin = arc ++ "sin"+ sh NR_ACos = arc ++ "cos"+ sh NR_ATan = arc ++ "tan"+ sh NR_Sinh = "sinh"+ sh NR_Cosh = "cosh"+ sh NR_Tanh = "tanh"+ sh NR_Sqrt = "sqrt"+ sh NR_Exp = "exp"+ sh NR_Log = "log"+ sh NR_Pow = "pow"++ -- DReal uses asin/acos etc. CVC5 uses arcsin. Other solvers probably+ -- don't even support these. But this isn't the right place to bail-out+ -- about it; so we just put "arc" following CVC5 here.+ arc = case slvr of+ DReal -> "a"+ _ -> "arc"++-- | Pseudo-boolean operations+data PBOp = PB_AtMost Int -- ^ At most k+ | PB_AtLeast Int -- ^ At least k+ | PB_Exactly Int -- ^ Exactly k+ | PB_Le [Int] Int -- ^ At most k, with coefficients given. Generalizes PB_AtMost+ | PB_Ge [Int] Int -- ^ At least k, with coefficients given. Generalizes PB_AtLeast+ | PB_Eq [Int] Int -- ^ Exactly k, with coefficients given. Generalized PB_Exactly+ deriving (Eq, Ord, Show, G.Data, NFData, Generic)++-- | Overflow operations+data OvOp = PlusOv Bool -- ^ Addition overflow. Bool is True if signed.+ | SubOv Bool -- ^ Subtraction overflow. Bool is True if signed.+ | MulOv Bool -- ^ Multiplication overflow. Bool is True if signed.+ | DivOv -- ^ Division overflow. Only signed, since unsigned division does not overflow.+ | NegOv -- ^ Unary negation overflow. Only signed, since unsigned negation does not overflow.+ deriving (Eq, Ord, G.Data, NFData, Generic)++-- | Show instance. It's important that these follow the SMTLib names.+instance Show OvOp where+ show (PlusOv signed) = "bv" ++ (if signed then "s" else "u") ++ "addo"+ show (SubOv signed) = "bv" ++ (if signed then "s" else "u") ++ "subo"+ show (MulOv signed) = "bv" ++ (if signed then "s" else "u") ++ "mulo"+ 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.+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+ | StrInRe RegExp -- ^ Check if string is in the regular expression+ deriving (Eq, Ord, G.Data, NFData, Generic)++-- | Regular-expression operators. The only thing we can do is to compare for equality/disequality.+data RegExOp = RegExEq RegExp RegExp+ | RegExNEq RegExp RegExp+ deriving (Eq, Ord, G.Data, NFData, Generic)++-- | Regular expressions. Note that regular expressions themselves are+-- concrete, but the 'Data.SBV.RegExp.match' function from the 'Data.SBV.RegExp.RegExpMatchable' class+-- can check membership against a symbolic string/character. Also, we+-- are preferring a datatype approach here, as opposed to coming up with+-- some string-representation; there are way too many alternatives+-- already so inventing one isn't a priority. Please get in touch if you+-- would like a parser for this type as it might be easier to use.+data RegExp = Literal String -- ^ Precisely match the given string+ | All -- ^ Accept every string+ | AllChar -- ^ Accept every single character+ | None -- ^ Accept no strings+ | Range Char Char -- ^ Accept range of characters+ | Conc [RegExp] -- ^ Concatenation+ | KStar RegExp -- ^ Kleene Star: Zero or more+ | KPlus RegExp -- ^ Kleene Plus: One or more+ | Opt RegExp -- ^ Zero or one+ | Comp RegExp -- ^ Complement of regular expression+ | Diff RegExp RegExp -- ^ Difference of regular expressions+ | Loop Int Int RegExp -- ^ From @n@ repetitions to @m@ repetitions+ | Power Int RegExp -- ^ Exactly @n@ repetitions, i.e., nth power+ | Union [RegExp] -- ^ Union of regular expressions+ | Inter RegExp RegExp -- ^ Intersection of regular expressions+ deriving (Eq, Ord, G.Data, Generic, NFData)++-- | With overloaded strings, we can have direct literal regular expressions.+instance IsString RegExp where+ fromString = Literal++-- | Regular expressions as a 'Num' instance. Note that only some operations make sense and+-- not in the most obvious way. For instance, we would typically expect @a - b@ to be the+-- same as @a + negate b@, but that equality does not hold in general. So, use the @Num@+-- instance only as constructing syntax, not doing algebraic manipulations.+instance Num RegExp where+ -- flatten the concats to make them simpler+ Conc xs * y = Conc (xs ++ [y])+ x * Conc ys = Conc (x : ys)+ x * y = Conc [x, y]++ -- flatten the unions to make them simpler+ Union xs + y = Union (xs ++ [y])+ x + Union ys = Union (x : ys)+ x + y = Union [x, y]++ x - y = Diff x y++ abs = error "Num.RegExp: no abs method"+ signum = error "Num.RegExp: no signum method"++ fromInteger x+ | x == 0 = None+ | x == 1 = Literal "" -- Unit for concatenation is the empty string+ | True = error $ "Num.RegExp: Only 0 and 1 makes sense as a reg-exp, no meaning for: " ++ show x++ negate = Comp++-- | Convert a reg-exp to a Haskell-like string+instance Show RegExp where+ show = T.unpack . regExpToText (T.pack . show)++-- | Convert a reg-exp to a SMT-lib acceptable representation+regExpToSMTString :: RegExp -> Text+regExpToSMTString = regExpToText (\s -> "\"" <> T.pack (stringToQFS s) <> "\"")++-- | Convert a RegExp to text, parameterized by how strings are converted+regExpToText :: (String -> Text) -> RegExp -> Text+regExpToText fs (Literal s) = "(str.to_re " <> fs s <> ")"+regExpToText _ All = "re.all"+regExpToText _ AllChar = "re.allchar"+regExpToText _ None = "re.nostr"+regExpToText fs (Range ch1 ch2) = "(re.range " <> fs [ch1] <> " " <> fs [ch2] <> ")"+regExpToText _ (Conc []) = "1"+regExpToText fs (Conc [x]) = regExpToText fs x+regExpToText fs (Conc xs) = "(re.++ " <> T.unwords (map (regExpToText fs) xs) <> ")"+regExpToText fs (KStar r) = "(re.* " <> regExpToText fs r <> ")"+regExpToText fs (KPlus r) = "(re.+ " <> regExpToText fs r <> ")"+regExpToText fs (Opt r) = "(re.opt " <> regExpToText fs r <> ")"+regExpToText fs (Comp r) = "(re.comp " <> regExpToText fs r <> ")"+regExpToText fs (Diff r1 r2) = "(re.diff " <> regExpToText fs r1 <> " " <> regExpToText fs r2 <> ")"+regExpToText fs (Loop lo hi r)+ | lo >= 0, hi >= lo = "((_ re.loop " <> showText lo <> " " <> showText hi <> ") " <> regExpToText fs r <> ")"+ | True = error $ "Invalid regular-expression Loop with arguments: " ++ show (lo, hi)+regExpToText fs (Power n r)+ | n >= 0 = regExpToText fs (Loop n n r)+ | True = error $ "Invalid regular-expression Power with arguments: " ++ show n+regExpToText fs (Inter r1 r2) = "(re.inter " <> regExpToText fs r1 <> " " <> regExpToText fs r2 <> ")"+regExpToText _ (Union []) = "re.nostr"+regExpToText fs (Union [x]) = regExpToText fs x+regExpToText fs (Union xs) = "(re.union " <> T.unwords (map (regExpToText fs) xs) <> ")"++-- | Show instance for @StrOp@. Note that the mapping here is important to match the SMTLib equivalents.+instance Show StrOp where+ 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"+ show StrFromCode = "str.from_code"+ -- Note the breakage here with respect to argument order. We fix this explicitly later.+ show (StrInRe s) = "str.in_re " ++ T.unpack (regExpToSMTString s)++-- | Show instance for @RegExOp@.+instance Show RegExOp where+ show (RegExEq r1 r2) = "(= " ++ T.unpack (regExpToSMTString r1) ++ " " ++ T.unpack (regExpToSMTString r2) ++ ")"+ show (RegExNEq r1 r2) = "(distinct " ++ T.unpack (regExpToSMTString r1) ++ " " ++ T.unpack (regExpToSMTString r2) ++ ")"++-- | For now, we represent lambda functions in op with their SMTLib equivalent strings.+-- This might change in the future.+newtype SMTLambda = SMTLambda T.Text+ deriving (Eq, Ord, G.Data, Generic)+ deriving newtype NFData++-- | Simple show instance for SMTLambda+instance Show SMTLambda where+ show (SMTLambda s) = T.unpack s++-- | 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 (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+ | SetMember+ | SetInsert+ | SetDelete+ | SetIntersect+ | SetUnion+ | SetSubset+ | SetDifference+ | SetComplement+ deriving (Eq, Ord, G.Data, NFData, Generic)++-- The show instance for 'SetOp' is merely for debugging, we map them separately so+-- the mapped strings are less important here.+instance Show SetOp where+ show SetEqual = "=="+ show SetMember = "Set.member"+ show SetInsert = "Set.insert"+ show SetDelete = "Set.delete"+ show SetIntersect = "Set.intersect"+ show SetUnion = "Set.union"+ show SetSubset = "Set.subset"+ show SetDifference = "Set.difference"+ show SetComplement = "Set.complement"++-- Show instance for 'Op'. Note that this is largely for debugging purposes, not used+-- for being read by any tool.+instance Show Op where+ show Shl = "<<"+ show Shr = ">>"++ show (Rol i) = "<<<" ++ show i+ show (Ror i) = ">>>" ++ show i++ show (Extract i j) = "choose [" ++ show i ++ ":" ++ show j ++ "]"++ show (LkUp (ti, at, rt, l) i e)+ = "lookup(" ++ tinfo ++ ", " ++ show i ++ ", " ++ show e ++ ")"+ where tinfo = "table" ++ show ti ++ "(" ++ show at ++ " -> " ++ show rt ++ ", " ++ show l ++ ")"++ show (KindCast fr to) = "cast_" ++ show fr ++ "_" ++ show to+ show (Uninterpreted i) = "[uninterpreted] " ++ T.unpack i+ show (QuantifiedBool i) = "[quantified boolean] " ++ T.unpack i++ show (Label s) = "[label] " ++ s++ show (IEEEFP w) = show w++ show (NonLinear w) = showNROp DReal w -- Just use DReal here, only used for debugging++ show (PseudoBoolean p) = show p++ show (OverflowOp o) = show o++ show (StrOp s) = show s+ show (RegExOp s) = show s+ show (SeqOp s) = show s+ show (SetOp s) = show s++ show (TupleConstructor 0) = "mkSBVTuple0"+ show (TupleConstructor n) = "mkSBVTuple" ++ show n+ show (TupleAccess i n) = "proj_" ++ show i ++ "_SBVTuple" ++ show n++ show RationalConstructor = "SBV.Rational"+ show (ArrayInit k) = case k of+ Left (a, b) -> "const-array[" ++ show a ++ " -> " ++ show b ++ "]"+ Right s -> show s+ show ReadArray = "select"+ show WriteArray = "store"++ show op+ | Just s <- op `lookup` syms = s+ | True = error "impossible happened; can't find op!" -- NB. Can't display the OP here! it's the show instance after all.+ where syms = [ (Plus, "+"), (Times, "*"), (Minus, "-"), (UNeg, "-"), (Abs, "abs")+ , (Quot, "quot")+ , (Rem, "rem")+ , (Equal True, "==="), (Equal False, "=="), (NotEqual, "/="), (Implies, "=>")+ , (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=")+ , (Ite, "if_then_else")+ , (And, "&"), (Or, "|"), (XOr, "^"), (Not, "~")+ , (Join, "#")+ ]++-- | Quantifiers: forall or exists. Note that we allow arbitrary nestings.+data Quantifier = ALL | EX deriving (Eq, G.Data)++-- | Show instance for 'Quantifier'+instance Show Quantifier where+ show ALL = "Forall"+ show EX = "Exists"++-- | Which context is this variable being created?+data VarContext = NonQueryVar (Maybe Quantifier) -- in this case, it can be quantified+ | QueryVar -- in this case, it is always existential++-- | Are there any existential quantifiers?+needsExistentials :: [Quantifier] -> Bool+needsExistentials = (EX `elem`)++-- | A simple type for SBV computations, used mainly for uninterpreted constants.+-- We keep track of the signedness/size of the arguments. A non-function will+-- have just one entry in the list.+newtype SBVType = SBVType [Kind]+ deriving (Eq, Ord, G.Data)++instance Show SBVType where+ show (SBVType []) = error "SBV: internal error, empty SBVType"+ show (SBVType xs) = intercalate " -> " $ map show xs++-- | A symbolic expression+data SBVExpr = SBVApp !Op ![SV]+ deriving (Eq, Ord, G.Data)++-- | To improve hash-consing, take advantage of commutative operators by+-- reordering their arguments.+reorder :: SBVExpr -> SBVExpr+reorder s = case s of+ SBVApp op [a, b] | isCommutative op && a > b -> SBVApp op [b, a]+ _ -> s+ where isCommutative :: Op -> Bool+ isCommutative o = o `elem` [Plus, Times, Equal True, Equal False, NotEqual, And, Or, XOr]++-- Show instance for 'SBVExpr'. Again, only for debugging purposes.+instance Show SBVExpr where+ show (SBVApp Ite [t, a, b]) = unwords ["if", show t, "then", show a, "else", show b]+ show (SBVApp Shl [a, i]) = unwords [show a, "<<", show i]+ show (SBVApp Shr [a, i]) = unwords [show a, ">>", show i]+ show (SBVApp (Rol i) [a]) = unwords [show a, "<<<", show i]+ show (SBVApp (Ror i) [a]) = unwords [show a, ">>>", show i]+ show (SBVApp (PseudoBoolean pb) args) = unwords (show pb : map show args)+ show (SBVApp (OverflowOp op) args) = unwords (show op : map show args)++ show (SBVApp op args) | showOpInfix op, length args == 2 = unwords (map show (take 1 args) ++ show op : map show (drop 1 args))+ | True = unwords (show op : map show args)++-- | Should we display this Op infix?+showOpInfix :: Op -> Bool+showOpInfix = (`elem` infixOps)+ where infixOps = [ Plus, Times, Minus, Quot, Rem, Implies+ , Equal True, Equal False, NotEqual, LessThan, GreaterThan, LessEq, GreaterEq+ , And, Or, XOr, Join+ ]++-- | A program is a sequence of assignments+newtype SBVPgm = SBVPgm {pgmAssignments :: S.Seq (SV, SBVExpr)}+ deriving G.Data++-- | Helper synonym for text, in case we switch to something else later.+type Name = T.Text++-- | t'NamedSymVar' pairs symbolic values and user given/automatically generated names+data NamedSymVar = NamedSymVar !SV !Name+ deriving (Show, Generic, G.Data)++-- | For comparison purposes, we simply use the SV and ignore the name+instance Eq NamedSymVar where+ (==) (NamedSymVar l _) (NamedSymVar r _) = l == r++instance Ord NamedSymVar where+ compare (NamedSymVar l _) (NamedSymVar r _) = compare l r++-- | Convert to a named symvar, from text+toNamedSV :: SV -> Name -> NamedSymVar+toNamedSV = NamedSymVar++-- | Get the SV from a named sym var+getSV :: NamedSymVar -> SV+getSV (NamedSymVar s _) = s++-- | Get the user-name typed value from named sym var+getUserName :: NamedSymVar -> Name+getUserName (NamedSymVar _ nm) = nm++-- | Get the string typed value from named sym var+getUserName' :: NamedSymVar -> String+getUserName' = T.unpack . getUserName++-- | Style of optimization. Note that in the pareto case the user is allowed+-- to specify a max number of fronts to query the solver for, since there might+-- potentially be an infinite number of them and there is no way to know exactly+-- how many ahead of time. If 'Nothing' is given, SBV will possibly loop forever+-- if the number is really infinite.+data OptimizeStyle = Lexicographic -- ^ Objectives are optimized in the order given, earlier objectives have higher priority.+ | Independent -- ^ Each objective is optimized independently.+ | Pareto (Maybe Int) -- ^ Objectives are optimized according to pareto front: That is, no objective can be made better without making some other worse.+ deriving (Eq, Show)++-- | Penalty for a soft-assertion. The default penalty is @1@, with all soft-assertions belonging+-- to the same objective goal. A positive weight and an optional group can be provided by using+-- the v'Penalty' constructor.+data Penalty = DefaultPenalty -- ^ Default: Penalty of @1@ and no group attached+ | Penalty Rational (Maybe String) -- ^ Penalty with a weight and an optional group+ deriving Show++-- | Objective of optimization. We can minimize, maximize, or give a soft assertion with a penalty+-- for not satisfying it.+data Objective a = Minimize String a -- ^ Minimize this metric+ | Maximize String a -- ^ Maximize this metric+ | AssertWithPenalty String a Penalty -- ^ A soft assertion, with an associated penalty+ deriving (Show, Functor)++-- | The name of the objective+objectiveName :: Objective a -> String+objectiveName (Minimize s _) = s+objectiveName (Maximize s _) = s+objectiveName (AssertWithPenalty s _ _) = s++-- | The state we keep track of as we interact with the solver+data QueryState = QueryState { queryAsk :: Maybe Int -> Text -> IO String+ , querySend :: Maybe Int -> Text -> IO ()+ , queryRetrieveResponse :: Maybe Int -> IO String+ , queryConfig :: SMTConfig+ , queryTerminate :: Maybe C.SomeException -> IO ()+ , queryTimeOutValue :: Maybe Int+ , queryAssertionStackDepth :: !Int+ }++-- | Computations which support query operations.+class Monad m => MonadQuery m where+ queryState :: m State++ default queryState :: (MonadTrans t, MonadQuery m', m ~ t m') => m State+ queryState = lift queryState++instance MonadQuery m => MonadQuery (ExceptT e m)+instance MonadQuery m => MonadQuery (MaybeT m)+instance MonadQuery m => MonadQuery (ReaderT r m)+instance MonadQuery m => MonadQuery (SS.StateT s m)+instance MonadQuery m => MonadQuery (LS.StateT s m)+instance (MonadQuery m, Monoid w) => MonadQuery (SW.WriterT w m)+instance (MonadQuery m, Monoid w) => MonadQuery (LW.WriterT w m)++-- | 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)++instance Monad m => MonadQuery (QueryT m) where+ queryState = QueryT ask++mapQueryT :: (ReaderT State m a -> ReaderT State n b) -> QueryT m a -> QueryT n b+mapQueryT f = QueryT . f . runQueryT+{-# INLINE mapQueryT #-}++-- Have to define this one by hand, because we use ReaderT in the implementation+instance MonadReader r m => MonadReader r (QueryT m) where+ ask = lift ask+ local f = mapQueryT $ mapReaderT $ local f++-- | A query is a user-guided mechanism to directly communicate and extract+-- results from the solver.+type Query = QueryT IO++instance MonadSymbolic Query where+ symbolicEnv = queryState++instance NFData OptimizeStyle where+ rnf x = x `seq` ()++instance NFData Penalty where+ rnf DefaultPenalty = ()+ rnf (Penalty p mbs) = rnf p `seq` rnf mbs++instance NFData a => NFData (Objective a) where+ rnf (Minimize s a) = rnf s `seq` rnf a+ rnf (Maximize s a) = rnf s `seq` rnf a+ rnf (AssertWithPenalty s a p) = rnf s `seq` rnf a `seq` rnf p++-- | A result can either produce something at the top or as a lambda/constraint. Distinguish by inputs+data ResultInp = ResultTopInps ([NamedSymVar], [NamedSymVar]) -- user inputs -- trackers+ | ResultLamInps [(Quantifier, NamedSymVar)] -- for constraints, we can have quantifiers+ deriving G.Data++instance NFData ResultInp where+ rnf (ResultTopInps xs) = rnf xs+ rnf (ResultLamInps xs) = rnf xs++-- | Several data about the program+data ProgInfo = ProgInfo { hasQuants :: !Bool+ , progSpecialRels :: ![SpecialRelOp]+ , progTransClosures :: ![(String, String)]+ }+ deriving G.Data++instance NFData ProgInfo where+ rnf (ProgInfo a b c) = rnf a `seq` rnf b `seq` rnf c++deriving instance G.Data CallStack+deriving instance G.Data SrcLoc++-- | Result of running a symbolic computation+data Result = Result { progInfo :: ProgInfo -- ^ various info we collect about the program+ , reskinds :: Set.Set Kind -- ^ kinds used in the program+ , resTraces :: [(String, CV)] -- ^ quick-check counter-example information (if any)+ , resObservables :: [(String, CV -> Bool, SV)] -- ^ observable expressions (part of the model)+ , resUISegs :: [(String, [String])] -- ^ uninterpreted code segments+ , resParams :: ResultInp -- ^ top-inputs or lambda params+ , 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 :: [(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+ , resOutputs :: [SV] -- ^ outputs+ }+ deriving G.Data++-- Show instance for 'Result'. Only for debugging purposes.+instance Show Result where+ -- If there's nothing interesting going on, just print the constant. Note that the+ -- definition of interesting here is rather subjective; but essentially if we reduced+ -- the result to a single constant already, without any reference to anything.+ show Result{resConsts=(_, cs), resOutputs=[r]}+ | Just c <- r `lookup` cs+ = show c+ show (Result _ kinds _ _ cgs params (_, cs) ts uis defns xs cstrs asserts os) = intercalate "\n" $+ (if null usorts then [] else "SORTS" : map (" " ++) usorts)+ ++ (case params of+ ResultTopInps (i, t) -> "INPUTS" : map shn i ++ (if null t then [] else "TRACKER VARS" : map shn t)+ ResultLamInps qs -> "LAMBDA-CONSTRAINT PARAMS" : map shq qs+ )+ ++ ["CONSTANTS"]+ ++ concatMap shc cs+ ++ ["TABLES"]+ ++ map sht ts+ ++ ["UNINTERPRETED CONSTANTS"]+ ++ map shui uis+ ++ ["USER GIVEN CODE SEGMENTS"]+ ++ concatMap shcg cgs+ ++ ["AXIOMS-DEFINITIONS"]+ ++ map show defns+ ++ ["DEFINE"]+ ++ map (\(s, e) -> " " ++ shs s ++ " = " ++ show e) (F.toList (pgmAssignments xs))+ ++ ["CONSTRAINTS"]+ ++ map ((" " ++) . shCstr) (F.toList cstrs)+ ++ ["ASSERTIONS"]+ ++ map ((" "++) . shAssert) asserts+ ++ ["OUTPUTS"]+ ++ sh2 os+ where sh2 :: Show a => [a] -> [String]+ sh2 = map ((" "++) . show)++ usorts = [s | KADT s _ _ <- filter isUninterpreted (Set.toList kinds)]++ shs sv = show sv ++ " :: " ++ show (swKind sv)++ sht ((i, at, rt), es) = " Table " ++ show i ++ " : " ++ show at ++ "->" ++ show rt ++ " = " ++ show es++ shc (sv, cv)+ | sv == falseSV || sv == trueSV+ = []+ | True+ = [" " ++ show sv ++ " = " ++ show cv]++ shcg (s, ss) = ("Variable: " ++ s) : map (" " ++) ss++ shn (NamedSymVar sv nm) = " " ++ ni ++ " :: " ++ show (swKind sv) ++ alias+ where ni = show sv++ alias | T.pack ni == nm = ""+ | True = ", aliasing " ++ show nm++ shq (q, v) = shn v ++ ", " ++ if q == ALL then "universal" else "existential"++ shui (nm, t) = " [uninterpreted] " ++ nm ++ " :: " ++ show t++ shCstr (isSoft, [], c) = soft isSoft ++ show c+ shCstr (isSoft, [(":named", nm)], c) = soft isSoft ++ nm ++ ": " ++ show c+ shCstr (isSoft, attrs, c) = soft isSoft ++ show c ++ " (attributes: " ++ show attrs ++ ")"++ soft True = "[SOFT] "+ soft False = ""++ shAssert (nm, stk, p) = " -- assertion: " ++ nm ++ " " ++ maybe "[No location]"+ prettyCallStack+ stk ++ ": " ++ show p++-- | Expression map, used for hash-consing+type ExprMap = Map.Map SBVExpr SV++-- | Constants are stored in a map, for hash-consing.+type CnstMap = Map.Map CV SV++-- | Kinds used in the program; used for determining the final SMT-Lib logic to pick+type KindSet = Set.Set Kind++-- | Tables generated during a symbolic run+type TableMap = Map.Map (Kind, Kind, [SV]) Int++-- | Uninterpreted-constants generated during a symbolic run+type UIMap = Map.Map String (Bool, Maybe [String], SBVType) -- If Bool is true, then this is a curried function++-- | Code-segments for Uninterpreted-constants, as given by the user+type CgMap = Map.Map String [String]++-- | Cached values, implementing sharing+type Cache a = IMap.IntMap [(StableName (State -> IO a), a)]++-- | Stage of an interactive run+data IStage = ISetup -- Before we initiate contact.+ | ISafe -- In the context of a safe/safeWith call+ | IRun -- After the contact is started++-- | Are we checking safety+isSafetyCheckingIStage :: IStage -> Bool+isSafetyCheckingIStage s = case s of+ ISetup -> False+ ISafe -> True+ IRun -> False++-- | Are we in setup?+isSetupIStage :: IStage -> Bool+isSetupIStage s = case s of+ ISetup -> True+ ISafe -> False+ IRun -> True++-- | Are we in a run?+isRunIStage :: IStage -> Bool+isRunIStage s = case s of+ ISetup -> False+ ISafe -> False+ IRun -> True++-- | Different means of running a symbolic piece of code+data SBVRunMode = SMTMode QueryContext IStage Bool SMTConfig -- ^ In regular mode, with a stage. Bool is True if this is SAT.+ | CodeGen -- ^ Code generation mode.+ | LambdaGen (Maybe Int) -- ^ Inside a lambda-expression at level. If Nothing, then closed lambda.+ | Concrete (Maybe (Bool, [(NamedSymVar, CV)])) -- ^ Concrete simulation mode, with given environment if any. If Nothing: Random.++-- Show instance for SBVRunMode; debugging purposes only+instance Show SBVRunMode where+ show (SMTMode qc ISetup True _) = "Satisfiability setup (" ++ show qc ++ ")"+ show (SMTMode qc ISafe True _) = "Safety setup (" ++ show qc ++ ")"+ show (SMTMode qc IRun True _) = "Satisfiability (" ++ show qc ++ ")"+ show (SMTMode qc ISetup False _) = "Proof setup (" ++ show qc ++ ")"+ show (SMTMode qc ISafe False _) = error $ "ISafe-False is not an expected/supported combination for SBVRunMode! (" ++ show qc ++ ")"+ show (SMTMode qc IRun False _) = "Proof (" ++ show qc ++ ")"+ show CodeGen = "Code generation"+ show LambdaGen{} = "Lambda generation"+ show (Concrete Nothing) = "Concrete evaluation with random values"+ show (Concrete (Just (True, _))) = "Concrete evaluation during model validation for sat"+ show (Concrete (Just (False, _))) = "Concrete evaluation during model validation for prove"++-- | Is this a CodeGen run? (i.e., generating code)+isCodeGenMode :: State -> IO Bool+isCodeGenMode State{runMode} = do rm <- readIORef runMode+ pure $ case rm of+ Concrete{} -> False+ SMTMode{} -> False+ LambdaGen{} -> False+ CodeGen -> True++-- | The state in query mode, i.e., additional context+data IncState = IncState { rNewInps :: IORef [NamedSymVar] -- always existential!+ , rNewKinds :: IORef KindSet+ , rNewConsts :: IORef CnstMap+ , rNewTbls :: IORef TableMap+ , rNewUIs :: IORef UIMap+ , rNewAsgns :: IORef SBVPgm+ , rNewConstraints :: IORef (S.Seq (Bool, [(String, String)], SV))+ }++-- | Get a new IncState+newIncState :: IO IncState+newIncState = do+ is <- newIORef []+ ks <- newIORef Set.empty+ nc <- newIORef Map.empty+ tm <- newIORef Map.empty+ ui <- newIORef Map.empty+ pgm <- newIORef (SBVPgm S.empty)+ cstrs <- newIORef S.empty+ pure IncState { rNewInps = is+ , rNewKinds = ks+ , rNewConsts = nc+ , rNewTbls = tm+ , rNewUIs = ui+ , rNewAsgns = pgm+ , rNewConstraints = cstrs+ }++-- | Get a new IncState+withNewIncState :: State -> (State -> IO a) -> IO (IncState, a)+withNewIncState st cont = do+ is <- newIncState+ R.modifyIORef' (rIncState st) (const is)+ r <- cont st+ finalIncState <- readIORef (rIncState st)+ pure (finalIncState, r)++-- | User defined inputs+type UserInputs = S.Seq NamedSymVar++-- | Internally declared+type InternInps = S.Seq NamedSymVar++-- | Entire set of names, for faster lookup+type AllInps = Set.Set Name++-- | Inputs as a record of maps and sets. See above type-synonyms for their roles.+data Inputs = Inputs { userInputs :: !UserInputs+ , internInputs :: !InternInps+ , allInputs :: !AllInps+ } deriving (Eq,Show)++-- | Inputs to a lambda-abstraction. These are quantified to handle constraints+type LambdaInputs = S.Seq (Quantifier, NamedSymVar)++-- | Semigroup instance; combining according to indexes.+instance Semigroup Inputs where+ (Inputs lui lii lai) <> (Inputs rui rii rai) = Inputs (lui <> rui) (lii <> rii) (lai <> rai)++-- | Monoid instance, we start with no maps.+instance Monoid Inputs where+ mempty = Inputs { userInputs = mempty+ , internInputs = mempty+ , allInputs = mempty+ }++-- | Modify the user-inputs field+onUserInputs :: (UserInputs -> UserInputs) -> Inputs -> Inputs+onUserInputs f inp@Inputs{userInputs} = inp{userInputs = f userInputs}++-- | Modify the internal-inputs field+onInternInputs :: (InternInps -> InternInps) -> Inputs -> Inputs+onInternInputs f inp@Inputs{internInputs} = inp{internInputs = f internInputs}++-- | Modify the all-inputs field+onAllInputs :: (AllInps -> AllInps) -> Inputs -> Inputs+onAllInputs f inp@Inputs{allInputs} = inp{allInputs = f allInputs}++-- | Add a new internal input+addInternInput :: SV -> Name -> Inputs -> Inputs+addInternInput sv nm = goAll . goIntern+ where !new = toNamedSV sv nm+ goIntern = onInternInputs (S.|> new)+ goAll = onAllInputs (Set.insert nm)++-- | Add a new user input+addUserInput :: SV -> Name -> Inputs -> Inputs+addUserInput sv nm = goAll . goUser+ where !new = toNamedSV sv nm+ goUser = onUserInputs (S.|> new) -- add to the end of the sequence+ goAll = onAllInputs (Set.insert nm)++-- | Find a user-input from its SV. Note that only level-0 vars+-- can be found this way.+lookupInput :: (a -> SV) -> SV -> S.Seq a -> Maybe a+lookupInput f sv ns+ | l == Just 0 = res+ | True = Nothing -- l != Just 0, a lambda var, whether top-level or in a scope, so we ignore+ where+ (_, l, i) = getId (swNodeId sv)+ svs = f <$> ns+ res = case S.lookup i ns of -- Nothing on negative Int or Int > length seq+ Nothing -> secondLookup+ x@(Just e) -> if sv == f e then x else secondLookup+ -- we try the fast lookup first, if the node ids don't match then+ -- we use the more expensive O (n) to find the index and the elem+ secondLookup = S.elemIndexL sv svs >>= flip S.lookup ns++-- | A defined function/value+data SMTDef = SMTDef Kind -- ^ Final kind of the definition (resulting kind, not the params)+ [String] -- ^ other definitions it refers to+ (Maybe Text) -- ^ parameter string+ (Int -> Text) -- ^ Body, in SMTLib syntax, given the tab amount+ deriving G.Data++-- | For debug purposes+instance Show SMTDef where+ show (SMTDef fk frees p body) = unlines [ "-- User defined function:"+ , "-- Final return type : " ++ show fk+ , "-- Refers to : " ++ intercalate ", " frees+ , "-- Parameters : " ++ maybe "NONE" T.unpack p+ , "-- Body : "+ , T.unpack (body 2)+ ]++-- | NFData instance for SMTDef+instance NFData SMTDef where+ rnf (SMTDef fk frees params body) = rnf fk `seq` rnf frees `seq` rnf params `seq` rnf body++-- | Compare two SMTDef values for semantic equality.+-- The body is @(Int -> Text)@ where @Int@ is indentation; we compare rendered output at indent 0.+smtDefEq :: SMTDef -> SMTDef -> Bool+smtDefEq (SMTDef k1 refs1 params1 body1) (SMTDef k2 refs2 params2 body2)+ = k1 == k2 && refs1 == refs2 && params1 == params2 && body1 0 == body2 0++-- | Error for conflicting smtFunction definitions with the same name.+conflictError :: String -> a+conflictError nm = error $ unlines [ ""+ , "*** Data.SBV: Function '" ++ nm ++ "' defined with conflicting bodies."+ , "***"+ , "*** Two calls to smtFunction (or related) used the name '" ++ nm ++ "'"+ , "*** but with different definitions. This would generate conflicting"+ , "*** SMTLib define-fun-rec declarations."+ , "***"+ , "*** Please use a unique name for each distinct function."+ ]++-- | Information about a compiled lambda body, used for measure verification.+data LambdaInfo = LambdaInfo+ { liAssignments :: S.Seq (SV, SBVExpr) -- ^ The expression DAG+ , liParams :: [(Quantifier, SV)] -- ^ Formal parameters with quantifier+ , liOutput :: SV -- ^ The output node+ , liConsts :: [(SV, CV)] -- ^ Constants used+ }++-- | The state of the symbolic interpreter+data State = State { sbvContext :: SBVContext+ , pathCond :: SVal -- ^ kind KBool+ , stCfg :: SMTConfig+ , startTime :: UTCTime+ , rProgInfo :: IORef ProgInfo+ , runMode :: IORef SBVRunMode+ , rIncState :: IORef IncState+ , rCInfo :: IORef [(String, CV)]+ , rObservables :: IORef (S.Seq (Name, CV -> Bool, SV))+ , 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)+ , rinps :: IORef Inputs+ , rlambdaInps :: IORef LambdaInputs+ , rConstraints :: IORef (S.Seq (Bool, [(String, String)], SV))+ , rPartitionVars :: IORef [String]+ , routs :: IORef [SV]+ , rtblMap :: IORef TableMap+ , spgm :: IORef SBVPgm+ , rconstMap :: IORef CnstMap+ , rexprMap :: IORef ExprMap+ , rUIMap :: IORef UIMap+ , rUserFuncs :: IORef (Map.Map String (Set.Set Int, Maybe Int)) -- Functions with explicit code generation; maps name to (verified StableName hashes, lambda level at first compilation)+ , rCompilingFuncs :: IORef (Set.Set String) -- Functions currently being compiled (used to detect recursive self-calls vs. genuine conflicts)+ , rCgMap :: IORef CgMap+ , rDefns :: IORef (Map.Map String (SMTDef, SBVType))+ , rMeasureChecks :: IORef [(String, Bool, SMTConfig -> IO ())] -- Measure checks for recursive functions. Bool is True for productive (guarded), False for terminating.+ , rFuncLambdaInfos :: IORef (Map.Map String LambdaInfo) -- LambdaInfo for all smtFunction definitions, used for mutual recursion checking+ , rSkipMeasureChecks :: IORef Bool -- If True, skip measure checking (used by TP and checker itself)+ , rNoTermCheckFunctions :: IORef (Set.Set String) -- Functions defined with smtFunctionNoTermination (no termination check)+ , rSMTOptions :: IORef [SMTOption]+ , rOptGoals :: IORef [Objective (SV, SV)]+ , rAsserts :: IORef [(String, Maybe CallStack, SV)]+ , rOutstandingAsserts :: IORef Bool -- Did we send an assert after the last check-sat call?+ , rSVCache :: IORef (Cache SV)+ , rQueryState :: IORef (Maybe QueryState)+ , parentState :: Maybe State -- Pointer to our parent if we're in a sublevel+ }++-- | Chase to the root state. No infinite chains!+getRootState :: State -> State+getRootState st = maybe st getRootState (parentState st)++-- NFData is a bit of a lie, but it's sufficient, most of the content is iorefs that we don't want to touch+instance NFData State where+ rnf State{} = ()++-- | Get the current path condition+getSValPathCondition :: State -> SVal+getSValPathCondition = pathCond++-- | Extend the path condition with the given test value.+extendSValPathCondition :: State -> (SVal -> SVal) -> State+extendSValPathCondition st f = st{pathCond = f (pathCond st)}++-- | Are we running in proof mode?+inSMTMode :: State -> IO Bool+inSMTMode State{runMode} = do rm <- readIORef runMode+ pure $ case rm of+ CodeGen -> False+ LambdaGen{} -> False+ Concrete{} -> False+ SMTMode{} -> True++-- | The "Symbolic" value. Either a constant (@Left@) or a symbolic+-- value (@Right Cached@). Note that caching is essential for making+-- sure sharing is preserved.+data SVal = SVal !Kind !(Either CV (Cached SV))++-- | Kind instance for SVal simply passes the kind out+instance HasKind SVal where+ kindOf (SVal k _) = k++-- Show instance for t'SVal'. Not particularly "desirable", but will do if needed+-- NB. We do not show the type info on constant KBool values, since there's no+-- implicit "fromBoolean" applied to Booleans in Haskell; and thus a statement+-- of the form "True :: SBool" is just meaningless. (There should be a fromBoolean!)+instance Show SVal where+ show (SVal KBool (Left c)) = showCV False c+ show (SVal k (Left c)) = showCV False c ++ " :: " ++ show k+ show (SVal k (Right _)) = "<symbolic> :: " ++ show k++-- | Things we do not support in interactive mode, at least for now!+noInteractive :: [String] -> a+noInteractive ss = error $ unlines $ ""+ : "*** Data.SBV: Unsupported interactive/query mode feature."+ : map ("*** " ++) ss+ ++ ["*** Data.SBV: Please report this as a feature request!"]++-- | Things we do not support in interactive mode, nor we ever intend to+noInteractiveEver :: [String] -> a+noInteractiveEver ss = error $ unlines $ ""+ : "*** Data.SBV: Unsupported interactive/query mode feature."+ : map ("*** " ++) ss++-- | Modification of the state, but carefully handling the interactive tasks.+-- Note that the state is always updated regardless of the mode, but we get+-- to also perform extra operation in interactive mode. (Typically error out, but also simply+-- ignore if it has no impact.)+modifyState :: State -> (State -> IORef a) -> (a -> a) -> IO () -> IO ()+modifyState st@State{runMode} field update interactiveUpdate = do+ R.modifyIORef' (field st) update+ rm <- readIORef runMode+ case rm of+ SMTMode _ IRun _ _ -> interactiveUpdate+ _ -> pure ()++-- | Modify the incremental state+modifyIncState :: State -> (IncState -> IORef a) -> (a -> a) -> IO ()+modifyIncState State{rIncState} field update = do+ incState <- readIORef rIncState+ R.modifyIORef' (field incState) update++-- | Add an observable+recordObservable :: State -> Text -> (CV -> Bool) -> SV -> IO ()+recordObservable st nm chk sv = modifyState st rObservables (S.|> (nm, chk, sv)) (pure ())++-- | Increment the variable counter+incrementInternalCounter :: State -> IO Int+incrementInternalCounter st = do ctr <- readIORef (rctr st)+ modifyState st rctr (+1) (pure ())+ pure ctr+{-# INLINE incrementInternalCounter #-}++-- | Increment the fresh-var counter+incrementFreshNameCounter :: State -> IO Int+incrementFreshNameCounter st = do ctr <- readIORef (freshNameCtr st)+ modifyState st freshNameCtr (+1) (pure ())+ pure 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++-- | A newtype wrapper for uninterpreted function names. We distinguish between user names and those of constructors+data UIName = UIGiven String -- ^ Full name+ | UIADT ADTOp -- ^ The name of an ADT operation based on the constructor++-- | Uninterpreted constants and functions. An uninterpreted constant is+-- a value that is indexed by its name. The only property the prover assumes+-- about these values are that they are equivalent to themselves; i.e., (for+-- functions) they return the same results when applied to same arguments.+-- We support uninterpreted-functions as a general means of black-box'ing+-- operations that are /irrelevant/ for the purposes of the proof; i.e., when+-- the proofs can be performed without any knowledge about the function itself.+svUninterpreted :: Kind -> UIName -> UICodeKind -> [SVal] -> SVal+svUninterpreted k nm code args = svUninterpretedGen k nm code args Nothing++svUninterpretedNamedArgs :: Kind -> UIName -> UICodeKind -> [(SVal, String)] -> SVal+svUninterpretedNamedArgs k nm code args = svUninterpretedGen k nm code (map fst args) (Just (map snd args))++svUninterpretedGen :: Kind -> UIName -> UICodeKind -> [SVal] -> Maybe [String] -> SVal+svUninterpretedGen k nm code args mbArgNames = SVal k $ Right $ cache result+ where result st = do let ty = SBVType (map kindOf args ++ [k])+ op <- newUninterpreted st nm mbArgNames ty code+ sws <- mapM (svToSV st) args+ mapM_ forceSVArg sws+ newExpr st k $ SBVApp op sws++-- | Create a new value, 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 Op+newUninterpreted st uiName mbArgNames t uiCode = do++ let (adtOp, candName) = case uiName of+ UIGiven n -> (False, n)+ UIADT o -> case o of+ ADTConstructor n _ -> (True, T.unpack n)+ ADTTester n _ -> (True, T.unpack n)+ ADTAccessor n _ -> (True, T.unpack n)++ -- determine the final name. We leave constructors alone.+ let nm = case () of+ () | "__internal_sbv_" `isPrefixOf` candName -> candName -- internal names go thru+ | adtOp -> candName -- ADT names go thru+ | True -> barify candName -- surround with bars if not legitimate in SMTLib++ extraComment = case uiName of+ UIGiven n | nm /= n -> " (Given: " ++ n ++ ")"+ _ -> ""++ -- Check if reserved:+ when (isReserved nm) $+ error $ unlines [ ""+ , "*** Data.SBV: User given name " ++ show nm ++ " is a reserved name in SMTLib."+ , "***"+ , "*** Please use a different name to avoid collisions."+ ]++ isCurried <- case uiCode of+ UINone c -> pure c+ UISMT d -> do -- Check for conflicting definitions with the same name+ defs <- readIORef (rDefns st)+ case Map.lookup nm defs of+ Just (oldDef, _)+ | not (smtDefEq d oldDef)+ -> conflictError nm+ _ -> pure ()+ modifyState st rDefns (Map.insert nm (d, t))+ $ noInteractive [ "Defined functions (smtFunction):"+ , " Name: " ++ nm ++ extraComment+ , " Type: " ++ show t+ , ""+ , "You should explicitly register these functions by calling"+ , "the function 'registerFunction' on them before starting the query section."+ ]+ pure True+ UICgC c -> -- No need to record the code in interactive mode: CodeGen doesn't use interactive+ do modifyState st rCgMap (Map.insert nm c) (pure ())+ pure True++ let checkType :: SBVType -> r -> r+ checkType t' cont+ | t /= t' = error $ "Uninterpreted constant " ++ show nm ++ extraComment ++ " used at incompatible types\n"+ ++ " Current type : " ++ show t ++ "\n"+ ++ " Previously used at: " ++ show t'+ | True = cont++ -- If we're not a constructor, register it:+ unless adtOp $ do+ uiMap <- readIORef (rUIMap st)+ case nm `Map.lookup` uiMap of+ Just (_, _, t') -> checkType t' (pure ())+ Nothing -> modifyState st rUIMap (Map.insert nm (isCurried, mbArgNames, t))+ $ modifyIncState st rNewUIs+ (\newUIs -> case nm `Map.lookup` newUIs of+ Just (_, _, t') -> checkType t' newUIs+ Nothing -> Map.insert nm (isCurried, mbArgNames, t) newUIs)++ pure $ let tnm = T.pack nm+ in case uiName of+ UIGiven{} -> Uninterpreted tnm+ UIADT (ADTConstructor _ k) -> ADTOp (ADTConstructor tnm k)+ UIADT (ADTTester _ k) -> ADTOp (ADTTester tnm k)+ UIADT (ADTAccessor _ k) -> ADTOp (ADTAccessor tnm k)++-- | Add a new sAssert based constraint+addAssertion :: State -> Maybe CallStack -> String -> SV -> IO ()+addAssertion st cs msg cond = modifyState st rAsserts ((msg, cs, cond):)+ $ noInteractive [ "Named assertions (sAssert):"+ , " Tag: " ++ msg+ , " Loc: " ++ maybe "Unknown" show cs+ ]++-- | Create an internal variable, which acts as an input but isn't visible to the user.+-- Such variables are existentially quantified in a SAT context, and universally quantified+-- in a proof context.+newInternalVariable :: State -> Kind -> IO SV+newInternalVariable st k = do NamedSymVar sv nm <- newSV st k+ let n = "__internal_sbv_" <> nm+ v = NamedSymVar sv n+ modifyState st rinps (addUserInput sv n) $ modifyIncState st rNewInps (v :)+ pure sv+{-# INLINE newInternalVariable #-}++-- | Create a variable to be used in a constraint-expression+quantVar :: Quantifier -> State -> Kind -> IO SV+quantVar q st k = do v@(NamedSymVar sv _) <- newSV st k+ modifyState st rlambdaInps (S.|> (q, v)) (pure ())+ pure sv+{-# INLINE quantVar #-}++-- | Create a variable to be used in a lambda-expression+lambdaVar :: State -> Kind -> IO SV+lambdaVar = quantVar ALL+{-# INLINE lambdaVar #-}++-- | Create a new SV+newSV :: State -> Kind -> IO NamedSymVar+newSV st k = do ctr <- incrementInternalCounter st+ ll <- readIORef (rLambdaLevel st)+ let sv = SV k (NodeId (sbvContext st, ll, ctr))+ registerKind st k+ pure $ NamedSymVar sv $ showText sv+{-# INLINE newSV #-}++-- | Register a new kind with the system, used for uninterpreted sorts.+-- NB: Is it safe to have new kinds in query mode? It could be that+-- the new kind might introduce a constraint that effects the logic. For+-- instance, if we're seeing 'Double' for the first time and using a BV+-- logic, then things would fall apart. But this should be rare, and hopefully+-- the success-response checking mechanism will catch the rare cases where this+-- is an issue. In either case, the user can always arrange for the right+-- logic by calling 'Data.SBV.setLogic' appropriately, so it seems safe to just+-- allow for this.+registerKind :: State -> Kind -> IO ()+registerKind st k+ | KADT sortName _ _ <- k, isReserved sortName+ = error $ "SBV: " ++ show sortName ++ " is a reserved sort; please use a different name."+ | True+ = do -- Adding a kind to the incState is tricky; we only need to add it+ -- * If it's an uninterpreted sort that's not already in the general state+ -- * OR If it's a tuple-sort whose cardinality isn't already in the general state+ -- * OR If it's a list that's not already in the general state (so we can send the flatten commands)++ existingKinds <- readIORef (rUsedKinds st)++ -- For ADTs we need to make sure we haven't added it before+ let adtNameExists s = any (\case KADT s' _ _ -> s == s'; _ -> False) existingKinds++ adtExists = case k of+ KADT s _ _ -> adtNameExists s+ _ -> False++ unless adtExists $+ modifyState st rUsedKinds (Set.insert k) $ do++ -- Why do we discriminate here? Because the incremental context is sensitive to the+ -- order: In particular, if an uninterpreted kind is already in there, we don't+ -- want to re-add because double-declaration would be wrong. See 'cvtInc' for details.+ let needsAdding = case k of+ KADT s _ _ -> not (adtNameExists s)+ KList{} -> k `Set.notMember` existingKinds+ KTuple nks -> not $ any (\case KTuple oks -> length nks == length oks; _ -> False) existingKinds+ _ -> False++ when needsAdding $ modifyIncState st rNewKinds (Set.insert k)++ -- Don't forget to register subkinds!+ case k of+ KVar {} -> pure ()+ KBool {} -> pure ()+ KBounded {} -> pure ()+ KUnbounded{} -> pure ()+ KReal {} -> pure ()+ KFloat {} -> pure ()+ KDouble {} -> pure ()+ KFP {} -> pure ()+ KRational {} -> pure ()+ KChar {} -> pure ()+ KString {} -> pure ()++ KApp _ ks -> mapM_ (registerKind st) ks+ KADT _ pks cks -> mapM_ (registerKind st) (map snd pks ++ concatMap snd cks)+ KList ek -> registerKind st ek+ KSet ek -> registerKind st ek+ KTuple eks -> mapM_ (registerKind st) eks+ KArray k1 k2 -> mapM_ (registerKind st) [k1, k2]++-- | Register a new label with the system, making sure they are unique and have no '|'s in them+registerLabel :: String -> State -> String -> IO ()+registerLabel whence st nm+ | isReserved nm+ = err "is a reserved string; please use a different name."+ | '|' `elem` nm+ = err "contains the character `|', which is not allowed!"+ | '\\' `elem` nm+ = err "contains the character `\\', which is not allowed!"+ | True+ = do old <- readIORef $ rUsedLbls st+ if nm `Set.member` old+ then err "is used multiple times. Please do not use duplicate names!"+ else modifyState st rUsedLbls (Set.insert nm) (pure ())++ where err w = error $ "SBV (" ++ whence ++ "): " ++ show nm ++ " " ++ w++-- | Create a new constant; hash-cons as necessary+newConst :: State -> CV -> IO SV+newConst st c = do+ constMap <- readIORef (rconstMap st)+ case c `Map.lookup` constMap of+ -- NB. Unlike in 'newExpr', we don't have to make sure the returned sv+ -- has the kind we asked for, because the constMap stores the full CV+ -- which already has a kind field in it.+ Just sv -> pure sv+ Nothing -> do (NamedSymVar sv _) <- newSV st (kindOf c)+ let ins = Map.insert c sv+ modifyState st rconstMap ins $ modifyIncState st rNewConsts ins+ pure sv+{-# INLINE newConst #-}++-- | Create a new table; hash-cons as necessary+getTableIndex :: State -> Kind -> Kind -> [SV] -> IO Int+getTableIndex st at rt elts = do+ let key = (at, rt, elts)+ tblMap <- readIORef (rtblMap st)+ case key `Map.lookup` tblMap of+ Just i -> pure i+ _ -> do let i = Map.size tblMap+ upd = Map.insert key i+ modifyState st rtblMap upd $ modifyIncState st rNewTbls upd+ pure i++-- | Create a new expression; hash-cons as necessary+newExpr :: State -> Kind -> SBVExpr -> IO SV+newExpr st k app = do+ let e = reorder app+ exprMap <- readIORef (rexprMap st)+ case e `Map.lookup` exprMap of+ -- NB. Check to make sure that the kind of the hash-consed value+ -- is the same kind as we're requesting. This might look unnecessary,+ -- at first, but `svSign` and `svUnsign` rely on this as we can+ -- get the same expression but at a different type. See+ -- <http://github.com/GaloisInc/cryptol/issues/566> as an example.+ Just sv | kindOf sv == k -> pure sv+ _ -> do (NamedSymVar sv _) <- newSV st k+ checkConsistent sv e+ let append (SBVPgm xs) = SBVPgm (xs S.|> (sv, e))+ modifyState st spgm append $ modifyIncState st rNewAsgns append+ modifyState st rexprMap (Map.insert e sv) (pure ())+ pure sv+{-# INLINE newExpr #-}++-- | In rare cases, we can get a context mismatch; so make sure the expression is well-formed.+-- 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, _, _)) = lhs+ check (SV _ (NodeId (rhsContext, _, _)))+ | lhsContext `compatibleContext` rhsContext+ = pure ()+ | True+ = contextMismatchError lhsContext rhsContext+{-# INLINE checkConsistent #-}++-- | Are these compatible contexts? Either the same, or one of them is global+compatibleContext :: SBVContext -> SBVContext -> Bool+compatibleContext c1 c2 = c1 == c2 || c1 == globalSBVContext || c2 == globalSBVContext+{-# INLINE compatibleContext #-}++-- | Convert a symbolic value to an internal SV+svToSV :: State -> SVal -> IO SV+svToSV st (SVal _ (Left c)) = newConst st c+svToSV st (SVal _ (Right f)) = uncache f st++-- | Generalization of 'Data.SBV.svToSymSV'+svToSymSV :: MonadSymbolic m => SVal -> m SV+svToSymSV sbv = do st <- symbolicEnv+ liftIO $ svToSV st sbv++-------------------------------------------------------------------------+-- * Symbolic Computations+-------------------------------------------------------------------------+-- | A Symbolic computation. Represented by a reader monad carrying the+-- state of the computation, layered on top of IO for creating unique+-- references to hold onto intermediate results.++-- | Computations which support symbolic operations+class MonadIO m => MonadSymbolic m where+ symbolicEnv :: m State++ default symbolicEnv :: (MonadTrans t, MonadSymbolic m', m ~ t m') => m State+ symbolicEnv = lift symbolicEnv++instance MonadSymbolic m => MonadSymbolic (ExceptT e m)+instance MonadSymbolic m => MonadSymbolic (MaybeT m)+instance MonadSymbolic m => MonadSymbolic (ReaderT r m)+instance MonadSymbolic m => MonadSymbolic (SS.StateT s m)+instance MonadSymbolic m => MonadSymbolic (LS.StateT s m)+instance (MonadSymbolic m, Monoid w) => MonadSymbolic (SW.WriterT w m)+instance (MonadSymbolic m, Monoid w) => MonadSymbolic (LW.WriterT w m)++-- | A generalization of 'Data.SBV.Symbolic'.+newtype SymbolicT m a = SymbolicT { runSymbolicT :: ReaderT State m a }+ deriving newtype ( Applicative, Functor, Monad, MonadIO, MonadTrans+ , MonadError e, MonadState s, MonadWriter w+ , MonadFail+ )++-- | `MonadSymbolic` instance for `SymbolicT m`+instance MonadIO m => MonadSymbolic (SymbolicT m) where+ symbolicEnv = SymbolicT ask++-- | Map a computation over the symbolic transformer.+mapSymbolicT :: (ReaderT State m a -> ReaderT State n b) -> SymbolicT m a -> SymbolicT n b+mapSymbolicT f = SymbolicT . f . runSymbolicT+{-# INLINE mapSymbolicT #-}++-- Have to define this one by hand, because we use ReaderT in the implementation+instance MonadReader r m => MonadReader r (SymbolicT m) where+ ask = lift ask+ local f = mapSymbolicT $ mapReaderT $ local f++-- | 'Symbolic' is specialization of t'SymbolicT' to the `IO` monad. Unless you are using+-- transformers explicitly, this is the type you should prefer.+type Symbolic = SymbolicT IO++-- | Create a symbolic value, based on the quantifier we have. If an+-- explicit quantifier is given, we just use that. If not, then we+-- pick the quantifier appropriately based on the run-mode.+-- @randomCV@ is used for generating random values for this variable+-- when used for @quickCheck@ or 'Data.SBV.Tools.GenTest.genTest' purposes.+svMkSymVar :: VarContext -> Kind -> Maybe String -> State -> IO SVal+svMkSymVar = svMkSymVarGen False++-- | Create an existentially quantified tracker variable+svMkTrackerVar :: Kind -> String -> State -> IO SVal+svMkTrackerVar k nm = svMkSymVarGen True (NonQueryVar (Just EX)) k (Just nm)++-- | Generalization of 'Data.SBV.sWordN'+sWordN :: MonadSymbolic m => Int -> String -> m SVal+sWordN w nm = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded False w) (Just nm)++-- | Generalization of 'Data.SBV.sWordN_'+sWordN_ :: MonadSymbolic m => Int -> m SVal+sWordN_ w = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded False w) Nothing++-- | Generalization of 'Data.SBV.sIntN'+sIntN :: MonadSymbolic m => Int -> String -> m SVal+sIntN w nm = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded True w) (Just nm)++-- | Generalization of 'Data.SBV.sIntN_'+sIntN_ :: MonadSymbolic m => Int -> m SVal+sIntN_ w = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded True w) Nothing++-- | Create a symbolic value, based on the quantifier we have. If an+-- explicit quantifier is given, we just use that. If not, then we+-- pick the quantifier appropriately based on the run-mode.+-- @randomCV@ is used for generating random values for this variable+-- when used for @quickCheck@ or 'Data.SBV.Tools.GenTest.genTest' purposes.+svMkSymVarGen :: Bool -> VarContext -> Kind -> Maybe String -> State -> IO SVal+svMkSymVarGen isTracker varContext k mbNm st = do+ registerKind st k++ rm <- readIORef (runMode st)++ let varInfo = case mbNm of+ Nothing -> "While defining a variable of type " ++ show k+ Just nm -> "While defining: " ++ nm ++ " :: " ++ show k++ disallow what = error $ unlines [ "*** Data.SBV: Unsupported: " ++ what+ , "***"+ , "*** " ++ varInfo+ , "*** "+ , "*** In mode: " ++ show rm+ ]++ (isQueryVar, mbQ) = case varContext of+ NonQueryVar mq -> (False, mq)+ QueryVar -> (True, Just EX)++ mkS q = do (NamedSymVar sv internalName) <- newSV st k+ let nm = maybe internalName T.pack mbNm+ introduceUserName st (isQueryVar, isTracker) nm k q sv++ mkC cv = do modifyState st rCInfo ((fromMaybe "_" mbNm, cv):) (pure ())+ pure $ SVal k (Left cv)++ case (mbQ, rm) of+ (Just q, SMTMode{} ) -> mkS q+ (Nothing, SMTMode _ _ isSAT _) -> mkS (if isSAT then EX else ALL)++ (Just EX, CodeGen{}) -> disallow "Existentially quantified variables"+ (_ , CodeGen) -> mkS ALL -- code generation, pick universal++ (Just EX, Concrete Nothing) -> disallow "Existentially quantified variables"+ (_ , Concrete Nothing) -> randomCV k >>= mkC++ (Just EX, LambdaGen{}) -> disallow "Existentially quantified variables"+ (_, LambdaGen{}) -> mkS ALL++ -- Model validation:+ (_ , Concrete (Just (_isSat, env))) -> do+ let bad why conc = error $ unlines [ ""+ , "*** Data.SBV: " ++ why+ , "***"+ , "*** To turn validation off, use `cfg{validateModel = False}`"+ , "***"+ , "*** " ++ conc+ ]++ report = "Please report this as a bug in SBV!"++ (NamedSymVar sv internalName) <- newSV st k++ let nm = maybe internalName T.pack mbNm+ nsv = NamedSymVar sv nm++ -- Ignore the context equivalence check here. When validating, we are in a different+ -- context; so they won't match+ same (NamedSymVar (SV _ (NodeId (_, ll1, li1))) _)+ (NamedSymVar (SV _ (NodeId (_, ll2, li2))) _) = (ll1, li1) == (ll2, li2)++ cv = case [v | (nsv', v) <- env, nsv `same` nsv'] of+ [] -> if isTracker+ then -- The sole purpose of a tracker variable is to send the optimization+ -- directive to the solver, so we can name "expressions" that are minimized+ -- or maximized. There will be no constraints on these when we are doing+ -- the validation; in fact they will not even be used anywhere during a+ -- validation run. So, simply push a zero value that inhabits all metrics.+ mkConstCV k (0::Integer)+ else bad ("Cannot locate variable: " ++ show (nsv, k)) report+ [c] -> c+ r -> bad ( "Found multiple matching values for variable: " ++ show nsv+ ++ "\n*** " ++ show r) report++ mkC cv++-- | Introduce a new user name. We simply append a suffix if we have seen this variable before.+introduceUserName :: State -> (Bool, Bool) -> Text -> Kind -> Quantifier -> SV -> IO SVal+introduceUserName st@State{runMode} (isQueryVar, isTracker) nmOrig k q sv = do+ old <- allInputs <$> readIORef (rinps st)++ let nm = mkUnique nmOrig old++ -- If this is not a query variable and we're in a query, reject it.+ -- See https://github.com/LeventErkok/sbv/issues/554 for the rationale.+ -- In theory, it should be possible to support this, but fixing it is+ -- rather costly as we'd have to track the regular updates and sync the+ -- incremental state appropriately. Instead, we issue an error message+ -- and ask the user to obey the query mode rules.+ rm <- readIORef runMode+ case rm of+ SMTMode _ IRun _ _ | not isQueryVar -> noInteractiveEver [ "Adding a new input variable in query mode: " ++ show nm+ , ""+ , "Hint: Use freshVar/freshVar_ for introducing new inputs in query mode."+ ]+ _ -> pure ()++ if isTracker && q == ALL+ then error $ "SBV: Impossible happened! A universally quantified tracker variable is being introduced: " ++ show nm+ else do let newInp olds = case q of+ EX -> toNamedSV sv nm : olds+ ALL -> noInteractive [ "Adding a new universally quantified variable: "+ , " Name : " ++ show nm+ , " Kind : " ++ show k+ , " Quantifier: Universal"+ , " Node : " ++ show sv+ , "Only existential variables are supported in query mode."+ ]+ if isTracker+ then modifyState st rinps (addInternInput sv nm)+ $ noInteractive ["Adding a new tracker variable in interactive mode: " ++ show nm]+ else modifyState st rinps (addUserInput sv nm)+ $ modifyIncState st rNewInps newInp+ pure $ SVal k $ Right $ cache (const (pure sv))++ where -- The following can be rather slow if we keep reusing the same prefix, but I doubt it'll be a problem in practice+ -- Also, the following will fail if we span the range of integers without finding a match, but your computer would+ -- die way ahead of that happening if that's the case!+ mkUnique :: T.Text -> Set.Set Name -> T.Text+ mkUnique prefix names = case dropWhile (`Set.member` names) (prefix : [prefix <> "_" <> showText i | i <- [(0::Int)..]]) of+ h:_ -> h+ _ -> error $ "mkUnique: Impossible happened! Couldn't get a unique name for " ++ show (prefix, names)++-- | Create a new state+mkNewState :: MonadIO m => SMTConfig -> SBVRunMode -> m State+mkNewState cfg currentRunMode = liftIO $ do+ currTime <- getCurrentTime+ progInfo <- newIORef ProgInfo { hasQuants = False+ , progSpecialRels = []+ , progTransClosures = []+ }+ 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+ Concrete{} -> Just 0+ LambdaGen mbi -> mbi+ cInfo <- newIORef []+ observes <- newIORef mempty+ pgm <- newIORef (SBVPgm S.empty)+ emap <- newIORef Map.empty+ cmap <- newIORef Map.empty+ inps <- newIORef mempty+ lambdaInps <- newIORef mempty+ outs <- newIORef []+ tables <- newIORef Map.empty+ userFuncs <- newIORef Map.empty+ compilingFuncs <- newIORef Set.empty+ uis <- newIORef Map.empty+ cgs <- newIORef Map.empty+ defns <- newIORef Map.empty+ measureChecks <- newIORef []+ funcLambdaInfos <- newIORef Map.empty+ skipMeasureChecks <- newIORef False+ noTermCheckFuncs <- newIORef Set.empty+ swCache <- newIORef IMap.empty+ usedKinds <- newIORef Set.empty+ usedLbls <- newIORef Set.empty+ cstrs <- newIORef S.empty+ pvs <- newIORef []+ smtOpts <- newIORef []+ optGoals <- newIORef []+ asserts <- newIORef []+ outstandingAsserts <- newIORef False+ istate <- newIORef =<< newIncState+ qstate <- newIORef Nothing+ ctx <- genSBVContext+ pure $ State { sbvContext = ctx+ , runMode = rm+ , stCfg = cfg+ , startTime = currTime+ , rProgInfo = progInfo+ , pathCond = SVal KBool (Left trueCV)+ , rIncState = istate+ , rCInfo = cInfo+ , rObservables = observes+ , rctr = ctr+ , freshNameCtr = fnctr+ , rLambdaLevel = lambda+ , rUsedKinds = usedKinds+ , rUsedLbls = usedLbls+ , rinps = inps+ , rlambdaInps = lambdaInps+ , routs = outs+ , rtblMap = tables+ , spgm = pgm+ , rconstMap = cmap+ , rexprMap = emap+ , rUserFuncs = userFuncs+ , rCompilingFuncs = compilingFuncs+ , rUIMap = uis+ , rCgMap = cgs+ , rDefns = defns+ , rMeasureChecks = measureChecks+ , rFuncLambdaInfos = funcLambdaInfos+ , rSkipMeasureChecks = skipMeasureChecks+ , rNoTermCheckFunctions = noTermCheckFuncs+ , rSVCache = swCache+ , rConstraints = cstrs+ , rPartitionVars = pvs+ , rSMTOptions = smtOpts+ , rOptGoals = optGoals+ , rAsserts = asserts+ , rOutstandingAsserts = outstandingAsserts+ , rQueryState = qstate+ , parentState = Nothing+ }++-- | Generalization of 'Data.SBV.runSymbolic'+runSymbolic :: MonadIO m => SMTConfig -> SBVRunMode -> SymbolicT m a -> m (a, Result)+runSymbolic cfg currentRunMode comp = do+ st <- mkNewState cfg currentRunMode+ runSymbolicInState st comp++-- | Catch the catastrophic case of context mismatch+-- NB. We're not printing _ctx1/_ctx2 here (hence the underscored variables).+-- The reason is that they can get different values; causing test-suite failures with no helpful info.+contextMismatchError :: SBVContext -> SBVContext -> a+contextMismatchError _ctx1 _ctx2 = error $ unlines [+ "Data.SBV: Mismatched contexts detected."+ , "***"+ , "*** This happens if you call a proof-function (prove/sat/runSMT/isSatisfiable) etc."+ , "*** while another one is in execution, or use results from one such call in another."+ , "*** Please avoid such nested calls, all interactions should be from the same context."+ , "*** See https://github.com/LeventErkok/sbv/issues/71 for several examples."+ ]++-- | Run a symbolic computation in a given state+runSymbolicInState :: MonadIO m => State -> SymbolicT m a -> m (a, Result)+runSymbolicInState st (SymbolicT c) = do+ _ <- liftIO $ newConst st falseCV -- s(-2) == falseSV+ _ <- liftIO $ newConst st trueCV -- s(-1) == trueSV+ r <- runReaderT c st+ res <- liftIO $ extractSymbolicSimulationState st++ -- Check that the state wasn't clobbered in any way+ let check ctx | ctx == sbvContext st || ctx == globalSBVContext+ = pure ()+ | True+ = contextMismatchError (sbvContext st) ctx++ mapM_ check $ nubOrd $ G.universeBi res++ pure (r, res)++-- | Grab the program from a running symbolic simulation state.+extractSymbolicSimulationState :: State -> IO Result+extractSymbolicSimulationState st@State{ runMode=rrm+ , spgm=pgm, rinps=inps, rlambdaInps=linps, routs=outs, rtblMap=tables+ , rUIMap=uis, rDefns=defns+ , rAsserts=asserts, rUsedKinds=usedKinds, rCgMap=cgs, rCInfo=cInfo, rConstraints=cstrs+ , rObservables=observes, rProgInfo=progInfo+ } = do+ SBVPgm rpgm <- readIORef pgm++ rm <- readIORef rrm++ inpsO <- do Inputs{userInputs, internInputs} <- readIORef inps+ ls <- readIORef linps++ let lambdaOnly = case rm of+ SMTMode{} -> False+ CodeGen{} -> False+ Concrete{} -> False+ LambdaGen{} -> True+ topInps = (F.toList userInputs, F.toList internInputs)+ lamInps = F.toList ls++ if lambdaOnly+ then case topInps of+ ([], []) -> pure $ ResultLamInps (F.toList ls)+ (xs, ys) -> error $ unlines [ ""+ , "*** Data.SBV: Impossible happened; saw inputs in lambda mode."+ , "***"+ , "*** Inps : " ++ show xs+ , "*** Trackers: " ++ show ys+ ]+ else case lamInps of+ [] -> pure $ ResultTopInps topInps+ _ -> error $ unlines [ ""+ , "*** Data.SBV: Impossible happened; saw lambda inputs in regular mode."+ , "***"+ , "*** Params: " ++ show lamInps+ ]++ outsO <- reverse <$> readIORef outs++ let arrange (i, (at, rt, es)) = ((i, at, rt), es)++ constMap <- readIORef (rconstMap st)+ let cnsts = mapToSortedList constMap++ tbls <- map arrange . mapToSortedList <$> readIORef tables+ defnMap <- readIORef defns+ let ds = Map.toList defnMap+ definedSet = Map.keysSet defnMap+ unint <- do unints <- Map.toList <$> readIORef uis+ -- drop those that has a definition associated with it+ pure [ui | ui@(nm, _) <- unints, nm `Set.notMember` definedSet]+ knds <- readIORef usedKinds+ cgMap <- Map.toList <$> readIORef cgs++ traceVals <- reverse <$> readIORef cInfo+ observables <- fmap (\(n,f,sv) -> (T.unpack n, f, sv)) . F.toList <$> readIORef observes+ extraCstrs <- readIORef cstrs+ assertions <- reverse <$> readIORef asserts++ pinfo <- readIORef progInfo++ pure $ Result pinfo knds traceVals observables cgMap inpsO (constMap, cnsts) tbls unint ds (SBVPgm rpgm) extraCstrs assertions outsO++-- | Generalization of 'Data.SBV.addNewSMTOption'+addNewSMTOption :: MonadSymbolic m => SMTOption -> m ()+addNewSMTOption o = do st <- symbolicEnv+ liftIO $ modifyState st rSMTOptions (o:) (pure ())++-- | Generalization of 'Data.SBV.imposeConstraint'+imposeConstraint :: MonadSymbolic m => Bool -> [(String, String)] -> SVal -> m ()+imposeConstraint isSoft attrs c = do st <- symbolicEnv+ rm <- liftIO $ readIORef (runMode st)++ case rm of+ CodeGen -> error "SBV: constraints are not allowed in code-generation"+ _ -> liftIO $ do mapM_ (registerLabel "Constraint" st) [nm | (":named", nm) <- attrs]+ internalConstraint st isSoft attrs c++-- | Require a boolean condition to be true in the state. Only used for internal purposes.+internalConstraint :: State -> Bool -> [(String, String)] -> SVal -> IO ()+internalConstraint st isSoft attrs b = do v <- svToSV st b++ rm <- liftIO $ readIORef (runMode st)++ -- Are we running validation? If so, we always want to+ -- add the constraint for debug purposes. Otherwise+ -- we only add it if it's interesting; i.e., not directly+ -- true or has some attributes.+ let isValidating = case rm of+ SMTMode _ _ _ cfg -> validationRequested cfg+ CodeGen -> False+ LambdaGen{} -> False+ Concrete Nothing -> False+ Concrete (Just _) -> True -- The case when we *are* running the validation++ let c = (isSoft, attrs, v)+ interesting = v /= trueSV || not (null attrs)++ when (isValidating || interesting) $+ modifyState st rConstraints (S.|> c)+ $ modifyIncState st rNewConstraints (S.|> c)++-- | Generalization of 'Data.SBV.addSValOptGoal'+addSValOptGoal :: MonadSymbolic m => Objective SVal -> m ()+addSValOptGoal obj = do st <- symbolicEnv++ -- create the tracking variable here for the metric+ let mkGoal nm orig = liftIO $ do origSV <- svToSV st orig+ track <- svMkTrackerVar (kindOf orig) nm st+ trackSV <- svToSV st track+ pure (origSV, trackSV)++ let walk (Minimize nm v) = Minimize nm <$> mkGoal nm v+ walk (Maximize nm v) = Maximize nm <$> mkGoal nm v+ walk (AssertWithPenalty nm v mbP) = flip (AssertWithPenalty nm) mbP <$> mkGoal nm v++ !obj' <- walk obj+ liftIO $ modifyState st rOptGoals (obj' :)+ $ noInteractive [ "Adding an optimization objective:"+ , " Objective: " ++ show obj+ ]++-- | Generalization of 'Data.SBV.sObserve'+sObserve :: MonadSymbolic m => String -> SVal -> m ()+sObserve m x+ | Just bad <- checkObservableName m+ = error bad+ | True+ = do st <- symbolicEnv+ liftIO $ do xsv <- svToSV st x+ recordObservable st (T.pack m) (const True) xsv++-- | Generalization of 'Data.SBV.outputSVal'+outputSVal :: MonadSymbolic m => SVal -> m ()+outputSVal (SVal _ (Left c)) = do+ st <- symbolicEnv+ sv <- liftIO $ newConst st c+ liftIO $ modifyState st routs (sv:) (pure ())+outputSVal (SVal _ (Right f)) = do+ st <- symbolicEnv+ sv <- liftIO $ uncache f st+ liftIO $ modifyState st routs (sv:) (pure ())++---------------------------------------------------------------------------------+-- * Cached values+---------------------------------------------------------------------------------++-- | We implement a peculiar caching mechanism, applicable to the use case in+-- implementation of SBV's. Whenever we do a state based computation, we do+-- not want to keep on evaluating it in the then-current state. That will+-- produce essentially a semantically equivalent value. Thus, we want to run+-- it only once, and reuse that result, capturing the sharing at the Haskell+-- level. This is similar to the "type-safe observable sharing" work, but also+-- takes into the account of how symbolic simulation executes.+--+-- See Andy Gill's type-safe observable sharing trick for the inspiration behind+-- this technique: <http://ku-fpg.github.io/files/Gill-09-TypeSafeReification.pdf>+--+-- Note that this is *not* a general memo utility!+newtype Cached a = Cached (State -> IO a)++-- | Cache a state-based computation+cache :: (State -> IO a) -> Cached a+cache = Cached++-- | Uncache a previously cached computation+uncache :: Cached SV -> State -> IO SV+uncache = uncacheGen rSVCache++-- | Generic uncaching. Note that this is entirely safe, since we do it in the IO monad.+uncacheGen :: (State -> IORef (Cache a)) -> Cached a -> State -> IO a+uncacheGen getCache (Cached f) st = do+ let rCache = getCache st+ stored <- readIORef rCache+ sn <- f `seq` makeStableName f+ let h = hashStableName sn+ case (h `IMap.lookup` stored) >>= (sn `lookup`) of+ Just r -> pure r+ Nothing -> do r <- f st+ r `seq` R.modifyIORef' rCache (IMap.insertWith (\_ old -> (sn, r) : old) h [(sn, r)])+ pure r++-- | Representation of SMTLib Program versions. As of June 2015, we're dropping support+-- for SMTLib1, and supporting SMTLib2 only. We keep this data-type around in case+-- SMTLib3 comes along and we want to support 2 and 3 simultaneously.+data SMTLibVersion = SMTLib2+ deriving (Bounded, Enum, Eq, Show)++-- | The extension associated with the version+smtLibVersionExtension :: SMTLibVersion -> String+smtLibVersionExtension SMTLib2 = "smt2"++-- | Representation of an SMT-Lib program. The second Text are the function definitions,+-- which is *replicated* in the first one. There are cases where that we need the second part on its own.+data SMTLibPgm = SMTLibPgm SMTLibVersion Text Text++instance NFData SMTLibVersion where rnf a = a `seq` ()+instance NFData SMTLibPgm where rnf (SMTLibPgm v p d) = rnf v `seq` rnf p `seq` rnf d++instance Show SMTLibPgm where+ show (SMTLibPgm _ pgm _) = T.unpack pgm++-- | Extract the program text from an SMTLibPgm without converting to String.+smtLibPgmText :: SMTLibPgm -> Text+smtLibPgmText (SMTLibPgm _ pgm _) = pgm++-- Other Technicalities..+instance NFData GeneralizedCV where+ rnf (ExtendedCV e) = e `seq` ()+ rnf (RegularCV c) = c `seq` ()++instance NFData NamedSymVar where+ rnf (NamedSymVar s n) = rnf s `seq` rnf n++instance NFData Result where+ rnf (Result hasQuants kindInfo qcInfo obs cgs inps consts tbls uis axs pgm cstr asserts outs)+ = rnf hasQuants `seq` rnf kindInfo `seq` rnf qcInfo `seq` rnf obs `seq` rnf cgs+ `seq` rnf inps `seq` rnf consts `seq` rnf tbls+ `seq` rnf uis `seq` rnf axs `seq` rnf pgm+ `seq` rnf cstr `seq` rnf asserts `seq` rnf outs+instance NFData SV where rnf a = seq a ()+instance NFData SBVExpr where rnf a = seq a ()+instance NFData Quantifier where rnf a = seq a ()+instance NFData SBVType where rnf a = seq a ()+instance NFData SBVPgm where rnf a = seq a ()+instance NFData (Cached a) where rnf (Cached f) = f `seq` ()+instance NFData SVal where rnf (SVal x y) = rnf x `seq` rnf y++instance NFData SMTResult where+ rnf (Unsatisfiable _ m ) = rnf m+ rnf (Satisfiable _ m ) = rnf m+ rnf (DeltaSat _ p m ) = rnf m `seq` rnf p+ rnf (SatExtField _ m ) = rnf m+ rnf (Unknown _ m ) = rnf m+ rnf (ProofError _ m mr) = rnf m `seq` rnf mr++instance NFData SMTModel where+ rnf (SMTModel objs bndgs assocs uifuns) = rnf objs `seq` rnf bndgs `seq` rnf assocs `seq` rnf uifuns++instance NFData SMTScript where+ rnf (SMTScript b m) = rnf b `seq` rnf m++-- | Translation tricks needed for specific capabilities afforded by each solver+data SolverCapabilities = SolverCapabilities {+ supportsQuantifiers :: Bool -- ^ Supports SMT-Lib2 style quantifiers?+ , supportsDefineFun :: Bool -- ^ Supports define-fun construct?+ , supportsDistinct :: Bool -- ^ Supports calls to distinct?+ , supportsBitVectors :: Bool -- ^ Supports bit-vectors?+ , supportsADTs :: Bool -- ^ Supports SMT-Lib2 style uninterpreted-sorts and ADTs+ , supportsUnboundedInts :: Bool -- ^ Supports unbounded integers?+ , supportsReals :: Bool -- ^ Supports reals?+ , supportsApproxReals :: Bool -- ^ Supports printing of approximations of reals?+ , supportsDeltaSat :: Maybe String -- ^ Supports delta-satisfiability? (With given precision query)+ , supportsIEEE754 :: Bool -- ^ Supports floating point numbers?+ , supportsSets :: Bool -- ^ Supports set operations?+ , supportsOptimization :: Bool -- ^ Supports optimization routines?+ , supportsPseudoBooleans :: Bool -- ^ Supports pseudo-boolean operations?+ , supportsCustomQueries :: Bool -- ^ Supports interactive queries per SMT-Lib?+ , supportsGlobalDecls :: Bool -- ^ Supports global declarations? (Needed for push-pop.)+ , supportsDataTypes :: Bool -- ^ Supports datatypes?+ , supportsLambdas :: Bool -- ^ Does it support lambdas?+ , supportsSpecialRels :: Bool -- ^ Does it support special relations (orders, transitive closure etc.)+ , supportsDirectTesters :: Bool -- ^ Supports data-type testers without full ascription?+ , supportsFlattenedModels :: Maybe [String] -- ^ Supports flattened model output? (With given config lines.)+ }++-- | Solver configuration. See also 'Data.SBV.z3', 'Data.SBV.yices', 'Data.SBV.cvc4', 'Data.SBV.boolector', 'Data.SBV.mathSAT', etc.+-- which are instantiations of this type for those solvers, with reasonable defaults. In particular, custom configuration can be+-- created by varying those values. (Such as @z3{verbose=True}@.)+--+-- Most fields are self explanatory. The notion of precision for printing algebraic reals stems from the fact that such values does+-- not necessarily have finite decimal representations, and hence we have to stop printing at some depth. It is important to+-- emphasize that such values always have infinite precision internally. The issue is merely with how we print such an infinite+-- precision value on the screen. The field 'printRealPrec' controls the printing precision, by specifying the number of digits after+-- the decimal point. The default value is 16, but it can be set to any positive integer.+--+-- When printing, SBV will add the suffix @...@ at the end of a real-value, if the given bound is not sufficient to represent the real-value+-- exactly. Otherwise, the number will be written out in standard decimal notation. Note that SBV will always print the whole value if it+-- is precise (i.e., if it fits in a finite number of digits), regardless of the precision limit. The limit only applies if the representation+-- of the real value is not finite, i.e., if it is not rational.+--+-- The 'printBase' field can be used to print numbers in base 2, 10, or 16.+--+-- The 'crackNum' field can be used to display numbers in detail, all its bits and how they are laid out in memory. Works with all bounded number types+-- (i.e., SWord and SInt), but also with floats. It is particularly useful with floating-point numbers, as it shows you how they are laid out in+-- memory following the IEEE754 rules.+data SMTConfig = SMTConfig {+ verbose :: Bool -- ^ Debug mode+ , timing :: Timing -- ^ Print timing information on how long different phases took (construction, solving, etc.)+ , printBase :: Int -- ^ Print integral literals in this base (2, 10, and 16 are supported.)+ , printRealPrec :: Int -- ^ Print algebraic real values with this precision. (SReal, default: 16)+ , crackNum :: Bool -- ^ For each numeric value, show it in detail in the model with its bits spliced out. Good for floats.+ , crackNumSurfaceVals :: [(String, Integer)] -- ^ For crackNum: The surface representation of variables, if available+ , satCmd :: String -- ^ Usually "(check-sat)". However, users might tweak it based on solver characteristics.+ , allSatMaxModelCount :: Maybe Int -- ^ In a 'Data.SBV.allSat' call, return at most this many models. If nothing, return all.+ , allSatPrintAlong :: Bool -- ^ In a 'Data.SBV.allSat' call, print models as they are found.+ , allSatTrackUFs :: Bool -- ^ In a 'Data.SBV.allSat' call, should we try to extract values of uninterpreted functions?+ , isNonModelVar :: String -> Bool -- ^ When constructing a model, ignore variables whose name satisfy this predicate. (Default: (const False), i.e., don't ignore anything)+ , validateModel :: Bool -- ^ If set, SBV will attempt to validate the model it gets back from the solver.+ , optimizeValidateConstraints :: Bool -- ^ Validate optimization results. NB: Does NOT make sure the model is optimal, just checks they satisfy the constraints.+ , transcript :: Maybe FilePath -- ^ If Just, the entire interaction will be recorded as a playable file (for debugging purposes mostly)+ , smtLibVersion :: SMTLibVersion -- ^ What version of SMT-lib we use for the tool+ , dsatPrecision :: Maybe Double -- ^ Delta-sat precision+ , solver :: SMTSolver -- ^ The actual SMT solver.+ , extraArgs :: [String] -- ^ Extra command line arguments to pass to the solver.+ , roundingMode :: RoundingMode -- ^ Rounding mode to use for floating-point calculations. Defaults to RNE.+ , solverSetOptions :: [SMTOption] -- ^ Options to set as we start the solver+ , smtLib2Compliant :: Bool -- ^ Ask the solver to be strictly SMTLib2 compliant. (Default: True.)+ , 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.+ , firstifyUniqueLen :: Int -- ^ Unique length used for firstified higher-order function names+ , tpOptions :: TPOptions -- ^ TP specific options+ }++-- | 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)+ , printAsms :: Bool -- ^ Print assumptions as they are proven as separate steps.+ , printStats :: Bool -- ^ Print time/statistics. If quiet is True, then measureTime is ignored.+ , measuresBeingVerified :: Set.Set String -- ^ Functions whose measures are currently being verified. Used to prevent infinite+ -- recursion when a measureLemma proof uses the function whose measure is being checked.+ }++-- | Ignore internal names and those the user told us to+mustIgnoreVar :: SMTConfig -> T.Text -> Bool+mustIgnoreVar cfg s = "__internal_sbv" `T.isPrefixOf` s || isNonModelVar cfg (T.unpack s)++-- | We show the name of the solver for the config. Arguably this is misleading, but better than nothing.+instance Show SMTConfig where+ show = show . name . solver++-- | Returns true if we have to perform validation+validationRequested :: SMTConfig -> Bool+validationRequested SMTConfig{validateModel, optimizeValidateConstraints} = validateModel || optimizeValidateConstraints++-- We're just seq'ing top-level here, it shouldn't really matter. (i.e., no need to go deeper.)+instance NFData SMTConfig where+ rnf SMTConfig{} = ()++-- | A model, as returned by a solver+data SMTModel = SMTModel {+ modelObjectives :: [(String, GeneralizedCV)] -- ^ Mapping of symbolic values to objective values.+ , modelBindings :: Maybe [(NamedSymVar, CV)] -- ^ Mapping of input variables as reported by the solver. Only collected if model validation is requested.+ , modelAssocs :: [(String, CV)] -- ^ Mapping of symbolic values to constants.+ , modelUIFuns :: [(String, (Bool, SBVType, Either String ([([CV], CV)], CV)))] -- ^ Mapping of uninterpreted functions to association lists in the model.+ -- Note that an uninterpreted constant (function of arity 0) will be stored+ -- in the 'modelAssocs' field. Left is used when the function returned is too+ -- difficult for SBV to figure out what it means+ }+ deriving Show++-- | The result of an SMT solver call. Each constructor is tagged with+-- the t'SMTConfig' that created it so that further tools can inspect it+-- and build layers of results, if needed. For ordinary uses of the library,+-- this type should not be needed, instead use the accessor functions on+-- it. (Custom Show instances and model extractors.)+data SMTResult = Unsatisfiable SMTConfig (Maybe [String]) -- ^ Unsatisfiable. If unsat-cores are enabled, they will be returned in the second parameter.+ | Satisfiable SMTConfig SMTModel -- ^ Satisfiable with model+ | DeltaSat SMTConfig (Maybe String) SMTModel -- ^ Delta satisfiable with queried string if available and model+ | SatExtField SMTConfig SMTModel -- ^ Prover returned a model, but in an extension field containing Infinite/epsilon+ | Unknown SMTConfig SMTReasonUnknown -- ^ Prover returned unknown, with the given reason+ | ProofError SMTConfig [String] (Maybe SMTResult) -- ^ Prover errored out, with possibly a bogus result++-- | A script, to be passed to the solver.+data SMTScript = SMTScript {+ scriptBody :: String -- ^ Initial feed+ , scriptModel :: [String] -- ^ Continuation script, to extract results+ }++-- | An SMT engine+type SMTEngine = forall res.+ SMTConfig -- ^ current configuration+ -> State -- ^ the state in which to run the engine+ -> Text -- ^ program+ -> (State -> IO res) -- ^ continuation+ -> IO res++-- | Solvers that SBV is aware of+data Solver = ABC+ | Boolector+ | Bitwuzla+ | CVC4+ | CVC5+ | DReal+ | MathSAT+ | Yices+ | Z3+ | OpenSMT+ deriving (Show, Enum, Bounded)++-- | An SMT solver+data SMTSolver = SMTSolver {+ name :: Solver -- ^ The solver in use+ , executable :: String -- ^ The path to its executable+ , preprocess :: Text -> Text -- ^ Each line sent to the solver will be passed through this function (typically id)+ , options :: SMTConfig -> [String] -- ^ Options to provide to the solver+ , engine :: SMTEngine -- ^ The solver engine, responsible for interpreting solver output+ , capabilities :: SolverCapabilities -- ^ Various capabilities of the solver+ }++-- | Query execution context+data QueryContext = QueryInternal -- ^ Triggered from inside SBV+ | QueryExternal -- ^ Triggered from user code++-- | Show instance for 'QueryContext', for debugging purposes+instance Show QueryContext where+ show QueryInternal = "Internal Query"+ show QueryExternal = "User Query"++{- HLint ignore type FPOp "Use camelCase" -}+{- HLint ignore type PBOp "Use camelCase" -}+{- HLint ignore type OvOp "Use camelCase" -}+{- HLint ignore type NROp "Use camelCase" -}
+ Data/SBV/Core/TH.hs view
@@ -0,0 +1,142 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SBV.Core.TH+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Template Haskell utilities for extracting constructor information from+-- algebraic data types. Factored out to avoid circular dependencies.+-----------------------------------------------------------------------------++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Core.TH (+ getConstructors+ , bad+ , report+ , sbvName+ ) where++import Data.Maybe (fromMaybe)++import qualified "template-haskell" Language.Haskell.TH as TH+import "template-haskell" Language.Haskell.TH.Syntax as THS (Name(..), OccName(..), NameFlavour(..), PkgName, ModName(..), NameSpace(..))++import Language.Haskell.TH.ExpandSyns as TH++import Data.SBV.Core.Kind (smtType)++-- | Construct a TH name for a value\/function in the @sbv@ package, given+-- the fully qualified module name and the unqualified identifier. This avoids+-- importing the target module (which would create import cycles) while still+-- producing exact 'NameG' names that resolve correctly in generated TH splices.+sbvName :: String -> String -> TH.Name+sbvName modNm fnNm = THS.Name (THS.OccName fnNm) (THS.NameG THS.VarName sbvPkg (THS.ModName modNm))+ where -- Extract the package key from a known cross-module name in the sbv package+ sbvPkg :: THS.PkgName+ sbvPkg = case 'smtType of+ THS.Name _ (THS.NameG _ pkg _) -> pkg+ _ -> error "Data.SBV.Core.TH.sbvName: unexpected name flavour"++bad :: MonadFail m => String -> [String] -> m a+bad what extras = fail $ unlines $ ("mkSymbolic: " ++ what) : map (" " ++) extras++report :: String+report = "Please report this as a feature request."++-- | Collect the constructors+getConstructors :: TH.Name -> TH.Q ([TH.Name], [(TH.Name, [(Maybe TH.Name, TH.Type)])])+getConstructors typeName = do res@(_, cstrs) <- getConstructorsFromType (TH.ConT typeName)++ -- make sure accessors are unique+ let noDup [] = pure ()+ noDup (n:ns)+ | n `elem` ns = bad "Unsupported field accessor definition."+ [ "Multiply used: " ++ TH.nameBase n+ , ""+ , "SBV does not support cases where accessor fields are replicated."+ , "Please use each accessor only once."+ ]+ | True = noDup ns+ noDup [n | (_, fs) <- cstrs, (Just n, _) <- fs]++ pure res++ where getConstructorsFromType :: TH.Type -> TH.Q ([TH.Name], [(TH.Name, [(Maybe TH.Name, TH.Type)])])+ getConstructorsFromType ty = do ty' <- expandSyns ty+ case headCon ty' of+ Just (n, args) -> reifyFromHead n args+ Nothing -> bad "Not a type constructor"+ [ "Name : " ++ show typeName+ , "Type : " ++ show ty+ , "Expanded: " ++ show ty'+ ]++ headCon :: TH.Type -> Maybe (TH.Name, [TH.Type])+ headCon = go []+ where go args (TH.ConT n) = Just (n, reverse args)+ go args (TH.AppT t a) = go (a:args) t+ go args (TH.SigT t _) = go args t+ go args (TH.ParensT t) = go args t+ go _ _ = Nothing++ reifyFromHead :: TH.Name -> [TH.Type] -> TH.Q ([TH.Name], [(TH.Name, [(Maybe TH.Name, TH.Type)])])+ reifyFromHead n args = do info <- TH.reify n+ case info of+ TH.TyConI (TH.DataD _ _ tvs _ cons _) -> (map tvName tvs,) <$> mapM (expandCon (mkSubst tvs args)) cons+ TH.TyConI (TH.NewtypeD _ _ tvs _ con _) -> (map tvName tvs,) <$> mapM (expandCon (mkSubst tvs args)) [con]+ TH.TyConI (TH.TySynD _ tvs rhs) -> getConstructorsFromType (applySubst (mkSubst tvs args) rhs)+ _ -> bad "Unsupported kind"+ [ "Type : " ++ show typeName+ , "Name : " ++ show n+ , "Kind : " ++ show info+ ]++ onSnd f (a, b) = (a,) <$> f b++ expandCon :: [(TH.Name, TH.Type)] -> TH.Con -> TH.Q (TH.Name, [(Maybe TH.Name, TH.Type)])+ expandCon sub (TH.NormalC n fields) = (n,) <$> mapM (onSnd (expandSyns . applySubst sub) . (\( _,t) -> (Nothing, t))) fields+ expandCon sub (TH.RecC n fields) = (n,) <$> mapM (onSnd (expandSyns . applySubst sub) . (\(fn,_,t) -> (Just fn, t))) fields+ expandCon sub (TH.InfixC (_, t1) n (_, t2)) = (n,) <$> mapM (onSnd (expandSyns . applySubst sub)) [(Nothing, t1), (Nothing, t2)]+ {- These don't have proper correspondences in SMTLib; so ignore.+ expandCon sub (TH.ForallC _ _ c) = expandCon sub c+ expandCon sub (TH.GadtC [n] fields _) = (n,) <$> mapM (onSnd (expandSyns . applySubst sub) . (\( _,t) -> (Nothing, t))) fields+ expandCon sub (TH.RecGadtC [n] fields _) = (n,) <$> mapM (onSnd (expandSyns . applySubst sub) . (\(fn,_,t) -> (Just fn, t))) fields+ -}+ expandCon _ c = bad "Unsupported constructor form: "+ [ "Type : " ++ show typeName+ , "Constructor: " ++ show c+ , ""+ , report+ ]++ tvName :: TH.TyVarBndr TH.BndrVis -> TH.Name+ tvName (TH.PlainTV n _) = n+ tvName (TH.KindedTV n _ _) = n++ -- | Make substitution from type variables to actual args+ mkSubst :: [TH.TyVarBndr TH.BndrVis] -> [TH.Type] -> [(TH.Name, TH.Type)]+ mkSubst tvs = zip (map tvName tvs)++ -- | Apply substitution to a Type+ applySubst :: [(TH.Name, TH.Type)] -> TH.Type -> TH.Type+ applySubst sub = go+ where go (TH.VarT n) = fromMaybe (TH.VarT n) (n `lookup` sub)+ go (TH.AppT t1 t2) = TH.AppT (go t1) (go t2)+ go (TH.SigT t k) = TH.SigT (go t) k+ go (TH.ParensT t) = TH.ParensT (go t)+ go (TH.InfixT t1 n t2) = TH.InfixT (go t1) n (go t2)+ go (TH.UInfixT t1 n t2) = TH.UInfixT (go t1) n (go t2)+ go (TH.ForallT bs ctx t) = TH.ForallT bs (map goPred ctx) (go t)+ go t = t++ goPred (TH.AppT t1 t2) = TH.AppT (go t1) (go t2)+ goPred p = p
Data/SBV/Dynamic.hs view
@@ -21,8 +21,6 @@ -- *** Abstract symbolic value type SVal , HasKind(..), Kind(..), CV(..), CVal(..), cvToBool- -- *** SMT Arrays of symbolic values- , SArr, readSArr, writeSArr, mergeSArr, newSArr, eqSArr -- ** Creating a symbolic variable , Symbolic , Quantifier(..)@@ -34,7 +32,9 @@ -- *** Integer literals , svInteger, svAsInteger -- *** Float literals- , svFloat, svDouble, svFloatingPoint+ , svFloat, svDouble, svFloatingPoint, svAsFloat, svAsDouble, svAsFP+ -- *** Rounding mode literals+ , svRoundingMode, svAsRoundingMode -- *** Algebraic reals (only from rationals) , svReal, svNumerator, svDenominator -- *** Symbolic equality@@ -65,6 +65,16 @@ , svBarrelRotateLeft, svBarrelRotateRight , svWordFromBE, svWordFromLE , svBlastLE, svBlastBE+ -- *** Floating-point operations+ , svFPNaN, svFPInf, svFPZero+ , svFPFromIntegerLit, svFPFromRationalLit+ , svFPIsZero, svFPIsInfinite, svFPIsNegative, svFPIsPositive+ , svFPIsNaN, svFPIsNormal, svFPIsSubnormal+ , svFPAdd, svFPSub, svFPMul, svFPDiv, svFPRem, svFPMin, svFPMax+ , svFPFMA, svFPAbs, svFPNeg, svFPRoundToIntegral, svFPSqrt+ , svCastToFP, svCastFromFP+ , svSWord32AsFloat, svSWord64AsDouble, svSWordAsFloatingPoint+ , svFloatAsSWord32, svDoubleAsSWord64, svFloatingPointAsSWord -- ** Conditionals: Mergeable values , svIte, svLazyIte, svSymbolicMerge -- * Uninterpreted sorts, constants, and functions@@ -92,7 +102,7 @@ -- ** Programmable model extraction , genParse, getModelAssignment, getModelDictionary -- * SMT Interface: Configurations and solvers- , SMTConfig(..), SMTLibVersion(..), Solver(..), SMTSolver(..), boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, defaultSMTCfg, sbvCheckSolverInstallation, getAvailableSolvers+ , SMTConfig(..), SMTLibVersion(..), Solver(..), SMTSolver(..), boolector, bitwuzla, cvc4, cvc5, dReal, yices, z3, mathSAT, abc, defaultSolverConfig, defaultSMTCfg, sbvCheckSolverInstallation, getAvailableSolvers -- * Symbolic computations , outputSVal@@ -122,7 +132,7 @@ , compileToC, compileToCLib -- ** Compilation to SMTLib- , generateSMTBenchmark+ , generateSMTBenchmarkSat, generateSMTBenchmarkProof ) where import Control.Monad.Trans (liftIO)@@ -144,7 +154,7 @@ ) import Data.SBV.Compilers.C (compileToC, compileToCLib) -import Data.SBV.Provers.Prover (boolector, cvc4, yices, z3, mathSAT, abc, defaultSMTCfg)+import Data.SBV.Provers.Prover (boolector, bitwuzla, cvc4, cvc5, dReal, yices, z3, mathSAT, abc, defaultSMTCfg) import Data.SBV.SMT.SMT (ThmResult(..), SatResult(..), SafeResult(..), OptimizeResult(..), AllSatResult(..), genParse) import Data.SBV (sbvCheckSolverInstallation, defaultSolverConfig, getAvailableSolvers) @@ -154,7 +164,7 @@ ) import qualified Data.SBV.Core.Data as SBV (SBV(..)) import qualified Data.SBV.Core.Model as SBV (sbvQuickCheck)-import qualified Data.SBV.Provers.Prover as SBV (proveWith, satWith, safeWith, allSatWith, generateSMTBenchmark)+import qualified Data.SBV.Provers.Prover as SBV (proveWith, satWith, safeWith, allSatWith, generateSMTBenchmarkSat, generateSMTBenchmarkProof) import qualified Data.SBV.SMT.SMT as SBV (Modelable(getModelAssignment, getModelDictionary)) import Data.Time (NominalDiffTime)@@ -166,78 +176,80 @@ toSBool :: SVal -> SBV.SBool toSBool = SBV.SBV --- | Create SMT-Lib benchmarks. The first argument is the basename of the file, we will automatically--- add ".smt2" per SMT-Lib2 convention. The 'Bool' argument controls whether this is a SAT instance, i.e.,--- translate the query directly, or a PROVE instance, i.e., translate the negated query.-generateSMTBenchmark :: Bool -> Symbolic SVal -> IO String-generateSMTBenchmark isSat s = SBV.generateSMTBenchmark isSat (fmap toSBool s)+-- | Create SMT-Lib benchmark for a sat call+generateSMTBenchmarkSat :: Symbolic SVal -> IO String+generateSMTBenchmarkSat s = SBV.generateSMTBenchmarkSat (toSBool <$> s) +-- | Create SMT-Lib benchmark for a proof call+generateSMTBenchmarkProof :: Symbolic SVal -> IO String+generateSMTBenchmarkProof s = SBV.generateSMTBenchmarkProof (toSBool <$> s)+ -- | Proves the predicate using the given SMT-solver proveWith :: SMTConfig -> Symbolic SVal -> IO ThmResult-proveWith cfg s = SBV.proveWith cfg (fmap toSBool s)+proveWith cfg s = SBV.proveWith cfg (toSBool <$> s) -- | Find a satisfying assignment using the given SMT-solver satWith :: SMTConfig -> Symbolic SVal -> IO SatResult-satWith cfg s = SBV.satWith cfg (fmap toSBool s)+satWith cfg s = SBV.satWith cfg (toSBool <$> s) -- | Check safety using the given SMT-solver safeWith :: SMTConfig -> Symbolic SVal -> IO [SafeResult]-safeWith cfg s = SBV.safeWith cfg (fmap toSBool s)+safeWith cfg s = SBV.safeWith cfg (toSBool <$> s) -- | Find all satisfying assignments using the given SMT-solver allSatWith :: SMTConfig -> Symbolic SVal -> IO AllSatResult-allSatWith cfg s = SBV.allSatWith cfg (fmap toSBool s)+allSatWith cfg s = SBV.allSatWith cfg (toSBool <$> s) -- | Prove a property with multiple solvers, running them in separate threads. The -- results will be returned in the order produced. proveWithAll :: [SMTConfig] -> Symbolic SVal -> IO [(Solver, NominalDiffTime, ThmResult)]-proveWithAll cfgs s = SBV.proveWithAll cfgs (fmap toSBool s)+proveWithAll cfgs s = SBV.proveWithAll cfgs (toSBool <$> s) -- | Prove a property with multiple solvers, running them in separate -- threads. Only the result of the first one to finish will be -- returned, remaining threads will be killed. proveWithAny :: [SMTConfig] -> Symbolic SVal -> IO (Solver, NominalDiffTime, ThmResult)-proveWithAny cfgs s = SBV.proveWithAny cfgs (fmap toSBool s)+proveWithAny cfgs s = SBV.proveWithAny cfgs (toSBool <$> s) -- | Prove a property with query mode using multiple threads. Each query -- computation will spawn a thread and a unique instance of your solver to run--- asynchronously. The 'Symbolic' 'SVal' is duplicated for each thread. This+-- asynchronously. The 'Symbolic' t'SVal' is duplicated for each thread. This -- function will block until all child threads return. proveConcurrentWithAll :: SMTConfig -> Symbolic SVal -> [Query SVal] -> IO [(Solver, NominalDiffTime, ThmResult)]-proveConcurrentWithAll cfg s queries = SBV.proveConcurrentWithAll cfg queries (fmap toSBool s)+proveConcurrentWithAll cfg s queries = SBV.proveConcurrentWithAll cfg queries (toSBool <$> s) -- | Prove a property with query mode using multiple threads. Each query -- computation will spawn a thread and a unique instance of your solver to run--- asynchronously. The 'Symbolic' 'SVal' is duplicated for each thread. This+-- asynchronously. The 'Symbolic' t'SVal' is duplicated for each thread. This -- function will return the first query computation that completes, killing the others. proveConcurrentWithAny :: SMTConfig -> Symbolic SVal -> [Query SVal] -> IO (Solver, NominalDiffTime, ThmResult)-proveConcurrentWithAny cfg s queries = SBV.proveConcurrentWithAny cfg queries (fmap toSBool s)+proveConcurrentWithAny cfg s queries = SBV.proveConcurrentWithAny cfg queries (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple solvers, -- running them in separate threads. The results will be returned in -- the order produced. satWithAll :: [SMTConfig] -> Symbolic SVal -> IO [(Solver, NominalDiffTime, SatResult)]-satWithAll cfgs s = SBV.satWithAll cfgs (fmap toSBool s)+satWithAll cfgs s = SBV.satWithAll cfgs (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple solvers, -- running them in separate threads. Only the result of the first one -- to finish will be returned, remaining threads will be killed. satWithAny :: [SMTConfig] -> Symbolic SVal -> IO (Solver, NominalDiffTime, SatResult)-satWithAny cfgs s = SBV.satWithAny cfgs (fmap toSBool s)+satWithAny cfgs s = SBV.satWithAny cfgs (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple threads in query--- mode. The 'Symbolic' 'SVal' represents what is known to all child query threads.+-- mode. The 'Symbolic' t'SVal' represents what is known to all child query threads. -- Each query thread will spawn a unique instance of the solver. Only the first -- one to finish will be returned and the other threads will be killed. satConcurrentWithAny :: SMTConfig -> [Query b] -> Symbolic SVal -> IO (Solver, NominalDiffTime, SatResult)-satConcurrentWithAny cfg qs s = SBV.satConcurrentWithAny cfg qs (fmap toSBool s)+satConcurrentWithAny cfg qs s = SBV.satConcurrentWithAny cfg qs (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple threads in query--- mode. The 'Symbolic' 'SVal' represents what is known to all child query threads.+-- mode. The 'Symbolic' t'SVal' represents what is known to all child query threads. -- Each query thread will spawn a unique instance of the solver. This function -- will block until all child threads have completed. satConcurrentWithAll :: SMTConfig -> [Query b] -> Symbolic SVal -> IO [(Solver, NominalDiffTime, SatResult)]-satConcurrentWithAll cfg qs s = SBV.satConcurrentWithAll cfg qs (fmap toSBool s)+satConcurrentWithAll cfg qs s = SBV.satConcurrentWithAll cfg qs (toSBool <$> s) -- | Extract a model, the result is a tuple where the first argument (if True) -- indicates whether the model was "probable". (i.e., if the solver returned unknown.)
Data/SBV/Either.hs view
@@ -10,103 +10,86 @@ -- Symbolic coproduct, symbolic version of Haskell's 'Either' type. ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Either ( -- * Constructing sums- sLeft, sRight, liftEither+ sLeft, sRight, liftEither, SEither, sEither, sEither_, sEithers -- * Destructing sums , either -- * Mapping functions , bimap, first, second -- * Scrutinizing branches of a sum , isLeft, isRight, fromLeft, fromRight+ -- * Case analysis (for sCase quasi-quoter)+ , sCaseEither, getLeft_1, getRight_1 ) where import Prelude hiding (either) import qualified Prelude -import Data.Proxy (Proxy(Proxy))-+import Data.SBV.Client import Data.SBV.Core.Data-import Data.SBV.Core.Model () -- instances only+import Data.SBV.Core.Model (OrdSymbolic(..))+import Data.SBV.SCase (sCase) +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Prelude hiding(either) -- >>> import Data.SBV+#endif --- | Construct an @SEither a b@ from an @SBV a@+-- | Make 'Either' symbolic. -- -- >>> sLeft 3 :: SEither Integer Bool--- Left 3 :: SEither Integer Bool-sLeft :: forall a b. (SymVal a, SymVal b) => SBV a -> SEither a b-sLeft sa- | Just a <- unliteral sa- = literal (Left a)- | True- = SBV $ SVal k $ Right $ cache res- where k1 = kindOf (Proxy @a)- k2 = kindOf (Proxy @b)- k = KEither k1 k2-- res st = do asv <- sbvToSV st sa- newExpr st k $ SBVApp (EitherConstructor k1 k2 False) [asv]---- | Return 'sTrue' if the given symbolic value is 'Left', 'sFalse' otherwise---+-- Left 3 :: Either Integer Bool -- >>> isLeft (sLeft 3 :: SEither Integer Bool) -- True -- >>> isLeft (sRight sTrue :: SEither Integer Bool) -- False-isLeft :: (SymVal a, SymVal b) => SEither a b -> SBV Bool-isLeft = either (const sTrue) (const sFalse)---- | Construct an @SEither a b@ from an @SBV b@--- -- >>> sRight sFalse :: SEither Integer Bool--- Right False :: SEither Integer Bool-sRight :: forall a b. (SymVal a, SymVal b) => SBV b -> SEither a b-sRight sb- | Just b <- unliteral sb- = literal (Right b)- | True- = SBV $ SVal k $ Right $ cache res- where k1 = kindOf (Proxy @a)- k2 = kindOf (Proxy @b)- k = KEither k1 k2-- res st = do bsv <- sbvToSV st sb- newExpr st k $ SBVApp (EitherConstructor k1 k2 True) [bsv]---- | Return 'sTrue' if the given symbolic value is 'Right', 'sFalse' otherwise---+-- Right False :: Either Integer Bool -- >>> isRight (sLeft 3 :: SEither Integer Bool) -- False -- >>> isRight (sRight sTrue :: SEither Integer Bool) -- True-isRight :: (SymVal a, SymVal b) => SEither a b -> SBV Bool-isRight = either (const sFalse) (const sTrue)+mkSymbolic [''Either] +-- | Declare a symbolic either.+sEither :: (SymVal a, SymVal b) => String -> Symbolic (SEither a b)+sEither = free++-- | Declare a symbolic either, unnamed.+sEither_ :: (SymVal a, SymVal b) => Symbolic (SEither a b)+sEither_ = free_++-- | Declare a list of symbolic eithers.+sEithers :: (SymVal a, SymVal b) => [String] -> Symbolic [SEither a b]+sEithers = symbolics+ -- | Construct an @SEither a b@ from an @Either (SBV a) (SBV b)@ -- -- >>> liftEither (Left 3 :: Either SInteger SBool)--- Left 3 :: SEither Integer Bool+-- Left 3 :: Either Integer Bool -- >>> liftEither (Right sTrue :: Either SInteger SBool)--- Right True :: SEither Integer Bool+-- Right True :: Either Integer Bool liftEither :: (SymVal a, SymVal b) => Either (SBV a) (SBV b) -> SEither a b liftEither = Prelude.either sLeft sRight -- | Case analysis for symbolic 'Either's. If the value 'isLeft', apply the -- first function; if it 'isRight', apply the second function. ----- >>> either (*2) (*3) (sLeft 3)+-- >>> either (*2) (*3) (sLeft (3 :: SInteger)) -- 6 :: SInteger--- >>> either (*2) (*3) (sRight 3)+-- >>> either (*2) (*3) (sRight (3 :: SInteger)) -- 9 :: SInteger -- >>> let f = uninterpret "f" :: SInteger -> SInteger -- >>> let g = uninterpret "g" :: SInteger -> SInteger@@ -119,31 +102,10 @@ -> (SBV b -> SBV c) -> SEither a b -> SBV c-either brA brB sab- | Just (Left a) <- unliteral sab- = brA $ literal a- | Just (Right b) <- unliteral sab- = brB $ literal b- | True- = SBV $ SVal kc $ Right $ cache res- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- kc = kindOf (Proxy @c)-- res st = do abv <- sbvToSV st sab-- let leftVal = SBV $ SVal ka $ Right $ cache $ \_ -> newExpr st ka $ SBVApp (EitherAccess False) [abv]- rightVal = SBV $ SVal kb $ Right $ cache $ \_ -> newExpr st kb $ SBVApp (EitherAccess True) [abv]-- leftRes = brA leftVal- rightRes = brB rightVal-- br1 <- sbvToSV st leftRes- br2 <- sbvToSV st rightRes-- -- Which branch are we in? Return the appropriate value:- onLeft <- newExpr st KBool $ SBVApp (EitherIs ka kb False) [abv]- newExpr st kc $ SBVApp Ite [onLeft, br1, br2]+either brA brB sab = [sCase| sab of+ Left x -> brA x+ Right x -> brB x+ |] -- | Map over both sides of a symbolic 'Either' at the same time --@@ -195,35 +157,7 @@ -- is unspecified, thus the SMT solver picks whatever satisfies the -- constraints, if there is one. fromLeft :: forall a b. (SymVal a, SymVal b) => SEither a b -> SBV a-fromLeft sab- | Just (Left a) <- unliteral sab- = literal a- | True- = SBV $ SVal ka $ Right $ cache res- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- kEither = KEither ka kb-- -- We play the usual trick here of creating a left value and asserting equivalence- -- under implication. This will be underspecified as required should the value- -- received be a right thing.- res st = do -- grab an internal variable and make a left out of it- e <- internalVariable st ka- es <- newExpr st kEither (SBVApp (EitherConstructor ka kb False) [e])-- -- Create the condition that it is equal to the input- ms <- sbvToSV st sab- eq <- newExpr st KBool (SBVApp Equal [es, ms])-- -- Gotta make sure we do this only when input is not right- caseRight <- sbvToSV st (isRight sab)- require <- newExpr st KBool (SBVApp Or [caseRight, eq])-- -- register the constraint:- internalConstraint st False [] $ SVal KBool $ Right $ cache $ \_ -> return require-- -- We're good to go- return e+fromLeft = getLeft_1 -- | Return the value from the right component. The behavior is undefined if -- passed a left value, i.e., it can return any value.@@ -232,42 +166,20 @@ -- 'a' :: SChar -- >>> prove $ \x -> fromRight (sRight x :: SEither Char Integer) .== (x :: SInteger) -- Q.E.D.--- >>> sat $ \x -> x .== (fromRight (sLeft (literal 'a') :: SEither Char Integer))+-- >>> sat $ \x -> x .== (fromRight (sLeft (literal 2) :: SEither Integer Char)) -- Satisfiable. Model:--- s0 = 0 :: Integer+-- s0 = 'A' :: Char -- -- Note how we get a satisfying assignment in the last case: The behavior -- is unspecified, thus the SMT solver picks whatever satisfies the -- constraints, if there is one. fromRight :: forall a b. (SymVal a, SymVal b) => SEither a b -> SBV b-fromRight sab- | Just (Right b) <- unliteral sab- = literal b- | True- = SBV $ SVal kb $ Right $ cache res- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)- kEither = KEither ka kb-- -- We play the usual trick here of creating a right value and asserting equivalence- -- under implication. This will be underspecified as required should the value- -- received be a right thing.- res st = do -- grab an internal variable and make a right out of it- e <- internalVariable st kb- es <- newExpr st kEither (SBVApp (EitherConstructor ka kb True) [e])-- -- Create the condition that it is equal to the input- ms <- sbvToSV st sab- eq <- newExpr st KBool (SBVApp Equal [es, ms])-- -- Gotta make sure we do this only when input is not left- caseLeft <- sbvToSV st (isLeft sab)- require <- newExpr st KBool (SBVApp Or [caseLeft, eq])-- -- register the constraint:- internalConstraint st False [] $ SVal KBool $ Right $ cache $ \_ -> return require+fromRight = getRight_1 - -- We're good to go- return e+-- | Custom 'OrdSymbolic' instance over 'SEither'.+instance (OrdSymbolic (SBV a), OrdSymbolic (SBV b), SymVal a, SymVal b) => OrdSymbolic (SBV (Either a b)) where+ eab .< ecd = either (\a -> either (a .<) (const sTrue) ecd)+ (\b -> either (const sFalse) (b .<) ecd)+ eab -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore module "Reduce duplication" -}
Data/SBV/Internals.hs view
@@ -17,15 +17,16 @@ -- is a very good but also a very difficult question to answer!) ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Internals ( -- * Running symbolic programs /manually/- Result(..), SBVRunMode(..), IStage(..), QueryContext(..), VarContext(..)+ Result(..), SBVRunMode(..), IStage(..), QueryContext(..), VarContext(..), SatModel(..), mkNewState -- * Solver capabilities , SolverCapabilities(..)@@ -33,8 +34,12 @@ -- * Internal structures useful for low-level programming , module Data.SBV.Core.Data + -- * Is this name reserved?+ , isReserved, UIName(..)+ -- * Operations useful for instantiating SBV type classes , genLiteral, genFromCV, CV(..), genMkSymVar, genParse, showModel, SMTModel(..), liftQRem, liftDMod, registerKind, svToSV+ , ProvableM(), SatisfiableM(), UICodeKind(..) -- * Compilation to C, extras , compileToC', compileToCLib'@@ -59,25 +64,37 @@ , addSValOptGoal , sFloatAsComparableSWord32, sDoubleAsComparableSWord64, sFloatingPointAsComparableSWord , sComparableSWord32AsSFloat, sComparableSWord64AsSDouble, sComparableSWordAsSFloatingPoint++ -- * Generalized floats+ , svFloatingPointAsSWord++ -- * Lambdas and axioms+ , lambda, lambdaStr, constraint, constraintStr, Lambda(..), Constraint(..), LambdaScope(..)++ -- * TP induction extras+ , HasInductionSchema(..), internalAxiom ) where import Control.Monad.IO.Class (MonadIO) -import Data.SBV.Core.Data+import Data.SBV.Core.Data hiding (Forall(..), Exists(..), ForallN(..), ExistsN(..), ExistsUnique(..), Skolemize(..), QNot(..))+ import Data.SBV.Core.Kind (BVIsNonZero, ValidFloat)-import Data.SBV.Core.Sized (SWord) import Data.SBV.Core.Model (genLiteral, genFromCV, genMkSymVar, liftQRem, liftDMod)-import Data.SBV.Core.Symbolic (IStage(..), QueryContext(..), MonadQuery, addSValOptGoal, registerKind, VarContext(..), svToSV)+import Data.SBV.Core.Symbolic (IStage(..), QueryContext(..), MonadQuery, addSValOptGoal, registerKind, VarContext(..), svToSV, mkNewState, UICodeKind(..), UIName(..)) -import Data.SBV.Core.Floating ( sFloatAsComparableSWord32, sDoubleAsComparableSWord64, sFloatingPointAsComparableSWord)+import Data.SBV.Core.Floating (sFloatAsComparableSWord32, sDoubleAsComparableSWord64, sFloatingPointAsComparableSWord, svFloatingPointAsSWord) import qualified Data.SBV.Core.Floating as CF (sComparableSWord32AsSFloat, sComparableSWord64AsSDouble, sComparableSWordAsSFloatingPoint) import Data.SBV.Compilers.C (compileToC', compileToCLib') import Data.SBV.Compilers.CodeGen -import Data.SBV.SMT.SMT (genParse, showModel)+import Data.SBV.SMT.SMTLibNames+import Data.SBV.SMT.SMT (genParse, showModel, SatModel(..)) +import Data.SBV.Provers.Prover (ProvableM, SatisfiableM)+ import Data.SBV.Utils.Numeric import Data.SBV.Utils.TDiff@@ -86,16 +103,23 @@ import GHC.TypeLits import qualified Data.SBV.Control.Utils as Query+import qualified Data.Text as T +import Data.SBV.Lambda++import Data.SBV.TP.Kernel++#ifdef DOCTEST --- $setup---- >>> -- For doctest purposes only:+-- >>> :set -XScopedTypeVariables --- >>> import Data.SBV+#endif -- | Send an arbitrary string to the solver in a query. -- Note that this is inherently dangerous as it can put the solver in an arbitrary -- state and confuse SBV. If you use this feature, you are on your own! sendStringToSolver :: (MonadIO m, MonadQuery m) => String -> m ()-sendStringToSolver = Query.send False+sendStringToSolver = Query.send False . T.pack -- | Retrieve multiple responses from the solver, until it responds with a user given -- tag that we shall arrange for internally. The optional timeout is in milliseconds.@@ -109,7 +133,7 @@ -- Note that this is inherently dangerous as it can put the solver in an arbitrary -- state and confuse SBV. sendRequestToSolver :: (MonadIO m, MonadQuery m) => String -> m String-sendRequestToSolver = Query.ask+sendRequestToSolver = Query.ask . T.pack {- $coordinateSolverInfo In rare cases it might be necessary to send an arbitrary string down to the solver. Needless to say, this@@ -127,7 +151,7 @@ -- >>> prove $ \x -> fpIsNegativeZero x .|| sComparableSWord32AsSFloat (sFloatAsComparableSWord32 x) `fpIsEqualObject` x -- Q.E.D. sComparableSWord32AsSFloat :: SWord32 -> SFloat-sComparableSWord32AsSFloat = CF.sComparableSWord32AsSFloat +sComparableSWord32AsSFloat = CF.sComparableSWord32AsSFloat -- | Inverse transformation to 'sDoubleAsComparableSWord64'. Note that this isn't a perfect inverse, since @-0@ maps to @0@ and back to @0@. -- Otherwise, it's faithful:@@ -137,16 +161,16 @@ -- >>> prove $ \x -> fpIsNegativeZero x .|| sComparableSWord64AsSDouble (sDoubleAsComparableSWord64 x) `fpIsEqualObject` x -- Q.E.D. sComparableSWord64AsSDouble :: SWord64 -> SDouble-sComparableSWord64AsSDouble = CF.sComparableSWord64AsSDouble +sComparableSWord64AsSDouble = CF.sComparableSWord64AsSDouble -- | Inverse transformation to 'sFloatingPointAsComparableSWord'. Note that this isn't a perfect inverse, since @-0@ maps to @0@ and back to @0@. -- Otherwise, it's faithful: ----- >>> prove $ \x -> let d = sComparableSWordAsSFloatingPoint x in fpIsNaN d .|| fpIsNegativeZero d .|| sFloatingPointAsComparableSWord (d :: SFPHalf) .== x+-- >>> prove $ \x -> let d :: SFPHalf = sComparableSWordAsSFloatingPoint x in fpIsNaN d .|| fpIsNegativeZero d .|| sFloatingPointAsComparableSWord d .== x -- Q.E.D. -- >>> prove $ \x -> fpIsNegativeZero x .|| sComparableSWordAsSFloatingPoint (sFloatingPointAsComparableSWord x) `fpIsEqualObject` (x :: SFPHalf) -- Q.E.D. sComparableSWordAsSFloatingPoint :: forall eb sb. (KnownNat (eb + sb), BVIsNonZero (eb + sb), ValidFloat eb sb) => SWord (eb + sb) -> SFloatingPoint eb sb sComparableSWordAsSFloatingPoint = CF.sComparableSWordAsSFloatingPoint -{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}+{- HLint ignore module "Use import/export shortcut" -}
+ Data/SBV/Lambda.hs view
@@ -0,0 +1,485 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SBV.Lambda+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Generating lambda-expressions, constraints, and named functions, for (limited)+-- higher-order function support in SBV.+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}++module Data.SBV.Lambda (+ lambda, lambdaStr+ , lambdaWithInfo, LambdaInfo(..)+ , constraint, constraintStr+ , LambdaScope(..)+ ) where++import Control.Monad (join)+import Control.Monad.Trans (liftIO, MonadIO)++import qualified Data.Text as T++import Data.SBV.Core.Data+import Data.SBV.Core.Kind+import Data.SBV.SMT.SMTLib2+import Data.SBV.Utils.Lib (showText)+import Data.SBV.Utils.PrettyNum++import Data.SBV.Core.Symbolic hiding (mkNewState)+import qualified Data.SBV.Core.Symbolic as S (mkNewState)++import Data.IORef (readIORef, modifyIORef')+import Data.List+import Data.Maybe (fromMaybe)+import qualified Data.Map.Strict as Map++import qualified Data.Foldable as F+import qualified Data.Set as Set++import qualified Data.Generics.Uniplate.Data as G++-- | What's the scope of the generated lambda?+data LambdaScope = HigherOrderArg -- This lambda will be firstified, hence can't have any free variables+ | TopLevel -- This lambda is used to represent a quantified axiom, can have free vars++-- LambdaInfo is defined in Data.SBV.Core.Symbolic and re-exported from here for backwards compatibility.++data Defn = Defn [String] -- The uninterpreted names referred to in the body+ [String] -- Free variables (i.e., not uninterpreted nor bound in the definition itself)+ (Maybe [(Quantifier, T.Text)]) -- Param declaration groups, if any+ (Int -> T.Text) -- Body, given the tab amount.++-- | Make a new substate from the incoming state, sharing parts as necessary+inSubState :: MonadIO m => LambdaScope -> State -> (State -> m b) -> m b+inSubState scope inState comp = do++ newLevel <- do ll <- liftIO $ readIORef (rLambdaLevel inState)+ pure $ case ll of+ 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++ stEmpty <- S.mkNewState (stCfg inState) (LambdaGen newLevel)++ let share fld = fld inState -- reuse the field from the parent-context+ fresh fld = fld stEmpty -- create a new field here++ -- freshen certain fields, sharing some from the parent, and run the comp+ -- Here's the guidance:+ --+ -- * Anything that's "shared" updates the calling context. It better be the case+ -- that the caller can handle that info.+ -- * Anything that's "fresh" will be used in this substate, and will be forgotten.+ -- It better be the case that in "toLambda" below, you do something with it.+ --+ -- Note the above applies to all the IORefs, which is most of the state, though+ -- not all. For the time being, those are pathCond, stCfg, and startTime; which+ -- don't really impact anything.+ comp State {+ -- These are not IORefs; so we share by copying the value; changes won't be copied back+ sbvContext = share sbvContext+ , pathCond = share pathCond+ , startTime = share startTime++ -- These are shared IORef's; and is shared, so they will be copied back to the parent state+ , rProgInfo = share rProgInfo+ , rIncState = share rIncState+ , rCInfo = share rCInfo+ , rUsedKinds = share rUsedKinds+ , rUsedLbls = share rUsedLbls+ , rUIMap = share rUIMap+ , rUserFuncs = share rUserFuncs+ , rCompilingFuncs = share rCompilingFuncs+ , rCgMap = share rCgMap+ , rDefns = share rDefns+ , rMeasureChecks = share rMeasureChecks+ , rFuncLambdaInfos = share rFuncLambdaInfos+ , rSkipMeasureChecks = share rSkipMeasureChecks+ , rNoTermCheckFunctions = share rNoTermCheckFunctions+ , rSMTOptions = share rSMTOptions+ , rOptGoals = share rOptGoals+ , rAsserts = share rAsserts+ , rOutstandingAsserts = share rOutstandingAsserts+ , rPartitionVars = share rPartitionVars++ -- Everything else is fresh in the substate; i.e., will not copy back+ , stCfg = fresh stCfg+ , runMode = fresh runMode+ , rctr = fresh rctr+ , freshNameCtr = fresh freshNameCtr+ , rLambdaLevel = fresh rLambdaLevel+ , rtblMap = fresh rtblMap+ , rinps = fresh rinps+ , rlambdaInps = fresh rlambdaInps+ , rConstraints = fresh rConstraints+ , rObservables = fresh rObservables+ , routs = fresh routs+ , spgm = fresh spgm+ , rconstMap = fresh rconstMap+ , rexprMap = fresh rexprMap+ , rSVCache = fresh rSVCache+ , rQueryState = fresh rQueryState++ -- keep track of our parent+ , parentState = Just inState+ }++-- In this case, we expect just one group of parameters, with universal quantification+extractAllUniversals :: [(Quantifier, T.Text)] -> T.Text+extractAllUniversals [(ALL, s)] = s+extractAllUniversals other = error $ unlines [ ""+ , "*** Data.SBV.Lambda: Impossible happened. Got existential quantifiers."+ , "***"+ , "*** Params: " ++ show (map (\(q, t) -> (q, T.unpack t)) other)+ , "***"+ , "*** Please report this as a bug!"+ ]+++-- | Generic creator for anonymous lambdas.+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 _ _)+ | 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) = T.unpack (body 0)+ sh (Defn _unints _frees (Just params) body) = "(lambda " ++ T.unpack (extractAllUniversals params) ++ "\n" ++ T.unpack (body 2) ++ ")"++ shift [] = []+ shift (x:xs) = intercalate "\n" (x : map tab xs)+ where tab s = "*** " ++ s++-- | 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) = SMTDef fk unints (extractAllUniversals <$> params) body++-- | Like 'lambda', but also returns the sub-state's DAG info for measure verification.+lambdaWithInfo :: (MonadIO m, Lambda (SymbolicT m) a) => State -> LambdaScope -> Kind -> a -> m (SMTDef, LambdaInfo)+lambdaWithInfo inState scope fk f = inSubState scope inState $ \st -> do+ defn <- handleDefn <$> convert st fk (mkLambda st f)+ info <- liftIO $ extractLambdaInfo st+ pure (defn, info)+ where handleDefn d@(Defn _ frees _ _)+ | null frees = mkLam d+ | True = error $ unlines [ ""+ , "*** Data.SBV.Lambda: Detected free variables in a function with a measure."+ , "*** Free vars: " ++ unwords frees+ ]+ mkLam (Defn unints _frees params body) = SMTDef fk unints (extractAllUniversals <$> params) body++-- | Extract DAG information from a lambda sub-state.+extractLambdaInfo :: State -> IO LambdaInfo+extractLambdaInfo st = do+ SBVPgm asgns <- readIORef (spgm st)+ linps <- readIORef (rlambdaInps st)+ outs <- readIORef (routs st)+ cmap <- readIORef (rconstMap st)+ let params = [(q, getSV nsv) | (q, nsv) <- F.toList linps]+ outSV = case F.toList outs of+ [o] -> o+ os -> error $ "Data.SBV.Lambda.extractLambdaInfo: expected exactly one output, got " ++ show (length os)+ pure LambdaInfo { liAssignments = asgns+ , liParams = params+ , liOutput = outSV+ , liConsts = map swap $ Map.toList cmap+ }+ where swap (a, b) = (b, a)++-- | 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+lambdaStr st scope k a = SMTLambda <$> lambdaGen scope mkLam st k a+ where mkLam (Defn _unints _frees Nothing body) = body 0+ mkLam (Defn _unints _frees (Just params) body) = "(lambda " <> extractAllUniversals params <> "\n" <> body 2 <> ")"++-- | Generic constraint generator.+constraintGen :: (MonadIO m, Constraint (SymbolicT m) a) => LambdaScope -> ([String] -> (Int -> T.Text) -> b) -> State -> a -> m b+constraintGen scope trans inState@State{rProgInfo} f = do+ -- indicate we have quantifiers+ liftIO $ modifyIORef' rProgInfo (\u -> u{hasQuants = True})++ let mkDef (Defn deps _frees Nothing body) = trans deps body+ mkDef (Defn deps _frees (Just params) body) = trans deps $ \i -> T.unwords (map mkGroup params) <> "\n"+ <> body (i + 2)+ <> T.replicate (length params) ")"+ mkGroup (ALL, s) = "(forall " <> s+ mkGroup (EX, s) = "(exists " <> s++ inSubState scope inState $ \st -> mkDef <$> convert st KBool (mkConstraint st f >>= output >> pure ())++-- | A constraint can be turned into a boolean+instance Constraint Symbolic a => QuantifiedBool a where+ quantifiedBool qb = SBV $ SVal KBool $ Right $ cache f+ where f st = liftIO $ constraint st qb++-- | Generate a constraint.+-- We allow free variables here (first arg of constraintGen). This might prove to be not kosher!+constraint :: (MonadIO m, Constraint (SymbolicT m) a) => State -> a -> m SV+constraint st = join . constraintGen TopLevel mkSV st+ where mkSV _deps d = liftIO $ newExpr st KBool (SBVApp (QuantifiedBool (d 0)) [])++-- | Generate a constraint, string version+-- We allow free variables here (first arg of constraintGen). This might prove to be not kosher!+constraintStr :: (MonadIO m, Constraint (SymbolicT m) a) => State -> a -> m String+constraintStr = constraintGen TopLevel toStr+ where toStr deps body = T.unpack $ T.intercalate "\n" [ "; user defined axiom: " <> T.pack (depInfo deps)+ , "(assert " <> body 2 <> ")"+ ]++ depInfo [] = ""+ depInfo ds = "[Refers to: " ++ intercalate ", " ds ++ "]"++-- | Convert to an appropriate SMTLib representation.+convert :: MonadIO m => State -> Kind -> SymbolicT m () -> m Defn+convert st expectedKind comp = do+ ((), res) <- runSymbolicInState st comp+ curProgInfo <- liftIO $ readIORef (rProgInfo st)+ level <- liftIO $ readIORef (rLambdaLevel st)+ pure $ toLambda level curProgInfo (stCfg st) expectedKind res++-- | Convert the result of a symbolic run to a more abstract representation+toLambda :: Maybe Int -> ProgInfo -> SMTConfig -> Kind -> Result -> Defn+toLambda level curProgInfo cfg expectedKind result@Result{resAsgns = SBVPgm asgnsSeq} = sh result+ where tbd xs = error $ unlines $ "*** Data.SBV.lambda: Unsupported construct." : map ("*** " ++) ("" : xs ++ ["", report])+ bad xs = error $ unlines $ "*** Data.SBV.lambda: Impossible happened." : map ("*** " ++) ("" : xs ++ ["", bugReport])+ report = "Please request this as a feature at https://github.com/LeventErkok/sbv/issues"+ bugReport = "Please report this at https://github.com/LeventErkok/sbv/issues"++ sh (Result _hasQuants -- Has quantified booleans? Does not apply++ _ki -- Kind info, we're assuming that all the kinds used are already available in the surrounding context.+ -- There's no way to create a new kind in a lambda. If a new kind is used, it should be registered.++ _qcInfo -- Quickcheck info, does not apply, ignored++ _observables -- Observables: There's no way to display these, so ignore++ _codeSegs -- UI code segments: Again, shouldn't happen; if present, error out++ is -- Inputs++ ( _allConsts -- Not needed, consts are sufficient for this translation+ , consts -- constants used+ )++ tbls -- Tables++ _uis -- Uninterpreted constants: nothing to do with them+ _axs -- Axioms definitions : nothing to do with them++ pgm -- Assignments++ cstrs -- Additional constraints: Not currently supported inside lambda's+ assertions -- Assertions: Not currently supported inside lambda's++ outputs -- Outputs of the lambda (should be singular)+ )+ | not (null cstrs)+ = tbd [ "Constraints."+ , " Saw: " ++ show (length cstrs) ++ " additional constraint(s)."+ ]+ | not (null assertions)+ = tbd [ "Assertions."+ , " Saw: " ++ intercalate ", " [n | (n, _, _) <- assertions]+ ]++ {- Simply ignore the observables, instead of choking on them,+ - This allows for more robust coding, though it might be confusing.+ | not (null observables)+ = tbd [ "Observables."+ , " Saw: " ++ intercalate ", " [n | (n, _, _) <- observables]+ ]+ -}++ | kindOf out /= expectedKind+ = bad [ "Expected kind and final kind do not match"+ , " Saw : " ++ show (kindOf out)+ , " Expected: " ++ show expectedKind+ ]+ | True+ = res+ where res = Defn (nub [T.unpack nm | Uninterpreted nm <- G.universeBi allOps])+ frees+ mbParam+ body++ -- Below can simply be defined as: nub (sort (G.universeBi asgnsSeq))+ -- Alas, it turns out this is really expensive when we have nested lambdas, so we do an explicit walk+ allOps = Set.toList $ foldl' (\sofar (_, SBVApp o _) -> Set.insert o sofar) Set.empty asgnsSeq++ params = case is of+ ResultTopInps as -> bad [ "Top inputs"+ , " Saw: " ++ show as+ ]+ ResultLamInps xs -> map (\(q, v) -> (q, getSV v)) xs++ frees = map show badFrees+ where (defs, uses) = unzip [(d, u) | (d, SBVApp _ u) <- F.toList asgnsSeq]+ defSet = Set.fromList (defs ++ map snd params ++ map fst constants)+ useSet = Set.fromList (concat uses)+ allFrees = Set.toList (useSet `Set.difference` defSet)+ 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+ | True = Just [(q, paramList (map snd l)) | l@((q, _) : _) <- pGroups]+ where pGroups = groupBy (\(q1, _) (q2, _) -> q1 == q2) params+ paramList ps = "(" <> T.unwords (map (\p -> "(" <> showText p <> " " <> smtType (kindOf p) <> ")") ps) <> ")"++ body tabAmnt+ | null constTables+ , null nonConstTables+ , Just e <- simpleBody (map (, Nothing) constBindings ++ svBindings) out+ = tab <> e+ | True+ = T.intercalate "\n" $ map (tab <>) $ [mkLet sv | sv <- constBindings]+ ++ [mkTable t | t <- constTables]+ ++ walk svBindings nonConstTables+ ++ [shift <> showText out <> T.replicate totalClose ")"]++ where tab = T.replicate tabAmnt " "++ mkBind l r = shift <> "(let ((" <> l <> " " <> r <> "))"+ mkLet (s, v) = mkBind (showText s) v++ -- Align according to level.+ shift = T.replicate (24 + 16 * (fromMaybe 0 level - 1)) " "++ mkTable (((i, ak, rk), elts), _) = mkBind nm (lambdaTable (T.map (const ' ') nm) ak rk elts)+ where nm = "table" <> showText i++ totalClose = length constBindings+ + length svBindings+ + length constTables+ + length nonConstTables++ walk [] [] = []+ walk [] remaining = error $ "Data.SBV: Impossible: Ran out of bindings, but tables remain: " ++ show remaining+ walk (cur@((SV _ nd, _), _) : rest) remaining = map (mkTable . snd) ready+ ++ [mkLocalBind cur]+ ++ walk rest notReady+ where (ready, notReady) = partition (\(need, _) -> need < getLLI nd) remaining+ mkLocalBind (b, Nothing) = mkLet b+ mkLocalBind (b, Just l) = mkLet b <> " ; " <> T.pack l++ getLLI :: NodeId -> (Int, Int)+ getLLI (NodeId (_, mbl, i)) = (fromMaybe 0 mbl, i)++ -- if we have just one definition returning it, and if the expression itself is simple enough (single-line), simplify+ -- If the line has new-lines we typically don't want to mess with it, but that causes a memory leak+ -- (see https://github.com/LeventErkok/sbv/issues/733), so only do it if we're being verbose for debugging purposes.+ mkPretty = verbose cfg++ simpleBody :: [((SV, T.Text), Maybe String)] -> SV -> Maybe T.Text+ simpleBody [((v, e), Nothing)] o | v == o, not mkPretty || not (T.any (== '\n') e) = Just e+ simpleBody _ _ = Nothing++ assignments = F.toList (pgmAssignments pgm)++ constants = filter ((`notElem` [falseSV, trueSV]) . fst) consts++ constBindings :: [(SV, T.Text)]+ constBindings = map mkConst constants+ where mkConst :: (SV, CV) -> (SV, T.Text)+ mkConst (sv, cv) = (sv, cvToSMTLib cv)++ svBindings :: [((SV, T.Text), Maybe String)]+ svBindings = map mkAsgn assignments+ where mkAsgn (sv, e@(SBVApp (Label l) _)) = ((sv, converter e), Just l)+ mkAsgn (sv, e) = ((sv, converter e), Nothing)++ converter = cvtExp cfg curProgInfo (capabilities (solver cfg)) rm tableMap+++ out :: SV+ out = case outputs of+ [o] -> o+ _ -> bad [ "Unexpected non-singular output"+ , " Saw: " ++ show outputs+ ]++ rm = roundingMode cfg++ -- NB. The following is dead-code, since we ensure tbls is empty+ -- We used to support this, but there are issues, so dropping support+ -- See, for instance, https://github.com/LeventErkok/sbv/issues/664+ (tableMap, constTables, nonConstTablesUnindexed) = constructTables consts tbls++ -- Index each non-const table with the largest index of SV it needs+ nonConstTables = [ (maximum ((0, 0) : [getLLI n | SV _ n <- elts]), nct)+ | nct@((_, elts), _) <- nonConstTablesUnindexed]++ lambdaTable :: T.Text -> Kind -> Kind -> [SV] -> T.Text+ lambdaTable extraSpace ak rk elts = "(lambda ((" <> lv <> " " <> smtType ak <> "))" <> space <> chain 0 elts <> ")"+ where cnst k i = cvtCV (mkConstCV k (i::Integer))++ lv = "idx"++ -- If more than 5 elts, use new-lines+ long = not (null (drop 5 elts))+ space+ | long+ = "\n " <> extraSpace+ | True+ = " "++ chain _ [] = cnst rk 0+ chain _ [x] = showText x+ chain i (x:xs) = "(ite (= " <> lv <> " " <> cnst ak i <> ") "+ <> showText x <> space+ <> chain (i+1) xs+ <> ")"++{- HLint ignore module "Use second" -}
Data/SBV/List.hs view
@@ -10,406 +10,1539 @@ -- 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 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, subList, replace, indexOf, offsetIndexOf- -- * Reverse- , reverse- ) where--import Prelude hiding (head, tail, init, length, take, drop, concat, null, elem, notElem, reverse, (++), (!!))-import qualified Prelude as P--import Data.SBV.Core.Data hiding (StrOp(..))-import Data.SBV.Core.Model--import Data.List (genericLength, genericIndex, genericDrop, genericTake)-import qualified Data.List as L (tails, isSuffixOf, isPrefixOf, isInfixOf)--import Data.Proxy---- $setup--- >>> -- For doctest purposes only:--- >>> import Prelude hiding (head, tail, init, length, take, drop, concat, null, elem, notElem, reverse, (++), (!!))--- >>> import Data.SBV--- >>> :set -XOverloadedLists--- >>> :set -XScopedTypeVariables---- | 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 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 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,32] :: [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@. 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 $ \(l :: SList Integer) i e -> i `inRange` (0, length l - 1) .&& l `elemAt` i .== e .=> indexOf l (singleton e) .<= i--- 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 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 -> map (elemAt (implode [e1, e2, e3])) (map literal [0 .. 2]) .== [e1, e2, e3]--- Q.E.D.-implode :: SymVal a => [SBV a] -> SList a-implode = foldr ((++) . singleton) (literal [])---- | Concatenate two lists. See also `++`.-concat :: SymVal a => SList a -> SList a -> SList a-concat x y | isConcretelyEmpty x = y- | isConcretelyEmpty y = x- | True = lift2 SeqConcat (Just (P.++)) x y---- | 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 = []---- | Short cut for `concat`.------ >>> 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-(++) = concat---- | @`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 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 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 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---- | @`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 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 :: (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- | Just a <- unliteral l- , Just b <- unliteral src- , Just c <- unliteral dst- = literal $ walk a b c- | True- = lift3 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---- | @`indexOf` l sub@. Retrieves first position of @sub@ in @l@, @-1@ if there are no occurrences.--- Equivalent to @`offsetIndexOf` l sub 0@.------ ->>> prove $ \(l :: SList Int8) i -> i .> 0 .&& i .< length l .=> indexOf l (subList l i 1) .<= i--- Q.E.D.------ >>> 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 :: (Eq a, SymVal a) => SList a -> SList a -> SInteger -> SInteger-offsetIndexOf s sub offset- | 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) <- zip [o ..] (L.tails (genericDrop o c)), n `L.isPrefixOf` t] of- (i:_) -> literal i- _ -> -1- | True- = lift3 SeqIndexOf Nothing s sub offset---- | @`reverse` s@ reverses the sequence.--- >>> 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- newExpr st k (SBVApp (SeqOp (SBVReverse k)) [sva])---- | Lift a unary operator over lists.-lift1 :: forall a b. (SymVal a, SymVal b) => SeqOp -> 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 (SeqOp w) [sva])---- | Lift a binary operator over lists.-lift2 :: forall a b c. (SymVal a, SymVal b, SymVal c) => SeqOp -> 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 (SeqOp w) [sva, svb])---- | Lift a ternary operator over lists.-lift3 :: forall a b c d. (SymVal a, SymVal b, SymVal c, SymVal d) => SeqOp -> 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 (SeqOp 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 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 QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}++module Data.SBV.List (+ -- * Length, emptiness+ length, null++ -- * Deconstructing/Reconstructing+ , nil, (.:), snoc, head, tail, uncons, init, last, singleton, listToListAt, elemAt, (!!), implode, concat, (++)++ -- * Case analysis (for sCase quasi-quoter)+ , list++ -- * Containment+ , elem, notElem, isInfixOf, isSuffixOf, isPrefixOf++ -- * List equality+ , listEq++ -- * 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++ -- * Minimum and maximum of a list+ , minimum, maximum++ -- * 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, minimum, maximum, uncurry)+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.SCase (sCase)+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++#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, minimum, maximum)+-- >>> import qualified Prelude as P(map)+-- >>> import Data.SBV+-- >>> :set -XDataKinds+-- >>> :set -XOverloadedLists+-- >>> :set -XOverloadedStrings+-- >>> :set -XScopedTypeVariables+-- >>> :set -XTypeApplications+-- >>> :set -XQuasiQuotes+#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.+-- >>> 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)++-- | Case analysis on a symbolic list. If the list is empty, return the first argument.+-- Otherwise, apply the second argument to the head and tail of the list.+--+-- >>> list (0 :: SInteger) (\h _ -> h) ([] :: SList Integer)+-- 0 :: SInteger+-- >>> list (0 :: SInteger) (\h _ -> h) ([3, 4, 5] :: SList Integer)+-- 3 :: SInteger+-- >>> prove $ \(l :: SList Integer) -> null l .|| list sFalse (\_ _ -> sTrue) l+-- Q.E.D.+list :: (SymVal a, SymVal b) => SBV b -> (SBV a -> SList a -> SBV b) -> SList a -> SBV b+list nilCase consCase xs = [sCase| xs of+ [] -> nilCase+ h:ts -> consCase h ts+ |]++-- | @`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,32] :: [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 [])++-- | 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]++-- nil is defined in Data.SBV.Core.Data and re-exported here.++-- | 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++-- | @listEq@ is a variant of equality that you can use for lists of floats. It respects @NaN /= NaN@. The reason+-- we do not do this automatically is that it complicates proof objectives usually, as it does not simply resolve to+-- the native equality check.+--+-- NB. We case-split on @x@ only and use a guard for @y@ being empty, rather than case-splitting on the+-- tuple @(x, y)@. A 4-way tuple match produces a larger and\/or\/not SMTLib tree that z3 struggles with.+listEq :: forall a. SymVal a => SList a -> SList a -> SBool+listEq+ | containsFloats (kindOf (Proxy @a))+ = smtFunction "listEq"+ $ \x y -> [sCase| x of+ [] -> null y+ a:xs -> case y of+ [] -> sFalse+ b : ys -> a .== b .&& xs `listEq` ys+ |]+ | True+ = (.==)++-- | @`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 @l@+--+-- >>> 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 -> [sCase| xs of+ [] -> []+ h:ts -> def ts ++ [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 -> [sCase| xs of+ [] -> []+ h : t -> 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 -> [sCase| envxs of+ (_, []) -> []+ (cEnv, h : t) -> 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 'sbv.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)+ $ \exs -> [sCase| exs of+ (e, []) -> e+ (e, h : t) -> 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 -> [sCase| envxs of+ (_, e, []) -> e+ (cEnv, e, h : t) -> 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 right. 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)+ $ \exs -> [sCase| exs of+ (e, []) -> e+ (e, h : t) -> 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 -> [sCase| envxs of+ (_, e, []) -> e+ (cEnv, e, h : t) -> 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 minimum 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"+ $ \x y -> [sCase| tuple (x, y) of+ ([], _ ) -> []+ (_, [] ) -> []+ (a:as, b:bs) -> tuple (a, b) .: def as 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 minimum 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)+ $ \asbs -> [sCase| asbs of+ ([], _ ) -> []+ (_, [] ) -> []+ (a:as, b:bs) -> f a b .: sbvZipWith (tuple (as, 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 -> [sCase| envasbs of+ (_, [], _ ) -> []+ (_, _, [] ) -> []+ (cEnv, a:as, b:bs) -> closureFun cEnv a b .: sbvZipWith (tuple (cEnv, as, 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 -> [sCase| count of+ _ | 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 -> [sCase| l of+ [] -> [[]]+ _ : _ -> 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 -> [sCase| l of+ [] -> [[]]+ _ : tl -> l .: def tl+ |]++-- | Minimum of a list that has symbolic-ordering. If the list is empty, then+-- the result is underspecified, i.e., it is an arbitrary element of the element type.+--+-- >>> minimum ([1,2,3] :: SList Integer)+-- 1 :: SInteger+-- >>> sat $ 512 .== minimum (literal [] :: SList Integer)+-- Satisfiable. Model:+-- SList.minimum @Integer = 512 :: Integer+minimum :: forall a. (SymVal a, Ord a, OrdSymbolic (SBV a)) => SList a -> SBV a+minimum xs+ | Just lxs@(_:_) <- unliteral xs+ = literal (P.minimum lxs)+ | True+ = foldr (smin @(SBV a)) (some "SList.minimum" (const sTrue)) xs++-- | Maximum of a list that has symbolic-ordering. If the list is empty, then+-- the result is underspecified, i.e., it is an arbitrary element of the element type.+--+-- >>> maximum ([1,2,3] :: SList Integer)+-- 3 :: SInteger+-- >>> sat $ 512 .== maximum (literal [] :: SList Integer)+-- Satisfiable. Model:+-- SList.maximum @Integer = 512 :: Integer+maximum :: forall a. (SymVal a, Ord a, OrdSymbolic (SBV a)) => SList a -> SBV a+maximum xs+ | Just lxs@(_:_) <- unliteral xs+ = literal (P.maximum lxs)+ | True+ = foldr (smax @(SBV a)) (some "SList.maximum" (const sTrue)) xs++-- | 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 -> [sCase| x of+ [] -> []+ h : t -> let 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 drop-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 -> [sCase| xs of+ [] -> []+ h : t -> let 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 -> [sCase| xs of+ [] -> tuple ([], [])+ h : t -> case sbvPartition t of+ (as, bs) | f h -> tuple (h .: as, bs)+ | True -> 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 -> [sCase| xs of+ [] -> []+ h : t | f h -> h .: sbvTakeWhile t+ | True -> []+ |]++ -- | @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 -> [sCase| xs of+ [] -> []+ h : t | f h -> sbvDropWhile t+ | True -> 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 -> [sCase| envxs of+ (_, []) -> []+ (cEnv, h : t) -> let 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 -> [sCase| envxs of+ (_, []) -> tuple ([], [])+ (cEnv, h : t) -> case sbvPartition (tuple (cEnv, t)) of+ (as, bs) | closureFun cEnv h -> tuple (h .: as, bs)+ | True -> 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 -> [sCase| envxs of+ (_, []) -> []+ (cEnv, h : t) | closureFun cEnv h -> h .: sbvTakeWhile (tuple (cEnv, t))+ | True -> []+ |]++ 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 -> [sCase| envxs of+ (_, []) -> []+ (cEnv, lst@(h : t)) | closureFun cEnv h -> sbvDropWhile (tuple (cEnv, t))+ | True -> lst+ |]++-- | @`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++ -- | @`enumFromThenTo`@ with an optionally statically-known integer step. The sEnum quasiquoter+ -- supplies @`Just` d@ for @[m, m' .. n]@ when @m'@ is @m@ shifted by a compile-time integer+ -- constant (e.g. @[m, m-1 .. n]@ gives @-1@); otherwise it supplies `Nothing`. Instances with+ -- exact arithmetic (integers, reals) use the hint to constant-fold the step, so the @step == 0@+ -- infinite-list branch (and its productive helper) drops out; every other instance ignores the+ -- hint and falls back to 'enumFromThenTo', preserving its exact semantics. Not meant to be called+ -- directly; the default is correct for any instance.+ enumFromThenToH :: SymVal a => SBV a -> SBV a -> SBV a -> Maybe Integer -> SList a+ enumFromThenToH from thn to _ = enumFromThenTo from thn to++-- | '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 m = enumFromThenToInteger n m 1++ enumFromThen x y = go x (y-x)+ where go = smtProductiveFunction "EnumSymbolic.Integer.enumFromThen" $ \start delta -> start .: go (start+delta) delta++ enumFromThenTo x y z = enumFromThenToInteger x z (y - x)++ enumFromThenToH x y z mStep = enumFromThenToInteger x z (maybe (y - x) fromIntegral mStep)++-- When the step is 0 (i.e., y == x), Haskell produces an infinite list of x's+-- if x <= z, and the empty list otherwise. We mirror that here.+enumFromThenToInteger :: SInteger -> SInteger -> SInteger -> SList Integer+enumFromThenToInteger x z delta = ite (delta .== 0)+ (ite (x .<= z) (enumFromThen x x) [])+ $ ite (delta .> 0) (up x delta z) (down x delta z)+ where -- The d==0 case is handled: 'up'/'down' are only *called* with d>0/d<0 (the d==0 case+ -- is routed to the infinite-list branch above), and the guard's @d .<= 0@/@d .>= 0@ test+ -- puts @d>0@/@d<0@ into the reaching condition, so measure verification never sees d==0.+ -- (The integer measure does not divide by d, so there's no zero-denominator to worry about.)+ up, down :: SInteger -> SInteger -> SInteger -> SList Integer+ up = smtFunctionWithMeasure "EnumSymbolic.Integer.enumFromThenTo.up"+ (\start _d end -> 0 `smax` (end - start + 1), [])+ $ \start d end -> ite (start .> end .|| d .<= 0) [] (start .: up (start + d) d end)+ down = smtFunctionWithMeasure "EnumSymbolic.Integer.enumFromThenTo.down"+ (\start _d end -> 0 `smax` (start - end + 1), [])+ $ \start d end -> ite (start .< end .|| d .>= 0) [] (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 m = enumFromThenToFloat n m 1++ enumFromThen x y = go 0 x (y-x)+ where go = smtProductiveFunction "EnumSymbolic.Float.enumFromThen" $ \k n d -> (n + k * d) .: go (k+1) n d++ enumFromThenTo x y zIn = enumFromThenToFloat x zIn (y - x)++-- When the step is 0 (i.e., y == x), Haskell produces an infinite list of x's+-- if x <= z, and the empty list otherwise. We mirror that here.+enumFromThenToFloat :: SFloat -> SFloat -> SFloat -> SList Float+enumFromThenToFloat x zIn delta = ite (delta .== 0)+ (ite (x .<= z) (enumFromThen x x) [])+ $ ite (delta .> 0) (up 0 x delta z) (down 0 x delta z)+ where z :: SFloat+ z = zIn + delta / 2++ -- Unlike the Integer/AlgReal instances, these are NOT given a termination measure:+ -- floating-point enumeration is genuinely partial. The step @k * d@ can saturate (once+ -- @k * d@ falls below the ULP of @n@, or once the float @k@ itself stops incrementing),+ -- so for some inputs @n + k * d@ never exceeds @end@ and the recursion does not terminate+ -- -- exactly as Haskell's own float enumeration diverges in those cases. A termination+ -- measure would therefore be unsound: no measure can certify termination of a function+ -- that does not always terminate. Instead we mark these productive -- each recursive call+ -- is guarded by a cons, so the definition is well-formed corecursion (finite when the+ -- enumeration terminates, infinite when it saturates). The d==0 case never reaches here:+ -- it is routed to the infinite-list branch above.+ up, down :: SFloat -> SFloat -> SFloat -> SFloat -> SList Float+ up = smtProductiveFunction "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 = smtProductiveFunction "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 m = enumFromThenToDouble n m 1++ enumFromThen x y = go 0 x (y-x)+ where go = smtProductiveFunction "EnumSymbolic.Double.enumFromThen" $ \k n d -> (n + k * d) .: go (k+1) n d++ enumFromThenTo x y zIn = enumFromThenToDouble x zIn (y - x)++-- When the step is 0 (i.e., y == x), Haskell produces an infinite list of x's+-- if x <= z, and the empty list otherwise. We mirror that here.+enumFromThenToDouble :: SDouble -> SDouble -> SDouble -> SList Double+enumFromThenToDouble x zIn delta = ite (delta .== 0)+ (ite (x .<= z) (enumFromThen x x) [])+ $ ite (delta .> 0) (up 0 x delta z) (down 0 x delta z)+ where z :: SDouble+ z = zIn + delta / 2++ -- See the Float instance for why these are productive rather than measured:+ -- floating-point enumeration is genuinely partial (the @k * d@ step can saturate), so a+ -- termination measure would be unsound. Each recursive call is guarded by a cons, so the+ -- definition is well-formed corecursion. The d==0 case is routed to the branch above.+ up, down :: SDouble -> SDouble -> SDouble -> SDouble -> SList Double+ up = smtProductiveFunction "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 = smtProductiveFunction "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 m = enumFromThenToFloatingPoint n m 1++ enumFromThen x y = go 0 x (y-x)+ where go = smtProductiveFunction "EnumSymbolic.FloatingPoint.enumFromThen" $ \k n d -> (n + k * d) .: go (k+1) n d++ enumFromThenTo x y zIn = enumFromThenToFloatingPoint x zIn (y - x)++-- When the step is 0 (i.e., y == x), Haskell produces an infinite list of x's+-- if x <= z, and the empty list otherwise. We mirror that here.+enumFromThenToFloatingPoint :: forall eb sb. ValidFloat eb sb => SFloatingPoint eb sb -> SFloatingPoint eb sb -> SFloatingPoint eb sb -> SList (FloatingPoint eb sb)+enumFromThenToFloatingPoint x zIn delta = ite (delta .== 0)+ (ite (x .<= z) (enumFromThen x x) [])+ $ ite (delta .> 0) (up 0 x delta z) (down 0 x delta z)+ where z :: SFloatingPoint eb sb+ z = zIn + delta / 2++ -- See the Float instance for why these are productive rather than measured:+ -- floating-point enumeration is genuinely partial (the @k * d@ step can saturate), so a+ -- termination measure would be unsound. Each recursive call is guarded by a cons, so the+ -- definition is well-formed corecursion. The d==0 case is routed to the branch above.+ up, down :: SFloatingPoint eb sb -> SFloatingPoint eb sb -> SFloatingPoint eb sb -> SFloatingPoint eb sb -> SList (FloatingPoint eb sb)+ up = smtProductiveFunction "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 = smtProductiveFunction "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 m = enumFromThenToAlgReal n m 1++ enumFromThen x y = go x (y-x)+ where go = smtProductiveFunction "EnumSymbolic.AlgReal.enumFromThen" $ \start delta -> start .: go (start+delta) delta++ enumFromThenTo x y zIn = enumFromThenToAlgReal x zIn (y - x)++ enumFromThenToH x y zIn mStep = enumFromThenToAlgReal x zIn (maybe (y - x) fromIntegral mStep)++-- When the step is 0 (i.e., y == x), Haskell produces an infinite list of x's+-- if x <= z, and the empty list otherwise. We mirror that here.+enumFromThenToAlgReal :: SReal -> SReal -> SReal -> SList AlgReal+enumFromThenToAlgReal x zIn delta = ite (delta .== 0)+ (ite (x .<= z) (enumFromThen x x) [])+ $ ite (delta .> 0) (up x delta z) (down x delta z)+ where z :: SReal+ z = zIn + delta / 2++ -- The measure is the number of remaining recursive steps, which is an INTEGER:+ -- @floor ((end - start) / d) + 1@ (clamped at 0). A real-valued measure would be+ -- unsound here, since the reals are not well-ordered (an infinite descending chain+ -- like 1, 1/2, 1/4, ... never reaches a minimum). 'sRealToSIntegerFloor' is @floor@, and+ -- @(end - start) / d@ is non-negative in both the up (d>0) and down (d<0) regimes, so+ -- the same expression serves both.+ --+ -- The d==0 case is handled: 'up'/'down' are only *called* with d>0/d<0 (the d==0 case is+ -- routed to the infinite-list branch above), and for measure *verification* the guard's+ -- @d .<= 0@/@d .>= 0@ test puts @d>0@/@d<0@ into the reaching condition, so the decrease+ -- obligation never sees d==0; the @0 `smax`@ keeps non-negativity vacuously true even for+ -- the unreachable zero-denominator value of @(end - start) / d@.+ up, down :: SReal -> SReal -> SReal -> SList AlgReal+ up = smtFunctionWithMeasure "EnumSymbolic.AlgReal.enumFromThenTo.up" (\start d end -> 0 `smax` (sRealToSIntegerFloor ((end - start) / d) + 1), [])+ $ \start d end -> ite (start .> end .|| d .<= 0) [] (start .: up (start + d) d end)+ down = smtFunctionWithMeasure "EnumSymbolic.AlgReal.enumFromThenTo.down" (\start d end -> 0 `smax` (sRealToSIntegerFloor ((end - start) / d) + 1), [])+ $ \start d end -> ite (start .< end .|| d .>= 0) [] (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:+-- sbv.lookup_notFound @Integer = 0 :: Integer+-- s0 = 1 :: Integer+lookup :: (SymVal k, SymVal v) => SBV k -> SList (k, v) -> SBV v+lookup = smtFunction "sbv.lookup"+ $ \k lst -> [sCase| lst of+ [] -> some "sbv.lookup_notFound" (const sTrue)+ (k', v) : rest | k .== k' -> v+ | True -> lookup k rest+ |]++-- | @`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 :" -}+{- HLint ignore replicate "Use const" -}
Data/SBV/Maybe.hs view
@@ -10,87 +10,84 @@ -- Symbolic option type, symbolic version of Haskell's 'Maybe' type. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Maybe ( -- * Constructing optional values- sJust, sNothing, liftMaybe+ sJust, sNothing, liftMaybe, SMaybe, sMaybe, sMaybe_, sMaybes+ -- * Destructing optionals , maybe+ -- * Mapping functions , map, map2+ -- * Scrutinizing the branches of an option , isNothing, isJust, fromMaybe, fromJust++ -- * Case analysis (for sCase quasi-quoter)+ , sCaseMaybe, getJust_1 ) where import Prelude hiding (maybe, map) import qualified Prelude -import Data.Proxy (Proxy(Proxy))-+import Data.SBV.Client import Data.SBV.Core.Data-import Data.SBV.Core.Model (ite)+import Data.SBV.Core.Model (ite, OrdSymbolic(..))+import Data.SBV.SCase (sCase) +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Prelude hiding (maybe, map) -- >>> import Data.SBV+#endif --- | The symbolic 'Nothing'.+-- | Make 'Maybe' symbolic. -- -- >>> sNothing :: SMaybe Integer--- Nothing :: SMaybe Integer-sNothing :: forall a. SymVal a => SMaybe a-sNothing = SBV $ SVal k $ Left $ CV k $ CMaybe Nothing- where k = kindOf (Proxy @(Maybe a))---- | Check if the symbolic value is nothing.---+-- Nothing :: Maybe Integer -- >>> isNothing (sNothing :: SMaybe Integer) -- True -- >>> isNothing (sJust (literal "nope")) -- False-isNothing :: SymVal a => SMaybe a -> SBool-isNothing = maybe sTrue (const sFalse)---- | Construct an @SMaybe a@ from an @SBV a@.--- -- >>> sJust (3 :: SInteger)--- Just 3 :: SMaybe Integer-sJust :: forall a. SymVal a => SBV a -> SMaybe a-sJust sa- | Just a <- unliteral sa- = literal (Just a)- | True- = SBV $ SVal kMaybe $ Right $ cache res- where ka = kindOf (Proxy @a)- kMaybe = KMaybe ka-- res st = do asv <- sbvToSV st sa- newExpr st kMaybe $ SBVApp (MaybeConstructor ka True) [asv]---- | Check if the symbolic value is not nothing.---+-- Just 3 :: Maybe Integer -- >>> isJust (sNothing :: SMaybe Integer) -- False -- >>> isJust (sJust (literal "yep")) -- True -- >>> prove $ \x -> isJust (sJust (x :: SInteger)) -- Q.E.D.-isJust :: SymVal a => SMaybe a -> SBool-isJust = maybe sFalse (const sTrue)+mkSymbolic [''Maybe] +-- | Declare a symbolic maybe.+sMaybe :: SymVal a => String -> Symbolic (SMaybe a)+sMaybe = free++-- | Declare a symbolic maybe, unnamed.+sMaybe_ :: SymVal a => Symbolic (SMaybe a)+sMaybe_ = free_++-- | Declare a list of symbolic maybes.+sMaybes :: SymVal a => [String] -> Symbolic [SMaybe a]+sMaybes = symbolics+ -- | Return the value of an optional value. The default is returned if Nothing. Compare to 'fromJust'. -- -- >>> fromMaybe 2 (sNothing :: SMaybe Integer) -- 2 :: SInteger--- >>> fromMaybe 2 (sJust 5 :: SMaybe Integer)--- 5 :: SInteger+-- >>> sat $ \x -> fromMaybe 2 (sJust 5 :: SMaybe Integer) .== x+-- Satisfiable. Model:+-- s0 = 5 :: Integer -- >>> prove $ \x -> fromMaybe x (sNothing :: SMaybe Integer) .== x -- Q.E.D. -- >>> prove $ \x -> fromMaybe (x+1) (sJust x :: SMaybe Integer) .== x@@ -101,8 +98,9 @@ -- | Return the value of an optional value. The behavior is undefined if -- passed Nothing, i.e., it can return any value. Compare to 'fromMaybe'. ----- >>> fromJust (sJust (literal 'a'))--- 'a' :: SChar+-- >>> sat $ \x -> fromJust (sJust (literal 'a')) .== x+-- Satisfiable. Model:+-- s0 = 'a' :: Char -- >>> prove $ \x -> fromJust (sJust x) .== (x :: SChar) -- Q.E.D. -- >>> sat $ \x -> x .== (fromJust sNothing :: SChar)@@ -113,42 +111,14 @@ -- is unspecified, thus the SMT solver picks whatever satisfies the -- constraints, if there is one. fromJust :: forall a. SymVal a => SMaybe a -> SBV a-fromJust ma- | Just (Just x) <- unliteral ma- = literal x- | True- = SBV $ SVal ka $ Right $ cache res- where ka = kindOf (Proxy @a)- kMaybe = KMaybe ka-- -- We play the usual trick here of creating a just value- -- and asserting equivalence under implication. This will- -- be underspecified as required should the value- -- received be `Nothing`.- res st = do -- grab an internal variable and make a Maybe out of it- e <- internalVariable st ka- es <- newExpr st kMaybe (SBVApp (MaybeConstructor ka True) [e])-- -- Create the condition that it is equal to the input- ms <- sbvToSV st ma- eq <- newExpr st KBool (SBVApp Equal [es, ms])-- -- Gotta make sure we do this only when input is not nothing- caseNothing <- sbvToSV st (isNothing ma)- require <- newExpr st KBool (SBVApp Or [caseNothing, eq])-- -- register the constraint:- internalConstraint st False [] $ SVal KBool $ Right $ cache $ \_ -> return require-- -- We're good to go:- return e+fromJust = getJust_1 -- | Construct an @SMaybe a@ from a @Maybe (SBV a)@. -- -- >>> liftMaybe (Just (3 :: SInteger))--- Just 3 :: SMaybe Integer+-- Just 3 :: Maybe Integer -- >>> liftMaybe (Nothing :: Maybe SInteger)--- Nothing :: SMaybe Integer+-- Nothing :: Maybe Integer liftMaybe :: SymVal a => Maybe (SBV a) -> SMaybe a liftMaybe = Prelude.maybe (literal Nothing) sJust @@ -176,10 +146,12 @@ -- | Case analysis for symbolic 'Maybe's. If the value 'isNothing', return the -- default value; if it 'isJust', apply the function. ----- >>> maybe 0 (`sMod` 2) (sJust (3 :: SInteger))--- 1 :: SInteger--- >>> maybe 0 (`sMod` 2) (sNothing :: SMaybe Integer)--- 0 :: SInteger+-- >>> sat $ \x -> x .== maybe 0 (`sMod` 2) (sJust (3 :: SInteger))+-- Satisfiable. Model:+-- s0 = 1 :: Integer+-- >>> sat $ \x -> x .== maybe 0 (`sMod` 2) (sNothing :: SMaybe Integer)+-- Satisfiable. Model:+-- s0 = 0 :: Integer -- >>> let f = uninterpret "f" :: SInteger -> SBool -- >>> prove $ \x d -> maybe d f (sJust x) .== f x -- Q.E.D.@@ -190,34 +162,20 @@ -> (SBV a -> SBV b) -> SMaybe a -> SBV b-maybe brNothing brJust ma- | Just (Just a) <- unliteral ma- = brJust (literal a)- | Just Nothing <- unliteral ma- = brNothing- | True- = SBV $ SVal kb $ Right $ cache res- where ka = kindOf (Proxy @a)- kb = kindOf (Proxy @b)-- res st = do mav <- sbvToSV st ma-- let justVal = SBV $ SVal ka $ Right $ cache $ \_ -> newExpr st ka $ SBVApp MaybeAccess [mav]-- justRes = brJust justVal-- br1 <- sbvToSV st brNothing- br2 <- sbvToSV st justRes-- -- Do we have a value?- noVal <- newExpr st KBool $ SBVApp (MaybeIs ka False) [mav]- newExpr st kb $ SBVApp Ite [noVal, br1, br2]+maybe brNothing brJust ma = [sCase| ma of+ Nothing -> brNothing+ Just x -> brJust x+ |] -- | Custom 'Num' instance over 'SMaybe'-instance {-# OVERLAPPING #-} (Ord a, SymVal a, Num a) => Num (SBV (Maybe a)) where+instance (Ord a, SymVal a, Num a, Num (SBV a)) => Num (SBV (Maybe a)) where (+) = map2 (+) (-) = map2 (-) (*) = map2 (*) abs = map abs signum = map signum fromInteger = sJust . fromInteger++-- | Custom 'OrdSymbolic' instance over 'SMaybe'.+instance (OrdSymbolic (SBV a), SymVal a) => OrdSymbolic (SBV (Maybe a)) where+ ma .< mb = maybe sFalse (\b -> maybe sTrue (.< b) ma) mb
Data/SBV/Provers/ABC.hs view
@@ -29,24 +29,25 @@ , options = const ["-S", "%blast; &sweep -C 5000; &syn4; &cec -s -m -C 2000"] , engine = standardEngine "SBV_ABC" "SBV_ABC_OPTIONS" , capabilities = SolverCapabilities {- supportsQuantifiers = False- , supportsDefineFun = True- , supportsDistinct = True- , supportsBitVectors = True- , supportsUninterpretedSorts = False- , supportsUnboundedInts = False- , supportsInt2bv = False- , supportsReals = False- , supportsApproxReals = False- , supportsDeltaSat = Nothing- , supportsIEEE754 = False- , supportsSets = False- , supportsOptimization = False- , supportsPseudoBooleans = False- , supportsCustomQueries = False- , supportsGlobalDecls = False- , supportsDataTypes = False- , supportsDirectAccessors = False- , supportsFlattenedModels = Nothing+ supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True+ , supportsADTs = False+ , supportsUnboundedInts = False+ , supportsReals = False+ , supportsApproxReals = False+ , supportsDeltaSat = Nothing+ , supportsIEEE754 = False+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = False+ , supportsGlobalDecls = False+ , supportsDataTypes = False+ , supportsLambdas = False+ , supportsSpecialRels = False+ , supportsDirectTesters = False+ , supportsFlattenedModels = Nothing } }
Data/SBV/Provers/Bitwuzla.hs view
@@ -24,27 +24,28 @@ name = Bitwuzla , executable = "bitwuzla" , preprocess = id- , options = const ["--smt2", "-m", "--output-format=smt2", "--no-exit-codes", "--incremental"]+ , options = const ["--produce-models"] , engine = standardEngine "SBV_BITWUZLA" "SBV_BITWUZLA_OPTIONS" , capabilities = SolverCapabilities {- supportsQuantifiers = False- , supportsDefineFun = True- , supportsDistinct = True- , supportsBitVectors = True- , supportsUninterpretedSorts = False- , supportsUnboundedInts = False- , supportsInt2bv = False- , supportsReals = False- , supportsApproxReals = False- , supportsDeltaSat = Nothing- , supportsIEEE754 = False- , supportsSets = False- , supportsOptimization = False- , supportsPseudoBooleans = False- , supportsCustomQueries = True- , supportsGlobalDecls = True- , supportsDataTypes = False- , supportsDirectAccessors = False- , supportsFlattenedModels = Nothing+ supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True+ , supportsADTs = True+ , supportsUnboundedInts = False+ , supportsReals = False+ , supportsApproxReals = False+ , supportsDeltaSat = Nothing+ , supportsIEEE754 = True+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = True+ , supportsGlobalDecls = True+ , supportsDataTypes = False+ , supportsLambdas = False+ , supportsSpecialRels = False+ , supportsDirectTesters = False+ , supportsFlattenedModels = Nothing } }
Data/SBV/Provers/Boolector.hs view
@@ -27,24 +27,25 @@ , options = const ["--smt2", "-m", "--output-format=smt2", "--no-exit-codes", "--incremental"] , engine = standardEngine "SBV_BOOLECTOR" "SBV_BOOLECTOR_OPTIONS" , capabilities = SolverCapabilities {- supportsQuantifiers = False- , supportsDefineFun = True- , supportsDistinct = True- , supportsBitVectors = True- , supportsUninterpretedSorts = False- , supportsUnboundedInts = False- , supportsInt2bv = False- , supportsReals = False- , supportsApproxReals = False- , supportsDeltaSat = Nothing- , supportsIEEE754 = False- , supportsSets = False- , supportsOptimization = False- , supportsPseudoBooleans = False- , supportsCustomQueries = True- , supportsGlobalDecls = True- , supportsDataTypes = False- , supportsDirectAccessors = False- , supportsFlattenedModels = Nothing+ supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True+ , supportsADTs = False+ , supportsUnboundedInts = False+ , supportsReals = False+ , supportsApproxReals = False+ , supportsDeltaSat = Nothing+ , supportsIEEE754 = False+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = True+ , supportsGlobalDecls = True+ , supportsDataTypes = False+ , supportsLambdas = False+ , supportsSpecialRels = False+ , supportsDirectTesters = False+ , supportsFlattenedModels = Nothing } }
Data/SBV/Provers/CVC4.hs view
@@ -9,7 +9,7 @@ -- The connection to the CVC4 SMT solver ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -17,6 +17,8 @@ import Data.Char (isSpace) +import qualified Data.Text as T+ import Data.SBV.Core.Data import Data.SBV.SMT.SMT @@ -31,33 +33,37 @@ , options = const ["--lang", "smt", "--incremental", "--interactive", "--no-interactive-prompt", "--model-witness-value"] , engine = standardEngine "SBV_CVC4" "SBV_CVC4_OPTIONS" , capabilities = SolverCapabilities {- supportsQuantifiers = True- , supportsDefineFun = True- , supportsDistinct = True- , supportsBitVectors = True- , supportsUninterpretedSorts = True- , supportsUnboundedInts = True- , supportsInt2bv = True- , supportsReals = True -- Not quite the same capability as Z3; but works more or less..- , supportsApproxReals = False- , supportsDeltaSat = Nothing- , supportsIEEE754 = True- , supportsSets = False- , supportsOptimization = False- , supportsPseudoBooleans = False- , supportsCustomQueries = True- , supportsGlobalDecls = True- , supportsDataTypes = True- , supportsDirectAccessors = True- , supportsFlattenedModels = Nothing+ supportsQuantifiers = True+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True+ , supportsADTs = True+ , supportsUnboundedInts = True+ , supportsReals = True -- Not quite the same capability as Z3; but works more or less..+ , supportsApproxReals = False+ , supportsDeltaSat = Nothing+ , supportsIEEE754 = True+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = True+ , supportsGlobalDecls = True+ , supportsDataTypes = True+ , supportsLambdas = False+ , supportsSpecialRels = False+ , supportsDirectTesters = True+ , supportsFlattenedModels = Nothing } } where -- CVC4 wants all input on one line- clean = map simpleSpace . noComment+ clean = T.map simpleSpace . noComment - noComment "" = ""- noComment (';':cs) = noComment $ dropWhile (/= '\n') cs- noComment (c:cs) = c : noComment cs+ noComment t+ | T.null t = T.empty+ | True = case T.break (== ';') t of+ (before, rest)+ | T.null rest -> before+ | True -> before <> noComment (T.dropWhile (/= '\n') (T.tail rest)) simpleSpace c | isSpace c = ' '
Data/SBV/Provers/CVC5.hs view
@@ -9,7 +9,7 @@ -- The connection to the CVC5 SMT solver ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -17,6 +17,8 @@ import Data.Char (isSpace) +import qualified Data.Text as T+ import Data.SBV.Core.Data import Data.SBV.SMT.SMT @@ -28,36 +30,40 @@ name = CVC5 , executable = "cvc5" , preprocess = clean- , options = const ["--lang", "smt", "--incremental", "--no-interactive", "--model-witness-value"]+ , options = const ["--lang", "smt", "--incremental", "--nl-cov"] , engine = standardEngine "SBV_CVC5" "SBV_CVC5_OPTIONS" , capabilities = SolverCapabilities {- supportsQuantifiers = True- , supportsDefineFun = True- , supportsDistinct = True- , supportsBitVectors = True- , supportsUninterpretedSorts = True- , supportsUnboundedInts = True- , supportsInt2bv = True- , supportsReals = True -- Not quite the same capability as Z3; but works more or less..- , supportsApproxReals = False- , supportsDeltaSat = Nothing- , supportsIEEE754 = True- , supportsSets = False- , supportsOptimization = False- , supportsPseudoBooleans = False- , supportsCustomQueries = True- , supportsGlobalDecls = True- , supportsDataTypes = True- , supportsDirectAccessors = True- , supportsFlattenedModels = Nothing+ supportsQuantifiers = True+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True+ , supportsADTs = True+ , supportsUnboundedInts = True+ , supportsReals = True -- Not quite the same capability as Z3; but works more or less..+ , supportsApproxReals = False+ , supportsDeltaSat = Nothing+ , supportsIEEE754 = True+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = True+ , supportsGlobalDecls = True+ , supportsDataTypes = True+ , supportsLambdas = True+ , supportsSpecialRels = False+ , supportsDirectTesters = True+ , supportsFlattenedModels = Nothing } } where -- CVC5 wants all input on one line- clean = map simpleSpace . noComment+ clean = T.map simpleSpace . noComment - noComment "" = ""- noComment (';':cs) = noComment $ dropWhile (/= '\n') cs- noComment (c:cs) = c : noComment cs+ noComment t+ | T.null t = T.empty+ | True = case T.break (== ';') t of+ (before, rest)+ | T.null rest -> before+ | True -> before <> noComment (T.dropWhile (/= '\n') (T.tail rest)) simpleSpace c | isSpace c = ' '
Data/SBV/Provers/DReal.hs view
@@ -9,8 +9,6 @@ -- The connection to the dReal SMT solver ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}- {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Provers.DReal(dReal) where@@ -31,25 +29,26 @@ , options = modConfig ["--in", "--format", "smt2"] , engine = standardEngine "SBV_DREAL" "SBV_DREAL_OPTIONS" , capabilities = SolverCapabilities {- supportsQuantifiers = False- , supportsDefineFun = True- , supportsDistinct = False- , supportsBitVectors = False- , supportsUninterpretedSorts = False- , supportsUnboundedInts = True- , supportsInt2bv = False- , supportsReals = True- , supportsApproxReals = False- , supportsDeltaSat = Just "(get-option :precision)"- , supportsIEEE754 = False- , supportsSets = False- , supportsOptimization = False- , supportsPseudoBooleans = False- , supportsCustomQueries = False- , supportsGlobalDecls = False- , supportsDataTypes = False- , supportsDirectAccessors = False- , supportsFlattenedModels = Nothing+ supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = False+ , supportsBitVectors = False+ , supportsADTs = False+ , supportsUnboundedInts = True+ , supportsReals = True+ , supportsApproxReals = False+ , supportsDeltaSat = Just "(get-option :precision)"+ , supportsIEEE754 = False+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = False+ , supportsGlobalDecls = False+ , supportsDataTypes = False+ , supportsLambdas = False+ , supportsSpecialRels = False+ , supportsDirectTesters = False+ , supportsFlattenedModels = Nothing } } where -- If dsat precision is given, pass that as an argument
Data/SBV/Provers/MathSAT.hs view
@@ -9,8 +9,6 @@ -- The connection to the MathSAT SMT solver ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}- {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Provers.MathSAT(mathSAT) where@@ -31,25 +29,26 @@ , options = modConfig ["-input=smt2", "-theory.fp.minmax_zero_mode=4"] , engine = standardEngine "SBV_MATHSAT" "SBV_MATHSAT_OPTIONS" , capabilities = SolverCapabilities {- supportsQuantifiers = True- , supportsDefineFun = True- , supportsDistinct = True- , supportsBitVectors = True- , supportsUninterpretedSorts = True- , supportsUnboundedInts = True- , supportsInt2bv = False- , supportsReals = True- , supportsApproxReals = False- , supportsDeltaSat = Nothing- , supportsIEEE754 = True- , supportsSets = False- , supportsOptimization = False- , supportsPseudoBooleans = False- , supportsCustomQueries = True- , supportsGlobalDecls = True- , supportsDataTypes = True- , supportsDirectAccessors = True- , supportsFlattenedModels = Nothing+ supportsQuantifiers = True+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True+ , supportsADTs = True+ , supportsUnboundedInts = True+ , supportsReals = True+ , supportsApproxReals = False+ , supportsDeltaSat = Nothing+ , supportsIEEE754 = True+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = True+ , supportsGlobalDecls = True+ , supportsDataTypes = True+ , supportsLambdas = False+ , supportsSpecialRels = False+ , supportsDirectTesters = True+ , supportsFlattenedModels = Nothing } }
+ Data/SBV/Provers/OpenSMT.hs view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SBV.Provers.OpenSMT+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- The connection to the OpenSMT SMT solver+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Provers.OpenSMT(openSMT) where++import Data.SBV.Core.Data+import Data.SBV.SMT.SMT++-- | The description of the OpenSMT SMT solver.+-- The default executable is @\"opensmt\"@, which must be in your path. You can use the @SBV_OpenSMT@ environment variable to point to the executable on your system.+-- You can use the @SBV_OpenSMT_OPTIONS@ environment variable to override the options.+openSMT :: SMTSolver+openSMT = SMTSolver {+ name = OpenSMT+ , executable = "openSMT"+ , preprocess = id+ , options = modConfig []+ , engine = standardEngine "SBV_OpenSMT" "SBV_OpenSMT_OPTIONS"+ , capabilities = SolverCapabilities {+ supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = False+ , supportsADTs = True+ , supportsUnboundedInts = True+ , supportsReals = True+ , supportsApproxReals = False+ , supportsDeltaSat = Nothing+ , supportsIEEE754 = False+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = True+ , supportsGlobalDecls = True+ , supportsDataTypes = False+ , supportsLambdas = False+ , supportsSpecialRels = False+ , supportsDirectTesters = False+ , supportsFlattenedModels = Nothing+ }+ }++ where modConfig :: [String] -> SMTConfig -> [String]+ modConfig opts _cfg = opts
Data/SBV/Provers/Prover.hs view
@@ -9,12 +9,13 @@ -- Provable abstraction and the connection to SMT solvers ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -22,20 +23,20 @@ module Data.SBV.Provers.Prover ( SMTSolver(..), SMTConfig(..), Predicate- , MProvable(..), Provable, proveWithAll, proveWithAny , satWithAll, satWithAny- , satConcurrentWithAny, satConcurrentWithAll, proveConcurrentWithAny, proveConcurrentWithAll- , generateSMTBenchmark- , Goal+ , ProvableM(..), Provable, SatisfiableM(..), Satisfiable+ , generateSMTBenchmarkSat, generateSMTBenchmarkProof, defs2smt, ConstraintSet , ThmResult(..), SatResult(..), AllSatResult(..), SafeResult(..), OptimizeResult(..), SMTResult(..) , SExecutable(..), isSafe , runSMT, runSMTWith , SatModel(..), Modelable(..), displayModels, extractModels- , getModelDictionaries, getModelValues, getModelUninterpretedValues- , abc, boolector, bitwuzla, cvc4, cvc5, dReal, mathSAT, yices, z3, defaultSMTCfg, defaultDeltaSMTCfg+ , getModelDictionaries, getModelValues+ , abc, boolector, bitwuzla, cvc4, cvc5, dReal, mathSAT, yices, z3, openSMT, defaultSMTCfg, defaultDeltaSMTCfg+ , proveWithAny, proveWithAll, proveConcurrentWithAny, proveConcurrentWithAll+ , satWithAny, satWithAll, satConcurrentWithAny, satConcurrentWithAll ) where -import Control.Monad (when, unless)+import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.DeepSeq (rnf, NFData(..)) @@ -46,13 +47,13 @@ import System.IO.Unsafe (unsafeInterleaveIO) -- only used safely! import System.Directory (getCurrentDirectory)- import Data.Time (getZonedTime, NominalDiffTime, UTCTime, getCurrentTime, diffUTCTime)-import Data.List (intercalate, isPrefixOf, nub)+import Data.List (intercalate, isPrefixOf) import Data.Maybe (mapMaybe, listToMaybe) -import qualified Data.Map.Strict as M+import qualified Data.Set as Set (empty)+ import qualified Data.Foldable as S (toList) import qualified Data.Text as T @@ -61,8 +62,11 @@ import Data.SBV.SMT.SMT import Data.SBV.SMT.Utils (debug, alignPlain) import Data.SBV.Utils.ExtractIO+import Data.SBV.Utils.Lib (showText) import Data.SBV.Utils.TDiff +import Data.SBV.Lambda () -- instances only+ import qualified Data.SBV.Trans.Control as Control import qualified Data.SBV.Control.Query as Control import qualified Data.SBV.Control.Utils as Control@@ -78,30 +82,41 @@ import qualified Data.SBV.Provers.MathSAT as MathSAT import qualified Data.SBV.Provers.Yices as Yices import qualified Data.SBV.Provers.Z3 as Z3+import qualified Data.SBV.Provers.OpenSMT as OpenSMT +import GHC.TypeLits+ mkConfig :: SMTSolver -> SMTLibVersion -> [Control.SMTOption] -> SMTConfig mkConfig s smtVersion startOpts = SMTConfig { verbose = False , timing = NoTiming , printBase = 10 , printRealPrec = 16 , crackNum = False+ , crackNumSurfaceVals = [] , transcript = Nothing , solver = s , smtLibVersion = smtVersion , dsatPrecision = Nothing , extraArgs = [] , satCmd = "(check-sat)"- , satTrackUFs = True -- i.e., yes, do extract UI function values+ , allSatTrackUFs = True -- i.e., yes, do extract UI function values , allSatMaxModelCount = Nothing -- i.e., return all satisfying models , allSatPrintAlong = False -- i.e., do not print models as they are found , isNonModelVar = const False -- i.e., everything is a model-variable by default , validateModel = False , optimizeValidateConstraints = False- , allowQuantifiedQueries = False , roundingMode = RoundNearestTiesToEven , solverSetOptions = startOpts+ , smtLib2Compliant = True , ignoreExitCode = False , redirectVerbose = Nothing+ , firstifyUniqueLen = 10+ , tpOptions = TPOptions { ribbonLength = 40+ , quiet = False+ , printAsms = False+ , printStats = False+ , measuresBeingVerified = Set.empty+ } } -- | If supported, this makes all output go to stdout, which works better with SBV@@ -148,6 +163,12 @@ , allOnStdOut ] +-- | Default configuration for the OpenSMT SMT solver+openSMT :: SMTConfig+openSMT = mkConfig OpenSMT.openSMT SMTLib2 [ Control.OptionKeyword ":smtlib2_compliant" ["true"]+ , allOnStdOut+ ]+ -- | The default solver used by SBV. This is currently set to z3. defaultSMTCfg :: SMTConfig defaultSMTCfg = z3@@ -164,49 +185,23 @@ -- type when necessary. type Predicate = Symbolic SBool --- | A goal is a symbolic program that returns no values. The idea is that the constraints/min-max--- goals will serve as appropriate directives for sat/prove calls.-type Goal = Symbolic ()---- | A type @a@ is provable if we can turn it into a predicate.--- Note that a predicate can be made from a curried function of arbitrary arity, where--- each element is either a symbolic type or up-to a 7-tuple of symbolic-types. So--- predicates can be constructed from almost arbitrary Haskell functions that have arbitrary--- shapes. (See the instance declarations below.)-class ExtractIO m => MProvable m a where- -- | Generalization of 'Data.SBV.universal_'- universal_ :: a -> SymbolicT m SBool-- -- | Generalization of 'Data.SBV.universal'- universal :: [String] -> a -> SymbolicT m SBool-- -- | Generalization of 'Data.SBV.existential_'- existential_ :: a -> SymbolicT m SBool-- -- | Generalization of 'Data.SBV.existential'- existential :: [String] -> a -> SymbolicT m SBool-- -- | Generalization of 'Data.SBV.prove'- prove :: a -> m ThmResult- prove = proveWith defaultSMTCfg+-- | A constraint set is a symbolic program that returns no values. The idea is that the constraints/min-max+-- goals will serve as the collection of constraints that will be used for sat/optimize calls.+type ConstraintSet = Symbolic () - -- | Generalization of 'Data.SBV.proveWith'- proveWith :: SMTConfig -> a -> m ThmResult- proveWith cfg a = do r <- runWithQuery False (checkNoOptimizations >> Control.getSMTResult) cfg a- ThmResult <$> if validationRequested cfg- then validate False cfg a r- else return r+-- | `Provable` is specialization of `ProvableM` to the `IO` monad. Unless you are using+-- transformers explicitly, this is the type you should prefer.+type Provable = ProvableM IO - -- | Generalization of 'Data.SBV.dprove'- dprove :: a -> m ThmResult- dprove = dproveWith defaultDeltaSMTCfg+-- | `Data.SBV.Provers.Satisfiable` is specialization of `SatisfiableM` to the `IO` monad. Unless you are using+-- transformers explicitly, this is the type you should prefer.+type Satisfiable = SatisfiableM IO - -- | Generalization of 'Data.SBV.dproveWith'- dproveWith :: SMTConfig -> a -> m ThmResult- dproveWith cfg a = do r <- runWithQuery False (checkNoOptimizations >> Control.getSMTResult) cfg a- ThmResult <$> if validationRequested cfg- then validate False cfg a r- else return r+-- | A type @a@ is satisfiable if it has constraints, potentially returning a boolean. This class+-- captures essentially sat and optimize calls.+class ExtractIO m => SatisfiableM m a where+ -- | Reduce an arg, for sat purposes.+ satArgReduce :: a -> SymbolicT m SBool -- | Generalization of 'Data.SBV.sat' sat :: a -> m SatResult@@ -214,10 +209,10 @@ -- | Generalization of 'Data.SBV.satWith' satWith :: SMTConfig -> a -> m SatResult- satWith cfg a = do r <- runWithQuery True (checkNoOptimizations >> Control.getSMTResult) cfg a+ satWith cfg a = do r <- runWithQuery satArgReduce True (checkNoOptimizations >> Control.getSMTResult) cfg a SatResult <$> if validationRequested cfg- then validate True cfg a r- else return r+ then validate satArgReduce True cfg a r+ else pure r -- | Generalization of 'Data.SBV.sat' dsat :: a -> m SatResult@@ -225,10 +220,10 @@ -- | Generalization of 'Data.SBV.satWith' dsatWith :: SMTConfig -> a -> m SatResult- dsatWith cfg a = do r <- runWithQuery True (checkNoOptimizations >> Control.getSMTResult) cfg a+ dsatWith cfg a = do r <- runWithQuery satArgReduce True (checkNoOptimizations >> Control.getSMTResult) cfg a SatResult <$> if validationRequested cfg- then validate True cfg a r- else return r+ then validate satArgReduce True cfg a r+ else pure r -- | Generalization of 'Data.SBV.allSat' allSat :: a -> m AllSatResult@@ -236,12 +231,24 @@ -- | Generalization of 'Data.SBV.allSatWith' allSatWith :: SMTConfig -> a -> m AllSatResult- allSatWith cfg a = do asr <- runWithQuery True (checkNoOptimizations >> Control.getAllSatResult) cfg a+ allSatWith cfg a = do asr <- runWithQuery satArgReduce True (checkNoOptimizations >> Control.getAllSatResult) cfg a if validationRequested cfg- then do rs' <- mapM (validate True cfg a) (allSatResults asr)- return asr{allSatResults = rs'}- else return asr+ then do rs' <- mapM (validate satArgReduce True cfg a) (allSatResults asr)+ pure asr{allSatResults = rs'}+ else pure asr + -- | Generalization of 'Data.SBV.isSatisfiable'+ isSatisfiable :: a -> m Bool+ isSatisfiable = isSatisfiableWith defaultSMTCfg++ -- | Generalization of 'Data.SBV.isSatisfiableWith'+ isSatisfiableWith :: SMTConfig -> a -> m Bool+ isSatisfiableWith cfg p = do r <- satWith cfg p+ case r of+ SatResult Satisfiable{} -> pure True+ SatResult Unsatisfiable{} -> pure False+ _ -> error $ "SBV.isSatisfiable: Received: " ++ show r+ -- | Generalization of 'Data.SBV.optimize' optimize :: OptimizeStyle -> a -> m OptimizeResult optimize = optimizeWith defaultSMTCfg@@ -249,129 +256,108 @@ -- | Generalization of 'Data.SBV.optimizeWith' optimizeWith :: SMTConfig -> OptimizeStyle -> a -> m OptimizeResult optimizeWith config style optGoal = do- res <- runWithQuery True opt config optGoal+ res <- runWithQuery satArgReduce True opt config optGoal if not (optimizeValidateConstraints config)- then return res+ then pure res else let v :: SMTResult -> m SMTResult- v = validate True config optGoal+ v = validate satArgReduce True config optGoal in case res of LexicographicResult m -> LexicographicResult <$> v m- IndependentResult xs -> let w [] sofar = return (reverse sofar)+ IndependentResult xs -> let w [] sofar = pure (reverse sofar) w ((n, m):rest) sofar = v m >>= \m' -> w rest ((n, m') : sofar) in IndependentResult <$> w xs [] ParetoResult (b, rs) -> ParetoResult . (b, ) <$> mapM v rs - where opt = do objectives <- Control.getObjectives- qinps <- Control.getQuantifiedInputs- spgm <- Control.getSBVPgm-- when (null objectives) $- error $ unlines [ ""- , "*** Data.SBV: Unsupported call to optimize when no objectives are present."- , "*** Use \"sat\" for plain satisfaction"- ]-- unless (supportsOptimization (capabilities (solver config))) $- error $ unlines [ ""- , "*** Data.SBV: The backend solver " ++ show (name (solver config)) ++ "does not support optimization goals."- , "*** Please use a solver that has support, such as z3"- ]-- when (validateModel config && not (optimizeValidateConstraints config)) $- error $ unlines [ ""- , "*** Data.SBV: Model validation is not supported in optimization calls."- , "***"- , "*** Instead, use `cfg{optimizeValidateConstraints = True}`"- , "***"- , "*** which checks that the results satisfy the constraints but does"- , "*** NOT ensure that they are optimal."- ]--- let universals = S.toList $ getUniversals qinps+ where opt = do mbDirs <- Control.startOptimizer config style - firstUniversal- | null universals = error "Data.SBV: Impossible happened! Universal optimization with no universals!"- | True = minimum $ fmap (swNodeId . getSV) universals+ case mbDirs of+ Nothing -> error $ unlines [ ""+ , "*** Data.SBV: Unsupported call to optimize when no objectives are present."+ , "*** Use \"sat\" for plain satisfaction"+ ]+ Just (objectives, optimizerDirectives) -> do+ mapM_ (Control.send True . T.pack) optimizerDirectives - mappings :: M.Map SV SBVExpr- mappings = M.fromList (S.toList (pgmAssignments spgm))+ case style of+ Lexicographic -> LexicographicResult <$> Control.getLexicographicOptResults+ Independent -> IndependentResult <$> Control.getIndependentOptResults (map objectiveName objectives)+ Pareto mbN -> ParetoResult <$> Control.getParetoOptResults mbN - chaseUniversal entry = go entry []- where go x sofar- | nx >= firstUniversal- = nub $ [unm | unm <- universals, nx >= swNodeId (getSV unm)] ++ sofar- | True- = let oVars (LkUp _ a b) = [a, b]- oVars (IEEEFP (FP_Cast _ _ o)) = [o]- oVars _ = []- vars = case x `M.lookup` mappings of- Nothing -> []- Just (SBVApp o ss) -> nub (oVars o ++ ss)- in foldr go sofar vars- where nx = swNodeId x+-- | Find a satisfying assignment to a property with multiple solvers, running them in separate threads. The+-- results will be returned in the order produced.+satWithAll :: Satisfiable a => [SMTConfig] -> a -> IO [(Solver, NominalDiffTime, SatResult)]+satWithAll = (`sbvWithAll` satWith) - let needsUniversalOpt = let tag _ [] = Nothing- tag nm xs = Just (nm, xs)- needsUniversal (Maximize nm (x, _)) = tag nm (chaseUniversal x)- needsUniversal (Minimize nm (x, _)) = tag nm (chaseUniversal x)- needsUniversal (AssertWithPenalty nm (x, _) _) = tag nm (chaseUniversal x)- in mapMaybe needsUniversal objectives+-- | Find a satisfying assignment to a property with multiple solvers, running them in separate threads. Only+-- the result of the first one to finish will be returned, remaining threads will be killed.+-- Note that we send an exception to the losing processes, but we do *not* actually wait for them+-- to finish. In rare cases this can lead to zombie processes. In previous experiments, we found+-- that some processes take their time to terminate. So, this solution favors quick turnaround.+satWithAny :: Satisfiable a => [SMTConfig] -> a -> IO (Solver, NominalDiffTime, SatResult)+satWithAny = (`sbvWithAny` satWith) - unless (null universals || null needsUniversalOpt) $- let len = maximum $ 0 : [length nm | (nm, _) <- needsUniversalOpt]- pad n = n ++ replicate (len - length n) ' '- in error $ unlines $ [ ""- , "*** Data.SBV: Problem needs optimization of metric in the scope of universally quantified variable(s):"- , "***"- ]- ++ [ "*** " ++ pad s ++ " [Depends on: " ++ intercalate ", " (getUserName' <$> xs) ++ "]" | (s, xs) <- needsUniversalOpt ]- ++ [ "***"- , "*** Optimization is only meaningful with existentially quantified metrics."- ]+-- | Find a satisfying assignment to a property using a single solver, but+-- providing several query problems of interest, with each query running in a+-- separate thread and return the first one that returns. This can be useful to+-- use symbolic mode to drive to a location in the search space of the solver+-- and then refine the problem in query mode. If the computation is very hard to+-- solve for the solver than running in concurrent mode may provide a large+-- performance benefit.+satConcurrentWithAny :: Satisfiable a => SMTConfig -> [Query b] -> a -> IO (Solver, NominalDiffTime, SatResult)+satConcurrentWithAny solver qs a = do (slvr,time,result) <- sbvConcurrentWithAny solver go qs a+ pure (slvr, time, SatResult result)+ where go cfg a' q = runWithQuery satArgReduce True (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' - let optimizerDirectives = concatMap minmax objectives ++ priority style- where mkEq (x, y) = "(assert (= " ++ show x ++ " " ++ show y ++ "))"+-- | Find a satisfying assignment to a property using a single solver, but run+-- each query problem in a separate isolated thread and wait for each thread to+-- finish. See 'satConcurrentWithAny' for more details.+satConcurrentWithAll :: Satisfiable a => SMTConfig -> [Query b] -> a -> IO [(Solver, NominalDiffTime, SatResult)]+satConcurrentWithAll solver qs a = do results <- sbvConcurrentWithAll solver go qs a+ pure $ (\(a',b,c) -> (a',b,SatResult c)) <$> results+ where go cfg a' q = runWithQuery satArgReduce True (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' - minmax (Minimize _ xy@(_, v)) = [mkEq xy, "(minimize " ++ show v ++ ")"]- minmax (Maximize _ xy@(_, v)) = [mkEq xy, "(maximize " ++ show v ++ ")"]- minmax (AssertWithPenalty nm xy@(_, v) mbp) = [mkEq xy, "(assert-soft " ++ show v ++ penalize mbp ++ ")"]- where penalize DefaultPenalty = ""- penalize (Penalty w mbGrp)- | w <= 0 = error $ unlines [ "SBV.AssertWithPenalty: Goal " ++ show nm ++ " is assigned a non-positive penalty: " ++ shw- , "All soft goals must have > 0 penalties associated."- ]- | True = " :weight " ++ shw ++ maybe "" group mbGrp- where shw = show (fromRational w :: Double)+-- | A type @a@ is provable if we can turn it into a predicate, i.e., it has to return a boolean.+-- This class captures essentially prove calls.+class ExtractIO m => ProvableM m a where+ -- | Reduce an arg, for proof purposes.+ proofArgReduce :: a -> SymbolicT m SBool - group g = " :id " ++ g+ -- | Generalization of 'Data.SBV.prove'+ prove :: a -> m ThmResult+ prove = proveWith defaultSMTCfg - priority Lexicographic = [] -- default, no option needed- priority Independent = ["(set-option :opt.priority box)"]- priority (Pareto _) = ["(set-option :opt.priority pareto)"]+ -- | Generalization of 'Data.SBV.proveWith'+ proveWith :: SMTConfig -> a -> m ThmResult+ proveWith cfg a = do r <- runWithQuery proofArgReduce False (checkNoOptimizations >> Control.getSMTResult) cfg a+ ThmResult <$> if validationRequested cfg+ then validate proofArgReduce False cfg a r+ else pure r - mapM_ (Control.send True) optimizerDirectives+ -- | Generalization of 'Data.SBV.dprove'+ dprove :: a -> m ThmResult+ dprove = dproveWith defaultDeltaSMTCfg - case style of- Lexicographic -> LexicographicResult <$> Control.getLexicographicOptResults- Independent -> IndependentResult <$> Control.getIndependentOptResults (map objectiveName objectives)- Pareto mbN -> ParetoResult <$> Control.getParetoOptResults mbN+ -- | Generalization of 'Data.SBV.dproveWith'+ dproveWith :: SMTConfig -> a -> m ThmResult+ dproveWith cfg a = do r <- runWithQuery proofArgReduce False (checkNoOptimizations >> Control.getSMTResult) cfg a+ ThmResult <$> if validationRequested cfg+ then validate proofArgReduce False cfg a r+ else pure r - -- | Generalization of 'Data.SBV.isVacuous'- isVacuous :: a -> m Bool- isVacuous = isVacuousWith defaultSMTCfg+ -- | Generalization of 'Data.SBV.isVacuousProof'+ isVacuousProof :: a -> m Bool+ isVacuousProof = isVacuousProofWith defaultSMTCfg - -- | Generalization of 'Data.SBV.isVacuousWith'- isVacuousWith :: SMTConfig -> a -> m Bool- isVacuousWith cfg a = -- NB. Can't call runWithQuery since last constraint would become the implication!- fst <$> runSymbolic (SMTMode QueryInternal ISetup True cfg) (existential_ a >> Control.executeQuery QueryInternal check)+ -- | Generalization of 'Data.SBV.isVacuousProofWith'+ isVacuousProofWith :: SMTConfig -> a -> m Bool+ isVacuousProofWith cfg a = -- NB. Can't call runWithQuery since last constraint would become the implication!+ fst <$> runSymbolic cfg (SMTMode QueryInternal ISetup True cfg) (proofArgReduce a >> Control.executeQuery QueryInternal check) where- check :: QueryT m Bool check = do cs <- Control.checkSat case cs of- Control.Unsat -> return True- Control.Sat -> return False- Control.DSat{} -> return False+ Control.Unsat -> pure True+ Control.Sat -> pure False+ Control.DSat{} -> pure False Control.Unk -> error "SBV: isVacuous: Solver returned unknown!" -- | Generalization of 'Data.SBV.isTheorem'@@ -383,254 +369,215 @@ isTheoremWith cfg p = do r <- proveWith cfg p let bad = error $ "SBV.isTheorem: Received:\n" ++ show r case r of- ThmResult Unsatisfiable{} -> return True- ThmResult Satisfiable{} -> return False- ThmResult DeltaSat{} -> return False- ThmResult SatExtField{} -> return False+ ThmResult Unsatisfiable{} -> pure True+ ThmResult Satisfiable{} -> pure False+ ThmResult DeltaSat{} -> pure False+ ThmResult SatExtField{} -> pure False ThmResult Unknown{} -> bad ThmResult ProofError{} -> bad - -- | Generalization of 'Data.SBV.isSatisfiable'- isSatisfiable :: a -> m Bool- isSatisfiable = isSatisfiableWith defaultSMTCfg-- -- | Generalization of 'Data.SBV.isSatisfiableWith'- isSatisfiableWith :: SMTConfig -> a -> m Bool- isSatisfiableWith cfg p = do r <- satWith cfg p- case r of- SatResult Satisfiable{} -> return True- SatResult Unsatisfiable{} -> return False- _ -> error $ "SBV.isSatisfiable: Received: " ++ show r-- -- | Validate a model obtained from the solver- validate :: Bool -> SMTConfig -> a -> SMTResult -> m SMTResult- validate isSAT cfg p res = case res of- Unsatisfiable{} -> return res- Satisfiable _ m -> case modelBindings m of- Nothing -> error "Data.SBV.validate: Impossible happened; no bindings generated during model validation."- Just env -> check env-- DeltaSat {} -> cant [ "The model is delta-satisfiable."- , "Cannot validate delta-satisfiable models."- ]-- SatExtField{} -> cant [ "The model requires an extension field value."- , "Cannot validate models with infinities/epsilons produced during optimization."- , ""- , "To turn validation off, use `cfg{optimizeValidateConstraints = False}`"- ]+-- | Prove a property with multiple solvers, running them in separate threads. Only+-- the result of the first one to finish will be returned, remaining threads will be killed.+-- Note that we send an exception to the losing processes, but we do *not* actually wait for them+-- to finish. In rare cases this can lead to zombie processes. In previous experiments, we found+-- that some processes take their time to terminate. So, this solution favors quick turnaround.+proveWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, NominalDiffTime, ThmResult)+proveWithAny = (`sbvWithAny` proveWith) - Unknown{} -> return res- ProofError{} -> return res+-- | Prove a property with multiple solvers, running them in separate threads. The+-- results will be returned in the order produced.+proveWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, NominalDiffTime, ThmResult)]+proveWithAll = (`sbvWithAll` proveWith) - where cant msg = return $ ProofError cfg (msg ++ [ ""- , "Unable to validate the produced model."- ]) (Just res)+-- | Prove a property by running many queries each isolated to their own thread+-- concurrently and return the first that finishes, killing the others+proveConcurrentWithAny :: Provable a => SMTConfig -> [Query b] -> a -> IO (Solver, NominalDiffTime, ThmResult)+proveConcurrentWithAny solver qs a = do (slvr,time,result) <- sbvConcurrentWithAny solver go qs a+ pure (slvr, time, ThmResult result)+ where go cfg a' q = runWithQuery proofArgReduce False (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' - check env = do let univs = [T.unpack n | ((ALL, NamedSymVar _ n), _) <- env]- envShown = showModelDictionary True True cfg modelBinds- where modelBinds = [(T.unpack n, fake q s v) | ((q, NamedSymVar s n), v) <- env]- fake q s Nothing- | q == ALL- = RegularCV $ CV (kindOf s) $ CUserSort (Nothing, "<universally quantified>")- | True- = RegularCV $ CV (kindOf s) $ CUserSort (Nothing, "<no binding found>")- fake _ _ (Just v) = RegularCV v+-- | Prove a property by running many queries each isolated to their own thread+-- concurrently and wait for each to finish returning all results+proveConcurrentWithAll :: Provable a => SMTConfig -> [Query b] -> a -> IO [(Solver, NominalDiffTime, ThmResult)]+proveConcurrentWithAll solver qs a = do results <- sbvConcurrentWithAll solver go qs a+ pure $ (\(a',b,c) -> (a',b,ThmResult c)) <$> results+ where go cfg a' q = runWithQuery proofArgReduce False (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' - notify s- | not (verbose cfg) = return ()- | True = debug cfg ["[VALIDATE] " `alignPlain` s]+-- | Validate a model obtained from the solver+validate :: MonadIO m => (a -> SymbolicT m SBool) -> Bool -> SMTConfig -> a -> SMTResult -> m SMTResult+validate reducer isSAT cfg p res =+ case res of+ Unsatisfiable{} -> pure res+ Satisfiable _ m -> case modelBindings m of+ Nothing -> error "Data.SBV.validate: Impossible happened; no bindings generated during model validation."+ Just env -> check env - notify $ "Validating the model. " ++ if null env then "There are no assignments." else "Assignment:"- mapM_ notify [" " ++ l | l <- lines envShown]+ DeltaSat {} -> cant [ "The model is delta-satisfiable."+ , "Cannot validate delta-satisfiable models."+ ] - unless (null univs) $ do- notify $ "NB. The following variable(s) are universally quantified: " ++ intercalate ", " univs- notify " We will assume that they are essentially zero for the purposes of validation."- notify " Note that this is a gross simplification of the model validation with universals!"+ SatExtField{} -> cant [ "The model requires an extension field value."+ , "Cannot validate models with infinities/epsilons produced during optimization."+ , ""+ , "To turn validation off, use `cfg{optimizeValidateConstraints = False}`"+ ] - result <- snd <$> runSymbolic (Concrete (Just (isSAT, env))) ((if isSAT then existential_ p else universal_ p) >>= output)+ Unknown{} -> pure res+ ProofError{} -> pure res - let explain = [ ""- , "Assignment:" ++ if null env then " <none>" else ""- ]- ++ [ "" | not (null env)]- ++ [ " " ++ l | l <- lines envShown]- ++ [ "" ]+ where cant msg = pure $ ProofError cfg (msg ++ [ ""+ , "Unable to validate the produced model."+ ]) (Just res) - wrap tag extras = return $ ProofError cfg (tag : explain ++ extras) (Just res)+ check env = do let envShown = showModelDictionary True True cfg modelBinds+ where modelBinds = [(T.unpack n, RegularCV v) | (NamedSymVar _ n, v) <- env] - giveUp s = wrap ("Data.SBV: Cannot validate the model: " ++ s)- [ "SBV's model validator is incomplete, and cannot handle this particular case."- , "Please report this as a feature request or possibly a bug!"- ]+ notify s+ | not (verbose cfg) = pure ()+ | True = debug cfg ["[VALIDATE] " `alignPlain` T.pack s] - badModel s = wrap ("Data.SBV: Model validation failure: " ++ s)- [ "Backend solver returned a model that does not satisfy the constraints."- , "This could indicate a bug in the backend solver, or SBV itself. Please report."- ]+ notify $ "Validating the model. " ++ if null env then "There are no assignments." else "Assignment:"+ mapM_ notify [" " ++ l | l <- lines envShown] - notConcrete sv = wrap ("Data.SBV: Cannot validate the model, since " ++ show sv ++ " is not concretely computable.")- ( perhaps (why sv)- ++ [ "SBV's model validator is incomplete, and cannot handle this particular case."- , "Please report this as a feature request or possibly a bug!"- ]- )- where perhaps Nothing = []- perhaps (Just x) = [x, ""]+ result <- snd <$> runSymbolic cfg (Concrete (Just (isSAT, env))) (reducer p >>= output) - -- This is incomplete, but should capture the most common cases- why s = case s `lookup` S.toList (pgmAssignments (resAsgns result)) of- Nothing -> Nothing- Just (SBVApp o as) -> case o of- Uninterpreted v -> Just $ "The value depends on the uninterpreted constant " ++ show v ++ "."- IEEEFP FP_FMA -> Just "Floating point FMA operation is not supported concretely."- IEEEFP _ -> Just "Not all floating point operations are supported concretely."- OverflowOp _ -> Just "Overflow-checking is not done concretely."- _ -> listToMaybe $ mapMaybe why as+ let explain = [ ""+ , "Assignment:" ++ if null env then " <none>" else ""+ ]+ ++ [ "" | not (null env)]+ ++ [ " " ++ l | l <- lines envShown]+ ++ [ "" ] - cstrs = S.toList $ resConstraints result+ wrap tag extras = pure $ ProofError cfg (tag : explain ++ extras) (Just res) - walkConstraints [] cont = do- unless (null cstrs) $ notify "Validated all constraints."- cont- walkConstraints ((isSoft, attrs, sv) : rest) cont- | kindOf sv /= KBool- = giveUp $ "Constraint tied to " ++ show sv ++ " is non-boolean."- | isSoft || sv == trueSV- = walkConstraints rest cont- | sv == falseSV- = case mbName of- Just nm -> badModel $ "Named constraint " ++ show nm ++ " evaluated to False."- Nothing -> badModel "A constraint was violated."- | True- = notConcrete sv- where mbName = listToMaybe [n | (":named", n) <- attrs]+ giveUp s = wrap ("Data.SBV: Cannot validate the model: " ++ s)+ [ "SBV's model validator is incomplete, and cannot handle this particular case."+ , "Please report this as a feature request or possibly a bug!"+ ] - -- SAT: All outputs must be true- satLoop []- = do notify "All outputs are satisfied. Validation complete."- return res- satLoop (sv:svs)- | kindOf sv /= KBool- = giveUp $ "Output tied to " ++ show sv ++ " is non-boolean."- | sv == trueSV- = satLoop svs- | sv == falseSV- = badModel "Final output evaluated to False."- | True- = notConcrete sv+ badModel s = wrap ("Data.SBV: Model validation failure: " ++ s)+ [ "Backend solver returned a model that does not satisfy the constraints."+ , "This could indicate a bug in the backend solver, or SBV itself. Please report."+ ] - -- Proof: At least one output must be false- proveLoop [] somethingFailed- | somethingFailed = do notify "Counterexample is validated."- return res- | True = do notify "Counterexample violates none of the outputs."- badModel "Counter-example violates no constraints."- proveLoop (sv:svs) somethingFailed- | kindOf sv /= KBool- = giveUp $ "Output tied to " ++ show sv ++ " is non-boolean."- | sv == trueSV- = proveLoop svs somethingFailed- | sv == falseSV- = proveLoop svs True- | True- = notConcrete sv+ notConcrete sv = wrap ("Data.SBV: Cannot validate the model, since " ++ show sv ++ " is not concretely computable.")+ ( perhaps (why sv)+ )+ where perhaps Nothing = case resObservables result of+ [] -> []+ xs -> [ "There are observable values in the model: " ++ unwords [show n | (n, _, _) <- xs]+ , "SBV cannot validate in the presence of observables, unfortunately."+ , "Try validation after removing calls to 'observe'."+ ] - -- Output checking is tricky, since we behave differently for different modes- checkOutputs []- | null cstrs- = giveUp "Impossible happened: There are no outputs nor any constraints to check."- checkOutputs os- = do notify "Validating outputs."- if isSAT then satLoop os- else proveLoop os False+ perhaps (Just x) = [ x+ , ""+ , "SBV's model validator is incomplete, and cannot handle this particular case."+ , "Please report this as a feature request or possibly a bug!"+ ] - notify $ if null cstrs- then "There are no constraints to check."- else "Validating " ++ show (length cstrs) ++ " constraint(s)."+ -- This is incomplete, but should capture the most common cases+ why s = case s `lookup` S.toList (pgmAssignments (resAsgns result)) of+ Nothing -> Nothing+ Just (SBVApp o as) -> case o of+ QuantifiedBool{} -> Just "The value depends on a quantified variable."+ IEEEFP FP_FMA -> Just "Floating point FMA operation is not supported concretely."+ IEEEFP _ -> Just "Not all floating point operations are supported concretely."+ OverflowOp _ -> Just "Overflow-checking is not done concretely."+ Uninterpreted v+ | any isADT as -> Just "Models containing ADTs are currently only partially supported."+ | True -> Just $ "The value depends on the uninterpreted constant " ++ T.unpack v ++ "."+ _ -> listToMaybe $ mapMaybe why as - walkConstraints cstrs (checkOutputs (resOutputs result))+ cstrs = S.toList $ resConstraints result --- | `Provable` is specialization of `MProvable` to the `IO` monad. Unless you are using--- transformers explicitly, this is the type you should prefer.-type Provable = MProvable IO+ walkConstraints [] cont = do+ unless (null cstrs) $ notify "Validated all constraints."+ cont+ walkConstraints ((isSoft, attrs, sv) : rest) cont+ | kindOf sv /= KBool+ = giveUp $ "Constraint tied to " ++ show sv ++ " is non-boolean."+ | isSoft || sv == trueSV+ = walkConstraints rest cont+ | sv == falseSV+ = case mbName of+ Just nm -> badModel $ "Named constraint " ++ show nm ++ " evaluated to False."+ Nothing -> badModel "A constraint was violated."+ | True+ = notConcrete sv+ where mbName = listToMaybe [n | (":named", n) <- attrs] --- | Prove a property with multiple solvers, running them in separate threads. The--- results will be returned in the order produced.-proveWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, NominalDiffTime, ThmResult)]-proveWithAll = (`sbvWithAll` proveWith)+ -- SAT: All outputs must be true+ satLoop []+ = do notify "All outputs are satisfied. Validation complete."+ pure res+ satLoop (sv:svs)+ | kindOf sv /= KBool+ = giveUp $ "Output tied to " ++ show sv ++ " is non-boolean."+ | sv == trueSV+ = satLoop svs+ | sv == falseSV+ = badModel "Final output evaluated to False."+ | True+ = notConcrete sv --- | Prove a property with multiple solvers, running them in separate threads. Only--- the result of the first one to finish will be returned, remaining threads will be killed.--- Note that we send an exception to the losing processes, but we do *not* actually wait for them--- to finish. In rare cases this can lead to zombie processes. In previous experiments, we found--- that some processes take their time to terminate. So, this solution favors quick turnaround.-proveWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, NominalDiffTime, ThmResult)-proveWithAny = (`sbvWithAny` proveWith)+ -- Proof: At least one output must be false+ proveLoop [] somethingFailed+ | somethingFailed = do notify "Counterexample is validated."+ pure res+ | True = do notify "Counterexample violates none of the outputs."+ badModel "Counter-example violates no constraints."+ proveLoop (sv:svs) somethingFailed+ | kindOf sv /= KBool+ = giveUp $ "Output tied to " ++ show sv ++ " is non-boolean."+ | sv == trueSV+ = proveLoop svs somethingFailed+ | sv == falseSV+ = proveLoop svs True+ | True+ = notConcrete sv --- | Find a satisfying assignment to a property with multiple solvers, running them in separate threads. The--- results will be returned in the order produced.-satWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, NominalDiffTime, SatResult)]-satWithAll = (`sbvWithAll` satWith)+ -- Output checking is tricky, since we behave differently for different modes+ checkOutputs []+ | null cstrs+ = giveUp "Impossible happened: There are no outputs nor any constraints to check."+ checkOutputs os+ = do notify "Validating outputs."+ if isSAT then satLoop os+ else proveLoop os False --- | Find a satisfying assignment to a property with multiple solvers, running them in separate threads. Only--- the result of the first one to finish will be returned, remaining threads will be killed.--- Note that we send an exception to the losing processes, but we do *not* actually wait for them--- to finish. In rare cases this can lead to zombie processes. In previous experiments, we found--- that some processes take their time to terminate. So, this solution favors quick turnaround.-satWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, NominalDiffTime, SatResult)-satWithAny = (`sbvWithAny` satWith)+ notify $ if null cstrs+ then "There are no constraints to check."+ else "Validating " ++ show (length cstrs) ++ " constraint(s)." --- | Find a satisfying assignment to a property using a single solver, but--- providing several query problems of interest, with each query running in a--- separate thread and return the first one that returns. This can be useful to--- use symbolic mode to drive to a location in the search space of the solver--- and then refine the problem in query mode. If the computation is very hard to--- solve for the solver than running in concurrent mode may provide a large--- performance benefit.-satConcurrentWithAny :: Provable a => SMTConfig -> [Query b] -> a -> IO (Solver, NominalDiffTime, SatResult)-satConcurrentWithAny solver qs a = do (slvr,time,result) <- sbvConcurrentWithAny solver go qs a- return (slvr, time, SatResult result)- where go cfg a' q = runWithQuery True (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a'+ walkConstraints cstrs (checkOutputs (resOutputs result)) --- | Prove a property by running many queries each isolated to their own thread--- concurrently and return the first that finishes, killing the others-proveConcurrentWithAny :: Provable a => SMTConfig -> [Query b] -> a -> IO (Solver, NominalDiffTime, ThmResult)-proveConcurrentWithAny solver qs a = do (slvr,time,result) <- sbvConcurrentWithAny solver go qs a- return (slvr, time, ThmResult result)- where go cfg a' q = runWithQuery False (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a'+-- | Given a satisfiability problem, extract the function definitions in it+defs2smt :: SatisfiableM m a => a -> m String+defs2smt = generateSMTBenchMarkGen True satArgReduce defs+ where defs (SMTLibPgm _ _ ds) = T.unpack ds --- | Find a satisfying assignment to a property using a single solver, but run--- each query problem in a separate isolated thread and wait for each thread to--- finish. See 'satConcurrentWithAny' for more details.-satConcurrentWithAll :: Provable a => SMTConfig -> [Query b] -> a -> IO [(Solver, NominalDiffTime, SatResult)]-satConcurrentWithAll solver qs a = do results <- sbvConcurrentWithAll solver go qs a- return $ (\(a',b,c) -> (a',b,SatResult c)) <$> results- where go cfg a' q = runWithQuery True (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a'+-- | Create an SMT-Lib2 benchmark, for a SAT query.+generateSMTBenchmarkSat :: SatisfiableM m a => a -> m String+generateSMTBenchmarkSat = generateSMTBenchMarkGen True satArgReduce (\p -> show p ++ "\n(check-sat)\n") --- | Prove a property by running many queries each isolated to their own thread--- concurrently and wait for each to finish returning all results-proveConcurrentWithAll :: Provable a => SMTConfig -> [Query b] -> a -> IO [(Solver, NominalDiffTime, ThmResult)]-proveConcurrentWithAll solver qs a = do results <- sbvConcurrentWithAll solver go qs a- return $ (\(a',b,c) -> (a',b,ThmResult c)) <$> results- where go cfg a' q = runWithQuery False (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a'+-- | Create an SMT-Lib2 benchmark, for a Proof query.+generateSMTBenchmarkProof :: ProvableM m a => a -> m String+generateSMTBenchmarkProof = generateSMTBenchMarkGen False proofArgReduce (\p -> show p ++ "\n(check-sat)\n") --- | Create an SMT-Lib2 benchmark. The 'Bool' argument controls whether this is a SAT instance, i.e.,--- translate the query directly, or a PROVE instance, i.e., translate the negated query.-generateSMTBenchmark :: (MonadIO m, MProvable m a) => Bool -> a -> m String-generateSMTBenchmark isSat a = do+-- | Generic benchmark creator+generateSMTBenchMarkGen :: MonadIO m => Bool -> (a -> SymbolicT m SBool) -> (SMTLibPgm -> b) -> a -> m b+generateSMTBenchMarkGen isSat reduce render a = do t <- liftIO getZonedTime let comments = ["Automatically created by SBV on " ++ show t] cfg = defaultSMTCfg { smtLibVersion = SMTLib2 } - (_, res) <- runSymbolic (SMTMode QueryInternal ISetup isSat cfg) $ (if isSat then existential_ else universal_) a >>= output+ (_, res) <- runSymbolic cfg (SMTMode QueryInternal ISetup isSat cfg) $ reduce a >>= output let SMTProblem{smtLibPgm} = Control.runProofOn (SMTMode QueryInternal IRun isSat cfg) QueryInternal comments res- out = show (smtLibPgm cfg) - return $ out ++ "\n(check-sat)\n"+ pure $ render (smtLibPgm cfg) checkNoOptimizations :: MonadIO m => QueryT m () checkNoOptimizations = do objectives <- Control.getObjectives@@ -641,127 +588,175 @@ , "*** Use \"optimize\"/\"optimizeWith\" to calculate optimal satisfaction!" ] --- If we get a program producing nothing (i.e., Symbolic ()), pretend it simply returns True.--- This is useful since min/max calls and constraints will provide the context-instance ExtractIO m => MProvable m (SymbolicT m ()) where- universal_ a = universal_ ((a >> return sTrue) :: SymbolicT m SBool)- universal ns a = universal ns ((a >> return sTrue) :: SymbolicT m SBool)- existential_ a = existential_ ((a >> return sTrue) :: SymbolicT m SBool)- existential ns a = existential ns ((a >> return sTrue) :: SymbolicT m SBool)+instance ExtractIO m => SatisfiableM m (SymbolicT m ()) where satArgReduce a = satArgReduce ((a >> pure sTrue) :: SymbolicT m SBool)+-- instance ExtractIO m => ProvableM m (SymbolicT m ()) -- NO INSTANCE ON PURPOSE; don't want to prove goals -instance ExtractIO m => MProvable m (SymbolicT m SBool) where- universal_ = id- universal [] = id- universal xs = error $ "SBV.universal: Extra unmapped name(s) in predicate construction: " ++ intercalate ", " xs- existential_ = id- existential [] = id- existential xs = error $ "SBV.existential: Extra unmapped name(s) in predicate construction: " ++ intercalate ", " xs+instance ExtractIO m => SatisfiableM m (SymbolicT m SBool) where satArgReduce = id+instance ExtractIO m => ProvableM m (SymbolicT m SBool) where proofArgReduce = id -instance ExtractIO m => MProvable m SBool where- universal_ = return- universal _ = return- existential_ = return- existential _ = return+instance ExtractIO m => SatisfiableM m SBool where satArgReduce = pure+instance ExtractIO m => ProvableM m SBool where proofArgReduce = pure +instance {-# OVERLAPPABLE #-} (ExtractIO m, SatisfiableM m a) => SatisfiableM m (SymbolicT m a) where satArgReduce a = a >>= satArgReduce+instance {-# OVERLAPPABLE #-} (ExtractIO m, ProvableM m a) => ProvableM m (SymbolicT m a) where proofArgReduce a = a >>= proofArgReduce++instance (ExtractIO m, SymVal a, Constraint Symbolic r, SatisfiableM m r) => SatisfiableM m (Forall nm a -> r) where+ satArgReduce = satArgReduce . quantifiedBool++instance (ExtractIO m, SymVal a, Constraint Symbolic r, ProvableM m r) => ProvableM m (Forall nm a -> r) where+ proofArgReduce = proofArgReduce . quantifiedBool++instance (ExtractIO m, SymVal a, Constraint Symbolic r, SatisfiableM m r) => SatisfiableM m (Exists nm a -> r) where+ satArgReduce = satArgReduce . quantifiedBool++instance (ExtractIO m, SymVal a, Constraint Symbolic r, SatisfiableM m r, EqSymbolic (SBV a)) => SatisfiableM m (ExistsUnique nm a -> r) where+ satArgReduce = satArgReduce . quantifiedBool++instance (KnownNat n, ExtractIO m, SymVal a, Constraint Symbolic r, ProvableM m r) => ProvableM m (ForallN n nm a -> r) where+ proofArgReduce = proofArgReduce . quantifiedBool++instance (KnownNat n, ExtractIO m, SymVal a, Constraint Symbolic r, SatisfiableM m r) => SatisfiableM m (ExistsN n nm a -> r) where+ satArgReduce = satArgReduce . quantifiedBool++instance (ExtractIO m, SymVal a, Constraint Symbolic r, ProvableM m r) => ProvableM m (Exists nm a -> r) where+ proofArgReduce = proofArgReduce . quantifiedBool++instance (ExtractIO m, SymVal a, Constraint Symbolic r, ProvableM m r, EqSymbolic (SBV a)) => ProvableM m (ExistsUnique nm a -> r) where+ proofArgReduce = proofArgReduce . quantifiedBool++instance (KnownNat n, ExtractIO m, SymVal a, Constraint Symbolic r, SatisfiableM m r) => SatisfiableM m (ForallN n nm a -> r) where+ satArgReduce = satArgReduce . quantifiedBool++instance (KnownNat n, ExtractIO m, SymVal a, Constraint Symbolic r, ProvableM m r) => ProvableM m (ExistsN n nm a -> r) where+ proofArgReduce = proofArgReduce . quantifiedBool+ {---- The following works, but it lets us write properties that+-- The following is a possible definition, but it lets us write properties that -- are not useful.. Such as: prove $ \x y -> (x::SInt8) == y--- Running that will throw an exception since Haskell's equality--- is not be supported by symbolic things. (Needs .==).-instance Provable Bool where- universal_ x = universal_ (if x then true else false :: SBool)- universal s x = universal s (if x then true else false :: SBool)- existential_ x = existential_ (if x then true else false :: SBool)- existential s x = existential s (if x then true else false :: SBool)+-- Running that will throw an exception since Haskell's equality is not be supported by symbolic things. (Needs .==).+-- So, we avoid these instances.+instance ExtractIO m => ProvableM m Bool where+ proofArgReduce x = proofArgReduce (if x then sTrue else sFalse :: SBool)++instance ExtractIO m => SatisfiableM m Bool where+ satArgReduce x = satArgReduce (if x then sTrue else sFalse :: SBool) -} +-- | Create an argument+mkArg :: (SymVal a, MonadSymbolic m) => m (SBV a)+mkArg = mkSymVal (NonQueryVar Nothing) Nothing+ -- Functions-instance (SymVal a, MProvable m p) => MProvable m (SBV a -> p) where- universal_ k = sbvForall_ >>= \a -> universal_ $ k a- universal (s:ss) k = sbvForall s >>= \a -> universal ss $ k a- universal [] k = universal_ k- existential_ k = sbvExists_ >>= \a -> existential_ $ k a- existential (s:ss) k = sbvExists s >>= \a -> existential ss $ k a- existential [] k = existential_ k+instance (SymVal a, SatisfiableM m p) => SatisfiableM m (SBV a -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ fn a --- Arrays-instance (HasKind a, HasKind b, MProvable m p) => MProvable m (SArray a b -> p) where- universal_ k = newArray_ Nothing >>= \a -> universal_ $ k a- universal (s:ss) k = newArray s Nothing >>= \a -> universal ss $ k a- universal [] k = universal_ k- existential_ k = newArray_ Nothing >>= \a -> existential_ $ k a- existential (s:ss) k = newArray s Nothing >>= \a -> existential ss $ k a- existential [] k = existential_ k+instance (SymVal a, ProvableM m p) => ProvableM m (SBV a -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ fn a +-- | Create an 'SBVs' sequence of arguments+mkArgs :: MonadSymbolic m => SymValInsts as -> m (SBVs as)+mkArgs SymValsNil = pure SBVsNil+mkArgs (SymValsCons insts) = SBVsCons <$> mkArgs insts <*> mkArg++-- Multi-arity Functions+instance (SymVals as, SatisfiableM m p) => SatisfiableM m (SBVs as -> p) where+ satArgReduce fn = mkArgs symValInsts >>= \args -> satArgReduce $ fn args++instance (SymVals as, ProvableM m p) => ProvableM m (SBVs as -> p) where+ proofArgReduce fn = mkArgs symValInsts >>= \args -> proofArgReduce $ fn args+ -- 2 Tuple-instance (SymVal a, SymVal b, MProvable m p) => MProvable m ((SBV a, SBV b) -> p) where- universal_ k = sbvForall_ >>= \a -> universal_ $ \b -> k (a, b)- universal (s:ss) k = sbvForall s >>= \a -> universal ss $ \b -> k (a, b)- universal [] k = universal_ k- existential_ k = sbvExists_ >>= \a -> existential_ $ \b -> k (a, b)- existential (s:ss) k = sbvExists s >>= \a -> existential ss $ \b -> k (a, b)- existential [] k = existential_ k+instance (SymVal a, SymVal b, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b -> fn (a, b) +instance (SymVal a, SymVal b, ProvableM m p) => ProvableM m ((SBV a, SBV b) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b -> fn (a, b)+ -- 3 Tuple-instance (SymVal a, SymVal b, SymVal c, MProvable m p) => MProvable m ((SBV a, SBV b, SBV c) -> p) where- universal_ k = sbvForall_ >>= \a -> universal_ $ \b c -> k (a, b, c)- universal (s:ss) k = sbvForall s >>= \a -> universal ss $ \b c -> k (a, b, c)- universal [] k = universal_ k- existential_ k = sbvExists_ >>= \a -> existential_ $ \b c -> k (a, b, c)- existential (s:ss) k = sbvExists s >>= \a -> existential ss $ \b c -> k (a, b, c)- existential [] k = existential_ k+instance (SymVal a, SymVal b, SymVal c, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c -> fn (a, b, c) +instance (SymVal a, SymVal b, SymVal c, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c -> fn (a, b, c)+ -- 4 Tuple-instance (SymVal a, SymVal b, SymVal c, SymVal d, MProvable m p) => MProvable m ((SBV a, SBV b, SBV c, SBV d) -> p) where- universal_ k = sbvForall_ >>= \a -> universal_ $ \b c d -> k (a, b, c, d)- universal (s:ss) k = sbvForall s >>= \a -> universal ss $ \b c d -> k (a, b, c, d)- universal [] k = universal_ k- existential_ k = sbvExists_ >>= \a -> existential_ $ \b c d -> k (a, b, c, d)- existential (s:ss) k = sbvExists s >>= \a -> existential ss $ \b c d -> k (a, b, c, d)- existential [] k = existential_ k+instance (SymVal a, SymVal b, SymVal c, SymVal d, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c, SBV d) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c d -> fn (a, b, c, d) +instance (SymVal a, SymVal b, SymVal c, SymVal d, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c, SBV d) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c d -> fn (a, b, c, d)+ -- 5 Tuple-instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, MProvable m p) => MProvable m ((SBV a, SBV b, SBV c, SBV d, SBV e) -> p) where- universal_ k = sbvForall_ >>= \a -> universal_ $ \b c d e -> k (a, b, c, d, e)- universal (s:ss) k = sbvForall s >>= \a -> universal ss $ \b c d e -> k (a, b, c, d, e)- universal [] k = universal_ k- existential_ k = sbvExists_ >>= \a -> existential_ $ \b c d e -> k (a, b, c, d, e)- existential (s:ss) k = sbvExists s >>= \a -> existential ss $ \b c d e -> k (a, b, c, d, e)- existential [] k = existential_ k+instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c, SBV d, SBV e) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c d e -> fn (a, b, c, d, e) +instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c, SBV d, SBV e) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c d e -> fn (a, b, c, d, e)+ -- 6 Tuple-instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, MProvable m p) => MProvable m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> p) where- universal_ k = sbvForall_ >>= \a -> universal_ $ \b c d e f -> k (a, b, c, d, e, f)- universal (s:ss) k = sbvForall s >>= \a -> universal ss $ \b c d e f -> k (a, b, c, d, e, f)- universal [] k = universal_ k- existential_ k = sbvExists_ >>= \a -> existential_ $ \b c d e f -> k (a, b, c, d, e, f)- existential (s:ss) k = sbvExists s >>= \a -> existential ss $ \b c d e f -> k (a, b, c, d, e, f)- existential [] k = existential_ k+instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c d e f -> fn (a, b, c, d, e, f) +instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c d e f -> fn (a, b, c, d, e, f)+ -- 7 Tuple-instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, MProvable m p) => MProvable m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> p) where- universal_ k = sbvForall_ >>= \a -> universal_ $ \b c d e f g -> k (a, b, c, d, e, f, g)- universal (s:ss) k = sbvForall s >>= \a -> universal ss $ \b c d e f g -> k (a, b, c, d, e, f, g)- universal [] k = universal_ k- existential_ k = sbvExists_ >>= \a -> existential_ $ \b c d e f g -> k (a, b, c, d, e, f, g)- existential (s:ss) k = sbvExists s >>= \a -> existential ss $ \b c d e f g -> k (a, b, c, d, e, f, g)- existential [] k = existential_ k+instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c d e f g -> fn (a, b, c, d, e, f, g) +instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c d e f g -> fn (a, b, c, d, e, f, g)++-- 8 Tuple+instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c d e f g h -> fn (a, b, c, d, e, f, g, h)++instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c d e f g h -> fn (a, b, c, d, e, f, g, h)++-- 9 Tuple+instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, SymVal i, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h, SBV i) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c d e f g h i -> fn (a, b, c, d, e, f, g, h, i)++instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, SymVal i, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h, SBV i) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c d e f g h i -> fn (a, b, c, d, e, f, g, h, i)++-- 10 Tuple+instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, SymVal i, SymVal j, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h, SBV i, SBV j) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c d e f g h i j -> fn (a, b, c, d, e, f, g, h, i, j)++instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, SymVal i, SymVal j, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h, SBV i, SBV j) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c d e f g h i j -> fn (a, b, c, d, e, f, g, h, i, j)++-- 11 Tuple+instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, SymVal i, SymVal j, SymVal k, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h, SBV i, SBV j, SBV k) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c d e f g h i j k -> fn (a, b, c, d, e, f, g, h, i, j, k)++instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, SymVal i, SymVal j, SymVal k, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h, SBV i, SBV j, SBV k) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c d e f g h i j k -> fn (a, b, c, d, e, f, g, h, i, j, k)++-- 12 Tuple+instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, SymVal i, SymVal j, SymVal k, SymVal l, SatisfiableM m p) => SatisfiableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h, SBV i, SBV j, SBV k, SBV l) -> p) where+ satArgReduce fn = mkArg >>= \a -> satArgReduce $ \b c d e f g h i j k l -> fn (a, b, c, d, e, f, g, h, i, j, k, l)++instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h, SymVal i, SymVal j, SymVal k, SymVal l, ProvableM m p) => ProvableM m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h, SBV i, SBV j, SBV k, SBV l) -> p) where+ proofArgReduce fn = mkArg >>= \a -> proofArgReduce $ \b c d e f g h i j k l -> fn (a, b, c, d, e, f, g, h, i, j, k, l)+ -- | Generalization of 'Data.SBV.runSMT' runSMT :: MonadIO m => SymbolicT m a -> m a runSMT = runSMTWith defaultSMTCfg -- | Generalization of 'Data.SBV.runSMTWith' runSMTWith :: MonadIO m => SMTConfig -> SymbolicT m a -> m a-runSMTWith cfg a = fst <$> runSymbolic (SMTMode QueryExternal ISetup True cfg) a+runSMTWith cfg a = fst <$> runSymbolic cfg (SMTMode QueryExternal ISetup True cfg) a -- | Runs with a query.-runWithQuery :: MProvable m a => Bool -> QueryT m b -> SMTConfig -> a -> m b-runWithQuery isSAT q cfg a = fst <$> runSymbolic (SMTMode QueryInternal ISetup isSAT cfg) comp- where comp = do _ <- (if isSAT then existential_ else universal_) a >>= output+runWithQuery :: ExtractIO m => (a -> SymbolicT m SBool) -> Bool -> QueryT m b -> SMTConfig -> a -> m b+runWithQuery reducer isSAT q cfg a = fst <$> runSymbolic cfg (SMTMode QueryInternal ISetup isSAT cfg) comp+ where comp = do _ <- reducer a >>= output Control.executeQuery QueryInternal q --- | Check if a safe-call was safe or not, turning a 'SafeResult' to a Bool.+-- | Check if a safe-call was safe or not, turning a t'SafeResult' to a Bool. isSafe :: SafeResult -> Bool isSafe (SafeResult (_, _, result)) = case result of Unsatisfiable{} -> True@@ -776,14 +771,14 @@ runInThread beginTime action config = async $ do result <- action config endTime <- rnf result `seq` getCurrentTime- return (name (solver config), endTime `diffUTCTime` beginTime, result)+ pure (name (solver config), endTime `diffUTCTime` beginTime, result) -- | Perform action for all given configs, return the first one that wins. Note that we do -- not wait for the other asyncs to terminate; hopefully they'll do so quickly. sbvWithAny :: NFData b => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO (Solver, NominalDiffTime, b) sbvWithAny [] _ _ = error "SBV.withAny: No solvers given!" sbvWithAny solvers what a = do beginTime <- getCurrentTime- snd `fmap` (mapM (runInThread beginTime (`what` a)) solvers >>= waitAnyFastCancel)+ snd <$> (mapM (runInThread beginTime (`what` a)) solvers >>= waitAnyFastCancel) where -- Async's `waitAnyCancel` nicely blocks; so we use this variant to ignore the -- wait part for killed threads. waitAnyFastCancel asyncs = waitAny asyncs `finally` mapM_ cancelFast asyncs@@ -791,7 +786,7 @@ sbvConcurrentWithAny :: NFData c => SMTConfig -> (SMTConfig -> a -> QueryT m b -> IO c) -> [QueryT m b] -> a -> IO (Solver, NominalDiffTime, c)-sbvConcurrentWithAny solver what queries a = snd `fmap` (mapM runQueryInThread queries >>= waitAnyFastCancel)+sbvConcurrentWithAny solver what queries a = snd <$> (mapM runQueryInThread queries >>= waitAnyFastCancel) where -- Async's `waitAnyCancel` nicely blocks; so we use this variant to ignore the -- wait part for killed threads. waitAnyFastCancel asyncs = waitAny asyncs `finally` mapM_ cancelFast asyncs@@ -805,7 +800,7 @@ where runQueryInThread q = do beginTime <- getCurrentTime runInThread beginTime (\cfg -> what cfg a q) solver - go [] = return []+ go [] = pure [] go as = do (d, r) <- waitAny as -- The following filter works because the Eq instance on Async -- checks the thread-id; so we know that we're removing the@@ -813,13 +808,13 @@ -- running the same-solver (with different options), since -- they will get different thread-ids. rs <- unsafeInterleaveIO $ go (filter (/= d) as)- return (r : rs)+ pure (r : rs) -- | Perform action for all given configs, return all the results. sbvWithAll :: NFData b => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO [(Solver, NominalDiffTime, b)] sbvWithAll solvers what a = do beginTime <- getCurrentTime mapM (runInThread beginTime (`what` a)) solvers >>= (unsafeInterleaveIO . go)- where go [] = return []+ where go [] = pure [] go as = do (d, r) <- waitAny as -- The following filter works because the Eq instance on Async -- checks the thread-id; so we know that we're removing the@@ -827,15 +822,13 @@ -- running the same-solver (with different options), since -- they will get different thread-ids. rs <- unsafeInterleaveIO $ go (filter (/= d) as)- return (r : rs)+ pure (r : rs) -- | Symbolically executable program fragments. This class is mainly used for 'safe' calls, and is sufficiently populated internally to cover most use -- cases. Users can extend it as they wish to allow 'safe' checks for SBV programs that return/take types that are user-defined. class ExtractIO m => SExecutable m a where- -- | Generalization of 'Data.SBV.sName_'- sName_ :: a -> SymbolicT m () -- | Generalization of 'Data.SBV.sName'- sName :: [String] -> a -> SymbolicT m ()+ sName :: a -> SymbolicT m () -- | Generalization of 'Data.SBV.safe' safe :: a -> m [SafeResult]@@ -847,7 +840,7 @@ let mkRelative path | cwd `isPrefixOf` path = drop (length cwd) path | True = path- fst <$> runSymbolic (SMTMode QueryInternal ISafe True cfg) (sName_ a >> check mkRelative)+ fst <$> runSymbolic cfg (SMTMode QueryInternal ISafe True cfg) (sName a >> check mkRelative) where check :: (FilePath -> FilePath) -> SymbolicT m [SafeResult] check mkRelative = Control.executeQuery QueryInternal $ Control.getSBVAssertions >>= mapM (verify mkRelative) @@ -857,105 +850,80 @@ verify mkRelative (msg, cs, cond) = do let locInfo ps = let loc (f, sl) = concat [mkRelative (srcLocFile sl), ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f] in intercalate ",\n " (map loc ps)- location = (locInfo . getCallStack) `fmap` cs+ location = locInfo . getCallStack <$> cs result <- do Control.push 1- Control.send True $ "(assert " ++ show cond ++ ")"+ Control.send True $ "(assert " <> showText cond <> ")" r <- Control.getSMTResult Control.pop 1- return r+ pure r - return $ SafeResult (location, msg, result)+ pure $ SafeResult (location, msg, result) instance (ExtractIO m, NFData a) => SExecutable m (SymbolicT m a) where- sName_ a = a >>= \r -> rnf r `seq` return ()- sName [] = sName_- sName xs = error $ "SBV.SExecutable.sName: Extra unmapped name(s): " ++ intercalate ", " xs+ sName a = a >>= \r -> rnf r `seq` pure () instance ExtractIO m => SExecutable m (SBV a) where- sName_ v = sName_ (output v :: SymbolicT m (SBV a))- sName xs v = sName xs (output v :: SymbolicT m (SBV a))+ sName v = sName (output v :: SymbolicT m (SBV a)) -- Unit output instance ExtractIO m => SExecutable m () where- sName_ () = sName_ (output () :: SymbolicT m ())- sName xs () = sName xs (output () :: SymbolicT m ())+ sName () = sName (output () :: SymbolicT m ()) -- List output instance ExtractIO m => SExecutable m [SBV a] where- sName_ vs = sName_ (output vs :: SymbolicT m [SBV a])- sName xs vs = sName xs (output vs :: SymbolicT m [SBV a])+ sName vs = sName (output vs :: SymbolicT m [SBV a]) -- 2 Tuple output instance (ExtractIO m, NFData a, SymVal a, NFData b, SymVal b) => SExecutable m (SBV a, SBV b) where- sName_ (a, b) = sName_ (output a >> output b :: SymbolicT m (SBV b))- sName _ = sName_+ sName (a, b) = sName (output a >> output b :: SymbolicT m (SBV b)) -- 3 Tuple output instance (ExtractIO m, NFData a, SymVal a, NFData b, SymVal b, NFData c, SymVal c) => SExecutable m (SBV a, SBV b, SBV c) where- sName_ (a, b, c) = sName_ (output a >> output b >> output c :: SymbolicT m (SBV c))- sName _ = sName_+ sName (a, b, c) = sName (output a >> output b >> output c :: SymbolicT m (SBV c)) -- 4 Tuple output instance (ExtractIO m, NFData a, SymVal a, NFData b, SymVal b, NFData c, SymVal c, NFData d, SymVal d) => SExecutable m (SBV a, SBV b, SBV c, SBV d) where- sName_ (a, b, c, d) = sName_ (output a >> output b >> output c >> output c >> output d :: SymbolicT m (SBV d))- sName _ = sName_+ sName (a, b, c, d) = sName (output a >> output b >> output c >> output c >> output d :: SymbolicT m (SBV d)) -- 5 Tuple output instance (ExtractIO m, NFData a, SymVal a, NFData b, SymVal b, NFData c, SymVal c, NFData d, SymVal d, NFData e, SymVal e) => SExecutable m (SBV a, SBV b, SBV c, SBV d, SBV e) where- sName_ (a, b, c, d, e) = sName_ (output a >> output b >> output c >> output d >> output e :: SymbolicT m (SBV e))- sName _ = sName_+ sName (a, b, c, d, e) = sName (output a >> output b >> output c >> output d >> output e :: SymbolicT m (SBV e)) -- 6 Tuple output instance (ExtractIO m, NFData a, SymVal a, NFData b, SymVal b, NFData c, SymVal c, NFData d, SymVal d, NFData e, SymVal e, NFData f, SymVal f) => SExecutable m (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) where- sName_ (a, b, c, d, e, f) = sName_ (output a >> output b >> output c >> output d >> output e >> output f :: SymbolicT m (SBV f))- sName _ = sName_+ sName (a, b, c, d, e, f) = sName (output a >> output b >> output c >> output d >> output e >> output f :: SymbolicT m (SBV f)) -- 7 Tuple output instance (ExtractIO m, NFData a, SymVal a, NFData b, SymVal b, NFData c, SymVal c, NFData d, SymVal d, NFData e, SymVal e, NFData f, SymVal f, NFData g, SymVal g) => SExecutable m (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) where- sName_ (a, b, c, d, e, f, g) = sName_ (output a >> output b >> output c >> output d >> output e >> output f >> output g :: SymbolicT m (SBV g))- sName _ = sName_+ sName (a, b, c, d, e, f, g) = sName (output a >> output b >> output c >> output d >> output e >> output f >> output g :: SymbolicT m (SBV g)) -- Functions instance (SymVal a, SExecutable m p) => SExecutable m (SBV a -> p) where- sName_ k = sbvExists_ >>= \a -> sName_ $ k a- sName (s:ss) k = sbvExists s >>= \a -> sName ss $ k a- sName [] k = sName_ k+ sName k = mkArg >>= \a -> sName $ k a -- 2 Tuple input instance (SymVal a, SymVal b, SExecutable m p) => SExecutable m ((SBV a, SBV b) -> p) where- sName_ k = sbvExists_ >>= \a -> sName_ $ \b -> k (a, b)- sName (s:ss) k = sbvExists s >>= \a -> sName ss $ \b -> k (a, b)- sName [] k = sName_ k+ sName k = mkArg >>= \a -> sName $ \b -> k (a, b) -- 3 Tuple input instance (SymVal a, SymVal b, SymVal c, SExecutable m p) => SExecutable m ((SBV a, SBV b, SBV c) -> p) where- sName_ k = sbvExists_ >>= \a -> sName_ $ \b c -> k (a, b, c)- sName (s:ss) k = sbvExists s >>= \a -> sName ss $ \b c -> k (a, b, c)- sName [] k = sName_ k+ sName k = mkArg >>= \a -> sName $ \b c -> k (a, b, c) -- 4 Tuple input instance (SymVal a, SymVal b, SymVal c, SymVal d, SExecutable m p) => SExecutable m ((SBV a, SBV b, SBV c, SBV d) -> p) where- sName_ k = sbvExists_ >>= \a -> sName_ $ \b c d -> k (a, b, c, d)- sName (s:ss) k = sbvExists s >>= \a -> sName ss $ \b c d -> k (a, b, c, d)- sName [] k = sName_ k+ sName k = mkArg >>= \a -> sName $ \b c d -> k (a, b, c, d) -- 5 Tuple input instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SExecutable m p) => SExecutable m ((SBV a, SBV b, SBV c, SBV d, SBV e) -> p) where- sName_ k = sbvExists_ >>= \a -> sName_ $ \b c d e -> k (a, b, c, d, e)- sName (s:ss) k = sbvExists s >>= \a -> sName ss $ \b c d e -> k (a, b, c, d, e)- sName [] k = sName_ k+ sName k = mkArg >>= \a -> sName $ \b c d e -> k (a, b, c, d, e) -- 6 Tuple input instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SExecutable m p) => SExecutable m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> p) where- sName_ k = sbvExists_ >>= \a -> sName_ $ \b c d e f -> k (a, b, c, d, e, f)- sName (s:ss) k = sbvExists s >>= \a -> sName ss $ \b c d e f -> k (a, b, c, d, e, f)- sName [] k = sName_ k+ sName k = mkArg >>= \a -> sName $ \b c d e f -> k (a, b, c, d, e, f) -- 7 Tuple input instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SExecutable m p) => SExecutable m ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> p) where- sName_ k = sbvExists_ >>= \a -> sName_ $ \b c d e f g -> k (a, b, c, d, e, f, g)- sName (s:ss) k = sbvExists s >>= \a -> sName ss $ \b c d e f g -> k (a, b, c, d, e, f, g)- sName [] k = sName_ k+ sName k = mkArg >>= \a -> sName $ \b c d e f g -> k (a, b, c, d, e, f, g) -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore module "Reduce duplication" -}
Data/SBV/Provers/Yices.hs view
@@ -9,8 +9,6 @@ -- The connection to the Yices SMT solver ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}- {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Provers.Yices(yices) where@@ -29,24 +27,25 @@ , options = const ["--incremental"] , engine = standardEngine "SBV_YICES" "SBV_YICES_OPTIONS" , capabilities = SolverCapabilities {- supportsQuantifiers = False- , supportsDefineFun = True- , supportsDistinct = True- , supportsBitVectors = True- , supportsUninterpretedSorts = True- , supportsUnboundedInts = True- , supportsInt2bv = False- , supportsReals = True- , supportsApproxReals = False- , supportsDeltaSat = Nothing- , supportsIEEE754 = False- , supportsSets = False- , supportsOptimization = False- , supportsPseudoBooleans = False- , supportsCustomQueries = True- , supportsGlobalDecls = True- , supportsDataTypes = False- , supportsDirectAccessors = False- , supportsFlattenedModels = Nothing+ supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True+ , supportsADTs = True+ , supportsUnboundedInts = True+ , supportsReals = True+ , supportsApproxReals = False+ , supportsDeltaSat = Nothing+ , supportsIEEE754 = False+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = True+ , supportsGlobalDecls = True+ , supportsDataTypes = False+ , supportsLambdas = False+ , supportsSpecialRels = False+ , supportsDirectTesters = False+ , supportsFlattenedModels = Nothing } }
Data/SBV/Provers/Z3.hs view
@@ -6,11 +6,9 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- The connection to the MathSAT SMT solver+-- The connection to the Z3 SMT solver ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}- {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Provers.Z3(z3) where@@ -29,28 +27,29 @@ , options = modConfig ["-nw", "-in", "-smt2"] , engine = standardEngine "SBV_Z3" "SBV_Z3_OPTIONS" , capabilities = SolverCapabilities {- supportsQuantifiers = True- , supportsDefineFun = True- , supportsDistinct = True- , supportsBitVectors = True- , supportsUninterpretedSorts = True- , supportsUnboundedInts = True- , supportsInt2bv = True- , supportsReals = True- , supportsApproxReals = True- , supportsDeltaSat = Nothing- , supportsIEEE754 = True- , supportsSets = True- , supportsOptimization = True- , supportsPseudoBooleans = True- , supportsCustomQueries = True- , supportsGlobalDecls = True- , supportsDataTypes = True- , supportsDirectAccessors = False -- Needs ascriptions. (See the CVC4 version of this)- , supportsFlattenedModels = Just [ "(set-option :pp.max_depth 4294967295)"- , "(set-option :pp.min_alias_size 4294967295)"- , "(set-option :model.inline_def true )"- ]+ supportsQuantifiers = True+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True+ , supportsADTs = True+ , supportsUnboundedInts = True+ , supportsReals = True+ , supportsApproxReals = True+ , supportsDeltaSat = Nothing+ , supportsIEEE754 = True+ , supportsSets = True+ , supportsOptimization = True+ , supportsPseudoBooleans = True+ , supportsCustomQueries = True+ , supportsGlobalDecls = True+ , supportsDataTypes = True+ , supportsLambdas = True+ , supportsSpecialRels = True+ , supportsDirectTesters = False -- Needs ascriptions. (See the CVC4 version of this)+ , supportsFlattenedModels = Just [ "(set-option :pp.max_depth 4294967295)"+ , "(set-option :pp.min_alias_size 4294967295)"+ , "(set-option :model.inline_def true )"+ ] } }
Data/SBV/Rational.hs view
@@ -9,25 +9,36 @@ -- Symbolic rationals, corresponds to Haskell's 'Rational' type ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}+ module Data.SBV.Rational ( -- * Constructing rationals (.%)- ) where+ -- * Rounding rationals+ , sRationalToSIntegerFloor, sRationalToSIntegerCeiling, sRationalToSIntegerTruncate+ , sRationalToSIntegerRoundAway, sRationalToSIntegerRoundToEven, sRationalToSIntegerRM+ -- * Converting between rationals and reals+ , sRationalToSReal, sRealToSRational+ ) where import qualified Data.Ratio as R +import Data.SBV.Core.AlgReals (isExactRational) import Data.SBV.Core.Data-import Data.SBV.Core.Model () -- instances only+import Data.SBV.Core.Model+import Data.SBV.Core.Symbolic (newInternalVariable)+import Data.SBV.Utils.Numeric (roundAway) infixl 7 .% -- | Construct a symbolic rational from a given numerator and denominator. Note that -- it is not possible to deconstruct a rational by taking numerator and denominator -- fields, since we do not represent them canonically. (This is due to the fact that--- SMTLib has no functions to compute the GCD. One can use the maximization engine--- to compute the GCD of numbers, but not as a function.)+-- SMTLib has no functions to compute the GCD. While we can define a recursive function+-- to do so, it would almost always imply non-decidability for even the simplest queries.) (.%) :: SInteger -> SInteger -> SRational top .% bot | Just t <- unliteral top@@ -38,3 +49,234 @@ where res st = do t <- sbvToSV st top b <- sbvToSV st bot newExpr st KRational $ SBVApp RationalConstructor [t, b]++-- | Convert an SRational to an SInteger, @floor@ version. That is, it computes+-- the largest integer @n@ that satisfies @(n .% 1) <= r@.+--+-- For instance, @1.3@ will be @1@, but @-1.3@ will be @-2@.+--+-- See 'sRationalToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRationalToSIntegerFloor :: SRational -> SInteger+-- NB: We use @sDiv@ below because it implements division that truncates+-- towards negative infinity, which is exactly what @floor@ needs.+sRationalToSIntegerFloor = lift1 floor (uncurry sDiv)++-- | Convert an SRational to an SInteger, @ceiling@ version. That is, it+-- computes the smallest integer @n@ that satisfies @r <= (n .% 1)@.+--+-- For instance, @1.3@ will be @2@, but @-1.3@ will be @-1@.+--+-- See 'sRationalToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRationalToSIntegerCeiling :: SRational -> SInteger+sRationalToSIntegerCeiling x+ | Just i <- unliteral x+ = literal $ ceiling i+ | True+ = - (sRationalToSIntegerFloor (- x))++-- | Convert an SRational to an SInteger, truncating version. Truncate simply+-- chops off the fractional part, essentially rounding towards zero.+--+-- For instance, @1.3@ will be @1@, and @-1.3@ will be @-1@.+--+-- See 'sRationalToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRationalToSIntegerTruncate :: SRational -> SInteger+sRationalToSIntegerTruncate x+ | Just i <- unliteral x+ = literal $ truncate i+ | True+ = ite (x .>= 0) (sRationalToSIntegerFloor x) (sRationalToSIntegerCeiling x)++-- | Convert an SRational to an SInteger by converting to the nearest integer.+-- If there is a tie (i.e., if the fractional component of the SRational is+-- equal to 0.5), then round away from zero.+--+-- For instance:+--+-- * @1.3@ will be @1@+-- * @1.5@ will be @2@ (because @abs 1 < abs 2@)+-- * @1.7@ will be @2@+-- * @2.3@ will be @2@+-- * @2.5@ will be @3@ (because @abs 2 < abs 3@)+-- * @2.7@ will be @3@+-- * @-1.3@ will be @-1@+-- * @-1.5@ will be @-2@ (because @abs (-1) < abs (-2)@)+-- * @-1.7@ will be @-2@+-- * @-2.3@ will be @-2@+-- * @-2.5@ will be @-3@ (because @abs (-2) < abs (-3)@)+-- * @-2.7@ will be @-3@+--+-- See 'sRationalToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRationalToSIntegerRoundAway :: SRational -> SInteger+sRationalToSIntegerRoundAway x+ | Just i <- unliteral x+ = literal $ roundAway i+ | True+ = ite+ (x .>= 0)+ (sRationalToSIntegerFloor (x + half))+ (sRationalToSIntegerCeiling (x - half))+ where+ half :: SRational+ half = 0.5++-- | Convert an SRational to an SInteger by converting to the nearest integer.+-- If there is a tie (i.e., if the fractional component of the SRational is+-- equal to 0.5), then round to the nearest even integer.+--+-- For instance:+--+-- * @1.3@ will be @1@+-- * @1.5@ will be @2@ (because @2@ is even)+-- * @1.7@ will be @2@+-- * @2.3@ will be @2@+-- * @2.5@ will be @2@ (because @2@ is even)+-- * @2.7@ will be @3@+-- * @-1.3@ will be @-1@+-- * @-1.5@ will be @-2@ (because @-2@ is even)+-- * @-1.7@ will be @-2@+-- * @-2.3@ will be @-2@+-- * @-2.5@ will be @-2@ (because @-2@ is even)+-- * @-2.7@ will be @-3@+--+-- See 'sRationalToSIntegerRM' to select the rounding mode with a symbolic 'SRoundingMode'.+sRationalToSIntegerRoundToEven :: SRational -> SInteger+sRationalToSIntegerRoundToEven x+ | Just i <- unliteral x+ = literal $ round i+ | True+ = ite (diff .< half) lo $+ ite (diff .> half) hi $+ ite (sDivides 2 lo) lo hi+ where+ half :: SRational+ half = 0.5++ lo, hi :: SInteger+ lo = sRationalToSIntegerFloor x+ hi = lo+1++ diff :: SRational+ diff = x - (lo .% 1)++-- | Convert an 'SRational' to an 'SInteger' according to the supplied+-- 'SRoundingMode'. This dispatches to 'sRationalToSIntegerRoundToEven',+-- 'sRationalToSIntegerRoundAway', 'sRationalToSIntegerCeiling',+-- 'sRationalToSIntegerFloor', and 'sRationalToSIntegerTruncate' for the+-- round-nearest-even, round-nearest-away, round-toward-positive,+-- round-toward-negative, and round-toward-zero modes respectively.+--+-- Note that we re-use the 'SRoundingMode' type here, even though+-- 'SRoundingMode' is normally associated with floating-point operations. The+-- floating-point resemblance is superficial, as this function does not use any+-- floating-point functionality behind the scenes.+sRationalToSIntegerRM :: SRoundingMode -> SRational -> SInteger+sRationalToSIntegerRM rm x =+ sCaseRoundingMode+ (sRationalToSIntegerRoundToEven x)+ (sRationalToSIntegerRoundAway x)+ (sRationalToSIntegerCeiling x)+ (sRationalToSIntegerFloor x)+ (sRationalToSIntegerTruncate x)+ rm++-- | Convert an 'SRational' to an 'SReal'. This conversion is always exact: the+-- rational @t .% b@ maps to the real @t \/ b@. (Recall that denominators are+-- always positive, so no division-by-zero can arise here.)+sRationalToSReal :: SRational -> SReal+sRationalToSReal = lift1 fromRational (\(t, b) -> sFromIntegral t / sFromIntegral b)++-- | Convert an 'SReal' to an 'SRational'. The conversion is /exact/ for reals+-- that are rational: a concrete rational is converted directly, while a+-- symbolic (or non-literal) real is handled by introducing a fresh symbolic+-- rational @r@ and constraining @'sRationalToSReal' r '.==' x@. Thus, whenever+-- the input real is representable as the ratio of two integers, the result+-- denotes exactly that same value---no precision is lost.+--+-- Note the caveat implied by this encoding: if the input real is /irrational/+-- (i.e., not expressible as a ratio of two integers), then the introduced+-- equality constraint is unsatisfiable, which renders the entire problem+-- @UNSAT@. In other words, using this function is an implicit assertion that+-- its argument is a rational number.+sRealToSRational :: SReal -> SRational+sRealToSRational x+ | Just v <- unliteral x, isExactRational v+ = literal (toRational v)+ | True+ = SBV $ SVal KRational $ Right $ cache res+ where res st = do n <- newInternalVariable st KRational+ let r = SBV (SVal KRational (Right (cache (const (pure n))))) :: SRational+ internalConstraint st False [] $ unSBV $ sRationalToSReal r .== x+ pure n++-- | Get the numerator. Note that this is always symbolic since we don't have a concrete representation.+-- Furthermore this is only used internally and is not exported to the user, since it is not canonical.+doNotExport_numerator :: SRational -> SInteger+doNotExport_numerator x = SBV $ SVal KUnbounded $ Right $ cache res+ where res st = do xv <- sbvToSV st x+ newExpr st KUnbounded $ SBVApp (Uninterpreted "sbv.rat.numerator") [xv]++-- | Get the numerator. Note that this is always symbolic since we don't have a concrete representation.+-- Furthermore this is only used internally and is not exported to the user, since it is not canonical.+doNotExport_denominator :: SRational -> SInteger+doNotExport_denominator x = SBV $ SVal KUnbounded $ Right $ cache res+ where res st = do xv <- sbvToSV st x+ newExpr st KUnbounded $ SBVApp (Uninterpreted "sbv.rat.denominator") [xv]++-- | Num instance for SRational. Note that denominators are always positive.+instance Num SRational where+ fromInteger i = SBV $ SVal KRational $ Left $ mkConstCV KRational (fromIntegral i :: Integer)+ (+) = lift2 (+) (\(t1, b1) (t2, b2) -> (t1 * b2 + t2 * b1) .% (b1 * b2))+ (-) = lift2 (-) (\(t1, b1) (t2, b2) -> (t1 * b2 - t2 * b1) .% (b1 * b2))+ (*) = lift2 (*) (\(t1, b1) (t2, b2) -> (t1 * t2 ) .% (b1 * b2))+ abs = lift1 abs (\(t, b) -> abs t .% b)+ negate = lift1 negate (\(t, b) -> negate t .% b)+ signum a = ite (a .> 0) 1 $ ite (a .< 0) (-1) 0++-- | Fractional instance for SRational. Just like the 'Num' instance, division is+-- implemented at the SBV level via cross-multiplication, since SMTLib has no direct+-- support for our rational representation. Note that we keep the denominator positive:+-- dividing by @t2 .% b2@ multiplies the denominator by @t2@, which may be negative, so+-- we flip the signs of both parts when needed. Following the SBV convention for reals,+-- division by zero is defined to be zero.+--+-- We mark this @OVERLAPPING@ as it takes precedence over the generic instance in "Data.SBV.Core.Model",+-- which would otherwise try to translate rational division as an SMTLib @Quot@ (which doesn't exist for our rationals).+instance {-# OVERLAPPING #-} Fractional SRational where+ fromRational = literal . fromRational+ a / b = ite (b .== 0) 0 (lift2 (/) divRat a b)+ where divRat (t1, b1) (t2, b2) = ite (t2 .> 0) ( num .% den)+ (negate num .% negate den)+ where num = t1 * b2+ den = b1 * t2++-- | Symbolic ordering for SRational. Note that denominators are always positive.+instance OrdSymbolic SRational where+ (.<) = lift2 (<) (\(t1, b1) (t2, b2) -> (t1 * b2) .< (b1 * t2))+ (.<=) = lift2 (<=) (\(t1, b1) (t2, b2) -> (t1 * b2) .<= (b1 * t2))+ (.>) = lift2 (>) (\(t1, b1) (t2, b2) -> (t1 * b2) .> (b1 * t2))+ (.>=) = lift2 (>=) (\(t1, b1) (t2, b2) -> (t1 * b2) .>= (b1 * t2))++-- | Get the top and bottom parts. Internal only; do not export!+doNotExport_getTB :: SRational -> (SInteger, SInteger)+doNotExport_getTB a = (doNotExport_numerator a, doNotExport_denominator a)++-- | Lift a function over one rational+lift1 :: SymVal t => (Rational -> t) -> ((SInteger, SInteger) -> SBV t) -> SRational -> SBV t+lift1 cf f a+ | Just va <- unliteral a+ = literal (cf va)+ | True+ = f (doNotExport_getTB a)++-- | Lift a function over two rationals+lift2 :: SymVal t => (Rational -> Rational -> t) -> ((SInteger, SInteger) -> (SInteger, SInteger) -> SBV t) -> SRational -> SRational -> SBV t+lift2 cf f a b+ | Just va <- unliteral a, Just vb <- unliteral b+ = literal (va `cf` vb)+ | True+ = f (doNotExport_getTB a) (doNotExport_getTB b)++{- HLint ignore type doNotExport_numerator "Use camelCase" -}+{- HLint ignore type doNotExport_denominator "Use camelCase" -}+{- HLint ignore type doNotExport_getTB "Use camelCase" -}
Data/SBV/RegExp.hs view
@@ -14,9 +14,9 @@ -- this module. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -50,15 +50,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@@ -66,14 +65,16 @@ -- For testing only import Data.SBV.Char +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> 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 -- | Matchable class. Things we can match against a 'RegExp'. --@@ -85,9 +86,9 @@ -- >>> 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 = "200-8000" :: String+-- s0 = "422-2222" :: String class RegExpMatchable a where -- | @`match` s r@ checks whether @s@ is in the language generated by @r@. match :: a -> RegExp -> SBool@@ -114,7 +115,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@@ -157,7 +158,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]@@ -165,7 +166,7 @@ -- | Recognize a newline. Also includes carriage-return and form-feed. -- -- >>> newline--- (re.union (str.to.re "\n") (str.to.re "\r") (str.to.re "\f"))+-- (re.union (str.to_re "\n") (str.to_re "\r") (str.to_re "\f")) -- >>> prove $ \c -> c `match` newline .=> isSpaceL1 c -- Q.E.D. newline :: RegExp@@ -174,7 +175,7 @@ -- | Recognize a tab. -- -- >>> tab--- (str.to.re "\t")+-- (str.to_re "\t") -- >>> prove $ \c -> c `match` tab .=> c .== literal '\t' -- Q.E.D. tab :: RegExp@@ -182,7 +183,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. --@@ -213,11 +214,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'@@ -226,11 +227,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'@@ -272,7 +273,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@@ -280,8 +281,8 @@ -- | Recognize an octal number. Must have a prefix of the form @0o@\/@0O@. -- -- >>> 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"]+-- (re.++ (re.union (str.to_re "0o") (str.to_re "0O")) (re.+ (re.range "0" "7")))+-- >>> prove $ \(s :: SString) -> s `match` octal .=> sAny (.== take 2 s) ["0o", "0O"] -- Q.E.D. octal :: RegExp octal = ("0o" + "0O") * KPlus octDigit@@ -289,8 +290,8 @@ -- | Recognize a hexadecimal number. Must have a prefix of the form @0x@\/@0X@. -- -- >>> 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"]+-- (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 :: SString) -> s `match` hexadecimal .=> sAny (.== take 2 s) ["0x", "0X"] -- Q.E.D. hexadecimal :: RegExp hexadecimal = ("0x" + "0X") * KPlus hexDigit@@ -298,7 +299,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@@ -310,9 +311,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 + "_" + "'")@@ -334,7 +335,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@@ -347,22 +348,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/SCase.hs view
@@ -0,0 +1,1409 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SBV.SCase+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Add support for symbolic case expressions. Constructed with the help of ChatGPT,+-- which was remarkably good at giving me the basic structure.+--+-- Provides a quasiquoter `[sCase| expr of ... |]` for symbolic cases+-- where @Expr@ is the underlying type. Plain @case@ expressions inside+-- @sCase@ are automatically treated as symbolic case-splits, enabling+-- nested symbolic pattern matching.+--+-- Also provides `[pCase| expr of ... |]` for proof case-splits. Plain+-- @case@ expressions inside @pCase@ are automatically treated as nested+-- proof case-splits (generating @cases [...]@ calls).+-----------------------------------------------------------------------------++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.SCase (sCase, pCase) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import qualified Language.Haskell.Meta.Parse as Meta+import qualified Language.Haskell.Meta.Syntax.Translate as Meta++import qualified Language.Haskell.Exts as E++import Control.Monad (unless, when, zipWithM)++import Data.SBV.Core.TH (getConstructors, sbvName)+import Data.SBV.Core.Model (ite, symWithKind)+import Data.SBV.Core.Data (sTrue, sNot, (.&&), (.||), (.==), (.===), (.:), literal)++import Data.Char (isDigit)+import Data.List (intercalate, stripPrefix)+import Data.Maybe (isJust, fromMaybe, catMaybes)++import Prelude hiding (fail)+import qualified Prelude as P(fail)++import Data.Generics (everywhereM, mkM)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Set (Set)++import System.FilePath++-- | Conjoin a list of TH boolean expressions with (.&&), filtering out trivially true guards.+sAndAll :: [Exp] -> Exp+sAndAll = go . filter (not . isTriviallyTrue)+ where go [] = VarE 'sTrue+ go [g] = g+ go gs = foldr1 (\a b -> foldl1 AppE [VarE '(.&&), a, b]) gs++ isTriviallyTrue (VarE nm) = nameBase nm == nameBase 'sTrue+ isTriviallyTrue (ConE nm) = nameBase nm == "True"+ isTriviallyTrue _ = False++-- | TH parse trees don't have location. Let's have a simple mechanism to keep track of them for our use case+data Offset = Unknown | OffBy Int Int Int+ deriving Show++-- | Better fail method, keeping track of offsets+fail :: Offset -> String -> Q a+fail Unknown s = P.fail s+fail off@OffBy{} s = do loc <- location+ P.fail (fmtLoc loc off ++ ": " ++ s)++-- | Format a given location by the offset+fmtLoc :: Loc -> Offset -> String+fmtLoc loc@Loc{loc_start = (sl, _)} off = takeFileName (loc_filename newLoc) ++ ":" ++ sh (loc_start newLoc) (loc_end newLoc)+ where sh ab@(a, b) cd@(c, d) | a == c = show a ++ ":" ++ show b ++ if b == d then "" else '-' : show d+ | True = show ab ++ "-" ++ show cd++ newLoc = case off of+ Unknown -> loc+ OffBy lo co w -> loc {loc_start = (sl + lo, co + 1), loc_end = (sl + lo, co + w)}++-- | Built-in types recognized by sCase/pCase. Maybe and Either do have mkSymbolic-generated+-- infrastructure, but we treat them as built-in so that the generated code uses TH-quoted names+-- (which resolve at SCase.hs compile time) instead of mkName-based references (which would+-- require the user to have the testers/accessors in scope at the splice site).+data BuiltinType = BTBool | BTMaybe | BTEither | BTList | BTTuple Int+ deriving Show++-- | Compare two Names by their base (unqualified) name. This is needed because+-- built-in constructor names (created with mkName) won't match the fully-qualified+-- names that GHC resolves patterns to (e.g., mkName "Nothing" vs GHC.Internal.Maybe.Nothing).+-- Since constructor names are unique within a type, comparing by nameBase is safe.+sameBase :: Name -> Name -> Bool+sameBase a b = nameBase a == nameBase b++-- | Lookup by nameBase instead of Name equality.+lookupBase :: Name -> [(Name, a)] -> Maybe a+lookupBase _ [] = Nothing+lookupBase nm ((k,v):kvs)+ | sameBase nm k = Just v+ | True = lookupBase nm kvs++-- | Recognize built-in type names.+recognizeBuiltin :: String -> Maybe BuiltinType+recognizeBuiltin "Bool" = Just BTBool+recognizeBuiltin "Maybe" = Just BTMaybe+recognizeBuiltin "Either" = Just BTEither+recognizeBuiltin "List" = Just BTList+recognizeBuiltin s+ | Just n <- stripPrefix "Tuple" s, not (null n), all isDigit n, let k = read n, k >= 2, k <= 8+ = Just (BTTuple k)+recognizeBuiltin _ = Nothing++-- | Recognize a constructor name as belonging to a built-in type. Used in flattenPat+-- to generate TH-quoted tester/accessor references for nested built-in constructors.+recognizeBuiltinCon :: String -> Maybe BuiltinType+recognizeBuiltinCon "True" = Just BTBool+recognizeBuiltinCon "False" = Just BTBool+recognizeBuiltinCon "Nothing" = Just BTMaybe+recognizeBuiltinCon "Just" = Just BTMaybe+recognizeBuiltinCon "Left" = Just BTEither+recognizeBuiltinCon "Right" = Just BTEither+recognizeBuiltinCon "[]" = Just BTList+recognizeBuiltinCon ":" = Just BTList+recognizeBuiltinCon _ = Nothing++-- | Infer the type from the constructor names used in the pattern matches.+-- Examines top-level patterns to find the first informative one (i.e., not a wildcard),+-- then resolves the constructor via TH to determine the parent type.+-- Returns 'Nothing' if all branches use wildcards (wildcard-only mode).+inferType :: String -> [Match] -> Q (Maybe (String, Maybe BuiltinType))+inferType label matches = case firstInfo matches of+ Just (Left n) -> pure $ Just ("Tuple" ++ show n, Just (BTTuple n))+ Just (Right Nothing) -> pure $ Just ("List", Just BTList)+ Just (Right (Just name)) -> Just <$> resolveConType name+ Nothing -> pure Nothing+ where+ -- Left n = tuple of arity n, Right Nothing = list, Right (Just name) = constructor name+ firstInfo [] = Nothing+ firstInfo (Match pat _ _ : rest) = case patInfo pat of+ Just info -> Just info+ Nothing -> firstInfo rest++ patInfo (ConP n _ _) = Just (Right (Just n))+ patInfo (RecP n _) = Just (Right (Just n))+ patInfo (InfixP _ n _) | nameBase n == ":" = Just (Right Nothing)+ patInfo (UInfixP _ n _) | nameBase n == ":" = Just (Right Nothing)+ patInfo (TupP ps) = Just (Left (length ps))+ patInfo (ListP _) = Just (Right Nothing)+ patInfo (ParensP p) = patInfo p+ patInfo (AsP _ p) = patInfo p+ patInfo _ = Nothing++ -- Resolve a constructor name to its parent type via TH+ resolveConType conName = do+ let base = nameBase conName+ -- Check if it's a known built-in constructor first (for cases where lookupValueName+ -- might not resolve, e.g., "[]" as a value name)+ case recognizeBuiltinCon base of+ Just bt -> pure (builtinTypeName bt, Just bt)+ Nothing -> do+ mbResolved <- lookupValueName base+ case mbResolved of+ Nothing -> fail Unknown $ unlines [ label ++ ": Unknown constructor: " ++ base+ , ""+ , " Cannot find this constructor in scope."+ , " Make sure the type is declared and mkSymbolic is called."+ ]+ Just resolved -> do+ info <- reify resolved+ case info of+ DataConI _ _ parentName -> let typName = nameBase parentName+ in pure (typName, recognizeBuiltin typName)+ _ -> fail Unknown $ label ++ ": " ++ base ++ " is not a data constructor."++ builtinTypeName BTBool = "Bool"+ builtinTypeName BTMaybe = "Maybe"+ builtinTypeName BTEither = "Either"+ builtinTypeName BTList = "List"+ builtinTypeName (BTTuple n) = "Tuple" ++ show n++-- | Constructor info for a built-in type: (name, arity).+builtinConstructors :: BuiltinType -> [(Name, Int)]+builtinConstructors BTBool = [(mkName "True", 0), (mkName "False", 0)]+builtinConstructors BTMaybe = [(mkName "Nothing", 0), (mkName "Just", 1)]+builtinConstructors BTEither = [(mkName "Left", 1), (mkName "Right", 1)]+builtinConstructors BTList = [(mkName "[]", 0), (mkName ":", 2)]+builtinConstructors (BTTuple n) = [(tupleDataName n, n)]++-- | Generate a tester expression for a built-in type constructor.+builtinTester :: BuiltinType -> Name -> Exp -> Exp+builtinTester BTBool nm scrut+ | nameBase nm == "True" = scrut+ | nameBase nm == "False" = AppE (VarE 'sNot) scrut+builtinTester BTMaybe nm scrut+ | nameBase nm == "Nothing" = AppE (VarE (sbvName "Data.SBV.Maybe" "isNothing")) scrut+ | nameBase nm == "Just" = AppE (VarE (sbvName "Data.SBV.Maybe" "isJust")) scrut+builtinTester BTEither nm scrut+ | nameBase nm == "Left" = AppE (VarE (sbvName "Data.SBV.Either" "isLeft")) scrut+ | nameBase nm == "Right" = AppE (VarE (sbvName "Data.SBV.Either" "isRight")) scrut+builtinTester BTList nm scrut+ | nameBase nm == "[]" = AppE (VarE (sbvName "Data.SBV.List" "null")) scrut+ | nameBase nm == ":" = AppE (VarE 'sNot) (AppE (VarE (sbvName "Data.SBV.List" "null")) scrut)+builtinTester (BTTuple _) _ _ = VarE 'sTrue+builtinTester bt nm _ = error $ "sCase: builtinTester: unexpected constructor " ++ nameBase nm ++ " for " ++ show bt++-- | Generate an accessor expression for a built-in type constructor field.+builtinAccessor :: BuiltinType -> Name -> Int -> Exp -> Exp+builtinAccessor BTBool nm _ _ = error $ "sCase: builtinAccessor: Bool constructor " ++ nameBase nm ++ " has no fields"+builtinAccessor BTMaybe nm i scrut+ | nameBase nm == "Just", i == 1 = AppE (VarE (sbvName "Data.SBV.Maybe" "getJust_1")) scrut+builtinAccessor BTEither nm i scrut+ | nameBase nm == "Left", i == 1 = AppE (VarE (sbvName "Data.SBV.Either" "getLeft_1")) scrut+ | nameBase nm == "Right", i == 1 = AppE (VarE (sbvName "Data.SBV.Either" "getRight_1")) scrut+builtinAccessor BTList nm i scrut+ | nameBase nm == ":", i == 1 = AppE (VarE (sbvName "Data.SBV.List" "head")) scrut+ | nameBase nm == ":", i == 2 = AppE (VarE (sbvName "Data.SBV.List" "tail")) scrut+builtinAccessor (BTTuple _) _ i scrut+ -- Simplify _i (tuple (a, b, ...)) to just the i-th component+ | AppE (VarE f) (TupE components) <- scrut+ , nameBase f == "tuple"+ , let cs = catMaybes components+ , i >= 1, i <= length cs+ = cs !! (i - 1)+ | True+ = AppE (VarE (tupleAccessorName i)) scrut+ where tupleAccessorName 1 = sbvName "Data.SBV.Tuple" "_1"+ tupleAccessorName 2 = sbvName "Data.SBV.Tuple" "_2"+ tupleAccessorName 3 = sbvName "Data.SBV.Tuple" "_3"+ tupleAccessorName 4 = sbvName "Data.SBV.Tuple" "_4"+ tupleAccessorName 5 = sbvName "Data.SBV.Tuple" "_5"+ tupleAccessorName 6 = sbvName "Data.SBV.Tuple" "_6"+ tupleAccessorName 7 = sbvName "Data.SBV.Tuple" "_7"+ tupleAccessorName 8 = sbvName "Data.SBV.Tuple" "_8"+ tupleAccessorName n = error $ "sCase: tupleAccessorName: unsupported index " ++ show n+builtinAccessor bt nm i _ = error $ "sCase: builtinAccessor: unexpected constructor " ++ nameBase nm ++ " field " ++ show i ++ " for " ++ show bt++-- | Generate a tester expression for a constructor, dispatching to builtinTester for+-- recognized built-in constructors or falling back to @is\<Con\>@ for user ADTs.+mkTester :: Name -> Exp -> Exp+mkTester nm scrut = case recognizeBuiltinCon (nameBase nm) of+ Just bt -> builtinTester bt nm scrut+ Nothing -> AppE (VarE (mkName ("is" ++ nameBase nm))) scrut++-- | Generate an accessor expression for a constructor field, dispatching to builtinAccessor for+-- recognized built-in constructors or falling back to @get\<Con\>_i@ for user ADTs.+mkAccessor :: Name -> Int -> Exp -> Exp+mkAccessor nm i scrut = case recognizeBuiltinCon (nameBase nm) of+ Just bt -> builtinAccessor bt nm i scrut+ Nothing -> AppE (VarE (mkName ("get" ++ nameBase nm ++ "_" ++ show i))) scrut++-- | Like 'mkTester', but when the built-in type is already known from the scrutinee type.+-- Used in top-level sCase/pCase code generation.+mkTesterFor :: Maybe BuiltinType -> Name -> Exp -> Exp+mkTesterFor (Just bt) nm scrut = builtinTester bt nm scrut+mkTesterFor Nothing nm scrut = AppE (VarE (mkName ("is" ++ nameBase nm))) scrut++-- | Like 'mkAccessor', but when the built-in type is already known from the scrutinee type.+mkAccessorFor :: Maybe BuiltinType -> Name -> Int -> Exp -> Exp+mkAccessorFor (Just bt) nm i scrut = builtinAccessor bt nm i scrut+mkAccessorFor Nothing nm i scrut = AppE (VarE (mkName ("get" ++ nameBase nm ++ "_" ++ show i))) scrut++-- | What kind of case-match are we given. In each case, the last maybe exp is the possible guard.+data Case = CMatch Offset -- regular match+ Name -- name of the constructor+ (Maybe [Pat]) -- [a, b, c] in C a b c. Or Nothing if C{}+ (Maybe Exp) -- guard+ Exp -- rhs+ (Set Name) -- All variables used all RHSs and All guards+ | CWild Offset -- wild card+ (Maybe Exp) -- guard+ Exp -- rhs++-- | What's the offset?+caseOffset :: Case -> Offset+caseOffset (CMatch o _ _ _ _ _) = o+caseOffset (CWild o _ _) = o++-- | Show a case nicely+showCase :: Case -> String+showCase = showCaseGen Nothing++-- | Show a case nicely, with location+showCaseGen :: Maybe Loc -> Case -> String+showCaseGen mbLoc sc = case sc of+ CMatch _ c (Just ps) mbG _ _ -> loc ++ unwords (nameBase c : map pprint ps ++ shGuard mbG)+ CMatch _ c Nothing mbG _ _ -> loc ++ unwords (nameBase c : "{}" : shGuard mbG)+ CWild _ mbG _ -> loc ++ unwords ("_" : shGuard mbG)+ where shGuard Nothing = []+ shGuard (Just e) = ["|", pprint e]++ loc = case mbLoc of+ Nothing -> ""+ Just l -> fmtLoc l (caseOffset sc) ++ ": "++-- | Get the name of the constructor, if any+getCaseConstructor :: Case -> Maybe Name+getCaseConstructor (CMatch _ nm _ _ _ _) = Just nm+getCaseConstructor CWild{} = Nothing++-- | Get the guard, if any+getCaseGuard :: Case -> Maybe Exp+getCaseGuard (CMatch _ _ _ mbg _ _) = mbg+getCaseGuard (CWild _ mbg _ ) = mbg++-- | Is there a guard?+isGuarded :: Case -> Bool+isGuarded = isJust . getCaseGuard++-- | Find offset of each successive match. This isn't perfect, but it does the job+findOffsets :: String -> [Offset]+findOffsets s = analyze $ E.parseExpWithMode E.defaultParseMode $ "case ()" ++ tab ++ rest+ where rest = relevant s+ -- there's a chance the replication below might yield a negative value, which can make our+ -- offset calculation slightly off. But this should be exceedingly rare because it'd have to be that+ -- matches are on the same line and the "Type expr" part of the original must be shorter than 7 chars.+ -- Let's ignore that possibility.+ tab = replicate (length s - length rest - 7) ' '+ relevant r@(' ':'o':'f':_) = r+ relevant "" = ""+ relevant (_:cs) = relevant cs++ analyze E.ParseFailed{} = [] -- Just ignore+ analyze (E.ParseOk e) = case e of+ E.Case _ _ alts -> map getOff alts+ _ -> []+ where getOff (E.Alt l p _ _) = OffBy (E.srcSpanStartLine as - 1) (E.srcSpanStartColumn as - 1) w+ where as = E.srcInfoSpan l+ cs = E.srcInfoSpan (E.ann p)+ w = E.srcSpanEndColumn cs - E.srcSpanStartColumn cs++-- * Shared parsing infrastructure++-- | Parse a Haskell expression using haskell-src-exts+metaParse :: String -> Either String Exp+metaParse = fmap Meta.toExp . Meta.parseResultToEither . E.parseExpWithMode pm+ where pm = E.defaultParseMode { E.parseFilename = []+ , E.baseLanguage = E.Haskell2010+ , E.extensions = map E.EnableExtension (exts ++ extras)+ }+ exts = [ E.PostfixOperators+ , E.QuasiQuotes+ , E.UnicodeSyntax+ , E.PatternSignatures+ , E.MagicHash+ , E.ForeignFunctionInterface+ , E.TemplateHaskell+ , E.RankNTypes+ , E.MultiParamTypeClasses+ , E.RecursiveDo+ , E.TypeApplications+ ]++ -- The above just mimics the defaults. These our extras.+ extras = [E.DataKinds]++-- | Handle a metaParse error by mapping the parse-error column back to the source file.+-- metaParse operates on @"case " <> src@ (5 extra chars), so we subtract 5 from its column.+-- For line 1 errors, we also add the quasi-quote content's starting column since the first+-- line of src is offset from the start of the source line. For subsequent lines, the columns+-- in the quasi-quote content already correspond to source file columns.+handleParseError :: String -> String -> Q a+handleParseError label err = do+ loc <- location+ let qqCol = snd (loc_start loc) -- 1-based column where quasi-quote content starts+ case lines err of+ (_:locLine:res) | ["SrcLoc", _, l, c] <- words locLine, all isDigit l, all isDigit c+ -> let mc = read c+ line = read l+ -- Line 1: column is relative to "case " <> src, need to add quasi-quote offset+ -- Lines 2+: column is already a source file column (verbatim from source)+ col = if line == 1 then qqCol + mc - 7 else mc - 1+ in fail (OffBy (line - 1) col 1) (unlines res)+ _ -> fail Unknown $ label ++ " parse error: " <> err+++-- | Extract guards from a match body+getGuards :: Body -> [Dec] -> Q [(Maybe Exp, Exp)]+getGuards (NormalB rhs) locals = pure [(Nothing, addLocals locals rhs)]+getGuards (GuardedB exps) locals = mapM get exps+ where get (NormalG e, rhs)+ | isSTrue e+ = pure (Nothing, addLocals locals rhs)+ | True+ = pure (Just e, addLocals locals rhs)+ get (PatG stmts, rhs)+ | all isNoBindS stmts+ = let guards = [e | NoBindS e <- stmts]+ conj = sAndAll guards+ in pure (if isSTrue conj then Nothing else Just conj, addLocals locals rhs)+ | True+ = fail Unknown $ unlines $ "sCase/pCase: Pattern guards are not supported: "+ : [" " ++ pprint s | s <- stmts]+ where isNoBindS (NoBindS _) = True+ isNoBindS _ = False++ -- Is this literally sTrue (or True)? This is a bit dangerous since+ -- we just look at the base-name, but good enough+ isSTrue (VarE nm) = nameBase nm == nameBase 'sTrue+ isSTrue (ConE nm) = nameBase nm == "True"+ isSTrue _ = False++-- | Turn where clause into simple let+addLocals :: [Dec] -> Exp -> Exp+addLocals [] e = e+addLocals ds e = LetE ds e++-- | Given an occurrence of a name, find what it refers to+getReference :: Offset -> Name -> Q Name+getReference off refName = do mbN <- lookupValueName (nameBase refName)+ case mbN of+ Nothing -> fail off $ "sCase/pCase: Not in scope: data constructor: " <> pprint refName+ Just n -> pure n++-- | Convert a match into a list of cases+matchToPair :: Exp -> Offset -> Match -> Q [Case]+matchToPair scrut off (Match pat grhs locals) = do+ rhss <- getGuards grhs locals+ let allUsed = Set.unions (map (\(mbG, e) -> maybe Set.empty freeVars mbG `Set.union` freeVars e) rhss)++ -- Common logic for constructor-like patterns: flatten sub-patterns, merge synthetic guards+ flattenAndMerge :: Name -> (Int -> Exp) -> [Pat] -> Q [Case]+ flattenAndMerge con accessor subpats = do+ flatResults <- zipWithM (flattenPat off . accessor) [(1::Int)..] subpats+ let ps = map fstOf3 flatResults+ subGrds = concatMap sndOf3 flatResults+ subDecs = concatMap thdOf3 flatResults++ merge (mbG, rhs) =+ let usedInRhs = freeVars rhs+ usedInGrd = maybe Set.empty freeVars mbG+ decsFor s = [ d | d@(ValD (VarP v) _ _) <- subDecs, v `Set.member` s ]+ rhs' = addLocals (decsFor usedInRhs) rhs+ mbG' = case (subGrds, mbG) of+ ([], Nothing) -> Nothing+ ([], Just g ) -> Just (addLocals (decsFor usedInGrd) g)+ (gs, Nothing) -> Just (sAndAll gs)+ (gs, Just g ) -> Just (sAndAll (gs ++ [addLocals (decsFor usedInGrd) g]))+ in (mbG', rhs')++ pure [CMatch off con (Just ps) mbG rhs allUsed | (mbG, rhs) <- map merge rhss]++ case pat of+ ConP conName _ subpats -> do+ con <- getReference off conName+ flattenAndMerge con (\i -> mkAccessor con i scrut) subpats++ RecP conName [] -> do con <- getReference off conName+ pure [CMatch off con Nothing mbG rhs allUsed | (mbG, rhs) <- rhss]++ WildP -> pure [CWild off mbG rhs | (mbG, rhs) <- rhss]++ -- List cons pattern: y : ys (InfixP or UInfixP from the parser)+ InfixP p1 conName p2+ | nameBase conName == ":" -> let con = mkName ":" in flattenAndMerge con (\i -> mkAccessorFor (Just BTList) con i scrut) [p1, p2]+ UInfixP p1 conName p2+ | nameBase conName == ":" -> let con = mkName ":" in flattenAndMerge con (\i -> mkAccessorFor (Just BTList) con i scrut) [p1, p2]++ -- Tuple pattern: (a, b, ...)+ TupP subpats -> do+ let n = length subpats+ con = tupleDataName n+ flattenAndMerge con (\i -> mkAccessorFor (Just (BTTuple n)) con i scrut) subpats++ -- List nil pattern: []+ ListP [] -> pure [CMatch off (mkName "[]") (Just []) mbG rhs allUsed | (mbG, rhs) <- rhss]++ -- List pattern with elements: [a], [a, b], etc. Desugar to nested cons: a : (b : [])+ ListP ps -> let desugar [] = ListP []+ desugar (p:rest) = InfixP p (mkName ":") (desugar rest)+ in matchToPair scrut off (Match (desugar ps) grhs locals)++ -- Parenthesized pattern: unwrap and recurse+ ParensP p -> matchToPair scrut off (Match p grhs locals)++ -- Literal pattern at top level: 0, 1, "hello", etc.+ -- Treated as a wildcard with a guard: scrut .== literal+ LitP lit -> do eq <- litToEq off scrut lit+ pure [CWild off (Just (maybe eq (\g -> sAndAll [eq, g]) mbG)) rhs | (mbG, rhs) <- rhss]++ -- Variable pattern at top level: binds the scrutinee (only when used)+ VarP v -> let bindScrut e | v `Set.member` freeVars e = LetE [ValD (VarP v) (NormalB scrut) []] e+ | True = e+ in pure [CWild off (bindScrut <$> mbG) (bindScrut rhs) | (mbG, rhs) <- rhss]++ -- As-pattern at top level: name@subpat — bind name to scrutinee, then process inner pattern+ AsP name subpat -> do+ cases <- matchToPair scrut off (Match subpat grhs locals)+ let bindAs e | name `Set.member` freeVars e = LetE [ValD (VarP name) (NormalB scrut) []] e+ | True = e+ addBind (CMatch o cn ps mbG' rhs' used) = CMatch o cn ps (bindAs <$> mbG') (bindAs rhs') used+ addBind (CWild o mbG' rhs') = CWild o (bindAs <$> mbG') (bindAs rhs')+ pure (map addBind cases)++ _ -> fail Unknown $ unlines [ "sCase/pCase: Unsupported pattern:"+ , " Saw: " <> pprint pat+ , ""+ , " Supported patterns: constructors (Cstr a b _ d),"+ , " empty records (Cstr{}), wildcards (_), variables,"+ , " as-patterns (x@pat), and integer/string literals."+ ]++-- | Flatten a sub-pattern against a given accessor expression.+-- Returns: a simple VarP/WildP for the flat pattern list, a list of+-- synthetic isCstr guard expressions, and let-bindings that bring+-- nested-pattern variables into scope.+flattenPat :: Offset -> Exp -> Pat -> Q (Pat, [Exp], [Dec])+flattenPat _ _ WildP = pure (WildP, [], [])+flattenPat _ _ p@(VarP _) = pure (p, [], [])+flattenPat off arg (ParensP p) = flattenPat off arg p+flattenPat off arg (ConP conName _ subpats) = do+ con <- getReference off conName+ -- Arity check: reify the constructor to find its actual field count+ DataConI _ conType parentName <- reify con+ let arity = countArgs conType+ unless (arity == length subpats) $+ fail off $ unlines [ "sCase/pCase: Arity mismatch in nested pattern."+ , " Constructor: " ++ nameBase con+ , " Expected : " ++ show arity+ , " Given : " ++ show (length subpats)+ ]+ -- Check if the parent type has only one constructor; if so, the tester is trivially true+ singleCon <- isSingleConstructorType parentName+ let tester = mkTester con arg+ accessor i = mkAccessor con i arg+ subResults <- zipWithM (flattenPat off . accessor) [(1::Int)..] subpats+ let subGrds = concatMap sndOf3 subResults+ subDecs = concatMap thdOf3 subResults+ subPats = map fstOf3 subResults+ patDecs = [ ValD (VarP v) (NormalB (accessor i)) []+ | (i, VarP v) <- zip [(1::Int)..] subPats ]+ -- Skip the tester guard for single-constructor types (it's always true)+ guards = (if singleCon then id else (tester :)) subGrds+ pure (WildP, guards, patDecs ++ subDecs)+flattenPat off arg (LitP lit) = do+ eq <- litToEq off arg lit+ pure (WildP, [eq], [])+-- Nested list cons pattern: x : xs (InfixP or UInfixP from the parser)+flattenPat off arg (InfixP p1 conName p2)+ | nameBase conName == ":" = flattenCons off arg p1 p2+flattenPat off arg (UInfixP p1 conName p2)+ | nameBase conName == ":" = flattenCons off arg p1 p2+-- Nested empty list pattern: []+flattenPat _ arg (ListP []) =+ pure (WildP, [AppE (VarE (sbvName "Data.SBV.List" "null")) arg], [])+-- Nested list pattern with elements: [a], [a, b], etc. Desugar to nested cons.+flattenPat off arg (ListP (p:ps)) =+ flattenPat off arg (InfixP p (mkName ":") (ListP ps))+-- Nested tuple pattern: (a, b, ...)+flattenPat off arg (TupP pats) = do+ let n = length pats+ accessor i = mkAccessorFor (Just (BTTuple n)) (tupleDataName n) i arg+ subResults <- zipWithM (flattenPat off . accessor) [(1::Int)..] pats+ let subGrds = concatMap sndOf3 subResults+ subDecs = concatMap thdOf3 subResults+ patDecs = [ ValD (VarP v) (NormalB (accessor i)) []+ | (i, VarP v) <- zip [(1::Int)..] (map fstOf3 subResults) ]+ pure (WildP, subGrds, patDecs ++ subDecs)+-- Nested as-pattern: name@subpat — bind name to accessor, then process inner pattern+flattenPat off arg (AsP name subpat) = do+ (pat', guards, decs) <- flattenPat off arg subpat+ let asDec = ValD (VarP name) (NormalB arg) []+ pure (pat', guards, asDec : decs)+-- Nested empty record pattern: Cstr{} — equivalent to Cstr with all wildcards+flattenPat off arg (RecP conName []) = do+ con <- getReference off conName+ DataConI _ conType _ <- reify con+ let arity = countArgs conType+ flattenPat off arg (ConP con [] (replicate arity WildP))+flattenPat o _ p = fail o $ unlines [ "sCase/pCase: Unsupported complex pattern match."+ , " Saw: " <> pprint p+ , ""+ , " Only variables, wildcards, as-patterns, nested constructors, and integer/string literals are supported."+ ]++-- | Flatten a nested list cons pattern (x : xs) against an accessor expression.+-- We include a destructuring equality (arg .=== head arg .: tail arg) because lists use+-- SMT Seq, not declare-datatypes, so the solver doesn't automatically know this relationship.+-- This is critical for pCase proof progress; harmless for sCase (redundant guard in ite-chain).+-- NB. For top-level list cons patterns in pCase, the same equality is added by processProofCases.+flattenCons :: Offset -> Exp -> Pat -> Pat -> Q (Pat, [Exp], [Dec])+flattenCons off arg p1 p2 = do+ let headExpr = mkAccessorFor (Just BTList) (mkName ":") 1 arg+ tailExpr = mkAccessorFor (Just BTList) (mkName ":") 2 arg+ tester = mkTesterFor (Just BTList) (mkName ":") arg+ destruct = foldl1 AppE [VarE '(.===), arg, InfixE (Just headExpr) (VarE '(.:)) (Just tailExpr)]+ sub1 <- flattenPat off headExpr p1+ sub2 <- flattenPat off tailExpr p2+ let subGrds = sndOf3 sub1 ++ sndOf3 sub2+ subDecs = thdOf3 sub1 ++ thdOf3 sub2+ patDecs = [ ValD (VarP v) (NormalB headExpr) [] | VarP v <- [fstOf3 sub1] ]+ ++ [ ValD (VarP v) (NormalB tailExpr) [] | VarP v <- [fstOf3 sub2] ]+ pure (WildP, tester : destruct : subGrds, patDecs ++ subDecs)++-- | Check if a type has only one constructor. Used to skip trivially-true tester guards+-- in nested patterns (e.g., @Just (Pocket n3 n5)@ where @Pocket@ is the sole constructor).+isSingleConstructorType :: Name -> Q Bool+isSingleConstructorType tyName = do+ info <- reify tyName+ pure $ case info of+ TyConI (DataD _ _ _ _ [_] _) -> True+ TyConI (NewtypeD {}) -> True+ _ -> False++fstOf3 :: (a, b, c) -> a+fstOf3 (a, _, _) = a++sndOf3 :: (a, b, c) -> b+sndOf3 (_, b, _) = b++thdOf3 :: (a, b, c) -> c+thdOf3 (_, _, c) = c++-- | Get the constructor list for a type. For built-in types, return synthetic entries;+-- for user ADTs, reify via getConstructors.+getCstrs :: Maybe BuiltinType -> String -> Q [(Name, [Type])]+getCstrs (Just bt) _ = pure [(nm, replicate ar WildCardT) | (nm, ar) <- builtinConstructors bt]+getCstrs Nothing typ = let dropFieldNames (c, nts) = (c, map snd nts)+ in map dropFieldNames . snd <$> getConstructors (mkName typ)++-- | Validate wildcard placement: unguarded wildcard must be last.+checkWildcard :: String -> Loc -> [Case] -> Q ()+checkWildcard label loc cs = do go cs; checkExhaustive cs+ where go [] = pure ()+ go (CMatch{} : rest) = go rest+ go (CWild _ Just{} _ : rest) = go rest+ go (CWild o Nothing _ : rest) =+ case rest of+ [] -> pure ()+ red -> fail o $ unlines $ (label ++ ": Wildcard makes the remaining matches redundant:")+ : [" " ++ showCaseGen (Just loc) r | r <- red]++ -- If all cases are wildcards (no CMatch), then we need an unguarded wildcard+ -- as a catch-all. Otherwise, guarded-only wildcards on an infinite domain+ -- (Integer, String, etc.) silently produce a free variable for unmatched cases.+ checkExhaustive cases+ | any isCMatch cases = pure () -- Has constructor patterns; exhaustiveness checked elsewhere+ | any isUnguardedWild cases = pure () -- Has an unguarded catch-all+ | True = fail (headOffset cases) $ unlines+ [ label ++ ": Non-exhaustive pattern match."+ , " All branches are guarded; add an unguarded wildcard or variable"+ , " as the last branch to ensure all cases are covered."+ ]++ isCMatch CMatch{} = True+ isCMatch _ = False++ isUnguardedWild (CWild _ Nothing _) = True+ isUnguardedWild _ = False++ headOffset (c:_) = caseOffset c+ headOffset [] = Unknown++-- | Validate that each constructor exists and has the right arity.+checkArities :: String -> String -> [(Name, [Type])] -> [Case] -> Q ()+checkArities label typ cstrs = mapM_ chk1+ where chk1 c = case c of+ CMatch o nm ps _ _ _ -> isSafe o nm (length <$> ps)+ CWild {} -> pure ()+ isSafe o nm mbLen+ | Just ts <- lookupBase nm cstrs+ = case mbLen of+ Nothing -> pure ()+ Just cnt -> unless (length ts == cnt)+ $ fail o $ unlines [ label ++ ": Arity mismatch."+ , " Type : " ++ typ+ , " Constructor: " ++ nameBase nm+ , " Expected : " ++ show (length ts)+ , " Given : " ++ show cnt+ ]+ | True+ = fail o $ unlines [ label ++ ": Unknown constructor:"+ , " Type : " ++ typ+ , " Saw : " ++ pprint nm+ , " Must be one of: " ++ intercalate ", " (map (pprint . fst) cstrs)+ ]++-- * sCase++-- | Quasi-quoter for symbolic case expressions.+sCase :: QuasiQuoter+sCase = QuasiQuoter+ { quoteExp = extract+ , quotePat = bad "pattern"+ , quoteType = bad "type"+ , quoteDec = bad "declaration"+ }+ where+ bad ctx _ = fail Unknown $ "sCase: not usable in " <> ctx <> " context"++ extract :: String -> ExpQ+ extract src = do+ let fullCase = "case " <> src+ offsets = findOffsets src+ case metaParse fullCase of+ Right (CaseE scrut matches) -> processCaseExp offsets scrut matches+ Right _ -> fail Unknown "sCase: Parse error, cannot extract a case-expression."+ Left err -> handleParseError "sCase" err++-- | Core sCase pipeline: given a scrutinee and matches (already in TH AST form),+-- run type inference, match conversion, validation, and code generation.+-- Factored out of 'sCase' so that 'transformNestedCases' can call it for+-- inner @case@ expressions.+processCaseExp :: [Offset] -> Exp -> [Match] -> Q Exp+processCaseExp offsets scrut0 matches0 = do+ -- Transform any nested case expressions in the RHS/guards of each match.+ -- This ensures inner cases become symbolic before the outer case processes them.+ matches <- transformMatches matches0+ scrut <- transformNestedCases scrut0+ mbTypeInfo <- inferType "sCase" matches+ case mbTypeInfo of+ Nothing -> do+ -- Wildcard-only: no type needed, generate ite-chain directly+ allCases <- concat <$> zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches+ loc <- location+ checkWildcard "sCase" loc allCases+ let wilds = [(mbG, rhs) | CWild _ mbG rhs <- allCases]+ -- An unguarded wildcard is the base case (no ite wrapper needed).+ -- checkWildcard guarantees an unguarded wildcard is last if present.+ iteChain [] = do uniq <- newName "u"+ let suffix = drop 2 (show uniq)+ pure $ AppE (VarE 'symWithKind) (LitE (StringL ("unmatched_sCase_wildcard_" ++ suffix)))+ iteChain ((Nothing, rhs) : _) = pure rhs+ iteChain ((Just g, rhs) : rest) = do r <- iteChain rest+ pure $ foldl AppE (VarE 'ite) [g, rhs, r]+ iteChain wilds+ Just (typ, mbt) -> do+ mbFnName <- case mbt of+ Just BTBool -> pure Nothing+ Just BTList -> pure Nothing -- Strategy B; see noAnalyzer comment above+ Just BTMaybe -> pure (Just (VarE (sbvName "Data.SBV.Maybe" "sCaseMaybe")))+ Just BTEither -> pure (Just (VarE (sbvName "Data.SBV.Either" "sCaseEither")))+ Just (BTTuple _) -> pure Nothing+ Nothing -> let fnTok = "sCase" <> typ+ in lookupValueName fnTok >>= \case+ Just n -> pure (Just (VarE n))+ Nothing -> fail Unknown $ unlines [ "sCase: Unknown symbolic ADT: " <> typ+ , ""+ , " To use a symbolic case expression, declare your ADT, and then:"+ , " mkSymbolic [''" <> typ <> "]"+ , " In a template-haskell context."+ ]+ let anyUserGuards = any (\(Match _ grhs _) -> case grhs of { GuardedB{} -> True; _ -> False }) matches+ cases <- zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches >>= checkCase scrut typ mbt anyUserGuards . concat+ buildCase typ mbFnName scrut cases+ where+ buildCase :: String -> Maybe Exp -> Exp -> Either [Exp] [(Exp, Exp)] -> ExpQ+ buildCase _ (Just caseFunc) s (Left cases) = pure $ AppE (foldl AppE caseFunc cases) s+ buildCase _ Nothing _ (Left _) = error "sCase: impossible: Strategy A without case function"+ buildCase typ _ _scrut (Right cases) = do+ uniq <- newName "u"+ let suffix = drop 2 (show uniq)+ fallback = AppE (VarE 'symWithKind) (LitE (StringL ("unmatched_sCase_" ++ typ ++ "_" ++ suffix)))++ iteChain [] = pure fallback+ iteChain ((t, e) : rest)+ -- Last branch with a trivially-true guard (e.g., unguarded wildcard, or the last+ -- constructor in a complete match): use its rhs directly as the default,+ -- avoiding an unreachable fallback variable.+ | null rest, isTriviallyTrue t = pure e+ | True = do r <- iteChain rest+ pure $ foldl AppE (VarE 'ite) [t, e, r]++ isTriviallyTrue (VarE nm) = nameBase nm == nameBase 'sTrue+ isTriviallyTrue (ConE nm) = nameBase nm == "True"+ isTriviallyTrue _ = False+ iteChain cases++ -- Make sure things are in good-shape and decide if we have guards+ checkCase :: Exp -> String -> Maybe BuiltinType -> Bool -> [Case] -> Q (Either [Exp] [(Exp, Exp)])+ checkCase s typ mbt anyUserGuards cases = do+ loc <- location+ cstrs <- getCstrs mbt typ++ -- Is there a catch all clause?+ let hasCatchAll = or [True | CWild _ Nothing _ <- cases]++ checkWildcard "sCase" loc cases+ checkArities "sCase" typ cstrs cases++ -- Step 2: Make sure constructor matches are not overlapping+ let problem w extras x = fail (caseOffset x) $ unlines $ [ "sCase: " ++ w ++ ":"+ , " Type : " ++ typ+ , " Constructor: " ++ showCase x+ ]+ ++ [ " " ++ e | e <- extras]++ overlap x xs = problem "Overlapping case constructors" extras x+ where extras = "Overlaps with:" : [" " ++ p | p <- map (showCaseGen (Just loc)) xs]++ unmatched x+ | isGuarded x = problem "Non-exhaustive match" ["NB. Guarded match might fail."] x+ | True = problem "Non-exhaustive match" [] x++ nonExhaustive o cstr = fail o $ unlines [ "sCase: Pattern match(es) are non-exhaustive."+ , " Not matched : " ++ nameBase cstr+ , " Patterns of type: " ++ typ+ , " Must match each : " ++ intercalate ", " (map (nameBase . fst) cstrs)+ , ""+ , " You can use a '_' to match multiple cases."+ ]+ -- We're done+ chk2 _ [] = pure ()++ -- If we have a non-guarded match, then there must be no matches for this constructor later on. If so, they're redundant.+ chk2 seen (c@(CMatch _ nm _ Nothing _ _) : rest)+ = case filter (maybe False (sameBase nm) . getCaseConstructor) rest of+ [] -> chk2 (Set.insert (nameBase nm) seen) rest+ os -> overlap (last os) (c : init os)++ -- If we have a guarded match, then this guard can fail. So either there must be a match+ -- for it later on, or there must be a catch-all. We also accept it if the same constructor+ -- was seen earlier (e.g., multiple nested-pattern alternatives like Left (x:_) / Left []).+ chk2 seen (c@(CMatch _ nm _ Just{} _ _) : rest)+ | hasCatchAll || any (maybe False (sameBase nm) . getCaseConstructor) rest || nameBase nm `Set.member` seen+ = chk2 (Set.insert (nameBase nm) seen) rest+ | True+ = unmatched c++ -- If there's a guarded wildcard, must make sure there's a catch all afterwards+ chk2 seen (c@(CWild _ Just{} _) : rest)+ | hasCatchAll+ = chk2 seen rest+ | True+ = unmatched c++ -- No need to worry about anything following catch-all, since we already covered that before+ chk2 seen (CWild _ Nothing _ : rest) = chk2 seen rest++ chk2 Set.empty cases++ -- At this point, we either have a simple case with no guards, in which case+ -- we translate this to an sCase for that type. So find all alternatives.+ -- Otherwise, this will become an ite-chain.+ -- Bool, List, and Tuple use the ite-chain path (Strategy B) directly.+ -- List is excluded from Strategy A because the case-analysis combinator 'list' is itself+ -- a candidate for sCase rewriting; calling it here would create a circular dependency.+ -- Maybe, Either, and user ADTs can use Strategy A (calling sCaseMaybe/sCaseEither/sCaseADT).+ let hasGuards = any isGuarded cases+ noAnalyzer = case mbt of { Just BTBool -> True; Just BTList -> True; Just (BTTuple _) -> True; _ -> False }+ useIteChain = hasGuards || noAnalyzer++ if not useIteChain+ then do defaultCase <- case [((e, mbg), c) | c@(CWild _ mbg e) <- cases] of+ [] -> pure Nothing+ [((e, Nothing), c)] -> pure $ Just (caseOffset c, e)+ cs@((_, c):_) -> fail (caseOffset c)+ $ unlines $ "sCase: Impossible happened; found unexpected cases:"+ : [ " " ++ showCase curc | curc <- map snd cs]+ ++ [ ""+ , " Please report this as a bug."+ ]+ let find _ [] = Nothing+ find w (c:cs)+ | mtches = Just c+ | True = find w cs+ where mtches = case c of+ CMatch _ nm _ _ _ _ -> sameBase nm w+ CWild {} -> False++ case2rhs :: Case -> [Type] -> (Maybe Exp, Exp)+ case2rhs cs ts = (LamE pats <$> mbGuard, LamE pats e)+ where (mbGuard, e, pats) = case cs of+ CMatch _ _ (Just ps) mbG rhs _ -> (mbG, rhs, ps)+ CMatch _ _ Nothing mbG rhs _ -> (mbG, rhs, map (const WildP) ts)+ CWild _ mbG rhs -> (mbG, rhs, map (const WildP) ts)++ collect (cstr, ts)+ | Just e <- find cstr cases+ = pure $ case2rhs e ts+ | True+ = case defaultCase of+ Nothing -> nonExhaustive Unknown cstr+ Just (_, de) -> do let ps = map (const WildP) ts+ pure (Nothing, LamE ps de)++ res <- mapM collect cstrs++ -- If we reached here, all is well; except we might have an extra wildcard that we did not use+ when (length cases > length cstrs) $+ case defaultCase of+ Nothing -> pure ()+ Just (o, _) -> fail o "sCase: Wildcard match is redundant"++ -- Double check that we had no guards and return the cases+ case [r | (Just{}, r) <- res] of+ [] -> pure $ Left $ map snd res+ rs -> fail Unknown $ unlines $ "sCase: Impossible happened; found a guard in no-guard case."+ : [ " " ++ pprint r | r <- rs]+ ++ [ ""+ , " Please report this as a bug."+ ]++ else do -- We have guards.+ defaultCase <- case [(c, e) | c@(CWild _ Nothing e) <- cases] of+ [] -> pure Nothing+ ((c, e):_) -> pure $ Just (caseOffset c, e)++ -- Collect, for each constructor, the corresponding cases:+ let cstrMatches :: [(Name, ([Type], [Case]))]+ cstrMatches = map (\(cstr, ts) -> (cstr, (ts, concatMap (mtches cstr) cases))) cstrs+ where mtches cstr c | Just n <- getCaseConstructor c, sameBase n cstr = [c]+ | True = []++ -- Make sure we have a match for every constructor or a catch-all+ unless hasCatchAll $ case [nm | (nm, (_, [])) <- cstrMatches] of+ [] -> pure ()+ (x:_) -> nonExhaustive Unknown x++ -- If every constructor have a full match, then catch-all, if exists, is redundant:+ case defaultCase of+ Nothing -> pure ()+ Just (o, _)+ | map fst cstrs == [nm | (nm, (_, cs)) <- cstrMatches, not (all isGuarded cs)]+ -> fail o "sCase: Wildcard match is redundant"+ | True+ -> pure ()++ let collect :: Case -> Q (Exp, Exp)+ collect (CWild _ mbG rhs ) = pure (fromMaybe (VarE 'sTrue) mbG, rhs)+ collect (CMatch o nm mbp mbG rhs allUsed) = do+ case lookupBase nm cstrs of+ Nothing -> fail o $ unlines [ "sCase: Impossible happened."+ , " Unable to determine params for: " <> pprint nm+ ]+ Just ts -> do let pats = fromMaybe (map (const WildP) ts) mbp+ args = [mkAccessorFor mbt nm i s | (i, _) <- zip [(1 :: Int) ..] ts]+ testerExpr = mkTesterFor mbt nm s++ -- What are the free variables in the guard and the rhs that we bind?+ used = Set.fromList [n | VarP n <- pats] `Set.intersection` allUsed+ close e = foldr1 (AppE . AppE (VarE 'const)) (e:extras)+ where extras = map VarE $ Set.toList (used Set.\\ freeVars e)++ mkApp f | null pats = f+ | True = foldl AppE (LamE pats f) args++ grd :: Exp+ grd = case mbG of+ Nothing -> testerExpr+ Just g -> sAndAll [testerExpr, mkApp (close g)]++ pure (grd, mkApp (close rhs))++ pairs <- mapM collect cases++ -- When every constructor has at least one unguarded match, the pattern+ -- is exhaustive. The last entry's tester is then redundant — replace it+ -- with sTrue so buildCase uses it as the default, avoiding an unreachable+ -- fallback variable.+ -- For single-constructor types (tuples), all branches match the sole+ -- constructor, with guards from nested patterns only. When there are no+ -- user-provided guards, the nested patterns partition the space and the+ -- last branch is the default.+ let allCovered = all hasUnguarded cstrs+ || (length cstrs == 1 && not anyUserGuards)+ hasUnguarded (cstr, _) = any (\case CMatch _ nm _ Nothing _ _ -> sameBase nm cstr; _ -> False) cases+ optimize ps | allCovered, not (null ps)+ = init ps ++ [(VarE 'sTrue, snd (last ps))]+ | True = ps++ pure $ Right (optimize pairs)++-- | Transform nested @case@ expressions inside a TH 'Exp' into symbolic case expressions.+-- Walks the expression bottom-up: inner cases are transformed before outer ones.+-- This is what enables @case@ expressions inside @[sCase| ... |]@ to work as symbolic cases.+transformNestedCases :: Exp -> Q Exp+transformNestedCases = everywhereM (mkM go)+ where go :: Exp -> Q Exp+ go (CaseE s ms) = processCaseExp (repeat Unknown) s ms+ go e = pure e++-- | Transform nested @case@ expressions inside a TH 'Exp' into proof case-splits.+-- Like 'transformNestedCases', but generates @cases [cond ==> rhs, ...]@ instead of+-- @ite@ chains. This is what enables @case@ expressions inside @[pCase| ... |]@ to work+-- as nested proof case-splits.+transformNestedCasesProof :: Exp -> Q Exp+transformNestedCasesProof = everywhereM (mkM go)+ where go :: Exp -> Q Exp+ go (CaseE s ms) = processProofCaseExp s ms+ go e = pure e++-- | Transform the matches of an outer sCase expression, resolving any nested+-- @case@ expressions in the RHS and guards before the outer case processes them.+transformMatches :: [Match] -> Q [Match]+transformMatches = transformMatchesWith transformNestedCases++-- | Transform the matches of an outer pCase expression, resolving any nested+-- @case@ expressions in the RHS and guards as proof case-splits.+transformMatchesProof :: [Match] -> Q [Match]+transformMatchesProof = transformMatchesWith transformNestedCasesProof++-- | Generic match transformer parameterized by the nested-case handler.+transformMatchesWith :: (Exp -> Q Exp) -> [Match] -> Q [Match]+transformMatchesWith xform = mapM transformMatch+ where transformMatch (Match pat body locals) = do+ body' <- transformBody body+ locals' <- mapM transformDec locals+ pure (Match pat body' locals')++ transformBody (NormalB e) = NormalB <$> xform e+ transformBody (GuardedB gs) = GuardedB <$> mapM transformGuarded gs++ transformGuarded (g, e) = do g' <- transformGuard g+ e' <- xform e+ pure (g', e')++ transformGuard (NormalG e) = NormalG <$> xform e+ transformGuard (PatG ss) = PatG <$> mapM transformStmt ss++ transformStmt (NoBindS e) = NoBindS <$> xform e+ transformStmt s = pure s++ transformDec (ValD p b ls) = do b' <- transformBody b+ ls' <- mapM transformDec ls+ pure (ValD p b' ls')+ transformDec (FunD n cs) = FunD n <$> mapM transformClause cs+ transformDec d = pure d++ transformClause (Clause ps b ls) = do b' <- transformBody b+ ls' <- mapM transformDec ls+ pure (Clause ps b' ls')++-- | Core proof-case pipeline: given a scrutinee and matches (in TH AST form),+-- generate @cases [cond ==> rhs, ...]@. This is the proof-level counterpart of+-- 'processCaseExp', used by 'transformNestedCasesProof' to handle inner @case@+-- expressions inside @[pCase| ... |]@.+processProofCaseExp :: Exp -> [Match] -> Q Exp+processProofCaseExp scrut0 matches0 = do+ -- Recursively transform any nested case expressions as proof case-splits.+ matches <- transformMatchesProof matches0+ scrut <- transformNestedCasesProof scrut0+ mbTypeInfo <- inferType "pCase" matches+ let offsets = repeat Unknown+ case mbTypeInfo of+ Nothing -> do+ allCases <- concat <$> zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches+ loc <- location+ checkWildcard "pCase" loc allCases+ allPairs <- processProofCases scrut [] Nothing [] allCases+ let casesName = mkName "cases"+ impliesName = mkName "==>"+ mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r)+ pure $ AppE (VarE casesName) (ListE (map mkPair allPairs))+ Just (typ, mbt) -> do+ cs <- zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches+ let cases = concat cs+ loc <- location+ cstrs <- getCstrs mbt typ+ checkWildcard "pCase" loc cases+ checkArities "pCase" typ cstrs cases+ allPairs <- processProofCases scrut cstrs mbt [] cases+ let casesName = mkName "cases"+ impliesName = mkName "==>"+ mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r)+ pure $ AppE (VarE casesName) (ListE (map mkPair allPairs))++-- * pCase++-- | Quasi-quoter for proof case-splits.+--+-- Like 'sCase', but generates @cases [cond ==> proof, ...]@ instead of+-- @ite@ chains. Wildcards are allowed as the last scrutinee (with or+-- without guards), and exhaustiveness is checked at proof time by the+-- @cases@ combinator rather than at compile time.+--+-- Guards within the same constructor accumulate negations: a second guard+-- implicitly assumes the first guard failed. A wildcard guard is the+-- negation of the disjunction of all prior guards (De Morgan).+pCase :: QuasiQuoter+pCase = QuasiQuoter+ { quoteExp = extractProof+ , quotePat = bad "pattern"+ , quoteType = bad "type"+ , quoteDec = bad "declaration"+ }+ where+ bad ctx _ = fail Unknown $ "pCase: not usable in " <> ctx <> " context"++ extractProof :: String -> ExpQ+ extractProof src = do+ let fullCase = "case " <> src+ offsets = findOffsets src+ case metaParse fullCase of+ Right (CaseE scrut0 matches0) -> do+ -- Transform any nested case expressions in the RHS/guards of each match.+ -- Inner case expressions become proof case-splits (cases [...]),+ -- just like inner cases in sCase become symbolic ite-chains.+ matches <- transformMatchesProof matches0+ scrut <- transformNestedCasesProof scrut0+ mbTypeInfo <- inferType "pCase" matches+ case mbTypeInfo of+ Nothing -> do+ -- Wildcard-only: no type needed, build proof cases directly+ allCases <- concat <$> zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches+ loc <- location+ checkWildcard "pCase" loc allCases+ allPairs <- processProofCases scrut [] Nothing [] allCases+ let casesName = mkName "cases"+ impliesName = mkName "==>"+ mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r)+ pure $ AppE (VarE casesName) (ListE (map mkPair allPairs))+ Just (typ, mbt) -> do+ cs <- zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches+ validated <- checkProofCase typ mbt (concat cs)+ buildProofCase scrut typ mbt validated+ Right _ -> fail Unknown "pCase: Parse error, cannot extract a case-expression."+ Left err -> handleParseError "pCase" err++ -- | Validate cases for proof context+ checkProofCase :: String -> Maybe BuiltinType -> [Case] -> Q [Case]+ checkProofCase typ mbt cases = do+ loc <- location+ cstrs <- getCstrs mbt typ++ checkWildcard "pCase" loc cases+ checkArities "pCase" typ cstrs cases++ -- Wildcards must come after all explicit constructor matches+ let checkWildBeforeCstr [] = pure ()+ checkWildBeforeCstr (CWild o _ _ : rest)+ | any (\case CMatch{} -> True; _ -> False) rest+ = fail o $ unlines $ "pCase: Wildcard must come after all constructor matches:"+ : [" " ++ showCaseGen (Just loc) r | r <- filter (\case CMatch{} -> True; _ -> False) rest]+ checkWildBeforeCstr (_ : rest) = checkWildBeforeCstr rest+ checkWildBeforeCstr cases++ -- Check overlap: unguarded constructor match followed by same constructor+ let chk2 [] = pure ()+ chk2 (c@(CMatch _ nm _ Nothing _ _) : rest)+ = case filter (maybe False (sameBase nm) . getCaseConstructor) rest of+ [] -> chk2 rest+ os -> overlap loc (last os) (c : init os)+ chk2 (_ : rest) = chk2 rest++ chk2 cases++ -- If every constructor has an unguarded match, any wildcard is redundant+ let fullyCovered = [ cstr | (cstr, _) <- cstrs+ , any (\c -> maybe False (sameBase cstr) (getCaseConstructor c) && not (isGuarded c)) cases+ ]+ case [c | c@CWild{} <- cases] of+ [] -> pure ()+ (c:_) | length fullyCovered == length cstrs+ -> fail (caseOffset c) "pCase: Wildcard match is redundant"+ | True+ -> pure ()++ -- No exhaustiveness check: the `cases` combinator checks completeness at proof time.+ pure cases++ overlap loc x xs = fail (caseOffset x) $ unlines $ [ "pCase: Overlapping case constructors:"+ , " Constructor: " ++ showCase x+ ]+ ++ [ " Overlaps with:" ]+ ++ [ " " ++ showCaseGen (Just loc) p | p <- xs]++ -- | Build the proof case expression+ buildProofCase :: Exp -> String -> Maybe BuiltinType -> [Case] -> ExpQ+ buildProofCase scrut typ mbt cases = do+ cstrs <- getCstrs mbt typ+ allPairs <- processProofCases scrut cstrs mbt [] cases+ let casesName = mkName "cases"+ impliesName = mkName "==>"+ mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r)+ pure $ AppE (VarE casesName) (ListE (map mkPair allPairs))++-- * Proof case processing++-- | Process all proof cases linearly, accumulating prior guards.+-- Shared between the top-level @pCase@ quasi-quoter and 'processProofCaseExp'+-- (which handles nested @case@ expressions inside @[pCase| ... |]@).+--+-- Prior guards are tagged with their constructor name (Nothing for wildcards).+-- Each entry stores (constructor, fullGuard, userGuardOnly):+--+-- * fullGuard = the complete guard expression (used for wildcard De Morgan negation)+-- * userGuardOnly = Just the user guard part (used for same-constructor negation),+-- Nothing if unguarded (same-constructor arms don't negate unguarded matches)+processProofCases :: Exp -> [(Name, [Type])] -> Maybe BuiltinType -> [(Maybe Name, Exp, Maybe Exp)] -> [Case] -> Q [(Exp, Exp)]+processProofCases scrut cstrs mbt priorGuards0 cases0 = go priorGuards0 cases0+ where+ -- Aggregate, per constructor, the variables used in any guard or RHS across all arms with that constructor.+ -- A pattern var used in *some* same-constructor arm but not in *this* arm's RHS is dropped from the+ -- RHS bindings (the guard handles its own bindings via 'grdBindings'), avoiding false unused-binding+ -- warnings. A pattern var truly unused everywhere is kept so GHC can flag the user oversight.+ cstrUsedVars :: Map.Map Name (Set Name)+ cstrUsedVars = Map.fromListWith Set.union+ [ (nm, allUsed) | CMatch _ nm _ _ _ allUsed <- cases0 ]++ go _ [] = pure []+ go priorGuards (c:rest) = case c of+ CWild _ mbG rhs -> do+ -- Wildcard: negate the disjunction of ALL prior full guards (De Morgan)+ let allGuards = [g | (_, g, _) <- priorGuards]+ baseGuard = negateAllGuards allGuards+ finalGuard = case mbG of+ Nothing -> baseGuard+ Just g -> sAndAll [baseGuard, g]+ rest' <- go (priorGuards ++ [(Nothing, finalGuard, Nothing)]) rest+ pure $ (finalGuard, rhs) : rest'++ CMatch _o nm mbp mbG rhs _allUsed -> do+ let ts = case lookupBase nm cstrs of+ Just t -> t+ Nothing -> error $ "pCase: impossible: unknown constructor " ++ nameBase nm+ pats = fromMaybe (map (const WildP) ts) mbp++ -- Build let-bindings for pattern variables+ args = [(i, mkAccessorFor mbt nm i scrut) | (i, _) <- zip [(1 :: Int) ..] ts]+ bindings = [ ValD (VarP v) (NormalB acc) []+ | (i, acc) <- args, VarP v <- [pats !! (i - 1)] ]++ testerGuard = mkTesterFor mbt nm scrut++ -- For list cons patterns in pCase, add a destructuring equality:+ -- scrut .=== head scrut .: tail scrut+ -- Lists use SMT Seq (not declare-datatypes), so the solver doesn't automatically+ -- know that xs = head xs .: tail xs from sNot (null xs). We must add an explicit+ -- equality to give the solver this information, mirroring what 'split' does.+ -- All other types (ADTs, Maybe, Either, Tuple) use declare-datatypes and get+ -- these axioms for free.+ -- NB. For nested list cons patterns, the same equality is added by 'flattenCons'.+ destructEq+ | Just BTList <- mbt, nameBase nm == ":"+ = let hd = AppE (VarE (sbvName "Data.SBV.List" "head")) scrut+ tl = AppE (VarE (sbvName "Data.SBV.List" "tail")) scrut+ in [foldl1 AppE [VarE '(.===), scrut, InfixE (Just hd) (VarE '(.:)) (Just tl)]]+ | True+ = []++ -- Only negate prior USER guards for the SAME constructor (others are mutually exclusive)+ sameUserGuards = [ ug | (Just cn, _, Just ug) <- priorGuards, sameBase cn nm ]+ negPriors = map (AppE (VarE 'sNot)) sameUserGuards++ -- Build the final guard (wrap user guard in bindings so pattern vars are in scope)+ grdVars = maybe Set.empty freeVars mbG+ grdBindings = filter (\case+ ValD (VarP v) _ _ -> v `Set.member` grdVars+ _ -> True) bindings+ guardParts = [testerGuard] ++ destructEq ++ negPriors ++ maybe [] (pure . addLocals grdBindings) mbG+ finalGuard = sAndAll guardParts++ -- Wrap RHS with let-bindings. Keep a binding when the variable is used in this RHS, OR when+ -- it isn't used in any same-constructor arm (so GHC can warn about a truly unused pattern var).+ -- Drop it when used in some same-constructor arm but not here, to avoid spurious warnings.+ cstrUsed = Map.findWithDefault Set.empty nm cstrUsedVars+ rhsVars = freeVars rhs+ rhs' = addLocals (filter (\case+ ValD (VarP v) _ _ -> v `Set.member` rhsVars+ || not (v `Set.member` cstrUsed)+ _ -> True) bindings) rhs++ -- Track: full guard for wildcard negation, user guard for same-constructor negation+ userGuardOnly = case mbG of+ Just g -> Just (addLocals grdBindings g)+ Nothing -> Nothing+ priorGuards' = priorGuards ++ [(Just nm, finalGuard, userGuardOnly)]++ rest' <- go priorGuards' rest+ pure $ (finalGuard, rhs') : rest'++-- | Negate the disjunction of all given guards using De Morgan: sNot (g1 .|| g2 .|| ...)+negateAllGuards :: [Exp] -> Exp+negateAllGuards [] = VarE 'sTrue+negateAllGuards gs = AppE (VarE 'sNot) (foldl1 (\a b -> foldl1 AppE [VarE '(.||), a, b]) gs)++-- * Standalone helpers++-- | Free variables of an expression, respecting lexical scope.+-- A variable is free if it is used (VarE) and not bound by any enclosing+-- LetE, LamE, or CaseE at its use site.+freeVars :: Exp -> Set Name+freeVars = go Set.empty+ where+ go :: Set Name -> Exp -> Set Name+ go bound = \case+ VarE n -> if n `Set.member` bound then Set.empty else Set.singleton n+ ConE {} -> Set.empty+ LitE {} -> Set.empty+ AppE f x -> go bound f <> go bound x+ AppTypeE e _ -> go bound e+ InfixE ml o mr -> maybe Set.empty (go bound) ml <> go bound o <> maybe Set.empty (go bound) mr+ UInfixE l o r -> go bound l <> go bound o <> go bound r+ ParensE e -> go bound e+ CondE c t f -> go bound c <> go bound t <> go bound f+ TupE mes -> foldMap (maybe Set.empty (go bound)) mes+ UnboxedTupE mes -> foldMap (maybe Set.empty (go bound)) mes+ ListE es -> foldMap (go bound) es+ SigE e _ -> go bound e+ RecConE _ fes -> foldMap (go bound . snd) fes+ RecUpdE e fes -> go bound e <> foldMap (go bound . snd) fes+ -- Binding forms: extend the bound set in the appropriate scope+ LamE ps body -> go (bound <> patsNames ps) body+ LetE ds body -> let bound' = bound <> decsNames ds+ in foldMap (goDec bound') ds <> go bound' body+ CaseE scr ms -> go bound scr <> foldMap (goMatch bound) ms+ -- Fallback for other expression forms: conservatively report all+ -- VarE names minus known bound (may over-report, never under-report)+ other -> allVarE other Set.\\ bound++ goMatch :: Set Name -> Match -> Set Name+ goMatch bound (Match pat body ds) =+ let bound' = bound <> patNames pat <> decsNames ds+ in goBody bound' body <> foldMap (goDec bound') ds++ goBody :: Set Name -> Body -> Set Name+ goBody bound (NormalB e) = go bound e+ goBody bound (GuardedB gs) = foldMap (\(g, e) -> goGuard bound g <> go bound e) gs++ goGuard :: Set Name -> Guard -> Set Name+ goGuard bound (NormalG e) = go bound e+ goGuard _ _ = Set.empty++ goDec :: Set Name -> Dec -> Set Name+ goDec bound (ValD _ body ds) = goBody bound body <> foldMap (goDec bound) ds+ goDec bound (FunD _ cs) = foldMap (goClause bound) cs+ goDec _ _ = Set.empty++ goClause :: Set Name -> Clause -> Set Name+ goClause bound (Clause ps body ds) =+ let bound' = bound <> patsNames ps <> decsNames ds+ in goBody bound' body <> foldMap (goDec bound') ds++ -- Extract bound names from patterns+ patNames :: Pat -> Set Name+ patNames (VarP n) = Set.singleton n+ patNames (AsP n p) = Set.singleton n <> patNames p+ patNames (ConP _ _ ps) = patsNames ps+ patNames (InfixP p1 _ p2) = patNames p1 <> patNames p2+ patNames (UInfixP p1 _ p2) = patNames p1 <> patNames p2+ patNames (TupP ps) = patsNames ps+ patNames (UnboxedTupP ps) = patsNames ps+ patNames (ListP ps) = patsNames ps+ patNames (SigP p _) = patNames p+ patNames (ParensP p) = patNames p+ patNames (TildeP p) = patNames p+ patNames (BangP p) = patNames p+ patNames (ViewP _ p) = patNames p+ patNames WildP = Set.empty+ patNames (LitP _) = Set.empty+ patNames _ = Set.empty++ patsNames :: [Pat] -> Set Name+ patsNames = foldMap patNames++ -- Extract bound names from declarations+ decsNames :: [Dec] -> Set Name+ decsNames ds = Set.fromList $ [n | ValD (VarP n) _ _ <- ds] ++ [n | FunD n _ <- ds]++ -- Collect all VarE names in an expression (scope-unaware, for fallback only)+ allVarE :: Exp -> Set Name+ allVarE = \case+ VarE n -> Set.singleton n+ AppE f x -> allVarE f <> allVarE x+ AppTypeE e _ -> allVarE e+ InfixE ml o mr -> maybe Set.empty allVarE ml <> allVarE o <> maybe Set.empty allVarE mr+ UInfixE l o r -> allVarE l <> allVarE o <> allVarE r+ ParensE e -> allVarE e+ CondE c t f -> allVarE c <> allVarE t <> allVarE f+ TupE mes -> foldMap (maybe Set.empty allVarE) mes+ UnboxedTupE mes -> foldMap (maybe Set.empty allVarE) mes+ ListE es -> foldMap allVarE es+ SigE e _ -> allVarE e+ RecConE _ fes -> foldMap (allVarE . snd) fes+ RecUpdE e fes -> allVarE e <> foldMap (allVarE . snd) fes+ LamE _ body -> allVarE body+ LetE ds body -> foldMap allVarEDec ds <> allVarE body+ CaseE scr ms -> allVarE scr <> foldMap allVarEMatch ms+ _ -> Set.empty++ allVarEMatch :: Match -> Set Name+ allVarEMatch (Match _ body ds) = allVarEBody body <> foldMap allVarEDec ds++ allVarEBody :: Body -> Set Name+ allVarEBody (NormalB e) = allVarE e+ allVarEBody (GuardedB gs) = foldMap (\(_, e) -> allVarE e) gs++ allVarEDec :: Dec -> Set Name+ allVarEDec (ValD _ body ds) = allVarEBody body <> foldMap allVarEDec ds+ allVarEDec (FunD _ cs) = foldMap (\(Clause _ body ds) -> allVarEBody body <> foldMap allVarEDec ds) cs+ allVarEDec _ = Set.empty++-- | Count the number of arguments in a constructor type by counting arrows.+-- e.g., @Integer -> String -> Bool@ has 2 arguments.+-- Handles both plain ArrowT and multiplicity-annotated arrows (MulArrowT).+countArgs :: Type -> Int+countArgs (AppT (AppT ArrowT _) rest) = 1 + countArgs rest+countArgs (AppT (AppT (AppT MulArrowT _) _) rest) = 1 + countArgs rest+countArgs (ForallT _ _ t) = countArgs t+countArgs _ = 0++-- | Generate a symbolic equality guard for a literal pattern.+-- @litToEq off arg lit@ produces the expression @arg .== litVal@.+-- For integers, the literal is used directly (relying on @fromInteger@).+-- For characters and strings, the literal is wrapped with @literal@.+litToEq :: Offset -> Exp -> Lit -> Q Exp+litToEq _ arg (IntegerL n) = pure $ foldl1 AppE [VarE '(.==), arg, LitE (IntegerL n)]+litToEq _ arg (CharL c) = pure $ foldl1 AppE [VarE '(.==), arg, AppE (VarE 'literal) (LitE (CharL c))]+litToEq _ arg (StringL s) = pure $ foldl1 AppE [VarE '(.==), arg, AppE (VarE 'literal) (LitE (StringL s))]+litToEq off _ lit = fail off $ unlines+ [ "sCase/pCase: Unsupported literal in pattern: " ++ show lit+ , " Only integer, character, and string literals are supported."+ ]
+ Data/SBV/SEnum.hs view
@@ -0,0 +1,203 @@+-----------------------------------------------------------------------------+-- |+-- 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, enumFromThenToH)++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) -> do ea <- parseHaskellExpr loc a+ eb <- parseHaskellExpr loc b+ ec <- parseHaskellExpr loc c+ -- Pass the from/then step as a hint when it's a statically-known integer+ -- (e.g. @[m, m-1 .. n]@ => @-1@). Exact-arithmetic instances fold it; the+ -- rest ignore it. See 'constStep'.+ varE 'enumFromThenToH `appE` pure ea `appE` pure eb `appE` pure ec `appE` liftMStep (constStep ea eb)++ _ -> errorWithLoc loc $ unlines [ "Data.SBV.Enum: Invalid format. Use one of:"+ , ""+ , " [sEnum| a .. |]"+ , " [sEnum| a, b .. |]"+ , " [sEnum| a .. c |]"+ , " [sEnum| a, b .. c |]"+ ]++-- | Read a parsed expression as @base + offset@: a single opaque atom plus an integer constant.+-- @Nothing@ base means the whole thing is a pure integer constant. We only look through @+@ and @-@+-- of integer literals; anything else is treated as an atom. This is intentionally a single-base+-- peel, not a general linear normalizer -- it's exactly enough to recognize @m@, @m-1@, @m+k@, etc.+peel :: Exp -> (Maybe Exp, Integer)+peel (LitE (IntegerL n)) = (Nothing, n)+peel (ParensE e) = peel e+peel (SigE e _) = peel e+peel (InfixE (Just l) (VarE op) (Just (LitE (IntegerL n)))) = shift op l n+peel (UInfixE l (VarE op) (LitE (IntegerL n))) = shift op l n+peel (InfixE (Just (LitE (IntegerL n))) (VarE op) (Just r)) | base op == "+" = add (peel r) n+peel (UInfixE (LitE (IntegerL n)) (VarE op) r) | base op == "+" = add (peel r) n+peel e = (Just e, 0)++-- | Helper for 'peel': fold a @base <op> lit@ where @op@ is @+@ or @-@.+shift :: Name -> Exp -> Integer -> (Maybe Exp, Integer)+shift op l n = case base op of+ "+" -> add (peel l) n+ "-" -> add (peel l) (negate n)+ _ -> (Just (UInfixE l (VarE op) (LitE (IntegerL n))), 0)++-- | Add a constant to a peeled @(base, offset)@.+add :: (Maybe Exp, Integer) -> Integer -> (Maybe Exp, Integer)+add (b, k) n = (b, k + n)++-- | Unqualified name of an operator (haskell-src-meta may leave it unqualified, so compare by base).+base :: Name -> String+base = nameBase++-- | The from->then step @then - from@, when it's a statically-known integer (same atom on both+-- sides, so the atoms cancel). Returns @Nothing@ for genuinely-symbolic steps (distinct atoms),+-- in which case the quasiquoter falls back to the ordinary, hint-free behavior.+constStep :: Exp -> Exp -> Maybe Integer+constStep from thn+ | bf == bt = Just (kt - kf)+ | True = Nothing+ where (bf, kf) = peel from+ (bt, kt) = peel thn++-- | Splice a @`Maybe` `Integer`@ step hint into the generated call.+liftMStep :: Maybe Integer -> Q Exp+liftMStep Nothing = conE 'Nothing+liftMStep (Just n) = conE 'Just `appE` litE (integerL n)++-- | 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/SMT.hs view
@@ -9,14 +9,16 @@ -- Abstraction of SMT solvers ----------------------------------------------------------------------------- -{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wall -Werror #-}@@ -26,7 +28,7 @@ Modelable(..) , SatModel(..), genParse , extractModels, getModelValues- , getModelDictionaries, getModelUninterpretedValues+ , getModelDictionaries , displayModels, showModel, shCV, showModelDictionary -- * Standard prover engine@@ -45,9 +47,9 @@ import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO) import Control.DeepSeq (NFData(..))-import Control.Monad (zipWithM)+import Control.Monad (zipWithM, mplus) import Data.Char (isSpace)-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (isJust) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intercalate, isPrefixOf, transpose, isInfixOf) import Data.Word (Word8, Word16, Word32, Word64)@@ -57,31 +59,34 @@ import Data.IORef (readIORef, writeIORef) -import Data.Time (getZonedTime, defaultTimeLocale, formatTime, diffUTCTime, getCurrentTime)+import Data.Either (rights) import System.Directory (findExecutable)-import System.Environment (getEnv)+import System.Environment (getEnv, lookupEnv) import System.Exit (ExitCode(..))-import System.IO (hClose, hFlush, hPutStrLn, hGetContents, hGetLine)+import System.IO (hClose, hFlush, hGetContents, hGetLine, hReady, hGetChar) import System.Process (runInteractiveProcess, waitForProcess, terminateProcess) import qualified Data.Map.Strict as M import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Text.Read (readMaybe) import Data.SBV.Core.AlgReals import Data.SBV.Core.Data-import Data.SBV.Core.Symbolic (SMTEngine, State(..))+import Data.SBV.Core.Symbolic (SMTEngine, State(..), mustIgnoreVar) import Data.SBV.Core.Concrete (showCV)-import Data.SBV.Core.Kind (showBaseKind, intOfProxy)+import Data.SBV.Core.Kind (showBaseKind, intOfProxy, BVIsNonZero) import Data.SBV.Core.SizedFloats(FloatingPoint(..)) -import Data.SBV.SMT.Utils (showTimeoutValue, alignPlain, debug, mergeSExpr, SBVException(..))+import Data.SBV.SMT.Utils ( showTimeoutValue, alignPlain, debug, mergeSExpr, SBVException(..)+ , startTranscript, recordTranscript, finalizeTranscript, recordEndTime, recordException, TranscriptMsg(..)+ ) import Data.SBV.Utils.PrettyNum-import Data.SBV.Utils.Lib (joinArgs, splitArgs)-import Data.SBV.Utils.SExpr (parenDeficit)-import Data.SBV.Utils.TDiff (Timing(..), showTDiff)+import Data.SBV.Utils.Lib (joinArgs, splitArgs, needsBars, showText, unQuote)+import Data.SBV.Utils.SExpr (parenDeficit, nameSupply) import qualified System.Timeout as Timeout (timeout) @@ -98,25 +103,24 @@ resultConfig (Unknown c _ ) = c resultConfig (ProofError c _ _) = c --- | A 'Data.SBV.prove' call results in a 'ThmResult'+-- | A 'Data.SBV.prove' call results in a t'ThmResult' newtype ThmResult = ThmResult SMTResult deriving NFData --- | A 'Data.SBV.sat' call results in a 'SatResult'--- The reason for having a separate 'SatResult' is to have a more meaningful 'Show' instance.+-- | A 'Data.SBV.sat' call results in a t'SatResult'+-- The reason for having a separate t'SatResult' is to have a more meaningful 'Show' instance. newtype SatResult = SatResult SMTResult deriving NFData --- | An 'Data.SBV.allSat' call results in a 'AllSatResult'-data AllSatResult = AllSatResult { allSatMaxModelCountReached :: Bool -- ^ Did we reach the user given model count limit?- , allSatHasPrefixExistentials :: Bool -- ^ Were there quantifiers in the problem (unique upto prefix existentials)- , allSatSolverReturnedUnknown :: Bool -- ^ Did the solver report unknown at the end?- , allSatSolverReturnedDSat :: Bool -- ^ Did the solver report delta-satisfiable at the end?- , allSatResults :: [SMTResult] -- ^ All satisfying models+-- | An 'Data.SBV.allSat' call results in a t'AllSatResult'+data AllSatResult = AllSatResult { allSatMaxModelCountReached :: !Bool -- ^ Did we reach the user given model count limit?+ , allSatSolverReturnedUnknown :: !Bool -- ^ Did the solver report unknown at the end?+ , allSatSolverReturnedDSat :: !Bool -- ^ Did the solver report delta-satisfiable at the end?+ , allSatResults :: ![SMTResult] -- ^ All satisfying models } --- | A 'Data.SBV.safe' call results in a 'SafeResult'-newtype SafeResult = SafeResult (Maybe String, String, SMTResult)+-- | A 'Data.SBV.safe' call results in a t'SafeResult'+newtype SafeResult = SafeResult (Maybe String, String, SMTResult) -- | An 'Data.SBV.optimize' call results in a 'OptimizeResult'. In the 'ParetoResult' case, the boolean is 'True' -- if we reached pareto-query limit and so there might be more unqueried results remaining. If 'False',@@ -142,7 +146,7 @@ "Falsifiable in an extension field:\n" r --- User friendly way of printing satisfiablity results+-- User friendly way of printing satisfiability results instance Show SatResult where show (SatResult r) = showSMTResult "Unsatisfiable" "Unknown"@@ -167,16 +171,12 @@ -- The Show instance of AllSatResults. instance Show AllSatResult where show AllSatResult { allSatMaxModelCountReached = l- , allSatHasPrefixExistentials = e , allSatSolverReturnedUnknown = u , allSatSolverReturnedDSat = d , allSatResults = xs } = go (0::Int) xs- where warnings = case (e, u) of- (False, False) -> ""- (False, True) -> " (Search stopped since solver has returned unknown.)"- (True, False) -> " (Unique up to prefix existentials.)"- (True, True) -> " (Search stopped because solver has returned unknown, only prefix existentials were considered.)"+ where warnings | u = " (Search stopped since solver has returned unknown.)"+ | True = "" go c (s:ss) = let c' = c+1 (ok, o) = sh c' s@@ -235,15 +235,14 @@ -- | Given a sequence of constant-words, extract one instance of the type @a@, returning -- the remaining elements untouched. If the next element is not what's expected for this -- type you should return 'Nothing'- parseCVs :: [CV] -> Maybe (a, [CV])+ parseCVs :: [CV] -> Maybe (a, [CV])+ -- | Given a parsed model instance, transform it using @f@, and return the result. -- The default definition for this method should be sufficient in most use cases.- cvtModel :: (a -> Maybe b) -> Maybe (a, [CV]) -> Maybe (b, [CV])- cvtModel f x = x >>= \(a, r) -> f a >>= \b -> return (b, r)+ cvtModel :: (a -> Maybe b) -> Maybe (a, [CV]) -> Maybe (b, [CV])+ cvtModel f x = x >>= \(a, r) -> f a >>= \b -> pure (b, r) - default parseCVs :: Read a => [CV] -> Maybe (a, [CV])- parseCVs (CV _ (CUserSort (_, s)) : r) = Just (read s, r)- parseCVs _ = Nothing+ {-# MINIMAL parseCVs #-} -- | Parse a signed/sized value from a sequence of CVs genParse :: Integral a => Kind -> [CV] -> Maybe (a, [CV])@@ -252,12 +251,12 @@ -- | Base case for 'SatModel' at unit type. Comes in handy if there are no real variables. instance SatModel () where- parseCVs xs = return ((), xs)+ parseCVs xs = pure ((), xs) -- | 'Bool' as extracted from a model instance SatModel Bool where parseCVs xs = do (x, r) <- genParse KBool xs- return ((x :: Integer) /= 0, r)+ pure ((x :: Integer) /= 0, r) -- | 'Word8' as extracted from a model instance SatModel Word8 where@@ -316,13 +315,38 @@ | intOfProxy (Proxy @eb) == ei , intOfProxy (Proxy @sb) == si = Just (FloatingPoint fp, r) parseCVs _ = Nothing +-- | Constructing models for 'WordN'+instance (KnownNat n, BVIsNonZero n) => SatModel (WordN n) where+ parseCVs = genParse (kindOf (undefined :: WordN n))++-- | Constructing models for 'IntN'+instance (KnownNat n, BVIsNonZero n) => SatModel (IntN n) where+ parseCVs = genParse (kindOf (undefined :: IntN n))++-- | Constructing models for t'ArrayModel'+instance (SatModel k, SatModel v) => SatModel (ArrayModel k v) where+ parseCVs (CV (KArray kk kv) (CArray (ArrayModel tbl def)) : r)+ | Just (def', _) <- parseCVs @v [CV kv def]+ , let convert (k, v) = do+ (k', _) <- parseCVs @k [CV kk k]+ (v', _) <- parseCVs @v [CV kv v]+ pure (k', v')+ , Just tbl' <- traverse convert tbl+ = Just (ArrayModel tbl' def', r)+ parseCVs _ = Nothing+ -- | @CV@ as extracted from a model; trivial definition instance SatModel CV where parseCVs (cv : r) = Just (cv, r) parseCVs [] = Nothing -- | A rounding mode, extracted from a model. (Default definition suffices)-instance SatModel RoundingMode+instance SatModel RoundingMode where+ parseCVs (CV k (CADT (s, [])) : r)+ | isRoundingMode k+ , Just mode <- s `lookup` [(show m, m) | m <- [minBound .. maxBound :: RoundingMode]]+ = Just (mode, r)+ parseCVs _ = Nothing -- | 'String' as extracted from a model instance {-# OVERLAPS #-} SatModel [Char] where@@ -349,37 +373,37 @@ instance (SatModel a, SatModel b) => SatModel (a, b) where parseCVs as = do (a, bs) <- parseCVs as (b, cs) <- parseCVs bs- return ((a, b), cs)+ pure ((a, b), cs) -- | 3-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c) => SatModel (a, b, c) where parseCVs as = do (a, bs) <- parseCVs as ((b, c), ds) <- parseCVs bs- return ((a, b, c), ds)+ pure ((a, b, c), ds) -- | 4-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d) => SatModel (a, b, c, d) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d), es) <- parseCVs bs- return ((a, b, c, d), es)+ pure ((a, b, c, d), es) -- | 5-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e) => SatModel (a, b, c, d, e) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d, e), fs) <- parseCVs bs- return ((a, b, c, d, e), fs)+ pure ((a, b, c, d, e), fs) -- | 6-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f) => SatModel (a, b, c, d, e, f) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d, e, f), gs) <- parseCVs bs- return ((a, b, c, d, e, f), gs)+ pure ((a, b, c, d, e, f), gs) -- | 7-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f, SatModel g) => SatModel (a, b, c, d, e, f, g) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d, e, f, g), hs) <- parseCVs bs- return ((a, b, c, d, e, f, g), hs)+ pure ((a, b, c, d, e, f, g), hs) -- | Various SMT results that we can extract models out of. class Modelable a where@@ -396,15 +420,7 @@ -- | Extract a model value for a given element. Also see `getModelValues`. getModelValue :: SymVal b => String -> a -> Maybe b- getModelValue v r = fromCV `fmap` (v `M.lookup` getModelDictionary r)-- -- | Extract a representative name for the model value of an uninterpreted kind.- -- This is supposed to correspond to the value as computed internally by the- -- SMT solver; and is unportable from solver to solver. Also see `getModelUninterpretedValues`.- getModelUninterpretedValue :: String -> a -> Maybe String- getModelUninterpretedValue v r = case v `M.lookup` getModelDictionary r of- Just (CV _ (CUserSort (_, s))) -> Just s- _ -> Nothing+ getModelValue v r = fromCV <$> (v `M.lookup` getModelDictionary r) -- | A simpler variant of 'getModelAssignment' to get a model out without the fuss. extractModel :: SatModel b => a -> Maybe b@@ -420,10 +436,10 @@ getModelObjectiveValue v r = v `M.lookup` getModelObjectives r -- | Extract model uninterpreted-functions- getModelUIFuns :: a -> M.Map String (SBVType, ([([CV], CV)], CV))+ getModelUIFuns :: a -> M.Map String (Bool, SBVType, Either String ([([CV], CV)], CV)) -- | Extract the value of an uninterpreted-function as an association list- getModelUIFunValue :: String -> a -> Maybe (SBVType, ([([CV], CV)], CV))+ getModelUIFunValue :: String -> a -> Maybe (Bool, SBVType, Either String ([([CV], CV)], CV)) getModelUIFunValue v r = v `M.lookup` getModelUIFuns r -- | Return all the models from an 'Data.SBV.allSat' call, similar to 'extractModel' but@@ -439,11 +455,7 @@ getModelValues :: SymVal b => String -> AllSatResult -> [Maybe b] getModelValues s AllSatResult{allSatResults = xs} = map (s `getModelValue`) xs --- | Extract value of an uninterpreted variable from an all-sat call. Similar to `getModelUninterpretedValue`.-getModelUninterpretedValues :: String -> AllSatResult -> [Maybe String]-getModelUninterpretedValues s AllSatResult{allSatResults = xs} = map (s `getModelUninterpretedValue`) xs---- | 'ThmResult' as a generic model provider+-- | t'ThmResult' as a generic model provider instance Modelable ThmResult where getModelAssignment (ThmResult r) = getModelAssignment r modelExists (ThmResult r) = modelExists r@@ -451,7 +463,7 @@ getModelObjectives (ThmResult r) = getModelObjectives r getModelUIFuns (ThmResult r) = getModelUIFuns r --- | 'SatResult' as a generic model provider+-- | t'SatResult' as a generic model provider instance Modelable SatResult where getModelAssignment (SatResult r) = getModelAssignment r modelExists (SatResult r) = modelExists r@@ -507,10 +519,10 @@ -- The arrange argument can sort the results in any way you like, if necessary. displayModels :: SatModel a => ([(Bool, a)] -> [(Bool, a)]) -> (Int -> (Bool, a) -> IO ()) -> AllSatResult -> IO Int displayModels arrange disp AllSatResult{allSatResults = ms} = do- let models = [a | Right a <- map (getModelAssignment . SatResult) ms]+ let models = rights (map (getModelAssignment . SatResult) ms) inds <- zipWithM display (arrange models) [(1::Int)..]- return $ last (0:inds)- where display r i = disp i r >> return i+ pure $ last (0:inds)+ where display r i = disp i r >> pure i -- | Show an SMTResult; generic version showSMTResult :: String -> String -> String -> String -> (Maybe String -> String) -> String -> SMTResult -> String@@ -520,7 +532,7 @@ Satisfiable _ m -> satMsgModel ++ showModel cfg m DeltaSat _ p m -> dSatMsgModel p ++ showModel cfg m SatExtField _ (SMTModel b _ _ _) -> satExtMsg ++ showModelDictionary True False cfg b- Unknown _ r -> unkMsg ++ ".\n" ++ " Reason: " `alignPlain` show r+ Unknown _ r -> unkMsg ++ ".\n" ++ T.unpack (" Reason: " `alignPlain` showText r) ProofError _ [] Nothing -> "*** An error occurred. No additional information available. Try running in verbose mode." ProofError _ ls Nothing -> "*** An error occurred.\n" ++ intercalate "\n" (map ("*** " ++) ls) ProofError _ ls (Just r) -> intercalate "\n" $ [ "*** " ++ l | l <- ls]@@ -561,10 +573,10 @@ relevantVars = filter (not . ignore) allVars ignore (T.pack -> s, _) | includeEverything = False- | True = "__internal_sbv_" `T.isPrefixOf` s || isNonModelVar cfg (T.unpack s)+ | True = mustIgnoreVar cfg s - shM (s, RegularCV v) = let vs = shCV cfg v in ((length s, s), (vlength vs, vs))- shM (s, other) = let vs = show other in ((length s, s), (vlength vs, vs))+ shM (s, RegularCV v) = let vs = shCV cfg s v in ((length s, s), (vlength vs, vs))+ shM (s, other) = let vs = show other in ((length s, s), (vlength vs, vs)) display svs = map line svs where line ((_, s), (_, v)) = " " ++ right (nameWidth - length s) s ++ " = " ++ left (valWidth - lTrimRight (valPart v)) v@@ -584,30 +596,55 @@ lTrimRight = length . dropWhile isSpace . reverse -- | Show an uninterpreted function-showModelUI :: SMTConfig -> (String, (SBVType, ([([CV], CV)], CV))) -> String-showModelUI cfg (nm, (SBVType ts, (defs, dflt))) = intercalate "\n" [" " ++ l | l <- sig : map align body]+showModelUI :: SMTConfig -> (String, (Bool, SBVType, Either String ([([CV], CV)], CV))) -> String+showModelUI cfg (nm, (isCurried, SBVType ts, interp))+ = intercalate "\n" $ case interp of+ Left e -> [" " ++ trim l | l <- [sig, e]]+ Right ds -> [" " ++ trim l | l <- sig : mkBody ds] where noOfArgs = length ts - 1 - sig = nm ++ " :: " ++ intercalate " -> " (map showBaseKind ts)+ trim = reverse . dropWhile isSpace . reverse - ls = map line defs- defLine = (nm : replicate noOfArgs "_", scv dflt)+ (ats, rt) = case map (T.unpack . showBaseKind) ts of+ [] -> error $ "showModelUI: Unexpected type: " ++ show (SBVType ts)+ tss -> (init tss, last tss) - body = ls ++ [defLine]+ -- signatures require parens if this is a non-ascii name, i.e., needs bars+ sigName | needsBars nm = '(' : nm ++ ")"+ | True = nm - colWidths = [maximum (0 : map length col) | col <- transpose (map fst body)]+ sig | isCurried = sigName ++ " :: " ++ intercalate " -> " ats ++ " -> " ++ rt+ | True = sigName ++ " :: (" ++ intercalate ", " ats ++ ") -> " ++ rt - resWidth = maximum (0 : map (length . snd) body)+ mkBody (defs, dflt) = map align body+ where ls = map line defs+ body = ls ++ [defLine] - align (xs, r) = unwords $ zipWith left colWidths xs ++ ["=", left resWidth r]- where left i x = take i (x ++ repeat ' ')+ -- is the default an argument? This is likely to be z3 specific+ defVal = scv dflt+ defPos = case span (/= '!') defVal of+ (_, '!':n) | Just (i :: Int) <- readMaybe n, i > 0 -> Just (i, nameSupply [] !! (i-1)) -- default is the ith argument+ _ -> Nothing -- default is a constant (or something else?)+ defLine = case defPos of+ Just (i, a) | i > 0 -> (replicate (i - 1) "_" ++ a : replicate (noOfArgs - i) "_", a)+ _ -> (replicate noOfArgs "_", defVal) + colWidths = [maximum (0 : map length col) | col <- transpose (map fst body)]++ resWidth = maximum (0 : map (length . snd) body)++ align (xs, r) = nm ++ " " ++ merge (zipWith left colWidths xs) ++ " = " ++ left resWidth r+ where left i x = take i (x ++ repeat ' ')++ merge as | isCurried = unwords as+ | True = '(' : intercalate ", " as ++ ")"+ -- NB. We'll ignore crackNum here. Seems to be overkill while displaying an -- uninterpreted function. scv = sh (printBase cfg)- where sh 2 = binP+ where sh 2 = T.unpack . binP sh 10 = showCV False- sh 16 = hexP+ sh 16 = T.unpack . hexP sh _ = show -- NB. If we have a float NaN/Infinity/+0/-0 etc. these will@@ -617,29 +654,29 @@ -- we might want to do this properly later somehow. (Perhaps -- using some sort of a view pattern.) line :: ([CV], CV) -> ([String], String)- line (args, r) = (nm : map (paren . scv) args, scv r)- where -- If negative, parenthesize. I think this is the only case+ line (args, r) = (map (paren isCurried . scv) args, scv r)+ where -- If negative and if we're curried, parenthesize. I think this is the only case -- we need to worry about. Hopefully!- paren :: String -> String- paren x@('-':_) = '(' : x ++ ")"- paren x = x+ paren :: Bool -> String -> String+ paren True x@('-':_) = '(' : x ++ ")"+ paren _ x = x -- | Show a constant value, in the user-specified base-shCV :: SMTConfig -> CV -> String-shCV SMTConfig{printBase, crackNum} cv = cracked (sh printBase cv)- where sh 2 = binS+shCV :: SMTConfig -> String -> CV -> String+shCV SMTConfig{printBase, crackNum, verbose, crackNumSurfaceVals} nm cv = cracked (sh printBase cv)+ where sh 2 = T.unpack . binS sh 10 = show- sh 16 = hexS+ sh 16 = T.unpack . hexS sh n = \w -> show w ++ " -- Ignoring unsupported printBase " ++ show n ++ ", use 2, 10, or 16." cracked def | not crackNum = def- | True = case CN.crackNum cv of+ | True = case CN.crackNum cv verbose (nm `lookup` crackNumSurfaceVals) of Nothing -> def Just cs -> def ++ "\n" ++ cs -- | Helper function to spin off to an SMT solver.-pipeProcess :: SMTConfig -> State -> String -> [String] -> String -> (State -> IO a) -> IO a+pipeProcess :: SMTConfig -> State -> String -> [String] -> T.Text -> (State -> IO a) -> IO a pipeProcess cfg ctx execName opts pgm continuation = do mbExecPath <- findExecutable execName case mbExecPath of@@ -657,14 +694,42 @@ ]) ] +-- Communication-level timeouts (microseconds). These are NOT solver timeouts+-- (i.e., how long check-sat takes); they govern how long SBV waits for the+-- solver process to respond to individual IPC commands.+--+-- Adjust via the @SBV_COMM_TIMEOUT_FACTOR@ environment variable (default: 1).+-- For instance, setting it to 2 doubles all communication timeouts.++-- | Timeout for @set-option@ commands (expected to be fast).+setCommandTimeOut :: Int+setCommandTimeOut = 2_000_000 -- 2 seconds++-- | Timeout for subsequent response lines once the solver starts responding,+-- and for heartbeat\/sync-point reads.+defaultLineTimeOut :: Int+defaultLineTimeOut = 5_000_000 -- 5 seconds++-- | Read @SBV_COMM_TIMEOUT_FACTOR@ and return a function that scales timeout values.+-- If the variable is unset, the identity function is returned. If set to an invalid+-- value (not a positive number), an error is raised.+commTimeOutScaler :: IO (Int -> Int)+commTimeOutScaler = do+ mbFactor <- lookupEnv "SBV_COMM_TIMEOUT_FACTOR"+ case mbFactor of+ Nothing -> pure id+ Just s -> case reads s of+ [(f, "")] | f > (0 :: Double) -> pure (round . (f *) . fromIntegral)+ _ -> error $ "SBV_COMM_TIMEOUT_FACTOR: invalid value " ++ show s ++ ". Must be a positive number."+ -- | A standard engine interface. Most solvers follow-suit here in how we "chat" to them.. standardEngine :: String -> String -> SMTEngine standardEngine envName envOptName cfg ctx pgm continuation = do - execName <- getEnv envName `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (executable (solver cfg))))- execOpts <- (splitArgs `fmap` getEnv envOptName) `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (options (solver cfg) cfg)))+ execName <- getEnv envName `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (executable (solver cfg))))+ execOpts <- (splitArgs <$> getEnv envOptName) `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (options (solver cfg) cfg))) let cfg' = cfg {solver = (solver cfg) {executable = execName, options = const execOpts}} @@ -674,65 +739,101 @@ -- communicating with it. standardSolver :: SMTConfig -- ^ The current configuration -> State -- ^ Context in which we are running- -> String -- ^ The program+ -> T.Text -- ^ The program -> (State -> IO a) -- ^ The continuation -> IO a standardSolver config ctx pgm continuation = do- let msg s = debug config ["** " ++ s]+ let msg s = debug config ["** " <> s] smtSolver= solver config exec = executable smtSolver opts = options smtSolver config ++ extraArgs config- msg $ "Calling: " ++ (exec ++ (if null opts then "" else " ") ++ joinArgs opts)+ msg $ "Calling: " <> T.pack (exec ++ (if null opts then "" else " ") ++ joinArgs opts) rnf pgm `seq` pipeProcess config ctx exec opts pgm continuation -- | An internal type to track of solver interactions-data SolverLine = SolverRegular String -- ^ All is well- | SolverTimeout String -- ^ Timeout expired- | SolverException String -- ^ Something else went wrong+data SolverLine = SolverRegular String -- ^ All is well+ | SolverTimeout String -- ^ Timeout expired+ | SolverException String -- ^ Something else went wrong -- | A variant of @readProcessWithExitCode@; except it deals with SBV continuations-runSolver :: SMTConfig -> State -> FilePath -> [String] -> String -> (State -> IO a) -> IO a+runSolver :: SMTConfig -> State -> FilePath -> [String] -> T.Text -> (State -> IO a) -> IO a runSolver cfg ctx execPath opts pgm continuation- = do let nm = show (name (solver cfg))- msg = debug cfg . map ("*** " ++)+ = do scaler <- commTimeOutScaler + let nm = show (name (solver cfg))+ msg = debug cfg . map ("*** " <>)+ clean = preprocess (solver cfg) + -- the very first command we send+ heartbeat = "(set-option :print-success true)"++ -- Scaled communication timeouts+ setCommandTO = Just (scaler setCommandTimeOut)+ defaultLineTO = Just (scaler defaultLineTimeOut)++ -- Default SBVException with solver config baked in; callers override fields as needed+ solverException desc =+ let (errOut, description)+ | "(error" `isPrefixOf` desc+ = ( Just $ unQuote (dropWhile isSpace (dropWhile (not . isSpace) (init desc)))+ , "Unexpected solver error"+ )+ | True+ = (Nothing, desc)+ in SBVException { sbvExceptionDescription = description+ , sbvExceptionSent = Nothing+ , sbvExceptionExpected = Nothing+ , sbvExceptionReceived = Nothing+ , sbvExceptionStdOut = Nothing+ , sbvExceptionStdErr = errOut+ , sbvExceptionExitCode = Nothing+ , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } }+ , sbvExceptionReason = Nothing+ , sbvExceptionHint = Nothing+ }+ (send, ask, getResponseFromSolver, terminateSolver, cleanUp, pid) <- do (inh, outh, errh, pid) <- runInteractiveProcess execPath opts Nothing Nothing - let send :: Maybe Int -> String -> IO ()- send mbTimeOut command = do hPutStrLn inh (clean command)+ let send :: Maybe Int -> T.Text -> IO ()+ send mbTimeOut command = do TIO.hPutStrLn inh (clean command) hFlush inh- recordTranscript (transcript cfg) $ Left (command, mbTimeOut)+ recordTranscript (transcript cfg) $ SentMsg command mbTimeOut + -- is this a set-command? Then we expect faster response; except for the heartbeat+ isSetCommand = maybe False chk+ where chk cmd = cmd /= heartbeat && "(set-option :" `isPrefixOf` cmd+ -- Send a line, get a whole s-expr. We ignore the pathetic case that there might be a string with an unbalanced parentheses in it in a response.- ask :: Maybe Int -> String -> IO String+ ask :: Maybe Int -> T.Text -> IO String ask mbTimeOut command =- -- solvers don't respond to empty lines or comments; we just pass back- -- success in these cases to keep the illusion of everything has a response- let cmd = dropWhile isSpace command- in if null cmd || ";" `isPrefixOf` cmd- then return "success"+ let -- solvers don't respond to empty lines or comments; we just pass back+ -- success in these cases to keep the illusion of everything has a response+ cmd = T.dropWhile isSpace command++ in if T.null cmd || ";" `T.isPrefixOf` cmd+ then pure "success" else do send mbTimeOut command- getResponseFromSolver (Just command) mbTimeOut+ getResponseFromSolver (Just (T.unpack command)) mbTimeOut -- Get a response from the solver, with an optional time-out on how long- -- to wait. Note that there's *always* a time-out of 5 seconds once we get the- -- first line of response, as while the solver might take it's time to respond,+ -- to wait. Note that there's *always* a time-out once we get the+ -- first line of response, as while the solver might take its time to respond, -- once it starts responding successive lines should come quickly. getResponseFromSolver :: Maybe String -> Maybe Int -> IO String getResponseFromSolver mbCommand mbTimeOut = do response <- go True 0 [] let collated = intercalate "\n" $ reverse response- recordTranscript (transcript cfg) $ Right collated- return collated+ recordTranscript (transcript cfg) $ RecvMsg collated+ pure collated where safeGetLine isFirst h =- let timeOutToUse | isFirst = mbTimeOut- | True = Just 5000000- timeOutMsg t | isFirst = "User specified timeout of " ++ showTimeoutValue t ++ " exceeded"- | True = "A multiline complete response wasn't received before " ++ showTimeoutValue t ++ " exceeded"+ let timeOutToUse | isSetCommand mbCommand = setCommandTO+ | isFirst = mbTimeOut+ | True = defaultLineTO+ timeOutMsg t | isFirst = "User specified timeout of " ++ T.unpack (showTimeoutValue t) ++ " exceeded"+ | True = "A multiline complete response wasn't received before " ++ T.unpack (showTimeoutValue t) ++ " exceeded" -- Like hGetLine, except it keeps getting lines if inside a string. getFullLine :: IO String@@ -749,113 +850,117 @@ if stillInside then collect True sofar'- else return sofar'+ else pure sofar' + -- Carefully grab things as they are ready. But don't block!+ collectH handle = reverse <$> coll ""+ where coll sofar = do b <- hReady handle+ if b+ then hGetChar handle >>= \c -> coll (c:sofar)+ else pure sofar++ -- grab the contents of a handle, and return it trimmed if any+ grab handle = do mbCts <- (Just <$> collectH handle) `C.catch` (\(_ :: C.SomeException) -> pure Nothing)+ pure $ dropWhile isSpace <$> mbCts+ in case timeOutToUse of- Nothing -> SolverRegular <$> getFullLine+ Nothing -> do l <- getFullLine+ -- If we see the line starting with error, we're about to die, so give up:+ pure $ if "(error" `isPrefixOf` l+ then SolverException l+ else SolverRegular l Just t -> do r <- Timeout.timeout t getFullLine case r of- Just l -> return $ SolverRegular l- Nothing -> return $ SolverTimeout $ timeOutMsg t-+ Just l -> pure $ SolverRegular l+ Nothing -> do out <- grab outh+ err <- grab errh+ -- in this case, if we have something on out/err pass that back as regular+ case err `mplus` out of+ Just x | not (null x) -> pure $ SolverRegular x+ _ -> pure $ SolverTimeout (timeOutMsg t) go isFirst i sofar = do- errln <- safeGetLine isFirst outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (SolverException (show e))))+ errln <- safeGetLine isFirst outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (SolverException (show e)))) case errln of- SolverRegular ln -> let need = i + parenDeficit ln+ SolverRegular ln -> let !need = i + parenDeficit ln -- make sure we get *something* empty = case dropWhile isSpace ln of [] -> True (';':_) -> True -- yes this does happen! I've seen z3 print out comments on stderr. _ -> False in case (empty, need <= 0) of- (True, _) -> do debug cfg ["[SKIP] " `alignPlain` ln]+ (True, _) -> do debug cfg ["[SKIP] " `alignPlain` T.pack ln] go isFirst need sofar (False, False) -> go False need (ln:sofar)- (False, True) -> return (ln:sofar)+ (False, True) -> pure (ln:sofar) SolverException e -> do terminateProcess pid- C.throwIO SBVException { sbvExceptionDescription = e- , sbvExceptionSent = mbCommand- , sbvExceptionExpected = Nothing- , sbvExceptionReceived = Just $ unlines (reverse sofar)- , sbvExceptionStdOut = Nothing- , sbvExceptionStdErr = Nothing- , sbvExceptionExitCode = Nothing- , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } }- , sbvExceptionReason = Nothing- , sbvExceptionHint = if "hGetLine: end of file" `isInfixOf` e- then Just [ "Solver process prematurely ended communication."- , ""- , "It is likely it was terminated because of a seg-fault."- , "Run with 'transcript=Just \"bad.smt2\"' option, and feed"- , "the generated \"bad.smt2\" file directly to the solver"- , "outside of SBV for further information."- ]- else Nothing- }+ C.throwIO (solverException e)+ { sbvExceptionSent = mbCommand+ , sbvExceptionReceived = Just $ unlines (reverse sofar)+ , sbvExceptionHint = if "hGetLine: end of file" `isInfixOf` e+ then Just [ "Solver process prematurely ended communication."+ , ""+ , "It is likely it was terminated because of a seg-fault."+ , "Run with 'transcript=Just \"bad.smt2\"' option, and feed"+ , "the generated \"bad.smt2\" file directly to the solver"+ , "outside of SBV for further information."+ ]+ else Nothing+ } SolverTimeout e -> do terminateProcess pid -- NB. Do not *wait* for the process, just quit.- C.throwIO SBVException { sbvExceptionDescription = "Timeout! " ++ e- , sbvExceptionSent = mbCommand- , sbvExceptionExpected = Nothing- , sbvExceptionReceived = Just $ unlines (reverse sofar)- , sbvExceptionStdOut = Nothing- , sbvExceptionStdErr = Nothing- , sbvExceptionExitCode = Nothing- , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } }- , sbvExceptionReason = Nothing- , sbvExceptionHint = if not (verbose cfg)- then Just ["Run with 'verbose=True' for further information"]- else Nothing- } + C.throwIO (solverException ("Timeout! " ++ e))+ { sbvExceptionSent = mbCommand+ , sbvExceptionReceived = Just $ unlines (reverse sofar)+ , sbvExceptionHint = if not (verbose cfg)+ then Just ["Run with 'verbose=True' for further information"]+ else Nothing+ }+ terminateSolver = do hClose inh outMVar <- newEmptyMVar- out <- hGetContents outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (show e)))+ out <- hGetContents outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (show e))) _ <- forkIO $ C.evaluate (length out) >> putMVar outMVar ()- err <- hGetContents errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (show e)))+ err <- hGetContents errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (show e))) _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar () takeMVar outMVar takeMVar outMVar- hClose outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return ()))- hClose errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return ()))- ex <- waitForProcess pid `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (ExitFailure (-999))))- return (out, err, ex)+ hClose outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure ()))+ hClose errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure ()))+ ex <- waitForProcess pid `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (ExitFailure (-999))))+ pure (out, err, ex) - cleanUp+ cleanUp maybeForwardedException = do (out, err, ex) <- terminateSolver - msg $ [ "Solver : " ++ nm- , "Exit code: " ++ show ex+ msg $ [ "Solver : " <> T.pack nm+ , "Exit code: " <> showText ex ]- ++ [ "Std-out : " ++ intercalate "\n " (lines out) | not (null out)]- ++ [ "Std-err : " ++ intercalate "\n " (lines err) | not (null err)]+ <> [ "Std-out : " <> T.pack (intercalate "\n " (lines out)) | not (null out)]+ <> [ "Std-err : " <> T.pack (intercalate "\n " (lines err)) | not (null err)] finalizeTranscript (transcript cfg) ex recordEndTime cfg ctx - case ex of- ExitSuccess -> return ()- _ -> if ignoreExitCode cfg- then msg ["Ignoring non-zero exit code of " ++ show ex ++ " per user request!"]- else C.throwIO SBVException { sbvExceptionDescription = "Failed to complete the call to " ++ nm- , sbvExceptionSent = Nothing- , sbvExceptionExpected = Nothing- , sbvExceptionReceived = Nothing- , sbvExceptionStdOut = Just out- , sbvExceptionStdErr = Just err- , sbvExceptionExitCode = Just ex- , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } }- , sbvExceptionReason = Nothing- , sbvExceptionHint = if not (verbose cfg)- then Just ["Run with 'verbose=True' for further information"]- else Nothing- }+ case (ex, maybeForwardedException) of+ (_, Just forwardedException) -> C.throwIO forwardedException+ (ExitSuccess, _) -> pure ()+ _ -> if ignoreExitCode cfg+ then msg ["Ignoring non-zero exit code of " <> showText ex <> " per user request!"]+ else C.throwIO (solverException ("Failed to complete the call to " ++ nm))+ { sbvExceptionStdOut = Just out+ , sbvExceptionStdErr = Just err+ , sbvExceptionExitCode = Just ex+ , sbvExceptionHint = if not (verbose cfg)+ then Just ["Run with 'verbose=True' for further information"]+ else Nothing+ } - return (send, ask, getResponseFromSolver, terminateSolver, cleanUp, pid)+ pure (send, ask, getResponseFromSolver, terminateSolver, cleanUp, pid) - let executeSolver = do let sendAndGetSuccess :: Maybe Int -> String -> IO ()+ let executeSolver = do let sendAndGetSuccess :: Maybe Int -> T.Text -> IO () sendAndGetSuccess mbTimeOut l -- The pathetic case when the solver doesn't support queries, so we pretend it responded "success" -- Currently ABC is the only such solver.@@ -868,7 +973,7 @@ ["success"] -> debug cfg ["[GOOD] " `alignPlain` l] _ -> do debug cfg ["[FAIL] " `alignPlain` l] - let isOption = "(set-option" `isPrefixOf` dropWhile isSpace l+ let isOption = T.isPrefixOf "(set-option" (T.dropWhile isSpace l) reason | isOption = [ "Backend solver reports it does not support this option." , "Check the spelling, and if correct please report this as a"@@ -879,8 +984,8 @@ ] -- put a sync point here before we die so we consume everything- mbExtras <- (Right <$> getResponseFromSolver Nothing (Just 5000000))- `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (Left (show e))))+ mbExtras <- (Right <$> getResponseFromSolver Nothing defaultLineTO)+ `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (Left (show e)))) -- Ignore any exceptions from last sync, pointless. let extras = case mbExtras of@@ -891,16 +996,14 @@ let out = intercalate "\n" . lines $ outOrig err = intercalate "\n" . lines $ errOrig - exc = SBVException { sbvExceptionDescription = "Unexpected non-success response from " ++ nm- , sbvExceptionSent = Just l- , sbvExceptionExpected = Just "success"- , sbvExceptionReceived = Just $ r ++ "\n" ++ extras- , sbvExceptionStdOut = Just out- , sbvExceptionStdErr = Just err- , sbvExceptionExitCode = Just ex- , sbvExceptionConfig = cfg { solver = (solver cfg) {executable = execPath } }- , sbvExceptionReason = Just reason- , sbvExceptionHint = Nothing+ exc = (solverException ("Unexpected non-success response from " ++ nm))+ { sbvExceptionSent = Just (T.unpack l)+ , sbvExceptionExpected = Just "success"+ , sbvExceptionReceived = Just $ r ++ "\n" ++ extras+ , sbvExceptionStdOut = Just out+ , sbvExceptionStdErr = Just err+ , sbvExceptionExitCode = Just ex+ , sbvExceptionReason = Just reason } C.throwIO exc@@ -911,11 +1014,10 @@ -- First check that the solver supports :print-success let backend = name $ solver cfg if not (supportsCustomQueries (capabilities (solver cfg)))- then debug cfg ["** Skipping heart-beat for the solver " ++ show backend]- else do let heartbeat = "(set-option :print-success true)"- r <- ask (Just 5000000) heartbeat -- Give the solver 5s to respond, this should be plenty enough!+ then debug cfg ["** Skipping heart-beat for the solver " <> showText backend]+ else do r <- ask defaultLineTO (T.pack heartbeat) case words r of- ["success"] -> debug cfg ["[GOOD] " ++ heartbeat]+ ["success"] -> debug cfg ["[GOOD] " <> T.pack heartbeat] ["unsupported"] -> error $ unlines [ "" , "*** Backend solver (" ++ show backend ++ ") does not support the command:" , "***"@@ -937,13 +1039,13 @@ -- For push/pop support, we require :global-declarations to be true. But not all solvers -- support this. Issue it if supported. (If not, we'll reject pop calls.) if not (supportsGlobalDecls (capabilities (solver cfg)))- then debug cfg [ "** Backend solver " ++ show backend ++ " does not support global decls."+ then debug cfg [ "** Backend solver " <> showText backend <> " does not support global decls." , "** Some incremental calls, such as pop, will be limited." ] else sendAndGetSuccess Nothing "(set-option :global-declarations true)" -- Now dump the program!- mapM_ (sendAndGetSuccess Nothing) (mergeSExpr (lines pgm))+ mapM_ (sendAndGetSuccess Nothing) (mergeSExpr (T.lines pgm)) -- Prepare the query context and ship it off let qs = QueryState { queryAsk = ask@@ -978,80 +1080,6 @@ finalizeTranscript (transcript cfg) ec recordEndTime cfg ctx C.throwIO e)---- | Compute and report the end time-recordEndTime :: SMTConfig -> State -> IO ()-recordEndTime SMTConfig{timing} state = case timing of- NoTiming -> return ()- PrintTiming -> do e <- elapsed- putStrLn $ "*** SBV: Elapsed time: " ++ showTDiff e- SaveTiming here -> writeIORef here =<< elapsed- where elapsed = getCurrentTime >>= \end -> return $ diffUTCTime end (startTime state)---- | Start a transcript file, if requested.-startTranscript :: Maybe FilePath -> SMTConfig -> IO ()-startTranscript Nothing _ = return ()-startTranscript (Just f) cfg = do ts <- show <$> getZonedTime- mbExecPath <- findExecutable (executable (solver cfg))- writeFile f $ start ts mbExecPath- where SMTSolver{name, options} = solver cfg- start ts mbPath = unlines [ ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"- , ";;; SBV: Starting at " ++ ts- , ";;;"- , ";;; Solver : " ++ show name- , ";;; Executable: " ++ fromMaybe "Unable to locate the executable" mbPath- , ";;; Options : " ++ unwords (options cfg ++ extraArgs cfg)- , ";;;"- , ";;; This file is an auto-generated loadable SMT-Lib file."- , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"- , ""- ]---- | Finish up the transcript file.-finalizeTranscript :: Maybe FilePath -> ExitCode -> IO ()-finalizeTranscript Nothing _ = return ()-finalizeTranscript (Just f) ec = do ts <- show <$> getZonedTime- appendFile f $ end ts- where end ts = unlines [ ""- , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"- , ";;;"- , ";;; SBV: Finished at " ++ ts- , ";;;"- , ";;; Exit code: " ++ show ec- , ";;;"- , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"- ]---- If requested, record in the transcript file-recordTranscript :: Maybe FilePath -> Either (String, Maybe Int) String -> IO ()-recordTranscript Nothing _ = return ()-recordTranscript (Just f) m = do tsPre <- formatTime defaultTimeLocale "; [%T%Q" <$> getZonedTime- let ts = take 15 $ tsPre ++ repeat '0'- case m of- Left (sent, mbTimeOut) -> appendFile f $ unlines $ (ts ++ "] " ++ to mbTimeOut ++ "Sending:") : lines sent- Right recv -> appendFile f $ unlines $ case lines (dropWhile isSpace recv) of- [] -> [ts ++ "] Received: <NO RESPONSE>"] -- can't really happen.- [x] -> [ts ++ "] Received: " ++ x]- xs -> (ts ++ "] Received: ") : map ("; " ++) xs- where to Nothing = ""- to (Just i) = "[Timeout: " ++ showTimeoutValue i ++ "] "-{-# INLINE recordTranscript #-}---- Record the exception-recordException :: Maybe FilePath -> String -> IO ()-recordException Nothing _ = return ()-recordException (Just f) m = do ts <- show <$> getZonedTime- appendFile f $ exc ts- where exc ts = unlines $ [ ""- , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"- , ";;;"- , ";;; SBV: Caught an exception at " ++ ts- , ";;;"- ]- ++ [ ";;; " ++ l | l <- dropWhile null (lines m) ]- ++ [ ";;;"- , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"- ] -- We should not be catching/processing asynchronous exceptions. -- See http://github.com/LeventErkok/sbv/issues/410
Data/SBV/SMT/SMTLib.hs view
@@ -19,12 +19,11 @@ , toIncSMTLib ) where -import qualified Data.Set as Set (member, toList)- import Data.SBV.Core.Data import Data.SBV.SMT.Utils import qualified Data.SBV.SMT.SMTLib2 as SMT2+import Data.Text (Text) -- | Convert to SMT-Lib, in a full program context. toSMTLib :: SMTConfig -> SMTLibConverter SMTLibPgm@@ -32,43 +31,18 @@ SMTLib2 -> toSMTLib2 -- | Convert to SMT-Lib, in an incremental query context.-toIncSMTLib :: SMTConfig -> SMTLibIncConverter [String]+toIncSMTLib :: SMTConfig -> SMTLibIncConverter [Text] toIncSMTLib SMTConfig{smtLibVersion} = case smtLibVersion of SMTLib2 -> toIncSMTLib2- -- | Convert to SMTLib-2 format toSMTLib2 :: SMTLibConverter SMTLibPgm toSMTLib2 = cvt SMTLib2- where cvt v ctx kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out config- | KUnbounded `Set.member` kindInfo && not (supportsUnboundedInts solverCaps)- = unsupported "unbounded integers"- | KReal `Set.member` kindInfo && not (supportsReals solverCaps)- = unsupported "algebraic reals"- | (needsFloats || needsDoubles) && not (supportsIEEE754 solverCaps)- = unsupported "floating-point numbers"- | needsQuantifiers && not (supportsQuantifiers solverCaps)- = unsupported "quantifiers"- | not (null sorts) && not (supportsUninterpretedSorts solverCaps)- = unsupported "uninterpreted sorts"- | True- = SMTLibPgm v pgm- where sorts = [s | KUserSort s _ <- Set.toList kindInfo]- solverCaps = capabilities (solver config)- unsupported w = error $ unlines [ "SBV: Given problem needs " ++ w- , "*** Which is not supported by SBV for the chosen solver: " ++ show (name (solver config))- ]- converter = case v of- SMTLib2 -> SMT2.cvt- pgm = converter ctx kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out config-- needsFloats = KFloat `Set.member` kindInfo- needsDoubles = KDouble `Set.member` kindInfo- needsQuantifiers- | isSat = ALL `elem` quantifiers- | True = EX `elem` quantifiers- where quantifiers = map fst (fst qinps)+ where cvt v ctx progInfo kindInfo isSat comments qinps consts tbls uis axs asgnsSeq cstrs out config = SMTLibPgm v pgm defs+ where converter = case v of+ SMTLib2 -> SMT2.cvt+ (pgm, defs) = converter ctx progInfo kindInfo isSat comments qinps consts tbls uis axs asgnsSeq cstrs out config -- | Convert to SMTLib-2 format-toIncSMTLib2 :: SMTLibIncConverter [String]+toIncSMTLib2 :: SMTLibIncConverter [Text] toIncSMTLib2 = cvt SMTLib2 where cvt SMTLib2 = SMT2.cvtInc
Data/SBV/SMT/SMTLib2.hs view
@@ -9,1391 +9,1385 @@ -- Conversion of symbolic programs to SMTLib format, Using v2 of the standard ----------------------------------------------------------------------------- -{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.SMT.SMTLib2(cvt, cvtInc) where--import Data.Bits (bit)-import Data.List (intercalate, partition, nub, sort)-import Data.Maybe (listToMaybe, fromMaybe, catMaybes)--import qualified Data.Foldable as F (toList)-import qualified Data.Map.Strict as M-import qualified Data.IntMap.Strict as IM-import Data.Set (Set)-import qualified Data.Set as Set--import Data.SBV.Core.Data-import Data.SBV.Core.Symbolic (QueryContext(..), SetOp(..), OvOp(..), CnstMap, getUserName', getSV, regExpToSMTString)-import Data.SBV.Core.Kind (smtType, needsFlattening)-import Data.SBV.SMT.Utils-import Data.SBV.Control.Types--import Data.SBV.Utils.PrettyNum (smtRoundingMode, cvToSMTLib)--import qualified Data.Generics.Uniplate.Data as G--tbd :: String -> a-tbd e = error $ "SBV.SMTLib2: Not-yet-supported: " ++ e---- | Translate a problem into an SMTLib2 script-cvt :: SMTLibConverter [String]-cvt ctx kindInfo isSat comments (inputs, trackerVars) skolemInps (allConsts, consts) tbls arrs uis axs (SBVPgm asgnsSeq) cstrs out cfg = pgm- where hasInteger = KUnbounded `Set.member` kindInfo- hasReal = KReal `Set.member` kindInfo- hasFP = not (null [() | KFP{} <- Set.toList kindInfo])- || KFloat `Set.member` kindInfo- || KDouble `Set.member` kindInfo- hasString = KString `Set.member` kindInfo- hasRegExp = (not . null) [() | (_ :: RegExOp) <- G.universeBi asgnsSeq]- hasChar = KChar `Set.member` kindInfo- hasRounding = not $ null [s | (s, _) <- usorts, s == "RoundingMode"]- hasBVs = not (null [() | KBounded{} <- Set.toList kindInfo])- usorts = [(s, dt) | KUserSort s dt <- Set.toList kindInfo]- trueUSorts = [s | (s, _) <- usorts, s /= "RoundingMode"]- tupleArities = findTupleArities kindInfo- hasNonBVArrays = (not . null) [() | (_, (_, (k1, k2), _)) <- arrs, not (isBounded k1 && isBounded k2)]- hasArrayInits = (not . null) [() | (_, (_, _, ArrayFree (Just _))) <- arrs]- hasOverflows = (not . null) [() | (_ :: OvOp) <- G.universeBi asgnsSeq]- hasList = any isList kindInfo- hasSets = any isSet kindInfo- hasTuples = not . null $ tupleArities- hasEither = any isEither kindInfo- hasMaybe = any isMaybe kindInfo- hasRational = any isRational kindInfo- rm = roundingMode cfg- solverCaps = capabilities (solver cfg)-- -- 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]- where checks = [ ("data types", supportsDataTypes solverCaps, hasTuples || hasEither || hasMaybe)- , ("set operations", supportsSets solverCaps, hasSets)- , ("bit vectors", supportsBitVectors solverCaps, hasBVs)- ]-- nope w = [ "*** Given problem requires support for " ++ w- , "*** But the chosen solver (" ++ show (name (solver cfg)) ++ ") doesn't support this feature."- ]-- setAll reason = ["(set-logic ALL) ; " ++ reason ++ ", using catch-all."]-- -- Determining the logic is surprisingly tricky!- logic- -- user told us what to do: so just take it:- | Just l <- case [l | SetLogic l <- solverSetOptions cfg] of- [] -> Nothing- [l] -> Just l- ls -> error $ unlines [ ""- , "*** Only one setOption call to 'setLogic' is allowed, found: " ++ show (length ls)- , "*** " ++ unwords (map show ls)- ]- = case l of- Logic_NONE -> ["; NB. Not setting the logic per user request of Logic_NONE"]- _ -> ["(set-logic " ++ show l ++ ") ; NB. User specified."]-- -- There's a reason why we can't handle this problem:- | Just cantDo <- doesntHandle- = error $ unlines $ [ ""- , "*** SBV is unable to choose a proper solver configuration:"- , "***"- ]- ++ cantDo- ++ [ "***"- , "*** Please report this as a feature request, either for SBV or the backend solver."- ]-- -- Otherwise, we try to determine the most suitable logic.- -- NB. This isn't really fool proof!-- -- we never set QF_S (ALL seems to work better in all cases)-- -- Things that require ALL- | hasInteger = setAll "has unbounded values"- | hasRational = setAll "has rational values"- | hasReal = setAll "has algebraic reals"- | not (null trueUSorts) = setAll "has user-defined sorts"- | hasNonBVArrays = setAll "has non-bitvector arrays"- | hasTuples = setAll "has tuples"- | hasEither = setAll "has either type"- | hasMaybe = setAll "has maybe type"- | hasSets = setAll "has sets"- | hasList = setAll "has lists"- | hasChar = setAll "has chars"- | hasString = setAll "has strings"- | hasRegExp = setAll "has regular expressions"- | hasArrayInits = setAll "has array initializers"- | hasOverflows = setAll "has overflow checks"-- | hasFP || hasRounding- = if not (null foralls)- then ["(set-logic ALL)"]- else if hasBVs- then ["(set-logic QF_FPBV)"]- else ["(set-logic QF_FP)"]-- -- If we're in a user query context, we'll pick ALL, otherwise- -- we'll stick to some bit-vector logic based on what we see in the problem.- -- This is controversial, but seems to work well in practice.- | True- = case ctx of- QueryExternal -> ["(set-logic ALL) ; external query, using all logics."]- QueryInternal -> if supportsBitVectors solverCaps- then ["(set-logic " ++ qs ++ as ++ ufs ++ "BV)"]- else ["(set-logic ALL)"] -- fall-thru- where qs | null foralls && null axs = "QF_" -- axioms are likely to contain quantifiers- | True = ""- as | null arrs = ""- | True = "A"- ufs | null uis && null tbls = "" -- we represent tables as UFs- | True = "UF"-- -- SBV always requires the production of models!- getModels = "(set-option :produce-models true)"- : concat [flattenConfig | any needsFlattening kindInfo, Just flattenConfig <- [supportsFlattenedModels solverCaps]]-- -- process all other settings we're given. If an option cannot be repeated, we only take the last one.- userSettings = map setSMTOption $ filter (not . isLogic) $ foldr comb [] $ solverSetOptions cfg- where -- Logic is already processed, so drop it:- isLogic SetLogic{} = True- isLogic _ = False-- -- SBV sets diagnostic-output channel on some solvers. If the user also gives it, let's just- -- take it by only taking the last one- isDiagOutput DiagnosticOutputChannel{} = True- isDiagOutput _ = False-- comb o rest- | isDiagOutput o && any isDiagOutput rest = rest- | True = o : rest-- settings = userSettings -- NB. Make sure this comes first!- ++ getModels- ++ logic-- pgm = map ("; " ++) comments- ++ settings- ++ [ "; --- uninterpreted sorts ---" ]- ++ concatMap declSort usorts- ++ [ "; --- tuples ---" ]- ++ concatMap declTuple tupleArities- ++ [ "; --- sums ---" ]- ++ (if containsSum kindInfo then declSum else [])- ++ (if containsMaybe kindInfo then declMaybe else [])- ++ (if containsRationals kindInfo then declRationals else [])- ++ [ "; --- literal constants ---" ]- ++ concatMap (declConst cfg) consts- ++ [ "; --- skolem constants ---" ]- ++ concat [declareFun s (SBVType (map kindOf (ss ++ [s]))) (userName s) | Right (s, ss) <- skolemInps]- ++ [ "; --- optimization tracker variables ---" | not (null trackerVars) ]- ++ concat [declareFun s (SBVType [kindOf s]) (Just ("tracks " <> nm)) | var <- trackerVars, let s = getSV var, let nm = getUserName' var]- ++ [ "; --- constant tables ---" ]- ++ concatMap (uncurry (:) . constTable) constTables- ++ [ "; --- skolemized tables ---" ]- ++ map (skolemTable (unwords (map svType foralls))) skolemTables- ++ [ "; --- arrays ---" ]- ++ concat arrayConstants- ++ [ "; --- uninterpreted constants ---" ]- ++ concatMap declUI uis- ++ [ "; --- SBV Function definitions" | not (null funcMap) ]- ++ concat [ declSBVFunc op nm | (op, nm) <- M.toAscList funcMap ]- ++ [ "; --- user given axioms ---" ]- ++ map declAx axs- ++ [ "; --- preQuantifier assignments ---" ]- ++ concatMap (declDef cfg skolemMap tableMap funcMap) preQuantifierAssigns- ++ [ "; --- arrayDelayeds ---" ]- ++ concat arrayDelayeds- ++ [ "; --- arraySetups ---" ]- ++ concat arraySetups- ++ [ "; --- formula ---" ]- ++ ["(assert (forall (" ++ intercalate "\n "- ["(" ++ show s ++ " " ++ svType s ++ ")" | s <- foralls] ++ ")"- | not (null foralls)- ]- ++ [ "; --- postQuantifier assignments ---" ]- ++ concatMap mkAssign postQuantifierAssigns- ++ [ "; --- delayedEqualities ---" ]- ++ delayedAsserts delayedEqualities- ++ [ "; -- finalAssert ---" ]- ++ finalAssert-- -- identify the assignments that can come before the first quantifier- (preQuantifierAssigns, postQuantifierAssigns)- | null foralls- = (asgns, [])- | True- = span pre asgns- where first = nodeId (minimum foralls)- pre (s, _) = nodeId s < first-- nodeId (SV _ n) = n-- noOfCloseParens- | null foralls = 0- | True = length postQuantifierAssigns + 2 + (if null delayedEqualities then 0 else 1)-- foralls = [s | Left s <- skolemInps]- forallArgs = concatMap ((" " ++) . show) foralls-- (constTables, skolemTables) = ([(t, d) | (t, Left d) <- allTables], [(t, d) | (t, Right d) <- allTables])- allTables = [(t, genTableData rm skolemMap (not (null foralls), forallArgs) (map fst consts) t) | t <- tbls]- (arrayConstants, arrayDelayeds, arraySetups) = unzip3 $ map (declArray cfg (not (null foralls)) allConsts skolemMap) arrs- delayedEqualities = concatMap snd skolemTables-- delayedAsserts [] = []- delayedAsserts ds@(deH : deTs)- | null foralls = map (\s -> "(assert " ++ s ++ ")") ds- | True = map letShift (("(and " ++ deH) : map (align 5) deTs)-- letShift = align 12-- finalAssert- | null foralls && noConstraints- = []- | null foralls- = map (\(attr, v) -> "(assert " ++ addAnnotations attr (mkLiteral v) ++ ")") hardAsserts- ++ map (\(attr, v) -> "(assert-soft " ++ addAnnotations attr (mkLiteral v) ++ ")") softAsserts- | not (null namedAsserts)- = error $ intercalate "\n" [ "SBV: Constraints with attributes and quantifiers cannot be mixed!"- , " Quantified variables: " ++ unwords (map show foralls)- , " Named constraints : " ++ intercalate ", " (map show namedAsserts)- ]- | not (null softAsserts)- = error $ intercalate "\n" [ "SBV: Soft constraints and quantifiers cannot be mixed!"- , " Quantified variables: " ++ unwords (map show foralls)- , " Soft constraints : " ++ intercalate ", " (map show softAsserts)- ]- | True- = [impAlign (letShift combined) ++ replicate noOfCloseParens ')']- where mkLiteral (Left v) = cvtSV skolemMap v- mkLiteral (Right v) = "(not " ++ cvtSV skolemMap v ++ ")"-- (noConstraints, assertions) = finalAssertions-- namedAsserts = [findName attrs | (_, attrs, _) <- assertions, not (null attrs)]- where findName attrs = fromMaybe "<anonymous>" (listToMaybe [nm | (":named", nm) <- attrs])-- hardAsserts, softAsserts :: [([(String, String)], Either SV SV)]- hardAsserts = [(attr, v) | (False, attr, v) <- assertions]- softAsserts = [(attr, v) | (True, attr, v) <- assertions]-- combined = case lits of- [] -> "true"- [x] -> mkLiteral x- xs | any bad xs -> "false"- | True -> "(and " ++ unwords (map mkLiteral xs) ++ ")"- where lits = filter (not . redundant) $ nub (sort (map snd hardAsserts))- redundant (Left v) = v == trueSV- redundant (Right v) = v == falseSV- bad (Left v) = v == falseSV- bad (Right v) = v == trueSV-- impAlign s- | null delayedEqualities = s- | True = " " ++ s-- align n s = replicate n ' ' ++ s-- finalAssertions :: (Bool, [(Bool, [(String, String)], Either SV SV)]) -- If Left: positive, Right: negative- finalAssertions- | null finals = (True, [(False, [], Left trueSV)])- | True = (False, finals)-- where finals = cstrs' ++ maybe [] (\r -> [(False, [], r)]) mbO-- cstrs' = [(isSoft, attrs, c') | (isSoft, attrs, c) <- F.toList cstrs, Just c' <- [pos c]]-- mbO | isSat = pos out- | True = neg out-- neg s- | s == falseSV = Nothing- | s == trueSV = Just $ Left falseSV- | True = Just $ Right s-- pos s- | s == trueSV = Nothing- | s == falseSV = Just $ Left falseSV- | True = Just $ Left s-- skolemMap = M.fromList [(s, ss) | Right (s, ss) <- skolemInps, not (null ss)]- tableMap = IM.fromList $ map mkConstTable constTables ++ map mkSkTable skolemTables- where mkConstTable (((t, _, _), _), _) = (t, "table" ++ show t)- mkSkTable (((t, _, _), _), _) = (t, "table" ++ show t ++ forallArgs)-- -- SBV only functions.- funcMap = M.fromList reverses- where reverses = zip (nub [op | op@(SeqOp SBVReverse{}) <- G.universeBi asgnsSeq])- ["sbv.reverse_" ++ show i | i <- [(0::Int)..]]-- asgns = F.toList asgnsSeq-- mkAssign a- | null foralls = declDef cfg skolemMap tableMap funcMap a- | True = [letShift (mkLet a)]-- mkLet (s, SBVApp (Label m) [e]) = "(let ((" ++ show s ++ " " ++ cvtSV skolemMap e ++ ")) ; " ++ m- mkLet (s, e) = "(let ((" ++ show s ++ " " ++ cvtExp solverCaps rm skolemMap tableMap funcMap e ++ "))"-- userNameMap = M.fromList $ map ((\nSymVar -> (getSV nSymVar, getUserName' nSymVar)) . snd) inputs- userName s = case M.lookup s userNameMap of- Just u | show s /= u -> Just $ "tracks user variable " ++ show u- _ -> Nothing---- Declare "known" SBV functions here-declSBVFunc :: Op -> String -> [String]-declSBVFunc op nm = case op of- SeqOp (SBVReverse KString) -> mkStringRev- SeqOp (SBVReverse (KList k)) -> mkSeqRev (KList k)- _ -> error $ "Data.SBV.declSBVFunc: Unexpected internal function: " ++ show (op, nm)- where 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 (= lst (as seq.empty " ++ t ++ "))"- , " (as seq.empty " ++ t ++ ")"- , " (seq.++ (" ++ nm ++ " (seq.extract lst 1 (- (seq.len lst) 1))) (seq.unit (seq.nth lst 0)))))"- ]- where t = smtType k---- | Declare new sorts-declSort :: (String, Maybe [String]) -> [String]-declSort (s, _)- | s == "RoundingMode" -- built-in-sort; so don't declare.- = []-declSort (s, Nothing) = ["(declare-sort " ++ s ++ " 0) ; N.B. Uninterpreted sort." ]-declSort (s, Just fs) = [ "(declare-datatypes ((" ++ s ++ " 0)) ((" ++ unwords (map (\c -> "(" ++ c ++ ")") fs) ++ ")))"- , "(define-fun " ++ s ++ "_constrIndex ((x " ++ s ++ ")) Int"- ] ++ [" " ++ body fs (0::Int)] ++ [")"]- where body [] _ = ""- body [_] i = show i- body (c:cs) i = "(ite (= x " ++ c ++ ") " ++ show i ++ " " ++ body cs (i+1) ++ ")"---- | Declare tuple datatypes------ eg:------ @--- (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)--- ((mkSBVTuple2 (proj_1_SBVTuple2 T1)--- (proj_2_SBVTuple2 T2))))))--- @-declTuple :: Int -> [String]-declTuple arity- | arity == 0 = ["(declare-datatypes ((SBVTuple0 0)) (((mkSBVTuple0))))"]- | arity == 1 = error "Data.SBV.declTuple: Unexpected one-tuple"- | True = (l1 ++ "(par (" ++ unwords [param i | i <- [1..arity]] ++ ")")- : [pre i ++ proj i ++ post i | i <- [1..arity]]- where l1 = "(declare-datatypes ((SBVTuple" ++ show arity ++ " " ++ show arity ++ ")) ("- l2 = replicate (length l1) ' ' ++ "((mkSBVTuple" ++ show arity ++ " "- tab = replicate (length l2) ' '-- pre 1 = l2- pre _ = tab-- proj i = "(proj_" ++ show i ++ "_SBVTuple" ++ show arity ++ " " ++ param i ++ ")"-- post i = if i == arity then ")))))" else ""-- param i = "T" ++ show i---- | Find the set of tuple sizes to declare, eg (2-tuple, 5-tuple).--- NB. We do *not* need to recursively go into list/tuple kinds here,--- because register-kind function automatically registers all subcomponent--- kinds, thus everything we need is available at the top-level.-findTupleArities :: Set Kind -> [Int]-findTupleArities ks = Set.toAscList- $ Set.map length- $ Set.fromList [ tupKs | KTuple tupKs <- Set.toList ks ]---- | Is @Either@ being used?-containsSum :: Set Kind -> Bool-containsSum = not . Set.null . Set.filter isEither---- | Is @Maybe@ being used?-containsMaybe :: Set Kind -> Bool-containsMaybe = not . Set.null . Set.filter isMaybe---- | Is @Rational@ being used?-containsRationals :: Set Kind -> Bool-containsRationals = not . Set.null . Set.filter isRational--declSum :: [String]-declSum = [ "(declare-datatypes ((SBVEither 2)) ((par (T1 T2)"- , " ((left_SBVEither (get_left_SBVEither T1))"- , " (right_SBVEither (get_right_SBVEither T2))))))"- ]--declMaybe :: [String]-declMaybe = [ "(declare-datatypes ((SBVMaybe 1)) ((par (T)"- , " ((nothing_SBVMaybe)"- , " (just_SBVMaybe (get_just_SBVMaybe T))))))"- ]---- Internally, we do *not* keep the rationals in reduced form! So, the boolean operators explicitly do the math--- to make sure equivalent values are treated correctly.-declRationals :: [String]-declRationals = [ "(declare-datatype SBVRational ((SBV.Rational (sbv.rat.numerator Int) (sbv.rat.denominator Int))))"- , ""- , "(define-fun sbv.rat.eq ((x SBVRational) (y SBVRational)) Bool"- , " (= (* (sbv.rat.numerator x) (sbv.rat.denominator y))"- , " (* (sbv.rat.denominator x) (sbv.rat.numerator y)))"- , ")"- , ""- , "(define-fun sbv.rat.notEq ((x SBVRational) (y SBVRational)) Bool"- , " (not (sbv.rat.eq x y))"- , ")"- , ""- , "(define-fun sbv.rat.lt ((x SBVRational) (y SBVRational)) Bool"- , " (< (* (sbv.rat.numerator x) (sbv.rat.denominator y))"- , " (* (sbv.rat.denominator x) (sbv.rat.numerator y)))"- , ")"- , ""- , "(define-fun sbv.rat.leq ((x SBVRational) (y SBVRational)) Bool"- , " (<= (* (sbv.rat.numerator x) (sbv.rat.denominator y))"- , " (* (sbv.rat.denominator x) (sbv.rat.numerator y)))"- , ")"- , ""- , "(define-fun sbv.rat.plus ((x SBVRational) (y SBVRational)) SBVRational"- , " (SBV.Rational (+ (* (sbv.rat.numerator x) (sbv.rat.denominator y))"- , " (* (sbv.rat.denominator x) (sbv.rat.numerator y)))"- , " (* (sbv.rat.denominator x) (sbv.rat.denominator y)))"- , ")"- , ""- , "(define-fun sbv.rat.minus ((x SBVRational) (y SBVRational)) SBVRational"- , " (SBV.Rational (- (* (sbv.rat.numerator x) (sbv.rat.denominator y))"- , " (* (sbv.rat.denominator x) (sbv.rat.numerator y)))"- , " (* (sbv.rat.denominator x) (sbv.rat.denominator y)))"- , ")"- , ""- , "(define-fun sbv.rat.times ((x SBVRational) (y SBVRational)) SBVRational"- , " (SBV.Rational (* (sbv.rat.numerator x) (sbv.rat.numerator y))"- , " (* (sbv.rat.denominator x) (sbv.rat.denominator y)))"- , ")"- , ""- , "(define-fun sbv.rat.uneg ((x SBVRational)) SBVRational"- , " (SBV.Rational (* (- 1) (sbv.rat.numerator x)) (sbv.rat.denominator x))"- , ")"- , ""- , "(define-fun sbv.rat.abs ((x SBVRational)) SBVRational"- , " (SBV.Rational (abs (sbv.rat.numerator x)) (sbv.rat.denominator x))"- , ")"- ]---- | Convert in a query context.--- NB. We do not store everything in @newKs@ below, but only what we need--- to do as an extra in the incremental context. See `Data.SBV.Core.Symbolic.registerKind`--- for a list of what we include, in case something doesn't show up--- and you need it!-cvtInc :: SMTLibIncConverter [String]-cvtInc inps newKs (allConsts, consts) arrs tbls uis (SBVPgm asgnsSeq) cstrs cfg =- -- any new settings?- settings- -- sorts- ++ concatMap declSort [(s, dt) | KUserSort s dt <- newKinds]- -- tuples. NB. Only declare the new sizes, old sizes persist.- ++ concatMap declTuple (findTupleArities newKs)- -- sums- ++ (if containsSum newKs then declSum else [])- ++ (if containsMaybe newKs then declMaybe else [])- -- constants- ++ concatMap (declConst cfg) consts- -- inputs- ++ concatMap declInp inps- -- arrays- ++ concat arrayConstants- -- uninterpreteds- ++ concatMap declUI uis- -- table declarations- ++ tableDecls- -- expressions- ++ concatMap (declDef cfg skolemMap tableMap funcMap) (F.toList asgnsSeq)- -- delayed equalities- ++ concat arrayDelayeds- -- table setups- ++ concat tableAssigns- -- array setups- ++ concat arraySetups- -- extra constraints- ++ map (\(isSoft, attr, v) -> "(assert" ++ (if isSoft then "-soft " else " ") ++ addAnnotations attr (cvtSV skolemMap v) ++ ")") (F.toList cstrs)- where -- NB. The below setting of skolemMap to empty is OK, since we do- -- not support queries in the context of skolemized variables- skolemMap = M.empty-- -- The following is not really kosher; if it happens that a "new" variant of a function is used only incrementally.- -- But we'll punt on this for now, as it should be rare and can be "worked-around" if necessary.- funcMap = M.empty-- rm = roundingMode cfg-- newKinds = Set.toList newKs-- declInp (getSV -> s) = declareFun s (SBVType [kindOf s]) Nothing-- (arrayConstants, arrayDelayeds, arraySetups) = unzip3 $ map (declArray cfg False allConsts skolemMap) arrs-- allTables = [(t, either id id (genTableData rm skolemMap (False, []) (map fst consts) t)) | t <- tbls]- (tableDecls, tableAssigns) = unzip $ map constTable allTables-- tableMap = IM.fromList $ map mkTable allTables- where mkTable (((t, _, _), _), _) = (t, "table" ++ show t)-- -- If we need flattening in models, do emit the required lines if preset- settings- | any needsFlattening newKinds- = concat (catMaybes [supportsFlattenedModels solverCaps])- | True- = []- where solverCaps = capabilities (solver cfg)--declDef :: SMTConfig -> SkolemMap -> TableMap -> FunctionMap -> (SV, SBVExpr) -> [String]-declDef cfg skolemMap tableMap funcMap (s, expr) =- case expr of- SBVApp (Label m) [e] -> defineFun cfg (s, cvtSV skolemMap e) (Just m)- e -> defineFun cfg (s, cvtExp caps rm skolemMap tableMap funcMap e) Nothing- where caps = capabilities (solver cfg)- rm = roundingMode cfg--defineFun :: SMTConfig -> (SV, String) -> Maybe String -> [String]-defineFun cfg (s, def) mbComment- | hasDefFun = ["(define-fun " ++ varT ++ " " ++ def ++ ")" ++ cmnt]- | True = [ "(declare-fun " ++ varT ++ ")" ++ cmnt- , "(assert (= " ++ var ++ " " ++ def ++ "))"- ]- where var = show s- varT = var ++ " " ++ svFunType [] s- cmnt = maybe "" (" ; " ++) mbComment-- hasDefFun = supportsDefineFun $ capabilities (solver cfg)---- Declare constants. NB. We don't declare true/false; but just inline those as necessary-declConst :: SMTConfig -> (SV, CV) -> [String]-declConst cfg (s, c)- | s == falseSV || s == trueSV- = []- | True- = defineFun cfg (s, cvtCV (roundingMode cfg) c) Nothing--declUI :: (String, SBVType) -> [String]-declUI (i, t) = declareName i t Nothing---- NB. We perform no check to as to whether the axiom is meaningful in any way.-declAx :: (Bool, String, [String]) -> String-declAx (hasDefinition, nm, ls) = (";; -- user given " ++ what ++ ": " ++ nm ++ "\n") ++ intercalate "\n" ls- where what | hasDefinition = "definition"- | True = "axiom"--constTable :: (((Int, Kind, Kind), [SV]), [String]) -> (String, [String])-constTable (((i, ak, rk), _elts), is) = (decl, zipWith wrap [(0::Int)..] is ++ setup)- where t = "table" ++ show i- decl = "(declare-fun " ++ t ++ " (" ++ smtType ak ++ ") " ++ smtType rk ++ ")"-- -- Arrange for initializers- mkInit idx = "table" ++ show i ++ "_initializer_" ++ show (idx :: Int)- initializer = "table" ++ show i ++ "_initializer"-- wrap index s = "(define-fun " ++ mkInit index ++ " () Bool " ++ s ++ ")"-- lis = length is-- setup- | lis == 0 = [ "(define-fun " ++ initializer ++ " () Bool true) ; no initialization needed"- ]- | lis == 1 = [ "(define-fun " ++ initializer ++ " () Bool " ++ mkInit 0 ++ ")"- , "(assert " ++ initializer ++ ")"- ]- | True = [ "(define-fun " ++ initializer ++ " () Bool (and " ++ unwords (map mkInit [0..lis - 1]) ++ "))"- , "(assert " ++ initializer ++ ")"- ]--skolemTable :: String -> (((Int, Kind, Kind), [SV]), [String]) -> String-skolemTable qsIn (((i, ak, rk), _elts), _) = decl- where qs = if null qsIn then "" else qsIn ++ " "- t = "table" ++ show i- decl = "(declare-fun " ++ t ++ " (" ++ qs ++ smtType ak ++ ") " ++ smtType rk ++ ")"---- Left if all constants, Right if otherwise-genTableData :: RoundingMode -> SkolemMap -> (Bool, String) -> [SV] -> ((Int, Kind, Kind), [SV]) -> Either [String] [String]-genTableData rm skolemMap (_quantified, args) consts ((i, aknd, _), elts)- | null post = Left (map (topLevel . snd) pre)- | True = Right (map (nested . snd) (pre ++ post))- where ssv = cvtSV skolemMap- (pre, post) = partition fst (zipWith mkElt elts [(0::Int)..])- t = "table" ++ show i-- mkElt x k = (isReady, (idx, ssv x))- where idx = cvtCV rm (mkConstCV aknd k)- isReady = x `Set.member` constsSet-- topLevel (idx, v) = "(= (" ++ t ++ " " ++ idx ++ ") " ++ v ++ ")"- nested (idx, v) = "(= (" ++ t ++ args ++ " " ++ idx ++ ") " ++ v ++ ")"-- constsSet = Set.fromList consts---- TODO: We currently do not support non-constant arrays when quantifiers are present, as--- we might have to skolemize those. Implement this properly.--- The difficulty is with the Mutate/Merge: We have to postpone an init if--- the components are themselves postponed, so this cannot be implemented as a simple map.-declArray :: SMTConfig -> Bool -> CnstMap -> SkolemMap -> (Int, ArrayInfo) -> ([String], [String], [String])-declArray cfg quantified consts skolemMap (i, (_, (aKnd, bKnd), ctx)) = (adecl : zipWith wrap [(0::Int)..] (map snd pre), zipWith wrap [lpre..] (map snd post), setup)- where constMapping = M.fromList [(s, c) | (c, s) <- M.assocs consts]- constNames = M.keys constMapping-- topLevel = not quantified || case ctx of- ArrayFree mbi -> maybe True (`elem` constNames) mbi- ArrayMutate _ a b -> all (`elem` constNames) [a, b]- ArrayMerge c _ _ -> c `elem` constNames- (pre, post) = partition fst ctxInfo- nm = "array_" ++ show i-- ssv sv- | topLevel || sv `elem` constNames- = cvtSV skolemMap sv- | True- = tbd "Non-constant array initializer in a quantified context"-- atyp = "(Array " ++ smtType aKnd ++ " " ++ smtType bKnd ++ ")"-- adecl = case ctx of- ArrayFree (Just v) -> "(define-fun " ++ nm ++ " () " ++ atyp ++ " ((as const " ++ atyp ++ ") " ++ constInit v ++ "))"- ArrayFree Nothing- | bKnd == KChar -> -- Can't support yet, because we need to make sure all the elements are length-1 strings. So, punt for now.- tbd "Free array declarations containing SChars"- _ -> "(declare-fun " ++ nm ++ " () " ++ atyp ++ ")"-- -- CVC4 chokes if the initializer is not a constant. (Z3 is ok with it.) So, print it as- -- a constant if we have it in the constants; otherwise, we merely print it and hope for the best.- constInit v = case v `M.lookup` constMapping of- Nothing -> ssv v -- Z3 will work, CVC4 will choke. Others don't even support this.- Just c -> cvtCV (roundingMode cfg) c -- Z3 and CVC4 will work. Other's don't support this.-- ctxInfo = case ctx of- ArrayFree _ -> []- ArrayMutate j a b -> [(all (`elem` constNames) [a, b], "(= " ++ nm ++ " (store array_" ++ show j ++ " " ++ ssv a ++ " " ++ ssv b ++ "))")]- ArrayMerge t j k -> [(t `elem` constNames, "(= " ++ nm ++ " (ite " ++ ssv t ++ " array_" ++ show j ++ " array_" ++ show k ++ "))")]-- -- Arrange for initializers- mkInit idx = "array_" ++ show i ++ "_initializer_" ++ show (idx :: Int)- initializer = "array_" ++ show i ++ "_initializer"-- wrap index s = "(define-fun " ++ mkInit index ++ " () Bool " ++ s ++ ")"-- lpre = length pre- lAll = lpre + length post-- setup- | lAll == 0 = [ "(define-fun " ++ initializer ++ " () Bool true) ; no initialization needed" | not quantified]- | lAll == 1 = [ "(define-fun " ++ initializer ++ " () Bool " ++ mkInit 0 ++ ")"- , "(assert " ++ initializer ++ ")"- ]- | True = [ "(define-fun " ++ initializer ++ " () Bool (and " ++ unwords (map mkInit [0..lAll - 1]) ++ "))"- , "(assert " ++ initializer ++ ")"- ]--svType :: SV -> String-svType s = smtType (kindOf s)--svFunType :: [SV] -> SV -> String-svFunType ss s = "(" ++ unwords (map svType ss) ++ ") " ++ svType s--cvtType :: SBVType -> String-cvtType (SBVType []) = error "SBV.SMT.SMTLib2.cvtType: internal: received an empty type!"-cvtType (SBVType xs) = "(" ++ unwords (map smtType body) ++ ") " ++ smtType ret- where (body, ret) = (init xs, last xs)--type SkolemMap = M.Map SV [SV]-type TableMap = IM.IntMap String-type FunctionMap = M.Map Op String---- Present an SV; inline true/false as needed-cvtSV :: SkolemMap -> SV -> String-cvtSV skolemMap s@(SV _ (NodeId n))- | Just ss <- s `M.lookup` skolemMap- = "(" ++ show s ++ concatMap ((" " ++) . show) ss ++ ")"- | s == trueSV- = "true"- | s == falseSV- = "false"- | True- = 's' : show n--cvtCV :: RoundingMode -> CV -> String-cvtCV = cvToSMTLib--getTable :: TableMap -> Int -> String-getTable m i- | Just tn <- i `IM.lookup` m = tn- | True = "table" ++ show i -- constant tables are always named this way--cvtExp :: SolverCapabilities -> RoundingMode -> SkolemMap -> TableMap -> FunctionMap -> SBVExpr -> String-cvtExp caps rm skolemMap tableMap functionMap expr@(SBVApp _ arguments) = sh expr- where ssv = cvtSV skolemMap-- hasPB = supportsPseudoBooleans caps- hasInt2bv = supportsInt2bv caps- hasDistinct = supportsDistinct caps-- bvOp = all isBounded arguments- intOp = any isUnbounded arguments- ratOp = any isRational arguments- realOp = any isReal arguments- fpOp = any (\a -> isDouble a || isFloat a || isFP a) arguments- boolOp = all isBoolean arguments- charOp = any isChar arguments- stringOp = any isString arguments- listOp = any isList arguments-- bad | intOp = error $ "SBV.SMTLib2: Unsupported operation on unbounded integers: " ++ show expr- | True = error $ "SBV.SMTLib2: Unsupported operation on real values: " ++ show expr-- ensureBVOrBool = bvOp || boolOp || bad- ensureBV = bvOp || bad-- addRM s = s ++ " " ++ smtRoundingMode rm-- -- lift a binary op- lift2 o _ [x, y] = "(" ++ o ++ " " ++ x ++ " " ++ y ++ ")"- lift2 o _ sbvs = error $ "SBV.SMTLib2.sh.lift2: Unexpected arguments: " ++ show (o, sbvs)-- -- lift an arbitrary arity operator- liftN o _ xs = "(" ++ o ++ " " ++ unwords xs ++ ")"-- -- lift a binary operation with rounding-mode added; used for floating-point arithmetic- lift2WM o fo | fpOp = lift2 (addRM fo)- | True = lift2 o-- lift1FP o fo | fpOp = lift1 fo- | True = lift1 o-- liftAbs sgned args | fpOp = lift1 "fp.abs" sgned args- | intOp = lift1 "abs" sgned args- | bvOp, sgned = mkAbs (head args) "bvslt" "bvneg"- | bvOp = head args- | True = mkAbs (head args) "<" "-"- where mkAbs x cmp neg = "(ite " ++ ltz ++ " " ++ nx ++ " " ++ x ++ ")"- where ltz = "(" ++ cmp ++ " " ++ x ++ " " ++ z ++ ")"- nx = "(" ++ neg ++ " " ++ x ++ ")"- z = cvtCV rm (mkConstCV (kindOf (head arguments)) (0::Integer))-- lift2B bOp vOp- | boolOp = lift2 bOp- | True = lift2 vOp-- lift1B bOp vOp- | boolOp = lift1 bOp- | True = lift1 vOp-- eqBV = lift2 "="- neqBV = liftN "distinct"-- equal sgn sbvs- | fpOp = lift2 "fp.eq" sgn sbvs- | True = lift2 "=" sgn sbvs-- -- Do not use distinct on floats; because +0/-0, and NaNs mess- -- up the meaning. Just go with reqular equals.- notEqual sgn sbvs- | fpOp || not hasDistinct = liftP sbvs- | True = liftN "distinct" sgn sbvs- where liftP xs@[_, _] = "(not " ++ equal sgn xs ++ ")"- liftP args = "(and " ++ unwords (walk args) ++ ")"-- walk [] = []- walk (e:es) = map (\e' -> liftP [e, e']) es ++ walk es-- lift2S oU oS sgn = lift2 (if sgn then oS else oU) sgn- liftNS oU oS sgn = liftN (if sgn then oS else oU) sgn-- lift2Cmp o fo | fpOp = lift2 fo- | True = lift2 o-- unintComp o [a, b]- | KUserSort s (Just _) <- kindOf (head arguments)- = let idx v = "(" ++ s ++ "_constrIndex " ++ v ++ ")" in "(" ++ o ++ " " ++ idx a ++ " " ++ idx b ++ ")"- unintComp o sbvs = error $ "SBV.SMT.SMTLib2.sh.unintComp: Unexpected arguments: " ++ show (o, sbvs, map kindOf arguments)-- stringOrChar KString = True- stringOrChar KChar = True- stringOrChar _ = False- stringCmp swap o [a, b]- | stringOrChar (kindOf (head arguments))- = let (a1, a2) | swap = (b, a)- | True = (a, b)- in "(" ++ o ++ " " ++ a1 ++ " " ++ a2 ++ ")"- stringCmp _ o sbvs = error $ "SBV.SMT.SMTLib2.sh.stringCmp: Unexpected arguments: " ++ show (o, sbvs)-- -- NB. Likewise for sequences- seqCmp swap o [a, b]- | KList{} <- kindOf (head arguments)- = let (a1, a2) | swap = (b, a)- | True = (a, b)- in "(" ++ o ++ " " ++ a1 ++ " " ++ a2 ++ ")"- seqCmp _ o sbvs = error $ "SBV.SMT.SMTLib2.sh.seqCmp: Unexpected arguments: " ++ show (o, sbvs)-- lift1 o _ [x] = "(" ++ o ++ " " ++ x ++ ")"- lift1 o _ sbvs = error $ "SBV.SMT.SMTLib2.sh.lift1: Unexpected arguments: " ++ show (o, sbvs)-- -- We fully qualify the constructor with their types to work around type checking issues- -- Note that this is rather bizarre, as we're tagging the constructor with its *result* type,- -- not its full function type as one would expect. But this is per the spec: Pg. 27 of SMTLib 2.6 spec- -- says:- --- -- To simplify sort checking, a function symbol in a term can be annotated with one of its result sorts sigma.- --- -- I wish it was the full type here not just the result, but we go with the spec. Also see: <http://github.com/Z3Prover/z3/issues/2135>- -- and in particular <http://github.com/Z3Prover/z3/issues/2135#issuecomment-477636435>- dtConstructor fld args res = "((as " ++ fld ++ " " ++ smtType res ++ ") " ++ unwords (map ssv args) ++ ")"-- -- Similarly, we fully qualify the accessors with their types to work around type checking issues- -- Unfortunately, z3 and CVC4 are behaving differently, so we tie this ascription to a solver capability.- dtAccessor fld params res- | supportsDirectAccessors caps = dResult- | True = aResult- where dResult = "(_ is " ++ fld ++ ")"- ps = " (" ++ unwords (map smtType params) ++ ") "- aResult = "(_ is (" ++ fld ++ ps ++ smtType res ++ "))"-- sh (SBVApp Ite [a, b, c]) = "(ite " ++ ssv a ++ " " ++ ssv b ++ " " ++ ssv c ++ ")"-- sh (SBVApp (LkUp (t, aKnd, _, l) i e) [])- | needsCheck = "(ite " ++ cond ++ ssv e ++ " " ++ lkUp ++ ")"- | True = lkUp- where needsCheck = case aKnd of- KBool -> (2::Integer) > fromIntegral l- KBounded _ n -> (2::Integer)^n > fromIntegral l- KUnbounded -> True- KReal -> error "SBV.SMT.SMTLib2.cvtExp: unexpected real valued index"- KFloat -> error "SBV.SMT.SMTLib2.cvtExp: unexpected float valued index"- KDouble -> error "SBV.SMT.SMTLib2.cvtExp: unexpected double valued index"- KFP{} -> error "SBV.SMT.SMTLib2.cvtExp: unexpected arbitrary float valued index"- KRational{} -> error "SBV.SMT.SMTLib2.cvtExp: unexpected rational valued index"- KChar -> error "SBV.SMT.SMTLib2.cvtExp: unexpected char valued index"- KString -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"- KList k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected list valued: " ++ show k- KSet k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected set valued: " ++ show k- KTuple k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected tuple valued: " ++ show k- KMaybe k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected maybe valued: " ++ show k- KEither k1 k2 -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sum valued: " ++ show (k1, k2)- KUserSort s _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s-- lkUp = "(" ++ getTable tableMap t ++ " " ++ ssv i ++ ")"-- cond- | hasSign i = "(or " ++ le0 ++ " " ++ gtl ++ ") "- | True = gtl ++ " "-- (less, leq) = case aKnd of- KBool -> error "SBV.SMT.SMTLib2.cvtExp: unexpected boolean valued index"- KBounded{} -> if hasSign i then ("bvslt", "bvsle") else ("bvult", "bvule")- KUnbounded -> ("<", "<=")- KReal -> ("<", "<=")- KFloat -> ("fp.lt", "fp.leq")- KDouble -> ("fp.lt", "fp.leq")- KRational -> ("sbv.rat.lt", "sbv.rat.leq")- KFP{} -> ("fp.lt", "fp.leq")- KChar -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"- KString -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"- KList k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sequence valued index: " ++ show k- KSet k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected set valued index: " ++ show k- KTuple k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected tuple valued index: " ++ show k- KMaybe k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected maybe valued index: " ++ show k- KEither k1 k2 -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sum valued index: " ++ show (k1, k2)- KUserSort s _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s-- mkCnst = cvtCV rm . mkConstCV (kindOf i)- le0 = "(" ++ less ++ " " ++ ssv i ++ " " ++ mkCnst 0 ++ ")"- gtl = "(" ++ leq ++ " " ++ mkCnst l ++ " " ++ ssv i ++ ")"-- sh (SBVApp (KindCast f t) [a]) = handleKindCast hasInt2bv f t (ssv a)-- sh (SBVApp (ArrEq i j) []) = "(= array_" ++ show i ++ " array_" ++ show j ++")"- sh (SBVApp (ArrRead i) [a]) = "(select array_" ++ show i ++ " " ++ ssv a ++ ")"-- sh (SBVApp (Uninterpreted nm) []) = nm- sh (SBVApp (Uninterpreted nm) args) = "(" ++ nm ++ " " ++ unwords (map ssv args) ++ ")"-- sh (SBVApp (Extract i j) [a]) | ensureBV = "((_ extract " ++ show i ++ " " ++ show j ++ ") " ++ ssv a ++ ")"-- sh (SBVApp (Rol i) [a])- | bvOp = rot ssv "rotate_left" i a- | True = bad-- sh (SBVApp (Ror i) [a])- | bvOp = rot ssv "rotate_right" i a- | True = bad-- sh (SBVApp Shl [a, i])- | bvOp = shft ssv "bvshl" "bvshl" a i- | True = bad-- sh (SBVApp Shr [a, i])- | bvOp = shft ssv "bvlshr" "bvashr" a i- | True = bad-- sh (SBVApp (ZeroExtend i) [a])- | bvOp = "((_ zero_extend " ++ show i ++ ") " ++ ssv a ++ ")"- | True = bad-- sh (SBVApp (SignExtend i) [a])- | bvOp = "((_ sign_extend " ++ show i ++ ") " ++ ssv a ++ ")"- | True = bad-- sh (SBVApp op args)- | Just f <- lookup op smtBVOpTable, ensureBVOrBool- = f (any hasSign args) (map ssv args)- where -- The first 4 operators below do make sense for Integer's in Haskell, but there's- -- no obvious counterpart for them in the SMTLib translation.- -- TODO: provide support for these.- smtBVOpTable = [ (And, lift2B "and" "bvand")- , (Or, lift2B "or" "bvor")- , (XOr, lift2B "xor" "bvxor")- , (Not, lift1B "not" "bvnot")- , (Join, lift2 "concat")- ]-- sh (SBVApp (Label _) [a]) = cvtSV skolemMap a -- This won't be reached; but just in case!-- sh (SBVApp (IEEEFP (FP_Cast kFrom kTo m)) args) = handleFPCast kFrom kTo (ssv m) (unwords (map ssv args))- sh (SBVApp (IEEEFP w ) args) = "(" ++ show w ++ " " ++ unwords (map ssv args) ++ ")"-- sh (SBVApp (NonLinear w) args) = "(" ++ show w ++ " " ++ unwords (map ssv args) ++ ")"-- sh (SBVApp (PseudoBoolean pb) args)- | hasPB = handlePB pb args'- | True = reducePB pb args'- where args' = map ssv args-- -- NB: Z3 semantics have the predicates reversed: i.e., it returns true if overflow isn't possible. Hence the not.- sh (SBVApp (OverflowOp op) args) = "(not (" ++ show op ++ " " ++ unwords (map ssv args) ++ "))"-- -- Note the unfortunate reversal in StrInRe..- sh (SBVApp (StrOp (StrInRe r)) args) = "(str.in.re " ++ unwords (map ssv args) ++ " " ++ regExpToSMTString r ++ ")"- -- StrUnit is no-op, since a character in SMTLib is the same as a string- sh (SBVApp (StrOp StrUnit) [a]) = ssv a- sh (SBVApp (StrOp op) args) = "(" ++ show op ++ " " ++ unwords (map ssv args) ++ ")"-- sh (SBVApp (RegExOp o@RegExEq{}) []) = show o- sh (SBVApp (RegExOp o@RegExNEq{}) []) = show o-- -- Reverse is special, since we need to generate call to the internally generated function- sh inp@(SBVApp op@(SeqOp SBVReverse{}) args) = "(" ++ ops ++ " " ++ unwords (map ssv args) ++ ")"- where ops = case op `M.lookup` functionMap of- Just s -> s- Nothing -> error $ "SBV.SMT.SMTLib2.cvtExp.sh: impossible happened; can't translate: " ++ show inp-- sh (SBVApp (SeqOp op) args) = "(" ++ show op ++ " " ++ unwords (map ssv args) ++ ")"-- sh (SBVApp (SetOp SetEqual) args) = "(= " ++ unwords (map ssv args) ++ ")"- sh (SBVApp (SetOp SetMember) [e, s]) = "(select " ++ ssv s ++ " " ++ ssv e ++ ")"- sh (SBVApp (SetOp SetInsert) [e, s]) = "(store " ++ ssv s ++ " " ++ ssv e ++ " true)"- sh (SBVApp (SetOp SetDelete) [e, s]) = "(store " ++ ssv s ++ " " ++ ssv e ++ " false)"- sh (SBVApp (SetOp SetIntersect) args) = "(intersection " ++ unwords (map ssv args) ++ ")"- sh (SBVApp (SetOp SetUnion) args) = "(union " ++ unwords (map ssv args) ++ ")"- sh (SBVApp (SetOp SetSubset) args) = "(subset " ++ unwords (map ssv args) ++ ")"- sh (SBVApp (SetOp SetDifference) args) = "(setminus " ++ unwords (map ssv args) ++ ")"- sh (SBVApp (SetOp SetComplement) args) = "(complement " ++ unwords (map ssv args) ++ ")"- sh (SBVApp (SetOp SetHasSize) args) = "(set-has-size " ++ unwords (map ssv args) ++ ")"-- sh (SBVApp (TupleConstructor 0) []) = "mkSBVTuple0"- sh (SBVApp (TupleConstructor n) args) = "((as mkSBVTuple" ++ show n ++ " " ++ smtType (KTuple (map kindOf args)) ++ ") " ++ unwords (map ssv args) ++ ")"- sh (SBVApp (TupleAccess i n) [tup]) = "(proj_" ++ show i ++ "_SBVTuple" ++ show n ++ " " ++ ssv tup ++ ")"-- sh (SBVApp (EitherConstructor k1 k2 False) [arg]) = dtConstructor "left_SBVEither" [arg] (KEither k1 k2)- sh (SBVApp (EitherConstructor k1 k2 True ) [arg]) = dtConstructor "right_SBVEither" [arg] (KEither k1 k2)- sh (SBVApp (EitherIs k1 k2 False) [arg]) = '(' : dtAccessor "left_SBVEither" [k1] (KEither k1 k2) ++ " " ++ ssv arg ++ ")"- sh (SBVApp (EitherIs k1 k2 True ) [arg]) = '(' : dtAccessor "right_SBVEither" [k2] (KEither k1 k2) ++ " " ++ ssv arg ++ ")"- sh (SBVApp (EitherAccess False) [arg]) = "(get_left_SBVEither " ++ ssv arg ++ ")"- sh (SBVApp (EitherAccess True ) [arg]) = "(get_right_SBVEither " ++ ssv arg ++ ")"-- sh (SBVApp RationalConstructor [t, b]) = "(SBV.Rational " ++ ssv t ++ " " ++ ssv b ++ ")"-- sh (SBVApp (MaybeConstructor k False) []) = dtConstructor "nothing_SBVMaybe" [] (KMaybe k)- sh (SBVApp (MaybeConstructor k True) [arg]) = dtConstructor "just_SBVMaybe" [arg] (KMaybe k)- sh (SBVApp (MaybeIs k False) [arg]) = '(' : dtAccessor "nothing_SBVMaybe" [] (KMaybe k) ++ " " ++ ssv arg ++ ")"- sh (SBVApp (MaybeIs k True ) [arg]) = '(' : dtAccessor "just_SBVMaybe" [k] (KMaybe k) ++ " " ++ ssv arg ++ ")"- sh (SBVApp MaybeAccess [arg]) = "(get_just_SBVMaybe " ++ ssv arg ++ ")"-- sh inp@(SBVApp op args)- | intOp, Just f <- lookup op smtOpIntTable- = f True (map ssv args)- | boolOp, Just f <- lookup op boolComps- = f (map ssv args)- | bvOp, Just f <- lookup op smtOpBVTable- = f (any hasSign args) (map ssv args)- | realOp, Just f <- lookup op smtOpRealTable- = f (any hasSign args) (map ssv args)- | ratOp, Just f <- lookup op ratOpTable- = f (map ssv args)- | fpOp, Just f <- lookup op smtOpFloatDoubleTable- = f (any hasSign args) (map ssv args)- | charOp || stringOp, Just f <- lookup op smtStringTable- = f (map ssv args)- | listOp, Just f <- lookup op smtListTable- = f (map ssv args)- | Just f <- lookup op uninterpretedTable- = f (map ssv args)- | True- = if not (null args) && isUserSort (head args)- then error $ unlines [ ""- , "*** Cannot translate operator : " ++ show op- , "*** When applied to arguments of kind: " ++ intercalate ", " (nub (map (show . kindOf) args))- , "*** Found as part of the expression : " ++ show inp- , "***"- , "*** Note that uninterpreted kinds only support equality."- , "*** If you believe this is in error, please report!"- ]- else error $ "SBV.SMT.SMTLib2.cvtExp.sh: impossible happened; can't translate: " ++ show inp- where smtOpBVTable = [ (Plus, lift2 "bvadd")- , (Minus, lift2 "bvsub")- , (Times, lift2 "bvmul")- , (UNeg, lift1B "not" "bvneg")- , (Abs, liftAbs)- , (Quot, lift2S "bvudiv" "bvsdiv")- , (Rem, lift2S "bvurem" "bvsrem")- , (Equal, eqBV)- , (NotEqual, neqBV)- , (LessThan, lift2S "bvult" "bvslt")- , (GreaterThan, lift2S "bvugt" "bvsgt")- , (LessEq, lift2S "bvule" "bvsle")- , (GreaterEq, lift2S "bvuge" "bvsge")- ]-- -- Boolean comparisons.. SMTLib's bool type doesn't do comparisons, but Haskell does.. Sigh- boolComps = [ (LessThan, blt)- , (GreaterThan, blt . swp)- , (LessEq, blq)- , (GreaterEq, blq . swp)- ]- where blt [x, y] = "(and (not " ++ x ++ ") " ++ y ++ ")"- blt xs = error $ "SBV.SMT.SMTLib2.boolComps.blt: Impossible happened, incorrect arity (expected 2): " ++ show xs- blq [x, y] = "(or (not " ++ x ++ ") " ++ y ++ ")"- blq xs = error $ "SBV.SMT.SMTLib2.boolComps.blq: Impossible happened, incorrect arity (expected 2): " ++ show xs- swp [x, y] = [y, x]- swp xs = error $ "SBV.SMT.SMTLib2.boolComps.swp: Impossible happened, incorrect arity (expected 2): " ++ show xs-- smtOpRealTable = smtIntRealShared- ++ [ (Quot, lift2WM "/" "fp.div")- ]-- smtOpIntTable = smtIntRealShared- ++ [ (Quot, lift2 "div")- , (Rem, lift2 "mod")- ]-- smtOpFloatDoubleTable = smtIntRealShared- ++ [(Quot, lift2WM "/" "fp.div")]-- smtIntRealShared = [ (Plus, lift2WM "+" "fp.add")- , (Minus, lift2WM "-" "fp.sub")- , (Times, lift2WM "*" "fp.mul")- , (UNeg, lift1FP "-" "fp.neg")- , (Abs, liftAbs)- , (Equal, equal)- , (NotEqual, notEqual)- , (LessThan, lift2Cmp "<" "fp.lt")- , (GreaterThan, lift2Cmp ">" "fp.gt")- , (LessEq, lift2Cmp "<=" "fp.leq")- , (GreaterEq, lift2Cmp ">=" "fp.geq")- ]-- ratOpTable = [ (Plus, lift2Rat "sbv.rat.plus")- , (Minus, lift2Rat "sbv.rat.minus")- , (Times, lift2Rat "sbv.rat.times")- , (UNeg, liftRat "sbv.rat.uneg")- , (Abs, liftRat "sbv.rat.abs")- , (Equal, lift2Rat "sbv.rat.eq")- , (NotEqual, lift2Rat "sbv.rat.notEq")- , (LessThan, lift2Rat "sbv.rat.lt")- , (GreaterThan, lift2Rat "sbv.rat.lt" . swap)- , (LessEq, lift2Rat "sbv.rat.leq")- , (GreaterEq, lift2Rat "sbv.rat.leq" . swap)- ]- where lift2Rat o [x, y] = "(" ++ o ++ " " ++ x ++ " " ++ y ++ ")"- lift2Rat o sbvs = error $ "SBV.SMTLib2.sh.lift2Rat: Unexpected arguments: " ++ show (o, sbvs)- liftRat o [x] = "(" ++ o ++ " " ++ x ++ ")"- liftRat o sbvs = error $ "SBV.SMTLib2.sh.lift2Rat: Unexpected arguments: " ++ show (o, sbvs)- swap [x, y] = [y, x]- swap sbvs = error $ "SBV.SMTLib2.sh.swap: Unexpected arguments: " ++ show sbvs-- -- equality and comparisons are the only thing that works on uninterpreted sorts and pretty much everything else- uninterpretedTable = [ (Equal, lift2S "=" "=" True)- , (NotEqual, liftNS "distinct" "distinct" True)- , (LessThan, unintComp "<")- , (GreaterThan, unintComp ">")- , (LessEq, unintComp "<=")- , (GreaterEq, unintComp ">=")- ]-- -- For strings, equality and comparisons are the only operators- smtStringTable = [ (Equal, lift2S "=" "=" True)- , (NotEqual, liftNS "distinct" "distinct" True)- , (LessThan, stringCmp False "str.<")- , (GreaterThan, stringCmp True "str.<")- , (LessEq, stringCmp False "str.<=")- , (GreaterEq, stringCmp True "str.<=")- ]-- -- For lists, equality is really the only operator- -- Likewise here, things might change for comparisons- smtListTable = [ (Equal, lift2S "=" "=" True)- , (NotEqual, liftNS "distinct" "distinct" True)- , (LessThan, seqCmp False "seq.<")- , (GreaterThan, seqCmp True "seq.<")- , (LessEq, seqCmp False "seq.<=")- , (GreaterEq, seqCmp True "seq.<=")- ]--declareFun :: SV -> SBVType -> Maybe String -> [String]-declareFun = declareName . show---- If we have a char, we have to make sure it's and SMTLib string of length exactly one--- If we have a rational, we have to make sure the denominator is > 0--- Otherwise, we just declare the name-declareName :: String -> SBVType -> Maybe String -> [String]-declareName s t@(SBVType inputKS) mbCmnt = decl : restrict- where decl = "(declare-fun " ++ s ++ " " ++ cvtType t ++ ")" ++ maybe "" (" ; " ++) mbCmnt-- (args, result) = case inputKS of- [] -> error $ "SBV.declareName: Unexpected empty type for: " ++ show s- _ -> (init inputKS, last inputKS)-- -- Does the kind KChar and KRational *not* occur in the kind anywhere?- charRatFree k = null $ [() | KChar <- G.universe k] ++ [() | KRational <- G.universe k]- noCharOrRat = charRatFree result- needsQuant = not $ null args-- resultVar | needsQuant = "result"- | True = s-- argList = ["a" ++ show i | (i, _) <- zip [1::Int ..] args]- argTList = ["(" ++ a ++ " " ++ smtType k ++ ")" | (a, k) <- zip argList args]- resultExp = "(" ++ s ++ " " ++ unwords argList ++ ")"-- restrict | noCharOrRat = []- | needsQuant = [ "(assert (forall (" ++ unwords argTList ++ ")"- , " (let ((" ++ resultVar ++ " " ++ resultExp ++ "))"- ]- ++ (case constraints of- [] -> [ " true"]- [x] -> [ " " ++ x]- (x:xs) -> ( " (and " ++ x)- : [ " " ++ c | c <- xs]- ++ [ " )"])- ++ [ " )))"]- | True = case constraints of- [] -> []- [x] -> ["(assert " ++ x ++ ")"]- (x:xs) -> ( "(assert (and " ++ x)- : [ " " ++ c | c <- xs]- ++ [ " ))"]-- constraints = walk 0 resultVar cstr result- where cstr KChar nm = ["(= 1 (str.len " ++ nm ++ "))"]- cstr KRational nm = ["(< 0 (sbv.rat.denominator " ++ nm ++ "))"]- cstr _ _ = []-- mkAnd [] = "true"- mkAnd [c] = c- mkAnd cs = "(and " ++ unwords cs ++ ")"-- walk :: Int -> String -> (Kind -> String -> [String]) -> Kind -> [String]- walk _d nm f k@KBool {} = f k nm- walk _d nm f k@KBounded {} = f k nm- walk _d nm f k@KUnbounded{} = f k nm- walk _d nm f k@KReal {} = f k nm- walk _d nm f k@KUserSort {} = f k nm- walk _d nm f k@KFloat {} = f k nm- walk _d nm f k@KDouble {} = f k nm- walk _d nm f k@KRational {} = f k nm- walk _d nm f k@KFP {} = f k nm- walk _d nm f k@KChar {} = f k nm- walk _d nm f k@KString {} = f k nm- walk d nm f (KList k)- | charRatFree k = []- | True = let fnm = "seq" ++ show d- cstrs = walk (d+1) ("(seq.nth " ++ nm ++ " " ++ fnm ++ ")") f k- in ["(forall ((" ++ fnm ++ " " ++ smtType KUnbounded ++ ")) " ++ "(=> (and (>= " ++ fnm ++ " 0) (< " ++ fnm ++ " (seq.len " ++ nm ++ "))) " ++ mkAnd cstrs ++ "))"]- walk d nm f (KSet k)- | charRatFree k = []- | True = let fnm = "set" ++ show d- cstrs = walk (d+1) nm (\sk snm -> ["(=> (select " ++ snm ++ " " ++ fnm ++ ") " ++ c ++ ")" | c <- f sk fnm]) k- in ["(forall ((" ++ fnm ++ " " ++ smtType k ++ ")) " ++ mkAnd cstrs ++ ")"]- walk d nm f (KTuple ks) = let tt = "SBVTuple" ++ show (length ks)- project i = "(proj_" ++ show i ++ "_" ++ tt ++ " " ++ nm ++ ")"- nmks = [(project i, k) | (i, k) <- zip [1::Int ..] ks]- in concatMap (\(n, k) -> walk (d+1) n f k) nmks- walk d nm f km@(KMaybe k) = let n = "(get_just_SBVMaybe " ++ nm ++ ")"- in ["(=> " ++ "((_ is (just_SBVMaybe (" ++ smtType k ++ ") " ++ smtType km ++ ")) " ++ nm ++ ") " ++ c ++ ")" | c <- walk (d+1) n f k]- walk d nm f ke@(KEither k1 k2) = let n1 = "(get_left_SBVEither " ++ nm ++ ")"- n2 = "(get_right_SBVEither " ++ nm ++ ")"- c1 = ["(=> " ++ "((_ is (left_SBVEither (" ++ smtType k1 ++ ") " ++ smtType ke ++ ")) " ++ nm ++ ") " ++ c ++ ")" | c <- walk (d+1) n1 f k1]- c2 = ["(=> " ++ "((_ is (right_SBVEither (" ++ smtType k2 ++ ") " ++ smtType ke ++ ")) " ++ nm ++ ") " ++ c ++ ")" | c <- walk (d+1) n2 f k2]- in c1 ++ c2---------------------------------------------------------------------------------------------------- Casts supported by SMTLib. (From: <http://smtlib.cs.uiowa.edu/theories-FloatingPoint.shtml>)--- ; from another floating point sort--- ((_ to_fp eb sb) RoundingMode (_ FloatingPoint mb nb) (_ FloatingPoint eb sb))------ ; from real--- ((_ to_fp eb sb) RoundingMode Real (_ FloatingPoint eb sb))------ ; from signed machine integer, represented as a 2's complement bit vector--- ((_ to_fp eb sb) RoundingMode (_ BitVec m) (_ FloatingPoint eb sb))------ ; from unsigned machine integer, represented as bit vector--- ((_ to_fp_unsigned eb sb) RoundingMode (_ BitVec m) (_ FloatingPoint eb sb))------ ; to unsigned machine integer, represented as a bit vector--- ((_ fp.to_ubv m) RoundingMode (_ FloatingPoint eb sb) (_ BitVec m))------ ; to signed machine integer, represented as a 2's complement bit vector--- ((_ fp.to_sbv m) RoundingMode (_ FloatingPoint eb sb) (_ BitVec m))------ ; to real--- (fp.to_real (_ FloatingPoint eb sb) Real)--------------------------------------------------------------------------------------------------handleFPCast :: Kind -> Kind -> String -> String -> String-handleFPCast kFromIn kToIn rm input- | kFrom == kTo- = input- | True- = "(" ++ cast kFrom kTo input ++ ")"- where addRM a s = s ++ " " ++ rm ++ " " ++ a-- kFrom = simplify kFromIn- kTo = simplify kToIn-- simplify KFloat = KFP 8 24- simplify KDouble = KFP 11 53- simplify k = k-- size (eb, sb) = show eb ++ " " ++ show sb-- -- To go and back from Ints, we detour through reals- cast KUnbounded (KFP eb sb) a = "(_ to_fp " ++ size (eb, sb) ++ ") " ++ rm ++ " (to_real " ++ a ++ ")"- cast KFP{} KUnbounded a = "to_int (fp.to_real " ++ a ++ ")"-- -- To floats- cast (KBounded False _) (KFP eb sb) a = addRM a $ "(_ to_fp_unsigned " ++ size (eb, sb) ++ ")"- cast (KBounded True _) (KFP eb sb) a = addRM a $ "(_ to_fp " ++ size (eb, sb) ++ ")"- cast KReal (KFP eb sb) a = addRM a $ "(_ to_fp " ++ size (eb, sb) ++ ")"- cast KFP{} (KFP eb sb) a = addRM a $ "(_ to_fp " ++ size (eb, sb) ++ ")"-- -- From float/double- cast KFP{} (KBounded False m) a = addRM a $ "(_ fp.to_ubv " ++ show m ++ ")"- cast KFP{} (KBounded True m) a = addRM a $ "(_ fp.to_sbv " ++ show m ++ ")"-- -- To real- cast KFP{} KReal a = "fp.to_real" ++ " " ++ a-- -- Nothing else should come up:- cast f d _ = error $ "SBV.SMTLib2: Unexpected FPCast from: " ++ show f ++ " to " ++ show d--rot :: (SV -> String) -> String -> Int -> SV -> String-rot ssv o c x = "((_ " ++ o ++ " " ++ show c ++ ") " ++ ssv x ++ ")"--shft :: (SV -> String) -> String -> String -> SV -> SV -> String-shft ssv oW oS x c = "(" ++ o ++ " " ++ ssv x ++ " " ++ ssv c ++ ")"- where o = if hasSign x then oS else oW---- Various casts-handleKindCast :: Bool -> Kind -> Kind -> String -> String-handleKindCast hasInt2bv kFrom kTo a- | kFrom == kTo- = a- | True- = case kFrom of- KBounded s m -> case kTo of- KBounded _ n -> fromBV (if s then signExtend else zeroExtend) m n- KUnbounded -> b2i s m- _ -> tryFPCast-- KUnbounded -> case kTo of- KReal -> "(to_real " ++ a ++ ")"- KBounded _ n -> i2b n- _ -> tryFPCast-- KReal -> case kTo of- KUnbounded -> "(to_int " ++ a ++ ")"- _ -> tryFPCast-- _ -> tryFPCast-- where -- See if we can push this down to a float-cast, using sRNE. This happens if one of the kinds is a float/double.- -- Otherwise complain- tryFPCast- | any (\k -> isFloat k || isDouble k) [kFrom, kTo]- = handleFPCast kFrom kTo (smtRoundingMode RoundNearestTiesToEven) a- | True- = error $ "SBV.SMTLib2: Unexpected cast from: " ++ show kFrom ++ " to " ++ show kTo-- fromBV upConv m n- | n > m = upConv (n - m)- | m == n = a- | True = extract (n - 1)-- b2i False _ = "(bv2nat " ++ a ++ ")"- b2i True 1 = "(ite (= " ++ a ++ " #b0) 0 (- 1))"- b2i True m = "(ite (= " ++ msb ++ " #b0" ++ ") " ++ ifPos ++ " " ++ ifNeg ++ ")"- where offset :: Integer- offset = 2^(m-1)- rest = extract (m - 2)-- msb = let top = show (m-1) in "((_ extract " ++ top ++ " " ++ top ++ ") " ++ a ++ ")"- ifPos = "(bv2nat " ++ rest ++")"- ifNeg = "(- " ++ ifPos ++ " " ++ show offset ++ ")"-- signExtend i = "((_ sign_extend " ++ show i ++ ") " ++ a ++ ")"- zeroExtend i = "((_ zero_extend " ++ show i ++ ") " ++ a ++ ")"- extract i = "((_ extract " ++ show i ++ " 0) " ++ a ++ ")"-- -- Some solvers support int2bv, but not all. So, we use a capability to determine.- --- -- NB. The "manual" implementation works regardless n < 0 or not, because the first thing we- -- do is to compute "reduced" to bring it down to the correct range. It also works- -- regardless were mapping to signed or unsigned bit-vector; because the representation- -- is the same.- i2b n- | hasInt2bv- = "((_ int2bv " ++ show n ++ ") " ++ a ++ ")"- | True- = "(let (" ++ reduced ++ ") (let (" ++ defs ++ ") " ++ body ++ "))"- where b i = show (bit i :: Integer)- reduced = "(__a (mod " ++ a ++ " " ++ b n ++ "))"- mkBit 0 = "(__a0 (ite (= (mod __a 2) 0) #b0 #b1))"- mkBit i = "(__a" ++ show i ++ " (ite (= (mod (div __a " ++ b i ++ ") 2) 0) #b0 #b1))"- defs = unwords (map mkBit [0 .. n - 1])- body = foldr1 (\c r -> "(concat " ++ c ++ " " ++ r ++ ")") ["__a" ++ show i | i <- [n-1, n-2 .. 0]]---- Translation of pseudo-booleans, in case the solver supports them-handlePB :: PBOp -> [String] -> String-handlePB (PB_AtMost k) args = "((_ at-most " ++ show k ++ ") " ++ unwords args ++ ")"-handlePB (PB_AtLeast k) args = "((_ at-least " ++ show k ++ ") " ++ unwords args ++ ")"-handlePB (PB_Exactly k) args = "((_ pbeq " ++ unwords (map show (k : replicate (length args) 1)) ++ ") " ++ unwords args ++ ")"-handlePB (PB_Eq cs k) args = "((_ pbeq " ++ unwords (map show (k : cs)) ++ ") " ++ unwords args ++ ")"-handlePB (PB_Le cs k) args = "((_ pble " ++ unwords (map show (k : cs)) ++ ") " ++ unwords args ++ ")"-handlePB (PB_Ge cs k) args = "((_ pbge " ++ unwords (map show (k : cs)) ++ ") " ++ unwords args ++ ")"---- Translation of pseudo-booleans, in case the solver does *not* support them-reducePB :: PBOp -> [String] -> String-reducePB op args = case op of- PB_AtMost k -> "(<= " ++ addIf (repeat 1) ++ " " ++ show k ++ ")"- PB_AtLeast k -> "(>= " ++ addIf (repeat 1) ++ " " ++ show k ++ ")"- PB_Exactly k -> "(= " ++ addIf (repeat 1) ++ " " ++ show k ++ ")"- PB_Le cs k -> "(<= " ++ addIf cs ++ " " ++ show k ++ ")"- PB_Ge cs k -> "(>= " ++ addIf cs ++ " " ++ show k ++ ")"- PB_Eq cs k -> "(= " ++ addIf cs ++ " " ++ show k ++ ")"-- where addIf :: [Int] -> String- addIf cs = "(+ " ++ unwords ["(ite " ++ a ++ " " ++ show c ++ " 0)" | (a, c) <- zip args cs] ++ ")"+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.SMT.SMTLib2(cvt, cvtExp, cvtCV, cvtInc, declUserFuns, constructTables, setSMTOption) where++import Data.List (intercalate, partition, nub, elemIndex)+import Data.Maybe (listToMaybe, catMaybes)++import qualified Data.Foldable as F (toList, foldl')+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IM+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text (Text)++import Data.SBV.Core.Data+import Data.SBV.Core.Kind (smtType, needsFlattening, expandKinds, substituteADTVars)+import Data.SBV.Control.Types++import Data.SBV.SMT.Utils++import Data.SBV.Core.Symbolic ( QueryContext(..), SetOp(..), getUserName, getUserName', getSV, regExpToSMTString, NROp(..), showNROp+ , SMTDef(..), SMTLambda(..), ResultInp(..), ProgInfo(..), SpecialRelOp(..), ADTOp(..)+ )++import Data.SBV.Utils.PrettyNum (smtRoundingMode, cvToSMTLib)+import Data.SBV.Utils.Lib (showText)++import qualified Data.Generics.Uniplate.Data as G++import qualified Data.Graph as DG+++-- Check that all ADT subkinds are registered. If not, tell the user to do so+-- NB. This should not be the case as we "automatically" register the subkinds+-- as we encounter them. But this is mostly a if-something-goes-wrong check.+checkKinds :: [Kind] -> Maybe String+checkKinds ks = case [m | m@(n, _) <- apps, n `notElem` defs] of+ [] -> Nothing+ xs@(f:_) -> let (h, cnt) = case [p | p@(_, i) <- xs, i > 0] of+ (p:_) -> p+ _ -> f+ plu | length xs > 1 = "s are"+ | True = " is"+ msg = T.unlines $ [+ "Data.SBV.mkSymbolic: Impossible happened! Unregistered subkinds."+ , "***"+ , "*** The following kind" <> plu <> " not registered: " <> T.unwords (map (T.pack . fst) xs)+ , "***"+ , "*** Please report this as a bug."+ , "***"+ , "*** As a workaround, you can try registering each ADT subfield, using: "+ , "***"+ , "*** {-# LANGUAGE TypeApplications #-}"+ , "***"+ , "*** import Data.Proxy"+ , "*** registerType (Proxy @" <> mkProxy h cnt <> ")"+ ]+ ++ extras cnt+ ++ [ "***"+ , "*** Even if the workaround does the trick for you, it should not"+ , "*** be needed. Please report this as a bug!"+ ]+ in Just $ T.unpack msg+++ where apps = nub [(n, length as) | KApp n as <- concatMap expandKinds ks]+ defs = nub [n | KADT n _ _ <- ks]+ mkProxy h 0 = T.pack h+ mkProxy h n = "(" <> T.unwords (T.pack h : replicate n "Integer") <> ")"++ extras 0 = []+ extras _ = [ "***"+ , "*** NB. You can use any base type as arguments, not just 'Integer'."+ , "*** It does not need to match the actual use cases, just one instance"+ , "*** at some base type is sufficent."+ ]++-- | Translate a problem into an SMTLib2 script+cvt :: SMTLibConverter (Text, Text)+cvt ctx curProgInfo kindInfo isSat comments allInputs (_, consts) tbls uis defs (SBVPgm asgnsSeq) cstrs out cfg+ | Just s <- checkKinds allKinds+ = error s+ | True+ = (T.intercalate "\n" pgm, T.intercalate "\n" exportedDefs)+ where allKinds = Set.toList kindInfo++ -- Below can simply be defined as: nub (sort (G.universeBi asgnsSeq))+ -- Alas, it turns out this is really expensive when we have nested lambdas, so we do an explicit walk+ allTopOps = Set.toList $ F.foldl' (\sofar (_, SBVApp o _) -> Set.insert o sofar) Set.empty asgnsSeq++ hasInteger = KUnbounded `Set.member` kindInfo+ hasArrays = not (null [() | KArray{} <- allKinds])+ hasNonBVArrays = not (null [() | KArray k1 k2 <- allKinds, not (isBounded k1 && isBounded k2)])+ hasReal = KReal `Set.member` kindInfo+ hasFP = not (null [() | KFP{} <- allKinds])+ || KFloat `Set.member` kindInfo+ || KDouble `Set.member` kindInfo+ hasString = KString `Set.member` kindInfo+ hasRegExp = (not . null) [() | (_ :: RegExOp) <- G.universeBi allTopOps]+ hasChar = KChar `Set.member` kindInfo+ hasRounding = any isRoundingMode allKinds+ hasBVs = not (null [() | KBounded{} <- allKinds])+ adtsNoRM = [(s, ps, cs) | k@(KADT s ps cs) <- allKinds, not (isRoundingMode k)]+ tupleArities = findTupleArities kindInfo+ hasOverflows = (not . null) [() | (_ :: OvOp) <- G.universeBi allTopOps]+ hasQuantBools = (not . null) [() | QuantifiedBool{} <- G.universeBi allTopOps]+ hasList = any isList kindInfo+ hasSets = any isSet kindInfo+ hasTuples = not . null $ tupleArities+ hasRational = any isRational kindInfo+ hasADTs = not . null $ adtsNoRM+ solverCaps = capabilities (solver cfg)++ (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 || hasADTs)+ , ("set operations", supportsSets, hasSets)+ , ("bit vectors", supportsBitVectors, hasBVs)+ , ("special relations", supportsSpecialRels, needsSpecialRels)+ , ("needs quantifiers", supportsQuantifiers, needsQuantifiers)+ , ("unbounded integers", supportsUnboundedInts, hasInteger)+ , ("algebraic reals", supportsReals, hasReal)+ , ("floating-point numbers", supportsIEEE754, hasFP)+ , ("has data-types/sorts", supportsADTs, not (null adtsNoRM))+ ]++ nope w = [ "*** Given problem requires support for " <> T.pack w+ , "*** But the chosen solver (" <> showText (name (solver cfg)) <> ") doesn't support this feature."+ ]++ -- Some cases require all, some require none.+ setAll reason = [logicString cfg Logic_ALL <> " ; " <> T.pack reason <> ", using catch-all."]++ -- Determining the logic is surprisingly tricky!+ logic :: [Text]+ logic+ -- user told us what to do: so just take it:+ | Just l <- case [l | SetLogic l <- solverSetOptions cfg] of+ [] -> Nothing+ [l] -> Just l+ ls -> error $ T.unpack $ T.unlines [ ""+ , "*** Only one setOption call to 'setLogic' is allowed, found: " <> showText (length ls)+ , "*** " <> T.unwords (map showText ls)+ ]+ = case l of+ Logic_NONE -> ["; NB. Not setting the logic per user request of Logic_NONE"]+ _ -> [logicString cfg l <> " ; NB. User specified."]++ -- There's a reason why we can't handle this problem:+ | Just cantDo <- doesntHandle+ = let msg = T.unlines $ [ ""+ , "*** SBV is unable to choose a proper solver configuration:"+ , "***"+ ]+ <> cantDo+ <> [ "***"+ , "*** Please report this as a feature request, either for SBV or the backend solver."+ ]+ in error $ T.unpack msg++ -- Otherwise, we try to determine the most suitable logic.+ -- NB. This isn't really fool proof!++ -- we never set QF_S (ALL seems to work better in all cases)++ | needsSpecialRels = ["; has special relations, no logic set."]++ -- Things that require ALL+ | hasInteger = setAll "has unbounded values"+ | hasRational = setAll "has rational values"+ | hasReal = setAll "has algebraic reals"+ | hasADTs = setAll "has user-defined data-types"+ | hasNonBVArrays = setAll "has non-bitvector arrays"+ | hasTuples = setAll "has tuples"+ | hasSets = setAll "has sets"+ | hasList = setAll "has lists"+ | hasChar = setAll "has chars"+ | hasString = setAll "has strings"+ | hasRegExp = setAll "has regular expressions"+ | hasOverflows = setAll "has overflow checks"+ | hasQuantBools = setAll "has quantified booleans"++ | hasFP || hasRounding+ = if needsQuantifiers+ then [logicString cfg Logic_ALL]+ else [logicString cfg (if hasBVs then QF_FPBV else QF_FP)]++ -- If we're in a user query context, we'll pick ALL, otherwise+ -- we'll stick to some bit-vector logic based on what we see in the problem.+ -- This is controversial, but seems to work well in practice.+ | True+ = case ctx of+ QueryExternal -> [logicString cfg Logic_ALL <> " ; external query, using all logics."]+ QueryInternal -> if supportsBitVectors solverCaps+ then [logicString cfg picked]+ else [logicString cfg Logic_ALL] -- fall-thru+ where picked+ | needsQuantifiers = Logic_ALL+ | True = case (hasArrays, null uis && null tbls) of+ (False, False) -> QF_UFBV+ (False, True) -> QF_BV+ (True, False) -> QF_AUFBV+ (True, True) -> QF_ABV++ -- SBV always requires the production of models!+ getModels :: [Text]+ getModels = "(set-option :produce-models true)"+ : concat [map T.pack flattenConfig | any needsFlattening kindInfo, Just flattenConfig <- [supportsFlattenedModels solverCaps]]++ -- process all other settings we're given. If an option cannot be repeated, we only take the last one.+ userSettings = filter (not . T.null) $ map (setSMTOption cfg) $ filter (not . isLogic) $ foldr comb [] $ solverSetOptions cfg+ where -- Logic is already processed, so drop it:+ isLogic SetLogic{} = True+ isLogic _ = False++ -- SBV sets diagnostic-output channel on some solvers. If the user also gives it, let's just+ -- take it by only taking the last one+ isDiagOutput DiagnosticOutputChannel{} = True+ isDiagOutput _ = False++ comb o rest+ | isDiagOutput o && any isDiagOutput rest = rest+ | True = o : rest++ settings = userSettings -- NB. Make sure this comes first!+ <> getModels+ <> logic++ (inputs, trackerVars)+ = case allInputs of+ ResultTopInps ists -> ists+ ResultLamInps ps -> error $ unlines [ ""+ , "*** Data.SBV.smtLib2: Unexpected lambda inputs in conversion"+ , "***"+ , "*** Saw: " ++ show ps+ ]++ pgm = map (T.pack . ("; " <>)) comments+ <> settings+ <> [ "; --- tuples ---" ]+ <> concatMap declTuple tupleArities+ <> [ "; --- sums ---" ]+ <> (if containsRationals kindInfo then declRationals else [])+ <> [ "; --- ADTs --- " | not (null adtsNoRM)]+ <> declADT adtsNoRM+ <> [ "; --- literal constants ---" ]+ <> concatMap (declConst cfg) consts+ <> [ "; --- top level inputs ---"]+ <> concat [declareFun s (SBVType [kindOf s]) (userName s) | var <- inputs, let s = getSV var]+ <> [ "; --- optimization tracker variables ---" | not (null trackerVars) ]+ <> concat [declareFun s (SBVType [kindOf s]) (Just ("tracks " <> getUserName var)) | var <- trackerVars, let s = getSV var]+ <> [ "; --- constant tables ---" ]+ <> concatMap (uncurry (:) . mkTable) constTables+ <> [ "; --- non-constant tables ---" ]+ <> map nonConstTable nonConstTables+ <> [ "; --- uninterpreted constants ---" ]+ <> concatMap (declUI curProgInfo) uis+ <> [ "; --- user defined functions ---"]+ <> userDefs+ <> [ "; --- assignments ---" ]+ <> concatMap (declDef curProgInfo cfg tableMap) asgns+ <> [ "; --- delayedEqualities ---" ]+ <> map (\s -> "(assert " <> s <> ")") delayedEqualities+ <> [ "; --- formula ---" ]+ <> finalAssert++ userDefs = declUserFuns defs+ exportedDefs+ | null userDefs+ = ["; No calls to 'smtFunction' found."]+ | True+ = "; Automatically generated by SBV. Do not modify!" : userDefs+++ (tableMap, constTables, nonConstTables) = constructTables consts tbls++ delayedEqualities = concatMap snd nonConstTables++ finalAssert+ | noConstraints = []+ | True = map (\(attr, v) -> "(assert " <> addAnnotations attr (mkLiteral v) <> ")") hardAsserts+ <> map (\(attr, v) -> "(assert-soft " <> addAnnotations attr (mkLiteral v) <> ")") softAsserts+ where mkLiteral (Left v) = cvtSV v+ mkLiteral (Right v) = "(not " <> cvtSV v <> ")"++ (noConstraints, assertions) = finalAssertions++ hardAsserts, softAsserts :: [([(String, String)], Either SV SV)]+ hardAsserts = [(attr, v) | (False, attr, v) <- assertions]+ softAsserts = [(attr, v) | (True, attr, v) <- assertions]++ finalAssertions :: (Bool, [(Bool, [(String, String)], Either SV SV)]) -- If Left: positive, Right: negative+ finalAssertions+ | null finals = (True, [(False, [], Left trueSV)])+ | True = (False, finals)++ where finals = cstrs' ++ maybe [] (\r -> [(False, [], r)]) mbO++ cstrs' = [(isSoft, attrs, c') | (isSoft, attrs, c) <- F.toList cstrs, Just c' <- [pos c]]++ mbO | isSat = pos out+ | True = neg out++ neg s+ | s == falseSV = Nothing+ | s == trueSV = Just $ Left falseSV+ | True = Just $ Right s++ pos s+ | s == trueSV = Nothing+ | s == falseSV = Just $ Left falseSV+ | True = Just $ Left s++ asgns = F.toList asgnsSeq++ userNameMap = M.fromList $ map (\nSymVar -> (getSV nSymVar, getUserName' nSymVar)) inputs+ userName s = case M.lookup s userNameMap of+ Just u | show s /= u -> Just $ "tracks user variable " <> showText u+ _ -> Nothing++-- | Declare ADTs+declADT :: [(String, [(String, Kind)], [(String, [Kind])])] -> [Text]+declADT = concatMap declGroup . DG.stronglyConnComp . map mkNode+ where mkNode adt@(n, pks, cstrs) = (adt, n, [s | KApp s _ <- concatMap expandKinds (map snd pks ++ concatMap snd cstrs)])++ declGroup (DG.AcyclicSCC d ) = singleADT d+ declGroup (DG.CyclicSCC ds)+ = case ds of+ [] -> error "Data.SBV.declADT: Impossible happened: an empty cyclic group was returned!"+ [d] -> singleADT d+ _ -> multiADT ds++ parParens :: [(String, Kind)] -> (Text, Text)+ parParens [] = ("", "")+ parParens ps = (" (par (" <> T.unwords (map (T.pack . fst) ps) <> ")", ")")++ mkC (nm, []) = T.pack nm+ mkC (nm, ts) = T.pack nm <> " " <> T.unwords ['(' `T.cons` mkF (nm <> "_" <> show i) t <> ")" | (i, t) <- zip [(1::Int)..] ts]+ where mkF a t = "get" <> T.pack a <> " " <> smtType t++ singleADT :: (String, [(String, Kind)], [(String, [Kind])]) -> [Text]+ singleADT (tName, [], []) = ["(declare-sort " <> T.pack tName <> " 0) ; N.B. Uninterpreted sort."]+ singleADT (tName, pks, cstrs) = ("; User defined ADT: " <> T.pack tName) : decl+ where decl = ("(declare-datatype " <> T.pack tName <> parOpen <> " (")+ : [" (" <> mkC c <> ")" | c <- cstrs]+ <> ["))" <> parClose]++ (parOpen, parClose) = parParens pks++ multiADT :: [(String, [(String, Kind)], [(String, [Kind])])] -> [Text]+ multiADT adts = ("; User defined mutually-recursive ADTs: " <> T.intercalate ", " (map (\(a, _, _) -> T.pack a) adts)) : decl+ where decl = ("(declare-datatypes (" <> typeDecls <> ") (")+ : concatMap adtBody adts+ <> ["))"]++ typeDecls = T.unwords ['(' `T.cons` T.pack name <> " " <> showText (length pks) <> ")" | (name, pks, _) <- adts]++ adtBody (_, pks, cstrs) = body+ where (parOpen, parClose) = parParens pks+ body = (" " <> parOpen <> " (")+ : [" (" <> mkC c <> ")" | c <- cstrs]+ <> [" )" <> parClose]++-- | Declare tuple datatypes+--+-- eg:+--+-- @+-- (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+-- ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+-- (proj_2_SBVTuple2 T2))))))+-- @+declTuple :: Int -> [Text]+declTuple arity+ | arity == 0 = ["(declare-datatypes ((SBVTuple0 0)) (((mkSBVTuple0))))"]+ | arity == 1 = error "Data.SBV.declTuple: Unexpected one-tuple"+ | True = (l1 <> "(par (" <> T.unwords [param i | i <- [1..arity]] <> ")")+ : [pre i <> proj i <> post i | i <- [1..arity]]+ where l1 = "(declare-datatypes ((SBVTuple" <> showText arity <> " " <> showText arity <> ")) ("+ l2 = T.replicate (T.length l1) " " <> "((mkSBVTuple" <> showText arity <> " "+ tab = T.replicate (T.length l2) " "++ pre 1 = l2+ pre _ = tab++ proj i = "(proj_" <> showText i <> "_SBVTuple" <> showText arity <> " " <> param i <> ")"++ post i = if i == arity then ")))))" else ""++ param i = "T" <> showText i++-- | Find the set of tuple sizes to declare, eg (2-tuple, 5-tuple).+-- NB. We do *not* need to recursively go into list/tuple kinds here,+-- because register-kind function automatically registers all subcomponent+-- kinds, thus everything we need is available at the top-level.+findTupleArities :: Set Kind -> [Int]+findTupleArities ks = Set.toAscList+ $ Set.map length+ $ Set.fromList [ tupKs | KTuple tupKs <- Set.toList ks ]++-- | Is @Rational@ being used?+containsRationals :: Set Kind -> Bool+containsRationals = not . Set.null . Set.filter isRational++-- Internally, we do *not* keep the rationals in reduced form! So, the boolean operators explicitly do the math+-- to make sure equivalent values are treated correctly.+declRationals :: [Text]+declRationals = [ "(declare-datatype SBVRational ((SBV.Rational (sbv.rat.numerator Int) (sbv.rat.denominator Int))))"+ , ""+ , "(define-fun sbv.rat.eq ((x SBVRational) (y SBVRational)) Bool"+ , " (= (* (sbv.rat.numerator x) (sbv.rat.denominator y))"+ , " (* (sbv.rat.denominator x) (sbv.rat.numerator y)))"+ , ")"+ , ""+ , "(define-fun sbv.rat.notEq ((x SBVRational) (y SBVRational)) Bool"+ , " (not (sbv.rat.eq x y))"+ , ")"+ ]++-- | Convert in a query context.+-- NB. We do not store everything in @newKs@ below, but only what we need+-- to do as an extra in the incremental context. See `Data.SBV.Core.Symbolic.registerKind`+-- for a list of what we include, in case something doesn't show up+-- and you need it!+cvtInc :: SMTLibIncConverter [Text]+cvtInc curProgInfo inps newKs (_, consts) tbls uis (SBVPgm asgnsSeq) cstrs cfg =+ -- any new settings?+ settings+ -- sorts+ <> declADT [(s, pks, cs) | k@(KADT s pks cs) <- newKinds, not (isRoundingMode k)]+ -- tuples. NB. Only declare the new sizes, old sizes persist.+ <> concatMap declTuple (findTupleArities newKs)+ -- constants+ <> concatMap (declConst cfg) consts+ -- inputs+ <> concatMap declInp inps+ -- uninterpreteds+ <> concatMap (declUI curProgInfo) uis+ -- table declarations+ <> tableDecls+ -- expressions+ <> concatMap (declDef curProgInfo cfg tableMap) asgnsSeq+ -- table setups+ <> concat tableAssigns+ -- extra constraints+ <> map (\(isSoft, attr, v) -> "(assert" <> (if isSoft then "-soft " else " ") <> addAnnotations attr (cvtSV v) <> ")") (F.toList cstrs)+ where newKinds = Set.toList newKs++ declInp (getSV -> s) = declareFun s (SBVType [kindOf s]) Nothing++ (tableMap, allTables) = (tm, ct <> nct)+ where (tm, ct, nct) = constructTables consts tbls++ (tableDecls, tableAssigns) = unzip $ map mkTable allTables++ -- If we need flattening in models, do emit the required lines if preset+ settings+ | any needsFlattening newKinds+ = concat (catMaybes [map T.pack <$> supportsFlattenedModels solverCaps])+ | True+ = []+ where solverCaps = capabilities (solver cfg)++declDef :: ProgInfo -> SMTConfig -> TableMap -> (SV, SBVExpr) -> [Text]+declDef curProgInfo cfg tableMap (s, expr) =+ case expr of+ SBVApp (Label m) [e] -> defineFun cfg (s, cvtSV e) (Just $ T.pack m)+ e -> defineFun cfg (s, cvtExp cfg curProgInfo caps rm tableMap e) Nothing+ where caps = capabilities (solver cfg)+ rm = roundingMode cfg++defineFun :: SMTConfig -> (SV, Text) -> Maybe Text -> [Text]+defineFun cfg (s, def) mbComment+ | hasDefFun = ["(define-fun " <> varT <> " " <> def <> ")" <> cmnt]+ | True = [ "(declare-fun " <> varT <> ")" <> cmnt+ , "(assert (= " <> var <> " " <> def <> "))"+ ]+ where var = showText s+ varT = var <> " " <> svFunType [] s+ cmnt = maybe "" (" ; " <>) mbComment++ hasDefFun = supportsDefineFun $ capabilities (solver cfg)++-- Declare constants. NB. We don't declare true/false; but just inline those as necessary+declConst :: SMTConfig -> (SV, CV) -> [Text]+declConst cfg (s, c)+ | s == falseSV || s == trueSV+ = []+ | True+ = defineFun cfg (s, cvtCV c) Nothing++-- Make a function equality of nm against the internal function fun+mkRelEq :: Text -> (Text, Text) -> Kind -> Text+mkRelEq nm (fun, order) ak = res+ where lhs = "(" <> nm <> " x y)"+ rhs = "((_ " <> fun <> " " <> order <> ") x y)"+ tk = smtType ak+ res = "(forall ((x " <> tk <> ") (y " <> tk <> ")) (= " <> lhs <> " " <> rhs <> "))"++declUI :: ProgInfo -> (String, (Bool, Maybe [String], SBVType)) -> [Text]+declUI ProgInfo{progTransClosures} (i, (_, _, t)) = declareName (T.pack i) t Nothing <> declClosure+ where declClosure | Just external <- lookup i progTransClosures+ = declareName (T.pack external) t Nothing+ <> ["(assert " <> mkRelEq (T.pack external) ("transitive-closure", T.pack i) (argKind t) <> ")"]+ | True+ = []++ argKind (SBVType [ka, _, KBool]) = ka+ argKind _ = error $ "declUI: Unexpected type for name: " <> show (i, t)++-- 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 :: [(String, (SMTDef, SBVType))] -> [Text]+declUserFuns ds = map declGroup sorted+ where mkNode d = (d, fst d, getDeps d)++ getDeps (_, (SMTDef _ d _ _, _)) = d++ mkDecl Nothing rt = "() " <> rt+ mkDecl (Just p) rt = p <> " " <> rt++ sorted = DG.stronglyConnComp (map mkNode ds)++ declGroup (DG.AcyclicSCC b) = declUserDef False b+ declGroup (DG.CyclicSCC bs) = case bs of+ [] -> error "Data.SBV.declFuns: Impossible happened: an empty cyclic group was returned!"+ [x] -> declUserDef True x+ xs -> declUserDefMulti xs++ declUserDef isRec (nm, (SMTDef fk deps param body, ty)) =+ "; " <> T.pack nm <> " :: " <> showText ty <> recursive <> frees <> "\n" <> s+ where (recursive, definer) | isRec = (" [Recursive]", "define-fun-rec")+ | True = ("", "define-fun")++ otherDeps = filter (/= nm) deps+ frees | null otherDeps = ""+ | True = " [Refers to: " <> T.intercalate ", " (map T.pack otherDeps) <> "]"++ decl = mkDecl param (smtType fk)++ s = "(" <> definer <> " " <> T.pack nm <> " " <> decl <> "\n" <> body 2 <> ")"++ -- declare a bunch of mutually-recursive functions+ declUserDefMulti bs = render $ map collect bs+ where collect (nm, (SMTDef fk deps param body, ty)) = (deps, nm, ty, "(" <> T.pack nm <> " " <> decl <> ")", body 3)+ where decl = mkDecl param (smtType fk)++ render defs = T.intercalate "\n" $+ [ "; " <> T.intercalate ", " [T.pack n <> " :: " <> showText ty | (_, n, ty, _, _) <- defs]+ , "(define-funs-rec"+ ]+ <> [ open i <> param d <> close1 i | (i, d) <- zip [1..] defs]+ <> [ open i <> dump d <> close2 i | (i, d) <- zip [1..] defs]+ where open 1 = " ("+ open _ = " "++ param (_deps, _nm, _ty, p, _body) = p++ dump (deps, nm, ty, _, body) = "; Definition of: " <> T.pack nm <> " :: " <> showText ty <> ". [Refers to: " <> T.intercalate ", " (map T.pack deps) <> "]"+ <> "\n" <> body++ ld = length defs++ close1 n = if n == ld then ")" else ""+ close2 n = if n == ld then "))" else ""++mkTable :: (((Int, Kind, Kind), [SV]), [Text]) -> (Text, [Text])+mkTable (((i, ak, rk), _elts), is) = (decl, zipWith wrap [(0::Int)..] is <> setup)+ where t = "table" <> showText i+ decl = "(declare-fun " <> t <> " (" <> smtType ak <> ") " <> smtType rk <> ")"++ -- Arrange for initializers+ mkInit idx = "table" <> showText i <> "_initializer_" <> showText (idx :: Int)+ initializer = "table" <> showText i <> "_initializer"++ wrap index s = "(define-fun " <> mkInit index <> " () Bool " <> s <> ")"++ lis = length is++ setup+ | lis == 0 = [ "(define-fun " <> initializer <> " () Bool true) ; no initialization needed"+ ]+ | lis == 1 = [ "(define-fun " <> initializer <> " () Bool " <> mkInit 0 <> ")"+ , "(assert " <> initializer <> ")"+ ]+ | True = [ "(define-fun " <> initializer <> " () Bool (and " <> T.unwords (map mkInit [0..lis - 1]) <> "))"+ , "(assert " <> initializer <> ")"+ ]+nonConstTable :: (((Int, Kind, Kind), [SV]), [Text]) -> Text+nonConstTable (((i, ak, rk), _elts), _) = decl+ where t = "table" <> showText i+ decl = "(declare-fun " <> t <> " (" <> smtType ak <> ") " <> smtType rk <> ")"++constructTables :: [(SV, CV)] -> [((Int, Kind, Kind), [SV])]+ -> ( IM.IntMap Text -- table enumeration+ , [(((Int, Kind, Kind), [SV]), [Text])] -- constant tables+ , [(((Int, Kind, Kind), [SV]), [Text])] -- non-constant tables+ )+constructTables consts tbls = (tableMap, constTables, nonConstTables)+ where allTables = [(t, genTableData (map fst consts) t) | t <- tbls]+ constTables = [(t, d) | (t, Left d) <- allTables]+ nonConstTables = [(t, d) | (t, Right d) <- allTables]+ tableMap = IM.fromList $ map grab allTables++ grab (((t, _, _), _), _) = (t, "table" <> showText t)++-- Left if all constants, Right if otherwise+genTableData :: [SV] -> ((Int, Kind, Kind), [SV]) -> Either [Text] [Text]+genTableData consts ((i, aknd, _), elts)+ | null post = Left (map (mkEntry . snd) pre)+ | True = Right (map (mkEntry . snd) (pre ++ post))+ where (pre, post) = partition fst (zipWith mkElt elts [(0::Int)..])+ t = "table" <> showText i++ mkElt x k = (isReady, (idx, cvtSV x))+ where idx = cvtCV (mkConstCV aknd k)+ isReady = x `Set.member` constsSet++ mkEntry (idx, v) = "(= (" <> t <> " " <> idx <> ") " <> v <> ")"++ constsSet = Set.fromList consts++svType :: SV -> Text+svType s = smtType (kindOf s)++svFunType :: [SV] -> SV -> Text+svFunType ss s = "(" <> T.unwords (map svType ss) <> ") " <> svType s++cvtType :: SBVType -> Text+cvtType (SBVType []) = error "SBV.SMT.SMTLib2.cvtType: internal: received an empty type!"+cvtType (SBVType xs) = "(" <> T.unwords (map smtType body) <> ") " <> smtType ret+ where (body, ret) = (init xs, last xs)++type TableMap = IM.IntMap Text++-- Present an SV, simply show+cvtSV :: SV -> Text+cvtSV = showText++cvtCV :: CV -> Text+cvtCV = cvToSMTLib++getTable :: TableMap -> Int -> Text+getTable m i+ | Just tn <- i `IM.lookup` m = tn+ | True = "table" <> showText i++cvtExp :: SMTConfig -> ProgInfo -> SolverCapabilities -> RoundingMode -> TableMap -> SBVExpr -> Text+cvtExp cfg curProgInfo caps rm tableMap expr@(SBVApp _ arguments) = sh expr+ where hasPB = supportsPseudoBooleans caps+ hasDistinct = supportsDistinct caps+ specialRels = progSpecialRels curProgInfo++ bvOp = all isBounded arguments+ intOp = any isUnbounded arguments+ ratOp = any isRational arguments+ realOp = any isReal arguments+ fpOp = any (\a -> isDouble a || isFloat a || isFP a) arguments+ boolOp = all isBoolean arguments+ charOp = any isChar arguments+ stringOp = any isString arguments+ listOp = any isList arguments++ bad | intOp = error $ "SBV.SMTLib2: Unsupported operation on unbounded integers: " ++ show expr+ | True = error $ "SBV.SMTLib2: Unsupported operation on real values: " ++ show expr++ ensureBVOrBool = bvOp || boolOp || bad+ ensureBV = bvOp || bad++ addRM s = s <> " " <> smtRoundingMode rm++ isZ3 = case name (solver cfg) of+ Z3 -> True+ _ -> False++ isCVC5 = case name (solver cfg) of+ CVC5 -> True+ _ -> False++ hd _ (a:_) = a+ hd w [] = error $ "Impossible: " ++ w ++ ": Received empty list of args!"++ -- lift a binary op+ lift2 o _ [x, y] = "(" <> o <> " " <> x <> " " <> y <> ")"+ lift2 o _ sbvs = error $ "SBV.SMTLib2.sh.lift2: Unexpected arguments: " ++ show (o, sbvs)++ -- lift an arbitrary arity operator+ liftN o _ xs = "(" <> o <> " " <> T.unwords xs <> ")"++ -- lift a binary operation with rounding-mode added; used for floating-point arithmetic+ lift2WM o fo | fpOp = lift2 (addRM fo)+ | True = lift2 o++ lift1FP o fo | fpOp = lift1 fo+ | True = lift1 o++ liftAbs sgned args | fpOp = lift1 "fp.abs" sgned args+ | intOp = lift1 "abs" sgned args+ | bvOp, sgned = mkAbs fArg "bvslt" "bvneg"+ | bvOp = fArg+ | True = mkAbs fArg "<" "-"+ where fArg = hd "liftAbs" args+ mkAbs x cmp neg = "(ite " <> ltz <> " " <> nx <> " " <> x <> ")"+ where ltz = "(" <> cmp <> " " <> x <> " " <> z <> ")"+ nx = "(" <> neg <> " " <> x <> ")"+ z = cvtCV (mkConstCV (kindOf (hd "liftAbs.arguments" arguments)) (0::Integer))++ lift2B bOp vOp+ | boolOp = lift2 bOp+ | True = lift2 vOp++ lift1B bOp vOp+ | boolOp = lift1 bOp+ | True = lift1 vOp++ eqBV = lift2 "="+ neqBV = liftN "distinct"++ equal sgn sbvs+ | fpOp = lift2 "fp.eq" sgn sbvs+ | True = lift2 "=" sgn sbvs++ -- Do not use distinct on floats; because +0/-0, and NaNs mess+ -- up the meaning. Just go with regular equals.+ notEqual sgn sbvs+ | fpOp || not hasDistinct = liftP sbvs+ | True = liftN "distinct" sgn sbvs+ where liftP xs@[_, _] = "(not " <> equal sgn xs <> ")"+ liftP args = "(and " <> T.unwords (walk args) <> ")"++ walk [] = []+ walk (e:es) = map (\e' -> liftP [e, e']) es <> walk es++ lift2S oU oS sgn = lift2 (if sgn then oS else oU) sgn+ liftNS oU oS sgn = liftN (if sgn then oS else oU) sgn++ lift2Cmp o fo | fpOp = lift2 fo+ | True = lift2 o++ stringOrChar KString = True+ stringOrChar KChar = True+ stringOrChar _ = False+ stringCmp swap o [a, b]+ | stringOrChar (kindOf (hd "stringCmp" arguments))+ = let (a1, a2) | swap = (b, a)+ | True = (a, b)+ in "(" <> o <> " " <> a1 <> " " <> a2 <> ")"+ stringCmp _ o sbvs = error $ "SBV.SMT.SMTLib2.sh.stringCmp: Unexpected arguments: " ++ show (o, sbvs)++ -- NB. Likewise for sequences+ seqCmp swap o [a, b]+ | KList{} <- kindOf (hd "seqCmp" arguments)+ = let (a1, a2) | swap = (b, a)+ | True = (a, b)+ in "(" <> o <> " " <> a1 <> " " <> a2 <> ")"+ seqCmp _ o sbvs = error $ "SBV.SMT.SMTLib2.sh.seqCmp: Unexpected arguments: " ++ show (o, sbvs)++ lift1 o _ [x] = "(" <> o <> " " <> x <> ")"+ lift1 o _ sbvs = error $ "SBV.SMTLib2.sh.lift1: Unexpected arguments: " ++ show (o, sbvs)++ sh (SBVApp Ite [a, b, c]) = "(ite " <> cvtSV a <> " " <> cvtSV b <> " " <> cvtSV c <> ")"++ sh (SBVApp (LkUp (t, aKnd, _, l) i e) [])+ | needsCheck = "(ite " <> cond <> cvtSV e <> " " <> lkUp <> ")"+ | True = lkUp+ where unexpected = error $ "SBV.SMT.SMTLib2.cvtExp: Unexpected: " ++ show aKnd+ needsCheck = case aKnd of+ KVar{} -> unexpected+ KBool -> (2::Integer) > fromIntegral l+ KBounded _ n -> (2::Integer)^n > fromIntegral l+ KUnbounded -> True+ KApp _ _ -> unexpected+ KADT _ _ _ -> unexpected+ KReal -> unexpected+ KFloat -> unexpected+ KDouble -> unexpected+ KFP _ _ -> unexpected+ KRational -> unexpected+ KChar -> unexpected+ KString -> unexpected+ KList _ -> unexpected+ KSet _ -> unexpected+ KTuple _ -> unexpected+ KArray _ _ -> unexpected++ lkUp = "(" <> getTable tableMap t <> " " <> cvtSV i <> ")"++ cond+ | hasSign i = "(or " <> le0 <> " " <> gtl <> ") "+ | True = gtl <> " "++ (less, leq) = case aKnd of+ KVar{} -> error "SBV.SMT.SMTLib2.cvtExp: unexpected variable index"+ KBool -> error "SBV.SMT.SMTLib2.cvtExp: unexpected boolean valued index"+ KBounded{} -> if hasSign i then ("bvslt", "bvsle") else ("bvult", "bvule")+ KUnbounded -> ("<", "<=")+ KReal -> ("<", "<=")+ KFloat -> ("fp.lt", "fp.leq")+ KDouble -> ("fp.lt", "fp.leq")+ KRational -> ("sbv.rat.lt", "sbv.rat.leq")+ KFP{} -> ("fp.lt", "fp.leq")+ KChar -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"+ KString -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"+ KApp s _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected ADT applied index: " ++ s+ KADT s _ _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected ADT valued index: " ++ s+ KList k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sequence valued index: " ++ show k+ KSet k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected set valued index: " ++ show k+ KTuple k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected tuple valued index: " ++ show k+ KArray k1 k2 -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected array valued index: " ++ show (k1, k2)++ mkCnst = cvtCV . mkConstCV (kindOf i)+ le0 = "(" <> less <> " " <> cvtSV i <> " " <> mkCnst 0 <> ")"+ gtl = "(" <> leq <> " " <> mkCnst l <> " " <> cvtSV i <> ")"++ sh (SBVApp (KindCast f t) [a]) = handleKindCast f t (cvtSV a)++ sh (SBVApp (ArrayInit (Left (f, t))) [a]) = "((as const (Array " <> smtType f <> " " <> smtType t <> ")) " <> cvtSV a <> ")"+ sh (SBVApp (ArrayInit (Right (SMTLambda s))) []) = s+ sh (SBVApp ReadArray [a, i]) = "(select " <> cvtSV a <> " " <> cvtSV i <> ")"+ sh (SBVApp WriteArray [a, i, e]) = "(store " <> cvtSV a <> " " <> cvtSV i <> " " <> cvtSV e <> ")"++ sh (SBVApp (Uninterpreted nm) []) = nm+ sh (SBVApp (Uninterpreted nm) args) = "(" <> nm <> " " <> T.unwords (map cvtSV args) <> ")"++ sh (SBVApp (ADTOp aop) args) = handleADT caps aop args++ sh (SBVApp (QuantifiedBool i) []) = i+ sh (SBVApp (QuantifiedBool i) args) = error $ "SBV.SMT.SMTLib2.cvtExp: unexpected arguments to quantified boolean: " ++ show (T.unpack i, args)++ sh a@(SBVApp (SpecialRelOp k o) args)+ | not (null args)+ = error $ "SBV.SMT.SMTLib2.cvtExp: unexpected arguments to special op: " ++ show a+ | True+ = let order = case o `elemIndex` specialRels of+ Just i -> i+ Nothing -> error $ unlines [ "SBV.SMT.SMTLib2.cvtExp: Cannot find " ++ show o ++ " in the special-relations list."+ , "Known relations: " ++ intercalate ", " (map show specialRels)+ ]+ asrt nm fun = mkRelEq (T.pack nm) (T.pack fun, showText order) k+ in case o of+ IsPartialOrder nm -> asrt nm "partial-order"+ IsLinearOrder nm -> asrt nm "linear-order"+ IsTreeOrder nm -> asrt nm "tree-order"+ IsPiecewiseLinearOrder nm -> asrt nm "piecewise-linear-order"++ sh (SBVApp (Divides n) [a]) = "((_ divisible " <> showText n <> ") " <> cvtSV a <> ")"++ sh (SBVApp (Extract i j) [a]) | ensureBV = "((_ extract " <> showText i <> " " <> showText j <> ") " <> cvtSV a <> ")"++ sh (SBVApp (Rol i) [a])+ | bvOp = rot "rotate_left" i a+ | True = bad++ sh (SBVApp (Ror i) [a])+ | bvOp = rot "rotate_right" i a+ | True = bad++ sh (SBVApp Shl [a, i])+ | bvOp = shft "bvshl" "bvshl" a i+ | True = bad++ sh (SBVApp Shr [a, i])+ | bvOp = shft "bvlshr" "bvashr" a i+ | True = bad++ sh (SBVApp (ZeroExtend i) [a])+ | bvOp = "((_ zero_extend " <> showText i <> ") " <> cvtSV a <> ")"+ | True = bad++ sh (SBVApp (SignExtend i) [a])+ | bvOp = "((_ sign_extend " <> showText i <> ") " <> cvtSV a <> ")"+ | True = bad++ sh (SBVApp op args)+ | Just f <- lookup op smtBVOpTable, ensureBVOrBool+ = f (any hasSign args) (map cvtSV args)+ where -- The first 4 operators below do make sense for Integer's in Haskell, but there's+ -- no obvious counterpart for them in the SMTLib translation.+ -- TODO: provide support for these.+ smtBVOpTable = [ (And, lift2B "and" "bvand")+ , (Or, lift2B "or" "bvor")+ , (XOr, lift2B "xor" "bvxor")+ , (Not, lift1B "not" "bvnot")+ , (Join, lift2 "concat")+ ]++ sh (SBVApp (Label _) [a]) = cvtSV a -- This won't be reached; but just in case!++ sh (SBVApp (IEEEFP (FP_Cast kFrom kTo m)) args) = handleFPCast kFrom kTo (cvtSV m) (T.unwords (map cvtSV args))+ sh (SBVApp (IEEEFP w ) args) = "(" <> showText w <> " " <> T.unwords (map cvtSV args) <> ")"++ -- Some non-linear operators are supported by z3/CVC5 specifically, so do the custom translation Otherwise+ -- we pass them along.+ sh (SBVApp (NonLinear NR_Sqrt) [a]) | isZ3 = "(^ " <> cvtSV a <> " 0.5)"+ | isCVC5 = "(sqrt " <> cvtSV a <> ")"++ sh (SBVApp (NonLinear NR_Pow) [a, b]) | isZ3 || isCVC5 = "(^ " <> cvtSV a <> " " <> cvtSV b <> ")"++ sh (SBVApp (NonLinear w) []) = T.pack (showNROp (name (solver cfg)) w)+ sh (SBVApp (NonLinear w) args) = "(" <> T.pack (showNROp (name (solver cfg)) w) <> " " <> T.unwords (map cvtSV args) <> ")"++ sh (SBVApp (PseudoBoolean pb) args)+ | hasPB = handlePB pb args'+ | True = reducePB pb args'+ where args' = map cvtSV args++ sh (SBVApp (OverflowOp op) args) = "(" <> showText op <> " " <> T.unwords (map cvtSV args) <> ")"++ -- Note the unfortunate reversal in StrInRe..+ sh (SBVApp (StrOp (StrInRe r)) args) = "(str.in_re " <> T.unwords (map cvtSV args) <> " " <> regExpToSMTString r <> ")"+ sh (SBVApp (StrOp op) args) = "(" <> showText op <> " " <> T.unwords (map cvtSV args) <> ")"++ sh (SBVApp (RegExOp o@RegExEq{}) []) = showText o+ sh (SBVApp (RegExOp o@RegExNEq{}) []) = showText o++ -- 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) = "(" <> showText op <> " " <> T.unwords (map cvtSV args) <> ")"++ sh (SBVApp (SetOp SetEqual) args) = "(= " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (SetOp SetMember) [e, s]) = "(select " <> cvtSV s <> " " <> cvtSV e <> ")"+ sh (SBVApp (SetOp SetInsert) [e, s]) = "(store " <> cvtSV s <> " " <> cvtSV e <> " true)"+ sh (SBVApp (SetOp SetDelete) [e, s]) = "(store " <> cvtSV s <> " " <> cvtSV e <> " false)"+ sh (SBVApp (SetOp SetIntersect) args) = "(intersection " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (SetOp SetUnion) args) = "(union " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (SetOp SetSubset) args) = "(subset " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (SetOp SetDifference) args) = "(setminus " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (SetOp SetComplement) args) = "(complement " <> T.unwords (map cvtSV args) <> ")"++ sh (SBVApp (TupleConstructor 0) []) = "mkSBVTuple0"+ sh (SBVApp (TupleConstructor n) args) = "((as mkSBVTuple" <> showText n <> " " <> smtType (KTuple (map kindOf args)) <> ") " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (TupleAccess i n) [tup]) = "(proj_" <> showText i <> "_SBVTuple" <> showText n <> " " <> cvtSV tup <> ")"++ sh (SBVApp RationalConstructor [t, b]) = "(SBV.Rational " <> cvtSV t <> " " <> cvtSV b <> ")"++ sh (SBVApp Implies [a, b]) = "(=> " <> cvtSV a <> " " <> cvtSV b <> ")"++ sh inp@(SBVApp op args)+ | intOp, Just f <- lookup op smtOpIntTable+ = f True (map cvtSV args)+ | boolOp, Just f <- lookup op boolComps+ = f (map cvtSV args)+ | bvOp, Just f <- lookup op smtOpBVTable+ = f (any hasSign args) (map cvtSV args)+ | realOp, Just f <- lookup op smtOpRealTable+ = f (any hasSign args) (map cvtSV args)+ | ratOp, Just f <- lookup op ratOpTable+ = f (map cvtSV args)+ | fpOp, Just f <- lookup op smtOpFloatDoubleTable+ = f (any hasSign args) (map cvtSV args)+ | charOp || stringOp, Just f <- lookup op smtStringTable+ = f (map cvtSV args)+ | listOp, Just f <- lookup op smtListTable+ = f (map cvtSV args)+ | Just f <- lookup op uninterpretedTable+ = f (map cvtSV args)+ | True+ = error $ unlines [ ""+ , "*** SBV.SMT.SMTLib2.cvtExp.sh: impossible happened; can't translate: " ++ show inp+ , "***"+ , "*** Applied to arguments of type: " ++ intercalate ", " (nub (map (show . kindOf) args))+ , "***"+ , "*** This can happen if the Num instance isn't properly defined for a lifted kind."+ , "*** (See https://github.com/LeventErkok/sbv/issues/698 for a discussion.)"+ , "***"+ , "*** If you believe this is in error, please report!"+ ]+ where smtOpBVTable = [ (Plus, lift2 "bvadd")+ , (Minus, lift2 "bvsub")+ , (Times, lift2 "bvmul")+ , (UNeg, lift1B "not" "bvneg")+ , (Abs, liftAbs)+ , (Quot, lift2S "bvudiv" "bvsdiv")+ , (Rem, lift2S "bvurem" "bvsrem")+ , (Equal True, eqBV)+ , (Equal False, eqBV)+ , (NotEqual, neqBV)+ , (LessThan, lift2S "bvult" "bvslt")+ , (GreaterThan, lift2S "bvugt" "bvsgt")+ , (LessEq, lift2S "bvule" "bvsle")+ , (GreaterEq, lift2S "bvuge" "bvsge")+ ]++ -- Boolean comparisons.. SMTLib's bool type doesn't do comparisons, but Haskell does.. Sigh+ boolComps = [ (LessThan, blt)+ , (GreaterThan, blt . swp)+ , (LessEq, blq)+ , (GreaterEq, blq . swp)+ ]+ where blt [x, y] = "(and (not " <> x <> ") " <> y <> ")"+ blt xs = error $ "SBV.SMT.SMTLib2.boolComps.blt: Impossible happened, incorrect arity (expected 2): " ++ show xs+ blq [x, y] = "(or (not " <> x <> ") " <> y <> ")"+ blq xs = error $ "SBV.SMT.SMTLib2.boolComps.blq: Impossible happened, incorrect arity (expected 2): " ++ show xs+ swp [x, y] = [y, x]+ swp xs = error $ "SBV.SMT.SMTLib2.boolComps.swp: Impossible happened, incorrect arity (expected 2): " ++ show xs++ smtOpRealTable = smtIntRealShared+ ++ [ (Quot, lift2WM "/" "fp.div")+ ]++ smtOpIntTable = smtIntRealShared+ ++ [ (Quot, lift2 "div")+ , (Rem, lift2 "mod")+ ]++ smtOpFloatDoubleTable = smtIntRealShared+ ++ [(Quot, lift2WM "/" "fp.div")]++ smtIntRealShared = [ (Plus, lift2WM "+" "fp.add")+ , (Minus, lift2WM "-" "fp.sub")+ , (Times, lift2WM "*" "fp.mul")+ , (UNeg, lift1FP "-" "fp.neg")+ , (Abs, liftAbs)+ , (Equal True, equal)+ , (Equal False, equal)+ , (NotEqual, notEqual)+ , (LessThan, lift2Cmp "<" "fp.lt")+ , (GreaterThan, lift2Cmp ">" "fp.gt")+ , (LessEq, lift2Cmp "<=" "fp.leq")+ , (GreaterEq, lift2Cmp ">=" "fp.geq")+ ]++ ratOpTable = [ (Equal True, lift2Rat "sbv.rat.eq")+ , (Equal False, lift2Rat "sbv.rat.eq")+ , (NotEqual, lift2Rat "sbv.rat.notEq")+ ]+ where lift2Rat o [x, y] = "(" <> o <> " " <> x <> " " <> y <> ")"+ lift2Rat o sbvs = error $ "SBV.SMTLib2.sh.lift2Rat: Unexpected arguments: " ++ show (o, sbvs)++ -- equality and comparisons are the only thing that works on uninterpreted sorts and pretty much everything else+ uninterpretedTable = [ (Equal True, lift2S "=" "=" True)+ , (Equal False, lift2S "=" "=" True)+ , (NotEqual, liftNS "distinct" "distinct" True)+ ]++ -- For strings, equality and comparisons are the only operators+ smtStringTable = [ (Equal True, lift2S "=" "=" True)+ , (Equal False, lift2S "=" "=" True)+ , (NotEqual, liftNS "distinct" "distinct" True)+ , (LessThan, stringCmp False "str.<")+ , (GreaterThan, stringCmp True "str.<")+ , (LessEq, stringCmp False "str.<=")+ , (GreaterEq, stringCmp True "str.<=")+ ]++ -- For lists, equality is really the only operator. Also, not strong-equality due to lists of floats.+ -- Likewise here, things might change for comparisons+ smtListTable = [ (Equal False, lift2S "=" "=" True)+ , (NotEqual, liftNS "distinct" "distinct" True)+ , (LessThan, seqCmp False "seq.<")+ , (GreaterThan, seqCmp True "seq.<")+ , (LessEq, seqCmp False "seq.<=")+ , (GreaterEq, seqCmp True "seq.<=")+ ]++declareFun :: SV -> SBVType -> Maybe Text -> [Text]+declareFun sv = declareName (showText sv)++-- If we have a char, we have to make sure it's and SMTLib string of length exactly one+-- If we have a rational, we have to make sure the denominator is > 0+-- Otherwise, we just declare the name+declareName :: Text -> SBVType -> Maybe Text -> [Text]+declareName s t@(SBVType inputKS) mbCmnt = decl : restrict+ where decl = "(declare-fun " <> s <> " " <> cvtType t <> ")" <> maybe "" (" ; " <>) mbCmnt++ (args, result) = case inputKS of+ [] -> error $ "SBV.declareName: Unexpected empty type for: " ++ T.unpack s+ _ -> (init inputKS, last inputKS)++ -- Does the kind KChar and KRational *not* occur in the kind anywhere?+ charRatFree k = all notCharOrRat (expandKinds k)+ where notCharOrRat KChar = False+ notCharOrRat KRational = False+ notCharOrRat _ = True++ noCharOrRat = charRatFree result+ needsQuant = not $ null args++ resultVar | needsQuant = "result"+ | True = s++ argList = ["a" <> showText i | (i, _) <- zip [1::Int ..] args]+ argTList = ["(" <> a <> " " <> smtType k <> ")" | (a, k) <- zip argList args]+ resultExp = "(" <> s <> " " <> T.unwords argList <> ")"++ restrict | noCharOrRat = []+ | needsQuant = [ "(assert (forall (" <> T.unwords argTList <> ")"+ , " (let ((" <> resultVar <> " " <> resultExp <> "))"+ ]+ <> (case constraints of+ [] -> [ " true"]+ [x] -> [ " " <> x]+ (x:xs) -> ( " (and " <> x)+ : [ " " <> c | c <- xs]+ <> [ " )"])+ <> [ " )))"]+ | True = case constraints of+ [] -> []+ [x] -> ["(assert " <> x <> ")"]+ (x:xs) -> ( "(assert (and " <> x)+ : [ " " <> c | c <- xs]+ <> [ " ))"]++ constraints = walk 0 resultVar cstr result+ where cstr KChar nm = ["(= 1 (str.len " <> nm <> "))"]+ cstr KRational nm = ["(< 0 (sbv.rat.denominator " <> nm <> "))"]+ cstr _ _ = []++ mkAnd [] _context = []+ mkAnd [c] context = context c+ mkAnd cs context = context $ "(and " <> T.unwords cs <> ")"++ walk :: Int -> Text -> (Kind -> Text -> [Text]) -> Kind -> [Text]+ walk _d nm f k@KVar {} = f k nm+ walk _d nm f k@KBool {} = f k nm+ walk _d nm f k@KBounded {} = f k nm+ walk _d nm f k@KUnbounded{} = f k nm+ walk _d nm f k@KReal {} = f k nm+ walk _d nm f k@KApp {} = f k nm+ walk _d nm f k@KFloat {} = f k nm+ walk _d nm f k@KDouble {} = f k nm+ walk _d nm f k@KRational {} = f k nm+ walk _d nm f k@KFP {} = f k nm+ walk _d nm f k@KChar {} = f k nm+ walk _d nm f k@KString {} = f k nm+ walk d nm f (KList k)+ | charRatFree k = []+ | True = let fnm = "seq" <> showText d+ cstrs = walk (d+1) ("(seq.nth " <> nm <> " " <> fnm <> ")") f k+ in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> smtType KUnbounded <> ")) (=> (and (>= " <> fnm <> " 0) (< " <> fnm <> " (seq.len " <> nm <> "))) " <> hole <> "))"]+ walk d nm f (KSet k)+ | charRatFree k = []+ | True = let fnm = "set" <> showText d+ cstrs = walk (d+1) nm (\sk snm -> ["(=> (select " <> snm <> " " <> fnm <> ") " <> c <> ")" | c <- f sk fnm]) k+ in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> smtType k <> ")) " <> hole <> ")"]+ walk d nm f (KTuple ks) = let tt = "SBVTuple" <> showText (length ks)+ project i = "(proj_" <> showText i <> "_" <> tt <> " " <> nm <> ")"+ nmks = [(project i, k) | (i, k) <- zip [1::Int ..] ks]+ in concatMap (\(n, k) -> walk (d+1) n f k) nmks+ walk d nm f (KArray k1 k2)+ | all charRatFree [k1, k2] = []+ | True = let fnm = "array" <> showText d+ cstrs = walk (d+1) ("(select " <> nm <> " " <> fnm <> ")") f k2+ in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> smtType k1 <> ")) " <> hole <> ")"]+ walk d nm f (KADT ty dict pureFS) = let fs = [(c, map (substituteADTVars ty dict) ks) | (c, ks) <- pureFS]+ nmks = [("(get" <> T.pack c <> "_" <> showText i <> " " <> nm <> ")", k) | (c, ks) <- fs, (i, k) <- zip [(1::Int)..] ks]+ in concatMap (\(n, k) -> walk (d+1) n f k) nmks++-----------------------------------------------------------------------------------------------+-- Casts supported by SMTLib. (From: <https://smt-lib.org/theories-FloatingPoint.shtml>)+-- ; from another floating point sort+-- ((_ to_fp eb sb) RoundingMode (_ FloatingPoint mb nb) (_ FloatingPoint eb sb))+--+-- ; from real+-- ((_ to_fp eb sb) RoundingMode Real (_ FloatingPoint eb sb))+--+-- ; from signed machine integer, represented as a 2's complement bit vector+-- ((_ to_fp eb sb) RoundingMode (_ BitVec m) (_ FloatingPoint eb sb))+--+-- ; from unsigned machine integer, represented as bit vector+-- ((_ to_fp_unsigned eb sb) RoundingMode (_ BitVec m) (_ FloatingPoint eb sb))+--+-- ; to unsigned machine integer, represented as a bit vector+-- ((_ fp.to_ubv m) RoundingMode (_ FloatingPoint eb sb) (_ BitVec m))+--+-- ; to signed machine integer, represented as a 2's complement bit vector+-- ((_ fp.to_sbv m) RoundingMode (_ FloatingPoint eb sb) (_ BitVec m))+--+-- ; to real+-- (fp.to_real (_ FloatingPoint eb sb) Real)+-----------------------------------------------------------------------------------------------++handleFPCast :: Kind -> Kind -> Text -> Text -> Text+handleFPCast kFromIn kToIn rm input+ | kFrom == kTo+ = input+ | True+ = "(" <> cast kFrom kTo input <> ")"+ where addRM a s = s <> " " <> rm <> " " <> a++ kFrom = simplify kFromIn+ kTo = simplify kToIn++ simplify KFloat = KFP 8 24+ simplify KDouble = KFP 11 53+ simplify k = k++ size (eb, sb) = showText eb <> " " <> showText sb++ -- To go and back from Ints, we detour through reals+ cast KUnbounded (KFP eb sb) a = "(_ to_fp " <> size (eb, sb) <> ") " <> rm <> " (to_real " <> a <> ")"+ cast KFP{} KUnbounded a = "to_int (fp.to_real (fp.roundToIntegral " <> rm <> " " <> a <> "))"++ -- To floats+ cast (KBounded False _) (KFP eb sb) a = addRM a $ "(_ to_fp_unsigned " <> size (eb, sb) <> ")"+ cast (KBounded True _) (KFP eb sb) a = addRM a $ "(_ to_fp " <> size (eb, sb) <> ")"+ cast KReal (KFP eb sb) a = addRM a $ "(_ to_fp " <> size (eb, sb) <> ")"+ cast KFP{} (KFP eb sb) a = addRM a $ "(_ to_fp " <> size (eb, sb) <> ")"++ -- From float/double+ cast KFP{} (KBounded False m) a = addRM a $ "(_ fp.to_ubv " <> showText m <> ")"+ cast KFP{} (KBounded True m) a = addRM a $ "(_ fp.to_sbv " <> showText m <> ")"++ -- To real+ cast KFP{} KReal a = "fp.to_real" <> " " <> a++ -- Nothing else should come up:+ cast f d _ = error $ "SBV.SMTLib2: Unexpected FPCast from: " ++ show f ++ " to " ++ show d++rot :: Text -> Int -> SV -> Text+rot o c x = "((_ " <> o <> " " <> showText c <> ") " <> cvtSV x <> ")"++shft :: Text -> Text -> SV -> SV -> Text+shft oW oS x c = "(" <> o <> " " <> cvtSV x <> " " <> cvtSV c <> ")"+ where o = if hasSign x then oS else oW++-- ADT operations+handleADT :: SolverCapabilities -> ADTOp -> [SV] -> Text+handleADT caps op args = case args of+ [] -> f+ _ -> "(" <> f <> " " <> T.unwords (map cvtSV args) <> ")"+ where f = case op of+ ADTConstructor nm k -> ascribe nm k+ ADTTester nm k -> if supportsDirectTesters caps+ then nm+ else ascribe nm k+ ADTAccessor nm _ -> nm++ ascribe nm k = "(as " <> nm <> " " <> smtType k <> ")"++-- | Handle a kind-cast. This function only needs to cover the conversions that the type-safe API can actually+-- produce; the dynamic 'Data.SBV.Dynamic.svFromIntegral' can request other combinations, which we reject with an error.+--+-- The type-safe generators of a 'KindCast' are:+--+-- * 'Data.SBV.sFromIntegral' : @Integral a => SBV a -> SBV b@. The source is 'Integral', so it is always 'KBounded'+-- or 'KUnbounded'; the target is any @Num@/@SymVal@ kind (bounded, unbounded, real, rational, or float/double/FP).+-- * 'Data.SBV.sRealToSIntegerFloor': only ever emits @KReal -> KUnbounded@.+-- * shift-amount adjustment: only ever emits @KBounded -> KBounded@.+--+-- So the reachable (from, to) pairs are exactly:+--+-- * @KBounded -> {KBounded, KUnbounded, KReal, KRational, KFloat/KDouble/KFP}@+-- * @KUnbounded -> {KBounded, KUnbounded, KReal, KRational, KFloat/KDouble/KFP}@+-- * @KReal -> KUnbounded@+--+-- All of these are handled below (float/double/FP targets are routed through 'handleFPCast' via @tryFPCast@). Note+-- that a real or rational can never be a source (reals only appear via 'Data.SBV.sRealToSIntegerFloor', which targets 'KUnbounded';+-- rationals are not 'Integral'), so those directions are unreachable and left to 'error'.+handleKindCast :: Kind -> Kind -> Text -> Text+handleKindCast kFrom kTo a+ | kFrom == kTo+ = a+ | True+ = case kFrom of+ KBounded s m -> case kTo of+ KReal -> handleKindCast KUnbounded KReal (handleKindCast kFrom KUnbounded a)+ KRational -> handleKindCast KUnbounded KRational (handleKindCast kFrom KUnbounded a)+ KBounded _ n -> fromBV (if s then signExtend else zeroExtend) m n+ KUnbounded -> if s then "(sbv_to_int " <> a <> ")"+ else "(ubv_to_int " <> a <> ")"+ _ -> tryFPCast++ KUnbounded -> case kTo of+ KReal -> "(to_real " <> a <> ")"+ KBounded _ n -> "((_ int_to_bv " <> showText n <> ") " <> a <> ")"+ KRational -> "(SBV.Rational " <> a <> " 1)"+ _ -> tryFPCast++ KReal -> case kTo of+ KUnbounded -> "(to_int " <> a <> ")"+ _ -> tryFPCast++ _ -> tryFPCast++ where -- See if we can push this down to a float-cast, using sRNE. This happens if one of the kinds is a float/double.+ -- Otherwise complain+ tryFPCast+ | any (\k -> isFloat k || isDouble k) [kFrom, kTo]+ = handleFPCast kFrom kTo (smtRoundingMode RoundNearestTiesToEven) a+ | True+ = error $ "SBV.SMTLib2: Unexpected cast from: " ++ show kFrom ++ " to " ++ show kTo++ fromBV upConv m n+ | n > m = upConv (n - m)+ | m == n = a+ | True = extract (n - 1)++ signExtend i = "((_ sign_extend " <> showText i <> ") " <> a <> ")"+ zeroExtend i = "((_ zero_extend " <> showText i <> ") " <> a <> ")"+ extract i = "((_ extract " <> showText i <> " 0) " <> a <> ")"++-- Translation of pseudo-booleans, in case the solver supports them+handlePB :: PBOp -> [Text] -> Text+handlePB (PB_AtMost k) args = "((_ at-most " <> showText k <> ") " <> T.unwords args <> ")"+handlePB (PB_AtLeast k) args = "((_ at-least " <> showText k <> ") " <> T.unwords args <> ")"+handlePB (PB_Exactly k) args = "((_ pbeq " <> T.unwords (map showText (k : replicate (length args) 1)) <> ") " <> T.unwords args <> ")"+handlePB (PB_Eq cs k) args = "((_ pbeq " <> T.unwords (map showText (k : cs)) <> ") " <> T.unwords args <> ")"+handlePB (PB_Le cs k) args = "((_ pble " <> T.unwords (map showText (k : cs)) <> ") " <> T.unwords args <> ")"+handlePB (PB_Ge cs k) args = "((_ pbge " <> T.unwords (map showText (k : cs)) <> ") " <> T.unwords args <> ")"++-- Translation of pseudo-booleans, in case the solver does *not* support them+reducePB :: PBOp -> [Text] -> Text+reducePB op args = case op of+ PB_AtMost k -> "(<= " <> addIf (repeat 1) <> " " <> showText k <> ")"+ PB_AtLeast k -> "(>= " <> addIf (repeat 1) <> " " <> showText k <> ")"+ PB_Exactly k -> "(= " <> addIf (repeat 1) <> " " <> showText k <> ")"+ PB_Le cs k -> "(<= " <> addIf cs <> " " <> showText k <> ")"+ PB_Ge cs k -> "(>= " <> addIf cs <> " " <> showText k <> ")"+ PB_Eq cs k -> "(= " <> addIf cs <> " " <> showText k <> ")"++ where addIf :: [Int] -> Text+ addIf cs = "(+ " <> T.unwords ["(ite " <> a <> " " <> showText c <> " 0)" | (a, c) <- zip args cs] <> ")"++-- | Translate an option setting to SMTLib. Note the SetLogic/SetInfo discrepancy.+setSMTOption :: SMTConfig -> SMTOption -> Text+setSMTOption cfg = set+ where set (DiagnosticOutputChannel f) = opt [":diagnostic-output-channel", showText f]+ set (ProduceAssertions b) = opt [":produce-assertions", smtBool b]+ set (ProduceAssignments b) = opt [":produce-assignments", smtBool b]+ set (ProduceProofs b) = opt [":produce-proofs", smtBool b]+ set (ProduceInterpolants b) = opt [":produce-interpolants", smtBool b]+ set (ProduceUnsatAssumptions b) = opt [":produce-unsat-assumptions", smtBool b]+ set (ProduceUnsatCores b) = opt [":produce-unsat-cores", smtBool b]+ set (ProduceAbducts b) = opt [":produce-abducts", smtBool b]+ set (RandomSeed i) = opt [":random-seed", showText i]+ set (ReproducibleResourceLimit i) = opt [":reproducible-resource-limit", showText i]+ set (SMTVerbosity i) = opt [":verbosity", showText i]+ set (OptionKeyword ":smtlib2_compliant" _)+ | not (smtLib2Compliant cfg) = ""+ set (OptionKeyword k as) = opt (T.pack k : map T.pack as)+ set (SetLogic l) = logicString cfg l+ set (SetInfo k as) = info (T.pack k : map T.pack as)+ set (SetTimeOut i) = opt $ timeOut i++ opt xs = "(set-option " <> T.unwords xs <> ")"+ info xs = "(set-info " <> T.unwords xs <> ")"++ -- timeout is not standard. We distinguish between CVC/Z3. All else follows z3+ -- The value is in milliseconds, which is how z3/CVC interpret it+ timeOut i = case name (solver cfg) of+ CVC4 -> [":tlimit-per", showText i]+ CVC5 -> [":tlimit-per", showText i]+ _ -> [":timeout", showText i]++ -- SMTLib's True/False is spelled differently than Haskell's.+ smtBool :: Bool -> Text+ smtBool True = "true"+ smtBool False = "false"++-- | Set the logic, accounting for solver inconsistencies.+logicString :: SMTConfig -> Logic -> Text+logicString cfg = pick+ where+ slvr = name (solver cfg)++ -- This is more or less showText, but with exceptions:+ --+ -- Logic_ALL : HO_ALL for CVC5 to get support for higher-order features.+ -- QF_FPBV : Bitwuzla calls it QF_BVFP. See: https://github.com/LeventErkok/sbv/issues/774+ -- Logic_NONE: Sets nothing, just sets a comment+ pick Logic_ALL | CVC5 <- slvr = wrap "HO_ALL"+ pick QF_FPBV | Bitwuzla <- slvr = wrap "QF_BVFP"+ pick Logic_NONE = "; NB. not setting the logic per user request of Logic_NONE"++ -- Fall thru+ pick l = wrap (showText l)++ wrap l = "(set-logic " <> l <> ")"++{- HLint ignore module "Use record patterns" -}
Data/SBV/SMT/SMTLibNames.hs view
@@ -11,11 +11,11 @@ {-# OPTIONS_GHC -Wall -Werror #-} -module Data.SBV.SMT.SMTLibNames where+module Data.SBV.SMT.SMTLibNames (isReserved) where import Data.Char (toLower) --- | Names reserved by SMTLib. This list is current as of Dec 6 2015; but of course+-- | Names reserved by SMTLib, all lower-case. This list is current as of Dec 6 2015; but of course -- there's no guarantee it'll stay that way. smtLibReservedNames :: [String] smtLibReservedNames = map (map toLower)@@ -28,3 +28,7 @@ -- The following are most likely Z3 specific , "interval", "assert-soft" ]++-- | Is this name reserved? Note that we'll ignore case in checking here. This is probably over-cautious.+isReserved :: String -> Bool+isReserved = (`elem` smtLibReservedNames)
Data/SBV/SMT/Utils.hs view
@@ -9,7 +9,8 @@ -- A few internally used types/routines ----------------------------------------------------------------------------- -{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -18,11 +19,16 @@ , SMTLibIncConverter , addAnnotations , showTimeoutValue- , alignDiagnostic , alignPlain , debug , mergeSExpr , SBVException(..)+ , startTranscript+ , finalizeTranscript+ , recordTranscript+ , recordException+ , recordEndTime+ , TranscriptMsg(..) ) where @@ -31,114 +37,130 @@ import Control.Monad.Trans (MonadIO, liftIO) import Data.SBV.Core.Data-import Data.SBV.Core.Symbolic (QueryContext, CnstMap)-import Data.SBV.Utils.Lib (joinArgs)+import Data.SBV.Core.Symbolic (QueryContext, CnstMap, SMTDef, ResultInp(..), ProgInfo(..), startTime) -import Data.List (intercalate)+import Data.SBV.Utils.Lib (joinArgs, showText)+import Data.SBV.Utils.TDiff (Timing(..), showTDiff)++import Data.IORef (writeIORef)+import Data.Time (getZonedTime, defaultTimeLocale, formatTime, diffUTCTime, getCurrentTime)++import Data.Char (isSpace)+import Data.Maybe (fromMaybe)+ import qualified Data.Set as Set (Set) import qualified Data.Sequence as S (Seq) -import System.Exit (ExitCode(..))+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Text (Text) +import System.Directory (findExecutable)+import System.Exit (ExitCode(..))+ -- | An instance of SMT-Lib converter; instantiated for SMT-Lib v1 and v2. (And potentially for newer versions in the future.)-type SMTLibConverter a = QueryContext -- ^ Internal or external query?- -> Set.Set Kind -- ^ Kinds used in the problem- -> Bool -- ^ is this a sat problem?- -> [String] -- ^ extra comments to place on top- -> ([(Quantifier, NamedSymVar)], [NamedSymVar]) -- ^ inputs and aliasing names and trackers- -> [Either SV (SV, [SV])] -- ^ skolemized inputs- -> (CnstMap, [(SV, CV)]) -- ^ constants. The map, and as rendered in order- -> [((Int, Kind, Kind), [SV])] -- ^ auto-generated tables- -> [(Int, ArrayInfo)] -- ^ user specified arrays- -> [(String, SBVType)] -- ^ uninterpreted functions/constants- -> [(Bool, String, [String])] -- ^ user given axioms/definitions- -> SBVPgm -- ^ assignments- -> S.Seq (Bool, [(String, String)], SV) -- ^ extra constraints- -> SV -- ^ output variable- -> SMTConfig -- ^ configuration+type SMTLibConverter a = QueryContext -- ^ Internal or external query?+ -> ProgInfo -- ^ Various program info+ -> Set.Set Kind -- ^ Kinds used in the problem+ -> Bool -- ^ is this a sat problem?+ -> [String] -- ^ extra comments to place on top+ -> ResultInp -- ^ inputs or params+ -> (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+ -> [(String, (SMTDef, SBVType))] -- ^ user given axioms/definitions+ -> SBVPgm -- ^ assignments+ -> S.Seq (Bool, [(String, String)], SV) -- ^ extra constraints+ -> SV -- ^ output variable+ -> SMTConfig -- ^ configuration -> a -- | An instance of SMT-Lib converter; instantiated for SMT-Lib v1 and v2. (And potentially for newer versions in the future.)-type SMTLibIncConverter a = [NamedSymVar] -- ^ inputs- -> Set.Set Kind -- ^ new kinds- -> (CnstMap, [(SV, CV)]) -- ^ all constants sofar, and new constants- -> [(Int, ArrayInfo)] -- ^ newly created arrays- -> [((Int, Kind, Kind), [SV])] -- ^ newly created tables- -> [(String, SBVType)] -- ^ newly created uninterpreted functions/constants- -> SBVPgm -- ^ assignments- -> S.Seq (Bool, [(String, String)], SV) -- ^ extra constraints- -> SMTConfig -- ^ configuration+type SMTLibIncConverter a = ProgInfo -- ^ Various prog info+ -> [NamedSymVar] -- ^ inputs+ -> Set.Set Kind -- ^ new kinds+ -> (CnstMap, [(SV, CV)]) -- ^ all constants sofar, and new constants+ -> [((Int, Kind, Kind), [SV])] -- ^ newly created tables+ -> [(String, (Bool, Maybe [String], SBVType))] -- ^ newly created uninterpreted functions/constants+ -> SBVPgm -- ^ assignments+ -> S.Seq (Bool, [(String, String)], SV) -- ^ extra constraints+ -> SMTConfig -- ^ configuration -> a -- | Create an annotated term-addAnnotations :: [(String, String)] -> String -> String+addAnnotations :: [(String, String)] -> Text -> Text addAnnotations [] x = x-addAnnotations atts x = "(! " ++ x ++ " " ++ unwords (map mkAttr atts) ++ ")"+addAnnotations atts x = "(! " <> x <> " " <> T.unwords (map (T.pack . mkAttr) atts) <> ")" where mkAttr (a, v) = a ++ " |" ++ concatMap sanitize v ++ "|" sanitize '|' = "_bar_" sanitize '\\' = "_backslash_" sanitize c = [c] -- | Show a millisecond time-out value somewhat nicely-showTimeoutValue :: Int -> String+showTimeoutValue :: Int -> Text showTimeoutValue i = case (i `quotRem` 1000000, i `quotRem` 500000) of- ((s, 0), _) -> shows s "s"- (_, (hs, 0)) -> shows (fromIntegral hs / (2::Float)) "s"- _ -> shows i "ms"+ ((s, 0), _) -> showText s <> "s"+ (_, (hs, 0)) -> showText (fromIntegral hs / (2::Float)) <> "s"+ _ -> showText i <> "ms" -- | Nicely align a potentially multi-line message with some tag, but prefix with three stars-alignDiagnostic :: String -> String -> String+alignDiagnostic :: Text -> Text -> Text alignDiagnostic = alignWithPrefix "*** " -- | Nicely align a potentially multi-line message with some tag, no prefix.-alignPlain :: String -> String -> String+alignPlain :: Text -> Text -> Text alignPlain = alignWithPrefix "" -- | Align with some given prefix-alignWithPrefix :: String -> String -> String -> String-alignWithPrefix pre tag multi = intercalate "\n" $ zipWith (++) (tag : repeat (pre ++ replicate (length tag - length pre) ' ')) (filter (not . null) (lines multi))+alignWithPrefix :: Text -> Text -> Text -> Text+alignWithPrefix pre tag multi = T.intercalate "\n" $ zipWith (<>) (tag : repeat (pre <> T.replicate (T.length tag - T.length pre) " ")) (filter (not . T.null) (T.lines multi)) -- | Diagnostic message when verbose-debug :: MonadIO m => SMTConfig -> [String] -> m ()+debug :: MonadIO m => SMTConfig -> [Text] -> m () debug cfg- | not (verbose cfg) = const (return ())- | Just f <- redirectVerbose cfg = liftIO . mapM_ (appendFile f . (++ "\n"))- | True = liftIO . mapM_ putStrLn+ | not (verbose cfg) = const (pure ())+ | Just f <- redirectVerbose cfg = liftIO . mapM_ (\t -> TIO.appendFile f (t <> "\n"))+ | True = liftIO . mapM_ TIO.putStrLn -- | In case the SMT-Lib solver returns a response over multiple lines, compress them so we have -- each S-Expression spanning only a single line.-mergeSExpr :: [String] -> [String]+mergeSExpr :: [Text] -> [Text] mergeSExpr [] = [] mergeSExpr (x:xs) | d == 0 = x : mergeSExpr xs- | True = let (f, r) = grab d xs in unlines (x:f) : mergeSExpr r+ | True = let (f, r) = grab d xs in T.unlines (x:f) : mergeSExpr r where d = parenDiff x - parenDiff :: String -> Int+ parenDiff :: Text -> Int parenDiff = go 0- where go i "" = i- go i ('(':cs) = let i'= i+1 in i' `seq` go i' cs- go i (')':cs) = let i'= i-1 in i' `seq` go i' cs- go i ('"':cs) = go i (skipString cs)- go i ('|':cs) = go i (skipBar cs)- go i (_ :cs) = go i cs+ where go i t = case T.uncons t of+ Nothing -> i+ Just ('(', r) -> let i' = i+1 in i' `seq` go i' r+ Just (')', r) -> let i' = i-1 in i' `seq` go i' r+ Just ('"', r) -> go i (skipString r)+ Just ('|', r) -> go i (skipBar r)+ Just (';', r) -> go i (T.drop 1 (T.dropWhile (/= '\n') r))+ Just (_, r) -> go i r grab i ls | i <= 0 = ([], ls) grab _ [] = ([], []) grab i (l:ls) = let (a, b) = grab (i+parenDiff l) ls in (l:a, b) - skipString ('"':'"':cs) = skipString cs- skipString ('"':cs) = cs- skipString (_:cs) = skipString cs- skipString [] = [] -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore!+ skipString t = case T.uncons t of+ Nothing -> T.empty -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore!+ Just ('"', r) -> case T.uncons r of+ Just ('"', r') -> skipString r' -- escaped quote+ _ -> r -- end of string+ Just (_, r) -> skipString r - skipBar ('|':cs) = cs- skipBar (_:cs) = skipBar cs- skipBar [] = [] -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore!+ skipBar t = case T.uncons t of+ Nothing -> T.empty -- Oh dear, line finished, but the bar didn't. We're in trouble. Ignore!+ Just ('|', r) -> r+ Just (_, r) -> skipBar r -- | An exception thrown from SBV. If the solver ever responds with a non-success value for a command,--- SBV will throw an 'SBVException', it so the user can process it as required. The provided 'Show' instance+-- SBV will throw an t'SBVException', it so the user can process it as required. The provided 'Show' instance -- will render the failure nicely. Note that if you ever catch this exception, the solver is no longer alive: -- You should either -- throw the exception up, or do other proper clean-up before continuing. data SBVException = SBVException {@@ -173,26 +195,108 @@ } = let grp1 = [ ""- , "*** Data.SBV: " ++ sbvExceptionDescription ++ ":"+ , "*** Data.SBV: " <> T.pack sbvExceptionDescription <> ":" ] - grp2 = ["*** Sent : " `alignDiagnostic` snt | Just snt <- [sbvExceptionSent], not $ null snt ]- ++ ["*** Expected : " `alignDiagnostic` excp | Just excp <- [sbvExceptionExpected], not $ null excp]- ++ ["*** Received : " `alignDiagnostic` rcvd | Just rcvd <- [sbvExceptionReceived], not $ null rcvd]+ grp2 = ["*** Sent : " `alignDiagnostic` T.pack snt | Just snt <- [sbvExceptionSent], not $ null snt ]+ <> ["*** Expected : " `alignDiagnostic` T.pack excp | Just excp <- [sbvExceptionExpected], not $ null excp]+ <> ["*** Received : " `alignDiagnostic` T.pack rcvd | Just rcvd <- [sbvExceptionReceived], not $ null rcvd] - grp3 = ["*** Stdout : " `alignDiagnostic` out | Just out <- [sbvExceptionStdOut], not $ null out ]- ++ ["*** Stderr : " `alignDiagnostic` err | Just err <- [sbvExceptionStdErr], not $ null err ]- ++ ["*** Exit code : " `alignDiagnostic` show ec | Just ec <- [sbvExceptionExitCode] ]- ++ ["*** Executable: " `alignDiagnostic` executable (solver sbvExceptionConfig) ]- ++ ["*** Options : " `alignDiagnostic` joinArgs (options (solver sbvExceptionConfig) sbvExceptionConfig) ]+ grp3 = ["*** Stdout : " `alignDiagnostic` T.pack out | Just out <- [sbvExceptionStdOut], not $ null out ]+ <> ["*** Stderr : " `alignDiagnostic` T.pack err | Just err <- [sbvExceptionStdErr], not $ null err ]+ <> ["*** Exit code : " `alignDiagnostic` showText ec | Just ec <- [sbvExceptionExitCode] ]+ <> ["*** Executable: " `alignDiagnostic` T.pack (executable (solver sbvExceptionConfig)) ]+ <> ["*** Options : " `alignDiagnostic` T.pack (joinArgs (options (solver sbvExceptionConfig) sbvExceptionConfig))] - grp4 = ["*** Reason : " `alignDiagnostic` unlines rsn | Just rsn <- [sbvExceptionReason]]- ++ ["*** Hint : " `alignDiagnostic` unlines hnt | Just hnt <- [sbvExceptionHint ]]+ grp4 = ["*** Reason : " `alignDiagnostic` T.pack (unlines rsn) | Just rsn <- [sbvExceptionReason]]+ <> ["*** Hint : " `alignDiagnostic` T.pack (unlines hnt) | Just hnt <- [sbvExceptionHint ]] join [] = [] join [x] = x join (g:gs) = case join gs of [] -> g- rest -> g ++ ["***"] ++ rest+ rest -> g <> ["***"] <> rest - in unlines $ join [grp1, grp2, grp3, grp4]+ in T.unpack $ T.unlines $ join [grp1, grp2, grp3, grp4]++-- | Compute and report the end time+recordEndTime :: SMTConfig -> State -> IO ()+recordEndTime SMTConfig{timing} state = case timing of+ NoTiming -> pure ()+ PrintTiming -> do e <- elapsed+ putStrLn $ "*** SBV: Elapsed time: " ++ showTDiff e+ SaveTiming here -> writeIORef here =<< elapsed+ where elapsed = getCurrentTime >>= \end -> pure $ diffUTCTime end (startTime state)++-- | Start a transcript file, if requested.+startTranscript :: Maybe FilePath -> SMTConfig -> IO ()+startTranscript Nothing _ = pure ()+startTranscript (Just f) cfg = do ts <- show <$> getZonedTime+ mbExecPath <- findExecutable (executable (solver cfg))+ writeFile f $ start ts mbExecPath+ where SMTSolver{name, options} = solver cfg+ start ts mbPath = unlines [ ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"+ , ";;; SBV: Starting at " ++ ts+ , ";;;"+ , ";;; Solver : " ++ show name+ , ";;; Executable: " ++ fromMaybe "Unable to locate the executable" mbPath+ , ";;; Options : " ++ unwords (options cfg ++ extraArgs cfg)+ , ";;;"+ , ";;; This file is an auto-generated loadable SMT-Lib file."+ , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"+ , ""+ ]++-- | Finish up the transcript file.+finalizeTranscript :: Maybe FilePath -> ExitCode -> IO ()+finalizeTranscript Nothing _ = pure ()+finalizeTranscript (Just f) ec = do ts <- show <$> getZonedTime+ appendFile f $ end ts+ where end ts = unlines [ ""+ , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"+ , ";;;"+ , ";;; SBV: Finished at " ++ ts+ , ";;;"+ , ";;; Exit code: " ++ show ec+ , ";;;"+ , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"+ ]++-- Kind of things we can record+data TranscriptMsg = SentMsg Text (Maybe Int) -- ^ Message sent, and time-out if any+ | RecvMsg String -- ^ Message received+ | DebugMsg Text -- ^ A debug message; neither sent nor received++-- If requested, record in the transcript file+recordTranscript :: Maybe FilePath -> TranscriptMsg -> IO ()+recordTranscript Nothing _ = pure ()+recordTranscript (Just f) m = do tsPre <- formatTime defaultTimeLocale "; [%T%Q" <$> getZonedTime+ let ts = take 15 $ tsPre ++ repeat '0'+ case m of+ SentMsg sent mbTimeOut -> TIO.appendFile f $ T.unlines $ (T.pack ts <> "] " <> to mbTimeOut <> "Sending:") : T.lines sent+ RecvMsg recv -> appendFile f $ unlines $ case lines (dropWhile isSpace recv) of+ [] -> [ts ++ "] Received: <NO RESPONSE>"] -- can't really happen.+ [x] -> [ts ++ "] Received: " ++ x]+ xs -> (ts ++ "] Received: ") : map ("; " ++) xs+ DebugMsg msg -> let tag = T.pack ts <> "] "+ emp = T.cons ';' (T.replicate (T.length tag - 1) " ")+ in TIO.appendFile f $ T.unlines $ zipWith (<>) (tag : repeat emp) (T.lines msg)+ where to Nothing = ""+ to (Just i) = "[Timeout: " <> showTimeoutValue i <> "] "+{-# INLINE recordTranscript #-}++-- Record the exception+recordException :: Maybe FilePath -> String -> IO ()+recordException Nothing _ = pure ()+recordException (Just f) m = do ts <- show <$> getZonedTime+ appendFile f $ exc ts+ where exc ts = unlines $ [ ""+ , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"+ , ";;;"+ , ";;; SBV: Caught an exception at " ++ ts+ , ";;;"+ ]+ ++ [ ";;; " ++ l | l <- dropWhile null (lines m) ]+ ++ [ ";;;"+ , ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"+ ]
Data/SBV/Set.hs view
@@ -19,13 +19,10 @@ -- which is something you cannot do in Haskell! Conversely, you cannot compute -- the size of a symbolic set (as it can be infinite!), nor you can turn -- it into a list or necessarily enumerate its elements.------ __A note on cardinality__: You can indirectly talk about cardinality: 'Data.SBV.Set.hasSize'--- can be used to state that the set is finite and has size @k@ for a user-specified symbolic--- integer @k@. ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -42,7 +39,7 @@ , insert, delete -- * Query- , member, notMember, null, isEmpty, isFull, isUniversal, hasSize, isSubsetOf, isProperSubsetOf, disjoint+ , member, notMember, null, isEmpty, isFull, isUniversal, isSubsetOf, isProperSubsetOf, disjoint -- * Combinations , union, unions, intersection, intersections, difference, (\\)@@ -55,16 +52,19 @@ import qualified Data.Set as Set import Data.SBV.Core.Data-import Data.SBV.Core.Model ((.==), (./=))+import Data.SBV.Core.Model () -- instances only import Data.SBV.Core.Symbolic (SetOp(..)) -import qualified Data.Generics.Uniplate.Data as G+import Data.SBV.Core.Kind +#ifdef DOCTEST -- $setup -- >>> -- For doctest purposes only: -- >>> import Prelude hiding(null) -- >>> import Data.SBV hiding(complement)+-- >>> import Data.SBV.Maybe -- >>> :set -XScopedTypeVariables+#endif -- | Empty set. --@@ -117,7 +117,7 @@ -- Q.E.D. complement :: forall a. (Ord a, SymVal a) => SSet a -> SSet a complement ss- | KChar `elem` G.universe k+ | KChar `elem` expandKinds k = error $ unlines [ "*** Data.SBV: Set.complement is not available for the type " ++ show k , "***" , "*** See: https://github.com/LeventErkok/sbv/issues/601 for a discussion"@@ -127,13 +127,11 @@ , "*** If you run into this issue, please comment on the above ticket for" , "*** possible improvements." ]- | Just (RegularSet rs) <- unliteral ss- = literal $ ComplementSet rs- | Just (ComplementSet cs) <- unliteral ss- = literal $ RegularSet cs- | True- = SBV $ SVal k $ Right $ cache r- where k = KSet (kindOf (Proxy @a))+ | eqCheckIsObjectEq ek, Just (RegularSet rs) <- unliteral ss = literal $ ComplementSet rs+ | eqCheckIsObjectEq ek, Just (ComplementSet cs) <- unliteral ss = literal $ RegularSet cs+ | True = SBV $ SVal k $ Right $ cache r+ where ek = kindOf (Proxy @a)+ k = KSet ek r st = do svs <- sbvToSV st ss newExpr st k $ SBVApp (SetOp SetComplement) [svs]@@ -149,8 +147,8 @@ -- -- >>> prove $ \x (s :: SSet Integer) -> x `delete` (x `insert` s) .== s -- Falsifiable. Counter-example:--- s0 = 2 :: Integer--- s1 = {2} :: {Integer}+-- s0 = 2 :: Integer+-- s1 = U :: {Integer} -- -- But the above is true if the element isn't in the set to start with: --@@ -164,11 +162,11 @@ insert :: forall a. (Ord a, SymVal a) => SBV a -> SSet a -> SSet a insert se ss -- Case 1: Constant regular set, just add it:- | Just e <- unliteral se, Just (RegularSet rs) <- unliteral ss+ | eqCheckIsObjectEq ka, Just e <- unliteral se, Just (RegularSet rs) <- unliteral ss = literal $ RegularSet $ e `Set.insert` rs -- Case 2: Constant complement set, with element in the complement, just remove it:- | Just e <- unliteral se, Just (ComplementSet cs) <- unliteral ss, e `Set.member` cs+ | eqCheckIsObjectEq ka, Just e <- unliteral se, Just (ComplementSet cs) <- unliteral ss, e `Set.member` cs = literal $ ComplementSet $ e `Set.delete` cs -- Otherwise, go symbolic@@ -192,8 +190,8 @@ -- -- >>> prove $ \x (s :: SSet Integer) -> x `insert` (x `delete` s) .== s -- Falsifiable. Counter-example:--- s0 = 2 :: Integer--- s1 = {} :: {Integer}+-- s0 = 2 :: Integer+-- s1 = U - {2} :: {Integer} -- -- But the above is true if the element is in the set to start with: --@@ -207,11 +205,11 @@ delete :: forall a. (Ord a, SymVal a) => SBV a -> SSet a -> SSet a delete se ss -- Case 1: Constant regular set, just remove it:- | Just e <- unliteral se, Just (RegularSet rs) <- unliteral ss+ | eqCheckIsObjectEq ka, Just e <- unliteral se, Just (RegularSet rs) <- unliteral ss = literal $ RegularSet $ e `Set.delete` rs -- Case 2: Constant complement set, with element missing in the complement, just add it:- | Just e <- unliteral se, Just (ComplementSet cs) <- unliteral ss, e `Set.notMember` cs+ | eqCheckIsObjectEq ka, Just e <- unliteral se, Just (ComplementSet cs) <- unliteral ss, e `Set.notMember` cs = literal $ ComplementSet $ e `Set.insert` cs -- Otherwise, go symbolic@@ -234,14 +232,14 @@ -- -- >>> prove $ \x -> x `member` (full :: SSet Integer) -- Q.E.D.-member :: (Ord a, SymVal a) => SBV a -> SSet a -> SBool+member :: forall a. (Ord a, SymVal a) => SBV a -> SSet a -> SBool member se ss -- Case 1: Constant regular set, just check:- | Just e <- unliteral se, Just (RegularSet rs) <- unliteral ss+ | eqCheckIsObjectEq ka, Just e <- unliteral se, Just (RegularSet rs) <- unliteral ss = literal $ e `Set.member` rs -- Case 2: Constant complement set, check for non-member- | Just e <- unliteral se, Just (ComplementSet cs) <- unliteral ss+ | eqCheckIsObjectEq ka, Just e <- unliteral se, Just (ComplementSet cs) <- unliteral ss = literal $ e `Set.notMember` cs -- Otherwise, go symbolic@@ -251,12 +249,14 @@ sve <- sbvToSV st se newExpr st KBool $ SBVApp (SetOp SetMember) [sve, svs] + ka = kindOf (Proxy @a)+ -- | Test for non-membership. -- -- >>> prove $ \x -> x `notMember` observe "set" (singleton (x :: SInteger)) -- Falsifiable. Counter-example:--- set = {0} :: {Integer} -- s0 = 0 :: Integer+-- set = {0} :: {Integer} -- -- >>> prove $ \x (s :: SSet Integer) -> x `notMember` (x `delete` s) -- Q.E.D.@@ -280,11 +280,11 @@ -- Note how we have to call `Data.SBV.prove` in the last case since dealing -- with infinite sets requires a call to the solver and cannot be -- constant folded.-null :: HasKind a => SSet a -> SBool+null :: (Ord a, SymVal a, HasKind a) => SSet a -> SBool null = (.== empty) -- | Synonym for 'Data.SBV.Set.null'.-isEmpty :: HasKind a => SSet a -> SBool+isEmpty :: (Ord a, SymVal a, HasKind a) => SSet a -> SBool isEmpty = null -- | Is this the full set?@@ -294,8 +294,8 @@ -- -- >>> prove $ \x -> isFull (observe "set" (x `delete` (full :: SSet Integer))) -- Falsifiable. Counter-example:--- set = U - {2} :: {Integer}--- s0 = 2 :: Integer+-- s0 = 0 :: Integer+-- set = U - {0} :: {Integer} -- -- >>> isFull (full :: SSet Integer) -- True@@ -303,56 +303,13 @@ -- Note how we have to call `Data.SBV.prove` in the first case since dealing -- with infinite sets requires a call to the solver and cannot be -- constant folded.-isFull :: HasKind a => SSet a -> SBool+isFull :: (Ord a, SymVal a, HasKind a) => SSet a -> SBool isFull = (.== full) -- | Synonym for 'Data.SBV.Set.isFull'.-isUniversal :: HasKind a => SSet a -> SBool+isUniversal :: (Ord a, SymVal a, HasKind a) => SSet a -> SBool isUniversal = isFull --- | Does the set have the given size? It implicitly asserts that the set--- it is operating on is finite. NB. Only z3 supported this call, and as--- discussed in http://github.com/Z3Prover/z3/issues/3854, recent versions--- of z3 doesn't support size calls either. So, you can only use this if you have--- a sufficiently old version of z3.------ >>> prove $ \i -> hasSize (empty :: SSet Integer) i .== (i .== 0)--- Q.E.D.------ >>> sat $ \i -> hasSize (full :: SSet Integer) i--- Unsatisfiable------ The following tests are commented out since z3 no longer supports size:------ > >>> prove $ \a b i j k -> hasSize (a :: SSet Integer) i .&& hasSize (b :: SSet Integer) j .&& hasSize (a `union` b) k .=> k .>= i `smax` j--- > Q.E.D.------ > >>> prove $ \a b i j k -> hasSize (a :: SSet Integer) i .&& hasSize (b :: SSet Integer) j .&& hasSize (a `intersection` b) k .=> k .<= i `smin` j--- > Q.E.D.------ > >>> prove $ \a k -> hasSize (a :: SSet Integer) k .=> k .>= 0--- > Q.E.D.-hasSize :: (Ord a, SymVal a) => SSet a -> SInteger -> SBool-hasSize sa si- -- Case 1: Constant regular set, see if the size matches- | Just (RegularSet a) <- unliteral sa- = literal (fromIntegral (Set.size a)) .== si-- -- Case 2: Constant complement set, will never have finite size- | Just (ComplementSet _) <- unliteral sa- = sFalse-- -- Case 3: Integer is constant, and is negative:- | Just i <- unliteral si, i < 0- = sFalse-- -- Otherwise, go symbolic- | True- = SBV $ SVal KBool $ Right $ cache r- where r st = do sva <- sbvToSV st sa- svi <- sbvToSV st si- newExpr st KBool $ SBVApp (SetOp SetHasSize) [sva, svi]- -- | Subset test. -- -- >>> prove $ empty `isSubsetOf` (full :: SSet Integer)@@ -363,14 +320,14 @@ -- -- >>> prove $ \x (s :: SSet Integer) -> (x `delete` s) `isSubsetOf` s -- Q.E.D.-isSubsetOf :: (Ord a, SymVal a) => SSet a -> SSet a -> SBool+isSubsetOf :: forall a. (Ord a, SymVal a) => SSet a -> SSet a -> SBool isSubsetOf sa sb -- Case 1: Constant regular sets, just check:- | Just (RegularSet a) <- unliteral sa, Just (RegularSet b) <- unliteral sb+ | eqCheckIsObjectEq ka, Just (RegularSet a) <- unliteral sa, Just (RegularSet b) <- unliteral sb = literal $ a `Set.isSubsetOf` b -- Case 2: Constant complement sets, check in the reverse direction:- | Just (ComplementSet a) <- unliteral sa, Just (ComplementSet b) <- unliteral sb+ | eqCheckIsObjectEq ka, Just (ComplementSet a) <- unliteral sa, Just (ComplementSet b) <- unliteral sb = literal $ b `Set.isSubsetOf` a -- Otherwise, go symbolic@@ -380,6 +337,8 @@ svb <- sbvToSV st sb newExpr st KBool $ SBVApp (SetOp SetSubset) [sva, svb] + ka = kindOf (Proxy @a)+ -- | Proper subset test. -- -- >>> prove $ empty `isProperSubsetOf` (full :: SSet Integer)@@ -442,14 +401,14 @@ -- Q.E.D. -- >>> prove $ \(a :: SSet Integer) -> a `union` complement a .== full -- Q.E.D.-union :: (Ord a, SymVal a) => SSet a -> SSet a -> SSet a+union :: forall a. (Ord a, SymVal a) => SSet a -> SSet a -> SSet a union sa sb -- Case 1: Constant regular sets, just compute- | Just (RegularSet a) <- unliteral sa, Just (RegularSet b) <- unliteral sb+ | eqCheckIsObjectEq ka, Just (RegularSet a) <- unliteral sa, Just (RegularSet b) <- unliteral sb = literal $ RegularSet $ a `Set.union` b -- Case 2: Constant complement sets, complement the intersection:- | Just (ComplementSet a) <- unliteral sa, Just (ComplementSet b) <- unliteral sb+ | eqCheckIsObjectEq ka, Just (ComplementSet a) <- unliteral sa, Just (ComplementSet b) <- unliteral sb = literal $ ComplementSet $ a `Set.intersection` b -- Otherwise, go symbolic@@ -460,6 +419,8 @@ svb <- sbvToSV st sb newExpr st k $ SBVApp (SetOp SetUnion) [sva, svb] + ka = kindOf (Proxy @a)+ -- | Unions. Equivalent to @'foldr' 'union' 'empty'@. -- -- >>> prove $ unions [] .== (empty :: SSet Integer)@@ -483,14 +444,14 @@ -- Q.E.D. -- >>> prove $ \(a :: SSet Integer) b -> a `disjoint` b .=> a `intersection` b .== empty -- Q.E.D.-intersection :: (Ord a, SymVal a) => SSet a -> SSet a -> SSet a+intersection :: forall a. (Ord a, SymVal a) => SSet a -> SSet a -> SSet a intersection sa sb -- Case 1: Constant regular sets, just compute- | Just (RegularSet a) <- unliteral sa, Just (RegularSet b) <- unliteral sb+ | eqCheckIsObjectEq ka, Just (RegularSet a) <- unliteral sa, Just (RegularSet b) <- unliteral sb = literal $ RegularSet $ a `Set.intersection` b -- Case 2: Constant complement sets, complement the union:- | Just (ComplementSet a) <- unliteral sa, Just (ComplementSet b) <- unliteral sb+ | eqCheckIsObjectEq ka, Just (ComplementSet a) <- unliteral sa, Just (ComplementSet b) <- unliteral sb = literal $ ComplementSet $ a `Set.union` b -- Otherwise, go symbolic@@ -501,6 +462,8 @@ svb <- sbvToSV st sb newExpr st k $ SBVApp (SetOp SetIntersect) [sva, svb] + ka = kindOf (Proxy @a)+ -- | Intersections. Equivalent to @'foldr' 'intersection' 'full'@. Note that -- Haskell's 'Data.Set' does not support this operation as it does not have a -- way of representing universal sets.@@ -520,10 +483,10 @@ -- Q.E.D. -- >>> prove $ \(a :: SSet Integer) -> a `difference` a .== empty -- Q.E.D.-difference :: (Ord a, SymVal a) => SSet a -> SSet a -> SSet a+difference :: forall a. (Ord a, SymVal a) => SSet a -> SSet a -> SSet a difference sa sb -- Only constant fold the regular case, others are left symbolic- | Just (RegularSet a) <- unliteral sa, Just (RegularSet b) <- unliteral sb+ | eqCheckIsObjectEq ka, Just (RegularSet a) <- unliteral sa, Just (RegularSet b) <- unliteral sb = literal $ RegularSet $ a `Set.difference` b -- Otherwise, go symbolic@@ -534,8 +497,10 @@ svb <- sbvToSV st sb newExpr st k $ SBVApp (SetOp SetDifference) [sva, svb] + ka = kindOf (Proxy @a)+ -- | Synonym for 'Data.SBV.Set.difference'.-infixl 9 \\+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 @@ -550,9 +515,9 @@ False >>> sat $ \(x::SSet (Maybe Integer)) y z -> distinct [x, y, z] Satisfiable. Model:- s0 = U :: {Maybe Integer}- s1 = U - {Just 3} :: {Maybe Integer}- s2 = {} :: {Maybe Integer}+ s0 = {Just 2} :: {Maybe Integer}+ s1 = {} :: {Maybe Integer}+ s2 = U :: {Maybe Integer} However, if we compare two sets that are constructed as regular or in the complement form, we have to use a proof to establish equality:
− Data/SBV/String.hs
@@ -1,442 +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 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.Data (SeqOp(SBVReverse))-import Data.SBV.Core.Model--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---- $setup--- >>> -- For doctest purposes only:--- >>> import Data.SBV--- >>> import Prelude hiding (head, tail, init, length, take, drop, concat, null, reverse, (++), (!!))--- >>> :set -XOverloadedStrings---- | 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--- whose value is the 8-bit value @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 8-bit value 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.------ ->>> prove $ \s i c -> i `inRange` (0, length s - 1) .&& s `strToCharAt` i .== c .=> indexOf s (singleton c) .<= i--- 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 $ \s i -> i .> 0 .&& i .< length s .=> indexOf s (subStr s i 1) .<= i--- Q.E.D.------ >>> 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- newExpr st KString (SBVApp (SeqOp (SBVReverse KString)) [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--{-# ANN implode ("HLint: ignore Use concatMap" :: String) #-}
+ Data/SBV/TP.hs view
@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------+-- |+-- 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++ -- * Basic proofs, with induction schema+ , inductiveLemma, inductiveLemmaWith++ -- * Reasoning via calculation+ , calc, calcWith++ -- * Reasoning via explicit regular induction+ , induct, inductWith++ -- * Reasoning via explicit measure-based strong induction+ , sInduct, sInductWith++ -- * Creating instances of proofs+ , at, Inst(..)++ -- * Faking proofs+ , sorry++ -- * Running TP proofs+ , TP, runTP, runTPWith, tpQuiet, tpStats, tpAsms++ -- * Dry run guards+ , whenDryRun, unlessDryRun++ -- * Measure helpers for smtFunctionWithMeasure+ , measureLemma, measureLemmaWith++ -- * 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++ -- * Recall an old proof, using the cache+ , recall, recallWith+ ) where++import Data.SBV.TP.TP
+ Data/SBV/TP/Kernel.hs view
@@ -0,0 +1,379 @@+-----------------------------------------------------------------------------+-- |+-- 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 FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.TP.Kernel (+ Proposition, Proof(..)+ , axiom+ , lemma, lemmaWith+ , inductiveLemma, inductiveLemmaWith+ , internalAxiom+ , TPProofContext (..), smtProofStep, HasInductionSchema(..)+ , tpMergeCfg, checkNewMeasures+ ) where++import Control.Monad (unless)+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(..), rSkipMeasureChecks, rMeasureChecks, rNoTermCheckFunctions)++import Data.SBV.SMT.SMT+import Data.SBV.Core.Model+import Data.SBV.Provers.Prover+import Data.SBV.Utils.Lib (showText)++import Data.SBV.TP.Utils++import Data.Time (NominalDiffTime)+import Data.SBV.Utils.TDiff++import Data.Dynamic+import Data.IORef (readIORef, writeIORef, modifyIORef')+import qualified Data.Set as Set++import Type.Reflection (typeRep)++-- | 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+ )++-- | An inductive proposition is a proposition that has an induction scheme associated with it.+type Inductive a = (HasInductionSchema a, Proposition a)++-- | A class of values that has an associated induction schema. SBV manages this internally.+class HasInductionSchema a where+ inductionSchema :: a -> ProofObj++-- | Induction schema for integers. Note that this is good for proving properties over naturals really.+-- There are other instances that would apply to all integers, but this one is really the most useful+-- in practice.+instance HasInductionSchema (Forall nm Integer -> SBool) where+ inductionSchema p = proofOf $ internalAxiom "inductInteger" ax+ where pf = p . Forall+ ax = sAnd [pf 0, quantifiedBool (\(Forall i) -> (i .>= 0 .=> pf i) .=> pf (i + 1))]+ .=> quantifiedBool (\(Forall i) -> pf i)++-- | Induction schema for integers with one extra argument+instance SymVal at => HasInductionSchema (Forall nm Integer -> Forall an at -> SBool) where+ inductionSchema p = proofOf $ internalAxiom "inductInteger1" ax+ where pf i a = p (Forall i) (Forall a)+ ax = sAnd [ quantifiedBool (\ (Forall a) -> pf 0 a)+ , quantifiedBool (\(Forall i) (Forall a) -> (i .>= 0 .=> pf i a) .=> pf (i + 1) a)]+ .=> quantifiedBool (\(Forall i) (Forall a) -> pf i a)++-- | Induction schema for integers with two extra arguments+instance (SymVal at, SymVal bt) => HasInductionSchema (Forall nm Integer -> Forall an at -> Forall bn bt -> SBool) where+ inductionSchema p = proofOf $ internalAxiom "inductInteger2" ax+ where pf i a b = p (Forall i) (Forall a) (Forall b)+ ax = sAnd [ quantifiedBool (\ (Forall a) (Forall b) -> pf 0 a b)+ , quantifiedBool (\(Forall i) (Forall a) (Forall b) -> (i .>= 0 .=> pf i a b) .=> pf (i + 1) a b)]+ .=> quantifiedBool (\(Forall i) (Forall a) (Forall b) -> pf i a b)++-- | Induction schema for integers with three extra arguments+instance (SymVal at, SymVal bt, SymVal ct) => HasInductionSchema (Forall nm Integer -> Forall an at -> Forall bn bt -> Forall cn ct -> SBool) where+ inductionSchema p = proofOf $ internalAxiom "inductInteger3" ax+ where pf i a b c = p (Forall i) (Forall a) (Forall b) (Forall c)+ ax = sAnd [ quantifiedBool (\ (Forall a) (Forall b) (Forall c) -> pf 0 a b c)+ , quantifiedBool (\(Forall i) (Forall a) (Forall b) (Forall c) -> (i .>= 0 .=> pf i a b c) .=> pf (i + 1) a b c)]+ .=> quantifiedBool (\(Forall i) (Forall a) (Forall b) (Forall c) -> pf i a b c)++-- | Induction schema for integers with four extra arguments+instance (SymVal at, SymVal bt, SymVal ct, SymVal dt) => HasInductionSchema (Forall nm Integer -> Forall an at -> Forall bn bt -> Forall cn ct -> Forall dn dt -> SBool) where+ inductionSchema p = proofOf $ internalAxiom "inductInteger4" ax+ where pf i a b c d = p (Forall i) (Forall a) (Forall b) (Forall c) (Forall d)+ ax = sAnd [ quantifiedBool (\ (Forall a) (Forall b) (Forall c) (Forall d) -> pf 0 a b c d)+ , quantifiedBool (\(Forall i) (Forall a) (Forall b) (Forall c) (Forall d) -> (i .>= 0 .=> pf i a b c d) .=> pf (i + 1) a b c d)]+ .=> quantifiedBool (\(Forall i) (Forall a) (Forall b) (Forall c) (Forall d) -> pf i a b c d)++-- | Induction schema for integers with five extra arguments+instance (SymVal at, SymVal bt, SymVal ct, SymVal dt, SymVal et) => HasInductionSchema (Forall nm Integer -> Forall an at -> Forall bn bt -> Forall cn ct -> Forall dn dt -> Forall en et -> SBool) where+ inductionSchema p = proofOf $ internalAxiom "inductInteger5" ax+ where pf i a b c d e = p (Forall i) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)+ ax = sAnd [ quantifiedBool (\ (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) -> pf 0 a b c d e)+ , quantifiedBool (\(Forall i) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) -> (i .>= 0 .=> pf i a b c d e) .=> pf (i + 1) a b c d e)]+ .=> quantifiedBool (\(Forall i) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) -> pf i a b c d e)++-- | Induction schema for lists.+instance SymVal x => HasInductionSchema (Forall nm [x] -> SBool) where+ inductionSchema p = proofOf $ internalAxiom ("induct" ++ show (typeRep @[x])) ax+ where pf = p . Forall+ ax = sAnd [pf [], quantifiedBool (\(Forall x) (Forall xs) -> pf xs .=> pf (x .: xs))]+ .=> quantifiedBool (\(Forall xs) -> pf xs)++-- | Induction schema for lists with one extra argument+instance (SymVal x, SymVal at) => HasInductionSchema (Forall nm [x] -> Forall an at -> SBool) where+ inductionSchema p = proofOf $ internalAxiom ("induct" ++ show (typeRep @[x]) ++ "1") ax+ where pf xs a = p (Forall xs) (Forall a)+ ax = sAnd [ quantifiedBool (\ (Forall a) -> pf [] a)+ , quantifiedBool (\(Forall x) (Forall xs) (Forall a) -> pf xs a .=> pf (x .: xs) a)]+ .=> quantifiedBool (\(Forall xs) (Forall a) -> pf xs a)++-- | Induction schema for lists with two extra arguments+instance (SymVal x, SymVal at, SymVal bt) => HasInductionSchema (Forall nm [x] -> Forall an at -> Forall bn bt -> SBool) where+ inductionSchema p = proofOf $ internalAxiom ("induct" ++ show (typeRep @[x]) ++ "2") ax+ where pf xs a b = p (Forall xs) (Forall a) (Forall b)+ ax = sAnd [ quantifiedBool (\ (Forall a) (Forall b) -> pf [] a b)+ , quantifiedBool (\(Forall x) (Forall xs) (Forall a) (Forall b) -> pf xs a b .=> pf (x .: xs) a b)]+ .=> quantifiedBool (\(Forall xs) (Forall a) (Forall b) -> pf xs a b)++-- | Induction schema for lists with three extra arguments+instance (SymVal x, SymVal at, SymVal bt, SymVal ct) => HasInductionSchema (Forall nm [x] -> Forall an at -> Forall bn bt -> Forall cn ct -> SBool) where+ inductionSchema p = proofOf $ internalAxiom ("induct" ++ show (typeRep @[x]) ++ "3") ax+ where pf xs a b c = p (Forall xs) (Forall a) (Forall b) (Forall c)+ ax = sAnd [ quantifiedBool (\ (Forall a) (Forall b) (Forall c) -> pf [] a b c)+ , quantifiedBool (\(Forall x) (Forall xs) (Forall a) (Forall b) (Forall c) -> pf xs a b c .=> pf (x .: xs) a b c)]+ .=> quantifiedBool (\(Forall xs) (Forall a) (Forall b) (Forall c) -> pf xs a b c)++-- | Induction schema for lists with four extra arguments+instance (SymVal x, SymVal at, SymVal bt, SymVal ct, SymVal dt) => HasInductionSchema (Forall nm [x] -> Forall an at -> Forall bn bt -> Forall cn ct -> Forall dn dt -> SBool) where+ inductionSchema p = proofOf $ internalAxiom ("induct" ++ show (typeRep @[x]) ++ "4") ax+ where pf xs a b c d = p (Forall xs) (Forall a) (Forall b) (Forall c) (Forall d)+ ax = sAnd [ quantifiedBool (\ (Forall a) (Forall b) (Forall c) (Forall d) -> pf [] a b c d)+ , quantifiedBool (\(Forall x) (Forall xs) (Forall a) (Forall b) (Forall c) (Forall d) -> pf xs a b c d .=> pf (x .: xs) a b c d)]+ .=> quantifiedBool (\(Forall xs) (Forall a) (Forall b) (Forall c) (Forall d) -> pf xs a b c d)++-- | Induction schema for lists with five extra arguments+instance (SymVal x, SymVal at, SymVal bt, SymVal ct, SymVal dt, SymVal et) => HasInductionSchema (Forall nm [x] -> Forall an at -> Forall bn bt -> Forall cn ct -> Forall dn dt -> Forall en et -> SBool) where+ inductionSchema p = proofOf $ internalAxiom ("induct" ++ show (typeRep @[x]) ++ "5") ax+ where pf xs a b c d e = p (Forall xs) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e)+ ax = sAnd [ quantifiedBool (\ (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) -> pf [] a b c d e)+ , quantifiedBool (\(Forall x) (Forall xs) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) -> pf xs a b c d e .=> pf (x .: xs) a b c d e)]+ .=> quantifiedBool (\(Forall xs) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) -> pf xs a b c d e)++-- | Accept the given definition as a fact. Usually used to introduce definitional 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+ , aliases = []+ , wasCached = False+ }++-- | 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{verbose = verbose top, tpOptions = tpOptions top}++-- | 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++-- | Prove a lemma, using the given configuration.+lemmaWith :: Proposition a => SMTConfig -> String -> a -> [ProofObj] -> TP (Proof a)+lemmaWith cfgIn nm inputProp by = do+ cached <- lookupProofCache inputProp+ topCfg <- getTPConfig+ case cached of+ Just prf -> do let cfg = cfgIn `tpMergeCfg` topCfg+ returnCachedProof cfg nm prf+ Nothing -> do let cfg@SMTConfig{tpOptions = TPOptions{printStats}} = cfgIn `tpMergeCfg` topCfg+ tpSt <- getTPState+ u <- tpGetNextUnique+ result <- liftIO $ getTimeStampIf printStats >>= runSMTWith cfg . go tpSt cfg u+ addToProofCache inputProp (proofOf result)+ pure result+ where go tpSt cfg u mbStartTime = do st <- symbolicEnv+ -- Skip measure checks in the normal runWithQuery path; we handle them here+ liftIO $ writeIORef (rSkipMeasureChecks st) True+ qSaturateSavingObservables inputProp+ mapM_ (constrain . getObjProof) by++ -- Run measure checks for any newly encountered recursive functions+ liftIO $ checkNewMeasures cfg st tpSt++ -- Read no-term-check functions from this proof's State (not TPState, which accumulates)+ noTermFns <- liftIO $ readIORef (rNoTermCheckFunctions st)++ query $ smtProofStep cfg tpSt "Lemma" 0 (TPProofOneShot nm by) Nothing inputProp [] (good noTermFns cfg mbStartTime u)++ -- What to do if all goes well+ good noTermFns cfg mbStart u d = do+ mbElapsed <- getElapsedTime mbStart+ let ntcDeps = map noTermCheckProof (Set.toList noTermFns)+ allBy = by ++ ntcDeps+ liftIO $ finishTP cfg ("Q.E.D." ++ concludeModulo allBy) d $ catMaybes [mbElapsed]+ pure $ Proof $ ProofObj { dependencies = allBy+ , isUserAxiom = False+ , getObjProof = label nm (quantifiedBool inputProp)+ , getProp = toDyn inputProp+ , proofName = nm+ , uniqId = u+ , aliases = []+ , wasCached = False+ }++-- | Prove a given statement, using the induction schema for the proposition. Using the default solver.+inductiveLemma :: Inductive a => String -> a -> [ProofObj] -> TP (Proof a)+inductiveLemma nm f by = do cfg <- getTPConfig+ inductiveLemmaWith cfg nm f by++-- | Prove a given statement, using the induction schema for the proposition. Using the default solver.+inductiveLemmaWith :: Inductive a => SMTConfig -> String -> a -> [ProofObj] -> TP (Proof a)+inductiveLemmaWith cfg nm f by = lemmaWith cfg nm f (inductionSchema f : by)++-- | Check any newly encountered recursive function measures. This reads deferred checks+-- from 'rMeasureChecks', runs those not yet verified, and records them as verified.+-- Skips functions in 'measuresBeingVerified' to prevent infinite recursion when a+-- measureLemma proof uses the function whose measure is currently being checked.+checkNewMeasures :: SMTConfig -> State -> TPState -> IO ()+checkNewMeasures cfg@SMTConfig{tpOptions = TPOptions{measuresBeingVerified}} st tpSt = do+ isDry <- readIORef (dryRun tpSt)+ unless isDry $ do+ checks <- readIORef (rMeasureChecks st)+ verified <- readIORef (measuresVerified tpSt)+ productive <- readIORef (productiveVerified tpSt)+ let allVerified = verified `Set.union` productive+ allNames = Set.fromList (map (\(n, _, _) -> n) checks)+ new = [(n, p, c) | (n, p, c) <- checks, n `Set.notMember` allVerified, n `Set.notMember` measuresBeingVerified]+ skipped = [n | (n, _, _) <- checks, n `Set.notMember` allVerified, n `Set.member` measuresBeingVerified]++ msg s | not (verbose cfg)+ = pure ()+ | Just f <- redirectVerbose cfg+ = appendFile f (s ++ "\n")+ | True+ = putStrLn s++ unless (null new && null skipped) $+ msg $ "[MEASURE] checkNewMeasures: " ++ show (length new) ++ " to verify"+ ++ (if null skipped then "" else ", " ++ show (length skipped) ++ " skipped (being verified): " ++ show skipped)++ modifyIORef' (measuresEncountered tpSt) (Set.union allNames)+ let verify (n, isProductive, c) = do+ msg $ "[MEASURE] checkNewMeasures: verifying " ++ n+ () <- c cfg+ msg $ "[MEASURE] checkNewMeasures: " ++ n ++ " verified"+ if isProductive+ then modifyIORef' (productiveVerified tpSt) (Set.insert n)+ else modifyIORef' (measuresVerified tpSt) (Set.insert n)+ mapM_ verify new++-- | 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++ isDry <- liftIO $ readIORef (dryRun tpState)+ if isDry+ then do -- Dry run: record width, skip solver, report success+ tab <- liftIO $ startTP cfg verbose tag level ctx+ liftIO $ modifyIORef' (maxRibbon tpState) (max tab)+ liftIO $ unsat (tab, Nothing)+ else case mbAssumptions of+ Nothing -> do queryDebug ["; smtProofStep: No context value to push."]+ check+ Just asm -> do queryDebug ["; smtProofStep: Pushing in the context: " <> showText 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 message cfg $ "\n*** Failed to prove " ++ fullNm ++ ".\n"+ message cfg $ "\n*** Solver reported: " ++ show r ++ "\n"+ die++ -- What to do if the proof fails+ cex = do+ liftIO $ message cfg $ "\n*** Failed to prove " ++ fullNm ++ ".\n"++ 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 $ message cfg $ show (ThmResult res) ++ "\n"++ die
+ Data/SBV/TP/TP.hs view
@@ -0,0 +1,1583 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SBV.TP.TP+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+-----------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# 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+ , inductiveLemma, inductiveLemmaWith+ , calc, calcWith+ , induct, inductWith+ , sInduct, sInductWith+ , sorry+ , TP, runTP, runTPWith, tpQuiet, tpStats, tpAsms+ , whenDryRun, unlessDryRun+ , measureLemma, measureLemmaWith+ , (|-), (|->), (⊢), (=:), (≡), (??), (∵), split, split2, cases, (==>), (⟹), qed, trivial, contradiction+ , qc, qcWith+ , disp+ , recall, recallWith+ ) 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 qualified Data.Text as T++import Data.SBV.Core.Symbolic (rSkipMeasureChecks, rNoTermCheckFunctions)+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.Exception (SomeException)+import Control.Monad (when)+import Control.Monad.Trans (liftIO)+import Data.IORef (readIORef, writeIORef, modifyIORef')++import qualified Data.Set as Set++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 calculational 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++-- | 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 (tpMergeCfg cfg cfg') nm p steps++ calcGeneric :: (SymVal t, EqSymbolic (SBV t), Proposition a) => SMTConfig -> String -> a -> StepArgs a t -> TP (Proof a)+ calcGeneric cfg nm result steps = do+ cached <- lookupProofCache result+ case cached of+ Just prf -> returnCachedProof cfg nm prf+ Nothing -> do+ tpSt <- getTPState+ u <- tpGetNextUnique++ (_, CalcStrategy {calcQCInstance}) <- liftIO $ runSMTWith cfg (calcSteps result steps)++ proof <- 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 header = "Lemma: " ++ nm+ message cfg $ header ++ "\n"+ liftIO $ do isDry <- readIORef (dryRun tpSt)+ when isDry $ modifyIORef' (maxRibbon tpSt) (max (length header))++ (calcGoal, strategy@CalcStrategy {calcIntros, calcProofTree}) <- calcSteps result steps++ -- Collect all subterms and saturate them+ mapM_ qSaturateSavingObservables $ getCalcStrategySaturatables strategy++ -- Run measure checks for any newly encountered recursive functions+ st <- symbolicEnv+ liftIO $ do writeIORef (rSkipMeasureChecks st) True+ checkNewMeasures cfg st tpSt++ query $ proveProofTree cfg tpSt nm (result, calcGoal) calcIntros calcProofTree u calcQCInstance++ addToProofCache result (proofOf proof)+ pure proof++-- | 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 [T.pack nm <> ": Proof end: proving the result:"]++ mbStartTime <- getTimeStampIf printStats+ st <- symbolicEnv+ noTermFns <- liftIO $ readIORef (rNoTermCheckFunctions st)+ let ntcDeps = map noTermCheckProof (Set.toList noTermFns)+ smtProofStep cfg tpSt "Result" 1+ (TPProofStep False nm [] [""])+ (Just (initialHypotheses .=> sAnd results))+ resultBool [] $ \d ->+ do mbElapsed <- getElapsedTime mbStartTime+ let allDeps = getDependencies calcProofTree ++ ntcDeps+ modulo = concludeModulo (concatMap getHelperProofs (getAllHelpers calcProofTree) ++ ntcDeps)+ finishTP cfg ("Q.E.D." ++ modulo) d (catMaybes [mbElapsed])++ pure $ Proof $ ProofObj { dependencies = allDeps+ , isUserAxiom = False+ , getObjProof = label nm (quantifiedBool result)+ , getProp = toDyn result+ , proofName = nm+ , uniqId = uniq+ , aliases = []+ , wasCached = False+ }++ where SMTConfig{tpOptions = TPOptions{printStats, printAsms}} = 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 || printAsms = (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)+ isDry <- readIORef (dryRun tpSt)+ when isDry $ modifyIORef' (maxRibbon tpSt) (max tab)++ (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, SBV a -> SBV a -> SBool) -> TPProofRaw (SBV a) -> TPProofGen c [String] SBool+mkProofTree (symTraceEq, 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 `symEq` 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 (prev `symTraceEq` 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, [ProofObj])+ , 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+ ++ measureDs+ ++ maybeToList inductionBaseCase+ where objDeps p = getObjProof p : concatMap objDeps (dependencies p)+ measureDs = case inductionMeasure of+ Nothing -> []+ Just (a, ps) -> a : concatMap objDeps ps++-- | 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 (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 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, [ProofObj]) -> (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, [ProofObj]) -> (Proof a -> StepArgs a t) -> TP (Proof a)++ sInduct nm p mhs steps = getTPConfig >>= \cfg -> sInductWith cfg nm p mhs steps+ sInductWith cfg nm p mhs steps = getTPConfig >>= \cfg' -> inductionEngine GeneralInduction (tpMergeCfg cfg cfg') nm p (sInductionStrategy p mhs 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, [ProofObj]) -> (Proof a -> StepArgs a t) -> Symbolic InductionStrategy++-- | Do an inductive proof, based on the given strategy+inductionEngine :: Proposition a => InductionStyle -> SMTConfig -> String -> a -> Symbolic InductionStrategy -> TP (Proof a)+inductionEngine style cfg nm result getStrategy = do+ cached <- lookupProofCache result+ case cached of+ Just prf -> returnCachedProof cfg nm prf+ Nothing -> do+ tpSt <- getTPState+ u <- tpGetNextUnique++ proof <- 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)"++ let header = "Inductive lemma" ++ qual ++ ": " ++ nm+ message cfg $ header ++ "\n"+ liftIO $ do isDry <- readIORef (dryRun tpSt)+ when isDry $ modifyIORef' (maxRibbon tpSt) (max (length header))++ strategy@InductionStrategy { inductionIntros+ , inductionMeasure+ , inductionBaseCase+ , inductionProofTree+ , inductiveStep+ , inductiveQCInstance+ } <- getStrategy++ mapM_ qSaturateSavingObservables $ getInductionStrategySaturatables strategy++ -- Run measure checks for any newly encountered recursive functions+ st <- symbolicEnv+ liftIO $ do writeIORef (rSkipMeasureChecks st) True+ checkNewMeasures cfg st tpSt++ query $ do++ case inductionMeasure of+ Nothing -> queryDebug [T.pack nm <> ": Induction" <> T.pack qual <> ", there is no custom measure to show non-negativeness."]+ Just (m, hs) -> do queryDebug [T.pack nm <> ": Induction, proving measure is always non-negative:"]+ smtProofStep cfg tpSt "Step" 1+ (TPProofStep False nm [] ["Measure is non-negative"])+ (Just (sAnd (inductionIntros : map getObjProof hs)))+ m+ []+ (\d -> finishTP cfg "Q.E.D." d [])+ case inductionBaseCase of+ Nothing -> queryDebug [T.pack nm <> ": Induction" <> T.pack qual <> ", there is no base case to prove."]+ Just bc -> do queryDebug [T.pack 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++ addToProofCache result (proofOf proof)+ pure proof++-- Induction strategy helper+mkIndStrategy :: (SymVal a, EqSymbolic (SBV a)) => Maybe (SBool, [ProofObj]) -> 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 [])+ 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 []) (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 []) (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 []) (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 []) (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 []) (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 [], Forall []) .&& result (Forall [], Forall (y SL..: ys)) .&& result (Forall (x SL..: xs), Forall [])+ 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 [], Forall []) (Forall a) .&& result (Forall [], Forall (y SL..: ys)) (Forall a) .&& result (Forall (x SL..: xs), Forall []) (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 [], Forall []) (Forall a) (Forall b) .&& result (Forall [], Forall (y SL..: ys)) (Forall a) (Forall b) .&& result (Forall (x SL..: xs), Forall []) (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 [], Forall []) (Forall a) (Forall b) (Forall c) .&& result (Forall [], Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) .&& result (Forall (x SL..: xs), Forall []) (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 [], Forall []) (Forall a) (Forall b) (Forall c) (Forall d) .&& result (Forall [], Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d) .&& result (Forall (x SL..: xs), Forall []) (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 [], Forall []) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) .&& result (Forall [], Forall (y SL..: ys)) (Forall a) (Forall b) (Forall c) (Forall d) (Forall e) .&& result (Forall (x SL..: xs), Forall []) (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, helpers) 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 (nonNeg (measure a), helpers))+ 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, helpers) 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 (nonNeg (measure a b), helpers))+ 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, helpers) 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 (nonNeg (measure a b c), helpers))+ 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, helpers) 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 (nonNeg (measure a b c d), helpers))+ 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, helpers) 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 (nonNeg (measure a b c d e), helpers))+ 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 |-++-- | Start an implicational proof, with the given hypothesis. Use @[]@ as the+-- first argument if the calculation holds unconditionally. Each step will be a cascading+-- chain of conjunctions of the previous, starting from @sTrue@.+(|->) :: [SBool] -> TPProofRaw SBool -> (SBool, TPProofRaw SBool)+bs |-> p = (sAnd bs, xform sTrue p)+ where xform :: SBool -> TPProofGen SBool [Helper] () -> TPProofGen SBool [Helper] ()+ xform conj (ProofStep a hs r) = let ca = conj .&& a in ProofStep ca hs (xform ca r)+ xform conj (ProofBranch b bh ss) = ProofBranch b bh [(bc, xform conj r) | (bc, r) <- ss]+ xform _ (ProofEnd b hs ) = ProofEnd b hs+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 ⟹++-- | Recalling a proof. If the proposition was previously proved and cached, the cached result+-- is returned without re-proving. The output is kept brief: a single "Q.E.D." line.+-- If stats mode is on, we show the full proof steps as the point of stats is to see detail.+recall :: TP (Proof a) -> TP (Proof a)+recall prf = getTPConfig >>= \cfg -> recallWith cfg prf++-- | Recalling a proof, using a given config. Sets the recall context flag so that+-- proof engines check the cache before proving.+recallWith :: SMTConfig -> TP (Proof a) -> TP (Proof a)+recallWith cfgIn prf = do+ topCfg <- getTPConfig+ tpSt <- getTPState+ let cfg@SMTConfig{tpOptions = TPOptions{printStats}} = cfgIn `tpMergeCfg` topCfg+ -- Set recall context so proof engines check the cache+ liftIO $ modifyIORef' (inRecallContext tpSt) (+1)+ let cleanup = liftIO $ modifyIORef' (inRecallContext tpSt) (subtract 1)+ if printStats+ then restoring cfg topCfg $ do r <- prf+ cleanup+ pure r+ else do let new = cfg{tpOptions = (tpOptions cfg) {quiet = True}}+ restoring new topCfg $ do+ res <- tryTP prf+ cleanup+ case res of+ Left (_ :: SomeException) ->+ -- Re-run with original config so failure details are visible+ restoring cfg topCfg prf >> pure (error "unreachable")+ Right r@Proof{proofOf = po@ProofObj{dependencies, aliases = aka, wasCached = cached}} -> do+ let nm = proofName po+ liftIO $ printLemmaResult cfg (verbose cfg) nm dependencies cached aka+ pure r+ where restoring new old act = do setTPConfig new+ res <- act+ setTPConfig old+ pure res++{- HLint ignore module "Eta reduce" -}+{- HLint ignore module "Reduce duplication" -}
+ Data/SBV/TP/Utils.hs view
@@ -0,0 +1,707 @@+-----------------------------------------------------------------------------+-- |+-- 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, tryTP, whenDryRun, unlessDryRun, Proof(..), ProofObj(..), assumptionFromProof, sorry, quickCheckProof, noTermCheckProof+ , startTP, finishTP, getTPState, getTPConfig, setTPConfig, tpGetNextUnique, TPState(..), TPStats(..), RootOfTrust(..)+ , TPProofContext(..), message, updStats, rootOfTrust, concludeModulo, printLemmaResult+ , ProofTree(..), TPUnique(..), showProofTree, showProofTreeHTML+ , addToProofCache, lookupProofCache, returnCachedProof+ , tpQuiet, tpAsms, tpStats+ , measureLemma, measureLemmaWith+ ) where++import Control.Exception (Exception, try)+import Control.Monad (unless, when)+import Control.Monad.Reader (ReaderT(..), runReaderT, MonadReader, ask, liftIO)+import Control.Monad.Trans (MonadIO)++import Data.Generics (everywhere, mkT)++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, nub, sort, dropWhileEnd)+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, sTrue, Forall(..), QuantifiedBool, quantifiedBool, SBV(..), SV(..), NodeId(..), SBVExpr(..), SBVPgm(..), Op(..), CV(..))+import Data.SBV.Core.Model (label, MeasureHelper(..))+import Data.SBV.Core.Symbolic (SMTConfig, TPOptions(..), State(..), mkNewState, svToSV, SBVRunMode(..), globalSBVContext)+import Data.SBV.Provers.Prover (defaultSMTCfg, SMTConfig(..))++import Data.SBV.Utils.TDiff (showTDiff, timeIf)+import Control.DeepSeq (NFData(rnf))++import Data.Foldable (toList)+import Data.IORef++import GHC.Generics+import Data.Dynamic++import qualified Data.Map.Strict as Map++import qualified Data.Set as Set+import Data.Set (Set)++-- | 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.Map (PropFingerprint, TypeRep) [ProofObj])+ , config :: IORef SMTConfig+ , inRecallContext :: IORef Int+ , measuresVerified :: IORef (Set String)+ , productiveVerified :: IORef (Set String)+ , measuresEncountered :: IORef (Set String)+ , dryRun :: IORef Bool -- ^ If True, collecting ribbon widths (no proving)+ , maxRibbon :: IORef Int -- ^ Session-wide maximum ribbon length+ }++-- | Monad for running TP proofs in.+newtype TP a = TP (ReaderT TPState IO a)+ deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader TPState, MonadFail)++-- | Run a TP action, catching exceptions.+tryTP :: Exception e => TP a -> TP (Either e a)+tryTP (TP act) = TP $ ReaderT $ \st -> try (runReaderT act st)++-- | Run an action only during the dry-run pass.+whenDryRun :: TP () -> TP ()+whenDryRun act = do st <- ask+ isDry <- liftIO $ readIORef (dryRun st)+ when isDry act++-- | Run an action only during the real (non-dry-run) pass. Useful for guarding user-facing output+-- (e.g., proof tree printing) that should be suppressed during ribbon calculation.+unlessDryRun :: TP () -> TP ()+unlessDryRun act = do st <- ask+ isDry <- liftIO $ readIORef (dryRun st)+ unless isDry act++-- | Extract the integer node ID from an SV.+svIntId :: SV -> Int+svIntId (SV _ (NodeId (_, _, i))) = i++-- | Zero out the SBVContext in an SV, keeping only the kind and integer node ID.+-- Used to normalize 'Op' values for fingerprinting.+zeroSV :: SV -> SV+zeroSV (SV k (NodeId (_, mb, i))) = SV k (NodeId (globalSBVContext, mb, i))++-- | Zero out all embedded SBVContext values inside an 'Op' using SYB generic traversal.+-- This automatically handles all current and future Op constructors that embed SV's.+zeroContextInOp :: Op -> Op+zeroContextInOp = everywhere (mkT zeroSV)++-- | Fingerprint of a proposition's symbolic expression DAG.+-- Computed by evaluating 'quantifiedBool' in a fresh State and extracting+-- the expression program (with embedded SV contexts zeroed out via SYB),+-- the constant map (mapping constant values to their SV int IDs), and the final result SV.+-- Two identical propositions evaluated in identically-initialized States produce+-- identical fingerprints. Different propositions diverge somewhere in variable creation,+-- expression construction, or hash-consing, producing different fingerprints.+newtype PropFingerprint = PropFingerprint ([(CV, Int)], [(Int, Op, [Int])], Int)+ deriving (Eq, Ord)++-- | Compute the fingerprint of a proposition by evaluating it in a fresh+-- lightweight State (no solver connection needed). The State is created via+-- 'mkNewState' with 'LambdaGen' mode, which initializes all counters identically+-- without starting a solver process.+propFingerprint :: QuantifiedBool a => a -> IO PropFingerprint+propFingerprint prop = do+ st <- mkNewState defaultSMTCfg (LambdaGen Nothing)+ sv <- svToSV st (unSBV (quantifiedBool prop))+ pgm <- readIORef (spgm st)+ cm <- readIORef (rconstMap st)+ let entries = [ (svIntId target, zeroContextInOp op, map svIntId args)+ | (target, SBVApp op args) <- toList (pgmAssignments pgm)+ ]+ consts = [(c, svIntId s) | (c, s) <- Map.toAscList cm]+ pure $ PropFingerprint (consts, entries, svIntId sv)++-- | After proving a proposition, add the proof to the cache for future recall lookups.+addToProofCache :: forall a. (Typeable a, QuantifiedBool a) => a -> ProofObj -> TP ()+addToProofCache prop prf = do+ TPState{proofCache} <- getTPState+ fp <- liftIO $ propFingerprint prop+ let key = (fp, typeOf (Proxy @a))+ liftIO $ modifyIORef' proofCache $ Map.insertWith (\_ old -> prf : old) key [prf]++-- | Look up a cached proof for the given proposition. Only succeeds when in recall context+-- (i.e., called from within a recall wrapper). On cache hit, the returned ProofObj has+-- its 'aliases' field populated with the names of other proofs of the same proposition.+lookupProofCache :: forall a. (Typeable a, QuantifiedBool a) => a -> TP (Maybe ProofObj)+lookupProofCache prop = do+ TPState{proofCache, inRecallContext} <- getTPState+ inRecall <- liftIO $ readIORef inRecallContext+ if inRecall == 0+ then pure Nothing+ else do fp <- liftIO $ propFingerprint prop+ let key = (fp, typeOf (Proxy @a))+ cache <- liftIO $ readIORef proofCache+ pure $ case reverse <$> Map.lookup key cache of+ Nothing -> Nothing+ Just [] -> Nothing+ Just (p:ps) -> Just p { aliases = [proofName q | q <- ps] }++-- | Return a cached proof, printing a brief "Q.E.D." line with optional "a.k.a." annotation.+returnCachedProof :: SMTConfig -> String -> ProofObj -> TP (Proof a)+returnCachedProof cfg nm prf = do+ let aka = filter (/= nm) $ nub $ proofName prf : aliases prf+ prf' = prf { proofName = nm, wasCached = True, aliases = aka }+ liftIO $ printLemmaResult cfg False nm (dependencies prf) True aka+ pure $ Proof prf'++-- | 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+ rDryRun <- newIORef True+ rMaxRibbon <- newIORef 0++ let runPass c = do+ rStats <- newIORef $ TPStats { noOfCheckSats = 0, solverElapsed = 0, qcElapsed = 0 }+ rCache <- newIORef Map.empty+ rCfg <- newIORef c+ rRecall <- newIORef (0 :: Int)+ rMeasures <- newIORef Set.empty+ rProductive <- newIORef Set.empty+ rEncountered <- newIORef Set.empty+ let st = TPState { config = rCfg+ , stats = rStats+ , proofCache = rCache+ , inRecallContext = rRecall+ , measuresVerified = rMeasures+ , productiveVerified = rProductive+ , measuresEncountered = rEncountered+ , dryRun = rDryRun+ , maxRibbon = rMaxRibbon+ }+ a <- runReaderT f st+ pure (a, st)++ -- Pass 1: Dry run to collect ribbon widths+ _ <- runPass ((tpQuiet True cfg){verbose = False})++ -- Pass 2: Real run with computed ribbon+ writeIORef rDryRun False+ ribbon <- readIORef rMaxRibbon+ let cfg' = cfg{tpOptions = (tpOptions cfg) { ribbonLength = max 20 (ribbon + 4) }}++ (mbT, (r, TPState{stats = rStats, measuresVerified = rMeasures, productiveVerified = rProductive, measuresEncountered = rEncountered}))+ <- timeIf printStats $ runPass cfg'++ -- Print verified measures and productive functions+ verified <- readIORef rMeasures+ productive <- readIORef rProductive+ encountered <- readIORef rEncountered++ unless (Set.null verified) $ printMeasures cfg' (Set.toAscList verified)+ unless (Set.null productive) $ printProductive cfg' (Set.toAscList productive)++ -- Belt-and-suspenders: make sure all encountered measures have been verified.+ -- Exclude functions in measuresBeingVerified: those are being verified by an outer caller+ -- (e.g., when a measureLemma proof uses the function whose measure is being checked).+ let beingVerified = measuresBeingVerified (tpOptions cfg)+ missed = encountered `Set.difference` verified `Set.difference` productive `Set.difference` beingVerified++ unless (Set.null missed) $+ error $ "SBV.runTP: Internal error: The following functions have termination measures that were encountered but not verified: "+ ++ intercalate ", " (Set.toAscList missed)++ 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 = do rCfg <- config <$> getTPState+ liftIO (readIORef rCfg)++-- | set the configuration+setTPConfig :: SMTConfig -> TP ()+setTPConfig cfg = do st <- getTPState+ liftIO (writeIORef (config st) cfg)++-- | 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}, redirectVerbose} s+ | quiet+ = pure ()+ | Just f <- redirectVerbose+ = liftIO $ appendFile f s+ | True+ = liftIO $ putStr s >> hFlush stdout++-- | Print the list of functions whose termination measures have been verified.+printMeasures :: SMTConfig -> [String] -> IO ()+printMeasures = printFunctions "Functions proven terminating"++-- | Print the list of functions whose productivity (guardedness) has been verified.+printProductive :: SMTConfig -> [String] -> IO ()+printProductive = printFunctions "Functions proven productive"++-- | Print a list of function names under a header, wrapping lines to avoid excessively long output.+-- If the list fits on one line, it follows the header directly. Otherwise, it starts on a new line.+printFunctions :: String -> SMTConfig -> [String] -> IO ()+printFunctions header cfg names+ | length oneLine <= limit = message cfg $ header ++ ": " ++ oneLine ++ "\n"+ | True = message cfg $ header ++ ":\n " ++ wrapped ++ "\n"+ where cleaned = nub (sort (map strip names))+ strip = dropWhileEnd (== ' ') . takeWhile (/= '@')++ limit = 90++ oneLine = intercalate ", " cleaned++ wrapped = go limit cleaned++ go _ [] = ""+ go _ [n] = n+ go r (n:ns) = let len = length n + 2 -- account for ", "+ rest = go (r - len) ns+ in if r - len < 0 && r /= limit+ then "\n " ++ go limit (n:ns)+ else case rest of+ '\n':_ -> n ++ "," ++ rest+ _ -> n ++ ", " ++ rest++-- | 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+ pure (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)+ | TPNoTermCheck -- no termination check (smtFunctionNoTermination)+ | TPUser Int64 -- user given+ deriving (NFData, Generic, Eq, Ord)++-- | 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+ , aliases :: [String] -- ^ Other names for proofs of the same proposition (populated on cache hit)+ , wasCached :: Bool -- ^ Was this proof retrieved from the cache?+ }++-- | Drop the instantiation part+shortProofName :: ProofObj -> String+shortProofName p | " @ " `isInfixOf` s = reverse . dropWhile isSpace . reverse . takeWhile (/= '@') $ s+ | True = s+ where s = proofName p++-- | Deduplicate proof objects by their unique id, keeping the first occurrence.+-- Same result as @nubBy ((==) \`on\` uniqId)@, but O(n log n) instead of O(n^2).+nubByUniqId :: [ProofObj] -> [ProofObj]+nubByUniqId = go Set.empty+ where go _ [] = []+ go seen (p:ps)+ | u `Set.member` seen = go seen ps+ | True = p : go (Set.insert u seen) ps+ where u = uniqId p++-- | Nicely format a bunch of proof-names, shortened and uniquified. Note that if we get a dependency+-- via multiple routes, they can get different uniqid's; so we do a bit of compression here.+shortProofNames :: [ProofObj] -> String+shortProofNames = intercalate ", " . map merge . compress . sort . map shortProofName . nubByUniqId+ where compress [] = []+ compress (a:as) = case span (a ==) as of+ (same, other) -> (a, length same + 1) : compress other+ merge (n, 1) = n+ merge (n, x) = n ++ " (x" ++ show x ++ ")"++-- | 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 [" ++ shortProofNames ps ++ "]"++-- | Trust forms a semigroup+instance Semigroup RootOfTrust where+ RootOfTrust as <> RootOfTrust bs = RootOfTrust $ nubByUniqId <$> (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 aliases wasCached) = rnf dependencies+ `seq` rnf isUserAxiom+ `seq` rnf getObjProof+ `seq` rnf proofName+ `seq` rnf uniqId+ `seq` rnf aliases+ `seq` rnf wasCached++-- | 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+ TPNoTermCheck -> 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 ProofObj{proofName = nm}) = '[' : sh (rootOfTrust p) ++ "] " ++ nm ++ " :: " ++ pretty (show (typeOf p))+ where sh (RootOfTrust Nothing) = "Proven"+ sh (RootOfTrust (Just ps)) = "Modulo: " ++ shortProofNames ps++ -- More mathematical notation for types.+ pretty :: String -> String+ pretty = charToString . compress . unwords . walk . words . concatMap (\c -> if c == ',' then " , " else [c]) . clean+ where fa v = ['Ɐ' : unQuote v, "∷"]+ ex v = ['∃' : unQuote v, "∷"]++ -- Remove spaces before commas: "foo , bar" -> "foo, bar"+ compress (' ' : ',' : rest) = compress (',' : rest)+ compress (c : rest) = c : compress rest+ compress [] = []++ -- Replace [Char] with String everywhere+ charToString ('[':'C':'h':'a':'r':']':rest) = "String" ++ charToString rest+ charToString (c:rest) = c : charToString rest+ charToString [] = []++ 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+ , aliases = []+ , wasCached = 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+ , aliases = []+ , wasCached = 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++-- | A proof object representing a function whose termination was not checked.+-- When a function is defined with 'Data.SBV.smtFunctionNoTermination', its termination+-- is assumed but not proven. Any proof that depends on such a function will be+-- marked as modulo this assumption in its root of trust.+noTermCheckProof :: String -> ProofObj+noTermCheckProof nm = ProofObj { dependencies = []+ , isUserAxiom = False+ , getObjProof = sTrue+ , getProp = toDyn True+ , proofName = nm ++ " termination"+ , uniqId = TPNoTermCheck+ , aliases = []+ , wasCached = False+ }++-- | 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]+ TPNoTermCheck -> RootOfTrust $ Just [p]+ 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 sorry is present, it dominates everything else. Otherwise keep all.+ compress (RootOfTrust mbps) = RootOfTrust $ reduce <$> mbps+ where reduce ps+ | any (\o -> uniqId o == TPSorry) ps = [sorry]+ | True = ps++-- | Print a one-line lemma result: @Lemma: name Q.E.D. [Modulo: ...] [Cached] (a.k.a. ...)@+printLemmaResult :: SMTConfig -> Bool -> String -> [ProofObj] -> Bool -> [String] -> IO ()+printLemmaResult cfg verboseFlag nm deps cached aka = do+ tab <- startTP cfg verboseFlag "Lemma" 0 (TPProofOneShot nm [])+ finishTP cfg ("Q.E.D." ++ concludeModulo deps ++ cacheStr ++ akaStr) (tab, Nothing) []+ where cacheStr | cached = " [Cached]"+ | True = ""+ akaStr | null aka = ""+ | True = " (a.k.a. " ++ intercalate ", " aka ++ ")"++-- | Calculate the modulo string for dependencies+concludeModulo :: [ProofObj] -> String+concludeModulo by = case foldMap (rootOfTrust . Proof) by of+ RootOfTrust Nothing -> ""+ RootOfTrust (Just ps) -> " [Modulo: " ++ shortProofNames 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 }}++-- | 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 }}+++-- | When proving assumptions for each step, print them as well. Normally, SBV doesn't+-- print assumptions in each proof step, though it does prove them as they are typically trivial.+-- But in certain cases seeing them would be helpful.+tpAsms :: SMTConfig -> SMTConfig+tpAsms cfg = cfg{tpOptions = (tpOptions cfg) { printAsms = True }}++-- | Create a t'MeasureHelper' from a TP proof action. During measure verification,+-- the proof is run to confirm the property holds, and the proven property is extracted+-- and asserted as an axiom in the measure verification session. The solver configuration+-- is inherited from the measure verification context, with output suppressed.+--+-- Example usage with 'Data.SBV.smtFunctionWithMeasure':+--+-- @+-- normalize = smtFunctionWithMeasure "normalize"+-- (\\f -> tuple (ifComplexity f, ifDepth f)+-- , [measureLemma ifDepthNonNeg, measureLemma ifComplexityPos]+-- )+-- $ \\f -> ...+-- @+measureLemma :: forall a. (QuantifiedBool a, Typeable a) => TP (Proof a) -> MeasureHelper+measureLemma tp = MeasureHelper $ \cfg -> do+ proof <- runTPWith (tpQuiet True cfg) tp+ case fromDynamic @a (getProp (proofOf proof)) of+ Just prop -> pure (quantifiedBool prop)+ Nothing -> error "Data.SBV.measureLemma: impossible type mismatch in measure helper"++-- | Like 'measureLemma', but using the given solver configuration, ignoring the+-- one from the measure verification context.+measureLemmaWith :: forall a. (QuantifiedBool a, Typeable a) => SMTConfig -> TP (Proof a) -> MeasureHelper+measureLemmaWith userCfg tp = MeasureHelper $ \_cfg -> do+ proof <- runTPWith (tpQuiet True userCfg) tp+ case fromDynamic @a (getProp (proofOf proof)) of+ Just prop -> pure (quantifiedBool prop)+ Nothing -> error "Data.SBV.measureLemmaWith: impossible type mismatch in measure helper"
Data/SBV/Tools/BMC.hs view
@@ -11,11 +11,12 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Tools.BMC (- bmc, bmcWith+ bmcRefute, bmcRefuteWith, bmcCover, bmcCoverWith ) where import Data.SBV@@ -23,51 +24,96 @@ import Control.Monad (when) --- | Bounded model checking, using the default solver. See "Documentation.SBV.Examples.ProofTools.BMC"--- for an example use case.------ Note that the BMC engine does *not* guarantee that the solution is unique. However, if it does--- find a solution at depth @i@, it is guaranteed that there are no shorter solutions.-bmc :: (EqSymbolic st, Queriable IO st res)+-- | Are we covering or refuting?+data BMCKind = Refute+ | Cover++-- | Refutation using bounded model checking, using the default solver. This version tries to refute the goal+-- in a depth-first fashion. Note that this method can find a refutation, but will never find a "proof."+-- If it finds a refutation, it will be the shortest, though not necessarily unique.+bmcRefute :: (Queriable IO st, res ~ QueryResult st) => Maybe Int -- ^ Optional bound -> Bool -- ^ Verbose: prints iteration count- -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.)+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition- -> (st -> [st]) -- ^ Transition relation+ -> (st -> st -> SBool) -- ^ Transition relation -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate. -> IO (Either String (Int, [res])) -- ^ Either a result, or a satisfying path of given length and intermediate observations.-bmc = bmcWith defaultSMTCfg+bmcRefute = bmcRefuteWith defaultSMTCfg --- | Bounded model checking, configurable with the solver-bmcWith :: (EqSymbolic st, Queriable IO st res)- => SMTConfig- -> Maybe Int- -> Bool- -> Symbolic ()- -> (st -> SBool)- -> (st -> [st])- -> (st -> SBool)+-- | Refutation using a given solver.+bmcRefuteWith :: (Queriable IO st, res ~ QueryResult st)+ => SMTConfig -- ^ Solver to use+ -> Maybe Int -- ^ Optional bound+ -> Bool -- ^ Verbose: prints iteration count+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.)+ -> (st -> SBool) -- ^ Initial condition+ -> (st -> st -> SBool) -- ^ Transition relation+ -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate.+ -> IO (Either String (Int, [res])) -- ^ Either a result, or a satisfying path of given length and intermediate observations.+bmcRefuteWith = bmcWith Refute++-- | Covers using bounded model checking, using the default solver. This version tries to cover the goal+-- in a depth-first fashion. Note that this method can find a cover, but will never find determine that a goal is+-- not coverable. If it finds a cover, it will be the shortest, though not necessarily unique.+bmcCover :: (Queriable IO st, res ~ QueryResult st)+ => Maybe Int -- ^ Optional bound+ -> Bool -- ^ Verbose: prints iteration count+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.)+ -> (st -> SBool) -- ^ Initial condition+ -> (st -> st -> SBool) -- ^ Transition relation+ -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate.+ -> IO (Either String (Int, [res])) -- ^ Either a result, or a satisfying path of given length and intermediate observations.+bmcCover = bmcCoverWith defaultSMTCfg++-- | Cover using a given solver.+bmcCoverWith :: (Queriable IO st, res ~ QueryResult st)+ => SMTConfig -- ^ Solver to use+ -> Maybe Int -- ^ Optional bound+ -> Bool -- ^ Verbose: prints iteration count+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.)+ -> (st -> SBool) -- ^ Initial condition+ -> (st -> st -> SBool) -- ^ Transition relation+ -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate.+ -> IO (Either String (Int, [res])) -- ^ Either a result, or a satisfying path of given length and intermediate observations.+bmcCoverWith = bmcWith Cover++-- | Bounded model checking, configurable with the solver. Not exported; use 'bmcCover', 'bmcRefute' and their "with" variants.+bmcWith :: (Queriable IO st, res ~ QueryResult st)+ => BMCKind -> SMTConfig -> Maybe Int -> Bool -> Symbolic () -> (st -> SBool) -> (st -> st -> SBool) -> (st -> SBool) -> IO (Either String (Int, [res]))-bmcWith cfg mbLimit chatty setup initial trans goal+bmcWith kind cfg mbLimit chatty setup initial trans goal = runSMTWith cfg $ do setup query $ do state <- create constrain $ initial state go 0 state []- where go i _ _+ where (what, badResult, goodResult) = case kind of+ Cover -> ("BMC Cover", "Cover can't be established.", "Satisfying")+ Refute -> ("BMC Refute", "Cannot refute the claim.", "Failing")++ go i _ _ | Just l <- mbLimit, i >= l- = return $ Left $ "BMC limit of " ++ show l ++ " reached"- go i curState sofar = do when chatty $ io $ putStrLn $ "BMC: Iteration: " ++ show i+ = pure $ Left $ what ++ " limit of " ++ show l ++ " reached. " ++ badResult++ go i curState sofar = do when chatty $ io $ putStrLn $ what ++ ": Iteration: " ++ show i+ push 1- constrain $ goal curState++ let g = goal curState+ constrain $ case kind of+ Cover -> g -- Covering the goal+ Refute -> sNot g -- Trying to refute the goal, so satisfy the negation+ cs <- checkSat+ case cs of- DSat{} -> error "BMC: Solver returned an unexpected delta-sat result."- Sat -> do when chatty $ io $ putStrLn $ "BMC: Solution found at iteration " ++ show i+ DSat{} -> error $ what ++ ": Solver returned an unexpected delta-sat result."+ Sat -> do when chatty $ io $ putStrLn $ what ++ ": " ++ goodResult ++ " state found at iteration " ++ show i ms <- mapM project (curState : sofar)- return $ Right (i, reverse ms)- Unk -> do when chatty $ io $ putStrLn $ "BMC: Backend solver said unknown at iteration " ++ show i- return $ Left $ "BMC: Solver said unknown in iteration " ++ show i+ pure $ Right (i, reverse ms)+ Unk -> do when chatty $ io $ putStrLn $ what ++ ": Backend solver said unknown at iteration " ++ show i+ pure $ Left $ what ++ ": Solver said unknown in iteration " ++ show i Unsat -> do pop 1 nextState <- create- constrain $ sAny (nextState .==) (trans curState)+ constrain $ curState `trans` nextState go (i+1) nextState (curState : sofar)
+ Data/SBV/Tools/BVOptimize.hs view
@@ -0,0 +1,126 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SBV.Tools.BVOptimize+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Bit-vector optimization based on linear scan of the bits. The optimization+-- engines are usually not incremental, and they perform poorly for optimizing+-- bit-vector values in the presence of complicated constraints. We implement+-- a simple optimizer by scanning the bits from top-to-bottom to minimize/maximize+-- unsigned bit vector quantities, using the regular (i.e., incremental) solver.+-- This can lead to better performance for this class of problems.+--+-- This implementation is based on an idea by Nikolaj Bjorner, see <https://github.com/Z3Prover/z3/issues/7156>.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Tools.BVOptimize (+ -- ** Maximizing bit-vectors+ -- $maxBVEx+ maxBV, maxBVWith+ -- ** Minimizing bit-vectors+ -- $minBVEx+ , minBV, minBVWith+ ) where++import Control.Monad++import Data.SBV+import Data.SBV.Control++#ifdef DOCTEST+-- $setup+-- >>> :set -XDataKinds+-- >>> import Data.SBV+#endif++{- $maxBVEx++Here is a simple example of maximizing a bit-vector value:++>>> :{+runSMT $ do x :: SWord 32 <- free "x"+ constrain $ x .> 5+ constrain $ x .< 27+ maxBV False x+:}+Satisfiable. Model:+ x = 26 :: Word32+-}++-- | Maximize the value of an unsigned bit-vector value, using the default solver.+maxBV :: SFiniteBits a+ => Bool -- ^ Do we want unsat-cores if unsatisfiable?+ -> SBV a -- ^ Value to maximize+ -> Symbolic SatResult+maxBV = maxBVWith defaultSMTCfg++-- | Maximize the value of an unsigned bit-vector value, using the given solver.+maxBVWith :: SFiniteBits a => SMTConfig -> Bool-> SBV a -> Symbolic SatResult+maxBVWith = minMaxBV True++{- $minBVEx++Here is a simple example of minimizing a bit-vector value:++>>> :{+runSMT $ do x :: SWord 32 <- free "x"+ constrain $ x .> 5+ constrain $ x .< 27+ minBV False x+:}+Satisfiable. Model:+ x = 6 :: Word32+-}++-- | Minimize the value of an unsigned bit-vector value, using the default solver.+minBV :: SFiniteBits a+ => Bool -- ^ Do we want unsat-cores if unsatisfiable?+ -> SBV a -- ^ Value to minimize+ -> Symbolic SatResult+minBV = minBVWith defaultSMTCfg++-- | Minimize the value of an unsigned bit-vector value, using the given solver.+minBVWith :: SFiniteBits a => SMTConfig -> Bool-> SBV a -> Symbolic SatResult+minBVWith = minMaxBV False++-- | min/max a given unsigned bit-vector. We walk down the bits in an incremental+-- fashion. If we are maximizing, we try to make the bits set as we go down, otherwise+-- we try to unset them. We keep adding the constraints so long as they are satisfiable,+-- and at the end, get the optimal value produced.+minMaxBV :: SFiniteBits a => Bool -> SMTConfig -> Bool -> SBV a -> Symbolic SatResult+minMaxBV isMax cfg getUC v+ | hasSign v+ = error $ "minMaxBV works on unsigned bit-vectors, received: " ++ show (kindOf v)+ | True+ = do when getUC $ setOption $ ProduceUnsatCores True+ query $ go (blastBE v)+ where uc | getUC = Just <$> getUnsatCore+ | True = pure Nothing++ rSat = SatResult . Satisfiable cfg <$> getModel+ rUnk = SatResult . Unknown cfg <$> getUnknownReason+ rUnsat = SatResult . Unsatisfiable cfg <$> uc++ go :: [SBool] -> Query SatResult+ go [] = do r <- checkSat+ case r of+ Sat -> rSat+ Unsat -> rUnsat+ Unk -> rUnk+ DSat {} -> error "minMaxBV: Unexpected DSat result"+ go (b:bs) = do push 1+ if isMax then constrain b+ else constrain $ sNot b+ r <- checkSat+ case r of+ Sat -> go bs >>= \res -> pop 1 >> pure res+ Unsat -> pop 1 >> go bs+ Unk -> pop 1 >> rUnk+ DSat{} -> error "minMaxBV: Unexpected DSat result"
− Data/SBV/Tools/BoundedFix.hs
@@ -1,88 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.SBV.Tools.BoundedFix--- Copyright : (c) Levent Erkok--- License : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Bounded fixed-point unrolling.--------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.Tools.BoundedFix (- bfix- ) where--import Data.SBV---- $setup--- >>> import Data.SBV--- >>> -- For doctest purposes only:--- >>> bfac = bfix 10 "fac" fact where fact f n = ite (n .== 0) 1 ((n :: SInteger) * f (n-1))---- | Bounded fixed-point operation. The call @bfix bnd nm f@ unrolls the recursion in @f@ at most--- @bnd@ times, and uninterprets the function (with the name @nm@) after the bound is reached.------ This combinator is handy for dealing with recursive definitions that are not symbolically terminating--- and when the property we are interested in does not require an infinite unrolling, or when we are happy--- with a bounded proof. In particular, this operator can be used as a basis of software-bounded model--- checking algorithms built on top of SBV. The bound can be successively refined in a CEGAR like loop--- as necessary, by analyzing the counter-examples and rejecting them if they are false-negatives.------ For instance, we can define the factorial function using the bounded fixed-point operator like this:------ @--- bfac :: SInteger -> SInteger--- bfac = bfix 10 "fac" fact--- where fact f n = ite (n .== 0) 1 (n * f (n-1))--- @------ This definition unrolls the recursion in factorial at most 10 times before uninterpreting the result.--- We can now prove:------ >>> prove $ \n -> n .>= 1 .&& n .<= 9 .=> bfac n .== n * bfac (n-1)--- Q.E.D.------ And we would get a bogus counter-example if the proof of our property needs a larger bound:------ >>> prove $ \n -> n .== 10 .=> bfac n .== 3628800--- Falsifiable. Counter-example:--- s0 = 10 :: Integer--- <BLANKLINE>--- fac :: Integer -> Integer--- fac _ = 2------ The counter-example is telling us how it instantiated the function @fac@ when the recursion--- bottomed out: It simply made it return @2@ for all arguments at that point, which provides--- the (unintended) counter-example.------ By design, if a function defined via `bfix` is given a concrete argument, it will unroll--- the recursion as much as necessary to complete the call (which can of course diverge). The bound--- only applies if the given argument is symbolic. This fact can be used to observe concrete--- values to see where the bounded-model-checking approach fails:------ >>> prove $ \n -> n .== 10 .=> observe "bfac_n" (bfac n) .== observe "bfac_10" (bfac 10)--- Falsifiable. Counter-example:--- bfac_10 = 3628800 :: Integer--- bfac_n = 7257600 :: Integer--- s0 = 10 :: Integer--- <BLANKLINE>--- fac :: Integer -> Integer--- fac _ = 2------ Here, we see further evidence that the SMT solver must have decided to assign the--- value @2@ in the final call just as it was reaching the base case, and thus got the--- final result incorrect. (Note that @7257600 = 2 * 3628800@.) A wrapper algorithm can--- then assert the actual value of @bfac 10@ here as an extra constraint and can--- search for "deeper bugs."-bfix :: (SymVal a, Uninterpreted (SBV a -> r)) => Int -> String -> ((SBV a -> r) -> (SBV a -> r)) -> SBV a -> r-bfix bound nm f x- | isConcrete x = g x- | True = unroll bound x- where g = f g- unroll 0 = uninterpret nm- unroll i = f (unroll (i-1))
− Data/SBV/Tools/BoundedList.hs
@@ -1,149 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.SBV.Tools.BoundedList--- Copyright : (c) Levent Erkok--- License : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ A collection of bounded list utilities, useful when working with symbolic lists.--- These functions all take a concrete bound, and operate on the prefix of a symbolic--- list that is at most that long. Due to limitations on writing recursive functions--- over lists (the classic symbolic termination problem), we cannot write arbitrary--- recursive programs on symbolic lists. But most of the time all we need is a--- bounded prefix of this list, at which point these functions come in handy.--------------------------------------------------------------------------------{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Data.SBV.Tools.BoundedList (- -- * General folds- bfoldr, bfoldrM, bfoldl, bfoldlM- -- * Map, filter, zipWith, elem- , bmap, bmapM, bfilter, bzipWith, belem- -- * Aggregates- , bsum, bprod, band, bor, bany, ball, bmaximum, bminimum- -- * Miscellaneous: Reverse and sort- , breverse, bsort- )- where--import Prelude hiding ((++))--import Data.SBV-import Data.SBV.List ((.:), (++))-import qualified Data.SBV.List as L---- | Case analysis on a symbolic list. (Not exported.)-lcase :: (SymVal a, Mergeable b) => SList a -> b -> (SBV a -> SList a -> b) -> b-lcase s e c = ite (L.null s) e (c (L.head s) (L.tail s))---- | Bounded fold from the right.-bfoldr :: (SymVal a, SymVal b) => Int -> (SBV a -> SBV b -> SBV b) -> SBV b -> SList a -> SBV b-bfoldr cnt f b = go (cnt `max` 0)- where go 0 _ = b- go i s = lcase s b (\h t -> h `f` go (i-1) t)---- | Bounded monadic fold from the right.-bfoldrM :: forall a b m. (SymVal a, SymVal b, Monad m, Mergeable (m (SBV b)))- => Int -> (SBV a -> SBV b -> m (SBV b)) -> SBV b -> SList a -> m (SBV b)-bfoldrM cnt f b = go (cnt `max` 0)- where go :: Int -> SList a -> m (SBV b)- go 0 _ = return b- go i s = lcase s (return b) (\h t -> f h =<< go (i-1) t)---- | Bounded fold from the left.-bfoldl :: (SymVal a, SymVal b) => Int -> (SBV b -> SBV a -> SBV b) -> SBV b -> SList a -> SBV b-bfoldl cnt f = go (cnt `max` 0)- where go 0 b _ = b- go i b s = lcase s b (\h t -> go (i-1) (b `f` h) t)---- | Bounded monadic fold from the left.-bfoldlM :: forall a b m. (SymVal a, SymVal b, Monad m, Mergeable (m (SBV b)))- => Int -> (SBV b -> SBV a -> m (SBV b)) -> SBV b -> SList a -> m (SBV b)-bfoldlM cnt f = go (cnt `max` 0)- where go :: Int -> SBV b -> SList a -> m (SBV b)- go 0 b _ = return b- go i b s = lcase s (return b) (\h t -> do { fbh <- f b h; go (i-1) fbh t })---- | Bounded sum.-bsum :: (SymVal a, Num a, Ord a) => Int -> SList a -> SBV a-bsum i = bfoldl i (+) 0---- | Bounded product.-bprod :: (SymVal a, Num a, Ord a) => Int -> SList a -> SBV a-bprod i = bfoldl i (*) 1---- | Bounded map.-bmap :: (SymVal a, SymVal b) => Int -> (SBV a -> SBV b) -> SList a -> SList b-bmap i f = bfoldr i (\x -> (f x .:)) []---- | Bounded monadic map.-bmapM :: (SymVal a, SymVal b, Monad m, Mergeable (m (SBV [b])))- => Int -> (SBV a -> m (SBV b)) -> SList a -> m (SList b)-bmapM i f = bfoldrM i (\a bs -> (.:) <$> f a <*> pure bs) []---- | Bounded filter.-bfilter :: SymVal a => Int -> (SBV a -> SBool) -> SList a -> SList a-bfilter i f = bfoldr i (\x y -> ite (f x) (x .: y) y) []---- | Bounded logical and-band :: Int -> SList Bool -> SBool-band i = bfoldr i (.&&) (sTrue :: SBool)---- | Bounded logical or-bor :: Int -> SList Bool -> SBool-bor i = bfoldr i (.||) (sFalse :: SBool)---- | Bounded any-bany :: SymVal a => Int -> (SBV a -> SBool) -> SList a -> SBool-bany i f = bor i . bmap i f---- | Bounded all-ball :: SymVal a => Int -> (SBV a -> SBool) -> SList a -> SBool-ball i f = band i . bmap i f---- | Bounded maximum. Undefined if list is empty.-bmaximum :: (Ord a, SymVal a) => Int -> SList a -> SBV a-bmaximum i l = bfoldl (i-1) smax (L.head l) (L.tail l)---- | Bounded minimum. Undefined if list is empty.-bminimum :: (Ord a, SymVal a) => Int -> SList a -> SBV a-bminimum i l = bfoldl (i-1) smin (L.head l) (L.tail l)---- | Bounded zipWith-bzipWith :: (SymVal a, SymVal b, SymVal c) => Int -> (SBV a -> SBV b -> SBV c) -> SList a -> SList b -> SList c-bzipWith cnt f = go (cnt `max` 0)- where go 0 _ _ = []- go i xs ys = ite (L.null xs .|| L.null ys)- []- (f (L.head xs) (L.head ys) .: go (i-1) (L.tail xs) (L.tail ys))---- | Bounded element check-belem :: (Eq a, SymVal a) => Int -> SBV a -> SList a -> SBool-belem i e = bany i (e .==)---- | Bounded reverse-breverse :: SymVal a => Int -> SList a -> SList a-breverse cnt = bfoldr cnt (\a b -> b ++ L.singleton a) []---- | Bounded paramorphism (not exported).-bpara :: (SymVal a, SymVal b) => Int -> (SBV a -> SBV [a] -> SBV b -> SBV b) -> SBV b -> SList a -> SBV b-bpara cnt f b = go (cnt `max` 0)- where go 0 _ = b- go i s = lcase s b (\h t -> f h t (go (i-1) t))---- | Insert an element into a sorted list (not exported).-binsert :: (Ord a, SymVal a) => Int -> SBV a -> SList a -> SList a-binsert cnt a = bpara cnt f (L.singleton a)- where f sortedHd sortedTl sortedTl' = ite (a .< sortedHd)- (a .: sortedHd .: sortedTl)- (sortedHd .: sortedTl')---- | Bounded insertion sort-bsort :: (Ord a, SymVal a) => Int -> SList a -> SList a-bsort cnt = bfoldr cnt (binsert cnt) []
Data/SBV/Tools/CodeGen.hs view
@@ -18,7 +18,7 @@ SBVCodeGen, cgSym -- ** Setting code-generation options- , cgPerformRTCs, cgSetDriverValues, cgGenerateDriver, cgGenerateMakefile, cgOverwriteFiles, cgShowU8UsingHex + , cgPerformRTCs, cgSetDriverValues, cgGenerateDriver, cgGenerateMakefile, cgOverwriteFiles, cgShowU8UsingHex -- ** Designating inputs , cgInput, cgInputArr
Data/SBV/Tools/GenTest.hs view
@@ -9,23 +9,27 @@ -- Test generation from symbolic programs ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Tools.GenTest ( -- * Test case generation genTest, TestVectors, getTestValues, renderTest, TestStyle(..) ) where +import Control.Monad (unless)+ import Data.Bits (testBit) import Data.Char (isAlpha, toUpper) import Data.Function (on) import Data.List (intercalate, groupBy) import Data.Maybe (fromMaybe)+import qualified Data.Text as T import Data.SBV.Core.AlgReals import Data.SBV.Core.Data import Data.SBV.Utils.PrettyNum+import Data.SBV.Provers.Prover(defaultSMTCfg) import qualified Data.Foldable as F (toList) @@ -45,14 +49,15 @@ genTest :: Outputtable a => Int -> Symbolic a -> IO TestVectors genTest n m = gen 0 [] where gen i sofar- | i == n = return $ TV $ reverse sofar+ | i == n = pure $ TV $ reverse sofar | True = do t <- tc gen (i+1) (t:sofar)- tc = do (_, Result {resTraces=tvals, resConsts=(_, cs), resConstraints=cstrs, resOutputs=os}) <- runSymbolic (Concrete Nothing) (m >>= output)- let cval = fromMaybe (error "Cannot generate tests in the presence of uninterpeted constants!") . (`lookup` cs)+ tc = do (_, Result {resTraces=tvals, resConsts=(_, cs), resDefinitions=definitions, resConstraints=cstrs, resOutputs=os}) <- runSymbolic defaultSMTCfg (Concrete Nothing) (m >>= output)+ let cval = fromMaybe (error "Cannot generate tests in the presence of uninterpreted constants!") . (`lookup` cs) cond = and [cvToBool (cval v) | (False, _, v) <- F.toList cstrs] -- Only pick-up "hard" constraints, as indicated by False in the fist component+ unless (null definitions) $ error "Cannot generate tests in the presence of 'smtFunction' calls!" if cond- then return (map snd tvals, map cval os)+ then pure (map snd tvals, map cval os) else tc -- try again, with the same set of constraints -- | Test output style@@ -78,9 +83,11 @@ ++ [ n ++ " :: " ++ getType vs , n ++ " = [ " ++ intercalate ("\n" ++ pad ++ ", ") (map mkLine vs), pad ++ "]" ]- where n | null vname = "testVectors"- | not (isAlpha (head vname)) = "tv" ++ vname- | True = vname+ where n = case vname of+ "" -> "testVectors"+ f:_ | not (isAlpha f) -> "tv" ++ vname+ | True -> vname+ imports | null vs = [] | needsInt && needsWord = ["import Data.Int", "import Data.Word", ""]@@ -88,8 +95,7 @@ | needsWord = ["import Data.Word", ""] | needsRatio = ["import Data.Ratio"] | True = []- where ((is, os):_) = vs- params = is ++ os+ where params = case vs of { (is, os):_ -> is ++ os; _ -> error "SBV.renderTest: impossible, empty test vectors" } needsInt = any isSW params needsWord = any isUW params needsRatio = any isR params@@ -102,7 +108,9 @@ isUW cv = case kindOf cv of KBounded False sz -> sz > 1 _ -> False- modName = let (f:r) = n in toUpper f : r+ modName = case n of+ f:r -> toUpper f : r+ _ -> error "SBV.renderTest: impossible, empty module name" pad = replicate (length n + 3) ' ' getType [] = "[a]" getType ((i, o):_) = "[(" ++ mapType typeOf i ++ ", " ++ mapType typeOf o ++ ")]"@@ -135,26 +143,27 @@ KReal -> error $ "SBV.renderTest: Unsupported real valued test value: " ++ show cv KList es -> error $ "SBV.renderTest: Unsupported list valued test: [" ++ show es ++ "]" KSet es -> error $ "SBV.renderTest: Unsupported set valued test: {" ++ show es ++ "}"- KUserSort us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us _ -> error $ "SBV.renderTest: Unexpected CV: " ++ show cv s cv = case kindOf cv of+ KVar{} -> error $ "SBV.renderTest: Unexpected: " ++ show (kindOf cv) KBool -> take 5 (show (cvToBool cv) ++ repeat ' ')- KBounded sgn sz -> let CInteger w = cvVal cv in shex False True (sgn, sz) w- KUnbounded -> let CInteger w = cvVal cv in shexI False True w- KFloat -> let CFloat w = cvVal cv in showHFloat w- KDouble -> let CDouble w = cvVal cv in showHDouble w+ KBounded sgn sz -> case cvVal cv of { CInteger w -> T.unpack $ shex False True (sgn, sz) w; r -> bad r }+ KUnbounded -> case cvVal cv of { CInteger w -> T.unpack $ shexI False True w; r -> bad r }+ KFloat -> case cvVal cv of { CFloat w -> showHFloat w; r -> bad r }+ KDouble -> case cvVal cv of { CDouble w -> showHDouble w; r -> bad r } KRational -> error "SBV.renderTest: Unsupported rational number" KFP{} -> error "SBV.renderTest: Unsupported arbitrary float" KChar -> error "SBV.renderTest: Unsupported char" KString -> error "SBV.renderTest: Unsupported string"- KReal -> let CAlgReal w = cvVal cv in algRealToHaskell w+ KReal -> case cvVal cv of { CAlgReal w -> algRealToHaskell w; r -> bad r } KList es -> error $ "SBV.renderTest: Unsupported list valued sort: [" ++ show es ++ "]" KSet es -> error $ "SBV.renderTest: Unsupported set valued sort: {" ++ show es ++ "}"- KUserSort us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us- k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple: " ++ show k- k@KMaybe{} -> error $ "SBV.renderTest: Unsupported maybe: " ++ show k- k@KEither{} -> error $ "SBV.renderTest: Unsupported sum: " ++ show k+ k@KApp{} -> error $ "SBV.renderTest: Unsupported adt app: " ++ show k+ k@KADT{} -> error $ "SBV.renderTest: Unsupported adt: " ++ show k+ k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple: " ++ show k+ k@KArray{} -> error $ "SBV.renderTest: Unsupported array: " ++ show k+ where bad _ = error $ "SBV.renderTest: Unexpected CVal for kind: " ++ show (kindOf cv) c :: String -> [([CV], [CV])] -> String c n vs = intercalate "\n" $@@ -191,11 +200,15 @@ , "typedef struct {" , " struct {" ]- ++ (if null vs then [] else zipWith (mkField "i") (fst (head vs)) [(0::Int)..])+ ++ (case vs of+ [] -> []+ (i, _):_ -> zipWith (mkField "i") i [(0::Int)..]) ++ [ " } input;" , " struct {" ]- ++ (if null vs then [] else zipWith (mkField "o") (snd (head vs)) [(0::Int)..])+ ++ (case vs of+ [] -> []+ (_, o):_ -> zipWith (mkField "o") o [(0::Int)..]) ++ [ " } output;" , "} " ++ n ++ "TestVector;" , ""@@ -220,6 +233,7 @@ ] where mkField p cv i = " " ++ t ++ " " ++ p ++ show i ++ ";" where t = case kindOf cv of+ KVar{} -> error $ "SBV.renderTest: Unexpected: " ++ show (kindOf cv) KBool -> "SBool" KBounded False 8 -> "SWord8" KBounded False 16 -> "SWord16"@@ -238,40 +252,44 @@ KString -> error "SBV.renderTest: Unsupported string" KUnbounded -> error "SBV.renderTest: Unbounded integers are not supported when generating C test-cases." KReal -> error "SBV.renderTest: Real values are not supported when generating C test-cases."- KUserSort us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us+ k@KApp{} -> error $ "SBV.renderTest: Unsupported adt app: " ++ show k+ k@KADT{} -> error $ "SBV.renderTest: Unsupported adt: " ++ show k k@KList{} -> error $ "SBV.renderTest: Unsupported list sort: " ++ show k- k@KSet{} -> error $ "SBV.renderTest: Unsupported set sort: " ++ show k+ k@KSet{} -> error $ "SBV.renderTest: Unsupported set sort: " ++ show k k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple sort: " ++ show k- k@KMaybe{} -> error $ "SBV.renderTest: Unsupported maybe sort: " ++ show k- k@KEither{} -> error $ "SBV.renderTest: Unsupported either sort: " ++ show k-+ k@KArray{} -> error $ "SBV.renderTest: Unsupported array sort: " ++ show k mkLine (is, os) = "{{" ++ intercalate ", " (map v is) ++ "}, {" ++ intercalate ", " (map v os) ++ "}}" v cv = case kindOf cv of- KBool -> if cvToBool cv then "true " else "false"- KBounded sgn sz -> let CInteger w = cvVal cv in chex False True (sgn, sz) w- KUnbounded -> let CInteger w = cvVal cv in shexI False True w- KFloat -> let CFloat w = cvVal cv in showCFloat w- KDouble -> let CDouble w = cvVal cv in showCDouble w- KRational -> error "SBV.renderTest: Unsupported rational number"- KFP{} -> error "SBV.renderTest: Unsupported arbitrary float"- KChar -> error "SBV.renderTest: Unsupported char"- KString -> error "SBV.renderTest: Unsupported string"- k@KList{} -> error $ "SBV.renderTest: Unsupported list sort!" ++ show k- k@KSet{} -> error $ "SBV.renderTest: Unsupported set sort!" ++ show k- KUserSort us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us- KReal -> error "SBV.renderTest: Real values are not supported when generating C test-cases."- k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple sort!" ++ show k- k@KMaybe{} -> error $ "SBV.renderTest: Unsupported maybe sort!" ++ show k- k@KEither{} -> error $ "SBV.renderTest: Unsupported sum sort!" ++ show k+ KVar{} -> error $ "SBV.renderTest: Unexpected: " ++ show (kindOf cv)+ KBool -> if cvToBool cv then "true " else "false"+ KBounded sgn sz -> case cvVal cv of { CInteger w -> T.unpack $ chex False True (sgn, sz) w; r -> bad r }+ KUnbounded -> case cvVal cv of { CInteger w -> T.unpack $ shexI False True w; r -> bad r }+ KFloat -> case cvVal cv of { CFloat w -> showCFloat w; r -> bad r }+ KDouble -> case cvVal cv of { CDouble w -> showCDouble w; r -> bad r }+ KRational -> error "SBV.renderTest: Unsupported rational number"+ KFP{} -> error "SBV.renderTest: Unsupported arbitrary float"+ KChar -> error "SBV.renderTest: Unsupported char"+ KString -> error "SBV.renderTest: Unsupported string"+ KReal -> error "SBV.renderTest: Real values are not supported when generating C test-cases."+ k@KList{} -> error $ "SBV.renderTest: Unsupported list sort!" ++ show k+ k@KSet{} -> error $ "SBV.renderTest: Unsupported set sort!" ++ show k+ k@KApp{} -> error $ "SBV.renderTest: Unsupported adt app: " ++ show k+ k@KADT{} -> error $ "SBV.renderTest: Unsupported adt: " ++ show k+ k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple sort: " ++ show k+ k@KArray{} -> error $ "SBV.renderTest: Unsupported sum sort: " ++ show k+ where bad _ = error $ "SBV.renderTest: Unexpected CVal for kind: " ++ show (kindOf cv) outLine | null vs = "printf(\"\");" | True = "printf(\"%*d. " ++ fmtString ++ "\\n\", " ++ show (length (show (length vs - 1))) ++ ", i" ++ concatMap ("\n , " ++ ) (zipWith inp is [(0::Int)..] ++ zipWith out os [(0::Int)..]) ++ ");"- where (is, os) = head vs+ where (is, os) = case vs of+ h:_ -> h+ _ -> error "outLine: Impossible hapepned, empty vs!"+ inp cv i = mkBool cv (n ++ "[i].input.i" ++ show i) out cv i = mkBool cv (n ++ "[i].output.o" ++ show i) mkBool cv s = case kindOf cv of@@ -305,14 +323,18 @@ ++ [ " in [ " ++ intercalate "\n , " (map mkLine vs) , " ];" ]- where n | null vname = "testVectors"- | not (isAlpha (head vname)) = "tv" ++ vname- | True = vname+ where n = case vname of+ "" -> "testVectors"+ f:_ | not (isAlpha f) -> "tv" ++ vname+ | True -> vname+ blaster | bigEndian = "map (\\s. s == \"1\") (explode (string_tl r))" | True = "rev (map (\\s. s == \"1\") (explode (string_tl r)))"+ toF True = '1' toF False = '0'+ blast cv = let noForte w = error "SBV.renderTest: " ++ w ++ " values are not supported when generating Forte test-cases." in case kindOf cv of KBool -> [toF (cvToBool cv)]@@ -332,7 +354,6 @@ KList ek -> noForte $ "List of " ++ show ek KSet ek -> noForte $ "Set of " ++ show ek KUnbounded -> noForte "Unbounded integers"- KUserSort s _ -> noForte $ "Uninterpreted kind " ++ show s _ -> error $ "SBV.renderTest: Unexpected CV: " ++ show cv xlt s (CInteger v) = [toF (testBit v i) | i <- [s-1, s-2 .. 0]]@@ -343,12 +364,11 @@ xlt _ (CChar r) = error $ "SBV.renderTest.Forte: Unexpected char value: " ++ show r xlt _ (CString r) = error $ "SBV.renderTest.Forte: Unexpected string value: " ++ show r xlt _ (CAlgReal r) = error $ "SBV.renderTest.Forte: Unexpected real value: " ++ show r+ xlt _ (CADT (k, _)) = error $ "SBV.renderTest.Forte: Unexpected ADT value: " ++ show k xlt _ CList{} = error "SBV.renderTest.Forte: Unexpected list value!" xlt _ CSet{} = error "SBV.renderTest.Forte: Unexpected set value!" xlt _ CTuple{} = error "SBV.renderTest.Forte: Unexpected list value!"- xlt _ CMaybe{} = error "SBV.renderTest.Forte: Unexpected maybe value!"- xlt _ CEither{} = error "SBV.renderTest.Forte: Unexpected sum value!"- xlt _ (CUserSort r) = error $ "SBV.renderTest.Forte: Unexpected uninterpreted value: " ++ show r+ xlt _ CArray{} = error "SBV.renderTest.Forte: Unexpected array value!" mkLine (i, o) = "(" ++ mkTuple (form (fst ss) (concatMap blast i)) ++ ", " ++ mkTuple (form (snd ss) (concatMap blast o)) ++ ")" mkTuple [] = "()"@@ -358,9 +378,9 @@ form [] bs = error $ "SBV.renderTest: Mismatched index in stream, extra " ++ show (length bs) ++ " bit(s) remain." form (i:is) bs | length bs < i = error $ "SBV.renderTest: Mismatched index in stream, was looking for " ++ show i ++ " bit(s), but only " ++ show bs ++ " remains."- | i == 1 = let b:r = bs- v = if b == '1' then "T" else "F"- in v : form is r+ | i == 1 = case bs of+ b:r -> (if b == '1' then "T" else "F") : form is r+ _ -> error "SBV.renderTest: impossible, empty bit stream" | True = let (f, r) = splitAt i bs v = "c \"" ++ show i ++ "'b" ++ f ++ "\"" in v : form is r
Data/SBV/Tools/Induction.hs view
@@ -20,6 +20,8 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -67,7 +69,7 @@ -- * A 'Failed' result in a 'PartialCorrectness' step means that the invariant holds, but assuming the -- termination condition the goal still does not follow. That is, the partial correctness -- does not hold.-data InductionResult a = Failed InductionStep a+data InductionResult a = Failed InductionStep (a, a) | Proven -- | Show instance for 'InductionResult', diagnostic purposes only.@@ -80,11 +82,11 @@ -- | Induction engine, using the default solver. See "Documentation.SBV.Examples.ProofTools.Strengthen" -- and "Documentation.SBV.Examples.ProofTools.Sum" for examples.-induct :: (Show res, Queriable IO st res)+induct :: (Show res, Queriable IO st, res ~ QueryResult st) => Bool -- ^ Verbose mode- -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.)+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition- -> (st -> [st]) -- ^ Transition relation+ -> (st -> st -> SBool) -- ^ Transition relation -> [(String, st -> SBool)] -- ^ Strengthenings, if any. The @String@ is a simple tag. -> (st -> SBool) -- ^ Invariant that ensures the goal upon termination -> (st -> (SBool, SBool)) -- ^ Termination condition and the goal to establish@@ -92,57 +94,61 @@ induct = inductWith defaultSMTCfg -- | Induction engine, configurable with the solver-inductWith :: (Show res, Queriable IO st res)+inductWith :: (Show res, Queriable IO st, res ~ QueryResult st) => SMTConfig -> Bool -> Symbolic () -> (st -> SBool)- -> (st -> [st])+ -> (st -> st -> SBool) -> [(String, st -> SBool)] -> (st -> SBool) -> (st -> (SBool, SBool)) -> IO (InductionResult res) inductWith cfg chatty setup initial trans strengthenings inv goal = try "Proving initiation"- (\s -> initial s .=> inv s)+ (\s _ -> initial s .=> inv s) (Failed (Initiation Nothing)) $ strengthen strengthenings $ try "Proving consecution"- (\s -> sAnd (inv s : [st s | (_, st) <- strengthenings]) .=> sAll inv (trans s))+ (\s s' -> sAnd (inv s : s `trans` s' : [st s | (_, st) <- strengthenings]) .=> inv s') (Failed (Consecution Nothing)) $ try "Proving partial correctness"- (\s -> let (term, result) = goal s in inv s .&& term .=> result)+ (\s _ -> let (term, result) = goal s in inv s .&& term .=> result) (Failed PartialCorrectness)- (msg "Done" >> return Proven)+ (msg "Done" >> pure Proven) where msg = when chatty . putStrLn try m p wrap cont = do msg m res <- check p case res of- Just ex -> return $ wrap ex+ Just ex -> pure $ wrap ex Nothing -> cont check p = runSMTWith cfg $ do setup- query $ do st <- create- constrain $ sNot (p st)+ query $ do s <- create+ s' <- create+ constrain $ sNot (p s s') cs <- checkSat case cs of Unk -> error "Solver said unknown" DSat{} -> error "Solver returned a delta-sat result"- Unsat -> return Nothing- Sat -> do io $ msg "Failed:"- ex <- project st- io $ msg $ show ex- return $ Just ex+ Unsat -> pure Nothing+ Sat -> do io $ msg "Failed in state:"+ exS <- project s+ io $ msg $ show exS+ io $ msg "Transitioning to:"+ exS' <- project s'+ io $ msg $ show exS'+ pure $ Just (exS, exS') strengthen [] cont = cont strengthen ((nm, st):sts) cont = try ("Proving strengthening initiation : " ++ nm)- (\s -> initial s .=> st s)+ (\s _ -> initial s .=> st s) (Failed (Initiation (Just nm))) $ try ("Proving strengthening consecution: " ++ nm)- (\s -> st s .=> sAll st (trans s))+ (\s s' -> sAnd [st s, s `trans` s'] .=> st s') (Failed (Consecution (Just nm))) (strengthen sts cont)
Data/SBV/Tools/Overflow.hs view
@@ -10,32 +10,33 @@ -- Based on: <http://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/z3prefix.pdf> ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Tools.Overflow (- -- * Arithmetic overflows ArithOverflow(..), CheckedArithmetic(..) - -- * Cast overflows- , sFromIntegralO, sFromIntegralChecked+ -- * Fast-checking of signed-multiplication overflow+ , signedMulOverflow + -- * Cast overflows+ , sFromIntegralO, sFromIntegralChecked ) where import Data.SBV.Core.Data import Data.SBV.Core.Kind-import Data.SBV.Core.Symbolic import Data.SBV.Core.Model import Data.SBV.Core.Operations-import Data.SBV.Core.Sized import GHC.TypeLits @@ -45,71 +46,63 @@ import Data.Word import Data.Proxy +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif --- | Detecting underflow/overflow conditions. For each function,--- the first result is the condition under which the computation--- underflows, and the second is the condition under which it--- overflows.+-- | Detecting overflow. Each function here will return 'sTrue' if the result will not fit in the target+-- type, i.e., if it overflows or underflows. class ArithOverflow a where -- | Bit-vector addition. Unsigned addition can only overflow. Signed addition can underflow and overflow. -- -- A tell tale sign of unsigned addition overflow is when the sum is less than minimum of the arguments. --- -- >>> prove $ \x y -> snd (bvAddO x (y::SWord16)) .<=> x + y .< x `smin` y+ -- >>> prove $ \x y -> bvAddO x (y::SWord16) .<=> x + y .< x `smin` y -- Q.E.D.- bvAddO :: a -> a -> (SBool, SBool)+ bvAddO :: a -> a -> SBool -- | Bit-vector subtraction. Unsigned subtraction can only underflow. Signed subtraction can underflow and overflow.- bvSubO :: a -> a -> (SBool, SBool)+ bvSubO :: a -> a -> SBool -- | Bit-vector multiplication. Unsigned multiplication can only overflow. Signed multiplication can underflow and overflow.- bvMulO :: a -> a -> (SBool, SBool)-- -- | Same as 'bvMulO', except instead of doing the computation internally, it simply sends it off to z3 as a primitive.- -- Obviously, only use if you have the z3 backend! Note that z3 provides this operation only when no logic is set,- -- so make sure to call @setLogic Logic_NONE@ in your program!- bvMulOFast :: a -> a -> (SBool, SBool)+ bvMulO :: a -> a -> SBool -- | Bit-vector division. Unsigned division neither underflows nor overflows. Signed division can only overflow. In fact, for each -- signed bitvector type, there's precisely one pair that overflows, when @x@ is @minBound@ and @y@ is @-1@: --- -- >>> allSat $ \x y -> snd (x `bvDivO` (y::SInt8))+ -- >>> allSat $ \x y -> x `bvDivO` (y::SInt8) -- Solution #1: -- s0 = -128 :: Int8 -- s1 = -1 :: Int8 -- This is the only solution.-- bvDivO :: a -> a -> (SBool, SBool)+ bvDivO :: a -> a -> SBool -- | Bit-vector negation. Unsigned negation neither underflows nor overflows. Signed negation can only overflow, when the argument is -- @minBound@: --- -- >>> prove $ \x -> x .== minBound .<=> snd (bvNegO (x::SInt16))+ -- >>> prove $ \x -> x .== minBound .<=> bvNegO (x::SInt16) -- Q.E.D.- bvNegO :: a -> (SBool, SBool)+ bvNegO :: a -> SBool -instance ArithOverflow SWord8 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}-instance ArithOverflow SWord16 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}-instance ArithOverflow SWord32 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}-instance ArithOverflow SWord64 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}-instance ArithOverflow SInt8 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}-instance ArithOverflow SInt16 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}-instance ArithOverflow SInt32 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}-instance ArithOverflow SInt64 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance ArithOverflow SWord8 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance ArithOverflow SWord16 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance ArithOverflow SWord32 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance ArithOverflow SWord64 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance ArithOverflow SInt8 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance ArithOverflow SInt16 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance ArithOverflow SInt32 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance ArithOverflow SInt64 where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO} -instance (KnownNat n, BVIsNonZero n) => ArithOverflow (SWord n) where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}-instance (KnownNat n, BVIsNonZero n) => ArithOverflow (SInt n) where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvMulOFast = l2 bvMulOFast; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance (KnownNat n, BVIsNonZero n) => ArithOverflow (SWord n) where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO}+instance (KnownNat n, BVIsNonZero n) => ArithOverflow (SInt n) where {bvAddO = l2 bvAddO; bvSubO = l2 bvSubO; bvMulO = l2 bvMulO; bvDivO = l2 bvDivO; bvNegO = l1 bvNegO} instance ArithOverflow SVal where- bvAddO = signPick2 bvuaddo bvsaddo- bvSubO = signPick2 bvusubo bvssubo- bvMulO = signPick2 bvumulo bvsmulo- bvMulOFast = signPick2 bvumuloFast bvsmuloFast- bvDivO = signPick2 bvudivo bvsdivo- bvNegO = signPick1 bvunego bvsnego+ bvAddO = signPick2 (svMkOverflow2 (PlusOv False)) (svMkOverflow2 (PlusOv True))+ bvSubO = signPick2 (svMkOverflow2 (SubOv False)) (svMkOverflow2 (SubOv True))+ bvMulO = signPick2 (svMkOverflow2 (MulOv False)) (svMkOverflow2 (MulOv True))+ bvDivO = signPick2 (const (const svFalse)) (svMkOverflow2 DivOv) -- unsigned division doesn't overflow+ bvNegO = signPick1 (const svFalse) (svMkOverflow1 NegOv) -- unsigned unary negation doesn't overflow -- | A class of checked-arithmetic operations. These follow the usual arithmetic, -- except make calls to 'Data.SBV.sAssert' to ensure no overflow/underflow can occur.@@ -194,45 +187,6 @@ (/!) = checkOp2 ?loc "division" sDiv bvDivO negateChecked = checkOp1 ?loc "unary negation" negate bvNegO ---- | Zero-extend to given bits-zx :: Int -> SVal -> SVal-zx n a- | n < sa = error $ "Data.SBV: Unexpected zero extension: from: " ++ show (intSizeOf a) ++ " to: " ++ show n- | True = p `svJoin` a- where sa = intSizeOf a- s = hasSign a- p = svInteger (KBounded s (n - sa)) 0---- | Sign-extend to given bits. Note that we keep the signedness of the argument.-sx :: Int -> SVal -> SVal-sx n a- | n < sa = error $ "Data.SBV: Unexpected sign extension: from: " ++ show (intSizeOf a) ++ " to: " ++ show n- | True = p `svJoin` a- where sa = intSizeOf a- mk = svInteger $ KBounded (hasSign a) (n - sa)- p = svIte (pos a) (mk 0) (mk (-1))---- | Get the sign-bit-signBit :: SVal -> SVal-signBit x = x `svTestBit` (intSizeOf x - 1)---- | Is the sign-bit high?-neg :: SVal -> SVal-neg x = signBit x `svEqual` svTrue---- | Is the sign-bit low?-pos :: SVal -> SVal-pos x = signBit x `svEqual` svFalse---- | Do these have the same sign?-sameSign :: SVal -> SVal -> SVal-sameSign x y = (pos x `svAnd` pos y) `svOr` (neg x `svAnd` neg y)---- | Do these have opposing signs?-diffSign :: SVal -> SVal -> SVal-diffSign x y = svNot (sameSign x y)- -- | Check all true svAll :: [SVal] -> SVal svAll = foldr svAnd svTrue@@ -255,155 +209,6 @@ = svAll [svTestBit x i `svEqual` svTrue | i <- [m, m-1 .. n]] where sz = intSizeOf x --- | Unsigned addition. Can only overflow.-bvuaddo :: Int -> SVal -> SVal -> (SVal, SVal)-bvuaddo n x y = (underflow, overflow)- where underflow = svFalse-- n' = n+1- overflow = neg $ zx n' x `svPlus` zx n' y---- | Signed addition.-bvsaddo :: Int -> SVal -> SVal -> (SVal, SVal)-bvsaddo _n x y = (underflow, overflow)- where underflow = svAll [neg x, neg y, pos (x `svPlus` y)]- overflow = svAll [pos x, pos y, neg (x `svPlus` y)]---- | Unsigned subtraction. Can only underflow.-bvusubo :: Int -> SVal -> SVal -> (SVal, SVal)-bvusubo _n x y = (underflow, overflow)- where underflow = y `svGreaterThan` x- overflow = svFalse---- | Signed subtraction.-bvssubo :: Int -> SVal -> SVal -> (SVal, SVal)-bvssubo _n x y = (underflow, overflow)- where underflow = svAll [neg x, pos y, pos (x `svMinus` y)]- overflow = svAll [pos x, neg y, neg (x `svMinus` y)]---- | Unsigned multiplication. Can only overflow.-bvumulo :: Int -> SVal -> SVal -> (SVal, SVal)-bvumulo 0 _ _ = (svFalse, svFalse)-bvumulo n x y = (underflow, overflow)- where underflow = svFalse-- n1 = n+1- overflow1 = signBit $ zx n1 x `svTimes` zx n1 y-- -- From Z3 sources:- --- -- expr_ref ovf(m()), v(m()), tmp(m());- -- ovf = m().mk_false();- -- v = m().mk_false();- -- for (unsigned i = 1; i < sz; ++i) {- -- mk_or(ovf, a_bits[sz-i], ovf);- -- mk_and(ovf, b_bits[i], tmp);- -- mk_or(tmp, v, v);- -- }- -- overflow2 = v;- --- overflow2 = go 1 svFalse svFalse- where go i ovf v- | i >= n = v- | True = go (i+1) ovf' v'- where ovf' = ovf `svOr` (x `svTestBit` (n-i))- tmp = ovf' `svAnd` (y `svTestBit` i)- v' = tmp `svOr` v-- overflow = overflow1 `svOr` overflow2---- | Signed multiplication.-bvsmulo :: Int -> SVal -> SVal -> (SVal, SVal)-bvsmulo 0 _ _ = (svFalse, svFalse)-bvsmulo n x y = (underflow, overflow)- where underflow = diffSign x y `svAnd` overflowPossible- overflow = sameSign x y `svAnd` overflowPossible-- n1 = n+1- overflow1 = (xy1 `svTestBit` n) `svXOr` (xy1 `svTestBit` (n-1))- where xy1 = sx n1 x `svTimes` sx n1 y-- -- From Z3 sources:- -- expr_ref v(m()), tmp(m()), a(m()), b(m()), a_acc(m()), sign(m());- -- a_acc = m().mk_false();- -- v = m().mk_false();- -- for (unsigned i = 1; i + 1 < sz; ++i) {- -- mk_xor(b_bits[sz-1], b_bits[i], b);- -- mk_xor(a_bits[sz-1], a_bits[sz-1-i], a);- -- mk_or(a, a_acc, a_acc);- -- mk_and(a_acc, b, tmp);- -- mk_or(tmp, v, v);- -- }- -- overflow2 = v;- overflow2 = go 1 svFalse svFalse- where sY = signBit y- sX = signBit x- go i v a_acc- | i + 1 >= n = v- | True = go (i+1) v' a_acc'- where b = sY `svXOr` (y `svTestBit` i)- a = sX `svXOr` (x `svTestBit` (n-1-i))- a_acc' = a `svOr` a_acc- tmp = a_acc' `svAnd` b- v' = tmp `svOr` v-- overflowPossible = overflow1 `svOr` overflow2---- | Is this a concrete value?-known :: SVal -> Bool-known (SVal _ (Left _)) = True-known _ = False---- | Unsigned multiplication, fast version using z3 primitives.-bvumuloFast :: Int -> SVal -> SVal -> (SVal, SVal)-bvumuloFast n x y- | known x && known y -- Not particularly fast, but avoids shipping of to the solver- = bvumulo n x y- | True- = (underflow, overflow)- where underflow = fst $ bvumulo n x y -- No internal version for underflow exists (because it can't underflow)- overflow = svMkOverflow Overflow_UMul_OVFL x y---- | Signed multiplication, fast version using z3 primitives.-bvsmuloFast :: Int -> SVal -> SVal -> (SVal, SVal)-bvsmuloFast n x y- | known x && known y -- Not particularly fast, but avoids shipping of to the solver- = bvsmulo n x y- | True- = (underflow, overflow)- where underflow = svMkOverflow Overflow_SMul_UDFL x y- overflow = svMkOverflow Overflow_SMul_OVFL x y---- | Unsigned division. Neither underflows, nor overflows.-bvudivo :: Int -> SVal -> SVal -> (SVal, SVal)-bvudivo _ _ _ = (underflow, overflow)- where underflow = svFalse- overflow = svFalse---- | Signed division. Can only overflow.-bvsdivo :: Int -> SVal -> SVal -> (SVal, SVal)-bvsdivo n x y = (underflow, overflow)- where underflow = svFalse-- ones = svInteger (KBounded True n) (-1)- topSet = svInteger (KBounded True n) (2^(n-1))-- overflow = svAll [x `svEqual` topSet, y `svEqual` ones]---- | Unsigned negation. Neither underflows, nor overflows.-bvunego :: Int -> SVal -> (SVal, SVal)-bvunego _ _ = (underflow, overflow)- where underflow = svFalse- overflow = svFalse---- | Signed negation. Can only overflow.-bvsnego :: Int -> SVal -> (SVal, SVal)-bvsnego n x = (underflow, overflow)- where underflow = svFalse-- topSet = svInteger (KBounded True n) (2^(n-1))- overflow = x `svEqual` topSet- -- | Detecting underflow/overflow conditions for casting between bit-vectors. The first output is the result, -- the second component itself is a pair with the first boolean indicating underflow and the second indicating overflow. --@@ -490,40 +295,82 @@ (r, (u, o)) = sFromIntegralO x +-- | signedMulOverflow: Checking if a signed bitvector multiplication can overflow. In general you should simply use 'bvMulO' for checking+-- signed multiplication overflow for bit-vectors. This is a function supported by SMTLib. Unfortunately, individual implementations have+-- different performance characteristics. For instance, bitwuzla has a fairly performant implementation of this, but z3 does not. (At least+-- not as of August 2024.) In cases where you can't use bitwuzla, you can use this implementation which has better performance.+signedMulOverflow :: forall n. ( KnownNat n, BVIsNonZero n+ , KnownNat (n+1), BVIsNonZero (n+1)+ , KnownNat (2+Log2 n), BVIsNonZero (2+Log2 n))+ => SInt n -> SInt n -> SBool+signedMulOverflow x y = sNot zeroOut .&& overflow+ where zeroOut = x .== 0 .|| y .== 0 + prod :: SInt (n+1)+ prod = sFromIntegral x * sFromIntegral y++ nv :: Int+ nv = fromIntegral $ natVal (Proxy @n)++ prodN, prodNm1 :: SBool+ prodN = prod `sTestBit` nv+ prodNm1 = prod `sTestBit` (nv-1)++ overflow = nonSignBitPos x + nonSignBitPos y .> literal (fromIntegral (nv - 2))+ .|| prodN .<+> prodNm1++ -- Find the position of the first non-sign bit. i.e., the first bit that differs from the msb.+ -- Position is 0 indexed. Note that if there's no differing bit, then you also get back 0.+ -- This is essentially an approximation of the logarithm of the magnitude of the number.+ --+ -- The result is at most N-2 for an N-bit word. Later we add two of these, so the maximum+ -- value we need to represent is 2N-4. This will require 1 + lg(2N-4) = 2 + log(N-1) bits.+ -- To support the case N=0, we return a (2 + log N) bit word.+ --+ -- Example for 3 bits:+ --+ -- 000 -> 0 (no differing bit from 0; so we get 0)+ -- 001 -> 0+ -- 010 -> 1+ -- 011 -> 1+ -- 100 -> 1+ -- 101 -> 1+ -- 110 -> 0+ -- 111 -> 0 (no differing bit from 1; so we get 0)+ nonSignBitPos :: ( KnownNat n, BVIsNonZero n+ , KnownNat (2+Log2 n), BVIsNonZero (2+Log2 n))+ => SInt n -> SWord (2+Log2 n)+ 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 (map literal [0..]) (reverse bs))++ walk sofar [] = sofar+ walk sofar ((i, b):bs) = walk (ite (b ./= sign) i sofar) bs+ -- Helpers-l2 :: (SVal -> SVal -> (SBool, SBool)) -> SBV a -> SBV a -> (SBool, SBool)+l2 :: (SVal -> SVal -> SBool) -> SBV a -> SBV a -> SBool l2 f (SBV a) (SBV b) = f a b -l1 :: (SVal -> (SBool, SBool)) -> SBV a -> (SBool, SBool)+l1 :: (SVal -> SBool) -> SBV a -> SBool l1 f (SBV a) = f a -signPick2 :: (Int -> SVal -> SVal -> (SVal, SVal)) -> (Int -> SVal -> SVal -> (SVal, SVal)) -> (SVal -> SVal -> (SBool, SBool))+signPick2 :: (SVal -> SVal -> SVal) -> (SVal -> SVal -> SVal) -> (SVal -> SVal -> SBool) signPick2 fu fs a b- | hasSign a = let (u, o) = fs n a b in (SBV u, SBV o)- | True = let (u, o) = fu n a b in (SBV u, SBV o)- where n = intSizeOf a+ | hasSign a = SBV (fs a b)+ | True = SBV (fu a b) -signPick1 :: (Int -> SVal -> (SVal, SVal)) -> (Int -> SVal -> (SVal, SVal)) -> (SVal -> (SBool, SBool))+signPick1 :: (SVal -> SVal) -> (SVal -> SVal) -> (SVal -> SBool) signPick1 fu fs a- | hasSign a = let (u, o) = fs n a in (SBV u, SBV o)- | True = let (u, o) = fu n a in (SBV u, SBV o)- where n = intSizeOf a+ | hasSign a = SBV (fs a)+ | True = SBV (fu a) -checkOp1 :: (HasKind a, HasKind b) => CallStack -> String -> (a -> SBV b) -> (a -> (SBool, SBool)) -> a -> SBV b-checkOp1 loc w op cop a = sAssert (Just loc) (msg "underflows") (sNot u)- $ sAssert (Just loc) (msg "overflows") (sNot o)- $ op a+checkOp1 :: (HasKind a, HasKind b) => CallStack -> String -> (a -> SBV b) -> (a -> SBool) -> a -> SBV b+checkOp1 loc w op cop a = sAssert (Just loc) (msg "overflows") (sNot (cop a)) $ op a where k = show $ kindOf a msg c = k ++ " " ++ w ++ " " ++ c - (u, o) = cop a--checkOp2 :: (HasKind a, HasKind c) => CallStack -> String -> (a -> b -> SBV c) -> (a -> b -> (SBool, SBool)) -> a -> b -> SBV c-checkOp2 loc w op cop a b = sAssert (Just loc) (msg "underflows") (sNot u)- $ sAssert (Just loc) (msg "overflows") (sNot o)- $ a `op` b+checkOp2 :: (HasKind a, HasKind c) => CallStack -> String -> (a -> b -> SBV c) -> (a -> b -> SBool) -> a -> b -> SBV c+checkOp2 loc w op cop a b = sAssert (Just loc) (msg "overflows") (sNot (a `cop` b)) $ a `op` b where k = show $ kindOf a msg c = k ++ " " ++ w ++ " " ++ c-- (u, o) = a `cop` b
Data/SBV/Tools/Polynomial.hs view
@@ -9,11 +9,8 @@ -- Implementation of polynomial arithmetic ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall -Werror #-}@@ -24,13 +21,16 @@ ) where import Data.Bits (Bits(..))-import Data.List (genericTake)+import Data.List (genericTake+#if !MIN_VERSION_base(4,20,0)+ , foldl'+#endif+ ) import Data.Maybe (fromJust, fromMaybe) import Data.Word (Word8, Word16, Word32, Word64) import Data.SBV.Core.Data import Data.SBV.Core.Kind-import Data.SBV.Core.Sized import Data.SBV.Core.Model import GHC.TypeLits@@ -48,7 +48,7 @@ -- For instance -- -- @polynomial [0, 1, 3] :: SWord8@- -- + -- -- will evaluate to @11@, since it sets the bits @0@, @1@, and @3@. Mathematicians would write this polynomial -- as @x^3 + x + 1@. And in fact, 'showPoly' will show it like that. polynomial :: [Int] -> a@@ -150,7 +150,7 @@ = fromBitsLE $ genericTake sz $ r ++ repeat sFalse where (_, r) = mdp ms rs ms = genericTake (2*sz) $ mul (blastLE x) (blastLE y) [] ++ repeat sFalse- rs = genericTake (2*sz) $ [fromBool (i `elem` red) | i <- [0 .. foldr max 0 red] ] ++ repeat sFalse+ rs = genericTake (2*sz) $ [fromBool (i `elem` red) | i <- [0 .. foldl' max 0 red] ] ++ repeat sFalse sz = intSizeOf x mul _ [] ps = ps mul as (b:bs) ps = mul (sFalse:as) bs (ites b (as `addPoly` ps) ps)@@ -202,7 +202,7 @@ divx n i xs ys' = (q:qs, rs) where q = xs `idx` i xs' = ites q (xs `addPoly` ys') xs- (qs, rs) = divx (n-1) (i-1) xs' (tail ys')+ (qs, rs) = divx (n-1) (i-1) xs' (drop 1 ys') -- | Compute CRCs over bit-vectors. The call @crcBV n m p@ computes -- the CRC of the message @m@ with respect to polynomial @p@. The@@ -242,7 +242,10 @@ go c [] = c go c (b:bs) = go next bs where c' = drop 1 c ++ [b]- next = ite (head c) (zipWith (.<+>) c' mask) c'+ next = ite (hd c) (zipWith (.<+>) c' mask) c'++ hd (f:_) = f+ hd [] = error "crcBV: Impossible, prefix is empty" -- | Compute CRC's over polynomials, i.e., symbolic words. The first -- 'Int' argument plays the same role as the one in the 'crcBV' function.
Data/SBV/Tools/Range.hs view
@@ -9,8 +9,10 @@ -- Single variable valid range detection. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -27,12 +29,15 @@ import Data.SBV import Data.SBV.Control +import Data.Proxy+ import Data.SBV.Internals hiding (Range, free_) +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV--- >>> :set -XScopedTypeVariables+-- >>> :set -XScopedTypeVariables -XDataKinds+#endif -- | A boundary value data Boundary a = Unbounded -- ^ Unbounded@@ -48,7 +53,7 @@ -- | A range is a pair of boundaries: Lower and upper bounds data Range a = Range (Boundary a) (Boundary a) --- | Show instance for 'Range'+-- | Show instance for t'Range' instance Show a => Show (Range a) where show (Range l u) = sh True l ++ "," ++ sh False u where sh onLeft b = case b of@@ -94,16 +99,16 @@ -- [[0.0,oo)] -- >>> ranges $ \x -> x .<= (0::SReal) -- [(-oo,0.0]]--- >>> ranges $ \(x :: SWord8) -> 2*x .== 4--- [[2,3),(129,130]]-ranges :: forall a. (Ord a, Num a, SymVal a, SatModel a, Metric a, SymVal (MetricSpace a), SatModel (MetricSpace a)) => (SBV a -> SBool) -> IO [Range a]+-- >>> ranges $ \(x :: SWord 4) -> 2*x .== 4+-- [[2,3),(9,10]]+ranges :: forall a. (OrdSymbolic (SBV a), Num a, SymVal a, SatModel a, Metric a, SymVal (MetricSpace a), SatModel (MetricSpace a)) => (SBV a -> SBool) -> IO [Range a] ranges = rangesWith defaultSMTCfg -- | Compute ranges, using the given solver configuration.-rangesWith :: forall a. (Ord a, Num a, SymVal a, SatModel a, Metric a, SymVal (MetricSpace a), SatModel (MetricSpace a)) => SMTConfig -> (SBV a -> SBool) -> IO [Range a]+rangesWith :: forall a. (OrdSymbolic (SBV a), Num a, SymVal a, SatModel a, Metric a, SymVal (MetricSpace a), SatModel (MetricSpace a)) => SMTConfig -> (SBV a -> SBool) -> IO [Range a] rangesWith cfg prop = do mbBounds <- getInitialBounds case mbBounds of- Nothing -> return []+ Nothing -> pure [] Just r -> search [r] [] where getInitialBounds :: IO (Maybe (Range a))@@ -150,16 +155,16 @@ constrain $ prop x cstr objName x case m of- Unsatisfiable{} -> return Nothing+ Unsatisfiable{} -> pure Nothing Unknown{} -> error "Solver said Unknown!" ProofError{} -> error (show res)- _ -> return $ getModelObjectiveValue objName m+ _ -> pure $ getModelObjectiveValue (annotateForMS (Proxy @a) objName) m mi <- getBound minimize ma <- getBound maximize case (mi, ma) of- (Just minV, Just maxV) -> return $ Just $ Range (getGenVal minV) (getGenVal maxV)- _ -> return Nothing+ (Just minV, Just maxV) -> pure $ Just $ Range (getGenVal minV) (getGenVal maxV)+ _ -> pure Nothing -- Is this range satisfiable? Returns a witness to it. witness :: Range a -> Symbolic (SBV a)@@ -175,17 +180,17 @@ constrain $ lower .&& upper - return x+ pure x isFeasible :: Range a -> IO Bool isFeasible r = runSMTWith cfg $ do _ <- witness r query $ do cs <- checkSat case cs of- Unsat -> return False+ Unsat -> pure False DSat{} -> error "Data.SBV.interval.isFeasible: Solver returned a delta-satisfiable result!" Unk -> error "Data.SBV.interval.isFeasible: Solver said unknown!"- Sat -> return True+ Sat -> pure True bisect :: Range a -> IO (Maybe [Range a]) bisect r@(Range lo hi) = runSMTWith cfg $ do x <- witness r@@ -194,14 +199,14 @@ query $ do cs <- checkSat case cs of- Unsat -> return Nothing+ Unsat -> pure Nothing DSat{} -> error "Data.SBV.interval.bisect: Solver returned a delta-satisfiable result!" Unk -> error "Data.SBV.interval.bisect: Solver said unknown!" Sat -> do midV <- Open <$> getValue x- return $ Just [Range lo midV, Range midV hi]+ pure $ Just [Range lo midV, Range midV hi] search :: [Range a] -> [Range a] -> IO [Range a]- search [] sofar = return $ reverse sofar+ search [] sofar = pure $ reverse sofar search (c:cs) sofar = do feasible <- isFeasible c if feasible then do mbCS <- bisect c@@ -210,4 +215,4 @@ Just xss -> search (xss ++ cs) sofar else search cs sofar -{-# ANN rangesWith ("HLint: ignore Use fromMaybe" :: String) #-}+{- HLint ignore rangesWith "Use fromMaybe" -}
Data/SBV/Tools/STree.hs view
@@ -57,7 +57,7 @@ writeSTree s i j = walk (blastBE i) s where walk [] _ = SLeaf j walk (b:bs) (SBin l r) = SBin (ite b l (walk bs l)) (ite b (walk bs r) r)- walk _ _ = error $ "SBV.STree.writeSTree: Impossible happened while reading: " ++ show i+ walk _ _ = error $ "SBV.STree.writeSTree: Impossible happened while writing: " ++ show i -- | Construct the fully balanced initial tree using the given values. mkSTree :: forall i e. HasKind i => [SBV e] -> STree i e
Data/SBV/Tools/WeakestPreconditions.hs view
@@ -13,10 +13,10 @@ -- several example proofs. ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -25,7 +25,7 @@ Program(..), Stmt(..), assert, stable -- * Invariants, measures, and stability- , Invariant, Measure, Stable+ , Invariant, WPMeasure, Stable -- * Verification conditions , VC(..)@@ -73,7 +73,7 @@ -- -- The 'setup' field is reserved for any symbolic code you might -- want to run before the proof takes place, typically for calls--- to 'Data.SBV.setOption'. If not needed, simply pass @return ()@.+-- to 'Data.SBV.setOption'. If not needed, simply pass @pure ()@. -- For an interesting use case where we use setup to axiomatize -- the spec, see "Documentation.SBV.Examples.WeakestPreconditions.Fib" -- and "Documentation.SBV.Examples.WeakestPreconditions.GCD".@@ -93,18 +93,18 @@ -- | A measure takes the state and returns a sequence of integers. The ordering -- will be done lexicographically over the elements.-type Measure st = st -> [SInteger]+type WPMeasure st = st -> [SInteger] -- | A statement in our imperative program, parameterized over the state.-data Stmt st = Skip -- ^ Skip, do nothing.- | Abort String -- ^ Abort execution. The name is for diagnostic purposes.- | Assign (st -> st) -- ^ Assignment: Transform the state by a function.- | If (st -> SBool) (Stmt st) (Stmt st) -- ^ Conditional: @If condition thenBranch elseBranch@.- | While String (Invariant st) (Maybe (Measure st)) (st -> SBool) (Stmt st) -- ^ A while loop: @While name invariant measure condition body@.- -- The string @name@ is merely for diagnostic purposes.- -- If the measure is 'Nothing', then only partial correctness- -- of this loop will be proven.- | Seq [Stmt st] -- ^ A sequence of statements.+data Stmt st = Skip -- ^ Skip, do nothing.+ | Abort String -- ^ Abort execution. The name is for diagnostic purposes.+ | Assign (st -> st) -- ^ Assignment: Transform the state by a function.+ | If (st -> SBool) (Stmt st) (Stmt st) -- ^ Conditional: @If condition thenBranch elseBranch@.+ | While String (Invariant st) (Maybe (WPMeasure st)) (st -> SBool) (Stmt st) -- ^ A while loop: @While name invariant measure condition body@.+ -- The string @name@ is merely for diagnostic purposes.+ -- If the measure is 'Nothing', then only partial correctness+ -- of this loop will be proven.+ | Seq [Stmt st] -- ^ A sequence of statements. -- | An 'assert' is a quick way of ensuring some condition holds. If it does, -- then it's equivalent to 'Skip'. Otherwise, it is equivalent to 'Abort'.@@ -206,7 +206,7 @@ -- | Checking WP based correctness-wpProveWith :: forall st res. (Show res, Mergeable st, Queriable IO st res) => WPConfig -> Program st -> IO (ProofResult res)+wpProveWith :: forall st res. (Show res, Mergeable st, Queriable IO st, res ~ QueryResult st) => WPConfig -> Program st -> IO (ProofResult res) wpProveWith cfg@WPConfig{wpVerbose} Program{setup, precondition, program, postcondition, stability} = runSMTWith (wpSolver cfg) $ do setup query q@@ -234,7 +234,7 @@ Sat -> do let checkVC :: (SBool, VC st SInteger) -> Query [VC res Integer] checkVC (cond, vc) = do c <- getValue cond if c- then return [] -- The VC was OK+ then pure [] -- The VC was OK else do vc' <- case vc of BadPrecondition s -> BadPrecondition <$> project s BadPostcondition s1 s2 -> BadPostcondition <$> project s1 <*> project s2@@ -244,13 +244,13 @@ InvariantMaintain l s1 s2 -> InvariantMaintain l <$> project s1 <*> project s2 MeasureBound l (s, m) -> do r <- project s v <- mapM getValue m- return $ MeasureBound l (r, v)+ pure $ MeasureBound l (r, v) MeasureDecrease l (s1, i1) (s2, i2) -> do r1 <- project s1 v1 <- mapM getValue i1 r2 <- project s2 v2 <- mapM getValue i2- return $ MeasureDecrease l (r1, v1) (r2, v2)- return [vc']+ pure $ MeasureDecrease l (r1, v1) (r2, v2)+ pure [vc'] badVCs <- concat <$> mapM checkVC vcs @@ -267,7 +267,7 @@ let disp c = mapM_ msg [" " ++ l | l <- lines (show c)] mapM_ disp badVCs - return $ Failed badVCs+ pure $ Failed badVCs msg = io . when wpVerbose . putStrLn @@ -275,28 +275,28 @@ wp :: st -> Stmt st -> (st -> [(SBool, VC st SInteger)]) -> Query (st -> [(SBool, VC st SInteger)]) -- Skip simply keeps the conditions- wp _ Skip post = return post+ wp _ Skip post = pure post -- Abort is never satisfiable. The only way to have Abort's VC to pass is -- to run it in a precondition (either via program or in an if branch) that -- evaluates to false, i.e., it must not be reachable.- wp start (Abort nm) _ = return $ \st -> [(sFalse, AbortReachable nm start st)]+ wp start (Abort nm) _ = pure $ \st -> [(sFalse, AbortReachable nm start st)] -- Assign simply transforms the state and passes on. It also checks that the -- stability constraints are not violated.- wp _ (Assign f) post = return $ \st -> let st' = f st- vcs = map (\s -> let (nm, b) = s st st' in (b, Unstable nm st st')) stability- in vcs ++ post st'+ wp _ (Assign f) post = pure $ \st -> let st' = f st+ vcs = map (\s -> let (nm, b) = s st st' in (b, Unstable nm st st')) stability+ in vcs ++ post st' -- Conditional: We separately collect the VCs, and predicate with the proper branch condition wp start (If c tb fb) post = do tWP <- wp start tb post fWP <- wp start fb post- return $ \st -> let cond = c st- in [( cond .=> b, v) | (b, v) <- tWP st]- ++ [(sNot cond .=> b, v) | (b, v) <- fWP st]+ pure $ \st -> let cond = c st+ in [( cond .=> b, v) | (b, v) <- tWP st]+ ++ [(sNot cond .=> b, v) | (b, v) <- fWP st] -- Sequencing: Simply run through the statements- wp _ (Seq []) post = return post+ wp _ (Seq []) post = pure post wp start (Seq (s:ss)) post = wp start s =<< wp start (Seq ss) post -- While loop, where all the WP magic happens!@@ -306,7 +306,7 @@ let noMeasure = isNothing mm m = fromJust mm curM = m st'- zero = map (const 0) curM+ zeroM = map (const 0) curM iterates = inv st' .&& cond st' terminates = inv st' .&& sNot (cond st')@@ -315,7 +315,7 @@ -- Condition 1: Invariant must hold prior to loop entry invHoldsPrior <- wp start Skip (\st -> [(inv st, InvariantPre nm st)]) - -- Condition 2: If we iterate, invariant must be maitained by the body+ -- Condition 2: If we iterate, invariant must be maintained by the body invMaintained <- wp st' body (\st -> [(iterates .=> inv st, InvariantMaintain nm st' st)]) -- Condition 3: If we terminate, invariant must be strong enough to establish the post condition@@ -323,23 +323,23 @@ -- Condition 4: If we iterate, measure must always be non-negative measureNonNegative <- if noMeasure- then return (const [])- else wp st' Skip (const [(iterates .=> curM .>= zero, MeasureBound nm (st', curM))])+ then pure (const [])+ else wp st' Skip (const [(iterates .=> curM .>= zeroM, MeasureBound nm (st', curM))]) -- Condition 5: If we iterate, the measure must decrease measureDecreases <- if noMeasure- then return (const [])+ then pure (const []) else wp st' body (\st -> let prevM = m st in [(iterates .=> prevM .< curM, MeasureDecrease nm (st', curM) (st, prevM))]) -- Simply concatenate the VCs from all our conditions:- return $ \st -> invHoldsPrior st- ++ invMaintained st'- ++ invEstablish st'- ++ measureNonNegative st'- ++ measureDecreases st'+ pure $ \st -> invHoldsPrior st+ ++ invMaintained st'+ ++ invEstablish st'+ ++ measureNonNegative st'+ ++ measureDecreases st' -- | Check correctness using the default solver. Equivalent to @'wpProveWith' 'defaultWPCfg'@.-wpProve :: (Show res, Mergeable st, Queriable IO st res) => Program st -> IO (ProofResult res)+wpProve :: (Show res, Mergeable st, Queriable IO st, res ~ QueryResult st) => Program st -> IO (ProofResult res) wpProve = wpProveWith defaultWPCfg -- | Configuration for WP proofs.@@ -388,7 +388,7 @@ else giveUp start (BadPrecondition start) "*** Initial state does not satisfy the precondition:" case status of- s@Stuck{} -> return s+ s@Stuck{} -> pure s Good end -> if unwrap [] "checking postcondition" (postcondition end) then step [] end "*** Program successfully terminated, post condition holds of the final state:" else giveUp end (BadPostcondition start end) "*** Failed, final state does not satisfy the postcondition:"@@ -403,16 +403,16 @@ step :: Loc -> st -> String -> IO (Status st) step l st m = do putStrLn $ sLoc l m printST st- return $ Good st+ pure $ Good st stop :: Loc -> VC st Integer -> String -> IO (Status st) stop l vc m = do putStrLn $ sLoc l m- return $ Stuck vc+ pure $ Stuck vc giveUp :: st -> VC st Integer -> String -> IO (Status st) giveUp st vc m = do r <- stop [] vc m printST st- return r+ pure r dispST :: st -> String dispST st = intercalate "\n" [" " ++ l | l <- lines (show st)]@@ -434,7 +434,7 @@ ] go :: Loc -> Stmt st -> Status st -> IO (Status st)- go _ _ s@Stuck{} = return s+ go _ _ s@Stuck{} = pure s go loc p (Good st) = analyze p where analyze Skip = step loc st "Skip" @@ -453,14 +453,14 @@ where branchTrue = unwrap loc "evaluating the test condition" (c st) analyze (Seq stmts) = walk stmts 1 (Good st)- where walk [] _ is = return is+ where walk [] _ is = pure is walk (s:ss) c is = walk ss (c+1) =<< go (Line c : loc) s is analyze (While loopName invariant mbMeasure condition body) | currentInvariant st = while 1 st Nothing (Good st) | True- = stop loc (InvariantPre loopName st) $ tag "invariant fails to hold prior to loop entry"+ = stop loc (InvariantPre loopName st) $ tag "invariant fails to hold prior to loop entry" where tag s = "Loop " ++ show loopName ++ ": " ++ s hasMeasure = isJust mbMeasure@@ -470,20 +470,20 @@ currentMeasure = map (unwrap loc (tag "evaluating the measure")) . measure currentInvariant = unwrap loc (tag "evaluating the invariant") . invariant - while _ _ _ s@Stuck{} = return s+ while _ _ _ s@Stuck{} = pure s while c prevST mbPrev (Good is) | not (currentCondition is) = step loc is $ tag "condition fails, terminating" | not (currentInvariant is) = stop loc (InvariantMaintain loopName prevST is) $ tag "invariant fails to hold in iteration " ++ show c- | hasMeasure && mCur < zero+ | hasMeasure && mCur < zeroM = stop loc (MeasureBound loopName (is, mCur)) $ tag "measure must be non-negative, evaluated to: " ++ show mCur | hasMeasure, Just mPrev <- mbPrev, mCur >= mPrev = stop loc (MeasureDecrease loopName (prevST, mPrev) (is, mCur)) $ tag $ "measure failed to decrease, prev = " ++ show mPrev ++ ", current = " ++ show mCur | True = do nextState <- go (Iteration c : loc) body =<< step loc is (tag "condition holds, executing the body") while (c+1) is (Just mCur) nextState- where mCur = currentMeasure is- zero = map (const 0) mCur+ where mCur = currentMeasure is+ zeroM = map (const 0) mCur -{-# ANN traceExecution ("HLint: ignore Use fromMaybe" :: String) #-}+{- HLint ignore traceExecution "Use fromMaybe" -}
Data/SBV/Trans.hs view
@@ -26,30 +26,32 @@ , SWord8, SWord16, SWord32, SWord64, SWord, WordN -- *** Signed bit-vectors , SInt8, SInt16, SInt32, SInt64, SInt, IntN- -- *** Converting between fixed-size and arbitrary bitvectors+ -- *** Converting between fixed-size and arbitrary bit-vectors , BVIsNonZero, FromSized, ToSized, fromSized, toSized -- ** Unbounded integers , SInteger -- ** Floating point numbers , SFloat, SDouble, SFloatingPoint -- ** Algebraic reals- , SReal, AlgReal, sRealToSInteger+ , SReal, AlgReal+ , sRealToSIntegerFloor, sRealToSIntegerCeiling, sRealToSIntegerTruncate+ , sRealToSIntegerRoundAway, sRealToSIntegerRoundToEven, sRealToSIntegerRM -- ** Characters, Strings and Regular Expressions , SChar, SString -- ** Symbolic lists , SList -- * Arrays of symbolic values- , SymArray(newArray_, newArray, readArray, writeArray, mergeArrays), SArray+ , readArray, writeArray, SArray -- * Creating symbolic values -- ** Single value- , sBool, sWord8, sWord16, sWord32, sWord64, sWord, sInt8, sInt16, sInt32, sInt64, sInt, sInteger, sReal, sFloat, sDouble, sChar, sString, sList+ , sBool, sWord8, sWord16, sWord32, sWord64, sWord, sInt8, sInt16, sInt32, sInt64, sInt, sInteger, sReal, sFloat, sDouble, sChar, sString, sList, sArray -- ** List of values- , sBools, sWord8s, sWord16s, sWord32s, sWord64s, sWords, sInt8s, sInt16s, sInt32s, sInt64s, sInts, sIntegers, sReals, sFloats, sDoubles, sChars, sStrings, sLists+ , sBools, sWord8s, sWord16s, sWord32s, sWord64s, sWords, sInt8s, sInt16s, sInt32s, sInt64s, sInts, sIntegers, sReals, sFloats, sDoubles, sChars, sStrings, sLists, sArrays -- * Symbolic Equality and Comparisons- , EqSymbolic(..), OrdSymbolic(..), Equality(..)+ , EqSymbolic(..), OrdSymbolic(..), Zero(..), MeasureOf, Equality(..) -- * Conditionals: Mergeable values , Mergeable(..), ite, iteLazy @@ -71,7 +73,7 @@ -- * IEEE-floating point numbers , IEEEFloating(..), RoundingMode(..), SRoundingMode, nan, infinity, sNaN, sInfinity -- ** Rounding modes- , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero, sRNE, sRNA, sRTP, sRTN, sRTZ+ , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero, sRNE, sRNA, sRTP, sRTN, sRTZ, sCaseRoundingMode -- ** Conversion to/from floats , IEEEFloatConvertible(..) @@ -85,16 +87,12 @@ , blastSDouble , blastSFloatingPoint - -- * Enumerations- , mkSymbolicEnumeration-- -- * Uninterpreted sorts, axioms, constants, and functions- , mkUninterpretedSort, Uninterpreted(..), addAxiom+ -- * Symbolic types+ , mkSymbolic, SMTDefinable(..), smtFunction, smtFunctionWithMeasure -- * Properties, proofs, and satisfiability- , Predicate, Goal, MProvable(..), Provable, proveWithAll, proveWithAny , satWithAll- , proveConcurrentWithAny, proveConcurrentWithAll, satConcurrentWithAny, satConcurrentWithAll- , satWithAny, generateSMTBenchmark+ , Predicate, ConstraintSet, ProvableM(..), Provable, SatisfiableM(..), Satisfiable+ , generateSMTBenchmarkSat, generateSMTBenchmarkProof , solve -- * Constraints -- ** General constraints@@ -121,11 +119,11 @@ -- ** Multiple optimization goals , OptimizeStyle(..) -- ** Objectives- , Objective(..), Metric(..)+ , Objective(..) -- ** Soft assumptions , assertWithPenalty , Penalty(..) -- ** Field extensions- -- | If an optimization results in an infinity/epsilon value, the returned `CV` value will be in the corresponding extension field.+ -- | If an optimization results in an infinity/epsilon value, the returned t'CV' value will be in the corresponding extension field. , ExtCV(..), GeneralizedCV(..) -- * Model extraction@@ -134,18 +132,18 @@ , ThmResult(..), SatResult(..), AllSatResult(..), SafeResult(..), OptimizeResult(..), SMTResult(..), SMTReasonUnknown(..) -- ** Observing expressions- , observe+ , observe, sObserve -- ** Programmable model extraction , SatModel(..), Modelable(..), displayModels, extractModels- , getModelDictionaries, getModelValues, getModelUninterpretedValues+ , getModelDictionaries, getModelValues -- * SMT Interface , SMTConfig(..), Timing(..), SMTLibVersion(..), Solver(..), SMTSolver(..) -- ** Controlling verbosity -- ** Solvers- , boolector, cvc4, yices, z3, mathSAT, abc+ , boolector, bitwuzla, cvc4, cvc5, dReal, yices, z3, mathSAT, abc -- ** Configurations , defaultSolverConfig, defaultSMTCfg, sbvCheckSolverInstallation, getAvailableSolvers , setLogic, Logic(..), setOption, setInfo, setTimeOut@@ -169,15 +167,11 @@ import Data.SBV.Core.Kind import Data.SBV.Core.Model import Data.SBV.Core.Floating-import Data.SBV.Core.Sized import Data.SBV.Core.Symbolic 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/Trans/Control.hs view
@@ -17,18 +17,12 @@ -- * User queries ExtractIO(..), MonadQuery(..), QueryT, Query, query - -- * Create a fresh variable- , freshVar_, freshVar-- -- * Create a fresh array- , freshArray_, freshArray- -- * Checking satisfiability , CheckSatResult(..), checkSat, ensureSat, checkSatUsing, checkSatAssuming, checkSatAssumingWithUnsatisfiableSet -- * Querying the solver -- ** Extracting values- , getValue, getFunction, getUninterpretedValue, getModel, getAssignment, getSMTResult, getUnknownReason, getObservables+ , getValue, getFunction, getModel, getAssignment, getSMTResult, getUnknownReason, getObservables -- ** Extracting the unsat core , getUnsatCore@@ -39,6 +33,9 @@ -- ** Extracting interpolants , getInterpolantMathSAT, getInterpolantZ3 + -- ** Getting abducts+ , getAbduct, getAbductNext+ -- ** Extracting assertions , getAssertions @@ -77,7 +74,7 @@ import Data.SBV.Core.Symbolic (MonadQuery(..), QueryT, Query, SymbolicT, QueryContext(..)) import Data.SBV.Control.Query-import Data.SBV.Control.Utils (queryDebug, executeQuery, getFunction)+import Data.SBV.Control.Utils (queryDebug, executeQuery, getFunction, getValue) import Data.SBV.Utils.ExtractIO
Data/SBV/Tuple.hs view
@@ -10,22 +10,29 @@ -- Accessing symbolic tuple fields and deconstruction. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Tuple ( -- * Symbolic field access (^.), _1, _2, _3, _4, _5, _6, _7, _8 -- * Tupling and untupling , tuple, untuple+ -- * Swapping, only for 2-tuples+ , swap+ -- * Currying and uncurrying+ , curry, uncurry, curry3, uncurry3+ -- * Extractors for 2-tuple+ , fst, snd+ -- * Extractors for 3-tuple+ , fst3, snd3, thd3 ) where import GHC.TypeLits@@ -34,10 +41,13 @@ import Data.SBV.Core.Symbolic import Data.SBV.Core.Model +import Prelude hiding (fst, snd, curry, uncurry)++#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> :set -XTypeApplications -- >>> import Data.SBV+#endif -- | Field access, inspired by the lens library. This is merely reverse -- application, but allows us to write things like @(1, 2)^._1@ which is@@ -48,6 +58,54 @@ t ^. f = f t infixl 8 ^. +-- | Swap the elements of a 2-tuple+swap :: (SymVal a, SymVal b) => STuple a b -> STuple b a+swap t = tuple (b, a)+ where (a, b) = untuple t++-- | Symbolic currying: turn a function that takes a symbolic 2-tuple into one+-- that takes its two components separately. The inverse of 'uncurry'.+curry :: (SymVal a, SymVal b) => (STuple a b -> r) -> SBV a -> SBV b -> r+curry f a b = f (tuple (a, b))++-- | Symbolic uncurrying: turn a function of two arguments into one that takes a+-- symbolic 2-tuple. The inverse of 'curry'.+uncurry :: (SymVal a, SymVal b) => (SBV a -> SBV b -> r) -> STuple a b -> r+uncurry f t = f a b+ where (a, b) = untuple t++-- | Symbolic currying for 3-tuples: turn a function that takes a symbolic+-- 3-tuple into one that takes its three components separately. The inverse of+-- 'uncurry3'.+curry3 :: (SymVal a, SymVal b, SymVal c) => (STuple3 a b c -> r) -> SBV a -> SBV b -> SBV c -> r+curry3 f a b c = f (tuple (a, b, c))++-- | Symbolic uncurrying for 3-tuples: turn a function of three arguments into+-- one that takes a symbolic 3-tuple. The inverse of 'curry3'.+uncurry3 :: (SymVal a, SymVal b, SymVal c) => (SBV a -> SBV b -> SBV c -> r) -> STuple3 a b c -> r+uncurry3 f t = f a b c+ where (a, b, c) = untuple t++-- | First of a tuple+fst :: (SymVal a, SymVal b) => STuple a b -> SBV a+fst t = a where (a, _) = untuple t++-- | Second of a tuple+snd :: (SymVal a, SymVal b) => STuple a b -> SBV b+snd t = b where (_, b) = untuple t++-- | First of a 3-tuple+fst3 :: (SymVal a, SymVal b, SymVal c) => STuple3 a b c -> SBV a+fst3 t = a where (a, _, _) = untuple t++-- | Second of a 3-tuple+snd3 :: (SymVal a, SymVal b, SymVal c) => STuple3 a b c -> SBV b+snd3 t = b where (_, b, _) = untuple t++-- | Third of a 3-tuple+thd3 :: (SymVal a, SymVal b, SymVal c) => STuple3 a b c -> SBV c+thd3 t = c where (_, _, c) = untuple t+ -- | Dynamic interface to exporting tuples, this function is not -- exported on purpose; use it only via the field functions '_1', '_2', etc. symbolicFieldAccess :: (SymVal a, HasKind tup) => Int -> SBV tup -> SBV a@@ -426,4 +484,4 @@ msMaximize (nm ++ "^._7") (p^._7) msMaximize (nm ++ "^._8") (p^._8) -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore module "Reduce duplication" -}
Data/SBV/Utils/CrackNum.hs view
@@ -11,7 +11,7 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Utils.CrackNum ( crackNum@@ -35,32 +35,40 @@ -- | A class for cracking things deeper, if we know how. class CrackNum a where -- | Convert an item to possibly bit-level description, if possible.- crackNum :: a -> Maybe String+ crackNum :: a -> Bool -> Maybe Integer -> Maybe String -- | CVs are easy to crack instance CrackNum CV where- crackNum cv = case kindOf cv of- -- Maybe one day we'll have a use for these, currently cracking them- -- any further seems overkill- KBool {} -> Nothing- KUnbounded {} -> Nothing- KReal {} -> Nothing- KUserSort {} -> Nothing- KChar {} -> Nothing- KString {} -> Nothing- KList {} -> Nothing- KSet {} -> Nothing- KTuple {} -> Nothing- KMaybe {} -> Nothing- KEither {} -> Nothing- KRational {} -> Nothing+ crackNum cv verbose mbIV = case kindOf cv of+ -- Maybe one day we'll have a use for these, currently cracking them+ -- any further seems overkill+ KVar {} -> Nothing+ KBool {} -> Nothing+ KUnbounded {} -> Nothing+ KReal {} -> Nothing+ KApp {} -> Nothing+ KADT {} -> Nothing+ KChar {} -> Nothing+ KString {} -> Nothing+ KList {} -> Nothing+ KSet {} -> Nothing+ KTuple {} -> Nothing+ KRational {} -> Nothing+ KArray {} -> Nothing - -- Actual crackables- KFloat{} -> Just $ let CFloat f = cvVal cv in float f- KDouble{} -> Just $ let CDouble d = cvVal cv in float d- KFP{} -> Just $ let CFP f = cvVal cv in float f- KBounded sg sz -> Just $ let CInteger i = cvVal cv in int sg sz i+ -- Actual crackables+ KFloat{} | CFloat f <- cvVal cv -> Just $ float verbose mbIV f+ | True -> Nothing -- Can't really happen; but don't die + KDouble{} | CDouble d <- cvVal cv -> Just $ float verbose mbIV d+ | True -> Nothing -- Can't really happen; but don't die++ KFP{} | CFP f <- cvVal cv -> Just $ float verbose mbIV f+ | True -> Nothing -- Can't really happen; but don't die++ KBounded sg sz | CInteger i <- cvVal cv -> Just $ int sg sz i+ | True -> Nothing -- Can't really happen; but don't die+ -- How far off the screen we want displayed? Somewhat experimentally found. tab :: String tab = replicate 18 ' '@@ -75,7 +83,7 @@ -- Convert bits to the corresponding integer. getVal :: [Bool] -> Integer-getVal = foldl (\s b -> 2 * s + if b then 1 else 0) 0+getVal = foldl' (\s b -> 2 * s + if b then 1 else 0) 0 -- Show in hex, but pay attention to how wide a field it should be in mkHex :: [Bool] -> String@@ -227,11 +235,31 @@ | bfIsSubnormal opts f = Subnormal | True = Normal --- | Show a float in detail-float :: HasFloatData a => a -> String-float f = intercalate "\n" $ ruler ++ legend : info- where fd@FloatData{prec, eb, sb, bits, fpKind, fpVals} = getFloatData f+-- | Show a float in detail. mbSurface is the integer equivalent if this is a NaN; so we+-- can represent it faithfully to the original given. Used by crackNum executable.+float :: HasFloatData a => Bool -> Maybe Integer -> a -> String+float verbose mbSurface f = intercalate "\n" $ ruler ++ legend : info+ where fd@FloatData{prec, eb, sb, bits = bitsAsStored, fpKind, fpVals} = getFloatData f + nanKind = case fpKind of+ Zero{} -> False+ Infty{} -> False+ NaN -> True+ Subnormal -> False+ Normal -> False++ (nanClassifier, bits, nanChanged)+ | nanKind, Just i <- mbSurface = (extraClassifier i, i, i /= bitsAsStored)+ | True = ("", bitsAsStored, False)++ -- Is this surface representation a signaling NaN or a quiet nan?+ -- The test is that the tip bit of the significand is high: If so, quiet. If top bit is low, then signaling.+ extraClassifier :: Integer -> String+ extraClassifier i+ | sb < 2 = "" -- I don't think this can happen, but just in case+ | i `testBit` (sb - 2) = " (Quiet)"+ | True = " (Signaling)"+ splits = [1, eb, sb] ruler = map (tab ++) $ mkRuler (eb + sb) splits @@ -242,6 +270,9 @@ allBits :: [Bool] allBits = [bits `testBit` i | i <- reverse [0 .. eb + sb - 1]] + storedBits :: [Bool]+ storedBits = [bitsAsStored `testBit` i | i <- reverse [0 .. eb + sb - 1]]+ flatHex = concatMap mkHex (split (split4 (eb + sb)) allBits) sign = bits `testBit` (eb+sb-1) @@ -249,18 +280,21 @@ esInfo = "Stored: " ++ show storedExponent ++ ", Bias: " ++ show bias + chunks bs = unwords [concatMap (\b -> if b then "1" else "0") is | is <- split splits bs]+ isSubNormal = case fpKind of Subnormal -> True _ -> False - info = [ " Binary layout: " ++ unwords [concatMap (\b -> if b then "1" else "0") is | is <- split splits allBits]- , " Hex layout: " ++ unwords (split (split4 (length flatHex)) flatHex)+ info = [ " Binary layout: " ++ chunks allBits]+ ++ [ " Calculated bits: " ++ chunks storedBits ++ " (Surface NaN value differs from calculated)" | verbose && nanChanged]+ ++ [ " Hex layout: " ++ unwords (split (split4 (length flatHex)) flatHex) , " Precision: " ++ prec , " Sign: " ++ if sign then "Negative" else "Positive" ] ++ [ " Exponent: " ++ show exponentVal ++ " (Subnormal, with fixed exponent value. " ++ esInfo ++ ")" | isSubNormal ] ++ [ " Exponent: " ++ show exponentVal ++ " (" ++ esInfo ++ ")" | not isSubNormal]- ++ [ " Classification: " ++ show fpKind]+ ++ [ " Classification: " ++ show fpKind ++ nanClassifier] ++ (case fpVals of Left val -> [ " Value: " ++ val] Right (bval, oval, dval, hval) -> [ " Binary: " ++ bval
Data/SBV/Utils/ExtractIO.hs view
@@ -32,20 +32,20 @@ -- | Trivial IO extraction for 'IO'. instance ExtractIO IO where- extractIO = pure+ extractIO = fmap pure --- | IO extraction for 'MaybeT'.+-- | IO extraction for t'MaybeT'. instance ExtractIO m => ExtractIO (MaybeT m) where extractIO = fmap MaybeT . extractIO . runMaybeT --- | IO extraction for 'ExceptT'.+-- | IO extraction for t'ExceptT'. instance ExtractIO m => ExtractIO (ExceptT e m) where extractIO = fmap ExceptT . extractIO . runExceptT --- | IO extraction for lazy 'LW.WriterT'.+-- | IO extraction for lazy t'LW.WriterT'. instance (Monoid w, ExtractIO m) => ExtractIO (LW.WriterT w m) where extractIO = fmap LW.WriterT . extractIO . LW.runWriterT --- | IO extraction for strict 'SW.WriterT'.+-- | IO extraction for strict t'SW.WriterT'. instance (Monoid w, ExtractIO m) => ExtractIO (SW.WriterT w m) where extractIO = fmap SW.WriterT . extractIO . SW.runWriterT
Data/SBV/Utils/Lib.hs view
@@ -9,24 +9,44 @@ -- Misc helpers ----------------------------------------------------------------------------- -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Utils.Lib ( mlift2, mlift3, mlift4, mlift5, mlift6, mlift7, mlift8 , joinArgs, splitArgs , stringToQFS, qfsToString+ , showText , isKString+ , checkObservableName+ , needsBars, barify+ , unQuote, unBar, nameSupply+ , atProxy+ , mapToSortedList+ , curry2, curry3, curry4, curry5, curry6, curry7, curry8, curry9, curry10, curry11, curry12+ , uncurry2, uncurry3, uncurry4, uncurry5, uncurry6, uncurry7, uncurry8, uncurry9, uncurry10, uncurry11, uncurry12 ) where -import Data.Char (isSpace, chr, ord)+import Data.Char (isSpace, chr, ord, isDigit, isAscii, isAlphaNum)+import Data.List (isPrefixOf, isSuffixOf, sortBy)+import Data.Ord (comparing) import Data.Dynamic (fromDynamic, toDyn, Typeable) import Data.Maybe (fromJust, isJust, isNothing)+import Data.Proxy+import Data.Text (Text) +import qualified Data.Text as T++import qualified Data.Map.Strict as Map++import Type.Reflection (typeRep)+ import Numeric (readHex, showHex) +import Data.SBV.SMT.SMTLibNames (isReserved)+ -- | We have a nasty issue with the usual String/List confusion in Haskell. However, we can -- do a simple dynamic trick to determine where we are. The ice is thin here, but it seems to work. isKString :: forall a. Typeable a => a -> Bool@@ -34,31 +54,31 @@ -- | Monadic lift over 2-tuples mlift2 :: Monad m => (a' -> b' -> r) -> (a -> m a') -> (b -> m b') -> (a, b) -> m r-mlift2 k f g (a, b) = f a >>= \a' -> g b >>= \b' -> return $ k a' b'+mlift2 k f g (a, b) = f a >>= \a' -> g b >>= \b' -> pure $ k a' b' -- | Monadic lift over 3-tuples mlift3 :: Monad m => (a' -> b' -> c' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (a, b, c) -> m r-mlift3 k f g h (a, b, c) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> return $ k a' b' c'+mlift3 k f g h (a, b, c) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> pure $ k a' b' c' -- | Monadic lift over 4-tuples mlift4 :: Monad m => (a' -> b' -> c' -> d' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (a, b, c, d) -> m r-mlift4 k f g h i (a, b, c, d) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> return $ k a' b' c' d'+mlift4 k f g h i (a, b, c, d) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> pure $ k a' b' c' d' -- | Monadic lift over 5-tuples mlift5 :: Monad m => (a' -> b' -> c' -> d' -> e' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (a, b, c, d, e) -> m r-mlift5 k f g h i j (a, b, c, d, e) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> return $ k a' b' c' d' e'+mlift5 k f g h i j (a, b, c, d, e) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> pure $ k a' b' c' d' e' -- | Monadic lift over 6-tuples mlift6 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (a, b, c, d, e, f) -> m r-mlift6 k f g h i j l (a, b, c, d, e, y) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> return $ k a' b' c' d' e' y'+mlift6 k f g h i j l (a, b, c, d, e, y) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> pure $ k a' b' c' d' e' y' -- | Monadic lift over 7-tuples mlift7 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> g' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (g -> m g') -> (a, b, c, d, e, f, g) -> m r-mlift7 k f g h i j l m (a, b, c, d, e, y, z) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> return $ k a' b' c' d' e' y' z'+mlift7 k f g h i j l m (a, b, c, d, e, y, z) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> pure $ k a' b' c' d' e' y' z' -- | Monadic lift over 8-tuples mlift8 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> g' -> h' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (g -> m g') -> (h -> m h') -> (a, b, c, d, e, f, g, h) -> m r-mlift8 k f g h i j l m n (a, b, c, d, e, y, z, w) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> n w >>= \w' -> return $ k a' b' c' d' e' y' z' w'+mlift8 k f g h i j l m n (a, b, c, d, e, y, z, w) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> n w >>= \w' -> pure $ k a' b' c' d' e' y' z' w' -- Command line argument parsing code courtesy of Neil Mitchell's cmdargs package: see -- <http://github.com/ndmitchell/cmdargs/blob/master/System/Console/CmdArgs/Explicit/SplitJoin.hs>@@ -122,6 +142,10 @@ -- Otherwise, just proceed; hopefully we covered everything above go (c : rest) = c : go rest +-- | Show a value as 'Text'.+showText :: Show a => a -> Text+showText = T.pack . show+ -- | Given a Haskell string, convert it to SMTLib. if ord is 0x00020 to 0x0007E, then we print it as is -- to cover the printable ASCII range. stringToQFS :: String -> String@@ -131,3 +155,138 @@ | oc >= 0x20 && oc <= 0x7E = [c] | True = "\\u{" ++ showHex oc "" ++ "}" where oc = ord c++-- | Check if an observable name is good.+checkObservableName :: String -> Maybe String+checkObservableName lbl+ | null lbl+ = Just "SBV.observe: Bad empty name!"+ | isReserved lbl+ = Just $ "SBV.observe: The name chosen is reserved, please change it!: " ++ show lbl+ | "s" `isPrefixOf` lbl && all isDigit (drop 1 lbl)+ = Just $ "SBV.observe: Names of the form sXXX are internal to SBV, please use a different name: " ++ show lbl+ | True+ = Nothing++-- Remove one pair of surrounding 'c's, if present+noSurrounding :: Char -> String -> String+noSurrounding c (c':cs@(_:_)) | c == c' && c == last cs = init cs+noSurrounding _ s = s++-- Remove a pair of surrounding quotes+unQuote :: String -> String+unQuote = noSurrounding '"'++-- Remove a pair of surrounding bars+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+ && "|" `isSuffixOf` nm+ && length nm > 2+ && not (any (`elem` ("|\\" :: String)) (drop 1 (init nm)))++-- Does this name need bar in SMTLib2?+needsBars :: String -> Bool+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]+nameSupply preSupply = preSupply ++ map mkUnique extras+ where extras = ["x", "y", "z"] -- x y z+ ++ [[c] | c <- ['a' .. 'w']] -- a b c ... w+ ++ ['x' : show i | i <- [(1::Int) ..]] -- x1 x2 x3 ...++ -- make sure extras are different than preSupply. Note that extras+ -- themselves are unique, so we only have to check the preSupply+ mkUnique x | x `elem` preSupply = mkUnique $ x ++ "'"+ | True = x++-- Different arities of curry/uncurry+curry2 :: ((a, b) -> z) -> a -> b -> z+curry2 fn a b = fn (a, b)++curry3 :: ((a, b, c) -> z) -> a -> b -> c -> z+curry3 fn a b c = fn (a, b, c)++curry4 :: ((a, b, c, d) -> z) -> a -> b -> c -> d -> z+curry4 fn a b c d = fn (a, b, c, d)++curry5 :: ((a, b, c, d, e) -> z) -> a -> b -> c -> d -> e -> z+curry5 fn a b c d e = fn (a, b, c, d, e)++curry6 :: ((a, b, c, d, e, f) -> z) -> a -> b -> c -> d -> e -> f -> z+curry6 fn a b c d e f = fn (a, b, c, d, e, f)++curry7 :: ((a, b, c, d, e, f, g) -> z) -> a -> b -> c -> d -> e -> f -> g -> z+curry7 fn a b c d e f g = fn (a, b, c, d, e, f, g)++curry8 :: ((a, b, c, d, e, f, g, h) -> z) -> a -> b -> c -> d -> e -> f -> g -> h -> z+curry8 fn a b c d e f g h = fn (a, b, c, d, e, f, g, h)++curry9 :: ((a, b, c, d, e, f, g, h, i) -> z) -> a -> b -> c -> d -> e -> f -> g -> h -> i -> z+curry9 fn a b c d e f g h i = fn (a, b, c, d, e, f, g, h, i)++curry10 :: ((a, b, c, d, e, f, g, h, i, j) -> z) -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> z+curry10 fn a b c d e f g h i j = fn (a, b, c, d, e, f, g, h, i, j)++curry11 :: ((a, b, c, d, e, f, g, h, i, j, k) -> z) -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> z+curry11 fn a b c d e f g h i j k = fn (a, b, c, d, e, f, g, h, i, j, k)++curry12 :: ((a, b, c, d, e, f, g, h, i, j, k, l) -> z) -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> z+curry12 fn a b c d e f g h i j k l = fn (a, b, c, d, e, f, g, h, i, j, k, l)++uncurry2 :: (a -> b -> z) -> (a, b) -> z+uncurry2 fn (a, b) = fn a b++uncurry3 :: (a -> b -> c -> z) -> (a, b, c) -> z+uncurry3 fn (a, b, c) = fn a b c++uncurry4 :: (a -> b -> c -> d -> z) -> (a, b, c, d) -> z+uncurry4 fn (a, b, c, d) = fn a b c d++uncurry5 :: (a -> b -> c -> d -> e -> z) -> (a, b, c, d, e) -> z+uncurry5 fn (a, b, c, d, e) = fn a b c d e++uncurry6 :: (a -> b -> c -> d -> e -> f -> z) -> (a, b, c, d, e, f) -> z+uncurry6 fn (a, b, c, d, e, f) = fn a b c d e f++uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> z) -> (a, b, c, d, e, f, g) -> z+uncurry7 fn (a, b, c, d, e, f, g) = fn a b c d e f g++uncurry8 :: (a -> b -> c -> d -> e -> f -> g -> h -> z) -> (a, b, c, d, e, f, g, h) -> z+uncurry8 fn (a, b, c, d, e, f, g, h) = fn a b c d e f g h++uncurry9 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> z) -> (a, b, c, d, e, f, g, h, i) -> z+uncurry9 fn (a, b, c, d, e, f, g, h, i) = fn a b c d e f g h i++uncurry10 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> z) -> (a, b, c, d, e, f, g, h, i, j) -> z+uncurry10 fn (a, b, c, d, e, f, g, h, i, j) = fn a b c d e f g h i j++uncurry11 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> z) -> (a, b, c, d, e, f, g, h, i, j, k) -> z+uncurry11 fn (a, b, c, d, e, f, g, h, i, j, k) = fn a b c d e f g h i j k++uncurry12 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> z) -> (a, b, c, d, e, f, g, h, i, j, k, l) -> z+uncurry12 fn (a, b, c, d, e, f, g, h, i, j, k, l) = fn a b c d e f g h i j k l++-- | Convert a map to a list of @(value, key)@ pairs, sorted by value.+-- Useful when the map is keyed by a descriptor but indexed by an integer+-- that determines output order.+mapToSortedList :: Ord v => Map.Map k v -> [(v, k)]+mapToSortedList = sortBy (comparing fst) . map (\(a, b) -> (b, a)) . Map.toList
Data/SBV/Utils/Numeric.hs view
@@ -9,23 +9,30 @@ -- Various number related utilities ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Utils.Numeric ( fpMaxH, fpMinH, fp2fp, fpRemH, fpRoundToIntegralH, fpIsEqualObjectH, fpCompareObjectH, fpIsNormalizedH+ , roundAway+ , divEucl, modEucl , floatToWord, wordToFloat, doubleToWord, wordToDouble+ , RoundingMode(..), smtRoundingMode ) where import Data.Word+import Data.Text (Text) import Data.Array.ST (newArray, readArray, MArray, STUArray) import Data.Array.Unsafe (castSTUArray) import GHC.ST (runST, ST) +import Test.QuickCheck (Arbitrary(..), elements)+ -- | The SMT-Lib (in particular Z3) implementation for min/max for floats does not agree with -- Haskell's; and also it does not agree with what the hardware does. Sigh.. See:--- <http://ghc.haskell.org/trac/ghc/ticket/10378>+-- <https://gitlab.haskell.org/ghc/ghc/-/issues/10378> -- <http://github.com/Z3Prover/z3/issues/68> -- So, we codify here what the Z3 (SMTLib) is implementing for fpMax. -- The discrepancy with Haskell is that the NaN propagation doesn't work in Haskell@@ -55,9 +62,9 @@ -- except careful on NaN, Infinities, and -0. fp2fp :: (RealFloat a, RealFloat b) => a -> b fp2fp x- | isNaN x = 0 / 0- | isInfinite x && x < 0 = -1 / 0- | isInfinite x = 1 / 0+ | isNaN x = 0 / 0+ | isInfinite x && x < 0 = -(1 / 0)+ | isInfinite x = 1 / 0 | isNegativeZero x = negate 0 | True = fromRational (toRational x) @@ -69,7 +76,7 @@ | isInfinite x || isNaN x = 0 / 0 | y == 0 || isNaN y = 0 / 0 | isInfinite y = x- | True = pSign (x - fromRational (fromInteger d * ry))+ | True = pSign (fromRational (rx - fromInteger d * ry)) where rx, ry, rd :: Rational rx = toRational x ry = toRational y@@ -87,7 +94,7 @@ | isNaN x = x | x == 0 = x | isInfinite x = x- | i == 0 = if x < 0 || isNegativeZero x then -0.0 else 0.0+ | i == 0 = if x < 0 then -0.0 else 0.0 | True = fromInteger i where i :: Integer i = round x@@ -120,6 +127,33 @@ fpIsNormalizedH :: RealFloat a => a -> Bool fpIsNormalizedH x = not (isDenormalized x || isInfinite x || isNaN x || x == 0) +-- | @'roundAway' x@ returns the nearest integer to @x@; the integer furthest+-- away from @0@ if @x@ is equidistant between two integers.++-- This implementation is taken directly from the @fp-ieee@ library. Somewhat+-- surprisingly, 'roundAway' is not a method of the 'RealFrac' class!+roundAway :: (RealFrac a, Integral b) => a -> b+roundAway x = case properFraction x of+ -- x == n + f, signum x == signum f, 0 <= abs f < 1+ (n,r) -> if abs r < 0.5 then+ n+ else+ if r < 0 then+ n - 1+ else+ n + 1++-- | Euclidean division. @'divEucl' a b@ returns the integer @q@ satisfying the+-- equations @a = (b * q) + r@ and @0 <= r < abs b@, where @'modEucl' a b = r@.+divEucl :: Integral a => a -> a -> a+divEucl a b = div a (abs b) * signum b++-- | Euclidean modular division. @'modEucl' a b@ returns the integer @r@+-- satisfying the equations @a = (b * q) + r@ and @0 <= r < abs b@, where+-- @'divEucl' a b = q@.+modEucl :: Integral a => a -> a -> a+modEucl a b = mod a (abs b)+ ------------------------------------------------------------------------- -- Reinterpreting float/double as word32/64 and back. Here, we use the -- definitions from the reinterpret-cast package:@@ -152,3 +186,30 @@ {-# INLINE cast #-} cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0++-- | Rounding mode to be used for the IEEE floating-point operations.+-- Note that Haskell's default is 'RoundNearestTiesToEven'. If you use+-- a different rounding mode, then the counter-examples you get may not+-- match what you observe in Haskell.+data RoundingMode = RoundNearestTiesToEven -- ^ Round to nearest representable floating point value.+ -- If precisely at half-way, pick the even number.+ -- (In this context, /even/ means the lowest-order bit is zero.)+ | RoundNearestTiesToAway -- ^ Round to nearest representable floating point value.+ -- If precisely at half-way, pick the number further away from 0.+ -- (That is, for positive values, pick the greater; for negative values, pick the smaller.)+ | RoundTowardPositive -- ^ Round towards positive infinity. (Also known as rounding-up or ceiling.)+ | RoundTowardNegative -- ^ Round towards negative infinity. (Also known as rounding-down or floor.)+ | RoundTowardZero -- ^ Round towards zero. (Also known as truncation.)+ deriving (Show, Enum, Bounded)++-- | Arbitrary instance for 'RoundingMode'+instance Arbitrary RoundingMode where+ arbitrary = elements [minBound .. maxBound]++-- | Convert a rounding mode to the format SMT-Lib2 understands.+smtRoundingMode :: RoundingMode -> Text+smtRoundingMode RoundNearestTiesToEven = "roundNearestTiesToEven"+smtRoundingMode RoundNearestTiesToAway = "roundNearestTiesToAway"+smtRoundingMode RoundTowardPositive = "roundTowardPositive"+smtRoundingMode RoundTowardNegative = "roundTowardNegative"+smtRoundingMode RoundTowardZero = "roundTowardZero"
Data/SBV/Utils/PrettyNum.hs view
@@ -10,24 +10,27 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Utils.PrettyNum ( PrettyNum(..), readBin, shex, chex, shexI, sbin, sbinI , showCFloat, showCDouble, showHFloat, showHDouble, showBFloat, showFloatAtBase- , showSMTFloat, showSMTDouble, smtRoundingMode, cvToSMTLib, mkSkolemZero+ , showSMTFloat, showSMTDouble, smtRoundingMode, cvToSMTLib , showNegativeNumber ) where -import Data.Bits ((.&.), countTrailingZeros)-import Data.Char (intToDigit, ord, chr, toUpper)+import Data.Bits ((.&.), countTrailingZeros, testBit)+import Data.Char (intToDigit, ord, chr) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (isPrefixOf)-import Data.Maybe (fromJust, fromMaybe, listToMaybe)+import Data.Maybe (fromMaybe, listToMaybe) import Data.Ratio (numerator, denominator) import Data.Word (Word8, Word16, Word32, Word64)+import Data.Text (Text)+import qualified Data.Text as T import qualified Data.Set as Set @@ -35,44 +38,45 @@ import qualified Numeric as N (showHFloat) import Data.SBV.Core.Data-import Data.SBV.Core.Kind (smtType, smtRoundingMode, showBaseKind)+import Data.SBV.Core.Kind (smtType, showBaseKind) import Data.SBV.Core.AlgReals (algRealToSMTLib2) import Data.SBV.Core.SizedFloats (fprToSMTLib2, bfToString) -import Data.SBV.Utils.Lib (stringToQFS)+import Data.SBV.Utils.Lib (stringToQFS, showText)+import Data.SBV.Utils.Numeric (smtRoundingMode, floatToWord, doubleToWord) -- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers. class PrettyNum a where -- | Show a number in hexadecimal, starting with @0x@ and type.- hexS :: a -> String+ hexS :: a -> Text -- | Show a number in binary, starting with @0b@ and type.- binS :: a -> String+ binS :: a -> Text -- | Show a number in hexadecimal, starting with @0x@ but no type.- hexP :: a -> String+ hexP :: a -> Text -- | Show a number in binary, starting with @0b@ but no type.- binP :: a -> String+ binP :: a -> Text -- | Show a number in hex, without prefix, or types.- hex :: a -> String+ hex :: a -> Text -- | Show a number in bin, without prefix, or types.- bin :: a -> String+ bin :: a -> Text -- Why not default methods? Because defaults need "Integral a" but Bool is not.. instance PrettyNum Bool where- hexS = show- binS = show- hexP = show- binP = show- hex = show- bin = show+ hexS = showText+ binS = showText+ hexP = showText+ binP = showText+ hex = showText+ bin = showText instance PrettyNum String where- hexS = show- binS = show- hexP = show- binP = show- hex = show- bin = show+ hexS = showText+ binS = showText+ hexP = showText+ binP = showText+ hex = showText+ bin = showText instance PrettyNum Word8 where hexS = shex True True (False, 8)@@ -164,106 +168,77 @@ hex = shexI False False bin = sbinI False False -shBKind :: HasKind a => a -> String-shBKind a = " :: " ++ showBaseKind (kindOf a)+shBKind :: HasKind a => a -> Text+shBKind a = " :: " <> showBaseKind (kindOf a) instance PrettyNum CV where- hexS cv | isUserSort cv = shows cv $ shBKind cv- | isBoolean cv = hexS (cvToBool cv) ++ shBKind cv- | isFloat cv = let CFloat f = cvVal cv in N.showHFloat f $ shBKind cv- | isDouble cv = let CDouble d = cvVal cv in N.showHFloat d $ shBKind cv- | isFP cv = let CFP f = cvVal cv in bfToString 16 True True f ++ shBKind cv- | isReal cv = let CAlgReal r = cvVal cv in show r ++ shBKind cv- | isString cv = let CString s = cvVal cv in show s ++ shBKind cv- | not (isBounded cv) = let CInteger i = cvVal cv in shexI True True i- | True = let CInteger i = cvVal cv in shex True True (hasSign cv, intSizeOf cv) i-- binS cv | isUserSort cv = shows cv $ shBKind cv- | isBoolean cv = binS (cvToBool cv) ++ shBKind cv- | isFloat cv = let CFloat f = cvVal cv in showBFloat f $ shBKind cv- | isDouble cv = let CDouble d = cvVal cv in showBFloat d $ shBKind cv- | isFP cv = let CFP f = cvVal cv in bfToString 2 True True f ++ shBKind cv- | isReal cv = let CAlgReal r = cvVal cv in shows r $ shBKind cv- | isString cv = let CString s = cvVal cv in shows s $ shBKind cv- | not (isBounded cv) = let CInteger i = cvVal cv in sbinI True True i- | True = let CInteger i = cvVal cv in sbin True True (hasSign cv, intSizeOf cv) i-- hexP cv | isUserSort cv = show cv- | isBoolean cv = hexS (cvToBool cv)- | isFloat cv = let CFloat f = cvVal cv in show f- | isDouble cv = let CDouble d = cvVal cv in show d- | isFP cv = let CFP f = cvVal cv in bfToString 16 True True f- | isReal cv = let CAlgReal r = cvVal cv in show r- | isString cv = let CString s = cvVal cv in show s- | not (isBounded cv) = let CInteger i = cvVal cv in shexI False True i- | True = let CInteger i = cvVal cv in shex False True (hasSign cv, intSizeOf cv) i-- binP cv | isUserSort cv = show cv- | isBoolean cv = binS (cvToBool cv)- | isFloat cv = let CFloat f = cvVal cv in show f- | isDouble cv = let CDouble d = cvVal cv in show d- | isFP cv = let CFP f = cvVal cv in bfToString 2 True True f- | isReal cv = let CAlgReal r = cvVal cv in show r- | isString cv = let CString s = cvVal cv in show s- | not (isBounded cv) = let CInteger i = cvVal cv in sbinI False True i- | True = let CInteger i = cvVal cv in sbin False True (hasSign cv, intSizeOf cv) i-- hex cv | isUserSort cv = show cv- | isBoolean cv = hexS (cvToBool cv)- | isFloat cv = let CFloat f = cvVal cv in show f- | isDouble cv = let CDouble d = cvVal cv in show d- | isFP cv = let CFP f = cvVal cv in bfToString 16 False True f- | isReal cv = let CAlgReal r = cvVal cv in show r- | isString cv = let CString s = cvVal cv in show s- | not (isBounded cv) = let CInteger i = cvVal cv in shexI False False i- | True = let CInteger i = cvVal cv in shex False False (hasSign cv, intSizeOf cv) i+ hexS = cvPretty True True True True (\f -> T.pack (N.showHFloat f "")) (\d -> T.pack (N.showHFloat d ""))+ binS = cvPretty False True True True (\f -> T.pack (showBFloat f "")) (\d -> T.pack (showBFloat d ""))+ hexP = cvPretty True False True False showText showText+ binP = cvPretty False False True False showText showText+ hex = cvPretty True False False False showText showText+ bin = cvPretty False False False False showText showText - bin cv | isUserSort cv = show cv- | isBoolean cv = binS (cvToBool cv)- | isFloat cv = let CFloat f = cvVal cv in show f- | isDouble cv = let CDouble d = cvVal cv in show d- | isFP cv = let CFP f = cvVal cv in bfToString 2 False True f- | isReal cv = let CAlgReal r = cvVal cv in show r- | isString cv = let CString s = cvVal cv in show s- | not (isBounded cv) = let CInteger i = cvVal cv in sbinI False False i- | True = let CInteger i = cvVal cv in sbin False False (hasSign cv, intSizeOf cv) i+-- | Factor out the common structure of PrettyNum CV methods+cvPretty :: Bool -- ^ isHex (True) or isBin (False)+ -> Bool -- ^ Show type suffix on integers+ -> Bool -- ^ Show prefix (0x/0b) on integers+ -> Bool -- ^ Show kind suffix on non-integer cases+ -> (Float -> Text) -- ^ Float formatter+ -> (Double -> Text) -- ^ Double formatter+ -> CV -> Text+cvPretty isHex shType shPre shKind fmtF fmtD cv+ | isADT cv = showText cv <> knd+ | isBoolean cv = (if isHex then hexS else binS) (cvToBool cv) <> knd+ | isFloat cv, CFloat f <- cvVal cv = fmtF f <> knd+ | isDouble cv, CDouble d <- cvVal cv = fmtD d <> knd+ | isFP cv, CFP f <- cvVal cv = T.pack (bfToString base shPre True f) <> knd+ | isReal cv, CAlgReal r <- cvVal cv = showText r <> knd+ | isString cv, CString s <- cvVal cv = showText s <> knd+ | not (isBounded cv), CInteger i <- cvVal cv = intI i+ | CInteger i <- cvVal cv = intB (hasSign cv, intSizeOf cv) i+ | True = error $ "PrettyNum: Received CV that can't be displayed: " ++ show cv+ where knd = if shKind then shBKind cv else ""+ base = if isHex then 16 else 2+ intI = (if isHex then shexI else sbinI) shType shPre+ intB = (if isHex then shex else sbin) shType shPre instance (SymVal a, PrettyNum a) => PrettyNum (SBV a) where- hexS s = maybe (show s) (hexS :: a -> String) $ unliteral s- binS s = maybe (show s) (binS :: a -> String) $ unliteral s+ hexS s = maybe (showText s) (hexS :: a -> Text) $ unliteral s+ binS s = maybe (showText s) (binS :: a -> Text) $ unliteral s - hexP s = maybe (show s) (hexP :: a -> String) $ unliteral s- binP s = maybe (show s) (binP :: a -> String) $ unliteral s+ hexP s = maybe (showText s) (hexP :: a -> Text) $ unliteral s+ binP s = maybe (showText s) (binP :: a -> Text) $ unliteral s - hex s = maybe (show s) (hex :: a -> String) $ unliteral s- bin s = maybe (show s) (bin :: a -> String) $ unliteral s+ hex s = maybe (showText s) (hex :: a -> Text) $ unliteral s+ bin s = maybe (showText s) (bin :: a -> Text) $ unliteral s -- | Show as a hexadecimal value. First bool controls whether type info is printed -- while the second boolean controls whether 0x prefix is printed. The tuple is -- the signedness and the bit-length of the input. The length of the string -- will /not/ depend on the value, but rather the bit-length.-shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String+shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> Text shex shType shPre (signed, size) a | a < 0- = "-" ++ pre ++ pad l (s16 (abs (fromIntegral a :: Integer))) ++ t+ = "-" <> pre <> T.pack (pad l (s16 (abs (fromIntegral a :: Integer)))) <> t | True- = pre ++ pad l (s16 a) ++ t- where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size- | True = ""+ = pre <> T.pack (pad l (s16 a)) <> t+ where t | shType = " :: " <> (if signed then "Int" else "Word") <> showText size+ | True = T.empty pre | shPre = "0x"- | True = ""+ | True = T.empty l = (size + 3) `div` 4 -- | Show as hexadecimal, but for C programs. We have to be careful about -- printing min-bounds, since C does some funky casting, possibly losing -- the sign bit. In those cases, we use the defined constants in <stdint.h>. -- We also properly append the necessary suffixes as needed.-chex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String+chex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> Text chex shType shPre (signed, size) a | Just s <- (signed, size, fromIntegral a) `lookup` specials- = s+ = T.pack s | True- = shex shType shPre (signed, size) a ++ suffix+ = shex shType shPre (signed, size) a <> T.pack suffix where specials :: [((Bool, Int, Integer), String)] specials = [ ((True, 8, fromIntegral (minBound :: Int8)), "INT8_MIN" ) , ((True, 16, fromIntegral (minBound :: Int16)), "INT16_MIN")@@ -284,40 +259,40 @@ -- | Show as a hexadecimal value, integer version. Almost the same as shex above -- except we don't have a bit-length so the length of the string will depend -- on the actual value.-shexI :: Bool -> Bool -> Integer -> String+shexI :: Bool -> Bool -> Integer -> Text shexI shType shPre a | a < 0- = "-" ++ pre ++ s16 (abs a) ++ t+ = "-" <> pre <> T.pack (s16 (abs a)) <> t | True- = pre ++ s16 a ++ t+ = pre <> T.pack (s16 a) <> t where t | shType = " :: Integer"- | True = ""+ | True = T.empty pre | shPre = "0x"- | True = ""+ | True = T.empty -- | Similar to 'shex'; except in binary.-sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String+sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> Text sbin shType shPre (signed,size) a | a < 0- = "-" ++ pre ++ pad size (s2 (abs (fromIntegral a :: Integer))) ++ t+ = "-" <> pre <> T.pack (pad size (s2 (abs (fromIntegral a :: Integer)))) <> t | True- = pre ++ pad size (s2 a) ++ t- where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size- | True = ""+ = pre <> T.pack (pad size (s2 a)) <> t+ where t | shType = " :: " <> (if signed then "Int" else "Word") <> showText size+ | True = T.empty pre | shPre = "0b"- | True = ""+ | True = T.empty -- | Similar to 'shexI'; except in binary.-sbinI :: Bool -> Bool -> Integer -> String+sbinI :: Bool -> Bool -> Integer -> Text sbinI shType shPre a | a < 0- = "-" ++ pre ++ s2 (abs a) ++ t+ = "-" <> pre <> T.pack (s2 (abs a)) <> t | True- = pre ++ s2 a ++ t+ = pre <> T.pack (s2 a) <> t where t | shType = " :: Integer"- | True = ""+ | True = T.empty pre | shPre = "0b"- | True = ""+ | True = T.empty -- | Pad a string to a given length. If the string is longer, then we don't drop anything. pad :: Int -> String -> String@@ -325,7 +300,7 @@ -- | Binary printer s2 :: (Show a, Integral a) => a -> String-s2 v = showIntAtBase 2 dig v "" where dig = fromJust . flip lookup [(0, '0'), (1, '1')]+s2 v = showIntAtBase 2 intToDigit v "" -- | Hex printer s16 :: (Show a, Integral a) => a -> String@@ -338,7 +313,7 @@ [(a, "")] -> a _ -> error $ "SBV.readBin: Cannot read a binary number from: " ++ show s where cvt c = ord c - ord '0'- isDigit = (`elem` "01")+ isDigit = (`elem` ("01" :: String)) s' | "0b" `isPrefixOf` s = drop 2 s | True = s @@ -375,53 +350,52 @@ | True = show d -- | A version of show for floats that generates correct SMTLib literals using the rounding mode-showSMTFloat :: RoundingMode -> Float -> String-showSMTFloat rm f+showSMTFloat :: Float -> Text+showSMTFloat f | isNaN f = as "NaN" | isInfinite f, f < 0 = as "-oo" | isInfinite f = as "+oo" | isNegativeZero f = as "-zero" | f == 0 = as "+zero"- | True = "((_ to_fp 8 24) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational f) ++ ")"- where as s = "(_ " ++ s ++ " 8 24)"-+ | True = let w = floatToWord f+ b i = if w `testBit` i then '1' else '0'+ s = T.pack [b 31]+ e = T.pack [b i | i <- [30, 29 .. 23]]+ m = T.pack [b i | i <- [22, 21 .. 0]]+ in "(fp #b" <> s <> " #b" <> e <> " #b" <> m <> ")"+ where as s = "(_ " <> s <> " 8 24)" -- | A version of show for doubles that generates correct SMTLib literals using the rounding mode-showSMTDouble :: RoundingMode -> Double -> String-showSMTDouble rm d+showSMTDouble :: Double -> Text+showSMTDouble d | isNaN d = as "NaN" | isInfinite d, d < 0 = as "-oo" | isInfinite d = as "+oo" | isNegativeZero d = as "-zero" | d == 0 = as "+zero"- | True = "((_ to_fp 11 53) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational d) ++ ")"- where as s = "(_ " ++ s ++ " 11 53)"+ | True = let w = doubleToWord d+ b i = if w `testBit` i then '1' else '0'+ s = T.pack [b 63]+ e = T.pack [b i | i <- [62, 61 .. 52]]+ m = T.pack [b i | i <- [51, 50 .. 0]]+ in "(fp #b" <> s <> " #b" <> e <> " #b" <> m <> ")"+ where as s = "(_ " <> s <> " 11 53)" -- | Show an SBV rational as an SMTLib value. This is used for faithful rationals.-showSMTRational :: Rational -> String-showSMTRational r = "(SBV.Rational " ++ showNegativeNumber (numerator r) ++ " " ++ showNegativeNumber (denominator r) ++ ")"---- | Show a rational in SMTLib format. This is used for conversions from regular rationals.-toSMTLibRational :: Rational -> String-toSMTLibRational r- | n < 0- = "(- (/ " ++ show (abs n) ++ ".0 " ++ show d ++ ".0))"- | True- = "(/ " ++ show n ++ ".0 " ++ show d ++ ".0)"- where n = numerator r- d = denominator r+showSMTRational :: Rational -> Text+showSMTRational r = "(SBV.Rational " <> showNegativeNumber (numerator r) <> " " <> showNegativeNumber (denominator r) <> ")" -- | Convert a CV to an SMTLib2 compliant value-cvToSMTLib :: RoundingMode -> CV -> String-cvToSMTLib rm x+cvToSMTLib :: CV -> Text+cvToSMTLib x | isBoolean x, CInteger w <- cvVal x = if w == 0 then "false" else "true"- | isUserSort x, CUserSort (_, s) <- cvVal x = roundModeConvert s- | isReal x, CAlgReal r <- cvVal x = algRealToSMTLib2 r- | isFloat x, CFloat f <- cvVal x = showSMTFloat rm f- | isDouble x, CDouble d <- cvVal x = showSMTDouble rm d+ | isRoundingMode x, CADT (s, []) <- cvVal x = roundModeConvert s+ | isReal x, CAlgReal r <- cvVal x = T.pack (algRealToSMTLib2 r) | isRational x, CRational r <- cvVal x = showSMTRational r- | isFP x, CFP f <- cvVal x = fprToSMTLib2 f- | not (isBounded x), CInteger w <- cvVal x = if w >= 0 then show w else "(- " ++ show (abs w) ++ ")"+ | isFloat x, CFloat f <- cvVal x = showSMTFloat f+ | isDouble x, CDouble d <- cvVal x = showSMTDouble d+ | isFP x, CFP f <- cvVal x = T.pack (fprToSMTLib2 f)+ | not (isBounded x), CInteger w <- cvVal x = if w >= 0 then showText w else "(- " <> showText (abs w) <> ")" | not (hasSign x) , CInteger w <- cvVal x = smtLibHex (intSizeOf x) w -- signed numbers (with 2's complement representation) is problematic -- since there's no way to put a bvneg over a positive number to get minBound..@@ -429,38 +403,42 @@ | hasSign x , CInteger w <- cvVal x = if w == negate (2 ^ intSizeOf x) then mkMinBound (intSizeOf x) else negIf (w < 0) $ smtLibHex (intSizeOf x) (abs w)- | isChar x , CChar c <- cvVal x = "(_ char " ++ smtLibHex 8 (fromIntegral (ord c)) ++ ")"- | isString x , CString s <- cvVal x = '\"' : stringToQFS s ++ "\""+ | isChar x , CChar c <- cvVal x = "(_ char " <> smtLibHex 8 (fromIntegral (ord c)) <> ")"+ | isString x , CString s <- cvVal x = "\"" <> T.pack (stringToQFS s) <> "\"" | isList x , CList xs <- cvVal x = smtLibSeq (kindOf x) xs | isSet x , CSet s <- cvVal x = smtLibSet (kindOf x) s | isTuple x , CTuple xs <- cvVal x = smtLibTup (kindOf x) xs- | isMaybe x , CMaybe mc <- cvVal x = smtLibMaybe (kindOf x) mc- | isEither x , CEither ec <- cvVal x = smtLibEither (kindOf x) ec + -- Arrays become sequence of stores+ | isArray x , CArray ac <- cvVal x = smtLibArray (kindOf x) ac++ -- ADTs+ | isADT x , CADT c <- cvVal x = smtLibADT (cvKind x) c+ | True = error $ "SBV.cvtCV: Impossible happened: Kind/Value disagreement on: " ++ show (kindOf x, x)- where roundModeConvert s = fromMaybe s (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s])+ where roundModeConvert s = fromMaybe (T.pack s) (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s]) -- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time -- being, SBV only supports sizes that are multiples of 4, but the below code is more robust -- in case of future extensions to support arbitrary sizes.- smtLibHex :: Int -> Integer -> String- smtLibHex 1 v = "#b" ++ show v+ smtLibHex :: Int -> Integer -> Text+ smtLibHex 1 v = "#b" <> showText v smtLibHex sz v- | sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "")- | True = "#b" ++ pad sz (showBin v "")+ | sz `mod` 4 == 0 = "#x" <> T.pack (pad (sz `div` 4) (showHex v ""))+ | True = "#b" <> T.pack (pad sz (showBin v "")) where showBin = showIntAtBase 2 intToDigit- negIf :: Bool -> String -> String- negIf True a = "(bvneg " ++ a ++ ")"+ negIf :: Bool -> Text -> Text+ negIf True a = "(bvneg " <> a <> ")" negIf False a = a - smtLibSeq :: Kind -> [CVal] -> String- smtLibSeq k [] = "(as seq.empty " ++ smtType k ++ ")"+ smtLibSeq :: Kind -> [CVal] -> Text+ smtLibSeq k [] = "(as seq.empty " <> smtType k <> ")" smtLibSeq (KList ek) xs = let mkSeq [e] = e- mkSeq es = "(seq.++ " ++ unwords es ++ ")"- mkUnit inner = "(seq.unit " ++ inner ++ ")"- in mkSeq (mkUnit . cvToSMTLib rm . CV ek <$> xs)- smtLibSeq k _ = error "SBV.cvToSMTLib: Impossible case (smtLibSeq), received kind: " ++ show k+ mkSeq es = "(seq.++ " <> T.unwords es <> ")"+ mkUnit inner = "(seq.unit " <> inner <> ")"+ in mkSeq (mkUnit . cvToSMTLib . CV ek <$> xs)+ smtLibSeq k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibSeq), received kind: " ++ show k - smtLibSet :: Kind -> RCSet CVal -> String+ smtLibSet :: Kind -> RCSet CVal -> Text smtLibSet k set = case set of RegularSet rs -> Set.foldr' (modify "true") (start "false") rs ComplementSet rs -> Set.foldr' (modify "false") (start "true") rs@@ -468,38 +446,38 @@ KSet ek -> ek _ -> error $ "SBV.cvToSMTLib: Impossible case (smtLibSet), received kind: " ++ show k - start def = "((as const " ++ smtType k ++ ") " ++ def ++ ")"+ start def = "((as const " <> smtType k <> ") " <> def <> ")" - modify how e s = "(store " ++ s ++ " " ++ cvToSMTLib rm (CV ke e) ++ " " ++ how ++ ")"+ modify how e s = "(store " <> s <> " " <> cvToSMTLib (CV ke e) <> " " <> how <> ")" - smtLibTup :: Kind -> [CVal] -> String+ smtLibTup :: Kind -> [CVal] -> Text smtLibTup (KTuple []) _ = "mkSBVTuple0"- smtLibTup (KTuple ks) xs = "(mkSBVTuple" ++ show (length ks) ++ " " ++ unwords (zipWith (\ek e -> cvToSMTLib rm (CV ek e)) ks xs) ++ ")"+ smtLibTup (KTuple ks) xs = "(mkSBVTuple" <> showText (length ks) <> " " <> T.unwords (zipWith (\ek e -> cvToSMTLib (CV ek e)) ks xs) <> ")" smtLibTup k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibTup), received kind: " ++ show k - dtConstructor fld [] res = "(as " ++ fld ++ " " ++ smtType res ++ ")"- dtConstructor fld args res = "((as " ++ fld ++ " " ++ smtType res ++ ") " ++ unwords args ++ ")"+ -- Remember that in an ArrayModel we keep a history; i.e., the earlier elements are written later. So, we reverse the assocs+ smtLibArray :: Kind -> ArrayModel CVal CVal -> Text+ smtLibArray k@(KArray k1 k2) (ArrayModel assocs def) = mkStoreChain k k1 k2 (reverse assocs) def+ smtLibArray k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibArray), received non-matching kind: " ++ show k - smtLibMaybe :: Kind -> Maybe CVal -> String- smtLibMaybe km@KMaybe{} Nothing = dtConstructor "nothing_SBVMaybe" [] km- smtLibMaybe km@(KMaybe k) (Just c) = dtConstructor "just_SBVMaybe" [cvToSMTLib rm (CV k c)] km- smtLibMaybe k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibMaybe), received kind: " ++ show k+ mkStoreChain k k1 k2 writes def = walk writes base+ where base = "((as const " <> smtType k <> ") " <> cvToSMTLib (CV k2 def) <> ")" - smtLibEither :: Kind -> Either CVal CVal -> String- smtLibEither ke@(KEither k _) (Left c) = dtConstructor "left_SBVEither" [cvToSMTLib rm (CV k c)] ke- smtLibEither ke@(KEither _ k) (Right c) = dtConstructor "right_SBVEither" [cvToSMTLib rm (CV k c)] ke- smtLibEither k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibEither), received kind: " ++ show k+ walk [] sofar = sofar+ walk ((key, val) : rest) sofar = walk rest (store key val sofar) + store key val sofar = "(store " <> sofar <> " " <> cvToSMTLib (CV k1 key) <> " " <> cvToSMTLib (CV k2 val) <> ")"+ -- anomaly at the 2's complement min value! Have to use binary notation here -- as there is no positive value we can provide to make the bvneg work.. (see above)- mkMinBound :: Int -> String- mkMinBound i = "#b1" ++ replicate (i-1) '0'+ mkMinBound :: Int -> Text+ mkMinBound i = "#b1" <> T.replicate (i-1) "0" --- | Create a skolem 0 for the kind-mkSkolemZero :: RoundingMode -> Kind -> String-mkSkolemZero _ (KUserSort _ (Just (f:_))) = f-mkSkolemZero _ (KUserSort s _) = error $ "SBV.mkSkolemZero: Unexpected user sort: " ++ s-mkSkolemZero rm k = cvToSMTLib rm (mkConstCV k (0::Integer))+ -- ADTs+ smtLibADT :: Kind -> (String, [(Kind, CVal)]) -> Text+ smtLibADT knd (c, []) = ascribe c knd+ smtLibADT knd (c, kvs) = "(" <> ascribe c knd <> " " <> T.unwords (map (\(k, v) -> cvToSMTLib (CV k v)) kvs) <> ")"+ ascribe nm k = "(as " <> T.pack nm <> " " <> smtType k <> ")" -- | Show a float as a binary showBFloat :: (Show a, RealFloat a) => a -> ShowS@@ -558,13 +536,12 @@ | all (== 0) digits = "" | True = "." ++ concatMap toDigit digits - toDigit v = map toUpper d- where d | v <= 15 = [intToDigit v]- | v < 36 = [chr (ord 'a' + v - 10)]- | True = '<' : show v ++ ">"+ toDigit v | v <= 15 = [intToDigit v]+ | v < 36 = [chr (ord 'a' + v - 10)]+ | True = '<' : show v ++ ">" -- | When we show a negative number in SMTLib, we must properly parenthesize.-showNegativeNumber :: (Show a, Num a, Ord a) => a -> String+showNegativeNumber :: (Show a, Num a, Ord a) => a -> Text showNegativeNumber i- | i < 0 = "(- " ++ show (-i) ++ ")"- | True = show i+ | i < 0 = "(- " <> showText (-i) <> ")"+ | True = showText i
Data/SBV/Utils/SExpr.hs view
@@ -13,28 +13,35 @@ {-# OPTIONS_GHC -Wall -Werror #-} -module Data.SBV.Utils.SExpr (SExpr(..), parenDeficit, parseSExpr, parseSExprFunction) where+module Data.SBV.Utils.SExpr ( SExpr(..), parenDeficit, parseSExpr+ , parseSExprFunction, makeHaskellFunction+ , unQuote, simplifyECon+ , nameSupply+ ) where import Data.Bits (setBit, testBit) import Data.Char (isDigit, ord, isSpace) import Data.Either (partitionEithers)-import Data.List (isPrefixOf, nubBy)+import Data.List (isPrefixOf, nubBy, intercalate) import Data.Maybe (fromMaybe, listToMaybe) import Data.Word (Word32, Word64) import Control.Monad (foldM) -import Numeric (readInt, readDec, readHex, fromRat)+import Numeric (readInt, readSigned, readDec, readHex, fromRat) import Data.SBV.Core.AlgReals import Data.SBV.Core.SizedFloats import Data.SBV.Core.Data (nan, infinity, RoundingMode(..)) +import Data.SBV.Utils.Lib (unBar, unQuote, nameSupply)+ import Data.SBV.Utils.Numeric (fpIsEqualObjectH, wordToFloat, wordToDouble) -- | ADT S-Expression format, suitable for representing get-model output of SMT-Lib data SExpr = ECon String- | ENum (Integer, Maybe Int) -- Second argument is how wide the field was in bits, if known. Useful in FP parsing.+ | ENum (Integer, Maybe Int, Bool) -- Second argument is how wide the field was in bits, if known. Useful in FP parsing.+ -- Third argument is true, if this was a boolean constant | EReal AlgReal | EFloat Float | EFloatingPoint FP@@ -58,10 +65,13 @@ go (':':cs) sofar = case break (`elem` stopper) cs of (pre, rest) -> go rest ((':':pre) : sofar) - go ('|':r) sofar = case span (/= '|') r of- (pre, '|':rest) -> go rest (pre : sofar)- (pre, rest) -> go rest (pre : sofar)+ go ('|':r) sofar = let wrap s = '|' : s ++ "|"+ in case span (/= '|') r of+ (pre, '|':rest) -> go rest (wrap pre : sofar)+ (pre, rest) -> go rest (wrap pre : sofar) + go (';':r) sofar = go (drop 1 (dropWhile (/= '\n') r)) sofar+ go ('"':r) sofar = go rest (finalStr : sofar) where grabString [] acc = (reverse acc, []) -- Strictly speaking, this is the unterminated string case; but let's ignore grabString ('"' :'"':cs) acc = grabString cs ('"' :acc)@@ -77,7 +87,7 @@ -- characters that can stop the current token -- it is *crucial* that this list contains every character -- we can match in one of the previous cases!- stopper = " \t\n():|\""+ stopper = " \t\n():|\";" -- | The balance of parens in this string. If 0, this means it's a legit line! parenDeficit :: String -> Int@@ -94,7 +104,7 @@ if null extras then case sexp of EApp [ECon "error", ECon er] -> Left $ "Solver returned an error: " ++ er- _ -> return sexp+ _ -> pure sexp else die "Extra tokens after valid input" where inpToks = tokenize inp@@ -105,29 +115,29 @@ parse [] = die "ran out of tokens" parse ("(":toks) = do (f, r) <- parseApp toks [] f' <- cvt (EApp f)- return (f', r)+ pure (f', r) parse (")":_) = die "extra tokens after close paren" parse [tok] = do t <- pTok tok- return (t, [])+ pure (t, []) parse _ = die "ill-formed s-expr" parseApp [] _ = die "failed to grab s-expr application"- parseApp (")":toks) sofar = return (reverse sofar, toks)+ parseApp (")":toks) sofar = pure (reverse sofar, toks) parseApp ("(":toks) sofar = do (f, r) <- parse ("(":toks) parseApp r (f : sofar) parseApp (tok:toks) sofar = do t <- pTok tok parseApp toks (t : sofar) - pTok "false" = return $ ENum (0, Nothing)- pTok "true" = return $ ENum (1, Nothing)+ pTok "false" = pure $ ENum (0, Nothing, True)+ pTok "true" = pure $ ENum (1, Nothing, True) pTok ('0':'b':r) = mkNum (Just (length r)) $ readInt 2 (`elem` "01") (\c -> ord c - ord '0') r pTok ('b':'v':r) | not (null r) && all isDigit r = mkNum Nothing $ readDec (takeWhile (/= '[') r) pTok ('#':'b':r) = mkNum (Just (length r)) $ readInt 2 (`elem` "01") (\c -> ord c - ord '0') r pTok ('#':'x':r) = mkNum (Just (4 * length r)) $ readHex r - pTok n | possiblyNum n = if all intChar n then mkNum Nothing $ readDec n else getReal n- pTok n = return $ ECon (constantMap n)+ pTok n | possiblyNum n = if all intChar n then mkNum Nothing $ readSigned readDec n else getReal n+ pTok n = pure $ ECon (constantMap n) -- crude, but effective! possiblyNum s = case s of@@ -137,109 +147,130 @@ intChar c = c == '-' || isDigit c - mkNum l [(n, "")] = return $ ENum (n, l)+ mkNum l [(n, "")] = pure $ ENum (n, l, False) mkNum _ _ = die "cannot read number" - getReal n = return $ EReal $ mkPolyReal (Left (exact, n'))+ getReal n = pure $ EReal $ mkPolyReal (Left (exact, n')) where exact = not ("?" `isPrefixOf` reverse n) n' | exact = n | True = init n + fst3 (a, _, _) = a+ snd3 (_, b, _) = b+ thd3 (_, _, c) = c+ -- simplify numbers and root-obj values- cvt (EApp [ECon "to_int", EReal a]) = return $ EReal a -- ignore the "casting"- cvt (EApp [ECon "to_real", EReal a]) = return $ EReal a -- ignore the "casting"- cvt (EApp [ECon "/", EReal a, EReal b]) = return $ EReal (a / b)- cvt (EApp [ECon "/", EReal a, ENum b]) = return $ EReal (a / fromInteger (fst b))- cvt (EApp [ECon "/", ENum a, EReal b]) = return $ EReal (fromInteger (fst a) / b )- cvt (EApp [ECon "/", ENum a, ENum b]) = return $ EReal (fromInteger (fst a) / fromInteger (fst b))- cvt (EApp [ECon "-", EReal a]) = return $ EReal (-a)- cvt (EApp [ECon "-", ENum a]) = return $ ENum (-(fst a), snd a)+ cvt (EApp [ECon "to_int", EReal a]) = pure $ EReal a -- ignore the "casting"+ cvt (EApp [ECon "to_real", EReal a]) = pure $ EReal a -- ignore the "casting"+ cvt (EApp [ECon "/", EReal a, EReal b]) = pure $ EReal (a / b)+ cvt (EApp [ECon "/", EReal a, ENum b]) = pure $ EReal (a / fromInteger (fst3 b))+ cvt (EApp [ECon "/", ENum a, EReal b]) = pure $ EReal (fromInteger (fst3 a) / b )+ cvt (EApp [ECon "/", ENum a, ENum b]) = pure $ EReal (fromInteger (fst3 a) / fromInteger (fst3 b))+ cvt (EApp [ECon "-", EReal a]) = pure $ EReal (-a)+ cvt (EApp [ECon "-", ENum a]) = pure $ ENum (-(fst3 a), snd3 a, thd3 a) -- bit-vector value as CVC4 prints: (_ bv0 16) for instance- cvt (EApp [ECon "_", ENum a, ENum _b]) = return $ ENum a+ cvt (EApp [ECon "_", ENum a, ENum _b]) = pure $ ENum a cvt (EApp [ECon "root-obj", EApp (ECon "+":trms), ENum k]) = do ts <- mapM getCoeff trms- return $ EReal $ mkPolyReal (Right (fst k, ts))- cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FloatingPoint", ENum (11, _), ENum (53, _)]]) = getDouble n- cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FloatingPoint", ENum ( 8, _), ENum (24, _)]]) = getFloat n- cvt (EApp [ECon "as", n, ECon "Float64"]) = getDouble n- cvt (EApp [ECon "as", n, ECon "Float32"]) = getFloat n+ pure $ EReal $ mkPolyReal (Right (fst3 k, ts))+ cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FloatingPoint", ENum (11, _, _), ENum (53, _, _)]]) = getDouble n+ cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FloatingPoint", ENum ( 8, _, _), ENum (24, _, _)]]) = getFloat n+ cvt (EApp [ECon "as", n, ECon "Float64"]) = getDouble n+ cvt (EApp [ECon "as", n, ECon "Float32"]) = getFloat n -- Deal with CVC4's approximate reals cvt x@(EApp [ECon "witness", EApp [EApp [ECon v, ECon "Real"]] , EApp [ECon "or", EApp [ECon "=", ECon v', val], _]]) | v == v' = do approx <- cvt val case approx of- ENum (s, _) -> return $ EReal $ mkPolyReal (Left (False, show s))- EReal aval -> case aval of- AlgRational _ r -> return $ EReal $ AlgRational False r- _ -> return $ EReal aval- _ -> die $ "Cannot parse a CVC4 approximate value from: " ++ show x+ ENum (s, _, _) -> pure $ EReal $ mkPolyReal (Left (False, show s))+ EReal aval -> case aval of+ AlgRational _ r -> pure $ EReal $ AlgRational False r+ _ -> pure $ EReal aval+ _ -> die $ "Cannot parse a CVC4 approximate value from: " ++ show x + -- Deal with CVC5's algebraic reals. This is very crude!+ cvt x@(EApp (ECon "_" : ECon "real_algebraic_number" : rest)) =+ let isComma (ECon ",") = True+ isComma _ = False++ get (ENum (n, _, _)) = pure $ fromIntegral n+ get (EReal (AlgRational True r)) = pure r+ get (EFloat f) = pure $ toRational f+ get (EDouble d) = pure $ toRational d+ get t = die $ "Cannot get a CVC5 real-algebraic bound from: " ++ show t++ in case drop 1 (dropWhile (not . isComma) rest) of+ [EApp [n1, n2], _] -> do low <- get n1+ high <- get n2+ pure $ EReal $ AlgInterval (OpenPoint low) (OpenPoint high)+ _ -> die $ "Cannot parse a CVC5 real-algebraic number from: " ++ show x+ -- NB. Note the lengths on the mantissa for the following two are 23/52; not 24/53!- cvt (EApp [ECon "fp", ENum (s, Just 1), ENum ( e, Just 8), ENum (m, Just 23)]) = return $ EFloat $ getTripleFloat s e m- cvt (EApp [ECon "fp", ENum (s, Just 1), ENum ( e, Just 11), ENum (m, Just 52)]) = return $ EDouble $ getTripleDouble s e m- cvt (EApp [ECon "fp", ENum (s, Just 1), ENum ( e, Just eb), ENum (m, Just sb)]) = return $ EFloatingPoint $ fpFromRawRep (s == 1) (e, eb) (m, sb+1)+ cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 8, _), ENum (m, Just 23, _)]) = pure $ EFloat $ getTripleFloat s e m+ cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 11, _), ENum (m, Just 52, _)]) = pure $ EDouble $ getTripleDouble s e m+ cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just eb, _), ENum (m, Just sb, _)]) = pure $ EFloatingPoint $ fpFromRawRep (s == 1) (e, eb) (m, sb+1) - cvt (EApp [ECon "_", ECon "NaN", ENum ( 8, _), ENum (24, _)]) = return $ EFloat nan- cvt (EApp [ECon "_", ECon "NaN", ENum (11, _), ENum (53, _)]) = return $ EDouble nan- cvt (EApp [ECon "_", ECon "NaN", ENum (eb, _), ENum (sb, _)]) = return $ EFloatingPoint $ fpNaN (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "NaN", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat nan+ cvt (EApp [ECon "_", ECon "NaN", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble nan+ cvt (EApp [ECon "_", ECon "NaN", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpNaN (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "+oo", ENum ( 8, _), ENum (24, _)]) = return $ EFloat infinity- cvt (EApp [ECon "_", ECon "+oo", ENum (11, _), ENum (53, _)]) = return $ EDouble infinity- cvt (EApp [ECon "_", ECon "+oo", ENum (eb, _), ENum (sb, _)]) = return $ EFloatingPoint $ fpInf False (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "+oo", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat infinity+ cvt (EApp [ECon "_", ECon "+oo", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble infinity+ cvt (EApp [ECon "_", ECon "+oo", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpInf False (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "-oo", ENum ( 8, _), ENum (24, _)]) = return $ EFloat $ -infinity- cvt (EApp [ECon "_", ECon "-oo", ENum (11, _), ENum (53, _)]) = return $ EDouble $ -infinity- cvt (EApp [ECon "_", ECon "-oo", ENum (eb, _), ENum (sb, _)]) = return $ EFloatingPoint $ fpInf True (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "-oo", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat $ -infinity+ cvt (EApp [ECon "_", ECon "-oo", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble $ -infinity+ cvt (EApp [ECon "_", ECon "-oo", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpInf True (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "+zero", ENum ( 8, _), ENum (24, _)]) = return $ EFloat 0- cvt (EApp [ECon "_", ECon "+zero", ENum (11, _), ENum (53, _)]) = return $ EDouble 0- cvt (EApp [ECon "_", ECon "+zero", ENum (eb, _), ENum (sb, _)]) = return $ EFloatingPoint $ fpZero False (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "+zero", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat 0+ cvt (EApp [ECon "_", ECon "+zero", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble 0+ cvt (EApp [ECon "_", ECon "+zero", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpZero False (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "-zero", ENum ( 8, _), ENum (24, _)]) = return $ EFloat $ -0- cvt (EApp [ECon "_", ECon "-zero", ENum (11, _), ENum (53, _)]) = return $ EDouble $ -0- cvt (EApp [ECon "_", ECon "-zero", ENum (eb, _), ENum (sb, _)]) = return $ EFloatingPoint $ fpZero True (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "-zero", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat $ -0+ cvt (EApp [ECon "_", ECon "-zero", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble $ -0+ cvt (EApp [ECon "_", ECon "-zero", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpZero True (fromIntegral eb) (fromIntegral sb) - cvt x = return x+ cvt x = pure x - getCoeff (EApp [ECon "*", ENum k, EApp [ECon "^", ECon "x", ENum p]]) = return (fst k, fst p) -- kx^p- getCoeff (EApp [ECon "*", ENum k, ECon "x" ] ) = return (fst k, 1) -- kx- getCoeff ( EApp [ECon "^", ECon "x", ENum p] ) = return ( 1, fst p) -- x^p- getCoeff ( ECon "x" ) = return ( 1, 1) -- x- getCoeff ( ENum k ) = return (fst k, 0) -- k+ getCoeff (EApp [ECon "*", ENum k, EApp [ECon "^", ECon "x", ENum p]]) = pure (fst3 k, fst3 p) -- kx^p+ getCoeff (EApp [ECon "*", ENum k, ECon "x" ] ) = pure (fst3 k, 1) -- kx+ getCoeff ( EApp [ECon "^", ECon "x", ENum p] ) = pure ( 1, fst3 p) -- x^p+ getCoeff ( ECon "x" ) = pure ( 1, 1) -- x+ getCoeff ( ENum k ) = pure (fst3 k, 0) -- k getCoeff x = die $ "Cannot parse a root-obj,\nProcessing term: " ++ show x getDouble (ECon s) = case (s, rdFP (dropWhile (== '+') s)) of- ("plusInfinity", _ ) -> return $ EDouble infinity- ("minusInfinity", _ ) -> return $ EDouble (-infinity)- ("oo", _ ) -> return $ EDouble infinity- ("-oo", _ ) -> return $ EDouble (-infinity)- ("zero", _ ) -> return $ EDouble 0- ("-zero", _ ) -> return $ EDouble (-0)- ("NaN", _ ) -> return $ EDouble nan- (_, Just v) -> return $ EDouble v+ ("plusInfinity", _ ) -> pure $ EDouble infinity+ ("minusInfinity", _ ) -> pure $ EDouble (-infinity)+ ("oo", _ ) -> pure $ EDouble infinity+ ("-oo", _ ) -> pure $ EDouble (-infinity)+ ("zero", _ ) -> pure $ EDouble 0+ ("-zero", _ ) -> pure $ EDouble (-0)+ ("NaN", _ ) -> pure $ EDouble nan+ (_, Just v) -> pure $ EDouble v _ -> die $ "Cannot parse a double value from: " ++ s getDouble (EApp [_, s, _, _]) = getDouble s- getDouble (EReal r) = return $ EDouble $ fromRat $ toRational r+ getDouble (EReal r) = pure $ EDouble $ fromRat $ toRational r getDouble x = die $ "Cannot parse a double value from: " ++ show x getFloat (ECon s) = case (s, rdFP (dropWhile (== '+') s)) of- ("plusInfinity", _ ) -> return $ EFloat infinity- ("minusInfinity", _ ) -> return $ EFloat (-infinity)- ("oo", _ ) -> return $ EFloat infinity- ("-oo", _ ) -> return $ EFloat (-infinity)- ("zero", _ ) -> return $ EFloat 0- ("-zero", _ ) -> return $ EFloat (-0)- ("NaN", _ ) -> return $ EFloat nan- (_, Just v) -> return $ EFloat v+ ("plusInfinity", _ ) -> pure $ EFloat infinity+ ("minusInfinity", _ ) -> pure $ EFloat (-infinity)+ ("oo", _ ) -> pure $ EFloat infinity+ ("-oo", _ ) -> pure $ EFloat (-infinity)+ ("zero", _ ) -> pure $ EFloat 0+ ("-zero", _ ) -> pure $ EFloat (-0)+ ("NaN", _ ) -> pure $ EFloat nan+ (_, Just v) -> pure $ EFloat v _ -> die $ "Cannot parse a float value from: " ++ s- getFloat (EReal r) = return $ EFloat $ fromRat $ toRational r+ getFloat (EReal r) = pure $ EFloat $ fromRat $ toRational r getFloat (EApp [_, s, _, _]) = getFloat s getFloat x = die $ "Cannot parse a float value from: " ++ show x -- | Parses the Z3 floating point formatted numbers like so: 1.321p5/1.2123e9 etc. rdFP :: (Read a, RealFloat a) => String -> Maybe a rdFP s = case break (`elem` "pe") s of- (m, 'p':e) -> rd m >>= \m' -> rd e >>= \e' -> return $ m' * ( 2 ** e')- (m, 'e':e) -> rd m >>= \m' -> rd e >>= \e' -> return $ m' * (10 ** e')+ (m, 'p':e) -> rd m >>= \m' -> rd e >>= \e' -> pure $ m' * ( 2 ** e')+ (m, 'e':e) -> rd m >>= \m' -> rd e >>= \e' -> pure $ m' * (10 ** e') (m, "") -> rd m _ -> Nothing where rd v = case reads v of@@ -291,7 +322,7 @@ -- (= x!1 "l") -- (= x!1 "e") -- (= x!1 "h")))--- For this, we do a little bit of an interpretative dance to see if we can "construct" the necesary expression.+-- For this, we do a little bit of an interpretative dance to see if we can "construct" the necessary expression. -- -- In parsed form: -- EApp [ECon "lambda",EApp [EApp [ECon "x!1",ECon "String"]],EApp [ECon "not",EApp [ECon "or",EApp [ECon "=",ECon "x!1",ECon "\"e\""],EApp [ECon "=",ECon "x!1",ECon "\"l\""]]]]@@ -311,20 +342,20 @@ foldM1 _ [] = error "Data.SBV.parseSetLambda: Impossible happened; empty arg to foldM1" foldM1 f (x:xs) = foldM f x xs - checkBool (ENum (1, Nothing)) = True- checkBool (ENum (0, Nothing)) = True- checkBool _ = False+ checkBool (ENum (1, Nothing, True)) = True+ checkBool (ENum (0, Nothing, True)) = True+ checkBool _ = False - negBool (ENum (1, Nothing)) = ENum (0, Nothing)- negBool _ = ENum (1, Nothing)+ negBool (ENum (1, Nothing, _)) = ENum (0, Nothing, True)+ negBool _ = ENum (1, Nothing, True) - orBool t@(ENum (1, Nothing)) _ = t- orBool _ t@(ENum (1, Nothing)) = t- orBool _ _ = ENum (0, Nothing)+ orBool t@(ENum (1, Nothing, _)) _ = t+ orBool _ t@(ENum (1, Nothing, _)) = t+ orBool _ _ = ENum (0, Nothing, True) - andBool f@(ENum (0, Nothing)) _ = f- andBool _ f@(ENum (0, Nothing)) = f- andBool _ _ = ENum (1, Nothing)+ andBool f@(ENum (0, Nothing, _)) _ = f+ andBool _ f@(ENum (0, Nothing, _)) = f+ andBool _ _ = ENum (1, Nothing, True) neg :: ([([SExpr], SExpr)], SExpr) -> Maybe ([([SExpr], SExpr)], SExpr) neg (rows, dflt)@@ -363,18 +394,24 @@ -- be flexible, this is certainly not a full fledged parser. But hopefully it'll -- cover everything z3 will throw at it. parseLambdaExpression :: SExpr -> Maybe ([([SExpr], SExpr)], SExpr)-parseLambdaExpression funExpr = case funExpr of+parseLambdaExpression funExpr = case squashLambdas funExpr of EApp [ECon "lambda", EApp params, body] -> mapM getParam params >>= flip lambda body >>= chainAssigns _ -> Nothing- where getParam (EApp [ECon v, ECon ty]) = Just (v, ty == "Bool")+ where -- convert (lambda p1 (lambda p2 body)) to (lambda (p1 ++ p2) body)+ squashLambdas (EApp [ECon "lambda", EApp p1+ , EApp [ECon "lambda", EApp p2, body]])+ = squashLambdas $ EApp [ECon "lambda", EApp (p1 ++ p2), body]+ squashLambdas other = other++ getParam (EApp [ECon v, ECon ty]) = Just (v, ty == "Bool") getParam (EApp [ECon v, _ ]) = Just (v, False) getParam _ = Nothing lambda :: [(String, Bool)] -- Bool is True if this is a boolean variable. Otherwise we don't keep track of the type -> SExpr -> Maybe [Either ([SExpr], SExpr) SExpr] lambda params body = reverse <$> go [] body- where true = ENum (1, Nothing)- false = ENum (0, Nothing)+ where true = ENum (1, Nothing, True)+ false = ENum (0, Nothing, True) go :: [Either ([SExpr], SExpr) SExpr] -> SExpr -> Maybe [Either ([SExpr], SExpr) SExpr] go sofar (EApp [ECon "ite", selector, thenBranch, elseBranch])@@ -467,13 +504,14 @@ parseStoreAssociations (EApp [ECon "_", ECon "as-array", ECon nm]) = Just $ Left nm parseStoreAssociations e = Right <$> (chainAssigns =<< vals e) where vals :: SExpr -> Maybe [Either ([SExpr], SExpr) SExpr]- vals (EApp [EApp [ECon "as", ECon "const", ECon "Array"], defVal]) = return [Right defVal]- vals (EApp [EApp [ECon "as", ECon "const", EApp (ECon "Array" : _)], defVal]) = return [Right defVal]+ vals (EApp [EApp [ECon "as", ECon "const", ECon "Array"], defVal]) = pure [Right defVal]+ vals (EApp [EApp [ECon "as", ECon "const", EApp (ECon "Array" : _)], defVal]) = pure [Right defVal] vals (EApp (ECon "store" : prev : argsVal)) | length argsVal >= 2 = do rest <- vals prev- return $ Left (init argsVal, last argsVal) : rest+ pure $ Left (init argsVal, last argsVal) : rest vals _ = Nothing -- | Turn a sequence of left-right chain assignments (condition + free) into a single chain+-- NB. We make sure the results here are unique, i.e., there's only one assignment to each unique entry chainAssigns :: [Either ([SExpr], SExpr) SExpr] -> Maybe ([([SExpr], SExpr)], SExpr) chainAssigns chain = regroup $ partitionEithers chain where regroup (vs, [d]) = Just (checkDup vs, d)@@ -486,6 +524,8 @@ -- then we need to drop the 1->2 assignment! -- -- The way we parse these, the first assignment wins.+ -- NB. I'm not sure if solvers actually would return duplicate assignments, but just being safe here. (i.e.,+ -- this duplication may actually never happen in practice.) checkDup :: [([SExpr], SExpr)] -> [([SExpr], SExpr)] checkDup [] = [] checkDup (a@(key, _):as) = a : checkDup [r | r@(key', _) <- as, not (key `sameKey` key')]@@ -498,15 +538,16 @@ -- We don't want to derive Eq; as this is more careful on floats and such same :: SExpr -> SExpr -> Bool same x y = case (x, y) of- (ECon a, ECon b) -> a == b- (ENum (i, _), ENum (j, _)) -> i == j- (EReal a, EReal b) -> algRealStructuralEqual a b- (EFloat f1, EFloat f2) -> fpIsEqualObjectH f1 f2- (EDouble d1, EDouble d2) -> fpIsEqualObjectH d1 d2- (EApp as, EApp bs) -> length as == length bs && and (zipWith same as bs)- (e1, e2) -> if eRank e1 == eRank e2- then error $ "Data.SBV: You've found a bug in SBV! Please report: SExpr(same): " ++ show (e1, e2)- else False+ (ECon a, ECon b) -> a == b+ (ENum (i, _, _), ENum (j, _, _)) -> i == j+ (EReal a, EReal b) -> algRealStructuralEqual a b+ (EFloat f1, EFloat f2) -> fpIsEqualObjectH f1 f2+ (EDouble d1, EDouble d2) -> fpIsEqualObjectH d1 d2+ (EFloatingPoint a1, EFloatingPoint a2) -> fpIsEqualObjectH a1 a2+ (EApp as, EApp bs) -> length as == length bs && and (zipWith same as bs)+ (e1, e2) -> if eRank e1 == eRank e2+ then error $ "Data.SBV: You've found a bug in SBV! Please report: SExpr(same): " ++ show (e1, e2)+ else False -- Defensive programming: It's too long to list all pair up, so we use this function and -- GHC's pattern-match completion warning to catch cases we might've forgotten. If -- you ever get the error line above fire, because you must've disabled the pattern-match@@ -520,4 +561,140 @@ eRank EDouble{} = 5 eRank EApp{} = 6 -{-# ANN chainAssigns ("HLint: ignore Redundant if" :: String) #-}+-- Turn+-- "((F (lambda ((x!1 Int)) (+ 3 (* 2 x!1)))))"+--- into+-- "F x = 3 + 2 * x"+-- if we can. We try but don't push too hard! This is only used for display purposes.+--+-- This isn't very fool-proof; can be confused if there are binding constructs etc.+-- Also, the generated text isn't necessarily fully Haskell acceptable.+-- But it seems to do an OK job for most common use cases.+makeHaskellFunction :: String -> String -> Bool -> Maybe [String] -> Maybe String+makeHaskellFunction resp nm isCurried mbArgs+ = case parseSExpr resp of+ Right (EApp [EApp [ECon o, e]]) | o == nm -> do (args, bd) <- lambda e+ let params | isCurried = unwords args+ | True = '(' : intercalate ", " args ++ ")"+ pure $ unBar nm ++ " " ++ params ++ " = " ++ bd+ _ -> Nothing++ where -- infinite supply of names; starting with the ones we're given+ preSupply = fromMaybe [] mbArgs++ lambda :: SExpr -> Maybe ([String], String)+ lambda (EApp [ECon "lambda", EApp args, bd]) = do as <- mapM getArg args+ let env = zip as (nameSupply preSupply)+ pure (map snd env, hprint env bd)+ lambda _ = Nothing++ getArg (EApp [ECon argName, _]) = Just argName+ getArg _ = Nothing++-- | z3 prints uninterpreted values like this: T!val!4 or T_val_4. Turn that into T_4+simplifyECon :: String -> String+simplifyECon "" = ""+simplifyECon ('!':'v':'a':'l':'!':rest) = '_' : simplifyECon rest+simplifyECon ('_':'v':'a':'l':'_':rest) = '_' : simplifyECon rest+simplifyECon (c:cs) = c : simplifyECon cs++-- Print as a Haskell expression, with minimal parens.+-- This isn't fool-proof; but it does an OK job+hprint :: [(String, String)] -> SExpr -> String+hprint env = go (0 :: Int)+ where go p e = case e of+ ECon n | Just a <- n `lookup` env -> a+ | True -> simplifyECon n+ ENum (1, _, True) -> "True"+ ENum (0, _, True) -> "False"+ ENum (i, _, _) -> cnst i+ EReal a -> cnst a+ EFloat f -> cnst f+ EFloatingPoint f -> cnst f+ EDouble f -> cnst f++ -- Handle lets+ EApp [ECon "let", EApp binders, rhs] ->+ let getBind (EApp [ECon nm, def]) = simplifyECon nm ++ " = " ++ go 0 def+ getBind bnd = go 0 bnd++ binds = '{' : intercalate "; " (map getBind binders) ++ "}"+ in parenIf (p >= 1) $ "let " ++ binds ++ " in " ++ go 0 rhs++ -- few simps+ EApp [ECon "not", EApp [ECon ">=", a, b]] -> go p $ EApp [ECon "<", a, b]+ EApp [ECon "not", EApp [ECon "<=", a, b]] -> go p $ EApp [ECon ">", a, b]+ EApp [ECon "not", EApp [ECon "<", a, b]] -> go p $ EApp [ECon ">=", a, b]+ EApp [ECon "not", EApp [ECon ">", a, b]] -> go p $ EApp [ECon "<=", a, b]++ -- Handle x + -y that z3 is fond of producing+ EApp [ECon a, x, EApp [ECon m, ENum (-1, _, _), y]] | isPlus a && isTimes m -> go p $ EApp [ECon "-", x, y]++ -- Handle x + -NUM that z3 is also fond of producing+ EApp [ECon a, x, ENum (i, mw, bool)] | isPlus a && i < 0 -> go p $ EApp [ECon "-", x, ENum (-i, mw, bool)]++ -- Handle -1 * x+ EApp [ECon o, ENum (-1, _, _), b] | isTimes o -> parenIf (p >= 8) (neg (go 8 b))++ -- Move additive constants to the right, multiplicative constants to the left+ EApp [ECon o, x, y] | isPlus o && isConst x && not (isConst y) -> go p $ EApp [ECon o, y, x]+ EApp [ECon o, x, y] | isTimes o && isConst y && not (isConst x) -> go p $ EApp [ECon o, y, x]++ -- Simp arithmetic+ EApp (ECon o : xs) | isPlus o -> recurse 6 (Just "+") xs+ EApp (ECon o : xs) | isMinus o -> recurse 6 (Just "-") xs+ EApp (ECon o : xs) | isTimes o -> recurse 7 (Just "*") xs+ EApp (ECon o : xs) | isDiv o -> recurse 7 (Just "/") xs++ -- Booleans+ EApp (ECon o : xs) | isLT o -> recurse 4 (Just "<") xs+ EApp (ECon o : xs) | isLTE o -> recurse 4 (Just "<=") xs+ EApp (ECon o : xs) | isGT o -> recurse 4 (Just ">") xs+ EApp (ECon o : xs) | isGTE o -> recurse 4 (Just ">=") xs+ EApp (ECon o : xs) | isAND o -> recurse 3 (Just "&&") xs+ EApp (ECon o : xs) | isOR o -> recurse 2 (Just "||") xs+ EApp (ECon o : xs) | isEQ o -> recurse 4 (Just "==") xs++ -- Otherwise, just do prefix+ EApp xs -> recurse 9 Nothing xs++ where recurse p' (Just op) xs = parenIf (p >= p') $ intercalate (' ' : op ++ " ") (map (parenNeg . go p') xs)+ recurse p' Nothing xs = parenIf (p >= p') $ unwords (map (parenNeg . go p') xs)++ isConst ECon {} = False+ isConst ENum {} = True+ isConst EReal {} = True+ isConst EFloat {} = True+ isConst EFloatingPoint{} = True+ isConst EDouble {} = True+ isConst EApp {} = False++ parenNeg x@('-':_) = paren x+ parenNeg x = x++ neg ('-':x) = x+ neg x = '-' : parenIf (any isSpace x) x++ cnst x = case show x of+ sx@('-' : _) -> paren sx+ sx -> sx++ paren r@('(':_) = r+ paren r = '(' : r ++ ")"++ parenIf False r = r+ parenIf True r = paren r++ isPlus = (`elem` ["+", "bvadd"])+ isTimes = (`elem` ["*", "bvmul"])+ isMinus = (`elem` ["-", "bvsub"])+ isDiv = (`elem` ["/", "bvdiv"])+ isLT = (`elem` ["<", "bvult", "bvslt", "fp.lt" ])+ isLTE = (`elem` ["<=", "bvule", "bvsle", "fp.leq"])+ isGT = (`elem` [">", "bvugt", "bvsgt", "fp.gt" ])+ isGTE = (`elem` [">=", "bvuge", "bvsge", "fp.gte"])+ isEQ = (`elem` ["=", "fp.eq"])+ isAND = (== "and")+ isOR = (== "or")++{- HLint ignore chainAssigns "Redundant if" -}
Data/SBV/Utils/TDiff.hs view
@@ -13,11 +13,15 @@ module Data.SBV.Utils.TDiff ( Timing(..)+ , timeIf+ , timeIfRNF , showTDiff+ , getTimeStampIf+ , getElapsedTime ) where -import Data.Time (NominalDiffTime)+import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime, UTCTime) import Data.IORef (IORef) import Data.List (intercalate)@@ -27,6 +31,10 @@ import Numeric (showFFloat) +import Control.Monad.Trans (liftIO, MonadIO)+import Control.DeepSeq (NFData(rnf))++ -- | Specify how to save timing information, if at all. data Timing = NoTiming | PrintTiming | SaveTiming (IORef NominalDiffTime) @@ -59,3 +67,28 @@ aboveSeconds = map (\(t, v) -> show v ++ [t]) $ dropWhile (\p -> snd p == 0) [('d', days), ('h', hours), ('m', minutes)] fields = aboveSeconds ++ [secondsPicos]++-- | Run an action and measure how long it took. We reduce the result to weak-head-normal-form,+-- so beware of the cases if the result is lazily computed; in which case we'll stop soon as the+-- result is in WHNF, and not necessarily fully calculated.+timeIf :: MonadIO m => Bool -> m a -> m (Maybe NominalDiffTime, a)+timeIf measureTime act = do mbStart <- getTimeStampIf measureTime+ r <- act+ r `seq` do mbElapsed <- getElapsedTime mbStart+ pure (mbElapsed, r)++-- | Same as 'timeIf', except we fully evaluate the result, via its NFData instance.+timeIfRNF :: (NFData a, MonadIO m) => Bool -> m a -> m (Maybe NominalDiffTime, a)+timeIfRNF measureTime act = timeIf measureTime (act >>= \r -> rnf r `seq` pure r)++-- | Get a time-stamp if we're asked to do so+getTimeStampIf :: MonadIO m => Bool -> m (Maybe UTCTime)+getTimeStampIf measureTime+ | not measureTime = pure Nothing+ | True = liftIO $ Just <$> getCurrentTime++-- | Get elapsed time from the given beginning time, if any.+getElapsedTime :: MonadIO m => Maybe UTCTime -> m (Maybe NominalDiffTime)+getElapsedTime Nothing = pure Nothing+getElapsedTime (Just start) = liftIO $ do e <- getCurrentTime+ pure $ Just (diffUTCTime e start)
+ Documentation/SBV/Examples/ADT/Expr.hs view
@@ -0,0 +1,172 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.ADT.Expr+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- A basic expression ADT example.+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.ADT.Expr where++import Data.SBV+import Data.SBV.Control+import Data.SBV.RegExp+import Data.SBV.Tuple+import qualified Data.SBV.List as SL++-- | A basic arithmetic expression type.+data Expr = Val Integer+ | Var String+ | Add Expr Expr+ | Mul Expr Expr+ | Let String Expr Expr++-- | Create a symbolic version of expressions.+mkSymbolic [''Expr]++-- | Show instance for 'Expr'.+instance Show Expr where+ show (Val i) = show i+ show (Var a) = a+ show (Add l r) = "(" ++ show l ++ " + " ++ show r ++ ")"+ show (Mul l r) = "(" ++ show l ++ " * " ++ show r ++ ")"+ show (Let s a b) = "(let " ++ s ++ " = " ++ show a ++ " in " ++ show b ++ ")"++-- | Num instance, simplifies construction of values+instance Num Expr where+ fromInteger = Val+ (+) = Add+ (*) = Mul+ abs = error "Num Expr: undefined abs"+ signum = error "Num Expr: undefined signum"+ negate = error "Num Expr: undefined negate"++-- | Num instance for the symbolic version+instance Num SExpr where+ fromInteger = sVal . literal+ (+) = sAdd+ (*) = sMul+ abs = error "Num SExpr: undefined abs"+ signum = error "Num SExpr: undefined signum"+ negate = error "Num SExpr: undefined negate"++-- | Validity: We require each variable appearing to be an identifier (lowercase letter followed by+-- any number of upper-lower case letters and digits), and all expressions are closed; i.e., any+-- variable referenced is introduced by an enclosing let expression.+isValid :: SExpr -> SBool+isValid = go []+ where isId s = s `match` (asciiLower * KStar (asciiLetter + digit))+ go :: SList String -> SExpr -> SBool+ go = smtFunction "valid"+ $ \env expr -> [sCase| expr of+ Var s -> isId s .&& s `SL.elem` env+ Val _ -> sTrue+ Add l r -> go env l .&& go env r+ Mul l r -> go env l .&& go env r+ Let s a b -> isId s .&& go env a .&& go (s SL..: env) b+ |]++-- | Evaluate an expression.+eval :: SExpr -> SInteger+eval = go []+ where go :: SList (String, Integer) -> SExpr -> SInteger+ go = smtFunction "eval"+ $ \env expr -> [sCase| expr of+ Val i -> i+ Var s -> get env s+ Add l r -> go env l + go env r+ Mul l r -> go env l * go env r+ Let s e r -> go (tuple (s, go env e) SL..: env) r+ |]++ get :: SList (String, Integer) -> SString -> SInteger+ get = smtFunction "get"+ $ \env s -> [sCase| env of+ [] -> 0+ (k, v) : es | s .== k -> v+ | True -> get es s+ |]++-- | A basic theorem about 'eval'.+-- >>> evalPlus5+-- Q.E.D.+evalPlus5 :: IO ThmResult+evalPlus5 = prove $ do e :: SExpr <- free "e"+ pure $ eval (e + 5) .== 5 + eval e++-- | A simple sat result example.+--+-- >>> evalSat+-- Satisfiable. Model:+-- e = Let "h" (Val 1) (Var "h") :: Expr+-- a = 9 :: Integer+-- b = 10 :: Integer+evalSat :: IO SatResult+evalSat = sat $ do e :: SExpr <- free "e"+ constrain $ isValid e+ constrain $ isLet e++ a :: SInteger <- free "a"+ b :: SInteger <- free "b"+ constrain $ a .>= 4+ constrain $ b .>= 10++ pure $ eval (e + sVal a) .== b * eval e++-- | Another test, generating some (mildly) interesting examples.+--+-- >>> genE+-- Satisfiable. Model:+-- e1 = Let "k" (Mul (Val 1) (Mul (Val (-3)) (Val (-1)))) (Var "k") :: Expr+-- e2 = Val (-2) :: Expr+genE :: IO SatResult+genE = sat $ do e1 :: SExpr <- free "e1"+ e2 :: SExpr <- free "e2"++ constrain $ isValid e1+ constrain $ isValid e2++ constrain $ e1 ./== e2+ constrain $ isLet e1+ constrain $ eval e1 .== 3+ constrain $ eval e1 .== eval e2 + 5++-- | Query mode example.+--+-- >>> queryE+-- e1: (let k = (1 * (-3 * -1)) in k)+-- e2: -2+queryE :: IO ()+queryE = runSMT $ do+ e1 :: SExpr <- free "e1"+ e2 :: SExpr <- free "e2"++ constrain $ isValid e1+ constrain $ isValid e2++ constrain $ e1 ./== e2+ constrain $ isLet e1+ constrain $ eval e1 .== 3+ constrain $ eval e1 .== eval e2 + 5++ query $ do cs <- checkSat+ case cs of+ Sat -> do e1v <- getValue e1+ e2v <- getValue e2+ io $ putStrLn $ "e1: " ++ show e1v+ io $ putStrLn $ "e2: " ++ show e2v+ _ -> error $ "Unexpected result: " ++ show cs++{- HLint ignore module "Reduce duplication" -}
+ Documentation/SBV/Examples/ADT/Param.hs view
@@ -0,0 +1,191 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.ADT.Param+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- A basic parameterized expression ADT example.+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.ADT.Param where++import Data.SBV+import Data.SBV.Control+import Data.SBV.RegExp+import Data.SBV.Tuple+import qualified Data.SBV.List as SL++-- | A basic arithmetic expression type.+data Expr nm val = Val val+ | Var nm+ | Add (Expr nm val) (Expr nm val)+ | Mul (Expr nm val) (Expr nm val)+ | Let nm (Expr nm val) (Expr nm val)++-- | Create a symbolic version of expressions.+mkSymbolic [''Expr]++-- | Show instance for 'Expr'.+instance (Show nm, Show val) => Show (Expr nm val) where+ show (Val i) = show i+ show (Var a) = show a+ show (Add l r) = "(" ++ show l ++ " + " ++ show r ++ ")"+ show (Mul l r) = "(" ++ show l ++ " * " ++ show r ++ ")"+ show (Let s a b) = "(let " ++ show s ++ " = " ++ show a ++ " in " ++ show b ++ ")"++-- | Show instance for 'Expr', specialized when name is string.+instance {-# OVERLAPPING #-} Show val => Show (Expr String val) where+ show (Val i) = show i+ show (Var a) = a+ show (Add l r) = "(" ++ show l ++ " + " ++ show r ++ ")"+ show (Mul l r) = "(" ++ show l ++ " * " ++ show r ++ ")"+ show (Let s a b) = "(let " ++ s ++ " = " ++ show a ++ " in " ++ show b ++ ")"++-- | Num instance, simplifies construction of values+instance Integral val => Num (Expr nm val) where+ fromInteger = Val . fromIntegral+ (+) = Add+ (*) = Mul+ abs = error "Num Expr: undefined abs"+ signum = error "Num Expr: undefined signum"+ negate = error "Num Expr: undefined negate"++-- | Num instance for the symbolic version+instance (SymVal nm, SymVal val, Integral val) => Num (SExpr nm val) where+ fromInteger = sVal . literal . fromIntegral+ (+) = sAdd+ (*) = sMul+ abs = error "Num SExpr: undefined abs"+ signum = error "Num SExpr: undefined signum"+ negate = error "Num SExpr: undefined negate"++-- | Validity: We require each variable appearing to be an identifier to satisfy the predicate given.+-- any number of upper-lower case letters and digits), and all expressions are closed; i.e., any+-- variable referenced is introduced by an enclosing let expression.+isValid :: (SymVal nm, Eq nm, SymVal val) => (SBV nm -> SBool) -> SExpr nm val -> SBool+isValid nmChk = go []+ where go = smtFunction "valid"+ $ \env expr -> [sCase| expr of+ Var s -> nmChk s .&& s `SL.elem` env+ Val _ -> sTrue+ Add l r -> go env l .&& go env r+ Mul l r -> go env l .&& go env r+ Let s a b -> nmChk s .&& go env a .&& go (s SL..: env) b+ |]++-- | Evaluate an expression.+eval :: (SymVal nm, SymVal val, Num (SBV val)) => SExpr nm val -> SBV val+eval = go []+ where go = smtFunction "eval"+ $ \env expr -> [sCase| expr of+ Val i -> i+ Var s -> get env s+ Add l r -> go env l + go env r+ Mul l r -> go env l * go env r+ Let s e r -> go (tuple (s, go env e) SL..: env) r+ |]++ get = smtFunction "get"+ $ \env s -> [sCase| env of+ [] -> 0+ (k, v) : es | s .== k -> v+ | True -> get es s+ |]++-- | A basic theorem about 'eval'.+-- >>> evalPlus5+-- Q.E.D.+evalPlus5 :: IO ThmResult+evalPlus5 = prove $ do e :: SExpr String Integer <- free "e"+ pure $ eval (e + 5) .== 5 + eval e++-- | Is this a string identifier? Lowercase letter followed by any number of upper-lower case letters and digits.+isId :: SString -> SBool+isId s = s `match` (asciiLower * KStar (asciiLetter + digit))++-- | A simple sat result example.+--+-- >>> evalSat+-- Satisfiable. Model:+-- e = Let "h" (Val 1) (Var "h") :: Expr String Integer+-- a = 9 :: Integer+-- b = 10 :: Integer+evalSat :: IO SatResult+evalSat = sat $ do e :: SExpr String Integer <- free "e"+ constrain $ isValid isId e+ constrain $ isLet e++ a :: SInteger <- free "a"+ b :: SInteger <- free "b"+ constrain $ a .>= 4+ constrain $ b .>= 10++ pure $ eval (e + sVal a) .== b * eval e++-- | Another test, generating some (mildly) interesting examples.+--+-- >>> genE+-- Satisfiable. Model:+-- e1 = Let "h" (Val 5) (Val 3) :: Expr String Integer+-- e2 = Val (-2) :: Expr String Integer+genE :: IO SatResult+genE = sat $ do e1 :: SExpr String Integer <- free "e1"+ e2 :: SExpr String Integer <- free "e2"++ constrain $ isValid isId e1+ constrain $ isValid isId e2++ constrain $ e1 ./== e2+ constrain $ isLet e1+ constrain $ eval e1 .== 3+ constrain $ eval e1 .== eval e2 + 5++-- | Query mode example.+--+-- >>> queryE+-- e1: (let a = ((let x = 20 in 4) * -5) in (-1 * -3))+-- e2: -2+-- e3: (let h = 79 % 80 in h)+queryE :: IO ()+queryE = runSMT $ do+ e1 :: SExpr String Integer <- free "e1"+ e2 :: SExpr String Integer <- free "e2"++ e3 :: SExpr String Rational <- free "e3"++ constrain $ isValid isId e1+ constrain $ isValid isId e2+ constrain $ isValid isId e3++ constrain $ e1 ./== e2+ constrain $ isLet e1+ constrain $ eval e1 .== 3+ constrain $ eval e1 .== eval e2 + 5++ constrain $ isLet e3+ constrain $ isMul (getLet_2 e1)+ constrain $ isMul (getLet_3 e1)++ query $ do cs <- checkSat+ case cs of+ Sat -> do e1v <- getValue e1+ e2v <- getValue e2+ e3v <- getValue e3+ io $ putStrLn $ "e1: " ++ show e1v+ io $ putStrLn $ "e2: " ++ show e2v+ io $ putStrLn $ "e3: " ++ show e3v+ _ -> error $ "Unexpected result: " ++ show cs++{- HLint ignore module "Reduce duplication" -}
+ Documentation/SBV/Examples/ADT/Types.hs view
@@ -0,0 +1,131 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.ADT.Types+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- An encoding of the simple type-checking via constraints, following+-- <https://microsoft.github.io/z3guide/docs/theories/Datatypes/#using-datatypes-for-solving-type-constraints>+-----------------------------------------------------------------------------+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Documentation.SBV.Examples.ADT.Types where++import Data.SBV++-- | Simple encoding of untyped lambda terms+data M = Var { var :: String } -- ^ Variables: @x@+ | Lam { bound :: String -- ^ Abstraction: @\x. M@+ , body :: M+ }+ | App { fn :: M -- ^ Application: @M M@+ , arg :: M+ }++-- | Types.+data T = TInt -- ^ Integers+ | TStr -- ^ Strings+ | TArr { dom :: T, rng :: T } -- ^ Functions: @t -> t@++-- | Make terms and types symbolic+mkSymbolic [''M]+mkSymbolic [''T]++-- | Instead of modeling environments for mapping variables to their+-- types, we'll simply use an uninterpreted function. Note that+-- this also implies we consider all terms to be given so that variables+-- do not shadow each other; i.e., all variables are unique. This is+-- a simplification, but it is not without justification: One can+-- always alpha-rename bound variables so all bound variables are unique.+env :: SString -> ST+env = uninterpret "env"++-- | Use an uninterpreted function to also magically find the type of a term.+typeOf :: SM -> ST+typeOf = uninterpret "typeOf"++-- | Given a term and a type, check that the term has that type.+tc :: SM -> ST -> SBool+tc = smtFunction "constraints" $ \m t ->+ [sCase| m of++ -- Var case. The environment must match the type we expect.+ Var s -> env s .== t++ -- Abstraction case. Type must be a function, whose domain matches the variable.+ -- And body must match the range.+ Lam v b+ | isTArr t .&& env v .== sdom t+ -> tc b (srng t)++ -- Application case. In this case, we ask the solver to give us the type of the+ -- function, and then ensure the whole thing is well-formed+ App f a -> let tf = typeOf f+ in isTArr tf -- f must have an arrow type+ .&& tc f tf -- The function must type-check with that type+ .&& tc a (sdom tf) -- Argument must have the type of this function+ .&& t .== srng tf -- Final result must match the type we're looking for++ -- Otherwise, ill-typed.+ _ -> sFalse+ |]++-- | Well typedness: If what the 'typeOf' function returns type-checks the term,+-- then a term is well-typed.+wellTyped :: SM -> SBool+wellTyped m = tc m (typeOf m)++-- | Make sure the identity function can be typed.+--+-- >>> idWF+-- Satisfiable. Model:+-- env :: String -> T+-- env _ = TInt+-- <BLANKLINE>+-- typeOf :: M -> T+-- typeOf _ = TArr TInt TInt+--+-- The model is rather uninteresting, but it shows that identity can have the type Integer to Integer, where+-- all variables are mapped to Integers.+idWF :: IO SatResult+idWF = sat $ wellTyped $ sLam x vx+ where x = literal "x"+ vx = sVar x++-- | Check that if we apply a function that takes n integer to a string is not well-typed.+--+-- >>> intFuncAppString+-- Unsatisfiable+--+-- As expected, the solver says that there's no way to type-check such an expression.+intFuncAppString :: IO SatResult+intFuncAppString = sat $ do+ -- Introduce the constant @plus1 :: Int -> Int@+ plus1 <- free "plus1"+ constrain $ tc plus1 (literal (TInt `TArr` TInt))++ -- Introduce the constant @str :: String@+ str <- free "str"+ constrain $ tc str sTStr++ -- Check if the application of plus1 to str can be well-typed+ pure $ wellTyped $ sApp plus1 str++-- | Make sure self-application cannot be typed.+--+-- >>> selfAppNotWellTyped+-- Unsatisfiable+--+-- We get unsatisfiable, indicating there's no way to come up with an environment that will+-- successfully assign a type to the term @\x -> x x@.+selfAppNotWellTyped :: IO SatResult+selfAppNotWellTyped = sat $ wellTyped $ sLam x (sApp vx vx)+ where x = literal "x"+ vx = sVar x
+ Documentation/SBV/Examples/BitPrecise/Adders.hs view
@@ -0,0 +1,185 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.BitPrecise.Adders+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Build two textbook binary adders out of logic gates and prove them correct,+-- fully automatically, by bit-blasting.+--+-- We model each adder as a Haskell function over a statically-known list of+-- symbolic bits, producing a fixed Boolean circuit. We then prove---for a+-- chosen word size---that the circuit computes the same result as SBV's native+-- bit-vector addition @(+)@:+--+-- * A /ripple-carry/ adder, which threads a carry sequentially through a+-- chain of full adders.+--+-- * A /carry-lookahead/ adder, which computes every carry directly from the+-- generate\/propagate signals of all lower bits, with no sequential+-- dependency.+--+-- Besides proving each adder equal to @(+)@, we also prove the two adders equal+-- to /each other/: the fast, parallel carry-lookahead circuit computes exactly+-- the same result as the simple ripple-carry reference.+--+-- All proofs here are discharged by a single decidable bit-vector query at a+-- fixed width. See "Documentation.SBV.Examples.TP.Adder" for the companion+-- development that instead proves a ripple-carry adder correct for /all/ widths+-- at once, by induction.+-----------------------------------------------------------------------------++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.BitPrecise.Adders where++import Data.SBV hiding (fullAdder)+import GHC.TypeLits (KnownNat)++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> :set -XDataKinds -XTypeApplications -XScopedTypeVariables+#endif++-- | A symbolic bit is just a symbolic boolean.+type Bit = SBool++-- * Logic gates++-- | A half adder takes two bits and produces their sum bit and carry bit:+-- @sum = a xor b@, @carry = a and b@.+halfAdder :: Bit -> Bit -> (Bit, Bit)+halfAdder a b = (a .<+> b, a .&& b)++-- | A full adder takes two bits and an incoming carry, and produces the sum bit+-- together with the outgoing carry. We build it out of two half adders, in the+-- usual way.+fullAdder :: Bit -> Bit -> Bit -> (Bit, Bit)+fullAdder a b cin = (s, c0 .|| c1)+ where (s0, c0) = halfAdder a b+ (s, c1) = halfAdder s0 cin++-- * Ripple-carry adder++-- | The ripple-carry adder. Given an incoming carry and a little-endian list of+-- bit pairs (one pair per bit position, least-significant first), it threads the+-- carry through a chain of full adders, returning the list of sum bits together+-- with the final carry-out.+rippleAdd :: Bit -> [(Bit, Bit)] -> ([Bit], Bit)+rippleAdd cin [] = ([], cin)+rippleAdd cin ((a, b) : ps) = (s : ss, cout)+ where (s, c) = fullAdder a b cin+ (ss, cout) = rippleAdd c ps++-- * Carry-lookahead adder++-- | Generate and propagate signals for a bit position: a position /generates/ a+-- carry when both inputs are set, and /propagates/ an incoming carry when+-- exactly one input is set.+generatePropagate :: Bit -> Bit -> (Bit, Bit)+generatePropagate a b = (a .&& b, a .<+> b)++-- | The carry-lookahead adder. Rather than rippling the carry through the chain,+-- it computes the carry /into/ each position directly from the+-- generate\/propagate signals of all lower positions, using the textbook+-- expansion+--+-- @+-- c(i) = g(i-1) + p(i-1).g(i-2) + ... + p(i-1)...p(1).g(0) + p(i-1)...p(0).cin+-- @+--+-- so that every carry is an independent flat formula with no sequential+-- dependency. The sum bit at position @i@ is then @p(i) xor c(i)@, and the+-- carry-out is the carry into the (nonexistent) position just past the top.+lookaheadAdd :: Bit -> [(Bit, Bit)] -> ([Bit], Bit)+lookaheadAdd cin ps = (sums, carryInto n)+ where n = length ps+ gps = [ generatePropagate a b | (a, b) <- ps ]++ g k = fst (gps !! k)+ p k = snd (gps !! k)++ -- product of the propagate signals over positions [lo .. hi-1]+ prodP lo hi = sAnd [ p k | k <- [lo .. hi - 1] ]++ -- carry into position i, expanded over all lower positions+ carryInto i = sOr $ (cin .&& prodP 0 i)+ : [ g j .&& prodP (j + 1) i | j <- [0 .. i - 1] ]++ sums = [ p i .<+> carryInto i | i <- [0 .. n - 1] ]++-- * Lifting to words++-- | Run an adder over the bits of two words. We blast both operands into+-- little-endian bit lists, feed them to the adder with no incoming carry, and+-- reassemble the sum bits into a word. The carry-out is dropped, matching the+-- wrap-around semantics of bit-vector @(+)@.+addWith :: forall n. (KnownNat n, BVIsNonZero n) => (Bit -> [(Bit, Bit)] -> ([Bit], Bit)) -> SWord n -> SWord n -> SWord n+addWith adder x y = fromBitsLE ss+ where (ss, _) = adder sFalse (zip (blastLE x) (blastLE y))++-- | The ripple-carry adder, lifted to words.+rippleAddWord :: (KnownNat n, BVIsNonZero n) => SWord n -> SWord n -> SWord n+rippleAddWord = addWith rippleAdd++-- | The carry-lookahead adder, lifted to words.+lookaheadAddWord :: (KnownNat n, BVIsNonZero n) => SWord n -> SWord n -> SWord n+lookaheadAddWord = addWith lookaheadAdd++-- * Correctness++-- | The ripple-carry adder computes bit-vector addition. We prove it here at+-- width 8, but the same call proves it at any width you instantiate:+--+-- >>> rippleCorrect @8+-- Q.E.D.+--+-- Adder-versus-@(+)@ equivalence is one of the easy cases for bit-blasting (the+-- carry chain is linear), so this stays fast even at large widths---it is the+-- cheap baseline to compare the lookahead proofs against.+rippleCorrect :: forall n. (KnownNat n, BVIsNonZero n) => IO ThmResult+rippleCorrect = prove $ \(x :: SWord n) (y :: SWord n) -> rippleAddWord x y .== x + y++-- | The carry-lookahead adder computes bit-vector addition:+--+-- >>> lookaheadCorrect @8+-- Q.E.D.+--+-- Note that, unlike 'rippleCorrect', this proof slows down noticeably as the+-- width grows. The lookahead carry is the flat \(O(n^2)\) generate\/propagate+-- expansion, so the formula handed to the solver grows quadratically in the+-- width---try @lookaheadCorrect \@64@, @\@128@, @\@256@ to watch it climb.+lookaheadCorrect :: forall n. (KnownNat n, BVIsNonZero n) => IO ThmResult+lookaheadCorrect = prove $ \(x :: SWord n) (y :: SWord n) -> lookaheadAddWord x y .== x + y++-- | The fast carry-lookahead adder agrees with the simple ripple-carry adder on+-- every input---the parallel carry computation refines the sequential one:+--+-- >>> rippleEqLookahead @8+-- Q.E.D.+--+-- This proof drags in the same \(O(n^2)\) lookahead carry expansion as+-- 'lookaheadCorrect', so it scales the same way: comfortable at small widths,+-- visibly slower as the width grows.+rippleEqLookahead :: forall n. (KnownNat n, BVIsNonZero n) => IO ThmResult+rippleEqLookahead = prove $ \(x :: SWord n) (y :: SWord n) -> rippleAddWord x y .== lookaheadAddWord x y++-- | The carry-out of the ripple-carry adder is exactly the unsigned overflow+-- flag: it is set precisely when the true sum does not fit in @n@ bits, which+-- for an addition with no incoming carry is detectable as the result wrapping+-- below either operand:+--+-- >>> rippleOverflow @8+-- Q.E.D.+rippleOverflow :: forall n. (KnownNat n, BVIsNonZero n) => IO ThmResult+rippleOverflow = prove $ \(x :: SWord n) (y :: SWord n) ->+ let (_, cout) = rippleAdd sFalse (zip (blastLE x) (blastLE y))+ in cout .== ((x + y) .< x)
Documentation/SBV/Examples/BitPrecise/BitTricks.hs view
@@ -53,8 +53,7 @@ -- | Collection of queries queries :: IO () queries =- let check :: Provable a => String -> a -> IO ()- check w t = do putStr $ "Proving " ++ show w ++ ": "+ let check w t = do putStr $ "Proving " ++ show w ++ ": " print =<< prove t in do check "Fast min " fastMinCorrect check "Fast max " fastMaxCorrect
Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs view
@@ -10,6 +10,8 @@ -- <http://ai.googleblog.com/2006/06/extra-extra-read-all-about-it-nearly.html> ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.BitPrecise.BrokenSearch where@@ -17,24 +19,26 @@ import Data.SBV import Data.SBV.Tools.Overflow +#ifdef DOCTEST -- $setup -- >>> import Data.SBV -- >>> import Data.Int+#endif -- | Model the mid-point computation of the binary search, which is broken due to arithmetic overflow. -- Note how we use the overflow checking variants of the arithmetic operators. We have: -- -- >>> checkArithOverflow midPointBroken--- ./Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs:39:32:+!: SInt32 addition overflows: Violated. Model:--- low = 2147483647 :: Int32--- high = 2147483647 :: Int32+-- ./Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs:43:32:+!: SInt32 addition overflows: Violated. Model:+-- low = 1073741832 :: Int32+-- high = 1107296257 :: Int32 -- -- Indeed: ----- >>> (2147483647 + 2147483647) `div` (2::Int32)--- -1+-- >>> (1073741832 + 1107296257) `div` (2::Int32)+-- -1056964604 ----- giving us a negative mid-point value!+-- giving us quite a large negative mid-point value! midPointBroken :: SInt32 -> SInt32 -> SInt32 midPointBroken low high = (low +! high) /! 2 @@ -106,6 +110,6 @@ mid = f low high - return $ sFromIntegral mid .== mid'+ pure $ sFromIntegral mid .== mid' -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore module "Reduce duplication" -}
Documentation/SBV/Examples/BitPrecise/Legato.hs view
@@ -13,16 +13,16 @@ -- Here's Legato's algorithm, as coded in Mostek assembly: -- -- @--- step1 : LDX #8 ; load X immediate with the integer 8 --- step2 : LDA #0 ; load A immediate with the integer 0 --- step3 : LOOP ROR F1 ; rotate F1 right circular through C --- step4 : BCC ZCOEF ; branch to ZCOEF if C = 0 --- step5 : CLC ; set C to 0 --- step6 : ADC F2 ; set A to A+F2+C and C to the carry --- step7 : ZCOEF ROR A ; rotate A right circular through C --- step8 : ROR LOW ; rotate LOW right circular through C --- step9 : DEX ; set X to X-1 --- step10: BNE LOOP ; branch to LOOP if Z = 0 +-- step1 : LDX #8 ; load X immediate with the integer 8+-- step2 : LDA #0 ; load A immediate with the integer 0+-- step3 : LOOP ROR F1 ; rotate F1 right circular through C+-- step4 : BCC ZCOEF ; branch to ZCOEF if C = 0+-- step5 : CLC ; set C to 0+-- step6 : ADC F2 ; set A to A+F2+C and C to the carry+-- step7 : ZCOEF ROR A ; rotate A right circular through C+-- step8 : ROR LOW ; rotate LOW right circular through C+-- step9 : DEX ; set X to X-1+-- step10: BNE LOOP ; branch to LOOP if Z = 0 -- @ -- -- This program came to be known as the Legato's challenge in the community, where@@ -81,7 +81,7 @@ -- Unlike traditional hardware, we assume the program is stored in some other memory area that -- we need not model. (No self modifying programs!) ----- 'Mostek' is equipped with an automatically derived 'Mergeable' instance+-- t'Mostek' is equipped with an automatically derived 'Mergeable' instance -- because each field is 'Mergeable'. data Mostek = Mostek { memory :: Memory , registers :: Registers@@ -294,7 +294,7 @@ flagC <- sBool "flagC" flagZ <- sBool "flagZ" - return $ legatoIsCorrect (x, y, lo, regX, regA, flagC, flagZ)+ pure $ legatoIsCorrect (x, y, lo, regX, regA, flagC, flagZ) ------------------------------------------------------------------ -- * C Code generation@@ -309,5 +309,5 @@ cgOutput "hi" hi cgOutput "lo" lo -{-# ANN legato ("HLint: ignore Redundant $" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore legato "Redundant $" -}+{- HLint ignore module "Reduce duplication" -}
Documentation/SBV/Examples/BitPrecise/MergeSort.hs view
@@ -6,9 +6,16 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- Symbolic implementation of merge-sort and its correctness.+-- Symbolic implementation of merge-sort and its correctness. Note that this+-- 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.TP.MergeSort", which+-- shows the full-power of the theorem-proving like aspects of SBV. ----------------------------------------------------------------------------- +{-# LANGUAGE TupleSections #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.BitPrecise.MergeSort where@@ -46,7 +53,7 @@ There are two main parts to proving that a sorting algorithm is correct: * Prove that the output is non-decreasing- + * Prove that the output is a permutation of the input -} @@ -60,7 +67,7 @@ -- is a subset of the other, when considered as a set. The check is slightly complicated -- for the need to account for possibly duplicated elements. isPermutationOf :: [E] -> [E] -> SBool-isPermutationOf as bs = go as (zip bs (repeat sTrue)) .&& go bs (zip as (repeat sTrue))+isPermutationOf as bs = go as (map (, sTrue) bs) .&& go bs (map (, sTrue) as) where go [] _ = sTrue go (x:xs) ys = let (found, ys') = mark x ys in found .&& go xs ys' -- Go and mark off an instance of 'x' in the list, if possible. We keep track@@ -81,7 +88,7 @@ correctness :: Int -> IO ThmResult correctness n = prove $ do xs <- mkFreeVars n let ys = mergeSort xs- return $ nonDecreasing ys .&& isPermutationOf xs ys+ pure $ nonDecreasing ys .&& isPermutationOf xs ys ----------------------------------------------------------------------------- -- * Generating C code
− Documentation/SBV/Examples/BitPrecise/MultMask.hs
@@ -1,64 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Documentation.SBV.Examples.BitPrecise.MultMask--- Copyright : (c) Levent Erkok--- License : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ An SBV solution to the bit-precise puzzle of shuffling the bits in a--- 64-bit word in a custom order. The idea is to take a 64-bit value:------ @1.......2.......3.......4.......5.......6.......7.......8.......@------ And turn it into another 64-bit value, that looks like this:------ @12345678........................................................@------ We do not care what happens to the bits that are represented by dots. The--- problem is to do this with one mask and one multiplication.------ Apparently this operation has several applications, including in programs--- that play chess of all things. We use SBV to find the appropriate mask and--- the multiplier.------ Note that this is an instance of the program synthesis problem, where--- we "fill in the blanks" given a certain skeleton that satisfy a certain--- property, using quantified formulas.--------------------------------------------------------------------------------{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.BitPrecise.MultMask where--import Data.SBV-import Data.SBV.Control---- | Find the multiplier and the mask as described. We have:------ >>> maskAndMult--- Satisfiable. Model:--- mask = 0x8080808080808080 :: Word64--- mult = 0x0002040810204081 :: Word64------ That is, any 64 bit value masked by the first and multiplied by the second--- value above will have its bits at positions @[7,15,23,31,39,47,55,63]@ moved--- to positions @[56,57,58,59,60,61,62,63]@ respectively.------ NB. Depending on your z3 version, you might also get the following--- multiplier as the result: 0x8202040810204081. That value works just fine as well!------ NB. Note the custom call to z3 with a specific tactic. A simple call to z3 unfortunately--- does not terminate quickly.-maskAndMult :: IO ()-maskAndMult = print =<< satWith z3{printBase=16} find- where find = do -- Magic incantation to make the test go fast. See <http://github.com/Z3Prover/z3/issues/5660> for details.- setOption $ OptionKeyword ":tactic.default_tactic" ["sat"]- setOption $ OptionKeyword ":sat.euf" ["true"]- setOption $ OptionKeyword ":smt.ematching" ["false"]-- mask <- sbvExists "mask"- mult <- sbvExists "mult"- inp <- sbvForall "inp"- let res = (mask .&. inp) * (mult :: SWord64)- solve [inp `sExtractBits` [7, 15 .. 63] .== res `sExtractBits` [56 .. 63]]
+ Documentation/SBV/Examples/BitPrecise/PEXT_PDEP.hs view
@@ -0,0 +1,163 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.BitPrecise.PEXT_PDEP+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+--+-- Models the x86 [PEXT](https://www.felixcloutier.com/x86/pext) and [PDEP](https://www.felixcloutier.com/x86/pdep) instructions.+--+-- The pseudo-code implementation given by Intel for PEXT (parallel extract) is:+--+-- @+-- TEMP := SRC1;+-- MASK := SRC2;+-- DEST := 0 ;+-- m := 0, k := 0;+-- DO WHILE m < OperandSize+-- IF MASK[m] = 1 THEN+-- DEST[k] := TEMP[m];+-- k := k+ 1;+-- FI+-- m := m+ 1;+-- OD+-- @+--+-- PDEP (parallel deposit) is similar, except the assignment is:+--+-- @+-- DEST[m] := TEMP[k]+-- @+--+-- In PEXT, we grab the values of the source corresponding to the mask, and pile them into the destination from the bottom. In PDEP, we+-- do the reverse: We distribute the bits from the bottom of the source to the destination according to the mask.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.BitPrecise.PEXT_PDEP where++import Data.SBV+import GHC.TypeLits (KnownNat)++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> :set -XDataKinds -XTypeApplications+#endif++--------------------------------------------------------------------------------------------------+-- * Parallel extraction+--------------------------------------------------------------------------------------------------++-- | Parallel extraction: Given a source value and a mask, extract the bits in the source that are+-- pointed to by the mask, and put it in the destination starting from the bottom.+--+-- >>> satWith z3{printBase = 16} $ \r -> r .== pext (0xAA :: SWord 8) 0xAA+-- Satisfiable. Model:+-- s0 = 0x0f :: Word8+-- >>> prove $ \x -> pext @8 x 0 .== 0+-- Q.E.D.+-- >>> prove $ \x -> pext @8 x (complement 0) .== x+-- Q.E.D.+pext :: forall n. (KnownNat n, BVIsNonZero n) => SWord n -> SWord n -> SWord n+pext src mask = walk 0 src 0 (blastLE mask)+ where walk dest _ _ [] = dest+ walk dest x idx (m:ms) = walk (ite m (sSetBitTo dest idx (lsb x)) dest)+ (x `shiftR` 1)+ (ite m (idx + 1) idx)+ ms++--------------------------------------------------------------------------------------------------+-- * Parallel deposit+--------------------------------------------------------------------------------------------------++-- | Parallel deposit: Given a source value and a mask, write into the destination that are+-- allowed by the mask, grabbing the bits from the source starting from the bottom.+--+-- >>> satWith z3{printBase = 16} $ \r -> r .== pdep (0xFF :: SWord 8) 0xAA+-- Satisfiable. Model:+-- s0 = 0xaa :: Word8+-- >>> prove $ \x -> pdep @8 x 0 .== 0+-- Q.E.D.+-- >>> prove $ \x -> pdep @8 x (complement 0) .== x+-- Q.E.D.+pdep :: forall n. (KnownNat n, BVIsNonZero n) => SWord n -> SWord n -> SWord n+pdep src mask = walk 0 src 0 (blastLE mask)+ where walk dest _ _ [] = dest+ walk dest x idx (m:ms) = walk (ite m (sSetBitTo dest idx (lsb x)) dest)+ (ite m (x `shiftR` 1) x)+ (idx + 1)+ ms+--------------------------------------------------------------------------------------------------+-- * Round-trip property+--------------------------------------------------------------------------------------------------++-- | Prove that extraction and depositing with the same mask restore the source in all masked positions:+--+-- >>> extractThenDeposit+-- Q.E.D.+extractThenDeposit :: IO ThmResult+extractThenDeposit = prove $ do x :: SWord 8 <- sWord "x"+ m :: SWord 8 <- sWord "m"+ pure $ (x .&. m) .== pdep (pext x m) m++-- | Prove that depositing and extracting with the same mask will push preserve the bottom+-- n-bits of the source, where n is the number of bits set in the mask.+--+-- >>> depositThenExtract+-- Q.E.D.+depositThenExtract :: IO ThmResult+depositThenExtract = prove $ do x :: SWord 8 <- sWord "x"+ m :: SWord 8 <- sWord "m"+ let preserved = 2 .^ sPopCount m - 1+ pure $ (x .&. preserved) .== pext (pdep x m) m++--------------------------------------------------------------------------------------------------+-- * Code generation+--------------------------------------------------------------------------------------------------++-- | We can generate the code for these functions if they need to be used in SMTLib. Below+-- is an example at 2-bits, which can be adjusted to produce any bit-size.+--+-- >>> putStrLn =<< sbv2smt pext_2+-- ; Automatically generated by SBV. Do not modify!+-- ; |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))+-- (let ((l1_s20 #b10))+-- (let ((l1_s2 ((_ extract 1 1) l1_s1)))+-- (let ((l1_s4 (distinct l1_s2 l1_s3)))+-- (let ((l1_s5 ((_ extract 0 0) l1_s1)))+-- (let ((l1_s6 (distinct l1_s3 l1_s5)))+-- (let ((l1_s9 (ite l1_s6 l1_s7 l1_s8)))+-- (let ((l1_s10 (= l1_s7 l1_s9)))+-- (let ((l1_s11 (bvlshr l1_s0 l1_s7)))+-- (let ((l1_s12 ((_ extract 0 0) l1_s11)))+-- (let ((l1_s13 (distinct l1_s3 l1_s12)))+-- (let ((l1_s14 (= l1_s8 l1_s9)))+-- (let ((l1_s15 ((_ extract 0 0) l1_s0)))+-- (let ((l1_s16 (distinct l1_s3 l1_s15)))+-- (let ((l1_s17 (ite l1_s16 l1_s7 l1_s8)))+-- (let ((l1_s18 (ite l1_s6 l1_s17 l1_s8)))+-- (let ((l1_s19 (bvor l1_s7 l1_s18)))+-- (let ((l1_s21 (bvand l1_s18 l1_s20)))+-- (let ((l1_s22 (ite l1_s13 l1_s19 l1_s21)))+-- (let ((l1_s23 (ite l1_s14 l1_s22 l1_s18)))+-- (let ((l1_s24 (bvor l1_s20 l1_s23)))+-- (let ((l1_s25 (bvand l1_s7 l1_s23)))+-- (let ((l1_s26 (ite l1_s13 l1_s24 l1_s25)))+-- (let ((l1_s27 (ite l1_s10 l1_s26 l1_s23)))+-- (let ((l1_s28 (ite l1_s4 l1_s27 l1_s18)))+-- l1_s28))))))))))))))))))))))))))))+pext_2 :: SWord 2 -> SWord 2 -> SWord 2+pext_2 = smtFunction "pext_2" (pext @2)
Documentation/SBV/Examples/BitPrecise/PrefixSum.hs view
@@ -8,11 +8,12 @@ -- -- The PrefixSum algorithm over power-lists and proof of -- the Ladner-Fischer implementation.--- See <http://dl.acm.org/citation.cfm?id=197356>+-- See <https://www.cs.utexas.edu/~misra/psp.dir/powerlist.pdf> -- and <http://www.cs.utexas.edu/~plaxton/c/337/05f/slides/ParallelRecursion-4.pdf>. ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-}@@ -21,16 +22,17 @@ import Data.SBV +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif ---------------------------------------------------------------------- -- * Formalizing power-lists ---------------------------------------------------------------------- -- | A poor man's representation of powerlists and--- basic operations on them: <http://dl.acm.org/citation.cfm?id=197356>+-- basic operations on them: <https://www.cs.utexas.edu/~misra/psp.dir/powerlist.pdf>. -- We merely represent power-lists by ordinary lists. type PowerList a = [a] @@ -64,16 +66,15 @@ -- * The Ladner-Fischer parallel version ---------------------------------------------------------------------- --- | The Ladner-Fischer (@lf@) implementation of prefix-sum. See <http://www.cs.utexas.edu/~plaxton/c/337/05f/slides/ParallelRecursion-4.pdf>--- or pg. 16 of <http://dl.acm.org/citation.cfm?id=197356>+-- | The Ladner-Fischer (@lf@) implementation of prefix-sum. lf :: (a, a -> a -> a) -> PowerList a -> PowerList a-lf _ [] = error "lf: malformed (empty) powerlist"-lf _ [x] = [x]-lf (zero, f) pl = zipPL (zipWith f (rsh lfpq) p) lfpq+lf _ [] = error "lf: malformed (empty) powerlist"+lf _ [x] = [x]+lf (zeroE, f) pl = zipPL (zipWith f (rsh lfpq) p) lfpq where (p, q) = unzipPL pl pq = zipWith f p q- lfpq = lf (zero, f) pq- rsh xs = zero : init xs+ lfpq = lf (zeroE, f) pq+ rsh xs = zeroE : init xs ----------------------------------------------------------------------@@ -83,8 +84,8 @@ -- | Correctness theorem, for a powerlist of given size, an associative operator, and its left-unit element. flIsCorrect :: Int -> (forall a. (OrdSymbolic a, Num a, Bits a) => (a, a -> a -> a)) -> Symbolic SBool flIsCorrect n zf = do- args :: PowerList SWord32 <- mkForallVars n- return $ ps zf args .== lf zf args+ args :: PowerList SWord32 <- mkFreeVars n+ pure $ ps zf args .== lf zf args -- | Proves Ladner-Fischer is equivalent to reference specification for addition. -- @0@ is the left-unit element, and we use a power-list of size @8@. We have:
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@@ -100,7 +107,7 @@ -- > const SWord64 s32 = s6 ? 0x0000000000000001ULL : s31; -- > const SWord64 s33 = s4 ? 0x0000000000000001ULL : s32; -- > const SWord64 s34 = s2 ? 0x0000000000000000ULL : s33;--- > +-- > -- > return s34; -- > } genFib1 :: SWord64 -> IO ()@@ -119,10 +126,10 @@ -} -- | Compute the fibonacci numbers statically at /code-generation/ time and--- put them in a table, accessed by the 'select' call. -fib2 :: SWord64 -> SWord64 -> SWord64+-- put them in a table, accessed by the 'select' call.+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@@ -169,10 +176,10 @@ -- > 0x000003af9a19bbd9ULL, 0x000005f6c7b064e2ULL, 0x000009a661ca20bbULL -- > }; -- > const SWord64 s65 = s0 >= 65 ? 0x0000000000000000ULL : table0[s0];--- > +-- > -- > 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/GCD.hs view
@@ -13,6 +13,8 @@ -- enforce termination by using a recursion depth counter. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.CodeGeneration.GCD where@@ -20,10 +22,11 @@ import Data.SBV import Data.SBV.Tools.CodeGen +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV -- >>> import Data.SBV.Tools.CodeGen+#endif ----------------------------------------------------------------------------- -- * Computing GCD@@ -85,14 +88,14 @@ -- precisely the same amount of time for all values of @x@ and @y@. -- -- > /* File: "sgcd.c". Automatically generated by SBV. Do not edit! */--- > +-- > -- > #include <stdio.h> -- > #include <stdlib.h> -- > #include <inttypes.h> -- > #include <stdint.h> -- > #include <stdbool.h> -- > #include "sgcd.h"--- > +-- > -- > SWord8 sgcd(const SWord8 x, const SWord8 y) -- > { -- > const SWord8 s0 = x;@@ -143,7 +146,7 @@ -- > const SWord8 s46 = s9 ? s5 : s45; -- > const SWord8 s47 = s6 ? s1 : s46; -- > const SWord8 s48 = s3 ? s0 : s47;--- > +-- > -- > return s48; -- > } genGCDInC :: IO ()
Documentation/SBV/Examples/CodeGeneration/PopulationCount.hs view
@@ -10,6 +10,8 @@ -- generating C code. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.CodeGeneration.PopulationCount where@@ -17,9 +19,10 @@ import Data.SBV import Data.SBV.Tools.CodeGen +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif ----------------------------------------------------------------------------- -- * Reference: Slow but /obviously/ correct@@ -56,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/CodeGeneration/Uninterpreted.hs view
@@ -13,6 +13,9 @@ -- purposes, such as efficiency, or reliability. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.CodeGeneration.Uninterpreted where@@ -22,9 +25,10 @@ import Data.SBV import Data.SBV.Tools.CodeGen +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif -- | A definition of shiftLeft that can deal with variable length shifts. -- (Note that the ``shiftL`` method from the 'Bits' class requires an 'Int' shift
Documentation/SBV/Examples/Crypto/AES.hs view
@@ -24,14 +24,16 @@ -- are supported. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-} module Documentation.SBV.Examples.Crypto.AES where -import Control.Monad (void)+import Control.Monad (void, when) import Data.SBV import Data.SBV.Tools.CodeGen@@ -40,11 +42,16 @@ import Data.List (transpose) import Data.Maybe (fromJust) +import Data.Proxy+ import Numeric (showHex) +import Test.QuickCheck hiding (verbose)++#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif ----------------------------------------------------------------------------- -- * Formalizing GF(2^8)@@ -56,7 +63,7 @@ -- | Multiplication in GF(2^8). This is simple polynomial multiplication, followed -- by the irreducible polynomial @x^8+x^4+x^3+x^1+1@. We simply use the 'pMult'--- function exported by SBV to do the operation. +-- function exported by SBV to do the operation. gf28Mult :: GF28 -> GF28 -> GF28 gf28Mult x y = pMult (x, y, [8, 4, 3, 1, 0]) @@ -135,10 +142,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.@@ -146,13 +153,13 @@ keyExpansion nk key = chop4 keys where keys :: [SWord 32] keys = key ++ [nextWord i prev old | i <- [nk ..] | prev <- drop (nk-1) keys | old <- keys]- chop4 :: [a] -> [[a]]- chop4 xs = let (f, r) = splitAt 4 xs in f : chop4 r+ nextWord :: Int -> SWord 32 -> SWord 32 -> SWord 32 nextWord i prev old | i `mod` nk == 0 = old `xor` subWordRcon (prev `rotateL` 8) (roundConstants !! (i `div` nk)) | i `mod` nk == 4 && nk > 6 = old `xor` subWordRcon prev 0 | True = old `xor` prev+ subWordRcon :: SWord 32 -> GF28 -> SWord 32 subWordRcon w rc = fromBytes [a `xor` rc, b, c, d] where [a, b, c, d] = map sbox $ toBytes w@@ -166,7 +173,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]] @@ -183,7 +190,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]] @@ -218,19 +225,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@@ -242,19 +249,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@@ -307,7 +314,9 @@ -- | Key schedule. Given a 128, 192, or 256 bit key, expand it to get key-schedules -- for encryption and decryption. The key is given as a sequence of 32-bit words.--- (4 elements for 128-bits, 6 for 192, and 8 for 256.)+-- (4 elements for 128-bits, 6 for 192, and 8 for 256.) Compare this function to 'aesInvKeySchedule'+-- which can calculate the key-expansion for decryption on the fly, as opposed to calculating+-- the forward key-expansion first. aesKeySchedule :: Key -> (KS, KS) aesKeySchedule key | nk `elem` [4, 6, 8]@@ -342,9 +351,152 @@ = error "aesDecrypt: Invalid cipher-text size" -----------------------------------------------------------------------------+-- * On-the-fly decryption+-- ${ontheflyintro}+-----------------------------------------------------------------------------+{- $ontheflyintro+ While regular encryption can be fused with key-generation, the standard method of AES+ decryption has to perform the key-expansion before decryption starts. This can be undesirable+ as it necessarily serializes the action of key-expansion before decryption. An+ alternative is to do on-the-fly decryption: We can expand the key in reverse, and thus+ need not save the key-schedule. One downside of this approach, however, is that we need+ to keep the "unwound" key: That is, instead of the common key used for encryption and+ decryption, we need to hold on to the final value of key-expansion, so it can be run+ in reverse. In this section, we implement on-the-fly decryption using this idea.+-}++-- | Inverse key expansion. Starting from the final round key, unwinds key generation operation+-- to construct keys for the previous rounds. Used in on-the-fly decryption.+invKeyExpansion :: Int -> Key -> [Key]+invKeyExpansion nk rkey = map reverse (chop4 keys)+ where keys :: [SWord 32]+ keys = rkey ++ [invNextWord i prev old | i <- reverse [0 .. remaining - 1] | prev <- drop 1 keys | old <- keys]++ totalWords = 4 * (nk + 6 + 1)+ remaining = totalWords - nk++ invNextWord :: Int -> SWord 32 -> SWord 32 -> SWord 32+ invNextWord i prev old+ | i `mod` nk == 0 = old `xor` subWordRcon (prev `rotateL` 8) (roundConstants !! (1 + i `div` nk))+ | i `mod` nk == 4 && nk > 6 = old `xor` subWordRcon prev 0+ | True = old `xor` prev++ subWordRcon :: SWord 32 -> GF28 -> SWord 32+ subWordRcon w rc = fromBytes [a `xor` rc, b, c, d]+ where [a, b, c, d] = map sbox $ toBytes w++-- | AES inverse key schedule. Starting from the last-round key, construct the sequence of keys+-- that can be used for doing on-the-fly decryption. Compare this function to 'aesKeySchedule' which+-- returns both encryption and decryption schedules: In this case, we don't calculate the encryption+-- sequence, hence we can fuse this function with the decryption operation.+aesInvKeySchedule :: Key -> KS+aesInvKeySchedule key+ | nk `elem` [4, 6, 8]+ = decKS+ | True+ = error "aesInvKeySchedule: Invalid key size"+ where nk = length key+ nr = nk + 6+ decKS = (head rKeys, take (nr-1) (tail rKeys), rKeys !! nr)+ rKeys = invKeyExpansion nk key++-- | Block decryption, starting from the unwound key. That is, start from the final key.+-- Also; we don't use the T-box implementation. Just pure AES inverse cipher.+aesDecryptUnwoundKey :: [SWord 32] -> KS -> [SWord 32]+aesDecryptUnwoundKey ct decKS+ | length ct == 4+ = doRounds aesInvRoundRegular decKS ct+ | True+ = error "aesDecrypt: Invalid cipher-text size"+ where aesInvRoundRegular isFinal s key = u+ where u :: State+ u = map (f isFinal) [0 .. 3]+ where a = map toBytes s+ kbs = map toBytes key+ f True j = fromBytes [ unSBox (a !! ((j+0) `mod` 4) !! 0)+ , unSBox (a !! ((j+3) `mod` 4) !! 1)+ , unSBox (a !! ((j+2) `mod` 4) !! 2)+ , unSBox (a !! ((j+1) `mod` 4) !! 3)+ ] `xor` (key !! j)+ f False j = e0 `xor` e1 `xor` e2 `xor` e3+ where e0 = otfU0 $ unSBox (a !! ((j+0) `mod` 4) !! 0) `xor` (kbs !! j !! 0)+ e1 = otfU1 $ unSBox (a !! ((j+3) `mod` 4) !! 1) `xor` (kbs !! j !! 1)+ e2 = otfU2 $ unSBox (a !! ((j+2) `mod` 4) !! 2) `xor` (kbs !! j !! 2)+ 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 <- 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 ----------------------------------------------------------------------------- +-- | Common plain text for test vectors+commonPT :: [SWord 32]+commonPT = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]++-- | Key for 128-bit encryption test+aes128Key :: Key+aes128Key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]++-- | Key for 192-bit encryption test+aes192Key :: Key+aes192Key = aes128Key ++ [0x10111213, 0x14151617]++-- | Key for 256-bit encryption test+aes256Key :: Key+aes256Key = aes192Key ++ [0x18191a1b, 0x1c1d1e1f]++-- | Expected cipher-text for 128-bit encryption+aes128CT :: [SWord 32]+aes128CT = [0x69c4e0d8, 0x6a7b0430, 0xd8cdb780, 0x70b4c55a]++-- | Expected cipher-text for 192-bit encryption+aes192CT :: [SWord 32]+aes192CT = [0xdda97ca4, 0x864cdfe0, 0x6eaf70a0, 0xec0d7191]++-- | Expected cipher-text for 256-bit encryption+aes256CT :: [SWord 32]+aes256CT = [0x8ea2b7ca, 0x516745bf, 0xeafc4990, 0x4b496089]++-- | Calculate the 128-bit final-round key from on-the-fly decryption key schedule+aes128InvKey :: Key+aes128InvKey = extractFinalKey aes128Key++-- | Calculate the 192-bit final-round key from on-the-fly decryption key schedule+aes192InvKey :: Key+aes192InvKey = extractFinalKey aes192Key++-- | Calculate the 192-bit final-round key from on-the-fly decryption key schedule. Compare this+-- to 'aes192InvKey': Typically we just need the final 6-blocks, but it is advantageous to have+-- the entire last 8-blocks even for 192-bit keys. That is, e store the final 256-bits of key-expansion+-- for speed purposes for both 192 and 256 bit versions. (But only the final 128 bits for the 128-bit version.)+aes192InvKeyExtended :: Key+aes192InvKeyExtended = extractFinalKeyExtended aes192Key++-- | Calculate the 256-bit final-round key from on-the-fly decryption key schedule+aes256InvKey :: Key+aes256InvKey = extractFinalKey aes256Key++-- | Extract the final key for on-the-fly decryption. This will extract exactly the number of blocks we need.+extractFinalKey :: [SWord 32] -> [SWord 32]+extractFinalKey initKey = take nk (extractFinalKeyExtended initKey)+ where nk = length initKey++-- | Extract the extended key for on-the-fly decryption. This will extract 4-blocks for 128-bit decryption,+-- but 256 bit for both 192 and 256-bit variants+extractFinalKeyExtended :: [SWord 32] -> [SWord 32]+extractFinalKeyExtended initKey = take feed (concatMap reverse (chop4 (take feed roundKeys)))+ where nk = length initKey+ feed | nk == 4 = 4+ | True = 8++ ((f, m, l), _) = aesKeySchedule initKey+ roundKeys = l ++ concat (reverse m) ++ f+ ----------------------------------------------------------------------------- -- ** 128-bit enc/dec test -----------------------------------------------------------------------------@@ -353,23 +505,17 @@ -- -- >>> map hex8 t128Enc -- ["69c4e0d8","6a7b0430","d8cdb780","70b4c55a"]--- t128Enc :: [SWord 32]-t128Enc = aesEncrypt pt ks- where pt = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]- key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]- (ks, _) = aesKeySchedule key+t128Enc = aesEncrypt commonPT ks+ where (ks, _) = aesKeySchedule aes128Key -- | 128-bit decryption test, from Appendix C.1 of the AES standard: -- -- >>> map hex8 t128Dec -- ["00112233","44556677","8899aabb","ccddeeff"]--- t128Dec :: [SWord 32]-t128Dec = aesDecrypt ct ks- where ct = [0x69c4e0d8, 0x6a7b0430, 0xd8cdb780, 0x70b4c55a]- key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]- (_, ks) = aesKeySchedule key+t128Dec = aesDecrypt aes128CT ks+ where (_, ks) = aesKeySchedule aes128Key ----------------------------------------------------------------------------- -- ** 192-bit enc/dec test@@ -379,12 +525,9 @@ -- -- >>> map hex8 t192Enc -- ["dda97ca4","864cdfe0","6eaf70a0","ec0d7191"]--- t192Enc :: [SWord 32]-t192Enc = aesEncrypt pt ks- where pt = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]- key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617]- (ks, _) = aesKeySchedule key+t192Enc = aesEncrypt commonPT ks+ where (ks, _) = aesKeySchedule aes192Key -- | 192-bit decryption test, from Appendix C.2 of the AES standard: --@@ -392,10 +535,8 @@ -- ["00112233","44556677","8899aabb","ccddeeff"] -- t192Dec :: [SWord 32]-t192Dec = aesDecrypt ct ks- where ct = [0xdda97ca4, 0x864cdfe0, 0x6eaf70a0, 0xec0d7191]- key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617]- (_, ks) = aesKeySchedule key+t192Dec = aesDecrypt aes192CT ks+ where (_, ks) = aesKeySchedule aes192Key ----------------------------------------------------------------------------- -- ** 256-bit enc/dec test@@ -405,25 +546,128 @@ -- -- >>> map hex8 t256Enc -- ["8ea2b7ca","516745bf","eafc4990","4b496089"]--- t256Enc :: [SWord 32]-t256Enc = aesEncrypt pt ks- where pt = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]- key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617, 0x18191a1b, 0x1c1d1e1f]- (ks, _) = aesKeySchedule key+t256Enc = aesEncrypt commonPT ks+ where (ks, _) = aesKeySchedule aes256Key -- | 256-bit decryption, from Appendix C.3 of the AES standard: -- -- >>> map hex8 t256Dec -- ["00112233","44556677","8899aabb","ccddeeff"]--- t256Dec :: [SWord 32]-t256Dec = aesDecrypt ct ks- where ct = [0x8ea2b7ca, 0x516745bf, 0xeafc4990, 0x4b496089]- key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617, 0x18191a1b, 0x1c1d1e1f]- (_, ks) = aesKeySchedule key+t256Dec = aesDecrypt aes256CT ks+ where (_, ks) = aesKeySchedule aes256Key +-- | Various tests for round-trip properties. We have:+--+-- >>> runAESTests False+-- GOOD: Key generation AES128+-- GOOD: Key generation AES192+-- GOOD: Key generation AES256+-- GOOD: Encryption AES128+-- GOOD: Decryption AES128+-- GOOD: Decryption-OTF AES128+-- GOOD: Encryption AES192+-- GOOD: Decryption AES192+-- GOOD: Decryption-OTF AES192+-- GOOD: Encryption AES256+-- GOOD: Decryption AES256+-- GOOD: Decryption-OTF AES256+runAESTests :: Bool -> IO ()+runAESTests runQC = do+ testInvKeyExpansion + check "AES128" aes128Key aes128InvKey aes128CT+ check "AES192" aes192Key aes192InvKey aes192CT+ check "AES256" aes256Key aes256InvKey aes256CT++ -- Quick-check tests are rather slow. So only run when requested.+ when runQC $ do+ putStrLn "Quick-check AES128 roundtrip" >> quickCheck roundTrip128+ putStrLn "Quick-check AES192 roundtrip" >> quickCheck roundTrip192+ putStrLn "Quick-check AES256 roundtrip" >> quickCheck roundTrip256++ where check :: String -> Key -> Key -> [SWord 32] -> IO ()+ check what key invKey ctExpected = do eq ("Encryption " ++ what) ctExpected ctGot+ eq ("Decryption " ++ what) commonPT ptGot+ eq ("Decryption-OTF " ++ what) commonPT ptGotInv+ where (encKS, decKS) = aesKeySchedule key+ ctGot = aesEncrypt commonPT encKS+ ptGot = aesDecrypt ctExpected decKS+ ptGotInv = aesDecryptUnwoundKey ctExpected (aesInvKeySchedule invKey)++ eq tag expected got+ | length expected /= length got+ = error $ unlines [ "BAD!: " ++ tag+ , "Comparing different sized lists:"+ , "Expected: " ++ show expected+ , "Got : " ++ show got+ ]+ | map extract expected == map extract got+ = putStrLn $ "GOOD: " ++ tag+ | True+ = error $ unlines [ "BAD!: " ++ tag+ , "Expected: " ++ unwords (map hex8 expected)+ , "Got : " ++ unwords (map hex8 got)+ ]+ where extract :: SWord 32 -> Integer+ extract = fromIntegral . fromJust . unliteral++ testInvKeyExpansion :: IO ()+ testInvKeyExpansion = do goTestInvKey "128" aes128Key+ goTestInvKey "192" aes192Key+ goTestInvKey "256" aes256Key+ goTestInvKey what k = do+ let nk = length k+ nr = nk + 6++ feed = case nk of+ 4 -> 4+ _ -> 8++ ((f, m, l), _) = aesKeySchedule k+ required = l ++ concat (reverse m) ++ f+ invKeySchedule = take (nr+1) $ invKeyExpansion nk (take nk (concatMap reverse (chop4 (take feed required))))+ obtained = concat invKeySchedule++ expected = map (fromJust . unliteral) required+ result = map (fromJust . unliteral) obtained++ sh i a b+ | a == b = pad ++ show i ++ " " ++ disp a+ | True = pad ++ show i ++ " " ++ disp a ++ " |vs| " ++ disp b+ where pad = if i < 10 then " " else ""++ disp = unwords . map (hex8 . literal)++ lexpected = length expected+ lresult = length result++ when (lexpected /= lresult) $+ error $ what ++ ": BAD! Mismatching lengths: " ++ show (lexpected, lresult)++ let debugging = False++ if expected == result+ then if debugging+ then putStrLn $ unlines $ ("Size " ++ what ++ ": Good") : zipWith3 sh [(0::Int)..] (chop4 expected) (chop4 result)+ else putStrLn $ "GOOD: Key generation AES" ++ what+ else error $ unlines $ ("Size " ++ what ++ ": BAD!") : zipWith3 sh [(0::Int)..] (chop4 expected) (chop4 result)++ roundTrip128 (i0, i1, i2, i3) (k0, k1, k2, k3) = roundTrip [i0, i1, i2, i3] [k0, k1, k2, k3]+ roundTrip192 (i0, i1, i2, i3) (k0, k1, k2, k3, k4, k5) = roundTrip [i0, i1, i2, i3] [k0, k1, k2, k3, k4, k5]+ roundTrip256 (i0, i1, i2, i3) (k0, k1, k2, k3, k4, k5, k6, k7) = roundTrip [i0, i1, i2, i3] [k0, k1, k2, k3, k4, k5, k6, k7]++ roundTrip :: [SWord32] -> [SWord32] -> SBool+ roundTrip ptIn keyIn = pt .== pt' .&& pt .== pt''+ where pt = map toSized ptIn+ key = map toSized keyIn++ (encKS, decKS) = aesKeySchedule key+ ct = aesEncrypt pt encKS+ pt' = aesDecrypt ct decKS+ pt'' = aesDecryptUnwoundKey ct (aesInvKeySchedule (extractFinalKey key))+ ----------------------------------------------------------------------------- -- * Verification -- ${verifIntro}@@ -449,12 +693,12 @@ -- @ -- quickCheck aes128IsCorrect -- @--- +-- -- and get some degree of confidence in our code. Similar predicates can be easily constructed for 192, and -- 256 bit cases as well. aes128IsCorrect :: (SWord 32, SWord 32, SWord 32, SWord 32) -- ^ plain-text words -> (SWord 32, SWord 32, SWord 32, SWord 32) -- ^ key-words- -> SBool -- ^ True if round-trip gives us plain-text back+ -> SBool -- ^ True if round-trip gives us plain-text back aes128IsCorrect (i0, i1, i2, i3) (k0, k1, k2, k3) = pt .== pt' where pt = [i0, i1, i2, i3] key = [k0, k1, k2, k3]@@ -463,6 +707,35 @@ pt' = aesDecrypt ct decKS -----------------------------------------------------------------------------+-- * Block encryption at full size+-----------------------------------------------------------------------------++-- | 128-bit encryption, that takes 128-bit values, instead of chunks. We have:+--+-- >>> hex8 $ aes128Enc 0x000102030405060708090a0b0c0d0e0f 0x00112233445566778899aabbccddeeff+-- "69c4e0d86a7b0430d8cdb78070b4c55a"+--+-- You can also render this function as a stand-alone function using:+--+-- @+-- sbv2smt (smtFunction "aes128Enc" aes128Enc)+-- @+aes128Enc :: SWord 128 -> SWord 128 -> SWord 128+aes128Enc key pt = from32 $ aesEncrypt (to32 pt) ks+ where to32 :: SWord 128 -> [SWord 32]+ to32 x = [ bvExtract (Proxy @127) (Proxy @96) x+ , bvExtract (Proxy @95) (Proxy @64) x+ , bvExtract (Proxy @63) (Proxy @32) x+ , bvExtract (Proxy @31) (Proxy @0) x+ ]++ from32 :: [SWord 32] -> SWord 128+ from32 [a, b, c, d] = a # b # c # d+ from32 _ = error "nope"++ (ks, _) = aesKeySchedule (to32 key)++----------------------------------------------------------------------------- -- * Code generation -- ${codeGenIntro} -----------------------------------------------------------------------------@@ -511,9 +784,10 @@ cgAES128BlockEncrypt = compileToC Nothing "aes128BlockEncrypt" $ do pt <- cgInputArr 4 "pt" -- plain-text as an array of 4 Word32's key <- cgInputArr 4 "key" -- key as an array of 4 Word32s+ -- Use the test values from Appendix C.1 of the AES standard as the driver values- cgSetDriverValues $ [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]- ++ [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]+ cgSetDriverValues $ map (fromIntegral . fromJust . unliteral) $ commonPT ++ aes128Key+ let (encKs, _) = aesKeySchedule key cgOutputArr "ct" $ aesEncrypt pt encKs @@ -530,33 +804,65 @@ The generated library is a typical @.a@ archive, that can be linked using the C-compiler as usual. -} --- | Components of the AES implementation that the library is generated from-aesLibComponents :: Int -> [(String, SBVCodeGen ())]-aesLibComponents sz = [ ("aes" ++ show sz ++ "KeySchedule", keySchedule)- , ("aes" ++ show sz ++ "BlockEncrypt", enc)- , ("aes" ++ show sz ++ "BlockDecrypt", dec)+-- | Components of the AES implementation that the library is generated from. For each case, we provide+-- the driver values from the AES test-vectors.+aesLibComponents :: Int -> [(String, [Integer], SBVCodeGen ())]+aesLibComponents sz = [ ("aes" ++ show sz ++ "KeySchedule", keyDriverVals, keySchedule)+ , ("aes" ++ show sz ++ "BlockEncrypt", encDriverVals, enc)+ , ("aes" ++ show sz ++ "BlockDecrypt", decDriverVals, dec)+ , ("aes" ++ show sz ++ "InvKeySchedule", invKeyDriverVals, invKeySchedule)+ , ("aes" ++ show sz ++ "OTFDecrypt", invDecDriverVals, otfDec) ]- where -- key-schedule+ where badSize = error $ "aesLibComponents: Size must be one of 128, 192, or 256; received: " ++ show sz++ -- key-schedule nk | sz == 128 = 4 | sz == 192 = 6 | sz == 256 = 8- | True = error $ "aesLibComponents: Size must be one of 128, 192, or 256; received: " ++ show sz+ | True = badSize+ -- We get 4*(nr+1) keys, where nr = nk + 6 nr = nk + 6 xk = 4 * (nr + 1)++ (keyDriverVals, invKeyDriverVals, encDriverVals, decDriverVals, invDecDriverVals)+ | sz == 128 = (keyDriver aes128Key, keyDriver aes128InvKey, encDriver commonPT aes128Key, decDriver aes128CT aes128Key, invDecDriver aes128CT aes128InvKey)+ | sz == 192 = (keyDriver aes192Key, keyDriver aes192InvKey, encDriver commonPT aes192Key, decDriver aes192CT aes192Key, invDecDriver aes192CT aes192InvKey)+ | sz == 256 = (keyDriver aes256Key, keyDriver aes256InvKey, encDriver commonPT aes256Key, decDriver aes256CT aes256Key, invDecDriver aes256CT aes256InvKey)+ | True = badSize+ where keyDriver key = map cvt $ concatMap reverse (chop4 key)+ encDriver pt key = map cvt $ pt ++ flatten (fst (aesKeySchedule key))+ decDriver ct key = map cvt $ ct ++ flatten (snd (aesKeySchedule key))+ invDecDriver ct key = map cvt $ ct ++ flatten (aesInvKeySchedule key)++ flatten (f, mid, l) = f ++ concat mid ++ l+ cvt = fromIntegral . fromJust . unliteral+ keySchedule = do key <- cgInputArr nk "key" -- key let (encKS, decKS) = aesKeySchedule key cgOutputArr "encKS" (ksToXKey encKS) cgOutputArr "decKS" (ksToXKey decKS)++ invKeySchedule = do key <- cgInputArr nk "key" -- key+ let decKS = aesInvKeySchedule (concatMap reverse (chop4 key))+ cgOutputArr "decKS" (ksToXKey decKS)+ -- encryption enc = do pt <- cgInputArr 4 "pt" -- plain-text xkey <- cgInputArr xk "xkey" -- expanded key cgOutputArr "ct" $ aesEncrypt pt (xkeyToKS xkey)+ -- decryption dec = do pt <- cgInputArr 4 "ct" -- cipher-text xkey <- cgInputArr xk "xkey" -- expanded key cgOutputArr "pt" $ aesDecrypt pt (xkeyToKS xkey)++ -- on-the-fly decryption+ otfDec = do ct <- cgInputArr 4 "ct" -- cipher-text+ xkey <- cgInputArr xk "xkey" -- expanded key+ cgOutputArr "pt" $ aesDecryptUnwoundKey ct (xkeyToKS xkey)+ -- Transforming back and forth from our KS type to a flat array used by the generated C code -- Turn a series of expanded keys to our internal KS type xkeyToKS :: [SWord 32] -> KS@@ -564,21 +870,20 @@ where f = take 4 xs -- first round key m = chop4 (take (xk - 8) (drop 4 xs)) -- middle rounds l = drop (xk - 4) xs -- last round key+ -- Turn a KS to a series of expanded key words ksToXKey :: KS -> [SWord 32] ksToXKey (f, m, l) = f ++ concat m ++ l- -- chunk in fours. (This function must be in some standard library, where?)- chop4 :: [a] -> [[a]]- chop4 [] = []- chop4 xs = let (f, r) = splitAt 4 xs in f : chop4 r -- | Generate code for AES functionality; given the key size. cgAESLibrary :: Int -> Maybe FilePath -> IO () cgAESLibrary sz mbd- | sz `elem` [128, 192, 256] = void $ compileToCLib mbd nm (aesLibComponents sz)+ | sz `elem` [128, 192, 256] = void $ compileToCLib mbd nm [(fnm, configure dvals f) | (fnm, dvals, f) <- aesLibComponents sz] | True = error $ "cgAESLibrary: Size must be one of 128, 192, or 256, received: " ++ show sz where nm = "aes" ++ show sz ++ "Lib" + configure dvals code = cgSetDriverValues dvals >> code+ -- | Generate a C library, containing functions for performing 128-bit enc/dec/key-expansion. -- A note on performance: In a very rough speed test, the generated code was able to do -- 6.3 million block encryptions per second on a decent MacBook Pro. On the same machine, OpenSSL@@ -594,5 +899,12 @@ hex8 v = replicate (8 - length s) '0' ++ s where s = flip showHex "" . fromJust . unliteral $ v -{-# ANN aesRound ("HLint: ignore Use head" :: String) #-}-{-# ANN aesInvRound ("HLint: ignore Use head" :: String) #-}+-- | Chunk in groups of 4. (This function must be in some standard library, where?)+chop4 :: [a] -> [[a]]+chop4 [] = []+chop4 xs = let (f, r) = splitAt 4 xs in f : chop4 r++{- HLint ignore aesRound "Use head" -}+{- HLint ignore aesInvRound "Use head" -}+{- HLint ignore aesDecryptUnwoundKey "Use head" -}+{- HLint ignore module "Reduce duplication" -}
+ Documentation/SBV/Examples/Crypto/Prince.hs view
@@ -0,0 +1,267 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Crypto.Prince+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Implementation of Prince encryption and decryption.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ParallelListComp #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}++module Documentation.SBV.Examples.Crypto.Prince where++import Prelude hiding(round)+import Numeric++import Data.SBV+import Data.SBV.Tools.CodeGen++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+#endif++-- * Types+-- | Section 2: Prince is essentially a 64-bit cipher, with 128-bit key, coming in two parts.+type Block = SWord 64++-- | Plantext is simply a block.+type PT = Block++-- | Key is again a 64-bit block.+type Key = Block++-- | Cypher text is another 64-bit block.+type CT = Block++-- | A nibble is 4-bits. Ideally, we would like to represent a nibble by @SWord 4@; and indeed SBV can do that for+-- verification purposes just fine. Unfortunately, the SBV's C compiler doesn't support 4-bit bit-vectors, as+-- there's nothing meaningful in the C-land that we can map it to. Thus, we represent a nibble with 8-bits. The+-- top 4 bits will always be 0.+type Nibble = SWord 8++-- * Key expansion++-- | Expanding a key, from Section 3.4 of the spec.+expandKey :: Key -> Key+expandKey k = (k `rotateR` 1) `xor` (k `shiftR` 63)++-- | expandKey(x) = x has a unique solution. We have:+--+-- >>> prop_ExpandKey+-- Q.E.D.+prop_ExpandKey :: IO ()+prop_ExpandKey = do let lim = 10+ ms <- extractModels <$> allSatWith z3{allSatMaxModelCount = Just lim}+ (\x -> x .== expandKey x)+ case length ms of+ 0 -> putStrLn "No solutions to equation `x == expandKey x`!"+ 1 -> putStrLn "Q.E.D."+ n -> do let qual = if n == lim then "at least " else ""+ putStrLn $ "Failed. There are " ++ qual ++ show n ++ " solutions to `x == expandKey x`!"+ mapM_ (\i -> putStrLn (" " ++ show i)) (ms :: [WordN 64])+++-- | Section 2: Encryption+encrypt :: PT -> Key -> Key -> CT+encrypt pt k0 k1 = prince k0 k0' k1 pt+ where k0' = expandKey k0++-- | Decryption+decrypt :: CT -> Key -> Key -> PT+decrypt ct k0 k1 = prince k0' k0 (k1 `xor` alpha) ct+ where k0' = expandKey k0+ alpha = 0xc0ac29b7c97c50dd++-- * Main algorithm++-- | Basic prince algorithm+prince :: Block -> Key -> Key -> Key -> Block+prince k0 k0' k1 inp = out+ where start = inp `xor` k0+ end = princeCore k1 start+ out = end `xor` k0'++-- | Core prince. It's essentially folding of 12 rounds stitched together:+princeCore :: Key -> Block -> Block+princeCore k1 inp = end+ where start = inp `xor` k1 `xor` rConstants 0+ front5 = foldl (round k1) start [1 .. 5]+ midPoint = sBoxInv . m' . sBox $ front5+ back5 = foldl (invRound k1) midPoint [6..10]+ end = back5 `xor` rConstants 11 `xor` k1++-- | Forward round.+round :: Key -> Block -> Int -> Block+round k1 b i = k1 `xor` rConstants i `xor` m (sBox b)++-- | Backend round.+invRound :: Key -> Block -> Int -> Block+invRound k1 b i = sBoxInv (mInv (rConstants i `xor` (b `xor` k1)))++-- | M transformation.+m :: Block -> Block+m = sr . m'++-- | Inverse of M.+mInv :: Block -> Block+mInv = m' . srInv++-- | SR.+sr :: Block -> Block+sr b = fromNibbles [n0, n5, n10, n15, n4, n9, n14, n3, n8, n13, n2, n7, n12, n1, n6, n11]+ where [n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11, n12, n13, n14, n15] = toNibbles b++-- | Inverse of SR:+srInv :: Block -> Block+srInv b = fromNibbles [n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11, n12, n13, n14, n15]+ where [n0, n5, n10, n15, n4, n9, n14, n3, n8, n13, n2, n7, n12, n1, n6, n11] = toNibbles b++-- | Prove sr and srInv are inverses: We have:+--+-- >>> prove prop_sr+-- Q.E.D.+prop_sr :: Predicate+prop_sr = do b <- free "block"+ pure $ b .== sr (srInv b)+ .&& b .== srInv (sr b)++-- | M' transformation+m' :: Block -> Block+m' = mMult++-- | The matrix as described in Section 3.3+mat :: [[Int]]+mat = res+ where m0 = [[0, 0, 0, 0], [0, 1, 0, 0], [0, 0, 1, 0], [0, 0, 0, 1]]+ m1 = [[1, 0, 0, 0], [0, 0, 0, 0], [0, 0, 1, 0], [0, 0, 0, 1]]+ m2 = [[1, 0, 0, 0], [0, 1, 0, 0], [0, 0, 0, 0], [0, 0, 0, 1]]+ m3 = [[1, 0, 0, 0], [0, 1, 0, 0], [0, 0, 1, 0], [0, 0, 0, 0]]++ rows as bs cs ds = [a ++ b ++ c ++ d | a <- as | b <- bs | c <- cs | d <- ds ]++ m0' = concat [rows m0 m1 m2 m3, rows m1 m2 m3 m0, rows m2 m3 m0 m1, rows m3 m0 m1 m2]+ m1' = concat [rows m1 m2 m3 m0, rows m2 m3 m0 m1, rows m3 m0 m1 m2, rows m0 m1 m2 m3]++ zs = replicate 16 (replicate 16 0)+ res = concat [rows m0' zs zs zs, rows zs m1' zs zs, rows zs zs m1' zs, rows zs zs zs m0']++-- | Multiplication.+mMult :: Block -> Block+mMult b | length mat /= 64 = error $ "mMult: Expected 64 rows, got : " ++ show (length mat)+ | any ((/= 64) . length) mat = error $ "mMult: Expected 64 on each row, got: " ++ show [p | p@(_, l) <- zip [(1::Int)..] (map length mat), l /= 64]+ | True = fromBitsBE $ map mult mat+ where bits = blastBE b++ mult :: [Int] -> SBool+ mult row = foldr (.<+>) sFalse $ zipWith mul row bits++ mul :: Int -> SBool -> SBool+ mul 0 _ = sFalse+ mul 1 v = v+ mul i _ = error $ "mMult: Unexpected constant: " ++ show i++-- | Non-linear transformation of a block+nonLinear :: [Nibble] -> Nibble -> Block -> Block+nonLinear box def = fromNibbles . map s . toNibbles+ where s :: Nibble -> Nibble+ s = select box def++-- | SBox transformation.+sBox :: Block -> Block+sBox = nonLinear [0xB, 0xF, 0x3, 0x2, 0xA, 0xC, 0x9, 0x1, 0x6, 0x7, 0x8, 0x0, 0xE, 0x5, 0xD, 0x4] 0x0++-- | Inverse SBox transformation.+sBoxInv :: Block -> Block+sBoxInv = nonLinear [0xB, 0x7, 0x3, 0x2, 0xF, 0xD, 0x8, 0x9, 0xA, 0x6, 0x4, 0x0, 0x5, 0xE, 0xC, 0x1] 0x0++-- | Prove that sbox and sBoxInv are inverses: We have:+--+-- >>> prove prop_SBox+-- Q.E.D.+prop_SBox :: Predicate+prop_SBox = do b <- free "block"+ pure $ b .== sBoxInv (sBox b)+ .&& b .== sBox (sBoxInv b)++-- * Round constants++-- | Round constants+rConstants :: Int -> SWord 64+rConstants 0 = 0x0000000000000000+rConstants 1 = 0x13198a2e03707344+rConstants 2 = 0xa4093822299f31d0+rConstants 3 = 0x082efa98ec4e6c89+rConstants 4 = 0x452821e638d01377+rConstants 5 = 0xbe5466cf34e90c6c+rConstants 6 = 0x7ef84f78fd955cb1+rConstants 7 = 0x85840851f1ac43aa+rConstants 8 = 0xc882d32f25323c54+rConstants 9 = 0x64a51195e0e3610d+rConstants 10 = 0xd3b5a399ca0c2399+rConstants 11 = 0xc0ac29b7c97c50dd+rConstants n = error $ "rConstants called with invalid round number: " ++ show n++-- | Round-constants property: rc_i `xor` rc_{11-i} is constant. We have:+--+-- >>> prop_RoundKeys+-- True+prop_RoundKeys :: SBool+prop_RoundKeys = sAnd [magic .== rConstants i `xor` rConstants (11-i) | i <- [0 .. 11]]+ where magic = rConstants 11++-- | Convert a 64 bit word to nibbles+toNibbles :: SWord 64 -> [Nibble]+toNibbles = concatMap nibbles . toBytes+ where nibbles :: SWord 8 -> [Nibble]+ nibbles b = [b `shiftR` 4, b .&. 0xF]++-- | Convert from nibbles to a 64 bit word+fromNibbles :: [Nibble] -> SWord 64+fromNibbles xs+ | length xs /= 16 = error $ "fromNibbles: Incorrect number of nibbles, expected 16, got: " ++ show (length xs)+ | True = fromBytes $ cvt xs+ where cvt (n1 : n2 : ns) = (n1 `shiftL` 4 .|. n2) : cvt ns+ cvt _ = []++-- * Test vectors++-- | From Appendix A of the spec. We have:+--+-- >>> testVectors+-- True+testVectors :: SBool+testVectors = sAnd $ [encrypt pt k0 k1 .== ct | (pt, k0, k1, ct) <- tvs]+ ++ [decrypt ct k0 k1 .== pt | (pt, k0, k1, ct) <- tvs]+ where tvs :: [(SWord 64, SWord 64, SWord 64, SWord 64)]+ tvs = [ (0x0000000000000000, 0x0000000000000000, 0x0000000000000000, 0x818665aa0d02dfda)+ , (0xffffffffffffffff, 0x0000000000000000, 0x0000000000000000, 0x604ae6ca03c20ada)+ , (0x0000000000000000, 0xffffffffffffffff, 0x0000000000000000, 0x9fb51935fc3df524)+ , (0x0000000000000000, 0x0000000000000000, 0xffffffffffffffff, 0x78a54cbe737bb7ef)+ , (0x0123456789abcdef, 0x0000000000000000, 0xfedcba9876543210, 0xae25ad3ca8fa9ccf)+ ]++-- | Nicely show a concrete block.+showBlock :: Block -> String+showBlock b = case unliteral b of+ Just v -> "0x" ++ pad (showHex v "")+ Nothing -> error "showBlock: Symbolic input!"+ where pad s = reverse $ take 16 $ reverse s ++ repeat '0'++-- * Code generation++-- | Generating C code for the encryption block.+codeGen :: IO ()+codeGen = compileToC Nothing "enc" $ do+ input <- cgInput "inp"+ k0 <- cgInput "k0"+ k1 <- cgInput "k1"+ cgOverwriteFiles True+ cgOutput "ct" $ encrypt input k0 k1
Documentation/SBV/Examples/Crypto/RC4.hs view
@@ -15,8 +15,6 @@ -- functional implementation. ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}- {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Crypto.RC4 where@@ -78,7 +76,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)@@ -141,12 +139,12 @@ -- large symbolic trace. rc4IsCorrect :: IO ThmResult rc4IsCorrect = prove $ do- key <- mkForallVars 5- pt <- mkForallVars 5+ key <- mkFreeVars 5+ pt <- mkFreeVars 5 let ks = keySchedule key ct = zipWith xor ks pt pt' = zipWith xor ks ct- return $ pt .== pt'+ pure $ pt .== pt' -------------------------------------------------------------------------------------------- -- | For doctest purposes only
Documentation/SBV/Examples/Crypto/SHA.hs view
@@ -17,7 +17,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -28,8 +27,9 @@ import Data.SBV import Data.SBV.Tools.CodeGen +import Prelude hiding (Foldable(..)) import Data.Char (ord, toLower)-import Data.List (genericLength)+import Data.List (genericLength, length, foldl') import Numeric (showHex) import Data.Proxy (Proxy(..))@@ -174,7 +174,7 @@ -- * Section 5, Preprocessing ----------------------------------------------------------------------------- --- | 'Block' is a synonym for lists, but makes the intent clear.+-- | t'Block' is a synonym for lists, but makes the intent clear. newtype Block a = Block [a] -- | Prepare the message by turning it into blocks. We also check for the message@@ -241,14 +241,14 @@ step3Body xs t = error $ "Impossible! step3Body received a list of length " ++ show (length xs) ++ ", iteration: " ++ show t -- Step 3 simply folds the body for the required loop-count- step3 = foldl step3Body hPrev [0 .. lim]+ step3 = foldl' step3Body hPrev [0 .. lim] -- Step 4 step4 = zipWith (+) step3 hPrev -- | Compute the hash of a given string using the specified parameterized hash algorithm. shaP :: (Num w, Bits w, ByteConverter w) => SHA w -> String -> [w]-shaP p@SHA{h0} = foldl (hashBlock p) h0 . prepareMessage p+shaP p@SHA{h0} = foldl' (hashBlock p) h0 . prepareMessage p ----------------------------------------------------------------------------- -- * Computing the digest@@ -373,6 +373,22 @@ let hIn = chunkBy 4 fromBytes hInBytes block = chunkBy 4 fromBytes blockBytes++ result = hashBlock algorithm hIn (Block block)++ cgOutputArr "hash" $ concatMap toBytes result++-- | Generate code for one block of SHA512 in action, starting from an arbitrary hash value.+cgSHA512 :: IO ()+cgSHA512 = compileToC Nothing "sha512" $ do++ let algorithm = sha512P++ hInBytes <- cgInputArr 64 "hIn"+ blockBytes <- cgInputArr 128 "block"++ let hIn = chunkBy 8 fromBytes hInBytes+ block = chunkBy 8 fromBytes blockBytes result = hashBlock algorithm hIn (Block block)
− Documentation/SBV/Examples/Existentials/CRCPolynomial.hs
@@ -1,89 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Documentation.SBV.Examples.Existentials.CRCPolynomial--- Copyright : (c) Levent Erkok--- License : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ This program demonstrates the use of the existentials and the QBVF (quantified--- bit-vector solver). We generate CRC polynomials of degree 16 that can be used--- for messages of size 48-bits. The query finds all such polynomials that have hamming--- distance is at least 4. That is, if the CRC can't tell two different 48-bit messages--- apart, then they must differ in at least 4 bits.--------------------------------------------------------------------------------{-# LANGUAGE DataKinds #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.Existentials.CRCPolynomial where--import Data.SBV-import Data.SBV.Tools.Polynomial---- | Compute the 16 bit CRC of a 48 bit message, using the given polynomial-crc_48_16 :: SWord 48 -> SWord16 -> [SBool]-crc_48_16 msg poly = crcBV 16 (blastBE msg) (blastBE poly)---- | Count the differing bits in the message and the corresponding CRC-diffCount :: (SWord 48, [SBool]) -> (SWord 48, [SBool]) -> SWord8-diffCount (d1, crc1) (d2, crc2) = count xorBits- where bits1 = blastBE d1 ++ crc1- bits2 = blastBE d2 ++ crc2- -- xor will give us a false if bits match, true if they differ- xorBits = zipWith (.<+>) bits1 bits2- count [] = 0- count (b:bs) = let r = count bs in ite b (1+r) r---- | Given a hamming distance value @hd@, 'crcGood' returns @true@ if--- the 16 bit polynomial can distinguish all messages that has at most--- @hd@ different bits. Note that we express this conversely: If the--- @sent@ and @received@ messages are different, then it must be the--- case that that must differ from each other (including CRCs), in--- more than @hd@ bits.-crcGood :: SWord8 -> SWord16 -> SWord 48 -> SWord 48 -> SBool-crcGood hd poly sent received =- sent ./= received .=> diffCount (sent, crcSent) (received, crcReceived) .>= hd- where crcSent = crc_48_16 sent poly- crcReceived = crc_48_16 received poly---- | Generate good CRC polynomials for 48-bit words, given the hamming distance @hd@.-genPoly :: SWord8 -> Int -> IO ()-genPoly hd maxCnt = do res <- allSatWith defaultSMTCfg{allSatMaxModelCount = Just maxCnt} $ do- p <- sbvExists "polynomial" -- the polynomial is existentially specified- s <- sbvForall "sent" -- sent word, universal- r <- sbvForall "received" -- received word, universal- -- assert that the polynomial @p@ is good. Note- -- that we also supply the extra information that- -- the least significant bit must be set in the- -- polynomial, as all CRC polynomials have the "+1"- -- term in them set. This simplifies the query.- return $ sTestBit p 0 .&& crcGood hd p s r- cnt <- displayModels id disp res- putStrLn $ "Found: " ++ show cnt ++ " polynomail(s)."- where disp :: Int -> (Bool, Word16) -> IO ()- disp n (_, s) = putStrLn $ "Polynomial #" ++ show n ++ ". x^16 + " ++ showPolynomial False s---- | Find and display all degree 16 polynomials with hamming distance at least 4, for 48 bit messages.------ When run, this function prints:------ @--- Polynomial #1. x^16 + x^3 + x^2 + 1--- Polynomial #2. x^16 + x^3 + x^2 + x + 1--- Polynomial #3. x^16 + x^3 + x + 1--- Polynomial #4. x^16 + x^15 + x^2 + 1--- Polynomial #5. x^16 + x^15 + x^2 + x + 1--- Found: 5 polynomial(s).--- @------ Note that different runs can produce different results, depending on the random--- numbers used by the solver, solver version, etc. (Also, the solver will take some--- time to generate these results. On my machine, the first five polynomials were--- generated in about 5 minutes.)-findHD4Polynomials :: IO ()-findHD4Polynomials = genPoly 4 cnt- where cnt = 5 -- Generate at most this many polynomials--{-# ANN crc_48_16 ("HLint: ignore Use camelCase" :: String) #-}
Documentation/SBV/Examples/Existentials/Diophantine.hs view
@@ -10,12 +10,22 @@ -- using explicit quantification. ----------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Existentials.Diophantine where +import Data.List (intercalate, transpose)+ import Data.SBV+import Data.Proxy +import GHC.TypeLits+ -------------------------------------------------------------------------------------------------- -- * Representing solutions --------------------------------------------------------------------------------------------------@@ -24,22 +34,46 @@ -- second component plus one of the vectors in the first component. data Solution = Homogeneous [[Integer]] | NonHomogeneous [[Integer]] [[Integer]]- deriving Show +instance Show Solution where+ show s = case s of+ Homogeneous xss -> comb supplyH (map (False,) xss)+ NonHomogeneous css xss -> intercalate "\n" [comb supplyNH ((True, cs) : map (False,) xss) | cs <- css]+ where supplyH = ['k' : replicate i '\'' | i <- [0 ..]]+ supplyNH = "" : supplyH++ comb supply xss = vec $ map add (transpose (zipWith muls supply xss))+ where muls x (isConst, cs) = map mul cs+ where mul 0 = "0"+ mul 1 | isConst = "1"+ | True = x+ mul k | isConst = show k+ | True = show k ++ x++ add [] = "0"+ add xs = foldr1 plus xs++ plus "0" y = y+ plus x "0" = x+ plus x y = x ++ "+" ++ y++ vec xs = "(" ++ intercalate ", " xs ++ ")"+ -------------------------------------------------------------------------------------------------- -- * Solving diophantine equations -------------------------------------------------------------------------------------------------- -- | ldn: Solve a (L)inear (D)iophantine equation, returning minimal solutions over (N)aturals. -- The input is given as a rows of equations, with rhs values separated into a tuple. The first--- parameter limits the search to bound: In case there are too many solutions, you might want--- to limit your search space.-ldn :: Maybe Int -> [([Integer], Integer)] -> IO Solution-ldn mbLim problem = do solution <- basis mbLim (map (map literal) m)- if homogeneous- then return $ Homogeneous solution- else do let ones = [xs | (1:xs) <- solution]- zeros = [xs | (0:xs) <- solution]- return $ NonHomogeneous ones zeros+-- argument must be a proxy of a natural, must be total number of columns in the system. (i.e.,+-- #of variables + 1). The second parameter limits the search to bound: In case there are+-- too many solutions, you might want to limit your search space.+ldn :: forall proxy n. KnownNat n => proxy n -> Maybe Int -> [([Integer], Integer)] -> IO Solution+ldn pn mbLim problem = do solution <- basis pn mbLim (map (map literal) m)+ if homogeneous+ then pure $ Homogeneous solution+ else do let ones = [xs | (1:xs) <- solution]+ zeros = [xs | (0:xs) <- solution]+ pure $ NonHomogeneous ones zeros where rhs = map snd problem lhs = map fst problem homogeneous = all (== 0) rhs@@ -50,14 +84,16 @@ -- that cannot be written as the sum of two other solutions. We use the mathematically equivalent -- statement that a solution is in the basis if it's least according to the natural partial -- order using the ordinary less-than relation.-basis :: Maybe Int -> [[SInteger]] -> IO [[Integer]]-basis mbLim m = extractModels `fmap` allSatWith z3{allSatMaxModelCount = mbLim} cond- where cond = do as <- mkExistVars n- bs <- mkForallVars n+basis :: forall proxy n. KnownNat n => proxy n -> Maybe Int -> [[SInteger]] -> IO [[Integer]]+basis _ mbLim m = extractModels `fmap` allSatWith z3{allSatMaxModelCount = mbLim} cond+ where cond = do as <- mkFreeVars n - return $ ok as .&& (ok bs .=> as .== bs .|| sNot (bs `less` as))+ constrain $ \(ForallN bs :: ForallN n nm Integer) ->+ ok as .&& (ok bs .=> as .== bs .|| sNot (bs `less` as)) - n = if null m then 0 else length (head m)+ n = case m of+ [] -> 0+ f:_ -> length f ok xs = sAny (.> 0) xs .&& sAll (.>= 0) xs .&& sAnd [sum (zipWith (*) r xs) .== 0 | r <- m] @@ -74,21 +110,14 @@ -- We have: -- -- >>> test--- NonHomogeneous [[0,2,0],[1,0,0]] [[1,0,2],[0,1,1]]------ which means that the solutions are of the form:------ @(0, 2, 0) + k (1, 0, 2) + k' (0, 1, 1) = (k, 2+k', 2k+k')@------ OR------ @(1, 0, 0) + k (1, 0, 2) + k' (0, 1, 1) = (1+k, k', 2k+k')@+-- (1+k, k', 2k+k')+-- (k, 2+k', 2k+k') ----- for arbitrary @k@, @k'@. It's easy to see that these are really solutions--- to the equation given. It's harder to see that they cover all possibilities,--- but a moments thought reveals that is indeed the case.+-- That is, for arbitrary @k@ and @k'@, we have two different solutions. (An infinite family.)+-- You can verify these solutions by substituting the values for @x@, @y@ and @z@ in the above, for each choice.+-- It's harder to see that they cover all possibilities, but a moments thought reveals that is indeed the case. test :: IO Solution-test = ldn Nothing [([2,1,-1], 2)]+test = ldn (Proxy @4) Nothing [([2,1,-1], 2)] -- | A puzzle: Five sailors and a monkey escape from a naufrage and reach an island with -- coconuts. Before dawn, they gather a few of them and decide to sleep first and share@@ -131,13 +160,15 @@ -- solutions to avoid the all-sat pitfall. sailors :: IO [Integer] sailors = search 1- where search i = do soln <- ldn (Just i) [ ([1, -5, 0, 0, 0, 0, 0], 1)- , ([0, 4, -5 , 0, 0, 0, 0], 1)- , ([0, 0, 4, -5 , 0, 0, 0], 1)- , ([0, 0, 0, 4, -5, 0, 0], 1)- , ([0, 0, 0, 0, 4, -5, 0], 1)- , ([0, 0, 0, 0, 0, 4, -5], 1)- ]+ where search i = do soln <- ldn (Proxy @8)+ (Just i)+ [ ([1, -5, 0, 0, 0, 0, 0], 1)+ , ([0, 4, -5 , 0, 0, 0, 0], 1)+ , ([0, 0, 4, -5 , 0, 0, 0], 1)+ , ([0, 0, 0, 4, -5, 0, 0], 1)+ , ([0, 0, 0, 0, 4, -5, 0], 1)+ , ([0, 0, 0, 0, 0, 4, -5], 1)+ ] case soln of- NonHomogeneous (xs:_) _ -> return xs+ NonHomogeneous (xs:_) _ -> pure xs _ -> search (i+1)
Documentation/SBV/Examples/Lists/BoundedMutex.hs view
@@ -6,16 +6,13 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- Demonstrates use of bounded list utilities, proving a simple--- mutex algorithm correct up to given bounds.+-- Proves a simple mutex algorithm correct up to a given bound. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -24,23 +21,19 @@ import Data.SBV import Data.SBV.Control -import Prelude hiding ((!!))-import Data.SBV.List ((!!))-import qualified Data.SBV.List as L-import qualified Data.SBV.Tools.BoundedList 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 Show -- | Make 'State' a symbolic enumeration-mkSymbolicEnumeration ''State+mkSymbolic [''State] --- | A bounded mutex property holds for two sequences of state transitions, if they are not in--- their critical section at the same time up to that given bound.-mutex :: Int -> SList State -> SList State -> SBool-mutex i p1s p2s = L.band i $ L.bzipWith i (\p1 p2 -> p1 ./= sCritical .|| p2 ./= sCritical) p1s p2s+-- | The mutex property holds for two sequences of state transitions, if they are not in+-- their critical section at the same time.+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: --@@ -49,36 +42,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@@ -88,18 +76,18 @@ -- 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!- constrain $ sNot $ mutex b p1 p2+ constrain $ sNot $ mutex p1 p2 query $ do cs <- checkSat case cs of@@ -107,9 +95,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@@ -120,11 +108,11 @@ -- trying to show a bounded trace of length 10, such that the second process is ready but -- never transitions to critical. We have: ----- > ghci> notFair 10--- > Fairness is violated at bound: 10--- > P1: [Idle,Idle,Ready,Critical,Idle,Idle,Ready,Critical,Idle,Idle]--- > P2: [Idle,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready]--- > Ts: [1,2,1,1,1,1,1,1,1,1]+-- >>> notFair 10+-- Fairness is violated at bound: 10+-- P1: [Idle,Idle,Idle,Idle,Ready,Critical,Idle,Ready,Critical,Critical]+-- P2: [Idle,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready]+-- Ts: [1,1,1,1,1,1,1,1,1,1] -- -- As expected, P2 gets ready but never goes critical since the arbiter keeps picking -- P1 unfairly. (You might get a different trace depending on what z3 happens to produce!)@@ -133,21 +121,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 $ L.belem b sCritical p2+ constrain $ sNot $ sCritical `sElem` p2 query $ do cs <- checkSat case cs of@@ -155,12 +143,12 @@ 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 io . putStrLn $ "Ts: " ++ show ts -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore module "Reduce duplication" -}
− Documentation/SBV/Examples/Lists/Nested.hs
@@ -1,45 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Documentation.SBV.Examples.Lists.Nested--- Copyright : (c) Levent Erkok--- License : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Demonstrates nested lists--------------------------------------------------------------------------------{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall -Werror #-}--module Documentation.SBV.Examples.Lists.Nested where--import Data.SBV-import Data.SBV.Control--import Prelude hiding ((!!))-import Data.SBV.List ((!!))-import qualified Data.SBV.List as L---- | Simple example demonstrating the use of nested lists. We have:------ Turned off. See: https://github.com/Z3Prover/z3/issues/2820--- nestedExample--- [[1,2,3],[4,5,6,7],[8,9,10],[11,12,13]]-nestedExample :: IO ()-nestedExample = runSMT $ do a :: SList [Integer] <- free "a"-- constrain $ a !! 0 .== [1, 2, 3]- constrain $ a !! 1 .== [4, 5, 6, 7]- constrain $ L.tail (L.tail a) .== [[8, 9, 10], [11, 12, 13]]- constrain $ L.length a .== 4-- query $ do cs <- checkSat- case cs of- Unk -> error "Solver said unknown!"- DSat{} -> error "Unexpected dsat result.."- Unsat -> io $ putStrLn "Unsat"- Sat -> do v <- getValue a- io $ print v
Documentation/SBV/Examples/Misc/Auxiliary.hs view
@@ -15,8 +15,6 @@ -- considering them explicitly in model construction. ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}- {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Misc.Auxiliary where@@ -30,7 +28,7 @@ y <- free "y" constrain $ x .>= 0 constrain $ x .<= 1- return $ x - abs y .== (0 :: SInteger)+ pure $ x - abs y .== (0 :: SInteger) -- | Generate all satisfying assignments for our problem. We have: --
Documentation/SBV/Examples/Misc/Definitions.hs view
@@ -11,57 +11,180 @@ -- for recursive definitions. ----------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Misc.Definitions where import Data.SBV+import Data.SBV.Tuple --- | Sum of numbers from 0 to the given number.--- Note that this cannot be defined as a regular Haskell function, as--- it wouldn't terminate as it recurses on a symbolic argument.+-------------------------------------------------------------------------+-- * Simple functions+-------------------------------------------------------------------------++-- | Add one to an argument+add1 :: SInteger -> SInteger+add1 = smtFunction "add1" (+1)++-- | Reverse run the add1 function. Note that the generated SMTLib will have the function+-- add1 itself defined. You can verify this by running the below in verbose mode.+--+-- >>> add1Example+-- Satisfiable. Model:+-- x = 4 :: Integer+add1Example :: IO SatResult+add1Example = sat $ do+ x <- sInteger "x"+ pure $ 5 .== add1 x++-------------------------------------------------------------------------+-- * Basic recursive functions+-------------------------------------------------------------------------++-- | Sum of numbers from 0 to the given number. Since this is a recursive+-- definition, we cannot simply symbolically simulate it as it wouldn't+-- terminate. So, we use the function generation facilities to define it+-- directly in SMTLib. sumToN :: SInteger -> SInteger-sumToN = uninterpret "sumToN"+sumToN = smtFunction "sumToN" $ \x -> [sCase| x of+ _ | x .<= 0 -> 0+ _ -> x + sumToN (x - 1)+ |] --- | Add the definition of sum to the SMT solver. Note that SBV--- performs no checks on your definition, neither that it is--- well formed, or even has the correct type!-defineSum :: Symbolic ()-defineSum = addSMTDefinition "sumToN"- [ "(define-fun-rec sumToN ((x Int)) Int"- , " (ite (<= x 0)"- , " 0"- , " (+ x (sumToN (- x 1)))))"- ]+-- | Prove that sumToN works as expected.+--+-- We have:+--+-- >>> sumToNExample+-- Satisfiable. Model:+-- s0 = 5 :: Integer+-- s1 = 15 :: Integer+sumToNExample :: IO SatResult+sumToNExample = sat $ \a r -> a .== 5 .&& r .== sumToN a --- | A simple proof using 'sumToN'. We get a failure, because we haven't--- given the solver the definition, and thus it goes completely uninterpreted.+-- | Coding list-length recursively. Again, we map directly to an SMTLib function.+len :: SList Integer -> SInteger+len = smtFunction "list_length" $ \xs -> [sCase| xs of+ [] -> 0+ _:ts -> 1 + len ts+ |]++-- | Calculate the length of a list, using recursive functions. -- -- We have: ----- >>> badExample--- Falsifiable. Counter-example:--- sumToN :: Integer -> Integer--- sumToN _ = 0+-- >>> lenExample+-- Satisfiable. Model:+-- s0 = [1,2,3] :: [Integer]+-- s1 = 3 :: Integer+lenExample :: IO SatResult+lenExample = sat $ \a r -> a .== [1,2,3] .&& r .== len a++-------------------------------------------------------------------------+-- * Mutual recursion+-------------------------------------------------------------------------++-- | A simple mutual-recursion example, from the z3 documentation. We have: ----- Since 'sumToN' remains uninterpreted, the solver gave us a model that obviously--- fails the property.-badExample :: IO ThmResult-badExample = prove $ do- let check = sumToN 5 .== 15 -- Should fail, even though 5*6/2 = 15- pure check :: Predicate+-- >>> pingPong+-- Satisfiable. Model:+-- s0 = 1 :: Integer+pingPong :: IO SatResult+pingPong = sat $ \x -> x .> 0 .&& ping x sTrue .> x+ where ping :: SInteger -> SBool -> SInteger+ ping = smtFunctionWithMeasure "ping" (\_ y -> ite y 1 (0 :: SInteger), [])+ $ \x y -> [sCase| y of+ True -> pong (x+1) (sNot y)+ False -> x - 1+ |] --- | Same example, except this time we give the solver the definition of the function,--- and thus the proof goes through.+ pong :: SInteger -> SBool -> SInteger+ pong = smtFunctionWithMeasure "pong" (\_ b -> ite b 1 (0 :: SInteger), [])+ $ \a b -> [sCase| b of+ True -> ping (a-1) (sNot b)+ False -> a+ |]++-- | Usual way to define even-odd mutually recursively. While the termination measure+-- is verified, current SMT solvers do not terminate when evaluating mutually recursive+-- @define-funs-rec@ definitions. See 'isEvenOdd' for a single-function alternative+-- that is more solver-friendly. ----- We have:+-- >>> evenOdd+-- Unknown.+-- Reason: timeout+evenOdd :: IO SatResult+evenOdd = sat $ do setTimeOut 5000+ a <- sInteger "a"+ r <- sBool "r"+ constrain $ a .== 20 .&& r .== isE a+ where isE, isO :: SInteger -> SBool+ isE = smtFunctionWithMeasure "isE" (\x -> tuple (abs x, ite (x .< 0) (1 :: SInteger) 0), [])+ $ \x -> [sCase| x of+ _ | x .< 0 -> isE (-x)+ _ -> x .== 0 .|| isO (x - 1)+ |]+ isO = smtFunctionWithMeasure "isO" (\x -> tuple (abs x, ite (x .< 0) (1 :: SInteger) 0), [])+ $ \x -> [sCase| x of+ _ | 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. ----- >>> goodExample--- Q.E.D.+-- The measure @(abs x, ite (x < 0) 1 0)@ ensures termination: when @x < 0@, the call @isEvenOdd(-x)@+-- keeps @abs x@ the same but drops the second component from 1 to 0. When @x > 0@, the call+-- @isEvenOdd(x-1)@ decreases @abs x@.+isEvenOdd :: SInteger -> STuple Bool Bool+isEvenOdd = smtFunctionWithMeasure "isEvenOdd" (\x -> tuple (abs x, ite (x .< 0) (1 :: SInteger) 0), [])+ $ \x -> [sCase| x of+ _ | x .< 0 -> isEvenOdd (-x)+ _ | x .== 0 -> tuple (sTrue, sFalse)+ _ -> swap (isEvenOdd (x - 1))+ |]++-- | Extract the isEven function for easier use.+isEven :: SInteger -> SBool+isEven x = isEvenOdd x ^._1++-- | Extract the isOdd function for easier use.+isOdd :: SInteger -> SBool+isOdd x = isEvenOdd x ^._2++-- | We can prove 20 is even and definitely not odd, thusly: ----- In this case, the solver has the definition, and proves the predicate as expected.-goodExample :: IO ThmResult-goodExample = prove $ do- defineSum- let check = sumToN 5 .== 15 -- Should fail, even though 5*6/2 = 15- pure check :: Predicate+-- >>> evenOdd2+-- Satisfiable. Model:+-- s0 = 20 :: Integer+-- s1 = True :: Bool+-- s2 = False :: Bool+evenOdd2 :: IO SatResult+evenOdd2 = sat $ \a r1 r2 -> a .== 20 .&& r1 .== isEven a .&& r2 .== isOdd a++-------------------------------------------------------------------------+-- * Nested recursion+-------------------------------------------------------------------------++-- | Ackermann function, demonstrating nested recursion.+ack :: SInteger -> SInteger -> SInteger+ack = smtFunction "ack"+ $ \x y -> [sCase| x of+ _ | x .<= 0 -> y + 1+ _ | y .<= 0 -> ack (x - 1) 1+ _ -> ack (x - 1) (ack x (y - 1))+ |]++-- | We can prove constant-folding instances of the equality @ack 1 y == y + 2@:+--+-- >>> ack1y+-- Satisfiable. Model:+-- s0 = 5 :: Integer+-- s1 = 7 :: Integer+--+-- Expecting the prover to handle the general case for arbitrary @y@ is beyond the current+-- scope of what SMT solvers do out-of-the-box for the time being.+ack1y :: IO SatResult+ack1y = sat $ \y r -> y .== 5 .&& r .== ack 1 y
Documentation/SBV/Examples/Misc/Enumerate.hs view
@@ -12,11 +12,10 @@ -- example involving enumerations. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -27,24 +26,20 @@ -- | A simple enumerated type, that we'd like to translate to SMT-Lib intact; -- i.e., this type will not be uninterpreted but rather preserved and will -- be just like any other symbolic type SBV provides.------ Also note that we need to have the following @LANGUAGE@ options defined:--- @TemplateHaskell@, @StandaloneDeriving@, @DeriveDataTypeable@, @DeriveAnyClass@ for--- this to work. data E = A | B | C -- | Make 'E' a symbolic value.-mkSymbolicEnumeration ''E+mkSymbolic [''E] -- | Have the SMT solver enumerate the elements of the domain. We have: -- -- >>> elts -- Solution #1:--- s0 = C :: E--- Solution #2: -- s0 = B :: E--- Solution #3:+-- Solution #2: -- s0 = A :: E+-- Solution #3:+-- s0 = C :: E -- Found 3 different solutions. elts :: IO AllSatResult elts = allSat $ \(x::SE) -> x .== x@@ -64,9 +59,8 @@ -- Satisfiable. Model: -- maxE = C :: E maxE :: IO SatResult-maxE = sat $ do mx <- sbvExists "maxE"- e <- sbvForall "e"- return $ mx .>= (e::SE)+maxE = sat $ do mx :: SE <- free "maxE"+ constrain $ \(Forall e) -> mx .>= e -- | Similarly, we get the minimum element. We have: --@@ -74,6 +68,5 @@ -- Satisfiable. Model: -- minE = A :: E minE :: IO SatResult-minE = sat $ do mx <- sbvExists "minE"- e <- sbvForall "e"- return $ mx .<= (e::SE)+minE = sat $ do mn :: SE <- free "minE"+ constrain $ \(Forall e) -> mn .<= e
+ Documentation/SBV/Examples/Misc/FirstOrderLogic.hs view
@@ -0,0 +1,470 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Misc.FirstOrderLogic+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proves various first-order logic properties using SBV. The properties we+-- prove all come from <https://en.wikipedia.org/wiki/First-order_logic>+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Misc.FirstOrderLogic where++import Data.SBV++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> :set -XDataKinds -XScopedTypeVariables+#endif++-- | An uninterpreted sort for demo purposes, named 'U'+data U+mkSymbolic [''U]++-- | An uninterpreted sort for demo purposes, named 'V'+data V+mkSymbolic [''V]++-- | An enumerated type for demo purposes, named 'E'+data E = A | B | C++mkSymbolic [''E]++-- | Helper to turn quantified formula to a regular boolean. We+-- can think of this as quantifier elimination, hence the name 'qe'.+qe :: QuantifiedBool a => a -> SBool+qe = quantifiedBool++-- * Pushing negation over quantifiers+{- $negUniv+\(\lnot \forall x\,P(x)\Leftrightarrow \exists x\,\lnot P(x)\)++>>> let p = uninterpret "P" :: SU -> SBool+>>> prove $ sNot (qe (\(Forall x) -> p x)) .<=> qe (\(Exists x) -> sNot (p x))+Q.E.D.++\(\lnot \exists x\,P(x)\Leftrightarrow \forall x\,\lnot P(x)\)++>>> let p = uninterpret "P" :: SU -> SBool+>>> prove $ sNot (qe (\(Exists x) -> p x)) .<=> qe (\(Forall x) -> sNot (p x))+Q.E.D.+-}++-- * Interchanging quantifiers+{- $interchange+\(\forall x\,\forall y\,P(x,y)\Leftrightarrow \forall y\,\forall x\,P(x,y)\)++>>> let p = uninterpret "P" :: (SU, SV) -> SBool+>>> prove $ qe (\(Forall x) (Forall y) -> p (x, y)) .<=> qe (\(Forall y) (Forall x) -> p (x, y))+Q.E.D.++\(\exists x\,\exists y\,P(x,y)\Leftrightarrow \exists y\,\exists x\,P(x,y)\)++>>> let p = uninterpret "P" :: (SU, SV) -> SBool+>>> prove $ qe (\(Exists x) (Exists y) -> p (x, y)) .<=> qe (\(Exists y) (Exists x) -> p (x, y))+Q.E.D.+-}++-- * Merging quantifiers+{- $mergeQuants+\(\forall x\,P(x)\land \forall x\,Q(x)\Leftrightarrow \forall x\,(P(x)\land Q(x))\)++>>> let p = uninterpret "P" :: SU -> SBool+>>> let q = uninterpret "Q" :: SU -> SBool+>>> prove $ (qe (\(Forall x) -> p x) .&& qe (\(Forall x) -> q x)) .<=> qe (\(Forall x) -> p x .&& q x)+Q.E.D.++\(\exists x\,P(x)\lor \exists x\,Q(x)\Leftrightarrow \exists x\,(P(x)\lor Q(x))\)++>>> let p = uninterpret "P" :: SU -> SBool+>>> let q = uninterpret "Q" :: SU -> SBool+>>> prove $ (qe (\(Exists x) -> p x) .|| qe (\(Exists x) -> q x)) .<=> qe (\(Exists x) -> p x .|| q x)+Q.E.D.+-}++-- * Scoping over quantifiers+{- $scopeOverQuants+Provided \(x\) is not free in \(P\): \(P\land \exists x\,Q(x)\Leftrightarrow \exists x\,(P\land Q(x))\)++>>> let p = uninterpret "P" :: SBool+>>> let q = uninterpret "Q" :: SU -> SBool+>>> prove $ (p .&& qe (\(Exists x) -> q x)) .<=> qe (\(Exists x) -> p .&& q x)+Q.E.D.++Provided \(x\) is not free in \(P\): \(P\lor \forall x\,Q(x)\Leftrightarrow \forall x\,(P\lor Q(x))\)++>>> let p = uninterpret "P" :: SBool+>>> let q = uninterpret "Q" :: SU -> SBool+>>> prove $ (p .|| qe (\(Forall x) -> q x)) .<=> qe (\(Forall x) -> p .|| q x)+Q.E.D.+-}++-- * A non-identity+{- $nonIdentity+It's instructive to look at an example where the proof actually fails. Consider, for instance, an+example of a merging quantifiers like we did above, except when the equality doesn't hold. That+is, we try to prove the "correct" sounding, but incorrect conjecture:++\(\forall x\,P(x)\lor \forall x\,Q(x)\Leftrightarrow \forall x\,(P(x)\lor Q(x))\)++We have:++>>> let p = uninterpret "P" :: SU -> SBool+>>> let q = uninterpret "Q" :: SU -> SBool+>>> prove $ (qe (\(Forall x) -> p x) .|| qe (\(Forall x) -> q x)) .<=> qe (\(Forall x) -> p x .|| q x)+Falsifiable. Counter-example:+ P :: U -> Bool+ P U_2 = True+ P U_0 = True+ P _ = False+<BLANKLINE>+ Q :: U -> Bool+ Q U_2 = False+ Q U_0 = False+ Q _ = True++The solver found us a falsifying instance: Pick a domain with at least three elements. We'll call+the first element @U_2@, and the second element @U_0@, without naming the others. (Unfortunately the solver picks nonintuitive names, but you can substitute better names if you like. They're just names of two distinct+objects that belong to the domain \(U\) with no other meaning.)++Arrange so that \(P\) is true on @U_2@ and @U_0@, but false for everything else.+Also arrange so that \(Q\) is false on these two elements, but true for everything else.++With this+assignment, the right hand side of our conjecture+is true no matter which element you pick, because either \(P\) or \(Q\) is true on any+given element. (Actually, only one will be true on any element, but that is tangential.)+But left-hand-side is not a tautology: Clearly neither \(P\) nor \(Q\) are true for all elements, and+hence both disjuncts are false. Thus, the alleged conjecture is not an equivalence in first order logic.+-}++-- * Exists unique+{- $existsUnique+We can use the t'ExistsUnique' constructor to indicate a value must exists uniquely. For instance,+we can prove that there is an element in 'E' that's less than 'C', but it's not unique. However,+there's a unique element that's less than all the elements in 'E':++>>> prove $ \(Exists (me :: SE)) -> me .<= sC+Q.E.D.+>>> prove $ \(ExistsUnique (me :: SE)) -> me .<= sC+Falsifiable+>>> prove $ \(ExistsUnique (me :: SE)) (Forall e) -> me .<= e+Q.E.D.+-}++-- * Skolemization+{- $skolemization+Given a formula, skolemization produces an equisatisfiable formula that has no existential quantifiers. Instead,+the existentials are replaced by uninterpreted functions.+Skolemization is useful when we want to see the instantiation of nested existential variables. Interpretation for such variables will be+functions of the enclosing universals.+-}++-- | Consider the formula \(\forall x\,\exists y\, x \ge y\), over bit-vectors of size 8. We can ask SBV to satisfy it:+--+-- >>> sat skolemEx1+-- Satisfiable+--+-- But this isn't really illuminating. We can first skolemize, and then ask to satisfy:+--+-- >>> sat $ skolemize skolemEx1+-- Satisfiable. Model:+-- y :: Word8 -> Word8+-- y x = x+--+-- which is much better We are told that we can have the witness as the value given for each choice of @x@.+skolemEx1 :: Forall "x" Word8 -> Exists "y" Word8 -> SBool+skolemEx1 (Forall x) (Exists y) = x .>= y++-- | Consider the formula \(\forall a\,\exists b\,\forall c\,\exists d\, a + b >= c + d\), over bit-vectors of size 8. We can ask SBV to satisfy it:+--+-- >>> sat skolemEx2+-- Satisfiable+--+-- Again, we're left in the dark as to why this is satisfiable. Let's skolemize first, and then call 'sat' on it:+--+-- >>> sat $ skolemize skolemEx2+-- Satisfiable. Model:+-- b :: Word8 -> Word8+-- b _ = 0+-- <BLANKLINE>+-- d :: Word8 -> Word8 -> Word8+-- d a c = a + 255 * c+--+-- Let's see what the solver said. It suggested we should use the value of @0@ for @b@, regardless of the+-- choice of @a@. (Note how @b@ is a function of one variable, i.e., of @a@)+-- And it suggested using @a + (255 * c)@ for @d@,+-- for whatever we choose for @a@ and @c@. Why does this work? Well, given+-- arbitrary @a@ and @c@, we end up with:+--+-- @+-- a + b >= c + d+-- --> substitute b = 0 and d = a + 255c as suggested by the solver+-- a + 0 >= c + a + 255c+-- a >= 256c + a+-- a >= a+-- @+--+-- showing the formula is satisfiable for whatever values you pick for @a@ and @c@. Note that @256@ is simply+-- @0@ when interpreted modulo @2^8@. Clever!+skolemEx2 :: Forall "a" Word8 -> Exists "b" Word8 -> Forall "c" Word8 -> Exists "d" Word8 -> SBool+skolemEx2 (Forall a) (Exists b) (Forall c) (Exists d) = a + b .>= c + d++-- | A common proof technique to show validity is to show that the negation is unsatisfiable. Note+-- that if you want to skolemize during this process, you should first /negate/ and then skolemize!+--+-- This example demonstrates the possible pitfall. The 'skolemEx3' function+-- encodes \(\exists x\, \forall y\, y \ge x\) for 8-bit bitvectors; which is a valid statement since+-- @x = 0@ acts as the witness. We can directly prove this in SBV:+--+-- >>> prove skolemEx3+-- Q.E.D.+--+-- Or, we can ask if the negation is unsatisfiable:+--+-- >>> sat (qNot skolemEx3)+-- Unsatisfiable+--+-- If we want, we can skolemize after the negation step:+--+-- >>> sat (skolemize (qNot skolemEx3))+-- Unsatisfiable+--+-- and get the same result. However, it would be __unsound__ to skolemize first and then negate:+--+-- >>> sat (qNot (skolemize skolemEx3))+-- Satisfiable. Model:+-- x = 1 :: Word8+--+-- And that would be the incorrect conclusion that our formula is invalid with a counter-example! You+-- can see the same by doing:+--+-- >>> prove (skolemize skolemEx3)+-- Falsifiable. Counter-example:+-- x = 1 :: Word8+--+-- So, if you want to check validity and want to also perform skolemization; you should negate your+-- formula first and then skolemize, not the other way around!+skolemEx3 :: Exists "x" Word8 -> Forall "y" Word8 -> SBool+skolemEx3 (Exists x) (Forall y) = y .>= x++-- | If you skolemize different formulas that share the same name for their existentials, then SBV will+-- get confused and will think those represent the same skolem function. This is unfortunate, but it follows+-- the requirement that uninterpreted function names should be unique. In this particular case, however, since+-- SBV creates these functions, it is harder to control the internal names. In such cases, use the function+-- 'taggedSkolemize' to provide a name to prefix the skolem functions. As demonstrated by 'skolemEx4'. We get:+--+-- >>> skolemEx4+-- Satisfiable. Model:+-- c1_y :: Integer -> Integer+-- c1_y x = x+-- <BLANKLINE>+-- c2_y :: Integer -> Integer+-- c2_y x = x + 1+--+-- Note how the internal skolem functions are named according to the tag given. If you use regular 'skolemize'+-- this program will essentially do the wrong thing by assuming the skolem functions for both predicates are+-- the same, and will return unsat. Beware!+-- All skolem functions should be named differently in your program for your deductions to be sound.+skolemEx4 :: IO SatResult+skolemEx4 = sat cs+ where cs :: ConstraintSet+ cs = do constrain $ taggedSkolemize "c1" $ \(Forall @"x" x) (Exists @"y" y) -> x .== (y :: SInteger)+ constrain $ taggedSkolemize "c2" $ \(Forall @"x" x) (Exists @"y" y) -> x .== (y-1 :: SInteger)++-- * Special relations++-- ** Partial orders+{- $partialOrder+A partial order is a reflexive, antisymmetic, and a transitive relation. We can prove these properties+for relations that are checked by the 'isPartialOrder' predicate in SBV:++\(\forall x\,R(x,x)\)++\(\forall x\,\forall y\, R(x, y) \land R(y, x) \Rightarrow x = y\)++\(\forall x\,\forall y\, \forall z\, R(x, y) \land R(y, z) \Rightarrow R(x, z)\)++>>> let r = uninterpret "R" :: Relation U+>>> let isPartial = isPartialOrder "poR" r+>>> prove $ \(Forall x) -> isPartial .=> r (x, x)+Q.E.D.+>>> prove $ \(Forall x) (Forall y) -> isPartial .=> (r (x, y) .&& r (y, x) .=> x .== y)+Q.E.D.+>>> prove $ \(Forall x) (Forall y) (Forall z) -> isPartial .=> (r (x, y) .&& r (y, z) .=> r (x, z))+Q.E.D.+-}++-- | Demonstrates creating a partial order. We have:+--+-- >>> poExample+-- Q.E.D.+poExample :: IO ThmResult+poExample = prove $ do+ let r = uninterpret "R" :: Relation E+ constrain $ isPartialOrder "poR" r++ pure $ qe (\(Forall x) -> r (x, x)) :: Predicate++-- ** Linear orders+{- $linearOrder+A linear order, ensured by the predicate 'isLinearOrder', satisfies the following axioms:++\(\forall x\,R(x,x)\)++\(\forall x\,\forall y\, R(x, y) \land R(y, x) \Rightarrow x = y\)++\(\forall x\,\forall y\, \forall z\, R(x, y) \land R(y, z) \Rightarrow R(x, z)\)++\(\forall x\,\forall y\, R(x, y) \lor R(y, x)\)++>>> let r = uninterpret "R" :: Relation U+>>> let isLinear = isLinearOrder "loR" r+>>> prove $ \(Forall x) -> isLinear .=> r (x, x)+Q.E.D.+>>> prove $ \(Forall x) (Forall y) -> isLinear .=> (r (x, y) .&& r (y, x) .=> x .== y)+Q.E.D.+>>> prove $ \(Forall x) (Forall y) (Forall z) -> isLinear .=> (r (x, y) .&& r (y, z) .=> r (x, z))+Q.E.D.+>>> prove $ \(Forall x) (Forall y) -> isLinear .=> (r (x, y) .|| r (y, x))+Q.E.D.+-}++-- ** Tree orders+{- $treeOrder+A tree order, ensured by the predicate 'isTreeOrder', satisfies the following axioms:++\(\forall x\,R(x,x)\)++\(\forall x\,\forall y\, R(x, y) \land R(y, x) \Rightarrow x = y\)++\(\forall x\,\forall y\, \forall z\, R(x, y) \land R(y, z) \Rightarrow R(x, z)\)++\(\forall x\,\forall y\,\forall z\, (R(y, x) \land R(z, z)) \Rightarrow (R (y, z) \lor R (z, y))\)++>>> let r = uninterpret "R" :: Relation U+>>> let isTree = isTreeOrder "toR" r+>>> prove $ \(Forall x) -> isTree .=> r (x, x)+Q.E.D.+>>> prove $ \(Forall x) (Forall y) -> isTree .=> (r (x, y) .&& r (y, x) .=> x .== y)+Q.E.D.+>>> prove $ \(Forall x) (Forall y) (Forall z) -> isTree .=> (r (x, y) .&& r (y, z) .=> r (x, z))+Q.E.D.+>>> prove $ \(Forall x) (Forall y) (Forall z) -> isTree .=> ((r (y, x) .&& r (z, x)) .=> (r (y, z) .|| r (z, y)))+Q.E.D.+-}++-- ** Piecewise linear orders+{- $piecewiseLinear+A piecewise linear order, ensured by the predicate 'isPiecewiseLinearOrder', satisfies the following axioms:++\(\forall x\,R(x,x)\)++\(\forall x\,\forall y\, R(x, y) \land R(y, x) \Rightarrow x = y\)++\(\forall x\,\forall y\, \forall z\, R(x, y) \land R(y, z) \Rightarrow R(x, z)\)++\(\forall x\,\forall y\,\forall z\, (R(x, y) \land R(x, z)) \Rightarrow (R (y, z) \lor R (z, y))\)++\(\forall x\,\forall y\,\forall z\, (R(y, x) \land R(z, x)) \Rightarrow (R (y, z) \lor R (z, y))\)++>>> let r = uninterpret "R" :: Relation U+>>> let isPiecewise = isPiecewiseLinearOrder "plR" r+>>> prove $ \(Forall x) -> isPiecewise .=> r (x, x)+Q.E.D.+>>> prove $ \(Forall x) (Forall y) -> isPiecewise .=> (r (x, y) .&& r (y, x) .=> x .== y)+Q.E.D.+>>> prove $ \(Forall x) (Forall y) (Forall z) -> isPiecewise .=> (r (x, y) .&& r (y, z) .=> r (x, z))+Q.E.D.+>>> prove $ \(Forall x) (Forall y) (Forall z) -> isPiecewise .=> ((r (x, y) .&& r (x, z)) .=> (r (y, z) .|| r (z, y)))+Q.E.D.+>>> prove $ \(Forall x) (Forall y) (Forall z) -> isPiecewise .=> ((r (y, x) .&& r (z, x)) .=> (r (y, z) .|| r (z, y)))+Q.E.D.+-}++-- ** Transitive closures+{- $transitiveClosures+The transitive closure of a relation can be created using 'mkTransitiveClosure'. Transitive closures+are not first-order axiomatizable. That is, we cannot write first-order formulas to uniquely+describe them. However, we can check some of the expected properties:++>>> let r = uninterpret "R" :: Relation U+>>> let tcR = mkTransitiveClosure "tcR" r+>>> prove $ \(Forall x) (Forall y) -> r (x, y) .=> tcR (x, y)+Q.E.D.+>>> prove $ \(Forall x) (Forall y) (Forall z) -> r (x, y) .&& r (y, z) .=> tcR (x, z)+Q.E.D.++What's missing here is the check that if the transitive closure relates two elements, then they are+connected transitively in the original relation. This requirement is not axiomatizable in first order logic.+-}++-- | Create a transitive relation of a simple relation and show that transitive connections are respected.+-- We have:+--+-- >>> tcExample1+-- Q.E.D.+tcExample1 :: IO ThmResult+tcExample1 = prove $ do+ a :: SU <- free "a"+ b :: SU <- free "b"+ c :: SU <- free "c"++ let r = uninterpret "R"+ tcR = mkTransitiveClosure "tcR" r++ -- Add R(a, b), R(b, c), but explicitly state ~R(a, c)+ constrain $ r (a, b)+ constrain $ r (b, c)+ constrain $ sNot $ r (a, c)++ -- Show that in tcR, a and c are connected+ pure $ tcR (a, c)++-- | Another transitive-closure example, this time we show the transitive closure is the smallest+-- relation, i.e., doesn't have extra connections. We have:+--+-- >>> tcExample2+-- Q.E.D.+tcExample2 :: IO ThmResult+tcExample2 = prove $ do+ let r = uninterpret "r"+ tcR = mkTransitiveClosure "tcR" r++ -- Add R(A, B), ~R(A, C), ~R(B, C) then it shouldn't be the case that R(a, c)+ constrain $ r (sA, sB)+ constrain $ sNot $ r (sA, sC)+ constrain $ sNot $ r (sB, sC)++ -- Show that in tcR, a and c cannot be connected+ pure $ sNot $ tcR (sA, sC) :: Predicate++-- | Demonstrates computing the transitive closure of existing relations. We have:+--+-- >>> tcExample3+-- Q.E.D.+tcExample3 :: IO ThmResult+tcExample3 = prove $ do++ -- Define a relation over the type 'E', which only relates 'A' to 'B'.+ let rel :: Relation E+ rel xy = xy .== (sA, sB)++ -- Create a relation and its transitive closure, and associate it with our function:+ let tcR = mkTransitiveClosure "R" rel++ -- Show that in tcR, a and c cannot be connected+ pure $ sNot $ tcR (sA, sC) :: Predicate
Documentation/SBV/Examples/Misc/Floating.hs view
@@ -17,6 +17,7 @@ -- the presence of @NaN@ is always something to look out for. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -26,9 +27,10 @@ import Data.SBV +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif ----------------------------------------------------------------------------- -- * FP addition is not associative@@ -66,21 +68,21 @@ -- -- >>> assocPlusRegular -- Falsifiable. Counter-example:--- x = -3.0359216e35 :: Float--- y = 5.058223e30 :: Float--- z = 8.307169e34 :: Float+-- x = 2.5291315e20 :: Float+-- y = -2.9558926e20 :: Float+-- z = 1.1256507e20 :: Float -- -- Indeed, we have: ----- >>> let x = -3.0359216e35 :: Float--- >>> let y = 5.058223e30 :: Float--- >>> let z = 8.307169e34 :: Float+-- >>> let x = 2.5291315e20 :: Float+-- >>> let y = -2.9558926e20 :: Float+-- >>> let z = 1.1256507e20 :: Float -- >>> x + (y + z)--- -2.205154e35+-- 6.988897e19 -- >>> (x + y) + z--- -2.2051543e35+-- 6.988896e19 ----- Note the difference in the results!+-- Note the significant difference in the results! assocPlusRegular :: IO ThmResult assocPlusRegular = prove $ do [x, y, z] <- sFloats ["x", "y", "z"] let lhs = x+(y+z)@@ -88,7 +90,7 @@ -- make sure we do not overflow at the intermediate points constrain $ fpIsPoint lhs constrain $ fpIsPoint rhs- return $ lhs .== rhs+ pure $ lhs .== rhs ----------------------------------------------------------------------------- -- * FP addition by non-zero can result in no change@@ -100,13 +102,13 @@ -- -- >>> nonZeroAddition -- Falsifiable. Counter-example:--- a = 2.5068128e37 :: Float--- b = -5.354632 :: Float+-- a = 2.9670994e34 :: Float+-- b = -7.208359e-5 :: Float -- -- Indeed, we have: ----- >>> let a = 2.5068128e37 :: Float--- >>> let b = -5.354632 :: Float+-- >>> let a = 2.9670994e34 :: Float+-- >>> let b = -7.208359e-5 :: Float -- >>> a + b == a -- True -- >>> b == 0@@ -116,7 +118,7 @@ constrain $ fpIsPoint a constrain $ fpIsPoint b constrain $ a + b .== a- return $ b .== 0+ pure $ b .== 0 ----------------------------------------------------------------------------- -- * FP multiplicative inverses may not exist@@ -129,18 +131,18 @@ -- -- >>> multInverse -- Falsifiable. Counter-example:--- a = 1.2760589e38 :: Float+-- a = -2.372672e38 :: Float -- -- Indeed, we have: ----- >>> let a = 1.2760589e38 :: Float+-- >>> let a = -2.372672e38 :: Float -- >>> a * (1/a) -- 0.99999994 multInverse :: IO ThmResult multInverse = prove $ do a <- sFloat "a" constrain $ fpIsPoint a constrain $ fpIsPoint (1/a)- return $ a * (1/a) .== 1+ pure $ a * (1/a) .== 1 ----------------------------------------------------------------------------- -- * Effect of rounding modes@@ -155,31 +157,29 @@ -- -- >>> roundingAdd -- Satisfiable. Model:--- rm = RoundTowardNegative :: RoundingMode--- x = 3.2806003e-21 :: Float--- y = -5.749071e-20 :: Float+-- rm = RoundTowardPositive :: RoundingMode+-- x = -4.0039067 :: Float+-- y = 131076.0 :: Float -- -- (Note that depending on your version of Z3, you might get a different result.) -- Unfortunately Haskell floats do not allow computation with arbitrary rounding modes, but SBV's -- 'SFloatingPoint' type does. We have: ----- >>> fpAdd sRoundNearestTiesToEven 3.2806003e-21 (-5.749071e-20) :: SFPSingle--- -5.42101054e-20 :: SFloatingPoint 8 24--- >>> fpAdd sRoundTowardNegative 3.2806003e-21 (-5.749071e-20) :: SFPSingle--- -5.42101086e-20 :: SFloatingPoint 8 24+-- >>> sat $ \x -> x .== (fpAdd sRoundTowardPositive (-4.0039067) 131076.0 :: SFloat)+-- Satisfiable. Model:+-- s0 = 131072.0 :: Float+-- >>> (-4.0039067) + 131076.0 :: Float+-- 131071.99 ----- We can see why these two results are indeed different: The 'RoundTowardNegative'--- (which rounds towards negative infinity from zero) produces a smaller result. Indeed, if we treat these numbers--- as 'Double' values, we get:+-- We can see why these two results are indeed different: The 'RoundTowardPositive+-- (which rounds towards positive infinity) produces a larger result. ----- >>> 3.2806003e-21 + (-5.749071e-20) :: Double--- -5.42101097e-20+-- >>> (-4.0039067) + 131076.0 :: Double+-- 131071.9960933 ----- we see that the "more precise" result is smaller than what the 'Float' value is, justifying the--- smaller value with 'RoundTowardNegative'. 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.+-- 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. roundingAdd :: IO SatResult roundingAdd = sat $ do m :: SRoundingMode <- free "rm" constrain $ m ./= literal RoundNearestTiesToEven@@ -189,7 +189,7 @@ let rhs = x + y constrain $ fpIsPoint lhs constrain $ fpIsPoint rhs- return $ lhs ./= rhs+ pure $ lhs ./= rhs -- | Arbitrary precision floating-point numbers. SBV can talk about floating point numbers with arbitrary -- exponent and significand sizes as well. Here is a simple example demonstrating the minimum non-zero positive@@ -197,33 +197,33 @@ -- bits for the significand explicitly stored, includes the hidden bit. We have: -- -- >>> fp54Bounds--- Objective "max": Optimal model:--- x = 61400 :: FloatingPoint 5 4--- max = 503 :: WordN 9--- min = 503 :: WordN 9--- Objective "min": Optimal model:--- x = 0.00000763 :: FloatingPoint 5 4--- max = 257 :: WordN 9--- min = 257 :: WordN 9+-- Objective "toMetricSpace(max)": Optimal model:+-- x = 61440 :: FloatingPoint 5 4+-- Objective "toMetricSpace(min)": Optimal model:+-- x = 0.000007629 :: FloatingPoint 5 4 ----- The careful reader will notice that the numbers @61400@ and @0.00000763@ are quite suspicious, but the metric--- space equivalents are correct. The reason for this is due to the sparcity of floats. The "computed" value of--- the maximum in this bound is actually @61440@, however in @FloatingPoint 5 4@ representation all numbers--- between @57344@ and @61440@ collapse to the same bit-pattern, and the pretty-printer picks a string--- representation in decimal that falls within range that it considers is the "simplest." (Printing--- floats precisely is a thorny subject!) Likewise, the minimum value we're looking for is actually--- 2^-17, but any number between 2^-16 and 2^-17 will map to this number. It turns out that 0.00000763--- in decimal is one such value. Moral of the story is that when reading floating-point numbers in+-- An important note is in order. When printing floats in decimal, one can get correct yet surprising results.+-- There's a large body of publications in how to render floats in decimal, or in bases that are not powers of+-- two in general. So, when looking at such values in decimal, keep in mind that what you see might be+-- a representative value: That is, it preserves the value when translated back to the format. For instance,+-- the more precise answer for the min value would be 2^-17, which is 0.00000762939453125. But we see+-- it truncated here. In fact, any number between 2^-16 and 2^-17 would be correct as they all map to the same+-- underlying representation in this format. Moral of the story is that when reading floating-point numbers in -- decimal notation one should be very careful about the printed representation and the numeric value; while--- they will match in vsalue (if there are no bugs!), they can print quite differently! (Also keep in+-- they will match in value (if there are no bugs!), they can print quite differently! (Also keep in -- mind the rounding modes that impact how the conversion is done.)+--+-- One final note: When printing the models, we skip optimization variables that are not named @x@. See the+-- call to `Data.SBV.Core.Symbolic.isNonModelVal`. When we optimize floating-point values, the underlying engine actually optimizes+-- with bit-vector values, producing intermediate results. We skip those here to simplify the presentation. fp54Bounds :: IO OptimizeResult-fp54Bounds = optimize Independent $ do x :: SFloatingPoint 5 4 <- sFloatingPoint "x"+fp54Bounds = optimizeWith z3{isNonModelVar = (/= "x")}+ Independent $ do x :: SFloatingPoint 5 4 <- sFloatingPoint "x" - constrain $ fpIsPoint x- constrain $ x .> 0+ constrain $ fpIsPoint x+ constrain $ x .> 0 - maximize "max" x- minimize "min" x+ maximize "max" x+ minimize "min" x - pure sTrue+ pure sTrue
+ Documentation/SBV/Examples/Misc/LambdaArray.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Misc.LambdaArray+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Demonstrates how lambda-abstractions can be used to model arrays.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Misc.LambdaArray where++import Data.SBV++-- | Given an array, and bounds on it, initialize it within the bounds to the element given.+-- Otherwise, leave it untouched.+memset :: SArray Integer Integer -> SInteger -> SInteger -> SInteger -> SArray Integer Integer+memset mem lo hi newVal = lambdaArray update+ where update :: SInteger -> SInteger+ update idx = let oldVal = readArray mem idx+ in ite (lo .<= idx .&& idx .<= hi) newVal oldVal++-- | Prove a simple property: If we read from the initialized region, we get the initial value. We have:+--+-- >>> memsetExample+-- Q.E.D.+memsetExample :: IO ThmResult+memsetExample = prove $ do+ mem <- sArray "mem"+ lo <- sInteger "lo"+ hi <- sInteger "hi"+ zeroV <- sInteger "zero"++ -- Get an index within lo/hi+ idx <- sInteger "idx"+ constrain $ idx .>= lo .&& idx .<= hi++ -- It must be the case that we get zero back after mem-setting+ pure $ readArray (memset mem lo hi zeroV) idx .== zeroV++-- | Get an example of reading a value out of range. The value returned should be out-of-range for lo/hi+--+-- >>> outOfInit+-- Satisfiable. Model:+-- mem = ([], 1) :: Array Integer Integer+-- lo = 0 :: Integer+-- hi = 0 :: Integer+-- zero = 0 :: Integer+-- idx = 1 :: Integer+-- Read = 1 :: Integer+outOfInit :: IO SatResult+outOfInit = sat $ do+ mem <- sArray "mem"+ lo <- sInteger "lo"+ hi <- sInteger "hi"+ zeroV <- sInteger "zero"++ -- Get a meaningful range:+ constrain $ lo .<= hi++ -- Get an index+ idx <- sInteger "idx"++ -- Let read produce non-zero+ constrain $ observe "Read" (readArray (memset mem lo hi zeroV) idx) ./= zeroV++{- HLint ignore module "Reduce duplication" -}
Documentation/SBV/Examples/Misc/ModelExtract.hs view
@@ -25,7 +25,7 @@ outside disallow = sat $ do x <- sInteger "x" let notEq i = constrain $ x ./= literal i mapM_ notEq disallow- return $ x .>= 0+ pure $ x .>= 0 -- | We now use "outside" repeatedly to generate 10 integers, such that we not only disallow -- previously generated elements, but also any value that differs from previous solutions@@ -37,7 +37,7 @@ genVals :: IO [Integer] genVals = go [] [] where go _ model- | length model >= 10 = return model+ | length model >= 10 = pure model go disallow model = do res <- outside disallow -- Look up the value of "x" in the generated model@@ -45,4 +45,4 @@ -- SBV known type would be OK as well. case "x" `getModelValue` res of Just c -> go ([c-4 .. c+4] ++ disallow) (c : model)- _ -> return model+ _ -> pure model
Documentation/SBV/Examples/Misc/NestedArray.hs view
@@ -23,11 +23,11 @@ -- another integer to integer array in each index. We have: -- -- >>> nestedArray--- (2,10)+-- (0,10) nestedArray :: IO (Integer, Integer) nestedArray = runSMT $ do idx <- sInteger "idx"- arr <- newArray_ Nothing :: Symbolic (SArray (Integer, Integer) Integer)+ arr <- sArray_ :: Symbolic (SArray (Integer, Integer) Integer) -- we'll assert that arr[idx][idx] = 10 let val = readArray arr (tuple (idx, idx))
Documentation/SBV/Examples/Misc/Newtypes.hs view
@@ -11,27 +11,31 @@ -- their wrapped type. ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# 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--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif --- | A 'Metres' is a newtype wrapper around 'Integer'.-newtype Metres = Metres Integer deriving (Real, Integral, Num, Enum, Eq, Ord)+-- | A t'Metres' is a newtype wrapper around 'Integer'.+newtype Metres = Metres Integer deriving (Real, Integral, Num, Enum, Eq, Ord, Arbitrary) --- | Symbolic version of 'Metres'.-type SMetres = SBV Metres+-- | Symbolic version of t'Metres'.+type SMetres = SBV Metres --- | To use 'Metres' symbolically, we associate it with the underlying symbolic+-- | To use t'Metres' symbolically, we associate it with the underlying symbolic -- type's kind. instance HasKind Metres where kindOf _ = KUnbounded@@ -39,20 +43,21 @@ -- | 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 'HumanHeightInCm'.+-- | Symbolic version of t'HumanHeightInCm'. type SHumanHeightInCm = SBV HumanHeightInCm --- | Symbolic instance simply follows the underlying type, just like 'Metres'.+-- | Symbolic instance simply follows the underlying type, just like t'Metres'. instance HasKind HumanHeightInCm where kindOf _ = KBounded False 16 @@ -82,11 +87,11 @@ -- >>> sat problem -- Satisfiable. Model: -- floorToCeiling = 3 :: Integer--- humanheight = 253 :: Word16+-- humanheight = 272 :: Word16 problem :: Predicate problem = do ceiling :: SMetres <- free "floorToCeiling" humanHeight :: SHumanHeightInCm <- free "humanheight"- constrain $ humanHeight .<= tallestHumanEver+ constrain $ humanHeight .== tallestHumanEver - return $ ceilingHighEnoughForHuman ceiling humanHeight+ pure $ ceilingHighEnoughForHuman ceiling humanHeight
Documentation/SBV/Examples/Misc/Polynomials.hs view
@@ -22,12 +22,12 @@ -- Note that addition in GF(2^n) is simply `xor`, so no custom function is provided. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall -Werror #-}+ module Documentation.SBV.Examples.Misc.Polynomials where import Data.SBV import Data.SBV.Tools.Polynomial--{-# OPTIONS_GHC -Wall -Werror #-} -- | Helper synonym for representing GF(2^8); which are merely 8-bit unsigned words. Largest -- term in such a polynomial has degree 7.
+ Documentation/SBV/Examples/Misc/ProgramPaths.hs view
@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Misc.ProgramPaths+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- A simple example of showing how to compute program paths. Consider the simple+-- program:+--+-- @+-- d1 x y = if y < x - 2 then 7 else 2+-- d2 y = if y > 3 then 10 else 50+-- d3 x y = if y < -x + 3 then 100 else 200+-- d4 x y = d1 x y + d2 y + d3 x y+-- @+--+-- What are all the possible values @d4 x y@ can take, and what are the values of+-- @x@ and @y@ to obtain these values?+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Misc.ProgramPaths where++import Data.SBV++-- | Symbolic version of @d1 x y = if y < x - 2 then 7 else 2@+d1 :: SInteger -> SInteger -> SInteger+d1 x y = ite (y .< x - 2) 7 2++-- | Symbolic version of @d2 y = if y > 3 then 10 else 50@+d2 :: SInteger -> SInteger+d2 y = ite (y .> 3) 10 50++-- | Symbolic version of @d3 x y = if y < -x + 3 then 100 else 200@+d3 :: SInteger -> SInteger -> SInteger+d3 x y = ite (y .< -x + 3) 100 200++-- | Symbolic version of @d4 x y = d1 x y + d2 x y + d3 x y@+d4 :: SInteger -> SInteger -> SInteger+d4 x y = d1 x y + d2 y + d3 x y++-- | Compute all possible program paths. Note the call to `allSatPartition`, which+-- causes `allSat` to find models that generate differing values for the given+-- expression. We have:+--+-- >>> paths+-- Solution #1:+-- x = -2 :: Integer+-- y = 4 :: Integer+-- r = 112 :: Integer+-- Solution #2:+-- x = 0 :: Integer+-- y = 3 :: Integer+-- r = 252 :: Integer+-- Solution #3:+-- x = -1 :: Integer+-- y = 4 :: Integer+-- r = 212 :: Integer+-- Solution #4:+-- x = 3 :: Integer+-- y = 0 :: Integer+-- r = 257 :: Integer+-- Solution #5:+-- x = 2 :: Integer+-- y = -1 :: Integer+-- r = 157 :: Integer+-- Solution #6:+-- x = 7 :: Integer+-- y = 4 :: Integer+-- r = 217 :: Integer+-- Solution #7:+-- x = 0 :: Integer+-- y = 0 :: Integer+-- r = 152 :: Integer+-- Found 7 different solutions.+paths :: IO AllSatResult+paths = allSat $ do+ x <- sInteger "x"+ y <- sInteger "y"+ allSatPartition "r" $ d4 x y
Documentation/SBV/Examples/Misc/SetAlgebra.hs view
@@ -10,24 +10,25 @@ -- prove all come from <http://en.wikipedia.org/wiki/Algebra_of_sets>. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Misc.SetAlgebra where import Data.SBV hiding (complement)-import Data.SBV.Set () -- This import shouldn't be necessary, but I can't get doctest to work otherwise. Sigh. +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV hiding (complement) -- >>> import Data.SBV.Set -- >>> :set -XScopedTypeVariables+#endif -- | Abbreviation for set of integers. For convenience only in monomorphising the properties. type SI = SSet Integer -- * Commutativity--- $commutativity {- $commutativity \(A\cup B=B\cup A\) @@ -41,7 +42,6 @@ -} -- * Associativity--- $associativity {- $associativity \((A\cup B)\cup C=A\cup (B\cup C)\)@@ -56,7 +56,6 @@ -} -- * Distributivity--- $distributivity {- $distributivity \(A\cup (B\cap C)=(A\cup B)\cap (A\cup C)\) @@ -70,7 +69,6 @@ -} -- * Identity properties--- $identity {- $identity \(A\cup \varnothing = A\)@@ -85,7 +83,6 @@ -} -- * Complement properties--- $complement {- $complement \( A\cup A^{C}=U \)@@ -116,7 +113,6 @@ -- * Uniqueness of the complement ----- $compUnique {- $compUnique The complement of a set is the only set that satisfies the first two complement properties above. That is complementation is characterized by those two laws, as we can formally establish:@@ -128,7 +124,6 @@ -} -- * Idempotency--- $idempotent {- $idempotent \( A\cup A=A \)@@ -143,7 +138,6 @@ -} -- * Domination properties--- $domination {- $domination \( A\cup U=U \)@@ -158,7 +152,6 @@ -} -- * Absorption properties--- $absorption {- $absorption \( A\cup (A\cap B)=A \)@@ -173,7 +166,6 @@ -} -- * Intersection and set difference--- $intdiff {- $intdiff \( A\cap B=A\setminus (A\setminus B) \)@@ -183,7 +175,6 @@ -} -- * De Morgan's laws--- $deMorgan {- $deMorgan \( (A\cup B)^{C}=A^{C}\cap B^{C} \)@@ -198,7 +189,6 @@ -} -- * Inclusion is a partial order--- $incPO {- $incPO Subset inclusion is a partial order, i.e., it is reflexive, antisymmetric, and transitive: @@ -219,7 +209,6 @@ -} -- * Joins and meets--- $joinMeet {- $joinMeet \( A\subseteq A\cup B \)@@ -250,17 +239,16 @@ -} -- * Subset characterization--- $subsetChar {- $subsetChar There are multiple equivalent ways of characterizing the subset relationship: -\( A\subseteq B \iff A \cap B = A \) +\( A\subseteq B \iff A \cap B = A \) >>> prove $ \(a :: SI) b -> a `isSubsetOf` b .<=> a `intersection` b .== a Q.E.D. -\( A\subseteq B \iff A \cup B = B \) +\( A\subseteq B \iff A \cup B = B \) >>> prove $ \(a :: SI) b -> a `isSubsetOf` b .<=> a `union` b .== b Q.E.D.@@ -277,7 +265,6 @@ -} -- * Relative complements--- $relComp {- $relComp \( C\setminus (A\cap B)=(C\setminus A)\cup (C\setminus B) \)@@ -350,7 +337,6 @@ -} -- * Distributing subset relation--- $distSubset {- $distSubset A common mistake newcomers to set theory make is to distribute the subset relationship over intersection@@ -373,6 +359,6 @@ >>> prove $ \(a :: SI) b c -> (b `intersection` c) `isSubsetOf` a .=> b `isSubsetOf` a .&& c `isSubsetOf` a Falsifiable. Counter-example: s0 = U - {2} :: {Integer}- s1 = {2} :: {Integer}- s2 = {} :: {Integer}+ s1 = U - {2} :: {Integer}+ s2 = {2} :: {Integer} -}
Documentation/SBV/Examples/Misc/SoftConstrain.hs view
@@ -44,4 +44,4 @@ softConstrain $ x .== "default-x-value" softConstrain $ y .== "default-y-value" - return sTrue+ pure sTrue
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@@ -38,7 +38,7 @@ -- | Create a dictionary of length 5, such that each element -- has an string key and each value is the length of the key.--- We impose a few more constraints to make the output interesting. +-- We impose a few more constraints to make the output interesting. -- For instance, you might get: -- -- @ ghci> example@@ -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
@@ -10,12 +10,10 @@ -- by properly defining your metric values. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -27,7 +25,7 @@ data Day = Mon | Tue | Wed | Thu | Fri | Sat | Sun -- | Make 'Day' a symbolic value.-mkSymbolicEnumeration ''Day+mkSymbolic [''Day] -- | Make day an optimizable value, by mapping it to 'Word8' in the most -- obvious way. We can map it to any value the underlying solver can optimize,@@ -51,6 +49,8 @@ $ ite (x .== 5) sSat sSun + annotateForMS _ s = "DayAsWord8(" ++ s ++ ")"+ -- | Identify weekend days isWeekend :: SDay -> SBool isWeekend = (`sElem` weekend)@@ -61,8 +61,9 @@ -- -- >>> almostWeekend -- Optimal model:--- almostWeekend = Fri :: Day--- last-day = 4 :: Word8+-- almostWeekend = Fri :: Day+-- DayAsWord8(last-day) = 4 :: Word8+-- last-day = Fri :: Day almostWeekend :: IO OptimizeResult almostWeekend = optimize Lexicographic $ do day <- free "almostWeekend"@@ -74,8 +75,9 @@ -- -- >>> weekendJustOver -- Optimal model:--- weekendJustOver = Mon :: Day--- first-day = 0 :: Word8+-- weekendJustOver = Mon :: Day+-- DayAsWord8(first-day) = 0 :: Word8+-- first-day = Mon :: Day weekendJustOver :: IO OptimizeResult weekendJustOver = optimize Lexicographic $ do day <- free "weekendJustOver"@@ -87,8 +89,9 @@ -- -- >>> firstWeekend -- Optimal model:--- firstWeekend = Sat :: Day--- first-weekend = 5 :: Word8+-- firstWeekend = Sat :: Day+-- DayAsWord8(first-weekend) = 5 :: Word8+-- first-weekend = Sat :: Day firstWeekend :: IO OptimizeResult firstWeekend = optimize Lexicographic $ do day <- free "firstWeekend"
Documentation/SBV/Examples/Optimization/ExtField.hs view
@@ -9,15 +9,18 @@ -- Demonstrates the extension field (@oo@/@epsilon@) optimization results. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Optimization.ExtField where import Data.SBV +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif -- | Optimization goals where min/max values might require assignments -- to values that are infinite (integer case), or infinite/epsilon (real case).@@ -38,7 +41,7 @@ -- one-x = oo :: Integer -- min_y = 7.0 :: Real -- min_z = 5.0 :: Real-problem :: Goal+problem :: ConstraintSet problem = do x <- sInteger "x" y <- sReal "y" z <- sReal "z"
Documentation/SBV/Examples/Optimization/LinearOpt.hs view
@@ -9,15 +9,18 @@ -- Simple linear optimization example, as found in operations research texts. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Optimization.LinearOpt where import Data.SBV +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif -- | Taken from <http://people.brunel.ac.uk/~mastjjb/jeb/or/morelp.html> --@@ -35,7 +38,7 @@ -- x1 = 47 % 9 :: Real -- x2 = 20 % 9 :: Real -- goal = 355 % 9 :: Real-problem :: Goal+problem :: ConstraintSet problem = do [x1, x2] <- mapM sReal ["x1", "x2"] constrain $ x1 + x2 .<= 10
Documentation/SBV/Examples/Optimization/Production.hs view
@@ -9,15 +9,18 @@ -- Solves a simple linear optimization problem ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Optimization.Production where import Data.SBV +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif -- | Taken from <http://people.brunel.ac.uk/~mastjjb/jeb/or/morelp.html> --@@ -50,7 +53,7 @@ -- stock = 1 :: Integer -- -- That is, we should produce 45 X's and 6 Y's, with the final maximum stock of just 1 expected!-production :: Goal+production :: ConstraintSet production = do x <- sInteger "X" -- Units of X produced y <- sInteger "Y" -- Units of X produced
Documentation/SBV/Examples/Optimization/VM.hs view
@@ -9,15 +9,18 @@ -- Solves a VM allocation problem using optimization features ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Optimization.VM where import Data.SBV +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif -- | Computer allocation problem: --@@ -48,7 +51,7 @@ -- cost = 20 :: Integer -- -- That is, we should put all the jobs on the third server, for a total cost of 20.-allocate :: Goal+allocate :: ConstraintSet allocate = do -- xij means VM i is running on server j x1@[x11, x12, x13] <- sBools ["x11", "x12", "x13"]
+ Documentation/SBV/Examples/ProofTools/AddHorn.hs view
@@ -0,0 +1,108 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.ProofTools.AddHorn+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Example of invariant generation for a simple addition algorithm:+--+-- @+-- z = x+-- i = 0+-- assume y > 0+--+-- while (i < y)+-- z = z + 1+-- i = i + 1+--+-- assert z == x + y+-- @+--+-- We use the Horn solver to calculate the invariant and then show that it+-- indeed is a sufficient invariant to establish correctness.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.ProofTools.AddHorn where++import Data.SBV++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+#endif++-- | Helper type synonym for the invariant.+type Inv = (SInteger, SInteger, SInteger, SInteger) -> SBool++-- | Helper type synonym for verification conditions.+type VC = Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> Forall "i" Integer -> SBool++-- | Helper for turning an invariant predicate to a boolean.+quantify :: Inv -> VC+quantify f = \(Forall x) (Forall y) (Forall z) (Forall i) -> f (x, y, z, i)++-- | First verification condition: Before the loop starts, invariant must hold:+--+-- \(z = x \land i = 0 \land y > 0 \Rightarrow inv (x, y, z, i)\)+vc1 :: Inv -> VC+vc1 inv = quantify $ \(x, y, z, i) -> z .== x .&& i .== 0 .&& y .> 0 .=> inv (x, y, z, i)++-- | Second verification condition: If the loop body executes, invariant must still hold at the end:+--+-- \(inv (x, y, z, i) \land i < y \Rightarrow inv (x, y, z+1, i+1)\)+vc2 :: Inv -> VC+vc2 inv = quantify $ \(x, y, z, i) -> inv (x, y, z, i) .&& i .< y .=> inv (x, y, z+1, i+1)++-- | Third verification condition: Once the loop exits, invariant and the negation of the loop condition+-- must establish the final assertion:+--+-- \(inv (x, y, z, i) \land i \geq y \Rightarrow z == x + y\)+vc3 :: Inv -> VC+vc3 inv = quantify $ \(x, y, z, i) -> inv (x, y, z, i) .&& i .>= y .=> z .== x + y++-- | Synthesize the invariant. We use an uninterpreted function for the SMT solver to synthesize. We get:+--+-- >>> synthesize+-- Satisfiable. Model:+-- invariant :: (Integer, Integer, Integer, Integer) -> Bool+-- invariant (x, y, z, i) = x + (-z) + i > (-1) && x + (-z) + i < 1 && x + y + (-z) > (-1)+--+-- This is a bit hard to read, but you can convince yourself it is equivalent to @x + i .== z .&& x + y .>= z@:+--+-- >>> let f (x, y, z, i) = x + (-z) + i .> (-1) .&& x + (-z) + i .< 1 .&& x + y + (-z) .> (-1)+-- >>> let g (x, y, z, i) = x + i .== z .&& x + y .>= z+-- >>> f === (g :: Inv)+-- Q.E.D.+synthesize :: IO SatResult+synthesize = sat vcs+ where invariant :: Inv+ invariant = uninterpretWithArgs "invariant" ["x", "y", "z", "i"]++ vcs :: ConstraintSet+ vcs = do setLogic $ CustomLogic "HORN"+ constrain $ vc1 invariant+ constrain $ vc2 invariant+ constrain $ vc3 invariant++-- | Verify that the synthesized function does indeed work. To do so, we simply prove that the invariant found satisfies all the vcs:+--+-- >>> verify+-- Q.E.D.+verify :: IO ThmResult+verify = prove vcs+ where invariant :: Inv+ invariant (x, y, z, i) = x + (-z) + i .> (-1) .&& x + (-z) + i .< 1 .&& x + y + (-z) .> (-1)++ vcs :: SBool+ vcs = quantifiedBool (vc1 invariant)+ .&& quantifiedBool (vc3 invariant)+ .&& quantifiedBool (vc3 invariant)++{- HLint ignore quantify "Redundant lambda" -}
Documentation/SBV/Examples/ProofTools/BMC.hs view
@@ -22,6 +22,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -29,13 +30,11 @@ import Data.SBV import Data.SBV.Tools.BMC-import Data.SBV.Control -- * System state -- | System state, containing the two integers.-data S a = S { x :: a, y :: a }- deriving (Functor, Foldable, Traversable)+data S a = S { x :: a, y :: a } deriving (Traversable, Functor, Foldable) -- | Show the state as a pair instance Show a => Show (S a) where@@ -45,28 +44,29 @@ instance EqSymbolic a => EqSymbolic (S a) where S {x = x1, y = y1} .== S {x = x2, y = y2} = x1 .== x2 .&& y1 .== y2 --- | 'Fresh' instance for our state-instance Fresh IO (S SInteger) where- fresh = S <$> freshVar_ <*> freshVar_+-- | 'Queriable instance for our state+instance Queriable IO (S SInteger) where+ type QueryResult (S SInteger) = S Integer+ create = S <$> freshVar_ <*> freshVar_ -- * Encoding the problem -- | We parameterize over the initial state for different variations. problem :: Int -> (S SInteger -> SBool) -> IO (Either String (Int, [S Integer]))-problem lim initial = bmc (Just lim) True setup initial trans goal+problem lim initial = bmcCover (Just lim) True setup initial trans goal where -- This is where we would put solver options, typically via -- calls to 'Data.SBV.setOption'. We do not need any for this problem, -- so we simply do nothing. setup :: Symbolic ()- setup = return ()+ setup = pure () -- Transition relation: At each step we either -- get to increase @x@ by 2, or decrement @y@ by 4:- trans :: S SInteger -> [S SInteger]- trans S{x, y} = [ S { x = x + 2, y = y }- , S { x = x, y = y - 4 }- ]+ trans :: S SInteger -> S SInteger -> SBool+ trans S{x, y} next = next `sElem` [ S { x = x + 2, y = y }+ , S { x = x, y = y - 4 }+ ] -- Goal state is when @x@ equals @y@: goal :: S SInteger -> SBool@@ -77,11 +77,11 @@ -- | Example 1: We start from @x=0@, @y=10@, and search up to depth @10@. We have: -- -- >>> ex1--- BMC: Iteration: 0--- BMC: Iteration: 1--- BMC: Iteration: 2--- BMC: Iteration: 3--- BMC: Solution found at iteration 3+-- BMC Cover: Iteration: 0+-- BMC Cover: Iteration: 1+-- BMC Cover: Iteration: 2+-- BMC Cover: Iteration: 3+-- BMC Cover: Satisfying state found at iteration 3 -- Right (3,[(0,10),(0,6),(2,6),(2,2)]) -- -- As expected, there's a solution in this case. Furthermore, since the BMC engine@@ -97,17 +97,17 @@ -- | Example 2: We start from @x=0@, @y=11@, and search up to depth @10@. We have: -- -- >>> ex2--- BMC: Iteration: 0--- BMC: Iteration: 1--- BMC: Iteration: 2--- BMC: Iteration: 3--- BMC: Iteration: 4--- BMC: Iteration: 5--- BMC: Iteration: 6--- BMC: Iteration: 7--- BMC: Iteration: 8--- BMC: Iteration: 9--- Left "BMC limit of 10 reached"+-- BMC Cover: Iteration: 0+-- BMC Cover: Iteration: 1+-- BMC Cover: Iteration: 2+-- BMC Cover: Iteration: 3+-- BMC Cover: Iteration: 4+-- BMC Cover: Iteration: 5+-- BMC Cover: Iteration: 6+-- BMC Cover: Iteration: 7+-- BMC Cover: Iteration: 8+-- BMC Cover: Iteration: 9+-- Left "BMC Cover limit of 10 reached. Cover can't be established." -- -- As expected, there's no solution in this case. While SBV (and BMC) cannot establish -- that there is no solution at a larger depth, you can see that this will never be the
Documentation/SBV/Examples/ProofTools/Fibonacci.hs view
@@ -22,12 +22,11 @@ -- uninterpreted function. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -35,20 +34,17 @@ import Data.SBV import Data.SBV.Tools.Induction-import Data.SBV.Control -import GHC.Generics hiding (S)- -- * System state -- | System state. We simply have two components, parameterized -- over the type so we can put in both concrete and symbolic values.-data S a = S { i :: a, k :: a, m :: a, n :: a }- deriving (Show, Mergeable, Generic, Functor, Foldable, Traversable)+data S a = S { i :: a, k :: a, m :: a, n :: a } deriving (Show, Traversable, Functor, Foldable) --- | 'Fresh' instance for our state-instance Fresh IO (S SInteger) where- fresh = S <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_+-- | 'Queriable instance for our state+instance Queriable IO (S SInteger) where+ type QueryResult (S SInteger) = S Integer+ create = S <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_ -- | Encoding partial correctness of the sum algorithm. We have: --@@ -74,25 +70,17 @@ setup :: Symbolic () setup = do constrain $ fib 0 .== 0 constrain $ fib 1 .== 1-- -- This is unfortunate; but SBV currently does not support- -- adding quantified constraints in the query mode. So we- -- have to write this axiom in SMT-Lib. Note also how carefully- -- we've chosen this axiom to work with our proof!- addAxiom "fib_n" [ "(assert (forall ((x Int))"- , " (= (fib (+ x 2)) (+ (fib (+ x 1)) (fib x)))))"- ]+ constrain $ \(Forall x) -> fib (x+2) .== fib (x+1) + fib x -- Initialize variables initial :: S SInteger -> SBool initial S{i, k, m, n} = i .== 0 .&& k .== 1 .&& m .== 0 .&& n .>= 0 -- We code the algorithm almost literally in SBV notation:- trans :: S SInteger -> [S SInteger]- trans st@S{i, k, m, n} = [ite (i .< n)- st { i = i + 1, k = m + k, m = k }- st- ]+ trans :: S SInteger -> S SInteger -> SBool+ trans S{i, k, m, n} S{i = i', k = k', m = m', n = n'} = (i', k', m', n') .== ite (i .< n)+ (i+1, m+k, k, n)+ (i, k, m, n) -- No strengthenings needed for this problem! strengthenings :: [(String, S SInteger -> SBool)]@@ -106,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/ProofTools/Strengthen.hs view
@@ -22,7 +22,7 @@ -- Where @*@ stands for non-deterministic choice. For each program we try to prove that @y >= 1@ is an invariant. -- -- It turns out that the property @y >= 1@ is indeed an invariant, but is--- not inductive for either program. We proceed to strengten the invariant+-- not inductive for either program. We proceed to strengthen the invariant -- and establish it for the first case. We then note that the same strengthening -- doesn't work for the second program, and find a further strengthening to -- establish that case as well. This example follows the introductory example@@ -33,6 +33,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -40,24 +41,23 @@ import Data.SBV import Data.SBV.Tools.Induction-import Data.SBV.Control -- * System state -- | System state. We simply have two components, parameterized -- over the type so we can put in both concrete and symbolic values.-data S a = S { x :: a, y :: a }- deriving (Show, Functor, Foldable, Traversable)+data S a = S { x :: a, y :: a } deriving (Show, Traversable, Functor, Foldable) --- | 'Fresh' instance for our state-instance Fresh IO (S SInteger) where- fresh = S <$> freshVar_ <*> freshVar_+-- | 'Queriable instance for our state+instance Queriable IO (S SInteger) where+ type QueryResult (S SInteger) = S Integer+ create = S <$> freshVar_ <*> freshVar_ -- * Encoding the problem -- | We parameterize over the transition relation and the strengthenings to -- investigate various combinations.-problem :: (S SInteger -> [S SInteger]) -> [(String, S SInteger -> SBool)] -> IO (InductionResult (S Integer))+problem :: (S SInteger -> S SInteger -> SBool) -> [(String, S SInteger -> SBool)] -> IO (InductionResult (S Integer)) problem trans strengthenings = induct chatty setup initial trans strengthenings inv goal where -- Set this to True for SBV to print steps as it proceeds -- through the inductive proof@@ -68,7 +68,7 @@ -- calls to 'Data.SBV.setOption'. We do not need any for this problem, -- so we simply do nothing. setup :: Symbolic ()- setup = return ()+ setup = pure () -- Initially, @x@ and @y@ are both @1@ initial :: S SInteger -> SBool@@ -83,12 +83,12 @@ goal _ = (sTrue, sTrue) -- | The first program, coded as a transition relation:-pgm1 :: S SInteger -> [S SInteger]-pgm1 S{x, y} = [S{x = x+1, y = y+x}]+pgm1 :: S SInteger -> S SInteger -> SBool+pgm1 S{x, y} S{x = x', y = y'} = x' .== x+1 .&& y' .== y+x -- | The second program, coded as a transition relation:-pgm2 :: S SInteger -> [S SInteger]-pgm2 S{x, y} = [S{x = x+y, y = y+x}]+pgm2 :: S SInteger -> S SInteger -> SBool+pgm2 S{x, y} S{x = x', y = y'} = x' .== x+y .&& y' .== y+x -- * Examples @@ -97,7 +97,7 @@ -- >>> ex1 -- Failed while establishing consecution. -- Counter-example to inductiveness:--- S {x = -1, y = 1}+-- (S {x = -1, y = 1},S {x = 0, y = 0}) ex1 :: IO (InductionResult (S Integer)) ex1 = problem pgm1 strengthenings where strengthenings :: [(String, S SInteger -> SBool)]@@ -117,7 +117,7 @@ -- >>> ex3 -- Failed while establishing consecution. -- Counter-example to inductiveness:--- S {x = -1, y = 1}+-- (S {x = -1, y = 1},S {x = 0, y = 0}) ex3 :: IO (InductionResult (S Integer)) ex3 = problem pgm2 strengthenings where strengthenings :: [(String, S SInteger -> SBool)]@@ -128,7 +128,7 @@ -- >>> ex4 -- Failed while establishing consecution for strengthening "x >= 0". -- Counter-example to inductiveness:--- S {x = 0, y = -1}+-- (S {x = 0, y = -1},S {x = -1, y = -1}) ex4 :: IO (InductionResult (S Integer)) ex4 = problem pgm2 strengthenings where strengthenings :: [(String, S SInteger -> SBool)]@@ -139,7 +139,7 @@ -- >>> ex5 -- Failed while establishing consecution for strengthening "x >= 0". -- Counter-example to inductiveness:--- S {x = 0, y = -1}+-- (S {x = 0, y = -1},S {x = -1, y = -1}) -- -- Note how this was sufficient in 'ex2' to establish the invariant for the first -- program, but fails for the second.
Documentation/SBV/Examples/ProofTools/Sum.hs view
@@ -21,12 +21,11 @@ -- @s@ is the sum of all numbers up to and including @n@ upon termination. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -34,19 +33,17 @@ import Data.SBV import Data.SBV.Tools.Induction-import Data.SBV.Control -import GHC.Generics hiding (S)- -- * System state -- | System state. We simply have two components, parameterized -- over the type so we can put in both concrete and symbolic values.-data S a = S { s :: a, i :: a, n :: a } deriving (Show, Mergeable, Generic, Functor, Foldable, Traversable)+data S a = S { s :: a, i :: a, n :: a } deriving (Show, Traversable, Functor, Foldable) --- | 'Fresh' instance for our state-instance Fresh IO (S SInteger) where- fresh = S <$> freshVar_ <*> freshVar_ <*> freshVar_+-- | 'Queriable instance for our state+instance Queriable IO (S SInteger) where+ type QueryResult (S SInteger) = S Integer+ create = S <$> freshVar_ <*> freshVar_ <*> freshVar_ -- | Encoding partial correctness of the sum algorithm. We have: --@@ -63,18 +60,17 @@ -- calls to 'Data.SBV.setOption'. We do not need any for this problem, -- so we simply do nothing. setup :: Symbolic ()- setup = return ()+ setup = pure () -- Initially, @s@ and @i@ are both @0@. We also require @n@ to be at least @0@. initial :: S SInteger -> SBool initial S{s, i, n} = s .== 0 .&& i .== 0 .&& n .>= 0 -- We code the algorithm almost literally in SBV notation:- trans :: S SInteger -> [S SInteger]- trans st@S{s, i, n} = [ite (i .<= n)- st { s = s+i, i = i+1 }- st- ]+ trans :: S SInteger -> S SInteger -> SBool+ trans S{s, i, n} S{s = s', i = i', n = n'} = (s', i', n') .== ite (i .<= n)+ (s+i, i+1, n)+ (s , i , n) -- No strengthenings needed for this problem! strengthenings :: [(String, S SInteger -> SBool)]
Documentation/SBV/Examples/Puzzles/AOC_2021_24.hs view
@@ -12,7 +12,7 @@ -- computer with 4 integer registers (w, x, y, z), and 6 instructions (inp, add, mul, div, mod, eql). -- You are given a program (hilariously called "monad"), and your goal is to figure out what -- the maximum and minimum inputs you can provide to this program such that when it runs--- register z ends up with the value 1. Please refer to the above link for the full description.+-- register z ends up with the value 0. Please refer to the above link for the full description. -- -- While there are multiple ways to solve this problem in SBV, the solution here demonstrates -- how to turn programs in this fictional language into actual Haskell/SBV programs, i.e.,@@ -20,15 +20,21 @@ -- should provide a template for other similar programs. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NegativeLiterals #-} +#if __GLASGOW_HASKELL__ >= 913+{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-record-selectors #-}+#else {-# OPTIONS_GHC -Wall -Werror #-}+#endif module Documentation.SBV.Examples.Puzzles.AOC_2021_24 where import Prelude hiding (read, mod, div) +import Control.Monad (forM_) import Data.Maybe import qualified Data.Map.Strict as M@@ -148,14 +154,17 @@ ----------------------------------------------------------------------------------------------- -- | We simply run the 'monad' program, and specify the constraints at the end. We take a boolean--- as a parameter, choosing whether we want to minimize or maximize the model-number. We have:+-- as a parameter, choosing whether we want to minimize or maximize the model-number. Note that this+-- test takes rather long to run. We get: ----- >>> puzzle True+-- @+-- ghci> puzzle True -- Optimal model: -- Maximum model number = 96918996924991 :: Int64--- >>> puzzle False+-- ghci> puzzle False -- Optimal model: -- Minimum model number = 91811241911641 :: Int64+-- @ puzzle :: Bool -> IO () puzzle shouldMaximize = print =<< optimizeWith z3{isNonModelVar = (/= finalVar)} Lexicographic problem where finalVar | shouldMaximize = "Maximum model number"@@ -169,7 +178,7 @@ let digits = reverse inputs -- Each digit is between 1-9- ST.forM_ digits $ \d -> constrain $ d `inRange` (1, 9)+ forM_ digits $ \d -> constrain $ d `inRange` (1, 9) -- Digits spell out the model number. We minimize/maximize this value as requested: let modelNum = foldl (\sofar d -> 10 * sofar + d) 0 digits@@ -439,4 +448,4 @@ mul y x add z y -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore module "Reduce duplication" -}
Documentation/SBV/Examples/Puzzles/Birthday.hs view
@@ -7,23 +7,22 @@ -- Stability : experimental -- -- This is a formalization of the Cheryl's birthday problem, which went viral in April 2015.--- (See <http://www.nytimes.com/2015/04/15/science/a-math-problem-from-singapore-goes-viral-when-is-cheryls-birthday.html>.) -- -- Here's the puzzle: -- -- @--- Albert and Bernard just met Cheryl. “When’s your birthday?” Albert asked Cheryl.+-- Albert and Bernard just met Cheryl. "When’s your birthday?" Albert asked Cheryl. ----- Cheryl thought a second and said, “I’m not going to tell you, but I’ll give you some clues.” She wrote down a list of 10 dates:+-- Cheryl thought a second and said, "I’m not going to tell you, but I’ll give you some clues." She wrote down a list of 10 dates: -- -- May 15, May 16, May 19 -- June 17, June 18 -- July 14, July 16 -- August 14, August 15, August 17 ----- “My birthday is one of these,” she said.+-- "My birthday is one of these," she said. ----- Then Cheryl whispered in Albert’s ear the month — and only the month — of her birthday. To Bernard, she whispered the day, and only the day. +-- Then Cheryl whispered in Albert’s ear the month — and only the month — of her birthday. To Bernard, she whispered the day, and only the day. -- “Can you figure it out now?” she asked Albert. -- -- Albert: I don’t know when your birthday is, but I know Bernard doesn’t know, either.@@ -36,8 +35,12 @@ -- NB. Thanks to Amit Goel for suggesting the formalization strategy used in here. ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wall -Werror #-}+ module Documentation.SBV.Examples.Puzzles.Birthday where import Data.SBV@@ -46,45 +49,30 @@ -- * Types and values ----------------------------------------------------------------------------------------------- --- | Represent month by 8-bit words; We can also use an uninterpreted type, but numbers work well here.-type Month = SWord8---- | Represent day by 8-bit words; Again, an uninterpreted type would work as well.-type Day = SWord8---- | Months referenced in the problem.-may, june, july, august :: SWord8-[may, june, july, august] = [5, 6, 7, 8]---------------------------------------------------------------------------------------------------- * Helper predicates------------------------------------------------------------------------------------------------+-- | Months. We only put in the months involved in the puzzle for simplicity+data Month = May | Jun | Jul | Aug --- | Check that a given month/day combo is a possible birth-date.-valid :: Month -> Day -> SBool-valid month day = (month, day) `sElem` candidates- where candidates :: [(Month, Day)]- candidates = [ ( may, 15), ( may, 16), ( may, 19)- , ( june, 17), ( june, 18)- , ( july, 14), ( july, 16)- , (august, 14), (august, 15), (august, 17)- ]+-- | Days. Again, only the ones mentioned in the puzzle.+data Day = D14 | D15 | D16 | D17 | D18 | D19 --- | Assert that the given function holds for one of the possible days.-existsDay :: (Day -> SBool) -> SBool-existsDay f = sAny (f . literal) [14 .. 19]+mkSymbolic [''Month]+mkSymbolic [''Day] --- | Assert that the given function holds for all of the possible days.-forallDay :: (Day -> SBool) -> SBool-forallDay f = sAll (f . literal) [14 .. 19]+-- | Represent the birthday as a record+data Birthday = BD SMonth SDay --- | Assert that the given function holds for one of the possible months.-existsMonth :: (Month -> SBool) -> SBool-existsMonth f = sAny f [may .. august]+-- | Make a valid symbolic birthday+mkBirthday :: Symbolic Birthday+mkBirthday = do b <- BD <$> free "birthMonth" <*> free "birthDay"+ constrain $ valid b+ pure b --- | Assert that the given function holds for all of the possible months.-forallMonth :: (Month -> SBool) -> SBool-forallMonth f = sAll f [may .. august]+-- | Is this a valid birthday? i.e., one that was declared by Cheryl to be a possibility.+valid :: Birthday -> SBool+valid (BD m d) = (m .== sMay .=> d `sElem` [sD15, sD16, sD19])+ .&& (m .== sJun .=> d `sElem` [sD17, sD18])+ .&& (m .== sJul .=> d `sElem` [sD14, sD16])+ .&& (m .== sAug .=> d `sElem` [sD14, sD15, sD17]) ----------------------------------------------------------------------------------------------- -- * The puzzle@@ -99,49 +87,43 @@ -- is a unique solution. Thanks to Lee for pointing this out! In fact, it is instructive to -- assert the conversation line-by-line, and see how the search-space gets reduced in each -- step.-puzzle :: Predicate-puzzle = do birthDay <- sbvExists "birthDay"- birthMonth <- sbvExists "birthMonth"+puzzle :: ConstraintSet+puzzle = do BD birthMonth birthDay <- mkBirthday + let ok = sAll valid+ qe qb = quantifiedBool qb+ -- Albert: I do not know- let a1 m = existsDay $ \d1 -> existsDay $ \d2 ->- d1 ./= d2 .&& valid m d1 .&& valid m d2+ let a1 m = qe $ \(Exists d1) (Exists d2) -> ok [BD m d1, BD m d2] .&& d1 ./= d2+ constrain $ a1 birthMonth -- Albert: I know that Bernard doesn't know- let a2 m = forallDay $ \d -> valid m d .=>- existsMonth (\m1 -> existsMonth $ \m2 ->- m1 ./= m2 .&& valid m1 d .&& valid m2 d)+ let a2 m = qe $ \(Forall d) -> ok [BD m d] .=> qe (\(Exists m1) (Exists m2) -> ok [BD m1 d, BD m2 d] .&& m1 ./= m2)+ constrain $ a2 birthMonth -- Bernard: I did not know- let b1 d = existsMonth $ \m1 -> existsMonth $ \m2 ->- m1 ./= m2 .&& valid m1 d .&& valid m2 d+ let b1 d = qe $ \(Exists m1) (Exists m2) -> ok [BD m1 d, BD m2 d] .&& m1 ./= m2+ constrain $ b1 birthDay -- Bernard: But now I know- let b2p m d = valid m d .&& a1 m .&& a2 m- b2 d = forallMonth $ \m1 -> forallMonth $ \m2 ->- (b2p m1 d .&& b2p m2 d) .=> m1 .== m2+ let b2p m d = ok [BD m d] .&& a1 m .&& a2 m+ b2 d = qe $ \(Forall m1) (Forall m2) -> (b2p m1 d .&& b2p m2 d) .=> m1 .== m2+ constrain $ b2 birthDay -- Albert: Now I know too- let a3p m d = valid m d .&& a1 m .&& a2 m .&& b1 d .&& b2 d- a3 m = forallDay $ \d1 -> forallDay $ \d2 ->- (a3p m d1 .&& a3p m d2) .=> d1 .== d2-- -- Assert all the statements made:- constrain $ a1 birthMonth- constrain $ a2 birthMonth- constrain $ b1 birthDay- constrain $ b2 birthDay+ let a3p m d = ok [BD m d] .&& a1 m .&& a2 m .&& b1 d .&& b2 d+ a3 m = \(Forall d1) (Forall d2) -> (a3p m d1 .&& a3p m d2) .=> d1 .== d2 constrain $ a3 birthMonth - -- Find a valid birth-day that satisfies the above constraints:- return $ valid birthMonth birthDay- -- | Find all solutions to the birthday problem. We have: -- -- >>> cheryl -- Solution #1:--- birthDay = 16 :: Word8--- birthMonth = 7 :: Word8+-- birthMonth = Jul :: Month+-- birthDay = D16 :: Day -- This is the only solution. cheryl :: IO () cheryl = print =<< allSat puzzle++{- HLint ignore puzzle "Redundant lambda" -}+{- HLint ignore puzzle "Eta reduce" -}
Documentation/SBV/Examples/Puzzles/Coins.hs view
@@ -18,10 +18,10 @@ -- friend: No. -- you: How about a quarter? -- friend: Nope, and before you ask I cant make change for a dime or nickel either.--- you: Really? and these six coins are all US government coins currently in production? +-- you: Really? and these six coins are all US government coins currently in production? -- friend: Yes. -- you: Well can you just put your coins into the vending machine and buy me a candy bar, and I'll pay you back?--- friend: Sorry, I would like to but I cant with the coins I have.+-- friend: Sorry, I would like to but I can't with the coins I have. -- What coins are your friend holding? -- @ --@@ -42,9 +42,9 @@ -- | Create a coin. The argument Int argument just used for naming the coin. Note that -- we constrain the value to be one of the valid U.S. coin values as we create it. mkCoin :: Int -> Symbolic Coin-mkCoin i = do c <- sbvExists $ 'c' : show i+mkCoin i = do c <- free $ 'c' : show i constrain $ sAny (.== c) [1, 5, 10, 25, 50, 100]- return c+ pure c -- | Return all combinations of a sequence of values. combinations :: [a] -> [[a]]@@ -94,12 +94,15 @@ puzzle :: IO SatResult puzzle = sat $ do cs <- mapM mkCoin [1..6]+ -- Assert each of the constraints for all combinations that has -- at least two coins (to make change) mapM_ constrain [c s | s <- combinations cs, length s >= 2, c <- [c1, c2, c3, c4, c5, c6]]+ -- the following constraint is not necessary for solving the puzzle -- however, it makes sure that the solution comes in decreasing value of coins, -- thus allowing the above test to succeed regardless of the solver used.- constrain $ sAnd $ zipWith (.>=) cs (tail cs)+ constrain $ sAnd $ zipWith (.>=) cs (drop 1 cs)+ -- assert that the sum must be 115 cents.- return $ sum cs .== 115+ pure $ sum cs .== 115
Documentation/SBV/Examples/Puzzles/Counts.hs view
@@ -33,7 +33,7 @@ import Data.List (sortOn) -- | We will assume each number can be represented by an 8-bit word, i.e., can be at most 128.-type Count = SWord8+type Count = SWord8 -- | Given a number, increment the count array depending on the digits of the number count :: Count -> [Count] -> [Count]@@ -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@@ -64,7 +64,7 @@ -- In this sentence, the number of occurrences of 0 is 1, of 1 is 7, of 2 is 3, of 3 is 2, of 4 is 1, of 5 is 1, of 6 is 1, of 7 is 2, of 8 is 1, of 9 is 1. -- Found: 2 solution(s). counts :: IO ()-counts = do res <- allSat $ puzzle `fmap` mkExistVars 10+counts = do res <- allSat $ puzzle `fmap` mkFreeVars 10 cnt <- displayModels (sortOn show) disp res putStrLn $ "Found: " ++ show cnt ++ " solution(s)." where disp n (_, s) = do putStrLn $ "Solution #" ++ show n@@ -83,4 +83,4 @@ ++ ", of 8 is " ++ show (ns !! 8) ++ ", of 9 is " ++ show (ns !! 9) ++ "."-{-# ANN counts ("HLint: ignore Use head" :: String) #-}+{- HLint ignore counts "Use head" -}
+ Documentation/SBV/Examples/Puzzles/DieHard.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Puzzles.DieHard+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Solves the die-hard riddle: In the movie Die Hard 3, the heroes must obtain+-- exactly 4 gallons of water using a 5 gallon jug, a 3 gallon jug, and a water faucet.+-- We use a bounded-model-checking style search to find a solution.+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Puzzles.DieHard where++import Data.SBV+import Data.SBV.Tools.BMC++-- | Possible actions+data Action = Initial | FillBig | FillSmall | EmptyBig | EmptySmall | BigToSmall | SmallToBig+ deriving Show++mkSymbolic [''Action]++-- | We represent the state with two quantities, the amount of water in each jug. The+-- action is how we got into this state.+data State a b = State { big :: a+ , small :: a+ , action :: b+ }++-- | Show instance+instance (Show a, Show b) => Show (State a b) where+ show s = "Big: " ++ show s.big ++ ", Small: " ++ show s.small ++ " (" ++ show s.action ++ ")"++-- | Fully symbolic state+type SState = State SInteger SAction++-- | Fully concrete state+type CState = State Integer Action++-- | 'Queriable' instance needed for running bmc+instance Queriable IO SState where+ type QueryResult SState = CState++ create = State <$> freshVar_ <*> freshVar_ <*> freshVar_+ project (State b s a) = State <$> project b <*> project s <*> project a+ embed (State b s a) = State <$> embed b <*> embed s <*> embed a++-- | Solve the problem using a BMC search. We have:+--+-- >>> dieHard+-- BMC Cover: Iteration: 0+-- BMC Cover: Iteration: 1+-- BMC Cover: Iteration: 2+-- BMC Cover: Iteration: 3+-- BMC Cover: Iteration: 4+-- BMC Cover: Iteration: 5+-- BMC Cover: Iteration: 6+-- BMC Cover: Satisfying state found at iteration 6+-- Big: 0, Small: 0 (Initial)+-- Big: 5, Small: 0 (FillBig)+-- Big: 2, Small: 3 (BigToSmall)+-- Big: 2, Small: 0 (EmptySmall)+-- Big: 0, Small: 2 (BigToSmall)+-- Big: 5, Small: 2 (FillBig)+-- Big: 4, Small: 3 (BigToSmall)+dieHard :: IO ()+dieHard = display =<< bmcCover Nothing True (pure ()) initial trans goal+ where -- we start from empty jugs, and try to reach a state where big has 4 gallons+ initial State{big, small, action} = (big, small, action) .== (0, 0, sInitial)+ goal State{big} = big .== 4++ -- Valid actions as a transition relation:+ trans :: SState -> SState -> SBool+ trans fromState toState = go actions+ where go [] = sFalse+ go ((act, f) : rest) = ite (toState.action .== act) (f fromState `matches` toState) (go rest)++ matches :: SState -> SState -> SBool+ p `matches` q = p.big .== q.big .&& p.small .== q.small++ infix 1 |=>+ a |=> f = (a, f)++ actions = [ sFillBig |=> \st -> st{big = 5}+ , sFillSmall |=> \st -> st{small = 3}++ , sEmptyBig |=> \st -> st{big = 0}+ , sEmptySmall |=> \st -> st{small = 0}++ , sBigToSmall |=> \st -> let space = 3 - st.small+ xfer = space `smin` st.big+ in st{big = st.big - xfer, small = st.small + xfer}++ , sSmallToBig |=> \st -> let space = 5 - st.big+ xfer = space `smin` st.small+ in st{big = st.big + xfer, small = st.small - xfer}+ ]++ display :: Either String (Int, [CState]) -> IO ()+ display (Left e) = error e+ display (Right (_, as)) = mapM_ print as
Documentation/SBV/Examples/Puzzles/Drinker.hs view
@@ -14,24 +14,9 @@ -- @ -- ∃x : P. D(x) -> ∀y : P. D(y) -- @------ In SBV, quantifiers are allowed, but you need to put the formula into prenex normal form manually. See--- <http://en.wikipedia.org/wiki/Prenex_normal_form> for details. (Note that you do not need to do skolemization--- by hand, though SBV will do that for you automatically as well as it casts the problem into an SMT query.)--- If we transform the above to prenex form, we get:------ @--- ∃x : P. ∀y : P. D(x) -> D(y)--- @------ In this file, we show two different ways of proving the above in SBV; one using the monadic style,--- and the other using the expression style. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -43,7 +28,7 @@ data P -- | Make 'P' an uninterpreted sort, introducing the type 'SP' for its symbolic version-mkUninterpretedSort ''P+mkSymbolic [''P] -- | Declare the uninterpret function 'd', standing for drinking. For each person, this function -- assigns whether they are drinking; but is otherwise completely uninterpreted. (i.e., our theorem@@ -51,23 +36,9 @@ d :: SP -> SBool d = uninterpret "D" --- | Monadic formulation. In this style, we use the 'sbvExists' and 'sbvForall' constructs to create--- our quantified variables. We have:------ >>> drinker1--- Q.E.D.-drinker1 :: IO ThmResult-drinker1 = prove $ do x <- sbvExists "x"- y <- sbvForall "y"-- pure $ d x .=> d y---- | Expression level formulation. In this style, we use the 'existential' and 'universal' functions instead.--- We have:+-- | Formulate the drinkers paradox, if some one is drinking, then everyone is! ----- >>> drinker2+-- >>> drinker -- Q.E.D.-drinker2 :: IO ThmResult-drinker2 = prove $ existential ["x"] $ \x ->- universal ["y"] $ \y ->- d x .=> d y+drinker :: IO ThmResult+drinker = prove $ \(Exists x) (Forall y) -> d x .=> d y
Documentation/SBV/Examples/Puzzles/Euler185.hs view
@@ -33,8 +33,8 @@ -- generated by zipping the alleged solution with each guess, and making sure the -- number of matching digits match what's given in the problem statement. euler185 :: Symbolic SBool-euler185 = do soln <- mkExistVars 16- return $ sAll digit soln .&& sAnd (map (genConstr soln) guesses)+euler185 = do soln <- mkFreeVars 16+ pure $ sAll digit soln .&& sAnd (map (genConstr soln) guesses) where genConstr a (b, c) = sum (zipWith eq a b) .== (c :: SWord8) digit x = (x :: SWord8) .>= 0 .&& x .<= 9 eq x y = ite (x .== fromIntegral (ord y - ord '0')) 1 0
Documentation/SBV/Examples/Puzzles/Fish.hs view
@@ -27,14 +27,13 @@ -- Who owns the fish? ------------------------------------------------------------------------------ -{-# OPTIONS_GHC -Wall -Werror #-}--{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wall -Werror #-}+ module Documentation.SBV.Examples.Puzzles.Fish where import Data.SBV@@ -43,31 +42,32 @@ data Color = Red | Green | White | Yellow | Blue -- | Make 'Color' a symbolic value.-mkSymbolicEnumeration ''Color+mkSymbolic [''Color] -- | Nationalities of the occupants data Nationality = Briton | Dane | Swede | Norwegian | German+ deriving Show -- | Make 'Nationality' a symbolic value.-mkSymbolicEnumeration ''Nationality+mkSymbolic [''Nationality] -- | Beverage choices data Beverage = Tea | Coffee | Milk | Beer | Water -- | Make 'Beverage' a symbolic value.-mkSymbolicEnumeration ''Beverage+mkSymbolic [''Beverage] -- | Pets they keep data Pet = Dog | Horse | Cat | Bird | Fish -- | Make 'Pet' a symbolic value.-mkSymbolicEnumeration ''Pet+mkSymbolic [''Pet] -- | Sports they engage in data Sport = Football | Baseball | Volleyball | Hockey | Tennis -- | Make 'Sport' a symbolic value.-mkSymbolicEnumeration ''Sport+mkSymbolic [''Sport] -- | We have: --@@ -76,10 +76,10 @@ -- -- It's not hard to modify this program to grab the values of all the assignments, i.e., the full -- solution to the puzzle. We leave that as an exercise to the interested reader!--- NB. We use the 'satTrackUFs' configuration to indicate that the uninterpreted function+-- NB. We use the 'allSatTrackUFs' configuration to indicate that the uninterpreted function -- changes do not matter for generating different values. All we care is that the fishOwner changes! fishOwner :: IO ()-fishOwner = do vs <- getModelValues "fishOwner" `fmap` allSatWith z3{satTrackUFs = False} puzzle+fishOwner = do vs <- getModelValues "fishOwner" `fmap` allSatWith z3{allSatTrackUFs = False} puzzle case vs of [Just (v::Nationality)] -> print v [] -> error "no solution"
Documentation/SBV/Examples/Puzzles/Garden.hs view
@@ -28,24 +28,21 @@ -- case, the second student would be right. ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Puzzles.Garden where import Data.SBV-import Data.List(isSuffixOf) -- | Colors of the flowers data Color = Red | Yellow | Blue -- | Make 'Color' a symbolic value.-mkSymbolicEnumeration ''Color+mkSymbolic [''Color] -- | Represent flowers by symbolic integers type Flower = SInteger@@ -66,46 +63,29 @@ count c fs = sum [ite (col f .== literal c) 1 0 | f <- fs] -- | Smullyan's puzzle.-puzzle :: Goal+puzzle :: ConstraintSet puzzle = do n <- sInteger "N" let valid = validPick n - -- Declare three existential flowers. We declare these with- -- _modelIgnore suffix, because we don't care different assignments- -- to them to be a different model. See 'isNonModelVar' below.- ef1 <- sbvExists "ef1_modelIgnore"- ef2 <- sbvExists "ef2_modelIgnore"- ef3 <- sbvExists "ef3_modelIgnore"-- -- Declare three universal flowers to aid in encoding the- -- statements made by students.- af1 <- sbvForall "af1"- af2 <- sbvForall "af2"- af3 <- sbvForall "af3"- -- Each color is represented:- constrain $ valid ef1 ef2 ef3- constrain $ map col [ef1, ef2, ef3] .== [sRed, sYellow, sBlue]-- -- Pick any three, at least one is Red- constrain $ valid af1 af2 af3 .=> count Red [af1, af2, af3] .>= 1-- -- Pick any three, at least one is Yellow- constrain $ valid af1 af2 af3 .=> count Yellow [af1, af2, af3] .>= 1+ constrain $ \(Exists ef1) (Exists ef2) (Exists ef3) ->+ valid ef1 ef2 ef3 .&& map col [ef1, ef2, ef3] .== [sRed, sYellow, sBlue] - -- Pick any three, at least one is Blue- constrain $ valid af1 af2 af3 .=> count Blue [af1, af2, af3] .>= 1+ -- Pick any three, at least one is Red, one is Yellow, one is Blue+ constrain $ \(Forall af1) (Forall af2) (Forall af3) ->+ let atLeastOne c = count c [af1, af2, af3] .>= 1+ in valid af1 af2 af3 .=> atLeastOne Red .&& atLeastOne Yellow .&& atLeastOne Blue -- | Solve the puzzle. We have: -- -- >>> flowerCount -- Solution #1: -- N = 3 :: Integer--- This is the only solution. (Unique up to prefix existentials.)+-- This is the only solution. -- -- So, a garden with 3 flowers is the only solution. (Note that we simply skip -- over the prefix existentials and the assignments to uninterpreted function 'col' -- for model purposes here, as they don't represent a different solution.) flowerCount :: IO ()-flowerCount = print =<< allSatWith z3{satTrackUFs = False, isNonModelVar = ("_modelIgnore" `isSuffixOf`)} puzzle+flowerCount = print =<< allSatWith z3{allSatTrackUFs=False} puzzle
Documentation/SBV/Examples/Puzzles/HexPuzzle.hs view
@@ -6,9 +6,6 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- A solution to the hexagon solver puzzle: <http://www5.cadence.com/2018ClubVQuiz_LP.html>--- In case the above URL goes dead, here's an ASCII rendering of the problem.--- -- We're given a board, with 19 hexagon cells. The cells are arranged as follows: -- -- @@@ -39,11 +36,9 @@ -- to the final one. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -52,11 +47,13 @@ import Data.SBV import Data.SBV.Control +import Data.Proxy+ -- | Colors we're allowed data Color = Black | Blue | Green | Red -- | Make 'Color' a symbolic value.-mkSymbolicEnumeration ''Color+mkSymbolic [''Color] -- | Use 8-bit words for button numbers, even though we only have 1 to 19. type Button = Word8@@ -81,13 +78,14 @@ $ ite (b .== 15) (rot [10, 11, 16, 19, 18, 14]) g where rot xs = foldr (\(i, c) a -> writeArray a (literal i) c) g (zip new cur) where cur = map (readArray g . literal) xs- new = tail xs ++ [head xs]+ new = drop 1 xs ++ take 1 xs -- | Iteratively search at increasing depths of button-presses to see if we can -- transform from the initial board position to a final board position. search :: [Color] -> [Color] -> IO ()-search initial final = runSMT $ do emptyGrid :: Grid <- newArray "emptyGrid" (Just sBlack)- let initGrid = foldr (\(i, c) a -> writeArray a (literal i) (literal c)) emptyGrid (zip [1..] initial)+search initial final = runSMT $ do registerType (Proxy @SColor)+ let emptyGrid = constArray sBlack+ initGrid = foldr (\(i, c) a -> writeArray a (literal i) (literal c)) emptyGrid (zip [1..] initial) query $ loop (0 :: Int) initGrid [] where loop i g sofar = do io $ putStrLn $ "Searching at depth: " ++ show i@@ -133,8 +131,8 @@ -- Searching at depth: 4 -- Searching at depth: 5 -- Searching at depth: 6--- Found: [10,10,11,9,14,6] -- Found: [10,10,9,11,14,6]+-- Found: [10,10,11,9,14,6] -- There are no more solutions. example :: IO () example = search initBoard finalBoard
@@ -0,0 +1,134 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Puzzles.KnightsAndKnaves+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- From Raymond Smullyan: On a fictional island, all inhabitants are either knights,+-- who always tell the truth, or knaves, who always lie. John and Bill are residents+-- of the island of knights and knaves. John and Bill make several utterances.+-- Determine which one is a knave or a knight, depending on their answers.+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Documentation.SBV.Examples.Puzzles.KnightsAndKnaves where++import Prelude hiding (and, not)++import Data.SBV+import Data.SBV.Control++-- | Inhabitants of the island, as an uninterpreted sort+data Inhabitant+mkSymbolic [''Inhabitant]++-- | Each inhabitant is either a knave or a knight+data Identity = Knave | Knight++mkSymbolic [''Identity]++-- | Statements are utterances which are either true or false+data Statement = Truth | Falsity++mkSymbolic [''Statement]++-- | John is an inhabitant of the island.+john :: SInhabitant+john = uninterpret "John"++-- | Bill is an inhabitant of the island.+bill :: SInhabitant+bill = uninterpret "Bill"++-- | The connective 'is' makes a statement about an inhabitant regarding his/her identity.+is :: SInhabitant -> SIdentity -> SStatement+is = uninterpret "is"++-- | The connective 'says' makes a predicate from what an inhabitant states+says :: SInhabitant -> SStatement -> SBool+says = uninterpret "says"++-- | The connective 'holds' is will be true if the statement is true+holds :: SStatement -> SBool+holds = uninterpret "holds"++-- | The connective 'and' creates the conjunction of two statements+and :: SStatement -> SStatement -> SStatement+and = uninterpret "AND"++-- | The connective 'not' negates a statement+not :: SStatement -> SStatement+not = uninterpret "NOT"++-- | The connective 'iff' creates a statement that equates the truth values of its argument statements+iff :: SStatement -> SStatement -> SStatement+iff = uninterpret "IFF"++-- | Encode Smullyan's puzzle. We have:+--+-- >>> puzzle+-- Question 1.+-- John says, We are both knaves+-- Then, John is: Knave+-- And, Bill is: Knight+-- Question 2.+-- John says If (and only if) Bill is a knave, then I am a knave.+-- Bill says We are of different kinds.+-- Then, John is: Knave+-- And, Bill is: Knight+puzzle :: IO ()+puzzle = runSMT $ do++ -- truth holds, falsity doesn't+ constrain $ holds sTruth+ constrain $ sNot $ holds sFalsity++ -- Each inhabitant is either a knave or a knight+ constrain $ \(Forall x) -> holds (is x sKnave) .<+> holds (is x sKnight)++ -- If x is a knave and he says something, then that statement is false+ constrain $ \(Forall x) (Forall y) -> holds (is x sKnave) .=> (says x y .=> sNot (holds y))++ -- If x is a knight and he says something, then that statement is true+ constrain $ \(Forall x) (Forall y) -> holds (is x sKnight) .=> (says x y .=> holds y)++ -- The meaning of conjunction: It holds whenever both statements hold+ constrain $ \(Forall x) (Forall y) -> holds (and x y) .== (holds x .&& holds y)++ -- The meaning of negation: It holds when the original doesn't+ constrain $ \(Forall x) -> holds (not x) .== sNot (holds x)++ -- The meaning of iff: both statements hold or don't hold at the same time+ constrain $ \(Forall x) (Forall y) -> holds (iff x y) .== (holds x .== holds y)++ query $ do++ -- helper to get the responses out+ let checkStatus = do cs <- checkSat+ case cs of+ Sat -> do jk <- getValue (holds (is john sKnight))+ bk <- getValue (holds (is bill sKnight))+ io $ putStrLn $ " Then, John is: " ++ if jk then "Knight" else "Knave"+ io $ putStrLn $ " And, Bill is: " ++ if bk then "Knight" else "Knave"+ _ -> error $ "Solver said: " ++ show cs++ question w q = inNewAssertionStack $ do+ io $ putStrLn w+ q >> checkStatus++ -- Question 1+ question "Question 1." $ do+ io $ putStrLn " John says, We are both knaves"+ constrain $ says john (and (is john sKnave) (is bill sKnave))++ -- Question 2+ question "Question 2." $ do+ io $ putStrLn " John says If (and only if) Bill is a knave, then I am a knave."+ io $ putStrLn " Bill says We are of different kinds."+ constrain $ says john (iff (is bill sKnave) (is john sKnave))+ constrain $ says bill (not (iff (is bill sKnave) (is john sKnave)))
Documentation/SBV/Examples/Puzzles/MagicSquare.hs view
@@ -34,7 +34,7 @@ -- | Get the diagonal of a square matrix diag :: [[a]] -> [a]-diag ((a:_):rs) = a : diag (map tail rs)+diag ((a:_):rs) = a : diag (map (drop 1) rs) diag _ = [] -- | Test if a given board is a magic square@@ -58,7 +58,7 @@ magic n | n < 0 = putStrLn $ "n must be non-negative, received: " ++ show n | True = do putStrLn $ "Finding all " ++ show n ++ "-magic squares.."- res <- allSat $ (isMagic . chunk n) `fmap` mkExistVars n2+ res <- allSat $ (isMagic . chunk n) `fmap` mkFreeVars n2 cnt <- displayModels id disp res putStrLn $ "Found: " ++ show cnt ++ " solution(s)." where n2 = n * n
Documentation/SBV/Examples/Puzzles/Murder.hs view
@@ -20,12 +20,11 @@ -- @ ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Puzzles.Murder where@@ -33,21 +32,24 @@ import Data.Char import Data.List -import Data.SBV+import Data.SBV hiding (some) import Data.SBV.Control -- | Locations data Location = Bar | Beach | Alone+ deriving Show -- | Sexes-data Sex = Male | Female+data Sex = Male | Female+ deriving Show -- | Roles data Role = Victim | Killer | Bystander+ deriving Show -mkSymbolicEnumeration ''Location-mkSymbolicEnumeration ''Sex-mkSymbolicEnumeration ''Role+mkSymbolic [''Location]+mkSymbolic [''Sex]+mkSymbolic [''Role] -- | A person has a name, age, together with location and sex. -- We parameterize over a function so we can use this struct@@ -88,8 +90,8 @@ -- Alice 48 Bar Female Bystander -- Husband 47 Beach Male Killer -- Brother 48 Beach Male Victim--- Daughter 20 Alone Female Bystander--- Son 21 Bar Male Bystander+-- Daughter 21 Alone Female Bystander+-- Son 20 Bar Male Bystander -- -- That is, Alice's brother was the victim and Alice's husband was the killer. killer :: IO ()@@ -137,8 +139,8 @@ let ifVictim p = role p .== sVictim ifKiller p = role p .== sKiller - every f = sAnd (map f chars)- some f = sOr (map f chars)+ every f = sAll f chars+ some f = sAny f chars -- A man and a woman were together in a bar at the time of the murder. constrain $ some $ \c -> sex c .== sFemale .&& location c .== sBar@@ -176,3 +178,5 @@ s <- getPerson son pure [a, h, b, d, s] _ -> error $ "Solver said: " ++ show cs++{- HLint ignore getPerson "Functor law" -}
Documentation/SBV/Examples/Puzzles/NQueens.hs view
@@ -35,7 +35,7 @@ nQueens n | n < 0 = putStrLn $ "n must be non-negative, received: " ++ show n | True = do putStrLn $ "Finding all " ++ show n ++ "-queens solutions.."- res <- allSat $ isValid n `fmap` mkExistVars n+ res <- allSat $ isValid n `fmap` mkFreeVars n cnt <- displayModels id disp res putStrLn $ "Found: " ++ show cnt ++ " solution(s)." where disp i (_, s) = do putStr $ "Solution #" ++ show i ++ ": "
+ Documentation/SBV/Examples/Puzzles/Newspaper.hs view
@@ -0,0 +1,104 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Puzzles.Newspaper+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Solution to the following puzzle (found at <http://hugopeters.me/posts/15>)+-- which contains 10 questions:+--+-- @+-- a. What is sum of all integer answers?+-- b. How many boolean answers are true?+-- c. Is a the largest number?+-- d. How many integers are equal to me?+-- e. Are all integers positive?+-- f. What is the average of all integers?+-- g. Is d strictly larger than b?+-- h. What is a / h?+-- i. Is f equal to d - b - h * d?+-- j. What is the answer to this question?+-- @+--+-- Note that @j@ is ambiguous: It can be a boolean or an integer. We use+-- the solver to decide what its type should be, so that all the other+-- answers are consistent with that decision.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Puzzles.Newspaper where++import Data.SBV+import Data.SBV.Either++-- | Encoding of the constraints.+puzzle :: Symbolic ()+puzzle = do+ a <- sInteger "a"+ b <- sInteger "b"+ c <- sBool "c"+ d <- sInteger "d"+ e <- sBool "e"+ f <- sInteger "f"+ g <- sBool "g"+ h <- sInteger "h"+ i <- sBool "i"+ j <- sEither "j"++ jIsInt <- sBool "jIsInt"++ let ints intj = [a, b, d, f, h] ++ [fromRight j | intj]+ bools intj = [c, e, g, i] ++ [fromLeft j | not intj]++ choice fn = ite jIsInt (fn True) (fn False)++ -- a. What is sum of all integer answers?+ constrain $ a .== choice (sum . ints)++ -- b. How many boolean answers are true?+ constrain $ b .== choice (sum . map oneIf . bools)++ -- c. Is a the largest number?+ constrain $ c .== (a .== choice (foldr1 smax . ints))++ -- d. How many integers are equal to me?+ constrain $ d .== choice (sum . map (oneIf . (d .==)) . ints)++ -- e. Are all integers positive?+ constrain $ e .== choice (sAll (.> 0) . ints)++ -- f. What is the average of all integers?+ constrain $ f * choice (literal . toInteger . length . ints) .== choice (sum . ints)++ -- g. is d strictly larger than b?+ constrain $ g .== (d .> b)++ -- h. what is a / h?+ constrain $ h * h .== a++ -- i. is f equal to d - b - h * d?+ constrain $ i .== (f .== d - b - h * d)++ -- j. what is the answer to this question?+ constrain $ ite jIsInt (isRight j) (isLeft j)++-- | Print all solutions to the problem. We have:+--+-- >>> solvePuzzle+-- Solution #1:+-- a = 144 :: Integer+-- b = 2 :: Integer+-- c = True :: Bool+-- d = 2 :: Integer+-- e = False :: Bool+-- f = 24 :: Integer+-- g = False :: Bool+-- h = -12 :: Integer+-- i = True :: Bool+-- j = Right (-16) :: Either Bool Integer+-- This is the only solution.+solvePuzzle :: IO ()+solvePuzzle = print =<< allSatWith z3{isNonModelVar = (== "jIsInt")} puzzle
+ Documentation/SBV/Examples/Puzzles/Orangutans.hs view
@@ -0,0 +1,117 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Puzzles.Orangutans+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Based on <http://github.com/goldfirere/video-resources/blob/main/2022-08-12-java/Haskell.hs>+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedRecordDot #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Puzzles.Orangutans where++import Data.SBV+import GHC.Generics (Generic)++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+#endif++-- | Orangutans in the puzzle.+data Orangutan = Merah | Ofallo | Quirrel | Shamir+ deriving (Show, Enum, Bounded)++-- | Handlers for each orangutan.+data Handler = Dolly | Eva | Francine | Gracie++-- | Location for each orangutan.+data Location = Ambalat | Basahan | Kendisi | Tarakan++mkSymbolic [''Orangutan]+mkSymbolic [''Handler]+mkSymbolic [''Location]++-- | An assignment is solution to the puzzle+data Assignment = MkAssignment { orangutan :: SOrangutan+ , handler :: SHandler+ , location :: SLocation+ , age :: SInteger+ }+ deriving (Generic, Mergeable)++-- | Create a symbolic assignment, using symbolic fields.+mkSym :: Orangutan -> Symbolic Assignment+mkSym o = do let h = show o ++ ".handler"+ l = show o ++ ".location"+ a = show o ++ ".age"+ s <- MkAssignment (literal o) <$> free h <*> free l <*> free a+ constrain $ s.age `sElem` [4, 7, 10, 13]+ pure s++-- | We get:+--+-- >>> allSat puzzle+-- Solution #1:+-- Merah.handler = Gracie :: Handler+-- Merah.location = Tarakan :: Location+-- Merah.age = 10 :: Integer+-- Ofallo.handler = Eva :: Handler+-- Ofallo.location = Kendisi :: Location+-- Ofallo.age = 13 :: Integer+-- Quirrel.handler = Dolly :: Handler+-- Quirrel.location = Basahan :: Location+-- Quirrel.age = 4 :: Integer+-- Shamir.handler = Francine :: Handler+-- Shamir.location = Ambalat :: Location+-- Shamir.age = 7 :: Integer+-- This is the only solution.+puzzle :: ConstraintSet+puzzle = do+ solution@[_merah, ofallo, quirrel, shamir] <- mapM mkSym [minBound .. maxBound]++ let find f = foldr1 (\a1 a2 -> ite (f a1) a1 a2) solution++ -- 0. All are different in terms of handlers, locations, and ages+ constrain $ distinct (map (.handler) solution)+ constrain $ distinct (map (.location) solution)+ constrain $ distinct (map (.age) solution)++ -- 1. Shamir is 7 years old.+ constrain $ shamir.age .== 7++ -- 2. Shamir came from Ambalat.+ constrain $ shamir.location .== sAmbalat++ -- 3. Quirrel is younger than the ape that was found in Tarakan.+ let tarakan = find (\a -> a.location .== sTarakan)+ constrain $ quirrel.age .< tarakan.age++ -- 4. Of Ofallo and the ape that was found in Tarakan, one is cared for by Gracie and the other is 13 years old.+ let clue4 a1 a2 = a1.handler .== sGracie .&& a2.age .== 13+ constrain $ clue4 ofallo tarakan .|| clue4 tarakan ofallo+ constrain $ sOfallo ./= tarakan.orangutan++ -- 5. The animal that was found in Ambalat is either the 10-year-old or the animal Francine works with.+ let ambalat = find (\a -> a.location .== sAmbalat)+ constrain $ ambalat.age .== 10 .|| ambalat.handler .== sFrancine++ -- 6. Ofallo isn't 10 years old.+ constrain $ ofallo.age ./= 10++ -- 7. The ape that was found in Kendisi is older than the ape Dolly works with.+ let kendisi = find (\a -> a.location .== sKendisi)+ let dolly = find (\a -> a.handler .== sDolly)+ constrain $ kendisi.age .> dolly.age
+ Documentation/SBV/Examples/Puzzles/Rabbits.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Puzzles.Rabbits+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- A puzzle, attributed to Lewis Caroll:+--+-- - All rabbits, that are not greedy, are black+-- - No old rabbits are free from greediness+-- - Therefore: Some black rabbits are not old+--+-- What's implicit here is that there is a rabbit that must be not-greedy;+-- which we add to our constraints.+-----------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Puzzles.Rabbits where++import Data.SBV++-- | A universe of rabbits+data Rabbit++-- | Make rabbits symbolically available.+mkSymbolic [''Rabbit]++-- | Identify those rabbits that are greedy. Note that we leave the predicate uninterpreted.+greedy :: SRabbit -> SBool+greedy = uninterpret "greedy"++-- | Identify those rabbits that are black. Note that we leave the predicate uninterpreted.+black :: SRabbit -> SBool+black = uninterpret "black"++-- | Identify those rabbits that are old. Note that we leave the predicate uninterpreted.+old :: SRabbit -> SBool+old = uninterpret "old"++-- | Express the puzzle.+rabbits :: Predicate+rabbits = do -- All rabbits that are not greedy are black+ constrain $ \(Forall x) -> sNot (greedy x) .=> black x++ -- No old rabbits are free from greediness+ constrain $ \(Forall x) -> old x .=> greedy x++ -- There is at least one non-greedy rabbit+ constrain $ \(Exists x) -> sNot (greedy x)++ -- Therefore, there must be a black rabbit that's not old:+ pure $ quantifiedBool $ \(Exists x) -> black x .&& sNot (old x)++-- | Prove the claim. We have:+--+-- >>> rabbitsAreOK+-- Q.E.D.+rabbitsAreOK :: IO ThmResult+rabbitsAreOK = prove rabbits
+ Documentation/SBV/Examples/Puzzles/SquareBirthday.hs view
@@ -0,0 +1,202 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Puzzles.SquareBirthday+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- As of January 2026, to access the careers link at <http://math.inc>, you need to solve the following+-- puzzle:+--+-- @+-- Suppose that today is June 1, 2025. We call a date "square" if all of its components (day, month, and year) are+-- perfect squares. I was born in the last millennium, and my next birthday (relative to that date) will be the last+-- square date in my life. If you sum the square roots of the components of that upcoming square birthday+-- (day, month, year), you obtain my age on June 1, 2025. My mother would have been born on a square date if the month+-- were a square number; in reality it is not a square date, but both the month and day are perfect cubes. When was+-- I born, and when was my mother born?+-- @+--+-- So, let's solve it using SBV.+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedRecordDot #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Puzzles.SquareBirthday where++import Prelude hiding (fromEnum, toEnum)++import Data.SBV+import Data.SBV.Control++import qualified Data.SBV.List as SL+import qualified Data.SBV.Tuple as ST++-- | Months in a year.+data Month = Jan | Feb | Mar | Apr | May | Jun+ | Jul | Aug | Sep | Oct | Nov | Dec+ deriving Show++-- | A date. We use unbounded integers for day and year, which simplifies coding,+-- though one can also enumerate the possible values from the problem itself.+data Date = MkDate { day :: Integer+ , month :: Month+ , year :: Integer+ }++-- | Make 'Month' and 'Date' usable in symbolic contexts.+mkSymbolic [''Month, ''Date]++-- | Show instance for date, for pretty-printing.+instance Show Date where+ show (MkDate d m y) = show m ++ " " ++ pad ++ show d ++ ", " ++ show y+ where pad | d < 10 = " "+ | True = ""++-- | Get a symbolic date with the given name. Since we used+-- integers for the day and year fields, we constrain them+-- appropriately. Note that one can further constrain days+-- based on the year and month; but that level detail isn't+-- necessary for the current problem.+symDate :: String -> Symbolic SDate+symDate nm = do dt <- free nm++ constrain [sCase| dt of+ MkDate d _ y -> sAnd [ 1 .<= d, d .<= 31+ , 0 .<= y+ ]+ |]++ pure dt++-- | Encode today as a symbolic value. The puzzle says today is June 1st, 2025.+today :: SDate+today = literal $ MkDate { day = 1+ , month = Jun+ , year = 2025+ }++-- | A date is on or after another, if the month-day combo is+-- lexicographically later. Note that we ignore the year for this+-- comparison, as we're interested if the anniversary of a date is after or not.+onOrAfter :: SDate -> SDate -> SBool+d1 `onOrAfter` d2 = (smonth d1, sday d1) .>= (smonth d2, sday d2)++-- | Similar to 'onOrAfter', except we require strictly later.+after :: SDate -> SDate -> SBool+d1 `after` d2 = (smonth d1, sday d1) .> (smonth d2, sday d2)++-- | The age based on a given date is the difference between years less than one.+-- We have to adjust by 1 if today happens to be after the given date.+age :: SDate -> SInteger+age d = syear today - syear d - 1 + oneIf (today `after` d)++-- | We can let years to range over arbitrary integers. But that complicates the+-- job of the solver. So, based on what we know from the problem, we restrict+-- our attention to years between 1900 and 2100. Note that there are only+-- two years that satisfy this in that range: 1936 and 2025. (Any other square+-- year makes no sense for the setting of the problem.) To simplify the square-root+-- computation, we also store the square root in this list as the second component:+--+-- >>> squareYears+-- [(1936,44),(2025,45)]+squareYears :: [(Integer, Integer)]+squareYears = takeWhile (\(y, _) -> y < 2100)+ $ dropWhile (\(y, _) -> y < 1900)+ $ [(i * i, i) | i <- [1::Integer ..]]++-- | A date is square if all its components are.+squareDate :: SDate -> SBool+squareDate dt = [sCase| dt of+ MkDate d m y -> squareDay d .&& squareMonth m .&& squareYear y+ |]+ where squareDay d = d `sElem` [1, 4, 9, 16, 25]+ squareMonth m = m `sElem` [sJan, sApr, sSep]+ squareYear y = y `sElem` map (literal . fst) squareYears+++-- | Summing the square-roots of the components of a date.+sqrSum :: SDate -> SInteger+sqrSum dt = [sCase| dt of+ MkDate d m y -> r d + mr m + r y+ |]+ where r v = v `SL.lookup` literal ([(i * i, i) | i <- [1, 2, 3, 4, 5]] ++ squareYears)++ mr :: SMonth -> SInteger+ mr m = [sCase| m of+ Jan -> 1+ Apr -> 2+ Sep -> 3+ _ -> some "Non-Square Month" (const sTrue)+ |]++-- | Formalizing the puzzle. We literally write down the description in+-- SBV notation. As with any formalization, this step is subjective; there+-- could be many different ways to express the same problem. The description+-- below is quite faithful to the problem description given. We have:+--+-- >>> puzzle+-- Me : Sep 25, 1971+-- Mom: Aug 1, 1936+puzzle :: IO ()+puzzle = runSMT $ do++ -----------------------------------+ -- Constraints about my birthday+ -----------------------------------+ myBirthday <- symDate "My Birthday"++ -- I was born in the last millennium+ constrain $ syear myBirthday .< 2000 .&& syear myBirthday .>= 1900++ -- My next birthday will be a square+ let next = [sCase| myBirthday of+ MkDate d m _ -> sMkDate d m (syear today + oneIf (today `onOrAfter` myBirthday))+ |]++ constrain $ squareDate next++ -- And it'll be the last square day of my life, so we maximize the metric corresponding to the+ -- date. We turn it into a 3-tuple of year, month, date over integers, which preserves the+ -- order of the dates.+ maximize "Next Birthday Latest" $ ST.tuple (syear next, fromEnum (smonth next), sday next)++ -- If you square the components of my next birthday, it gives me my current age on Jun 1, 2025+ constrain $ sqrSum next .== age myBirthday++ -----------------------------------+ -- Constraints about mom's birthday+ -----------------------------------+ momBirthday <- symDate "Mom's Birthday"++ -- Mom has a square birth-date, except for the month:+ constrain [sCase| momBirthday of+ MkDate d _ y -> squareDate (sMkDate d sJan y)+ |]++ -- Mom's day and month are perfect cubes+ constrain [sCase| momBirthday of+ MkDate d m _ -> sAnd [ d `sElem` [1, 8, 27]+ , m `sElem` [sJan, sAug]+ ]+ |]++ -- Extract the results:+ query $ do cs <- checkSat+ case cs of+ Sat -> do me <- getValue myBirthday+ mom <- getValue momBirthday++ io $ do putStrLn $ "Me : " ++ show me+ putStrLn $ "Mom: " ++ show mom++ _ -> error $ "Unexpected result: " ++ show cs
Documentation/SBV/Examples/Puzzles/Sudoku.hs view
@@ -9,246 +9,183 @@ -- The Sudoku solver, quintessential SMT solver example! ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Puzzles.Sudoku where -import Data.List (transpose)-import Data.Maybe (fromJust)+import Control.Monad (when, zipWithM_) +import Control.Monad.State.Lazy++import Data.List (transpose)+ import Data.SBV+import Data.SBV.Control ------------------------------------------------------------------- -- * Modeling Sudoku ---------------------------------------------------------------------- | A row is a sequence of 8-bit words, too large indeed for representing 1-9, but does not harm-type Row = [SWord8]+-- | A row is a sequence of digits that we represent symbolic integers+type Row = [SInteger] -- | A Sudoku board is a sequence of 9 rows type Board = [Row] -- | Given a series of elements, make sure they are all different -- and they all are numbers between 1 and 9-check :: [SWord8] -> SBool+check :: [SInteger] -> SBool check grp = sAnd $ distinct grp : map rangeFine grp- where rangeFine x = x .> 0 .&& x .<= 9+ where rangeFine x = x `inRange` (1, 9) -- | Given a full Sudoku board, check that it is valid valid :: Board -> SBool valid rows = sAnd $ literal sizesOK : map check (rows ++ columns ++ squares) where sizesOK = length rows == 9 && all (\r -> length r == 9) rows+ columns = transpose rows regions = transpose [chunk 3 row | row <- rows] squares = [concat sq | sq <- chunk 3 (concat regions)]+ chunk :: Int -> [a] -> [[a]] chunk _ [] = [] chunk i xs = let (f, r) = splitAt i xs in f : chunk i r --- | A puzzle is a pair: First is the number of missing elements, second--- is a function that given that many elements returns the final board.-type Puzzle = (Int, [SWord8] -> Board)+-- | A puzzle is simply a list of rows. Put 0 to indicate blanks.+type Puzzle = [[Integer]] ------------------------------------------------------------------- -- * Solving Sudoku puzzles ------------------------------------------------------------------- +-- | Fill a given board, replacing 0's with appropriate elements to solve the puzzle+fillBoard :: Puzzle -> IO Puzzle+fillBoard board = runSMT $ do+ let emptyCellCount = length $ concatMap (filter (== 0)) board+ subst <- mkFreeVars emptyCellCount+ constrain $ valid (fill literal subst)++ query $ do cs <- checkSat+ case cs of+ Sat -> do vals <- mapM getValue subst+ pure $ fill id vals+ Unsat -> error "Unsolvable puzzle!"+ _ -> error $ "Solver said: " ++ show cs++ where fill xform = evalState (mapM (mapM replace) board)+ where replace 0 = do supply <- get+ case supply of+ [] -> error "Run out of supplies while filling in the board!"+ (s:ss) -> put ss >> pure s+ replace n = pure $ xform n+ -- | Solve a given puzzle and print the results sudoku :: Puzzle -> IO ()-sudoku p@(i, f) = do putStrLn "Solving the puzzle.."- model <- getModelAssignment `fmap` sat ((valid . f) `fmap` mkExistVars i)- case model of- Right sln -> dispSolution p sln- Left m -> putStrLn $ "Unsolvable puzzle: " ++ m---- | Helper function to display results nicely, not really needed, but helps presentation-dispSolution :: Puzzle -> (Bool, [Word8]) -> IO ()-dispSolution (i, f) (_, fs)- | lmod /= i = error $ "Impossible! Backend solver returned " ++ show lmod ++ " values, was expecting: " ++ show i- | True = do putStrLn "Final board:"- mapM_ printRow final- putStrLn $ "Valid Check: " ++ show (valid final)- putStrLn "Done."- where lmod = length fs- final = f (map literal fs)- printRow r = putStr " " >> mapM_ (\x -> putStr (show (fromJust (unliteral x)) ++ " ")) r >> putStrLn ""+sudoku board = fillBoard board >>= displayBoard+ where displayBoard :: Puzzle -> IO ()+ displayBoard puzzle = do+ let sh i r = show r ++ if i `elem` [3, 6] then " " else ""+ printRow i r = do putStrLn $ " " ++ unwords (zipWith sh [(1::Int)..] r)+ when (i `elem` [3, 6]) $ putStrLn ""+ zipWithM_ printRow [(1::Int)..] puzzle --- | Find all solutions to a puzzle-solveAll :: Puzzle -> IO ()-solveAll p@(i, f) = do putStrLn "Finding all solutions.."- res <- allSat $ (valid . f) `fmap` mkExistVars i- cnt <- displayModels id disp res- putStrLn $ "Found: " ++ show cnt ++ " solution(s)."- where disp n s = do putStrLn $ "Solution #" ++ show n- dispSolution p s+ let isValid = valid (map (map literal) puzzle)+ case unliteral isValid of+ Just True -> pure ()+ Just False -> error "Invalid solution generated!"+ Nothing -> error "Impossible happened, got a symbolic result for valid." ------------------------------------------------------------------- -- * Example boards ------------------------------------------------------------------- --- | Find an arbitrary good board-puzzle0 :: Puzzle-puzzle0 = (81, f)- where f [ a1, a2, a3, a4, a5, a6, a7, a8, a9,- b1, b2, b3, b4, b5, b6, b7, b8, b9,- c1, c2, c3, c4, c5, c6, c7, c8, c9,- d1, d2, d3, d4, d5, d6, d7, d8, d9,- e1, e2, e3, e4, e5, e6, e7, e8, e9,- f1, f2, f3, f4, f5, f6, f7, f8, f9,- g1, g2, g3, g4, g5, g6, g7, g8, g9,- h1, h2, h3, h4, h5, h6, h7, h8, h9,- i1, i2, i3, i4, i5, i6, i7, i8, i9 ]- = [ [a1, a2, a3, a4, a5, a6, a7, a8, a9],- [b1, b2, b3, b4, b5, b6, b7, b8, b9],- [c1, c2, c3, c4, c5, c6, c7, c8, c9],- [d1, d2, d3, d4, d5, d6, d7, d8, d9],- [e1, e2, e3, e4, e5, e6, e7, e8, e9],- [f1, f2, f3, f4, f5, f6, f7, f8, f9],- [g1, g2, g3, g4, g5, g6, g7, g8, g9],- [h1, h2, h3, h4, h5, h6, h7, h8, h9],- [i1, i2, i3, i4, i5, i6, i7, i8, i9] ]- f _ = error "puzzle0 needs exactly 81 elements!"- -- | A random puzzle, found on the internet.. puzzle1 :: Puzzle-puzzle1 = (49, f)- where f [ a1, a3, a4, a5, a6, a7, a9,- b1, b2, b3, b7, b8, b9,- c2, c4, c5, c6, c8,- d3, d5, d7,- e1, e2, e4, e5, e6, e8, e9,- f3, f5, f7,- g2, g4, g5, g6, g8,- h1, h2, h3, h7, h8, h9,- i1, i3, i4, i5, i6, i7, i9 ]- = [ [a1, 6, a3, a4, a5, a6, a7, 1, a9],- [b1, b2, b3, 6, 5, 1, b7, b8, b9],- [ 1, c2, 7, c4, c5, c6, 6, c8, 2],- [ 6, 2, d3, 3, d5, 5, d7, 9, 4],- [e1, e2, 3, e4, e5, e6, 2, e8, e9],- [ 4, 8, f3, 9, f5, 7, f7, 3, 6],- [ 9, g2, 6, g4, g5, g6, 4, g8, 8],- [h1, h2, h3, 7, 9, 4, h7, h8, h9],- [i1, 5, i3, i4, i5, i6, i7, 7, i9] ]- f _ = error "puzzle1 needs exactly 49 elements!"+puzzle1 = [ [0, 6, 0, 0, 0, 0, 0, 1, 0]+ , [0, 0, 0, 6, 5, 1, 0, 0, 0]+ , [1, 0, 7, 0, 0, 0, 6, 0, 2] + , [6, 2, 0, 3, 0, 5, 0, 9, 4]+ , [0, 0, 3, 0, 0, 0, 2, 0, 0]+ , [4, 8, 0, 9, 0, 7, 0, 3, 6]++ , [9, 0, 6, 0, 0, 0, 4, 0, 8]+ , [0, 0, 0, 7, 9, 4, 0, 0, 0]+ , [0, 5, 0, 0, 0, 0, 0, 7, 0] ]+ -- | Another random puzzle, found on the internet.. puzzle2 :: Puzzle-puzzle2 = (55, f)- where f [ a2, a4, a5, a6, a7, a9,- b1, b2, b4, b7, b8, b9,- c1, c3, c4, c5, c6, c7, c8, c9,- d2, d3, d4, d8, d9,- e1, e3, e5, e7, e9,- f1, f2, f6, f7, f8,- g1, g2, g3, g4, g5, g6, g7, g9,- h1, h2, h3, h6, h8, h9,- i1, i3, i4, i5, i6, i8 ]- = [ [ 1, a2, 3, a4, a5, a6, a7, 8, a9],- [b1, b2, 6, b4, 4, 8, b7, b8, b9],- [c1, 4, c3, c4, c5, c6, c7, c8, c9],- [ 2, d2, d3, d4, 9, 6, 1, d8, d9],- [e1, 9, e3, 8, e5, 1, e7, 4, e9],- [f1, f2, 4, 3, 2, f6, f7, f8, 8],- [g1, g2, g3, g4, g5, g6, g7, 7, g9],- [h1, h2, h3, 1, 5, h6, 4, h8, h9],- [i1, 6, i3, i4, i5, i6, 2, i8, 3] ]- f _ = error "puzzle2 needs exactly 55 elements!"+puzzle2 = [ [1, 0, 3, 0, 0, 0, 0, 8, 0]+ , [0, 0, 6, 0, 4, 8, 0, 0, 0]+ , [0, 4, 0, 0, 0, 0, 0, 0, 0] + , [2, 0, 0, 0, 9, 6, 1, 0, 0]+ , [0, 9, 0, 8, 0, 1, 0, 4, 0]+ , [0, 0, 4, 3, 2, 0, 0, 0, 8]++ , [0, 0, 0, 0, 0, 0, 0, 7, 0]+ , [0, 0, 0, 1, 5, 0, 4, 0, 0]+ , [0, 6, 0, 0, 0, 0, 2, 0, 3] ]+ -- | Another random puzzle, found on the internet.. puzzle3 :: Puzzle-puzzle3 = (56, f)- where f [ a2, a3, a4, a6, a8, a9,- b2, b4, b5, b6, b7, b8, b9,- c1, c2, c3, c4, c6, c7, c9,- d1, d3, d5, d7, d9,- e2, e3, e4, e6, e7, e8,- f1, f3, f5, f7, f9,- g1, g3, g4, g6, g7, g8, g9,- h1, h2, h3, h4, h5, h6, h8,- i1, i2, i4, i6, i7, i8 ]- = [ [ 6, a2, a3, a4, 1, a6, 5, a8, a9],- [ 8, b2, 3, b4, b5, b6, b7, b8, b9],- [c1, c2, c3, c4, 6, c6, c7, 2, c9],- [d1, 3, d3, 1, d5, 8, d7, 9, d9],- [ 1, e2, e3, e4, 9, e6, e7, e8, 4],- [f1, 5, f3, 2, f5, 3, f7, 1, f9],- [g1, 7, g3, g4, 3, g6, g7, g8, g9],- [h1, h2, h3, h4, h5, h6, 3, h8, 6],- [i1, i2, 4, i4, 5, i6, i7, i8, 9] ]- f _ = error "puzzle3 needs exactly 56 elements!"+puzzle3 = [ [6, 0, 0, 0, 1, 0, 5, 0, 0]+ , [8, 0, 3, 0, 0, 0, 0, 0, 0]+ , [0, 0, 0, 0, 6, 0, 0, 2, 0] --- | According to the web, this is the toughest + , [0, 3, 0, 1, 0, 8, 0, 9, 0]+ , [1, 0, 0, 0, 9, 0, 0, 0, 4]+ , [0, 5, 0, 2, 0, 3, 0, 1, 0]++ , [0, 7, 0, 0, 3, 0, 0, 0, 0]+ , [0, 0, 0, 0, 0, 0, 3, 0, 6]+ , [0, 0, 4, 0, 5, 0, 0, 0, 9] ]++-- | According to the web, this is the toughest. -- sudoku puzzle ever.. It even has a name: Al Escargot: -- <http://zonkedyak.blogspot.com/2006/11/worlds-hardest-sudoku-puzzle-al.html> puzzle4 :: Puzzle-puzzle4 = (58, f)- where f [ a2, a3, a4, a5, a7, a9,- b1, b3, b4, b6, b7, b8,- c1, c2, c5, c6, c8, c9,- d1, d2, d5, d6, d8, d9,- e1, e3, e4, e6, e7, e8,- f2, f3, f4, f5, f7, f8, f9,- g2, g3, g4, g5, g6, g7, g9,- h1, h3, h4, h5, h6, h7, h8,- i1, i2, i4, i5, i6, i8, i9 ]- = [ [ 1, a2, a3, a4, a5, 7, a7, 9, a9],- [b1, 3, b3, b4, 2, b6, b7, b8, 8],- [c1, c2, 9, 6, c5, c6, 5, c8, c9],- [d1, d2, 5, 3, d5, d6, 9, d8, d9],- [e1, 1, e3, e4, 8, e6, e7, e8, 2],- [ 6, f2, f3, f4, f5, 4, f7, f8, f9],- [ 3, g2, g3, g4, g5, g6, g7, 1, g9],- [h1, 4, h3, h4, h5, h6, h7, h8, 7],- [i1, i2, 7, i4, i5, i6, 3, i8, i9] ]- f _ = error "puzzle4 needs exactly 58 elements!"+puzzle4 = [ [1, 0, 0, 0, 0, 7, 0, 9, 0]+ , [0, 3, 0, 0, 2, 0, 0, 0, 8]+ , [0, 0, 9, 6, 0, 0, 5, 0, 0] + , [0, 0, 5, 3, 0, 0, 9, 0, 0]+ , [0, 1, 0, 0, 8, 0, 0, 0, 2]+ , [6, 0, 0, 0, 0, 4, 0, 0, 0]++ , [3, 0, 0, 0, 0, 0, 0, 1, 0]+ , [0, 4, 0, 0, 0, 0, 0, 0, 7]+ , [0, 0, 7, 0, 0, 0, 3, 0, 0] ]+ -- | This one has been called diabolical, apparently puzzle5 :: Puzzle-puzzle5 = (53, f)- where f [ a1, a3, a5, a6, a9,- b1, b4, b5, b7, b9,- c2, c4, c5, c6, c7, c8, c9,- d1, d2, d4, d6, d7, d8,- e1, e2, e3, e5, e7, e8, e9,- f2, f3, f4, f6, f8, f9,- g1, g2, g3, g4, g5, g6, g8,- h1, h3, h5, h6, h9,- i1, i4, i5, i7, i9 ]- = [ [a1, 9, a3, 7, a5, a6, 8, 6, a9],- [b1, 3, 1, b4, b5, 5, b7, 2, b9],- [ 8, c2, 6, c4, c5, c6, c7, c8, c9],- [d1, d2, 7, d4, 5, d6, d7, d8, 6],- [e1, e2, e3, 3, e5, 7, e7, e8, e9],- [ 5, f2, f3, f4, 1, f6, 7, f8, f9],- [g1, g2, g3, g4, g5, g6, 1, g8, 9],- [h1, 2, h3, 6, h5, h6, 3, 5, h9],- [i1, 5, 4, i4, i5, 8, i7, 7, i9] ]- f _ = error "puzzle5 needs exactly 53 elements!"+puzzle5 = [ [ 0, 9, 0, 7, 0, 0, 8, 6, 0]+ , [ 0, 3, 1, 0, 0, 5, 0, 2, 0]+ , [ 8, 0, 6, 0, 0, 0, 0, 0, 0] --- | The following is nefarious according to--- <http://haskell.org/haskellwiki/Sudoku>+ , [ 0, 0, 7, 0, 5, 0, 0, 0, 6]+ , [ 0, 0, 0, 3, 0, 7, 0, 0, 0]+ , [ 5, 0, 0, 0, 1, 0, 7, 0, 0]++ , [ 0, 0, 0, 0, 0, 0, 1, 0, 9]+ , [ 0, 2, 0, 6, 0, 0, 3, 5, 0]+ , [ 0, 5, 4, 0, 0, 8, 0, 7, 0] ]++-- | Another example puzzle6 :: Puzzle-puzzle6 = (64, f)- where f [ a1, a2, a3, a4, a6, a7, a9,- b1, b3, b4, b5, b6, b7, b8, b9,- c1, c2, c4, c5, c6, c7, c8, c9,- d1, d3, d4, d5, d6, d8,- e2, e3, e4, e6, e7, e8, e9,- f1, f2, f3, f4, f5, f6, f8, f9,- g1, g2, g5, g7, g8, g9,- h2, h3, h5, h6, h8, h9,- i1, i2, i3, i4, i5, i6, i7, i9 ]- = [ [a1, a2, a3, a4, 6, a6, a7, 8, a9],- [b1, 2, b3, b4, b5, b6, b7, b8, b9],- [c1, c2, 1, c4, c5, c6, c7, c8, c9],- [d1, 7, d3, d4, d5, d6, 1, d8, 2],- [ 5, e2, e3, e4, 3, e6, e7, e8, e9],- [f1, f2, f3, f4, f5, f6, 4, f8, f9],- [g1, g2, 4, 2, g5, 1, g7, g8, g9],- [ 3, h2, h3, 7, h5, h6, 6, h8, h9],- [i1, i2, i3, i4, i5, i6, i7, 5, i9] ]- f _ = error "puzzle6 needs exactly 64 elements!"+puzzle6 = [ [0, 0, 0, 0, 6, 0, 0, 8, 0]+ , [0, 2, 0, 0, 0, 0, 0, 0, 0]+ , [0, 0, 1, 0, 0, 0, 0, 0, 0] + , [0, 7, 0, 0, 0, 0, 1, 0, 2]+ , [5, 0, 0, 0, 3, 0, 0, 0, 0]+ , [0, 0, 0, 0, 0, 0, 4, 0, 0]++ , [0, 0, 4, 2, 0, 1, 0, 0, 0]+ , [3, 0, 0, 7, 0, 0, 6, 0, 0]+ , [0, 0, 0, 0, 0, 0, 0, 5, 0] ]+ -- | Solve them all, this takes a fraction of a second to run for each case allPuzzles :: IO ()-allPuzzles = mapM_ sudoku [puzzle0, puzzle1, puzzle2, puzzle3, puzzle4, puzzle5, puzzle6]+allPuzzles = mapM_ sudoku [puzzle1, puzzle2, puzzle3, puzzle4, puzzle5, puzzle6]
+ Documentation/SBV/Examples/Puzzles/Tower.hs view
@@ -0,0 +1,153 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Puzzles.Tower+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Solves the tower puzzle, <http://www.chiark.greenend.org.uk/%7Esgtatham/puzzles/js/towers.html>.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Puzzles.Tower where++import Control.Monad+import Data.Array hiding (inRange)+import Data.SBV+import Data.SBV.Control++-------------------------------------------------------------------+-- * Modeling Towers+-------------------------------------------------------------------++-- | Count of visible towers as an array.+type Count a = Array Integer a++-- | The grid itself. The indexes are tuples, first coordinate increases as you go from+-- left to right, and the second increases as you go from top to bottom.+type Grid a = Array (Integer, Integer) a++-- | The problem has 4 counts, from top, left, bottom, and right. And the grid itself.+type Problem a = (Count a, Count a, Count a, Count a, Grid a)++-- | Example problem. Encodes:+--+-- @+-- - - 3 - - 4+-- - 2 5+-- - 2 -+-- 4 -+-- 2 -+-- - 2+-- 3 -+-- - - 3 4 - -+-- @+problem :: Problem (Maybe Integer)+problem = (top, left, bot, right, grid)+ where build ix es = accumArray (\_ a -> a) Nothing ix [(i, Just v) | (i, v) <- es]++ top = build (1, 6) [(3, 3), (6, 4)]+ left = build (1, 6) [(3, 4), (4, 2), (6, 3)]+ bot = build (1, 6) [(3, 3), (4, 4)]+ right = build (1, 6) [(1, 5), (5, 2)]+ grid = build ((1, 1), (6, 6)) [((3, 1), 2), ((2, 2), 2)]++-- | Given a concrete partial board, turn it into a symbolic board, by filling in the+-- empty cells with symbolic variables.+symProblem :: Problem (Maybe Integer) -> Symbolic (Problem SInteger)+symProblem (t, l, b, r, g) = (,,,,) <$> fill t <*> fill l <*> fill b <*> fill r <*> fill g+ where fill :: Traversable f => f (Maybe Integer) -> Symbolic (f SInteger)+ fill = mapM (maybe free_ (pure . literal))++-------------------------------------------------------------------+-- * Counting visible towers+-------------------------------------------------------------------++-- | Given a list of tower heights, count the number of visible ones in the given order.+-- We simply keep track of the tallest we have seen so far, and increment the count for+-- each tower we see if it's taller than the tallest seen so far.+visible :: [SInteger] -> SInteger+visible = go 0 0+ where go _ visibleSofar [] = visibleSofar+ go tallestSofar visibleSofar (x:xs) = go (tallestSofar `smax` x)+ (ite (x .> tallestSofar) (1 + visibleSofar) visibleSofar)+ xs++-------------------------------------------------------------------+-- * Building constraints+-------------------------------------------------------------------++-- | Build the constraints for a given problem. We scan the elements and add the required+-- visibility counts for each row and column, viewed both in the correct order and in the backwards order.+tower :: Problem SInteger -> Symbolic ()+tower (top, left, bot, right, grid) = do+ let (minX, maxX) = bounds top+ (minY, maxY) = bounds left++ -- Constraints from top and bottom+ forM_ [minX .. maxX] $ \x -> do+ let reqT = top ! x+ reqB = bot ! x+ elts = [grid ! (x, y) | y <- [minY .. maxY]]+ mapM_ (\e -> constrain (inRange e (literal 1, literal maxY))) elts+ constrain $ distinct elts+ constrain $ reqT .== visible elts+ constrain $ reqB .== visible (reverse elts)++ -- Constraints from left and right+ forM_ [minY .. maxY] $ \y -> do+ let reqL = left ! y+ reqR = right ! y+ elts = [grid ! (x, y) | x <- [minX .. maxX]]+ mapM_ (\e -> constrain (inRange e (literal 1, literal maxX))) elts+ constrain $ distinct elts+ constrain $ reqL .== visible elts+ constrain $ reqR .== visible (reverse elts)++-------------------------------------------------------------------+-- * Example run+-------------------------------------------------------------------++-- | Solve the puzzle described above. We get:+--+-- >>> example+-- 1 2 3 2 2 4+-- 1 6 5 2 4 3 1 5+-- 3 3 2 5 6 1 4 2+-- 4 2 4 1 5 6 3 2+-- 2 5 3 6 1 4 2 3+-- 2 1 6 4 3 2 5 2+-- 3 4 1 3 2 5 6 1+-- 3 2 3 4 2 1+example :: IO ()+example = runSMT $ do+ sp <- symProblem problem+ tower sp+ query $ do cs <- checkSat+ case cs of+ Unsat -> io $ putStrLn "Unsolvable"+ Sat -> display sp+ _ -> error $ "Unexpected result: " ++ show cs+ where display :: Problem SInteger -> Query ()+ display (top, left, bot, right, grid) = do+ let (minX, maxX) = bounds top+ (minY, maxY) = bounds left++ -- Display top row+ io $ putStr " "+ topVals <- forM [minX .. maxX] $ \x -> getValue (top ! x)+ io $ putStrLn $ unwords (map show topVals)++ -- Display each row, sandwiched between left/right+ forM_ [minY .. maxY] $ \y -> do+ lv <- getValue (left ! y)+ rv <- getValue (right ! y)+ row <- forM [minX .. maxX] $ \x -> getValue (grid ! (x, y))+ io $ putStrLn $ unwords (map show (lv : row ++ [rv]))++ -- Finish with bottom row+ io $ putStr " "+ botVals <- forM [minX .. maxX] $ \x -> getValue (bot ! x)+ io $ putStrLn $ unwords (map show botVals)
Documentation/SBV/Examples/Puzzles/U2Bridge.hs view
@@ -9,14 +9,13 @@ -- The famous U2 bridge crossing puzzle: <http://www.braingle.com/brainteasers/515/u2.html> ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Puzzles.U2Bridge where @@ -33,12 +32,12 @@ -- * Modeling the puzzle ------------------------------------------------------------- --- | U2 band members. We want to translate this to SMT-Lib as a data-type, and hence the--- call to mkSymbolicEnumeration.+-- | U2 band members. data U2Member = Bono | Edge | Adam | Larry+ deriving Show -- | Make 'U2Member' a symbolic value.-mkSymbolicEnumeration ''U2Member+mkSymbolic [''U2Member] -- | Model time using 32 bits type Time = Word32@@ -62,9 +61,10 @@ -- | Location of the flash data Location = Here | There+ deriving (Eq, Show, Enum, Bounded) -- | Make 'Location' a symbolic value.-mkSymbolicEnumeration ''Location+mkSymbolic [''Location] -- | The status of the puzzle after each move --@@ -114,7 +114,7 @@ let (ar, s1) = runState a s (br, s2) = runState b s put $ symbolicMerge f t s1 s2- return $ symbolicMerge f t ar br+ pure $ symbolicMerge f t ar br -- | Read the state via an accessor function peek :: (Status -> a) -> Move a@@ -133,7 +133,10 @@ -- | Transferring a person to the other side xferPerson :: SU2Member -> Move ()-xferPerson p = do ~[lb, le, la, ll] <- mapM peek [lBono, lEdge, lAdam, lLarry]+xferPerson p = do lb <- peek lBono+ le <- peek lEdge+ la <- peek lAdam+ ll <- peek lLarry let move l = ite (l .== sHere) sThere sHere lb' = ite (p .== sBono) (move lb) lb le' = ite (p .== sEdge) (move le) le@@ -151,7 +154,7 @@ -- | Symbolic version of 'Control.Monad.when' whenS :: SBool -> Move () -> Move ()-whenS t a = ite t a (return ())+whenS t a = ite t a (pure ()) -- | Move one member, remembering to take the flash move1 :: SU2Member -> Move ()@@ -195,9 +198,12 @@ -- | Check if a given sequence of actions is valid, i.e., they must all -- cross the bridge according to the rules and in less than 17 seconds isValid :: Actions -> SBool-isValid as = time end .<= 17 .&& sAll check as .&& zigZag (cycle [sThere, sHere]) (map flash states) .&& sAll (.== sThere) [lBono end, lEdge end, lAdam end, lLarry end]- where check (s, p1, p2) = (sNot s .=> p1 .> p2) -- for two person moves, ensure first person is "larger"- .&& (s .=> p2 .== sBono) -- for one person moves, ensure second person is always "bono"+isValid as = time end .<= 17+ .&& sAll check as+ .&& zigZag (cycle [sThere, sHere]) (map flash states)+ .&& sAll (.== sThere) [lBono end, lEdge end, lAdam end, lLarry end]+ where check (s, p1, p2) = (sNot s .=> p1 .> p2) -- for two person moves, ensure first person is "larger"+ .&& (s .=> p2 .== sBono) -- for one person moves, ensure second person is always "bono" states = evalState (run as) start end = last states zigZag reqs locs = sAnd $ zipWith (.==) locs reqs@@ -209,22 +215,22 @@ -- | See if there is a solution that has precisely @n@ steps solveN :: Int -> IO Bool solveN n = do putStrLn $ "Checking for solutions with " ++ show n ++ " move" ++ plu n ++ "."- let genAct = do b <- sbvExists_- p1 <- sbvExists_- p2 <- sbvExists_- return (b, p1, p2)+ let genAct = do b <- free_+ p1 <- free_+ p2 <- free_+ pure (b, p1, p2) res <- allSat $ isValid `fmap` mapM (const genAct) [1..n] cnt <- displayModels (sortOn show) disp res- if cnt == 0 then return False+ if cnt == 0 then pure False else do putStrLn $ "Found: " ++ show cnt ++ " solution" ++ plu cnt ++ " with " ++ show n ++ " move" ++ plu n ++ "."- return True+ pure True where plu v = if v == 1 then "" else "s" disp :: Int -> (Bool, [(Bool, U2Member, U2Member)]) -> IO () disp i (_, ss) | lss /= n = error $ "Expected " ++ show n ++ " results; got: " ++ show lss- | True = do putStrLn $ "Solution #" ++ show i ++ ": "+ | True = do putStrLn $ "Solution #" ++ show i ++ ":" go False 0 ss- return ()+ pure () where lss = length ss go _ t [] = putStrLn $ "Total time: " ++ show t go l t ((True, a, _):rest) = do putStrLn $ sh2 t ++ shL l ++ show a
+ Documentation/SBV/Examples/Queries/Abducts.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Queries.Abducts+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Demonstrates extraction of abducts via queries.+--+-- N.B. Interpolants are only supported by CVC5 currently.+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.Queries.Abducts where++import Data.SBV+import Data.SBV.Control++-- | Abduct extraction example. We have the constraint @x >= 0@+-- and we want to make @x + y >= 2@. We have:+--+-- >>> example+-- Got: (define-fun abd () Bool (= s1 2))+-- Got: (define-fun abd () Bool (and (= s1 1) (= s1 s0)))+-- Got: (define-fun abd () Bool (and (= s0 2) (= s1 1)))+-- Got: (define-fun abd () Bool (and (<= 1 s0) (= s1 1)))+--+-- Note that @s0@ refers to @x@ and @s1@ refers to @y@ above. You can verify+-- that adding any of these will ensure @x + y >= 2@.+example :: IO ()+example = runSMTWith cvc5 $ do++ setOption $ ProduceAbducts True++ x <- sInteger "x"+ y <- sInteger "y"++ constrain $ x .>= 0++ query $ do abd <- getAbduct Nothing "abd" $ x + y .>= 2+ io $ putStrLn $ "Got: " ++ abd++ let next = getAbductNext >>= io . putStrLn . ("Got: " ++)++ -- Get and display a couple of abducts+ next+ next+ next
Documentation/SBV/Examples/Queries/AllSat.hs view
@@ -10,7 +10,7 @@ -- solver repeatedly, telling it to give us a new model each time. SBV already -- provides 'Data.SBV.allSat' that precisely does this. However, this example demonstrates -- how the query mode can be used to achieve the same, and can also incorporate--- extra conditions with easy as we walk through solutions.+-- extra conditions with ease as we walk through solutions. ----------------------------------------------------------------------------- {-# OPTIONS_GHC -Wall -Werror #-}@@ -45,7 +45,7 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return $ reverse sofar+ pure $ reverse sofar Sat -> do xv <- getValue x yv <- getValue y
Documentation/SBV/Examples/Queries/CaseSplit.hs view
@@ -41,7 +41,7 @@ x <- sFloat "x" - constrain $ x ./= x -- yes, in the FP land, this does hold+ constrain $ x ./= x -- yes, in the FP land, this is satisfiable by NaN query $ do mbR <- caseSplit True [ ("fpIsNegativeZero", fpIsNegativeZero x) , ("fpIsPositiveZero", fpIsPositiveZero x)@@ -52,9 +52,9 @@ ] case mbR of- Nothing -> error "Cannot find a FP number x such that x == x + 1" -- Won't happen!+ Nothing -> error "Cannot find a FP number x such that x /= x" -- Won't happen! Just (s, _) -> do xv <- getValue x- return (s, xv)+ pure (s, xv) -- | Demonstrates the "coverage" case. --@@ -82,4 +82,4 @@ case mbR of Nothing -> error "Cannot find a solution!" -- Won't happen! Just (s, _) -> do xv <- getValue x- return (s, xv)+ pure (s, xv)
Documentation/SBV/Examples/Queries/Concurrency.hs view
@@ -11,10 +11,10 @@ -- to perform push's and pop's. However performing a push and a pop is still -- single threaded and so each solution will need to wait for the previous -- solution to be found. In this example we show a class of functions--- 'Data.SBV.satConcurrentAll' and 'Data.SBV.satConcurrentAny' which spin up+-- 'Data.SBV.satConcurrentWithAll' and 'Data.SBV.satConcurrentWithAny' which spin up -- independent solver instances and runs query computations concurrently. The -- children query computations are allowed to communicate with one another as--- demonstrated in the second demo+-- demonstrated in the second demo. ----------------------------------------------------------------------------- {-# OPTIONS_GHC -Wall -Werror #-}@@ -61,12 +61,12 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ pure Nothing Sat -> do xv <- getValue x yv <- getValue y io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv)- return $ Just (xv + yv)+ pure $ Just (xv + yv) -- | In the second query we constrain for an answer where y is smaller than x, -- and then return the product of the found values.@@ -81,12 +81,12 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ pure Nothing Sat -> do yv <- getValue y xv <- getValue x io $ putStrLn $ "[Two]: Current solution is: " ++ show (xv, yv)- return $ Just (xv * yv)+ pure $ Just (xv * yv) -- | Run the demo several times to see that the children threads will change ordering. demo :: IO ()@@ -125,14 +125,14 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ pure Nothing Sat -> do xv <- getValue x yv <- getValue y io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv) io $ putStrLn "[One]: Place vars for [Two]" liftIO $ putMVar v2 (literal (xv + yv), literal (xv * yv))- return $ Just (xv + yv)+ pure $ Just (xv + yv) -- | In the second query we create a new variable z, and then a symbolic query -- using information from the first query and return a solution that uses the@@ -153,13 +153,13 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ pure Nothing Sat -> do yv <- getValue y xv <- getValue x zv <- getValue z io $ putStrLn $ "[Two]: My solution is: " ++ show (zv + xv, zv + yv)- return $ Just (zv * xv * yv)+ pure $ Just (zv * xv * yv) -- | In our second demonstration we show how through the use of concurrency -- constructs the user can have children queries communicate with one another.@@ -173,4 +173,4 @@ results <- satConcurrentWithAll z3 [firstQuery v1 v2, secondQuery v2] (sharedDependent v1) print results -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore module "Reduce duplication" -}
Documentation/SBV/Examples/Queries/Enums.hs view
@@ -9,11 +9,10 @@ -- Demonstrates the use of enumeration values during queries. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -22,11 +21,12 @@ import Data.SBV import Data.SBV.Control --- | Days of the week. We make it symbolic using the 'mkSymbolicEnumeration' splice.+-- | Days of the week. We make it symbolic using the 'mkSymbolic' splice. data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday+ deriving Show -- | Make 'Day' a symbolic value.-mkSymbolicEnumeration ''Day+mkSymbolic [''Day] -- | A trivial query to find three consecutive days that's all before 'Thursday'. The point -- here is that we can perform queries on such enumerated values and use 'getValue' on them@@ -60,6 +60,6 @@ Sat -> do a <- getValue d1 b <- getValue d2 c <- getValue d3- return [a, b, c]+ pure [a, b, c] _ -> error "Impossible, can't find days!"
Documentation/SBV/Examples/Queries/FourFours.hs view
@@ -19,12 +19,9 @@ -- and ask the SMT solver to find the appropriate fillings. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -40,18 +37,20 @@ -- 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, Show) -- | Make 'BinOp' a symbolic value.-mkSymbolicEnumeration ''BinOp+mkSymbolic [''BinOp] -- | 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 -- | Make 'UnOp' a symbolic value.-mkSymbolicEnumeration ''UnOp+mkSymbolic [''UnOp] --- | The shape of a tree, either a binary node, or a unary node, or the number @4@, represented hear by+-- | The shape of a tree, either a binary node, or a unary node, or the number @4@, represented here by -- the constructor @F@. We parameterize by the operator type: When doing symbolic computations, we'll fill -- those with 'SBinOp' and 'SUnOp'. When finding the shapes, we will simply put unit values, i.e., holes. data T b u = B b (T b u) (T b u)@@ -85,20 +84,20 @@ t1 <- trees left t2 <- trees right trees [B () t1 t2]- where splits = init $ tail $ zip (inits xs) (tails xs)+ where splits = init $ drop 1 $ zip (inits xs) (tails xs) -- | Given a tree with hols, fill it with symbolic operators. This is the /trick/ that allows -- us to consider only 640 trees as opposed to over 10 million. fill :: T () () -> Symbolic (T SBinOp SUnOp) fill (B _ l r) = B <$> free_ <*> fill l <*> fill r fill (U _ t) = U <$> free_ <*> fill t-fill F = return F+fill F = pure F -- | Minor helper for writing "symbolic" case statements. Simply walks down a list -- of values to match against a symbolic version of the key.-sCase :: (Eq a, SymVal a, Mergeable v) => SBV a -> [(a, v)] -> v-sCase k = walk- where walk [] = error "sCase: Expected a non-empty list of cases!"+cases :: (Eq a, SymVal a, Mergeable v) => SBV a -> [(a, v)] -> v+cases k = walk+ where walk [] = error "cases: Expected a non-empty list of cases!" walk [(_, v)] = v walk ((k1, v1):rest) = ite (k .== literal k1) v1 (walk rest) @@ -110,27 +109,27 @@ eval tree = case tree of B b l r -> eval l >>= \l' -> eval r >>= \r' -> binOp b l' r' U u t -> eval t >>= uOp u- F -> return 4+ F -> pure 4 where binOp :: SBinOp -> SInteger -> SInteger -> Symbolic SInteger binOp o l r = do constrain $ o .== sDivide .=> r .== 4 .|| r .== 2 constrain $ o .== sExpt .=> r .== 0- return $ sCase o- [ (Plus, l+r)- , (Minus, l-r)- , (Times, l*r)- , (Divide, l `sDiv` r)- , (Expt, 1) -- exponent is restricted to 0, so the value is 1- ]+ pure $ cases o+ [ (Plus, l+r)+ , (Minus, l-r)+ , (Times, l*r)+ , (Divide, l `sDiv` r)+ , (Expt, 1) -- exponent is restricted to 0, so the value is 1+ ] uOp :: SUnOp -> SInteger -> Symbolic SInteger uOp o v = do constrain $ o .== sSqrt .=> v .== 4 constrain $ o .== sFactorial .=> v .== 4- return $ sCase o- [ (Negate, -v)- , (Sqrt, 2) -- argument is restricted to 4, so the value is 2- , (Factorial, 24) -- argument is restricted to 4, so the value is 24- ]+ pure $ cases o+ [ (Negate, -v)+ , (Sqrt, 2) -- argument is restricted to 4, so the value is 2+ , (Factorial, 24) -- argument is restricted to 4, so the value is 24+ ] -- | In the query mode, find a filling of a given tree shape /t/, such that it evaluates to the -- requested number /i/. Note that we return back a concrete tree.@@ -141,10 +140,10 @@ query $ do cs <- checkSat case cs of Sat -> Just <$> construct symT- _ -> return Nothing+ _ -> pure Nothing where -- Walk through the tree, ask the solver for -- the assignment to symbolic operators and fill back.- construct F = return F+ construct F = pure F construct (U o s') = do uo <- getValue o U uo <$> construct s' construct (B b l' r') = do bo <- getValue b
Documentation/SBV/Examples/Queries/GuessNumber.hs view
@@ -42,7 +42,7 @@ DSat{} -> error "Unexpected delta-sat result.." -- Won't really happen Unsat -> -- This cannot happen! If it does, the input was- -- not properly constrainted. Note that we found this+ -- not properly constrained. Note that we found this -- by getting an Unsat, not by checking the value! error $ unlines [ "There's no solution!" , "Guess sequence: " ++ show (reverse sofar)@@ -50,7 +50,7 @@ Sat -> do gv <- getValue g case gv `compare` input of EQ -> -- Got it, return:- return (reverse (gv : sofar))+ pure (reverse (gv : sofar)) LT -> -- Solver guess is too small, increase the lower bound: loop ((lb+1) `max` (lb + (input - lb) `div` 2)) ub (gv : sofar) GT -> -- Solver guess is too big, decrease the upper bound:@@ -65,16 +65,15 @@ -- -- >>> play -- Current bounds: (0,1000)--- Current bounds: (0,521)--- Current bounds: (21,521)--- Current bounds: (31,521)--- Current bounds: (36,521)--- Current bounds: (39,521)--- Current bounds: (40,521)--- Current bounds: (41,521)--- Current bounds: (42,521)--- Solved in: 9 guesses:--- 776 0 21 31 36 39 40 41 42+-- Current bounds: (21,1000)+-- Current bounds: (31,1000)+-- Current bounds: (36,1000)+-- Current bounds: (39,1000)+-- Current bounds: (40,1000)+-- Current bounds: (41,1000)+-- Current bounds: (42,1000)+-- Solved in: 8 guesses:+-- 8 21 31 36 39 40 41 42 play :: IO () play = do gs <- runSMT (guess 42) putStrLn $ "Solved in: " ++ show (length gs) ++ " guesses:"
Documentation/SBV/Examples/Queries/Interpolants.hs view
@@ -14,6 +14,8 @@ -- to demonstrate the usage. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Queries.Interpolants where@@ -21,10 +23,11 @@ import Data.SBV import Data.SBV.Control +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV -- >>> import Data.SBV.Control+#endif -- | MathSAT example. Compute the interpolant for the following sets of formulas: --@@ -96,25 +99,25 @@ -- of @y@, which is the only common symbol among them. We have: -- -- >>> runSMT evenOdd--- "(or (= s1 0) (= s1 (* 2 (div s1 2))))"+-- "(let (a!1 (= (mod (+ (* (- 1) s1) 0) 2) 0)) (or (= s1 0) a!1))" -- -- This is a bit hard to read unfortunately, due to translation artifacts and use of strings. To analyze, -- we need to know that @s1@ is @y@ through SBV's translation. Let's express it in--- regular infix notation with @y@ for @s1@:+-- regular infix notation with @y@ for @s1@, and substitute the let-bound variable: ----- @(y == 0) || (y == 2 * (y `div` 2))@+-- @(y == 0) || ((-y) `mod` 2 == 0)@ -- -- Notice that the only symbol is @y@, as required. To establish that this is -- indeed an interpolant, we should establish that when @y@ is even, this formula -- is @True@; and if @y@ is odd, then it should be @False@. You can argue--- mathematically that this indeed the case, but let's just use SBV to prove these:+-- mathematically that this indeed the case, but let's just use SBV to prove the required relationships: ----- >>> prove $ \y -> (y `sMod` 2 .== 0) .=> ((y .== 0) .|| (y .== 2 * (y `sDiv` (2::SInteger))))+-- >>> prove $ \(y :: SInteger) -> (y `sMod` 2 .== 0) .=> ((y .== 0) .|| ((-y) `sMod` 2 .== 0)) -- Q.E.D. -- -- And: ----- >>> prove $ \y -> (y `sMod` 2 .== 1) .=> sNot ((y .== 0) .|| (y .== 2 * (y `sDiv` (2::SInteger))))+-- >>> prove $ \(y :: SInteger) -> (y `sMod` 2 .== 1) .=> sNot ((y .== 0) .|| ((-y) `sMod` 2 .== 0)) -- Q.E.D. -- -- This establishes that we indeed have an interpolant!@@ -126,4 +129,4 @@ query $ getInterpolantZ3 [y .== 2*x, y .== 2*z+1] -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLint ignore module "Reduce duplication" -}
Documentation/SBV/Examples/Queries/UnsatCore.hs view
@@ -36,7 +36,7 @@ query $ do cs <- checkSat case cs of Unsat -> Just <$> getUnsatCore- _ -> return Nothing+ _ -> pure Nothing -- | Extract the unsat-core of 'p'. We have:@@ -44,7 +44,7 @@ -- >>> ucCore -- Unsat core is: ["less than 5","more than 10"] ----- Demonstrating that the constraint @a .> b@ is /not/ needed for unsatisfiablity in this case.+-- Demonstrating that the constraint @a .> b@ is /not/ needed for unsatisfiability in this case. ucCore :: IO () ucCore = do mbCore <- runSMT p case mbCore of
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- return row+ constrain $ L.length row .== literal numCols+ pure 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- return col+ constrain $ L.length col .== literal numRows+ pure 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@@ -48,12 +48,12 @@ eval :: SQLExpr -> M SString eval (Query q) = do q' <- eval q tell [q']- lift $ lift sbvExists_-eval (Const str) = return $ literal str+ lift $ lift free_+eval (Const str) = pure $ literal str eval (Concat e1 e2) = (++) <$> eval e1 <*> eval e2 eval (ReadVar nm) = do n <- eval nm arr <- get- return $ readArray arr n+ pure $ readArray arr n -- | A simple program to query all messages with a given topic id. In SQL like notation: --@@ -138,7 +138,7 @@ -- Create an initial environment that returns the symbolic -- value my_topicid only, and unspecified for all other variables- emptyEnv :: SArray String String <- newArray "emptyEnv" Nothing+ emptyEnv :: SArray String String <- sArray "emptyEnv" let env = writeArray emptyEnv "my_topicid" badTopic
+ Documentation/SBV/Examples/TP/Ackermann.hs view
@@ -0,0 +1,279 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Ackermann+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving the relationship between Ackermann's original 3-argument function (1928)+-- and the Ackermann-Péter function (1935).+--+-- Ackermann's original function was a 3-argument function designed to demonstrate+-- a total computable function that is not primitive recursive. The third argument+-- generalizes the operation: @ack 0 n a = n + a@ (addition), and higher levels+-- correspond to multiplication, exponentiation, etc.+--+-- Rózsa Péter simplified this to a 2-argument function in 1935, which is what+-- most people today call "the Ackermann function."+--+-- This example is inspired by: <https://github.com/imandra-ai/imandrax-examples/blob/main/src/ackermann.iml>+--+-- Note: This proof was developed by Claude (Anthropic's AI assistant) with+-- minimal user prompting and guidance.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Ackermann where++import Data.SBV+import Data.SBV.Tuple+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+#endif++-- * Ackermann's original 3-argument function (1928)++-- | Ackermann's original 3-argument function (1928). This is the lesser-known+-- original version, not the commonly referenced Ackermann-Péter function.+-- The third argument @a@ generalizes the operation at each level.+ack :: SInteger -> SInteger -> SInteger -> SInteger+ack = smtFunction "ack"+ $ \m n a -> [sCase| m of+ _ | m .<= 0 -> n + a+ _ | n .<= 0 -> 0+ _ | n .== 1 -> a+ _ -> ack (m - 1) (ack m (n - 1) a) a+ |]++-- * Ackermann-Péter function (1935)++-- | The Ackermann-Péter function (1935), commonly known as "the Ackermann function."+-- This is Rózsa Péter's simplified 2-argument version of Ackermann's original function.+pet :: SInteger -> SInteger -> SInteger+pet = smtFunction "pet"+ $ \m n -> [sCase| m of+ _ | m .<= 0 -> n + 1+ _ | n .<= 0 -> pet (m - 1) 1+ _ -> pet (m - 1) (pet m (n - 1))+ |]++-- * Correctness++-- | Prove that @ack m 2 2 = 4@ for all m >= 0.+--+-- >>> runTP ack_2_2_4+-- Inductive lemma (strong): ack_2_2_4+-- 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.+-- Functions proven terminating: ack+-- [Proven] ack_2_2_4 :: Ɐm ∷ Integer → Bool+ack_2_2_4 :: TP (Proof (Forall "m" Integer -> SBool))+ack_2_2_4 = sInduct "ack_2_2_4"+ (\(Forall m) -> m .>= 0 .=> ack m 2 2 .== 4)+ (id, []) $+ \ih m -> [m .>= 0]+ |- ack m 2 2+ =: cases [ m .== 0 ==> trivial+ , m .> 0 ==> ack m 2 2+ =: ack (m - 1) (ack m 1 2) 2+ =: ack (m - 1) 2 2+ ?? ih `at` Inst @"m" (m - 1)+ =: (4 :: SInteger)+ =: qed+ ]++-- | Prove that @ack@ is non-negative when all arguments are non-negative.+-- We use strong induction on the lexicographic measure (m, n).+--+-- >>> runTP ack_psd+-- Inductive lemma (strong): ack_psd+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 way 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.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: ack+-- [Proven] ack_psd :: Ɐm ∷ Integer → Ɐn ∷ Integer → Ɐa ∷ Integer → Bool+ack_psd :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> Forall "a" Integer -> SBool))+ack_psd = sInduct "ack_psd"+ (\(Forall m) (Forall n) (Forall a) ->+ m .>= 0 .&& n .>= 0 .&& a .>= 0 .=> ack m n a .>= 0)+ (\m n _a -> tuple (m, n), []) $+ \ih m n a -> [m .>= 0, n .>= 0, a .>= 0]+ |- ack m n a .>= 0+ =: cases [ m .<= 0 ==> trivial -- n + a >= 0+ , n .<= 0 ==> trivial -- 0 >= 0+ , n .== 1 ==> trivial -- a >= 0+ , m .> 0 .&& n .> 1+ ==> ack m n a .>= 0+ =: ack (m - 1) (ack m (n - 1) a) a .>= 0+ ?? ih `at` (Inst @"m" m, Inst @"n" (n - 1), Inst @"a" a)+ ?? ih `at` (Inst @"m" (m - 1), Inst @"n" (ack m (n - 1) a), Inst @"a" a)+ =: sTrue+ =: qed+ ]++-- | Prove that @pet@ is non-negative when both arguments are non-negative.+-- We use strong induction on the lexicographic measure (m, n).+--+-- >>> runTPWith cvc5 pet_psd+-- Inductive lemma (strong): pet_psd+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (3 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.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.+-- Functions proven terminating: pet+-- [Proven] pet_psd :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool+pet_psd :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))+pet_psd = do+ sInduct "pet_psd"+ (\(Forall m) (Forall n) -> m .>= 0 .&& n .>= 0 .=> pet m n .>= 0)+ (\m n -> tuple (m, n), []) $+ \ih m n -> [m .>= 0, n .>= 0]+ |- pet m n .>= 0+ =: cases [ m .<= 0 ==> trivial -- n + 1 >= 0+ , m .> 0 .&& n .<= 0+ ==> pet m n .>= 0+ =: pet (m - 1) 1 .>= 0+ ?? ih `at` (Inst @"m" (m - 1), Inst @"n" (1 :: SInteger))+ =: sTrue+ =: qed+ , m .> 0 .&& n .> 0+ ==> pet m n .>= 0+ =: pet (m - 1) (pet m (n - 1)) .>= 0+ ?? ih `at` (Inst @"m" m, Inst @"n" (n - 1))+ ?? ih `at` (Inst @"m" (m - 1), Inst @"n" (pet m (n - 1)))+ =: sTrue+ =: qed+ ]++-- | The main theorem, relating @pet@ and @ack@: @pet m n + 3 = ack (m-1) (n+3) 2@ for @m > 0@ and @n >= 0@.+--+-- >>> runTPWith cvc5 petAck+-- Inductive lemma (strong): ack_2_2_4+-- 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.+-- Inductive lemma (strong): pet_psd+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (3 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.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.+-- Inductive lemma (strong): petAck+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 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.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 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.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: ack, pet+-- [Proven] petAck :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool+petAck :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))+petAck = do+ ack224 <- ack_2_2_4+ psd <- pet_psd+ sInduct "petAck"+ (\(Forall m) (Forall n) ->+ m .> 0 .&& n .>= 0 .=> pet m n + 3 .== ack (m - 1) (n + 3) 2)+ (\m n -> tuple (m, n), []) $+ \ih m n -> [m .> 0, n .>= 0]+ |- pet m n + 3 .== ack (m - 1) (n + 3) 2+ =: cases [ m .== 1 .&& n .== 0+ ==> trivial+ , m .== 1 .&& n .> 0+ ==> pet 1 n + 3 .== ack 0 (n + 3) 2+ =: pet 0 (pet 1 (n - 1)) + 3 .== (n + 3) + 2+ ?? ih `at` (Inst @"m" (1 :: SInteger), Inst @"n" (n - 1))+ =: sTrue+ =: qed+ , m .> 1 .&& n .<= 0+ -- n <= 0 with n >= 0 means n == 0+ ==> pet m n + 3 .== ack (m - 1) (n + 3) 2+ -- First unfold pet: since n <= 0, pet m n = pet (m-1) 1+ =: pet (m - 1) 1 + 3 .== ack (m - 1) (n + 3) 2+ -- Unfold ack: ack (m-1) (n+3) 2 = ack (m-2) (ack (m-1) (n+2) 2) 2+ =: pet (m - 1) 1 + 3 .== ack (m - 2) (ack (m - 1) (n + 2) 2) 2+ -- Apply IH at (m-1, 1): pet (m-1) 1 + 3 = ack (m-2) 4 2+ ?? ih `at` (Inst @"m" (m - 1), Inst @"n" (1 :: SInteger))+ =: ack (m - 2) 4 2 .== ack (m - 2) (ack (m - 1) (n + 2) 2) 2+ -- Since n = 0, n+2 = 2, and ack (m-1) 2 2 = 4 by ack_2_2_4+ ?? ack224 `at` Inst @"m" (m - 1)+ =: sTrue+ =: qed+ , m .> 1 .&& n .> 0+ ==> pet m n + 3 .== ack (m - 1) (n + 3) 2+ -- Unfold pet: pet m n = pet (m-1) (pet m (n-1))+ =: pet (m - 1) (pet m (n - 1)) + 3 .== ack (m - 1) (n + 3) 2+ -- Unfold ack on RHS: ack (m-1) (n+3) 2 = ack (m-2) (ack (m-1) (n+2) 2) 2+ =: pet (m - 1) (pet m (n - 1)) + 3 .== ack (m - 2) (ack (m - 1) (n + 2) 2) 2+ -- Use pet_psd to establish pet m (n-1) >= 0+ ?? psd `at` (Inst @"m" m, Inst @"n" (n - 1))+ -- Apply IH at (m-1, pet m (n-1)) to transform LHS+ ?? ih `at` (Inst @"m" (m - 1), Inst @"n" (pet m (n - 1)))+ =: ack (m - 2) (pet m (n - 1) + 3) 2 .== ack (m - 2) (ack (m - 1) (n + 2) 2) 2+ -- Apply IH at (m, n-1): pet m (n-1) + 3 = ack (m-1) (n+2) 2+ ?? ih `at` (Inst @"m" m, Inst @"n" (n - 1))+ =: sTrue+ =: qed+ ]++{- HLint ignore module "Use curry" -}+{- HLint ignore ack_psd "Use camelCase" -}+{- HLint ignore pet_psd "Use camelCase" -}+{- HLint ignore ack_2_2_4 "Use camelCase" -}
+ Documentation/SBV/Examples/TP/Adder.hs view
@@ -0,0 +1,395 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Adder+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Prove binary adders correct by induction, for /all/ widths at once.+--+-- This is the inductive companion to+-- "Documentation.SBV.Examples.BitPrecise.Adders", which proves fixed-width+-- adders correct automatically by bit-blasting. Here, instead, we model the+-- operands as arbitrary-length, little-endian symbolic bit lists and prove---by+-- induction on the list---properties that hold with no bound on the width:+--+-- * a ripple-carry adder agrees with the mathematical value of the bits+-- (@correctness@);+--+-- * a parallel-prefix (carry-lookahead) tree computes the same carry as the+-- ripple, because the generate\/propagate carry operator is associative+-- (@lookaheadCorrect@); and+--+-- * that lookahead carry is exactly the carry the ripple adder threads+-- (@lookaheadMatchesAdder@).+--+-- A number is represented by a little-endian list of bit pairs: one+-- @(a, b)@ per position, least-significant first, where @a@ is a bit of the+-- first operand and @b@ the corresponding bit of the second. The integer value+-- of such a list is @sum_i bit_i * 2^i@.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Adder where++import Prelude hiding (fst, snd, foldl, map, curry, uncurry, (++))++import Data.SBV hiding (fullAdder)+import Data.SBV.List (foldl, map, (++))+import Data.SBV.Tuple+import Data.SBV.TP++import Documentation.SBV.Examples.TP.Lists (foldlOverAppend)++-- We reuse the very same combinational gates that the fixed-width, bit-blasted+-- companion proves correct---only the adder driver differs (a symbolic,+-- inductive recursion here versus a metalevel one there). The 'Data.SBV.fullAdder'+-- word-level operation is hidden above so 'fullAdder' refers to that gate.+import Documentation.SBV.Examples.BitPrecise.Adders (Bit, fullAdder, generatePropagate)++#ifdef DOCTEST+-- $setup+-- >>> :set -XOverloadedLists+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+#endif++-- * Bits, values, and the adder++-- | The integer value of a single bit: @1@ if set, @0@ otherwise.+bitVal :: Bit -> SInteger+bitVal b = ite b 1 0++-- | The integer value of a little-endian bit list: @sum_i bit_i * 2^i@.+val :: SList Bool -> SInteger+val = smtFunction "val"+ $ \bs -> [sCase| bs of+ [] -> 0+ x : xs -> bitVal x + 2 * val xs+ |]++-- | The value of the first operand, read off the first components of the pairs.+valA :: SList (Bool, Bool) -> SInteger+valA = smtFunction "valA"+ $ \ps -> [sCase| ps of+ [] -> 0+ (a, _) : qs -> bitVal a + 2 * valA qs+ |]++-- | The value of the second operand, read off the second components of the pairs.+valB :: SList (Bool, Bool) -> SInteger+valB = smtFunction "valB"+ $ \ps -> [sCase| ps of+ [] -> 0+ (_, b) : qs -> bitVal b + 2 * valB qs+ |]++-- | The ripple-carry adder. Given an incoming carry and a little-endian list of+-- bit pairs, thread the carry through a chain of full adders (the same+-- 'fullAdder' gate the bit-blasted companion verifies), emitting each sum bit+-- and, at the end, the final carry-out as the most-significant bit. The result+-- is therefore one bit longer than the input, so its value is exactly the full+-- sum---no truncation.+rca :: Bit -> SList (Bool, Bool) -> SList Bool+rca = smtFunction "rca"+ $ \c ps -> [sCase| ps of+ [] -> [c]+ p : qs -> let (s, co) = uncurry fullAdder p c+ in s .: rca co qs+ |]++-- * Correctness++-- | The ripple-carry adder computes the sum of its operands, for any width:+--+-- @val (rca 0 ps) == valA ps + valB ps@+--+-- We prove it via a more general lemma that tracks the incoming carry, since the+-- recursive calls feed each stage's carry-out into the next.+--+-- >>> runTP correctness+-- Lemma: fullAdderCorrect Q.E.D.+-- Inductive lemma: rcaCorrect+-- 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: adderCorrect Q.E.D.+-- Functions proven terminating: rca, val, valA, valB+-- [Proven] adderCorrect :: Ɐps ∷ [(Bool, Bool)] → Bool+correctness :: TP (Proof (Forall "ps" [(Bool, Bool)] -> SBool))+correctness = do++ -- A single full adder is arithmetically correct: the sum bit plus twice the+ -- carry-out equals the sum of the three input bits. This is a finite boolean+ -- fact, discharged directly.+ faC <- lemma "fullAdderCorrect"+ (\(Forall @"a" a) (Forall @"b" b) (Forall @"c" c) ->+ let (s, co) = fullAdder a b c+ in bitVal s + 2 * bitVal co .== bitVal a + bitVal b + bitVal c)+ []++ -- The general statement, tracking the incoming carry. Induct on the list of+ -- bit pairs; the carry is universally quantified so the induction hypothesis+ -- applies at the carry-out fed to the recursive call.+ rcaC <- induct "rcaCorrect"+ (\(Forall @"ps" ps) (Forall @"c" c) ->+ val (rca c ps) .== valA ps + valB ps + bitVal c) $+ \ih (p, ps) c ->+ let a = fst p+ b = snd p+ (s, co) = fullAdder a b c+ in [] |- val (rca c (p .: ps))+ =: val (s .: rca co ps)+ =: bitVal s + 2 * val (rca co ps)+ ?? ih `at` Inst @"c" co+ =: bitVal s + 2 * (valA ps + valB ps + bitVal co)+ ?? faC `at` (Inst @"a" a, Inst @"b" b, Inst @"c" c)+ =: (bitVal a + 2 * valA ps) + (bitVal b + 2 * valB ps) + bitVal c+ =: valA (p .: ps) + valB (p .: ps) + bitVal c+ =: qed++ -- The headline corollary: with no incoming carry, the adder computes the sum.+ lemma "adderCorrect"+ (\(Forall ps) -> val (rca sFalse ps) .== valA ps + valB ps)+ [proofOf rcaC]++-- * Carry-lookahead, via a parallel-prefix tree+--+-- $lookahead+-- A ripple-carry adder is slow because each stage waits for the carry from the+-- one below it. A /carry-lookahead/ adder breaks that chain by computing the+-- carries in parallel. The key is to summarize a contiguous block of positions+-- by a @(generate, propagate)@ /section/: whether the block produces a carry on+-- its own (@generate@), and whether it would pass an incoming carry straight+-- through (@propagate@). Adjacent sections combine with the associative operator+-- 'dot', so the carries can be gathered by a balanced /tree/ of 'dot's rather+-- than a linear ripple.+--+-- We prove that tree correct against the ripple as follows. 'dot' is an+-- associative monoid with identity 'idSec', and applying a section to an+-- incoming carry ('applyC') is its action. The ripple carry is the /linear/+-- fold of 'dot' over the sections (@carryIsFold@), and a balanced tree of 'dot's+-- computes that /same/ fold by associativity (@treeIsFold@). Hence the parallel+-- tree and the sequential ripple agree.++-- | Combine two adjacent @(generate, propagate)@ sections, lower-order first.+-- The combined block generates a carry if the high part does, or if it+-- propagates one generated by the low part; it propagates only if both do.+dot :: SBV (Bool, Bool) -> SBV (Bool, Bool) -> SBV (Bool, Bool)+dot lo hi = tuple (fst hi .|| (snd hi .&& fst lo), snd hi .&& snd lo)++-- | The identity section: generates nothing, propagates everything.+idSec :: SBV (Bool, Bool)+idSec = tuple (sFalse, sTrue)++-- | Apply a section to an incoming carry, giving the carry out of that section.+applyC :: SBV (Bool, Bool) -> Bit -> Bit+applyC sec c = fst sec .|| (snd sec .&& c)++-- | The sequential ripple carry-out: thread the incoming carry through the+-- sections, left to right.+carry :: Bit -> SList (Bool, Bool) -> Bit+carry = smtFunction "carry"+ $ \c gps -> [sCase| gps of+ [] -> c+ b : rest -> carry (applyC b c) rest+ |]++-- | The @(generate, propagate)@ section of a single operand bit-pair @(a, b)@,+-- using the very same 'generatePropagate' gate as the bit-blasted companion.+gpOf :: SBV (Bool, Bool) -> SBV (Bool, Bool)+gpOf p = tuple (uncurry generatePropagate p)++-- | The carry-out actually threaded by the ripple adder 'rca': fold the+-- incoming carry through the full-adder carry of each position. (This is 'rca'+-- with the sum bits dropped---it threads the identical carry, via the same+-- 'fullAdder'.)+rcaCarry :: Bit -> SList (Bool, Bool) -> Bit+rcaCarry = smtFunction "rcaCarry"+ $ \c ps -> [sCase| ps of+ [] -> c+ p : qs -> let (_, co) = uncurry fullAdder p c+ in rcaCarry co qs+ |]++-- | The headline lookahead result, in textbook parallel-prefix form: the ripple+-- carry over a concatenation equals combining the two halves' sections+-- /independently/ and then applying the result to the incoming carry. Since+-- 'dot' is associative, the halves can be split the same way recursively---so+-- the carries can be gathered by a balanced /tree/ of 'dot's instead of a linear+-- ripple, and this says every such tree computes the same carry.+--+-- The proof rests on two pieces: @carryIsFold@ (the ripple carry /is/ the linear+-- fold of 'dot'), kept as its own reusable lemma, and @foldlDotSplit@ (the fold+-- distributes over append---the associativity law that licenses any tree).+--+-- >>> runTP lookaheadCorrect+-- Lemma: dotAssoc Q.E.D.+-- Lemma: dotLeftUnit Q.E.D.+-- Lemma: applyCDot Q.E.D.+-- Inductive lemma: foldlDotShift+-- 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.+-- Inductive lemma: carryIsFold+-- 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.+-- 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.+-- Lemma: foldlDotSplit+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Lemma: treeCarry+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: carry, sbv.foldl+-- [Proven] treeCarry :: Ɐc ∷ Bool → Ɐxs ∷ [(Bool, Bool)] → Ɐys ∷ [(Bool, Bool)] → Bool+lookaheadCorrect :: TP (Proof (Forall "c" Bool -> Forall "xs" [(Bool, Bool)] -> Forall "ys" [(Bool, Bool)] -> SBool))+lookaheadCorrect = do++ -- 'dot' is an associative monoid with identity 'idSec'; 'applyC' is its+ -- action. All finite boolean facts.+ assoc <- lemma "dotAssoc" (\(Forall @"x" x) (Forall @"y" y) (Forall @"z" z) -> dot x (dot y z) .== dot (dot x y) z) []+ lunit <- lemma "dotLeftUnit" (\(Forall @"x" x) -> dot idSec x .== x) []+ act <- lemma "applyCDot" (\(Forall @"lo" lo) (Forall @"hi" hi) (Forall @"c" c) -> applyC (dot lo hi) c .== applyC hi (applyC lo c)) []++ -- Folding with an initial section @s@ equals @s@ combined with the fold from+ -- the identity. (Accumulator reassociation, à la Lists.foldrFoldl.)+ fldShift <- induct "foldlDotShift"+ (\(Forall @"xs" xs) (Forall @"s" s) ->+ foldl dot s xs .== dot s (foldl dot idSec xs)) $+ \ih (x, xs) s -> [] |- foldl dot s (x .: xs)+ =: foldl dot (dot s x) xs+ ?? ih `at` Inst @"s" (dot s x)+ =: dot (dot s x) (foldl dot idSec xs)+ ?? assoc+ =: dot s (dot x (foldl dot idSec xs))+ ?? ih `at` Inst @"s" x+ =: dot s (foldl dot x xs)+ ?? lunit+ =: dot s (foldl dot (dot idSec x) xs)+ =: dot s (foldl dot idSec (x .: xs))+ =: qed++ -- The reusable link: the sequential ripple carry is the left fold of 'dot'+ -- over the sections, applied to the incoming carry. Induct on the sections;+ -- the carry is the threaded argument, so the hypothesis applies at the next+ -- carry-in.+ cif <- induct "carryIsFold"+ (\(Forall @"gps" gps) (Forall @"c" c) ->+ carry c gps .== applyC (foldl dot idSec gps) c) $+ \ih (b, gps) c -> [] |- carry c (b .: gps)+ =: carry (applyC b c) gps+ ?? ih `at` Inst @"c" (applyC b c)+ =: applyC (foldl dot idSec gps) (applyC b c)+ ?? act `at` (Inst @"lo" b, Inst @"hi" (foldl dot idSec gps), Inst @"c" c)+ =: applyC (dot b (foldl dot idSec gps)) c+ ?? fldShift `at` (Inst @"xs" gps, Inst @"s" b)+ =: applyC (foldl dot b gps) c+ ?? lunit+ =: applyC (foldl dot (dot idSec b) gps) c+ =: applyC (foldl dot idSec (b .: gps)) c+ =: qed++ -- foldl of 'dot' distributes over append (imported from the Lists examples).+ foa <- foldlOverAppend dot++ -- The split/homomorphism law: reducing a concatenation equals reducing the+ -- halves independently and combining them with 'dot'. This is what licenses+ -- any balanced (tree) grouping of the sections.+ splitLaw <- calc "foldlDotSplit"+ (\(Forall @"xs" xs) (Forall @"ys" ys) ->+ foldl dot idSec (xs ++ ys) .== dot (foldl dot idSec xs) (foldl dot idSec ys)) $+ \xs ys -> [] |- foldl dot idSec (xs ++ ys)+ ?? foa `at` (Inst @"xs" xs, Inst @"ys" ys, Inst @"e" idSec)+ =: foldl dot (foldl dot idSec xs) ys+ ?? fldShift `at` (Inst @"xs" ys, Inst @"s" (foldl dot idSec xs))+ =: dot (foldl dot idSec xs) (foldl dot idSec ys)+ =: qed++ -- Headline: the ripple carry of a concatenation equals applying the+ -- independently-combined half-sections to the incoming carry.+ calc "treeCarry"+ (\(Forall @"c" c) (Forall @"xs" xs) (Forall @"ys" ys) ->+ carry c (xs ++ ys) .== applyC (dot (foldl dot idSec xs) (foldl dot idSec ys)) c) $+ \c xs ys -> [] |- carry c (xs ++ ys)+ ?? cif `at` (Inst @"gps" (xs ++ ys), Inst @"c" c)+ =: applyC (foldl dot idSec (xs ++ ys)) c+ ?? splitLaw `at` (Inst @"xs" xs, Inst @"ys" ys)+ =: applyC (dot (foldl dot idSec xs) (foldl dot idSec ys)) c+ =: qed++-- | The capstone, tying the lookahead machinery back to the actual adder:+-- running the (foldable, tree-groupable) section 'carry' over the operands'+-- generate\/propagate signals reproduces exactly the carry that the ripple adder+-- 'rca' threads. Combined with @treeCarry@, this says the adder's own carry can+-- be computed by any balanced prefix tree.+--+-- >>> runTP lookaheadMatchesAdder+-- Lemma: applyCgpOf Q.E.D.+-- Inductive lemma: lookaheadMatchesAdder+-- 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.+-- Functions proven terminating: carry, rcaCarry, sbv.map+-- [Proven] lookaheadMatchesAdder :: Ɐps ∷ [(Bool, Bool)] → Ɐc ∷ Bool → Bool+lookaheadMatchesAdder :: TP (Proof (Forall "ps" [(Bool, Bool)] -> Forall "c" Bool -> SBool))+lookaheadMatchesAdder = do++ -- Applying a position's generate/propagate section to a carry is exactly the+ -- full-adder carry-out. A finite boolean fact.+ applyGP <- lemma "applyCgpOf"+ (\(Forall @"p" p) (Forall @"c" c) ->+ let (_, co) = uncurry fullAdder p c+ in applyC (gpOf p) c .== co)+ []++ -- Induct on the operands; the carry is threaded, so the hypothesis applies at+ -- the next carry-in.+ induct "lookaheadMatchesAdder"+ (\(Forall @"ps" ps) (Forall @"c" c) -> carry c (map gpOf ps) .== rcaCarry c ps) $+ \ih (p, ps) c -> let (_, co) = uncurry fullAdder p c+ in [] |- carry c (map gpOf (p .: ps))+ =: carry c (gpOf p .: map gpOf ps)+ =: carry (applyC (gpOf p) c) (map gpOf ps)+ ?? applyGP `at` (Inst @"p" p, Inst @"c" c)+ =: carry co (map gpOf ps)+ ?? ih `at` Inst @"c" co+ =: rcaCarry co ps+ =: rcaCarry c (p .: ps)+ =: qed
+ Documentation/SBV/Examples/TP/Basics.hs view
@@ -0,0 +1,427 @@+-----------------------------------------------------------------------------+-- |+-- 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 QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# 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 4 = True+-- p 3 = False+-- p _ = True+-- <BLANKLINE>+-- q :: Integer -> Bool+-- q 4 = False+-- q 3 = True+-- q _ = True+--+-- Note how @p@ and @q@ differ in their treatment of the inputs 3 and 4, but agree everywhere else. So, for each+-- input, at least one of @p@ or @q@ is @True@, making the disjunction @True@ for all inputs. But the predicates+-- @p@ and @q@ are not universally true themselves, constituting a counter-example.+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 3 = False+-- p _ = True+-- <BLANKLINE>+-- q :: Integer -> Bool+-- q 3 = True+-- q _ = False+--+-- In this case, both @p@ and @q@ have a satisfying input (for @p@ everything but 3, for @q@, only 3), but+-- there is no single value that satisfies both, thus giving us our 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++-- * Termination checking++-- | When a recursive function is defined via 'smtFunction', SBV automatically checks that it terminates+-- by guessing and verifying a termination measure. Here we define a simple recursive @sumToN@ and prove+-- a property about it. Note the @Functions proven terminating@ line in the output, confirming that SBV+-- verified the termination of @sumToN@ before proceeding with the proof.+--+-- >>> terminationDemo+-- Lemma: sumToN_at_5 Q.E.D.+-- Functions proven terminating: sumToN+-- [Proven] sumToN_at_5 :: Ɐn ∷ Integer → Bool+terminationDemo :: IO (Proof (Forall "n" Integer -> SBool))+terminationDemo = runTP $ do+ let sumToN :: SInteger -> SInteger+ sumToN = smtFunction "sumToN" $ \x -> [sCase| x of+ _ | x .<= 0 -> 0+ _ -> x + sumToN (x - 1)+ |]++ lemma "sumToN_at_5"+ (\(Forall n) -> n .== 5 .=> sumToN n .== 15)+ []++-- | If SBV cannot determine a termination measure, it will report an error. Here, we define+-- a function that recurses without decreasing any argument, and SBV rightfully rejects it:+--+-- >>> badTermination `catch` (\(e :: SomeException) -> mapM_ putStrLn . filter (\l -> take 3 l == "***") . lines $ show e)+-- *** Data.SBV: Cannot determine a termination measure.+-- ***+-- *** Function: bad :: SBV Integer -> SBV Integer+-- ***+-- *** Measures tried:+-- *** abs arg1+-- *** smax 0 arg1+-- *** abs arg1 + smax 0 arg1+-- *** (abs arg1, smax 0 arg1)+-- *** (smax 0 arg1, abs arg1)+-- ***+-- *** Please use 'smtFunctionWithMeasure' to provide an explicit measure.+badTermination :: IO ()+badTermination = do+ let bad :: SInteger -> SInteger+ bad = smtFunction "bad" $ \x -> [sCase| x of+ _ | x .== 0 -> 0+ _ -> bad x+ |]+ r <- prove $ \x -> bad x .== bad x+ print r++-- | If the user provides an explicit but incorrect termination measure via 'smtFunctionWithMeasure',+-- SBV will detect this and report an error. Here, we use @const 0@ as a measure, which clearly+-- does not decrease at recursive calls:+--+-- >>> badMeasure `catch` (\(e :: SomeException) -> mapM_ putStrLn . filter (\l -> take 3 l == "***") . lines $ show e)+-- *** Data.SBV: Termination measure does not strictly decrease at a recursive call site.+-- ***+-- *** Function: badM :: SBV Integer -> SBV Integer+-- ***+-- *** Falsifiable. Counter-example:+-- *** arg = 1 :: Integer+-- *** before = 0 :: Integer+-- *** then = 0 :: Integer+-- ***+-- *** The measure must strictly decrease at every recursive call.+badMeasure :: IO ()+badMeasure = do+ let badM :: SInteger -> SInteger+ badM = smtFunctionWithMeasure "badM" (const (0 :: SInteger), [])+ $ \x -> [sCase| x of+ _ | x .<= 0 -> 0+ _ -> x + badM (x - 1)+ |]+ r <- prove $ \x -> badM x .== badM x+ print r++-- | A termination measure is only a valid argument for termination if it takes values in a+-- /well-founded/ order: one with no infinite descending chains. Being non-negative and strictly+-- decreasing then forces the recursion to stop. The integers (bounded below by @0@) are well-founded,+-- but the reals are /not/: the chain @1, 1\/2, 1\/4, ...@ descends forever without ever reaching a+-- minimum. So a real-valued measure proves nothing.+--+-- Consider this Zeno-style non-terminating recursion: for any @x > 0@, the argument @x \/ 2@ is+-- again positive, so it never reaches the base case. Yet the measure @0 `smax` x@ is non-negative+-- and strictly decreases at the recursive call (@x \/ 2 < x@). Accepting it would mean certifying a+-- non-terminating function as terminating, which can be used to derive falsehoods.+--+-- @+-- zeno :: SReal -> SReal+-- zeno = smtFunctionWithMeasure \"zeno\" (\\x -> 0 \`smax\` x, [])+-- $ \\x -> ite (x .<= 0) 0 (zeno (x \/ 2))+-- @+--+-- SBV rules this out /at compile time/: the 'Data.SBV.Zero' class gates which types may be used as+-- measures, and there is deliberately no instance for algebraic reals. So the definition above does+-- not type-check, reporting:+--+-- @+-- • A termination measure may not have a real-valued result.+--+-- The reals are not well-ordered: an infinite descending chain such as+-- 1, 1\/2, 1\/4, ... has no least element, so a non-negative and strictly+-- decreasing real measure does not imply termination.+--+-- Use an integer-valued measure instead (e.g. a count of remaining steps).+-- @++-- * Axioms and consistency++-- | SBV checks that recursive functions defined via 'smtFunction' terminate, verifying a termination measure, which+-- can be auto-guessed or specified by the user. However, axioms are taken on faith: they are not checked for consistency.+-- If an axiom introduces a non-terminating or contradictory definition, the logic becomes inconsistent, i.e.,+-- we can prove arbitrary results.+--+-- Here is a simple example where we assert an axiom equivalent to a non-terminating definition @f n == 1 + f n@.+-- Using this, we can deduce @False@:+--+-- >>> axiomsAreDangerous+-- Axiom: bad+-- Lemma: axiomsCanBeInconsistent+-- Step: 1 (bad @ (n |-> 0 :: SInteger)) Q.E.D.+-- Result: Q.E.D.+-- [Proven] axiomsCanBeInconsistent :: Bool+axiomsAreDangerous :: IO (Proof SBool)+axiomsAreDangerous = runTP $ do++ let f :: SInteger -> SInteger+ f = uninterpret "f"++ badAxiom <- axiom "bad" (\(Forall n) -> f n .== 1 + f n)++ calc "axiomsCanBeInconsistent"+ 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 = [17,17,17] :: [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 = [12,15,19,25,32,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, SBV caches proof results keyed by symbolic fingerprint. Use 'recall' to invoke a proof action that+-- benefits from the cache: if the proposition has already been proved, the cached result is returned immediately.+-- Note that 'lemma', 'calc', and 'induct' always prove from scratch and then store the result in the cache;+-- only 'recall' performs a cache lookup.+--+-- Lemma names do not need to be unique. If you prove the same proposition under different names, 'recall' will+-- show the aliases. If you prove different propositions under the same name, each is proved independently.+-- To demonstrate, note that reusing the name @"evil"@ does not cause any confusion: the second call to+-- 'lemma' proves from scratch and correctly fails:+--+-- >>> runTP duplicateNames `catch` (\(_ :: SomeException) -> pure ())+-- Lemma: evil Q.E.D.+-- Lemma: evil+-- *** Failed to prove evil.+-- Falsifiable+--+-- (Incidentally, if you really want to be evil, you can just use 'axiom' and assert false, but that's another story.)+duplicateNames :: TP ()+duplicateNames = do+ -- Prove true+ _ <- lemma "evil" sTrue []++ -- Attempt to prove false, reusing the same name. Will be caught!+ _ <- lemma "evil" sFalse []++ pure ()
+ Documentation/SBV/Examples/TP/BinarySearch.hs view
@@ -0,0 +1,269 @@+-----------------------------------------------------------------------------+-- |+-- 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 QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}++{-# 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 = smtFunctionWithMeasure "bsearch" (\_arr lo hi _x -> (hi - lo + 1) `smax` 0, [])+ $ \arr lo hi x ->+ let mid = (lo + hi) `sEDiv` 2+ xmid = arr `readArray` mid+ in [sCase| lo of+ _ | lo .> hi -> sNothing+ _ | xmid .== x -> sJust mid+ _ | 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.+-- Functions proven terminating: bsearch+-- [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 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+ ]++{- HLint ignore module "Reduce duplication" -}
+ Documentation/SBV/Examples/TP/CaseSplit.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+-- |+-- 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 #-}++{-# 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/Coins.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Coins+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving the classic coin change theorem: For any amount @n >= 8@, you can make+-- exact change using only 3-cent and 5-cent coins.+--+-- This example is inspired by: <https://github.com/imandra-ai/imandrax-examples/blob/main/src/coins.iml>+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Coins where++import Data.SBV+import Data.SBV.Maybe hiding (maybe)+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+#endif++-- * Types++-- | A pocket contains a count of 3-cent and 5-cent coins.+data Pocket = Pocket { num3s :: Integer+ , num5s :: Integer+ }++-- | Create a symbolic version of Pocket.+mkSymbolic [''Pocket]++-- * Making change++-- | Make change for a given amount. Returns 'Nothing' if the amount is less than 8.+-- Base cases:+--+-- * 8 = 3 + 5+-- * 9 = 3 + 3 + 3+-- * 10 = 5 + 5+--+-- For @n > 10@, we use change for @n-3@ and add one more 3-cent coin.+mkChange :: SInteger -> SMaybe Pocket+mkChange = smtFunction "mkChange" $ \n ->+ [sCase| n of+ _ | n .< 8 -> sNothing+ _ | n .== 8 -> sJust (sPocket 1 1)+ _ | n .== 9 -> sJust (sPocket 3 0)+ _ | n .== 10 -> sJust (sPocket 0 2)+ _ -> case mkChange (n - 3) of+ Nothing -> sNothing+ Just (Pocket n3 n5) -> sJust (sPocket (n3 + 1) n5)+ |]++-- | Evaluate the value of a pocket (total cents).+evalPocket :: SMaybe Pocket -> SInteger+evalPocket mp = [sCase| mp of+ Nothing -> 0+ Just (Pocket n3 n5) -> 3 * n3 + 5 * n5+ |]++-- * Correctness++-- | Prove that for any @n >= 8@, @mkChange@ produces a pocket that evaluates to @n@.+--+-- We have:+--+-- >>> runTP correctness+-- Inductive lemma (strong): mkChangeCorrect+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (5 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4 Q.E.D.+-- Step: 1.5.1 Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: mkChange+-- [Proven] mkChangeCorrect :: Ɐn ∷ Integer → Bool+correctness :: TP (Proof (Forall "n" Integer -> SBool))+correctness =+ sInduct "mkChangeCorrect"+ (\(Forall n) -> n .>= 8 .=> evalPocket (mkChange n) .== n)+ (id, []) $+ \ih n -> [n .>= 8]+ |- evalPocket (mkChange n) .== n+ =: cases [ n .== 8 ==> trivial+ , n .== 9 ==> trivial+ , n .== 10 ==> trivial+ , n .< 8 ==> trivial -- Vacuously true: contradicts n >= 8+ , n .> 10 ==> evalPocket (mkChange n) .== n+ =: [sCase| mkChange (n - 3) of+ Nothing -> evalPocket sNothing .== n+ Just (Pocket n3 n5) -> evalPocket (sJust (sPocket (n3 + 1) n5)) .== n+ |]+ ?? ih `at` Inst @"n" (n - 3)+ =: sTrue+ =: qed+ ]
+ Documentation/SBV/Examples/TP/Collatz.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Collatz+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- The Collatz function: starting from a positive integer, if it is 1 we stop;+-- if it is even we halve it; if it is odd we triple and add one. Whether this+-- process terminates for every positive integer is the famous Collatz conjecture,+-- an open problem in mathematics. Because no termination measure is known, we+-- define 'collatz' with 'smtFunctionNoTermination', which emits the recursive+-- definition without any termination check.+--+-- We then prove that 'collatz' reaches 1 for every power of two.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Collatz where++import Data.SBV+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+#endif++-- * Definitions++-- | The Collatz function. Termination for all positive integers is the famous+-- Collatz conjecture, an open problem in mathematics. We use 'smtFunctionNoTermination'+-- since no termination measure is known.+collatz :: SInteger -> SInteger+collatz = smtFunctionNoTermination "collatz"+ $ \n -> [sCase| n of+ 1 -> 1+ _ | 2 `sDivides` n -> collatz (n `sDiv` 2)+ | True -> collatz (3 * n + 1)+ |]++-- | Power of two: @pow2 k = 2^k@ for @k >= 0@.+pow2 :: SInteger -> SInteger+pow2 = smtFunction "pow2"+ $ \k -> [sCase| k of+ _ | k .<= 0 -> 1+ | True -> 2 * pow2 (k - 1)+ |]++-- * Helper lemmas++-- | Doubling doesn't change the Collatz result.+--+-- >>> runTP doubling+-- Lemma: doubling Q.E.D. [Modulo: collatz termination]+-- [Modulo: collatz termination] doubling :: Ɐn ∷ Integer → Bool+doubling :: TP (Proof (Forall "n" Integer -> SBool))+doubling = lemma "doubling" (\(Forall @"n" n) -> n .>= 1 .=> collatz (2 * n) .== collatz n) []++-- | Powers of two are positive.+--+-- >>> runTP pow2pos+-- Inductive lemma: pow2pos+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: pow2+-- [Proven] pow2pos :: Ɐk ∷ Integer → Bool+pow2pos :: TP (Proof (Forall "k" Integer -> SBool))+pow2pos = induct "pow2pos"+ (\(Forall @"k" k) -> pow2 k .>= 1) $+ \ih k -> []+ |- pow2 (k + 1) .>= 1+ =: 2 * pow2 k .>= 1+ ?? ih+ =: sTrue+ =: qed++-- * Correctness++-- | All powers of two reach 1 under the Collatz function.+--+-- >>> runTP collatzPow2+-- Lemma: doubling Q.E.D. [Modulo: collatz termination]+-- Lemma: pow2pos Q.E.D.+-- Inductive lemma: collatzPow2+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D. [Modulo: collatz termination]+-- Step: 3 Q.E.D.+-- Result: Q.E.D. [Modulo: collatz termination]+-- Functions proven terminating: pow2+-- [Modulo: collatz termination] collatzPow2 :: Ɐk ∷ Integer → Bool+collatzPow2 :: TP (Proof (Forall "k" Integer -> SBool))+collatzPow2 = do+ dbl <- recall doubling+ p2p <- recall pow2pos++ induct "collatzPow2"+ (\(Forall @"k" k) -> k .>= 0 .=> collatz (pow2 k) .== 1) $+ \ih k -> [k .>= 0]+ |- collatz (pow2 (k + 1))+ =: collatz (2 * pow2 k)+ ?? dbl+ ?? p2p+ =: collatz (pow2 k)+ ?? ih+ =: (1 :: SInteger)+ =: qed
+ Documentation/SBV/Examples/TP/ConstFold.hs view
@@ -0,0 +1,1523 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.ConstFold+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Correctness of constant folding for a simple expression language.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.ConstFold where++import Prelude hiding ((++), snd)++import Data.SBV+import Data.SBV.List as SL+import Data.SBV.Tuple as ST+import Data.SBV.TP++-- Get the expression language definitions+import Documentation.SBV.Examples.TP.VM++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+-- >>> :set -XTypeApplications+#endif++-- | Base expression type (used in quantifiers).+type Exp = Expr String Integer++-- | Base environment-list type (used in quantifiers).+type EL = [(String, Integer)]++-- | Symbolic expression over strings and integers.+type SE = SExpr String Integer++-- | Symbolic environment over strings and integers.+type E = Env String Integer++-- * Simplification++-- | Simplify an expression at the top level, assuming sub-expressions are already folded.+-- The rules are:+--+-- * @Sqr (Con v) → Con (v*v)@+-- * @Inc (Con v) → Con (v+1)@+-- * @Add (Con 0) x → x@+-- * @Add x (Con 0) → x@+-- * @Add (Con a) (Con b) → Con (a+b)@+-- * @Mul (Con 0) x → Con 0@+-- * @Mul x (Con 0) → Con 0@+-- * @Mul (Con 1) x → x@+-- * @Mul x (Con 1) → x@+-- * @Mul (Con a) (Con b) → Con (a*b)@+-- * @Let nm (Con v) b → subst nm v b@+simplify :: SE -> SE+simplify = smtFunction "simplify" $ \expr ->+ [sCase| expr of+ Sqr (Con v) -> sCon (v * v)++ Inc (Con v) -> sCon (v + 1)++ Add (Con 0) r -> r+ Add l (Con 0) -> l+ Add (Con a) (Con b) -> sCon (a + b)++ Mul (Con 0) _ -> sCon 0+ Mul _ (Con 0) -> sCon 0+ Mul (Con 1) r -> r+ Mul l (Con 1) -> l+ Mul (Con a) (Con b) -> sCon (a * b)++ Let nm (Con v) b -> subst nm v b++ -- fall-thru+ _ -> expr+ |]++-- * Substitution++-- | Substitute a variable with a value in an expression. Capture-avoiding:+-- if a @Let@-bound variable shadows the target, we do not substitute in the body.+--+-- * @Var x → if x == nm then Con v else Var x@+-- * @Con c → Con c@+-- * @Sqr a → Sqr (subst nm v a)@+-- * @Inc a → Inc (subst nm v a)@+-- * @Add a b → Add (subst nm v a) (subst nm v b)@+-- * @Mul a b → Mul (subst nm v a) (subst nm v b)@+-- * @Let x a b → Let x (subst nm v a) (if x == nm then b else subst nm v b)@+subst :: SString -> SInteger -> SE -> SE+subst = smtFunction "subst" $ \nm v expr ->+ [sCase| expr of++ -- Substitute for vars if name matches+ Var x | x .== nm -> sCon v+ | True -> sVar x++ -- pass thru+ Con c -> sCon c+ Sqr a -> sSqr (subst nm v a)+ Inc a -> sInc (subst nm v a)+ Add a b -> sAdd (subst nm v a) (subst nm v b)+ Mul a b -> sMul (subst nm v a) (subst nm v b)++ -- substitute in the definition, but only substitute in the body if the name is not shadowing+ Let x a b | x .== nm -> sLet x (subst nm v a) b+ | True -> sLet x (subst nm v a) (subst nm v b)+ |]++-- * Constant folding++-- | Constant fold an expression bottom-up: first fold sub-expressions, then simplify.+cfold :: SE -> SE+cfold = smtFunction "cfold" $ \expr ->+ [sCase| expr of+ Var nm -> sVar nm+ Con v -> sCon v+ Sqr a -> simplify (sSqr (cfold a))+ Inc a -> simplify (sInc (cfold a))+ Add a b -> simplify (sAdd (cfold a) (cfold b))+ Mul a b -> simplify (sMul (cfold a) (cfold b))+ Let nm a b -> simplify (sLet nm (cfold a) (cfold b))+ |]++-- * Correctness++-- | The size measure is always non-negative.+--+-- >>> runTP measureNonNeg+-- Lemma: measureNonNeg Q.E.D.+-- Functions proven terminating: exprSize+-- [Proven] measureNonNeg :: Ɐe ∷ (Expr String Integer) → Bool+measureNonNeg :: TP (Proof (Forall "e" Exp -> SBool))+measureNonNeg = inductiveLemma "measureNonNeg"+ (\(Forall @"e" (e :: SE)) -> size e .>= 0)+ []++-- | Congruence for squaring: if @a == b@ then @a*a == b*b@.+--+-- >>> runTP sqrCong+-- Lemma: sqrCong Q.E.D.+-- [Proven] sqrCong :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+sqrCong :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+sqrCong = lemma "sqrCong"+ (\(Forall @"a" (a :: SInteger)) (Forall @"b" b) ->+ a .== b .=> a * a .== b * b) []++-- | Congruence for addition on the left: if @a == b@ then @a+c == b+c@.+--+-- >>> runTP addCongL+-- Lemma: addCongL Q.E.D.+-- [Proven] addCongL :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool+addCongL :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool))+addCongL = lemma "addCongL"+ (\(Forall @"a" (a :: SInteger)) (Forall @"b" b) (Forall @"c" c) ->+ a .== b .=> a + c .== b + c) []++-- | Congruence for addition on the right: if @b == c@ then @a+b == a+c@.+--+-- >>> runTP addCongR+-- Lemma: addCongR Q.E.D.+-- [Proven] addCongR :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool+addCongR :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool))+addCongR = lemma "addCongR"+ (\(Forall @"a" (a :: SInteger)) (Forall @"b" b) (Forall @"c" c) ->+ b .== c .=> a + b .== a + c) []++-- | Congruence for multiplication on the left: if @a == b@ then @a*c == b*c@.+--+-- >>> runTP mulCongL+-- Lemma: mulCongL Q.E.D.+-- [Proven] mulCongL :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool+mulCongL :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool))+mulCongL = lemma "mulCongL"+ (\(Forall @"a" (a :: SInteger)) (Forall @"b" b) (Forall @"c" c) ->+ a .== b .=> a * c .== b * c) []++-- | Congruence for multiplication on the right: if @b == c@ then @a*b == a*c@.+--+-- >>> runTP mulCongR+-- Lemma: mulCongR Q.E.D.+-- [Proven] mulCongR :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool+mulCongR :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool))+mulCongR = lemma "mulCongR"+ (\(Forall @"a" (a :: SInteger)) (Forall @"b" b) (Forall @"c" c) ->+ b .== c .=> a * b .== a * c) []++-- | Unfolding @interpInEnv@ over @Sqr@.+--+-- >>> runTP sqrHelper+-- Lemma: sqrHelper Q.E.D.+-- Functions proven terminating: interpInEnv, sbv.lookup+-- [Proven] sqrHelper :: Ɐenv ∷ [(String, Integer)] → Ɐa ∷ (Expr String Integer) → Bool+sqrHelper :: TP (Proof (Forall "env" EL -> Forall "a" Exp -> SBool))+sqrHelper = lemma "sqrHelper"+ (\(Forall @"env" (env :: E)) (Forall @"a" a) ->+ interpInEnv env (sSqr a) .== interpInEnv env a * interpInEnv env a) []++-- | Unfolding @interpInEnv@ over @Add@.+--+-- >>> runTP addHelper+-- Lemma: addHelper Q.E.D.+-- Functions proven terminating: interpInEnv, sbv.lookup+-- [Proven] addHelper :: Ɐenv ∷ [(String, Integer)] → Ɐa ∷ (Expr String Integer) → Ɐb ∷ (Expr String Integer) → Bool+addHelper :: TP (Proof (Forall "env" EL -> Forall "a" Exp -> Forall "b" Exp -> SBool))+addHelper = lemma "addHelper"+ (\(Forall @"env" (env :: E)) (Forall @"a" a) (Forall @"b" b) ->+ interpInEnv env (sAdd a b) .== interpInEnv env a + interpInEnv env b) []++-- | Unfolding @interpInEnv@ over @Mul@.+--+-- >>> runTP mulHelper+-- Lemma: mulHelper Q.E.D.+-- Functions proven terminating: interpInEnv, sbv.lookup+-- [Proven] mulHelper :: Ɐenv ∷ [(String, Integer)] → Ɐa ∷ (Expr String Integer) → Ɐb ∷ (Expr String Integer) → Bool+mulHelper :: TP (Proof (Forall "env" EL -> Forall "a" Exp -> Forall "b" Exp -> SBool))+mulHelper = lemma "mulHelper"+ (\(Forall @"env" (env :: E)) (Forall @"a" a) (Forall @"b" b) ->+ interpInEnv env (sMul a b) .== interpInEnv env a * interpInEnv env b) []++-- | Unfolding @interpInEnv@ over @Let@.+--+-- >>> runTP letHelper+-- Lemma: letHelper Q.E.D.+-- Functions proven terminating: interpInEnv, sbv.lookup+-- [Proven] letHelper :: Ɐenv ∷ [(String, Integer)] → Ɐnm ∷ String → Ɐa ∷ (Expr String Integer) → Ɐb ∷ (Expr String Integer) → Bool+letHelper :: TP (Proof (Forall "env" EL -> Forall "nm" String -> Forall "a" Exp -> Forall "b" Exp -> SBool))+letHelper = lemma "letHelper"+ (\(Forall @"env" (env :: E)) (Forall @"nm" nm) (Forall @"a" a) (Forall @"b" b) ->+ interpInEnv env (sLet nm a b) .== interpInEnv (ST.tuple (nm, interpInEnv env a) .: env) b) []++-- * Environment lemmas++-- | Swapping two adjacent bindings with distinct keys does not affect lookup.+--+-- >>> runTP lookupSwap+-- Lemma: lookupSwap+-- 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.+-- Functions proven terminating: sbv.lookup+-- [Proven] lookupSwap :: Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool+lookupSwap :: TP (Proof (Forall "k" String -> Forall "b1" (String, Integer)+ -> Forall "b2" (String, Integer) -> Forall "env" EL -> SBool))+lookupSwap = calc "lookupSwap"+ (\(Forall @"k" (k :: SString)) (Forall @"b1" (b1 :: STuple String Integer))+ (Forall @"b2" (b2 :: STuple String Integer)) (Forall @"env" (env :: E)) ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ in x ./= y .=> SL.lookup k (b1 .: b2 .: env) .== SL.lookup k (b2 .: b1 .: env)) $+ \k b1 b2 env ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ in [x ./= y]+ |- cases [ k .== x+ ==> SL.lookup k (b1 .: b2 .: env)+ =: SL.lookup k (b2 .: b1 .: env)+ =: qed+ , k ./= x+ ==> SL.lookup k (b1 .: b2 .: env)+ =: SL.lookup k (b2 .: env)+ =: SL.lookup k (b2 .: b1 .: env)+ =: qed+ ]++-- | One-step unfolding of 'SL.lookup' on a cons cell. The solver can expand the+-- @define-fun-rec@ but struggles to fold it back, so we provide this as a reusable hint.+--+-- >>> runTP lookupCons+-- Lemma: lookupCons Q.E.D.+-- Functions proven terminating: sbv.lookup+-- [Proven] lookupCons :: Ɐk ∷ String → Ɐb ∷ (String, Integer) → Ɐrest ∷ [(String, Integer)] → Bool+lookupCons :: TP (Proof (Forall "k" String -> Forall "b" (String, Integer) -> Forall "rest" EL -> SBool))+lookupCons = lemma "lookupCons"+ (\(Forall @"k" (k :: SString)) (Forall @"b" (b :: STuple String Integer)) (Forall @"rest" (rest :: E)) ->+ let (bk, bv) = ST.untuple b+ in SL.lookup k (b .: rest) .== ite (k .== bk) bv (SL.lookup k rest))+ []++-- | Generalized swap: swapping two adjacent distinct-keyed bindings behind+-- a prefix does not affect lookup.+--+-- >>> runTP lookupSwapPfx+-- Lemma: lookupSwap Q.E.D.+-- Lemma: lookupCons Q.E.D.+-- Inductive lemma (strong): lookupSwapPfx+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (2 way case split)+-- Step: 1.1 (base) Q.E.D.+-- Step: 1.2.1 (cons) 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.2.5 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: sbv.lookup+-- [Proven] lookupSwapPfx :: Ɐpfx ∷ [(String, Integer)] → Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool+lookupSwapPfx :: TP (Proof (Forall "pfx" EL -> Forall "k" String -> Forall "b1" (String, Integer)+ -> Forall "b2" (String, Integer) -> Forall "env" EL -> SBool))+lookupSwapPfx = do+ lkS <- recall lookupSwap+ lkC <- recall lookupCons++ sInduct "lookupSwapPfx"+ (\(Forall @"pfx" (pfx :: E)) (Forall @"k" (k :: SString)) (Forall @"b1" (b1 :: STuple String Integer))+ (Forall @"b2" (b2 :: STuple String Integer)) (Forall @"env" (env :: E)) ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ in x ./= y .=> SL.lookup k (pfx ++ b1 .: b2 .: env)+ .== SL.lookup k (pfx ++ b2 .: b1 .: env))+ (\pfx _ _ _ _ -> SL.length pfx :: SInteger, []) $+ \ih pfx k b1 b2 env ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ in [x ./= y]+ |- cases [ SL.null pfx+ ==> SL.lookup k (pfx ++ b1 .: b2 .: env)+ ?? "base"+ ?? lkS `at` (Inst @"k" k, Inst @"b1" b1, Inst @"b2" b2, Inst @"env" env)+ =: SL.lookup k (pfx ++ b2 .: b1 .: env)+ =: qed+ , sNot (SL.null pfx)+ ==> let h = SL.head pfx+ t = SL.tail pfx+ (hk, hv) = ST.untuple h+ in SL.lookup k (pfx ++ b1 .: b2 .: env)+ ?? "cons"+ ?? pfx .== h .: t+ =: SL.lookup k (h .: (t ++ b1 .: b2 .: env))+ =: ite (k .== hk) hv (SL.lookup k (t ++ b1 .: b2 .: env))+ ?? ih `at` (Inst @"pfx" t, Inst @"k" k, Inst @"b1" b1, Inst @"b2" b2, Inst @"env" env)+ =: ite (k .== hk) hv (SL.lookup k (t ++ b2 .: b1 .: env))+ ?? lkC `at` (Inst @"k" k, Inst @"b" h, Inst @"rest" (t ++ b2 .: b1 .: env))+ =: SL.lookup k (h .: (t ++ b2 .: b1 .: env))+ =: SL.lookup k (pfx ++ b2 .: b1 .: env)+ =: qed+ ]++-- | A shadowed binding does not affect lookup: if the same key appears first, the second is irrelevant.+--+-- >>> runTP lookupShadow+-- Lemma: lookupShadow Q.E.D.+-- Functions proven terminating: sbv.lookup+-- [Proven] lookupShadow :: Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool+lookupShadow :: TP (Proof (Forall "k" String -> Forall "b1" (String, Integer)+ -> Forall "b2" (String, Integer) -> Forall "env" EL -> SBool))+lookupShadow = lemma "lookupShadow"+ (\(Forall @"k" (k :: SString)) (Forall @"b1" (b1 :: STuple String Integer))+ (Forall @"b2" (b2 :: STuple String Integer)) (Forall @"env" (env :: E)) ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ in x .== y .=> SL.lookup k (b1 .: b2 .: env)+ .== SL.lookup k (b1 .: env))+ []++-- | Generalized shadow: a shadowed binding behind a prefix does not affect lookup.+--+-- >>> runTP lookupShadowPfx+-- Lemma: lookupShadow Q.E.D.+-- Lemma: lookupCons Q.E.D.+-- Inductive lemma (strong): lookupShadowPfx+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (2 way case split)+-- Step: 1.1 (base) Q.E.D.+-- Step: 1.2.1 (cons) 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.2.5 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: sbv.lookup+-- [Proven] lookupShadowPfx :: Ɐpfx ∷ [(String, Integer)] → Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool+lookupShadowPfx :: TP (Proof (Forall "pfx" EL -> Forall "k" String -> Forall "b1" (String, Integer)+ -> Forall "b2" (String, Integer) -> Forall "env" EL -> SBool))+lookupShadowPfx = do+ lkSh <- recall lookupShadow+ lkC <- recall lookupCons+ sInduct "lookupShadowPfx"+ (\(Forall @"pfx" (pfx :: E)) (Forall @"k" (k :: SString)) (Forall @"b1" (b1 :: STuple String Integer))+ (Forall @"b2" (b2 :: STuple String Integer)) (Forall @"env" (env :: E)) ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ in x .== y .=> SL.lookup k (pfx ++ b1 .: b2 .: env)+ .== SL.lookup k (pfx ++ b1 .: env))+ (\pfx _ _ _ _ -> SL.length pfx :: SInteger, []) $+ \ih pfx k b1 b2 env ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ in [x .== y]+ |- cases [ SL.null pfx+ ==> SL.lookup k (pfx ++ b1 .: b2 .: env)+ ?? "base"+ ?? lkSh `at` (Inst @"k" k, Inst @"b1" b1, Inst @"b2" b2, Inst @"env" env)+ =: SL.lookup k (pfx ++ b1 .: env)+ =: qed+ , sNot (SL.null pfx)+ ==> let h = SL.head pfx+ t = SL.tail pfx+ (hk, hv) = ST.untuple h+ in SL.lookup k (pfx ++ b1 .: b2 .: env)+ ?? "cons"+ ?? pfx .== h .: t+ =: SL.lookup k (h .: (t ++ b1 .: b2 .: env))+ =: ite (k .== hk) hv (SL.lookup k (t ++ b1 .: b2 .: env))+ ?? ih `at` (Inst @"pfx" t, Inst @"k" k, Inst @"b1" b1, Inst @"b2" b2, Inst @"env" env)+ =: ite (k .== hk) hv (SL.lookup k (t ++ b1 .: env))+ ?? lkC `at` (Inst @"k" k, Inst @"b" h, Inst @"rest" (t ++ b1 .: env))+ =: SL.lookup k (h .: (t ++ b1 .: env))+ =: SL.lookup k (pfx ++ b1 .: env)+ =: qed+ ]++-- | Swapping two adjacent distinct-keyed bindings in the environment+-- does not affect interpretation. The @pfx@ parameter allows the swap+-- to happen at any depth in the environment.+--+-- >>> runTPWith cvc5 envSwap+-- Lemma: measureNonNeg Q.E.D.+-- Lemma: lookupSwapPfx Q.E.D.+-- Lemma: sqrCong Q.E.D.+-- Lemma: sqrHelper Q.E.D.+-- Lemma: addCongL Q.E.D.+-- Lemma: addCongR Q.E.D.+-- Lemma: addHelper Q.E.D.+-- Lemma: mulCongL Q.E.D.+-- Lemma: mulCongR Q.E.D.+-- Lemma: mulHelper Q.E.D.+-- Lemma: letHelper Q.E.D.+-- Inductive lemma (strong): envSwap+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (7 way case split)+-- Step: 1.1 (Var) Q.E.D.+-- Step: 1.2 (Con) Q.E.D.+-- Step: 1.3.1 (Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.4 (Inc) Q.E.D.+-- Step: 1.5.1 (Add) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.6.1 (Mul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.7.1 (Let) Q.E.D.+-- Step: 1.7.2 Q.E.D.+-- Step: 1.7.3 Q.E.D.+-- Step: 1.7.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: exprSize, interpInEnv, sbv.lookup+-- [Proven] envSwap :: Ɐe ∷ (Expr String Integer) → Ɐpfx ∷ [(String, Integer)] → Ɐenv ∷ [(String, Integer)] → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Bool+envSwap :: TP (Proof (Forall "e" Exp -> Forall "pfx" EL -> Forall "env" EL+ -> Forall "b1" (String, Integer) -> Forall "b2" (String, Integer) -> SBool))+envSwap = do+ mnn <- recall measureNonNeg+ lkSP <- recall lookupSwapPfx+ sqrC <- recall sqrCong+ sqrH <- recall sqrHelper+ addCL <- recall addCongL+ addCR <- recall addCongR+ addH <- recall addHelper+ mulCL <- recall mulCongL+ mulCR <- recall mulCongR+ mulH <- recall mulHelper+ letH <- recall letHelper++ sInduct "envSwap"+ (\(Forall @"e" (e :: SE)) (Forall @"pfx" (pfx :: E)) (Forall @"env" (env :: E))+ (Forall @"b1" (b1 :: STuple String Integer)) (Forall @"b2" (b2 :: STuple String Integer)) ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ in x ./= y .=> interpInEnv (pfx ++ b1 .: b2 .: env) e .== interpInEnv (pfx ++ b2 .: b1 .: env) e)+ (\e _ _ _ _ -> size e :: SInteger, [proofOf mnn]) $+ \ih e pfx env b1 b2 ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ env1 = pfx ++ b1 .: b2 .: env+ env2 = pfx ++ b2 .: b1 .: env+ in [x ./= y]+ |- cases [ isVar e+ ==> let nm = svar e+ in interpInEnv env1 (sVar nm)+ ?? "Var"+ ?? lkSP `at` (Inst @"pfx" pfx, Inst @"k" nm, Inst @"b1" b1, Inst @"b2" b2, Inst @"env" env)+ =: interpInEnv env2 (sVar nm)+ =: qed++ , isCon e+ ==> let v = scon e+ in interpInEnv env1 (sCon v)+ ?? "Con"+ =: interpInEnv env2 (sCon v)+ =: qed++ , isSqr e+ ==> let a = ssqrVal e+ in interpInEnv env1 (sSqr a)+ ?? "Sqr"+ ?? sqrH `at` (Inst @"env" env1, Inst @"a" a)+ =: interpInEnv env1 a * interpInEnv env1 a+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? sqrC `at` (Inst @"a" (interpInEnv env1 a), Inst @"b" (interpInEnv env2 a))+ =: interpInEnv env2 a * interpInEnv env2 a+ ?? sqrH `at` (Inst @"env" env2, Inst @"a" a)+ =: interpInEnv env2 (sSqr a)+ =: qed++ , isInc e+ ==> let a = sincVal e+ in interpInEnv env1 (sInc a)+ ?? "Inc"+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ =: interpInEnv env2 (sInc a)+ =: qed++ , isAdd e+ ==> let a = sadd1 e+ b = sadd2 e+ in interpInEnv env1 (sAdd a b)+ ?? "Add"+ ?? addH `at` (Inst @"env" env1, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env1 a + interpInEnv env1 b+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? addCL `at` (Inst @"a" (interpInEnv env1 a), Inst @"b" (interpInEnv env2 a), Inst @"c" (interpInEnv env1 b))+ =: interpInEnv env2 a + interpInEnv env1 b+ ?? ih `at` (Inst @"e" b, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? addCR `at` (Inst @"a" (interpInEnv env2 a), Inst @"b" (interpInEnv env1 b), Inst @"c" (interpInEnv env2 b))+ =: interpInEnv env2 a + interpInEnv env2 b+ ?? addH `at` (Inst @"env" env2, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env2 (sAdd a b)+ =: qed++ , isMul e+ ==> let a = smul1 e+ b = smul2 e+ in interpInEnv env1 (sMul a b)+ ?? "Mul"+ ?? mulH `at` (Inst @"env" env1, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env1 a * interpInEnv env1 b+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? mulCL `at` (Inst @"a" (interpInEnv env1 a), Inst @"b" (interpInEnv env2 a), Inst @"c" (interpInEnv env1 b))+ =: interpInEnv env2 a * interpInEnv env1 b+ ?? ih `at` (Inst @"e" b, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? mulCR `at` (Inst @"a" (interpInEnv env2 a), Inst @"b" (interpInEnv env1 b), Inst @"c" (interpInEnv env2 b))+ =: interpInEnv env2 a * interpInEnv env2 b+ ?? mulH `at` (Inst @"env" env2, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env2 (sMul a b)+ =: qed++ , isLet e+ ==> let nm = slvar e+ a = slval e+ b = slbody e+ val1 = interpInEnv env1 a+ val2 = interpInEnv env2 a+ in interpInEnv env1 (sLet nm a b)+ ?? "Let"+ ?? letH `at` (Inst @"env" env1, Inst @"nm" nm, Inst @"a" a, Inst @"b" b)+ =: interpInEnv (ST.tuple (nm, val1) .: env1) b+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ =: interpInEnv (ST.tuple (nm, val2) .: env1) b+ ?? ih `at` (Inst @"e" b, Inst @"pfx" (ST.tuple (nm, val2) .: pfx), Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ =: interpInEnv (ST.tuple (nm, val2) .: env2) b+ ?? letH `at` (Inst @"env" env2, Inst @"nm" nm, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env2 (sLet nm a b)+ =: qed+ ]++-- | A shadowed binding in the environment does not affect interpretation.+-- The @pfx@ parameter allows the shadow to occur at any depth.+--+-- >>> runTPWith cvc5 envShadow+-- Lemma: measureNonNeg Q.E.D.+-- Lemma: lookupShadowPfx Q.E.D.+-- Lemma: sqrCong Q.E.D.+-- Lemma: sqrHelper Q.E.D.+-- Lemma: addCongL Q.E.D.+-- Lemma: addCongR Q.E.D.+-- Lemma: addHelper Q.E.D.+-- Lemma: mulCongL Q.E.D.+-- Lemma: mulCongR Q.E.D.+-- Lemma: mulHelper Q.E.D.+-- Lemma: letHelper Q.E.D.+-- Inductive lemma (strong): envShadow+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (7 way case split)+-- Step: 1.1 (Var) Q.E.D.+-- Step: 1.2 (Con) Q.E.D.+-- Step: 1.3.1 (Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.4 (Inc) Q.E.D.+-- Step: 1.5.1 (Add) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.6.1 (Mul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.7.1 (Let) Q.E.D.+-- Step: 1.7.2 Q.E.D.+-- Step: 1.7.3 Q.E.D.+-- Step: 1.7.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: exprSize, interpInEnv, sbv.lookup+-- [Proven] envShadow :: Ɐe ∷ (Expr String Integer) → Ɐpfx ∷ [(String, Integer)] → Ɐenv ∷ [(String, Integer)] → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Bool+envShadow :: TP (Proof (Forall "e" Exp -> Forall "pfx" EL -> Forall "env" EL+ -> Forall "b1" (String, Integer) -> Forall "b2" (String, Integer) -> SBool))+envShadow = do+ mnn <- recall measureNonNeg+ lkShP <- recall lookupShadowPfx+ sqrC <- recall sqrCong+ sqrH <- recall sqrHelper+ addCL <- recall addCongL+ addCR <- recall addCongR+ addH <- recall addHelper+ mulCL <- recall mulCongL+ mulCR <- recall mulCongR+ mulH <- recall mulHelper+ letH <- recall letHelper++ sInduct "envShadow"+ (\(Forall @"e" (e :: SE)) (Forall @"pfx" (pfx :: E)) (Forall @"env" (env :: E))+ (Forall @"b1" (b1 :: STuple String Integer)) (Forall @"b2" (b2 :: STuple String Integer)) ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ in x .== y .=> interpInEnv (pfx ++ b1 .: b2 .: env) e .== interpInEnv (pfx ++ b1 .: env) e)+ (\e _ _ _ _ -> size e :: SInteger, [proofOf mnn]) $+ \ih e pfx env b1 b2 ->+ let (x, _) = ST.untuple b1+ (y, _) = ST.untuple b2+ env1 = pfx ++ b1 .: b2 .: env+ env2 = pfx ++ b1 .: env+ in [x .== y]+ |- cases [ isVar e+ ==> let nm = svar e+ in interpInEnv env1 (sVar nm)+ ?? "Var"+ ?? lkShP `at` (Inst @"pfx" pfx, Inst @"k" nm, Inst @"b1" b1, Inst @"b2" b2, Inst @"env" env)+ =: interpInEnv env2 (sVar nm)+ =: qed++ , isCon e+ ==> let v = scon e+ in interpInEnv env1 (sCon v)+ ?? "Con"+ =: interpInEnv env2 (sCon v)+ =: qed++ , isSqr e+ ==> let a = ssqrVal e+ in interpInEnv env1 (sSqr a)+ ?? "Sqr"+ ?? sqrH `at` (Inst @"env" env1, Inst @"a" a)+ =: interpInEnv env1 a * interpInEnv env1 a+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? sqrC `at` (Inst @"a" (interpInEnv env1 a), Inst @"b" (interpInEnv env2 a))+ =: interpInEnv env2 a * interpInEnv env2 a+ ?? sqrH `at` (Inst @"env" env2, Inst @"a" a)+ =: interpInEnv env2 (sSqr a)+ =: qed++ , isInc e+ ==> let a = sincVal e+ in interpInEnv env1 (sInc a)+ ?? "Inc"+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ =: interpInEnv env2 (sInc a)+ =: qed++ , isAdd e+ ==> let a = sadd1 e+ b = sadd2 e+ in interpInEnv env1 (sAdd a b)+ ?? "Add"+ ?? addH `at` (Inst @"env" env1, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env1 a + interpInEnv env1 b+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? addCL `at` (Inst @"a" (interpInEnv env1 a), Inst @"b" (interpInEnv env2 a), Inst @"c" (interpInEnv env1 b))+ =: interpInEnv env2 a + interpInEnv env1 b+ ?? ih `at` (Inst @"e" b, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? addCR `at` (Inst @"a" (interpInEnv env2 a), Inst @"b" (interpInEnv env1 b), Inst @"c" (interpInEnv env2 b))+ =: interpInEnv env2 a + interpInEnv env2 b+ ?? addH `at` (Inst @"env" env2, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env2 (sAdd a b)+ =: qed++ , isMul e+ ==> let a = smul1 e+ b = smul2 e+ in interpInEnv env1 (sMul a b)+ ?? "Mul"+ ?? mulH `at` (Inst @"env" env1, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env1 a * interpInEnv env1 b+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? mulCL `at` (Inst @"a" (interpInEnv env1 a), Inst @"b" (interpInEnv env2 a), Inst @"c" (interpInEnv env1 b))+ =: interpInEnv env2 a * interpInEnv env1 b+ ?? ih `at` (Inst @"e" b, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ ?? mulCR `at` (Inst @"a" (interpInEnv env2 a), Inst @"b" (interpInEnv env1 b), Inst @"c" (interpInEnv env2 b))+ =: interpInEnv env2 a * interpInEnv env2 b+ ?? mulH `at` (Inst @"env" env2, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env2 (sMul a b)+ =: qed++ , isLet e+ ==> let nm = slvar e+ a = slval e+ b = slbody e+ val1 = interpInEnv env1 a+ val2 = interpInEnv env2 a+ in interpInEnv env1 (sLet nm a b)+ ?? "Let"+ ?? letH `at` (Inst @"env" env1, Inst @"nm" nm, Inst @"a" a, Inst @"b" b)+ =: interpInEnv (ST.tuple (nm, val1) .: env1) b+ ?? ih `at` (Inst @"e" a, Inst @"pfx" pfx, Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ =: interpInEnv (ST.tuple (nm, val2) .: env1) b+ ?? ih `at` (Inst @"e" b, Inst @"pfx" (ST.tuple (nm, val2) .: pfx), Inst @"env" env, Inst @"b1" b1, Inst @"b2" b2)+ =: interpInEnv (ST.tuple (nm, val2) .: env2) b+ ?? letH `at` (Inst @"env" env2, Inst @"nm" nm, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env2 (sLet nm a b)+ =: qed+ ]++-- * Substitution correctness++-- | Unfolding @interpInEnv@ over @Var@.+--+-- >>> runTP varHelper+-- Lemma: varHelper Q.E.D.+-- Functions proven terminating: interpInEnv, sbv.lookup+-- [Proven] varHelper :: Ɐenv ∷ [(String, Integer)] → Ɐnm ∷ String → Bool+varHelper :: TP (Proof (Forall "env" EL -> Forall "nm" String -> SBool))+varHelper = lemma "varHelper"+ (\(Forall @"env" (env :: E)) (Forall @"nm" nm) ->+ interpInEnv env (sVar nm) .== SL.lookup nm env) []++-- | Substitution preserves semantics: interpreting in an extended environment+-- is the same as substituting and interpreting in the original environment.+--+-- >>> runTPWith cvc5 substCorrect+-- Lemma: measureNonNeg Q.E.D.+-- Lemma: sqrCong Q.E.D.+-- Lemma: sqrHelper Q.E.D.+-- Lemma: addHelper Q.E.D.+-- Lemma: mulCongL Q.E.D.+-- Lemma: mulCongR Q.E.D.+-- Lemma: mulHelper Q.E.D.+-- Lemma: letHelper Q.E.D.+-- Lemma: varHelper Q.E.D.+-- Lemma: envSwap Q.E.D.+-- Lemma: envShadow Q.E.D.+-- Inductive lemma (strong): substCorrect+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (7 way case split)+-- Step: 1.1 (2 way case split)+-- Step: 1.1.1.1 (Var) Q.E.D.+-- Step: 1.1.1.2 Q.E.D.+-- Step: 1.1.1.3 Q.E.D.+-- Step: 1.1.1.4 Q.E.D.+-- Step: 1.1.1.5 Q.E.D.+-- Step: 1.1.2.1 (Var) Q.E.D.+-- Step: 1.1.2.2 Q.E.D.+-- Step: 1.1.2.3 Q.E.D.+-- Step: 1.1.2.4 Q.E.D.+-- Step: 1.1.2.5 Q.E.D.+-- Step: 1.1.Completeness Q.E.D.+-- Step: 1.2 (Con) Q.E.D.+-- Step: 1.3.1 (Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.4 (Inc) Q.E.D.+-- Step: 1.5.1 (Add) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.6.1 (Mul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.6.5 Q.E.D.+-- Step: 1.7.1 (Let) Q.E.D.+-- Step: 1.7.2 (2 way case split)+-- Step: 1.7.2.1.1 Q.E.D.+-- Step: 1.7.2.1.2 (shadow) Q.E.D.+-- Step: 1.7.2.1.3 Q.E.D.+-- Step: 1.7.2.1.4 Q.E.D.+-- Step: 1.7.2.1.5 Q.E.D.+-- Step: 1.7.2.2.1 Q.E.D.+-- Step: 1.7.2.2.2 (swap) Q.E.D.+-- Step: 1.7.2.2.3 Q.E.D.+-- Step: 1.7.2.2.4 Q.E.D.+-- Step: 1.7.2.2.5 Q.E.D.+-- Step: 1.7.2.2.6 Q.E.D.+-- Step: 1.7.2.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: exprSize, interpInEnv, sbv.lookup, subst+-- [Proven] substCorrect :: Ɐe ∷ (Expr String Integer) → Ɐnm ∷ String → Ɐv ∷ Integer → Ɐenv ∷ [(String, Integer)] → Bool+substCorrect :: TP (Proof (Forall "e" Exp -> Forall "nm" String -> Forall "v" Integer -> Forall "env" EL -> SBool))+substCorrect = do+ mnn <- recall measureNonNeg+ sqrC <- recall sqrCong+ sqrH <- recall sqrHelper+ addH <- recall addHelper+ mulCL <- recall mulCongL+ mulCR <- recall mulCongR+ mulH <- recall mulHelper+ letH <- recall letHelper+ varH <- recall varHelper+ eSwp <- recall envSwap+ eShd <- recall envShadow++ sInduct "substCorrect"+ (\(Forall @"e" (e :: SE)) (Forall @"nm" (nm :: SString)) (Forall @"v" (v :: SInteger)) (Forall @"env" (env :: E)) ->+ interpInEnv (ST.tuple (nm, v) .: env) e .== interpInEnv env (subst nm v e))+ (\e _ _ _ -> size e :: SInteger, [proofOf mnn]) $+ \ih e nm v env ->+ let nmv = ST.tuple (nm, v)+ env1 = nmv .: env+ in []+ |- cases [ isVar e+ ==> let x = svar e+ in interpInEnv env1 (sVar x)+ ?? "Var"+ =: cases [ x .== nm+ ==> interpInEnv env1 (sVar nm)+ ?? varH `at` (Inst @"env" env1, Inst @"nm" nm)+ =: SL.lookup nm env1+ =: v+ =: interpInEnv env (sCon v)+ =: interpInEnv env (subst nm v (sVar nm))+ =: qed+ , x ./= nm+ ==> interpInEnv env1 (sVar x)+ ?? varH `at` (Inst @"env" env1, Inst @"nm" x)+ =: SL.lookup x env1+ =: SL.lookup x env+ ?? varH `at` (Inst @"env" env, Inst @"nm" x)+ =: interpInEnv env (sVar x)+ =: interpInEnv env (subst nm v (sVar x))+ =: qed+ ]++ , isCon e+ ==> let c = scon e+ in interpInEnv env1 (sCon c)+ ?? "Con"+ =: interpInEnv env (subst nm v (sCon c))+ =: qed++ , isSqr e+ ==> let a = ssqrVal e+ in interpInEnv env1 (sSqr a)+ ?? "Sqr"+ ?? sqrH `at` (Inst @"env" env1, Inst @"a" a)+ =: interpInEnv env1 a * interpInEnv env1 a+ ?? ih `at` (Inst @"e" a, Inst @"nm" nm, Inst @"v" v, Inst @"env" env)+ ?? sqrC `at` (Inst @"a" (interpInEnv env1 a), Inst @"b" (interpInEnv env (subst nm v a)))+ =: interpInEnv env (subst nm v a) * interpInEnv env (subst nm v a)+ ?? sqrH `at` (Inst @"env" env, Inst @"a" (subst nm v a))+ =: interpInEnv env (sSqr (subst nm v a))+ =: interpInEnv env (subst nm v (sSqr a))+ =: qed++ , isInc e+ ==> let a = sincVal e+ in interpInEnv env1 (sInc a)+ ?? "Inc"+ ?? ih `at` (Inst @"e" a, Inst @"nm" nm, Inst @"v" v, Inst @"env" env)+ =: interpInEnv env (subst nm v (sInc a))+ =: qed++ , isAdd e+ ==> let a = sadd1 e+ b = sadd2 e+ in interpInEnv env1 (sAdd a b)+ ?? "Add"+ ?? addH `at` (Inst @"env" env1, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env1 a + interpInEnv env1 b+ ?? ih `at` (Inst @"e" a, Inst @"nm" nm, Inst @"v" v, Inst @"env" env)+ ?? ih `at` (Inst @"e" b, Inst @"nm" nm, Inst @"v" v, Inst @"env" env)+ =: interpInEnv env (subst nm v a) + interpInEnv env (subst nm v b)+ ?? addH `at` (Inst @"env" env, Inst @"a" (subst nm v a), Inst @"b" (subst nm v b))+ =: interpInEnv env (sAdd (subst nm v a) (subst nm v b))+ =: interpInEnv env (subst nm v (sAdd a b))+ =: qed++ , isMul e+ ==> let a = smul1 e+ b = smul2 e+ in interpInEnv env1 (sMul a b)+ ?? "Mul"+ ?? mulH `at` (Inst @"env" env1, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env1 a * interpInEnv env1 b+ ?? ih `at` (Inst @"e" a, Inst @"nm" nm, Inst @"v" v, Inst @"env" env)+ ?? mulCL `at` (Inst @"a" (interpInEnv env1 a), Inst @"b" (interpInEnv env (subst nm v a)), Inst @"c" (interpInEnv env1 b))+ =: interpInEnv env (subst nm v a) * interpInEnv env1 b+ ?? ih `at` (Inst @"e" b, Inst @"nm" nm, Inst @"v" v, Inst @"env" env)+ ?? mulCR `at` (Inst @"a" (interpInEnv env (subst nm v a)), Inst @"b" (interpInEnv env1 b), Inst @"c" (interpInEnv env (subst nm v b)))+ =: interpInEnv env (subst nm v a) * interpInEnv env (subst nm v b)+ ?? mulH `at` (Inst @"env" env, Inst @"a" (subst nm v a), Inst @"b" (subst nm v b))+ =: interpInEnv env (sMul (subst nm v a) (subst nm v b))+ =: interpInEnv env (subst nm v (sMul a b))+ =: qed++ , isLet e+ ==> let x = slvar e+ a = slval e+ b = slbody e+ val = interpInEnv env1 a+ in interpInEnv env1 (sLet x a b)+ ?? "Let"+ ?? letH `at` (Inst @"env" env1, Inst @"nm" x, Inst @"a" a, Inst @"b" b)+ =: interpInEnv (ST.tuple (x, val) .: env1) b+ =: cases [ x .== nm+ ==> let xv = ST.tuple (x, val)+ in interpInEnv (xv .: nmv .: env) b+ ?? "shadow"+ ?? eShd `at` (Inst @"e" b, Inst @"pfx" (SL.nil :: E), Inst @"env" env, Inst @"b1" xv, Inst @"b2" nmv)+ =: interpInEnv (xv .: env) b+ ?? ih `at` (Inst @"e" a, Inst @"nm" nm, Inst @"v" v, Inst @"env" env)+ =: interpInEnv (ST.tuple (x, interpInEnv env (subst nm v a)) .: env) b+ ?? letH `at` (Inst @"env" env, Inst @"nm" x, Inst @"a" (subst nm v a), Inst @"b" b)+ =: interpInEnv env (sLet x (subst nm v a) b)+ =: interpInEnv env (subst nm v (sLet x a b))+ =: qed+ , x ./= nm+ ==> let xv = ST.tuple (x, val)+ in interpInEnv (xv .: nmv .: env) b+ ?? "swap"+ ?? eSwp `at` (Inst @"e" b, Inst @"pfx" (SL.nil :: E), Inst @"env" env, Inst @"b1" xv, Inst @"b2" nmv)+ =: interpInEnv (nmv .: xv .: env) b+ ?? ih `at` (Inst @"e" b, Inst @"nm" nm, Inst @"v" v, Inst @"env" (xv .: env))+ =: interpInEnv (xv .: env) (subst nm v b)+ ?? ih `at` (Inst @"e" a, Inst @"nm" nm, Inst @"v" v, Inst @"env" env)+ =: interpInEnv (ST.tuple (x, interpInEnv env (subst nm v a)) .: env) (subst nm v b)+ ?? letH `at` (Inst @"env" env, Inst @"nm" x, Inst @"a" (subst nm v a), Inst @"b" (subst nm v b))+ =: interpInEnv env (sLet x (subst nm v a) (subst nm v b))+ =: interpInEnv env (subst nm v (sLet x a b))+ =: qed+ ]+ ]++-- | Simplification preserves semantics.+--+-- >>> runTPWith cvc5 simpCorrect+-- Lemma: sqrCong Q.E.D.+-- Lemma: sqrHelper Q.E.D.+-- Lemma: addHelper Q.E.D.+-- Lemma: mulCongL Q.E.D.+-- Lemma: mulCongR Q.E.D.+-- Lemma: mulHelper Q.E.D.+-- Lemma: letHelper Q.E.D.+-- Lemma: substCorrect Q.E.D.+-- Lemma: simpCorrect+-- Step: 1 (7 way case split)+-- Step: 1.1.1 (Var) Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.1.3 Q.E.D.+-- Step: 1.2.1 (Con) Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 (Sqr) Q.E.D.+-- Step: 1.3.2 (2 way case split)+-- Step: 1.3.2.1.1 Q.E.D.+-- Step: 1.3.2.1.2 (Sqr Con) Q.E.D.+-- Step: 1.3.2.1.3 Q.E.D.+-- Step: 1.3.2.1.4 Q.E.D.+-- Step: 1.3.2.1.5 Q.E.D.+-- Step: 1.3.2.2.1 Q.E.D.+-- Step: 1.3.2.2.2 (Sqr _) Q.E.D.+-- Step: 1.3.2.Completeness Q.E.D.+-- Step: 1.4.1 (Inc) Q.E.D.+-- Step: 1.4.2 (2 way case split)+-- Step: 1.4.2.1.1 Q.E.D.+-- Step: 1.4.2.1.2 (Inc Con) Q.E.D.+-- Step: 1.4.2.1.3 Q.E.D.+-- Step: 1.4.2.2.1 Q.E.D.+-- Step: 1.4.2.2.2 (Inc _) Q.E.D.+-- Step: 1.4.2.Completeness Q.E.D.+-- Step: 1.5.1 (Add) Q.E.D.+-- Step: 1.5.2 (6 way case split)+-- Step: 1.5.2.1.1 Q.E.D.+-- Step: 1.5.2.1.2 (Add 0+b) Q.E.D.+-- Step: 1.5.2.1.3 Q.E.D.+-- Step: 1.5.2.2.1 Q.E.D.+-- Step: 1.5.2.2.2 (Add a+0) Q.E.D.+-- Step: 1.5.2.2.3 Q.E.D.+-- Step: 1.5.2.3.1 Q.E.D.+-- Step: 1.5.2.3.2 (Add Con) Q.E.D.+-- Step: 1.5.2.3.3 Q.E.D.+-- Step: 1.5.2.4 (2 way case split)+-- Step: 1.5.2.4.1.1 Q.E.D.+-- Step: 1.5.2.4.1.2 (Add 0,_) Q.E.D.+-- Step: 1.5.2.4.1.3 Q.E.D.+-- Step: 1.5.2.4.2.1 Q.E.D.+-- Step: 1.5.2.4.2.2 (Add C,_) Q.E.D.+-- Step: 1.5.2.4.Completeness Q.E.D.+-- Step: 1.5.2.5 (2 way case split)+-- Step: 1.5.2.5.1.1 Q.E.D.+-- Step: 1.5.2.5.1.2 (Add _,0) Q.E.D.+-- Step: 1.5.2.5.1.3 Q.E.D.+-- Step: 1.5.2.5.2.1 Q.E.D.+-- Step: 1.5.2.5.2.2 (Add _,C) Q.E.D.+-- Step: 1.5.2.5.Completeness Q.E.D.+-- Step: 1.5.2.6.1 Q.E.D.+-- Step: 1.5.2.6.2 (Add _,_) Q.E.D.+-- Step: 1.5.2.Completeness Q.E.D.+-- Step: 1.6.1 (Mul) Q.E.D.+-- Step: 1.6.2 (8 way case split)+-- Step: 1.6.2.1.1 Q.E.D.+-- Step: 1.6.2.1.2 (Mul 0*b) Q.E.D.+-- Step: 1.6.2.1.3 Q.E.D.+-- Step: 1.6.2.2.1 Q.E.D.+-- Step: 1.6.2.2.2 (Mul a*0) Q.E.D.+-- Step: 1.6.2.2.3 Q.E.D.+-- Step: 1.6.2.3.1 Q.E.D.+-- Step: 1.6.2.3.2 (Mul 1*b) Q.E.D.+-- Step: 1.6.2.3.3 Q.E.D.+-- Step: 1.6.2.3.4 Q.E.D.+-- Step: 1.6.2.3.5 Q.E.D.+-- Step: 1.6.2.4.1 Q.E.D.+-- Step: 1.6.2.4.2 (Mul a*1) Q.E.D.+-- Step: 1.6.2.4.3 Q.E.D.+-- Step: 1.6.2.4.4 Q.E.D.+-- Step: 1.6.2.4.5 Q.E.D.+-- Step: 1.6.2.5.1 Q.E.D.+-- Step: 1.6.2.5.2 (Mul Con) Q.E.D.+-- Step: 1.6.2.5.3 Q.E.D.+-- Step: 1.6.2.5.4 Q.E.D.+-- Step: 1.6.2.5.5 Q.E.D.+-- Step: 1.6.2.5.6 Q.E.D.+-- Step: 1.6.2.6 (3 way case split)+-- Step: 1.6.2.6.1.1 Q.E.D.+-- Step: 1.6.2.6.1.2 (Mul 0,_) Q.E.D.+-- Step: 1.6.2.6.1.3 Q.E.D.+-- Step: 1.6.2.6.2.1 Q.E.D.+-- Step: 1.6.2.6.2.2 (Mul 1,_) Q.E.D.+-- Step: 1.6.2.6.2.3 Q.E.D.+-- Step: 1.6.2.6.2.4 Q.E.D.+-- Step: 1.6.2.6.2.5 Q.E.D.+-- Step: 1.6.2.6.3.1 Q.E.D.+-- Step: 1.6.2.6.3.2 (Mul C,_) Q.E.D.+-- Step: 1.6.2.6.Completeness Q.E.D.+-- Step: 1.6.2.7 (3 way case split)+-- Step: 1.6.2.7.1.1 Q.E.D.+-- Step: 1.6.2.7.1.2 (Mul _,0) Q.E.D.+-- Step: 1.6.2.7.1.3 Q.E.D.+-- Step: 1.6.2.7.2.1 Q.E.D.+-- Step: 1.6.2.7.2.2 (Mul _,1) Q.E.D.+-- Step: 1.6.2.7.2.3 Q.E.D.+-- Step: 1.6.2.7.2.4 Q.E.D.+-- Step: 1.6.2.7.2.5 Q.E.D.+-- Step: 1.6.2.7.3.1 Q.E.D.+-- Step: 1.6.2.7.3.2 (Mul _,C) Q.E.D.+-- Step: 1.6.2.7.Completeness Q.E.D.+-- Step: 1.6.2.8.1 Q.E.D.+-- Step: 1.6.2.8.2 (Mul _,_) Q.E.D.+-- Step: 1.6.2.Completeness Q.E.D.+-- Step: 1.7.1 (Let) Q.E.D.+-- Step: 1.7.2 (2 way case split)+-- Step: 1.7.2.1.1 Q.E.D.+-- Step: 1.7.2.1.2 (Let Con) Q.E.D.+-- Step: 1.7.2.1.3 Q.E.D.+-- Step: 1.7.2.1.4 Q.E.D.+-- Step: 1.7.2.2.1 Q.E.D.+-- Step: 1.7.2.2.2 (Let _) Q.E.D.+-- Step: 1.7.2.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: exprSize, interpInEnv, sbv.lookup, simplify, subst+-- [Proven] simpCorrect :: Ɐe ∷ (Expr String Integer) → Ɐenv ∷ [(String, Integer)] → Bool+simpCorrect :: TP (Proof (Forall "e" Exp -> Forall "env" EL -> SBool))+simpCorrect = do+ sqrC <- recall sqrCong+ sqrH <- recall sqrHelper+ addH <- recall addHelper+ mulCL <- recall mulCongL+ mulCR <- recall mulCongR+ mulH <- recall mulHelper+ letH <- recall letHelper+ subC <- recall substCorrect++ calc "simpCorrect"+ (\(Forall @"e" (e :: SE)) (Forall @"env" (env :: E)) -> interpInEnv env (simplify e) .== interpInEnv env e) $+ \e env -> []+ |- [pCase| e of+ Var nm -> interpInEnv env (simplify e)+ ?? "Var"+ =: interpInEnv env (simplify (sVar nm))+ =: interpInEnv env (sVar nm)+ =: interpInEnv env e+ =: qed++ Con c -> interpInEnv env (simplify e)+ ?? "Con"+ =: interpInEnv env (simplify (sCon c))+ =: interpInEnv env (sCon c)+ =: interpInEnv env e+ =: qed++ Sqr a -> interpInEnv env (simplify e)+ ?? "Sqr"+ =: interpInEnv env (simplify (sSqr a))+ =: cases [ isCon a+ ==> let v = scon a+ in interpInEnv env (simplify (sSqr (sCon v)))+ ?? "Sqr Con"+ =: interpInEnv env (sCon (v * v))+ ?? interpInEnv env (sCon (v * v)) .== v * v+ =: v * v+ ?? sqrC `at` (Inst @"a" (interpInEnv env (sCon v)), Inst @"b" v)+ =: interpInEnv env (sCon v) * interpInEnv env (sCon v)+ ?? sqrH `at` (Inst @"env" env, Inst @"a" (sCon v))+ =: interpInEnv env (sSqr (sCon v))+ =: qed+ , sNot (isCon a)+ ==> interpInEnv env (simplify (sSqr a))+ ?? "Sqr _"+ =: interpInEnv env (sSqr a)+ =: qed+ ]++ Inc a -> interpInEnv env (simplify e)+ ?? "Inc"+ =: interpInEnv env (simplify (sInc a))+ =: cases [ isCon a+ ==> let v = scon a+ in interpInEnv env (simplify (sInc (sCon v)))+ ?? "Inc Con"+ =: interpInEnv env (sCon (v + 1))+ =: interpInEnv env (sInc (sCon v))+ =: qed+ , sNot (isCon a)+ ==> interpInEnv env (simplify (sInc a))+ ?? "Inc _"+ =: interpInEnv env (sInc a)+ =: qed+ ]++ Add a b -> interpInEnv env (simplify e)+ ?? "Add"+ =: interpInEnv env (simplify (sAdd a b))+ =: cases [ isCon a .&& scon a .== 0+ ==> interpInEnv env (simplify (sAdd (sCon 0) b))+ ?? "Add 0+b"+ =: interpInEnv env b+ ?? addH `at` (Inst @"env" env, Inst @"a" (sCon 0), Inst @"b" b)+ =: interpInEnv env (sAdd (sCon 0) b)+ =: qed++ , isCon b .&& scon b .== 0+ ==> interpInEnv env (simplify (sAdd a (sCon 0)))+ ?? "Add a+0"+ =: interpInEnv env a+ ?? addH `at` (Inst @"env" env, Inst @"a" a, Inst @"b" (sCon 0))+ =: interpInEnv env (sAdd a (sCon 0))+ =: qed++ , isCon a .&& isCon b+ ==> let va = scon a; vb = scon b+ in interpInEnv env (simplify (sAdd (sCon va) (sCon vb)))+ ?? "Add Con"+ =: interpInEnv env (sCon (va + vb))+ ?? addH `at` (Inst @"env" env, Inst @"a" (sCon va), Inst @"b" (sCon vb))+ =: interpInEnv env (sAdd (sCon va) (sCon vb))+ =: qed++ , isCon a .&& sNot (isCon b)+ ==> let va = scon a+ in cases [ va .== 0+ ==> interpInEnv env (simplify (sAdd (sCon 0) b))+ ?? "Add 0,_"+ =: interpInEnv env b+ ?? addH `at` (Inst @"env" env, Inst @"a" (sCon 0), Inst @"b" b)+ =: interpInEnv env (sAdd (sCon 0) b)+ =: qed+ , va ./= 0+ ==> interpInEnv env (simplify (sAdd (sCon va) b))+ ?? "Add C,_"+ =: interpInEnv env (sAdd (sCon va) b)+ =: qed+ ]++ , sNot (isCon a) .&& isCon b+ ==> let vb = scon b+ in cases [ vb .== 0+ ==> interpInEnv env (simplify (sAdd a (sCon 0)))+ ?? "Add _,0"+ =: interpInEnv env a+ ?? addH `at` (Inst @"env" env, Inst @"a" a, Inst @"b" (sCon 0))+ =: interpInEnv env (sAdd a (sCon 0))+ =: qed+ , vb ./= 0+ ==> interpInEnv env (simplify (sAdd a (sCon vb)))+ ?? "Add _,C"+ =: interpInEnv env (sAdd a (sCon vb))+ =: qed+ ]++ , sNot (isCon a) .&& sNot (isCon b)+ ==> interpInEnv env (simplify (sAdd a b))+ ?? "Add _,_"+ =: interpInEnv env (sAdd a b)+ =: qed+ ]++ Mul a b -> interpInEnv env (simplify e)+ ?? "Mul"+ =: interpInEnv env (simplify (sMul a b))+ =: cases [ isCon a .&& scon a .== 0+ ==> interpInEnv env (simplify (sMul (sCon 0) b))+ ?? "Mul 0*b"+ =: interpInEnv env (sCon 0)+ ?? mulH `at` (Inst @"env" env, Inst @"a" (sCon 0), Inst @"b" b)+ =: interpInEnv env (sMul (sCon 0) b)+ =: qed++ , isCon b .&& scon b .== 0+ ==> interpInEnv env (simplify (sMul a (sCon 0)))+ ?? "Mul a*0"+ =: interpInEnv env (sCon 0)+ ?? mulH `at` (Inst @"env" env, Inst @"a" a, Inst @"b" (sCon 0))+ =: interpInEnv env (sMul a (sCon 0))+ =: qed++ , isCon a .&& scon a .== 1+ ==> interpInEnv env (simplify (sMul (sCon 1) b))+ ?? "Mul 1*b"+ =: interpInEnv env b+ =: 1 * interpInEnv env b+ ?? interpInEnv env (sCon 1) .== 1+ =: interpInEnv env (sCon 1) * interpInEnv env b+ ?? mulH `at` (Inst @"env" env, Inst @"a" (sCon 1), Inst @"b" b)+ =: interpInEnv env (sMul (sCon 1) b)+ =: qed++ , isCon b .&& scon b .== 1+ ==> interpInEnv env (simplify (sMul a (sCon 1)))+ ?? "Mul a*1"+ =: interpInEnv env a+ =: interpInEnv env a * 1+ ?? interpInEnv env (sCon 1) .== 1+ =: interpInEnv env a * interpInEnv env (sCon 1)+ ?? mulH `at` (Inst @"env" env, Inst @"a" a, Inst @"b" (sCon 1))+ =: interpInEnv env (sMul a (sCon 1))+ =: qed++ , isCon a .&& isCon b+ ==> let va = scon a; vb = scon b+ in interpInEnv env (simplify (sMul (sCon va) (sCon vb)))+ ?? "Mul Con"+ ?? simplify (sMul (sCon va) (sCon vb)) .== sCon (va * vb)+ =: interpInEnv env (sCon (va * vb))+ ?? interpInEnv env (sCon (va * vb)) .== va * vb+ =: va * vb+ ?? mulCL `at` (Inst @"a" (interpInEnv env (sCon va)), Inst @"b" va, Inst @"c" vb)+ =: interpInEnv env (sCon va) * vb+ ?? mulCR `at` (Inst @"a" (interpInEnv env (sCon va)), Inst @"b" (interpInEnv env (sCon vb)), Inst @"c" vb)+ =: interpInEnv env (sCon va) * interpInEnv env (sCon vb)+ ?? mulH `at` (Inst @"env" env, Inst @"a" (sCon va), Inst @"b" (sCon vb))+ =: interpInEnv env (sMul (sCon va) (sCon vb))+ =: qed++ , isCon a .&& sNot (isCon b)+ ==> let va = scon a+ in cases [ va .== 0+ ==> interpInEnv env (simplify (sMul (sCon 0) b))+ ?? "Mul 0,_"+ =: interpInEnv env (sCon 0)+ ?? mulH `at` (Inst @"env" env, Inst @"a" (sCon 0), Inst @"b" b)+ =: interpInEnv env (sMul (sCon 0) b)+ =: qed+ , va .== 1+ ==> interpInEnv env (simplify (sMul (sCon 1) b))+ ?? "Mul 1,_"+ =: interpInEnv env b+ =: 1 * interpInEnv env b+ ?? interpInEnv env (sCon 1) .== 1+ =: interpInEnv env (sCon 1) * interpInEnv env b+ ?? mulH `at` (Inst @"env" env, Inst @"a" (sCon 1), Inst @"b" b)+ =: interpInEnv env (sMul (sCon 1) b)+ =: qed+ , va ./= 0 .&& va ./= 1+ ==> interpInEnv env (simplify (sMul (sCon va) b))+ ?? "Mul C,_"+ =: interpInEnv env (sMul (sCon va) b)+ =: qed+ ]++ , sNot (isCon a) .&& isCon b+ ==> let vb = scon b+ in cases [ vb .== 0+ ==> interpInEnv env (simplify (sMul a (sCon 0)))+ ?? "Mul _,0"+ =: interpInEnv env (sCon 0)+ ?? mulH `at` (Inst @"env" env, Inst @"a" a, Inst @"b" (sCon 0))+ =: interpInEnv env (sMul a (sCon 0))+ =: qed+ , vb .== 1+ ==> interpInEnv env (simplify (sMul a (sCon 1)))+ ?? "Mul _,1"+ =: interpInEnv env a+ =: interpInEnv env a * 1+ ?? interpInEnv env (sCon 1) .== 1+ =: interpInEnv env a * interpInEnv env (sCon 1)+ ?? mulH `at` (Inst @"env" env, Inst @"a" a, Inst @"b" (sCon 1))+ =: interpInEnv env (sMul a (sCon 1))+ =: qed+ , vb ./= 0 .&& vb ./= 1+ ==> interpInEnv env (simplify (sMul a (sCon vb)))+ ?? "Mul _,C"+ =: interpInEnv env (sMul a (sCon vb))+ =: qed+ ]++ , sNot (isCon a) .&& sNot (isCon b)+ ==> interpInEnv env (simplify (sMul a b))+ ?? "Mul _,_"+ =: interpInEnv env (sMul a b)+ =: qed+ ]++ Let nm a b -> interpInEnv env (simplify e)+ ?? "Let"+ =: interpInEnv env (simplify (sLet nm a b))+ =: cases [ isCon a+ ==> let v = scon a+ in interpInEnv env (simplify (sLet nm (sCon v) b))+ ?? "Let Con"+ =: interpInEnv env (subst nm v b)+ ?? subC `at` (Inst @"e" b, Inst @"nm" nm, Inst @"v" v, Inst @"env" env)+ =: interpInEnv (ST.tuple (nm, v) .: env) b+ ?? letH `at` (Inst @"env" env, Inst @"nm" nm, Inst @"a" (sCon v), Inst @"b" b)+ =: interpInEnv env (sLet nm (sCon v) b)+ =: qed+ , sNot (isCon a)+ ==> interpInEnv env (simplify (sLet nm a b))+ ?? "Let _"+ =: interpInEnv env (sLet nm a b)+ =: qed+ ]+ |]++-- | Constant folding preserves the semantics: interpreting an expression+-- is the same as constant-folding it first and then interpreting the result.+--+-- >>> runTPWith cvc5 cfoldCorrect+-- Lemma: measureNonNeg Q.E.D.+-- Lemma: simpCorrect Q.E.D.+-- Lemma: sqrCong Q.E.D. [Cached]+-- Lemma: sqrHelper Q.E.D. [Cached]+-- Lemma: mulCongL Q.E.D. [Cached]+-- Lemma: mulCongR Q.E.D. [Cached]+-- Lemma: mulHelper Q.E.D. [Cached]+-- Inductive lemma (strong): cfoldCorrect+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (7 way case split)+-- Step: 1.1.1 (case Var) Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.1.3 Q.E.D.+-- Step: 1.2.1 (case Con) Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 (case Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 Q.E.D.+-- Step: 1.3.7 Q.E.D.+-- Step: 1.4.1 (case Inc) 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.5.1 (case Add) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.5.5 Q.E.D.+-- Step: 1.6.1 (case Mul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.6.5 Q.E.D.+-- Step: 1.6.6 Q.E.D.+-- Step: 1.6.7 Q.E.D.+-- Step: 1.6.8 Q.E.D.+-- Step: 1.7.1 (case Let) Q.E.D.+-- Step: 1.7.2 Q.E.D.+-- Step: 1.7.3 Q.E.D.+-- Step: 1.7.4 Q.E.D.+-- Step: 1.7.5 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: cfold, exprSize, interpInEnv, sbv.lookup, simplify, subst+-- [Proven] cfoldCorrect :: Ɐe ∷ (Expr String Integer) → Ɐenv ∷ [(String, Integer)] → Bool+cfoldCorrect :: TP (Proof (Forall "e" Exp -> Forall "env" EL -> SBool))+cfoldCorrect = do+ mnn <- recall measureNonNeg+ sc <- recall simpCorrect+ sqrC <- recall sqrCong+ sqrH <- recall sqrHelper+ mulCL <- recall mulCongL+ mulCR <- recall mulCongR+ mulH <- recall mulHelper++ sInduct "cfoldCorrect"+ (\(Forall @"e" (e :: SE)) (Forall @"env" (env :: E)) -> interpInEnv env (cfold e) .== interpInEnv env e)+ (\e _ -> size e, [proofOf mnn]) $+ \ih e env -> []+ |- [pCase| e of+ Var nm -> interpInEnv env (cfold e)+ ?? "case Var"+ =: interpInEnv env (cfold (sVar nm))+ =: interpInEnv env (sVar nm)+ =: interpInEnv env e+ =: qed++ Con v -> interpInEnv env (cfold e)+ ?? "case Con"+ =: interpInEnv env (cfold (sCon v))+ =: interpInEnv env (sCon v)+ =: interpInEnv env e+ =: qed++ Sqr a -> interpInEnv env (cfold e)+ ?? "case Sqr"+ =: interpInEnv env (cfold (sSqr a))+ =: interpInEnv env (simplify (sSqr (cfold a)))+ ?? sc `at` (Inst @"e" (sSqr (cfold a)), Inst @"env" env)+ =: interpInEnv env (sSqr (cfold a))+ ?? sqrH `at` (Inst @"env" env, Inst @"a" (cfold a))+ =: interpInEnv env (cfold a) * interpInEnv env (cfold a)+ ?? ih `at` (Inst @"e" a, Inst @"env" env)+ ?? sqrC `at` (Inst @"a" (interpInEnv env (cfold a)), Inst @"b" (interpInEnv env a))+ =: interpInEnv env a * interpInEnv env a+ ?? sqrH `at` (Inst @"env" env, Inst @"a" a)+ =: interpInEnv env (sSqr a)+ =: interpInEnv env e+ =: qed++ Inc a -> interpInEnv env (cfold e)+ ?? "case Inc"+ =: interpInEnv env (cfold (sInc a))+ =: interpInEnv env (simplify (sInc (cfold a)))+ ?? sc `at` (Inst @"e" (sInc (cfold a)), Inst @"env" env)+ =: interpInEnv env (sInc (cfold a))+ ?? ih `at` (Inst @"e" a, Inst @"env" env)+ =: interpInEnv env (sInc a)+ =: interpInEnv env e+ =: qed++ Add a b -> interpInEnv env (cfold e)+ ?? "case Add"+ =: interpInEnv env (cfold (sAdd a b))+ =: interpInEnv env (simplify (sAdd (cfold a) (cfold b)))+ ?? sc `at` (Inst @"e" (sAdd (cfold a) (cfold b)), Inst @"env" env)+ =: interpInEnv env (sAdd (cfold a) (cfold b))+ ?? ih `at` (Inst @"e" a, Inst @"env" env)+ ?? ih `at` (Inst @"e" b, Inst @"env" env)+ =: interpInEnv env (sAdd a b)+ =: interpInEnv env e+ =: qed++ Mul a b -> interpInEnv env (cfold e)+ ?? "case Mul"+ =: interpInEnv env (cfold (sMul a b))+ =: interpInEnv env (simplify (sMul (cfold a) (cfold b)))+ ?? sc `at` (Inst @"e" (sMul (cfold a) (cfold b)), Inst @"env" env)+ =: interpInEnv env (sMul (cfold a) (cfold b))+ ?? mulH `at` (Inst @"env" env, Inst @"a" (cfold a), Inst @"b" (cfold b))+ =: interpInEnv env (cfold a) * interpInEnv env (cfold b)+ ?? ih `at` (Inst @"e" a, Inst @"env" env)+ ?? mulCL `at` (Inst @"a" (interpInEnv env (cfold a)), Inst @"b" (interpInEnv env a), Inst @"c" (interpInEnv env (cfold b)))+ =: interpInEnv env a * interpInEnv env (cfold b)+ ?? ih `at` (Inst @"e" b, Inst @"env" env)+ ?? mulCR `at` (Inst @"a" (interpInEnv env a), Inst @"b" (interpInEnv env (cfold b)), Inst @"c" (interpInEnv env b))+ =: interpInEnv env a * interpInEnv env b+ ?? mulH `at` (Inst @"env" env, Inst @"a" a, Inst @"b" b)+ =: interpInEnv env (sMul a b)+ =: interpInEnv env e+ =: qed++ Let nm a b -> interpInEnv env (cfold e)+ ?? "case Let"+ =: interpInEnv env (cfold (sLet nm a b))+ =: interpInEnv env (simplify (sLet nm (cfold a) (cfold b)))+ ?? sc `at` (Inst @"e" (sLet nm (cfold a) (cfold b)), Inst @"env" env)+ =: interpInEnv env (sLet nm (cfold a) (cfold b))+ ?? ih `at` (Inst @"e" a, Inst @"env" env)+ ?? ih `at` (Inst @"e" b, Inst @"env" (ST.tuple (nm, interpInEnv env a) .: env))+ =: interpInEnv env (sLet nm a b)+ =: interpInEnv env e+ =: qed+ |]++{-# ANN simpCorrect ("HLint: ignore Evaluate" :: String) #-}+{-# ANN cfoldCorrect ("HLint: ignore Evaluate" :: String) #-}
+ Documentation/SBV/Examples/TP/Countdown.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Countdown+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving properties of a countdown function that builds a list+-- from @n@ down to @0@.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Countdown where++import Prelude hiding (head, length, (!!))++import Data.SBV+import Data.SBV.List+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+#endif++-- * Definitions++-- | A function that counts down from @n@ to @0@, building a list.+countdown :: SInteger -> SList Integer+countdown = smtFunction "countdown"+ $ \n -> [sCase| n of+ v | v .<= 0 -> singleton 0+ | True -> v .: countdown (v - 1)+ |]++-- * Correctness++-- | Prove that @countdown n@ always starts with @n@, for positive @n@.+--+-- >>> runTP countdownHead+-- Lemma: countdownHead Q.E.D.+-- Functions proven terminating: countdown+-- [Proven] countdownHead :: Ɐn ∷ Integer → Bool+countdownHead :: TP (Proof (Forall "n" Integer -> SBool))+countdownHead = lemma "countdownHead" (\(Forall @"n" n) -> n .> 0 .=> head (countdown n) .== n) []++-- | Prove by induction that @countdown n@ is never empty.+--+-- >>> runTP countdownNonEmpty+-- Inductive lemma: countdownNonEmpty+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: countdown+-- [Proven] countdownNonEmpty :: Ɐn ∷ Integer → Bool+countdownNonEmpty :: TP (Proof (Forall "n" Integer -> SBool))+countdownNonEmpty =+ induct "countdownNonEmpty"+ (\(Forall @"n" n) -> n .>= 0 .=> length (countdown n) .> 0) $+ \ih n -> [n .>= 0] |- length (countdown (n + 1))+ =: length ((n + 1) .: countdown n)+ ?? ih+ =: 1 + length (countdown n)+ =: qed++-- | Prove by induction that @countdown n@ has length @n + 1@.+--+-- >>> runTP countdownLen+-- Inductive lemma: countdownLen+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: countdown+-- [Proven] countdownLen :: Ɐn ∷ Integer → Bool+countdownLen :: TP (Proof (Forall "n" Integer -> SBool))+countdownLen =+ induct "countdownLen"+ (\(Forall @"n" n) -> n .>= 0 .=> length (countdown n) .== n + 1) $+ \ih n -> [n .>= 0] |- length (countdown (n + 1))+ =: length ((n + 1) .: countdown n)+ =: 1 + length (countdown n)+ ?? ih+ =: n + 2+ =: qed++-- | Prove by induction that the @k@-th element of @countdown n@ is @n - k@.+--+-- The key subtlety is that the 'induct' Result step only has access to the calc chain+-- equalities, not to the helper proofs (which live inside each step's assertion stack).+-- The Result step must prove @P(n+1, k)@ for all valid @k@, i.e., @0 <= k <= n+1@.+-- If the intros only cover @k <= n@, the Result step has no information for @k = n+1@+-- and hangs. The fix is to use intros @[n >= 0, 0 <= k, k <= n+1]@ so the calc chain+-- covers the entire domain of the goal.+--+-- >>> runTP countdownElem+-- Lemma: countdownLen Q.E.D.+-- Lemma: elemOne Q.E.D.+-- Inductive lemma: countdownElem+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: countdown+-- [Proven] countdownElem :: Ɐn ∷ Integer → Ɐk ∷ Integer → Bool+countdownElem :: TP (Proof (Forall "n" Integer -> Forall "k" Integer -> SBool))+countdownElem = do+ cLen <- recall countdownLen++ -- NB. The precondition uses (<=) not (<): this is important so the lemma covers+ -- k = length y (the last valid index of x .: y), not just k < length y.+ elemOne <- lemma "elemOne" (\(Forall @"x" (x :: SInteger)) (Forall @"y" y) (Forall @"k" k) ->+ k .> 0 .&& k .<= length y .=> (x .: y) !! k .== y !! (k - 1)) []++ induct "countdownElem"+ (\(Forall @"n" n) (Forall @"k" k) -> 0 .<= k .&& k .<= n .=> countdown n !! k .== n - k) $+ \ih n k -> [n .>= 0, 0 .<= k, k .<= n + 1]+ |- countdown (n + 1) !! k+ =: ((n + 1) .: countdown n) !! k+ ?? elemOne+ ?? cLen+ ?? ih `at` Inst @"k" (k - 1)+ =: n + 1 - k+ =: qed
+ Documentation/SBV/Examples/TP/Fibonacci.hs view
@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------+-- |+-- 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 QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}++{-# 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 -> [sCase| n of+ _ | 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 -> [sCase| n of+ _ | 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 tail recursive 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.+-- Functions proven terminating: fib, fibonacci+-- [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/GCD.hs view
@@ -0,0 +1,1063 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.GCD+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- We define three different versions of the GCD algorithm: (1) Regular+-- version using the modulus operator, (2) the more basic version using+-- subtraction, and (3) the so called binary GCD. We prove that the modulus+-- based algorithm correct, i.e., that it calculates the greatest-common-divisor+-- of its arguments. We then prove that the other two variants are equivalent+-- to this version, thus establishing their correctness as well.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.GCD where++import Prelude hiding (gcd)++import Data.SBV+import Data.SBV.TP+import Data.SBV.Tuple++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+#endif++-- * Calculating GCD++-- | @nGCD@ is the version of GCD that works on non-negative integers.+--+-- Ideally, we should make this function local to @gcd@, but then we can't refer to it explicitly in our proofs.+--+-- Note on maximality: Note that, by definition @gcd 0 0 = 0@. Since any number divides @0@,+-- there is no greatest common divisor for the pair @(0, 0)@. So, maximality here is meant+-- to be in terms of divisibility. That is, any divisor of @a@ and @b@ will also divide their @gcd@.+nGCD :: SInteger -> SInteger -> SInteger+nGCD = smtFunction "nGCD" $ \a b -> [sCase| b of+ _ | b .== 0 -> a+ _ -> nGCD b (a `sEMod` b)+ |]++-- | Generalized GCD, working for all integers. We simply call @nGCD@ with the absolute value of the arguments.+gcd :: SInteger -> SInteger -> SInteger+gcd a b = nGCD (abs a) (abs b)++-- * Basic properties++-- | \(\gcd\, a\ b \geq 0\)+--+-- ==== __Proof__+-- >>> runTP gcdNonNegative+-- Inductive lemma (strong): nonNegativeNGCD+-- 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.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: nonNegative Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] nonNegative :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+gcdNonNegative :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+gcdNonNegative = do+ -- We first prove over nGCD, using strong induction with the measure @a+b@.+ nn <- sInduct "nonNegativeNGCD"+ (\(Forall a) (Forall b) -> a .>= 0 .&& b .>= 0 .=> nGCD a b .>= 0)+ (\_a b -> b, []) $+ \ih a b -> [a .>= 0, b .>= 0]+ |- cases [ b .== 0 ==> trivial+ , b ./= 0 ==> nGCD a b .>= 0+ =: nGCD b (a `sEMod` b) .>= 0+ ?? ih `at` (Inst @"a" b, Inst @"b" (a `sEMod` b))+ =: sTrue+ =: qed+ ]++ lemma "nonNegative"+ (\(Forall a) (Forall b) -> gcd a b .>= 0)+ [proofOf nn]++-- | \(\gcd\, a\ b=0\implies a=0\land b=0\)+--+-- ==== __Proof__+-- >>> runTP gcdZero+-- Inductive lemma (strong): nGCDZero+-- 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.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: gcdZero Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] gcdZero :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+gcdZero :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+gcdZero = do++ -- First prove over nGCD:+ nGCDZero <-+ sInduct "nGCDZero"+ (\(Forall @"a" a) (Forall @"b" b) -> a .>= 0 .&& b .>= 0 .&& nGCD a b .== 0 .=> a .== 0 .&& b .== 0)+ (\_a b -> b, []) $+ \ih a b -> [a .>= 0, b .>= 0]+ |- (nGCD a b .== 0 .=> a .== 0 .&& b .== 0)+ =: cases [ b .== 0 ==> trivial+ , b .> 0 ==> (nGCD b (a `sEMod` b) .== 0 .=> a .== 0 .&& b .== 0)+ ?? ih `at` (Inst @"a" b, Inst @"b" (a `sEMod` b))+ =: sTrue+ =: qed+ ]++ lemma "gcdZero"+ (\(Forall @"a" a) (Forall @"b" b) -> gcd a b .== 0 .=> a .== 0 .&& b .== 0)+ [proofOf nGCDZero]++-- | \(\gcd\, a\ b=\gcd\, b\ a\)+--+-- ==== __Proof__+-- >>> runTP commutative+-- Lemma: nGCDCommutative+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Lemma: commutative+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] commutative :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+commutative :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+commutative = do+ -- First prove over nGCD. Simple enough proof, but quantifiers and recursive functions+ -- cause z3 to diverge. So, we have to explicitly write it out.+ nGCDComm <-+ calc "nGCDCommutative"+ (\(Forall @"a" a) (Forall @"b" b) -> a .>= 0 .&& b .>= 0 .=> nGCD a b .== nGCD b a) $+ \a b -> [a .>= 0, b .>= 0]+ |- nGCD a b+ =: nGCD b a+ =: qed++ -- It's unfortunate we have to spell this out explicitly, a simple lemma call+ -- that uses the above proof doesn't converge.+ calc "commutative"+ (\(Forall a) (Forall b) -> gcd a b .== gcd b a) $+ \a b -> [] |- gcd a b+ =: nGCD (abs a) (abs b)+ ?? nGCDComm `at` (Inst @"a" (abs a), Inst @"b" (abs b))+ =: gcd b a+ =: qed++-- | \(\gcd\,(-a)\,b = \gcd\,a\,b = \gcd\,a\,(-b)\)+--+-- ==== __Proof__+-- >>> runTP negGCD+-- Lemma: negGCD Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] negGCD :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+negGCD :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+negGCD = lemma "negGCD" (\(Forall a) (Forall b) -> let g = gcd a b in gcd (-a) b .== g .&& g .== gcd a (-b)) []++-- | \( \gcd\,a\,0 = \gcd\,0\,a = |a| \land \gcd\,0\,0 = 0\)+--+-- ==== __Proof__+-- >>> runTP zeroGCD+-- Lemma: zeroGCD Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] zeroGCD :: Ɐa ∷ Integer → Bool+zeroGCD :: TP (Proof (Forall "a" Integer -> SBool))+zeroGCD = lemma "zeroGCD" (\(Forall a) -> gcd a 0 .== gcd 0 a .&& gcd 0 a .== abs a .&& gcd 0 0 .== 0) []++-- * Even and odd++-- | Is the given integer even?+isEven :: SInteger -> SBool+isEven = (2 `sDivides`)++-- | Is the given integer odd?+isOdd :: SInteger -> SBool+isOdd = sNot . isEven++-- * Divisibility++-- | Divides relation. By definition @0@ only divides @0@. (But every number divides @0@).+dvd :: SInteger -> SInteger -> SBool+a `dvd` b = ite (a .== 0) (b .== 0) (b `sEMod` a .== 0)++-- | \(d \mid a \implies d \mid ka\)+--+-- ==== __Proof__+-- >>> runTP dvdMul+-- Lemma: dvdMul+-- 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] dvdMul :: Ɐd ∷ Integer → Ɐa ∷ Integer → Ɐk ∷ Integer → Bool+dvdMul :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> Forall "k" Integer -> SBool))+dvdMul = calc "dvdMul"+ (\(Forall d) (Forall a) (Forall k) -> d `dvd` a .=> d `dvd` (k*a)) $+ \d a k -> [d `dvd` a]+ |- cases [ d .== 0 ==> d `dvd` (k*a)+ ?? a .== 0+ =: sTrue+ =: qed+ , d ./= 0 ==> d `dvd` (k*a)+ =: (k*a) `sEMod` d .== 0+ ?? a .== d * a `sEDiv` d+ ?? k * a .== d * (k * a `sEDiv` d)+ ?? (d * (k * a `sEDiv` d)) `sEMod` d .== 0+ =: sTrue+ =: qed+ ]++-- | \(a \mid |b| \iff a \mid b\)+--+-- A number divides another exactly when it also divides its absolute value. This follows+-- from 'dvdMul', as both directions are an instance of multiplying by @-1@.+--+-- ==== __Proof__+-- >>> runTP dvdAbs+-- Lemma: dvdMul Q.E.D.+-- Lemma: dvdAbs_l2r+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: dvdAbs_r2l+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: dvdAbs Q.E.D.+-- [Proven] dvdAbs :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+dvdAbs :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+dvdAbs = do+ dM <- recall dvdMul++ l2r <- calc "dvdAbs_l2r"+ (\(Forall @"a" a) (Forall @"b" b) -> a `dvd` abs b .=> a `dvd` b) $+ \a b -> [a `dvd` abs b]+ |- cases [ b .>= 0 ==> a `dvd` b+ =: sTrue+ =: qed+ , b .< 0 ==> a `dvd` b+ ?? dM `at` (Inst @"d" a, Inst @"a" (abs b), Inst @"k" (-1))+ =: sTrue+ =: qed+ ]++ r2l <- calc "dvdAbs_r2l"+ (\(Forall @"a" a) (Forall @"b" b) -> a `dvd` b .=> a `dvd` abs b) $+ \a b -> [a `dvd` b]+ |- cases [ b .>= 0 ==> a `dvd` abs b+ =: sTrue+ =: qed+ , b .< 0 ==> a `dvd` abs b+ ?? dM `at` (Inst @"d" a, Inst @"a" b, Inst @"k" (-1))+ =: sTrue+ =: qed+ ]++ lemma "dvdAbs"+ (\(Forall @"a" a) (Forall @"b" b) -> a `dvd` b .== a `dvd` abs b)+ [proofOf l2r, proofOf r2l]++-- | \(d \mid (2a + 1) \implies \mathrm{isOdd}(d)\)+--+-- ==== __Proof__+-- >>> runTP dvdOddThenOdd+-- Lemma: dvdOddThenOdd+-- 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] dvdOddThenOdd :: Ɐd ∷ Integer → Ɐa ∷ Integer → Bool+dvdOddThenOdd :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> SBool))+dvdOddThenOdd = calc "dvdOddThenOdd"+ (\(Forall d) (Forall a) -> d `dvd` (2*a+1) .=> isOdd d) $+ \d a -> [d `dvd` (2*a+1)]+ |- cases [ isOdd d ==> trivial+ , isEven d ==> (2 * (d `sEDiv` 2)) `dvd` (2*a+1)+ =: 2 `dvd` (2*a+1)+ =: contradiction+ ]++-- | \(\mathrm{isOdd}(d) \land d \mid 2a \implies d \mid a\)+--+-- ==== __Proof__+-- >>> runTP dvdEvenWhenOdd+-- Lemma: dvdEvenWhenOdd+-- 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] dvdEvenWhenOdd :: Ɐd ∷ Integer → Ɐa ∷ Integer → Bool+dvdEvenWhenOdd :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> SBool))+dvdEvenWhenOdd = calc "dvdEvenWhenOdd"+ (\(Forall d) (Forall a) -> isOdd d .&& d `dvd` (2*a) .=> d `dvd` a) $+ \d a -> [isOdd d, d `dvd` (2*a)]+ |- let t = (d - 1) `sEDiv` 2+ m = (2*a) `sEDiv` d+ in sTrue++ -- Observe that d = 2t+1 and 2a = dm+ =: d .== 2*t + 1 .&& 2*a .== d*m++ -- So, 2a == (2t+1)m holds+ =: 2*a .== (2*t+1) * m++ -- Arithmetic gives us+ =: 2*a .== 2*t*m + m .&& 2*(a-t*m) .== m++ -- So m = 2*(a-t*m), i.e., m is even+ =: m .== 2 * (a - t*m)++ -- Let n = a - t*m, so m = 2n. It follows that 2a = d(2n) = 2(dn)+ =: let n = a - t*m+ in 2*a .== d * (2 * n) .&& 2 * a .== 2 * (d * n)++ -- From which we can conclude a = dn+ =: a .== d * n++ -- Thus we can deduce d must divide a+ ?? d `dvd` (d * n)+ =: d `dvd` a++ -- Done!+ =: qed++-- | \(d \mid a \land d \mid b \implies d \mid (a + b)\)+--+-- ==== __Proof__+-- >>> runTP dvdSum1+-- Lemma: dvdSum1+-- 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] dvdSum1 :: Ɐd ∷ Integer → Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+dvdSum1 :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> Forall "b" Integer -> SBool))+dvdSum1 =+ calc "dvdSum1"+ (\(Forall d) (Forall a) (Forall b) -> d `dvd` a .&& d `dvd` b .=> d `dvd` (a + b)) $+ \d a b -> [d `dvd` a .&& d `dvd` b]+ |- cases [ a .== 0 .|| b .== 0 ==> trivial+ , a ./= 0 .&& b ./= 0 ==> d `dvd` (a + b)+ =: d `dvd` (a `sEDiv` d * d + b `sEDiv` d * d)+ =: d `dvd` (d * (a `sEDiv` d + b `sEDiv` d))+ =: sTrue+ =: qed+ ]++-- | \(d \mid (a + b) \land d \mid b \implies d \mid a \)+--+-- ==== __Proof__+-- >>> runTP dvdSum2+-- Lemma: dvdSum2+-- 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] dvdSum2 :: Ɐd ∷ Integer → Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+dvdSum2 :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> Forall "b" Integer -> SBool))+dvdSum2 =+ calc "dvdSum2"+ (\(Forall d) (Forall a) (Forall b) -> d `dvd` (a + b) .&& d `dvd` b .=> d `dvd` a) $+ \d a b -> [d `dvd` (a + b) .&& d `dvd` b]+ |- cases [ d .== 0 ==> trivial+ , d ./= 0 ==> let k1 = (a + b) `sEDiv` d+ k2 = b `sEDiv` d+ in a `sEDiv` d+ =: (a + b - b) `sEDiv` d+ =: (k1 * d - k2 * d) `sEDiv` d+ =: (k1 - k2) * d `sEDiv` d+ =: qed+ ]++-- * Correctness of GCD++-- | \(\gcd\,a\,b \mid a \land \gcd\,a\,b \mid b\)+--+-- GCD of two numbers divide these numbers. This is part one of the proof, where we are+-- not concerned with maximality. Our goal is to show that the calculated gcd divides both inputs.+--+-- ==== __Proof__+-- >>> runTP gcdDivides+-- Lemma: dvdAbs Q.E.D.+-- Lemma: helper+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Inductive lemma (strong): dvdNGCD+-- 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.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: gcdDivides Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] gcdDivides :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+gcdDivides :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+gcdDivides = do++ dAbs <- recall dvdAbs++ -- Helper about divisibility. If x|b and x| a%b, then x|a.+ helper <- calc "helper"+ (\(Forall @"a" a) (Forall @"b" b) (Forall @"x" x) ->+ b ./= 0 .&& x `dvd` b .&& x `dvd` (a `sEMod` b)+ .=> -----------------------------------------------+ x `dvd` a+ ) $+ \a b x -> [b ./= 0, x `dvd` b, x `dvd` (a `sEMod` b)]+ |- x `dvd` a+ ?? a `sEDiv` x .== (a `sEDiv` b) * (b `sEDiv` x) + (a `sEMod` b) `sEDiv` x+ =: sTrue+ =: qed++ -- Use strong induction to prove divisibility over non-negative numbers.+ dNGCD <- sInduct "dvdNGCD"+ (\(Forall @"a" a) (Forall @"b" b) -> a .>= 0 .&& b .>= 0 .=> nGCD a b `dvd` a .&& nGCD a b `dvd` b)+ (\_a b -> b, []) $+ \ih a b -> [a .>= 0, b .>= 0]+ |- let g = nGCD a b+ in g `dvd` a .&& g `dvd` b+ =: cases [ b .== 0 ==> trivial+ , b .> 0 ==> let g' = nGCD b (a `sEMod` b)+ in g' `dvd` a .&& g' `dvd` b+ ?? ih `at` (Inst @"a" b, Inst @"b" (a `sEMod` b))+ ?? helper+ =: sTrue+ =: qed+ ]++ -- Now generalize to arbitrary integers.+ lemma"gcdDivides"+ (\(Forall a) (Forall b) -> gcd a b `dvd` a .&& gcd a b `dvd` b)+ [proofOf dAbs, proofOf dNGCD]++-- | \(x \mid a \land x \mid b \implies x \mid \gcd\,a\,b\)+--+-- Maximality. Any divisor of the inputs divides the GCD.+--+-- ==== __Proof__+-- >>> runTP gcdMaximal+-- Lemma: dvdAbs Q.E.D.+-- Lemma: commutative Q.E.D.+-- Lemma: eDiv Q.E.D.+-- Lemma: helper+-- Step: 1 (x `dvd` a && x `dvd` b) Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Inductive lemma (strong): mNGCD+-- 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.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: gcdMaximal+-- 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.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] gcdMaximal :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐx ∷ Integer → Bool+gcdMaximal :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "x" Integer -> SBool))+gcdMaximal = do++ dAbs <- recall dvdAbs+ comm <- recall commutative++ eDiv <- lemma "eDiv"+ (\(Forall @"x" x) (Forall @"y" y) -> y ./= 0 .=> x .== (x `sEDiv` y) * y + x `sEMod` y)+ []++ -- Helper: If x|a, x|b then x|a%b.+ helper <- calc "helper"+ (\(Forall @"a" a) (Forall @"b" b) (Forall @"x" x) ->+ x ./= 0 .&& b ./= 0 .&& x `dvd` a .&& x `dvd` b+ .=> -----------------------------------------------+ x `dvd` (a `sEMod` b)+ ) $+ \a b x -> [x ./= 0, b ./= 0, x `dvd` a, x `dvd` b]+ |- x `dvd` (a `sEMod` b)+ ?? "x `dvd` a && x `dvd` b"+ =: let k1 = a `sDiv` x+ k2 = b `sDiv` x+ in x `dvd` ((k1*x) `sEMod` (k2*x))+ ?? eDiv `at` (Inst @"x" (k1*x), Inst @"y" (k2*x))+ =: x `dvd` ((k1*x) - ((k1*x) `sEDiv` (k2*x)) * (k2*x))+ =: sTrue+ =: qed++ -- Now prove maximality for non-negative integers:+ mNGCD <- sInduct "mNGCD"+ (\(Forall @"a" a) (Forall @"b" b) (Forall @"x" x) ->+ a .>= 0 .&& b .>= 0 .&& x `dvd` a .&& x `dvd` b .=> x `dvd` nGCD a b)+ (\_a b _x -> b, []) $+ \ih a b x -> let g = nGCD a b+ in [a .>= 0, b .>= 0, x `dvd` a .&& x `dvd` b]+ |- x `dvd` g+ =: cases [ b .== 0 ==> trivial+ , b .> 0 ==> x `dvd` nGCD b (a `sEMod` b)+ ?? ih `at` (Inst @"a" b, Inst @"b" (a `sEMod` b), Inst @"x" x)+ ?? helper+ =: sTrue+ =: qed+ ]++ -- Generalize to arbitrary integers:+ calc "gcdMaximal"+ (\(Forall @"a" a) (Forall @"b" b) (Forall @"x" x) -> x `dvd` a .&& x `dvd` b .=> x `dvd` gcd a b) $+ \a b x -> [x `dvd` a, x `dvd` b]+ |- x `dvd` gcd a b+ =: cases [ abs a .>= abs b ==> x `dvd` nGCD (abs a) (abs b)+ ?? mNGCD `at` (Inst @"a" (abs a), Inst @"b" (abs b), Inst @"x" x)+ ?? dAbs `at` (Inst @"a" x, Inst @"b" a)+ ?? dAbs `at` (Inst @"a" x, Inst @"b" b)+ =: sTrue+ =: qed+ , abs a .< abs b ==> x `dvd` gcd a b+ ?? comm `at` (Inst @"a" a, Inst @"b" b)+ =: x `dvd` gcd b a+ =: x `dvd` nGCD (abs b) (abs a)+ ?? mNGCD `at` (Inst @"a" (abs b), Inst @"b" (abs a), Inst @"x" x)+ ?? dAbs `at` (Inst @"a" x, Inst @"b" a)+ ?? dAbs `at` (Inst @"a" x, Inst @"b" b)+ =: sTrue+ =: qed+ ]++-- | \(\gcd\,a\,b \mid a \land \gcd\,a\,b \mid b \land (x \mid a \land x \mid b \implies x \mid \gcd\,a\,b)\)+--+-- Putting it all together: GCD divides both arguments, and its maximal.+--+-- ==== __Proof__+-- >>> runTP gcdCorrect+-- Lemma: gcdDivides Q.E.D.+-- Lemma: gcdMaximal Q.E.D.+-- Lemma: gcdCorrect+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] gcdCorrect :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+gcdCorrect :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+gcdCorrect = do+ divides <- recall gcdDivides+ maximal <- recall gcdMaximal++ calc "gcdCorrect"+ (\(Forall a) (Forall b) ->+ let g = gcd a b+ in g `dvd` a+ .&& g `dvd` b+ .&& quantifiedBool (\(Forall x) -> x `dvd` a .&& x `dvd` b .=> x `dvd` g)+ ) $+ \a b -> []+ |- let g = gcd a b+ m = quantifiedBool (\(Forall x) -> x `dvd` a .&& x `dvd` b .=> x `dvd` g)+ in g `dvd` a .&& g `dvd` b .&& m+ ?? divides `at` (Inst @"a" a, Inst @"b" b)+ =: m+ ?? maximal+ =: sTrue+ =: qed++-- | \(\bigl((a \neq 0 \lor b \neq 0) \land x \mid a \land x \mid b \bigr) \implies x \leq \gcd\,a\,b\)+--+-- Additionally prove that GCD is really maximum, i.e., it is the largest in the regular sense. Note+-- that we have to make an exception for @gcd 0 0@ since by definition the GCD is @0@, which is clearly+-- not the largest divisor of @0@ and @0@. (Since any number is a GCD for the pair @(0, 0)@, there is+-- no maximum.)+--+-- ==== __Proof__+-- >>> runTP gcdLargest+-- Lemma: gcdMaximal Q.E.D.+-- Lemma: gcdZero Q.E.D.+-- Lemma: nonNegative Q.E.D.+-- Lemma: gcdLargest+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] gcdLargest :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐx ∷ Integer → Bool+gcdLargest :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "x" Integer -> SBool))+gcdLargest = do+ maximal <- recall gcdMaximal+ gcdZ <- recall gcdZero+ nn <- recall gcdNonNegative++ calc "gcdLargest"+ (\(Forall a) (Forall b) (Forall x) -> (a ./= 0 .|| b ./= 0) .&& x `dvd` a .&& x `dvd` b .=> x .<= gcd a b) $+ \a b x -> [(a ./= 0 .|| b ./= 0) .&& x `dvd` a, x `dvd` b]+ |- x .<= gcd a b+ ?? maximal `at` (Inst @"a" a, Inst @"b" b, Inst @"x" x)+ =: (x `dvd` gcd a b .=> x .<= gcd a b)+ ?? gcdZ `at` (Inst @"a" a, Inst @"b" b)+ ?? nn `at` (Inst @"a" a, Inst @"b" b)+ =: sTrue+ =: qed++-- * Other GCD Facts++-- | \(\gcd\, a\, b = \gcd\, (a + b)\, b\)+--+-- ==== __Proof__+-- >>> runTP gcdAdd+-- Lemma: dvdSum1 Q.E.D.+-- Lemma: dvdSum2 Q.E.D.+-- Lemma: gcdDivides Q.E.D.+-- Lemma: gcdLargest Q.E.D.+-- Lemma: gcdAdd+-- 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.+-- Functions proven terminating: nGCD+-- [Proven] gcdAdd :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+gcdAdd :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+gcdAdd = do++ dSum1 <- recall dvdSum1+ dSum2 <- recall dvdSum2+ divides <- recall gcdDivides+ largest <- recall gcdLargest++ calc "gcdAdd"+ (\(Forall @"a" a) (Forall @"b" b) -> gcd a b .== gcd (a + b) b) $+ \a b -> [] |-> let g1 = gcd a b+ g2 = gcd (a + b) b+ in sTrue++ -- First use the divides property to conclude that g1 divides a and b+ ?? divides `at` (Inst @"a" a, Inst @"b" b)+ =: g1 `dvd` a .&& g1 `dvd` b++ -- Same for g2 for a+b and b+ ?? divides `at` (Inst @"a" (a + b), Inst @"b" b)+ =: g2 `dvd` (a+b) .&& g2 `dvd` b++ -- Use dSum1 to show g1 divides a+b+ ?? dSum1 `at` (Inst @"d" g1, Inst @"a" a, Inst @"b" b)+ =: g1 `dvd` (a+b)++ -- Similarly, use dSum2 to show g2 divides a+ ?? dSum2 `at` (Inst @"d" g2, Inst @"a" a, Inst @"b" b)+ =: g2 `dvd` a++ -- Now use largest to show g1 >= g2+ ?? largest `at` (Inst @"a" a, Inst @"b" b, Inst @"x" g2)+ =: g1 .>= g2++ -- But again via largest, we can show g2 >= g1+ ?? largest `at` (Inst @"a" (a+b), Inst @"b" b, Inst @"x" g1)+ =: g2 .>= g1++ -- Finally conclude g1 = g2, since both are greater-than-equal to each other:+ =: g1 .== g2+ =: qed++-- | \(\gcd\, (2a)\, (2b) = 2 (\gcd\,a\, b)\)+--+-- ==== __Proof__+-- >>> runTP gcdEvenEven+-- Lemma: red2 Q.E.D.+-- Lemma: modEE+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Inductive lemma (strong): nGCDEvenEven+-- 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.+-- Lemma: gcdEvenEven+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: nGCD+-- [Proven] gcdEvenEven :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+gcdEvenEven :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+gcdEvenEven = do++ red2 <- lemmaWith z3 "red2"+ (\(Forall @"a" a) (Forall @"b" b) -> b ./= 0 .=> (2*a) `sEDiv` (2*b) .== a `sEDiv` b)+ []++ modEE <- calcWith cvc5 "modEE"+ (\(Forall @"a" a) (Forall @"b" b) -> b ./= 0 .=> (2*a) `sEMod` (2*b) .== 2 * (a `sEMod` b)) $+ \a b -> [b ./= 0]+ |- (2*a) `sEMod` (2*b)+ ?? red2 `at` (Inst @"a" a, Inst @"b" b)+ =: 2*a - 2*b * (a `sEDiv` b)+ =: 2 * (a - b * (a `sEDiv` b))+ =: 2 * (a `sEMod` b)+ =: qed++ nGCDEvenEven <- sInduct "nGCDEvenEven"+ (\(Forall @"a" a) (Forall @"b" b) -> a .>= 0 .&& b .>= 0 .=> nGCD (2*a) (2*b) .== 2 * nGCD a b)+ (\_a b -> b, []) $+ \ih a b -> [a .>= 0, b .>= 0]+ |- nGCD (2*a) (2*b)+ =: cases [ b .== 0 ==> trivial+ , b ./= 0 ==> nGCD (2 * a) (2 * b)+ =: nGCD (2 * b) ((2 * a) `sEMod` (2 * b))+ ?? modEE `at` (Inst @"a" a, Inst @"b" b)+ =: nGCD (2 * b) (2 * (a `sEMod` b))+ ?? ih+ =: 2 * nGCD a b+ =: qed+ ]++ calc "gcdEvenEven"+ (\(Forall a) (Forall b) -> gcd (2*a) (2*b) .== 2 * gcd a b) $+ \a b -> [] |- gcd (2*a) (2*b)+ =: nGCD (abs (2*a)) (abs (2*b))+ =: nGCD (2 * abs a) (2 * abs b)+ ?? nGCDEvenEven `at` (Inst @"a" (abs a), Inst @"b" (abs b))+ =: 2 * nGCD (abs a) (abs b)+ =: 2 * gcd a b+ =: qed++-- | \(\gcd\, (2a+1)\, (2b) = \gcd\,(2a+1)\, b\)+--+-- ==== __Proof__+-- >>> runTP gcdOddEven+-- Lemma: gcdDivides Q.E.D.+-- Lemma: gcdLargest Q.E.D.+-- Lemma: dvdMul Q.E.D. [Cached]+-- Lemma: dvdOddThenOdd Q.E.D.+-- Lemma: dvdEvenWhenOdd Q.E.D.+-- Lemma: gcdOddEven+-- 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.+-- Functions proven terminating: nGCD+-- [Proven] gcdOddEven :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+gcdOddEven :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+gcdOddEven = do++ divides <- recall gcdDivides+ largest <- recall gcdLargest+ dMul <- recall dvdMul+ dOddThenOdd <- recall dvdOddThenOdd+ dEvenWhenOdd <- recall dvdEvenWhenOdd++ calc "gcdOddEven"+ (\(Forall a) (Forall b) -> gcd (2*a+1) (2*b) .== gcd (2*a+1) b) $+ \a b -> [] |-> let g1 = gcd (2*a+1) (2*b)+ g2 = gcd (2*a+1) b+ in sTrue++ -- First use the divides property to conclude that g1 divides both 2*a+1 and 2*b+ ?? divides `at` (Inst @"a" (2*a+1), Inst @"b" (2*b))+ =: g1 `dvd` (2*a+1) .&& g1 `dvd` (2*b)++ -- Same for g2, for 2*a+1 and b+ ?? divides `at` (Inst @"a" (2*a+1), Inst @"b" b)+ =: g2 `dvd` (2*a+1) .&& g2 `dvd` b++ -- By arithmetic, g2 divides 2*b+ ?? dMul `at` (Inst @"d" g2, Inst @"a" b, Inst @"k" 2)+ =: g2 `dvd` (2*b)++ -- Observe that g1 must be odd+ ?? dOddThenOdd `at` (Inst @"d" g1, Inst @"a" a)+ =: isOdd g1++ -- Conclude that g1 must divide b+ ?? dEvenWhenOdd `at` (Inst @"d" g1, Inst @"a" b)+ =: g1 `dvd` b++ -- Now use largest to show g1 >= g2+ ?? largest `at` (Inst @"a" (2*a+1), Inst @"b" (2*b), Inst @"x" g2)+ =: g1 .>= g2++ -- But again via largest, we can show g2 >= g1+ ?? largest `at` (Inst @"a" (2*a+1), Inst @"b" b, Inst @"x" g1)+ =: g2 .>= g1++ -- Finally conclude g1 = g2 since both are greater-than-equal to each other:+ =: g1 .== g2+ =: qed++-- * GCD via subtraction++-- | @nGCDSub@ is the original version of Euclid, which uses subtraction instead of modulus. This is the version that+-- works on non-negative numbers. It has the precondition that @a >= b >= 0@, and maintains this invariant in each+-- recursive call.+nGCDSub :: SInteger -> SInteger -> SInteger+nGCDSub = smtFunction "nGCDSub"+ $ \a b -> [sCase| a of+ _ | a .== b -> a+ _ | a .<= 0 -> b+ _ | b .<= 0 -> a+ _ | a .> b -> nGCDSub (a - b) b+ _ -> nGCDSub a (b - a)+ |]++-- | Generalized version of subtraction based GCD, working over all integers.+gcdSub :: SInteger -> SInteger -> SInteger+gcdSub a b = nGCDSub (abs a) (abs b)++-- | \(\mathrm{gcdSub}\, a\, b = \gcd\, a\, b\)+--+-- Instead of proving @gcdSub@ correct, we'll simply show that it is equivalent to @gcd@, hence it has+-- all the properties we already established.+--+-- ==== __Proof__+-- >>> runTP gcdSubEquiv+-- Lemma: commutative Q.E.D.+-- Lemma: gcdAdd Q.E.D.+-- Inductive lemma (strong): nGCDSubEquiv+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (5 way 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.5.1 Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.5.5 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: gcdSubEquiv+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: nGCD, nGCDSub+-- [Proven] gcdSubEquiv :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+gcdSubEquiv :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+gcdSubEquiv = do++ -- We'll be using the commutativity of GCD and the gcdAdd property+ comm <- recall commutative+ addG <- recall gcdAdd++ -- First prove over the non-negative numbers:+ nEq <- sInduct "nGCDSubEquiv"+ (\(Forall @"a" a) (Forall @"b" b) -> a .>= 0 .&& b .>= 0 .=> nGCDSub a b .== nGCD a b)+ (\a b -> a + b, []) $+ \ih a b -> [a .>= 0, b .>= 0]+ |- nGCDSub a b+ =: cases [ a .== b ==> nGCD a b =: qed+ , a .== 0 ==> nGCD a b =: qed+ , b .== 0 ==> nGCD a b =: qed+ , a .> b .&& b ./= 0 ==> nGCDSub (a - b) b+ ?? ih+ =: nGCD (a - b) b+ ?? addG `at` (Inst @"a" (a - b), Inst @"b" b)+ =: nGCD a b+ =: qed+ , a .< b .&& a ./= 0 ==> nGCDSub a (b - a)+ ?? ih+ =: nGCD a (b - a)+ ?? comm+ =: nGCD (b - a) a+ ?? addG `at` (Inst @"a" (b - a), Inst @"b" a)+ =: nGCD b a+ ?? comm+ =: nGCD a b+ =: qed+ ]++ -- Now prove over all integers+ calcWith cvc5 "gcdSubEquiv"+ (\(Forall a) (Forall b) -> gcd a b .== gcdSub a b) $+ \a b -> [] |- gcd a b+ =: nGCD (abs a) (abs b)+ ?? nEq `at` (Inst @"a" (abs a), Inst @"b" (abs b))+ =: nGCDSub (abs a) (abs b)+ =: gcdSub a b+ =: qed++-- * Binary GCD++-- | @nGCDBin@ is the binary GCD algorithm that works on non-negative numbers.+nGCDBin :: SInteger -> SInteger -> SInteger+nGCDBin = smtFunction "nGCDBin"+ $ \a b -> [sCase| a of+ _ | a .<= 0 -> b+ _ | b .<= 0 -> a+ _ | isEven a .&& isEven b -> 2 * nGCDBin (a `sEDiv` 2) (b `sEDiv` 2)+ _ | isOdd a .&& isEven b -> nGCDBin a (b `sEDiv` 2)+ _ | a .<= b -> nGCDBin a (b - a)+ _ -> nGCDBin (a - b) b+ |]+-- | Generalized version that works on arbitrary integers.+gcdBin :: SInteger -> SInteger -> SInteger+gcdBin a b = nGCDBin (abs a) (abs b)++-- | \(\mathrm{gcdBin}\, a\, b = \gcd\, a\, b\)+--+-- Instead of proving @gcdBin@ correct, we'll simply show that it is equivalent to @gcd@, hence it has+-- all the properties we already established.+--+-- ==== __Proof__+-- >>> runTP gcdBinEquiv+-- Lemma: gcdEvenEven Q.E.D.+-- Lemma: gcdOddEven Q.E.D.+-- Lemma: gcdAdd Q.E.D.+-- Lemma: commutative Q.E.D. [Cached]+-- Inductive lemma (strong): nGCDBinEquiv+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (5 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.4.1 Q.E.D.+-- Step: 1.4.2 Q.E.D.+-- Step: 1.4.3 Q.E.D.+-- Step: 1.5 (3 way case split)+-- Step: 1.5.1 Q.E.D.+-- Step: 1.5.2.1 Q.E.D.+-- Step: 1.5.2.2 Q.E.D.+-- Step: 1.5.2.3 Q.E.D.+-- Step: 1.5.2.4 Q.E.D.+-- Step: 1.5.2.5 Q.E.D.+-- Step: 1.5.2.6 Q.E.D.+-- Step: 1.5.3.1 Q.E.D.+-- Step: 1.5.3.2 Q.E.D.+-- Step: 1.5.3.3 Q.E.D.+-- Step: 1.5.3.4 Q.E.D.+-- Step: 1.5.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: gcdBinEquiv+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: nGCD, nGCDBin+-- [Proven] gcdBinEquiv :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool+gcdBinEquiv :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))+gcdBinEquiv = do+ gEvenEven <- recallWith cvc5 gcdEvenEven+ gOddEven <- recall gcdOddEven+ gAdd <- recall gcdAdd+ comm <- recall commutative++ -- First prove over the non-negative numbers:+ nEq <- sInduct "nGCDBinEquiv"+ (\(Forall @"a" a) (Forall @"b" b) -> a .>= 0 .&& b .>= 0 .=> nGCDBin a b .== nGCD a b)+ (\a b -> tuple (a, b), []) $+ \ih a b -> [a .>= 0, b .>= 0]+ |- nGCDBin a b+ =: cases [ a .== 0 ==> trivial+ , b .== 0 ==> trivial+ , isEven a .&& isEven b ==> 2 * nGCDBin (a `sEDiv` 2) (b `sEDiv` 2)+ ?? ih `at` (Inst @"a" (a `sEDiv` 2), Inst @"b" (b `sEDiv` 2))+ =: 2 * nGCD (a `sEDiv` 2) (b `sEDiv` 2)+ ?? a .== 2 * a `sEDiv` 2+ ?? b .== 2 * b `sEDiv` 2+ ?? gEvenEven `at` (Inst @"a" (a `sEDiv` 2), Inst @"b" (b `sEDiv` 2))+ =: nGCD a b+ =: qed+ , isOdd a .&& isEven b ==> nGCDBin a (b `sEDiv` 2)+ ?? ih `at` (Inst @"a" a, Inst @"b" (b `sEDiv` 2))+ =: nGCD a (b `sEDiv` 2)+ ?? a .== 2 * ((a-1) `sEDiv` 2) + 1+ ?? b .== 2 * b `sEDiv` 2+ ?? gOddEven `at` (Inst @"a" ((a-1) `sEDiv` 2), Inst @"b" (b `sEDiv` 2))+ =: nGCD a b+ =: qed+ , isOdd b ==> cases [ a .== 0 ==> trivial+ , a ./= 0 .&& a .<= b ==> nGCDBin a b+ =: nGCDBin a (b - a)+ ?? ih `at` (Inst @"a" a, Inst @"b" (b - a))+ =: nGCD a (b - a)+ ?? comm `at` (Inst @"a" a, Inst @"b" (b - a))+ =: nGCD (b - a) a+ ?? gAdd `at` (Inst @"a" (b - a), Inst @"b" a)+ =: nGCD b a+ ?? comm `at` (Inst @"a" b, Inst @"b" a)+ =: nGCD a b+ =: qed+ , a .> b ==> nGCDBin a b+ =: nGCDBin (a - b) b+ ?? ih `at` (Inst @"a" (a - b), Inst @"b" b)+ =: nGCD (a - b) b+ ?? gAdd `at` (Inst @"a" a, Inst @"b" (-b))+ =: nGCD a b+ =: qed+ ]+ ]++ -- Now prove over all integers+ calcWith cvc5 "gcdBinEquiv"+ (\(Forall a) (Forall b) -> gcd a b .== gcdBin a b) $+ \a b -> [] |- gcd a b+ =: nGCD (abs a) (abs b)+ ?? nEq `at` (Inst @"a" (abs a), Inst @"b" (abs b))+ =: nGCDBin (abs a) (abs b)+ =: gcdBin a b+ =: qed++{- HLint ignore gcdSubEquiv "Avoid lambda" -}+{- HLint ignore gcdBinEquiv "Use curry" -}
+ Documentation/SBV/Examples/TP/InsertionSort.hs view
@@ -0,0 +1,225 @@+-----------------------------------------------------------------------------+-- |+-- 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 FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# 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 :: (OrdSymbolic (SBV a), SymVal a) => SBV a -> SList a -> SList a+insert = smtFunction "insert"+ $ \e l -> [sCase| l of+ [] -> [e]+ x : xs | e .<= x -> e .: x .: xs+ | True -> x .: insert e xs+ |]++-- | Insertion sort, using 'insert' above to successively insert the elements.+insertionSort :: (OrdSymbolic (SBV a), SymVal a) => SList a -> SList a+insertionSort = smtFunction "insertionSort"+ $ \l -> [sCase| l of+ [] -> []+ x : xs -> 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 -> [sCase| l of+ [] -> []+ x : xs | e .== x -> xs+ | True -> 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 -> [sCase| l of+ [] -> null r+ x : xs -> 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.+-- Functions proven terminating: insert, insertionSort, isPermutation, nonDecreasing, removeFirst+-- [Proven] insertionSortIsCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. (OrdSymbolic (SBV a), Eq a, SymVal a) => IO (Proof (Forall "xs" [a] -> SBool))+correctness = runTPWith 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 permutation 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/Kadane.hs view
@@ -0,0 +1,175 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Kadane+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving the correctness of Kadane's algorithm for computing the maximum+-- sum of any contiguous list (maximum segment sum problem).+--+-- Kadane's algorithm is a classic dynamic programming algorithm that solves+-- the maximum segment sum problem in O(n) time. Given a list of integers,+-- it finds the maximum sum of any contiguous list, where the empty+-- list has sum 0.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Kadane where++import Prelude hiding (length, maximum, null, head, tail, (++))++import Data.SBV+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+-- >>> :set -XOverloadedLists+#endif++-- * Problem specification++-- | The maximum segment sum problem: Find the maximum sum of any contiguous+-- subarray. We include the empty subarray (with sum 0) as a valid segment.+-- This is the obvious definition: Empty list maps to 0. Otherwise, we take the+-- value of the segment starting at the current position, and take the maximum+-- of that value with the recursive result of the tail. This is obviously+-- correct, but has the runtime of O(n^2).+--+-- We have:+--+-- >>> mss [1, -2, 3, 4, -1, 2] -- the segment: [3, 4, -1, 2]+-- 8 :: SInteger+-- >>> mss [-2, -3, -1] -- empty segment+-- 0 :: SInteger+-- >>> mss [1, 2, 3] -- the whole list+-- 6 :: SInteger+mss :: SList Integer -> SInteger+mss = smtFunction "mss"+ $ \xs -> [sCase| xs of+ [] -> 0+ _ : t -> mssBegin xs `smax` mss t+ |]++-- | Maximum sum of segments starting at the beginning of the given list.+-- This is 0 if the empty segment is best, or positive if a non-empty prefix exists.+--+-- We have:+--+-- >>> mssBegin [1, -2, 3, 4, -1, 2] -- the segment: [1, -2, 3, 4, -1, 2]+-- 7 :: SInteger+-- >>> mssBegin [-2, -3, -1] -- empty segment+-- 0 :: SInteger+-- >>> mssBegin [1, 2, 3] -- the whole list+-- 6 :: SInteger+mssBegin :: SList Integer -> SInteger+mssBegin = smtFunction "mssBegin"+ $ \xs -> [sCase| xs of+ [] -> 0+ h : t -> 0 `smax` (h `smax` (h + mssBegin t))+ |]++-- * Kadane's algorithm implementation++-- | Kadane algorithm: We call the helper with the values of maximum value ending+-- at the beginning and the list, and recurse.+--+-- >>> kadane [1, -2, 3, 4, -1, 2] -- the segment: [3, 4, -1, 2]+-- 8 :: SInteger+-- >>> kadane [-2, -3, -1] -- empty segment+-- 0 :: SInteger+-- >>> kadane [1, 2, 3] -- the whole list+-- 6 :: SInteger+kadane :: SList Integer -> SInteger+kadane xs = kadaneHelper xs 0 0++-- | Helper for Kadane's algorithm. Along with the list, we keep track of the maximum-value+-- ending at the beginning of the list argument, and the maximum value sofar.+kadaneHelper :: SList Integer -> SInteger -> SInteger -> SInteger+kadaneHelper = smtFunction "kadaneHelper"+ $ \xs maxEndingHere maxSoFar ->+ [sCase| xs of+ [] -> maxSoFar+ h : t -> let newMaxEndingHere = 0 `smax` (h + maxEndingHere)+ newMaxSofar = maxSoFar `smax` newMaxEndingHere+ in kadaneHelper t newMaxEndingHere newMaxSofar+ |]++-- * Correctness proof++-- | The key insight is that we need a generalized invariant that characterizes+-- @kadaneHelper@ for arbitrary accumulator values, not just the initial @(0, 0)@.+--+-- The invariant states: for @kadaneHelper xs meh msf@ where:+--+-- * @meh@ (max-ending-here) is the maximum sum of a segment ending at the boundary+-- * @msf@ (max-so-far) is the best segment sum seen in the already-processed prefix+-- * Preconditions: @meh >= 0@ and @msf >= meh@+--+-- @+-- kadaneHelper xs meh msf == msf `smax` mss xs `smax` (meh + mssBegin xs)+-- @+--+-- This captures that the result is the maximum of:+--+-- * @msf@ - the best segment entirely in the already-processed prefix+-- * @mss xs@ - the best segment entirely in the remaining suffix+-- * @meh + mssBegin xs@ - the best segment crossing the boundary+--+-- >>> runTPWith cvc5 correctness+-- Inductive lemma: kadaneHelperInvariant+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Lemma: correctness+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: kadaneHelper, mss, mssBegin+-- [Proven] correctness :: Ɐxs ∷ [Integer] → Bool+correctness :: TP (Proof (Forall "xs" [Integer] -> SBool))+correctness = do++ -- First, prove the generalized invariant. This is the heart of the proof: it relates kadaneHelper with arbitrary+ -- accumulators to the specification functions mss and mssBegin.+ invariant <- induct "kadaneHelperInvariant"+ (\(Forall xs) (Forall meh) (Forall msf) ->+ (meh .>= 0 .&& msf .>= meh) .=> kadaneHelper xs meh msf .== (msf `smax` mss xs `smax` (meh + mssBegin xs))) $+ \ih (a, as) meh msf ->+ [meh .>= 0, msf .>= meh] |- let newMeh = 0 `smax` (a + meh)+ newMsf = msf `smax` newMeh+ in kadaneHelper (a .: as) meh msf+ =: kadaneHelper as newMeh newMsf+ ?? ih `at` (Inst @"meh" newMeh, Inst @"msf" newMsf)+ =: newMsf `smax` mss as `smax` (newMeh + mssBegin as)+ =: qed++ -- Now the main theorem follows easily: kadane xs = kadaneHelper xs 0 0+ -- and with meh=0, msf=0, the invariant gives us:+ -- kadaneHelper xs 0 0 = 0 `smax` mss xs `smax` (0 + mssBegin xs)+ -- = mss xs `smax` mssBegin xs+ -- = mss xs (since mss xs >= mssBegin xs by definition)+ calc "correctness"+ (\(Forall xs) -> mss xs .== kadane xs) $+ \xs -> [] |- kadane xs+ =: kadaneHelper xs 0 0+ ?? invariant `at` (Inst @"xs" xs, Inst @"meh" (0 :: SInteger), Inst @"msf" (0 :: SInteger))+ =: 0 `smax` mss xs `smax` (0 + mssBegin xs)+ =: mss xs `smax` mssBegin xs+ -- mss xs >= mssBegin xs by definition (mss considers all segments)+ =: mss xs+ =: qed
+ Documentation/SBV/Examples/TP/Kleene.hs view
@@ -0,0 +1,140 @@+-----------------------------------------------------------------------------+-- |+-- 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 FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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+mkSymbolic [''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/Lists.hs view
@@ -0,0 +1,2064 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Lists+-- 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 QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Lists (+ -- * 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, mapConcat++ -- * 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, countOneStep, 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 ++ [] .== 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.+-- Functions proven terminating: sbv.inits+-- [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.+-- Functions proven terminating: sbv.tails+-- [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 @tails@ 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. (NB. z3 is finicky on this+-- problem, while cvc5 works much better.)+--+-- >>> runTPWith cvc5 $ 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.+-- Functions proven terminating: sbv.closureMap, sbv.tails+-- [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.+-- Functions proven terminating: sbv.reverse+-- [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.+-- Functions proven terminating: sbv.reverse+-- [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.+-- Functions proven terminating: sbv.reverse+-- [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.+-- Functions proven terminating: sbv.reverse+-- [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.+-- Functions proven terminating: sbv.reverse+-- [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++-- | \(\mathit{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.+-- Functions proven terminating: EnumSymbolic.Integer.enumFromThenTo.up+-- [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.+-- Functions proven terminating:+-- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, sbv.reverse+-- [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.+-- Functions proven terminating: sbv.replicate+-- [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.+-- Functions proven terminating: sbv.foldr+-- [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.+-- Functions proven terminating: sbv.map+-- [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.+-- Functions proven terminating: sbv.map+-- [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.+-- Functions proven terminating: sbv.map, sbv.reverse+-- [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.+-- Step: 5 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: sbv.map+-- [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+ =: (g . f) x .: map (g . f) xs+ =: map (g . f) (x .: xs)+ =: qed++-- | @map f . concat = concat . map (map f)@+--+-- >>> runTP $ mapConcat @Integer @Bool (uninterpret "f")+-- Lemma: mapAppend Q.E.D.+-- Inductive lemma: mapConcat+-- 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.+-- Functions proven terminating: sbv.foldr, sbv.map+-- [Proven] mapConcat :: Ɐxs ∷ [[Integer]] → Bool+mapConcat :: (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "xs" [[a]] -> SBool))+mapConcat f = do+ ma <- recall (mapAppend f)++ induct "mapConcat"+ (\(Forall xs) -> map f (concat xs) .== concat (map (map f) xs)) $+ \ih (x, xs) -> [] |- map f (concat (x .: xs))+ =: map f (x ++ concat xs)+ ?? ma+ =: map f x ++ map f (concat xs)+ ?? ih+ =: map f x ++ concat (map (map f) xs)+ =: concat (map f x .: map (map f) xs)+ =: concat (map (map 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.+-- Functions proven terminating: sbv.foldr, sbv.map+-- [Proven] foldrMapFusion :: Ɐxs ∷ [String] → 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.+-- Functions proven terminating: sbv.foldr+-- [Proven] foldrFusion :: Ɐxs ∷ [String] → 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.+-- Functions proven terminating: sbv.foldr+-- [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.+-- Functions proven terminating: sbv.foldl+-- [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.+-- Functions proven terminating: sbv.foldl, sbv.foldr, sbv.reverse+-- [Proven] foldrFoldlDuality :: Ɐxs ∷ [Integer] → Ɐe ∷ String → 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.+-- Functions proven terminating: sbv.foldl, sbv.foldr+-- [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.+-- Functions proven terminating: sbv.foldl, sbv.foldr+-- [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.+-- Functions proven terminating: sbv.foldr, sbv.map+-- [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.+-- Functions proven terminating: sbv.filter+-- [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.+-- Functions proven terminating: sbv.filter, sbv.foldr, sbv.map+-- [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.+-- Functions proven terminating: sbv.dropWhile, sbv.takeWhile+-- [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 -> [sCase| xs of+ [] -> xs+ [_] -> xs+ a : rest@(b : _) | a .== b -> destutter rest+ | True -> a .: destutter rest+ |]++-- | @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 (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 (2 way case split)+-- Step: 1.3.2.1.1 Q.E.D.+-- Step: 1.3.2.1.2 Q.E.D.+-- Step: 1.3.2.2.1 Q.E.D.+-- Step: 1.3.2.2.2 Q.E.D.+-- Step: 1.3.2.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: destutterIdempotent Q.E.D.+-- Functions proven terminating: destutter, noAdd+-- [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 -> [sCase| xs of+ [] -> sTrue+ [_] -> sTrue+ a : rest@(b : _) | a .== b -> sFalse+ | True -> noAdd rest+ |]++ -- 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)+ =: [pCase| xs of+ [] -> trivial+ [_] -> trivial+ whole@(a : rest@(b : bs))+ -> noAdd (destutter whole)+ =: cases [a .== b ==> noAdd (destutter rest)+ ?? ih+ =: sTrue+ =: qed+ , a ./= b ==> noAdd (a .: destutter rest)+ ?? 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.+-- Functions proven terminating: sbv.diff+-- [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.+-- Functions proven terminating: sbv.diff+-- [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.+-- Functions proven terminating: sbv.diff+-- [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 -> [sCase| xs of+ [] -> sTrue+ a : as -> a `notElem` ys .&& disjoint as 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.+-- Functions proven terminating: disjoint, sbv.diff+-- [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.+-- Functions proven terminating: sbv.filter, sbv.partition+-- [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.+-- Functions proven terminating: sbv.filter, sbv.partition+-- [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 @Integer (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+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: sbv.map+-- [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 <- inductWith cvc5 "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++ calc "take_map"+ (\(Forall n) (Forall xs) -> take n (map f xs) .== map f (take n xs)) $+ \n xs -> [] |- take n (map f xs)+ ?? h1+ ?? h2+ =: map f (take n xs)+ =: qed++-- | @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.+-- Functions proven terminating: sbv.map+-- [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 == []@+--+-- >>> 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 .== [])+ []++-- | @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.+-- Functions proven terminating: sbv.map, sbv.zip+-- [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.+-- Functions proven terminating: sbv.map, sbv.zip+-- [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.+-- Functions proven terminating: sbv.map, sbv.zip+-- [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.+-- Functions proven terminating: sbv.map, sbv.zip+-- [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 -> [sCase| l of+ [] -> 0+ x : xs | e .== x -> 1 + count e xs+ | True -> count e xs+ |]++-- | One-step unfolding of 'count' on a cons cell. The solver can expand the+-- @define-fun-rec@ but struggles to fold it back, so we provide this as a reusable hint.+--+-- >>> runTP $ countOneStep @Integer+-- Lemma: countOneStep Q.E.D.+-- Functions proven terminating: count+-- [Proven] countOneStep :: Ɐe ∷ Integer → Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+countOneStep :: forall a. SymVal a => TP (Proof (Forall "e" a -> Forall "x" a -> Forall "xs" [a] -> SBool))+countOneStep = lemma "countOneStep"+ (\(Forall @"e" e) (Forall @"x" x) (Forall @"xs" (xs :: SList a)) ->+ count e (x .: xs) .== ite (e .== x) (1 + count e xs) (count e xs))+ []++-- | 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 -> [sCase| xs of+ [] -> ys+ a : as -> a .: interleave ys as+ |]++-- | 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 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.+-- Functions proven terminating: interleave+-- [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)+ =: [pCase| xs of+ [] -> trivial+ whole@(_ : as) ->+ length whole + length ys .== length (interleave whole 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 ([], []))++-- | Generalized form of uninterleave with the auxiliary 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 [sCase| xs of+ [] -> tuple (reverse es, reverse os)+ x : ys -> uninterleaveGen ys (tuple (os, x .: 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 (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.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 Q.E.D.+-- Step: 1.3.7 Q.E.D.+-- Step: 1.3.8 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: interleaveRoundTrip+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: interleave, sbv.reverse, uninterleave+-- [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+ =: [pCase| tuple (xs, ys) of+ ([], _) -> trivial+ (_, []) -> trivial+ (ll@(a : as), rr@(b : bs)) ->+ uninterleaveGen (interleave ll rr) alts+ =: uninterleaveGen (a .: interleave rr 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 ++ ll, reverse (b .: os) ++ bs)+ ?? revHelper `at` (Inst @"a" b, Inst @"as" os, Inst @"bs" bs)+ =: tuple (reverse es ++ ll, reverse os ++ rr)+ =: 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 ([], []))+ ?? roundTripGen `at` (Inst @"xs" xs, Inst @"ys" ys, Inst @"alts" (tuple ([], [])))+ =: tuple (reverse [] ++ xs, reverse [] ++ 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.+-- Functions proven terminating: count+-- [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.+-- Functions proven terminating: count+-- [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.+-- Functions proven terminating: count+-- [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.+-- Functions proven terminating: count+-- [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.+-- Functions proven terminating: count+-- [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 mapConcat "Use concatMap" -}+{- HLint ignore takeDropWhile "Evaluate" -}
+ Documentation/SBV/Examples/TP/Majority.hs view
@@ -0,0 +1,157 @@+-----------------------------------------------------------------------------+-- |+-- 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 DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# 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 Documentation.SBV.Examples.TP.Lists 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 -> [sCase| lst of+ [] -> c+ x : xs | i .== 0 -> majority x 1 xs+ | True -> 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.+-- Functions proven terminating: count, majority+-- ([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 .< howMany 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 + howMany 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 + howMany 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,94 @@+-----------------------------------------------------------------------------+-- |+-- 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 QuasiQuotes #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# 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. We use 'smtFunctionWithContract' because+-- the nested recursion @mcCarthy91 (mcCarthy91 (n + 11))@ requires knowing what the inner call returns+-- in order to verify that the outer call's measure decreases. The contract states that for inputs @≤ 100@,+-- the result is @91@. Note that the contract itself is verified as part of the measure check: SBV proves+-- both measure decrease and the contract simultaneously via well-founded induction.+mcCarthy91 :: SInteger -> SInteger+mcCarthy91 = smtFunctionWithContract "mcCarthy91"+ ( \n -> 0 `smax` (101 - n)+ , \n r -> n .<= 100 .=> r .== 91+ , []+ )+ $ \n -> [sCase| n of+ _ | 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.+-- Functions proven terminating: mcCarthy91+-- [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,314 @@+-----------------------------------------------------------------------------+-- |+-- 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 FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# 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 Documentation.SBV.Examples.TP.Lists 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 :: (OrdSymbolic (SBV a), SymVal a) => SList a -> SList a -> SList a+merge = smtFunction "merge"+ $ \l r -> [sCase| tuple (l, r) of+ ([], _) -> r+ (_, []) -> l++ (ll@(a : as), rr@(b : bs)) | a .<= b -> a .: merge as rr+ | True -> b .: merge ll bs+ |]++-- | Merge sort, using 'merge' above to successively sort halved input+mergeSort :: (OrdSymbolic (SBV a), SymVal a) => SList a -> SList a+mergeSort = smtFunction "mergeSort"+ $ \l -> [sCase| l of+ [] -> l+ [_] -> 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.+-- Lemma: countOneStep Q.E.D.+-- Lemma: mergeHead Q.E.D.+-- Lemma: mergeUnfold Q.E.D.+-- Inductive lemma (strong): mergeKeepsSort+-- 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 (2 way case split)+-- Step: 1.3.1.1 (2 way case split) Q.E.D.+-- Step: 1.3.1.2 Q.E.D.+-- Step: 1.3.1.3 Q.E.D.+-- Step: 1.3.2.1 (2 way case split) Q.E.D.+-- Step: 1.3.2.2 Q.E.D.+-- Step: 1.3.2.3 Q.E.D.+-- Step: 1.3.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Inductive lemma (strong): sortNonDecreasing+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (2 way 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.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Inductive lemma (strong): mergeCount+-- 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 (unfold merge) Q.E.D.+-- Step: 1.3.2 (push count inside) Q.E.D.+-- Step: 1.3.3 (unfold count, twice) Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 (unfold count in reverse, twice) Q.E.D.+-- Step: 1.3.7 (simplify) Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Inductive lemma (strong): sortIsPermutation+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (2 way 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.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: mergeSortIsCorrect Q.E.D.+-- Functions proven terminating: count, merge, mergeSort, nonDecreasing+-- [Proven] mergeSortIsCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. (OrdSymbolic (SBV a), SymVal a) => IO (Proof (Forall "xs" [a] -> SBool))+correctness = runTP $ 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+ cntStep <- TP.countOneStep @a++ -- Head of merge: one unfold of merge suffices for the solver+ mergeHead <- lemma "mergeHead"+ (\(Forall xs) (Forall ys) -> sNot (null ys) .=>+ head (merge xs ys) .== ite (null xs) (head ys) (ite (head xs .<= head ys) (head xs) (head ys)))+ []++ -- Unfold lemma for merge's recursive case+ mergeUnfold <- lemma "mergeUnfold"+ (\(Forall x) (Forall xs) (Forall y) (Forall ys) ->+ merge (x .: xs) (y .: ys) .== ite (x .<= y) (x .: merge xs (y .: ys)) (y .: merge (x .: xs) ys))+ []++ --------------------------------------------------------------------------------------------+ -- 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]+ |- [pCase| tuple (xs, ys) of+ ([], _) -> trivial+ (_, []) -> trivial+ (ll@(a : as), rr@(b : bs)) ->+ nonDecreasing (merge ll rr)+ ?? "2 way case split"+ =: cases [ a .<= b ==> nonDecreasing (merge ll rr)+ ?? mergeUnfold `at` (Inst @"x" a, Inst @"xs" as, Inst @"y" b, Inst @"ys" bs)+ =: nonDecreasing (a .: merge as rr)+ ?? ih `at` (Inst @"xs" as, Inst @"ys" rr)+ ?? nonDecrIns `at` (Inst @"x" a, Inst @"xs" (merge as rr))+ ?? mergeHead `at` (Inst @"xs" as, Inst @"ys" rr)+ =: sTrue+ =: qed+ , a .> b ==> nonDecreasing (merge ll rr)+ ?? mergeUnfold `at` (Inst @"x" a, Inst @"xs" as, Inst @"y" b, Inst @"ys" bs)+ =: nonDecreasing (b .: merge ll bs)+ ?? ih `at` (Inst @"xs" ll, Inst @"ys" bs)+ ?? nonDecrIns `at` (Inst @"x" b, Inst @"xs" (merge ll bs))+ ?? mergeHead `at` (Inst @"xs" ll, Inst @"ys" bs)+ =: sTrue+ =: qed+ ]+ |]++ sortNonDecreasing <-+ sInduct "sortNonDecreasing"+ (\(Forall xs) -> nonDecreasing (mergeSort xs))+ (length, []) $+ \ih xs -> [] |- [pCase| xs of+ [] -> qed+ whole@(_ : es) ->+ nonDecreasing (mergeSort whole)+ ?? "unfold"+ =: let (h1, h2) = splitAt (length whole `sEDiv` 2) whole+ in nonDecreasing (ite (length whole .<= 1)+ whole+ (merge (mergeSort h1) (mergeSort h2)))+ ?? "push nonDecreasing down"+ =: ite (length whole .<= 1)+ (nonDecreasing whole)+ (nonDecreasing (merge (mergeSort h1) (mergeSort h2)))+ ?? ih `at` Inst @"xs" es+ =: ite (length whole .<= 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 permutation 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 -> [] |- [pCase| tuple (as, bs) of+ ([], _) -> trivial+ (_, []) -> trivial++ (ll@(x : xs), rr@(y : ys)) ->+ count e (merge ll rr)+ ?? "unfold merge"+ =: count e (ite (x .<= y)+ (x .: merge xs rr)+ (y .: merge ll ys))+ ?? "push count inside"+ =: ite (x .<= y)+ (count e (x .: merge xs rr))+ (count e (y .: merge ll ys))+ ?? "unfold count, twice"+ ?? cntStep `at` (Inst @"e" e, Inst @"x" x, Inst @"xs" (merge xs rr))+ ?? cntStep `at` (Inst @"e" e, Inst @"x" y, Inst @"xs" (merge ll ys))+ =: ite (x .<= y)+ (let r = count e (merge xs rr) in ite (e .== x) (1+r) r)+ (let r = count e (merge ll ys) in ite (e .== y) (1+r) r)+ ?? ih `at` (Inst @"xs" xs, Inst @"ys" rr, Inst @"e" e)+ =: ite (x .<= y)+ (let r = count e xs + count e rr in ite (e .== x) (1+r) r)+ (let r = count e (merge ll ys) in ite (e .== y) (1+r) r)+ ?? ih `at` (Inst @"xs" ll, Inst @"ys" ys, Inst @"e" e)+ =: ite (x .<= y)+ (let r = count e xs + count e rr in ite (e .== x) (1+r) r)+ (let r = count e ll + count e ys in ite (e .== y) (1+r) r)+ ?? "unfold count in reverse, twice"+ ?? cntStep `at` (Inst @"e" e, Inst @"x" x, Inst @"xs" xs)+ ?? cntStep `at` (Inst @"e" e, Inst @"x" y, Inst @"xs" ys)+ =: ite (x .<= y)+ (count e ll + count e rr)+ (count e ll + count e rr)+ ?? "simplify"+ =: count e ll + count e rr+ =: qed+ |]++ sortIsPermutation <-+ sInductWith cvc5 "sortIsPermutation"+ (\(Forall xs) (Forall e) -> count e xs .== count e (mergeSort xs))+ (\xs _e -> length xs, []) $+ \ih as e -> [] |- [pCase| as of+ [] -> trivial+ whole@(x : xs) -> count e (mergeSort whole)+ ?? "unfold mergeSort"+ =: count e (ite (length whole .<= 1)+ whole+ (let (h1, h2) = splitAt (length whole `sEDiv` 2) whole+ in merge (mergeSort h1) (mergeSort h2)))+ ?? "push count down, simplify, rearrange"+ =: let (h1, h2) = splitAt (length whole `sEDiv` 2) whole+ 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" whole, Inst @"n" (length whole `sEDiv` 2), Inst @"e" e)+ =: ite (null xs)+ (count e [x])+ (count e whole)+ =: 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/MutualCorecursion.hs view
@@ -0,0 +1,187 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.MutualCorecursion+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Demonstrating mutually corecursive (productive) functions. Two functions+-- @ping@ and @pong@ take turns producing elements of a stream: each emits+-- its argument and then calls the other with the next value:+--+-- @+-- ping n = n .: pong (n + 1)+-- pong n = n .: ping (n + 1)+-- @+--+-- Together they produce the natural number stream starting from @n@:+-- @ping 0 = [0, 1, 2, 3, ...]@. We prove that the @k@-th element+-- of @ping n@ is @n + k@.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.MutualCorecursion where++import Prelude hiding (head, length, (!!))++import Data.SBV+import Data.SBV.List+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+#endif++-- * Definitions++-- | @ping n@ emits @n@ and hands off to 'pong'. Note the use of 'smtProductiveFunction':+-- since @ping@ and @pong@ are corecursive (no base case, always producing output), we+-- declare them productive instead of terminating.+ping :: SInteger -> SList Integer+ping = smtProductiveFunction "ping"+ $ \n -> n .: pong (n + 1)++-- | @pong n@ emits @n@ and hands off to 'ping'. See 'ping' for why we use 'smtProductiveFunction'.+pong :: SInteger -> SList Integer+pong = smtProductiveFunction "pong"+ $ \n -> n .: ping (n + 1)++-- * Helper lemmas++-- | @ping@ produces unboundedly long lists.+--+-- >>> runTP pingLen+-- Inductive lemma: pingLen+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven productive: ping, pong+-- [Proven] pingLen :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool+pingLen :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))+pingLen = inductWith cvc5 "pingLen"+ (\(Forall @"m" (m :: SInteger)) (Forall @"n" n) -> length (ping n) .>= m) $+ \ih m n -> []+ |- length (ping n) .>= m + 1+ =: length (n .: pong (n + 1)) .>= m + 1+ ?? ih `at` Inst @"n" (n + 2)+ =: sTrue+ =: qed++-- | @pong@ produces unboundedly long lists.+--+-- >>> runTP pongLen+-- Inductive lemma: pongLen+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven productive: ping, pong+-- [Proven] pongLen :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool+pongLen :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))+pongLen = inductWith cvc5 "pongLen"+ (\(Forall @"m" (m :: SInteger)) (Forall @"n" n) -> length (pong n) .>= m) $+ \ih m n -> []+ |- length (pong n) .>= m + 1+ =: length (n .: ping (n + 1)) .>= m + 1+ ?? ih `at` Inst @"n" (n + 2)+ =: sTrue+ =: qed++-- | Indexing past a cons: @(x .: y) !! k == y !! (k - 1)@ when @k > 0@ and in bounds.+--+-- >>> runTP consIndex+-- Lemma: consIndex Q.E.D.+-- [Proven] consIndex :: Ɐx ∷ Integer → Ɐy ∷ [Integer] → Ɐk ∷ Integer → Bool+consIndex :: TP (Proof (Forall "x" Integer -> Forall "y" [Integer] -> Forall "k" Integer -> SBool))+consIndex = lemma "consIndex"+ (\(Forall @"x" (x :: SInteger)) (Forall @"y" y) (Forall @"k" k) ->+ k .> 0 .&& k .<= length y .=> (x .: y) !! k .== y !! (k - 1))+ []++-- * Correctness++-- | Proving @ping n@ and @pong n@ produce the same elements. We prove that the @k@-th+-- elements are the same, by induction on @k@.+--+-- >>> runTP pingEqPong+-- Lemma: pingLen Q.E.D.+-- Lemma: pongLen Q.E.D.+-- Lemma: consIndex Q.E.D.+-- Inductive lemma: pingEqPong+-- 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.+-- Functions proven productive: ping, pong+-- [Proven] pingEqPong :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool+pingEqPong :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))+pingEqPong = do+ piLen <- recall pingLen+ poLen <- recall pongLen+ ci <- recall consIndex++ inductWith cvc5 "pingEqPong"+ (\(Forall @"k" k) (Forall @"n" n) -> k .>= 0 .=> ping n !! k .== pong n !! k) $+ \ih k n -> [k .>= 0]+ |- ping n !! (k + 1)+ =: (n .: pong (n + 1)) !! (k + 1)+ ?? ci `at` (Inst @"x" n, Inst @"y" (pong (n + 1)), Inst @"k" (k + 1))+ ?? poLen+ =: pong (n + 1) !! k+ ?? ih `at` Inst @"n" (n + 1)+ =: ping (n + 1) !! k+ ?? ci `at` (Inst @"x" n, Inst @"y" (ping (n + 1)), Inst @"k" (k + 1))+ ?? piLen+ =: (n .: ping (n + 1)) !! (k + 1)+ =: pong n !! (k + 1)+ =: qed++-- | The @k@-th element of @ping n@ is @n + k@.+--+-- >>> runTP pingElem+-- Lemma: pingEqPong Q.E.D.+-- Lemma: consIndex Q.E.D. [Cached]+-- Lemma: pongLen Q.E.D. [Cached]+-- Inductive lemma: pingElem+-- 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.+-- Functions proven productive: ping, pong+-- [Proven] pingElem :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool+pingElem :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))+pingElem = do+ eq <- recall pingEqPong+ ci <- recall consIndex+ poLen <- recall pongLen++ inductWith cvc5 "pingElem"+ (\(Forall @"k" k) (Forall @"n" n) -> k .>= 0 .=> ping n !! k .== n + k) $+ \ih k n -> [k .>= 0]+ |- ping n !! (k + 1)+ =: (n .: pong (n + 1)) !! (k + 1)+ ?? ci `at` (Inst @"x" n, Inst @"y" (pong (n + 1)), Inst @"k" (k + 1))+ ?? poLen+ =: pong (n + 1) !! k+ ?? eq `at` (Inst @"k" k, Inst @"n" (n + 1))+ =: ping (n + 1) !! k+ ?? ih `at` Inst @"n" (n + 1)+ =: (n + 1) + k+ =: n + (k + 1)+ =: qed
+ Documentation/SBV/Examples/TP/NatStream.hs view
@@ -0,0 +1,121 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.NatStream+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Demonstrating productive (corecursive) functions. A productive function+-- is one where every recursive call is guarded by a data constructor, so+-- the function always makes progress by producing output. Unlike terminating+-- functions, productive functions need not have a base case and may produce+-- infinite output.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.NatStream where++import Prelude hiding (head, length, (!!))++import Data.SBV+import Data.SBV.List+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+#endif++-- * Definitions++-- | The infinite stream of integers starting from @n@: @[n, n+1, n+2, ...]@.+-- There is no base case; every recursive call is guarded by the list+-- constructor @.:@, making this a productive (corecursive) definition.+nats :: SInteger -> SList Integer+nats = smtProductiveFunction "nats"+ $ \n -> n .: nats (n + 1)++-- * Correctness++-- | Prove that @nats n@ always starts with @n@.+--+-- NB. As of Mar 2026, z3 can't handle this but cvc5 can.+--+-- >>> runTP natsHead+-- Lemma: natsHead Q.E.D.+-- Functions proven productive: nats+-- [Proven] natsHead :: Ɐn ∷ Integer → Bool+natsHead :: TP (Proof (Forall "n" Integer -> SBool))+natsHead = lemmaWith cvc5 "natsHead"+ (\(Forall @"n" n) -> head (nats n) .== n)+ []++-- | Prove by induction that @nats n@ has at least @m@ elements, for any @m@.+-- This captures the idea that @nats@ produces an unboundedly long list.+--+-- NB. As of Mar 2026, z3 can't handle this but cvc5 can.+--+-- >>> runTP natsLen+-- Inductive lemma: natsLen+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven productive: nats+-- [Proven] natsLen :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool+natsLen :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))+natsLen =+ inductWith cvc5 "natsLen"+ (\(Forall @"m" m) (Forall @"n" n) -> length (nats n) .>= m) $+ \ih m n -> []+ |- length (nats n) .>= m + 1+ =: length (n .: nats (n + 1)) .>= m + 1+ ?? ih `at` Inst @"n" (n + 1)+ =: sTrue+ =: qed++-- | Prove by induction that the @k@-th element of @nats n@ is @n + k@.+--+-- NB. As of Mar 2026, z3 can't handle this but cvc5 can.+--+-- >>> runTP natsElem+-- Lemma: natsLen Q.E.D.+-- Lemma: elemOne Q.E.D.+-- Inductive lemma: natsElem+-- 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.+-- Functions proven productive: nats+-- [Proven] natsElem :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool+natsElem :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))+natsElem = do+ nLen <- recall natsLen++ elemOne <- lemma "elemOne"+ (\(Forall @"x" (x :: SInteger)) (Forall @"y" y) (Forall @"k" k) ->+ k .> 0 .&& k .<= length y .=> (x .: y) !! k .== y !! (k - 1))+ []++ inductWith cvc5 "natsElem"+ (\(Forall @"k" k) (Forall @"n" n) -> k .>= 0 .=> nats n !! k .== n + k) $+ \ih k n -> [k .>= 0]+ |- nats n !! (k + 1)+ =: (n .: nats (n + 1)) !! (k + 1)+ ?? elemOne+ ?? nLen+ =: nats (n + 1) !! k+ ?? ih `at` Inst @"n" (n + 1)+ =: (n + 1) + k+ =: n + (k + 1)+ =: qed
+ Documentation/SBV/Examples/TP/Numeric.hs view
@@ -0,0 +1,370 @@+-----------------------------------------------------------------------------+-- |+-- 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.+-- Functions proven terminating: sbv.foldr, sbv.replicate+-- [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.+-- Functions proven terminating: EnumSymbolic.Integer.enumFromThenTo.down, sbv.foldr+-- [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.+-- Functions proven terminating: EnumSymbolic.Integer.enumFromThenTo.down, sbv.foldr, sbv.map+-- [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.+-- Functions proven terminating: EnumSymbolic.Integer.enumFromThenTo.down, sbv.foldr, sumCubed+-- [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 -> [sCase| n of+ _ | 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.+-- Functions proven terminating: pow+-- [Proven] elevenMinusFour :: Ɐn ∷ Integer → Bool+elevenMinusFour :: TP (Proof (Forall "n" Integer -> SBool))+elevenMinusFour = do+ let pow :: SInteger -> SInteger -> SInteger+ pow = smtFunction "pow" $ \x y -> [sCase| y of+ _ | 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.+-- Functions proven terminating: EnumSymbolic.Integer.enumFromThenTo.down, sbv.foldr, sbv.map+-- [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.+-- Functions proven terminating: sbv.foldr+-- [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/Peano.hs view
@@ -0,0 +1,926 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Peano+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Modeling Peano arithmetic in SBV and proving various properties using TP.+-- Most of the properties we prove come from <https://en.wikipedia.org/wiki/Peano_axioms>.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Peano where++import Data.SBV+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+#endif++-- | Natural numbers. (If you are looking at the haddock documents, note the plethora of definitions+-- the call to 'mkSymbolic' generates. You can mostly ignore these, except for the case analyzer,+-- the testers and accessors.)+data Nat = Zero+ | Succ { prev :: Nat }++-- | Create a symbolic version of naturals.+mkSymbolic [''Nat]++-- | Numeric instance. Choices: We clamp everything at Zero. Negation is identity.+instance Num Nat where+ fromInteger i | i <= 0 = Zero+ | True = Succ (fromInteger (i - 1))++ a + Zero = a+ a + Succ b = Succ (a + b)++ (-) = error "Nat: No support for subtraction"++ _ * Zero = Zero+ a * Succ b = a + a * b++ abs = id++ signum Zero = 0+ signum _ = 1++ negate = id++-- Symbolic numeric instance, mirroring the above+instance Num SNat where+ fromInteger = literal . fromInteger++ (+) = plus+ where plus = smtFunction "sNatPlus" $+ \m n -> [sCase| m of+ Zero -> n+ Succ p -> sSucc (p + n)+ |]++ (-) = error "SNat: No support for subtraction"++ (*) = times+ where times = smtFunction "sNatTimes" $+ \m n -> [sCase| m of+ Zero -> 0+ Succ p -> n + p * n+ |]++ abs = id++ signum m = [sCase| m of+ Zero -> 0+ _ -> 1+ |]++-- | Symbolic ordering. We only define less-than, other methods use the defaults.+instance OrdSymbolic SNat where+ m .< n = quantifiedBool (\(Exists k) -> n .== m + sSucc k)++-- * Conversion to and from integers++-- | Convert from 'Nat' to 'Integer'.+--+-- NB. When writing the properties below, we use the notation \(\overline{n}\) to mean @n2i n@.+n2i :: SNat -> SInteger+n2i = smtFunction "n2i" $ \n -> [sCase| n of+ Zero -> 0+ Succ p -> 1 + n2i p+ |]++-- | Convert Non-negative integers to 'Nat'. Negative numbers become Zero.+--+-- NB. When writing the properties below, we use the notation \(\underline{i}\) to mean @i2n i@.+i2n :: SInteger -> SNat+i2n = smtFunction "i2n" $ \i -> [sCase| i of+ _ | i .<= 0 -> 0+ _ -> sSucc (i2n (i - 1))+ |]++-- | \(\overline{n} \geq 0\)+--+-- >>> runTP n2iNonNeg+-- Lemma: n2iNonNeg Q.E.D.+-- Functions proven terminating: n2i+-- [Proven] n2iNonNeg :: Ɐn ∷ Nat → Bool+n2iNonNeg :: TP (Proof (Forall "n" Nat -> SBool))+n2iNonNeg = inductiveLemma "n2iNonNeg" (\(Forall n) -> n2i n .>= 0) []++-- | \(\overline{\underline{i}} = \max(i, 0)\).+--+-- >>> runTP i2n2i+-- Lemma: i2n2i Q.E.D.+-- Functions proven terminating: i2n, n2i+-- [Proven] i2n2i :: Ɐi ∷ Integer → Bool+i2n2i :: TP (Proof (Forall "i" Integer -> SBool))+i2n2i = inductiveLemma "i2n2i" (\(Forall i) -> n2i (i2n i) .== i `smax` 0) []++-- | \(\underline{\overline{n}} = n\)+--+-- >>> runTP n2i2n+-- Lemma: n2i2n Q.E.D.+-- Functions proven terminating: i2n, n2i+-- [Proven] n2i2n :: Ɐn ∷ Nat → Bool+n2i2n :: TP (Proof (Forall "n" Nat -> SBool))+n2i2n = inductiveLemma "n2i2n" (\(Forall n) -> i2n (n2i n) .== n) []++-- | \(\overline{m + n} = \overline{m} + \overline{n}\)+--+-- >>> runTP n2iAdd+-- Lemma: n2iAdd Q.E.D.+-- Functions proven terminating: n2i, sNatPlus+-- [Proven] n2iAdd :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+n2iAdd :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+n2iAdd = inductiveLemma "n2iAdd" (\(Forall m) (Forall n) -> n2i (m + n) .== n2i m + n2i n) []++-- * Addition++-- ** Correctness++-- | \(\overline{m + n} = \overline{m} + \overline{n}\)+--+-- >>> runTP addCorrect+-- Lemma: addCorrect Q.E.D.+-- Functions proven terminating: n2i, sNatPlus+-- [Proven] addCorrect :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+addCorrect :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+addCorrect = inductiveLemma+ "addCorrect"+ (\(Forall m) (Forall n) -> n2i (m + n) .== n2i m + n2i n)+ []++-- ** Left and right unit++-- | \(0 + m = m\)+--+-- >>> runTP addLeftUnit+-- Lemma: addLeftUnit Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] addLeftUnit :: Ɐm ∷ Nat → Bool+addLeftUnit :: TP (Proof (Forall "m" Nat -> SBool))+addLeftUnit = lemma "addLeftUnit" (\(Forall m) -> 0 + m .== m) []++-- | \(m + 0 = m\)+--+-- >>> runTP addRightUnit+-- Lemma: addRightUnit Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] addRightUnit :: Ɐm ∷ Nat → Bool+addRightUnit :: TP (Proof (Forall "m" Nat -> SBool))+addRightUnit = inductiveLemma "addRightUnit" (\(Forall m) -> m + 0 .== m) []++-- ** Addition with non-zero values++-- | \(m + \mathrm{Succ}\,n = \mathrm{Succ}\,(m + n)\)+--+-- >>> runTP addSucc+-- Lemma: caseZero Q.E.D.+-- Lemma: caseSucc+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: addSucc Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] addSucc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+addSucc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+addSucc = do+ caseZero <- lemma "caseZero"+ (\(Forall @"n" n) -> 0 + sSucc n .== sSucc (0 + n))+ []++ caseSucc <- calc "caseSucc"+ (\(Forall @"m" m) (Forall @"n" n) ->+ m + sSucc n .== sSucc (m + n) .=> sSucc m + sSucc n .== sSucc (sSucc m + n)) $+ \m n -> let ih = m + sSucc n .== sSucc (m + n)+ in [ih] |- sSucc m + sSucc n+ =: sSucc (m + sSucc n)+ ?? ih+ =: sSucc (sSucc (m + n))+ =: sSucc (sSucc m + n)+ =: qed++ inductiveLemma+ "addSucc"+ (\(Forall @"m" m) (Forall @"n" n) -> m + sSucc n .== sSucc (m + n))+ [proofOf caseZero, proofOf caseSucc]++-- ** Associativity++-- | \(m + (n + o) = (m + n) + o\)+--+-- >>> runTP addAssoc+-- Lemma: addAssoc Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] addAssoc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool+addAssoc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))+addAssoc = inductiveLemma+ "addAssoc"+ (\(Forall m) (Forall n) (Forall o) -> m + (n + o) .== (m + n) + o)+ []++-- ** Commutativity++-- | \(m + n = n + m\)+--+-- >>> runTP addComm+-- Lemma: addLeftUnit Q.E.D.+-- Lemma: addRightUnit Q.E.D.+-- Lemma: caseZero Q.E.D.+-- Lemma: addSucc Q.E.D.+-- Lemma: caseSucc+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: addComm Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] addComm :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+addComm :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+addComm = do+ alu <- recall addLeftUnit+ aru <- recall addRightUnit++ caseZero <- lemma "caseZero"+ (\(Forall @"n" (n :: SNat)) -> 0 + n .== n + 0)+ [proofOf alu, proofOf aru]++ as <- recall addSucc++ caseSucc <- calc "caseSucc"+ (\(Forall @"m" m) (Forall @"n" n) -> m + n .== n + m .=> sSucc m + n .== n + sSucc m) $+ \m n -> let ih = m + n .== n + m+ in [ih] |- sSucc m + n+ =: sSucc (m + n)+ ?? ih+ =: sSucc (n + m)+ ?? as `at` (Inst @"m" n, Inst @"n" m)+ =: n + sSucc m+ =: qed++ inductiveLemma "addComm"+ (\(Forall m) (Forall n) -> m + n .== n + m)+ [proofOf caseZero, proofOf caseSucc]++-- * Multiplication++-- ** Correctness++-- | \(\overline{m * n} = \overline{m} * \overline{n}\)+--+-- >>> runTP mulCorrect+-- Lemma: caseZero Q.E.D.+-- Lemma: addCorrect Q.E.D.+-- Lemma: caseSucc+-- 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: mullCorrect Q.E.D.+-- Functions proven terminating: n2i, sNatPlus, sNatTimes+-- [Proven] mullCorrect :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+mulCorrect :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+mulCorrect = do+ caseZero <- lemma "caseZero"+ (\(Forall @"n" n) -> n2i (0 * n) .== n2i 0 * n2i n)+ []++ addC <- recall addCorrect++ caseSucc <- calc "caseSucc"+ (\(Forall @"m" m) (Forall @"n" n) ->+ n2i (m * n) .== n2i m * n2i n .=> n2i (sSucc m * n) .== n2i (sSucc m) * n2i n) $+ \m n -> let ih = n2i (m * n) .== n2i m * n2i n+ in [ih] |- n2i (sSucc m * n)+ =: n2i (n + m * n)+ ?? addC `at` (Inst @"m" n, Inst @"n" (m * n))+ =: n2i n + n2i (m * n)+ ?? ih+ =: n2i n + n2i m * n2i n+ =: n2i n * (1 + n2i m)+ =: n2i n * n2i (sSucc m)+ =: qed++ inductiveLemma+ "mullCorrect"+ (\(Forall @"m" m) (Forall @"n" n) -> n2i (m * n) .== n2i m * n2i n)+ [proofOf caseZero, proofOf caseSucc]++-- ** Left and right absorption++-- | \(0 * m = 0\)+--+-- >>> runTP mulLeftAbsorb+-- Lemma: mulLeftAbsorb Q.E.D.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] mulLeftAbsorb :: Ɐm ∷ Nat → Bool+mulLeftAbsorb :: TP (Proof (Forall "m" Nat -> SBool))+mulLeftAbsorb = lemma "mulLeftAbsorb" (\(Forall m) -> 0 * m .== 0) []++-- | \(m * 0 = 0\)+--+-- >>> runTP mulRightAbsorb+-- Lemma: mulRightAbsorb Q.E.D.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] mulRightAbsorb :: Ɐm ∷ Nat → Bool+mulRightAbsorb :: TP (Proof (Forall "m" Nat -> SBool))+mulRightAbsorb = inductiveLemma "mulRightAbsorb" (\(Forall m) -> m * 0 .== 0) []++-- ** Left and right unit++-- | \(\mathrm{Succ\,0} * m = m\)+--+-- >>> runTP mulLeftUnit+-- Lemma: mulLeftUnit Q.E.D.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] mulLeftUnit :: Ɐm ∷ Nat → Bool+mulLeftUnit :: TP (Proof (Forall "m" Nat -> SBool))+mulLeftUnit = inductiveLemma "mulLeftUnit" (\(Forall m) -> sSucc 0 * m .== m) []++-- | \(m * \mathrm{Succ\,0} = m\)+--+-- >>> runTP mulRightUnit+-- Lemma: mulRightUnit Q.E.D.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] mulRightUnit :: Ɐm ∷ Nat → Bool+mulRightUnit :: TP (Proof (Forall "m" Nat -> SBool))+mulRightUnit = inductiveLemma "mulRightUnit" (\(Forall m) -> m * sSucc 0 .== m) []++-- ** Distribution over addition++-- | \(m * (n + o) = m * n + m * o\)+--+-- >>> runTP distribLeft+-- Lemma: caseZero Q.E.D.+-- Lemma: addAssoc Q.E.D.+-- Lemma: addComm Q.E.D.+-- Lemma: caseSucc+-- 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: distribLeft Q.E.D.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] distribLeft :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool+distribLeft :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))+distribLeft = do+ caseZero <- lemma "caseZero" (\(Forall @"n" n) (Forall @"o" (o :: SNat)) -> 0 * (n + o) .== 0 * n + 0 * o) []++ addAsc <- recall addAssoc+ addCom <- recall addComm++ caseSucc <- calc "caseSucc"+ (\(Forall @"m" m) (Forall @"n" n) (Forall @"o" o) ->+ m * (n + o) .== m * n + m * o .=> sSucc m * (n + o) .== sSucc m * n + sSucc m * o) $+ \m n o -> let ih = m * (n + o) .== m * n + m * o+ in [ih] |- sSucc m * (n + o)+ =: (n + o) + m * (n + o)+ ?? ih+ =: (n + o) + (m * n + m * o)+ ?? addAsc `at` (Inst @"m" n, Inst @"n" o, Inst @"o" (m * n + m * o))+ =: n + (o + (m * n + m * o))+ ?? addCom `at` (Inst @"m" (m * n), Inst @"n" (m * o))+ =: n + (o + (m * o + m * n))+ ?? addAsc `at` (Inst @"m" o, Inst @"n" (m * o), Inst @"o" (m * n))+ =: n + ((o + m * o) + m * n)+ =: n + (sSucc m * o + m * n)+ ?? addCom `at` (Inst @"m" (sSucc m * o), Inst @"n" (m * n))+ =: n + (m * n + sSucc m * o)+ ?? addAsc `at` (Inst @"m" n, Inst @"n" (m * n), Inst @"o" (sSucc m * o))+ =: (n + m * n) + sSucc m * o+ =: sSucc m * n + sSucc m * o+ =: qed++ inductiveLemma+ "distribLeft"+ (\(Forall m) (Forall n) (Forall o) -> m * (n + o) .== m * n + m * o)+ [proofOf caseZero, proofOf caseSucc]++-- | \((m + n) * o = m * o + n * o\)+--+-- >>> runTP distribRight+-- Lemma: caseZero Q.E.D.+-- Lemma: addAssoc Q.E.D.+-- Lemma: addComm Q.E.D.+-- Lemma: addSucc Q.E.D. [Cached]+-- Lemma: caseSucc+-- 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.+-- Lemma: distribRight Q.E.D.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] distribRight :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool+distribRight :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))+distribRight = do+ caseZero <- lemma "caseZero" (\(Forall @"n" n) (Forall @"o" (o :: SNat)) -> (0 + n) * o .== 0 * o + n * o) []++ pAddAssoc <- recall addAssoc+ pAddCom <- recall addComm+ pAddSucc <- recall addSucc++ caseSucc <- calc "caseSucc"+ (\(Forall @"m" m) (Forall @"n" n) (Forall @"o" o) ->+ (m + n) * o .== m * o + n * o .=> (sSucc m + n) * o .== sSucc m * o + n * o) $+ \m n o -> let ih = (m + n) * o .== m * o + n * o+ in [ih] |- (sSucc m + n) * o+ ?? pAddCom `at` (Inst @"m" (sSucc m), Inst @"n" n)+ =: (n + sSucc m) * o+ ?? pAddSucc `at` (Inst @"m" n, Inst @"n" m)+ =: sSucc (n + m) * o+ ?? pAddCom `at` (Inst @"m" n, Inst @"n" m)+ =: sSucc (m + n) * o+ =: o + (m + n) * o+ ?? ih+ =: o + (m * o + n *o)+ ?? pAddAssoc `at` (Inst @"m" o, Inst @"n" (m * o), Inst @"o" (n * o))+ =: (o + m * o) + n * o+ =: sSucc m * o + n * o+ =: qed++ inductiveLemma+ "distribRight"+ (\(Forall m) (Forall n) (Forall o) -> (m + n) * o .== m * o + n * o)+ [proofOf caseZero, proofOf caseSucc]++-- ** Multiplication with non-zero values++-- | \(m * \mathrm{Succ}\,n = m * n + m\)+--+-- >>> runTP mulSucc+-- Lemma: addLeftUnit Q.E.D.+-- Lemma: distribLeft Q.E.D.+-- Lemma: mulRightUnit Q.E.D.+-- Lemma: addComm Q.E.D. [Cached]+-- Lemma: mulSucc+-- Step: 1 Q.E.D.+-- Step: 2 (defn of +) Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] mulSucc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+mulSucc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+mulSucc = do+ alu <- recall addLeftUnit+ dL <- recall distribLeft+ mru <- recall mulRightUnit+ ac <- recall addComm++ calc "mulSucc"+ (\(Forall @"m" m) (Forall @"n" n) -> m * sSucc n .== m * n + m) $+ \m n -> [] |- m * sSucc n+ ?? alu+ =: m * sSucc (0 + n)+ ?? "defn of +"+ =: m * (sSucc 0 + n)+ ?? dL `at` (Inst @"m" m, Inst @"n" (sSucc 0), Inst @"o" n)+ =: m * sSucc 0 + m * n+ ?? mru+ =: m + m * n+ ?? ac `at` (Inst @"m" m, Inst @"n" (m * n))+ =: m * n + m+ =: qed++-- ** Associativity++-- | \(m * (n * o) = (m * n) * o\)+--+-- >>> runTP mulAssoc+-- Lemma: caseZero Q.E.D.+-- Lemma: distribRight Q.E.D.+-- Lemma: caseSucc+-- 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: mulAssoc Q.E.D.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] mulAssoc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool+mulAssoc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))+mulAssoc = do+ caseZero <- lemma "caseZero"+ (\(Forall @"n" n) (Forall @"o" (o :: SNat)) -> 0 * (n * o) .== (0 * n) * o)+ []++ distR <- recall distribRight++ caseSucc <- calc "caseSucc"+ (\(Forall @"m" m) (Forall @"n" n) (Forall @"o" o) ->+ m * (n * o) .== (m * n) * o .=> sSucc m * (n * o) .== (sSucc m * n) * o) $+ \m n o -> let ih = m * (n * o) .== (m * n) * o+ in [ih] |- sSucc m * (n * o)+ =: (n * o) + m * (n * o)+ ?? ih+ =: (n * o) + (m * n) * o+ ?? distR `at` (Inst @"m" n, Inst @"n" (m * n), Inst @"o" o)+ =: (n + m * n) * o+ =: (sSucc m * n) * o+ =: qed++ inductiveLemma+ "mulAssoc"+ (\(Forall m) (Forall n) (Forall o) -> m * (n * o) .== (m * n) * o)+ [proofOf caseZero, proofOf caseSucc]++-- ** Commutativity++-- | \(m * n = n * m\)+--+-- >>> runTP mulComm+-- Lemma: mulRightAbsorb Q.E.D.+-- Lemma: caseZero Q.E.D.+-- Lemma: mulRightUnit Q.E.D.+-- Lemma: distribLeft Q.E.D.+-- Lemma: caseSucc+-- 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: mulComm Q.E.D.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] mulComm :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+mulComm :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+mulComm = do+ mra <- recall mulRightAbsorb++ caseZero <- lemma "caseZero"+ (\(Forall @"m" (m :: SNat)) -> 0 * m .== m * 0)+ [proofOf mra]++ mru <- recall mulRightUnit+ dL <- recall distribLeft++ caseSucc <- calc "caseSucc"+ (\(Forall @"m" m) (Forall @"n" n) -> m * n .== n * m .=> sSucc m * n .== n * sSucc m) $+ \m n -> let ih = m * n .== n * m+ in [ih] |- sSucc m * n+ =: n + m * n+ ?? ih+ =: n + n * m+ ?? mru+ =: n * sSucc 0 + n * m+ ?? dL `at` (Inst @"m" n, Inst @"n" (sSucc 0), Inst @"o" m)+ =: n * (sSucc 0 + m)+ =: n * sSucc (0 + m)+ =: n * sSucc m+ =: qed++ inductiveLemma+ "mulComm"+ (\(Forall @"m" m) (Forall @"n" n) -> m * n .== n * m)+ [proofOf caseZero, proofOf caseSucc]++-- * Ordering++-- ** Transitivity of @<@++-- | \(m < n \;\wedge\; n < o \;\rightarrow\; m < o\)+--+-- >>> runTP ltTrans+-- Lemma: addAssoc Q.E.D.+-- Lemma: ltTrans+-- 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.+-- Functions proven terminating: sNatPlus+-- [Proven] ltTrans :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool+ltTrans :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))+ltTrans = do+ aa <- recall addAssoc++ calc "ltTrans"+ (\(Forall @"m" m) (Forall @"n" n) (Forall @"o" o) -> m .< n .&& n .< o .=> m .< o) $+ \m n o -> [m .< n, n .< o]+ |-> let k1 = some "k1" (\k -> n .== m + sSucc k)+ k2 = some "k2" (\k -> o .== n + sSucc k)+ in n .== m + sSucc k1+ =: o .== n + sSucc k2+ =: o .== (m + sSucc k1) + sSucc k2+ ?? aa `at` (Inst @"m" m, Inst @"n" (sSucc k1), Inst @"o" (sSucc k2))+ =: o .== m + (sSucc k1 + sSucc k2)+ =: o .== m + sSucc (k1 + sSucc k2)+ =: m .< o+ =: sTrue+ =: qed++-- ** Irreflexivity of @<@++-- | \(\neg(m < m)\)+--+-- >>> runTP ltIrreflexive+-- Lemma: cancel Q.E.D.+-- Lemma: ltIrreflexive+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] ltIrreflexive :: Ɐm ∷ Nat → Bool+ltIrreflexive :: TP (Proof (Forall "m" Nat -> SBool))+ltIrreflexive = do+ cancel <- inductiveLemma+ "cancel"+ (\(Forall @"m" m) (Forall @"n" n) -> m + n .== m .=> n .== 0)+ []++ calc "ltIrreflexive"+ (\(Forall @"m" m) -> sNot (m .< m)) $+ \m -> [m .< m] |-> let k = some "k" (\d -> m .== m + sSucc d)+ in m .== m + sSucc k+ ?? cancel `at` (Inst @"m" m, Inst @"n" (sSucc k))+ =: sSucc k .== 0+ =: contradiction++-- ** Trichotomy++-- | \(m \geq n = \overline{m} \geq \overline{n}\)+--+-- >>> runTP lteEquiv+-- Lemma: n2iAdd Q.E.D.+-- Lemma: n2iNonNeg Q.E.D.+-- Lemma: n2i2n Q.E.D.+-- Lemma: i2n2i Q.E.D.+-- Lemma: addRightUnit Q.E.D.+-- Lemma: lteEquiv_ltr+-- 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.+-- Lemma: lteEquiv_rtl+-- 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 (2 way case split)+-- Step: 7.1 Q.E.D.+-- Step: 7.2.1 Q.E.D.+-- Step: 7.2.2 Q.E.D.+-- Step: 7.2.3 Q.E.D.+-- Step: 7.2.4 Q.E.D.+-- Step: 7.2.5 Q.E.D.+-- Step: 7.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: lteEquiv Q.E.D.+-- Functions proven terminating: i2n, n2i, sNatPlus+-- [Proven] lteEquiv :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+lteEquiv :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+lteEquiv = do+ n2ia <- recall n2iAdd+ nn <- recall n2iNonNeg+ n2i2nId <- recall n2i2n+ i2n2iId <- recall i2n2i+ aru <- recall addRightUnit++ ltr <- calcWith cvc5 "lteEquiv_ltr"+ (\(Forall @"m" m) (Forall @"n" n) -> (m .>= n) .=> (n2i m .>= n2i n)) $+ \m n -> [m .>= n]+ |- n2i m .>= n2i n+ =: cases [ m .== n ==> trivial+ , m .> n ==> let k = some "k" (\d -> m .== n + sSucc d)+ in n2i m .>= n2i n+ ?? m .> n+ =: n2i (n + sSucc k) .>= n2i n+ ?? n2ia `at` (Inst @"m" n, Inst @"n" (sSucc k))+ =: n2i n + n2i (sSucc k) .>= n2i n+ ?? nn `at` Inst @"n" (sSucc k)+ =: sTrue+ =: qed+ ]++ rtl <- calc "lteEquiv_rtl"+ (\(Forall @"m" m) (Forall @"n" n) -> (n2i m .>= n2i n) .=> (m .>= n)) $+ \m n -> [n2i m .>= n2i n]+ |-> let k = n2i m - n2i n+ in k .>= 0+ =: n2i m .== n2i n + k+ ?? i2n2iId `at` Inst @"i" k+ =: n2i m .== n2i n + n2i (i2n k)+ ?? n2ia `at` (Inst @"m" n, Inst @"n" (i2n k))+ =: n2i m .== n2i (n + i2n k)+ =: i2n (n2i m) .== i2n (n2i (n + i2n k))+ ?? n2i2nId `at` Inst @"n" m+ =: m .== i2n (n2i (n + i2n k))+ ?? n2i2nId `at` Inst @"n" (n + i2n k)+ =: m .== n + i2n k+ =: cases [ k .> 0 ==> trivial+ , k .<= 0 ==> m .== n + i2n k+ ?? i2n k .== 0+ =: m .== n + 0+ ?? aru+ =: m .== n+ =: m .== n .|| m .> n+ =: m .>= n+ =: qed+ ]++ lemma "lteEquiv"+ (\(Forall m) (Forall n) -> (n2i m .>= n2i n) .== (m .>= n))+ [proofOf ltr, proofOf rtl]++-- | \(m \geq n \;\lor\; n \geq m\)+--+-- >>> runTP ordered+-- Lemma: lteEquiv Q.E.D.+-- Lemma: ordered+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: i2n, n2i, sNatPlus+-- [Proven] ordered :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+ordered :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+ordered = do+ lteEq <- recall lteEquiv++ calcWith cvc5 "ordered"+ (\(Forall m) (Forall n) -> m .>= n .|| n .>= m) $+ \m n -> [] |- (m .>= n .|| n .>= m)+ ?? lteEq `at` (Inst @"m" m, Inst @"n" n)+ =: (n2i m .>= n2i n .|| n .>= m)+ ?? lteEq `at` (Inst @"m" n, Inst @"n" m)+ =: (n2i m .>= n2i n .|| n2i n .>= n2i m)+ =: qed++-- | \(m < n \;\lor\; m = n \;\lor\; n < m\)+--+-- >>> runTP trichotomy+-- Lemma: ordered Q.E.D.+-- Lemma: trichotomy Q.E.D.+-- Functions proven terminating: i2n, n2i, sNatPlus+-- [Proven] trichotomy :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+trichotomy :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+trichotomy = do+ pOrdered <- recall ordered++ lemma "trichotomy"+ (\(Forall m) (Forall n) -> m .< n .|| m .== n .|| n .< m)+ [proofOf pOrdered]++-- ** Addition and ordering++-- | \(m < n \;\rightarrow\; m + o < n + o\)+--+-- >>> runTP addOrder+-- Lemma: addAssoc Q.E.D.+-- Lemma: addComm Q.E.D.+-- Lemma: addOrder+-- 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.+-- Functions proven terminating: sNatPlus+-- [Proven] addOrder :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool+addOrder :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))+addOrder = do+ pAddAssoc <- recall addAssoc+ pAddComm <- recall addComm++ calc "addOrder"+ (\(Forall m) (Forall n) (Forall o) -> m .< n .=> m + o .< n + o) $+ \m n o -> [m .< n]+ |-> let k = some "k" (\d -> n .== m + sSucc d)+ in n .== m + sSucc k+ =: n + o .== (m + sSucc k) + o+ ?? pAddAssoc `at` (Inst @"m" m, Inst @"n" (sSucc k), Inst @"o" o)+ =: n + o .== m + (sSucc k + o)+ ?? pAddComm `at` (Inst @"m" (sSucc k), Inst @"n" o)+ =: n + o .== m + (o + sSucc k)+ ?? pAddAssoc `at` (Inst @"m" m, Inst @"n" o, Inst @"o" (sSucc k))+ =: n + o .== (m + o) + sSucc k+ =: m + o .<= n + o+ =: qed++-- ** Multiplication and ordering++-- | \(o > 0 \;\wedge\; m < n \;\rightarrow\; m * o < n * o\)+--+-- >>> runTP mulOrder+-- Lemma: distribRight Q.E.D.+-- Lemma: mulOrder+-- 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.+-- Functions proven terminating: sNatPlus, sNatTimes+-- [Proven] mulOrder :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool+mulOrder :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))+mulOrder = do+ pDistribRight <- recall distribRight++ calc "mulOrder"+ (\(Forall m) (Forall n) (Forall o) -> 0 .< o .&& m .< n .=> m * o .< n * o) $+ \m n o -> [0 .< o, m .< n]+ |-> let k = some "k" (\d -> n .== m + sSucc d)+ in n .== m + sSucc k+ =: n * o .== (m + sSucc k) * o+ ?? pDistribRight `at` (Inst @"m" m, Inst @"n" (sSucc k), Inst @"o" o)+ =: n * o .== m * o + sSucc k * o+ ?? 0 .< o+ =: n * o .== m * o + sSucc k * sSucc (sprev o)+ =: n * o .== m * o + (sSucc (sprev o) + k * sSucc (sprev o))+ =: n * o .== m * o + sSucc (sprev o + k * sSucc (sprev o))+ =: m * o .< n * o+ =: qed++-- ** Order and sum++-- | \(m < n \;\rightarrow\; \exists o.\; m + o = n\)+--+-- >>> runTP orderSum+-- Lemma: orderSum Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] orderSum :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool+orderSum :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))+orderSum = lemma "orderSum"+ (\(Forall m) (Forall n) -> m .< n .=> quantifiedBool (\(Exists o) -> m + o .== n))+ []++-- ** 0 and 1 relationship++-- | \(0 < 1\)+--+-- >>> runTP zeroLtOne+-- Lemma: zeroLtOne Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] zeroLtOne :: Bool+zeroLtOne :: TP (Proof SBool)+zeroLtOne = lemma "zeroLtOne" (0 .< (1 :: SNat)) []++-- | \(m > 0 \;\rightarrow\; m \geq 1\)+--+-- >>> runTP nothingBetweenZeroAndOne+-- Lemma: nothingBetweenZeroAndOne Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] nothingBetweenZeroAndOne :: Ɐm ∷ Nat → Bool+nothingBetweenZeroAndOne :: TP (Proof (Forall "m" Nat -> SBool))+nothingBetweenZeroAndOne = lemma "nothingBetweenZeroAndOne"+ (\(Forall m) -> m .> 0 .=> m .>= 1)+ []++-- ** 0 is the minimum++-- | \(m \geq 0\)+--+-- >>> runTP minimumElt+-- Lemma: minimumElt Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] minimumElt :: Ɐm ∷ Nat → Bool+minimumElt :: TP (Proof (Forall "m" Nat -> SBool))+minimumElt = lemma "minimumElt" (\(Forall m) -> m .>= 0) []++-- ** There is no maximum element++-- | \(\forall m \;\exists n \;.\; m < n\)+--+-- >>> runTP noMaximumElt+-- Lemma: noMaximumElt Q.E.D.+-- Functions proven terminating: sNatPlus+-- [Proven] noMaximumElt :: Ɐm ∷ Nat → ∃n ∷ Nat → Bool+noMaximumElt :: TP (Proof (Forall "m" Nat -> Exists "n" Nat -> SBool))+noMaximumElt = lemma "noMaximumElt" (\(Forall m) (Exists n) -> m .< n) []
+ Documentation/SBV/Examples/TP/PigeonHole.hs view
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.PigeonHole+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proves the pigeon-hole principle. If a list of integers sum to more than the length+-- of the list itself, then some cell must contain a value larger than @1@.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.PigeonHole where++import Prelude hiding (sum, length, elem, null, any)++import Data.SBV+import Data.SBV.List+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+#endif++-- | Overflow: Some value is greater than 1.+overflow :: SList Integer -> SBool+overflow = any (.> 1)++-- | \(\sum xs > \lvert xs \rvert \Rightarrow \textrm{overflow}\, xs\)+--+-- >>> runTP pigeonHole+-- Inductive lemma: pigeonHole+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: sbv.foldr+--[Proven] pigeonHole :: Ɐxs ∷ [Integer] → Bool+pigeonHole :: TP (Proof (Forall "xs" [Integer] -> SBool))+pigeonHole = induct "pigeonHole"+ (\(Forall xs) -> sum xs .> length xs .=> overflow xs) $+ \ih (x, xs) -> [sum xs .> length xs]+ |- overflow (x .: xs)+ =: (x .> 1 .|| overflow xs)+ ?? ih+ =: sTrue+ =: qed
+ Documentation/SBV/Examples/TP/PowerMod.hs view
@@ -0,0 +1,507 @@+-----------------------------------------------------------------------------+-- |+-- 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 use of recall for reusing previously established proofs.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.PowerMod where++import Data.SBV+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+#endif++-- | Power function over integers.+power :: SInteger -> SInteger -> SInteger+power = smtFunction "power" $ \b n -> [sCase| n of+ _ | n .<= 0 -> 1+ _ -> b * power b (n-1)+ |]++-- | \(m > 1 \Rightarrow n + mk \equiv n \pmod{m}\)+--+-- ==== __Proof__+-- >>> runTP modAddMultiple+-- Inductive lemma: modAddMultiplePos+-- 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: modAddMultiple+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness 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+ -- First prove for k >= 0 by induction. We need this restriction since+ -- the inductive hypothesis for integers is guarded by k >= 0.+ pos <- induct "modAddMultiplePos"+ (\(Forall k) (Forall n) (Forall m) -> k .>= 0 .&& m .> 1 .=> (n + m*k) `sEMod` m .== n `sEMod` m) $+ \ih k n m -> [k .>= 0, m .> 1] |- (n + m*(k+1)) `sEMod` m+ =: (n + m*k + m) `sEMod` m+ ?? m `sEMod` m .== 0+ ?? (n + m*k + m) `sEDiv` m .== (n + m*k) `sEDiv` m + 1+ =: (n + m*k) `sEMod` m+ ?? ih `at` (Inst @"n" n, Inst @"m" m)+ =: n `sEMod` m+ =: qed++ -- Extend to all k by case-splitting. For k < 0, use the positive case with+ -- k' = -k > 0 and n' = n+m*k: pos gives (n'+m*k') mod m = n' mod m,+ -- i.e., n mod m = (n+m*k) mod m.+ calc "modAddMultiple"+ (\(Forall k) (Forall n) (Forall m) -> m .> 1 .=> (n + m*k) `sEMod` m .== n `sEMod` m) $+ \k n m -> [m .> 1] |- cases [ k .>= 0 ==> (n + m*k) `sEMod` m+ ?? pos `at` (Inst @"k" k, Inst @"n" n, Inst @"m" m)+ =: n `sEMod` m+ =: qed+ , k .< 0 ==> (n + m*k) `sEMod` m+ ?? pos `at` (Inst @"k" (-k), Inst @"n" (n + m*k), Inst @"m" m)+ =: n `sEMod` m+ =: qed+ ]++-- | \(m > 0 \Rightarrow a + b \equiv a + (b \bmod m) \pmod{m}\)+--+-- ==== __Proof__+-- >>> runTP modAddRight+-- Inductive lemma: modAddMultiplePos+-- 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: modAddMultiple+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness 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__+-- >>> runTP modAddLeft+-- Inductive lemma: modAddMultiplePos+-- 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: modAddMultiple+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness 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__+-- >>> runTP modSubRight+-- Inductive lemma: modAddMultiplePos+-- 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: modAddMultiple+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness 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+ ?? b .== b `sEMod` m + m * b `sEDiv` 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__+-- >>> runTP modMulRightNonneg+-- Inductive lemma: modAddMultiplePos+-- 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: modAddMultiple+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness 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.+-- Lemma: modAddRight Q.E.D. [Cached]+-- 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] 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 <- recall 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__+-- >>> runTP modMulRightNeg+-- Inductive lemma: modAddMultiplePos+-- 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: modAddMultiple+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness 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.+-- Lemma: modSubRight 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] 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 <- recall 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__+-- >>> runTP modMulRight+-- Inductive lemma: modAddMultiplePos+-- 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: modAddMultiple+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness 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.+-- Lemma: modAddRight Q.E.D. [Cached]+-- 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.+-- Lemma: modMulRightNeg 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] 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 <- recall 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__+-- >>> runTP modMulLeft+-- Lemma: modMulRight 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] modMulLeft :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool+modMulLeft :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool))+modMulLeft = do+ mMulR <- recall 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__+-- >>> runTP powerMod+-- Lemma: modMulLeft Q.E.D.+-- Lemma: modMulRight Q.E.D. [Cached]+-- 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.+-- Functions proven terminating: power+-- [Proven] powerMod :: Ɐb ∷ Integer → Ɐn ∷ Integer → Ɐm ∷ Integer → Bool+powerMod :: TP (Proof (Forall "b" Integer -> Forall "n" Integer -> Forall "m" Integer -> SBool))+powerMod = do+ mMulL <- recall modMulLeft+ mMulR <- recall 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__+-- >>> runTP 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.+-- Functions proven terminating: power+-- [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__+-- >>> runTP powerOf27+-- Lemma: onePower 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.+-- Functions proven terminating: power+-- [Proven] powerOf27 :: Ɐn ∷ Integer → Bool+powerOf27 :: TP (Proof (Forall "n" Integer -> SBool))+powerOf27 = do+ pOne <- recall onePower+ pMod <- recall 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__+-- >>> runTP powerOfThreeMod13VarDivisor+-- Lemma: powerOf27 Q.E.D.+-- Lemma: powerOfThreeMod13VarDivisor+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: power+-- [Proven] powerOfThreeMod13VarDivisor :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool+powerOfThreeMod13VarDivisor :: TP (Proof (Forall "n" Integer -> Forall "m" Integer -> SBool))+powerOfThreeMod13VarDivisor = do+ p27 <- recall 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/Primes.hs view
@@ -0,0 +1,522 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Primes+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Prove that there are an infinite number of primes. Along the way we formalize+-- and prove a number of properties about divisibility as well. Our proof is inspired by+-- the ACL2 proof in <https://github.com/acl2/acl2/blob/master/books/projects/numbers/euclid.lisp>.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Primes where++import Data.SBV+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+#endif++-- * Divisibility++-- | Divides relation. By definition @0@ only divides @0@. (But every number divides @0@).+dvd :: SInteger -> SInteger -> SBool+x `dvd` y = ite (x .== 0) (y .== 0) (y `sEMod` x .== 0)++-- | \(x \mid y \implies x \mid y * z\)+--+-- === __Proof__+-- >>> runTP dividesProduct+-- Lemma: dividesProduct+-- 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] dividesProduct :: Ɐx ∷ Integer → Ɐy ∷ Integer → Ɐz ∷ Integer → Bool+dividesProduct :: TP (Proof (Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> SBool))+dividesProduct = calc "dividesProduct"+ (\(Forall x) (Forall y) (Forall z) -> x `dvd` y .=> x `dvd` (y*z)) $+ \x y z -> [x `dvd` y]+ |- cases [ x .== 0 ==> x `dvd` (y*z)+ ?? y .== 0+ =: sTrue+ =: qed+ , x ./= 0 ==> x `dvd` (y*z)+ ?? y .== x * y `sEDiv` x+ =: x `dvd` ((x * y `sEDiv` x) * z)+ =: x `dvd` (x * ((y `sEDiv` x) * z))+ =: sTrue+ =: qed+ ]+-- | \(x \mid y \land y \mid z \implies x \mid z\)+--+-- === __Proof__+-- >>> runTP dividesTransitive+-- Lemma: dividesProduct Q.E.D.+-- Lemma: dividesTransitive+-- 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] dividesTransitive :: Ɐx ∷ Integer → Ɐy ∷ Integer → Ɐz ∷ Integer → Bool+dividesTransitive :: TP (Proof (Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> SBool))+dividesTransitive = do+ dp <- recall dividesProduct++ calc "dividesTransitive"+ (\(Forall x) (Forall y) (Forall z) -> x `dvd` y .&& y `dvd` z .=> x `dvd` z) $+ \x y z -> [x `dvd` y, y `dvd` z]+ |- cases [ x .== 0 .|| y .== 0 .|| z .== 0 ==> trivial+ , x ./= 0 .&& y ./= 0 .&& z ./= 0+ ==> x `dvd` z+ ?? z .== z `sEDiv` y * y+ =: x `dvd` (z `sEDiv` y * y)+ ?? y .== y `sEDiv` x * x+ ?? x `dvd` y+ =: x `dvd` ((z `sEDiv` y) * (y `sEDiv` x * x))+ =: x `dvd` (x * ((z `sEDiv` y) * (y `sEDiv` x)))+ ?? dp `at` (Inst @"x" x, Inst @"y" x, Inst @"z" ((z `sEDiv` y) * (y `sEDiv` x)))+ =: sTrue+ =: qed+ ]++-- * The least divisor++-- | The definition of primality will depend on the notion of least divisor. Given @k@ and @n@, the least-divisor of+-- @n@ that is at least @k@ is the number that is at least @k@ and divides @n@ evenly. The idea is that a number is+-- prime if the least divisor starting from @2@ is itself.+ld :: SInteger -> SInteger -> SInteger+ld = smtFunctionWithMeasure "ld" (\k n -> (n - k) `smax` 0, [])+ $ \k n -> [sCase| tuple (k .<= 0 .|| k .> n, n `sEMod` k) of+ (True, _) -> 0+ (_, 0) -> k+ _ -> ld (k+1) n+ |]++-- | \(1 < k \leq n \implies \mathit{ld}\,k\,n \mid n \land k \leq \mathit{ld}\,k\,n \leq n\)+--+-- === __Proof__+-- >>> runTP leastDivisorDivides+-- Inductive lemma (strong): leastDivisorDivides+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: ld+-- [Proven] leastDivisorDivides :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool+leastDivisorDivides :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))+leastDivisorDivides =+ sInduct "leastDivisorDivides"+ (\(Forall k) (Forall n) -> 1 .< k .&& k .<= n .=> let d = ld k n in d `dvd` n .&& k .<= d .&& d .<= n)+ (\k n -> n - k, []) $+ \ih k n -> [1 .< k, k .<= n]+ |- let d = ld k n+ in cases [ n `sEMod` k .== 0 ==> d `dvd` n .&& k .<= d .&& d .<= n+ ?? d .== k+ =: sTrue+ =: qed+ , n `sEMod` k ./= 0 ==> d `dvd` n .&& k .<= d .&& d .<= n+ ?? d .== ld (k+1) n+ ?? ih `at` (Inst @"k" (k+1), Inst @"n" n)+ =: sTrue+ =: qed+ ]++-- | \(1 < k \leq n \land d \mid n \land k \leq d \implies \mathit{ld}\,k\,n \leq d\)+--+-- === __Proof__+-- >>> runTP leastDivisorIsLeast+-- Inductive lemma (strong): leastDivisorisLeast+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (2 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: ld+-- [Proven] leastDivisorisLeast :: Ɐk ∷ Integer → Ɐn ∷ Integer → Ɐd ∷ Integer → Bool+leastDivisorIsLeast :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> Forall "d" Integer -> SBool))+leastDivisorIsLeast =+ sInduct "leastDivisorisLeast"+ (\(Forall k) (Forall n) (Forall d) -> 1 .< k .&& k .<= n .&& d `dvd` n .&& k .<= d .=> ld k n .<= d)+ (\k n _d -> n - k, []) $+ \ih k n d -> [1 .< k, k .<= n, d `dvd` n, k .<= d]+ |- cases [ n `sEMod` k .== 0 ==> ld k n .<= d+ =: k .<= d+ =: qed+ , n `sEMod` k ./= 0 ==> ld k n .<= d+ ?? ih+ =: sTrue+ =: qed+ ]++-- | \(n \geq k \geq 2 \implies \mathit{ld}\,k\,(\mathit{ld}\,k\,n) = \mathit{ld}\,k\,n\)+--+-- === __Proof__+-- >>> runTP leastDivisorTwice+-- Lemma: dividesTransitive Q.E.D.+-- Lemma: leastDivisorDivides Q.E.D.+-- Lemma: leastDivisorisLeast Q.E.D.+-- Lemma: helper1 Q.E.D.+-- Lemma: helper2 Q.E.D.+-- Lemma: helper3+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Lemma: helper4 Q.E.D.+-- Lemma: helper5+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Lemma: leastDivisorTwice Q.E.D.+-- Functions proven terminating: ld+-- [Proven] leastDivisorTwice :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool+leastDivisorTwice :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))+leastDivisorTwice = do+ dt <- recall dividesTransitive+ ldd <- recall leastDivisorDivides+ ldl <- recall leastDivisorIsLeast++ h1 <- lemmaWith cvc5+ "helper1"+ (\(Forall @"k" k) (Forall @"n" n) -> n .>= k .&& k .>= 2 .=> ld k (ld k n) `dvd` ld k n .&& ld k (ld k n) .<= ld k n)+ [proofOf ldd]++ h2 <- lemma "helper2"+ (\(Forall @"k" k) (Forall @"n" n) -> n .>= k .&& k .>= 2 .=> ld k n `dvd` n)+ [proofOf ldd]++ h3 <- calc "helper3"+ (\(Forall @"k" k) (Forall @"n" n) -> n .>= k .&& k .>= 2 .=> ld k (ld k n) `dvd` n) $+ \k n -> [n .>= k, k .>= 2]+ |- ld k (ld k n) `dvd` n+ ?? h1+ ?? h2+ ?? dt `at` (Inst @"x" (ld k (ld k n)), Inst @"y" (ld k n), Inst @"z" n)+ =: sTrue+ =: qed++ h4 <- lemma "helper4"+ (\(Forall @"k" k) (Forall @"n" n) -> n .>= k .&& k .>= 2 .=> k .<= ld k (ld k n))+ [proofOf ldd]++ h5 <- calc "helper5"+ (\(Forall @"k" k) (Forall @"n" n) -> n .>= k .&& k .>= 2 .=> ld k n .<= ld k (ld k n)) $+ \k n -> [n .>= k, k .>= 2]+ |- ld k n .<= ld k (ld k n)+ ?? h3 `at` (Inst @"k" k, Inst @"n" n)+ ?? h4 `at` (Inst @"k" k, Inst @"n" n)+ ?? ldl `at` (Inst @"k" k, Inst @"n" n, Inst @"d" (ld k (ld k n)))+ =: sTrue+ =: qed++ lemma "leastDivisorTwice"+ (\(Forall k) (Forall n) -> n .>= k .&& k .>= 2 .=> ld k (ld k n) .== ld k n)+ [proofOf h1, proofOf h5]++-- * Primality++-- | A number is prime if its least divisor greater than or equal to @2@ is itself.+isPrime :: SInteger -> SBool+isPrime n = n .>= 2 .&& ld 2 n .== n++-- | \(\mathit{isPrime}\,p \implies p \geq 2\)+--+-- === __Proof__+-- >>> runTP primeAtLeast2+-- Lemma: primeAtLeast2 Q.E.D.+-- Functions proven terminating: ld+-- [Proven] primeAtLeast2 :: Ɐp ∷ Integer → Bool+primeAtLeast2 :: TP (Proof (Forall "p" Integer -> SBool))+primeAtLeast2 = lemma "primeAtLeast2" (\(Forall p) -> isPrime p .=> p .>= 2) []++-- | \(n \geq 2 \implies \mathit{isPrime}\,(\mathit{ld}\,2\,n)\)+--+-- === __Proof__+-- >>> runTP leastDivisorIsPrime+-- Lemma: leastDivisorTwice Q.E.D.+-- Lemma: leastDivisorDivides Q.E.D. [Cached]+-- Lemma: leastDivisorIsPrime+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: ld+-- [Proven] leastDivisorIsPrime :: Ɐn ∷ Integer → Bool+leastDivisorIsPrime :: TP (Proof (Forall "n" Integer -> SBool))+leastDivisorIsPrime = do+ ldt <- recall leastDivisorTwice+ ldd <- recall leastDivisorDivides++ calc "leastDivisorIsPrime"+ (\(Forall n) -> n .>= 2 .=> isPrime (ld 2 n)) $+ \n -> [n .>= 2] |- isPrime (ld 2 n)+ ?? ldt `at` (Inst @"k" 2, Inst @"n" n)+ ?? ldd `at` (Inst @"k" 2, Inst @"n" n)+ =: sTrue+ =: qed++-- | The least prime divisor is the least divisor of it starting from @2@. By 'leastDivisorIsPrime', this number+-- is guaranteed to be prime.+leastPrimeDivisor :: SInteger -> SInteger+leastPrimeDivisor n = ld 2 n++-- * Formalizing factorial++-- | The factorial function.+fact :: SInteger -> SInteger+fact = smtFunction "fact" $ \n -> [sCase| n of+ _ | n .<= 0 -> 1+ _ -> n * fact (n - 1)+ |]++-- | \(n! \geq 1\)+--+-- === __Proof__+-- >>> runTP factAtLeast1+-- Inductive lemma: factAtLeast1+-- 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.+-- Functions proven terminating: fact+-- [Proven] factAtLeast1 :: Ɐn ∷ Integer → Bool+factAtLeast1 :: TP (Proof (Forall "n" Integer -> SBool))+factAtLeast1 = inductWith cvc5 "factAtLeast1"+ (\(Forall n) -> fact n .>= 1) $+ \ih n -> [] |- fact (n+1) .>= 1+ =: cases [ n+1 .<= 0 ==> trivial+ , n+1 .> 0 ==> (n+1) * fact n .>= 1+ ?? ih+ =: sTrue+ =: qed+ ]++-- | \(1 \leq k \land k \leq n \implies k \mid n!\)+--+-- === __Proof__+-- >>> runTP dividesFact+-- Lemma: dividesProduct Q.E.D.+-- Inductive lemma: dividesFact+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (2 way case split)+-- Step: 2.1.1 Q.E.D.+-- Step: 2.1.2 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.+-- Functions proven terminating: fact+-- [Proven] dividesFact :: Ɐn ∷ Integer → Ɐk ∷ Integer → Bool+dividesFact :: TP (Proof (Forall "n" Integer -> Forall "k" Integer -> SBool))+dividesFact = do+ dvp <- recall dividesProduct++ induct "dividesFact"+ (\(Forall n) (Forall k) -> 1 .<= k .&& k .<= n .=> k `dvd` fact n) $+ \ih n k -> [1 .<= k, k .<= n + 1]+ |- k `dvd` fact (n + 1)+ =: k `dvd` ((n + 1) * fact n)+ =: cases [ k .== n + 1 ==> k `dvd` ((n + 1) * fact n)+ ?? dvp `at` (Inst @"x" k, Inst @"y" (n+1), Inst @"z" (fact n))+ =: sTrue+ =: qed+ , k ./= n + 1 ==> k `dvd` ((n + 1) * fact n)+ ?? ih+ ?? dvp `at` (Inst @"x" k, Inst @"y" (fact n), Inst @"z" (n+1))+ =: sTrue+ =: qed+ ]++-- | \(1 \leq k \land k \leq n \implies \neg (k \mid n! + 1)\)+--+-- === __Proof__+-- >>> runTP notDividesFactP1+-- Lemma: dividesFact Q.E.D.+-- Lemma: notDividesFactP1+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: fact+-- [Proven] notDividesFactP1 :: Ɐn ∷ Integer → Ɐk ∷ Integer → Bool+notDividesFactP1 :: TP (Proof (Forall "n" Integer -> Forall "k" Integer -> SBool))+notDividesFactP1 = do+ df <- recall dividesFact++ calc "notDividesFactP1"+ (\(Forall n) (Forall k) -> 1 .< k .&& k .<= n .=> sNot (k `dvd` (fact n + 1))) $+ \n k -> [1 .< k, k .<= n]+ |- k `dvd` (fact n + 1)+ ?? df `at` (Inst @"n" n, Inst @"k" k)+ =: k `dvd` (k * fact n `sEDiv` k + 1)+ =: k `dvd` 1+ =: contradiction++-- * Finding a greater prime++-- | Given a number, return another number which is both prime and is larger than the input. Note that+-- we don't claim to return the closest prime to the input. Just some prime that is larger, as we shall prove.+greaterPrime :: SInteger -> SInteger+greaterPrime n = leastPrimeDivisor (1 + fact n)++-- | \(\mathit{greaterPrime}\, n \mid n! + 1\)+--+-- === __Proof__+-- >>> runTP greaterPrimeDivides+-- Lemma: leastDivisorDivides Q.E.D.+-- Lemma: factAtLeast1 Q.E.D.+-- Lemma: greaterPrimeDivides+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: fact, ld+-- [Proven] greaterPrimeDivides :: Ɐn ∷ Integer → Bool+greaterPrimeDivides :: TP (Proof (Forall "n" Integer -> SBool))+greaterPrimeDivides = do+ ldd <- recall leastDivisorDivides+ fal1 <- recall factAtLeast1++ calc "greaterPrimeDivides"+ (\(Forall n) -> greaterPrime n `dvd` (1 + fact n)) $+ \n -> [] |- greaterPrime n `dvd` (1 + fact n)+ =: leastPrimeDivisor (1 + fact n) `dvd` (1 + fact n)+ =: ld 2 (1 + fact n) `dvd` (1 + fact n)+ ?? ldd `at` (Inst @"k" 2, Inst @"n" (1 + fact n))+ ?? fal1 `at` Inst @"n" n+ =: sTrue+ =: qed++-- | \(\mathit{greaterPrime}\, n > n\)+--+-- === __Proof__+-- >>> runTP greaterPrimeGreater+-- Lemma: notDividesFactP1 Q.E.D.+-- Lemma: greaterPrimeDivides Q.E.D.+-- Lemma: leastDivisorIsPrime Q.E.D.+-- Lemma: factAtLeast1 Q.E.D. [Cached]+-- Lemma: primeAtLeast2 Q.E.D.+-- Lemma: greaterPrimeGreater+-- 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.+-- Functions proven terminating: fact, ld+-- [Proven] greaterPrimeGreater :: Ɐn ∷ Integer → Bool+greaterPrimeGreater :: TP (Proof (Forall "n" Integer -> SBool))+greaterPrimeGreater = do+ ndfp1 <- recall notDividesFactP1+ gpd <- recall greaterPrimeDivides+ ldp <- recall leastDivisorIsPrime+ fal1 <- recall factAtLeast1+ pal2 <- recall primeAtLeast2++ calc "greaterPrimeGreater"+ (\(Forall n) -> greaterPrime n .> n) $+ \n -> [] |-> sTrue+ ?? ndfp1 `at` (Inst @"n" n, Inst @"k" (greaterPrime n))+ ?? gpd `at` Inst @"n" n+ =: sNot (1 .< greaterPrime n .&& greaterPrime n .<= n)+ =: (1 .>= greaterPrime n .|| greaterPrime n .> n)+ =: (1 .>= leastPrimeDivisor (1 + fact n) .|| greaterPrime n .> n)+ =: (1 .>= leastPrimeDivisor (1 + fact n) .|| greaterPrime n .> n)+ =: (1 .>= ld 2 (1 + fact n) .|| greaterPrime n .> n)+ ?? ldp `at` Inst @"n" (1 + fact n)+ ?? pal2 `at` Inst @"p" (ld 2 (1 + fact n))+ ?? fal1 `at` Inst @"n" n+ =: greaterPrime n .> n+ =: qed++-- * Infinitude of primes++-- | \(\mathit{isPrime}\,(\mathit{greaterPrime}\,n) \land \mathit{greaterPrime}\,n > n\)+--+-- We can finally prove our goal: For each given number, there is a larger number that is prime. This+-- establishes that we have an infinite number of primes.+--+-- === __Proof__+-- >>> runTP infinitudeOfPrimes+-- Lemma: leastDivisorIsPrime Q.E.D.+-- Lemma: factAtLeast1 Q.E.D.+-- Lemma: greaterPrimeGreater Q.E.D.+-- Lemma: infinitudeOfPrimes+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: fact, ld+-- [Proven] infinitudeOfPrimes :: Ɐn ∷ Integer → Bool+infinitudeOfPrimes :: TP (Proof (Forall "n" Integer -> SBool))+infinitudeOfPrimes = do+ ldp <- recall leastDivisorIsPrime+ fa1 <- recall factAtLeast1+ gpg <- recall greaterPrimeGreater++ calc "infinitudeOfPrimes"+ (\(Forall n) -> let p = greaterPrime n in p .> n .&& isPrime p) $+ \n -> [] |- let p = greaterPrime n+ in p .> n .&& isPrime (greaterPrime n)+ =: p .> n .&& isPrime (leastPrimeDivisor (1 + fact n))+ =: p .> n .&& isPrime (ld 2 (1 + fact n))+ ?? ldp `at` Inst @"n" (1 + fact n)+ ?? fa1 `at` Inst @"n" n+ ?? gpg `at` Inst @"n" n+ =: sTrue+ =: qed++-- | \(\forall n. \exists p. \mathit{isPrime}\,p \land p > n\)+--+-- Another expression of the fact that there are infinitely many primes. One might prefer this+-- version as it only refers to the 'isPrime' predicate only.+--+-- === __Proof__+-- >>> runTP noLargestPrime+-- Lemma: infinitudeOfPrimes Q.E.D.+-- Lemma: helper+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Lemma: noLargestPrime Q.E.D.+-- Functions proven terminating: fact, ld+-- [Proven] noLargestPrime :: Ɐn ∷ Integer → ∃p ∷ Integer → Bool+noLargestPrime :: TP (Proof (Forall "n" Integer -> Exists "p" Integer -> SBool))+noLargestPrime = do+ iop <- recall infinitudeOfPrimes++ h <- calc "helper"+ (\(Forall @"n" n) -> quantifiedBool (\(Exists p) -> isPrime p .&& p .> n)) $+ \n -> [] |- quantifiedBool (\(Exists p) -> isPrime p .&& p .> n)+ ?? iop `at` Inst @"n" n+ =: sTrue+ =: qed++ lemmaWith cvc5 "noLargestPrime"+ (\(Forall n) (Exists p) -> isPrime p .&& p .> n)+ [proofOf h]++{- HLint ignore module "Avoid lambda" -}+{- HLint ignore module "Eta reduce" -}
+ Documentation/SBV/Examples/TP/Queue.hs view
@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.Queue+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- A classic functional queue implemented with two stacks (lists). The front+-- list holds elements ready for dequeue; the back list accumulates new+-- elements in reverse. We prove that this representation faithfully+-- implements a FIFO queue by showing:+--+-- (1) Enqueue appends to the abstract queue.+-- (2) Enqueuing a sequence of elements and reading out the abstraction+-- gives back the original sequence.+-- (3) Dequeue retrieves the front of the abstract queue.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.Queue where++import Prelude hiding (length, head, tail, null, reverse, (++), fst, snd)++import Data.SBV+import Data.SBV.List+import Data.SBV.Tuple+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> :set -XOverloadedLists+-- >>> :set -XTypeApplications+-- >>> import Data.SBV+-- >>> import Data.SBV.Tuple+-- >>> import Data.SBV.TP+#endif++-- * Queue representation++-- | A queue is a pair @(front, back)@ representing the abstract list+-- @front ++ reverse back@.+type Queue a = STuple [a] [a]++-- | Abstraction function: the list a queue represents.+--+-- >>> toList (tuple ([1,2,3], [6,5,4])) :: SList Integer+-- [1,2,3,4,5,6] :: [SInteger]+toList :: SymVal a => Queue a -> SList a+toList q = [sCase| q of+ (f, b) -> f ++ reverse b+ |]++-- | The empty queue.+--+-- >>> toList (emptyQ @Integer)+-- [] :: [SInteger]+emptyQ :: SymVal a => Queue a+emptyQ = tuple ([], [])++-- | Enqueue: add an element to the back.+--+-- >>> toList (enqueue (tuple ([1,2], [4,3])) 5) :: SList Integer+-- [1,2,3,4,5] :: [SInteger]+enqueue :: SymVal a => Queue a -> SBV a -> Queue a+enqueue q x = [sCase| q of+ (f, b) -> tuple (f, x .: b)+ |]++-- | Enqueue all elements of a list, left to right.+--+-- >>> toList (enqueueAll (emptyQ @Integer) [1,2,3])+-- [1,2,3] :: [SInteger]+enqueueAll :: SymVal a => Queue a -> SList a -> Queue a+enqueueAll = smtFunction "enqueueAll"+ $ \q xs -> [sCase| xs of+ [] -> q+ x : rest -> enqueueAll (enqueue q x) rest+ |]++-- | Dequeue: remove and return the front element. When the front list+-- is empty, we reverse the back list into the front first.+-- Precondition: the queue is non-empty.+--+-- >>> let (v, q') = untuple (dequeue (tuple ([1,2,3], [6,5,4]) :: Queue Integer)) in (v, toList q')+-- (1 :: SInteger,[2,3,4,5,6] :: [SInteger])+-- >>> let (v, q') = untuple (dequeue (tuple ([], [3,2,1]) :: Queue Integer)) in (v, toList q')+-- (1 :: SInteger,[2,3] :: [SInteger])+dequeue :: forall a. SymVal a => Queue a -> STuple a ([a], [a])+dequeue q = [sCase| q of+ (x : xs, t) -> tuple (x, tuple (xs, t))+ ([], t) -> case reverse t of+ y : ys -> tuple (y, tuple (ys, []))+ -- unreachable: both front and back are empty+ _ -> tuple (some "dead" (const sTrue), tuple ([], []))+ |]++-- * Correctness++-- | @toList (enqueue q x) == toList q ++ [x]@+--+-- Enqueue appends to the abstract list.+--+-- >>> runTP $ enqueueCorrect @Integer+-- Lemma: enqueueCorrect Q.E.D.+-- Functions proven terminating: sbv.reverse+-- [Proven] enqueueCorrect :: Ɐf ∷ [Integer] → Ɐb ∷ [Integer] → Ɐx ∷ Integer → Bool+enqueueCorrect :: forall a. SymVal a => TP (Proof (Forall "f" [a] -> Forall "b" [a] -> Forall "x" a -> SBool))+enqueueCorrect =+ lemma "enqueueCorrect"+ (\(Forall @"f" f) (Forall @"b" b) (Forall @"x" x) ->+ toList (enqueue (tuple (f, b)) x) .== toList (tuple (f, b)) ++ [x])+ []++-- | @toList (enqueueAll q xs) == toList q ++ xs@+--+-- Enqueuing a sequence of elements appends the whole sequence to the+-- abstract list. This is the key invariant of the two-stack representation.+--+-- >>> runTP $ enqueueAllCorrect @Integer+-- Lemma: enqueueCorrect Q.E.D.+-- Inductive lemma: enqueueAllCorrect+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: enqueueAll, sbv.reverse+-- [Proven] enqueueAllCorrect :: Ɐxs ∷ [Integer] → Ɐf ∷ [Integer] → Ɐb ∷ [Integer] → Bool+enqueueAllCorrect :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "f" [a] -> Forall "b" [a] -> SBool))+enqueueAllCorrect = do++ eqC <- enqueueCorrect @a++ induct "enqueueAllCorrect"+ (\(Forall @"xs" xs) (Forall @"f" f) (Forall @"b" b) ->+ toList (enqueueAll (tuple (f, b)) xs) .== (f ++ reverse b) ++ xs) $+ \ih (x, xs) f b -> []+ |- toList (enqueueAll (tuple (f, b)) (x .: xs))+ =: toList (enqueueAll (tuple (f, x .: b)) xs)+ ?? ih `at` (Inst @"f" f, Inst @"b" (x .: b))+ =: (f ++ reverse (x .: b)) ++ xs+ ?? eqC+ =: (f ++ reverse b) ++ (x .: xs)+ =: qed++-- | @toList (enqueueAll emptyQ xs) == xs@+--+-- Starting from an empty queue, enqueuing a list of elements produces+-- a queue whose abstract contents is that same list. This demonstrates+-- the fundamental FIFO property: elements come out in the order they went in.+--+-- >>> runTP $ fifo @Integer+-- Lemma: enqueueAllCorrect Q.E.D.+-- Lemma: fifo+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: enqueueAll, sbv.reverse+-- [Proven] fifo :: Ɐxs ∷ [Integer] → Bool+fifo :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+fifo = do+ eaC <- recall (enqueueAllCorrect @a)++ calc "fifo"+ (\(Forall xs) -> toList (enqueueAll emptyQ xs) .== xs) $+ \xs -> [] |- toList (enqueueAll emptyQ xs)+ ?? eaC `at` (Inst @"xs" xs, Inst @"f" ([] :: SList a), Inst @"b" ([] :: SList a))+ =: reverse [] ++ xs+ =: xs+ =: qed++-- | Dequeue from a non-empty queue gives the head of the abstract list,+-- and the remaining queue represents the tail.+--+-- >>> runTP $ dequeueCorrect @Integer+-- Lemma: dequeueCorrect Q.E.D.+-- Functions proven terminating: sbv.reverse+-- [Proven] dequeueCorrect :: Ɐf ∷ [Integer] → Ɐb ∷ [Integer] → Bool+dequeueCorrect :: forall a. SymVal a => TP (Proof (Forall "f" [a] -> Forall "b" [a] -> SBool))+dequeueCorrect =+ lemma "dequeueCorrect"+ (\(Forall @"f" f) (Forall @"b" b) ->+ sNot (null (toList (tuple (f, b))))+ .=> let (v, q) = untuple (dequeue (tuple (f, b)))+ l = toList (tuple (f, b))+ in v .== head l .&& toList q .== tail l)+ []
+ Documentation/SBV/Examples/TP/QuickSort.hs view
@@ -0,0 +1,698 @@+-----------------------------------------------------------------------------+-- |+-- 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 FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# 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 Documentation.SBV.Examples.TP.Lists as TP++import qualified Documentation.SBV.Examples.TP.SortHelpers as SH++#ifdef DOCTEST+-- $setup+-- >>> :set -XTypeApplications+-- >>> import Data.SBV.TP+#endif++-- * Quick sort++-- | Quick-sort, using the first element as pivot.+quickSort :: forall a. (OrdSymbolic (SBV a), SymVal a) => SList a -> SList a+quickSort = smtFunctionWithMeasure "quickSort"+ ( length @a+ , [ measureLemma (partitionFstBound @a)+ , measureLemma (partitionSndBound @a)+ ]+ )+ $ \l -> [sCase| l of+ [] -> []+ x : xs -> case partition x xs of+ (lo, hi) -> 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 :: (OrdSymbolic (SBV a), SymVal a) => SBV a -> SList a -> STuple [a] [a]+partition = smtFunction "partition"+ $ \pivot xs -> [sCase| xs of+ [] -> tuple ([], [])+ a : as -> case partition pivot as of+ (lo, hi) | a .< pivot -> tuple (a .: lo, hi)+ | True -> tuple (lo, a .: hi)+ |]++-- | The first component of partition is no longer than the input.+--+-- >>> runTP $ partitionFstBound @Integer+-- Inductive lemma (strong): partitionNotLongerFst+-- 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 (simplify) Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: partition+-- [Proven] partitionNotLongerFst :: Ɐl ∷ [Integer] → Ɐpivot ∷ Integer → Bool+partitionFstBound :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "l" [a] -> Forall "pivot" a -> SBool))+partitionFstBound = 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+ =: [pCase| l of+ [] -> trivial+ whole@(a : as) ->+ let lo = fst (partition pivot as)+ in ite (a .< pivot)+ (length (a .: lo) .<= length whole)+ (length lo .<= length whole)+ ?? "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 component of partition is no longer than the input.+--+-- >>> runTP $ partitionSndBound @Integer+-- Inductive lemma (strong): partitionNotLongerSnd+-- 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 (simplify) Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: partition+-- [Proven] partitionNotLongerSnd :: Ɐl ∷ [Integer] → Ɐpivot ∷ Integer → Bool+partitionSndBound :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "l" [a] -> Forall "pivot" a -> SBool))+partitionSndBound = 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+ =: [pCase| l of+ [] -> trivial+ whole@(a : as) -> let hi = snd (partition pivot as)+ in ite (a .< pivot)+ (length hi .<= length whole)+ (length (a .: hi) .<= length whole)+ ?? "simplify"+ =: ite (a .< pivot)+ (length hi .<= 1 + length as)+ (length hi .<= length as)+ ?? ih `at` (Inst @"l" as, Inst @"pivot" pivot)+ =: sTrue+ =: qed+ |]++-- * 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 (unroll partition) Q.E.D.+-- Step: 2 (push fst down, simplify) Q.E.D.+-- Step: 3 (push llt down) Q.E.D.+-- Step: 4 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.+-- Lemma: partitionNotLongerFst Q.E.D.+-- Lemma: partitionNotLongerSnd 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 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.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: sortIsPermutation Q.E.D.+-- Inductive lemma: nonDecreasingMerge+-- 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.2.5 Q.E.D.+-- Step: 1.2.6 Q.E.D.+-- Step: 1.2.7 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Inductive lemma (strong): sortIsNonDecreasing+-- 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 (expand quickSort) Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness 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+-- Functions proven terminating: count, lge, llt, nonDecreasing, partition, quickSort+-- [Proven] quickSortIsCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. (Eq a, OrdSymbolic (SBV a), SymVal a) => IO (Proof (Forall "xs" [a] -> SBool))+correctness = runTP $ 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 -> [sCase| l of+ [] -> sTrue+ x : xs -> x .< pivot .&& llt pivot xs+ |]+ lge = smtFunction "lge"+ $ \pivot l -> [sCase| l of+ [] -> sTrue+ x : xs -> 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)))+ ?? "unroll partition"+ =: let (lo, hi) = untuple (partition pivot as)+ in llt pivot (fst (ite (a .< pivot)+ (tuple (a .: lo, hi))+ (tuple (lo, a .: hi))))+ ?? "push fst down, simplify"+ =: llt pivot (ite (a .< pivot) (a .: lo) lo)+ ?? "push llt down"+ =: ite (a .< pivot) (llt pivot (a .: lo)) (llt pivot lo)+ ?? 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 <- recall (partitionFstBound @a)++ -- The second element of partition does not increase in size+ partitionNotLongerSnd <- recall (partitionSndBound @a)++ --------------------------------------------------------------------------------------------+ -- 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)+ =: [pCase| xs of+ [] -> trivial+ whole@(a : as) ->+ let (lo, hi) = untuple (partition a as)+ in count e (quickSort whole)+ ?? "expand quickSort"+ =: count e (quickSort lo ++ [a] ++ quickSort hi)+ ?? "push count down"+ =: 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)+ =: [pCase| xs of+ [] -> trivial+ whole@(a : as) ->+ nonDecreasing (x .: whole ++ [pivot] ++ ys)+ =: nonDecreasing (x .: a .: (as ++ [pivot] ++ ys))+ =: x .<= a .&& nonDecreasing (a .: (as ++ [pivot] ++ ys))+ =: nonDecreasing (a .: (as ++ [pivot] ++ ys))+ =: nonDecreasing (whole ++ [pivot] ++ ys)+ =: nonDecreasing (xs ++ [pivot] ++ ys)+ -- This hint shouldn't be necessary, but it makes the proof go faster!+ ?? nonDecreasing xs+ ?? 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)+ =: [pCase| xs of+ [] -> trivial+ whole@(a : as) ->+ let (lo, hi) = untuple (partition a as)+ in nonDecreasing (quickSort whole)+ ?? "expand quickSort"+ =: 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 corollary 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.+ -- Note that we do avoid doing this during the+ -- dry-run of the proof to avoid duplicate output.+ --------------------------------------------------------------------------------------------+ unlessDryRun $ 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,81 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.RevAcc+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proves that the accumulating version of reverse is equivalent to the+-- standard definition.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# 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 accumulator.++-- | Accumulating reverse.+revAcc :: SymVal a => SList a -> SList a -> SList a+revAcc = smtFunction "revAcc"+ $ \acc xs -> [sCase| xs of+ [] -> acc+ a : as -> revAcc (a .: acc) as+ |]++-- | 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.+-- Functions proven terminating: revAcc, sbv.reverse+-- [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,176 @@+-----------------------------------------------------------------------------+-- |+-- 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 QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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 Documentation.SBV.Examples.TP.Lists as TP++#ifdef DOCTEST+-- $setup+-- >>> :set -XTypeApplications+-- >>> import Data.SBV.TP+#endif++-- * Reversing with no auxiliaries++-- | This definition of reverse uses no helper functions, other than the usual+-- head, tail, and cons to reverse a given list. Note that efficiency+-- is not our concern here, we call 'rev' itself three times in the body.+rev :: forall a. SymVal a => SList a -> SList a+rev = smtFunctionWithMeasure "rev"+ ( length @a+ , [measureLemma (revPreservesLen @a)]+ )+ $ \xs -> [sCase| xs of+ [] -> xs+ x : as -> case rev as of+ [] -> [x]+ hras : tas -> hras .: rev (x .: rev tas)+ |]++-- | Reversing preserves length. Needed as a measure helper for 'rev'.+--+-- >>> runTP $ revPreservesLen @Integer+-- Inductive lemma (strong): revPreservesLen+-- 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.+-- Functions proven terminating: rev+-- [Proven] revPreservesLen :: Ɐxs ∷ [Integer] → Bool+revPreservesLen :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+revPreservesLen = sInductWith cvc5 "revPreservesLen"+ (\(Forall xs) -> length (rev @a xs) .== length xs)+ (length, []) $+ \ih xs -> [] |- length (rev @a xs) .== length xs+ =: [pCase| xs of+ [] -> trivial+ [_] -> trivial+ whole@(a : as) -> length (head (rev as) .: rev (a .: rev (tail (rev as)))) .== length whole+ -- Simplify: length (h .: e) = 1 + length e+ =: (1 + length (rev (a .: rev (tail (rev as))))) .== (1 + length as)+ -- Now apply the IH instances in order: each precondition depends on previous conclusions+ ?? ih `at` Inst @"xs" as+ ?? ih `at` Inst @"xs" (tail (rev as))+ ?? ih `at` Inst @"xs" (a .: rev (tail (rev as)))+ =: sTrue+ =: qed+ |]++-- * Correctness proof++-- | Correctness the function 'rev'. We have:+--+-- >>> runTP $ correctness @Integer+-- Lemma: revLen Q.E.D.+-- Lemma: revApp Q.E.D.+-- Lemma: revSnoc Q.E.D.+-- Lemma: revRev Q.E.D.+-- Inductive lemma (strong): revCorrect+-- 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.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 (simplify head) Q.E.D.+-- Step: 1.3.7 Q.E.D.+-- Step: 1.3.8 (simplify tail) Q.E.D.+-- Step: 1.3.9 Q.E.D.+-- Step: 1.3.10 Q.E.D.+-- Step: 1.3.11 Q.E.D.+-- Step: 1.3.12 (substitute) Q.E.D.+-- Step: 1.3.13 Q.E.D.+-- Step: 1.3.14 Q.E.D.+-- Step: 1.3.15 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: rev, sbv.reverse+-- [Proven] revCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+correctness = do++ -- Quietly import a few helpers from "Data.SBV.TP.List"+ revLen <- recall $ TP.revLen @a+ revApp <- recall $ TP.revApp @a+ revSnoc <- recall $ TP.revSnoc @a+ revRev <- recall $ TP.revRev @a++ sInductWith cvc5 "revCorrect"+ (\(Forall xs) -> rev xs .== reverse xs)+ (length, []) $+ \ih xs -> [] |- rev xs+ =: [pCase| xs of+ [] -> trivial+ [_] -> trivial+ a : as -> head (rev as) .: rev (a .: rev (tail (rev as)))+ ?? ih `at` Inst @"xs" as+ =: head (reverse 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" (a .: 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/RunLength.hs view
@@ -0,0 +1,198 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.RunLength+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proving that run-length decoding inverts encoding. We define:+--+-- * @encode@: groups consecutive equal elements into (value, count) pairs+-- * @decode@: expands each pair back into a run of elements+--+-- and prove @decode (encode xs) == xs@ for all finite lists @xs@.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.RunLength where++import Prelude hiding (length, head, tail, null, reverse, (++), replicate, fst, snd)++import Data.SBV+import Data.SBV.List+import Data.SBV.Tuple+import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> :set -XOverloadedLists+-- >>> :set -XTypeApplications+-- >>> import Data.SBV+-- >>> import Data.SBV.Tuple+-- >>> import Data.SBV.TP+#endif++-- * Definitions++-- | Run-length decode: expand each (value, count) pair into a run of that element.+--+-- >>> decode (tuple (1,3) .: tuple (2,2) .: tuple (3,1) .: []) :: SList Integer+-- [1,1,1,2,2,3] :: [SInteger]+-- >>> decode ([] :: SList (Integer, Integer))+-- [] :: [SInteger]+decode :: forall a. SymVal a => SList (a, Integer) -> SList a+decode = smtFunction "decode"+ $ \ps -> [sCase| ps of+ [] -> []+ (e, c) : rest -> replicate c e ++ decode rest+ |]++-- | Prepend an element to a run-length encoded list. If the head run has the+-- same value, we increment its count; otherwise we create a new singleton run.+--+-- >>> encodeCons 1 (encode [1,1,2,2]) :: SList (Integer, Integer)+-- [(1,3),(2,2)] :: [(SInteger, SInteger)]+-- >>> encodeCons 5 (encode [1,1,2,2]) :: SList (Integer, Integer)+-- [(5,1),(1,2),(2,2)] :: [(SInteger, SInteger)]+encodeCons :: forall a. SymVal a => SBV a -> SList (a, Integer) -> SList (a, Integer)+encodeCons = smtFunction "encodeCons"+ $ \x ps -> [sCase| ps of+ [] -> [tuple (x, 1)]+ (e, c) : rest | x .== e -> tuple (x, c + 1) .: rest+ | True -> tuple (x, 1) .: ps+ |]++-- | Run-length encode: fold from the right, using 'encodeCons' to merge+-- each element into the growing encoding.+--+-- >>> encode [1,1,1,2,2,3] :: SList (Integer, Integer)+-- [(1,3),(2,2),(3,1)] :: [(SInteger, SInteger)]+-- >>> encode ([] :: SList Integer)+-- [] :: [(SInteger, SInteger)]+-- >>> encode [4] :: SList (Integer, Integer)+-- [(4,1)] :: [(SInteger, SInteger)]+encode :: forall a. SymVal a => SList a -> SList (a, Integer)+encode = smtFunction "encode"+ $ \xs -> [sCase| xs of+ [] -> []+ x : rest -> encodeCons x (encode rest)+ |]++-- * Correctness++-- | @decode (encode xs) == xs@+--+-- The proof proceeds by induction on @xs@. The key helper shows that+-- decoding after 'encodeCons' is the same as consing the element,+-- provided the head count in the encoded list is positive (which+-- 'encode' always guarantees).+--+-- >>> runTPWith cvc5 $ correctness @Integer+-- Lemma: decodeEncodeCons+-- Step: 1 (3 way case split)+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.1.3 Q.E.D.+-- Step: 1.1.4 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.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Inductive lemma: encodeHeadPos+-- Step: Base Q.E.D.+-- Step: 1 (3 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.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Inductive lemma (strong): rleCorrect+-- 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.+-- Functions proven terminating: decode, encode, sbv.replicate+-- [Proven] rleCorrect :: Ɐxs ∷ [Integer] → Bool+correctness :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))+correctness = do++ -- Key helper: encodeCons followed by decode is the same as consing.+ -- The condition ensures the head count is positive so that+ -- replicate (n+1) unfolds correctly.+ helper <- calc "decodeEncodeCons"+ (\(Forall @"x" (x :: SBV a)) (Forall @"ps" ps) ->+ (null ps .|| snd (head ps) .>= 1)+ .=> decode (encodeCons x ps) .== x .: decode ps) $+ \x ps -> [null ps .|| snd (head ps) .>= 1]+ |- decode (encodeCons x ps)+ =: [pCase| ps of+ [] -> decode [tuple (x, 1)]+ =: replicate 1 x ++ decode []+ =: [x] ++ decode []+ =: x .: decode []+ =: qed+ ((e, c) : ecs) | x .== e -> decode (tuple (x, c + 1) .: ecs)+ =: replicate (c + 1) x ++ decode ecs+ =: x .: replicate c x ++ decode ecs+ =: x .: decode (tuple (e, c) .: ecs)+ =: qed+ | True -> decode (tuple (x, 1) .: ps)+ =: x .: decode ps+ =: qed+ |]++ -- encode always produces a list whose head (if any) has count >= 1+ -- (This is needed as a precondition for helper above.)+ encPos <- induct "encodeHeadPos"+ (\(Forall @"xs" (xs :: SList a)) ->+ null (encode xs) .|| snd (head (encode xs)) .>= 1) $+ \ih (x, xs) -> []+ |- (null (encodeCons x (encode xs)) .|| snd (head (encodeCons x (encode xs))) .>= 1)+ =: cases [ null (encode xs) ==> trivial+ , sNot (null (encode xs)) .&& x .== fst (head (encode xs))+ ==> snd (head (encodeCons x (encode xs))) .>= 1+ =: snd (head (encode xs)) + 1 .>= 1+ ?? ih+ =: sTrue+ =: qed+ , sNot (null (encode xs)) .&& x ./= fst (head (encode xs))+ ==> trivial+ ]++ -- Main theorem: decode . encode == id+ sInduct "rleCorrect"+ (\(Forall xs) -> decode @a (encode xs) .== xs)+ (length @a, []) $+ \ih xs -> [] |- decode (encode xs)+ =: [pCase| xs of+ [] -> trivial+ whole@(x : ys) -> decode (encode whole)+ =: decode (encodeCons x (encode ys))+ ?? helper `at` (Inst @"x" x, Inst @"ps" (encode ys))+ ?? encPos `at` Inst @"xs" ys+ =: x .: decode (encode ys)+ ?? ih `at` Inst @"xs" ys+ =: x .: ys+ =: qed+ |]
+ Documentation/SBV/Examples/TP/ShefferStroke.hs view
@@ -0,0 +1,689 @@+-----------------------------------------------------------------------------+-- |+-- 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 FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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+mkSymbolic [''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 = runTP $ 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,195 @@+-----------------------------------------------------------------------------+-- |+-- 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 FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.SortHelpers where++import Prelude hiding (null, length, tail, elem, head, (++), take, drop)++import Data.SBV+import Data.SBV.List+import Data.SBV.TP+import Documentation.SBV.Examples.TP.Lists++#ifdef DOCTEST+-- $setup+-- >>> :set -XTypeApplications+-- >>> import Data.SBV.TP+#endif++-- | A predicate testing whether a given list is non-decreasing.+nonDecreasing :: (OrdSymbolic (SBV a), SymVal a) => SList a -> SBool+nonDecreasing = smtFunction "nonDecreasing"+ $ \l -> [sCase| l of+ [] -> sTrue+ [_] -> sTrue+ x : rest@(y : _) -> x .<= y .&& nonDecreasing rest+ |]++-- | 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.+-- Functions proven terminating: nonDecreasing+-- [Proven] nonDecrTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+nonDecrTail :: forall a. (OrdSymbolic (SBV 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.+-- Functions proven terminating: nonDecreasing+-- [Proven] nonDecrInsert :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool+nonDecrIns :: forall a. (OrdSymbolic (SBV 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.+-- Functions proven terminating: count+-- [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.+-- Functions proven terminating: count+-- [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.+-- Functions proven terminating: count+-- [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.+-- Functions proven terminating: count+-- [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,111 @@+-----------------------------------------------------------------------------+-- |+-- 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 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 has to 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,336 @@+-----------------------------------------------------------------------------+-- |+-- 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 QuasiQuotes #-}+{-# 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.+-- Functions proven terminating: seq+-- [Proven] oddSequence1 :: Ɐn ∷ Integer → Bool+oddSequence1 :: IO (Proof (Forall "n" Integer -> SBool))+oddSequence1 = runTP $ do+ let s :: SInteger -> SInteger+ s = smtFunction "seq"+ $ \n -> [sCase| n of+ _ | n .<= 0 -> 1+ _ | 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.+-- Functions proven terminating: seq+-- [Proven] oddSequence2 :: Ɐn ∷ Integer → Bool+oddSequence2 :: IO (Proof (Forall "n" Integer -> SBool))+oddSequence2 = runTP $ do+ let s :: SInteger -> SInteger+ s = smtFunction "seq"+ $ \n -> [sCase| n of+ _ | n .<= 0 -> 1+ _ | 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 -> [sCase| xs of+ [] -> 0+ _ : as -> 1 + len as+ |]++ -- 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 -> [sCase| xs of+ [] -> 123+ _ : as -> 1 + len as+ |]++ _ <- 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 -> [sCase| x of+ _ | 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 (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.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 (simplify) Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: halvingSum, sbv.foldr+-- [Proven] sumHalves :: Ɐxs ∷ [Integer] → Bool+sumHalves :: IO (Proof (Forall "xs" [Integer] -> SBool))+sumHalves = runTP $ do++ let halvingSum :: SList Integer -> SInteger+ halvingSum = smtFunction "halvingSum"+ $ \xs -> [sCase| xs of+ [] -> sum 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+ =: [pCase| xs of+ [] -> qed+ [_] -> qed+ whole@(_ : _ : _) ->+ halvingSum whole+ =: let (f, s) = splitAt (length whole `sDiv` 2) whole+ 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 whole+ =: qed+ |]
+ Documentation/SBV/Examples/TP/SumReverse.hs view
@@ -0,0 +1,85 @@+-----------------------------------------------------------------------------+-- |+-- 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 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 (associativity) Q.E.D.+-- Step: 5 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 (commutativity) Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: sbv.foldr, sbv.reverse+-- [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)+ ?? "associativity"+ =: (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+ ?? "commutativity"+ =: x + sum xs+ =: sum (x .: xs)+ =: qed
+ Documentation/SBV/Examples/TP/Tao.hs view
@@ -0,0 +1,58 @@+-----------------------------------------------------------------------------+-- |+-- 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 ScopedTypeVariables #-}+{-# 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+mkSymbolic [''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/TP/TautologyChecker.hs view
@@ -0,0 +1,1124 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.TautologyChecker+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- A verified tautology checker (unordered BDD-style SAT solver) in SBV.+-- This is a port of the Imandra proof by Grant Passmore, originally+-- inspired by Boyer-Moore '79.+-- See <https://raw.githubusercontent.com/imandra-ai/imandrax-examples/refs/heads/main/src/tautology.iml>+--+-- We define a simple formula type with If-then-else, normalize formulas into a canonical form, and prove+-- both soundness and completeness of the tautology checker. The canonical form is essentially an+-- unordered-BDD, making it easy to evaluate it.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.TautologyChecker where++import Prelude hiding (null, tail, head, (++))++import Data.SBV+import Data.SBV.List+import Data.SBV.TP+import Data.SBV.Tuple++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+-- >>> import Data.SBV.TP+#endif++-- * Formula representation++-- | A propositional formula with variables and if-then-else.+data Formula = FTrue+ | FFalse+ | Var { fVar :: Integer }+ | If { ifCond :: Formula+ , ifThen :: Formula+ , ifElse :: Formula+ }++-- | Make formulas symbolic.+mkSymbolic [''Formula]++-- * Measuring formulas++-- | Depth of nested If constructors in the condition position.+ifDepth :: SFormula -> SInteger+ifDepth = smtFunction "ifDepth"+ $ \f -> [sCase| f of+ If c _ _ -> 1 + ifDepth c+ _ -> 0+ |]++-- | \(\mathit{ifDepth}(f) \geq 0\)+--+-- >>> runTP ifDepthNonNeg+-- Lemma: ifDepthNonNeg Q.E.D.+-- Functions proven terminating: ifDepth+-- [Proven] ifDepthNonNeg :: Ɐf ∷ Formula → Bool+ifDepthNonNeg :: TP (Proof (Forall "f" Formula -> SBool))+ifDepthNonNeg = inductiveLemma "ifDepthNonNeg" (\(Forall f) -> ifDepth f .>= 0) []++-- | Complexity of a formula (for termination measure).+ifComplexity :: SFormula -> SInteger+ifComplexity = smtFunction "ifComplexity"+ $ \f -> [sCase| f of+ If c l r -> ifComplexity c * (ifComplexity l + ifComplexity r)+ _ -> 1+ |]++-- | \(\mathit{ifComplexity}(f) > 0\)+--+-- >>> runTP ifComplexityPos+-- Lemma: ifComplexityPos Q.E.D.+-- Functions proven terminating: ifComplexity+-- [Proven] ifComplexityPos :: Ɐf ∷ Formula → Bool+ifComplexityPos :: TP (Proof (Forall "f" Formula -> SBool))+ifComplexityPos = inductiveLemma "ifComplexityPos" (\(Forall f) -> ifComplexity f .> 0) []++-- | The branches of an If have smaller complexity than the whole.+--+-- \(\mathit{ifComplexity}(c) < \mathit{ifComplexity}(\mathit{If}(c, l, r)) \land \mathit{ifComplexity}(l) < \mathit{ifComplexity}(\mathit{If}(c, l, r)) \land \mathit{ifComplexity}(r) < \mathit{ifComplexity}(\mathit{If}(c, l, r))\)+--+-- >>> runTP ifComplexitySmaller+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: ifComplexity+-- [Proven] ifComplexitySmaller :: Ɐc ∷ Formula → Ɐl ∷ Formula → Ɐr ∷ Formula → Bool+ifComplexitySmaller :: TP (Proof (Forall "c" Formula -> Forall "l" Formula -> Forall "r" Formula -> SBool))+ifComplexitySmaller = do+ icp <- recall ifComplexityPos++ calc "ifComplexitySmaller"+ (\(Forall c) (Forall l) (Forall r) ->+ let ic = ifComplexity (sIf c l r)+ in ifComplexity c .< ic .&& ifComplexity l .< ic .&& ifComplexity r .< ic) $+ \c l r ->+ let ic = ifComplexity (sIf c l r)+ cc = ifComplexity c+ cl = ifComplexity l+ cr = ifComplexity r+ in [] |- cc .< ic .&& cl .< ic .&& cr .< ic+ ?? icp `at` Inst @"f" c+ ?? icp `at` Inst @"f" l+ ?? icp `at` Inst @"f" r+ =: sTrue+ =: qed++-- * Normalization++-- | Check if a formula is in normal form (no nested If in condition position).+isNormal :: SFormula -> SBool+isNormal = smtFunction "isNormal"+ $ \f -> [sCase| f of+ If c p q -> sNot (isIf c) .&& isNormal p .&& isNormal q+ _ -> sTrue+ |]++-- | Normalize a formula by eliminating nested Ifs in condition position.+--+-- The key transformation is:+--+-- @+-- If (If (p, q, r), left, right)+-- =+-- If (p, If (q, left, right), If (r, left, right))+-- @+--+-- Note that this transformation increases the size of the formula, but reduces its complexity.+normalize :: SFormula -> SFormula+normalize = smtFunctionWithMeasure "normalize"+ ( \f -> tuple (ifComplexity f, ifDepth f)+ , [ measureLemma ifDepthNonNeg+ , measureLemma ifComplexityPos+ , measureLemmaWith z3 ifComplexitySmaller+ , measureLemmaWith z3 normalizePreservesComplexity+ ]+ )+ $ \f -> [sCase| f of+ If (If p q r) left right -> normalize (sIf p (sIf q left right) (sIf r left right))+ If c left right -> sIf c (normalize left) (normalize right)+ _ -> f+ |]++-- | The normalization transformation preserves complexity.+--+-- \(\mathit{ifComplexity}(\mathit{If}(p, \mathit{If}(q, l, r), \mathit{If}(s, l, r))) = \mathit{ifComplexity}(\mathit{If}(\mathit{If}(p, q, s), l, r))\)+--+-- >>> runTP normalizePreservesComplexity+-- Lemma: helper Q.E.D.+-- Lemma: normalizePreservesComplexity+-- 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.+-- Functions proven terminating: ifComplexity+-- [Proven] normalizePreservesComplexity :: Ɐp ∷ Formula → Ɐq ∷ Formula → Ɐs ∷ Formula → Ɐl ∷ Formula → Ɐr ∷ Formula → Bool+normalizePreservesComplexity :: TP (Proof (Forall "p" Formula -> Forall "q" Formula -> Forall "s" Formula -> Forall "l" Formula -> Forall "r" Formula -> SBool))+normalizePreservesComplexity = do++ -- The following is a trivial lemma, but without it the solver don't seem to be able to make progress since+ -- it needs to instantiate it properly. So we help the solver out explicitly.+ helper <- lemma "helper"+ (\(Forall @"a" a) (Forall @"b" b) (Forall @"c" c) -> a .== b .=> a * c .== b * (c :: SInteger))+ []++ calc "normalizePreservesComplexity"+ (\(Forall p) (Forall q) (Forall s) (Forall l) (Forall r) ->+ ifComplexity (sIf p (sIf q l r) (sIf s l r)) .== ifComplexity (sIf (sIf p q s) l r)) $+ \p q s l r ->+ let cp = ifComplexity p+ cq = ifComplexity q+ cs = ifComplexity s+ cl = ifComplexity l+ cr = ifComplexity r+ in [] |- ifComplexity (sIf p (sIf q l r) (sIf s l r))+ =: cp * (ifComplexity (sIf q l r) + ifComplexity (sIf s l r))+ =: cp * (cq * (cl + cr) + cs * (cl + cr))+ =: cp * ((cq + cs) * (cl + cr))+ =: (cp * (cq + cs)) * (cl + cr)+ ?? helper `at` (Inst @"a" (ifComplexity (sIf p q s)), Inst @"b" (cp * (cq + cs)), Inst @"c" (cl + cr))+ =: ifComplexity (sIf p q s) * (cl + cr)+ =: ifComplexity (sIf p q s) * (ifComplexity l + ifComplexity r)+ =: ifComplexity (sIf (sIf p q s) l r)+ =: qed++-- * Variable bindings++-- | A binding associates a variable ID with a boolean value.+data Binding = Binding { varId :: Integer+ , value :: Bool+ }++-- | Make bindings symbolic.+mkSymbolic [''Binding]++-- | Look up a variable in the binding list. If it's not in the list, then it's false.+lookUp :: SInteger -> SList Binding -> SBool+lookUp = smtFunction "lookUp"+ $ \vid bs -> [sCase| bs of+ [] -> sFalse+ Binding bId bVal : rest | vid .== bId -> bVal+ | True -> lookUp vid rest+ |]++-- | Check if a variable is assigned in the bindings.+isAssigned :: SInteger -> SList Binding -> SBool+isAssigned = smtFunction "isAssigned"+ $ \vid bs -> [sCase| bs of+ [] -> sFalse+ Binding bId _ : rst | bId .== vid -> sTrue+ | True -> isAssigned vid rst+ |]++-- | Add a binding assuming the variable is true.+assumeTrue :: SInteger -> SList Binding -> SList Binding+assumeTrue vid bs = sBinding vid sTrue .: bs++-- | Add a binding assuming the variable is false.+assumeFalse :: SInteger -> SList Binding -> SList Binding+assumeFalse vid bs = sBinding vid sFalse .: bs++-- | Adding a binding preserves existing assignments.+--+-- >>> runTP isAssignedExtends+-- Lemma: isAssignedExtends Q.E.D.+-- Functions proven terminating: isAssigned+-- [Proven] isAssignedExtends :: Ɐi ∷ Integer → Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool+isAssignedExtends :: TP (Proof (Forall "i" Integer -> Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool))+isAssignedExtends = lemma "isAssignedExtends"+ (\(Forall i) (Forall n) (Forall v) (Forall bs) -> isAssigned i bs .=> isAssigned i (sBinding n v .: bs))+ []++-- | Looking up a variable in extended bindings: if already assigned, value is preserved.+--+-- >>> runTP lookUpExtends+-- Lemma: lookUpExtends Q.E.D.+-- Functions proven terminating: isAssigned, lookUp+-- [Proven] lookUpExtends :: Ɐi ∷ Integer → Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool+lookUpExtends :: TP (Proof (Forall "i" Integer -> Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool))+lookUpExtends = lemma "lookUpExtends"+ (\(Forall i) (Forall n) (Forall v) (Forall bs) ->+ isAssigned i bs .&& i ./= n .=> lookUp i (sBinding n v .: bs) .== lookUp i bs)+ []++-- | Looking up a variable that was just added returns the added value.+--+-- >>> runTP lookUpSame+-- Lemma: lookUpSame Q.E.D.+-- Functions proven terminating: lookUp+-- [Proven] lookUpSame :: Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool+lookUpSame :: TP (Proof (Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool))+lookUpSame = lemma "lookUpSame" (\(Forall n) (Forall v) (Forall bs) -> lookUp n (sBinding n v .: bs) .== v) []++-- | Adding a binding for a variable makes it assigned.+--+-- >>> runTP isAssignedSame+-- Lemma: isAssignedSame Q.E.D.+-- Functions proven terminating: isAssigned+-- [Proven] isAssignedSame :: Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool+isAssignedSame :: TP (Proof (Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool))+isAssignedSame = lemma "isAssignedSame" (\(Forall n) (Forall v) (Forall bs) -> isAssigned n (sBinding n v .: bs)) []++-- * Formula evaluation++-- | Evaluate a formula under a binding environment.+eval :: SFormula -> SList Binding -> SBool+eval = smtFunction "eval"+ $ \f bs -> [sCase| f of+ Var n -> lookUp n bs+ If c l r | eval c bs -> eval l bs+ | True -> eval r bs+ FTrue -> sTrue+ FFalse -> sFalse+ |]++-- * Tautology checking++-- | Check if a normalized formula is a tautology.+isTautology' :: SFormula -> SList Binding -> SBool+isTautology' = smtFunction "isTautology'" $ \f bs ->+ [sCase| f of+ -- Trivial cases+ FTrue -> sTrue+ FFalse -> sFalse++ -- Variable+ Var _ -> eval f bs++ -- Constant branches+ If FTrue l _ -> isTautology' l bs+ If FFalse _ r -> isTautology' r bs++ -- Branching on a variable+ If (Var n) l r+ -- We have already this variable, so evaluate based on the current choice+ | isAssigned n bs, eval (sVar n) bs -> isTautology' l bs+ | isAssigned n bs -> isTautology' r bs++ -- We haven't yet assigned this variable. Both branches should work out:+ | True -> isTautology' l (assumeTrue n bs)+ .&& isTautology' r (assumeFalse n bs)++ If _ _ _ -> sFalse -- Contradicts isNormal assumption+ |]++-- | Main tautology checker.+isTautology :: SFormula -> SBool+isTautology f = isTautology' (normalize f) []++-- * Soundness++-- | \(\mathit{lookUp}(x, a \mathbin{+\!\!+} b) = \mathit{if } \mathit{isAssigned}(x, a) \mathit{ then } \mathit{lookUp}(x, a) \mathit{ else } \mathit{lookUp}(x, b)\)+--+-- If we look up a variable in a concatenated binding list, we first check+-- the first list, and only if not found there, check the second.+--+-- >>> runTP lookUpStable+-- Inductive lemma: lookUpStable+-- 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.+-- Functions proven terminating: isAssigned, lookUp+-- [Proven] lookUpStable :: Ɐa ∷ [Binding] → Ɐx ∷ Integer → Ɐb ∷ [Binding] → Bool+lookUpStable :: TP (Proof (Forall "a" [Binding] -> Forall "x" Integer -> Forall "b" [Binding] -> SBool))+lookUpStable =+ induct "lookUpStable"+ (\(Forall a) (Forall x) (Forall b) -> lookUp x (a ++ b) .== ite (isAssigned x a) (lookUp x a) (lookUp x b)) $+ \ih (binding, a) x b ->+ let vid = svarId binding+ val = svalue binding+ in [] |- lookUp x ((binding .: a) ++ b)+ =: cases [ vid .== x ==> ite (isAssigned x (binding .: a)) (lookUp x (binding .: a)) (lookUp x b)+ =: val+ =: qed+ , vid ./= x ==> lookUp x (a ++ b)+ ?? ih+ =: ite (isAssigned x a) (lookUp x a) (lookUp x b)+ =: qed+ ]++-- | \(\mathit{lookUp}(x, a) \implies \mathit{isAssigned}(x, a)\)+--+-- >>> runTP trueIsAssigned+-- Inductive lemma: trueIsAssigned+-- 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.+-- Functions proven terminating: isAssigned, lookUp+-- [Proven] trueIsAssigned :: Ɐa ∷ [Binding] → Ɐx ∷ Integer → Bool+trueIsAssigned :: TP (Proof (Forall "a" [Binding] -> Forall "x" Integer -> SBool))+trueIsAssigned =+ induct "trueIsAssigned"+ (\(Forall a) (Forall x) -> lookUp x a .=> isAssigned x a) $+ \ih (binding, a) x ->+ let vid = [sCase| binding of Binding v _ -> v|]+ in [lookUp x (binding .: a)]+ |- isAssigned x (binding .: a)+ =: cases [ vid .== x ==> trivial+ , vid ./= x ==> isAssigned x a+ ?? ih+ =: sTrue+ =: qed+ ]++-- | \(\mathit{value} = \mathit{lookUp}(x, bs) \implies \mathit{eval}(f, \{x \mapsto \mathit{value}\} :: bs) = \mathit{eval}(f, bs)\)+--+-- If we add a redundant binding (same id and value) to the front, evaluation doesn't change.+--+-- >>> runTPWith cvc5 evalStable+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Inductive lemma (strong): evalStable+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 way 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.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: eval, ifComplexity, lookUp+-- [Proven] evalStable :: Ɐf ∷ Formula → Ɐx ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool+evalStable :: TP (Proof (Forall "f" Formula -> Forall "x" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool))+evalStable = do+ icp <- recall ifComplexityPos+ ibs <- recall ifComplexitySmaller++ sInduct "evalStable"+ (\(Forall f) (Forall x) (Forall v) (Forall bs) -> v .== lookUp x bs .=> eval f (sBinding x v .: bs) .== eval f bs)+ (\f _ _ _ -> ifComplexity f, [proofOf icp]) $+ \ih f x v bs ->+ let b = sBinding x v+ in [v .== lookUp x bs]+ |- cases [ isFTrue f ==> trivial+ , isFFalse f ==> trivial+ , isVar f ==> trivial+ , isIf f ==>+ let c = sifCond f+ l = sifThen f+ r = sifElse f+ in eval f (b .: bs)+ =: eval (sIf c l r) (b .: bs)+ =: ite (eval c (b .: bs)) (eval l (b .: bs)) (eval r (b .: bs))+ ?? ih `at` (Inst @"f" c, Inst @"x" x, Inst @"v" v, Inst @"bs" bs)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ =: ite (eval c bs) (eval l (b .: bs)) (eval r (b .: bs))+ ?? ih `at` (Inst @"f" l, Inst @"x" x, Inst @"v" v, Inst @"bs" bs)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ =: ite (eval c bs) (eval l bs) (eval r (b .: bs))+ ?? ih `at` (Inst @"f" r, Inst @"x" x, Inst @"v" v, Inst @"bs" bs)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ =: ite (eval c bs) (eval l bs) (eval r bs)+ =: eval (sIf c l r) bs+ =: qed+ ]++-- | Key soundness lemma: If a normalized formula is a tautology under bindings @b@,+-- then it evaluates to true under @b ++ a@ for any @a@.+--+-- >>> runTPWith cvc5 tautologyImpliesEval+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Lemma: lookUpStable Q.E.D.+-- Lemma: trueIsAssigned Q.E.D.+-- Lemma: evalStable Q.E.D.+-- Inductive lemma (strong): tautologyImpliesEval+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 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.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.4 (4 way case split)+-- Step: 1.4.1.1 Q.E.D.+-- Step: 1.4.1.2 Q.E.D.+-- Step: 1.4.2.1 Q.E.D.+-- Step: 1.4.2.2 Q.E.D.+-- Step: 1.4.2.3 Q.E.D.+-- Step: 1.4.3 (2 way case split)+-- Step: 1.4.3.1.1 Q.E.D.+-- Step: 1.4.3.1.2 Q.E.D.+-- Step: 1.4.3.1.3 Q.E.D.+-- Step: 1.4.3.1.4 Q.E.D.+-- Step: 1.4.3.2 (2 way case split)+-- Step: 1.4.3.2.1.1 Q.E.D.+-- Step: 1.4.3.2.1.2 Q.E.D.+-- Step: 1.4.3.2.1.3 Q.E.D.+-- Step: 1.4.3.2.1.4 Q.E.D.+-- Step: 1.4.3.2.1.5 Q.E.D.+-- Step: 1.4.3.2.1.6 Q.E.D.+-- Step: 1.4.3.2.1.7 Q.E.D.+-- Step: 1.4.3.2.1.8 Q.E.D.+-- Step: 1.4.3.2.2.1 Q.E.D.+-- Step: 1.4.3.2.2.2 Q.E.D.+-- Step: 1.4.3.2.2.3 Q.E.D.+-- Step: 1.4.3.2.2.4 Q.E.D.+-- Step: 1.4.3.2.2.5 Q.E.D.+-- Step: 1.4.3.2.2.6 Q.E.D.+-- Step: 1.4.3.2.2.7 Q.E.D.+-- Step: 1.4.3.2.2.8 Q.E.D.+-- Step: 1.4.3.2.Completeness Q.E.D.+-- Step: 1.4.3.Completeness Q.E.D.+-- Step: 1.4.4 Q.E.D.+-- Step: 1.4.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: eval, ifComplexity, isAssigned, isNormal, isTautology', lookUp+-- [Proven] tautologyImpliesEval :: Ɐf ∷ Formula → Ɐa ∷ [Binding] → Ɐb ∷ [Binding] → Bool+tautologyImpliesEval :: TP (Proof (Forall "f" Formula -> Forall "a" [Binding] -> Forall "b" [Binding] -> SBool))+tautologyImpliesEval = do++ icp <- recall ifComplexityPos+ ibs <- recall ifComplexitySmaller+ lus <- recall lookUpStable+ tia <- recall trueIsAssigned+ evs <- recall evalStable++ sInduct "tautologyImpliesEval"+ (\(Forall f) (Forall a) (Forall b) -> isNormal f .&& isTautology' f b .=> eval f (b ++ a))+ (\f _ _ -> ifComplexity f, [proofOf icp]) $+ \ih f a b ->+ [isNormal f, isTautology' f b]+ |- cases [ isFTrue f ==> trivial+ , isFFalse f ==> trivial+ , isVar f ==> let n = sfVar f+ in eval f (b ++ a)+ =: eval (sVar n) (b ++ a)+ =: lookUp n (b ++ a)+ ?? lus `at` (Inst @"a" b, Inst @"x" n, Inst @"b" a)+ =: ite (isAssigned n b) (lookUp n b) (lookUp n a)+ ?? tia `at` (Inst @"a" b, Inst @"x" n)+ =: lookUp n b+ =: sTrue+ =: qed+ , isIf f ==>+ let c = sifCond f+ l = sifThen f+ r = sifElse f+ in cases [ isFTrue c ==> eval (sIf c l r) (b ++ a)+ =: ite (eval c (b ++ a)) (eval l (b ++ a)) (eval r (b ++ a))+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" l, Inst @"a" a, Inst @"b" b)+ =: sTrue+ =: qed+ , isFFalse c ==> eval (sIf c l r) (b ++ a)+ =: ite (eval c (b ++ a)) (eval l (b ++ a)) (eval r (b ++ a))+ =: eval r (b ++ a)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" r, Inst @"a" a, Inst @"b" b)+ =: sTrue+ =: qed+ , isVar c ==> let n = sfVar c+ in cases [ isAssigned n b ==>+ eval (sIf (sVar n) l r) (b ++ a)+ =: ite (eval (sVar n) (b ++ a)) (eval l (b ++ a)) (eval r (b ++ a))+ =: ite (lookUp n (b ++ a)) (eval l (b ++ a)) (eval r (b ++ a))+ ?? lus `at` (Inst @"a" b, Inst @"x" n, Inst @"b" a)+ =: ite (lookUp n b) (eval l (b ++ a)) (eval r (b ++ a))+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" l, Inst @"a" a, Inst @"b" b)+ ?? ih `at` (Inst @"f" r, Inst @"a" a, Inst @"b" b)+ =: sTrue+ =: qed+ , sNot (isAssigned n b) ==>+ cases [ lookUp n a ==>+ eval (sIf (sVar n) l r) (b ++ a)+ =: ite (eval (sVar n) (b ++ a)) (eval l (b ++ a)) (eval r (b ++ a))+ =: ite (lookUp n (b ++ a)) (eval l (b ++ a)) (eval r (b ++ a))+ ?? lus `at` (Inst @"a" b, Inst @"x" n, Inst @"b" a)+ =: ite (lookUp n a) (eval l (b ++ a)) (eval r (b ++ a))+ =: eval l (b ++ a)+ ?? evs `at` (Inst @"f" l, Inst @"x" n, Inst @"v" (lookUp n a), Inst @"bs" (b ++ a))+ ?? lus `at` (Inst @"a" b, Inst @"x" n, Inst @"b" a)+ =: eval l (sBinding n (lookUp n a) .: (b ++ a))+ =: eval l (sBinding n sTrue .: (b ++ a))+ =: eval l (assumeTrue n b ++ a)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" l, Inst @"a" a, Inst @"b" (assumeTrue n b))+ =: sTrue+ =: qed+ , sNot (lookUp n a) ==>+ eval (sIf (sVar n) l r) (b ++ a)+ =: ite (eval (sVar n) (b ++ a)) (eval l (b ++ a)) (eval r (b ++ a))+ =: ite (lookUp n (b ++ a)) (eval l (b ++ a)) (eval r (b ++ a))+ ?? lus `at` (Inst @"a" b, Inst @"x" n, Inst @"b" a)+ =: ite (lookUp n a) (eval l (b ++ a)) (eval r (b ++ a))+ =: eval r (b ++ a)+ ?? evs `at` (Inst @"f" r, Inst @"x" n, Inst @"v" (lookUp n a), Inst @"bs" (b ++ a))+ ?? lus `at` (Inst @"a" b, Inst @"x" n, Inst @"b" a)+ =: eval r (sBinding n (lookUp n a) .: (b ++ a))+ =: eval r (sBinding n sFalse .: (b ++ a))+ =: eval r (assumeFalse n b ++ a)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" r, Inst @"a" a, Inst @"b" (assumeFalse n b))+ =: sTrue+ =: qed+ ]+ ]+ , isIf c ==> trivial -- Contradicts isNormal+ ]+ ]++-- * Normalization correctness++-- | \(\mathit{isNormal}(\mathit{normalize}(f))\)+--+-- Normalization produces normalized formulas.+--+-- >>> runTP normalizeCorrect+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Lemma: normalizePreservesComplexity Q.E.D.+-- Lemma: ifDepthNonNeg Q.E.D.+-- Inductive lemma (strong): normalizeCorrect+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4 (2 way case split)+-- Step: 1.4.1.1 Q.E.D.+-- Step: 1.4.1.2 Q.E.D.+-- Step: 1.4.2.1 Q.E.D.+-- Step: 1.4.2.2 Q.E.D.+-- Step: 1.4.2.3 Q.E.D.+-- Step: 1.4.2.4 Q.E.D.+-- Step: 1.4.2.5 Q.E.D.+-- Step: 1.4.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: ifComplexity, ifDepth, isNormal, normalize+-- [Proven] normalizeCorrect :: Ɐf ∷ Formula → Bool+normalizeCorrect :: TP (Proof (Forall "f" Formula -> SBool))+normalizeCorrect = do+ icp <- recall ifComplexityPos+ ibs <- recall ifComplexitySmaller+ npc <- recall normalizePreservesComplexity+ idn <- recall ifDepthNonNeg++ sInductWith cvc5 "normalizeCorrect"+ (\(Forall f) -> isNormal (normalize f))+ (\f -> tuple (ifComplexity f, ifDepth f), [proofOf icp, proofOf idn]) $+ \ih f -> []+ |- isNormal (normalize f)+ =: cases [ isFTrue f ==> trivial+ , isFFalse f ==> trivial+ , isVar f ==> trivial+ , isIf f ==> let c = sifCond f+ l = sifThen f+ r = sifElse f+ in cases [ isIf c ==>+ let p = sifCond c+ q = sifThen c+ rc = sifElse c+ transformed = sIf p (sIf q l r) (sIf rc l r)+ in isNormal (normalize transformed)+ ?? npc `at` (Inst @"p" p, Inst @"q" q, Inst @"s" rc, Inst @"l" l, Inst @"r" r)+ ?? ih `at` Inst @"f" transformed+ =: sTrue+ =: qed+ , sNot (isIf c) ==>+ isNormal (sIf c (normalize l) (normalize r))+ =: sNot (isIf c) .&& isNormal (normalize l) .&& isNormal (normalize r)+ =: isNormal (normalize l) .&& isNormal (normalize r)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` Inst @"f" l+ =: isNormal (normalize r)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` Inst @"f" r+ =: sTrue+ =: qed+ ]+ ]++-- | \(\mathit{isNormal}(f) \implies \mathit{normalize}(f) = f\)+--+-- Normalizing a normalized formula is the identity.+--+-- >>> runTP normalizeSame+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Inductive lemma (strong): normalizeSame+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 way 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.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: ifComplexity, isNormal, normalize+-- [Proven] normalizeSame :: Ɐf ∷ Formula → Bool+normalizeSame :: TP (Proof (Forall "f" Formula -> SBool))+normalizeSame = do+ icp <- recall ifComplexityPos+ ibs <- recall ifComplexitySmaller++ sInduct "normalizeSame"+ (\(Forall f) -> isNormal f .=> normalize f .== f)+ (ifComplexity, [proofOf icp]) $+ \ih f -> [isNormal f]+ |- cases [ isFTrue f ==> trivial+ , isFFalse f ==> trivial+ , isVar f ==> trivial+ , isIf f ==> let c = sifCond f+ l = sifThen f+ r = sifElse f+ in sIf c (normalize l) (normalize r)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` Inst @"f" l+ =: sIf c l (normalize r)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` Inst @"f" r+ =: sIf c l r+ =: qed+ ]++-- | \(\mathit{eval}(\mathit{normalize}(f), bs) = \mathit{eval}(f, bs)\)+--+-- Normalization preserves semantics.+--+-- >>> runTP normalizeRespectsTruth+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Lemma: normalizePreservesComplexity Q.E.D.+-- Lemma: ifDepthNonNeg Q.E.D.+-- Inductive lemma (strong): normalizeRespectsTruth+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4 (2 way case split)+-- Step: 1.4.1 Q.E.D.+-- Step: 1.4.2.1 Q.E.D.+-- Step: 1.4.2.2 Q.E.D.+-- Step: 1.4.2.3 Q.E.D.+-- Step: 1.4.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: eval, ifComplexity, ifDepth, lookUp, normalize+-- [Proven] normalizeRespectsTruth :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Bool+normalizeRespectsTruth :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> SBool))+normalizeRespectsTruth = do+ icp <- recall ifComplexityPos+ ibs <- recall ifComplexitySmaller+ npc <- recall normalizePreservesComplexity+ idn <- recall ifDepthNonNeg++ sInductWith cvc5 "normalizeRespectsTruth"+ (\(Forall f) (Forall bs) -> eval (normalize f) bs .== eval f bs)+ (\f _ -> tuple (ifComplexity f, ifDepth f), [proofOf icp, proofOf idn]) $+ \ih f bs -> []+ |- cases [ isFTrue f ==> trivial+ , isFFalse f ==> trivial+ , isVar f ==> trivial+ , isIf f ==> let c = sifCond f+ l = sifThen f+ r = sifElse f+ in cases [ isIf c ==>+ let p = sifCond c+ q = sifThen c+ rc = sifElse c+ transformed = sIf p (sIf q l r) (sIf rc l r)+ in eval (normalize (sIf c l r)) bs .== eval (sIf c l r) bs+ ?? npc `at` (Inst @"p" p, Inst @"q" q, Inst @"s" rc, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" transformed, Inst @"bs" bs)+ =: sTrue+ =: qed+ , sNot (isIf c) ==>+ eval (normalize (sIf c l r)) bs .== eval (sIf c l r) bs+ =: eval (sIf c (normalize l) (normalize r)) bs .== eval (sIf c l r) bs+ =: ite (eval c bs) (eval (normalize l) bs) (eval (normalize r) bs) .== ite (eval c bs) (eval l bs) (eval r bs)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" l, Inst @"bs" bs)+ ?? ih `at` (Inst @"f" r, Inst @"bs" bs)+ =: sTrue+ =: qed+ ]+ ]++-- * Main soundness theorem++-- | \(\mathit{isTautology}(f) \implies \mathit{eval}(f, \mathit{bindings})\)+--+-- If the tautology checker says a formula is a tautology, then it evaluates+-- to true under any binding environment. This is the soundness theorem.+--+-- >>> runTP soundness+-- Lemma: tautologyImpliesEval Q.E.D.+-- Lemma: normalizeRespectsTruth Q.E.D.+-- Lemma: normalizeCorrect Q.E.D.+-- Lemma: soundness+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: eval, ifComplexity, ifDepth, isAssigned, isNormal, isTautology', lookUp, normalize+-- [Proven] soundness :: Ɐf ∷ Formula → Ɐbindings ∷ [Binding] → Bool+soundness :: TP (Proof (Forall "f" Formula -> Forall "bindings" [Binding] -> SBool))+soundness = do+ tie <- recallWith cvc5 tautologyImpliesEval+ nrt <- recall normalizeRespectsTruth+ nc <- recall normalizeCorrect++ calc "soundness"+ (\(Forall f) (Forall bindings) -> isTautology f .=> eval f bindings) $+ \f bindings -> [isTautology f]+ |- eval f bindings+ ?? nrt `at` (Inst @"f" f, Inst @"bs" bindings)+ =: eval (normalize f) bindings+ ?? nc `at` Inst @"f" f+ ?? tie `at` (Inst @"f" (normalize f), Inst @"a" bindings, Inst @"b" [])+ =: sTrue+ =: qed++-- * Completeness++-- | Result of attempting to falsify a formula.+data FalsifyResult = FalsifyResult { falsified :: Bool+ , cex :: [Binding]+ }++-- | Make FalsifyResult symbolic.+mkSymbolic [''FalsifyResult]++-- | Attempt to falsify a normalized formula under given bindings.+-- Returns whether falsification succeeded and the counterexample bindings.+falsify' :: SFormula -> SList Binding -> SFalsifyResult+falsify' = smtFunction "falsify'" $ \f bs ->+ [sCase| f of+ FTrue -> sFalsifyResult sFalse []+ FFalse -> sFalsifyResult sTrue bs++ Var i+ | isAssigned i bs, eval (sVar i) bs -> sFalsifyResult sFalse []+ | isAssigned i bs -> sFalsifyResult sTrue bs+ | True -> sFalsifyResult sTrue (sBinding i sFalse .: bs)++ If (Var i) l r+ | isAssigned i bs, eval (sVar i) bs -> falsify' l bs+ | isAssigned i bs -> falsify' r bs+ | True -> let resL = falsify' l (assumeTrue i bs)+ in ite (sNot (sfalsified resL))+ (falsify' r (assumeFalse i bs))+ resL+ If FTrue l _ -> falsify' l bs+ If FFalse _ r -> falsify' r bs+ If _ _ _ -> sFalsifyResult sFalse [] -- Shouldn't happen for normal formulas+ |]++-- | Falsify a formula by first normalizing it.+falsify :: SFormula -> SFalsifyResult+falsify f = falsify' (normalize f) []++-- * Completeness lemmas++-- | If a normalized formula is not a tautology, then falsify' returns falsified = true.+--+-- >>> runTPWith cvc5 nonTautIsFalsified+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Inductive lemma (strong): nonTautIsFalsified+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: eval, falsify', ifComplexity, isAssigned, isNormal, isTautology', lookUp+-- [Proven] nonTautIsFalsified :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Bool+nonTautIsFalsified :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> SBool))+nonTautIsFalsified = do+ icp <- recall ifComplexityPos+ ibs <- recall ifComplexitySmaller++ sInduct "nonTautIsFalsified"+ (\(Forall f) (Forall bs) -> isNormal f .&& sNot (isTautology' f bs) .=> sfalsified (falsify' f bs))+ (\f _ -> ifComplexity f, [proofOf icp]) $+ \ih f bs -> [isNormal f, sNot (isTautology' f bs)]+ |- cases [ isFTrue f ==> trivial+ , isFFalse f ==> trivial+ , isVar f ==> trivial+ , isIf f ==> let c = sifCond f+ l = sifThen f+ r = sifElse f+ in sfalsified (falsify' f bs)+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" l, Inst @"bs" bs)+ ?? ih `at` (Inst @"f" r, Inst @"bs" bs)+ ?? ih `at` (Inst @"f" l, Inst @"bs" (assumeTrue (sfVar c) bs))+ ?? ih `at` (Inst @"f" r, Inst @"bs" (assumeFalse (sfVar c) bs))+ =: sTrue+ =: qed+ ]++-- | If a variable is assigned in the input bindings and falsify' succeeds,+-- the lookup value is preserved in the output bindings.+--+-- >>> runTPWith cvc5 falsifyExtendsBindings+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Lemma: isAssignedExtends Q.E.D.+-- Lemma: lookUpExtends Q.E.D.+-- Inductive lemma (strong): falsifyExtendsBindings+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 way case split)+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: eval, falsify', ifComplexity, isAssigned, lookUp+-- [Proven] falsifyExtendsBindings :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Ɐi ∷ Integer → Bool+falsifyExtendsBindings :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> Forall "i" Integer -> SBool))+falsifyExtendsBindings = do+ icp <- recall ifComplexityPos+ ibs <- recall ifComplexitySmaller+ iae <- recall isAssignedExtends+ lue <- recall lookUpExtends++ sInduct "falsifyExtendsBindings"+ (\(Forall f) (Forall bs) (Forall i) ->+ isAssigned i bs .&& sfalsified (falsify' f bs) .=>+ lookUp i (scex (falsify' f bs)) .== lookUp i bs)+ (\f _ _ -> ifComplexity f, [proofOf icp]) $+ \ih f bs i -> [isAssigned i bs, sfalsified (falsify' f bs)]+ |- cases [ isFTrue f ==> trivial+ , isFFalse f ==> trivial+ , isVar f ==> let n = sfVar f+ in lookUp i (scex (falsify' f bs)) .== lookUp i bs+ ?? lue `at` (Inst @"i" i, Inst @"n" n, Inst @"v" sFalse, Inst @"bs" bs)+ =: sTrue+ =: qed+ , isIf f ==> let c = sifCond f+ l = sifThen f+ r = sifElse f+ n = sfVar c+ in lookUp i (scex (falsify' f bs)) .== lookUp i bs+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? iae `at` (Inst @"i" i, Inst @"n" n, Inst @"v" sTrue, Inst @"bs" bs)+ ?? iae `at` (Inst @"i" i, Inst @"n" n, Inst @"v" sFalse, Inst @"bs" bs)+ ?? lue `at` (Inst @"i" i, Inst @"n" n, Inst @"v" sTrue, Inst @"bs" bs)+ ?? lue `at` (Inst @"i" i, Inst @"n" n, Inst @"v" sFalse, Inst @"bs" bs)+ ?? ih `at` (Inst @"f" l, Inst @"bs" bs, Inst @"i" i)+ ?? ih `at` (Inst @"f" r, Inst @"bs" bs, Inst @"i" i)+ ?? ih `at` (Inst @"f" l, Inst @"bs" (assumeTrue n bs), Inst @"i" i)+ ?? ih `at` (Inst @"f" r, Inst @"bs" (assumeFalse n bs), Inst @"i" i)+ =: sTrue+ =: qed+ ]++-- | If falsify' returns falsified = true, then evaluating the formula+-- with the returned bindings gives false.+--+-- >>> runTPWith cvc5 falsifyFalsifies+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Lemma: falsifyExtendsBindings Q.E.D.+-- Lemma: lookUpSame Q.E.D.+-- Lemma: isAssignedSame Q.E.D.+-- Inductive lemma (strong): falsifyFalsifies+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (4 way case split)+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.1.3 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.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.4 (4 way case split)+-- Step: 1.4.1 Q.E.D.+-- Step: 1.4.2 Q.E.D.+-- Step: 1.4.3 (2 way case split)+-- Step: 1.4.3.1 (2 way case split)+-- Step: 1.4.3.1.1 Q.E.D.+-- Step: 1.4.3.1.2 Q.E.D.+-- Step: 1.4.3.1.Completeness Q.E.D.+-- Step: 1.4.3.2 (2 way case split)+-- Step: 1.4.3.2.1 Q.E.D.+-- Step: 1.4.3.2.2 Q.E.D.+-- Step: 1.4.3.2.Completeness Q.E.D.+-- Step: 1.4.3.Completeness Q.E.D.+-- Step: 1.4.4 Q.E.D.+-- Step: 1.4.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: eval, falsify', ifComplexity, isAssigned, isNormal, lookUp+-- [Proven] falsifyFalsifies :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Bool+falsifyFalsifies :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> SBool))+falsifyFalsifies = do+ icp <- recall ifComplexityPos+ ibs <- recall ifComplexitySmaller+ feb <- recall falsifyExtendsBindings+ lus <- recall lookUpSame+ ias <- recall isAssignedSame++ sInduct "falsifyFalsifies"+ (\(Forall f) (Forall bs) -> isNormal f .&& sfalsified (falsify' f bs) .=> sNot (eval f (scex (falsify' f bs))))+ (\f _ -> ifComplexity f, [proofOf icp]) $+ \ih f bs -> [isNormal f, sfalsified (falsify' f bs)]+ |- cases [ isFTrue f ==> sNot (eval f (scex (falsify' f bs)))+ =: sNot (eval sFTrue (scex (falsify' sFTrue bs)))+ =: sNot sTrue+ =: sFalse+ =: qed+ , isFFalse f ==> sNot (eval f (scex (falsify' f bs)))+ =: sNot (eval sFFalse bs)+ =: sNot sFalse+ =: sTrue+ =: qed+ , isVar f ==> let n = sfVar f+ in sNot (eval f (scex (falsify' f bs)))+ =: sNot (eval (sVar n) (scex (falsify' (sVar n) bs)))+ =: sNot (lookUp n (scex (falsify' (sVar n) bs)))+ =: sTrue+ =: qed+ , isIf f ==> let c = sifCond f+ l = sifThen f+ r = sifElse f+ in cases [ isFTrue c ==> sNot (eval f (scex (falsify' f bs)))+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" l, Inst @"bs" bs)+ =: sTrue+ =: qed+ , isFFalse c ==> sNot (eval f (scex (falsify' f bs)))+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ih `at` (Inst @"f" r, Inst @"bs" bs)+ =: sTrue+ =: qed+ , isVar c ==> let n = sfVar c+ in cases [ isAssigned n bs ==>+ cases [ lookUp n bs ==>+ sNot (eval f (scex (falsify' f bs)))+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? feb `at` (Inst @"f" l, Inst @"bs" bs, Inst @"i" n)+ ?? ih `at` (Inst @"f" l, Inst @"bs" bs)+ =: sTrue+ =: qed+ , sNot (lookUp n bs) ==>+ sNot (eval f (scex (falsify' f bs)))+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? feb `at` (Inst @"f" r, Inst @"bs" bs, Inst @"i" n)+ ?? ih `at` (Inst @"f" r, Inst @"bs" bs)+ =: sTrue+ =: qed+ ]+ , sNot (isAssigned n bs) ==>+ let resL = falsify' l (assumeTrue n bs)+ in cases [ sfalsified resL ==>+ sNot (eval f (scex (falsify' f bs)))+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ias `at` (Inst @"n" n, Inst @"v" sTrue, Inst @"bs" bs)+ ?? lus `at` (Inst @"n" n, Inst @"v" sTrue, Inst @"bs" bs)+ ?? feb `at` (Inst @"f" l, Inst @"bs" (assumeTrue n bs), Inst @"i" n)+ ?? ih `at` (Inst @"f" l, Inst @"bs" (assumeTrue n bs))+ =: sTrue+ =: qed+ , sNot (sfalsified resL) ==>+ sNot (eval f (scex (falsify' f bs)))+ ?? ibs `at` (Inst @"c" c, Inst @"l" l, Inst @"r" r)+ ?? ias `at` (Inst @"n" n, Inst @"v" sFalse, Inst @"bs" bs)+ ?? lus `at` (Inst @"n" n, Inst @"v" sFalse, Inst @"bs" bs)+ ?? feb `at` (Inst @"f" r, Inst @"bs" (assumeFalse n bs), Inst @"i" n)+ ?? ih `at` (Inst @"f" r, Inst @"bs" (assumeFalse n bs))+ =: sTrue+ =: qed+ ]+ ]+ , isIf c ==> sNot (eval f (scex (falsify' f bs)))+ =: sTrue -- Contradicts isNormal+ =: qed+ ]+ ]++-- | Helper lemma for completeness: If a formula is not a tautology,+-- evaluating its normalization with falsify's bindings gives false.+--+-- >>> runTPWith cvc5 completenessHelper+-- Lemma: falsifyFalsifies Q.E.D.+-- Lemma: nonTautIsFalsified Q.E.D.+-- Lemma: normalizeCorrect Q.E.D.+-- Lemma: completenessHelper Q.E.D.+-- Functions proven terminating:+-- eval, falsify', ifComplexity, ifDepth, isAssigned, isNormal, isTautology', lookUp, normalize+-- [Proven] completenessHelper :: Ɐf ∷ Formula → Bool+completenessHelper :: TP (Proof (Forall "f" Formula -> SBool))+completenessHelper = do+ ff <- recall falsifyFalsifies+ nti <- recall nonTautIsFalsified+ nc <- recallWith z3 normalizeCorrect++ lemma "completenessHelper"+ (\(Forall f) -> sNot (isTautology f) .=> sNot (eval (normalize f) (scex (falsify f))))+ [proofOf ff, proofOf nti, proofOf nc]++-- * Main completeness theorem++-- | \(\lnot\mathit{isTautology}(f) \implies \lnot\mathit{eval}(f, \mathit{falsify}(f).\mathit{bindings})\)+--+-- If the tautology checker says a formula is not a tautology, then there exists+-- a binding environment (provided by falsify) under which it evaluates to false.+-- This is the completeness theorem.+--+-- >>> runTPWith cvc5 completeness+-- Lemma: completenessHelper Q.E.D.+-- Lemma: normalizeRespectsTruth Q.E.D.+-- Lemma: completeness Q.E.D.+-- Functions proven terminating:+-- eval, falsify', ifComplexity, ifDepth, isAssigned, isNormal, isTautology', lookUp, normalize+-- [Proven] completeness :: Ɐf ∷ Formula → Bool+completeness :: TP (Proof (Forall "f" Formula -> SBool))+completeness = do+ ch <- recall completenessHelper+ nrt <- recallWith z3 normalizeRespectsTruth++ lemma "completeness"+ (\(Forall f) -> sNot (isTautology f) .=> sNot (eval f (scex (falsify f))))+ [proofOf ch, proofOf nrt]
+ Documentation/SBV/Examples/TP/UpDown.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.UpDown+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Proves @reverse (down n) = up n@.+--+-- This problem is motivated by an ACL2 midterm exam question, from Fall 2011.+-- See: <https://www.cs.utexas.edu/~moore/classes/cs389r/midterm-answers.lisp>.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.UpDown where++import Prelude hiding (reverse, (++))++import Data.SBV+import Data.SBV.TP+import Data.SBV.List++import Documentation.SBV.Examples.TP.Lists+import Documentation.SBV.Examples.TP.Peano++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+#endif++-- | Construct a list of size @n@, containing numbers @1@ to @n@.+--+-- >>> up 0+-- [] :: [SInteger]+-- >>> up 5+-- [1,2,3,4,5] :: [SInteger]+up :: SNat -> SList Integer+up n = upAcc n []++-- | Keep consing the first argument on to the accumulator, until we hit zero. After that, return the second argument.+-- Normally, we'd define this as a local function, but the definition needs to be visible for the proofs.+upAcc :: SNat -> SList Integer -> SList Integer+upAcc = smtFunction "up"+ $ \n lst -> [sCase| n of+ Zero -> lst+ Succ p -> upAcc p (n2i n .: lst)+ |]++-- | Construct a list of size @n@, containing numbers @n-1@ down to @0@.+--+-- >>> down 0+-- [] :: [SInteger]+-- >>> down 5+-- [5,4,3,2,1] :: [SInteger]+down :: SNat -> SList Integer+down = smtFunction "down"+ $ \n -> [sCase| n of+ Zero -> []+ Succ p -> n2i n .: down p+ |]++-- | Prove that @reverse (down n)@ is the same as @up n@+--+-- >>> runTP upDown+-- Lemma: n2iNonNeg Q.E.D.+-- Lemma: revCons Q.E.D.+-- Inductive lemma (strong): upDownGen+-- 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.+-- Lemma: upDown Q.E.D.+-- Functions proven terminating: down, n2i, sbv.reverse, up+-- [Proven] upDown :: Ɐn ∷ Nat → Bool+upDown :: TP (Proof (Forall "n" Nat -> SBool))+upDown = do+ n2inn <- recall n2iNonNeg+ rc <- recall (revCons @Integer)++ -- We first generalize the theorem, to make it inductive+ upDownGen <- sInduct "upDownGen"+ (\(Forall @"n" n) (Forall @"xs" xs) -> reverse (down n) ++ xs .== upAcc n xs)+ (\n _ -> n2i n, [proofOf n2inn]) $+ \ih n xs -> [] |- cases [ isZero n ==> trivial+ , isSucc n ==> let p = getSucc_1 n+ in reverse (down (sSucc p)) ++ xs+ =: reverse (n2i n .: down p) ++ xs+ ?? rc+ =: reverse (down p) ++ (n2i n .: xs)+ ?? ih `at` (Inst @"n" p, Inst @"xs" (n2i n .: xs))+ =: upAcc p (n2i n .: xs)+ =: upAcc n xs+ =: qed+ ]++ -- The theorem we want to prove follows by instantiating the list at empty, and+ -- the SMT solver can figure it out by itself+ lemma "upDown"+ (\(Forall n) -> reverse (down n) .== up n)+ [proofOf upDownGen]
+ Documentation/SBV/Examples/TP/VM.hs view
@@ -0,0 +1,448 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.TP.VM+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Correctness of a simple interpreter vs virtual-machine interpretation of a language.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.TP.VM+#ifndef DOCTEST+ ( -- * Language+ Expr(..), SExpr, size+++ -- * Symbolic accessors+ , sCaseExpr+ , isVar, sVar, getVar_1, svar+ , isCon, sCon, getCon_1, scon+ , isSqr, sSqr, getSqr_1, ssqrVal+ , isInc, sInc, getInc_1, sincVal+ , isAdd, sAdd, getAdd_1, getAdd_2, sadd1, sadd2+ , isMul, sMul, getMul_1, getMul_2, smul1, smul2+ , isLet, sLet, getLet_1, getLet_2, getLet_3, slvar, slval, slbody++ -- * Environment and the stack+ , Env, Stack++ -- * Interpretation+ , interpInEnv, interp++ -- * Virtual machine+ , Instr(..), SInstr++ -- * Compilation+ , compile, compileAndRun++ -- * Correctness of the compiler+ , correctness)+#endif+where++import Data.SBV+import Data.SBV.Tuple as ST+import Data.SBV.List as SL++import Data.SBV.TP++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV.TP+-- >>> :set -XTypeApplications+#endif++-- * Language++-- | Basic expression language.+data Expr nm val = Var {var :: nm } -- ^ Variables+ | Con {con :: val } -- ^ Constants+ | Sqr {sqrVal :: Expr nm val } -- ^ Squaring+ | Inc {incVal :: Expr nm val } -- ^ Increment+ | Add {add1 :: Expr nm val, add2 :: Expr nm val } -- ^ Addition+ | Mul {mul1 :: Expr nm val, mul2 :: Expr nm val } -- ^ Addition+ | Let {lvar :: nm, lval :: Expr nm val, lbody :: Expr nm val} -- ^ Let expression++-- | Create symbolic version of expressions+mkSymbolic [''Expr]++-- | Size of an expression. Used in strong induction.+size :: (SymVal nm, SymVal val) => SExpr nm val -> SInteger+size = smtFunction "exprSize"+ $ \expr -> [sCase| expr of+ Var _ -> 0+ Con _ -> 0+ Sqr a -> 1 + size a+ Inc a -> 1 + size a+ Add a b -> 1 + size a `smax` size b+ Mul a b -> 1 + size a `smax` size b+ Let _ a b -> 1 + size a `smax` size b+ |]++-- | Environment, binding names to values+type Env nm val = SList (nm, val)++-- * Functional interpretation++-- | Interpreter, in the usual functional style, taking an arbitrary environment.+interpInEnv :: (SymVal nm, SymVal val, Num (SBV val)) => Env nm val -> SExpr nm val -> SBV val+interpInEnv = smtFunction "interpInEnv"+ $ \env expr ->+ [sCase| expr of+ Var nm -> nm `SL.lookup` env+ Con v -> v+ Sqr a -> let av = interpInEnv env a in av * av+ Inc a -> let av = interpInEnv env a in av + 1+ Add a b -> let av = interpInEnv env a; bv = interpInEnv env b in av + bv+ Mul a b -> let av = interpInEnv env a; bv = interpInEnv env b in av * bv+ Let v a b -> let av = interpInEnv env a in interpInEnv (tuple (v, av) .: env) b+ |]++-- | Interpret starting from empty environment.+interp :: (SymVal nm, SymVal val, Num (SBV val)) => SExpr nm val -> SBV val+interp = interpInEnv []++-- * Virtual machine++-- | Instructions+data Instr nm val = IPushN { ivar :: nm } -- ^ Push the value of nm from the environment on to the stack+ | IPushV { ival :: val } -- ^ Push a value on to the stack+ | IDup -- ^ Duplicate the top of the stack+ | IAdd -- ^ Add the top two elements and push back+ | IMul -- ^ Multiply the top two elements and push back+ | IBind nm -- ^ Bind the value on top of stack to name+ | IForget -- ^ Pop and ignore the binding on the environment++-- | Create symbolic version of instructions+mkSymbolic [''Instr]++-- | Stack of values.+type Stack val = SList val++-- | Pushing on to the stack.+push :: SymVal val => SBV val -> Stack val -> Stack val+push = (SL..:)++-- | Top of the stack. If the stack is empty, the result is underspecified.+top :: SymVal val => Stack val -> SBV val+top = SL.head++-- | Popping from the stack. If the stack is empty, the result is underspecified.+pop :: SymVal val => Stack val -> Stack val+pop = SL.tail++-- | A pair containing an environment and a stack+type EnvStack nm val = SBV ([(nm, val)], [val])++-- | Executing a single instruction in a given environment and the instruction stack.+-- We produce the new environment, and the new stack.+execute :: (SymVal nm, SymVal val, Num (SBV val)) => EnvStack nm val -> SInstr nm val -> EnvStack nm val+execute envStk instr = let (env, stk) = untuple envStk+ in tuple [sCase| instr of+ IPushN nm -> (env, push (nm `SL.lookup` env) stk)+ IPushV v -> (env, push v stk)+ IDup -> (env, push (top stk) stk)+ IAdd -> (env, let a = top stk; b = top (pop stk) in push (a + b) (pop (pop stk)))+ IMul -> (env, let a = top stk; b = top (pop stk) in push (a * b) (pop (pop stk)))+ IBind nm -> (push (tuple (nm, top stk)) env, pop stk)+ IForget -> (pop env, stk)+ |]++-- | Execute a sequence of instructions, in a given stack and env. Returnsg the final environment and the stack. This is a+-- simple fold-left.+run :: (SymVal nm, SymVal val, Num (SBV val)) => EnvStack nm val -> SList (Instr nm val) -> EnvStack nm val+run = SL.foldl execute++-- * Compiler++-- | Convert an expression to a sequence of instructions for our virtual machine.+compile :: (SymVal nm, SymVal val, Num (SBV val)) => SExpr nm val -> SList (Instr nm val)+compile = smtFunction "compile"+ $ \expr -> [sCase| expr of+ Var nm -> [sIPushN nm]+ Con v -> [sIPushV v]+ Sqr a -> compile a SL.++ [sIDup, sIMul]+ Inc a -> compile a SL.++ [sIPushV 1, sIAdd]+ Add a b -> compile a SL.++ compile b SL.++ [sIAdd]+ Mul a b -> compile a SL.++ compile b SL.++ [sIMul]+ Let v a b -> compile a SL.++ [sIBind v] SL.++ compile b SL.++ [sIForget]+ |]++-- | Compile and run an expression.+compileAndRun :: (SymVal nm, SymVal val, Num (SBV val)) => SExpr nm val -> SBV val+compileAndRun = top . ST.snd . run (tuple ([], [])) . compile++-- * Correctness++-- | The property we're after is that interpreting an expression is the same as+-- first compiling it to virtual-machine instructions, and then running them.+--+-- >>> runTP (correctness @String @Integer)+-- Inductive lemma: runSeq+-- 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: runOne Q.E.D.+-- Lemma: runTwo+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Lemma: runMul Q.E.D.+-- Lemma: measureNonNeg Q.E.D.+-- Inductive lemma (strong): helper+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (7 way case split)+-- Step: 1.1.1 (case Var) Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 (case Con) Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 (case Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 Q.E.D.+-- Step: 1.3.7 Q.E.D.+-- Step: 1.4.1 (case Inc) 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.5.1 (case sAdd) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.5.5 Q.E.D.+-- Step: 1.5.6 Q.E.D.+-- Step: 1.5.7 Q.E.D.+-- Step: 1.5.8 Q.E.D.+-- Step: 1.5.9 Q.E.D.+-- Step: 1.6.1 (case sMul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.6.5 Q.E.D.+-- Step: 1.6.6 Q.E.D.+-- Step: 1.6.7 Q.E.D.+-- Step: 1.6.8 Q.E.D.+-- Step: 1.6.9 Q.E.D.+-- Step: 1.7.1 (case Let) Q.E.D.+-- Step: 1.7.2 Q.E.D.+-- Step: 1.7.3 Q.E.D.+-- Step: 1.7.4 Q.E.D.+-- Step: 1.7.5 Q.E.D.+-- Step: 1.7.6 Q.E.D.+-- Step: 1.7.7 Q.E.D.+-- Step: 1.7.8 Q.E.D.+-- Step: 1.7.9 Q.E.D.+-- Step: 1.7.10 Q.E.D.+-- Step: 1.7.11 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: correctness+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D.+-- Functions proven terminating: compile, exprSize, interpInEnv, sbv.foldl, sbv.lookup+-- [Proven] correctness :: Ɐexpr ∷ (Expr String Integer) → Bool+correctness :: forall nm val. (SymVal nm, SymVal val, Num (SBV val)) => TP (Proof (Forall "expr" (Expr nm val) -> SBool))+correctness = do++ -- Running a sequence of instructions that are appended is equivalent to running them in sequence:+ runSeq <- induct "runSeq"+ (\(Forall @"xs" xs) (Forall @"ys" ys) (Forall @"es" (es :: EnvStack nm val))+ -> run es (xs SL.++ ys) .== run (run es xs) ys) $+ \ih (x, xs) ys es -> [] |- run es ((x .: xs) SL.++ ys)+ =: run es (x .: (xs SL.++ ys))+ =: run (execute es x) (xs SL.++ ys)+ ?? ih `at` (Inst @"ys" ys, Inst @"es" (execute es x))+ =: run (run es (x .: xs)) ys+ =: qed++ -- The following few lemmas make the proof go thru faster, even though they're really easy to prove themselves.++ -- Running one instruction is equal to just executing it+ runOne <- lemma "runOne"+ (\(Forall @"es" (es :: EnvStack nm val)) (Forall @"i" i) -> run es [i] .== execute es i)+ []++ -- Same for two+ runTwo <- calc "runTwo"+ (\(Forall @"es" (es :: EnvStack nm val)) (Forall @"i" i) (Forall @"j" j)+ -> run es [i, j] .== execute (execute es i) j) $+ \es i j -> [] |- run es [i, j]+ =: run (execute es i) [j]+ =: execute (execute es i) j+ =: qed++ -- Provers struggle with multiplication, so help them a bit here even though this is really+ -- a trivial proof. What's hard is the correct instantiation of it, so abstracting it away helps+ -- us speed up the solver.+ runMul <- lemma "runMul"+ (\(Forall @"a" a) (Forall @"b" b) (Forall @"env" (env :: Env nm val)) (Forall @"stk" stk)+ -> execute (tuple (env, push a (push b stk))) sIMul+ .== tuple (env, push (a * b) stk))+ []++ -- We will use the size of the expression as the measure. We need to show that it is+ -- always positive for the inductive proof to go thru.+ measureNonNeg <- inductiveLemma "measureNonNeg"+ (\(Forall @"e" (e :: SExpr nm val)) -> size e .>= 0)+ []++ -- A more general version of the theorem, starting with an arbitrary env and stack.+ -- We prove this using the induction principle for expressions.+ helper <- sInductWith cvc5 "helper"+ (\(Forall @"e" e) (Forall @"env" (env :: Env nm val)) (Forall @"stk" stk) ->+ run (tuple (env, stk)) (compile e)+ .== tuple (env, push (interpInEnv env e) stk))+ (\e _ _ -> size e, [proofOf measureNonNeg]) $+ \ih e env stk -> []+ |- [pCase| e of+ Var nm -> run (tuple (env, stk)) (compile (sVar nm))+ ?? "case Var"+ =: run (tuple (env, stk)) [sIPushN nm]+ =: tuple (env, push (interpInEnv env (sVar nm)) stk)+ =: qed++ Con v -> run (tuple (env, stk)) (compile (sCon v))+ ?? "case Con"+ =: run (tuple (env, stk)) [sIPushV v]+ =: tuple (env, push v stk)+ =: tuple (env, push (interpInEnv env (sCon v)) stk)+ =: qed++ Sqr a -> run (tuple (env, stk)) (compile (sSqr a))+ ?? "case Sqr"+ =: run (tuple (env, stk)) (compile a SL.++ [sIDup, sIMul])+ ?? runSeq+ =: run (run (tuple (env, stk)) (compile a)) [sIDup, sIMul]+ ?? ih `at` (Inst @"e" a, Inst @"env" env, Inst @"stk" stk)+ =: let stk' = push (interpInEnv env a) stk+ in run (tuple (env, stk')) [sIDup, sIMul]+ ?? runTwo `at` (Inst @"es" (tuple (env, stk')), Inst @"i" sIDup, Inst @"j" sIMul)+ =: execute (execute (tuple (env, stk')) sIDup) sIMul+ =: let stk'' = push (interpInEnv env a) stk'+ in execute (tuple (env, stk'')) sIMul+ =: tuple (env, push (interpInEnv env a * interpInEnv env a) stk)+ =: tuple (env, push (interpInEnv env (sSqr a)) stk)+ =: qed++ Inc a -> run (tuple (env, stk)) (compile (sInc a))+ ?? "case Inc"+ =: run (tuple (env, stk)) (compile a SL.++ [sIPushV 1, sIAdd])+ ?? runSeq+ =: run (run (tuple (env, stk)) (compile a)) [sIPushV 1, sIAdd]+ ?? ih `at` (Inst @"e" a, Inst @"env" env, Inst @"stk" stk)+ =: let stk' = push (interpInEnv env a) stk+ in run (tuple (env, stk')) [sIPushV 1, sIAdd]+ ?? runTwo `at` (Inst @"es" (tuple (env, stk')), Inst @"i" (sIPushV 1), Inst @"j" sIAdd)+ =: execute (execute (tuple (env, stk')) (sIPushV 1)) sIAdd+ =: let stk'' = push 1 stk'+ in execute (tuple (env, stk'')) sIAdd+ =: tuple (env, push (1 + interpInEnv env a) stk)+ =: tuple (env, push (interpInEnv env (sInc a)) stk)+ =: qed++ Add a b -> run (tuple (env, stk)) (compile (sAdd a b))+ ?? "case sAdd"+ =: run (tuple (env, stk)) (compile a SL.++ compile b SL.++ [sIAdd])+ ?? runSeq+ =: run (run (tuple (env, stk)) (compile a)) (compile b SL.++ [sIAdd])+ ?? ih `at` (Inst @"e" a, Inst @"env" env, Inst @"stk" stk)+ =: let stk' = push (interpInEnv env a) stk+ in run (tuple (env, stk')) (compile b SL.++ [sIAdd])+ ?? runSeq+ =: run (run (tuple (env, stk')) (compile b)) [sIAdd]+ ?? ih `at` (Inst @"e" b, Inst @"env" env, Inst @"stk" stk')+ =: let stk'' = push (interpInEnv env b) stk'+ in run (tuple (env, stk'')) [sIAdd]+ ?? runOne `at` (Inst @"es" (tuple (env, stk'')), Inst @"i" sIAdd)+ =: execute (tuple (env, stk'')) sIAdd+ =: tuple (env, push (interpInEnv env b + interpInEnv env a) stk)+ =: tuple (env, push (interpInEnv env a + interpInEnv env b) stk)+ =: tuple (env, push (interpInEnv env (sAdd a b)) stk)+ =: qed++ Mul a b -> run (tuple (env, stk)) (compile (sMul a b))+ ?? "case sMul"+ =: run (tuple (env, stk)) (compile a SL.++ compile b SL.++ [sIMul])+ ?? runSeq+ =: run (run (tuple (env, stk)) (compile a)) (compile b SL.++ [sIMul])+ ?? ih `at` (Inst @"e" a, Inst @"env" env, Inst @"stk" stk)+ =: let stk' = push (interpInEnv env a) stk+ in run (tuple (env, stk')) (compile b SL.++ [sIMul])+ ?? runSeq+ =: run (run (tuple (env, stk')) (compile b)) [sIMul]+ ?? ih `at` (Inst @"e" b, Inst @"env" env, Inst @"stk" stk')+ =: let stk'' = push (interpInEnv env b) stk'+ in run (tuple (env, stk'')) [sIMul]+ ?? runOne `at` (Inst @"es" (tuple (env, stk'')), Inst @"i" sIMul)+ =: execute (tuple (env, stk'')) sIMul+ ?? runMul `at` ( Inst @"a" (interpInEnv env b)+ , Inst @"b" (interpInEnv env a)+ , Inst @"env" env+ , Inst @"stk" stk)+ =: tuple (env, push (interpInEnv env b * interpInEnv env a) stk)+ =: tuple (env, push (interpInEnv env a * interpInEnv env b) stk)+ =: tuple (env, push (interpInEnv env (sMul a b)) stk)+ =: qed++ Let nm a b -> run (tuple (env, stk)) (compile (sLet nm a b))+ ?? "case Let"+ =: run (tuple (env, stk)) (compile a SL.++ [sIBind nm] SL.++ compile b SL.++ [sIForget])+ ?? runSeq+ =: run (run (tuple (env, stk)) (compile a)) ([sIBind nm] SL.++ compile b SL.++ [sIForget])+ ?? ih `at` (Inst @"e" a, Inst @"env" env, Inst @"stk" stk)+ =: let stk' = push (interpInEnv env a) stk+ in run (tuple (env, stk')) ([sIBind nm] SL.++ compile b SL.++ [sIForget])+ ?? runSeq+ =: run (run (tuple (env, stk')) [sIBind nm]) (compile b SL.++ [sIForget])+ ?? runOne+ =: run (execute (tuple (env, stk')) (sIBind nm)) (compile b SL.++ [sIForget])+ =: let env' = push (tuple (nm, interpInEnv env a)) env+ in run (tuple (env', stk)) (compile b SL.++ [sIForget])+ ?? runSeq+ =: run (run (tuple (env', stk)) (compile b)) [sIForget]+ ?? ih `at` (Inst @"e" b, Inst @"env" env', Inst @"stk" stk)+ =: let stk'' = push (interpInEnv env' b) stk+ in run (tuple (env', stk'')) [sIForget]+ ?? runOne+ =: execute (tuple (env', stk'')) sIForget+ =: tuple (env, stk'')+ =: tuple (env, push (interpInEnv env (sLet nm a b)) stk)+ =: qed+ |]++ -- We can now prove the final correctness theorem, based on the helper.+ calc "correctness"+ (\(Forall @"expr" (e :: SExpr nm val)) -> compileAndRun e .== interp e) $+ \(e :: SExpr nm val) -> [] |- compileAndRun e+ =: top (ST.snd (run (tuple ([], [])) (compile e)))+ ?? helper `at` (Inst @"e" e, Inst @"env" [], Inst @"stk" [])+ =: top (ST.snd (tuple ([] :: Env nm val, push (interpInEnv [] e) [])))+ =: interpInEnv [] e+ =: interp e+ =: qed
Documentation/SBV/Examples/Transformers/SymbolicEval.hs view
@@ -6,7 +6,7 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- A demonstration of the use of the 'SymbolicT' and 'QueryT' transformers in+-- A demonstration of the use of the t'SymbolicT' and t'QueryT' transformers in -- the setting of symbolic program evaluation. -- -- In this example, we perform symbolic evaluation across three steps:@@ -20,7 +20,6 @@ -- named @x@ and @y@. ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -41,12 +40,8 @@ import Data.SBV.Internals (SBV(SBV), unSBV) import Data.SBV.Trans.Control --- Starting with base 4.16; Data.Bits exports And, which conflicts with the definition here-#if MIN_VERSION_base(4,16,0)+-- Data.Bits exports And, which conflicts with the definition here import Data.SBV.Trans hiding(And)-#else-import Data.SBV.Trans-#endif -- * Allocation of symbolic variables, so we can extract a model later. @@ -63,14 +58,14 @@ -- we only have a value during property -- evaluation. }- deriving (Eq, Show)+ deriving Show -- | Allocate an integer variable with the provided name. alloc :: String -> Alloc (SBV Integer) alloc "" = throwError "tried to allocate unnamed value" alloc nm = free nm --- | Allocate an 'Env' holding all input variables for the program.+-- | Allocate an t'Env' holding all input variables for the program. allocEnv :: Alloc Env allocEnv = do x <- alloc "x"@@ -131,28 +126,28 @@ -- output. newtype Result = Result SVal --- | Makes a 'Result' from a symbolic value.+-- | Makes a t'Result' from a symbolic value. mkResult :: SBV a -> Result mkResult = Result . unSBV --- | Performs symbolic evaluation of a 'Program'.+-- | Performs symbolic evaluation of a t'Program'. runProgramEval :: Env -> Program a -> Except String Result runProgramEval env (Program term) = mkResult <$> runEval env term -- * Property evaluation --- | A property describes a quality of a 'Program'. It is a 'Term' yields a+-- | A property describes a quality of a t'Program'. It is a 'Term' yields a -- boolean value. newtype Property = Property (Term Bool) --- | Performs symbolic evaluation of a 'Property.+-- | Performs symbolic evaluation of a t'Property. runPropertyEval :: Result -> Env -> Property -> Except String (SBV Bool) runPropertyEval (Result res) env (Property term) = runEval (env { result = Just res }) term -- * Checking whether a program satisfies a property --- | The result of 'check'ing the combination of a 'Program' and a 'Property'.+-- | The result of 'check'ing the combination of a t'Program' and a t'Property'. data CheckResult = Proved | Counterexample Integer Integer deriving (Eq, Show) @@ -175,7 +170,7 @@ DSat{} -> throwError "delta-sat" Unk -> throwError "unknown" --- | Checks a 'Property' of a 'Program' (or fails).+-- | Checks a t'Property' of a t'Program' (or fails). check :: Program a -> Property -> IO (Either String CheckResult) check program prop = runExceptT $ runSMTWith z3 $ do env <- runAlloc allocEnv@@ -191,7 +186,7 @@ -- result is less than @10@ when @x+y@ is at least @9@. We have: -- -- >>> ex1--- Right (Counterexample 9 0)+-- Right (Counterexample 0 9) ex1 :: IO (Either String CheckResult) ex1 = check (Program $ Var "x" `Plus` Lit 1 `Plus` Var "y") (Property $ Var "result" `LessThan` Lit 10)@@ -215,3 +210,5 @@ ex3 :: IO (Either String CheckResult) ex3 = check (Program $ Var "notAValidVar") (Property $ Var "result" `LessThan` Lit 10)++{- HLint ignore module "Use fewer imports" -}
Documentation/SBV/Examples/Uninterpreted/AUF.hs view
@@ -6,7 +6,7 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- Formalizes and proves the following theorem, about arithmetic,+-- Formalizes and proves the following theorem about arithmetic, -- uninterpreted functions, and arrays. (For reference, see <http://research.microsoft.com/en-us/um/redmond/projects/z3/fmcad06-slides.pdf> -- slide number 24): --@@ -27,7 +27,7 @@ -- The function @read@ and @write@ are usual array operations. ----------------------------------------------------------------------------- -{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -35,30 +35,21 @@ import Data.SBV ------------------------------------------------------------------ * Model using functional arrays---------------------------------------------------------------+#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+#endif -- | Uninterpreted function in the theorem f :: SWord32 -> SWord64 f = uninterpret "f" --- | Correctness theorem. We state it for all values of @x@, @y@, and--- the given array @a@. Note that we're being generic in the type of--- array we're expecting.-thm :: SymArray a => SWord32 -> SWord32 -> a Word32 Word32 -> SBool+-- | Correctness theorem. We state it for all values of @x@, @y@, and the given array @a@. We have:+--+-- >>> prove thm+-- Q.E.D.+thm :: SWord32 -> SWord32 -> SArray Word32 Word32 -> SBool thm x y a = lhs .=> rhs where lhs = x + 2 .== y rhs = f (readArray (writeArray a x 3) (y - 2)) .== f (y - x + 1)---- | Prove it using SMT-Lib arrays.------ >>> proveSArray--- Q.E.D.-proveSArray :: IO ThmResult-proveSArray = prove $ do- x <- free "x"- y <- free "y"- a :: SArray Word32 Word32 <- newArray_ Nothing- return $ thm x y a
Documentation/SBV/Examples/Uninterpreted/Deduce.hs view
@@ -7,14 +7,9 @@ -- 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 #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -35,7 +30,7 @@ -- | Make this sort uninterpreted. This splice will automatically introduce -- the type 'SB' into the environment, as a synonym for 'SBV' 'B'.-mkUninterpretedSort ''B+mkSymbolic [''B] ----------------------------------------------------------------------------- -- * Uninterpreted connectives over 'B'@@ -54,31 +49,6 @@ not = uninterpret "NOT" -------------------------------------------------------------------------------- * Axioms of the logical system---------------------------------------------------------------------------------- | Distributivity of OR over AND, as an axiom in terms of--- the uninterpreted functions we have introduced. Note how--- variables range over the uninterpreted sort 'B'.-ax1 :: [String]-ax1 = [ "(assert (forall ((p B) (q B) (r B))"- , " (= (AND (OR p q) (OR p r))"- , " (OR p (AND q r)))))"- ]---- | One of De Morgan's laws, again as an axiom in terms--- of our uninterpeted logical connectives.-ax2 :: [String]-ax2 = [ "(assert (forall ((p B) (q B))"- , " (= (NOT (OR p q))"- , " (AND (NOT p) (NOT q)))))"- ]---- | Double negation axiom, similar to the above.-ax3 :: [String]-ax3 = ["(assert (forall ((p B)) (= (NOT (NOT p)) p)))"]------------------------------------------------------------------------------- -- * Demonstrated deduction ----------------------------------------------------------------------------- @@ -88,11 +58,14 @@ -- >>> test -- Q.E.D. test :: IO ThmResult-test = prove $ do addAxiom "OR distributes over AND" ax1- addAxiom "de Morgan" ax2- addAxiom "double negation" ax3+test = prove $ do constrain $ \(Forall p) (Forall q) (Forall r) -> (p `or` q) `and` (p `or` r) .== p `or` (q `and` r)+ constrain $ \(Forall p) (Forall q) -> not (p `or` q) .== not p `and` not q+ constrain $ \(Forall p) -> not (not p) .== p p <- free "p" q <- free "q" r <- free "r"- return $ not (p `or` (q `and` r))- .== (not p `and` not q) `or` (not p `and` not r)+ pure $ not (p `or` (q `and` r))+ .== (not p `and` not q) `or` (not p `and` not r)++-- Hlint gets confused and thinks the use of @not@ above is from the prelude. Sigh.+{- HLint ignore test "Redundant not" -}
+ Documentation/SBV/Examples/Uninterpreted/EUFLogic.hs view
@@ -0,0 +1,340 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.Uninterpreted.EUFLogic+-- License : BSD3+-- Stability : experimental+--+-- Demonstrates the ability to generate uninterpreted functions of arbitrarily+-- many arguments, whose types are generated programmatically. The high-level+-- idea of this module is to provide a strongly-typed representation, using a+-- GADT, of a logic that includes uninterpreted functions. This module then+-- defines an interpretation of this logic into SBV, which it uses to perform+-- SMT queries in the logic.+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Documentation.SBV.Examples.Uninterpreted.EUFLogic where++import Data.SBV++import Control.Monad.State++import Data.Kind+import Data.Type.Equality+import Data.Map (Map)+import qualified Data.Map as Map++import GHC.TypeLits++#ifdef DOCTEST+-- $setup+-- >>> import Data.SBV+#endif++----------------------------------------------------------------------+-- * Types of the EUF Logic+----------------------------------------------------------------------++-- | The datakind for the types in our EUF logic.+data EUFType = Tp_Bool | Tp_BV Natural++-- | A singleton type for natural numbers that can be used as the widths of bitvectors.+data BVWidth w = (KnownNat w, BVIsNonZero w) => BVWidth (SNat w)++-- | Create a t'BVWidth' object for a 'KnownNat' that is non-zero+knownBVWidth :: (KnownNat w, BVIsNonZero w) => BVWidth w+knownBVWidth = BVWidth natSing++-- | TestEquality instance for BVWidth.+instance TestEquality BVWidth where+ testEquality (BVWidth w1) (BVWidth w2) | Just Refl <- testEquality w1 w2 = Just Refl+ | True = Nothing++-- | A singleton type that represents type-level 'EUFType's at the object level+data TypeRepr (tp :: EUFType) where+ Repr_Bool :: TypeRepr Tp_Bool+ Repr_BV :: BVWidth w -> TypeRepr (Tp_BV w)++-- | TestEquality instance for Type representations+instance TestEquality TypeRepr where+ testEquality Repr_Bool Repr_Bool = Just Refl+ testEquality (Repr_BV w1) (Repr_BV w2) | Just Refl <- testEquality w1 w2 = Just Refl+ testEquality _ _ = Nothing++-- | A list of 'TypeRepr's for each type in a type-level list+data TypeReprs tps where+ Repr_Nil :: TypeReprs '[]+ Repr_Cons :: TypeRepr tp -> TypeReprs tps -> TypeReprs (tp ': tps)++instance TestEquality TypeReprs where+ testEquality Repr_Nil Repr_Nil = Just Refl+ testEquality (Repr_Cons tps1 tp1) (Repr_Cons tps2 tp2) | Just Refl <- testEquality tps1 tps2+ , Just Refl <- testEquality tp1 tp2 = Just Refl+ testEquality _ _ = Nothing++-- | An 'EUFType' with a known 'TypeRepr' representation+class KnownEUFType tp where+ knownEUFType :: TypeRepr tp++-- | Mapping from Tp_Bool+instance KnownEUFType Tp_Bool where+ knownEUFType = Repr_Bool++-- | Mapping from Tp_BV+instance (KnownNat w, BVIsNonZero w) => KnownEUFType (Tp_BV w) where+ knownEUFType = Repr_BV (BVWidth natSing)++-- | A sequence of types t'EUFType' with a known 'TypeReprs' representation+class KnownEUFTypes tps where+ knownEUFTypes :: TypeReprs tps++instance KnownEUFTypes '[] where+ knownEUFTypes = Repr_Nil++instance (KnownEUFType tp, KnownEUFTypes tps) => KnownEUFTypes (tp ': tps) where+ knownEUFTypes = Repr_Cons knownEUFType knownEUFTypes++----------------------------------------------------------------------+-- * Operations of the EUF Logic+----------------------------------------------------------------------++-- | An uninterpreted function in our EUF logic, which is a string name plus the input and output types.+data UnintOp (ins :: [EUFType]) (out :: EUFType) = UnintOp { unintOpName :: String+ , unintOpIns :: TypeReprs ins+ , unintOpOut :: TypeRepr out+ }++-- | The operations of our EUF logic, which are indexed by a list of 0 or more+-- input types and a single output type.+data Op (ins :: [EUFType]) (out :: EUFType) where+ -- Uninterpreted functions+ Op_Unint :: UnintOp ins out -> Op ins out++ -- Boolean operations+ Op_And :: Op (Tp_Bool ': Tp_Bool ': '[]) Tp_Bool+ Op_Or :: Op (Tp_Bool ': Tp_Bool ': '[]) Tp_Bool+ Op_Not :: Op (Tp_Bool ': '[]) Tp_Bool+ Op_BoolLit :: Bool -> Op '[] Tp_Bool+ Op_IfThenElse :: TypeRepr a -> Op (Tp_Bool ': a ': a ': '[]) a++ -- Bitvector operations+ Op_Plus :: BVWidth w -> Op (Tp_BV w ': Tp_BV w ': '[]) (Tp_BV w)+ Op_Minus :: BVWidth w -> Op (Tp_BV w ': Tp_BV w ': '[]) (Tp_BV w)+ Op_Times :: BVWidth w -> Op (Tp_BV w ': Tp_BV w ': '[]) (Tp_BV w)++ Op_Abs :: BVWidth w -> Op (Tp_BV w ': '[]) (Tp_BV w)+ Op_Signum :: BVWidth w -> Op (Tp_BV w ': '[]) (Tp_BV w)++ Op_BVLit :: BVWidth w -> Integer -> Op '[] (Tp_BV w)++ Op_BVEq :: BVWidth w -> Op (Tp_BV w ': Tp_BV w ': '[]) Tp_Bool+ Op_BVLt :: BVWidth w -> Op (Tp_BV w ': Tp_BV w ': '[]) Tp_Bool++-- | Create an uninterpreted 'Op' of known type+mkUnintOp :: (KnownEUFTypes ins, KnownEUFType out) => String -> Op ins out+mkUnintOp nm = Op_Unint $ UnintOp nm knownEUFTypes knownEUFType++-- | Get the input types and output type of an 'Op'+opInsOut :: Op ins out -> (TypeReprs ins, TypeRepr out)+opInsOut (Op_Unint uop) = (unintOpIns uop, unintOpOut uop)+opInsOut Op_And = (knownEUFTypes, knownEUFType)+opInsOut Op_Or = (knownEUFTypes, knownEUFType)+opInsOut Op_Not = (knownEUFTypes, knownEUFType)+opInsOut (Op_BoolLit _) = (knownEUFTypes, knownEUFType)+opInsOut (Op_IfThenElse Repr_Bool) = (knownEUFTypes, knownEUFType)+opInsOut (Op_IfThenElse (Repr_BV BVWidth{})) = (knownEUFTypes, knownEUFType)+opInsOut (Op_Plus BVWidth{}) = (knownEUFTypes, knownEUFType)+opInsOut (Op_Minus BVWidth{}) = (knownEUFTypes, knownEUFType)+opInsOut (Op_Times BVWidth{}) = (knownEUFTypes, knownEUFType)+opInsOut (Op_Abs BVWidth{}) = (knownEUFTypes, knownEUFType)+opInsOut (Op_Signum BVWidth{}) = (knownEUFTypes, knownEUFType)+opInsOut (Op_BVLit BVWidth{} _) = (knownEUFTypes, knownEUFType)+opInsOut (Op_BVEq BVWidth{}) = (knownEUFTypes, knownEUFType)+opInsOut (Op_BVLt BVWidth{}) = (knownEUFTypes, knownEUFType)++-- | Get the input types of an 'Op'+opIns :: Op ins out -> TypeReprs ins+opIns = fst . opInsOut++----------------------------------------------------------------------+-- * Expressions of the EUF Logic+----------------------------------------------------------------------++-- | The expressions of our EUF logic, which are just operations applied to argument expressions.+data EUFExpr tp where+ EUFExpr :: Op ins out -> EUFExprs ins -> EUFExpr out++-- | A sequence of expressions for each type in a type-level list+data EUFExprs tps where+ EUFExprsNil :: EUFExprs '[]+ EUFExprsCons :: EUFExpr tp -> EUFExprs tps -> EUFExprs (tp ': tps)++-- | Build the type @t'EUFExpr' in1 -> ... -> t'EUFExpr' inn -> out@+type family EUFExprFun (ins :: [EUFType]) (out :: EUFType) :: Type where+ EUFExprFun '[] out = EUFExpr out+ EUFExprFun (tp ': tps) out = EUFExpr tp -> EUFExprFun tps out++-- | Build an t'EUFExprFun' from a function on t'EUFExprs'+lambdaEUFExprFun :: TypeReprs ins -> (EUFExprs ins -> EUFExpr out) -> EUFExprFun ins out+lambdaEUFExprFun Repr_Nil f = f EUFExprsNil+lambdaEUFExprFun (Repr_Cons _ tps) f = \e -> lambdaEUFExprFun tps (f . EUFExprsCons e)++-- | Apply an 'Op' to t'EUFExprs' for its input types, returning an t'EUFExpr' for its output type+applyOp :: Op ins out -> EUFExprFun ins out+applyOp op = lambdaEUFExprFun (opIns op) (EUFExpr op)++instance (KnownNat w, BVIsNonZero w) => Num (EUFExpr (Tp_BV w)) where+ fromInteger i = applyOp (Op_BVLit knownBVWidth i)++ e1 + e2 = applyOp (Op_Plus knownBVWidth) e1 e2+ e1 - e2 = applyOp (Op_Minus knownBVWidth) e1 e2+ e1 * e2 = applyOp (Op_Times knownBVWidth) e1 e2++ abs e = applyOp (Op_Abs knownBVWidth) e+ signum e = applyOp (Op_Signum knownBVWidth) e++-- | Build an expression from an uninterpreted operation of a known type+mkUnintExpr :: KnownEUFType tp => String -> EUFExpr tp+mkUnintExpr nm = EUFExpr (mkUnintOp nm) EUFExprsNil++----------------------------------------------------------------------+-- * Interpreting the EUF Logic into SBV+----------------------------------------------------------------------++-- | Convert an 'EUFType' to a type of SBV expressions+type family Type2SBV (tp :: EUFType) :: Type where+ Type2SBV Tp_Bool = SBool+ Type2SBV (Tp_BV w) = SBV (WordN w)++-- | Convert the type inputs plus output of an 'Op' to a function over 'SBV' values+type family OpTypes2SBV (ins :: [EUFType]) (out :: EUFType) :: Type where+ OpTypes2SBV '[] out = Type2SBV out+ OpTypes2SBV (tp ': tps) out = Type2SBV tp -> OpTypes2SBV tps out++-- | Create an 'SMTDefinable' instance for the type returned by 'OpTypes2SBV' and pass it to a local function+withSMTDefOpTypes :: TypeReprs ins -> TypeRepr out -> (SMTDefinable (OpTypes2SBV ins out) => a) -> a+withSMTDefOpTypes Repr_Nil Repr_Bool f = f+withSMTDefOpTypes Repr_Nil (Repr_BV BVWidth{}) f = f+withSMTDefOpTypes (Repr_Cons Repr_Bool ins) out f = withSMTDefOpTypes ins out f+withSMTDefOpTypes (Repr_Cons (Repr_BV BVWidth{}) ins) out f = withSMTDefOpTypes ins out f++-- | An uninterpreted function that has been resolved to an 'SBV' function+data ResolvedUnintOp = forall ins out. ResolvedUnintOp (UnintOp ins out) (OpTypes2SBV ins out)++-- | A 'Map' for resolving uninterpreted operations+type UnintMap = Map String ResolvedUnintOp++-- | Look up the uninterpreted op associated with a 'String' in an 'UnintMap' at+-- a particular type, raising an error if that 'String' is associated with a+-- different type. If the 'String' is not associated with any uninterpreted+-- function, create one and return it, updating the 'UnintMap'.+unintEnsure :: UnintOp ins out -> UnintMap -> (OpTypes2SBV ins out, UnintMap)+unintEnsure uop m+ | Just (ResolvedUnintOp uop' f) <- Map.lookup (unintOpName uop) m+ , Just Refl <- testEquality (unintOpIns uop) (unintOpIns uop')+ , Just Refl <- testEquality (unintOpOut uop) (unintOpOut uop')+ = (f, m)+unintEnsure uop m+ | Just _ <- Map.lookup (unintOpName uop) m+ = error $ "unintEnsure: uninterpreted op " ++ unintOpName uop ++ " used at incorrect type"+unintEnsure uop m =+ withSMTDefOpTypes (unintOpIns uop) (unintOpOut uop)+ $ let f = uninterpret (unintOpName uop)+ in (f, Map.insert (unintOpName uop) (ResolvedUnintOp uop f) m)++-- | The monad for interpreting t'EUFExpr's into SBV, which is just a state monad+-- over an 'UnintMap'+type InterpM = State UnintMap++-- | Run an 'InterpM' computation starting with the empty 'UnintMap'+runInterpM :: InterpM a -> a+runInterpM = flip evalState Map.empty++-- | Interpret an 'Op' into a function over SBV values+interpOp :: Op ins out -> InterpM (OpTypes2SBV ins out)+interpOp (Op_Unint uop) = state (unintEnsure uop)+interpOp Op_And = pure (.&&)+interpOp Op_Or = pure (.||)+interpOp Op_Not = pure sNot+interpOp (Op_BoolLit b) = pure $ fromBool b+interpOp (Op_IfThenElse Repr_Bool) = pure ite+interpOp (Op_IfThenElse (Repr_BV BVWidth{})) = pure ite+interpOp (Op_Plus BVWidth{}) = pure (+)+interpOp (Op_Minus BVWidth{}) = pure (-)+interpOp (Op_Times BVWidth{}) = pure (*)+interpOp (Op_Abs BVWidth{}) = pure abs+interpOp (Op_Signum BVWidth{}) = pure signum+interpOp (Op_BVLit BVWidth{} i) = pure $ fromInteger i+interpOp (Op_BVEq BVWidth{}) = pure (.==)+interpOp (Op_BVLt BVWidth{}) = pure (.<)++-- | Interpret an t'EUFExpr' into an SBV value.+interpEUFExpr :: EUFExpr tp -> InterpM (Type2SBV tp)+interpEUFExpr (EUFExpr op args) = do f <- interpOp op+ interpApplyEUFExprs op f args++-- | Apply an interpretation of an operator to the interpretations of a sequence of arguments for it.+interpApplyEUFExprs :: ghost out -> OpTypes2SBV ins out -> EUFExprs ins -> InterpM (Type2SBV out)+interpApplyEUFExprs _ f EUFExprsNil = pure f+interpApplyEUFExprs out f (EUFExprsCons e es) = do f_app <- f <$> interpEUFExpr e+ interpApplyEUFExprs out f_app es++-- | Top-level call to interpret an t'EUFExpr' to an 'SBV' value+interpEUF :: EUFExpr a -> Type2SBV a+interpEUF = runInterpM . interpEUFExpr++----------------------------------------------------------------------+-- * Examples+----------------------------------------------------------------------++-- | Example EUF problem+--+-- > f (f (a) - f (b)) /= f (c), b >= a, a >= b + c, c >= 0+--+-- from <https://goto.ucsd.edu/~rjhala/classes/sp13/cse291/slides/lec-smt.markdown.pdf>+-- noting that @x >= y@ is the same as @not (x < y)@. We have:+--+-- >>> sat $ interpEUF example+-- Satisfiable. Model:+-- a = 996506182 :: Word32+-- b = 3298461113 :: Word32+-- c = 1445036292 :: Word32+-- <BLANKLINE>+-- f :: Word32 -> Word32+-- f 0 = 4188219399+-- f 1445036292 = 285239361+-- f 3298461113 = 4054018119+-- f 996506182 = 4054018119+-- f _ = 0+--+-- Note that the original example is unsatisfiable over integers. It is however satisfiable+-- over 32-bit words, hence the model above.+example :: EUFExpr Tp_Bool+example =+ applyOp Op_And (applyOp Op_Not (applyOp (Op_BVEq knownBVWidth)+ (applyOp f (applyOp f a - applyOp f b))+ (applyOp f c)))+ (applyOp Op_And (applyOp Op_Not (applyOp (Op_BVLt knownBVWidth) b a))+ (applyOp Op_And+ (applyOp Op_Not (applyOp (Op_BVLt knownBVWidth) a (b + c)))+ (applyOp Op_Not (applyOp (Op_BVLt knownBVWidth) c 0))))+ where+ f :: Op '[Tp_BV 32] (Tp_BV 32)+ f = mkUnintOp "f"++ a, b, c :: EUFExpr (Tp_BV 32)+ a = mkUnintExpr "a"+ b = mkUnintExpr "b"+ c = mkUnintExpr "c"++{- HLint ignore "Use camelCase" -}+{- HLint ignore "Eta reduce" -}
Documentation/SBV/Examples/Uninterpreted/Function.hs view
@@ -9,15 +9,18 @@ -- Demonstrates function counter-examples ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Uninterpreted.Function where import Data.SBV +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif -- | An uninterpreted function f :: SWord8 -> SWord8 -> SWord16
Documentation/SBV/Examples/Uninterpreted/Multiply.hs view
@@ -10,17 +10,19 @@ -- a simple two-bit multiplier. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Uninterpreted.Multiply where import Data.SBV +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif -- | The uninterpreted implementation of our 2x2 multiplier. We simply -- receive two 2-bit values, and return the high and the low bit of the@@ -47,12 +49,12 @@ -- >>> sat synthMul22 -- Satisfiable. Model: -- mul22_hi :: Bool -> Bool -> Bool -> Bool -> Bool--- mul22_hi True False False True = True--- mul22_hi True True False True = True -- mul22_hi False True True True = True+-- mul22_hi True True False True = True+-- mul22_hi True False True True = True+-- mul22_hi True False False True = True -- mul22_hi False True True False = True -- mul22_hi True True True False = True--- mul22_hi True False True True = True -- mul22_hi _ _ _ _ = False -- <BLANKLINE> -- mul22_lo :: Bool -> Bool -> Bool@@ -67,12 +69,12 @@ -- -- >>> :{ -- mul22_hi :: (SBool, SBool, SBool, SBool) -> SBool--- mul22_hi params = params `sElem` [ (sTrue, sFalse, sFalse, sTrue )--- , (sTrue, sTrue , sFalse, sTrue )--- , (sFalse, sTrue , sTrue , sTrue )--- , (sFalse, sTrue , sTrue , sFalse)--- , (sTrue , sTrue , sTrue , sFalse)--- , (sTrue , sFalse, sTrue , sTrue )+-- mul22_hi params = params `sElem` [ (sFalse, sTrue, sTrue, sTrue)+-- , (sTrue, sTrue, sFalse, sTrue)+-- , (sTrue, sFalse, sTrue, sTrue)+-- , (sTrue, sFalse, sFalse, sTrue)+-- , (sFalse, sTrue, sTrue, sFalse)+-- , (sTrue, sTrue, sTrue, sFalse) -- ] -- :} --@@ -82,11 +84,8 @@ -- Q.E.D. -- -- and rest assured that we have a correctly synthesized circuit!-synthMul22 :: Goal-synthMul22 = do a :: SWord8 <- sbvForall "a"- b :: SWord8 <- sbvForall "b"-- let lsb2 x = let [x1, x0] = reverse $ take 2 $ blastLE x- in (x1, x0)-- constrain $ mul22 (lsb2 a) (lsb2 b) .== lsb2 (a * b)+synthMul22 :: ConstraintSet+synthMul22 = constrain $ \(Forall (a :: SWord8)) (Forall b) -> mul22 (lsb2 a) (lsb2 b) .== lsb2 (a * b)+ where lsb2 x = case blastLE x of+ (x0 : x1 : _) -> (x1, x0)+ _ -> error "synthMul22: Can't get enough bits from x!"
Documentation/SBV/Examples/Uninterpreted/Shannon.hs view
@@ -14,7 +14,7 @@ module Documentation.SBV.Examples.Uninterpreted.Shannon where -import Data.SBV hiding (universal, existential)+import Data.SBV ----------------------------------------------------------------------------- -- * Boolean functions
Documentation/SBV/Examples/Uninterpreted/Sort.hs view
@@ -9,10 +9,7 @@ -- Demonstrates uninterpreted sorts, together with axioms. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -24,10 +21,10 @@ -- in the backend SMT solver. data Q --- | Make 'Q' an uinterpreted sort. This will automatically introduce the+-- | Make 'Q' an uninterpreted sort. This will automatically introduce the -- type 'SQ' into our environment, which is the symbolic version of the -- carrier type 'Q'.-mkUninterpretedSort ''Q+mkSymbolic [''Q] -- | Declare an uninterpreted function that works over Q's f :: SQ -> SQ@@ -39,13 +36,13 @@ -- -- >>> t1 -- Satisfiable. Model:--- x = Q!val!0 :: Q+-- x = Q_0 :: Q -- <BLANKLINE> -- f :: Q -> Q--- f _ = Q!val!1+-- f _ = Q_1 t1 :: IO SatResult t1 = sat $ do x <- free "x"- return $ f x ./= x+ pure $ f x ./= x -- | This is a variant on the first example, except we also add an axiom -- for the sort, stating that the domain 'Q' has only one element. In this case@@ -55,5 +52,5 @@ -- Unsatisfiable t2 :: IO SatResult t2 = sat $ do x <- free "x"- addAxiom "Q" ["(assert (forall ((x Q) (y Q)) (= x y)))"]- return $ f x ./= x+ constrain $ \(Forall a) (Forall b) -> a .== (b :: SQ)+ pure $ f x ./= x
Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs view
@@ -10,10 +10,8 @@ -- Thanks to Eric Seidel for the idea. ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -21,9 +19,10 @@ import Data.SBV +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif -- | A "list-like" data type, but one we plan to uninterpret at the SMT level. -- The actual shape is really immaterial for us.@@ -31,7 +30,7 @@ -- | Make 'L' into an uninterpreted sort, automatically introducing 'SL' -- as a synonym for 'SBV' 'L'.-mkUninterpretedSort ''L+mkSymbolic [''L] -- | An uninterpreted "classify" function. Really, we only care about -- the fact that such a function exists, not what it does.@@ -51,39 +50,39 @@ -- -- >>> allSat genLs -- Solution #1:--- l = L!val!2 :: L--- l0 = L!val!0 :: L--- l1 = L!val!1 :: L--- l2 = L!val!2 :: L+-- l = L_2 :: L+-- l0 = L_0 :: L+-- l1 = L_1 :: L+-- l2 = L_2 :: L -- <BLANKLINE> -- classify :: L -> Integer--- classify L!val!2 = 2--- classify L!val!1 = 1--- classify _ = 0+-- classify L_2 = 2+-- classify L_1 = 1+-- classify _ = 0 -- Solution #2:--- l = L!val!1 :: L--- l0 = L!val!0 :: L--- l1 = L!val!1 :: L--- l2 = L!val!2 :: L+-- l = L_1 :: L+-- l0 = L_0 :: L+-- l1 = L_1 :: L+-- l2 = L_2 :: L -- <BLANKLINE> -- classify :: L -> Integer--- classify L!val!2 = 2--- classify L!val!1 = 1--- classify _ = 0+-- classify L_2 = 2+-- classify L_1 = 1+-- classify _ = 0 -- Solution #3:--- l = L!val!0 :: L--- l0 = L!val!0 :: L--- l1 = L!val!1 :: L--- l2 = L!val!2 :: L+-- l = L_0 :: L+-- l0 = L_0 :: L+-- l1 = L_1 :: L+-- l2 = L_2 :: L -- <BLANKLINE> -- classify :: L -> Integer--- classify L!val!2 = 2--- classify L!val!1 = 1--- classify _ = 0+-- classify L_2 = 2+-- classify L_1 = 1+-- classify _ = 0 -- Found 3 different solutions. genLs :: Predicate genLs = do [l, l0, l1, l2] <- symbolics ["l", "l0", "l1", "l2"] constrain $ classify l0 .== 0 constrain $ classify l1 .== 1 constrain $ classify l2 .== 2- return $ l .== l0 .|| l .== l1 .|| l .== l2+ pure $ l .== l0 .|| l .== l1 .|| l .== l2
Documentation/SBV/Examples/WeakestPreconditions/Append.hs view
@@ -13,17 +13,19 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.WeakestPreconditions.Append where import Data.SBV-import Data.SBV.Control+import Data.SBV.Tools.WeakestPreconditions import Prelude hiding ((++)) import qualified Prelude as P@@ -31,42 +33,29 @@ import Data.SBV.List ((++)) import qualified Data.SBV.List as L -import Data.SBV.Tools.WeakestPreconditions- import GHC.Generics (Generic) -- * Program state --- | The state of the length program, paramaterized over the element type @a@-data AppS a = AppS { xs :: SList a -- ^ The first input list- , ys :: SList a -- ^ The second input list- , ts :: SList a -- ^ Temporary variable- , zs :: SList a -- ^ Output+-- | The state of the length program, parameterized over the element type @a@+data AppS a = AppS { xs :: a -- ^ The first input list+ , ys :: a -- ^ The second input list+ , ts :: a -- ^ Temporary variable+ , zs :: a -- ^ Output }- deriving (Generic, Mergeable)---- | The concrete counterpart of 'AppS'. Again, we can't simply use the duality between--- @SBV a@ and @a@ due to the difference between @SList a@ and @[a]@.-data AppC a = AppC [a] [a] [a] [a]---- | Show instance for 'AppS'. The above deriving clause would work just as well,--- but we want it to be a little prettier here, and hence the @OVERLAPS@ directive.-instance {-# OVERLAPS #-} (SymVal a, Show a) => Show (AppS a) where- show (AppS xs ys ts zs) = "{xs = " P.++ sh xs P.++ ", ys = " P.++ sh ys P.++ ", ts = " P.++ sh ts P.++ ", zs = " P.++ sh zs P.++ "}"- where sh v = maybe "<symbolic>" show (unliteral v)+ deriving (Generic, Mergeable, Traversable, Functor, Foldable) -- | Show instance, a bit more prettier than what would be derived:-instance Show a => Show (AppC a) where- show (AppC xs ys ts zs) = "{xs = " P.++ show xs P.++ ", ys = " P.++ show ys P.++ ", ts = " P.++ show ts P.++ ", zs = " P.++ show zs P.++ "}"+instance Show (f a) => Show (AppS (f a)) where+ show AppS{xs, ys, ts, zs} = "{xs = " P.++ show xs P.++ ", ys = " P.++ show ys P.++ ", ts = " P.++ show ts P.++ ", zs = " P.++ show zs P.++ "}" -- | 'Queriable' instance for the program state-instance Queriable IO (AppS Integer) (AppC Integer) where- create = AppS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_- project (AppS xs ys ts zs) = AppC <$> getValue xs <*> getValue ys <*> getValue ts <*> getValue zs- embed (AppC xs ys ts zs) = return $ AppS (literal xs) (literal ys) (literal ts) (literal zs)+instance Queriable IO (AppS (SList Integer)) where+ type QueryResult (AppS (SList Integer)) = AppS [Integer]+ create = AppS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_ -- | Helper type synonym-type A = AppS Integer+type A = AppS (SList Integer) -- * The algorithm @@ -100,7 +89,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeAppend :: Program A-imperativeAppend = Program { setup = return ()+imperativeAppend = Program { setup = pure () , precondition = const sTrue -- no precondition , program = algorithm , postcondition = postcondition@@ -120,5 +109,5 @@ -- >>> correctness -- Total correctness is established. -- Q.E.D.-correctness :: IO (ProofResult (AppC Integer))+correctness :: IO (ProofResult (AppS [Integer])) correctness = wpProveWith defaultWPCfg{wpVerbose=True} imperativeAppend
Documentation/SBV/Examples/WeakestPreconditions/Basics.hs view
@@ -11,29 +11,30 @@ -- an example. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.WeakestPreconditions.Basics where import Data.SBV-import Data.SBV.Control- import Data.SBV.Tools.WeakestPreconditions import GHC.Generics (Generic) +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV -- >>> import Data.SBV.Control -- >>> import Data.SBV.Tools.WeakestPreconditions+#endif -- * Program state @@ -41,17 +42,18 @@ data IncS a = IncS { x :: a -- ^ Input value , y :: a -- ^ Output }- deriving (Show, Generic, Mergeable, Functor, Foldable, Traversable)+ deriving (Show, Generic, Mergeable, Traversable, Functor, Foldable) --- | Show instance for 'IncS'. The above deriving clause would work just as well,+-- | Show instance for t'IncS'. The above deriving clause would work just as well, -- but we want it to be a little prettier here, and hence the @OVERLAPS@ directive. instance {-# OVERLAPS #-} (SymVal a, Show a) => Show (IncS (SBV a)) where show (IncS x y) = "{x = " ++ sh x ++ ", y = " ++ sh y ++ "}" where sh v = maybe "<symbolic>" show (unliteral v) --- | 'Fresh' instance for the program state-instance SymVal a => Fresh IO (IncS (SBV a)) where- fresh = IncS <$> freshVar_ <*> freshVar_+-- | 'Queriable instance for our state+instance Queriable IO (IncS SInteger) where+ type QueryResult (IncS SInteger) = IncS Integer+ create = IncS <$> freshVar_ <*> freshVar_ -- | Helper type synonym type I = IncS SInteger@@ -88,7 +90,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeInc :: Stmt I -> Stmt I -> Program I-imperativeInc before after = Program { setup = return ()+imperativeInc before after = Program { setup = pure () , precondition = pre , program = algorithm before after , postcondition = post
Documentation/SBV/Examples/WeakestPreconditions/Fib.hs view
@@ -12,49 +12,51 @@ -- and proper axioms to complete the proof. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.WeakestPreconditions.Fib where import Data.SBV-import Data.SBV.Control- import Data.SBV.Tools.WeakestPreconditions import GHC.Generics (Generic) +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV -- >>> import Data.SBV.Control -- >>> import Data.SBV.Tools.WeakestPreconditions+#endif -- * Program state --- | The state for the sum program, parameterized over a base type @a@.+-- | The state for the fibonacci program, parameterized over a base type @a@. data FibS a = FibS { n :: a -- ^ The input value , i :: a -- ^ Loop counter , k :: a -- ^ tracks @fib (i+1)@ , m :: a -- ^ tracks @fib i@ }- deriving (Show, Generic, Mergeable, Functor, Foldable, Traversable)+ deriving (Show, Generic, Mergeable, Traversable, Functor, Foldable) --- | Show instance for 'FibS'. The above deriving clause would work just as well,+-- | Show instance for t'FibS'. The above deriving clause would work just as well, -- but we want it to be a little prettier here, and hence the @OVERLAPS@ directive. instance {-# OVERLAPS #-} (SymVal a, Show a) => Show (FibS (SBV a)) where show (FibS n i k m) = "{n = " ++ sh n ++ ", i = " ++ sh i ++ ", k = " ++ sh k ++ ", m = " ++ sh m ++ "}" where sh v = maybe "<symbolic>" show (unliteral v) --- | 'Fresh' instance for the program state-instance SymVal a => Fresh IO (FibS (SBV a)) where- fresh = FibS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_+-- | 'Queriable instance for our state+instance Queriable IO (FibS SInteger) where+ type QueryResult (FibS SInteger) = FibS Integer+ create = FibS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_ -- | Helper type synonym type F = FibS SInteger@@ -113,18 +115,11 @@ -- -- As otherwise they would be concretely evaluated and -- would not be sent to the SMT solver!- x <- sInteger_ constrain $ x .== 0 .=> fib x .== 0 constrain $ x .== 1 .=> fib x .== 1 - -- The inductive case. Unfortunately; SBV does not support- -- adding quantified constraints in the query mode. So we- -- have to write this axiom directly in SMT-Lib. Note also how- -- carefully we've chosen this axiom to work with our proof!- addAxiom "fib_n" [ "(assert (forall ((x Int))"- , " (= (fib (+ x 2)) (+ (fib (+ x 1)) (fib x)))))"- ]+ constrain $ \(Forall n) -> fib (n+2) .== fib (n+1) + fib n -- | Precondition for our program: @n@ must be non-negative. pre :: F -> SBool
Documentation/SBV/Examples/WeakestPreconditions/GCD.hs view
@@ -14,20 +14,20 @@ -- specifications for WP proofs. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.WeakestPreconditions.GCD where import Data.SBV-import Data.SBV.Control- import Data.SBV.Tools.WeakestPreconditions import GHC.Generics (Generic)@@ -36,31 +36,33 @@ import Prelude hiding (gcd) import qualified Prelude as P (gcd) +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV -- >>> import Data.SBV.Control -- >>> import Data.SBV.Tools.WeakestPreconditions+#endif -- * Program state --- | The state for the sum program, parameterized over a base type @a@.+-- | The state for the GCD program, parameterized over a base type @a@. data GCDS a = GCDS { x :: a -- ^ First value , y :: a -- ^ Second value , i :: a -- ^ Copy of x to be modified , j :: a -- ^ Copy of y to be modified }- deriving (Show, Generic, Mergeable, Functor, Foldable, Traversable)+ deriving (Show, Generic, Mergeable, Traversable, Functor, Foldable) --- | Show instance for 'GCDS'. The above deriving clause would work just as well,+-- | Show instance for t'GCDS'. The above deriving clause would work just as well, -- but we want it to be a little prettier here, and hence the @OVERLAPS@ directive. instance {-# OVERLAPS #-} (SymVal a, Show a) => Show (GCDS (SBV a)) where show (GCDS x y i j) = "{x = " ++ sh x ++ ", y = " ++ sh y ++ ", i = " ++ sh i ++ ", j = " ++ sh j ++ "}" where sh v = maybe "<symbolic>" show (unliteral v) --- | 'Fresh' instance for the program state-instance SymVal a => Fresh IO (GCDS (SBV a)) where- fresh = GCDS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_+-- | 'Queriable instance for our state+instance Queriable IO (GCDS SInteger) where+ type QueryResult (GCDS SInteger) = GCDS Integer+ create = GCDS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_ -- | Helper type synonym type G = GCDS SInteger@@ -121,28 +123,9 @@ -- | Constraints and axioms we need to state explicitly to tell -- the SMT solver about our specification for GCD. axiomatizeGCD :: Symbolic ()-axiomatizeGCD = do -- Base case. Strictly speaking, we don't really need this case- -- here, but it declares the presence of gcd as an uninterpreted- -- function to SBV so it gets registered as such.- x <- sInteger_- constrain $ gcd x x .== x-- -- Unfortunately; SBV does not support adding quantified constraints- -- in the query mode. So we have to write this axiom directly in SMT-Lib.- -- Note also how carefully we've chosen these axioms to work with our proof!- -- Actually proving these is beyond the scope of our WP proof, but obviously- -- should be done in some other system. (Note that SMT solvers will have hard- -- time with the definition of GCD in general as the axiomatization requires- -- quantification and definition requires recursion.)- addAxiom "gcd_equal" [ "(assert (forall ((x Int))"- , " (=> (> x 0) (= (gcd x x) x))))"- ]- addAxiom "gcd_unequal1" [ "(assert (forall ((x Int) (y Int))"- , " (=> (and (> x 0) (> y 0)) (= (gcd (+ x y) y) (gcd x y)))))"- ]- addAxiom "gcd_unequal2" [ "(assert (forall ((x Int) (y Int))"- , " (=> (and (> x 0) (> y 0)) (= (gcd x (+ y x)) (gcd x y)))))"- ]+axiomatizeGCD = do constrain $ \(Forall x) -> x .> 0 .=> gcd x x .== x+ constrain $ \(Forall x) (Forall y) -> x .> 0 .&& y .> 0 .=> gcd (x+y) y .== gcd x y+ constrain $ \(Forall x) (Forall y) -> x .> 0 .&& y .> 0 .=> gcd x (y+x) .== gcd x y -- | Precondition for our program: @x@ and @y@ must be strictly positive pre :: G -> SBool
Documentation/SBV/Examples/WeakestPreconditions/IntDiv.hs view
@@ -17,14 +17,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.WeakestPreconditions.IntDiv where import Data.SBV-import Data.SBV.Control- import Data.SBV.Tools.WeakestPreconditions import GHC.Generics (Generic)@@ -37,17 +36,18 @@ , q :: a -- ^ The quotient , r :: a -- ^ The remainder }- deriving (Show, Generic, Mergeable, Functor, Foldable, Traversable)+ deriving (Show, Generic, Mergeable, Traversable, Functor, Foldable) --- | Show instance for 'DivS'. The above deriving clause would work just as well,+-- | Show instance for t'DivS'. The above deriving clause would work just as well, -- but we want it to be a little prettier here, and hence the @OVERLAPS@ directive. instance {-# OVERLAPS #-} (SymVal a, Show a) => Show (DivS (SBV a)) where show (DivS x y q r) = "{x = " ++ sh x ++ ", y = " ++ sh y ++ ", q = " ++ sh q ++ ", r = " ++ sh r ++ "}" where sh v = maybe "<symbolic>" show (unliteral v) --- | 'Fresh' instance for the program state-instance SymVal a => Fresh IO (DivS (SBV a)) where- fresh = DivS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_+-- | 'Queriable' instance for the program state+instance SymVal a => Queriable IO (DivS (SBV a)) where+ type QueryResult (DivS (SBV a)) = DivS a+ create = DivS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_ -- | Helper type synonym type D = DivS SInteger@@ -66,7 +66,7 @@ -- -- Note that we need to explicitly annotate each loop with its invariant and the termination -- measure. For convenience, we take those two as parameters for simplicity.-algorithm :: Invariant D -> Maybe (Measure D) -> Stmt D+algorithm :: Invariant D -> Maybe (WPMeasure D) -> Stmt D algorithm inv msr = Seq [ assert "x, y >= 0" $ \DivS{x, y} -> x .>= 0 .&& y .>= 0 , Assign $ \st@DivS{x} -> st{r = x, q = 0} , While "y <= r"@@ -92,8 +92,8 @@ noChange = [stable "x" x, stable "y" y] -- | A program is the algorithm, together with its pre- and post-conditions.-imperativeDiv :: Invariant D -> Maybe (Measure D) -> Program D-imperativeDiv inv msr = Program { setup = return ()+imperativeDiv :: Invariant D -> Maybe (WPMeasure D) -> Program D+imperativeDiv inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post@@ -110,7 +110,7 @@ -- | The measure. In each iteration @r@ decreases, but always remains positive. -- Since @y@ is strictly positive, @r@ can serve as a measure for the loop.-measure :: Measure D+measure :: WPMeasure D measure DivS{r} = [r] -- | Check that the program terminates and the post condition holds. We have:
Documentation/SBV/Examples/WeakestPreconditions/IntSqrt.hs view
@@ -19,14 +19,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.WeakestPreconditions.IntSqrt where import Data.SBV-import Data.SBV.Control- import Data.SBV.Tools.WeakestPreconditions import GHC.Generics (Generic)@@ -41,17 +40,18 @@ , i :: a -- ^ Successive squares, as the sum of j's , j :: a -- ^ Successive odds }- deriving (Show, Generic, Mergeable, Functor, Foldable, Traversable)+ deriving (Show, Generic, Mergeable, Traversable, Functor, Foldable) --- | Show instance for 'SqrtS'. The above deriving clause would work just as well,+-- | Show instance for t'SqrtS'. The above deriving clause would work just as well, -- but we want it to be a little prettier here, and hence the @OVERLAPS@ directive. instance {-# OVERLAPS #-} (SymVal a, Show a) => Show (SqrtS (SBV a)) where show (SqrtS x sqrt i j) = "{x = " ++ sh x ++ ", sqrt = " ++ sh sqrt ++ ", i = " ++ sh i ++ ", j = " ++ sh j ++ "}" where sh v = maybe "<symbolic>" show (unliteral v) --- | 'Fresh' instance for the program state-instance SymVal a => Fresh IO (SqrtS (SBV a)) where- fresh = SqrtS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_+-- | 'Queriable instance for the program state+instance SymVal a => Queriable IO (SqrtS (SBV a)) where+ type QueryResult (SqrtS (SBV a)) = SqrtS a+ create = SqrtS <$> freshVar_ <*> freshVar_ <*> freshVar_ <*> freshVar_ -- | Helper type synonym type S = SqrtS SInteger@@ -72,7 +72,7 @@ -- -- Note that we need to explicitly annotate each loop with its invariant and the termination -- measure. For convenience, we take those two as parameters for simplicity.-algorithm :: Invariant S -> Maybe (Measure S) -> Stmt S+algorithm :: Invariant S -> Maybe (WPMeasure S) -> Stmt S algorithm inv msr = Seq [ assert "x >= 0" $ \SqrtS{x} -> x .>= 0 , Assign $ \st -> st{sqrt = 0, i = 1, j = 1} , While "i <= x"@@ -102,8 +102,8 @@ noChange = [stable "x" x] -- | A program is the algorithm, together with its pre- and post-conditions.-imperativeSqrt :: Invariant S -> Maybe (Measure S) -> Program S-imperativeSqrt inv msr = Program { setup = return ()+imperativeSqrt :: Invariant S -> Maybe (WPMeasure S) -> Program S+imperativeSqrt inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post@@ -123,7 +123,7 @@ where sq n = n * n -- | The measure. In each iteration @i@ strictly increases, thus reducing the differential @x - i@-measure :: Measure S+measure :: WPMeasure S measure SqrtS{x, i} = [x - i] -- | Check that the program terminates and the post condition holds. We have:
Documentation/SBV/Examples/WeakestPreconditions/Length.hs view
@@ -16,55 +16,42 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.WeakestPreconditions.Length where import Data.SBV-import Data.SBV.Control+import Data.SBV.Tools.WeakestPreconditions import qualified Data.SBV.List as L -import Data.SBV.Tools.WeakestPreconditions- import GHC.Generics (Generic) -- * Program state --- | The state of the length program, paramaterized over the element type @a@-data LenS a = LenS { xs :: SList a -- ^ The input list- , ys :: SList a -- ^ Copy of input- , l :: SInteger -- ^ Running length- }- deriving (Generic, Mergeable)---- | The concrete counterpart to 'LenS'. Note that we can no longer use the duality--- between @SBV a@ and @a@ as in other examples and just use one datatype for both.--- This is because @SList a@ and @[a]@ are fundamentally different types. This can--- be a bit confusing at first, but the point is that it is the list that is symbolic--- in case of an @SList a@, not that we have a concrete list with symbolic elements--- in it. Subtle difference, but it is important to keep these two separate.-data LenC a = LenC [a] [a] Integer+-- | The state of the length program, parameterized over the element type @a@+data LenS a b = LenS { xs :: a -- ^ The input list+ , ys :: a -- ^ Copy of input+ , l :: b -- ^ Running length+ }+ deriving (Generic, Mergeable) -- | Show instance: A simplified version of what would otherwise be generated.-instance (SymVal a, Show a) => Show (LenS a) where- show (LenS xs ys l) = "{xs = " ++ sh xs ++ ", ys = " ++ sh ys ++ ", l = " ++ sh l ++ "}"- where sh v = maybe "<symbolic>" show (unliteral v)+instance (SymVal a, Show (f a), Show b) => Show (LenS (f a) b) where+ show LenS{xs, ys, l} = "{xs = " ++ show xs ++ ", ys = " ++ show ys ++ ", l = " ++ show l ++ "}" --- | Show instance: Similarly, we want to be a bit more concise here.-instance Show a => Show (LenC a) where- show (LenC xs ys l) = "{xs = " ++ show xs ++ ", ys = " ++ show ys ++ ", l = " ++ show l ++ "}"+-- | Injection/projection from concrete and symbolic values.+instance Queriable IO (LenS (SList Integer) SInteger) where+ type QueryResult (LenS (SList Integer) SInteger) = LenS [Integer] Integer --- | We have to write the bijection between 'LenS' and 'LenC' explicitly. Luckily, the--- definition is more or less boilerplate.-instance Queriable IO (LenS Integer) (LenC Integer) where- create = LenS <$> freshVar_ <*> freshVar_ <*> freshVar_- project (LenS xs ys l) = LenC <$> getValue xs <*> getValue ys <*> getValue l- embed (LenC xs ys l) = return $ LenS (literal xs) (literal ys) (literal l)+ create = LenS <$> freshVar_ <*> freshVar_ <*> freshVar_+ project (LenS xs ys l) = LenS <$> project xs <*> project ys <*> project l+ embed (LenS xs ys l) = LenS <$> embed xs <*> embed ys <*> embed l -- | Helper type synonym-type S = LenS Integer+type S = LenS (SList Integer) SInteger -- * The algorithm @@ -80,7 +67,7 @@ -- -- Note that we need to explicitly annotate each loop with its invariant and the termination -- measure. For convenience, we take those two as parameters, so we can experiment later.-algorithm :: Invariant S -> Maybe (Measure S) -> Stmt S+algorithm :: Invariant S -> Maybe (WPMeasure S) -> Stmt S algorithm inv msr = Seq [ Assign $ \st@LenS{xs} -> st{ys = xs, l = 0} , While "! (null ys)" inv@@ -104,8 +91,8 @@ noChange = [stable "xs" xs] -- | A program is the algorithm, together with its pre- and post-conditions.-imperativeLength :: Invariant S -> Maybe (Measure S) -> Program S-imperativeLength inv msr = Program { setup = return ()+imperativeLength :: Invariant S -> Maybe (WPMeasure S) -> Program S+imperativeLength inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post@@ -118,7 +105,7 @@ invariant LenS{xs, ys, l} = L.length xs .== l + L.length ys -- | The measure is obviously the length of @ys@, as we peel elements off of it through the loop.-measure :: Measure S+measure :: WPMeasure S measure LenS{ys} = [L.length ys] -- * Correctness
Documentation/SBV/Examples/WeakestPreconditions/Sum.hs view
@@ -11,27 +11,28 @@ -- different versions lead to proofs and failures. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.WeakestPreconditions.Sum where import Data.SBV-import Data.SBV.Control- import Data.SBV.Tools.WeakestPreconditions import GHC.Generics (Generic) +#ifdef DOCTEST -- $setup--- >>> -- For doctest purposes only: -- >>> import Data.SBV+#endif -- * Program state @@ -40,17 +41,18 @@ , i :: a -- ^ Loop counter , s :: a -- ^ Running sum }- deriving (Show, Generic, Mergeable, Functor, Foldable, Traversable)+ deriving (Show, Generic, Mergeable, Traversable, Functor, Foldable) --- | Show instance for 'SumS'. The above deriving clause would work just as well,+-- | Show instance for t'SumS'. The above deriving clause would work just as well, -- but we want it to be a little prettier here, and hence the @OVERLAPS@ directive. instance {-# OVERLAPS #-} (SymVal a, Show a) => Show (SumS (SBV a)) where show (SumS n i s) = "{n = " ++ sh n ++ ", i = " ++ sh i ++ ", s = " ++ sh s ++ "}" where sh v = maybe "<symbolic>" show (unliteral v) --- | 'Fresh' instance for the program state-instance SymVal a => Fresh IO (SumS (SBV a)) where- fresh = SumS <$> freshVar_ <*> freshVar_ <*> freshVar_+-- | 'Queriable' instance for our state+instance Queriable IO (SumS SInteger) where+ type QueryResult (SumS SInteger) = SumS Integer+ create = SumS <$> freshVar_ <*> freshVar_ <*> freshVar_ -- | Helper type synonym type S = SumS SInteger@@ -69,7 +71,7 @@ -- -- Note that we need to explicitly annotate each loop with its invariant and the termination -- measure. For convenience, we take those two as parameters, so we can experiment later.-algorithm :: Invariant S -> Maybe (Measure S) -> Stmt S+algorithm :: Invariant S -> Maybe (WPMeasure S) -> Stmt S algorithm inv msr = Seq [ Assign $ \st -> st{i = 0, s = 0} , assert "n >= 0" $ \SumS{n} -> n .>= 0 , While "i < n"@@ -97,8 +99,8 @@ noChange = [stable "n" n] -- | A program is the algorithm, together with its pre- and post-conditions.-imperativeSum :: Invariant S -> Maybe (Measure S) -> Program S-imperativeSum inv msr = Program { setup = return ()+imperativeSum :: Invariant S -> Maybe (WPMeasure S) -> Program S+imperativeSum inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post@@ -141,7 +143,7 @@ -- >>> correctness invariant (Just measure) -- Total correctness is established. -- Q.E.D.-correctness :: Invariant S -> Maybe (Measure S) -> IO (ProofResult (SumS Integer))+correctness :: Invariant S -> Maybe (WPMeasure S) -> IO (ProofResult (SumS Integer)) correctness inv msr = wpProveWith defaultWPCfg{wpVerbose=True} (imperativeSum inv msr) -- * Example proof attempts@@ -182,17 +184,17 @@ ================================== Postcondition fails: Start: SumS {n = 0, i = 0, s = 0}- End : SumS {n = 0, i = 0, s = -1}+ End : SumS {n = 0, i = 0, s = 1} In this case, we are told that the end state does not establish the-post-condition. Indeed when @n=0@, we would expect @s=0@, not @s=-1@.+post-condition. Indeed when @n=0@, we would expect @s=0@, not @s=1@. The natural question to ask is how did SBV come up with this unexpected state at the end of the program run? If you think about the program execution, indeed this state is unreachable: We know that @s@ represents the sum of all numbers up to @i@, so if @i=0@, we would expect @s@ to be @0@. Our invariant is clearly an overapproximation of the reachable space, and SBV is telling us that we need to constrain and outlaw-the state @{n = 0, i = 0, s = -1}@. Clearly, the invariant has to state something+the state @{n = 0, i = 0, s = 1}@. Clearly, the invariant has to state something about the relationship between @i@ and @s@, which we are missing in this case. == Failing to maintain the invariant@@ -205,8 +207,8 @@ Following proof obligation failed: ================================== Invariant for loop "i < n" is not maintained by the body:- Before: SumS {n = 2, i = 1, s = 1}- After : SumS {n = 2, i = 2, s = 3}+ Before: SumS {n = 3, i = 1, s = 1}+ After : SumS {n = 3, i = 2, s = 3} Here, we posed the extra incorrect invariant that @s <= i@ must be maintained, and SBV found us a reachable state that violates the invariant. The /before/ state indeed satisfies @s <= i@, but the /after/ state does not. Note that the proof fails in this case not because the program@@ -217,13 +219,13 @@ The termination measure must always be non-negative: >>> let invariant SumS{n, i, s} = s .== (i*(i+1)) `sDiv` 2 .&& i .<= n->>> let measure SumS{n, i} = [- i]+>>> let measure SumS{n, i} = [1-i] >>> void $ correctness invariant (Just measure) Following proof obligation failed: ================================== Measure for loop "i < n" is negative:- State : SumS {n = 2, i = 1, s = 1}- Measure: -1+ State : SumS {n = 7, i = 6, s = 21}+ Measure: -5 The failure is pretty obvious in this case: Measure produces a negative value. @@ -237,12 +239,11 @@ Following proof obligation failed: ================================== Measure for loop "i < n" does not decrease:- Before : SumS {n = 1, i = 0, s = 0}+ Before : SumS {n = 1, i = -1, s = 0}+ Measure: 0+ After : SumS {n = 1, i = 0, 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 a counterexample where @i@ is-negative is also possible for this failure, as the SMT solver will find a counter-example to induction, not-necessarily a reachable state. Obviously, all such failures need to be addressed for the full proof.+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.) -}
INSTALL view
@@ -4,7 +4,7 @@ cabal install sbv SBV relies on an external SMT solver to be installed. We currently support-ABC, Boolector, Bitwuzla, CVC4, CVC5, MathSAT, Yices, and Z3. We recommend installing the+ABC, Boolector, Bitwuzla, CVC4, CVC5, DReal, MathSAT, OpenSMT, Yices, and Z3. We recommend installing the freely available z3 SMT solver from Microsoft, the default solver used by SBV. You can get it from <http://github.com/Z3Prover/z3>.
LICENSE view
@@ -1,6 +1,6 @@ SBV: SMT Based Verification in Haskell -Copyright (c) 2010-2022, Levent Erkok (erkokl@gmail.com)+Copyright (c) 2010-2026, Levent Erkok (erkokl@gmail.com) All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,7 +1,285 @@-## SBV: SMT Based Verification in Haskell+# SBV: SMT Based Verification in Haskell -[](https://github.com/LeventErkok/sbv/actions/workflows/haskell-ci.yml)+[](https://github.com/LeventErkok/sbv/actions/workflows/ci.yml) -On Hackage: http://hackage.haskell.org/package/sbv+***Express properties about Haskell programs and automatically prove them using SMT solvers.*** -Please see: http://leventerkok.github.io/sbv/+[Hackage](http://hackage.haskell.org/package/sbv) | [Release Notes](http://github.com/LeventErkok/sbv/tree/master/CHANGES.md) | [Documentation](http://hackage.haskell.org/package/sbv/docs/Data-SBV.html)++SBV provides symbolic versions of Haskell types. Programs written with these types can be automatically verified, checked for satisfiability, optimized, or compiled to C — all via SMT solvers.++## SBV in 5 Minutes++Fire up GHCi with SBV:++```+$ cabal repl --build-depends sbv+```++For unbounded integers, `x + 1 .> x` is always true:++```haskell+ghci> :m Data.SBV+ghci> prove $ \x -> x + 1 .> (x :: SInteger)+Q.E.D.+```++But with machine arithmetic, overflow lurks:++```haskell+ghci> prove $ \x -> x + 1 .> (x :: SInt8)+Falsifiable. Counter-example:+ s0 = 127 :: Int8+```++IEEE-754 floats break reflexivity of equality:++```haskell+ghci> prove $ \x -> (x :: SFloat) .== x+Falsifiable. Counter-example:+ s0 = NaN :: Float+```++What's the multiplicative inverse of 3 modulo 256?++```haskell+ghci> sat $ \x -> x * 3 .== (1 :: SWord8)+Satisfiable. Model:+ s0 = 171 :: Word8+```++Use quantifiers for named results:++```haskell+ghci> sat $ skolemize $ \(Exists @"x" x) (Exists @"y" y) -> x * y .== (96::SInteger) .&& x + y .== 28+Satisfiable. Model:+ x = 24 :: Integer+ y = 4 :: Integer+```++Optimize a cost function subject to constraints:++```haskell+ghci> :{+optimize Lexicographic $ do x <- sInteger "x"+ y <- sInteger "y"+ constrain $ x + y .== 20+ constrain $ x .>= 5+ constrain $ y .>= 5+ minimize "cost" $ x * y+:}+Optimal in an extension field:+ x = 5 :: Integer+ y = 15 :: Integer+ cost = 75 :: Integer+```++For inductive proofs and equational reasoning, SBV includes a theorem prover:++```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+```++```+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.+Functions proven terminating: sbv.reverse+[Proven] revApp :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool+```++## Features++**Symbolic types** — Booleans, signed/unsigned integers (8/16/32/64-bit and arbitrary-width), unbounded integers, reals, rationals, IEEE-754 floats, characters, strings, lists, tuples, sums, optionals, sets, enumerations, algebraic data types, and uninterpreted sorts.++**Verification** — `prove`/`sat`/`allSat` for property checking and model finding, `safe`/`sAssert` for assertion verification, `dsat`/`dprove` for delta-satisfiability, and QuickCheck integration.++**Optimization** — Minimize/maximize cost functions subject to constraints via `optimize`/`maximize`/`minimize`, with support for lexicographic, independent, and Pareto objectives.++**Quantifiers and functions** — Universal and existential quantifiers (including alternating), with skolemization for named bindings. Define SMT-level functions directly from Haskell via `smtFunction`, including recursive and mutually recursive definitions with automatic termination checking.++**Theorem proving (TP)** — Semi-automated inductive proofs (including strong induction) with equational reasoning chains. Includes termination checking, recursive and mutually recursive definitions, productive (co-recursive) functions, and user-defined measures.++**Code generation** — Compile symbolic programs to C as straight-line programs or libraries (`compileToC`, `compileToCLib`), and generate test vectors (`genTest`).++**SMT interaction** — Incremental mode via `runSMT`/`query` for programmatic solver interaction with a high-level typed API. Run multiple solvers simultaneously with `proveWithAny`/`proveWithAll`.++## Algebraic Data Types++User-defined algebraic data types — including enumerations, recursive, and parametric types — are supported via `mkSymbolic`, with pattern matching via `sCase` (and its proof counterpart `pCase`):++```haskell+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++import Data.SBV++data Expr a = Val a+ | Add (Expr a) (Expr a)+ | Mul (Expr a) (Expr a)+ deriving Show++-- Make Expr symbolically available, named SExpr+mkSymbolic [''Expr]++eval :: SymVal a => (SBV a -> SBV a -> SBV a) -> (SBV a -> SBV a -> SBV a) -> SBV (Expr a) -> SBV a+eval add mul = smtFunction "eval" $ \e ->+ [sCase| e of+ Val v -> v+ Add x y -> eval add mul x `add` eval add mul y+ Mul x y -> eval add mul x `mul` eval add mul y+ |]+```++The `sCase` construct supports nested pattern matching, as-patterns, guards, and wildcards, making programming with algebraic data types natural. Plain `case` expressions inside `sCase` are automatically treated as symbolic case-splits. The `pCase` variant provides the same features for proof case-splits in the theorem proving context.++## Supported SMT Solvers++SBV communicates with solvers via the standard SMT-Lib interface:++| Solver | From | | Solver | From |+|--------|------|-|--------|------|+| [ABC](http://www.eecs.berkeley.edu/~alanmi/abc) | Berkeley | | [DReal](http://dreal.github.io/) | CMU |+| [Bitwuzla](http://bitwuzla.github.io/) | Stanford | | [MathSAT](http://mathsat.fbk.eu/) | FBK / Trento |+| [Boolector](http://boolector.github.io/) | JKU | | [OpenSMT](http://verify.inf.usi.ch/opensmt) | USI |+| [CVC4](http://cvc4.github.io/) | Stanford / Iowa | | [Yices](http://github.com/SRI-CSL/yices2) | SRI |+| [CVC5](http://cvc5.github.io/) | Stanford / Iowa | | [Z3](http://github.com/Z3Prover/z3/wiki) | Microsoft |++**Z3** is the default solver. Use `proveWith`, `satWith`, etc. to select a different one (e.g., `proveWith cvc5`). See [tested versions](http://github.com/LeventErkok/sbv/blob/master/SMTSolverVersions.md) for details. Other SMT-Lib compatible solvers can be hooked up with minimal effort — get in touch if you'd like to use one not listed here.++## A Selection of Examples++SBV ships with many worked examples. Here are some highlights:++| Example | Description |+|---------|-------------|+| [Sudoku](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-Puzzles-Sudoku.html) | Solve Sudoku puzzles using SMT constraints |+| [N-Queens](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-Puzzles-NQueens.html) | Solve the N-Queens placement puzzle |+| [SEND + MORE = MONEY](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-Puzzles-SendMoreMoney.html) | The classic cryptarithmetic puzzle |+| [Fish/Zebra](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-Puzzles-Fish.html) | Einstein's logic puzzle |+| [SQL Injection](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-Strings-SQLInjection.html) | Find inputs that cause SQL injection vulnerabilities |+| [Regex Crossword](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-Strings-RegexCrossword.html) | Solve regex crossword puzzles |+| [BitTricks](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-BitPrecise-BitTricks.html) | Verify bit-manipulation tricks from Stanford's bithacks collection |+| [Legato multiplier](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-BitPrecise-Legato.html) | Correctness proof of Legato's 8-bit multiplier |+| [Prefix sum](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-BitPrecise-PrefixSum.html) | Ladner-Fischer prefix-sum implementation proof |+| [AES](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-Crypto-AES.html) | AES encryption with C code generation |+| [CRC](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-CodeGeneration-CRC_USB5.html) | Symbolic CRC computation with C code generation |+| [Sqrt2 irrational](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-Sqrt2IsIrrational.html) | Prove that the square root of 2 is irrational |+| [Sorting](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-InsertionSort.html) | Prove [insertion sort](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-InsertionSort.html), [merge sort](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-MergeSort.html), and [quick sort](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-QuickSort.html) correct |+| [Kadane](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-Kadane.html) | Prove Kadane's maximum segment-sum algorithm correct |+| [McCarthy91](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-McCarthy91.html) | Prove McCarthy's 91 function meets its specification |+| [Binary search](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-BinarySearch.html) | Prove binary search correct |+| [Collatz](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-Collatz.html) | Explore properties of the Collatz sequence |+| [Infinitely many primes](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-Primes.html) | Prove there are infinitely many primes |+| [Tautology checker](http://hackage.haskell.org/package/sbv/docs/Documentation-SBV-Examples-TP-TautologyChecker.html) | A verified BDD-style tautology checker |++Browse the full collection in `Documentation.SBV.Examples` [on Hackage](http://hackage.haskell.org/package/sbv).++## License++SBV is distributed under the [BSD3](http://en.wikipedia.org/wiki/BSD_licenses) license. See [COPYRIGHT](http://github.com/LeventErkok/sbv/tree/master/COPYRIGHT) and [LICENSE](http://github.com/LeventErkok/sbv/tree/master/LICENSE) for details.++Please report bugs and feature requests at the [GitHub issue tracker](http://github.com/LeventErkok/sbv/issues).++## Thanks++The following people made major contributions to SBV, by developing new features and contributing to the design in significant ways: Joel Burget, Brian Huffman, Brian Schroeder, and Jeffrey Young.++The following people reported bugs, provided comments/feedback, or contributed to the development of SBV in various ways:+Andreas Abel,+Ara Adkins,+Andrew Anderson,+Kanishka Azimi,+Markus Barenhoff,+Reid Barton,+Ben Blaxill,+Ian Blumenfeld,+Guillaume Bouchard,+Martin Brain,+Ian Calvert,+Oliver Charles,+Christian Conkle,+Matthew Danish,+Iavor Diatchki,+Alex Dixon,+Robert Dockins,+Thomas DuBuisson,+Trevor Elliott,+Gergő Érdi,+John Erickson,+Richard Fergie,+Adam Foltzer,+Joshua Gancher,+Remy Goldschmidt,+Jan Grant,+Brad Hardy,+Tom Hawkins,+Greg Horn,+Jan Hrcek,+Georges-Axel Jaloyan,+Anders Kaseorg,+Tom Sydney Kerckhove,+Lars Kuhtz,+Piërre van de Laar,+Pablo Lamela,+Ken Friis Larsen,+Andrew Lelechenko,+Joe Leslie-Hurd,+Nick Lewchenko,+Brett Letner,+Sirui Lu,+Georgy Lukyanov,+Martin Lundfall,+Daniel Matichuk,+John Matthews,+Curran McConnell,+Philipp Meyer,+Fabian Mitterwallner,+Joshua Moerman,+Matt Parker,+Jan Path,+Matt Peddie,+Lucas Peña,+Matthew Pickering,+Lee Pike,+Gleb Popov,+Rohit Ramesh,+Geoffrey Ramseyer,+Blake C. Rawlings,+Jaro Reinders,+Stephan Renatus,+Dan Rosén,+Ryan Scott,+Eric Seidel,+Austin Seipp,+Andrés Sicard-Ramírez,+Don Stewart,+Greg Sullivan,+Josef Svenningsson,+George Thomas,+May Torrence,+Daniel Wagner,+Sean Weaver,+Robin Webbers,+Eddy Westbrook,+Nis Wegmann,+Jared Ziegler,+and Marco Zocca.++Thanks!
SBVBenchSuite/BenchSuite/Bench/Bench.hs view
@@ -10,7 +10,7 @@ -- Assessing the overhead of calling solving examples via sbv vs individual solvers ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}@@ -44,7 +44,7 @@ -- | The type of the problem to benchmark. This allows us to operate on Runners -- as values themselves yet still have a unified interface with gauge.-data Problem = forall a . U.Provable a => Problem a+data Problem = forall a . (U.Provable a, U.Satisfiable a) => Problem a -- | Similarly to Problem, BenchResult is boilerplate for a nice api data BenchResult = forall a . (Show a, NFData a) => BenchResult a@@ -80,14 +80,14 @@ -- | Set the runner function runner :: (Show c, NFData c) =>- (forall a. U.Provable a => U.SMTConfig -> a -> IO c) -> Runner -> Runner+ (forall a. (U.Provable a, U.Satisfiable a) => U.SMTConfig -> a -> IO c) -> Runner -> Runner runner r' (Runner r@RunnerI{}) = Runner $ r{runI = toRun r'} runner r' (RunnerGroup rs) = RunnerGroup $ runner r' <$> rs runner _ x = x {-# INLINE runner #-} toRun :: (Show c, NFData c) =>- (forall a. U.Provable a => U.SMTConfig -> a -> IO c)+ (forall a. (U.Provable a, U.Satisfiable a) => U.SMTConfig -> a -> IO c) -> U.SMTConfig -> Problem -> IO BenchResult@@ -133,7 +133,7 @@ -- | This is just a wrapper around the RunnerI constructor and serves as the main -- entry point to make a runner for a user in case they need something custom. run' :: (NFData b, Show b) =>- (forall a. U.Provable a => U.SMTConfig -> a -> IO b)+ (forall a. (U.Provable a, U.Satisfiable a) => U.SMTConfig -> a -> IO b) -> U.SMTConfig -> String -> Problem@@ -143,14 +143,14 @@ {-# INLINE run' #-} -- | Convenience function for creating benchmarks that exposes a configuration-runWith :: U.Provable a => U.SMTConfig -> String -> a -> Runner+runWith :: (U.Provable a, U.Satisfiable a) => U.SMTConfig -> String -> a -> Runner runWith c d p = run' U.satWith c d (Problem p) {-# INLINE runWith #-} -- | Main entry point for simple benchmarks. See 'mkRunner'' or 'mkRunnerWith' -- for versions of this function that allows custom inputs. If you have some use -- case that is not considered then you can simply overload the record fields.-run :: U.Provable a => String -> a -> Runner+run :: (U.Provable a, U.Satisfiable a) => String -> a -> Runner run d p = runWith U.z3 d p `using` runner U.satWith {-# INLINE run #-} @@ -180,8 +180,8 @@ -- | Orphaned instances just for benchmarking instance NFData U.AllSatResult where- rnf (U.AllSatResult a b c d results) =- rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rwhnf results+ rnf (U.AllSatResult a b c results) =+ rnf a `seq` rnf b `seq` rnf c `seq` rwhnf results -- | Unwrap the existential type to make gauge happy instance NFData BenchResult where rnf (BenchResult a) = rnf a
− SBVBenchSuite/BenchSuite/BitPrecise/MultMask.hs
@@ -1,31 +0,0 @@--------------------------------------------------------------------------------- |--- Module : BenchSuite.BitPrecise.MultMask--- Copyright : (c) Jeffrey Young--- Levent Erkok--- License : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Bench suite for Documentation.SBV.Examples.BitPrecise.MultMask--------------------------------------------------------------------------------{-# OPTIONS_GHC -Wall -Werror #-}--module BenchSuite.BitPrecise.MultMask(benchmarks) where--import BenchSuite.Bench.Bench as B--import Data.SBV---- benchmark suite-benchmarks :: Runner-benchmarks = rGroup- [ B.runWith conf "MultMask" find- ]- where find = do mask <- sbvExists "mask"- mult <- sbvExists "mult"- inp <- sbvForall "inp"- let res = (mask .&. inp) * (mult :: SWord64)- solve [inp `sExtractBits` [7, 15 .. 63] .== res `sExtractBits` [56 .. 63]]- conf = z3{printBase=16, satCmd = "(check-sat-using (and-then simplify smtfd))"}
SBVBenchSuite/BenchSuite/CodeGeneration/Uninterpreted.hs view
@@ -26,3 +26,5 @@ , runIO "CodeGen" genCCode ] where testLeft = \x y -> tstShiftLeft x y 0 .== x + y++{- HLint ignore module "Redundant lambda" -}
SBVBenchSuite/BenchSuite/Crypto/AES.hs view
@@ -33,3 +33,5 @@ , runIO "CodeGen.AES128Lib" cgAES128Library ] where inverseGFPrf = \x -> x ./= 0 .=> x `gf28Mult` gf28Inverse x .== 1++{- HLint ignore module "Redundant lambda" -}
− SBVBenchSuite/BenchSuite/Existentials/CRCPolynomial.hs
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Module : BenchSuite.Existentials.CRCPolynomial--- Copyright : (c) Jeffrey Young--- Levent Erkok--- License : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Bench suite for Documentation.SBV.Examples.Existentials.CRCPolynomial--------------------------------------------------------------------------------{-# OPTIONS_GHC -Wall -Werror #-}--module BenchSuite.Existentials.CRCPolynomial(benchmarks) where--import Documentation.SBV.Examples.Existentials.CRCPolynomial--import BenchSuite.Bench.Bench---- benchmark suite-benchmarks :: Runner-benchmarks = runIO "FindPolynomials" findHD4Polynomials
SBVBenchSuite/BenchSuite/Existentials/Diophantine.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Existentials.Diophantine ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Existentials.Diophantine(benchmarks) where
− SBVBenchSuite/BenchSuite/Lists/Nested.hs
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- Module : BenchSuite.Lists.Nested--- Copyright : (c) Jeffrey Young--- Levent Erkok--- License : BSD3--- Maintainer: erkokl@gmail.com--- Stability : experimental------ Bench suite for Documentation.SBV.Examples.Lists.Nested--------------------------------------------------------------------------------{-# OPTIONS_GHC -Wall -Werror #-}--module BenchSuite.Lists.Nested(benchmarks) where--import Documentation.SBV.Examples.Lists.Nested--import BenchSuite.Bench.Bench---- benchmark suite-benchmarks :: Runner-benchmarks = rGroup- [ runIO "Nested.Example" nestedExample- ]
SBVBenchSuite/BenchSuite/Misc/Enumerate.hs view
@@ -31,9 +31,9 @@ ] where _elts = \(x::SE) -> x .== x _four = \a b c (d::SE) -> distinct [a, b, c, d]- _maxE = do mx <- sbvExists "maxE"- e <- sbvForall "e"- return $ mx .>= (e::SE)- _minE = do mx <- sbvExists "minE"- e <- sbvForall "e"- return $ mx .<= (e::SE)+ _maxE = do mx <- free "maxE"+ constrain $ \(Forall e) -> mx .>= (e::SE)+ _minE = do mx <- free "minE"+ constrain $ \(Forall e) -> mx .<= (e::SE)++{- HLint ignore module "Redundant lambda" -}
SBVBenchSuite/BenchSuite/Misc/NoDiv0.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Misc.NoDiv0 ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Misc.NoDiv0(benchmarks) where
SBVBenchSuite/BenchSuite/Misc/SetAlgebra.hs view
@@ -129,3 +129,5 @@ relCompFull = \(a :: SI) -> a \\ full .== empty distSubset1 = \(a :: SI) b c -> a `isSubsetOf` (b `union` c) .=> a `isSubsetOf` b .&& a `isSubsetOf` c distSubset2 = \(a :: SI) b c -> (b `intersection` c) `isSubsetOf` a .=> b `isSubsetOf` a .&& c `isSubsetOf` a++{- HLint ignore module "Redundant lambda" -}
SBVBenchSuite/BenchSuite/Optimization/Instances.hs view
@@ -10,7 +10,7 @@ -- Helper file to provide common orphaned instances for Optimization benchmarks ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Optimization.Instances where
SBVBenchSuite/BenchSuite/ProofTools/BMC.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.BMC ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.BMC(benchmarks) where
SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.Fibonacci ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.Fibonacci(benchmarks) where
SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.Strengthen ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.Strengthen(benchmarks) where
SBVBenchSuite/BenchSuite/ProofTools/Sum.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.Sum ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.Sum(benchmarks) where @@ -25,5 +25,5 @@ benchmarks :: Runner benchmarks = runIO "Sum.Correctness" sumCorrect -instance NFData a => NFData (S a)+instance NFData a => NFData (S a) where rnf a = seq a () instance NFData a => NFData (InductionResult a) where rnf a = seq a ()
SBVBenchSuite/BenchSuite/Puzzles/Coins.hs view
@@ -25,7 +25,7 @@ benchmarks = rGroup [ S.run "Coins" coinsPgm ] where coinsPgm = do cs <- mapM mkCoin [1..6] mapM_ constrain [c s | s <- combinations cs, length s >= 2, c <- [c1, c2, c3, c4, c5, c6]]- constrain $ sAnd $ zipWith (.>=) cs (tail cs)+ constrain $ sAnd $ zipWith (.>=) cs (drop 1 cs) -- normally we would call output here, but returning -- several outputs from a symbolic computation doesn't -- play nice with either the transcript generation or the benchmarking apparently
SBVBenchSuite/BenchSuite/Puzzles/Counts.hs view
@@ -23,5 +23,4 @@ -- benchmark suite benchmarks :: Runner benchmarks = rGroup [ S.run "Counts" countPgm ]- where countPgm = puzzle `fmap` mkExistVars 10- -- puzzle' d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 = puzzle [d0, d1, d2, d3, d4, d5, d6, d7, d8, d9]+ where countPgm = puzzle `fmap` mkFreeVars 10
SBVBenchSuite/BenchSuite/Puzzles/Garden.hs view
@@ -26,4 +26,4 @@ -- benchmark suite benchmarks :: Runner benchmarks = rGroup [ S.runWith s "Garden" puzzle `using` runner allSatWith ]- where s = z3{satTrackUFs = False, isNonModelVar = ("_modelIgnore" `isSuffixOf`)}+ where s = z3{allSatTrackUFs = False, isNonModelVar = ("_modelIgnore" `isSuffixOf`)}
SBVBenchSuite/BenchSuite/Puzzles/MagicSquare.hs view
@@ -28,4 +28,4 @@ ] mkMagic :: Int -> Symbolic SBool-mkMagic n = (isMagic . chunk n) `fmap` mkExistVars (n*n)+mkMagic n = (isMagic . chunk n) `fmap` mkFreeVars (n*n)
SBVBenchSuite/BenchSuite/Puzzles/NQueens.hs view
@@ -34,4 +34,4 @@ ] mkQueens :: Int -> Symbolic SBool-mkQueens n = isValid n `fmap` mkExistVars n+mkQueens n = isValid n `fmap` mkFreeVars n
SBVBenchSuite/BenchSuite/Puzzles/Sudoku.hs view
@@ -19,16 +19,14 @@ import Utils.SBVBenchFramework import BenchSuite.Bench.Bench as S - -- benchmark suite benchmarks :: Runner benchmarks = rGroup- [ S.run ("sudoku " ++ show n) (checkPuzzle s) `using` runner satWith- | (n, s) <-- zip- [(0::Int)..]- [puzzle0, puzzle1, puzzle2, puzzle3, puzzle4, puzzle5, puzzle6] ]+ [ runIO ("sudoku" ++ show n) (checkPuzzle s)+ | (n, s) <- zip [(0::Int)..] [puzzle1, puzzle2, puzzle3, puzzle4, puzzle5, puzzle6] ] -checkPuzzle :: Puzzle -> Symbolic SBool-checkPuzzle (i, f) = (valid . f) `fmap` mkExistVars i+checkPuzzle :: Puzzle -> IO Bool+checkPuzzle p = do final <- fillBoard p+ let vld = valid (map (map literal) final)+ pure $ Just True == unliteral vld
SBVBenchSuite/BenchSuite/Puzzles/U2Bridge.hs view
@@ -30,5 +30,5 @@ , S.run "U2Bridge_cnt6" (count 6) `using` runner satWith ] where- act = do b <- sbvExists_; p1 <- sbvExists_; p2 <- sbvExists_; return (b, p1, p2)+ act = do b <- free_; p1 <- free_; p2 <- free_; return (b, p1, p2) count n = isValid `fmap` mapM (const act) [1..(n::Int)]
SBVBenchSuite/BenchSuite/Queries/Enums.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Queries.Enums ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Queries.Enums(benchmarks) where
SBVBenchSuite/BenchSuite/Queries/GuessNumber.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Queries.GuessNumber ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Queries.GuessNumber(benchmarks) where
SBVBenchSuite/BenchSuite/Transformers/SymbolicEval.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Transformers.SymbolicEval ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Transformers.SymbolicEval(benchmarks) where
SBVBenchSuite/BenchSuite/Uninterpreted/AUF.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Uninterpreted.AUF ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} module BenchSuite.Uninterpreted.AUF(benchmarks) where@@ -26,5 +26,5 @@ ] where array = do x <- free "x" y <- free "y"- a :: SArray Word32 Word32 <- newArray_ Nothing+ a :: SArray Word32 Word32 <- sArray_ return $ thm x y a
SBVBenchSuite/BenchSuite/Uninterpreted/Deduce.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Uninterpreted.Deduce ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} module BenchSuite.Uninterpreted.Deduce(benchmarks) where@@ -25,11 +25,14 @@ benchmarks = rGroup [ run "test" t `using` runner proveWith ]- where t = do addAxiom "OR distributes over AND" ax1- addAxiom "de Morgan" ax2- addAxiom "double negation" ax3+ where t = do constrain $ \(Forall p) (Forall q) (Forall r) -> (p `or` q) `and` (p `or` r) .== p `or` (q `and` r)+ constrain $ \(Forall p) (Forall q) -> not (p `or` q) .== not p `and` not q+ constrain $ \(Forall p) -> not (not p) .== p p <- free "p" q <- free "q" r <- free "r" return $ not (p `or` (q `and` r)) .== (not p `and` not q) `or` (not p `and` not r)++{- HLint ignore module "Redundant lambda" -}+{- HLint ignore module "Redundant not" -}
SBVBenchSuite/BenchSuite/Uninterpreted/Multiply.hs view
@@ -36,3 +36,5 @@ sFalse correct = \a1 a0 b1 b0 -> mul22_hi a1 a0 b1 b0 .== (a1 .&& b0) .<+> (a0 .&& b1)++{- HLint ignore module "Redundant lambda" -}
SBVBenchSuite/BenchSuite/Uninterpreted/Shannon.hs view
@@ -16,7 +16,7 @@ module BenchSuite.Uninterpreted.Shannon(benchmarks) where import Documentation.SBV.Examples.Uninterpreted.Shannon-import Data.SBV hiding (universal, existential)+import Data.SBV import BenchSuite.Bench.Bench @@ -41,3 +41,5 @@ f' = derivative f f'' = universal f f''' = existential f++{- HLint ignore module "Redundant lambda" -}
SBVBenchSuite/BenchSuite/Uninterpreted/Sort.hs view
@@ -22,11 +22,11 @@ benchmarks :: Runner benchmarks = rGroup [ run "t1" _t1 `using` runner satWith- , run "r2" _t1 `using` runner satWith+ , run "t2" _t2 `using` runner satWith ] where _t1 = do x <- free "x" return $ f x ./= x - _t2 = do x <- free "x"- addAxiom "Q" ["(assert (forall ((x Q) (y Q)) (= x y)))"]+ _t2 = do constrain $ \(Forall x) (Forall y) -> x .== (y :: SQ)+ x <- free "x" return $ f x ./= x
SBVBenchSuite/BenchSuite/WeakestPreconditions/Append.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Append ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Append(benchmarks) where @@ -22,7 +22,7 @@ -- | orphaned instance for benchmarks-instance NFData a => NFData (AppC a) where rnf x = seq x ()+instance NFData a => NFData (AppS a) where rnf x = seq x () benchmarks :: Runner benchmarks = runIO "Correctness.Append" correctness
SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Basics ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE NamedFieldPuns #-} module BenchSuite.WeakestPreconditions.Basics(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/Fib.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Fig ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Fib(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/GCD.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.GCD ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.GCD(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/Instances.hs view
@@ -10,7 +10,7 @@ -- Helper file to provide common orphaned instances for WeakestPrecondition benchmarks ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Instances where
SBVBenchSuite/BenchSuite/WeakestPreconditions/IntDiv.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.IntDiv ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.IntDiv(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/IntSqrt.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.IntSqrt ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.IntSqrt(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/Length.hs view
@@ -10,18 +10,14 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Length ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Length(benchmarks) where import Documentation.SBV.Examples.WeakestPreconditions.Length -import Control.DeepSeq import BenchSuite.Bench.Bench import BenchSuite.WeakestPreconditions.Instances()--instance NFData a => NFData (LenS a)- benchmarks :: Runner benchmarks = runIO "Correctness.Length" correctness
SBVBenchSuite/BenchSuite/WeakestPreconditions/Sum.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Sum ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE NamedFieldPuns #-} module BenchSuite.WeakestPreconditions.Sum(benchmarks) where
SBVBenchSuite/SBVBench.hs view
@@ -38,7 +38,7 @@ -- import qualified BenchSuite.BitPrecise.BrokenSearch -- import qualified BenchSuite.BitPrecise.Legato -- import qualified BenchSuite.BitPrecise.MergeSort-import qualified BenchSuite.BitPrecise.MultMask+-- import qualified BenchSuite.BitPrecise.MultMask -- import qualified BenchSuite.BitPrecise.PrefixSum -- Queries@@ -111,14 +111,13 @@ -- Lists import qualified BenchSuite.Lists.BoundedMutex import qualified BenchSuite.Lists.Fibonacci-import qualified BenchSuite.Lists.Nested -- Strings import qualified BenchSuite.Strings.RegexCrossword import qualified BenchSuite.Strings.SQLInjection -- Existentials-import qualified BenchSuite.Existentials.CRCPolynomial+-- import qualified BenchSuite.Existentials.CRCPolynomial import qualified BenchSuite.Existentials.Diophantine -- Transformers@@ -208,7 +207,7 @@ -- , BenchSuite.BitPrecise.BrokenSearch.benchmarks -- , BenchSuite.BitPrecise.Legato.benchmarks -- , BenchSuite.BitPrecise.MergeSort.benchmarks- , BenchSuite.BitPrecise.MultMask.benchmarks+ -- , BenchSuite.BitPrecise.MultMask.benchmarks -- expensive -- , BenchSuite.BitPrecise.PrefixSum.benchmarks ]@@ -342,7 +341,6 @@ listBenchmarks :: [Runner] listBenchmarks = [ BenchSuite.Lists.BoundedMutex.benchmarks , BenchSuite.Lists.Fibonacci.benchmarks- , BenchSuite.Lists.Nested.benchmarks ] lists :: Benchmark@@ -361,8 +359,8 @@ --------------------------- Existentials ---------------------------------------- existentialBenchmarks :: [Runner]-existentialBenchmarks = [ BenchSuite.Existentials.CRCPolynomial.benchmarks- , BenchSuite.Existentials.Diophantine.benchmarks+existentialBenchmarks = [ -- BenchSuite.Existentials.CRCPolynomial.benchmarks+ BenchSuite.Existentials.Diophantine.benchmarks ] existentials :: Benchmark
SBVBenchSuite/Utils/SBVBenchFramework.hs view
@@ -11,7 +11,11 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-missing-methods #-} -- for ProvableM orphan+ module Utils.SBVBenchFramework ( mkExecString , mkFileName@@ -34,6 +38,7 @@ import Data.Time.Calendar import Data.SBV+import Data.SBV.Internals -- | make the string to call executable from the command line. All the heavy -- lifting is done by 'System.Process.showCommandForUser', the rest is just@@ -68,7 +73,7 @@ spaceTo :: Char -> Char -> Char spaceTo c x | isSpace x = c- | otherwise = x+ | True = x -- | Construct a benchmark file name. The input name should be a time stamp or -- whatever you want to name the benchmark@@ -83,7 +88,7 @@ is :: [Int] is = L.elemIndices e nm - chunks = [(a, tail b) | (a, b) <- fmap (`L.splitAt` nm) is]+ chunks = [(a, drop 1 b) | (a, b) <- fmap (`L.splitAt` nm) is] -- | We live with some code duplication due to the way overhead benchmarks apply -- the "standalone" and "sbv" labels. By abstracting for overhead benchmarks@@ -91,7 +96,7 @@ -- the assumptions of the bench-show package, thus we define a specialty -- classifier to handle the overhead case overheadClassifier :: Char -> String -> Maybe (String, String)-overheadClassifier e nm = Just $ last $ fmap (\(a,b) -> (tail b, a)) chunks+overheadClassifier e nm = Just $ last $ fmap (\(a,b) -> (drop 1 b, a)) chunks where is :: [Int] is = L.elemIndices e nm@@ -112,3 +117,10 @@ filteredFilePath = fp ++ "_filtered" writeFile filteredFilePath (concat $ header:filteredContent) return filteredFilePath++-- NO INSTANCE ON PURPOSE; don't want to prove goals. We provide this instance+-- just to allow the testsuite to run tests with try to Prove Goals. In general,+-- this violates the invariants promised by the @ProvableM@ and @SatisfiableM@+-- type classes. Thus, this should not be publicly exposed under any+-- circumstances.+instance ProvableM IO (SymbolicT IO ())
+ SBVTestSuite/GoldFiles/adt00.gold view
@@ -0,0 +1,94 @@+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] (declare-datatypes ((SBVTuple3 3)) ((par (T1 T2 T3)+ ((mkSBVTuple3 (proj_1_SBVTuple3 T1)+ (proj_2_SBVTuple3 T2)+ (proj_3_SBVTuple3 T3))))))+[GOOD] ; --- sums ---+[GOOD] (declare-datatype SBVRational ((SBV.Rational (sbv.rat.numerator Int) (sbv.rat.denominator Int))))++[GOOD] (define-fun sbv.rat.eq ((x SBVRational) (y SBVRational)) Bool+ (= (* (sbv.rat.numerator x) (sbv.rat.denominator y))+ (* (sbv.rat.denominator x) (sbv.rat.numerator y)))+ )++[GOOD] (define-fun sbv.rat.notEq ((x SBVRational) (y SBVRational)) Bool+ (not (sbv.rat.eq x y))+ )+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Maybe+[GOOD] (declare-datatype Maybe (par (a) (+ (Nothing)+ (Just (getJust_1 a))+ )))+[GOOD] ; User defined ADT: Either+[GOOD] (declare-datatype Either (par (a b) (+ (Left (getLeft_1 a))+ (Right (getRight_1 b))+ )))+[GOOD] ; User defined ADT: ADT+[GOOD] (declare-datatype ADT (+ (AEmpty)+ (ABool (getABool_1 Bool))+ (AInteger (getAInteger_1 Int))+ (AWord8 (getAWord8_1 (_ BitVec 8)))+ (AWord16 (getAWord16_1 (_ BitVec 16)))+ (AWord32 (getAWord32_1 (_ BitVec 32)))+ (AWord64 (getAWord64_1 (_ BitVec 64)))+ (AInt8 (getAInt8_1 (_ BitVec 8)))+ (AInt16 (getAInt16_1 (_ BitVec 16)))+ (AInt32 (getAInt32_1 (_ BitVec 32)))+ (AInt64 (getAInt64_1 (_ BitVec 64)))+ (AWord1 (getAWord1_1 (_ BitVec 1)))+ (AWord5 (getAWord5_1 (_ BitVec 5)))+ (AWord30 (getAWord30_1 (_ BitVec 30)))+ (AInt1 (getAInt1_1 (_ BitVec 1)))+ (AInt5 (getAInt5_1 (_ BitVec 5)))+ (AInt30 (getAInt30_1 (_ BitVec 30)))+ (AReal (getAReal_1 Real))+ (AFloat (getAFloat_1 (_ FloatingPoint 8 24)))+ (ADouble (getADouble_1 (_ FloatingPoint 11 53)))+ (AFP (getAFP_1 (_ FloatingPoint 5 12)))+ (AString (getAString_1 String))+ (AList (getAList_1 (Seq Int)))+ (ATuple (getATuple_1 (SBVTuple2 (_ FloatingPoint 11 53) (Seq (SBVTuple2 (_ BitVec 5) (Seq (_ FloatingPoint 8 24)))))))+ (AMaybe (getAMaybe_1 (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))))+ (AEither (getAEither_1 (Either (SBVTuple2 (Maybe Int) Bool) (Seq Int))))+ (APair (getAPair_1 ADT) (getAPair_2 ADT))+ (KChar (getKChar_1 String))+ (KRational (getKRational_1 SBVRational))+ ))+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () ADT) ; tracks user variable "e"+[GOOD] (assert (and (= 1 (str.len (getKChar_1 s0)))+ (< 0 (sbv.rat.denominator (getKRational_1 s0)))+ ))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool (= s0 s0))+[GOOD] (define-fun s2 () Bool (not s1))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[SEND] (check-sat)+[RECV] unsat++UNSAT*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt01.gold view
@@ -0,0 +1,102 @@+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] (declare-datatypes ((SBVTuple3 3)) ((par (T1 T2 T3)+ ((mkSBVTuple3 (proj_1_SBVTuple3 T1)+ (proj_2_SBVTuple3 T2)+ (proj_3_SBVTuple3 T3))))))+[GOOD] ; --- sums ---+[GOOD] (declare-datatype SBVRational ((SBV.Rational (sbv.rat.numerator Int) (sbv.rat.denominator Int))))++[GOOD] (define-fun sbv.rat.eq ((x SBVRational) (y SBVRational)) Bool+ (= (* (sbv.rat.numerator x) (sbv.rat.denominator y))+ (* (sbv.rat.denominator x) (sbv.rat.numerator y)))+ )++[GOOD] (define-fun sbv.rat.notEq ((x SBVRational) (y SBVRational)) Bool+ (not (sbv.rat.eq x y))+ )+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Maybe+[GOOD] (declare-datatype Maybe (par (a) (+ (Nothing)+ (Just (getJust_1 a))+ )))+[GOOD] ; User defined ADT: Either+[GOOD] (declare-datatype Either (par (a b) (+ (Left (getLeft_1 a))+ (Right (getRight_1 b))+ )))+[GOOD] ; User defined ADT: ADT+[GOOD] (declare-datatype ADT (+ (AEmpty)+ (ABool (getABool_1 Bool))+ (AInteger (getAInteger_1 Int))+ (AWord8 (getAWord8_1 (_ BitVec 8)))+ (AWord16 (getAWord16_1 (_ BitVec 16)))+ (AWord32 (getAWord32_1 (_ BitVec 32)))+ (AWord64 (getAWord64_1 (_ BitVec 64)))+ (AInt8 (getAInt8_1 (_ BitVec 8)))+ (AInt16 (getAInt16_1 (_ BitVec 16)))+ (AInt32 (getAInt32_1 (_ BitVec 32)))+ (AInt64 (getAInt64_1 (_ BitVec 64)))+ (AWord1 (getAWord1_1 (_ BitVec 1)))+ (AWord5 (getAWord5_1 (_ BitVec 5)))+ (AWord30 (getAWord30_1 (_ BitVec 30)))+ (AInt1 (getAInt1_1 (_ BitVec 1)))+ (AInt5 (getAInt5_1 (_ BitVec 5)))+ (AInt30 (getAInt30_1 (_ BitVec 30)))+ (AReal (getAReal_1 Real))+ (AFloat (getAFloat_1 (_ FloatingPoint 8 24)))+ (ADouble (getADouble_1 (_ FloatingPoint 11 53)))+ (AFP (getAFP_1 (_ FloatingPoint 5 12)))+ (AString (getAString_1 String))+ (AList (getAList_1 (Seq Int)))+ (ATuple (getATuple_1 (SBVTuple2 (_ FloatingPoint 11 53) (Seq (SBVTuple2 (_ BitVec 5) (Seq (_ FloatingPoint 8 24)))))))+ (AMaybe (getAMaybe_1 (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))))+ (AEither (getAEither_1 (Either (SBVTuple2 (Maybe Int) Bool) (Seq Int))))+ (APair (getAPair_1 ADT) (getAPair_2 ADT))+ (KChar (getKChar_1 String))+ (KRational (getKRational_1 SBVRational))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () ADT ((as APair ADT) ((as AInt64 ADT) #x0000000000000004) ((as AMaybe ADT) ((as Just (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))) (mkSBVTuple3 0.0 (fp #b0 #b10000010 #b10000000000000000000000) (mkSBVTuple2 ((as Left (Either Int (_ FloatingPoint 8 24))) 3) (seq.++ (seq.unit false) (seq.unit true))))))))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () ADT) ; tracks user variable "e"+[GOOD] (assert (and (= 1 (str.len (getKChar_1 s0)))+ (< 0 (sbv.rat.denominator (getKRational_1 s0)))+ ))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (APair (AInt64 #x0000000000000004)+ (AMaybe (Just (mkSBVTuple3 0.0+ (fp #b0 #x82 #b10000000000000000000000)+ (mkSBVTuple2 (Left 3)+ (seq.++ (seq.unit false)+ (seq.unit true)))))))))++MODEL: SMTModel {modelObjectives = [], modelBindings = Nothing, modelAssocs = [("e",APair (AInt64 4) (AMaybe (Just (0.0,12.0,(Left 3,[False,True])))) :: ADT)], modelUIFuns = []}+DONE.*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt02.gold view
@@ -0,0 +1,96 @@+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] (declare-datatypes ((SBVTuple3 3)) ((par (T1 T2 T3)+ ((mkSBVTuple3 (proj_1_SBVTuple3 T1)+ (proj_2_SBVTuple3 T2)+ (proj_3_SBVTuple3 T3))))))+[GOOD] ; --- sums ---+[GOOD] (declare-datatype SBVRational ((SBV.Rational (sbv.rat.numerator Int) (sbv.rat.denominator Int))))++[GOOD] (define-fun sbv.rat.eq ((x SBVRational) (y SBVRational)) Bool+ (= (* (sbv.rat.numerator x) (sbv.rat.denominator y))+ (* (sbv.rat.denominator x) (sbv.rat.numerator y)))+ )++[GOOD] (define-fun sbv.rat.notEq ((x SBVRational) (y SBVRational)) Bool+ (not (sbv.rat.eq x y))+ )+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Maybe+[GOOD] (declare-datatype Maybe (par (a) (+ (Nothing)+ (Just (getJust_1 a))+ )))+[GOOD] ; User defined ADT: Either+[GOOD] (declare-datatype Either (par (a b) (+ (Left (getLeft_1 a))+ (Right (getRight_1 b))+ )))+[GOOD] ; User defined ADT: ADT+[GOOD] (declare-datatype ADT (+ (AEmpty)+ (ABool (getABool_1 Bool))+ (AInteger (getAInteger_1 Int))+ (AWord8 (getAWord8_1 (_ BitVec 8)))+ (AWord16 (getAWord16_1 (_ BitVec 16)))+ (AWord32 (getAWord32_1 (_ BitVec 32)))+ (AWord64 (getAWord64_1 (_ BitVec 64)))+ (AInt8 (getAInt8_1 (_ BitVec 8)))+ (AInt16 (getAInt16_1 (_ BitVec 16)))+ (AInt32 (getAInt32_1 (_ BitVec 32)))+ (AInt64 (getAInt64_1 (_ BitVec 64)))+ (AWord1 (getAWord1_1 (_ BitVec 1)))+ (AWord5 (getAWord5_1 (_ BitVec 5)))+ (AWord30 (getAWord30_1 (_ BitVec 30)))+ (AInt1 (getAInt1_1 (_ BitVec 1)))+ (AInt5 (getAInt5_1 (_ BitVec 5)))+ (AInt30 (getAInt30_1 (_ BitVec 30)))+ (AReal (getAReal_1 Real))+ (AFloat (getAFloat_1 (_ FloatingPoint 8 24)))+ (ADouble (getADouble_1 (_ FloatingPoint 11 53)))+ (AFP (getAFP_1 (_ FloatingPoint 5 12)))+ (AString (getAString_1 String))+ (AList (getAList_1 (Seq Int)))+ (ATuple (getATuple_1 (SBVTuple2 (_ FloatingPoint 11 53) (Seq (SBVTuple2 (_ BitVec 5) (Seq (_ FloatingPoint 8 24)))))))+ (AMaybe (getAMaybe_1 (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))))+ (AEither (getAEither_1 (Either (SBVTuple2 (Maybe Int) Bool) (Seq Int))))+ (APair (getAPair_1 ADT) (getAPair_2 ADT))+ (KChar (getKChar_1 String))+ (KRational (getKRational_1 SBVRational))+ ))+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () ADT) ; tracks user variable "e"+[GOOD] (assert (and (= 1 (str.len (getKChar_1 s0)))+ (< 0 (sbv.rat.denominator (getKRational_1 s0)))+ ))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-AList Bool) s0))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s1)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (AList (seq.unit 2))))++MODEL: SMTModel {modelObjectives = [], modelBindings = Nothing, modelAssocs = [("e",AList [2] :: ADT)], modelUIFuns = []}+DONE.*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt03.gold view
@@ -0,0 +1,95 @@+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] (declare-datatypes ((SBVTuple3 3)) ((par (T1 T2 T3)+ ((mkSBVTuple3 (proj_1_SBVTuple3 T1)+ (proj_2_SBVTuple3 T2)+ (proj_3_SBVTuple3 T3))))))+[GOOD] ; --- sums ---+[GOOD] (declare-datatype SBVRational ((SBV.Rational (sbv.rat.numerator Int) (sbv.rat.denominator Int))))++[GOOD] (define-fun sbv.rat.eq ((x SBVRational) (y SBVRational)) Bool+ (= (* (sbv.rat.numerator x) (sbv.rat.denominator y))+ (* (sbv.rat.denominator x) (sbv.rat.numerator y)))+ )++[GOOD] (define-fun sbv.rat.notEq ((x SBVRational) (y SBVRational)) Bool+ (not (sbv.rat.eq x y))+ )+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Maybe+[GOOD] (declare-datatype Maybe (par (a) (+ (Nothing)+ (Just (getJust_1 a))+ )))+[GOOD] ; User defined ADT: Either+[GOOD] (declare-datatype Either (par (a b) (+ (Left (getLeft_1 a))+ (Right (getRight_1 b))+ )))+[GOOD] ; User defined ADT: ADT+[GOOD] (declare-datatype ADT (+ (AEmpty)+ (ABool (getABool_1 Bool))+ (AInteger (getAInteger_1 Int))+ (AWord8 (getAWord8_1 (_ BitVec 8)))+ (AWord16 (getAWord16_1 (_ BitVec 16)))+ (AWord32 (getAWord32_1 (_ BitVec 32)))+ (AWord64 (getAWord64_1 (_ BitVec 64)))+ (AInt8 (getAInt8_1 (_ BitVec 8)))+ (AInt16 (getAInt16_1 (_ BitVec 16)))+ (AInt32 (getAInt32_1 (_ BitVec 32)))+ (AInt64 (getAInt64_1 (_ BitVec 64)))+ (AWord1 (getAWord1_1 (_ BitVec 1)))+ (AWord5 (getAWord5_1 (_ BitVec 5)))+ (AWord30 (getAWord30_1 (_ BitVec 30)))+ (AInt1 (getAInt1_1 (_ BitVec 1)))+ (AInt5 (getAInt5_1 (_ BitVec 5)))+ (AInt30 (getAInt30_1 (_ BitVec 30)))+ (AReal (getAReal_1 Real))+ (AFloat (getAFloat_1 (_ FloatingPoint 8 24)))+ (ADouble (getADouble_1 (_ FloatingPoint 11 53)))+ (AFP (getAFP_1 (_ FloatingPoint 5 12)))+ (AString (getAString_1 String))+ (AList (getAList_1 (Seq Int)))+ (ATuple (getATuple_1 (SBVTuple2 (_ FloatingPoint 11 53) (Seq (SBVTuple2 (_ BitVec 5) (Seq (_ FloatingPoint 8 24)))))))+ (AMaybe (getAMaybe_1 (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))))+ (AEither (getAEither_1 (Either (SBVTuple2 (Maybe Int) Bool) (Seq Int))))+ (APair (getAPair_1 ADT) (getAPair_2 ADT))+ (KChar (getKChar_1 String))+ (KRational (getKRational_1 SBVRational))+ ))+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () ADT) ; tracks user variable "e"+[GOOD] (assert (and (= 1 (str.len (getKChar_1 s0)))+ (< 0 (sbv.rat.denominator (getKRational_1 s0)))+ ))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-AList Bool) s0))+[GOOD] (define-fun s2 () Bool ((as is-AFP Bool) s0))+[GOOD] (define-fun s3 () Bool (and s1 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s3)+[SEND] (check-sat)+[RECV] unsat++UNSAT*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt04.gold view
@@ -0,0 +1,180 @@+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] (declare-datatypes ((SBVTuple3 3)) ((par (T1 T2 T3)+ ((mkSBVTuple3 (proj_1_SBVTuple3 T1)+ (proj_2_SBVTuple3 T2)+ (proj_3_SBVTuple3 T3))))))+[GOOD] ; --- sums ---+[GOOD] (declare-datatype SBVRational ((SBV.Rational (sbv.rat.numerator Int) (sbv.rat.denominator Int))))++[GOOD] (define-fun sbv.rat.eq ((x SBVRational) (y SBVRational)) Bool+ (= (* (sbv.rat.numerator x) (sbv.rat.denominator y))+ (* (sbv.rat.denominator x) (sbv.rat.numerator y)))+ )++[GOOD] (define-fun sbv.rat.notEq ((x SBVRational) (y SBVRational)) Bool+ (not (sbv.rat.eq x y))+ )+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Maybe+[GOOD] (declare-datatype Maybe (par (a) (+ (Nothing)+ (Just (getJust_1 a))+ )))+[GOOD] ; User defined ADT: Either+[GOOD] (declare-datatype Either (par (a b) (+ (Left (getLeft_1 a))+ (Right (getRight_1 b))+ )))+[GOOD] ; User defined ADT: ADT+[GOOD] (declare-datatype ADT (+ (AEmpty)+ (ABool (getABool_1 Bool))+ (AInteger (getAInteger_1 Int))+ (AWord8 (getAWord8_1 (_ BitVec 8)))+ (AWord16 (getAWord16_1 (_ BitVec 16)))+ (AWord32 (getAWord32_1 (_ BitVec 32)))+ (AWord64 (getAWord64_1 (_ BitVec 64)))+ (AInt8 (getAInt8_1 (_ BitVec 8)))+ (AInt16 (getAInt16_1 (_ BitVec 16)))+ (AInt32 (getAInt32_1 (_ BitVec 32)))+ (AInt64 (getAInt64_1 (_ BitVec 64)))+ (AWord1 (getAWord1_1 (_ BitVec 1)))+ (AWord5 (getAWord5_1 (_ BitVec 5)))+ (AWord30 (getAWord30_1 (_ BitVec 30)))+ (AInt1 (getAInt1_1 (_ BitVec 1)))+ (AInt5 (getAInt5_1 (_ BitVec 5)))+ (AInt30 (getAInt30_1 (_ BitVec 30)))+ (AReal (getAReal_1 Real))+ (AFloat (getAFloat_1 (_ FloatingPoint 8 24)))+ (ADouble (getADouble_1 (_ FloatingPoint 11 53)))+ (AFP (getAFP_1 (_ FloatingPoint 5 12)))+ (AString (getAString_1 String))+ (AList (getAList_1 (Seq Int)))+ (ATuple (getATuple_1 (SBVTuple2 (_ FloatingPoint 11 53) (Seq (SBVTuple2 (_ BitVec 5) (Seq (_ FloatingPoint 8 24)))))))+ (AMaybe (getAMaybe_1 (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))))+ (AEither (getAEither_1 (Either (SBVTuple2 (Maybe Int) Bool) (Seq Int))))+ (APair (getAPair_1 ADT) (getAPair_2 ADT))+ (KChar (getKChar_1 String))+ (KRational (getKRational_1 SBVRational))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () Int 0)+[GOOD] (define-fun s5 () Int 5)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () ADT) ; tracks user variable "a"+[GOOD] (assert (and (= 1 (str.len (getKChar_1 s0)))+ (< 0 (sbv.rat.denominator (getKRational_1 s0)))+ ))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-AInteger Bool) s0))+[GOOD] (define-fun s2 () Int (getAInteger_1 s0))+[GOOD] (define-fun s4 () Bool (>= s2 s3))+[GOOD] (define-fun s6 () Bool (<= s2 s5))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s1)+[GOOD] (assert s4)+[GOOD] (assert s6)+*** Checking Satisfiability, all solutions..+Fast allSat, Looking for solution 1+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (AInteger 4)))+[GOOD] (push 1)+[GOOD] (define-fun s7 () ADT ((as AInteger ADT) 4))+[GOOD] (define-fun s8 () Bool (= s0 s7))+[GOOD] (define-fun s9 () Bool (not s8))+[GOOD] (assert s9)+Fast allSat, Looking for solution 2+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (AInteger 0)))+[GOOD] (push 1)+[GOOD] (define-fun s10 () ADT ((as AInteger ADT) 0))+[GOOD] (define-fun s11 () Bool (= s0 s10))+[GOOD] (define-fun s12 () Bool (not s11))+[GOOD] (assert s12)+Fast allSat, Looking for solution 3+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (AInteger 3)))+[GOOD] (push 1)+[GOOD] (define-fun s13 () ADT ((as AInteger ADT) 3))+[GOOD] (define-fun s14 () Bool (= s0 s13))+[GOOD] (define-fun s15 () Bool (not s14))+[GOOD] (assert s15)+Fast allSat, Looking for solution 4+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (AInteger 5)))+[GOOD] (push 1)+[GOOD] (define-fun s16 () ADT ((as AInteger ADT) 5))+[GOOD] (define-fun s17 () Bool (= s0 s16))+[GOOD] (define-fun s18 () Bool (not s17))+[GOOD] (assert s18)+Fast allSat, Looking for solution 5+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (AInteger 2)))+[GOOD] (push 1)+[GOOD] (define-fun s19 () ADT ((as AInteger ADT) 2))+[GOOD] (define-fun s20 () Bool (= s0 s19))+[GOOD] (define-fun s21 () Bool (not s20))+[GOOD] (assert s21)+Fast allSat, Looking for solution 6+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (AInteger 1)))+[GOOD] (push 1)+[GOOD] (define-fun s22 () ADT ((as AInteger ADT) 1))+[GOOD] (define-fun s23 () Bool (= s0 s22))+[GOOD] (define-fun s24 () Bool (not s23))+[GOOD] (assert s24)+Fast allSat, Looking for solution 7+[SEND] (check-sat)+[RECV] unsat+[GOOD] (pop 1)+[GOOD] (pop 1)+[GOOD] (pop 1)+[GOOD] (pop 1)+[GOOD] (pop 1)+[GOOD] (pop 1)+*** Solver : Z3+*** Exit code: ExitSuccess++MODEL:Satisfiable. Model:+ a = AInteger 1 :: ADT+MODEL:Satisfiable. Model:+ a = AInteger 2 :: ADT+MODEL:Satisfiable. Model:+ a = AInteger 5 :: ADT+MODEL:Satisfiable. Model:+ a = AInteger 3 :: ADT+MODEL:Satisfiable. Model:+ a = AInteger 0 :: ADT+MODEL:Satisfiable. Model:+ a = AInteger 4 :: ADT
+ SBVTestSuite/GoldFiles/adt05.gold view
@@ -0,0 +1,130 @@+** Calling: cvc5 --lang smt --incremental --nl-cov+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic HO_ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] (declare-datatypes ((SBVTuple3 3)) ((par (T1 T2 T3)+ ((mkSBVTuple3 (proj_1_SBVTuple3 T1)+ (proj_2_SBVTuple3 T2)+ (proj_3_SBVTuple3 T3))))))+[GOOD] ; --- sums ---+[GOOD] (declare-datatype SBVRational ((SBV.Rational (sbv.rat.numerator Int) (sbv.rat.denominator Int))))++[GOOD] (define-fun sbv.rat.eq ((x SBVRational) (y SBVRational)) Bool+ (= (* (sbv.rat.numerator x) (sbv.rat.denominator y))+ (* (sbv.rat.denominator x) (sbv.rat.numerator y)))+ )++[GOOD] (define-fun sbv.rat.notEq ((x SBVRational) (y SBVRational)) Bool+ (not (sbv.rat.eq x y))+ )+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Maybe+[GOOD] (declare-datatype Maybe (par (a) (+ (Nothing)+ (Just (getJust_1 a))+ )))+[GOOD] ; User defined ADT: Either+[GOOD] (declare-datatype Either (par (a b) (+ (Left (getLeft_1 a))+ (Right (getRight_1 b))+ )))+[GOOD] ; User defined ADT: ADT+[GOOD] (declare-datatype ADT (+ (AEmpty)+ (ABool (getABool_1 Bool))+ (AInteger (getAInteger_1 Int))+ (AWord8 (getAWord8_1 (_ BitVec 8)))+ (AWord16 (getAWord16_1 (_ BitVec 16)))+ (AWord32 (getAWord32_1 (_ BitVec 32)))+ (AWord64 (getAWord64_1 (_ BitVec 64)))+ (AInt8 (getAInt8_1 (_ BitVec 8)))+ (AInt16 (getAInt16_1 (_ BitVec 16)))+ (AInt32 (getAInt32_1 (_ BitVec 32)))+ (AInt64 (getAInt64_1 (_ BitVec 64)))+ (AWord1 (getAWord1_1 (_ BitVec 1)))+ (AWord5 (getAWord5_1 (_ BitVec 5)))+ (AWord30 (getAWord30_1 (_ BitVec 30)))+ (AInt1 (getAInt1_1 (_ BitVec 1)))+ (AInt5 (getAInt5_1 (_ BitVec 5)))+ (AInt30 (getAInt30_1 (_ BitVec 30)))+ (AReal (getAReal_1 Real))+ (AFloat (getAFloat_1 (_ FloatingPoint 8 24)))+ (ADouble (getADouble_1 (_ FloatingPoint 11 53)))+ (AFP (getAFP_1 (_ FloatingPoint 5 12)))+ (AString (getAString_1 String))+ (AList (getAList_1 (Seq Int)))+ (ATuple (getATuple_1 (SBVTuple2 (_ FloatingPoint 11 53) (Seq (SBVTuple2 (_ BitVec 5) (Seq (_ FloatingPoint 8 24)))))))+ (AMaybe (getAMaybe_1 (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))))+ (AEither (getAEither_1 (Either (SBVTuple2 (Maybe Int) Bool) (Seq Int))))+ (APair (getAPair_1 ADT) (getAPair_2 ADT))+ (KChar (getKChar_1 String))+ (KRational (getKRational_1 SBVRational))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s4 () (_ FloatingPoint 8 24) (fp #b0 #b10000001 #b00000000000000000000000))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () ADT) ; tracks user variable "a"+[GOOD] (assert (and (= 1 (str.len (getKChar_1 s0)))+ (< 0 (sbv.rat.denominator (getKRational_1 s0)))+ ))+[GOOD] (declare-fun s1 () ADT) ; tracks user variable "b"+[GOOD] (assert (and (= 1 (str.len (getKChar_1 s1)))+ (< 0 (sbv.rat.denominator (getKRational_1 s1)))+ ))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (is-AFloat s0))+[GOOD] (define-fun s3 () (_ FloatingPoint 8 24) (getAFloat_1 s0))+[GOOD] (define-fun s5 () Bool (fp.eq s3 s4))+[GOOD] (define-fun s6 () Bool (and s2 s5))+[GOOD] (define-fun s7 () Bool (is-AFloat s1))+[GOOD] (define-fun s8 () (_ FloatingPoint 8 24) (getAFloat_1 s1))+[GOOD] (define-fun s9 () Bool (fp.isNaN s8))+[GOOD] (define-fun s10 () Bool (and s7 s9))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s6)+[GOOD] (assert s10)+*** Checking Satisfiability, all solutions..+Fast allSat, Looking for solution 1+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (AFloat (fp #b0 #b10000001 #b00000000000000000000000))))+[SEND] (get-value (s1))+[RECV] ((s1 (AFloat (fp #b0 #b11111111 #b10000000000000000000000))))+[GOOD] (push 1)+[GOOD] (define-fun s11 () ADT ((as AFloat ADT) (fp #b0 #b10000001 #b00000000000000000000000)))+[GOOD] (define-fun s12 () Bool (= s0 s11))+[GOOD] (define-fun s13 () Bool (not s12))+[GOOD] (assert s13)+Fast allSat, Looking for solution 2+[SEND] (check-sat)+[RECV] unsat+[GOOD] (pop 1)+[GOOD] (push 1)+[GOOD] (define-fun s14 () ADT ((as AFloat ADT) (_ NaN 8 24)))+[GOOD] (define-fun s15 () Bool (= s1 s14))+[GOOD] (define-fun s16 () Bool (not s15))+[GOOD] (assert s16)+[GOOD] (assert s12)+Fast allSat, Looking for solution 2+[SEND] (check-sat)+[RECV] unsat+[GOOD] (pop 1)+*** Solver : CVC5+*** Exit code: ExitSuccess++MODEL:Satisfiable. Model:+ a = AFloat 4.0 :: ADT+ b = AFloat NaN :: ADT
+ SBVTestSuite/GoldFiles/adt06.gold view
@@ -0,0 +1,103 @@+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] (declare-datatypes ((SBVTuple3 3)) ((par (T1 T2 T3)+ ((mkSBVTuple3 (proj_1_SBVTuple3 T1)+ (proj_2_SBVTuple3 T2)+ (proj_3_SBVTuple3 T3))))))+[GOOD] ; --- sums ---+[GOOD] (declare-datatype SBVRational ((SBV.Rational (sbv.rat.numerator Int) (sbv.rat.denominator Int))))++[GOOD] (define-fun sbv.rat.eq ((x SBVRational) (y SBVRational)) Bool+ (= (* (sbv.rat.numerator x) (sbv.rat.denominator y))+ (* (sbv.rat.denominator x) (sbv.rat.numerator y)))+ )++[GOOD] (define-fun sbv.rat.notEq ((x SBVRational) (y SBVRational)) Bool+ (not (sbv.rat.eq x y))+ )+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Maybe+[GOOD] (declare-datatype Maybe (par (a) (+ (Nothing)+ (Just (getJust_1 a))+ )))+[GOOD] ; User defined ADT: Either+[GOOD] (declare-datatype Either (par (a b) (+ (Left (getLeft_1 a))+ (Right (getRight_1 b))+ )))+[GOOD] ; User defined ADT: ADT+[GOOD] (declare-datatype ADT (+ (AEmpty)+ (ABool (getABool_1 Bool))+ (AInteger (getAInteger_1 Int))+ (AWord8 (getAWord8_1 (_ BitVec 8)))+ (AWord16 (getAWord16_1 (_ BitVec 16)))+ (AWord32 (getAWord32_1 (_ BitVec 32)))+ (AWord64 (getAWord64_1 (_ BitVec 64)))+ (AInt8 (getAInt8_1 (_ BitVec 8)))+ (AInt16 (getAInt16_1 (_ BitVec 16)))+ (AInt32 (getAInt32_1 (_ BitVec 32)))+ (AInt64 (getAInt64_1 (_ BitVec 64)))+ (AWord1 (getAWord1_1 (_ BitVec 1)))+ (AWord5 (getAWord5_1 (_ BitVec 5)))+ (AWord30 (getAWord30_1 (_ BitVec 30)))+ (AInt1 (getAInt1_1 (_ BitVec 1)))+ (AInt5 (getAInt5_1 (_ BitVec 5)))+ (AInt30 (getAInt30_1 (_ BitVec 30)))+ (AReal (getAReal_1 Real))+ (AFloat (getAFloat_1 (_ FloatingPoint 8 24)))+ (ADouble (getADouble_1 (_ FloatingPoint 11 53)))+ (AFP (getAFP_1 (_ FloatingPoint 5 12)))+ (AString (getAString_1 String))+ (AList (getAList_1 (Seq Int)))+ (ATuple (getATuple_1 (SBVTuple2 (_ FloatingPoint 11 53) (Seq (SBVTuple2 (_ BitVec 5) (Seq (_ FloatingPoint 8 24)))))))+ (AMaybe (getAMaybe_1 (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))))+ (AEither (getAEither_1 (Either (SBVTuple2 (Maybe Int) Bool) (Seq Int))))+ (APair (getAPair_1 ADT) (getAPair_2 ADT))+ (KChar (getKChar_1 String))+ (KRational (getKRational_1 SBVRational))+ ))+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () ADT) ; tracks user variable "a"+[GOOD] (assert (and (= 1 (str.len (getKChar_1 s0)))+ (< 0 (sbv.rat.denominator (getKRational_1 s0)))+ ))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-AMaybe Bool) s0))+[GOOD] (define-fun s2 () (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool)))) (getAMaybe_1 s0))+[GOOD] (define-fun s3 () Bool ((as is-Just Bool) s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s1)+[GOOD] (assert s3)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (AMaybe (Just (mkSBVTuple3 2.0+ (fp #b0 #x00 #b00000000000000000000001)+ (mkSBVTuple2 (Right (fp #b0 #x00 #b00000000000000000100000))+ (seq.unit true)))))))++getValue: AMaybe (Just (2.0,1.0e-45,(Right 4.5e-44,[True])))+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_chk01.gold view
@@ -0,0 +1,40 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: A+[GOOD] (declare-datatype A (+ (A (getA_1 Int))+ (B (getB_1 (_ BitVec 8)))+ (C (getC_1 A) (getC_2 A))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () A ((as A A) 13))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () A) ; tracks user variable "res"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (A 13)))+Result: A 13+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr00.gold view
@@ -0,0 +1,219 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Val Expr) 3))+[GOOD] (define-fun s3 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s5 () Int 3)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s4 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s3 s0))+[GOOD] (define-fun s6 () Bool (distinct s4 s5))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr00c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr01.gold view
@@ -0,0 +1,219 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))+[GOOD] (define-fun s3 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s5 () Int 7)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s4 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s3 s0))+[GOOD] (define-fun s6 () Bool (distinct s4 s5))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr01c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr02.gold view
@@ -0,0 +1,219 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 3) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))))+[GOOD] (define-fun s3 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s5 () Int 21)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s4 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s3 s0))+[GOOD] (define-fun s6 () Bool (distinct s4 s5))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr02c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr03.gold view
@@ -0,0 +1,219 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Let Expr) "a" ((as Mul Expr) ((as Val Expr) 3) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))) ((as Add Expr) ((as Var Expr) "a") ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))))+[GOOD] (define-fun s3 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s5 () Int 28)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s4 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s3 s0))+[GOOD] (define-fun s6 () Bool (distinct s4 s5))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr03c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr04.gold view
@@ -0,0 +1,30 @@+** 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-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Int 63)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "res"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 63))+Result: 63+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr05.gold view
@@ -0,0 +1,30 @@+** 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-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Int 3969)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "res"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 3969))+Result: 3969+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr06.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Var Expr) "a"))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s8 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr06c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr07.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Var Expr) "b"))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s15 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr07c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr08.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Var Expr) "c"))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s15 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr08c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr09.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Var Expr) "d"))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s16 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr09c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr10.gold view
@@ -0,0 +1,454 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s15 () Expr ((as Val Expr) (- 5)))+[GOOD] (define-fun s17 () Expr ((as Val Expr) (- 4)))+[GOOD] (define-fun s19 () Expr ((as Val Expr) (- 3)))+[GOOD] (define-fun s21 () Expr ((as Val Expr) (- 2)))+[GOOD] (define-fun s23 () Expr ((as Val Expr) (- 1)))+[GOOD] (define-fun s25 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s27 () Expr ((as Val Expr) 1))+[GOOD] (define-fun s29 () Expr ((as Val Expr) 2))+[GOOD] (define-fun s31 () Expr ((as Val Expr) 3))+[GOOD] (define-fun s33 () Expr ((as Val Expr) 4))+[GOOD] (define-fun s35 () Expr ((as Val Expr) 5))+[GOOD] (define-fun s37 () Expr ((as Val Expr) 6))+[GOOD] (define-fun s39 () Expr ((as Val Expr) 7))+[GOOD] (define-fun s41 () Expr ((as Val Expr) 8))+[GOOD] (define-fun s43 () Expr ((as Val Expr) 9))+[GOOD] (define-fun s61 () String "a")+[GOOD] (define-fun s64 () Int 0)+[GOOD] (define-fun s65 () String "b")+[GOOD] (define-fun s67 () String "c")+[GOOD] (define-fun s71 () Int 1)+[GOOD] (define-fun s72 () Int 2)+[GOOD] (define-fun s75 () Int 10)+[GOOD] (define-fun s78 () Int 3)+[GOOD] (define-fun s81 () Int 4)+[GOOD] (define-fun s84 () Int 5)+[GOOD] (define-fun s85 () Int 6)+[GOOD] (define-fun s414 () Int 45)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] (declare-fun s1 () Expr)+[GOOD] (declare-fun s2 () Expr)+[GOOD] (declare-fun s3 () Expr)+[GOOD] (declare-fun s4 () Expr)+[GOOD] (declare-fun s5 () Expr)+[GOOD] (declare-fun s6 () Expr)+[GOOD] (declare-fun s7 () Expr)+[GOOD] (declare-fun s8 () Expr)+[GOOD] (declare-fun s9 () Expr)+[GOOD] (declare-fun s10 () Expr)+[GOOD] (declare-fun s11 () Expr)+[GOOD] (declare-fun s12 () Expr)+[GOOD] (declare-fun s13 () Expr)+[GOOD] (declare-fun s14 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s16 () Bool (= s0 s15))+[GOOD] (define-fun s18 () Bool (= s1 s17))+[GOOD] (define-fun s20 () Bool (= s2 s19))+[GOOD] (define-fun s22 () Bool (= s3 s21))+[GOOD] (define-fun s24 () Bool (= s4 s23))+[GOOD] (define-fun s26 () Bool (= s5 s25))+[GOOD] (define-fun s28 () Bool (= s6 s27))+[GOOD] (define-fun s30 () Bool (= s7 s29))+[GOOD] (define-fun s32 () Bool (= s8 s31))+[GOOD] (define-fun s34 () Bool (= s9 s33))+[GOOD] (define-fun s36 () Bool (= s10 s35))+[GOOD] (define-fun s38 () Bool (= s11 s37))+[GOOD] (define-fun s40 () Bool (= s12 s39))+[GOOD] (define-fun s42 () Bool (= s13 s41))+[GOOD] (define-fun s44 () Bool (= s14 s43))+[GOOD] (define-fun s45 () Bool (and s42 s44))+[GOOD] (define-fun s46 () Bool (and s40 s45))+[GOOD] (define-fun s47 () Bool (and s38 s46))+[GOOD] (define-fun s48 () Bool (and s36 s47))+[GOOD] (define-fun s49 () Bool (and s34 s48))+[GOOD] (define-fun s50 () Bool (and s32 s49))+[GOOD] (define-fun s51 () Bool (and s30 s50))+[GOOD] (define-fun s52 () Bool (and s28 s51))+[GOOD] (define-fun s53 () Bool (and s26 s52))+[GOOD] (define-fun s54 () Bool (and s24 s53))+[GOOD] (define-fun s55 () Bool (and s22 s54))+[GOOD] (define-fun s56 () Bool (and s20 s55))+[GOOD] (define-fun s57 () Bool (and s18 s56))+[GOOD] (define-fun s58 () Bool (and s16 s57))+[GOOD] (define-fun s59 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s60 () String (getVar_1 s0))+[GOOD] (define-fun s62 () Bool (= s60 s61))+[GOOD] (define-fun s63 () Bool (and s59 s62))+[GOOD] (define-fun s66 () Bool (= s60 s65))+[GOOD] (define-fun s68 () Bool (= s60 s67))+[GOOD] (define-fun s69 () Bool (or s66 s68))+[GOOD] (define-fun s70 () Bool (and s59 s69))+[GOOD] (define-fun s73 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s74 () Int (getVal_1 s0))+[GOOD] (define-fun s76 () Bool (< s74 s75))+[GOOD] (define-fun s77 () Bool (and s73 s76))+[GOOD] (define-fun s79 () Bool (= s74 s75))+[GOOD] (define-fun s80 () Bool (and s73 s79))+[GOOD] (define-fun s82 () Bool (> s74 s75))+[GOOD] (define-fun s83 () Bool (and s73 s82))+[GOOD] (define-fun s86 () Int (ite s83 s84 s85))+[GOOD] (define-fun s87 () Int (ite s80 s81 s86))+[GOOD] (define-fun s88 () Int (ite s77 s78 s87))+[GOOD] (define-fun s89 () Int (ite s59 s72 s88))+[GOOD] (define-fun s90 () Int (ite s70 s71 s89))+[GOOD] (define-fun s91 () Int (ite s63 s64 s90))+[GOOD] (define-fun s92 () Bool ((as is-Var Bool) s1))+[GOOD] (define-fun s93 () String (getVar_1 s1))+[GOOD] (define-fun s94 () Bool (= s61 s93))+[GOOD] (define-fun s95 () Bool (and s92 s94))+[GOOD] (define-fun s96 () Bool (= s65 s93))+[GOOD] (define-fun s97 () Bool (= s67 s93))+[GOOD] (define-fun s98 () Bool (or s96 s97))+[GOOD] (define-fun s99 () Bool (and s92 s98))+[GOOD] (define-fun s100 () Bool ((as is-Val Bool) s1))+[GOOD] (define-fun s101 () Int (getVal_1 s1))+[GOOD] (define-fun s102 () Bool (< s101 s75))+[GOOD] (define-fun s103 () Bool (and s100 s102))+[GOOD] (define-fun s104 () Bool (= s75 s101))+[GOOD] (define-fun s105 () Bool (and s100 s104))+[GOOD] (define-fun s106 () Bool (> s101 s75))+[GOOD] (define-fun s107 () Bool (and s100 s106))+[GOOD] (define-fun s108 () Int (ite s107 s84 s85))+[GOOD] (define-fun s109 () Int (ite s105 s81 s108))+[GOOD] (define-fun s110 () Int (ite s103 s78 s109))+[GOOD] (define-fun s111 () Int (ite s92 s72 s110))+[GOOD] (define-fun s112 () Int (ite s99 s71 s111))+[GOOD] (define-fun s113 () Int (ite s95 s64 s112))+[GOOD] (define-fun s114 () Int (+ s91 s113))+[GOOD] (define-fun s115 () Bool ((as is-Var Bool) s2))+[GOOD] (define-fun s116 () String (getVar_1 s2))+[GOOD] (define-fun s117 () Bool (= s61 s116))+[GOOD] (define-fun s118 () Bool (and s115 s117))+[GOOD] (define-fun s119 () Bool (= s65 s116))+[GOOD] (define-fun s120 () Bool (= s67 s116))+[GOOD] (define-fun s121 () Bool (or s119 s120))+[GOOD] (define-fun s122 () Bool (and s115 s121))+[GOOD] (define-fun s123 () Bool ((as is-Val Bool) s2))+[GOOD] (define-fun s124 () Int (getVal_1 s2))+[GOOD] (define-fun s125 () Bool (< s124 s75))+[GOOD] (define-fun s126 () Bool (and s123 s125))+[GOOD] (define-fun s127 () Bool (= s75 s124))+[GOOD] (define-fun s128 () Bool (and s123 s127))+[GOOD] (define-fun s129 () Bool (> s124 s75))+[GOOD] (define-fun s130 () Bool (and s123 s129))+[GOOD] (define-fun s131 () Int (ite s130 s84 s85))+[GOOD] (define-fun s132 () Int (ite s128 s81 s131))+[GOOD] (define-fun s133 () Int (ite s126 s78 s132))+[GOOD] (define-fun s134 () Int (ite s115 s72 s133))+[GOOD] (define-fun s135 () Int (ite s122 s71 s134))+[GOOD] (define-fun s136 () Int (ite s118 s64 s135))+[GOOD] (define-fun s137 () Int (+ s114 s136))+[GOOD] (define-fun s138 () Bool ((as is-Var Bool) s3))+[GOOD] (define-fun s139 () String (getVar_1 s3))+[GOOD] (define-fun s140 () Bool (= s61 s139))+[GOOD] (define-fun s141 () Bool (and s138 s140))+[GOOD] (define-fun s142 () Bool (= s65 s139))+[GOOD] (define-fun s143 () Bool (= s67 s139))+[GOOD] (define-fun s144 () Bool (or s142 s143))+[GOOD] (define-fun s145 () Bool (and s138 s144))+[GOOD] (define-fun s146 () Bool ((as is-Val Bool) s3))+[GOOD] (define-fun s147 () Int (getVal_1 s3))+[GOOD] (define-fun s148 () Bool (< s147 s75))+[GOOD] (define-fun s149 () Bool (and s146 s148))+[GOOD] (define-fun s150 () Bool (= s75 s147))+[GOOD] (define-fun s151 () Bool (and s146 s150))+[GOOD] (define-fun s152 () Bool (> s147 s75))+[GOOD] (define-fun s153 () Bool (and s146 s152))+[GOOD] (define-fun s154 () Int (ite s153 s84 s85))+[GOOD] (define-fun s155 () Int (ite s151 s81 s154))+[GOOD] (define-fun s156 () Int (ite s149 s78 s155))+[GOOD] (define-fun s157 () Int (ite s138 s72 s156))+[GOOD] (define-fun s158 () Int (ite s145 s71 s157))+[GOOD] (define-fun s159 () Int (ite s141 s64 s158))+[GOOD] (define-fun s160 () Int (+ s137 s159))+[GOOD] (define-fun s161 () Bool ((as is-Var Bool) s4))+[GOOD] (define-fun s162 () String (getVar_1 s4))+[GOOD] (define-fun s163 () Bool (= s61 s162))+[GOOD] (define-fun s164 () Bool (and s161 s163))+[GOOD] (define-fun s165 () Bool (= s65 s162))+[GOOD] (define-fun s166 () Bool (= s67 s162))+[GOOD] (define-fun s167 () Bool (or s165 s166))+[GOOD] (define-fun s168 () Bool (and s161 s167))+[GOOD] (define-fun s169 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s170 () Int (getVal_1 s4))+[GOOD] (define-fun s171 () Bool (< s170 s75))+[GOOD] (define-fun s172 () Bool (and s169 s171))+[GOOD] (define-fun s173 () Bool (= s75 s170))+[GOOD] (define-fun s174 () Bool (and s169 s173))+[GOOD] (define-fun s175 () Bool (> s170 s75))+[GOOD] (define-fun s176 () Bool (and s169 s175))+[GOOD] (define-fun s177 () Int (ite s176 s84 s85))+[GOOD] (define-fun s178 () Int (ite s174 s81 s177))+[GOOD] (define-fun s179 () Int (ite s172 s78 s178))+[GOOD] (define-fun s180 () Int (ite s161 s72 s179))+[GOOD] (define-fun s181 () Int (ite s168 s71 s180))+[GOOD] (define-fun s182 () Int (ite s164 s64 s181))+[GOOD] (define-fun s183 () Int (+ s160 s182))+[GOOD] (define-fun s184 () Bool ((as is-Var Bool) s5))+[GOOD] (define-fun s185 () String (getVar_1 s5))+[GOOD] (define-fun s186 () Bool (= s61 s185))+[GOOD] (define-fun s187 () Bool (and s184 s186))+[GOOD] (define-fun s188 () Bool (= s65 s185))+[GOOD] (define-fun s189 () Bool (= s67 s185))+[GOOD] (define-fun s190 () Bool (or s188 s189))+[GOOD] (define-fun s191 () Bool (and s184 s190))+[GOOD] (define-fun s192 () Bool ((as is-Val Bool) s5))+[GOOD] (define-fun s193 () Int (getVal_1 s5))+[GOOD] (define-fun s194 () Bool (< s193 s75))+[GOOD] (define-fun s195 () Bool (and s192 s194))+[GOOD] (define-fun s196 () Bool (= s75 s193))+[GOOD] (define-fun s197 () Bool (and s192 s196))+[GOOD] (define-fun s198 () Bool (> s193 s75))+[GOOD] (define-fun s199 () Bool (and s192 s198))+[GOOD] (define-fun s200 () Int (ite s199 s84 s85))+[GOOD] (define-fun s201 () Int (ite s197 s81 s200))+[GOOD] (define-fun s202 () Int (ite s195 s78 s201))+[GOOD] (define-fun s203 () Int (ite s184 s72 s202))+[GOOD] (define-fun s204 () Int (ite s191 s71 s203))+[GOOD] (define-fun s205 () Int (ite s187 s64 s204))+[GOOD] (define-fun s206 () Int (+ s183 s205))+[GOOD] (define-fun s207 () Bool ((as is-Var Bool) s6))+[GOOD] (define-fun s208 () String (getVar_1 s6))+[GOOD] (define-fun s209 () Bool (= s61 s208))+[GOOD] (define-fun s210 () Bool (and s207 s209))+[GOOD] (define-fun s211 () Bool (= s65 s208))+[GOOD] (define-fun s212 () Bool (= s67 s208))+[GOOD] (define-fun s213 () Bool (or s211 s212))+[GOOD] (define-fun s214 () Bool (and s207 s213))+[GOOD] (define-fun s215 () Bool ((as is-Val Bool) s6))+[GOOD] (define-fun s216 () Int (getVal_1 s6))+[GOOD] (define-fun s217 () Bool (< s216 s75))+[GOOD] (define-fun s218 () Bool (and s215 s217))+[GOOD] (define-fun s219 () Bool (= s75 s216))+[GOOD] (define-fun s220 () Bool (and s215 s219))+[GOOD] (define-fun s221 () Bool (> s216 s75))+[GOOD] (define-fun s222 () Bool (and s215 s221))+[GOOD] (define-fun s223 () Int (ite s222 s84 s85))+[GOOD] (define-fun s224 () Int (ite s220 s81 s223))+[GOOD] (define-fun s225 () Int (ite s218 s78 s224))+[GOOD] (define-fun s226 () Int (ite s207 s72 s225))+[GOOD] (define-fun s227 () Int (ite s214 s71 s226))+[GOOD] (define-fun s228 () Int (ite s210 s64 s227))+[GOOD] (define-fun s229 () Int (+ s206 s228))+[GOOD] (define-fun s230 () Bool ((as is-Var Bool) s7))+[GOOD] (define-fun s231 () String (getVar_1 s7))+[GOOD] (define-fun s232 () Bool (= s61 s231))+[GOOD] (define-fun s233 () Bool (and s230 s232))+[GOOD] (define-fun s234 () Bool (= s65 s231))+[GOOD] (define-fun s235 () Bool (= s67 s231))+[GOOD] (define-fun s236 () Bool (or s234 s235))+[GOOD] (define-fun s237 () Bool (and s230 s236))+[GOOD] (define-fun s238 () Bool ((as is-Val Bool) s7))+[GOOD] (define-fun s239 () Int (getVal_1 s7))+[GOOD] (define-fun s240 () Bool (< s239 s75))+[GOOD] (define-fun s241 () Bool (and s238 s240))+[GOOD] (define-fun s242 () Bool (= s75 s239))+[GOOD] (define-fun s243 () Bool (and s238 s242))+[GOOD] (define-fun s244 () Bool (> s239 s75))+[GOOD] (define-fun s245 () Bool (and s238 s244))+[GOOD] (define-fun s246 () Int (ite s245 s84 s85))+[GOOD] (define-fun s247 () Int (ite s243 s81 s246))+[GOOD] (define-fun s248 () Int (ite s241 s78 s247))+[GOOD] (define-fun s249 () Int (ite s230 s72 s248))+[GOOD] (define-fun s250 () Int (ite s237 s71 s249))+[GOOD] (define-fun s251 () Int (ite s233 s64 s250))+[GOOD] (define-fun s252 () Int (+ s229 s251))+[GOOD] (define-fun s253 () Bool ((as is-Var Bool) s8))+[GOOD] (define-fun s254 () String (getVar_1 s8))+[GOOD] (define-fun s255 () Bool (= s61 s254))+[GOOD] (define-fun s256 () Bool (and s253 s255))+[GOOD] (define-fun s257 () Bool (= s65 s254))+[GOOD] (define-fun s258 () Bool (= s67 s254))+[GOOD] (define-fun s259 () Bool (or s257 s258))+[GOOD] (define-fun s260 () Bool (and s253 s259))+[GOOD] (define-fun s261 () Bool ((as is-Val Bool) s8))+[GOOD] (define-fun s262 () Int (getVal_1 s8))+[GOOD] (define-fun s263 () Bool (< s262 s75))+[GOOD] (define-fun s264 () Bool (and s261 s263))+[GOOD] (define-fun s265 () Bool (= s75 s262))+[GOOD] (define-fun s266 () Bool (and s261 s265))+[GOOD] (define-fun s267 () Bool (> s262 s75))+[GOOD] (define-fun s268 () Bool (and s261 s267))+[GOOD] (define-fun s269 () Int (ite s268 s84 s85))+[GOOD] (define-fun s270 () Int (ite s266 s81 s269))+[GOOD] (define-fun s271 () Int (ite s264 s78 s270))+[GOOD] (define-fun s272 () Int (ite s253 s72 s271))+[GOOD] (define-fun s273 () Int (ite s260 s71 s272))+[GOOD] (define-fun s274 () Int (ite s256 s64 s273))+[GOOD] (define-fun s275 () Int (+ s252 s274))+[GOOD] (define-fun s276 () Bool ((as is-Var Bool) s9))+[GOOD] (define-fun s277 () String (getVar_1 s9))+[GOOD] (define-fun s278 () Bool (= s61 s277))+[GOOD] (define-fun s279 () Bool (and s276 s278))+[GOOD] (define-fun s280 () Bool (= s65 s277))+[GOOD] (define-fun s281 () Bool (= s67 s277))+[GOOD] (define-fun s282 () Bool (or s280 s281))+[GOOD] (define-fun s283 () Bool (and s276 s282))+[GOOD] (define-fun s284 () Bool ((as is-Val Bool) s9))+[GOOD] (define-fun s285 () Int (getVal_1 s9))+[GOOD] (define-fun s286 () Bool (< s285 s75))+[GOOD] (define-fun s287 () Bool (and s284 s286))+[GOOD] (define-fun s288 () Bool (= s75 s285))+[GOOD] (define-fun s289 () Bool (and s284 s288))+[GOOD] (define-fun s290 () Bool (> s285 s75))+[GOOD] (define-fun s291 () Bool (and s284 s290))+[GOOD] (define-fun s292 () Int (ite s291 s84 s85))+[GOOD] (define-fun s293 () Int (ite s289 s81 s292))+[GOOD] (define-fun s294 () Int (ite s287 s78 s293))+[GOOD] (define-fun s295 () Int (ite s276 s72 s294))+[GOOD] (define-fun s296 () Int (ite s283 s71 s295))+[GOOD] (define-fun s297 () Int (ite s279 s64 s296))+[GOOD] (define-fun s298 () Int (+ s275 s297))+[GOOD] (define-fun s299 () Bool ((as is-Var Bool) s10))+[GOOD] (define-fun s300 () String (getVar_1 s10))+[GOOD] (define-fun s301 () Bool (= s61 s300))+[GOOD] (define-fun s302 () Bool (and s299 s301))+[GOOD] (define-fun s303 () Bool (= s65 s300))+[GOOD] (define-fun s304 () Bool (= s67 s300))+[GOOD] (define-fun s305 () Bool (or s303 s304))+[GOOD] (define-fun s306 () Bool (and s299 s305))+[GOOD] (define-fun s307 () Bool ((as is-Val Bool) s10))+[GOOD] (define-fun s308 () Int (getVal_1 s10))+[GOOD] (define-fun s309 () Bool (< s308 s75))+[GOOD] (define-fun s310 () Bool (and s307 s309))+[GOOD] (define-fun s311 () Bool (= s75 s308))+[GOOD] (define-fun s312 () Bool (and s307 s311))+[GOOD] (define-fun s313 () Bool (> s308 s75))+[GOOD] (define-fun s314 () Bool (and s307 s313))+[GOOD] (define-fun s315 () Int (ite s314 s84 s85))+[GOOD] (define-fun s316 () Int (ite s312 s81 s315))+[GOOD] (define-fun s317 () Int (ite s310 s78 s316))+[GOOD] (define-fun s318 () Int (ite s299 s72 s317))+[GOOD] (define-fun s319 () Int (ite s306 s71 s318))+[GOOD] (define-fun s320 () Int (ite s302 s64 s319))+[GOOD] (define-fun s321 () Int (+ s298 s320))+[GOOD] (define-fun s322 () Bool ((as is-Var Bool) s11))+[GOOD] (define-fun s323 () String (getVar_1 s11))+[GOOD] (define-fun s324 () Bool (= s61 s323))+[GOOD] (define-fun s325 () Bool (and s322 s324))+[GOOD] (define-fun s326 () Bool (= s65 s323))+[GOOD] (define-fun s327 () Bool (= s67 s323))+[GOOD] (define-fun s328 () Bool (or s326 s327))+[GOOD] (define-fun s329 () Bool (and s322 s328))+[GOOD] (define-fun s330 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s331 () Int (getVal_1 s11))+[GOOD] (define-fun s332 () Bool (< s331 s75))+[GOOD] (define-fun s333 () Bool (and s330 s332))+[GOOD] (define-fun s334 () Bool (= s75 s331))+[GOOD] (define-fun s335 () Bool (and s330 s334))+[GOOD] (define-fun s336 () Bool (> s331 s75))+[GOOD] (define-fun s337 () Bool (and s330 s336))+[GOOD] (define-fun s338 () Int (ite s337 s84 s85))+[GOOD] (define-fun s339 () Int (ite s335 s81 s338))+[GOOD] (define-fun s340 () Int (ite s333 s78 s339))+[GOOD] (define-fun s341 () Int (ite s322 s72 s340))+[GOOD] (define-fun s342 () Int (ite s329 s71 s341))+[GOOD] (define-fun s343 () Int (ite s325 s64 s342))+[GOOD] (define-fun s344 () Int (+ s321 s343))+[GOOD] (define-fun s345 () Bool ((as is-Var Bool) s12))+[GOOD] (define-fun s346 () String (getVar_1 s12))+[GOOD] (define-fun s347 () Bool (= s61 s346))+[GOOD] (define-fun s348 () Bool (and s345 s347))+[GOOD] (define-fun s349 () Bool (= s65 s346))+[GOOD] (define-fun s350 () Bool (= s67 s346))+[GOOD] (define-fun s351 () Bool (or s349 s350))+[GOOD] (define-fun s352 () Bool (and s345 s351))+[GOOD] (define-fun s353 () Bool ((as is-Val Bool) s12))+[GOOD] (define-fun s354 () Int (getVal_1 s12))+[GOOD] (define-fun s355 () Bool (< s354 s75))+[GOOD] (define-fun s356 () Bool (and s353 s355))+[GOOD] (define-fun s357 () Bool (= s75 s354))+[GOOD] (define-fun s358 () Bool (and s353 s357))+[GOOD] (define-fun s359 () Bool (> s354 s75))+[GOOD] (define-fun s360 () Bool (and s353 s359))+[GOOD] (define-fun s361 () Int (ite s360 s84 s85))+[GOOD] (define-fun s362 () Int (ite s358 s81 s361))+[GOOD] (define-fun s363 () Int (ite s356 s78 s362))+[GOOD] (define-fun s364 () Int (ite s345 s72 s363))+[GOOD] (define-fun s365 () Int (ite s352 s71 s364))+[GOOD] (define-fun s366 () Int (ite s348 s64 s365))+[GOOD] (define-fun s367 () Int (+ s344 s366))+[GOOD] (define-fun s368 () Bool ((as is-Var Bool) s13))+[GOOD] (define-fun s369 () String (getVar_1 s13))+[GOOD] (define-fun s370 () Bool (= s61 s369))+[GOOD] (define-fun s371 () Bool (and s368 s370))+[GOOD] (define-fun s372 () Bool (= s65 s369))+[GOOD] (define-fun s373 () Bool (= s67 s369))+[GOOD] (define-fun s374 () Bool (or s372 s373))+[GOOD] (define-fun s375 () Bool (and s368 s374))+[GOOD] (define-fun s376 () Bool ((as is-Val Bool) s13))+[GOOD] (define-fun s377 () Int (getVal_1 s13))+[GOOD] (define-fun s378 () Bool (< s377 s75))+[GOOD] (define-fun s379 () Bool (and s376 s378))+[GOOD] (define-fun s380 () Bool (= s75 s377))+[GOOD] (define-fun s381 () Bool (and s376 s380))+[GOOD] (define-fun s382 () Bool (> s377 s75))+[GOOD] (define-fun s383 () Bool (and s376 s382))+[GOOD] (define-fun s384 () Int (ite s383 s84 s85))+[GOOD] (define-fun s385 () Int (ite s381 s81 s384))+[GOOD] (define-fun s386 () Int (ite s379 s78 s385))+[GOOD] (define-fun s387 () Int (ite s368 s72 s386))+[GOOD] (define-fun s388 () Int (ite s375 s71 s387))+[GOOD] (define-fun s389 () Int (ite s371 s64 s388))+[GOOD] (define-fun s390 () Int (+ s367 s389))+[GOOD] (define-fun s391 () Bool ((as is-Var Bool) s14))+[GOOD] (define-fun s392 () String (getVar_1 s14))+[GOOD] (define-fun s393 () Bool (= s61 s392))+[GOOD] (define-fun s394 () Bool (and s391 s393))+[GOOD] (define-fun s395 () Bool (= s65 s392))+[GOOD] (define-fun s396 () Bool (= s67 s392))+[GOOD] (define-fun s397 () Bool (or s395 s396))+[GOOD] (define-fun s398 () Bool (and s391 s397))+[GOOD] (define-fun s399 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s400 () Int (getVal_1 s14))+[GOOD] (define-fun s401 () Bool (< s400 s75))+[GOOD] (define-fun s402 () Bool (and s399 s401))+[GOOD] (define-fun s403 () Bool (= s75 s400))+[GOOD] (define-fun s404 () Bool (and s399 s403))+[GOOD] (define-fun s405 () Bool (> s400 s75))+[GOOD] (define-fun s406 () Bool (and s399 s405))+[GOOD] (define-fun s407 () Int (ite s406 s84 s85))+[GOOD] (define-fun s408 () Int (ite s404 s81 s407))+[GOOD] (define-fun s409 () Int (ite s402 s78 s408))+[GOOD] (define-fun s410 () Int (ite s391 s72 s409))+[GOOD] (define-fun s411 () Int (ite s398 s71 s410))+[GOOD] (define-fun s412 () Int (ite s394 s64 s411))+[GOOD] (define-fun s413 () Int (+ s390 s412))+[GOOD] (define-fun s415 () Bool (distinct s413 s414))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s58)+[GOOD] (assert s415)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr10c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr11.gold view
@@ -0,0 +1,102 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s2 () Expr ((as Val Expr) 10))+[GOOD] (define-fun s8 () String "a")+[GOOD] (define-fun s11 () Int 0)+[GOOD] (define-fun s12 () String "b")+[GOOD] (define-fun s14 () String "c")+[GOOD] (define-fun s18 () Int 1)+[GOOD] (define-fun s19 () Int 2)+[GOOD] (define-fun s22 () Int 10)+[GOOD] (define-fun s25 () Int 3)+[GOOD] (define-fun s28 () Int 4)+[GOOD] (define-fun s31 () Int 5)+[GOOD] (define-fun s32 () Int 6)+[GOOD] (define-fun s62 () Int 8)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] (declare-fun s1 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s3 () Bool (= s0 s2))+[GOOD] (define-fun s4 () Bool (= s1 s2))+[GOOD] (define-fun s5 () Bool (and s3 s4))+[GOOD] (define-fun s6 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s7 () String (getVar_1 s0))+[GOOD] (define-fun s9 () Bool (= s7 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s13 () Bool (= s7 s12))+[GOOD] (define-fun s15 () Bool (= s7 s14))+[GOOD] (define-fun s16 () Bool (or s13 s15))+[GOOD] (define-fun s17 () Bool (and s6 s16))+[GOOD] (define-fun s20 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s21 () Int (getVal_1 s0))+[GOOD] (define-fun s23 () Bool (< s21 s22))+[GOOD] (define-fun s24 () Bool (and s20 s23))+[GOOD] (define-fun s26 () Bool (= s21 s22))+[GOOD] (define-fun s27 () Bool (and s20 s26))+[GOOD] (define-fun s29 () Bool (> s21 s22))+[GOOD] (define-fun s30 () Bool (and s20 s29))+[GOOD] (define-fun s33 () Int (ite s30 s31 s32))+[GOOD] (define-fun s34 () Int (ite s27 s28 s33))+[GOOD] (define-fun s35 () Int (ite s24 s25 s34))+[GOOD] (define-fun s36 () Int (ite s6 s19 s35))+[GOOD] (define-fun s37 () Int (ite s17 s18 s36))+[GOOD] (define-fun s38 () Int (ite s10 s11 s37))+[GOOD] (define-fun s39 () Bool ((as is-Var Bool) s1))+[GOOD] (define-fun s40 () String (getVar_1 s1))+[GOOD] (define-fun s41 () Bool (= s8 s40))+[GOOD] (define-fun s42 () Bool (and s39 s41))+[GOOD] (define-fun s43 () Bool (= s12 s40))+[GOOD] (define-fun s44 () Bool (= s14 s40))+[GOOD] (define-fun s45 () Bool (or s43 s44))+[GOOD] (define-fun s46 () Bool (and s39 s45))+[GOOD] (define-fun s47 () Bool ((as is-Val Bool) s1))+[GOOD] (define-fun s48 () Int (getVal_1 s1))+[GOOD] (define-fun s49 () Bool (< s48 s22))+[GOOD] (define-fun s50 () Bool (and s47 s49))+[GOOD] (define-fun s51 () Bool (= s22 s48))+[GOOD] (define-fun s52 () Bool (and s47 s51))+[GOOD] (define-fun s53 () Bool (> s48 s22))+[GOOD] (define-fun s54 () Bool (and s47 s53))+[GOOD] (define-fun s55 () Int (ite s54 s31 s32))+[GOOD] (define-fun s56 () Int (ite s52 s28 s55))+[GOOD] (define-fun s57 () Int (ite s50 s25 s56))+[GOOD] (define-fun s58 () Int (ite s39 s19 s57))+[GOOD] (define-fun s59 () Int (ite s46 s18 s58))+[GOOD] (define-fun s60 () Int (ite s42 s11 s59))+[GOOD] (define-fun s61 () Int (+ s38 s60))+[GOOD] (define-fun s63 () Bool (distinct s61 s62))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s5)+[GOOD] (assert s63)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr11c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr12.gold view
@@ -0,0 +1,319 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s10 () Expr ((as Val Expr) 11))+[GOOD] (define-fun s12 () Expr ((as Val Expr) 12))+[GOOD] (define-fun s14 () Expr ((as Val Expr) 13))+[GOOD] (define-fun s16 () Expr ((as Val Expr) 14))+[GOOD] (define-fun s18 () Expr ((as Val Expr) 15))+[GOOD] (define-fun s20 () Expr ((as Val Expr) 16))+[GOOD] (define-fun s22 () Expr ((as Val Expr) 17))+[GOOD] (define-fun s24 () Expr ((as Val Expr) 18))+[GOOD] (define-fun s26 () Expr ((as Val Expr) 19))+[GOOD] (define-fun s28 () Expr ((as Val Expr) 20))+[GOOD] (define-fun s41 () String "a")+[GOOD] (define-fun s44 () Int 0)+[GOOD] (define-fun s45 () String "b")+[GOOD] (define-fun s47 () String "c")+[GOOD] (define-fun s51 () Int 1)+[GOOD] (define-fun s52 () Int 2)+[GOOD] (define-fun s55 () Int 10)+[GOOD] (define-fun s58 () Int 3)+[GOOD] (define-fun s61 () Int 4)+[GOOD] (define-fun s64 () Int 5)+[GOOD] (define-fun s65 () Int 6)+[GOOD] (define-fun s279 () Int 50)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] (declare-fun s1 () Expr)+[GOOD] (declare-fun s2 () Expr)+[GOOD] (declare-fun s3 () Expr)+[GOOD] (declare-fun s4 () Expr)+[GOOD] (declare-fun s5 () Expr)+[GOOD] (declare-fun s6 () Expr)+[GOOD] (declare-fun s7 () Expr)+[GOOD] (declare-fun s8 () Expr)+[GOOD] (declare-fun s9 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s11 () Bool (= s0 s10))+[GOOD] (define-fun s13 () Bool (= s1 s12))+[GOOD] (define-fun s15 () Bool (= s2 s14))+[GOOD] (define-fun s17 () Bool (= s3 s16))+[GOOD] (define-fun s19 () Bool (= s4 s18))+[GOOD] (define-fun s21 () Bool (= s5 s20))+[GOOD] (define-fun s23 () Bool (= s6 s22))+[GOOD] (define-fun s25 () Bool (= s7 s24))+[GOOD] (define-fun s27 () Bool (= s8 s26))+[GOOD] (define-fun s29 () Bool (= s9 s28))+[GOOD] (define-fun s30 () Bool (and s27 s29))+[GOOD] (define-fun s31 () Bool (and s25 s30))+[GOOD] (define-fun s32 () Bool (and s23 s31))+[GOOD] (define-fun s33 () Bool (and s21 s32))+[GOOD] (define-fun s34 () Bool (and s19 s33))+[GOOD] (define-fun s35 () Bool (and s17 s34))+[GOOD] (define-fun s36 () Bool (and s15 s35))+[GOOD] (define-fun s37 () Bool (and s13 s36))+[GOOD] (define-fun s38 () Bool (and s11 s37))+[GOOD] (define-fun s39 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s40 () String (getVar_1 s0))+[GOOD] (define-fun s42 () Bool (= s40 s41))+[GOOD] (define-fun s43 () Bool (and s39 s42))+[GOOD] (define-fun s46 () Bool (= s40 s45))+[GOOD] (define-fun s48 () Bool (= s40 s47))+[GOOD] (define-fun s49 () Bool (or s46 s48))+[GOOD] (define-fun s50 () Bool (and s39 s49))+[GOOD] (define-fun s53 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s54 () Int (getVal_1 s0))+[GOOD] (define-fun s56 () Bool (< s54 s55))+[GOOD] (define-fun s57 () Bool (and s53 s56))+[GOOD] (define-fun s59 () Bool (= s54 s55))+[GOOD] (define-fun s60 () Bool (and s53 s59))+[GOOD] (define-fun s62 () Bool (> s54 s55))+[GOOD] (define-fun s63 () Bool (and s53 s62))+[GOOD] (define-fun s66 () Int (ite s63 s64 s65))+[GOOD] (define-fun s67 () Int (ite s60 s61 s66))+[GOOD] (define-fun s68 () Int (ite s57 s58 s67))+[GOOD] (define-fun s69 () Int (ite s39 s52 s68))+[GOOD] (define-fun s70 () Int (ite s50 s51 s69))+[GOOD] (define-fun s71 () Int (ite s43 s44 s70))+[GOOD] (define-fun s72 () Bool ((as is-Var Bool) s1))+[GOOD] (define-fun s73 () String (getVar_1 s1))+[GOOD] (define-fun s74 () Bool (= s41 s73))+[GOOD] (define-fun s75 () Bool (and s72 s74))+[GOOD] (define-fun s76 () Bool (= s45 s73))+[GOOD] (define-fun s77 () Bool (= s47 s73))+[GOOD] (define-fun s78 () Bool (or s76 s77))+[GOOD] (define-fun s79 () Bool (and s72 s78))+[GOOD] (define-fun s80 () Bool ((as is-Val Bool) s1))+[GOOD] (define-fun s81 () Int (getVal_1 s1))+[GOOD] (define-fun s82 () Bool (< s81 s55))+[GOOD] (define-fun s83 () Bool (and s80 s82))+[GOOD] (define-fun s84 () Bool (= s55 s81))+[GOOD] (define-fun s85 () Bool (and s80 s84))+[GOOD] (define-fun s86 () Bool (> s81 s55))+[GOOD] (define-fun s87 () Bool (and s80 s86))+[GOOD] (define-fun s88 () Int (ite s87 s64 s65))+[GOOD] (define-fun s89 () Int (ite s85 s61 s88))+[GOOD] (define-fun s90 () Int (ite s83 s58 s89))+[GOOD] (define-fun s91 () Int (ite s72 s52 s90))+[GOOD] (define-fun s92 () Int (ite s79 s51 s91))+[GOOD] (define-fun s93 () Int (ite s75 s44 s92))+[GOOD] (define-fun s94 () Int (+ s71 s93))+[GOOD] (define-fun s95 () Bool ((as is-Var Bool) s2))+[GOOD] (define-fun s96 () String (getVar_1 s2))+[GOOD] (define-fun s97 () Bool (= s41 s96))+[GOOD] (define-fun s98 () Bool (and s95 s97))+[GOOD] (define-fun s99 () Bool (= s45 s96))+[GOOD] (define-fun s100 () Bool (= s47 s96))+[GOOD] (define-fun s101 () Bool (or s99 s100))+[GOOD] (define-fun s102 () Bool (and s95 s101))+[GOOD] (define-fun s103 () Bool ((as is-Val Bool) s2))+[GOOD] (define-fun s104 () Int (getVal_1 s2))+[GOOD] (define-fun s105 () Bool (< s104 s55))+[GOOD] (define-fun s106 () Bool (and s103 s105))+[GOOD] (define-fun s107 () Bool (= s55 s104))+[GOOD] (define-fun s108 () Bool (and s103 s107))+[GOOD] (define-fun s109 () Bool (> s104 s55))+[GOOD] (define-fun s110 () Bool (and s103 s109))+[GOOD] (define-fun s111 () Int (ite s110 s64 s65))+[GOOD] (define-fun s112 () Int (ite s108 s61 s111))+[GOOD] (define-fun s113 () Int (ite s106 s58 s112))+[GOOD] (define-fun s114 () Int (ite s95 s52 s113))+[GOOD] (define-fun s115 () Int (ite s102 s51 s114))+[GOOD] (define-fun s116 () Int (ite s98 s44 s115))+[GOOD] (define-fun s117 () Int (+ s94 s116))+[GOOD] (define-fun s118 () Bool ((as is-Var Bool) s3))+[GOOD] (define-fun s119 () String (getVar_1 s3))+[GOOD] (define-fun s120 () Bool (= s41 s119))+[GOOD] (define-fun s121 () Bool (and s118 s120))+[GOOD] (define-fun s122 () Bool (= s45 s119))+[GOOD] (define-fun s123 () Bool (= s47 s119))+[GOOD] (define-fun s124 () Bool (or s122 s123))+[GOOD] (define-fun s125 () Bool (and s118 s124))+[GOOD] (define-fun s126 () Bool ((as is-Val Bool) s3))+[GOOD] (define-fun s127 () Int (getVal_1 s3))+[GOOD] (define-fun s128 () Bool (< s127 s55))+[GOOD] (define-fun s129 () Bool (and s126 s128))+[GOOD] (define-fun s130 () Bool (= s55 s127))+[GOOD] (define-fun s131 () Bool (and s126 s130))+[GOOD] (define-fun s132 () Bool (> s127 s55))+[GOOD] (define-fun s133 () Bool (and s126 s132))+[GOOD] (define-fun s134 () Int (ite s133 s64 s65))+[GOOD] (define-fun s135 () Int (ite s131 s61 s134))+[GOOD] (define-fun s136 () Int (ite s129 s58 s135))+[GOOD] (define-fun s137 () Int (ite s118 s52 s136))+[GOOD] (define-fun s138 () Int (ite s125 s51 s137))+[GOOD] (define-fun s139 () Int (ite s121 s44 s138))+[GOOD] (define-fun s140 () Int (+ s117 s139))+[GOOD] (define-fun s141 () Bool ((as is-Var Bool) s4))+[GOOD] (define-fun s142 () String (getVar_1 s4))+[GOOD] (define-fun s143 () Bool (= s41 s142))+[GOOD] (define-fun s144 () Bool (and s141 s143))+[GOOD] (define-fun s145 () Bool (= s45 s142))+[GOOD] (define-fun s146 () Bool (= s47 s142))+[GOOD] (define-fun s147 () Bool (or s145 s146))+[GOOD] (define-fun s148 () Bool (and s141 s147))+[GOOD] (define-fun s149 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s150 () Int (getVal_1 s4))+[GOOD] (define-fun s151 () Bool (< s150 s55))+[GOOD] (define-fun s152 () Bool (and s149 s151))+[GOOD] (define-fun s153 () Bool (= s55 s150))+[GOOD] (define-fun s154 () Bool (and s149 s153))+[GOOD] (define-fun s155 () Bool (> s150 s55))+[GOOD] (define-fun s156 () Bool (and s149 s155))+[GOOD] (define-fun s157 () Int (ite s156 s64 s65))+[GOOD] (define-fun s158 () Int (ite s154 s61 s157))+[GOOD] (define-fun s159 () Int (ite s152 s58 s158))+[GOOD] (define-fun s160 () Int (ite s141 s52 s159))+[GOOD] (define-fun s161 () Int (ite s148 s51 s160))+[GOOD] (define-fun s162 () Int (ite s144 s44 s161))+[GOOD] (define-fun s163 () Int (+ s140 s162))+[GOOD] (define-fun s164 () Bool ((as is-Var Bool) s5))+[GOOD] (define-fun s165 () String (getVar_1 s5))+[GOOD] (define-fun s166 () Bool (= s41 s165))+[GOOD] (define-fun s167 () Bool (and s164 s166))+[GOOD] (define-fun s168 () Bool (= s45 s165))+[GOOD] (define-fun s169 () Bool (= s47 s165))+[GOOD] (define-fun s170 () Bool (or s168 s169))+[GOOD] (define-fun s171 () Bool (and s164 s170))+[GOOD] (define-fun s172 () Bool ((as is-Val Bool) s5))+[GOOD] (define-fun s173 () Int (getVal_1 s5))+[GOOD] (define-fun s174 () Bool (< s173 s55))+[GOOD] (define-fun s175 () Bool (and s172 s174))+[GOOD] (define-fun s176 () Bool (= s55 s173))+[GOOD] (define-fun s177 () Bool (and s172 s176))+[GOOD] (define-fun s178 () Bool (> s173 s55))+[GOOD] (define-fun s179 () Bool (and s172 s178))+[GOOD] (define-fun s180 () Int (ite s179 s64 s65))+[GOOD] (define-fun s181 () Int (ite s177 s61 s180))+[GOOD] (define-fun s182 () Int (ite s175 s58 s181))+[GOOD] (define-fun s183 () Int (ite s164 s52 s182))+[GOOD] (define-fun s184 () Int (ite s171 s51 s183))+[GOOD] (define-fun s185 () Int (ite s167 s44 s184))+[GOOD] (define-fun s186 () Int (+ s163 s185))+[GOOD] (define-fun s187 () Bool ((as is-Var Bool) s6))+[GOOD] (define-fun s188 () String (getVar_1 s6))+[GOOD] (define-fun s189 () Bool (= s41 s188))+[GOOD] (define-fun s190 () Bool (and s187 s189))+[GOOD] (define-fun s191 () Bool (= s45 s188))+[GOOD] (define-fun s192 () Bool (= s47 s188))+[GOOD] (define-fun s193 () Bool (or s191 s192))+[GOOD] (define-fun s194 () Bool (and s187 s193))+[GOOD] (define-fun s195 () Bool ((as is-Val Bool) s6))+[GOOD] (define-fun s196 () Int (getVal_1 s6))+[GOOD] (define-fun s197 () Bool (< s196 s55))+[GOOD] (define-fun s198 () Bool (and s195 s197))+[GOOD] (define-fun s199 () Bool (= s55 s196))+[GOOD] (define-fun s200 () Bool (and s195 s199))+[GOOD] (define-fun s201 () Bool (> s196 s55))+[GOOD] (define-fun s202 () Bool (and s195 s201))+[GOOD] (define-fun s203 () Int (ite s202 s64 s65))+[GOOD] (define-fun s204 () Int (ite s200 s61 s203))+[GOOD] (define-fun s205 () Int (ite s198 s58 s204))+[GOOD] (define-fun s206 () Int (ite s187 s52 s205))+[GOOD] (define-fun s207 () Int (ite s194 s51 s206))+[GOOD] (define-fun s208 () Int (ite s190 s44 s207))+[GOOD] (define-fun s209 () Int (+ s186 s208))+[GOOD] (define-fun s210 () Bool ((as is-Var Bool) s7))+[GOOD] (define-fun s211 () String (getVar_1 s7))+[GOOD] (define-fun s212 () Bool (= s41 s211))+[GOOD] (define-fun s213 () Bool (and s210 s212))+[GOOD] (define-fun s214 () Bool (= s45 s211))+[GOOD] (define-fun s215 () Bool (= s47 s211))+[GOOD] (define-fun s216 () Bool (or s214 s215))+[GOOD] (define-fun s217 () Bool (and s210 s216))+[GOOD] (define-fun s218 () Bool ((as is-Val Bool) s7))+[GOOD] (define-fun s219 () Int (getVal_1 s7))+[GOOD] (define-fun s220 () Bool (< s219 s55))+[GOOD] (define-fun s221 () Bool (and s218 s220))+[GOOD] (define-fun s222 () Bool (= s55 s219))+[GOOD] (define-fun s223 () Bool (and s218 s222))+[GOOD] (define-fun s224 () Bool (> s219 s55))+[GOOD] (define-fun s225 () Bool (and s218 s224))+[GOOD] (define-fun s226 () Int (ite s225 s64 s65))+[GOOD] (define-fun s227 () Int (ite s223 s61 s226))+[GOOD] (define-fun s228 () Int (ite s221 s58 s227))+[GOOD] (define-fun s229 () Int (ite s210 s52 s228))+[GOOD] (define-fun s230 () Int (ite s217 s51 s229))+[GOOD] (define-fun s231 () Int (ite s213 s44 s230))+[GOOD] (define-fun s232 () Int (+ s209 s231))+[GOOD] (define-fun s233 () Bool ((as is-Var Bool) s8))+[GOOD] (define-fun s234 () String (getVar_1 s8))+[GOOD] (define-fun s235 () Bool (= s41 s234))+[GOOD] (define-fun s236 () Bool (and s233 s235))+[GOOD] (define-fun s237 () Bool (= s45 s234))+[GOOD] (define-fun s238 () Bool (= s47 s234))+[GOOD] (define-fun s239 () Bool (or s237 s238))+[GOOD] (define-fun s240 () Bool (and s233 s239))+[GOOD] (define-fun s241 () Bool ((as is-Val Bool) s8))+[GOOD] (define-fun s242 () Int (getVal_1 s8))+[GOOD] (define-fun s243 () Bool (< s242 s55))+[GOOD] (define-fun s244 () Bool (and s241 s243))+[GOOD] (define-fun s245 () Bool (= s55 s242))+[GOOD] (define-fun s246 () Bool (and s241 s245))+[GOOD] (define-fun s247 () Bool (> s242 s55))+[GOOD] (define-fun s248 () Bool (and s241 s247))+[GOOD] (define-fun s249 () Int (ite s248 s64 s65))+[GOOD] (define-fun s250 () Int (ite s246 s61 s249))+[GOOD] (define-fun s251 () Int (ite s244 s58 s250))+[GOOD] (define-fun s252 () Int (ite s233 s52 s251))+[GOOD] (define-fun s253 () Int (ite s240 s51 s252))+[GOOD] (define-fun s254 () Int (ite s236 s44 s253))+[GOOD] (define-fun s255 () Int (+ s232 s254))+[GOOD] (define-fun s256 () Bool ((as is-Var Bool) s9))+[GOOD] (define-fun s257 () String (getVar_1 s9))+[GOOD] (define-fun s258 () Bool (= s41 s257))+[GOOD] (define-fun s259 () Bool (and s256 s258))+[GOOD] (define-fun s260 () Bool (= s45 s257))+[GOOD] (define-fun s261 () Bool (= s47 s257))+[GOOD] (define-fun s262 () Bool (or s260 s261))+[GOOD] (define-fun s263 () Bool (and s256 s262))+[GOOD] (define-fun s264 () Bool ((as is-Val Bool) s9))+[GOOD] (define-fun s265 () Int (getVal_1 s9))+[GOOD] (define-fun s266 () Bool (< s265 s55))+[GOOD] (define-fun s267 () Bool (and s264 s266))+[GOOD] (define-fun s268 () Bool (= s55 s265))+[GOOD] (define-fun s269 () Bool (and s264 s268))+[GOOD] (define-fun s270 () Bool (> s265 s55))+[GOOD] (define-fun s271 () Bool (and s264 s270))+[GOOD] (define-fun s272 () Int (ite s271 s64 s65))+[GOOD] (define-fun s273 () Int (ite s269 s61 s272))+[GOOD] (define-fun s274 () Int (ite s267 s58 s273))+[GOOD] (define-fun s275 () Int (ite s256 s52 s274))+[GOOD] (define-fun s276 () Int (ite s263 s51 s275))+[GOOD] (define-fun s277 () Int (ite s259 s44 s276))+[GOOD] (define-fun s278 () Int (+ s255 s277))+[GOOD] (define-fun s280 () Bool (distinct s278 s279))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s38)+[GOOD] (assert s280)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr12c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr13.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Val Expr) 3))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s22 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr13c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr14.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s29 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr14c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr15.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 3) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s29 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr15c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr16.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Let Expr) "a" ((as Mul Expr) ((as Val Expr) 3) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))) ((as Add Expr) ((as Var Expr) "a") ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s29 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr16c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr17.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Let Expr) "a" ((as Mul Expr) ((as Val Expr) 3) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))) ((as Add Expr) ((as Var Expr) "a") ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))) ((as Let Expr) "a" ((as Let Expr) "a" ((as Mul Expr) ((as Val Expr) 3) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))) ((as Add Expr) ((as Var Expr) "a") ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))) ((as Add Expr) ((as Var Expr) "a") ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))))))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s29 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr17c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr18.gold view
@@ -0,0 +1,75 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Let Expr) "a" ((as Add Expr) ((as Let Expr) "a" ((as Mul Expr) ((as Val Expr) 3) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))) ((as Add Expr) ((as Var Expr) "a") ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))) ((as Let Expr) "a" ((as Let Expr) "a" ((as Mul Expr) ((as Val Expr) 3) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))) ((as Add Expr) ((as Var Expr) "a") ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))) ((as Add Expr) ((as Var Expr) "a") ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))))) ((as Mul Expr) ((as Var Expr) "a") ((as Var Expr) "a"))))+[GOOD] (define-fun s5 () String "a")+[GOOD] (define-fun s8 () Int 0)+[GOOD] (define-fun s9 () String "b")+[GOOD] (define-fun s11 () String "c")+[GOOD] (define-fun s15 () Int 1)+[GOOD] (define-fun s16 () Int 2)+[GOOD] (define-fun s19 () Int 10)+[GOOD] (define-fun s22 () Int 3)+[GOOD] (define-fun s25 () Int 4)+[GOOD] (define-fun s28 () Int 5)+[GOOD] (define-fun s29 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s4 () String (getVar_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s12 () Bool (= s4 s11))+[GOOD] (define-fun s13 () Bool (or s10 s12))+[GOOD] (define-fun s14 () Bool (and s3 s13))+[GOOD] (define-fun s17 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s18 () Int (getVal_1 s0))+[GOOD] (define-fun s20 () Bool (< s18 s19))+[GOOD] (define-fun s21 () Bool (and s17 s20))+[GOOD] (define-fun s23 () Bool (= s18 s19))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s26 () Bool (> s18 s19))+[GOOD] (define-fun s27 () Bool (and s17 s26))+[GOOD] (define-fun s30 () Int (ite s27 s28 s29))+[GOOD] (define-fun s31 () Int (ite s24 s25 s30))+[GOOD] (define-fun s32 () Int (ite s21 s22 s31))+[GOOD] (define-fun s33 () Int (ite s3 s16 s32))+[GOOD] (define-fun s34 () Int (ite s14 s15 s33))+[GOOD] (define-fun s35 () Int (ite s7 s8 s34))+[GOOD] (define-fun s36 () Bool (distinct s29 s35))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s36)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_expr18c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen00.gold view
@@ -0,0 +1,277 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer), valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)+[MEASURE] valid @(SBV [[Char]] -> SBV Expr -> SBV Bool): barified = "|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)|"+[MEASURE] valid @(SBV [[Char]] -> SBV Expr -> SBV Bool): Uninterpreted ops in DAG: [("|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)|",2),("|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)|",2),("|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)|",2),("|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)|",2),("|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)|",2),("|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)|",2)]+[MEASURE] valid @(SBV [[Char]] -> SBV Expr -> SBV Bool): recursive calls found = 6+[MEASURE] valid @(SBV [[Char]] -> SBV Expr -> SBV Bool): trying sbv.dt.size.Expr arg2+[MEASURE] valid @(SBV [[Char]] -> SBV Expr -> SBV Bool): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] valid @(SBV [[Char]] -> SBV Expr -> SBV Bool): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () (Seq String) (as seq.empty (Seq String)))+[GOOD] (define-fun s3 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s5 () Int 12)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)| :: [SString] -> Expr -> SBool [Recursive]+[GOOD] (define-fun-rec |valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)| ((l1_s0 (Seq String)) (l1_s1 Expr)) Bool+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 ((as is-Var Bool) l1_s1)))+ (let ((l1_s4 (getVar_1 l1_s1)))+ (let ((l1_s5 (str.in_re l1_s4 (re.++ (re.range "a" "z") (re.* (re.union (re.range "a" "z") (re.range "A" "Z") (re.range "0" "9")))))))+ (let ((l1_s6 (seq.unit l1_s4)))+ (let ((l1_s7 (seq.contains l1_s0 l1_s6)))+ (let ((l1_s8 (and l1_s5 l1_s7)))+ (let ((l1_s9 ((as is-Add Bool) l1_s1)))+ (let ((l1_s10 (getAdd_1 l1_s1)))+ (let ((l1_s11 (|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)| l1_s0 l1_s10)))+ (let ((l1_s12 (getAdd_2 l1_s1)))+ (let ((l1_s13 (|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)| l1_s0 l1_s12)))+ (let ((l1_s14 (and l1_s11 l1_s13)))+ (let ((l1_s15 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s16 (getMul_1 l1_s1)))+ (let ((l1_s17 (|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)| l1_s0 l1_s16)))+ (let ((l1_s18 (getMul_2 l1_s1)))+ (let ((l1_s19 (|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)| l1_s0 l1_s18)))+ (let ((l1_s20 (and l1_s17 l1_s19)))+ (let ((l1_s21 (getLet_1 l1_s1)))+ (let ((l1_s22 (str.in_re l1_s21 (re.++ (re.range "a" "z") (re.* (re.union (re.range "a" "z") (re.range "A" "Z") (re.range "0" "9")))))))+ (let ((l1_s23 (getLet_2 l1_s1)))+ (let ((l1_s24 (|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)| l1_s0 l1_s23)))+ (let ((l1_s25 (seq.unit l1_s21)))+ (let ((l1_s26 (seq.++ l1_s25 l1_s0)))+ (let ((l1_s27 (getLet_3 l1_s1)))+ (let ((l1_s28 (|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)| l1_s26 l1_s27)))+ (let ((l1_s29 (and l1_s24 l1_s28)))+ (let ((l1_s30 (and l1_s22 l1_s29)))+ (let ((l1_s31 (ite l1_s15 l1_s20 l1_s30)))+ (let ((l1_s32 (ite l1_s9 l1_s14 l1_s31)))+ (let ((l1_s33 (ite l1_s3 l1_s8 l1_s32)))+ (let ((l1_s34 (or l1_s2 l1_s33)))+ l1_s34))))))))))))))))))))))))))))))))))+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (|valid @(SBV [[Char]] -> SBV Expr -> SBV Bool)| s1 s0))+[GOOD] (define-fun s4 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s3 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s8 () Expr (getLet_3 s0))+[GOOD] (define-fun s9 () Bool ((as is-Let Bool) s8))+[GOOD] (define-fun s10 () Expr (getLet_3 s8))+[GOOD] (define-fun s11 () Bool ((as is-Add Bool) s10))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s6)+[GOOD] (assert s7)+[GOOD] (assert s9)+[GOOD] (assert s11)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Let "l"+ (Val 6)+ (Let "a" (Val 0) (Add (Mul (Val 3) (Let "p" (Val 4) (Var "p"))) (Var "a"))))))++Got: (let l = 6 in (let a = 0 in ((3 * (let p = 4 in p)) + a)))+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen01.gold view
@@ -0,0 +1,83 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] (define-fun s43 () Int (- 1))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s44 () Bool (= s42 s43))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s44)+[SEND] (check-sat)+[RECV] unsat++UNSAT+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen02.gold view
@@ -0,0 +1,85 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s6 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Var "a")))++Got: a+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen03.gold view
@@ -0,0 +1,85 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s13 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Var "b")))++Got: b+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen04.gold view
@@ -0,0 +1,85 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s14 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Var "")))++Got: +DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen05.gold view
@@ -0,0 +1,85 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s20 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Val 0)))++Got: 0+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen06.gold view
@@ -0,0 +1,85 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s23 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Val 10)))++Got: 10+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen07.gold view
@@ -0,0 +1,85 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s26 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Val 11)))++Got: 11+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen08.gold view
@@ -0,0 +1,85 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s28 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Add (Var "!0!") (Var "!0!"))))++Got: (!0! + !0!)+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen09.gold view
@@ -0,0 +1,85 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s30 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Mul (Var "!0!") (Var "!0!"))))++Got: (!0! * !0!)+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen10.gold view
@@ -0,0 +1,85 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s32 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Let "!0!" (Var "!0!") (Var "!0!"))))++Got: (let !0! = !0! in !0!)+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen11.gold view
@@ -0,0 +1,83 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] (define-fun s43 () Int 9)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s44 () Bool (= s42 s43))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s44)+[SEND] (check-sat)+[RECV] unsat++UNSAT+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_gen12.gold view
@@ -0,0 +1,82 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () String "a")+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s7 () String "b")+[GOOD] (define-fun s9 () String "c")+[GOOD] (define-fun s13 () Int 1)+[GOOD] (define-fun s14 () Int 2)+[GOOD] (define-fun s17 () Int 10)+[GOOD] (define-fun s20 () Int 3)+[GOOD] (define-fun s23 () Int 4)+[GOOD] (define-fun s26 () Int 5)+[GOOD] (define-fun s28 () Int 6)+[GOOD] (define-fun s30 () Int 7)+[GOOD] (define-fun s32 () Int 8)+[GOOD] (define-fun s33 () Int 100)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Var Bool) s0))+[GOOD] (define-fun s2 () String (getVar_1 s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (define-fun s5 () Bool (and s1 s4))+[GOOD] (define-fun s8 () Bool (= s2 s7))+[GOOD] (define-fun s10 () Bool (= s2 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (and s1 s11))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s16 () Int (getVal_1 s0))+[GOOD] (define-fun s18 () Bool (< s16 s17))+[GOOD] (define-fun s19 () Bool (and s15 s18))+[GOOD] (define-fun s21 () Bool (= s16 s17))+[GOOD] (define-fun s22 () Bool (and s15 s21))+[GOOD] (define-fun s24 () Bool (> s16 s17))+[GOOD] (define-fun s25 () Bool (and s15 s24))+[GOOD] (define-fun s27 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s29 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s31 () Bool ((as is-Let Bool) s0))+[GOOD] (define-fun s34 () Int (ite s31 s32 s33))+[GOOD] (define-fun s35 () Int (ite s29 s30 s34))+[GOOD] (define-fun s36 () Int (ite s27 s28 s35))+[GOOD] (define-fun s37 () Int (ite s25 s26 s36))+[GOOD] (define-fun s38 () Int (ite s22 s23 s37))+[GOOD] (define-fun s39 () Int (ite s19 s20 s38))+[GOOD] (define-fun s40 () Int (ite s1 s14 s39))+[GOOD] (define-fun s41 () Int (ite s12 s13 s40))+[GOOD] (define-fun s42 () Int (ite s5 s6 s41))+[GOOD] (define-fun s43 () Bool (= s33 s42))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s43)+[SEND] (check-sat)+[RECV] unsat++UNSAT+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit00.gold view
@@ -0,0 +1,240 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s5 () Int 0)+[GOOD] (define-fun s8 () Int 100)+[GOOD] (define-fun s9 () Int 1)+[GOOD] (define-fun s12 () Int 200)+[GOOD] (define-fun s20 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s4 () Int (getVal_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s11 () Bool (and s3 s10))+[GOOD] (define-fun s13 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s14 () Expr (getAdd_1 s0))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Int (getVal_1 s14))+[GOOD] (define-fun s17 () Bool (= s5 s16))+[GOOD] (define-fun s18 () Bool (and s15 s17))+[GOOD] (define-fun s19 () Bool (and s13 s18))+[GOOD] (define-fun s21 () Expr (getAdd_2 s0))+[GOOD] (define-fun s22 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s21))+[GOOD] (define-fun s23 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s0))+[GOOD] (define-fun s24 () Int (ite s19 s22 s23))+[GOOD] (define-fun s25 () Int (ite s11 s12 s24))+[GOOD] (define-fun s26 () Int (ite s7 s8 s25))+[GOOD] (define-fun s27 () Bool (distinct s8 s26))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s27)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit00c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit01.gold view
@@ -0,0 +1,240 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Val Expr) 1))+[GOOD] (define-fun s5 () Int 0)+[GOOD] (define-fun s8 () Int 100)+[GOOD] (define-fun s9 () Int 1)+[GOOD] (define-fun s12 () Int 200)+[GOOD] (define-fun s20 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s4 () Int (getVal_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s11 () Bool (and s3 s10))+[GOOD] (define-fun s13 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s14 () Expr (getAdd_1 s0))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Int (getVal_1 s14))+[GOOD] (define-fun s17 () Bool (= s5 s16))+[GOOD] (define-fun s18 () Bool (and s15 s17))+[GOOD] (define-fun s19 () Bool (and s13 s18))+[GOOD] (define-fun s21 () Expr (getAdd_2 s0))+[GOOD] (define-fun s22 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s21))+[GOOD] (define-fun s23 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s0))+[GOOD] (define-fun s24 () Int (ite s19 s22 s23))+[GOOD] (define-fun s25 () Int (ite s11 s12 s24))+[GOOD] (define-fun s26 () Int (ite s7 s8 s25))+[GOOD] (define-fun s27 () Bool (distinct s12 s26))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s27)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit01c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit02.gold view
@@ -0,0 +1,241 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Val Expr) 2))+[GOOD] (define-fun s5 () Int 0)+[GOOD] (define-fun s8 () Int 100)+[GOOD] (define-fun s9 () Int 1)+[GOOD] (define-fun s12 () Int 200)+[GOOD] (define-fun s20 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s27 () Int 2)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s4 () Int (getVal_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s11 () Bool (and s3 s10))+[GOOD] (define-fun s13 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s14 () Expr (getAdd_1 s0))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Int (getVal_1 s14))+[GOOD] (define-fun s17 () Bool (= s5 s16))+[GOOD] (define-fun s18 () Bool (and s15 s17))+[GOOD] (define-fun s19 () Bool (and s13 s18))+[GOOD] (define-fun s21 () Expr (getAdd_2 s0))+[GOOD] (define-fun s22 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s21))+[GOOD] (define-fun s23 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s0))+[GOOD] (define-fun s24 () Int (ite s19 s22 s23))+[GOOD] (define-fun s25 () Int (ite s11 s12 s24))+[GOOD] (define-fun s26 () Int (ite s7 s8 s25))+[GOOD] (define-fun s28 () Bool (distinct s26 s27))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s28)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit02c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit03.gold view
@@ -0,0 +1,241 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 0) ((as Val Expr) 5)))+[GOOD] (define-fun s5 () Int 0)+[GOOD] (define-fun s8 () Int 100)+[GOOD] (define-fun s9 () Int 1)+[GOOD] (define-fun s12 () Int 200)+[GOOD] (define-fun s20 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s27 () Int 5)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s4 () Int (getVal_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s11 () Bool (and s3 s10))+[GOOD] (define-fun s13 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s14 () Expr (getAdd_1 s0))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Int (getVal_1 s14))+[GOOD] (define-fun s17 () Bool (= s5 s16))+[GOOD] (define-fun s18 () Bool (and s15 s17))+[GOOD] (define-fun s19 () Bool (and s13 s18))+[GOOD] (define-fun s21 () Expr (getAdd_2 s0))+[GOOD] (define-fun s22 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s21))+[GOOD] (define-fun s23 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s0))+[GOOD] (define-fun s24 () Int (ite s19 s22 s23))+[GOOD] (define-fun s25 () Int (ite s11 s12 s24))+[GOOD] (define-fun s26 () Int (ite s7 s8 s25))+[GOOD] (define-fun s28 () Bool (distinct s26 s27))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s28)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit03c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit04.gold view
@@ -0,0 +1,241 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 1) ((as Val Expr) 5)))+[GOOD] (define-fun s5 () Int 0)+[GOOD] (define-fun s8 () Int 100)+[GOOD] (define-fun s9 () Int 1)+[GOOD] (define-fun s12 () Int 200)+[GOOD] (define-fun s20 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s27 () Int 6)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s4 () Int (getVal_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s11 () Bool (and s3 s10))+[GOOD] (define-fun s13 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s14 () Expr (getAdd_1 s0))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Int (getVal_1 s14))+[GOOD] (define-fun s17 () Bool (= s5 s16))+[GOOD] (define-fun s18 () Bool (and s15 s17))+[GOOD] (define-fun s19 () Bool (and s13 s18))+[GOOD] (define-fun s21 () Expr (getAdd_2 s0))+[GOOD] (define-fun s22 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s21))+[GOOD] (define-fun s23 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s0))+[GOOD] (define-fun s24 () Int (ite s19 s22 s23))+[GOOD] (define-fun s25 () Int (ite s11 s12 s24))+[GOOD] (define-fun s26 () Int (ite s7 s8 s25))+[GOOD] (define-fun s28 () Bool (distinct s26 s27))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s28)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit04c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit05.gold view
@@ -0,0 +1,240 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Var Expr) "x"))+[GOOD] (define-fun s5 () Int 0)+[GOOD] (define-fun s8 () Int 100)+[GOOD] (define-fun s9 () Int 1)+[GOOD] (define-fun s12 () Int 200)+[GOOD] (define-fun s20 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Val Bool) s0))+[GOOD] (define-fun s4 () Int (getVal_1 s0))+[GOOD] (define-fun s6 () Bool (= s4 s5))+[GOOD] (define-fun s7 () Bool (and s3 s6))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (define-fun s11 () Bool (and s3 s10))+[GOOD] (define-fun s13 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s14 () Expr (getAdd_1 s0))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Int (getVal_1 s14))+[GOOD] (define-fun s17 () Bool (= s5 s16))+[GOOD] (define-fun s18 () Bool (and s15 s17))+[GOOD] (define-fun s19 () Bool (and s13 s18))+[GOOD] (define-fun s21 () Expr (getAdd_2 s0))+[GOOD] (define-fun s22 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s21))+[GOOD] (define-fun s23 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s20 s0))+[GOOD] (define-fun s24 () Int (ite s19 s22 s23))+[GOOD] (define-fun s25 () Int (ite s11 s12 s24))+[GOOD] (define-fun s26 () Int (ite s7 s8 s25))+[GOOD] (define-fun s27 () Bool (distinct s5 s26))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s27)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_lit05c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_mr00.gold view
@@ -0,0 +1,69 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (par (var val) (+ (Con (getCon_1 val))+ (Var (getVar_1 var))+ (Add (getAdd_1 (Expr var val)) (getAdd_2 (Expr var val)))+ (Mul (getMul_1 (Expr var val)) (getMul_2 (Expr var val)))+ )))+[GOOD] ; User defined ADT: Stmt+[GOOD] (declare-datatype Stmt (par (var val) (+ (Assign (getAssign_1 var) (getAssign_2 (Expr var val)))+ (Seq (getSeq_1 (Stmt var val)) (getSeq_2 (Stmt var val)))+ )))+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Stmt String Int)) ; tracks user variable "p"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Seq Bool) s0))+[GOOD] (define-fun s2 () (Stmt String Int) (getSeq_2 s0))+[GOOD] (define-fun s3 () Bool ((as is-Seq Bool) s2))+[GOOD] (define-fun s4 () (Stmt String Int) (getSeq_2 s2))+[GOOD] (define-fun s5 () Bool ((as is-Seq Bool) s4))+[GOOD] (define-fun s6 () (Stmt String Int) (getSeq_2 s4))+[GOOD] (define-fun s7 () Bool ((as is-Assign Bool) s6))+[GOOD] (define-fun s8 () (Expr String Int) (getAssign_2 s6))+[GOOD] (define-fun s9 () Bool ((as is-Add Bool) s8))+[GOOD] (define-fun s10 () (Expr String Int) (getAdd_1 s8))+[GOOD] (define-fun s11 () Bool ((as is-Var Bool) s10))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s1)+[GOOD] (assert s3)+[GOOD] (assert s5)+[GOOD] (assert s7)+[GOOD] (assert s9)+[GOOD] (assert s11)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Seq (Assign "!3!" (Var "!6!"))+ (Seq (Assign "!5!" (Var "!8!"))+ (Seq (Assign "!4!" (Var "!7!"))+ (Assign "!0!" (Add (Var "!1!") (Var "!2!"))))))))++Got:+!3! := !6!;+!5! := !8!;+!4! := !7!;+!0! := (!1! + !2!)+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_mr01.gold view
@@ -0,0 +1,73 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Maybe+[GOOD] (declare-datatype Maybe (par (a) (+ (Nothing)+ (Just (getJust_1 a))+ )))+[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (par (var val) (+ (Con (getCon_1 val))+ (Var (getVar_1 var))+ (Add (getAdd_1 (Expr var val)) (getAdd_2 (Expr var val)))+ (Mul (getMul_1 (Expr var val)) (getMul_2 (Expr var val)))+ )))+[GOOD] ; User defined ADT: Stmt+[GOOD] (declare-datatype Stmt (par (var val) (+ (Assign (getAssign_1 var) (getAssign_2 (Expr var val)))+ (Seq (getSeq_1 (Stmt var val)) (getSeq_2 (Stmt var val)))+ )))+[GOOD] ; User defined ADT: Either+[GOOD] (declare-datatype Either (par (a b) (+ (Left (getLeft_1 a))+ (Right (getRight_1 b))+ )))+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Stmt String (Maybe (Either Int Bool)))) ; tracks user variable "p"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Assign Bool) s0))+[GOOD] (define-fun s2 () (Expr String (Maybe (Either Int Bool))) (getAssign_2 s0))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s2))+[GOOD] (define-fun s4 () (Expr String (Maybe (Either Int Bool))) (getAdd_1 s2))+[GOOD] (define-fun s5 () Bool ((as is-Con Bool) s4))+[GOOD] (define-fun s6 () (Expr String (Maybe (Either Int Bool))) (getAdd_2 s2))+[GOOD] (define-fun s7 () Bool ((as is-Con Bool) s6))+[GOOD] (define-fun s8 () (Maybe (Either Int Bool)) (getCon_1 s4))+[GOOD] (define-fun s9 () Bool ((as is-Nothing Bool) s8))+[GOOD] (define-fun s10 () (Maybe (Either Int Bool)) (getCon_1 s6))+[GOOD] (define-fun s11 () Bool ((as is-Just Bool) s10))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s1)+[GOOD] (assert s3)+[GOOD] (assert s5)+[GOOD] (assert s7)+[GOOD] (assert s9)+[GOOD] (assert s11)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (Assign "!0!" (Add (Con Nothing) (Con (Just (Left 2)))))))++Got:+!0! := (Nothing + Just (Left 2))+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_mr02.gold view
@@ -0,0 +1,50 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: A+[GOOD] (declare-datatype A (par (a b) (+ (Aa (getAa_1 a))+ (Ab (getAb_1 b))+ (Aab (getAab_1 a) (getAab_2 b))+ (A2 (getA2_1 (A b String)))+ (A3 (getA3_1 (A b a)))+ )))+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (A Int Bool)) ; tracks user variable "p"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-A2 Bool) s0))+[GOOD] (define-fun s2 () (A Bool String) (getA2_1 s0))+[GOOD] (define-fun s3 () Bool ((as is-A2 Bool) s2))+[GOOD] (define-fun s4 () (A String String) (getA2_1 s2))+[GOOD] (define-fun s5 () Bool ((as is-Aa Bool) s4))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s1)+[GOOD] (assert s3)+[GOOD] (assert s5)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (A2 ((as A2 (A Bool String)) (Aa "!0!")))))++Got:+A2 {a2 = A2 {a2 = Aa {aa = "!0!"}}}+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_mr03.gold view
@@ -0,0 +1,47 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: A+[GOOD] (declare-datatype A (par (a b) (+ (Aa (getAa_1 a))+ (Ab (getAb_1 b))+ (Aab (getAab_1 a) (getAab_2 b))+ (A2 (getA2_1 (A b String)))+ (A3 (getA3_1 (A b a)))+ )))+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (A Int Bool)) ; tracks user variable "p"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-A3 Bool) s0))+[GOOD] (define-fun s2 () (A Bool Int) (getA3_1 s0))+[GOOD] (define-fun s3 () Bool ((as is-Ab Bool) s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s1)+[GOOD] (assert s3)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (A3 (Ab 2))))++Got:+A3 {a3 = Ab {ab = 2}}+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_mr04.gold view
@@ -0,0 +1,51 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: A+[GOOD] (declare-datatype A (par (a b) (+ (Aa (getAa_1 a))+ (Ab (getAb_1 b))+ (Aab (getAab_1 a) (getAab_2 b))+ (A2 (getA2_1 (A b String)))+ (A3 (getA3_1 (A b a)))+ )))+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (A Int (A (_ FloatingPoint 8 24) Bool))) ; tracks user variable "p"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-A2 Bool) s0))+[GOOD] (define-fun s2 () (A (A (_ FloatingPoint 8 24) Bool) String) (getA2_1 s0))+[GOOD] (define-fun s3 () Bool ((as is-A3 Bool) s2))+[GOOD] (define-fun s4 () (A String (A (_ FloatingPoint 8 24) Bool)) (getA3_1 s2))+[GOOD] (define-fun s5 () Bool ((as is-Aab Bool) s4))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s1)+[GOOD] (assert s3)+[GOOD] (assert s5)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 ((as A2 (A Int (A (_ FloatingPoint 8 24) Bool))) (A3 (Aab "!0!"+ (Aab (_ +zero 8 24) false))))))++Got:+A2 {a2 = A3 {a3 = Aab {aba = "!0!", abb = Aab {aba = 0.0, abb = False}}}}+DONE+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested00.gold view
@@ -0,0 +1,80 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 0) ((as Val Expr) 5)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s40 () Expr ((as Val Expr) 5))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s41 () Bool (distinct s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s41)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested00c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested01.gold view
@@ -0,0 +1,80 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 7) ((as Val Expr) 0)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s40 () Expr ((as Val Expr) 7))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s41 () Bool (distinct s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s41)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested01c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested02.gold view
@@ -0,0 +1,80 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 1) ((as Val Expr) 9)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s40 () Expr ((as Val Expr) 9))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s41 () Bool (distinct s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s41)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested02c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested03.gold view
@@ -0,0 +1,80 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 4) ((as Val Expr) 1)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s40 () Expr ((as Val Expr) 4))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s41 () Bool (distinct s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s41)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested03c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested04.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 0) ((as Val Expr) 99)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s34 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested04c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested05.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s1 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested05c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested06.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 1) ((as Val Expr) 5)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s1 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested06c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested07.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 0) ((as Val Expr) 0)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s34 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested07c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested08.gold view
@@ -0,0 +1,80 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 1) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s40 () Expr ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s41 () Bool (distinct s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s41)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested08c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested09.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 0) ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4))))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s34 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested09c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested10.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Var Expr) "x"))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s1 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested10c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested11.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Val Expr) 42))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s1 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested11c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested12.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Let Expr) "x" ((as Val Expr) 1) ((as Var Expr) "x")))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s1 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested12c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested13.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 0) ((as Var Expr) "x")))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s34 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested13c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested14.gold view
@@ -0,0 +1,80 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 0) ((as Mul Expr) ((as Val Expr) 2) ((as Val Expr) 3))))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s40 () Expr ((as Mul Expr) ((as Val Expr) 2) ((as Val Expr) 3)))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s41 () Bool (distinct s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s41)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested14c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested15.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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 0) ((as Val Expr) 5)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s74 () Expr ((as Val Expr) 5))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool ((as is-Add Bool) s39))+[GOOD] (define-fun s41 () Expr (getAdd_1 s39))+[GOOD] (define-fun s42 () Bool ((as is-Val Bool) s41))+[GOOD] (define-fun s43 () Int (getVal_1 s41))+[GOOD] (define-fun s44 () Bool (= s7 s43))+[GOOD] (define-fun s45 () Bool (and s42 s44))+[GOOD] (define-fun s46 () Bool (and s40 s45))+[GOOD] (define-fun s47 () Expr (getAdd_2 s39))+[GOOD] (define-fun s48 () Bool ((as is-Val Bool) s47))+[GOOD] (define-fun s49 () Int (getVal_1 s47))+[GOOD] (define-fun s50 () Bool (= s7 s49))+[GOOD] (define-fun s51 () Bool (and s48 s50))+[GOOD] (define-fun s52 () Bool (and s40 s51))+[GOOD] (define-fun s53 () Bool ((as is-Mul Bool) s39))+[GOOD] (define-fun s54 () Expr (getMul_1 s39))+[GOOD] (define-fun s55 () Bool ((as is-Val Bool) s54))+[GOOD] (define-fun s56 () Int (getVal_1 s54))+[GOOD] (define-fun s57 () Bool (= s21 s56))+[GOOD] (define-fun s58 () Bool (and s55 s57))+[GOOD] (define-fun s59 () Bool (and s53 s58))+[GOOD] (define-fun s60 () Expr (getMul_2 s39))+[GOOD] (define-fun s61 () Bool ((as is-Val Bool) s60))+[GOOD] (define-fun s62 () Int (getVal_1 s60))+[GOOD] (define-fun s63 () Bool (= s21 s62))+[GOOD] (define-fun s64 () Bool (and s61 s63))+[GOOD] (define-fun s65 () Bool (and s53 s64))+[GOOD] (define-fun s66 () Bool (= s7 s56))+[GOOD] (define-fun s67 () Bool (and s55 s66))+[GOOD] (define-fun s68 () Bool (and s53 s67))+[GOOD] (define-fun s69 () Expr (ite s68 s34 s39))+[GOOD] (define-fun s70 () Expr (ite s65 s54 s69))+[GOOD] (define-fun s71 () Expr (ite s59 s60 s70))+[GOOD] (define-fun s72 () Expr (ite s52 s41 s71))+[GOOD] (define-fun s73 () Expr (ite s46 s47 s72))+[GOOD] (define-fun s75 () Bool (distinct s73 s74))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s75)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested15c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested16.gold view
@@ -0,0 +1,113 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 3) ((as Val Expr) 4)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool ((as is-Add Bool) s39))+[GOOD] (define-fun s41 () Expr (getAdd_1 s39))+[GOOD] (define-fun s42 () Bool ((as is-Val Bool) s41))+[GOOD] (define-fun s43 () Int (getVal_1 s41))+[GOOD] (define-fun s44 () Bool (= s7 s43))+[GOOD] (define-fun s45 () Bool (and s42 s44))+[GOOD] (define-fun s46 () Bool (and s40 s45))+[GOOD] (define-fun s47 () Expr (getAdd_2 s39))+[GOOD] (define-fun s48 () Bool ((as is-Val Bool) s47))+[GOOD] (define-fun s49 () Int (getVal_1 s47))+[GOOD] (define-fun s50 () Bool (= s7 s49))+[GOOD] (define-fun s51 () Bool (and s48 s50))+[GOOD] (define-fun s52 () Bool (and s40 s51))+[GOOD] (define-fun s53 () Bool ((as is-Mul Bool) s39))+[GOOD] (define-fun s54 () Expr (getMul_1 s39))+[GOOD] (define-fun s55 () Bool ((as is-Val Bool) s54))+[GOOD] (define-fun s56 () Int (getVal_1 s54))+[GOOD] (define-fun s57 () Bool (= s21 s56))+[GOOD] (define-fun s58 () Bool (and s55 s57))+[GOOD] (define-fun s59 () Bool (and s53 s58))+[GOOD] (define-fun s60 () Expr (getMul_2 s39))+[GOOD] (define-fun s61 () Bool ((as is-Val Bool) s60))+[GOOD] (define-fun s62 () Int (getVal_1 s60))+[GOOD] (define-fun s63 () Bool (= s21 s62))+[GOOD] (define-fun s64 () Bool (and s61 s63))+[GOOD] (define-fun s65 () Bool (and s53 s64))+[GOOD] (define-fun s66 () Bool (= s7 s56))+[GOOD] (define-fun s67 () Bool (and s55 s66))+[GOOD] (define-fun s68 () Bool (and s53 s67))+[GOOD] (define-fun s69 () Expr (ite s68 s34 s39))+[GOOD] (define-fun s70 () Expr (ite s65 s54 s69))+[GOOD] (define-fun s71 () Expr (ite s59 s60 s70))+[GOOD] (define-fun s72 () Expr (ite s52 s41 s71))+[GOOD] (define-fun s73 () Expr (ite s46 s47 s72))+[GOOD] (define-fun s74 () Bool (distinct s1 s73))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s74)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested16c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested17.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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 1) ((as Add Expr) ((as Val Expr) 0) ((as Val Expr) 5))))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s74 () Expr ((as Val Expr) 5))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool ((as is-Add Bool) s39))+[GOOD] (define-fun s41 () Expr (getAdd_1 s39))+[GOOD] (define-fun s42 () Bool ((as is-Val Bool) s41))+[GOOD] (define-fun s43 () Int (getVal_1 s41))+[GOOD] (define-fun s44 () Bool (= s7 s43))+[GOOD] (define-fun s45 () Bool (and s42 s44))+[GOOD] (define-fun s46 () Bool (and s40 s45))+[GOOD] (define-fun s47 () Expr (getAdd_2 s39))+[GOOD] (define-fun s48 () Bool ((as is-Val Bool) s47))+[GOOD] (define-fun s49 () Int (getVal_1 s47))+[GOOD] (define-fun s50 () Bool (= s7 s49))+[GOOD] (define-fun s51 () Bool (and s48 s50))+[GOOD] (define-fun s52 () Bool (and s40 s51))+[GOOD] (define-fun s53 () Bool ((as is-Mul Bool) s39))+[GOOD] (define-fun s54 () Expr (getMul_1 s39))+[GOOD] (define-fun s55 () Bool ((as is-Val Bool) s54))+[GOOD] (define-fun s56 () Int (getVal_1 s54))+[GOOD] (define-fun s57 () Bool (= s21 s56))+[GOOD] (define-fun s58 () Bool (and s55 s57))+[GOOD] (define-fun s59 () Bool (and s53 s58))+[GOOD] (define-fun s60 () Expr (getMul_2 s39))+[GOOD] (define-fun s61 () Bool ((as is-Val Bool) s60))+[GOOD] (define-fun s62 () Int (getVal_1 s60))+[GOOD] (define-fun s63 () Bool (= s21 s62))+[GOOD] (define-fun s64 () Bool (and s61 s63))+[GOOD] (define-fun s65 () Bool (and s53 s64))+[GOOD] (define-fun s66 () Bool (= s7 s56))+[GOOD] (define-fun s67 () Bool (and s55 s66))+[GOOD] (define-fun s68 () Bool (and s53 s67))+[GOOD] (define-fun s69 () Expr (ite s68 s34 s39))+[GOOD] (define-fun s70 () Expr (ite s65 s54 s69))+[GOOD] (define-fun s71 () Expr (ite s59 s60 s70))+[GOOD] (define-fun s72 () Expr (ite s52 s41 s71))+[GOOD] (define-fun s73 () Expr (ite s46 s47 s72))+[GOOD] (define-fun s75 () Bool (distinct s73 s74))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s75)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested17c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested18.gold view
@@ -0,0 +1,252 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s20 () Int 1)+[GOOD] (define-fun s33 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "e"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s3 () Expr (getAdd_1 s0))+[GOOD] (define-fun s4 () Bool ((as is-Val Bool) s3))+[GOOD] (define-fun s5 () Int (getVal_1 s3))+[GOOD] (define-fun s7 () Bool (= s5 s6))+[GOOD] (define-fun s8 () Bool (and s4 s7))+[GOOD] (define-fun s9 () Bool (and s2 s8))+[GOOD] (define-fun s10 () Expr (getAdd_2 s0))+[GOOD] (define-fun s11 () Bool ((as is-Val Bool) s10))+[GOOD] (define-fun s12 () Int (getVal_1 s10))+[GOOD] (define-fun s13 () Bool (= s6 s12))+[GOOD] (define-fun s14 () Bool (and s11 s13))+[GOOD] (define-fun s15 () Bool (and s2 s14))+[GOOD] (define-fun s16 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s17 () Expr (getMul_1 s0))+[GOOD] (define-fun s18 () Bool ((as is-Val Bool) s17))+[GOOD] (define-fun s19 () Int (getVal_1 s17))+[GOOD] (define-fun s21 () Bool (= s19 s20))+[GOOD] (define-fun s22 () Bool (and s18 s21))+[GOOD] (define-fun s23 () Bool (and s16 s22))+[GOOD] (define-fun s24 () Expr (getMul_2 s0))+[GOOD] (define-fun s25 () Bool ((as is-Val Bool) s24))+[GOOD] (define-fun s26 () Int (getVal_1 s24))+[GOOD] (define-fun s27 () Bool (= s20 s26))+[GOOD] (define-fun s28 () Bool (and s25 s27))+[GOOD] (define-fun s29 () Bool (and s16 s28))+[GOOD] (define-fun s30 () Bool (= s6 s19))+[GOOD] (define-fun s31 () Bool (and s18 s30))+[GOOD] (define-fun s32 () Bool (and s16 s31))+[GOOD] (define-fun s34 () Expr (ite s32 s33 s0))+[GOOD] (define-fun s35 () Expr (ite s29 s17 s34))+[GOOD] (define-fun s36 () Expr (ite s23 s24 s35))+[GOOD] (define-fun s37 () Expr (ite s15 s3 s36))+[GOOD] (define-fun s38 () Expr (ite s9 s10 s37))+[GOOD] (define-fun s39 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s1 s38))+[GOOD] (define-fun s40 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s1 s0))+[GOOD] (define-fun s41 () Bool (= s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s41))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested19.gold view
@@ -0,0 +1,80 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 1) ((as Val Expr) 1)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s40 () Expr ((as Val Expr) 1))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s41 () Bool (distinct s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s41)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested19c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested20.gold view
@@ -0,0 +1,79 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 2) ((as Val Expr) 3)))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool (distinct s1 s39))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s40)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested20c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested21.gold view
@@ -0,0 +1,80 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 1) ((as Var Expr) "x")))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s40 () Expr ((as Var Expr) "x"))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s41 () Bool (distinct s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s41)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested21c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested22.gold view
@@ -0,0 +1,80 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 0) ((as Var Expr) "x")))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s40 () Expr ((as Var Expr) "x"))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s41 () Bool (distinct s39 s40))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s41)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested22c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested23.gold view
@@ -0,0 +1,253 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s2 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s20 () Int 1)+[GOOD] (define-fun s33 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "e"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s3 () Expr (getAdd_1 s0))+[GOOD] (define-fun s4 () Bool ((as is-Val Bool) s3))+[GOOD] (define-fun s5 () Int (getVal_1 s3))+[GOOD] (define-fun s7 () Bool (= s5 s6))+[GOOD] (define-fun s8 () Bool (and s4 s7))+[GOOD] (define-fun s9 () Bool (and s1 s8))+[GOOD] (define-fun s10 () Expr (getAdd_2 s0))+[GOOD] (define-fun s11 () Bool ((as is-Val Bool) s10))+[GOOD] (define-fun s12 () Int (getVal_1 s10))+[GOOD] (define-fun s13 () Bool (= s6 s12))+[GOOD] (define-fun s14 () Bool (and s11 s13))+[GOOD] (define-fun s15 () Bool (and s1 s14))+[GOOD] (define-fun s16 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s17 () Expr (getMul_1 s0))+[GOOD] (define-fun s18 () Bool ((as is-Val Bool) s17))+[GOOD] (define-fun s19 () Int (getVal_1 s17))+[GOOD] (define-fun s21 () Bool (= s19 s20))+[GOOD] (define-fun s22 () Bool (and s18 s21))+[GOOD] (define-fun s23 () Bool (and s16 s22))+[GOOD] (define-fun s24 () Expr (getMul_2 s0))+[GOOD] (define-fun s25 () Bool ((as is-Val Bool) s24))+[GOOD] (define-fun s26 () Int (getVal_1 s24))+[GOOD] (define-fun s27 () Bool (= s20 s26))+[GOOD] (define-fun s28 () Bool (and s25 s27))+[GOOD] (define-fun s29 () Bool (and s16 s28))+[GOOD] (define-fun s30 () Bool (= s6 s19))+[GOOD] (define-fun s31 () Bool (and s18 s30))+[GOOD] (define-fun s32 () Bool (and s16 s31))+[GOOD] (define-fun s34 () Expr (ite s32 s33 s0))+[GOOD] (define-fun s35 () Expr (ite s29 s17 s34))+[GOOD] (define-fun s36 () Expr (ite s23 s24 s35))+[GOOD] (define-fun s37 () Expr (ite s15 s3 s36))+[GOOD] (define-fun s38 () Expr (ite s9 s10 s37))+[GOOD] (define-fun s39 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s2 s38))+[GOOD] (define-fun s40 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s2 s0))+[GOOD] (define-fun s41 () Bool (= s39 s40))+[GOOD] (define-fun s42 () Bool (=> s1 s41))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s42))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested24.gold view
@@ -0,0 +1,253 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s2 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s20 () Int 1)+[GOOD] (define-fun s33 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "e"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s1 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Expr (getMul_1 s0))+[GOOD] (define-fun s18 () Bool ((as is-Val Bool) s17))+[GOOD] (define-fun s19 () Int (getVal_1 s17))+[GOOD] (define-fun s21 () Bool (= s19 s20))+[GOOD] (define-fun s22 () Bool (and s18 s21))+[GOOD] (define-fun s23 () Bool (and s1 s22))+[GOOD] (define-fun s24 () Expr (getMul_2 s0))+[GOOD] (define-fun s25 () Bool ((as is-Val Bool) s24))+[GOOD] (define-fun s26 () Int (getVal_1 s24))+[GOOD] (define-fun s27 () Bool (= s20 s26))+[GOOD] (define-fun s28 () Bool (and s25 s27))+[GOOD] (define-fun s29 () Bool (and s1 s28))+[GOOD] (define-fun s30 () Bool (= s7 s19))+[GOOD] (define-fun s31 () Bool (and s18 s30))+[GOOD] (define-fun s32 () Bool (and s1 s31))+[GOOD] (define-fun s34 () Expr (ite s32 s33 s0))+[GOOD] (define-fun s35 () Expr (ite s29 s17 s34))+[GOOD] (define-fun s36 () Expr (ite s23 s24 s35))+[GOOD] (define-fun s37 () Expr (ite s16 s4 s36))+[GOOD] (define-fun s38 () Expr (ite s10 s11 s37))+[GOOD] (define-fun s39 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s2 s38))+[GOOD] (define-fun s40 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s2 s0))+[GOOD] (define-fun s41 () Bool (= s39 s40))+[GOOD] (define-fun s42 () Bool (=> s1 s41))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s42))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested25.gold view
@@ -0,0 +1,71 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Mul Expr) ((as Val Expr) 2) ((as Val Expr) 3)) ((as Mul Expr) ((as Val Expr) 4) ((as Val Expr) 5))))+[GOOD] (define-fun s31 () Expr ((as Val Expr) 26))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Mul Bool) s4))+[GOOD] (define-fun s6 () Expr (getMul_1 s4))+[GOOD] (define-fun s7 () Bool ((as is-Val Bool) s6))+[GOOD] (define-fun s8 () Expr (getMul_2 s4))+[GOOD] (define-fun s9 () Bool ((as is-Val Bool) s8))+[GOOD] (define-fun s10 () Expr (getAdd_2 s0))+[GOOD] (define-fun s11 () Bool ((as is-Mul Bool) s10))+[GOOD] (define-fun s12 () Expr (getMul_1 s10))+[GOOD] (define-fun s13 () Bool ((as is-Val Bool) s12))+[GOOD] (define-fun s14 () Expr (getMul_2 s10))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Bool (and s13 s15))+[GOOD] (define-fun s17 () Bool (and s11 s16))+[GOOD] (define-fun s18 () Bool (and s9 s17))+[GOOD] (define-fun s19 () Bool (and s7 s18))+[GOOD] (define-fun s20 () Bool (and s5 s19))+[GOOD] (define-fun s21 () Bool (and s3 s20))+[GOOD] (define-fun s22 () Int (getVal_1 s6))+[GOOD] (define-fun s23 () Int (getVal_1 s8))+[GOOD] (define-fun s24 () Int (* s22 s23))+[GOOD] (define-fun s25 () Int (getVal_1 s12))+[GOOD] (define-fun s26 () Int (getVal_1 s14))+[GOOD] (define-fun s27 () Int (* s25 s26))+[GOOD] (define-fun s28 () Int (+ s24 s27))+[GOOD] (define-fun s29 () Expr ((as Val Expr) s28))+[GOOD] (define-fun s30 () Expr (ite s21 s29 s0))+[GOOD] (define-fun s32 () Bool (distinct s30 s31))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s32)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested25c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested26.gold view
@@ -0,0 +1,71 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Mul Expr) ((as Val Expr) 0) ((as Val Expr) 99)) ((as Mul Expr) ((as Val Expr) 1) ((as Val Expr) 1))))+[GOOD] (define-fun s31 () Expr ((as Val Expr) 1))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Mul Bool) s4))+[GOOD] (define-fun s6 () Expr (getMul_1 s4))+[GOOD] (define-fun s7 () Bool ((as is-Val Bool) s6))+[GOOD] (define-fun s8 () Expr (getMul_2 s4))+[GOOD] (define-fun s9 () Bool ((as is-Val Bool) s8))+[GOOD] (define-fun s10 () Expr (getAdd_2 s0))+[GOOD] (define-fun s11 () Bool ((as is-Mul Bool) s10))+[GOOD] (define-fun s12 () Expr (getMul_1 s10))+[GOOD] (define-fun s13 () Bool ((as is-Val Bool) s12))+[GOOD] (define-fun s14 () Expr (getMul_2 s10))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Bool (and s13 s15))+[GOOD] (define-fun s17 () Bool (and s11 s16))+[GOOD] (define-fun s18 () Bool (and s9 s17))+[GOOD] (define-fun s19 () Bool (and s7 s18))+[GOOD] (define-fun s20 () Bool (and s5 s19))+[GOOD] (define-fun s21 () Bool (and s3 s20))+[GOOD] (define-fun s22 () Int (getVal_1 s6))+[GOOD] (define-fun s23 () Int (getVal_1 s8))+[GOOD] (define-fun s24 () Int (* s22 s23))+[GOOD] (define-fun s25 () Int (getVal_1 s12))+[GOOD] (define-fun s26 () Int (getVal_1 s14))+[GOOD] (define-fun s27 () Int (* s25 s26))+[GOOD] (define-fun s28 () Int (+ s24 s27))+[GOOD] (define-fun s29 () Expr ((as Val Expr) s28))+[GOOD] (define-fun s30 () Expr (ite s21 s29 s0))+[GOOD] (define-fun s32 () Bool (distinct s30 s31))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s32)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested26c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested27.gold view
@@ -0,0 +1,70 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Mul Expr) ((as Val Expr) 2) ((as Val Expr) 3)) ((as Var Expr) "x")))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Mul Bool) s4))+[GOOD] (define-fun s6 () Expr (getMul_1 s4))+[GOOD] (define-fun s7 () Bool ((as is-Val Bool) s6))+[GOOD] (define-fun s8 () Expr (getMul_2 s4))+[GOOD] (define-fun s9 () Bool ((as is-Val Bool) s8))+[GOOD] (define-fun s10 () Expr (getAdd_2 s0))+[GOOD] (define-fun s11 () Bool ((as is-Mul Bool) s10))+[GOOD] (define-fun s12 () Expr (getMul_1 s10))+[GOOD] (define-fun s13 () Bool ((as is-Val Bool) s12))+[GOOD] (define-fun s14 () Expr (getMul_2 s10))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Bool (and s13 s15))+[GOOD] (define-fun s17 () Bool (and s11 s16))+[GOOD] (define-fun s18 () Bool (and s9 s17))+[GOOD] (define-fun s19 () Bool (and s7 s18))+[GOOD] (define-fun s20 () Bool (and s5 s19))+[GOOD] (define-fun s21 () Bool (and s3 s20))+[GOOD] (define-fun s22 () Int (getVal_1 s6))+[GOOD] (define-fun s23 () Int (getVal_1 s8))+[GOOD] (define-fun s24 () Int (* s22 s23))+[GOOD] (define-fun s25 () Int (getVal_1 s12))+[GOOD] (define-fun s26 () Int (getVal_1 s14))+[GOOD] (define-fun s27 () Int (* s25 s26))+[GOOD] (define-fun s28 () Int (+ s24 s27))+[GOOD] (define-fun s29 () Expr ((as Val Expr) s28))+[GOOD] (define-fun s30 () Expr (ite s21 s29 s0))+[GOOD] (define-fun s31 () Bool (distinct s1 s30))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s31)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested27c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested28.gold view
@@ -0,0 +1,70 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 2) ((as Val Expr) 3)))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Mul Bool) s4))+[GOOD] (define-fun s6 () Expr (getMul_1 s4))+[GOOD] (define-fun s7 () Bool ((as is-Val Bool) s6))+[GOOD] (define-fun s8 () Expr (getMul_2 s4))+[GOOD] (define-fun s9 () Bool ((as is-Val Bool) s8))+[GOOD] (define-fun s10 () Expr (getAdd_2 s0))+[GOOD] (define-fun s11 () Bool ((as is-Mul Bool) s10))+[GOOD] (define-fun s12 () Expr (getMul_1 s10))+[GOOD] (define-fun s13 () Bool ((as is-Val Bool) s12))+[GOOD] (define-fun s14 () Expr (getMul_2 s10))+[GOOD] (define-fun s15 () Bool ((as is-Val Bool) s14))+[GOOD] (define-fun s16 () Bool (and s13 s15))+[GOOD] (define-fun s17 () Bool (and s11 s16))+[GOOD] (define-fun s18 () Bool (and s9 s17))+[GOOD] (define-fun s19 () Bool (and s7 s18))+[GOOD] (define-fun s20 () Bool (and s5 s19))+[GOOD] (define-fun s21 () Bool (and s3 s20))+[GOOD] (define-fun s22 () Int (getVal_1 s6))+[GOOD] (define-fun s23 () Int (getVal_1 s8))+[GOOD] (define-fun s24 () Int (* s22 s23))+[GOOD] (define-fun s25 () Int (getVal_1 s12))+[GOOD] (define-fun s26 () Int (getVal_1 s14))+[GOOD] (define-fun s27 () Int (* s25 s26))+[GOOD] (define-fun s28 () Int (+ s24 s27))+[GOOD] (define-fun s29 () Expr ((as Val Expr) s28))+[GOOD] (define-fun s30 () Expr (ite s21 s29 s0))+[GOOD] (define-fun s31 () Bool (distinct s1 s30))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s31)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested28c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested29.gold view
@@ -0,0 +1,243 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "e"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s3 () Expr (getAdd_1 s0))+[GOOD] (define-fun s4 () Bool ((as is-Mul Bool) s3))+[GOOD] (define-fun s5 () Expr (getMul_1 s3))+[GOOD] (define-fun s6 () Bool ((as is-Val Bool) s5))+[GOOD] (define-fun s7 () Expr (getMul_2 s3))+[GOOD] (define-fun s8 () Bool ((as is-Val Bool) s7))+[GOOD] (define-fun s9 () Expr (getAdd_2 s0))+[GOOD] (define-fun s10 () Bool ((as is-Mul Bool) s9))+[GOOD] (define-fun s11 () Expr (getMul_1 s9))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Expr (getMul_2 s9))+[GOOD] (define-fun s14 () Bool ((as is-Val Bool) s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s10 s15))+[GOOD] (define-fun s17 () Bool (and s8 s16))+[GOOD] (define-fun s18 () Bool (and s6 s17))+[GOOD] (define-fun s19 () Bool (and s4 s18))+[GOOD] (define-fun s20 () Bool (and s2 s19))+[GOOD] (define-fun s21 () Int (getVal_1 s5))+[GOOD] (define-fun s22 () Int (getVal_1 s7))+[GOOD] (define-fun s23 () Int (* s21 s22))+[GOOD] (define-fun s24 () Int (getVal_1 s11))+[GOOD] (define-fun s25 () Int (getVal_1 s13))+[GOOD] (define-fun s26 () Int (* s24 s25))+[GOOD] (define-fun s27 () Int (+ s23 s26))+[GOOD] (define-fun s28 () Expr ((as Val Expr) s27))+[GOOD] (define-fun s29 () Expr (ite s20 s28 s0))+[GOOD] (define-fun s30 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s1 s29))+[GOOD] (define-fun s31 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s1 s0))+[GOOD] (define-fun s32 () Bool (= s30 s31))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s32))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested30.gold view
@@ -0,0 +1,108 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Mul Expr) ((as Val Expr) 2) ((as Val Expr) 3)) ((as Mul Expr) ((as Val Expr) 4) ((as Val Expr) 5))))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s68 () Expr ((as Val Expr) 26))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool ((as is-Add Bool) s39))+[GOOD] (define-fun s41 () Expr (getAdd_1 s39))+[GOOD] (define-fun s42 () Bool ((as is-Mul Bool) s41))+[GOOD] (define-fun s43 () Expr (getMul_1 s41))+[GOOD] (define-fun s44 () Bool ((as is-Val Bool) s43))+[GOOD] (define-fun s45 () Expr (getMul_2 s41))+[GOOD] (define-fun s46 () Bool ((as is-Val Bool) s45))+[GOOD] (define-fun s47 () Expr (getAdd_2 s39))+[GOOD] (define-fun s48 () Bool ((as is-Mul Bool) s47))+[GOOD] (define-fun s49 () Expr (getMul_1 s47))+[GOOD] (define-fun s50 () Bool ((as is-Val Bool) s49))+[GOOD] (define-fun s51 () Expr (getMul_2 s47))+[GOOD] (define-fun s52 () Bool ((as is-Val Bool) s51))+[GOOD] (define-fun s53 () Bool (and s50 s52))+[GOOD] (define-fun s54 () Bool (and s48 s53))+[GOOD] (define-fun s55 () Bool (and s46 s54))+[GOOD] (define-fun s56 () Bool (and s44 s55))+[GOOD] (define-fun s57 () Bool (and s42 s56))+[GOOD] (define-fun s58 () Bool (and s40 s57))+[GOOD] (define-fun s59 () Int (getVal_1 s43))+[GOOD] (define-fun s60 () Int (getVal_1 s45))+[GOOD] (define-fun s61 () Int (* s59 s60))+[GOOD] (define-fun s62 () Int (getVal_1 s49))+[GOOD] (define-fun s63 () Int (getVal_1 s51))+[GOOD] (define-fun s64 () Int (* s62 s63))+[GOOD] (define-fun s65 () Int (+ s61 s64))+[GOOD] (define-fun s66 () Expr ((as Val Expr) s65))+[GOOD] (define-fun s67 () Expr (ite s58 s66 s39))+[GOOD] (define-fun s69 () Bool (distinct s67 s68))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s69)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested30c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested31.gold view
@@ -0,0 +1,108 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Mul Expr) ((as Val Expr) 1) ((as Val Expr) 2)) ((as Mul Expr) ((as Val Expr) 0) ((as Val Expr) 4))))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s68 () Expr ((as Val Expr) 2))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool ((as is-Add Bool) s39))+[GOOD] (define-fun s41 () Expr (getAdd_1 s39))+[GOOD] (define-fun s42 () Bool ((as is-Mul Bool) s41))+[GOOD] (define-fun s43 () Expr (getMul_1 s41))+[GOOD] (define-fun s44 () Bool ((as is-Val Bool) s43))+[GOOD] (define-fun s45 () Expr (getMul_2 s41))+[GOOD] (define-fun s46 () Bool ((as is-Val Bool) s45))+[GOOD] (define-fun s47 () Expr (getAdd_2 s39))+[GOOD] (define-fun s48 () Bool ((as is-Mul Bool) s47))+[GOOD] (define-fun s49 () Expr (getMul_1 s47))+[GOOD] (define-fun s50 () Bool ((as is-Val Bool) s49))+[GOOD] (define-fun s51 () Expr (getMul_2 s47))+[GOOD] (define-fun s52 () Bool ((as is-Val Bool) s51))+[GOOD] (define-fun s53 () Bool (and s50 s52))+[GOOD] (define-fun s54 () Bool (and s48 s53))+[GOOD] (define-fun s55 () Bool (and s46 s54))+[GOOD] (define-fun s56 () Bool (and s44 s55))+[GOOD] (define-fun s57 () Bool (and s42 s56))+[GOOD] (define-fun s58 () Bool (and s40 s57))+[GOOD] (define-fun s59 () Int (getVal_1 s43))+[GOOD] (define-fun s60 () Int (getVal_1 s45))+[GOOD] (define-fun s61 () Int (* s59 s60))+[GOOD] (define-fun s62 () Int (getVal_1 s49))+[GOOD] (define-fun s63 () Int (getVal_1 s51))+[GOOD] (define-fun s64 () Int (* s62 s63))+[GOOD] (define-fun s65 () Int (+ s61 s64))+[GOOD] (define-fun s66 () Expr ((as Val Expr) s65))+[GOOD] (define-fun s67 () Expr (ite s58 s66 s39))+[GOOD] (define-fun s69 () Bool (distinct s67 s68))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s69)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested31c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested32.gold view
@@ -0,0 +1,108 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Mul Expr) ((as Val Expr) 1) ((as Add Expr) ((as Mul Expr) ((as Val Expr) 2) ((as Val Expr) 3)) ((as Mul Expr) ((as Val Expr) 4) ((as Val Expr) 5)))))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s68 () Expr ((as Val Expr) 26))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool ((as is-Add Bool) s39))+[GOOD] (define-fun s41 () Expr (getAdd_1 s39))+[GOOD] (define-fun s42 () Bool ((as is-Mul Bool) s41))+[GOOD] (define-fun s43 () Expr (getMul_1 s41))+[GOOD] (define-fun s44 () Bool ((as is-Val Bool) s43))+[GOOD] (define-fun s45 () Expr (getMul_2 s41))+[GOOD] (define-fun s46 () Bool ((as is-Val Bool) s45))+[GOOD] (define-fun s47 () Expr (getAdd_2 s39))+[GOOD] (define-fun s48 () Bool ((as is-Mul Bool) s47))+[GOOD] (define-fun s49 () Expr (getMul_1 s47))+[GOOD] (define-fun s50 () Bool ((as is-Val Bool) s49))+[GOOD] (define-fun s51 () Expr (getMul_2 s47))+[GOOD] (define-fun s52 () Bool ((as is-Val Bool) s51))+[GOOD] (define-fun s53 () Bool (and s50 s52))+[GOOD] (define-fun s54 () Bool (and s48 s53))+[GOOD] (define-fun s55 () Bool (and s46 s54))+[GOOD] (define-fun s56 () Bool (and s44 s55))+[GOOD] (define-fun s57 () Bool (and s42 s56))+[GOOD] (define-fun s58 () Bool (and s40 s57))+[GOOD] (define-fun s59 () Int (getVal_1 s43))+[GOOD] (define-fun s60 () Int (getVal_1 s45))+[GOOD] (define-fun s61 () Int (* s59 s60))+[GOOD] (define-fun s62 () Int (getVal_1 s49))+[GOOD] (define-fun s63 () Int (getVal_1 s51))+[GOOD] (define-fun s64 () Int (* s62 s63))+[GOOD] (define-fun s65 () Int (+ s61 s64))+[GOOD] (define-fun s66 () Expr ((as Val Expr) s65))+[GOOD] (define-fun s67 () Expr (ite s58 s66 s39))+[GOOD] (define-fun s69 () Bool (distinct s67 s68))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s69)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested32c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested33.gold view
@@ -0,0 +1,108 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Expr ((as Add Expr) ((as Val Expr) 0) ((as Add Expr) ((as Mul Expr) ((as Val Expr) 2) ((as Val Expr) 3)) ((as Mul Expr) ((as Val Expr) 4) ((as Val Expr) 5)))))+[GOOD] (define-fun s7 () Int 0)+[GOOD] (define-fun s21 () Int 1)+[GOOD] (define-fun s34 () Expr ((as Val Expr) 0))+[GOOD] (define-fun s68 () Expr ((as Val Expr) 26))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr)+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s4 () Expr (getAdd_1 s0))+[GOOD] (define-fun s5 () Bool ((as is-Val Bool) s4))+[GOOD] (define-fun s6 () Int (getVal_1 s4))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s9 () Bool (and s5 s8))+[GOOD] (define-fun s10 () Bool (and s3 s9))+[GOOD] (define-fun s11 () Expr (getAdd_2 s0))+[GOOD] (define-fun s12 () Bool ((as is-Val Bool) s11))+[GOOD] (define-fun s13 () Int (getVal_1 s11))+[GOOD] (define-fun s14 () Bool (= s7 s13))+[GOOD] (define-fun s15 () Bool (and s12 s14))+[GOOD] (define-fun s16 () Bool (and s3 s15))+[GOOD] (define-fun s17 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s18 () Expr (getMul_1 s0))+[GOOD] (define-fun s19 () Bool ((as is-Val Bool) s18))+[GOOD] (define-fun s20 () Int (getVal_1 s18))+[GOOD] (define-fun s22 () Bool (= s20 s21))+[GOOD] (define-fun s23 () Bool (and s19 s22))+[GOOD] (define-fun s24 () Bool (and s17 s23))+[GOOD] (define-fun s25 () Expr (getMul_2 s0))+[GOOD] (define-fun s26 () Bool ((as is-Val Bool) s25))+[GOOD] (define-fun s27 () Int (getVal_1 s25))+[GOOD] (define-fun s28 () Bool (= s21 s27))+[GOOD] (define-fun s29 () Bool (and s26 s28))+[GOOD] (define-fun s30 () Bool (and s17 s29))+[GOOD] (define-fun s31 () Bool (= s7 s20))+[GOOD] (define-fun s32 () Bool (and s19 s31))+[GOOD] (define-fun s33 () Bool (and s17 s32))+[GOOD] (define-fun s35 () Expr (ite s33 s34 s0))+[GOOD] (define-fun s36 () Expr (ite s30 s18 s35))+[GOOD] (define-fun s37 () Expr (ite s24 s25 s36))+[GOOD] (define-fun s38 () Expr (ite s16 s4 s37))+[GOOD] (define-fun s39 () Expr (ite s10 s11 s38))+[GOOD] (define-fun s40 () Bool ((as is-Add Bool) s39))+[GOOD] (define-fun s41 () Expr (getAdd_1 s39))+[GOOD] (define-fun s42 () Bool ((as is-Mul Bool) s41))+[GOOD] (define-fun s43 () Expr (getMul_1 s41))+[GOOD] (define-fun s44 () Bool ((as is-Val Bool) s43))+[GOOD] (define-fun s45 () Expr (getMul_2 s41))+[GOOD] (define-fun s46 () Bool ((as is-Val Bool) s45))+[GOOD] (define-fun s47 () Expr (getAdd_2 s39))+[GOOD] (define-fun s48 () Bool ((as is-Mul Bool) s47))+[GOOD] (define-fun s49 () Expr (getMul_1 s47))+[GOOD] (define-fun s50 () Bool ((as is-Val Bool) s49))+[GOOD] (define-fun s51 () Expr (getMul_2 s47))+[GOOD] (define-fun s52 () Bool ((as is-Val Bool) s51))+[GOOD] (define-fun s53 () Bool (and s50 s52))+[GOOD] (define-fun s54 () Bool (and s48 s53))+[GOOD] (define-fun s55 () Bool (and s46 s54))+[GOOD] (define-fun s56 () Bool (and s44 s55))+[GOOD] (define-fun s57 () Bool (and s42 s56))+[GOOD] (define-fun s58 () Bool (and s40 s57))+[GOOD] (define-fun s59 () Int (getVal_1 s43))+[GOOD] (define-fun s60 () Int (getVal_1 s45))+[GOOD] (define-fun s61 () Int (* s59 s60))+[GOOD] (define-fun s62 () Int (getVal_1 s49))+[GOOD] (define-fun s63 () Int (getVal_1 s51))+[GOOD] (define-fun s64 () Int (* s62 s63))+[GOOD] (define-fun s65 () Int (+ s61 s64))+[GOOD] (define-fun s66 () Expr ((as Val Expr) s65))+[GOOD] (define-fun s67 () Expr (ite s58 s66 s39))+[GOOD] (define-fun s69 () Bool (distinct s67 s68))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s69)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested33c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_nested34.gold view
@@ -0,0 +1,157 @@+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (+ (Val (getVal_1 Int))+ (Var (getVar_1 String))+ (Add (getAdd_1 Expr) (getAdd_2 Expr))+ (Mul (getMul_1 Expr) (getMul_2 Expr))+ (Let (getLet_1 String) (getLet_2 Expr) (getLet_3 Expr))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s6 () Int 0)+[GOOD] (define-fun s20 () Int 1)+[GOOD] (define-fun s33 () Expr ((as Val Expr) 0))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () Expr) ; tracks user variable "e"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s9 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s6 (proj_1_SBVTuple2 l2_s5)))+ (let ((l2_s7 (= l2_s1 l2_s6)))+ (let ((l2_s8 (proj_2_SBVTuple2 l2_s5)))+ (let ((l2_s10 (- l2_s2 l2_s9)))+ (let ((l2_s11 (seq.extract l2_s0 l2_s9 l2_s10)))+ (let ((l2_s12 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s11 l2_s1)))+ (let ((l2_s13 (ite l2_s7 l2_s8 l2_s12)))+ (let ((l2_s14 (ite l2_s4 l2_s3 l2_s13)))+ l2_s14))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| :: [(SString, SInteger)] -> Expr -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 Expr)) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool ((as is-Add Bool) s0))+[GOOD] (define-fun s3 () Expr (getAdd_1 s0))+[GOOD] (define-fun s4 () Bool ((as is-Val Bool) s3))+[GOOD] (define-fun s5 () Int (getVal_1 s3))+[GOOD] (define-fun s7 () Bool (= s5 s6))+[GOOD] (define-fun s8 () Bool (and s4 s7))+[GOOD] (define-fun s9 () Bool (and s2 s8))+[GOOD] (define-fun s10 () Expr (getAdd_2 s0))+[GOOD] (define-fun s11 () Bool ((as is-Val Bool) s10))+[GOOD] (define-fun s12 () Int (getVal_1 s10))+[GOOD] (define-fun s13 () Bool (= s6 s12))+[GOOD] (define-fun s14 () Bool (and s11 s13))+[GOOD] (define-fun s15 () Bool (and s2 s14))+[GOOD] (define-fun s16 () Bool ((as is-Mul Bool) s0))+[GOOD] (define-fun s17 () Expr (getMul_1 s0))+[GOOD] (define-fun s18 () Bool ((as is-Val Bool) s17))+[GOOD] (define-fun s19 () Int (getVal_1 s17))+[GOOD] (define-fun s21 () Bool (= s19 s20))+[GOOD] (define-fun s22 () Bool (and s18 s21))+[GOOD] (define-fun s23 () Bool (and s16 s22))+[GOOD] (define-fun s24 () Expr (getMul_2 s0))+[GOOD] (define-fun s25 () Bool ((as is-Val Bool) s24))+[GOOD] (define-fun s26 () Int (getVal_1 s24))+[GOOD] (define-fun s27 () Bool (= s20 s26))+[GOOD] (define-fun s28 () Bool (and s25 s27))+[GOOD] (define-fun s29 () Bool (and s16 s28))+[GOOD] (define-fun s30 () Bool (= s6 s19))+[GOOD] (define-fun s31 () Bool (and s18 s30))+[GOOD] (define-fun s32 () Bool (and s16 s31))+[GOOD] (define-fun s34 () Expr (ite s32 s33 s0))+[GOOD] (define-fun s35 () Expr (ite s29 s17 s34))+[GOOD] (define-fun s36 () Expr (ite s23 s24 s35))+[GOOD] (define-fun s37 () Expr (ite s15 s3 s36))+[GOOD] (define-fun s38 () Expr (ite s9 s10 s37))+[GOOD] (define-fun s39 () Bool ((as is-Add Bool) s38))+[GOOD] (define-fun s40 () Expr (getAdd_1 s38))+[GOOD] (define-fun s41 () Bool ((as is-Mul Bool) s40))+[GOOD] (define-fun s42 () Expr (getMul_1 s40))+[GOOD] (define-fun s43 () Bool ((as is-Val Bool) s42))+[GOOD] (define-fun s44 () Expr (getMul_2 s40))+[GOOD] (define-fun s45 () Bool ((as is-Val Bool) s44))+[GOOD] (define-fun s46 () Expr (getAdd_2 s38))+[GOOD] (define-fun s47 () Bool ((as is-Mul Bool) s46))+[GOOD] (define-fun s48 () Expr (getMul_1 s46))+[GOOD] (define-fun s49 () Bool ((as is-Val Bool) s48))+[GOOD] (define-fun s50 () Expr (getMul_2 s46))+[GOOD] (define-fun s51 () Bool ((as is-Val Bool) s50))+[GOOD] (define-fun s52 () Bool (and s49 s51))+[GOOD] (define-fun s53 () Bool (and s47 s52))+[GOOD] (define-fun s54 () Bool (and s45 s53))+[GOOD] (define-fun s55 () Bool (and s43 s54))+[GOOD] (define-fun s56 () Bool (and s41 s55))+[GOOD] (define-fun s57 () Bool (and s39 s56))+[GOOD] (define-fun s58 () Int (getVal_1 s42))+[GOOD] (define-fun s59 () Int (getVal_1 s44))+[GOOD] (define-fun s60 () Int (* s58 s59))+[GOOD] (define-fun s61 () Int (getVal_1 s48))+[GOOD] (define-fun s62 () Int (getVal_1 s50))+[GOOD] (define-fun s63 () Int (* s61 s62))+[GOOD] (define-fun s64 () Int (+ s60 s63))+[GOOD] (define-fun s65 () Expr ((as Val Expr) s64))+[GOOD] (define-fun s66 () Expr (ite s57 s65 s38))+[GOOD] (define-fun s67 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s1 s66))+[GOOD] (define-fun s68 () Int (|eval @(SBV [([Char],Integer)] -> SBV Expr -> SBV Integer)| s1 s0))+[GOOD] (define-fun s69 () Bool (= s67 s68))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s69))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_pchk01.gold view
@@ -0,0 +1,40 @@+** 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] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: A+[GOOD] (declare-datatype A (+ (A (getA_1 Int))+ (B (getB_1 (_ BitVec 8)))+ (C (getC_1 A) (getC_2 A))+ ))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () A ((as A A) 13))+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () A) ; tracks user variable "res"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (A 13)))+Result: A 13+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_pexpr00.gold view
@@ -0,0 +1,219 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (par (nm val) (+ (Val (getVal_1 val))+ (Var (getVar_1 nm))+ (Add (getAdd_1 (Expr nm val)) (getAdd_2 (Expr nm val)))+ (Mul (getMul_1 (Expr nm val)) (getMul_2 (Expr nm val)))+ (Let (getLet_1 nm) (getLet_2 (Expr nm val)) (getLet_3 (Expr nm val)))+ )))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () (Expr String Int) ((as Val (Expr String Int)) 3))+[GOOD] (define-fun s3 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s5 () Int 3)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Expr String Int))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| :: [(SString, SInteger)] -> Expr String Integer -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 (Expr String Int))) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s4 () Int (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| s3 s0))+[GOOD] (define-fun s6 () Bool (distinct s4 s5))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_pexpr00c.gold view
@@ -0,0 +1,25 @@+** 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-logic ALL) ; external query, using all logics.+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- top level inputs ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert false)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_pexpr01.gold view
@@ -0,0 +1,219 @@+[MEASURE] Verifying termination measures for: eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer), eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer), get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): not in a multi-member cycle, skipping mutual check+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)+[MEASURE] Checking: eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): barified = "|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|"+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2),("|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)|",2)]+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): recursive calls found = 6+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): trying sbv.dt.size.Expr arg2+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): sbv.dt.size.Expr arg2 -> OK (structural recursion)+[MEASURE] eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer): sbv.dt.size.Expr arg2 -> OK+[MEASURE] Passed (terminating): eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)+[MEASURE] Checking: get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): barified = "|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|"+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): Uninterpreted ops in DAG: [("|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|",2)]+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): recursive calls found = 1+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): trying length arg1+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Bool (>= s4 s2))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s17))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] replayDAG {get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)}: replaying 13 node(s)+** 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] ; --- 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 () Int 0)+[GOOD] (define-fun s3 () Int 1)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Seq (SBVTuple2 String Int))) ; tracks user variable "arg0"+[GOOD] (declare-fun s1 () String) ; tracks user variable "arg1"+[GOOD] (declare-fun s14 () Int) ; tracks user variable "__internal_sbv_s14"+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; --- assignments ---+[GOOD] (define-fun s4 () Int (seq.len s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () (SBVTuple2 String Int) (seq.nth s0 s2))+[GOOD] (define-fun s8 () String (proj_1_SBVTuple2 s7))+[GOOD] (define-fun s9 () Bool (= s1 s8))+[GOOD] (define-fun s10 () Bool (and s6 s9))+[GOOD] (define-fun s11 () Int (proj_2_SBVTuple2 s7))+[GOOD] (define-fun s12 () Int (- s4 s3))+[GOOD] (define-fun s13 () (Seq (SBVTuple2 String Int)) (seq.extract s0 s3 s12))+[GOOD] (define-fun s15 () Int (ite s10 s11 s14))+[GOOD] (define-fun s16 () Int (ite s5 s2 s15))+[GOOD] (define-fun s17 () Int (seq.len s13))+[GOOD] (define-fun s18 () Bool (not s10))+[GOOD] (define-fun s19 () Bool (and s6 s18))+[GOOD] (define-fun s20 () Bool (> s4 s17))+[GOOD] (define-fun s21 () Bool (=> s19 s20))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert (not s21))+[SEND] (check-sat)+[RECV] unsat+*** Solver : Z3+*** Exit code: ExitSuccess+[MEASURE] get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer): length arg1 -> OK+[MEASURE] Passed (terminating): get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)+** 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] ; --- tuples ---+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] ; --- sums ---+[GOOD] ; --- ADTs --- +[GOOD] ; User defined ADT: Expr+[GOOD] (declare-datatype Expr (par (nm val) (+ (Val (getVal_1 val))+ (Var (getVar_1 nm))+ (Add (getAdd_1 (Expr nm val)) (getAdd_2 (Expr nm val)))+ (Mul (getMul_1 (Expr nm val)) (getMul_2 (Expr nm val)))+ (Let (getLet_1 nm) (getLet_2 (Expr nm val)) (getLet_3 (Expr nm val)))+ )))+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () (Expr String Int) ((as Add (Expr String Int)) ((as Val (Expr String Int)) 3) ((as Val (Expr String Int)) 4)))+[GOOD] (define-fun s3 () (Seq (SBVTuple2 String Int)) (as seq.empty (Seq (SBVTuple2 String Int))))+[GOOD] (define-fun s5 () Int 7)+[GOOD] ; --- top level inputs ---+[GOOD] (declare-fun s0 () (Expr String Int))+[GOOD] ; --- constant tables ---+[GOOD] ; --- non-constant tables ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user defined functions ---+[GOOD] ; |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| :: [(SString, SInteger)] -> SString -> SInteger [Recursive]+[GOOD] (define-fun-rec |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| ((l2_s0 (Seq (SBVTuple2 String Int))) (l2_s1 String)) Int+ (let ((l2_s3 0))+ (let ((l2_s11 1))+ (let ((l2_s2 (seq.len l2_s0)))+ (let ((l2_s4 (= l2_s2 l2_s3)))+ (let ((l2_s5 (not l2_s4)))+ (let ((l2_s6 (seq.nth l2_s0 l2_s3)))+ (let ((l2_s7 (proj_1_SBVTuple2 l2_s6)))+ (let ((l2_s8 (= l2_s1 l2_s7)))+ (let ((l2_s9 (and l2_s5 l2_s8)))+ (let ((l2_s10 (proj_2_SBVTuple2 l2_s6)))+ (let ((l2_s12 (- l2_s2 l2_s11)))+ (let ((l2_s13 (seq.extract l2_s0 l2_s11 l2_s12)))+ (let ((l2_s14 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l2_s13 l2_s1)))+ (let ((l2_s15 (ite l2_s9 l2_s10 l2_s14)))+ (let ((l2_s16 (ite l2_s4 l2_s3 l2_s15)))+ l2_s16))))))))))))))))+[GOOD] ; |eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| :: [(SString, SInteger)] -> Expr String Integer -> SInteger [Recursive] [Refers to: |get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)|]+[GOOD] (define-fun-rec |eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| ((l1_s0 (Seq (SBVTuple2 String Int))) (l1_s1 (Expr String Int))) Int+ (let ((l1_s2 ((as is-Val Bool) l1_s1)))+ (let ((l1_s3 (getVal_1 l1_s1)))+ (let ((l1_s4 ((as is-Var Bool) l1_s1)))+ (let ((l1_s5 (getVar_1 l1_s1)))+ (let ((l1_s6 (|get @(SBV [([Char],Integer)] -> SBV [Char] -> SBV Integer)| l1_s0 l1_s5)))+ (let ((l1_s7 ((as is-Add Bool) l1_s1)))+ (let ((l1_s8 (getAdd_1 l1_s1)))+ (let ((l1_s9 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s8)))+ (let ((l1_s10 (getAdd_2 l1_s1)))+ (let ((l1_s11 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s10)))+ (let ((l1_s12 (+ l1_s9 l1_s11)))+ (let ((l1_s13 ((as is-Mul Bool) l1_s1)))+ (let ((l1_s14 (getMul_1 l1_s1)))+ (let ((l1_s15 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s14)))+ (let ((l1_s16 (getMul_2 l1_s1)))+ (let ((l1_s17 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s16)))+ (let ((l1_s18 (* l1_s15 l1_s17)))+ (let ((l1_s19 (getLet_1 l1_s1)))+ (let ((l1_s20 (getLet_2 l1_s1)))+ (let ((l1_s21 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s0 l1_s20)))+ (let ((l1_s22 ((as mkSBVTuple2 (SBVTuple2 String Int)) l1_s19 l1_s21)))+ (let ((l1_s23 (seq.unit l1_s22)))+ (let ((l1_s24 (seq.++ l1_s23 l1_s0)))+ (let ((l1_s25 (getLet_3 l1_s1)))+ (let ((l1_s26 (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| l1_s24 l1_s25)))+ (let ((l1_s27 (ite l1_s13 l1_s18 l1_s26)))+ (let ((l1_s28 (ite l1_s7 l1_s12 l1_s27)))+ (let ((l1_s29 (ite l1_s4 l1_s6 l1_s28)))+ (let ((l1_s30 (ite l1_s2 l1_s3 l1_s29)))+ l1_s30))))))))))))))))))))))))))))))+[GOOD] ; --- assignments ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s4 () Int (|eval @(SBV [([Char],Integer)] -> SBV (Expr [Char] Integer) -> SBV Integer)| s3 s0))+[GOOD] (define-fun s6 () Bool (distinct s4 s5))+[GOOD] ; --- delayedEqualities ---+[GOOD] ; --- formula ---+[GOOD] (assert s2)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+All good.+*** Solver : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/adt_pexpr01c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr02.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr02c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr03.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr03c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr04.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr05.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr06.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr06c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr07.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr07c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr08.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr08c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr09.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr09c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr10.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr10c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr11.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr11c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr12.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr12c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr13.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr13c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr14.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr14c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr15.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr15c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr16.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr16c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr17.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr17c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr18.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr18c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr19.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr20.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pexpr21.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen00.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen01.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen02.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen03.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen04.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen05.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen06.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen07.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen08.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen09.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen10.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen11.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/adt_pgen12.gold view
file too large to diff
SBVTestSuite/GoldFiles/aes128Lib.gold view
file too large to diff
SBVTestSuite/GoldFiles/allSat1.gold view
file too large to diff
SBVTestSuite/GoldFiles/allSat2.gold view
file too large to diff
SBVTestSuite/GoldFiles/allSat6.gold view
file too large to diff
SBVTestSuite/GoldFiles/allSat7.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/allSat8.gold view
file too large to diff
SBVTestSuite/GoldFiles/arbFp_opt_1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/arrayGetValTest1.gold view
file too large to diff
SBVTestSuite/GoldFiles/array_caching_01.gold view
file too large to diff
SBVTestSuite/GoldFiles/array_caching_02.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_11.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_12.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_13.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_14.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_15.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_16.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_17.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_18.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_19.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_2.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_20.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_21.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_22.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_23.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_24.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_25.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_26.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_27.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_28.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_29.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_3.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_30.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_31.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_5.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_7.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/array_misc_9.gold view
file too large to diff
SBVTestSuite/GoldFiles/auf-1.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int16_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int16_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int16_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int16_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int32_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int32_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int32_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int32_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int64_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int64_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int64_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int64_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int8_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int8_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int8_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Int8_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word16_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word16_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word16_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word16_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word32_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word32_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word32_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word32_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word64_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word64_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word64_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word64_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word8_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word8_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word8_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Left_Word8_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int16_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int16_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int16_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int16_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int32_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int32_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int32_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int32_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int64_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int64_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int64_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int64_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int8_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int8_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int8_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Int8_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word16_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word16_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word16_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word16_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word32_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word32_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word32_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word32_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word64_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word64_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word64_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word64_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word8_Word16.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word8_Word32.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word8_Word64.gold view
file too large to diff
SBVTestSuite/GoldFiles/barrelRotate_Right_Word8_Word8.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-2_1.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-2_2.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-2_3.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-2_4.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-3_1.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-3_2.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-3_3.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-3_4.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-3_5.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-4_1.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-4_2.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-4_3.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-4_4.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-4_5.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-5_1.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-5_2.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-5_3.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-5_4.gold view
file too large to diff
SBVTestSuite/GoldFiles/basic-5_5.gold view
file too large to diff
SBVTestSuite/GoldFiles/ccitt.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr00.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr01.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr02.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr03.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr04.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr05.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr06.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr07.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr08.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr09.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr10.gold view
file too large to diff
SBVTestSuite/GoldFiles/charConstr11.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/check1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/check2.gold view
file too large to diff
SBVTestSuite/GoldFiles/coins.gold view
file too large to diff
− SBVTestSuite/GoldFiles/concreteFoldl.gold
file too large to diff
− SBVTestSuite/GoldFiles/concreteFoldr.gold
file too large to diff
− SBVTestSuite/GoldFiles/concreteReverse.gold
file too large to diff
− SBVTestSuite/GoldFiles/concreteSort.gold
file too large to diff
SBVTestSuite/GoldFiles/constArr2_SArray.gold view
file too large to diff
SBVTestSuite/GoldFiles/constArr_SArray.gold view
file too large to diff
SBVTestSuite/GoldFiles/counts.gold view
file too large to diff
− SBVTestSuite/GoldFiles/crcPolyExist.gold
file too large to diff
+ SBVTestSuite/GoldFiles/doctest_sanity.gold view
file too large to diff
SBVTestSuite/GoldFiles/dsat01.gold view
file too large to diff
SBVTestSuite/GoldFiles/exceptionLocal1.gold view
file too large to diff
SBVTestSuite/GoldFiles/exceptionLocal2.gold view
file too large to diff
SBVTestSuite/GoldFiles/exceptionRemote1.gold view
file too large to diff
− SBVTestSuite/GoldFiles/foldlABC1.gold
file too large to diff
− SBVTestSuite/GoldFiles/foldlABC2.gold
file too large to diff
− SBVTestSuite/GoldFiles/foldlABC3.gold
file too large to diff
− SBVTestSuite/GoldFiles/foldrAB1.gold
file too large to diff
− SBVTestSuite/GoldFiles/foldrAB2.gold
file too large to diff
− SBVTestSuite/GoldFiles/foldrAB3.gold
file too large to diff
SBVTestSuite/GoldFiles/freshVars.gold view
file too large to diff
SBVTestSuite/GoldFiles/genBenchMark1.gold view
file too large to diff
SBVTestSuite/GoldFiles/genBenchMark2.gold view
file too large to diff
− SBVTestSuite/GoldFiles/iteTest1.gold
file too large to diff
− SBVTestSuite/GoldFiles/iteTest2.gold
file too large to diff
− SBVTestSuite/GoldFiles/iteTest3.gold
file too large to diff
+ SBVTestSuite/GoldFiles/lambda01.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda02.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda03.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda04.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda05.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda06.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda07.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda08.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda09.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda10.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda11.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda12.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda13.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda14.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda15.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda16.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda17.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda18.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda19.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda20.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda21.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda22.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda23.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda24.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda25.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda26.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda27.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda28.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda29.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda30.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda31.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda32.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda33.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda34.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda35.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda36.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda37.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda38.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda40.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda41.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda42.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda43.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda44.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda45.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda46.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda47.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda47_c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda48.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda48_c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda49.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda49_c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda50.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda50_c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda51.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda51_c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda52.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda52_c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda53.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda54.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda55.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda56.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda57.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda57a.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda57b.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda57c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda58.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda59.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda60.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda61.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda62.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda63.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda64.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda65.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda66.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda67.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda68.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda69.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda70.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda71.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda72.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda73.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda74.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda75.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda76.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda77.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda78.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda79.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda80.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda81.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda82.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda83.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda84.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda85.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda86.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda87.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/lambda88.gold view
file too large to diff
SBVTestSuite/GoldFiles/legato.gold view
file too large to diff
SBVTestSuite/GoldFiles/legato_c.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/listFloat1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/listFloat2.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/listFloat3.gold view
file too large to diff
− SBVTestSuite/GoldFiles/mapNoFailure.gold
file too large to diff
− SBVTestSuite/GoldFiles/mapWithFailure.gold
file too large to diff
− SBVTestSuite/GoldFiles/maxlWithFailure.gold
file too large to diff
− SBVTestSuite/GoldFiles/maxrWithFailure.gold
file too large to diff
+ SBVTestSuite/GoldFiles/nested1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/nested2.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/nested3.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/nested4.gold view
file too large to diff
SBVTestSuite/GoldFiles/noOpt1.gold view
file too large to diff
SBVTestSuite/GoldFiles/noOpt2.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/nonlinear_cvc4.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/nonlinear_cvc5.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/nonlinear_z3.gold view
file too large to diff
SBVTestSuite/GoldFiles/optBasicsRange_08_signed_max.gold view
file too large to diff
SBVTestSuite/GoldFiles/optBasicsRange_08_signed_min.gold view
file too large to diff
SBVTestSuite/GoldFiles/optBasicsRange_16_signed_max.gold view
file too large to diff
SBVTestSuite/GoldFiles/optBasicsRange_16_signed_min.gold view
file too large to diff
SBVTestSuite/GoldFiles/optBasicsRange_32_signed_max.gold view
file too large to diff
SBVTestSuite/GoldFiles/optBasicsRange_32_signed_min.gold view
file too large to diff
SBVTestSuite/GoldFiles/optBasicsRange_64_signed_max.gold view
file too large to diff
SBVTestSuite/GoldFiles/optBasicsRange_64_signed_min.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat1a.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat1b.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat1c.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat1d.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat2a.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat2b.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat2c.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat2d.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat3.gold view
file too large to diff
SBVTestSuite/GoldFiles/optFloat4.gold view
file too large to diff
SBVTestSuite/GoldFiles/optQuant1.gold view
file too large to diff
SBVTestSuite/GoldFiles/optQuant5.gold view
file too large to diff
SBVTestSuite/GoldFiles/pareto1.gold view
file too large to diff
SBVTestSuite/GoldFiles/pareto2.gold view
file too large to diff
SBVTestSuite/GoldFiles/pbAtLeast.gold view
file too large to diff
SBVTestSuite/GoldFiles/pbAtMost.gold view
file too large to diff
SBVTestSuite/GoldFiles/pbEq.gold view
file too large to diff
SBVTestSuite/GoldFiles/pbEq2.gold view
file too large to diff
SBVTestSuite/GoldFiles/pbExactly.gold view
file too large to diff
SBVTestSuite/GoldFiles/pbGe.gold view
file too large to diff
SBVTestSuite/GoldFiles/pbLe.gold view
file too large to diff
SBVTestSuite/GoldFiles/pbMutexed.gold view
file too large to diff
SBVTestSuite/GoldFiles/pbStronglyMutexed.gold view
file too large to diff
SBVTestSuite/GoldFiles/qEnum1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/qOpt_1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/qOpt_2.gold view
file too large to diff
SBVTestSuite/GoldFiles/qUninterp1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_0.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_2.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_3.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_4.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_5.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_6.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_7.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_8.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_9.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_A.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/quantifiedB_B.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_existsexists_contradiction_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_existsexists_contradiction_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_existsexists_satisfiable_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_existsexists_satisfiable_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_existsexists_thm_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_existsexists_thm_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_existsforall_contradiction_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_existsforall_contradiction_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_existsforall_satisfiable_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_existsforall_satisfiable_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_existsforall_thm_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_existsforall_thm_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_forallexists_contradiction_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_forallexists_contradiction_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_forallexists_satisfiable_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_forallexists_satisfiable_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_forallexists_thm_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_forallexists_thm_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_forallforall_contradiction_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_forallforall_contradiction_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_forallforall_satisfiable_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_forallforall_satisfiable_p.gold view
file too large to diff
− SBVTestSuite/GoldFiles/quantified_prove_forallforall_thm_c.gold
file too large to diff
SBVTestSuite/GoldFiles/quantified_prove_forallforall_thm_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsexists_contradiction_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsexists_contradiction_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsexists_satisfiable_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsexists_satisfiable_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsexists_thm_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsexists_thm_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsforall_contradiction_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsforall_contradiction_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsforall_satisfiable_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsforall_satisfiable_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsforall_thm_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_existsforall_thm_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallexists_contradiction_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallexists_contradiction_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallexists_satisfiable_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallexists_satisfiable_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallexists_thm_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallexists_thm_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallforall_contradiction_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallforall_contradiction_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallforall_satisfiable_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallforall_satisfiable_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallforall_thm_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/quantified_sat_forallforall_thm_p.gold view
file too large to diff
SBVTestSuite/GoldFiles/query1.gold view
file too large to diff
SBVTestSuite/GoldFiles/queryArrays1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/queryArrays10.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/queryArrays11.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/queryArrays12.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/queryArrays13.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/queryArrays14.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/queryArrays15.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/queryArrays16.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/queryArrays17.gold view
file too large to diff
SBVTestSuite/GoldFiles/queryArrays2.gold view
file too large to diff
SBVTestSuite/GoldFiles/queryArrays3.gold view
file too large to diff
SBVTestSuite/GoldFiles/queryArrays4.gold view
file too large to diff
SBVTestSuite/GoldFiles/queryArrays5.gold view
file too large to diff
SBVTestSuite/GoldFiles/queryArrays6.gold view
file too large to diff
SBVTestSuite/GoldFiles/queryArrays7.gold view
file too large to diff
SBVTestSuite/GoldFiles/queryArrays8.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/queryArrays9.gold view
file too large to diff
SBVTestSuite/GoldFiles/queryTables.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Chars1.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Interpolant1.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Interpolant2.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Interpolant3.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Interpolant4.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_ListOfMaybe.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_ListOfSum.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Lists1.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Maybe.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Strings1.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_SumMaybeBoth.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Sums.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Tuples1.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_Tuples2.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_abc.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_badOption.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_bitwuzla.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_boolector.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_cvc4.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_cvc5.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_mathsat.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_sumMergeEither1.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_sumMergeEither2.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_sumMergeMaybe1.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_sumMergeMaybe2.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_uiSat_test1.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_uiSat_test2.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_uisatex1.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_uisatex2.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/query_uisatex3.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_yices.gold view
file too large to diff
SBVTestSuite/GoldFiles/query_z3.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive10_mutual.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive11_chain.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive12_badMutual.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive13_mutualMeasure.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive14_badMutualMeasure.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive15_mixedMutualMeasure.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive16_badMixedMutualMeasure.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive17_chainMeasure.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive19_selfAndMutual.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive1_ack.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive20_mutualTP.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive21_allSelfBadCross.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive22_allSelfGoodCross.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive23_mutualProductive.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive24_badMutualProductive.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive25_contractMutualRejected.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive26_selfAndMutualProductive.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive27_mutualProductive3.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive28_noTermCheck.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive2_enum.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive3_badMeasure.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive4_mcCarthy91.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive5_badContract.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive6_uselessContract.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive7_productive.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive8_badProductive.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/recursive9_productive2.gold view
file too large to diff
− SBVTestSuite/GoldFiles/reverse.gold
file too large to diff
− SBVTestSuite/GoldFiles/reverseAlt10.gold
file too large to diff
SBVTestSuite/GoldFiles/safe1.gold view
file too large to diff
SBVTestSuite/GoldFiles/safe2.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqConcat.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqConcatBad.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqExamples1.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqExamples2.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqExamples3.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqExamples4.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqExamples5.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqExamples6.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqExamples7.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqExamples8.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqIndexOf.gold view
file too large to diff
SBVTestSuite/GoldFiles/seqIndexOfBad.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_compl1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_delete1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_diff1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_disj1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_empty1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_full1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_insert1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_intersect1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_member1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_notMember1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_psubset1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_subset1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_tupleSet.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_uninterp1.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_uninterp2.gold view
file too large to diff
SBVTestSuite/GoldFiles/set_union1.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/smtFuncUniq_captureConflict.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/smtFuncUniq_captureTagged.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/smtFuncUniq_conflict.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/smtFuncUniq_recursiveConflict.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/smtFuncUniq_recursiveOk.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/smtFuncUniq_sameOk.gold view
file too large to diff
− SBVTestSuite/GoldFiles/sort.gold
file too large to diff
SBVTestSuite/GoldFiles/strConcat.gold view
file too large to diff
SBVTestSuite/GoldFiles/strConcatBad.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples1.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples10.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples11.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples12.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples13.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples2.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples3.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples4.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples5.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples6.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples7.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples8.gold view
file too large to diff
SBVTestSuite/GoldFiles/strExamples9.gold view
file too large to diff
SBVTestSuite/GoldFiles/strIndexOf.gold view
file too large to diff
SBVTestSuite/GoldFiles/strIndexOfBad.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumBimapPlus.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumEitherSat.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumLiftEither.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumLiftMaybe.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumMaybe.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumMaybeBoth.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumMergeEither1.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumMergeEither2.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumMergeMaybe1.gold view
file too large to diff
SBVTestSuite/GoldFiles/sumMergeMaybe2.gold view
file too large to diff
SBVTestSuite/GoldFiles/tgen_c.gold view
file too large to diff
SBVTestSuite/GoldFiles/tgen_forte.gold view
file too large to diff
SBVTestSuite/GoldFiles/tgen_haskell.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_alias.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_barFail.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_calcCollapse.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_fooFail.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_hit.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_miss.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_nested.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_recallFail.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_statsHit.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_statsMiss.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/tpCache_statsNested.gold view
file too large to diff
SBVTestSuite/GoldFiles/tuple_enum.gold view
file too large to diff
SBVTestSuite/GoldFiles/tuple_list.gold view
file too large to diff
SBVTestSuite/GoldFiles/tuple_nested.gold view
file too large to diff
SBVTestSuite/GoldFiles/tuple_swap.gold view
file too large to diff
SBVTestSuite/GoldFiles/tuple_twoTwo.gold view
file too large to diff
SBVTestSuite/GoldFiles/tuple_unequal.gold view
file too large to diff
SBVTestSuite/GoldFiles/uiSat_test1.gold view
file too large to diff
SBVTestSuite/GoldFiles/uiSat_test2.gold view
file too large to diff
SBVTestSuite/GoldFiles/uiSat_test3.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/unint-axioms-empty.gold view
file too large to diff
SBVTestSuite/GoldFiles/unint-axioms-query.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/unint-axioms.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/unint-sort01.gold view
file too large to diff
+ SBVTestSuite/GoldFiles/uninterpreted-1a.gold view
file too large to diff
SBVTestSuite/GoldFiles/uninterpreted-3.gold view
file too large to diff
SBVTestSuite/GoldFiles/uninterpreted-3a.gold view
file too large to diff
SBVTestSuite/GoldFiles/uninterpreted-4.gold view
file too large to diff
SBVTestSuite/GoldFiles/uninterpreted-4a.gold view
file too large to diff
SBVTestSuite/GoldFiles/validate_0.gold view
file too large to diff
SBVTestSuite/GoldFiles/validate_1.gold view
file too large to diff
SBVTestSuite/GoldFiles/validate_2.gold view
file too large to diff
SBVTestSuite/GoldFiles/validate_3.gold view
file too large to diff
SBVTestSuite/GoldFiles/validate_4.gold view
file too large to diff
SBVTestSuite/GoldFiles/validate_5.gold view
file too large to diff
SBVTestSuite/GoldFiles/validate_6.gold view
file too large to diff
SBVTestSuite/GoldFiles/validate_7.gold view
file too large to diff
SBVTestSuite/SBVConnectionTest.hs view
file too large to diff
SBVTestSuite/SBVDocTest.hs view
file too large to diff
SBVTestSuite/SBVHLint.hs view
file too large to diff
SBVTestSuite/SBVTest.hs view
file too large to diff
+ SBVTestSuite/TestSuite/ADT/ADT.hs view
file too large to diff
+ SBVTestSuite/TestSuite/ADT/Expr.hs view
file too large to diff
+ SBVTestSuite/TestSuite/ADT/MutRec.hs view
file too large to diff
+ SBVTestSuite/TestSuite/ADT/PExpr.hs view
file too large to diff
SBVTestSuite/TestSuite/Arrays/Caching.hs view
file too large to diff
SBVTestSuite/TestSuite/Arrays/InitVals.hs view
file too large to diff
SBVTestSuite/TestSuite/Arrays/Memory.hs view
file too large to diff
SBVTestSuite/TestSuite/Arrays/Query.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/AllSat.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs view
file too large to diff
+ SBVTestSuite/TestSuite/Basics/ArithNoSolver2.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/ArithSolver.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/BarrelRotate.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/BasicTests.hs view
file too large to diff
− SBVTestSuite/TestSuite/Basics/BoundedList.hs
file too large to diff
+ SBVTestSuite/TestSuite/Basics/EqSym.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/Exceptions.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/GenBenchmark.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/Index.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/IteTest.hs view
file too large to diff
+ SBVTestSuite/TestSuite/Basics/Lambda.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/List.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/ModelValidate.hs view
file too large to diff
+ SBVTestSuite/TestSuite/Basics/Nonlinear.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/ProofTests.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/PseudoBoolean.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/Quantifiers.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/Recursive.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/Set.hs view
file too large to diff
+ SBVTestSuite/TestSuite/Basics/SmtFunctionUnique.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/String.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/Sum.hs view
file too large to diff
+ SBVTestSuite/TestSuite/Basics/TPCaching.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/Tuple.hs view
file too large to diff
SBVTestSuite/TestSuite/Basics/UISat.hs view
file too large to diff
SBVTestSuite/TestSuite/BitPrecise/Legato.hs view
file too large to diff
SBVTestSuite/TestSuite/CRC/CCITT.hs view
file too large to diff
SBVTestSuite/TestSuite/CRC/CCITT_Unidir.hs view
file too large to diff
SBVTestSuite/TestSuite/CRC/GenPoly.hs view
file too large to diff
SBVTestSuite/TestSuite/CRC/USB5.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CantTypeCheck/Misc.hs view
file too large to diff
SBVTestSuite/TestSuite/Char/Char.hs view
file too large to diff
SBVTestSuite/TestSuite/CodeGeneration/Floats.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/Expr.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase01.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase01.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase02.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase02.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase03.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase03.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase04.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase04.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase05.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase05.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase06.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase06.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase07.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase07.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase08.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase08.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase09.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase09.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase10.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase10.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase11.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase11.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase12.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase12.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase13.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase13.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase14.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase14.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase15.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase15.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase16.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase16.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase18.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase18.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase19.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase19.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase20.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase20.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase21.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase21.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase22.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase22.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase23.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase23.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase24.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase24.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase25.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase25.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase26.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase26.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase27.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase27.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase28.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase28.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase29.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase29.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase30.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase30.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase31.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase31.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase32.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase32.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase33.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase33.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase34.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase34.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase35.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase35.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase36.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase36.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase37.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase37.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase39.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase39.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase40.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase40.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase41.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase41.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase42.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase42.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase43.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase43.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase44.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase44.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase45.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase45.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase46.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase46.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase47.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase47.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase48.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase48.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase49.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase49.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase50.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase50.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase51.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase51.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase52.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase52.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase53.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase53.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase54.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase54.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase55.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase55.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase56.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase56.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase57.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase57.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase58.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase58.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase59.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase59.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase60.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase60.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase61.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase61.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase62.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase62.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase63.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase63.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase64.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase64.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase65.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase65.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase66.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase66.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase67.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase67.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase68.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase68.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase69.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase69.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase70.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase70.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase71.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase71.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase72.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase72.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase73.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase73.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase74.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase74.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase75.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase75.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase76.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase76.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/Expr.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase01.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase01.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase02.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase02.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase03.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase03.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase04.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase04.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase05.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase05.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase06.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase06.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase07.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase07.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase08.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase08.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase09.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase09.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase10.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase10.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase100.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase100.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase102.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase102.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase103.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase103.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase104.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase104.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase105.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase105.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase106.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase106.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase11.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase11.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase12.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase12.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase13.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase13.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase14.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase14.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase15.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase15.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase16.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase16.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase17.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase17.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase18.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase18.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase19.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase19.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase20.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase20.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase21.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase21.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase22.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase22.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase23.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase23.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase24.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase24.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase25.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase25.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase26.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase26.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase27.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase27.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase28.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase28.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase29.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase29.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase30.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase30.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase31.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase31.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase32.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase32.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase33.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase33.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase34.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase34.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase35.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase35.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase36.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase36.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase37.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase37.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase38.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase38.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase39.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase39.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase40.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase40.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase41.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase41.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase42.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase42.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase43.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase43.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase44.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase44.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase45.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase45.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase46.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase46.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase47.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase47.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase48.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase48.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase49.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase49.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase50.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase50.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase51.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase51.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase52.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase52.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase53.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase53.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase54.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase54.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase55.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase55.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase56.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase56.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase57.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase57.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase58.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase58.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase60.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase60.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase61.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase61.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase62.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase62.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase63.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase63.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase64.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase64.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase65.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase65.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase67.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase67.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase68.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase68.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase69.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase69.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase70.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase70.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase71.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase71.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase72.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase72.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase73.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase73.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase74.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase74.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase75.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase75.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase76.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase76.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase77.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase77.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase78.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase78.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase79.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase79.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase80.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase80.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase81.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase81.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase82.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase82.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase83.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase83.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase84.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase84.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase85.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase85.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase86.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase86.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase87.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase87.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase88.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase88.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase90.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase90.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase91.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase91.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase92.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase92.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase93.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase93.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase94.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase94.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase95.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase95.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase96.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase96.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase97.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase97.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase98.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase98.stderr view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase99.hs view
file too large to diff
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase99.stderr view
file too large to diff
SBVTestSuite/TestSuite/Crypto/AES.hs view
file too large to diff
− SBVTestSuite/TestSuite/Existentials/CRCPolynomial.hs
file too large to diff
SBVTestSuite/TestSuite/Optimization/AssertWithPenalty.hs view
file too large to diff
SBVTestSuite/TestSuite/Optimization/Basics.hs view
file too large to diff
SBVTestSuite/TestSuite/Optimization/Combined.hs view
file too large to diff
SBVTestSuite/TestSuite/Optimization/ExtensionField.hs view
file too large to diff
SBVTestSuite/TestSuite/Optimization/Floats.hs view
file too large to diff
SBVTestSuite/TestSuite/Optimization/NoOpt.hs view
file too large to diff
SBVTestSuite/TestSuite/Optimization/Quantified.hs view
file too large to diff
SBVTestSuite/TestSuite/Optimization/Reals.hs view
file too large to diff
SBVTestSuite/TestSuite/Optimization/Tuples.hs view
file too large to diff
SBVTestSuite/TestSuite/Overflows/Arithmetic.hs view
file too large to diff
SBVTestSuite/TestSuite/Overflows/Casts.hs view
file too large to diff
SBVTestSuite/TestSuite/Puzzles/Coins.hs view
file too large to diff
SBVTestSuite/TestSuite/Puzzles/Counts.hs view
file too large to diff
SBVTestSuite/TestSuite/Puzzles/MagicSquare.hs view
file too large to diff
SBVTestSuite/TestSuite/Puzzles/NQueens.hs view
file too large to diff
SBVTestSuite/TestSuite/Puzzles/Sudoku.hs view
file too large to diff
SBVTestSuite/TestSuite/Puzzles/Temperature.hs view
file too large to diff
SBVTestSuite/TestSuite/Puzzles/U2Bridge.hs view
file too large to diff
+ SBVTestSuite/TestSuite/Queries/ArrayGetVal.hs view
file too large to diff
SBVTestSuite/TestSuite/Queries/Enums.hs view
file too large to diff
SBVTestSuite/TestSuite/Queries/FreshVars.hs view
file too large to diff
SBVTestSuite/TestSuite/Queries/Interpolants.hs view
file too large to diff
SBVTestSuite/TestSuite/Queries/Lists.hs view
file too large to diff
SBVTestSuite/TestSuite/Queries/Sums.hs view
file too large to diff
SBVTestSuite/TestSuite/Queries/Tables.hs view
file too large to diff
SBVTestSuite/TestSuite/Queries/Tuples.hs view
file too large to diff
SBVTestSuite/TestSuite/Queries/UISatEx.hs view
file too large to diff
SBVTestSuite/TestSuite/Queries/Uninterpreted.hs view
file too large to diff
SBVTestSuite/TestSuite/QuickCheck/QC.hs view
file too large to diff
SBVTestSuite/TestSuite/Transformers/SymbolicEval.hs view
file too large to diff
SBVTestSuite/TestSuite/Uninterpreted/AUF.hs view
file too large to diff
SBVTestSuite/TestSuite/Uninterpreted/Axioms.hs view
file too large to diff
+ SBVTestSuite/TestSuite/Uninterpreted/EUFLogic.hs view
file too large to diff
SBVTestSuite/TestSuite/Uninterpreted/Function.hs view
file too large to diff
SBVTestSuite/TestSuite/Uninterpreted/Sort.hs view
file too large to diff
SBVTestSuite/TestSuite/Uninterpreted/Uninterpreted.hs view
file too large to diff
SBVTestSuite/Utils/SBVTestFramework.hs view
file too large to diff
sbv.cabal view
file too large to diff