Add theorem prover docs page with Phase 2 constraint solving
Some checks failed
Build and Deploy / build-and-deploy (push) Has been cancelled
Some checks failed
Build and Deploy / build-and-deploy (push) Has been cancelled
- prove.sx Phase 2: bounded model checking with 34 algebraic properties (commutativity, associativity, distributivity, inverses, bounds, transitivity) - prove.sx generates SMT-LIB for unbounded Z3 verification via z3-expr - New docs page /plans/theorem-prover with live results (91/91 sat, 34/34 verified) - Page helper runs both proof phases and returns structured data - Parser: re-add ' quote syntax (removed by prior edit) - Load prove.sx alongside z3.sx at startup Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
This commit is contained in:
@@ -28,7 +28,7 @@ def _load_sx_libraries() -> None:
|
||||
"""Load self-hosted SX libraries from the ref directory."""
|
||||
from .jinja_bridge import register_components
|
||||
ref_dir = os.path.join(os.path.dirname(__file__), "ref")
|
||||
for name in ("z3.sx",):
|
||||
for name in ("z3.sx", "prove.sx"):
|
||||
path = os.path.join(ref_dir, name)
|
||||
if os.path.exists(path):
|
||||
with open(path, encoding="utf-8") as f:
|
||||
|
||||
@@ -309,7 +309,11 @@ def _parse_expr(tok: Tokenizer) -> Any:
|
||||
if raw == "{":
|
||||
tok.next_token() # consume the '{'
|
||||
return _parse_map(tok)
|
||||
# Quasiquote syntax: ` , ,@
|
||||
# Quote / quasiquote syntax: ' ` , ,@
|
||||
if raw == "'":
|
||||
tok._advance(1) # consume the quote
|
||||
inner = _parse_expr(tok)
|
||||
return [Symbol("quote"), inner]
|
||||
if raw == "`":
|
||||
tok._advance(1) # consume the backtick
|
||||
inner = _parse_expr(tok)
|
||||
|
||||
@@ -402,3 +402,381 @@
|
||||
:sat sat-count
|
||||
:all-sat (= sat-count total)
|
||||
:results results})))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; Phase 2: Property-based constraint solving
|
||||
;; ==========================================================================
|
||||
;;
|
||||
;; Properties are dicts:
|
||||
;; {:name "+-commutative"
|
||||
;; :vars ("a" "b")
|
||||
;; :test (fn (a b) (= (+ a b) (+ b a))) — for bounded checking
|
||||
;; :holds (= (+ a b) (+ b a)) — quoted AST for SMT-LIB
|
||||
;; :given (fn (lo hi) (<= lo hi)) — optional precondition
|
||||
;; :given-expr (<= lo hi) — quoted AST of precondition
|
||||
;; :domain (-20 21)} — optional custom range
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Domain generation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Default domain bounds by arity — balance coverage vs. combinatorics
|
||||
(define prove-domain-for
|
||||
(fn (arity)
|
||||
(cond
|
||||
(<= arity 1) (range -50 51) ;; 101 values
|
||||
(= arity 2) (range -20 21) ;; 41^2 = 1,681 pairs
|
||||
(= arity 3) (range -8 9) ;; 17^3 = 4,913 triples
|
||||
:else (range -5 6)))) ;; 11^n for n >= 4
|
||||
|
||||
;; Cartesian product: all n-tuples from a domain
|
||||
(define prove-tuples
|
||||
(fn (domain arity)
|
||||
(if (<= arity 0) (list (list))
|
||||
(if (= arity 1)
|
||||
(map (fn (x) (list x)) domain)
|
||||
(let ((sub (prove-tuples domain (- arity 1))))
|
||||
(prove-tuples-expand domain sub (list)))))))
|
||||
|
||||
(define prove-tuples-expand
|
||||
(fn (domain sub acc)
|
||||
(if (empty? domain) acc
|
||||
(prove-tuples-expand
|
||||
(rest domain) sub
|
||||
(append acc
|
||||
(map (fn (t) (cons (first domain) t)) sub))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Function application by arity (no apply primitive available)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define prove-call
|
||||
(fn (f vals)
|
||||
(let ((n (len vals)))
|
||||
(cond
|
||||
(= n 0) (f)
|
||||
(= n 1) (f (nth vals 0))
|
||||
(= n 2) (f (nth vals 0) (nth vals 1))
|
||||
(= n 3) (f (nth vals 0) (nth vals 1) (nth vals 2))
|
||||
(= n 4) (f (nth vals 0) (nth vals 1) (nth vals 2) (nth vals 3))
|
||||
:else nil))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Bounded model checker
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Search for a counterexample. Returns nil if property holds for all tested
|
||||
;; values, or the first counterexample found.
|
||||
(define prove-search
|
||||
(fn (test-fn given-fn domain vars)
|
||||
(let ((arity (len vars))
|
||||
(tuples (prove-tuples domain arity)))
|
||||
(prove-search-loop test-fn given-fn tuples 0 0))))
|
||||
|
||||
(define prove-search-loop
|
||||
(fn (test-fn given-fn tuples tested skipped)
|
||||
(if (empty? tuples)
|
||||
{:status "verified" :tested tested :skipped skipped}
|
||||
(let ((vals (first tuples))
|
||||
(rest-t (rest tuples)))
|
||||
;; Check precondition (if any)
|
||||
(if (and (not (nil? given-fn))
|
||||
(not (prove-call given-fn vals)))
|
||||
;; Precondition not met — skip this combination
|
||||
(prove-search-loop test-fn given-fn rest-t tested (+ skipped 1))
|
||||
;; Evaluate the property
|
||||
(if (prove-call test-fn vals)
|
||||
;; Passed — continue
|
||||
(prove-search-loop test-fn given-fn rest-t (+ tested 1) skipped)
|
||||
;; Failed — counterexample found
|
||||
{:status "falsified"
|
||||
:tested tested
|
||||
:skipped skipped
|
||||
:counterexample vals}))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Property verification (public API)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Verify a single property via bounded model checking
|
||||
(define prove-property
|
||||
(fn (prop)
|
||||
(let ((name (get prop "name"))
|
||||
(vars (get prop "vars"))
|
||||
(test-fn (get prop "test"))
|
||||
(given-fn (get prop "given" nil))
|
||||
(custom (get prop "domain" nil))
|
||||
(domain (if (nil? custom)
|
||||
(prove-domain-for (len vars))
|
||||
(range (nth custom 0) (nth custom 1)))))
|
||||
(let ((result (prove-search test-fn given-fn domain vars)))
|
||||
(assoc result "name" name)))))
|
||||
|
||||
;; Batch verify a list of properties
|
||||
(define prove-properties
|
||||
(fn (props)
|
||||
(let ((results (map prove-property props))
|
||||
(verified (filter (fn (r) (= (get r "status") "verified")) results))
|
||||
(falsified (filter (fn (r) (= (get r "status") "falsified")) results)))
|
||||
{:total (len results)
|
||||
:verified (len verified)
|
||||
:falsified (len falsified)
|
||||
:all-verified (= (len falsified) 0)
|
||||
:results results})))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; SMT-LIB generation for properties
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Generate SMT-LIB for a property — asserts (not (forall ...)) so that
|
||||
;; Z3 returning "unsat" proves the property holds universally.
|
||||
(define prove-property-smtlib
|
||||
(fn (prop)
|
||||
(let ((name (get prop "name"))
|
||||
(vars (get prop "vars"))
|
||||
(holds (get prop "holds"))
|
||||
(given-e (get prop "given-expr" nil))
|
||||
(bindings (join " "
|
||||
(map (fn (v) (str "(" v " Int)")) vars)))
|
||||
(holds-smt (z3-expr holds))
|
||||
(body (if (nil? given-e)
|
||||
holds-smt
|
||||
(str "(=> " (z3-expr given-e) " " holds-smt ")"))))
|
||||
(str "; Property: " name "\n"
|
||||
"; Strategy: assert negation, check for unsat\n"
|
||||
"(assert (not (forall ((" bindings "))\n"
|
||||
" " body ")))\n"
|
||||
"(check-sat) ; expect unsat\n"))))
|
||||
|
||||
;; Generate SMT-LIB for all properties, including necessary definitions
|
||||
(define prove-properties-smtlib
|
||||
(fn (props primitives-exprs)
|
||||
(let ((defs (z3-translate-file primitives-exprs))
|
||||
(prop-smts (map prove-property-smtlib props)))
|
||||
(str ";; ================================================================\n"
|
||||
";; Auto-generated by prove.sx — property verification conditions\n"
|
||||
";; Feed to Z3 for unbounded proofs\n"
|
||||
";; ================================================================\n\n"
|
||||
";; --- Primitive definitions ---\n"
|
||||
defs "\n\n"
|
||||
";; --- Properties ---\n"
|
||||
(join "\n" prop-smts)))))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; Property library: algebraic laws of SX primitives
|
||||
;; ==========================================================================
|
||||
|
||||
(define sx-properties
|
||||
(list
|
||||
|
||||
;; ----- Arithmetic identities -----
|
||||
|
||||
{:name "+-commutative"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (+ a b) (+ b a)))
|
||||
:holds '(= (+ a b) (+ b a))}
|
||||
|
||||
{:name "+-associative"
|
||||
:vars (list "a" "b" "c")
|
||||
:test (fn (a b c) (= (+ (+ a b) c) (+ a (+ b c))))
|
||||
:holds '(= (+ (+ a b) c) (+ a (+ b c)))}
|
||||
|
||||
{:name "+-identity"
|
||||
:vars (list "a")
|
||||
:test (fn (a) (= (+ a 0) a))
|
||||
:holds '(= (+ a 0) a)}
|
||||
|
||||
{:name "*-commutative"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (* a b) (* b a)))
|
||||
:holds '(= (* a b) (* b a))}
|
||||
|
||||
{:name "*-associative"
|
||||
:vars (list "a" "b" "c")
|
||||
:test (fn (a b c) (= (* (* a b) c) (* a (* b c))))
|
||||
:holds '(= (* (* a b) c) (* a (* b c)))}
|
||||
|
||||
{:name "*-identity"
|
||||
:vars (list "a")
|
||||
:test (fn (a) (= (* a 1) a))
|
||||
:holds '(= (* a 1) a)}
|
||||
|
||||
{:name "*-zero"
|
||||
:vars (list "a")
|
||||
:test (fn (a) (= (* a 0) 0))
|
||||
:holds '(= (* a 0) 0)}
|
||||
|
||||
{:name "distributive"
|
||||
:vars (list "a" "b" "c")
|
||||
:test (fn (a b c) (= (* a (+ b c)) (+ (* a b) (* a c))))
|
||||
:holds '(= (* a (+ b c)) (+ (* a b) (* a c)))}
|
||||
|
||||
{:name "--inverse"
|
||||
:vars (list "a")
|
||||
:test (fn (a) (= (- a a) 0))
|
||||
:holds '(= (- a a) 0)}
|
||||
|
||||
;; ----- inc / dec -----
|
||||
|
||||
{:name "inc-is-plus-1"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (inc n) (+ n 1)))
|
||||
:holds '(= (inc n) (+ n 1))}
|
||||
|
||||
{:name "dec-is-minus-1"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (dec n) (- n 1)))
|
||||
:holds '(= (dec n) (- n 1))}
|
||||
|
||||
{:name "inc-dec-inverse"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (dec (inc n)) n))
|
||||
:holds '(= (dec (inc n)) n)}
|
||||
|
||||
{:name "dec-inc-inverse"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (inc (dec n)) n))
|
||||
:holds '(= (inc (dec n)) n)}
|
||||
|
||||
;; ----- abs -----
|
||||
|
||||
{:name "abs-non-negative"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (>= (abs n) 0))
|
||||
:holds '(>= (abs n) 0)}
|
||||
|
||||
{:name "abs-idempotent"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (abs (abs n)) (abs n)))
|
||||
:holds '(= (abs (abs n)) (abs n))}
|
||||
|
||||
{:name "abs-symmetric"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (abs n) (abs (- 0 n))))
|
||||
:holds '(= (abs n) (abs (- 0 n)))}
|
||||
|
||||
;; ----- Predicates -----
|
||||
|
||||
{:name "odd-not-even"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (odd? n) (not (even? n))))
|
||||
:holds '(= (odd? n) (not (even? n)))}
|
||||
|
||||
{:name "even-mod-2"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (even? n) (= (mod n 2) 0)))
|
||||
:holds '(= (even? n) (= (mod n 2) 0))}
|
||||
|
||||
{:name "zero-is-zero"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (zero? n) (= n 0)))
|
||||
:holds '(= (zero? n) (= n 0))}
|
||||
|
||||
{:name "not-involution"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (not (not (zero? n))) (zero? n)))
|
||||
:holds '(= (not (not (zero? n))) (zero? n))}
|
||||
|
||||
;; ----- min / max -----
|
||||
|
||||
{:name "min-commutative"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (min a b) (min b a)))
|
||||
:holds '(= (min a b) (min b a))}
|
||||
|
||||
{:name "max-commutative"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (max a b) (max b a)))
|
||||
:holds '(= (max a b) (max b a))}
|
||||
|
||||
{:name "min-le-both"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (and (<= (min a b) a) (<= (min a b) b)))
|
||||
:holds '(and (<= (min a b) a) (<= (min a b) b))}
|
||||
|
||||
{:name "max-ge-both"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (and (>= (max a b) a) (>= (max a b) b)))
|
||||
:holds '(and (>= (max a b) a) (>= (max a b) b))}
|
||||
|
||||
{:name "min-max-identity"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (+ (min a b) (max a b)) (+ a b)))
|
||||
:holds '(= (+ (min a b) (max a b)) (+ a b))}
|
||||
|
||||
;; ----- clamp -----
|
||||
|
||||
{:name "clamp-in-range"
|
||||
:vars (list "x" "lo" "hi")
|
||||
:test (fn (x lo hi) (and (<= lo (clamp x lo hi))
|
||||
(<= (clamp x lo hi) hi)))
|
||||
:given (fn (x lo hi) (<= lo hi))
|
||||
:holds '(and (<= lo (clamp x lo hi)) (<= (clamp x lo hi) hi))
|
||||
:given-expr '(<= lo hi)}
|
||||
|
||||
{:name "clamp-identity-in-range"
|
||||
:vars (list "x" "lo" "hi")
|
||||
:test (fn (x lo hi) (= (clamp x lo hi) x))
|
||||
:given (fn (x lo hi) (and (<= lo hi) (<= lo x) (<= x hi)))
|
||||
:holds '(= (clamp x lo hi) x)
|
||||
:given-expr '(and (<= lo hi) (<= lo x) (<= x hi))}
|
||||
|
||||
{:name "clamp-idempotent"
|
||||
:vars (list "x" "lo" "hi")
|
||||
:test (fn (x lo hi) (= (clamp (clamp x lo hi) lo hi)
|
||||
(clamp x lo hi)))
|
||||
:given (fn (x lo hi) (<= lo hi))
|
||||
:holds '(= (clamp (clamp x lo hi) lo hi) (clamp x lo hi))
|
||||
:given-expr '(<= lo hi)}
|
||||
|
||||
;; ----- Comparison -----
|
||||
|
||||
{:name "lt-gt-flip"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (< a b) (> b a)))
|
||||
:holds '(= (< a b) (> b a))}
|
||||
|
||||
{:name "le-not-gt"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (<= a b) (not (> a b))))
|
||||
:holds '(= (<= a b) (not (> a b)))}
|
||||
|
||||
{:name "ge-not-lt"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (>= a b) (not (< a b))))
|
||||
:holds '(= (>= a b) (not (< a b)))}
|
||||
|
||||
{:name "trichotomy"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (or (< a b) (= a b) (> a b)))
|
||||
:holds '(or (< a b) (= a b) (> a b))}
|
||||
|
||||
{:name "lt-transitive"
|
||||
:vars (list "a" "b" "c")
|
||||
:test (fn (a b c) (if (and (< a b) (< b c)) (< a c) true))
|
||||
:given (fn (a b c) (and (< a b) (< b c)))
|
||||
:holds '(< a c)
|
||||
:given-expr '(and (< a b) (< b c))}
|
||||
|
||||
;; ----- Inequality -----
|
||||
|
||||
{:name "neq-is-not-eq"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (!= a b) (not (= a b))))
|
||||
:holds '(= (!= a b) (not (= a b)))}))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Run all built-in properties
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define prove-all-properties
|
||||
(fn ()
|
||||
(prove-properties sx-properties)))
|
||||
|
||||
Reference in New Issue
Block a user