mirror of
https://github.com/google-deepmind/deepmind-research.git
synced 2026-05-09 12:37:43 +08:00
Crediting Alex Matthews as a code contributor
PiperOrigin-RevId: 360859332
This commit is contained in:
Jonathan Schwarz
committed by
Louise Deason
Louise Deason
parent
7e6fd889e4
commit
ca532c106c
@@ -60,7 +60,8 @@
|
||||
"code authors:\n",
|
||||
"\n",
|
||||
"* Jonathan Schwarz (schwarzjn@google.com)\n",
|
||||
"* Michalis Titsias (mtitsias@google.com)"
|
||||
"* Michalis Titsias (mtitsias@google.com)\n",
|
||||
"* Alex Matthews (alexmatthews@google.com)"
|
||||
]
|
||||
},
|
||||
{
|
||||
|
||||
@@ -0,0 +1,246 @@
|
||||
#lang racket/base
|
||||
|
||||
;**************************************************************************************;
|
||||
;**** Clause: Clauses With Additional Properties In A Struct ****;
|
||||
;**************************************************************************************;
|
||||
|
||||
(require define2
|
||||
define2/define-wrapper
|
||||
global
|
||||
racket/format
|
||||
racket/list
|
||||
racket/string
|
||||
satore/clause
|
||||
satore/clause-format
|
||||
satore/misc
|
||||
satore/unification
|
||||
text-table)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;==============;
|
||||
;=== Clause ===;
|
||||
;==============;
|
||||
|
||||
;; TODO: A lot of space is wasted in Clause (boolean flags?)
|
||||
;; What's the best way to gain space without losing time or readability?
|
||||
|
||||
;; parents : (listof Clause?) ; The first parent is the 'mother'.
|
||||
;; binary-rewrite-rule? : Initiually #false, set to #true if the clause has been added (at some point)
|
||||
;; to the binary rewrite rules (but may not be in the set anymore if subsumed).
|
||||
;; size: tree-size of the clause.
|
||||
;; depth: Maternal-path depth.
|
||||
;; cost: Maternal-path cost.
|
||||
(struct Clause (idx
|
||||
parents
|
||||
clause
|
||||
type
|
||||
[binary-rewrite-rule? #:mutable]
|
||||
[candidate? #:mutable]
|
||||
[discarded? #:mutable]
|
||||
n-literals
|
||||
size
|
||||
depth
|
||||
[cost #:mutable]
|
||||
[g-cost #:mutable])
|
||||
#:prefab)
|
||||
|
||||
(define-counter clause-index 0)
|
||||
|
||||
(define (make-Clause cl
|
||||
[parents '()]
|
||||
#:type [type '?]
|
||||
#:candidate? [candidate? #false]
|
||||
#:n-literals [n-literals (length cl)]
|
||||
#:size [size (clause-size cl)]
|
||||
#:depth [depth (if (empty? parents) 1 (+ 1 (Clause-depth (first parents))))])
|
||||
(++clause-index)
|
||||
(when-debug>= steps
|
||||
(define cl2 (clause-normalize cl)) ; costly, hence done only in debug mode
|
||||
(unless (= (tree-size cl) (tree-size cl2))
|
||||
(displayln "Assertion failed: clause is in normal form")
|
||||
(printf "Clause (type: ~a):\n~a\n" type (clause->string cl))
|
||||
(displayln "Parents:")
|
||||
(print-Clauses parents)
|
||||
(error (format "Assertion failed: (= (tree-size cl) (tree-size cl2)): ~a ~a"
|
||||
(tree-size cl) (tree-size cl2)))))
|
||||
; Notice: Variables are ASSUMED freshed. Freshing is not performed here.
|
||||
(Clause clause-index
|
||||
parents
|
||||
cl
|
||||
type
|
||||
#false ; binary-rewrite-rule
|
||||
candidate?
|
||||
#false ; discarded?
|
||||
n-literals
|
||||
size
|
||||
depth ; depth (C0 is of depth 0, axioms are of depth 1)
|
||||
0. ; cost
|
||||
0. ; g-cost
|
||||
))
|
||||
|
||||
(define (discard-Clause! C) (set-Clause-discarded?! C #true))
|
||||
|
||||
(define true-Clause (make-Clause (list ltrue)))
|
||||
|
||||
;; For temporary converse Clauses for binary clauses.
|
||||
(define (make-converse-Clause C #:candidate? [candidate? #false])
|
||||
(if (unit-Clause? C)
|
||||
true-Clause ; If C has 1 literal A, then C = A | false, and converse is ~A | true = true
|
||||
(make-Clause (fresh (clause-converse (Clause-clause C)))
|
||||
(list C)
|
||||
#:type 'converse
|
||||
#:candidate? candidate?
|
||||
)))
|
||||
|
||||
(define Clause->string-all-fields '(idx parents clause type binary-rw? depth size cost))
|
||||
|
||||
;; If what is a list, each element is printed (possibly multiple times).
|
||||
;; If what is 'all, all fields are printed.
|
||||
(define (Clause->list C [what '(idx parents clause)])
|
||||
(when (eq? what 'all)
|
||||
(set! what Clause->string-all-fields))
|
||||
(for/list ([w (in-list what)])
|
||||
(case w
|
||||
[(idx) (~a (Clause-idx C))]
|
||||
[(parents) (~a (map Clause-idx (Clause-parents C)))]
|
||||
[(clause) (clause->string (Clause-clause C))]
|
||||
[(clause-pretty) (clause->string/pretty (Clause-clause C))]
|
||||
[(type) (~a (Clause-type C))]
|
||||
[(binary-rw?) (~a (Clause-binary-rewrite-rule? C))]
|
||||
[(depth) (~r (Clause-depth C))]
|
||||
[(size) (~r (Clause-size C))]
|
||||
[(cost) (~r2 (Clause-cost C))])))
|
||||
|
||||
(define (Clause->string C [what '(idx parents clause)])
|
||||
(string-join (Clause->list C what) " "))
|
||||
|
||||
(define (Clause->string/alone C [what '(idx parents clause)])
|
||||
(when (eq? what 'all)
|
||||
(set! what Clause->string-all-fields))
|
||||
(string-join (map (λ (f w) (format "~a: ~a " w f))
|
||||
(Clause->list C what)
|
||||
what)
|
||||
" "))
|
||||
|
||||
(define (print-Clauses Cs [what '(idx parents clause)])
|
||||
(when (eq? what 'all)
|
||||
(set! what Clause->string-all-fields))
|
||||
(print-simple-table
|
||||
(cons what
|
||||
(map (λ (C) (Clause->list C what)) Cs))))
|
||||
|
||||
;; <=> to avoid hard-to-debug mistakes where Clause-subsumes is used instead of Clause<-subsumes
|
||||
;; for example.
|
||||
;; Notice: This is an approximation of the correct subsumption based on multisets, and may not
|
||||
;; be confluent.
|
||||
(define (Clause<=>-subsumes C1 C2)
|
||||
(clause-subsumes (Clause-clause C1) (Clause-clause C2)))
|
||||
|
||||
;; Use atom<=> ?
|
||||
(define Clause-cmp-key Clause-size)
|
||||
(define (Clause<= C1 C2) (<= (Clause-cmp-key C1) (Clause-cmp-key C2)))
|
||||
(define (Clause< C1 C2) (< (Clause-cmp-key C1) (Clause-cmp-key C2)))
|
||||
|
||||
(define (Clause<=-subsumes C1 C2)
|
||||
(and (Clause<= C1 C2)
|
||||
(Clause<=>-subsumes C1 C2)))
|
||||
|
||||
(define (Clause<-subsumes C1 C2)
|
||||
(and (Clause< C1 C2)
|
||||
(Clause<=>-subsumes C1 C2)))
|
||||
|
||||
;; Useful for rewrite rules
|
||||
(define (Clause<=>-converse-subsumes C1 C2)
|
||||
(clause-subsumes (clause-converse (Clause-clause C1))
|
||||
(Clause-clause C2)))
|
||||
|
||||
(define (unit-Clause? C)
|
||||
(= 1 (Clause-n-literals C)))
|
||||
|
||||
(define (binary-Clause? C)
|
||||
(= 2 (Clause-n-literals C)))
|
||||
|
||||
(define (Clause-tautology? C)
|
||||
(clause-tautology? (Clause-clause C)))
|
||||
|
||||
;; Returns the tree of ancestor Clauses of C up to init Clauses,
|
||||
;; but each Clause appears only once in the tree.
|
||||
;; (The full tree can be further retrieved from the Clause-parents.)
|
||||
;; Used for proofs.
|
||||
(define (Clause-ancestor-graph C #:depth [dmax +inf.0])
|
||||
(define h (make-hasheq))
|
||||
(let loop ([C C] [depth 0])
|
||||
(cond
|
||||
[(or (> depth dmax)
|
||||
(hash-has-key? h C))
|
||||
#false]
|
||||
[else
|
||||
(hash-set! h C #true)
|
||||
(cons C (filter-map (λ (C2) (loop C2 (+ depth 1)))
|
||||
(Clause-parents C)))])))
|
||||
|
||||
(define (Clause-ancestor-graph-string C
|
||||
#:? [depth +inf.0]
|
||||
#:? [prefix ""]
|
||||
#:? [tab " "]
|
||||
#:? [what '(idx parents type clause)])
|
||||
(define h (make-hasheq))
|
||||
(define str-out "")
|
||||
(let loop ([C C] [d 0])
|
||||
(unless (or (> d depth)
|
||||
(hash-has-key? h C))
|
||||
(set! str-out (string-append str-out
|
||||
prefix
|
||||
(string-append* (make-list d tab))
|
||||
(Clause->string C what)
|
||||
"\n"))
|
||||
(hash-set! h C #true)
|
||||
(for ([P (in-list (Clause-parents C))])
|
||||
(loop P (+ d 1)))))
|
||||
str-out)
|
||||
|
||||
(define-wrapper (display-Clause-ancestor-graph
|
||||
(Clause-ancestor-graph-string C #:? depth #:? prefix #:? tab #:? what))
|
||||
#:call-wrapped call
|
||||
(display (call)))
|
||||
|
||||
(define (Clause-age<= C1 C2)
|
||||
(<= (Clause-idx C1) (Clause-idx C2)))
|
||||
|
||||
(define (save-Clauses! Cs f #:? exists)
|
||||
(save-clauses! (map Clause-clause Cs) f #:exists exists))
|
||||
|
||||
(define (load-Clauses f #:? [sort? #true] #:? [type 'load])
|
||||
(define Cs (map (λ (c) (make-Clause c #:type type))
|
||||
(load-clauses f)))
|
||||
(if sort?
|
||||
(sort Cs Clause<=)
|
||||
Cs))
|
||||
|
||||
(define (Clause-equivalence? C1 C2)
|
||||
(and (Clause<=>-subsumes C1 C2)
|
||||
(Clause<=>-subsumes C2 C1)))
|
||||
|
||||
;; Provides testing utilities. Use with `(require (submod "Clause.rkt" test))`.
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(provide Clausify
|
||||
check-Clause-set-equivalent?)
|
||||
|
||||
(define Clausify (compose make-Clause clausify))
|
||||
|
||||
(define-check (check-Clause-set-equivalent? Cs1 Cs2)
|
||||
(unless (= (length Cs1) (length Cs2))
|
||||
(fail-check "not ="))
|
||||
(for/fold ([Cs2 Cs2])
|
||||
([C1 (in-list Cs1)])
|
||||
(define C1b
|
||||
(for/first ([C2 (in-list Cs2)] #:when (Clause-equivalence? C1 C2))
|
||||
C2))
|
||||
(unless C1b
|
||||
(printf "Cannot find equivalence Clause for ~a\n" (Clause->string C1))
|
||||
(print-Clauses Cs1)
|
||||
(print-Clauses Cs2)
|
||||
(fail-check))
|
||||
(remq C1b Cs2))))
|
||||
@@ -0,0 +1,50 @@
|
||||
# Satore: First-order logic saturation with atomic rewriting
|
||||
|
||||
This is a first-order logic resolution based theorem prover in CNF without
|
||||
equality, but with atom rewrite rules. New rewrite rules can be
|
||||
discovered during the proof search, potentially reducing exponentially the
|
||||
search space.
|
||||
|
||||
Satore stands for Saturation with Atom Rewriting.
|
||||
|
||||
## Installation
|
||||
|
||||
### Install racket (Apache2/MIT):
|
||||
* Windows, MacOS X: https://download.racket-lang.org
|
||||
* Ubuntu/Debian: `[sudo] apt install racket`
|
||||
* Linux (other): [Download](https://download.racket-lang.org) the `.sh` and
|
||||
install it with `[sudo] sh racket-<something>.sh`
|
||||
|
||||
You may need to configure the PATH environment variable to include the
|
||||
directory containing the `racket` and `raco` executables.
|
||||
For Windows this directory should be something like
|
||||
`C:>Program Files\Racket`.
|
||||
|
||||
### Install satore and its dependencies (all are Apache2/MIT licensed):
|
||||
|
||||
In a directory of your choice, type:
|
||||
|
||||
```shell
|
||||
git clone https://github.com/deepmind/deepmind-research/tree/master/satore
|
||||
raco pkg install --auto --link satore
|
||||
```
|
||||
|
||||
## Running Satore
|
||||
|
||||
Run a trivial example:
|
||||
|
||||
```shell
|
||||
racket -l- satore -p satore/examples/socrates.p --proof
|
||||
```
|
||||
|
||||
To see the various flags:
|
||||
|
||||
```shell
|
||||
racket -l- satore --help
|
||||
```
|
||||
|
||||
The .p file is assumed to be a standalone file with only comments and
|
||||
`cnf(…).` lines without equality, where the logic clause must be surrounded by
|
||||
parentheses. All axioms must be included. (This will likely be improved soon.)
|
||||
|
||||
Note that `racket -l- satore` can be invoked from anywhere.
|
||||
@@ -0,0 +1,41 @@
|
||||
#lang racket/base
|
||||
|
||||
;***************************************************************************************;
|
||||
;**** Clause <-> String Conversions ****;
|
||||
;***************************************************************************************;
|
||||
|
||||
;;; In a separate file because of cyclic dependencies with "tptp.rkt" if in "clause.rkt"
|
||||
|
||||
(require racket/format
|
||||
racket/list
|
||||
racket/pretty
|
||||
satore/clause
|
||||
satore/tptp
|
||||
satore/unification
|
||||
text-table)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (clause->string cl)
|
||||
((if (*tptp-out?*)
|
||||
clause->tptp-string
|
||||
~a)
|
||||
(Vars->symbols cl)))
|
||||
|
||||
(define (clause->string/pretty cl)
|
||||
(pretty-format (Vars->symbols cl)))
|
||||
|
||||
(define (print-clause cl)
|
||||
(displayln (clause->string cl)))
|
||||
|
||||
(define (print-clauses cls #:sort? [sort? #false])
|
||||
(unless (empty? cls)
|
||||
(print-table
|
||||
(for/list ([cl (in-list (if sort?
|
||||
(sort cls < #:key tree-size #:cache-keys? #true)
|
||||
cls))]
|
||||
[i (in-naturals)])
|
||||
(cons i (Vars->symbols cl)))
|
||||
#:border-style 'space
|
||||
#:row-sep? #false
|
||||
#:framed? #false)))
|
||||
@@ -0,0 +1,197 @@
|
||||
#lang racket/base
|
||||
|
||||
;***************************************************************************************;
|
||||
;**** Operations on clauses ****;
|
||||
;***************************************************************************************;
|
||||
|
||||
(require bazaar/cond-else
|
||||
bazaar/debug
|
||||
bazaar/list
|
||||
bazaar/loop
|
||||
bazaar/mutation
|
||||
(except-in bazaar/order atom<=>)
|
||||
define2
|
||||
global
|
||||
racket/file
|
||||
racket/format
|
||||
racket/list
|
||||
racket/pretty
|
||||
satore/misc
|
||||
satore/trie
|
||||
satore/unification
|
||||
syntax/parse/define
|
||||
text-table)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-global *subsumes-iter-limit* 0
|
||||
'("Number of iterations in the θ-subsumption loop before failing."
|
||||
"May help in cases where subsumption take far too long."
|
||||
"0 = no limit.")
|
||||
exact-nonnegative-integer?
|
||||
string->number)
|
||||
|
||||
(define-counter n-tautologies 0)
|
||||
|
||||
(define (sort-clause cl)
|
||||
(sort cl literal<?))
|
||||
|
||||
;; cl is assumed to be already Varified, but possibly not freshed.
|
||||
;; Notice: Does not do rewriting.
|
||||
(define (clause-normalize cl)
|
||||
; fresh the variables just to make sure
|
||||
(fresh (safe-factoring (sort-clause cl))))
|
||||
|
||||
;; Used to turn human-readable clauses into computer-friendly clauses.
|
||||
(define (clausify cl)
|
||||
(clause-normalize (Varify cl)))
|
||||
|
||||
(define (empty-clause? cl)
|
||||
(empty? cl))
|
||||
|
||||
;; Definition of tautology:
|
||||
;; cl is a tautology if all ground instances of cl contain an atom and its negation.
|
||||
;; Assumes that the clause cl is sorted according to `sort-clause`.
|
||||
(define (clause-tautology? cl)
|
||||
(define-values (neg pos) (partition lnot? cl))
|
||||
(define pneg (map lnot neg))
|
||||
(and
|
||||
(or
|
||||
(memq ltrue pos)
|
||||
(memq lfalse pneg)
|
||||
(let loop ([pos pos] [pneg pneg])
|
||||
(cond/else
|
||||
[(or (empty? pos) (empty? pneg)) #false]
|
||||
#:else
|
||||
(define p (first pos))
|
||||
(define n (first pneg))
|
||||
(define c (literal<=> p n))
|
||||
#:cond
|
||||
[(order<? c) (loop (rest pos) pneg)]
|
||||
[(order>? c) (loop pos (rest pneg))]
|
||||
[(literal==? p n)]
|
||||
#:else (error "uh?"))))
|
||||
(begin (++n-tautologies) #true)))
|
||||
|
||||
;; NOTICE: This does *not* rename the variables.
|
||||
(define (clause-converse cl)
|
||||
(sort-clause (map lnot cl)))
|
||||
|
||||
;; Assumes that cl is sorted according to `sort-clause`.
|
||||
(define (remove-duplicate-literals cl)
|
||||
(zip-loop ([(x r) cl] [res '()] #:result (reverse res))
|
||||
(cond/else
|
||||
[(empty? r) (cons x res)]
|
||||
#:else
|
||||
(define y (first r))
|
||||
#:cond
|
||||
[(literal==? x y) res]
|
||||
#:else (cons x res))))
|
||||
|
||||
(define (predicate.arity lit)
|
||||
(cond [(list? lit) (cons (first lit) (length lit))]
|
||||
[else (cons lit 0)]))
|
||||
|
||||
|
||||
(define-counter n-subsumes-checks 0)
|
||||
(define-counter n-subsumes-steps 0)
|
||||
(define-counter n-subsumes-breaks 0)
|
||||
(define (reset-subsumes-stats!)
|
||||
(reset-n-subsumes-checks!)
|
||||
(reset-n-subsumes-steps!)
|
||||
(reset-n-subsumes-breaks!))
|
||||
|
||||
|
||||
;; θ-subsumption.
|
||||
;; ca θ-subsumes cb if there exists a substitution α such that ca[α] ⊆ cb
|
||||
;; (requires removing duplicate literals as in FOL clauses are assumed to be sets of literals).
|
||||
;; Assumes vars(ca) ∩ vars(cb) = ∅.
|
||||
|
||||
(define (clause-subsumes ca cb)
|
||||
(++n-subsumes-checks)
|
||||
; For every each la of ca with current substitution β, we need to find a literal lb of cb
|
||||
; such that we can extend β to β' so that la[β'] = lb.
|
||||
; TODO: order the groups by smallest size for cb.
|
||||
; TODO: need to split by polarity first, or sort by (polarity predicate arity)
|
||||
; For each literal of ca, obtain the list of literals of cb that unify with it.
|
||||
; place cb in a trie
|
||||
; then retrieve
|
||||
|
||||
(define cbtrie (make-trie #:variable? Var?))
|
||||
(for ([litb (in-list cb)])
|
||||
; the key must be a list, but a literal may be just a constant, so we need to `list` it.
|
||||
(trie-insert! cbtrie (list litb) litb))
|
||||
|
||||
;; Each literal lita of ca is paired with a list of potential literals in cb that lita matches,
|
||||
;; for subsequent left-unification.
|
||||
;; We sort the groups by smallest size first, to fail fast.
|
||||
(define groups
|
||||
(sort
|
||||
(for/list ([lita (in-list ca)])
|
||||
; lita must match litb, hence inverse-ref
|
||||
(cons lita (append* (trie-inverse-ref cbtrie (list lita)))))
|
||||
< #:key length #:cache-keys? #true))
|
||||
|
||||
;; Depth-first search while trying to find a substitution that works for all literals of ca.
|
||||
;; TODO: if number of iterations is larger than threshold, abort (use let/ec)
|
||||
(define n-iter-max (*subsumes-iter-limit*))
|
||||
(define n-iter 0)
|
||||
|
||||
(let/ec return
|
||||
(let loop ([groups groups] [subst '()])
|
||||
(++ n-iter)
|
||||
(when (= n-iter n-iter-max) ; if n-iter-max = 0 then no limit
|
||||
(++n-subsumes-breaks)
|
||||
(return #false))
|
||||
(++n-subsumes-steps)
|
||||
(cond
|
||||
[(empty? groups) subst]
|
||||
[else
|
||||
(define-values (lita litbs) (car+cdr (first groups)))
|
||||
(for/or ([litb (in-list litbs)])
|
||||
; We use a immutable substitution to let racket handle copies when needed.
|
||||
(define new-subst (left-unify/assoc lita litb subst))
|
||||
(and new-subst (loop (rest groups) new-subst)))]))))
|
||||
|
||||
;; Assumes that the clause cl is sorted according to `sort-clause`.
|
||||
;; A safe factor f of cl is such that f[α] ⊆ cl for some subst α, that is,
|
||||
;; f θ-subsumes cl. But since cl necessarily θ-subsumes all of its factors XXX
|
||||
;; - The return value is eq? to the argument cl if no safe-factoring is possible.
|
||||
;; - Applies safe-factoring as much as possible.
|
||||
(define (safe-factoring cl)
|
||||
(let/ec return
|
||||
(zip-loop ([(l x r) cl])
|
||||
(define pax (predicate.arity x))
|
||||
(zip-loop ([(l2 y r2) r] #:break (not (equal? pax (predicate.arity y))))
|
||||
; To avoid code duplication:
|
||||
(define-simple-macro (attempt a b)
|
||||
(begin
|
||||
(define s (left-unify a b))
|
||||
(when s
|
||||
(define new-cl
|
||||
(sort-clause
|
||||
(fresh ; required for clause-subsumes below
|
||||
(left-substitute (rev-append l (rev-append l2 (cons a r2))) ; remove b
|
||||
s))))
|
||||
(when (clause-subsumes new-cl cl)
|
||||
; Try one more time with new-cl.
|
||||
(return (safe-factoring new-cl))))))
|
||||
|
||||
(attempt x y)
|
||||
(attempt y x)))
|
||||
cl))
|
||||
|
||||
(define (clause-equivalence? A B)
|
||||
(and (clause-subsumes A B)
|
||||
(clause-subsumes B A)))
|
||||
|
||||
;==============;
|
||||
;=== Saving ===;
|
||||
;==============;
|
||||
|
||||
(define (save-clauses! cls f #:? [exists 'replace])
|
||||
(with-output-to-file f #:exists exists
|
||||
(λ () (for-each writeln cls))))
|
||||
|
||||
(define (load-clauses f)
|
||||
(map clausify (file->list f)))
|
||||
@@ -0,0 +1,62 @@
|
||||
cnf(i_0, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a))).
|
||||
cnf(i_1, plain, (~num(b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26, X27, X28) | num(a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26, X27, X28))).
|
||||
cnf(i_2, plain, (num(b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26, X27, X28) | ~num(a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26, X27, X28))).
|
||||
cnf(i_3, plain, (~num(a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26, X27) | num(b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26, X27))).
|
||||
cnf(i_4, plain, (num(a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26, X27) | ~num(b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26, X27))).
|
||||
cnf(i_5, plain, (~num(a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26) | num(b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26))).
|
||||
cnf(i_6, plain, (num(a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26) | ~num(b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25, X26))).
|
||||
cnf(i_7, plain, (~num(a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25) | num(b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25))).
|
||||
cnf(i_8, plain, (num(a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25) | ~num(b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24, X25))).
|
||||
cnf(i_9, plain, (~num(a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24) | num(b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24))).
|
||||
cnf(i_10, plain, (num(a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24) | ~num(b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23, X24))).
|
||||
cnf(i_11, plain, (~num(a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23) | num(b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23))).
|
||||
cnf(i_12, plain, (num(a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23) | ~num(b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22, X23))).
|
||||
cnf(i_13, plain, (~num(a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22) | num(b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22))).
|
||||
cnf(i_14, plain, (num(a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22) | ~num(b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21, X22))).
|
||||
cnf(i_15, plain, (~num(a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21) | num(b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21))).
|
||||
cnf(i_16, plain, (num(a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21) | ~num(b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20, X21))).
|
||||
cnf(i_17, plain, (~num(a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20) | num(b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20))).
|
||||
cnf(i_18, plain, (num(a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20) | ~num(b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19, X20))).
|
||||
cnf(i_19, plain, (~num(a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19) | num(b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19))).
|
||||
cnf(i_20, plain, (num(a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19) | ~num(b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18, X19))).
|
||||
cnf(i_21, plain, (~num(a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18) | num(b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18))).
|
||||
cnf(i_22, plain, (num(a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18) | ~num(b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17, X18))).
|
||||
cnf(i_23, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17) | num(b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17))).
|
||||
cnf(i_24, plain, (num(a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17) | ~num(b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16, X17))).
|
||||
cnf(i_25, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16) | num(b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16))).
|
||||
cnf(i_26, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15, X16))).
|
||||
cnf(i_27, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15))).
|
||||
cnf(i_28, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14, X15))).
|
||||
cnf(i_29, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14))).
|
||||
cnf(i_30, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13, X14))).
|
||||
cnf(i_31, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13))).
|
||||
cnf(i_32, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12, X13))).
|
||||
cnf(i_33, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12))).
|
||||
cnf(i_34, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11, X12))).
|
||||
cnf(i_35, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11))).
|
||||
cnf(i_36, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10, X11))).
|
||||
cnf(i_37, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10))).
|
||||
cnf(i_38, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9, X10))).
|
||||
cnf(i_39, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9))).
|
||||
cnf(i_40, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8, X9))).
|
||||
cnf(i_41, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8))).
|
||||
cnf(i_42, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7, X8) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7, X8))).
|
||||
cnf(i_43, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7))).
|
||||
cnf(i_44, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6, X7) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6, X7))).
|
||||
cnf(i_45, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6))).
|
||||
cnf(i_46, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5, X6) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5, X6))).
|
||||
cnf(i_47, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5))).
|
||||
cnf(i_48, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4, X5) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4, X5))).
|
||||
cnf(i_49, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4))).
|
||||
cnf(i_50, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3, X4) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3, X4))).
|
||||
cnf(i_51, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3))).
|
||||
cnf(i_52, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2, X3) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2, X3))).
|
||||
cnf(i_53, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2))).
|
||||
cnf(i_54, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1, X2) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1, X2))).
|
||||
cnf(i_55, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1))).
|
||||
cnf(i_56, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0, X1) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0, X1))).
|
||||
cnf(i_57, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0))).
|
||||
cnf(i_58, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b, X0) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a, X0))).
|
||||
cnf(i_59, plain, (~num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b) | num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a))).
|
||||
cnf(i_60, plain, (num(a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, b) | ~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, a))).
|
||||
cnf(i_0, negated_conjecture, (~num(b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b, b))).
|
||||
@@ -0,0 +1,3 @@
|
||||
cnf(humans_are_mortal, axiom, (~human(X) | mortal(X))).
|
||||
cnf(socrates_is_human, hypothesis, (human(c))).
|
||||
cnf(socrates_is_mortal, negated_conjecture, (~mortal(c))).
|
||||
@@ -0,0 +1,30 @@
|
||||
#lang info
|
||||
(define collection "satore")
|
||||
(define deps '("bazaar"
|
||||
"data-lib"
|
||||
"define2"
|
||||
"global"
|
||||
"math-lib"
|
||||
"text-table"
|
||||
"base"))
|
||||
(define build-deps '("rackunit-lib"
|
||||
"scribble-lib"
|
||||
))
|
||||
(define scribblings '(("scribblings/satore.scrbl" ())))
|
||||
(define pkg-desc "First-order logic prover in CNF without equality, but with atom rewrite rules")
|
||||
(define version "0.1")
|
||||
(define pkg-authors '(orseau))
|
||||
|
||||
(define racket-launcher-names '("satore"))
|
||||
(define racket-launcher-libraries '("satore.rkt"))
|
||||
|
||||
(define test-omit-paths '("info.rkt"
|
||||
"last-results.rkt"
|
||||
"parse-log.rkt"
|
||||
"in-progress/"
|
||||
"find-rules.rkt"
|
||||
"print-rules.rkt"
|
||||
"run-eprover.rkt"
|
||||
"rules/"
|
||||
"logs/"
|
||||
"scribblings/"))
|
||||
@@ -0,0 +1,96 @@
|
||||
#lang racket/base
|
||||
|
||||
;***************************************************************************************;
|
||||
;**** User Interaction Commands ****;
|
||||
;***************************************************************************************;
|
||||
|
||||
(require (for-syntax racket/base syntax/parse)
|
||||
racket/format
|
||||
racket/list
|
||||
racket/match
|
||||
racket/port)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; Notice: variables set via eval or only set locally, in the local namespace,
|
||||
;; and not in the main namespace.
|
||||
;; variables set via the (list 'var val) pattern are set in the main namespace.
|
||||
;; Even though the namespace is at the module level, the variables
|
||||
;; are set in the namespace with their value so they can be used with eval.
|
||||
;; TODO: When a ns-anchor is given, commands are eval'ed by default, and to directly modify
|
||||
;; variables one must use ! (where the second argument is evaled)
|
||||
(define-syntax (interact stx)
|
||||
(syntax-parse stx
|
||||
#:literals (list)
|
||||
[(_ (~alt (~optional (~seq #:prompt prompt:expr)) ; must evaluate to a string, default "> "
|
||||
(~optional (~seq #:command command:expr))
|
||||
(~optional (~seq #:namespace-anchor ns-anchor:expr)) ; default #false
|
||||
(~optional (~seq #:variables (var:id ...))) ; must be bound identifiers
|
||||
(~optional (~seq #:readline? readline?:expr))) ; start with readline enabled? (#false)
|
||||
...
|
||||
[(list pat ...) help-string body ...+] ...) ; match patterns
|
||||
(with-syntax ([(var ...) #'(~? (var ...) ())])
|
||||
#'(begin
|
||||
(define names (list 'var ...))
|
||||
(define nsa (~? ns-anchor #false))
|
||||
(define ns (and nsa (namespace-anchor->namespace nsa)))
|
||||
(when (~? readline? #false) (eval '(require readline) ns))
|
||||
(when ns
|
||||
(namespace-set-variable-value! 'var var #false ns) ...
|
||||
(void)) ; to avoid bad 'when' form if no variable
|
||||
(define the-prompt (~? prompt "> "))
|
||||
(let loop ()
|
||||
(with-handlers ([exn:fail? (λ (e)
|
||||
(displayln (exn-message e))
|
||||
(loop))])
|
||||
(define cmd (~? command #false))
|
||||
(when (and cmd (not (string? cmd)))
|
||||
(error "command must be a string"))
|
||||
(unless cmd (display the-prompt))
|
||||
(define cmd-str (or cmd (read-line)))
|
||||
(unless (eof-object? cmd-str)
|
||||
(define cmd (with-input-from-string (string-append "(" cmd-str ")") read))
|
||||
(match cmd
|
||||
['() (void)]
|
||||
['(help)
|
||||
(unless (empty? names)
|
||||
(printf "Available variables: ~a\n" names))
|
||||
(displayln "Other commands:")
|
||||
(parameterize ([print-reader-abbreviations #true]
|
||||
[print-as-expression #false])
|
||||
(void)
|
||||
(begin
|
||||
(displayln (string-append " " (apply ~v '(pat ...) #:separator " ")))
|
||||
(displayln (string-append " " help-string)))
|
||||
...)
|
||||
(when ns
|
||||
(displayln " eval expr")
|
||||
(displayln
|
||||
" Evaluate expr in a namespace that is local to this interaction loop."))
|
||||
(loop)]
|
||||
[(list 'eval cmd)
|
||||
(if ns
|
||||
(call-with-values (λ () (eval cmd ns))
|
||||
(λ l (if (= 1 (length l))
|
||||
(unless (void? (first l))
|
||||
(displayln (first l)))
|
||||
(for-each displayln l))))
|
||||
(displayln "Cannot use eval without a namespace-anchor"))
|
||||
(loop)]
|
||||
['(var) (println var) (loop)] ...
|
||||
[(list 'var val) (set! var val) (loop)] ...
|
||||
[(list pat ...) body ... (loop)] ...
|
||||
[else (printf "Unknown command: ~a\n" cmd)
|
||||
(loop)]))))))]))
|
||||
|
||||
(module+ drracket
|
||||
(define-namespace-anchor ns-anchor) ; optional, to use the eval command
|
||||
|
||||
(let ([x 3] [y 'a])
|
||||
(interact
|
||||
#:prompt ">> "
|
||||
#:namespace-anchor ns-anchor
|
||||
#:variables (x y)
|
||||
;; All patterns must be of the form (list ....)
|
||||
[(list 'yo) "prints yo" (displayln "yo")]
|
||||
[(list 'yo (? number? n)) "prints multiple yos" (displayln (make-list n 'yo))])))
|
||||
@@ -0,0 +1,65 @@
|
||||
#lang racket/base
|
||||
|
||||
;***************************************************************************************;
|
||||
;**** Json Output ****;
|
||||
;***************************************************************************************;
|
||||
|
||||
(require bazaar/debug
|
||||
racket/dict
|
||||
racket/string)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define status-dict
|
||||
'((running . UNSPECIFIED_PROOF_STATUS)
|
||||
(refuted . REFUTATION_FOUND)
|
||||
(time . TIME_LIMIT_REACHED)
|
||||
(memory . MEMORY_LIMIT_REACHED)
|
||||
(steps . STEP_LIMIT_REACHED)
|
||||
(saturated . COUNTER_SATISFIABLE)))
|
||||
|
||||
(define (saturation-result->json res)
|
||||
(define d
|
||||
(let* ([res (dict-remove res 'name)]
|
||||
[res (dict-remove res 'file)]
|
||||
[res (dict-update res 'status (λ (v) (dict-ref status-dict v)))])
|
||||
res))
|
||||
(string-join
|
||||
#:before-first "{\n "
|
||||
(for/list ([(k v) (in-dict d)])
|
||||
(define kstr (regexp-replace* #px"-|:" (symbol->string k) "_"))
|
||||
(format "~s: ~s" kstr (if (symbol? v) (symbol->string v) v)))
|
||||
",\n "
|
||||
#:after-last "\n}"))
|
||||
|
||||
(module+ drracket
|
||||
(define res
|
||||
'((name . "GEO170+1.p")
|
||||
(file . "data/tptp_geo/GEO170+1.p")
|
||||
(status . refuted)
|
||||
(steps . 205)
|
||||
(generated . 3186)
|
||||
(actives . 106)
|
||||
(candidates . 2651)
|
||||
(priority-remaining . 0)
|
||||
(tautologies . 156)
|
||||
(rules . 30)
|
||||
(unit-rules . 24)
|
||||
(binary-rules . 6)
|
||||
(binary-rules-static . 0)
|
||||
(binary-rules-dynamic . 6)
|
||||
(binary-rewrites . 164)
|
||||
(forward-subsumed . 96)
|
||||
(backward-subsumed . 0)
|
||||
(subsumes-checks . 7654)
|
||||
(subsumes-steps . 13268)
|
||||
(subsumes-breaks . 0)
|
||||
(L-resolvent-pruning . 0)
|
||||
(memory . 181509744)
|
||||
(time . 196)
|
||||
(proof-length . 12)
|
||||
(proof-inferences . 5)
|
||||
(proof-type:in . 7)
|
||||
(proof-type:res . 4)
|
||||
(proof-type:rw . 1)))
|
||||
(displayln (saturation-result->json res)))
|
||||
@@ -0,0 +1,57 @@
|
||||
#lang racket/base
|
||||
|
||||
;***************************************************************************************;
|
||||
;**** Logging To File With Consistent Debugging Information ****;
|
||||
;***************************************************************************************;
|
||||
|
||||
(require bazaar/date
|
||||
bazaar/debug
|
||||
define2
|
||||
global
|
||||
racket/file
|
||||
racket/port
|
||||
racket/pretty
|
||||
racket/string
|
||||
racket/system)
|
||||
|
||||
(provide call-with-log
|
||||
*log*)
|
||||
|
||||
(define-global:boolean *log* #false
|
||||
"Output to a log file?")
|
||||
|
||||
(define-global:boolean *git?* #false
|
||||
"Commit to git if needed and include the last git commit hash in the globals.")
|
||||
|
||||
(define (call-with-log thunk
|
||||
#:? [dir "logs"]
|
||||
#:? [filename (string-append "log-" (date-iso-file) ".txt")]
|
||||
; if given, dir and filename have no effect:
|
||||
#:? [filepath (build-path dir filename)]
|
||||
#:? [log? (*log*)]
|
||||
#:? [quiet? #false])
|
||||
|
||||
(when (*git?*)
|
||||
(define cmd "git commit -am \".\" ")
|
||||
(displayln cmd)
|
||||
(system cmd))
|
||||
|
||||
;; Non-quiet mode.
|
||||
(define (thunk2)
|
||||
; Also write the last commit hash for easy retrieval.
|
||||
(pretty-write
|
||||
(list* `(cmd-line . ,(current-command-line-arguments))
|
||||
`(git-commit . ,(and (*git?*)
|
||||
(string-normalize-spaces
|
||||
(with-output-to-string (λ () (system "git rev-parse HEAD"))))))
|
||||
(globals->assoc)))
|
||||
(thunk))
|
||||
|
||||
(cond [log?
|
||||
(make-parent-directory* filepath)
|
||||
(assert (not (file-exists? filepath)) filepath)
|
||||
(printf "Logging to: ~a\n" filepath)
|
||||
(pretty-write (globals->assoc))
|
||||
(with-output-to-file filepath thunk2)]
|
||||
[quiet? (thunk)]
|
||||
[else (thunk2)]))
|
||||
Executable
+42
@@ -0,0 +1,42 @@
|
||||
#!/usr/bin/env racket
|
||||
#lang racket/base
|
||||
|
||||
;**************************************************************************************;
|
||||
;**** Satore ****;
|
||||
;**************************************************************************************;
|
||||
|
||||
(module+ main
|
||||
(require global
|
||||
racket/file
|
||||
racket/port
|
||||
satore/misc
|
||||
satore/rewrite-tree
|
||||
satore/saturation
|
||||
satore/unification)
|
||||
|
||||
(define-global *prog* #false
|
||||
'("Data file containing a single TPTP program."
|
||||
"If not provided, reads from the input port.")
|
||||
file-exists?
|
||||
values
|
||||
'("-p"))
|
||||
|
||||
;; If -p is not specified, reads from current-input-port
|
||||
(void (globals->command-line #:program "satore"))
|
||||
|
||||
;; No validation here yet.
|
||||
(define program
|
||||
(if (*prog*)
|
||||
(file->string (*prog*))
|
||||
(port->string)))
|
||||
|
||||
(iterative-saturation
|
||||
(λ (#:clauses input-clauses #:cpu-limit cpu-limit #:rwtree-in rwtree-in #:rwtree-out rwtree-out)
|
||||
(saturation input-clauses
|
||||
#:cpu-limit cpu-limit
|
||||
#:rwtree rwtree-in
|
||||
#:rwtree-out rwtree-out))
|
||||
#:tptp-program program
|
||||
#:rwtree-in (make-rewrite-tree #:atom<=> (get-atom<=>)
|
||||
#:dynamic-ok? (*dynamic-rules?*)
|
||||
#:rules-file (*input-rules*))))
|
||||
@@ -0,0 +1,90 @@
|
||||
#lang racket/base
|
||||
|
||||
;***************************************************************************************;
|
||||
;**** Various Utilities ****;
|
||||
;***************************************************************************************;
|
||||
|
||||
(require (for-syntax racket/base racket/port racket/syntax syntax/parse)
|
||||
(except-in bazaar/order atom<=>)
|
||||
global
|
||||
racket/contract
|
||||
racket/format
|
||||
racket/list
|
||||
racket/match
|
||||
racket/port
|
||||
racket/struct
|
||||
racket/stxparam)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(print-boolean-long-form #true)
|
||||
|
||||
(define-syntax-rule (begin-for-both e)
|
||||
(begin
|
||||
e
|
||||
(begin-for-syntax e)))
|
||||
|
||||
(begin-for-both
|
||||
(define (debug-level->number lev)
|
||||
(cond
|
||||
[(number? lev) lev]
|
||||
[(string? lev) (debug-level->number (with-input-from-string lev read))]
|
||||
[else
|
||||
(case lev
|
||||
[(none) 0]
|
||||
[(init) 1]
|
||||
[(step steps) 2]
|
||||
[(interact) 3]
|
||||
[else (error "unknown debug level" lev)])])))
|
||||
|
||||
(define-global *debug-level* 0
|
||||
"Number or one of (none=0 init=1 steps interact)."
|
||||
exact-nonnegative-integer?
|
||||
debug-level->number
|
||||
'("--debug"))
|
||||
|
||||
(define (debug>= lev)
|
||||
(>= (*debug-level*) (debug-level->number lev)))
|
||||
|
||||
;; TODO: Make faster
|
||||
(define-syntax (when-debug>= stx)
|
||||
(syntax-case stx ()
|
||||
[(_ lev body ...)
|
||||
(with-syntax ([levv (debug-level->number (syntax-e #'lev))])
|
||||
#'(when (>= (*debug-level*) levv)
|
||||
body ...))]))
|
||||
|
||||
(define (thunk? p)
|
||||
(and (procedure? p)
|
||||
(procedure-arity-includes? p 0)))
|
||||
|
||||
;; Defines a counter with a reset function and an increment function
|
||||
;; Ex:
|
||||
;; (define-counter num 0)
|
||||
;; (++num)
|
||||
;; (++num 3)
|
||||
;; (reset-num!)
|
||||
(define-syntax (define-counter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name init)
|
||||
(with-syntax ([reset (format-id stx #:source stx "reset-~a!" (syntax-e #'name))]
|
||||
[++ (format-id stx #:source stx "++~a" (syntax-e #'name))])
|
||||
#'(begin
|
||||
(define name init)
|
||||
(define (reset)
|
||||
(set! name init))
|
||||
(define (++ [n 1])
|
||||
(set! name (+ name n)))))]))
|
||||
|
||||
|
||||
(define (current-memory-use-MB)
|
||||
(arithmetic-shift (current-memory-use) -20))
|
||||
|
||||
(define (car+cdr p)
|
||||
(values (car p) (cdr p)))
|
||||
|
||||
(define (~r2 x #:precision [precision 2])
|
||||
(if (rational? x)
|
||||
(~r x #:precision precision)
|
||||
(~a x)))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,5 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@title{First-order logic saturation with atomic rewriting}
|
||||
|
||||
See the @hyperlink["https://link-to-readme"]{readme}.
|
||||
@@ -0,0 +1,12 @@
|
||||
#lang racket/base
|
||||
|
||||
(require rackunit
|
||||
"../Clause.rkt"
|
||||
(submod "../Clause.rkt" test))
|
||||
|
||||
;; Polarity should not count for the 'weight' cost function because otherwise it will be harder
|
||||
;; to prove ~A | ~B than A | B.
|
||||
(check-equal? (Clause-size (make-Clause '[p q]))
|
||||
(Clause-size (make-Clause '[(not p) (not q)])))
|
||||
|
||||
;; TODO: test (check-Clause-set-equivalent? Cs1 Cs2)
|
||||
@@ -0,0 +1,197 @@
|
||||
#lang racket/base
|
||||
|
||||
(require global
|
||||
racket/dict
|
||||
rackunit
|
||||
racket/list
|
||||
"../clause.rkt"
|
||||
"../misc.rkt"
|
||||
"../unification.rkt")
|
||||
|
||||
(*subsumes-iter-limit* 0)
|
||||
|
||||
(begin
|
||||
(define-simple-check (check-tautology cl res)
|
||||
(check-equal? (clause-tautology? (sort-clause (Varify cl))) res))
|
||||
|
||||
(check-tautology '[] #false)
|
||||
(check-tautology `[,ltrue] #true)
|
||||
(check-tautology `[,(lnot lfalse)] #true)
|
||||
(check-tautology '[a] #false)
|
||||
(check-tautology '[a a] #false)
|
||||
(check-tautology '[a (not a)] #true)
|
||||
(check-tautology '[a b (not c)] #false)
|
||||
(check-tautology '[a b (not a)] #true)
|
||||
(check-tautology '[a (not (a a)) (a b) (not (a (not a)))] #false)
|
||||
(check-tautology '[a (a a) b c (not (a a))] #true)
|
||||
(check-tautology `[(a b) b (not (b a)) (not (b b)) (not (a c)) (not (a ,(Var 'b)))] #false)
|
||||
)
|
||||
|
||||
(begin
|
||||
(define-simple-check (check-remove-duplicate-literals cl res)
|
||||
(check-equal? (remove-duplicate-literals (sort-clause (Varify cl)))
|
||||
(sort-clause (Varify res))))
|
||||
|
||||
(check-remove-duplicate-literals '(a (p X) (q X) (p X) (p Y) a (p a) a b)
|
||||
'(a b (p a) (p X) (p Y) (q X))))
|
||||
|
||||
|
||||
|
||||
(begin
|
||||
;; NOTICE: symbol-tree->clause first performs some simplications (which themselves call
|
||||
;; clause-implies/1pass)
|
||||
;; Equivalences
|
||||
(for ([(A B) (in-dict '(([] . [] ) ; if empty clause #true, everything is #true
|
||||
([p] . [p] )
|
||||
([(p X)] . [(p X)] )
|
||||
([(p X)] . [(p Y)] )
|
||||
([(not (p X))] . [(not (p X))] )
|
||||
([(p X) (q X)] . [(p X) (q X) (q Y)] )
|
||||
))])
|
||||
(define cl1 (sort-clause (Varify A)))
|
||||
(define cl2 (sort-clause (fresh (Varify B))))
|
||||
(check-not-false (clause-subsumes cl1 cl2)
|
||||
(format "cl1: ~a\ncl2: ~a" cl1 cl2))
|
||||
(check-not-false (clause-subsumes cl2 cl1)
|
||||
(format "cl1: ~a\ncl2: ~a" cl1 cl2))
|
||||
)
|
||||
|
||||
;; One-way implication (not equivalence)
|
||||
(for ([(A B) (in-dict '(([] . [p] ) ; if empty clause #true, everything is #true
|
||||
([p] . [p q] )
|
||||
([(p X)] . [(p c)] )
|
||||
([(p X) (p X) (p Y)] . [(p c)] )
|
||||
([(p X)] . [(p X) (q X)] )
|
||||
([(p X)] . [(p X) (q Y)] )
|
||||
([(p X Y)] . [(p X X)] )
|
||||
([(p X) (q Y)] . [(p X) (p Y) (q Y)] )
|
||||
([(p X) (p Y) (q Y)] . [(p Y) (q Y) c] )
|
||||
([(p X Y) (p Y X)] . [(p X X)] )
|
||||
([(q X X) (q X Y) (q Y Z)] . [(q a a) (q b b)])
|
||||
([(f (q X)) (p X)] . [(p c) (f (q c))])
|
||||
; A θ-subsumes B, but does not θ-subsume it 'strictly'
|
||||
([(p X Y) (p Y X)] . [(p X X) (r)])
|
||||
))])
|
||||
(define cl1 (sort-clause (Varify A)))
|
||||
(define cl2 (sort-clause (fresh (Varify B))))
|
||||
(check-not-false (clause-subsumes cl1 cl2))
|
||||
(check-false (clause-subsumes cl2 cl1)))
|
||||
|
||||
; Not implications, both ways. Actually, this is independence
|
||||
(for ([(A B) (in-dict '(([p] . [q])
|
||||
([(p X)] . [(q X)])
|
||||
([p] . [(not p)])
|
||||
([(p X c)] . [(p d Y)])
|
||||
([(p X) (q X)] . [(p c)])
|
||||
([(p X) (f (q X))] . [(p c)])
|
||||
([(eq X X)] . [(eq (mul X0 X1) (mul X2 X3))
|
||||
(not (eq X0 X2)) (not (eq X1 X3))])
|
||||
; A implies B, but there is no θ-subsumption
|
||||
; https://www.doc.ic.ac.uk/~kb/MACTHINGS/SLIDES/2013Notes/6LSub4up13.pdf
|
||||
([(p (f X)) (not (p X))] . [(p (f (f Y))) (not (p Y))])
|
||||
))])
|
||||
(define cl1 (sort-clause (Varify A)))
|
||||
(define cl2 (sort-clause (fresh (Varify B))))
|
||||
(check-false (clause-subsumes cl1 cl2)
|
||||
(list (list 'A= A) (list 'B= B)))
|
||||
(check-false (clause-subsumes cl2 cl1)
|
||||
(list A B)))
|
||||
|
||||
(let* ()
|
||||
(define-Vars X Y Z)
|
||||
(define cl
|
||||
`((not (incident ,X ,Y))
|
||||
(not (incident ab ,Y))
|
||||
(not (incident ab ,Z))
|
||||
(not (incident ab ,Z))
|
||||
(not (incident ac ,Y))
|
||||
(not (incident ac ,Z))
|
||||
(not (incident ac ,Z))
|
||||
(not (incident bc a1b1))
|
||||
(not (line_equal ,Z ,Z))
|
||||
(not (point_equal bc ,X))))
|
||||
(define cl2
|
||||
(sort-clause (fresh (left-substitute cl (hasheq (Var-name X) 'bc
|
||||
(Var-name Y) 'a1b1)))))
|
||||
(check-not-false (clause-subsumes cl cl2)))
|
||||
)
|
||||
|
||||
#;
|
||||
(begin
|
||||
; This case SHOULD pass, according to the standard definition of clause subsumption based on
|
||||
; multisets, but our current definition of subsumption is more general (not necessarily in a
|
||||
; good way.)
|
||||
; Our definition is based on sets, with a constraint on the number of literals (in
|
||||
; Clause<=-subsumes).
|
||||
; This makes it more general, but also not well-founded (though I'm not sure yet whether this is
|
||||
; really bad).
|
||||
(check-false (clause-subsumes (clausify '[(p A A) (q X Y) (q Y Z)])
|
||||
(clausify '[(p a a) (p b b) (q C C)])))
|
||||
)
|
||||
|
||||
|
||||
(begin
|
||||
|
||||
(*debug-level* (debug-level->number 'steps))
|
||||
|
||||
(define-simple-check (check-safe-factoring cl res)
|
||||
(define got (safe-factoring (sort-clause (Varify cl))))
|
||||
(set! res (sort-clause (Varify res)))
|
||||
; Check equivalence
|
||||
(check-not-false (clause-subsumes res got))
|
||||
(check-not-false (clause-subsumes got res)))
|
||||
|
||||
(check-safe-factoring '[(p a b) (p A B)]
|
||||
'[(p a b)]) ; Note that [(p a b) (p A B)] ≠> (p A B)
|
||||
(check-safe-factoring '[(p X) (p Y)]
|
||||
'[(p Y)])
|
||||
(check-safe-factoring '[(p Y) (p Y)]
|
||||
'[(p Y)])
|
||||
(check-safe-factoring '[(p X) (q X) (p Y) (q Y)]
|
||||
'[(p Y) (q Y)])
|
||||
(check-safe-factoring '[(p X Y) (p A X)]
|
||||
'[(p X Y) (p A X)])
|
||||
(check-safe-factoring '[(p X Y) (p X X)]
|
||||
'[(p X X)]) ; is a subset of above, so necessarily no less general
|
||||
(check-safe-factoring '[(p X Y) (p A X) (p Y A)]
|
||||
'[(p X Y) (p A X) (p Y A)]) ; cannot be safely factored?
|
||||
(check-safe-factoring '[(p X) (p Y) (q X Y)]
|
||||
'[(p X) (p Y) (q X Y)]) ; Cannot be safely factored (proven)
|
||||
(check-safe-factoring '[(leq B A) (leq A B) (not (def B)) (not (def A))]
|
||||
'[(leq B A) (leq A B) (not (def B)) (not (def A))]) ; no safe factor
|
||||
(check-safe-factoring '[(p X) (p (f X))]
|
||||
'[(p X) (p (f X))])
|
||||
|
||||
(check-safe-factoring
|
||||
(fresh '((not (incident #s(Var 5343) #s(Var 5344)))
|
||||
(not (incident ab #s(Var 5344)))
|
||||
(not (incident ab #s(Var 5345)))
|
||||
(not (incident ab #s(Var 5345)))
|
||||
(not (incident ac #s(Var 5344)))
|
||||
(not (incident ac #s(Var 5345)))
|
||||
(not (incident ac #s(Var 5345)))
|
||||
(not (incident bc a1b1))
|
||||
(not (line_equal #s(Var 5345) #s(Var 5345)))
|
||||
(not (point_equal bc #s(Var 5343)))))
|
||||
(fresh
|
||||
'((not (incident #s(Var 148) #s(Var 149)))
|
||||
(not (incident ab #s(Var 149)))
|
||||
(not (incident ab #s(Var 150)))
|
||||
(not (incident ac #s(Var 149)))
|
||||
(not (incident ac #s(Var 150)))
|
||||
(not (incident bc a1b1))
|
||||
(not (line_equal #s(Var 150) #s(Var 150)))
|
||||
(not (point_equal bc #s(Var 148))))))
|
||||
|
||||
(check-not-exn (λ () (safe-factoring
|
||||
(fresh '((not (incident #s(Var 5343) #s(Var 5344)))
|
||||
(not (incident ab #s(Var 5344)))
|
||||
(not (incident ab #s(Var 5345)))
|
||||
(not (incident ab #s(Var 5345)))
|
||||
(not (incident ac #s(Var 5344)))
|
||||
(not (incident ac #s(Var 5345)))
|
||||
(not (incident ac #s(Var 5345)))
|
||||
(not (incident bc a1b1))
|
||||
(not (line_equal #s(Var 5345) #s(Var 5345)))
|
||||
(not (point_equal bc #s(Var 5343))))))))
|
||||
)
|
||||
@@ -0,0 +1,118 @@
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax racket/base
|
||||
syntax/parse)
|
||||
bazaar/debug
|
||||
define2
|
||||
define2/define-wrapper
|
||||
global
|
||||
racket/list
|
||||
racket/pretty
|
||||
rackunit
|
||||
"../Clause.rkt"
|
||||
"../clause.rkt"
|
||||
"../clause-format.rkt"
|
||||
"../rewrite-tree.rkt"
|
||||
"../unification.rkt"
|
||||
(submod "../Clause.rkt" test))
|
||||
|
||||
(define-global:boolean *dynamic-ok?* #true
|
||||
"Use dynamic rules?")
|
||||
|
||||
(define (take-at-most l n)
|
||||
(take l (min (length l) n)))
|
||||
|
||||
(define (display-rwtree rwtree #:? [n-max 100])
|
||||
(define rules (rewrite-tree-rules rwtree))
|
||||
(define-values (statics dyns)
|
||||
(partition rule-static?
|
||||
(filter-not (λ (rl) (lnot? (rule-from-literal rl)))
|
||||
rules)))
|
||||
(display-rules (take-at-most (reverse (sort-rules statics)) n-max))
|
||||
(display-rules (take-at-most (reverse (sort-rules dyns)) n-max))
|
||||
(when (or (> (length statics) n-max) (> (length dyns) n-max))
|
||||
(displayln "(output truncated because there are too many rules)"))
|
||||
(pretty-write (rewrite-tree-stats rwtree)))
|
||||
|
||||
;; Adds an equivalence as rules.
|
||||
;; For testing purposes.
|
||||
(define (add-equiv! rwtree equiv)
|
||||
(define C (make-Clause (clausify (list (lnot (first equiv)) (second equiv)))))
|
||||
(force-add-binary-Clause! rwtree C))
|
||||
|
||||
(define (rewrite-literal rwt lit)
|
||||
(define-values (new-lit rls) (binary-rewrite-literal rwt lit #false))
|
||||
new-lit)
|
||||
|
||||
;; Given a set of implications, generate equivalence
|
||||
(define (equivs->rwtree equivs
|
||||
#:? [dynamic-ok? (*dynamic-ok?*)]
|
||||
#:? [atom<=> (get-atom<=>)])
|
||||
(define rwt (make-rewrite-tree #:atom<=> atom<=> #:dynamic-ok? dynamic-ok?))
|
||||
(for ([equiv (in-list equivs)])
|
||||
(add-equiv! rwt equiv)
|
||||
(add-equiv! rwt (map lnot equiv)))
|
||||
rwt)
|
||||
|
||||
(define-syntax (test-confluence stx)
|
||||
(syntax-parse stx
|
||||
[(_ equivs expected-stats #:with rwt body ...)
|
||||
#'(let ()
|
||||
(define rwt (equivs->rwtree equivs))
|
||||
(rewrite-tree-confluence! rwt)
|
||||
(define stats (rewrite-tree-stats rwt))
|
||||
(unless (equal? stats expected-stats)
|
||||
(display-rwtree rwt))
|
||||
(check-equal? stats expected-stats)
|
||||
body ...)]
|
||||
[(_ equivs expected-stats)
|
||||
#'(test-confluence equivs expected-stats #:with _rwt)]))
|
||||
|
||||
|
||||
(with-globals ([*bounded-confluence?* #true]
|
||||
[*dynamic-ok?* #false])
|
||||
;; This induction does work and is not subsumed.
|
||||
;; This is possibly the minimal induction scheme (that doesn't lead to subsumed rules).
|
||||
(test-confluence
|
||||
'([(p A (f B)) (p A B)]
|
||||
[(p C C) d]) ; not left linear
|
||||
; Should not produce longer rules than the parents!
|
||||
'((rules . 6)
|
||||
(unit-rules . 0)
|
||||
(binary-rules . 6)
|
||||
(binary-rules-static . 6)
|
||||
(binary-rules-dynamic . 0)))
|
||||
|
||||
(test-confluence
|
||||
'([(p (f (f (f z))) (f (f (f z)))) (g (g (g b)))] ; should -> b
|
||||
[(p (f (f (f z))) (f (f (f X)))) b]
|
||||
[(p (f (f z)) (f (f X))) c]
|
||||
[(p (f z) (f X)) d]
|
||||
[(p X X) (q X)])
|
||||
'((rules . 18) ; 16 also ok
|
||||
(unit-rules . 0)
|
||||
(binary-rules . 18)
|
||||
(binary-rules-static . 18)
|
||||
(binary-rules-dynamic . 0))
|
||||
#:with rwt
|
||||
(check-equal? (rewrite-literal rwt '(p z z)) '(q z))
|
||||
(check-equal? (rewrite-literal rwt '(p (f (f (f z))) (f (f (f a))))) 'b)
|
||||
(check-equal? (rewrite-literal rwt '(p (f (f (f z))) (f (f (f z))))) 'b))
|
||||
|
||||
(test-confluence
|
||||
'([(p a X) q]
|
||||
[(p X a) f]
|
||||
[(p a a) (g b)])
|
||||
'((rules . 8)
|
||||
(unit-rules . 0)
|
||||
(binary-rules . 8)
|
||||
(binary-rules-static . 8)
|
||||
(binary-rules-dynamic . 0))
|
||||
#:with rwt
|
||||
(check-equal? (rewrite-literal rwt '(p a a)) 'f)
|
||||
(check-equal? (rewrite-literal rwt '(p a b)) 'f)
|
||||
(check-equal? (rewrite-literal rwt '(g b)) 'f)
|
||||
(check-equal? (rewrite-literal rwt 'q) 'f))
|
||||
)
|
||||
|
||||
|
||||
@@ -0,0 +1,34 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/list
|
||||
racket/port
|
||||
rackunit
|
||||
"../interact.rkt")
|
||||
|
||||
(define-syntax-rule (check-interact in out args ...)
|
||||
(check-equal?
|
||||
(with-output-to-string
|
||||
(λ ()
|
||||
(with-input-from-string (string-append in "\n\n") ; ensure no read loop
|
||||
(λ () (interact args ...)))))
|
||||
out))
|
||||
|
||||
(define-namespace-anchor ns-anchor) ; optional, to use the eval command
|
||||
|
||||
(let ([x 2] [y 'a])
|
||||
(check-interact
|
||||
"x\ny\nx 3\nx"
|
||||
"2\n'a\n3\n"
|
||||
#:prompt ""
|
||||
#:variables (x y)))
|
||||
|
||||
(let ([x 3] [y 'a])
|
||||
(check-interact
|
||||
"yo\nyo 4\nx\nx 2\nx"
|
||||
"yo\n(yo yo yo yo)\n3\n2\n"
|
||||
#:prompt ""
|
||||
#:namespace-anchor ns-anchor
|
||||
#:variables (x y)
|
||||
;; All patterns must be of the form (list ....)
|
||||
[(list 'yo) "prints yo" (displayln "yo")]
|
||||
[(list 'yo (? number? n)) "prints multiple yos" (displayln (make-list n 'yo))]))
|
||||
@@ -0,0 +1,5 @@
|
||||
#lang racket/base
|
||||
|
||||
(require "../misc.rkt"
|
||||
rackunit)
|
||||
|
||||
@@ -0,0 +1,250 @@
|
||||
#lang racket/base
|
||||
|
||||
(require bazaar/debug
|
||||
(except-in bazaar/order atom<=>)
|
||||
racket/list
|
||||
racket/file
|
||||
racket/pretty
|
||||
racket/random
|
||||
rackunit
|
||||
"../Clause.rkt"
|
||||
"../clause.rkt"
|
||||
"../misc.rkt"
|
||||
"../rewrite-tree.rkt"
|
||||
"../unification.rkt" ; for atom1<=>
|
||||
(submod "../Clause.rkt" test))
|
||||
|
||||
(*debug-level* 0)
|
||||
|
||||
(define-check (check-rewrite rwtree c crw)
|
||||
(define C (Clausify c))
|
||||
(define Crw (binary-rewrite-Clause rwtree C))
|
||||
(define crw-sorted (sort-clause crw))
|
||||
(unless (equal? (Clause-clause Crw) crw-sorted)
|
||||
(eprintf "c-sorted : ~a\ncrw-sorted: ~a\n" (Clause-clause C) crw-sorted)
|
||||
(eprintf (Clause-ancestor-graph-string Crw))
|
||||
(fail-check)))
|
||||
|
||||
(define-simple-check (check-not-rewrite rwtree c)
|
||||
(check-rewrite rwtree c c))
|
||||
|
||||
;;; Self-equivalence
|
||||
(let ()
|
||||
(define rwtree (make-rewrite-tree #:atom<=> atom1<=>))
|
||||
|
||||
(define C1 (make-Clause (clausify '[(not (eq A B)) (eq B A)])))
|
||||
(define rls1 (Clause->rules C1 C1 #:atom<=> atom1<=>))
|
||||
(rewrite-tree-add-binary-Clause! rwtree C1 C1)
|
||||
(check-equal? (rewrite-tree-count rwtree) 2)
|
||||
; Rewrite clause in lexicographical order
|
||||
(check-rewrite rwtree '[(eq b a)] '[(eq a b)]))
|
||||
|
||||
;;; Adding two converse implications
|
||||
(let ()
|
||||
(define rwtree (make-rewrite-tree #:atom<=> atom1<=>))
|
||||
|
||||
(define C1 (make-Clause (clausify '[(not (p A A)) (q A)])))
|
||||
(define C2 (make-Clause (clausify '[(not (q A)) (p A A)])))
|
||||
(define rls1 (Clause->rules C1 C2 #:atom<=> atom1<=>))
|
||||
(rewrite-tree-add-binary-Clause! rwtree C1 C2)
|
||||
; This is not needed because both polarities are considered by Clause->rules:
|
||||
(rewrite-tree-add-binary-Clauses! rwtree (list C2) C1 #:rewrite? #true)
|
||||
(check-equal? (rewrite-tree-count rwtree) 2)
|
||||
(check-rewrite rwtree '[(p a a) (z c)] '[(q a) (z c)])
|
||||
(check-rewrite rwtree '[(not (p a a)) (z c)] '[(not (q a)) (z c)]))
|
||||
|
||||
;;; Adding rules where the converse implication is more general
|
||||
(let ()
|
||||
(define rwtree (make-rewrite-tree #:atom<=> atom1<=>))
|
||||
|
||||
(define Crules
|
||||
(map (compose make-Clause clausify)
|
||||
'([(not (p A A)) (q A)]
|
||||
[(not (q a)) (p a a)]
|
||||
[(not (q b)) (p b b)])))
|
||||
(for ([C (in-list (rest Crules))])
|
||||
(rewrite-tree-add-binary-Clause! rwtree C (first Crules)))
|
||||
(check-equal? (rewrite-tree-count rwtree) 4)
|
||||
(check-rewrite rwtree '[(p a a) (z c)] '[(q a) (z c)])
|
||||
(check-rewrite rwtree '[(not (p a a)) (z c)] '[(not (q a)) (z c)])
|
||||
(check-rewrite rwtree '[(p b b) (z c)] '[(q b) (z c)])
|
||||
(check-rewrite rwtree '[(not (p b b)) (z c)] '[(not (q b)) (z c)])
|
||||
(check-not-rewrite rwtree '[(p x x) (z c)]))
|
||||
;;; The same with add-binary-Clauses
|
||||
(let ()
|
||||
(define rwtree (make-rewrite-tree #:atom<=> atom1<=>))
|
||||
|
||||
(define Crules
|
||||
(map (compose make-Clause clausify)
|
||||
'([(not (p A A)) (q A)]
|
||||
[(not (q a)) (p a a)]
|
||||
[(not (q b)) (p b b)])))
|
||||
(rewrite-tree-add-binary-Clauses! rwtree (rest Crules) (first Crules))
|
||||
(check-equal? (rewrite-tree-count rwtree) 4)
|
||||
(check-rewrite rwtree '[(p a a) (z c)] '[(q a) (z c)])
|
||||
(check-rewrite rwtree '[(not (p a a)) (z c)] '[(not (q a)) (z c)])
|
||||
(check-not-rewrite rwtree '[(p x x) (z c)]))
|
||||
|
||||
;;; Dynamic, non-self-converse Clauses, leading to 4 rules
|
||||
(let ()
|
||||
(define rwtree (make-rewrite-tree #:atom<=> atom1<=>))
|
||||
|
||||
(define C1 (make-Clause (clausify '[(not (p A B C)) (p C A B)])))
|
||||
(define C2 (make-converse-Clause C1))
|
||||
(define rls1 (Clause->rules C1 C2 #:atom<=> atom1<=>))
|
||||
(rewrite-tree-add-binary-Clause! rwtree C1 C2)
|
||||
(check-equal? (rewrite-tree-count rwtree) 4)
|
||||
(check-rewrite rwtree '[(p a b c)] '[(p a b c)])
|
||||
(check-rewrite rwtree '[(p c a b)] '[(p a b c)])
|
||||
(check-rewrite rwtree '[(p b c a)] '[(p a b c)])
|
||||
(check-rewrite rwtree '[(p b a c)] '[(p a c b)]))
|
||||
|
||||
;;; Some random testing to make sure atom<=> has the Groundedness property.
|
||||
|
||||
(define (random-atom)
|
||||
(define syms '(aaa a p q r z zzz))
|
||||
(define choices (append syms syms '(NV OV L L))) ; reduce proba of NV and OV
|
||||
(define vars '())
|
||||
(let loop ()
|
||||
(define r (random-ref choices))
|
||||
(case r
|
||||
[(NV) ; new var
|
||||
(define v (new-Var))
|
||||
(set! vars (cons v vars))
|
||||
v]
|
||||
[(OV) (if (empty? vars) (loop) (random-ref vars))] ; old vars
|
||||
[(L) (cons (random-ref syms) ; first element must be a symbol
|
||||
(build-list (random 4) (λ (i) (loop))))]
|
||||
[else r])))
|
||||
|
||||
(define random-atom-bank
|
||||
(remove-duplicates (build-list 1000 (λ _ (random-atom)))))
|
||||
(debug-vars (length random-atom-bank))
|
||||
|
||||
(define (check-groundedness atom<=> lita litb)
|
||||
(define from<=>to (atom<=> lita litb))
|
||||
; no point in testing groundedness if we don't have from literal< to
|
||||
(assert (order<? from<=>to) lita litb from<=>to)
|
||||
(define vs (vars (list lita litb)))
|
||||
(define s (make-subst))
|
||||
(for ([v (in-list vs)])
|
||||
(subst-set!/name s v (random-ref random-atom-bank)))
|
||||
(define lita2 (substitute lita s))
|
||||
(define litb2 (substitute litb s))
|
||||
(check-equal? (atom<=> lita2 litb2) '<))
|
||||
|
||||
(for ([i 10000])
|
||||
(apply check-groundedness atom1<=> (Varify '[(eq A B) (eq A (mul B a))]))
|
||||
(apply check-groundedness atom1<=> (Varify '[(eq A B a) (eq A (mul B a))])))
|
||||
|
||||
; IMPORTANT CASE: Check circularity of the rules
|
||||
; Imagine we have two clauses:
|
||||
; c1 = p | q
|
||||
; c2 = ~p | ~q
|
||||
; They are converse implications.
|
||||
; From c1 we can generate the rules:
|
||||
; r1 = ~p → q
|
||||
; r2 = ~q → p
|
||||
; and from c2 we can generate:
|
||||
; r3 = p → ~q
|
||||
; r4 = q → ~p
|
||||
; If we choose {r1, r4} or {r2, r3} we run in circles!
|
||||
; Hence the valid choices are {r2, r4} and {r1, r2}
|
||||
; {r2, r4} is justified by removing negations and considering 'p < 'q.
|
||||
; {r1, r2} is justified by considering that the negated atoms 'weigh' more.
|
||||
;
|
||||
; Now if the two clauses are:
|
||||
; c3 = ~p | q with rules p → q and ~q → ~p
|
||||
; c4 = p | ~q with rules ~p → ~q and q → p
|
||||
; Now we should choose q → p and ~q → ~p to avoid running in circles.
|
||||
(for* ([lits (in-list '( (p q) ; + ((not p) (not q))
|
||||
(p (not q))
|
||||
((distinct_points A B) (equal_points A B))
|
||||
((distinct_points A B) (not (equal_points A B)))
|
||||
))]
|
||||
[r1 (in-list
|
||||
(Clause->rules (Clausify lits) #false #:atom<=> atom1<=>))]
|
||||
[r2 (in-list
|
||||
(Clause->rules (Clausify (map lnot lits)) #false #:atom<=> atom1<=>))])
|
||||
; The rules should NOT be circular!
|
||||
(check-not-equal?
|
||||
(Vars->symbols (list (rule-from-literal r1) (rule-to-literal r1)))
|
||||
(Vars->symbols (list (rule-to-literal r2) (rule-from-literal r2)))))
|
||||
|
||||
;; Saving and loading rules, especially with asymmetric rules.
|
||||
(let ()
|
||||
(define rwtree (make-rewrite-tree #:atom<=> atom1<=>))
|
||||
(define rwtree2 (make-rewrite-tree #:atom<=> atom1<=>))
|
||||
|
||||
;; Asymmetric rules
|
||||
(let ([Conv (Clausify '[(not (p A A)) (q A)])])
|
||||
(rewrite-tree-add-binary-Clauses! rwtree
|
||||
(map Clausify
|
||||
'([(not (q a)) (p a a)]
|
||||
[(not (q b)) (p b b)]
|
||||
[(not (q c)) (p c c)]))
|
||||
Conv))
|
||||
; Self-converse
|
||||
(let ([C (Clausify '[(not (eq A B)) (eq B A)])])
|
||||
(rewrite-tree-add-binary-Clause! rwtree C C))
|
||||
; Symmetric
|
||||
(rewrite-tree-add-binary-Clause! rwtree
|
||||
(Clausify '[(not (pp A A)) (qq A)])
|
||||
(Clausify '[(pp A A) (not (qq A))]))
|
||||
|
||||
(define Crules (rewrite-tree-original-Clauses rwtree))
|
||||
(define f (make-temporary-file))
|
||||
(save-rules! rwtree #:rules-file f)
|
||||
(load-rules! rwtree2 #:rules-file f)
|
||||
(define Crules2 (rewrite-tree-original-Clauses rwtree2))
|
||||
(check-equal? (length Crules2) (length Crules))
|
||||
;; not efficient
|
||||
(for ([C (in-list Crules)])
|
||||
(define cl (Clause-clause C))
|
||||
(check-not-false (for/or ([C2 (in-list Crules2)])
|
||||
(Clause-equivalence? C C2))
|
||||
cl)))
|
||||
|
||||
;; Tautology reduction
|
||||
(let ()
|
||||
(define rwtree (make-rewrite-tree #:atom<=> atom1<=>))
|
||||
(rewrite-tree-add-binary-Clause! rwtree
|
||||
(make-Clause (clausify '[(not (p (p X))) (p X)]))
|
||||
(make-Clause (clausify '[(p (p X)) (not (p X))])))
|
||||
(check-equal? (rewrite-tree-stats rwtree)
|
||||
'((rules . 2)
|
||||
(unit-rules . 0)
|
||||
(binary-rules . 2)
|
||||
(binary-rules-static . 2)
|
||||
(binary-rules-dynamic . 0)))
|
||||
; These should be reduced to tautologies and thus not added
|
||||
(rewrite-tree-add-binary-Clause! rwtree
|
||||
(make-Clause (clausify '[(not (p (p (p X)))) (p X)]))
|
||||
(make-Clause (clausify '[(p (p (p X))) (not (p X))])))
|
||||
(check-equal? (rewrite-tree-stats rwtree)
|
||||
'((rules . 2)
|
||||
(unit-rules . 0)
|
||||
(binary-rules . 2)
|
||||
(binary-rules-static . 2)
|
||||
(binary-rules-dynamic . 0))))
|
||||
|
||||
;; Tautology reduction by dynamic rule
|
||||
;; Currently fails
|
||||
#;
|
||||
(let ()
|
||||
(define rwtree (make-rewrite-tree #:atom<=> atom1<=>))
|
||||
(define Cp (Clausify '[(not (p A B)) (p B A)]))
|
||||
(rewrite-tree-add-binary-Clause! rwtree Cp Cp)
|
||||
; What should we do?
|
||||
; The dynamic rule *can* reduce this to a tautology, but doesn't because
|
||||
; it can't be ground-oriented.
|
||||
(check Clause-equivalence?
|
||||
(binary-rewrite-Clause rwtree (Clausify '[(p A B) (p B A) q]))
|
||||
(Clausify '[(p A B) q]))
|
||||
; Same, but after a rewrite
|
||||
(rewrite-tree-add-binary-Clause! rwtree
|
||||
(Clausify '[(not (p (f A) B)) (p A B)])
|
||||
(Clausify '[(p (f A) B) (not (p A B))]))
|
||||
(check Clause-equivalence?
|
||||
(binary-rewrite-Clause rwtree (Clausify '[(p (f A) B) (p B A) q]))
|
||||
(Clausify '[(p A B) q])))
|
||||
@@ -0,0 +1,348 @@
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
racket/base)
|
||||
define2
|
||||
define2/define-wrapper
|
||||
global
|
||||
rackunit
|
||||
racket/dict
|
||||
racket/pretty
|
||||
syntax/parse/define
|
||||
"../clause.rkt"
|
||||
"../misc.rkt" ; for easy access to *debug-level*
|
||||
"../rewrite-tree.rkt"
|
||||
(prefix-in sat: "../saturation.rkt")
|
||||
"../unification.rkt")
|
||||
|
||||
(define-global *cpu-limit* 10
|
||||
"Time limit in seconds for tests"
|
||||
number?
|
||||
string->number)
|
||||
|
||||
(define (Vars+clausify-list l)
|
||||
(map clausify
|
||||
(symbol-variables->Vars l)))
|
||||
|
||||
(define current-saturation-args #false)
|
||||
|
||||
(define-syntax (for-in-list* stx)
|
||||
(syntax-parse stx
|
||||
[(_ ([var x ...] ... clauses ...) body ...)
|
||||
#:with (name ...) (generate-temporaries #'(var ...))
|
||||
#'(for ((~@ [var (in-list (list x ...))]
|
||||
[name (in-list '(x ...))]
|
||||
#:when #true)
|
||||
...)
|
||||
(set! current-saturation-args (list (cons 'var name) ...))
|
||||
body ...)]))
|
||||
|
||||
;; Print additional information
|
||||
(define old-check-handler (current-check-handler))
|
||||
(current-check-handler
|
||||
(λ (e)
|
||||
(eprintf (pretty-format current-saturation-args))
|
||||
(eprintf "\n")
|
||||
(old-check-handler e)))
|
||||
|
||||
;; USE THIS FOR DEBUGGING
|
||||
(define-simple-macro (replay-on-failure body ...)
|
||||
(let ([old-check-handler (current-check-handler)])
|
||||
(parameterize ([current-check-handler
|
||||
(λ (e)
|
||||
(old-check-handler e)
|
||||
(eprintf
|
||||
"Some checks have failed. Replaying in interactive mode for debugging.\n")
|
||||
(*debug-level* 3)
|
||||
(*cpu-limit* +inf.0)
|
||||
(let () body ...))])
|
||||
; encapsulated to avoid collisions
|
||||
(let () body ...))))
|
||||
|
||||
(for-in-list* ([l-res-pruning? #true #false]
|
||||
[neg-lit-select? #true #false]
|
||||
[atom<=> KBO1lex<=> atom1<=>]
|
||||
[dynamic-ok? #true #false]
|
||||
[rwtree-in=out? #true #false] ; false means no search for new rules
|
||||
;#:unless (and l-res-pruning? neg-lit-select?) ; can't have both at the same time
|
||||
)
|
||||
|
||||
(define-wrapper (saturation
|
||||
(sat:saturation input-clauses
|
||||
#:? [step-limit 200]
|
||||
#:? [memory-limit 4096] ; in MB
|
||||
#:? [cpu-limit (*cpu-limit*)] ; in seconds
|
||||
#:? [rwtree (make-rewrite-tree #:atom<=> atom<=>
|
||||
#:dynamic-ok? dynamic-ok?)]
|
||||
#:? [rwtree-out (and rwtree-in=out? rwtree)]
|
||||
#:? backward-rewrite?
|
||||
#:? age:cost
|
||||
#:? cost-type
|
||||
#:? [disp-proof? #false]
|
||||
#:? [L-resolvent-pruning? l-res-pruning?]
|
||||
#:? [negative-literal-selection? neg-lit-select?]))
|
||||
#:call-wrapped call
|
||||
(define res (call))
|
||||
(unless l-res-pruning?
|
||||
(check-equal? (dict-ref res 'L-resolvent-pruning) 0))
|
||||
(unless dynamic-ok?
|
||||
(check-equal? (dict-ref res 'binary-rules-dynamic) 0))
|
||||
(unless rwtree-in=out?
|
||||
(check-equal? (dict-ref res 'binary-rules) 0)
|
||||
(check-true (= (dict-ref res 'binary-rewrites) 0)))
|
||||
res)
|
||||
|
||||
|
||||
;; Some refutation tests
|
||||
(check-equal?
|
||||
(dict-ref (saturation (Vars+clausify-list '( [] )))
|
||||
'status)
|
||||
'refuted)
|
||||
(check-equal?
|
||||
(dict-ref (saturation (Vars+clausify-list '( [p] )))
|
||||
'status)
|
||||
'saturated)
|
||||
(check-equal?
|
||||
(dict-ref (saturation (Vars+clausify-list '( [p]
|
||||
[(not p)])))
|
||||
'status)
|
||||
'refuted)
|
||||
(check-equal?
|
||||
(dict-ref (saturation (Vars+clausify-list '( [p]
|
||||
[(not q)])))
|
||||
'status)
|
||||
'saturated)
|
||||
|
||||
;; WARNING (TODO): If L-resolvents-pruning applied to input clauses too,
|
||||
;; it would discard the 2nd clause immediately and would saturate!
|
||||
(replay-on-failure
|
||||
(check-equal?
|
||||
(dict-ref (saturation (Vars+clausify-list '( [(p z)]
|
||||
[(not (p X)) (p (s X))]
|
||||
[(not q)])))
|
||||
'status)
|
||||
'steps))
|
||||
|
||||
|
||||
|
||||
;; Russell's 'paradox', requires factoring:
|
||||
(check-equal?
|
||||
(dict-ref (saturation (Vars+clausify-list
|
||||
'( [(s X X) (s b X)]
|
||||
[(not (s X X)) (not (s b X))])))
|
||||
'status)
|
||||
'refuted)
|
||||
|
||||
;; Second version
|
||||
(check-equal?
|
||||
(dict-ref (saturation (Vars+clausify-list
|
||||
'( [(s X b) (s b X)]
|
||||
[(not (s X b)) (not (s b X))])))
|
||||
'status)
|
||||
'refuted)
|
||||
|
||||
|
||||
|
||||
; TPTP 100k idx = 348
|
||||
(check-equal?
|
||||
(dict-ref (saturation (Vars+clausify-list
|
||||
'( [(big_f T0_0 T0_1) (big_g T0_0 T0_2)]
|
||||
[(big_f T1_0 T1_1) (not (big_g T1_0 T1_0))]
|
||||
[(big_g T2_0 T2_1) (not (big_f T2_0 T2_2))]
|
||||
[(not (big_f T3_0 T3_1)) (not (big_g T3_0 (esk1_1 T3_0)))])))
|
||||
'status)
|
||||
'refuted)
|
||||
|
||||
|
||||
; TPTP 100k idx = 784
|
||||
(check-equal?
|
||||
(dict-ref (saturation (Vars+clausify-list '( [p1 p2]
|
||||
[p1 (not p2)]
|
||||
[p2 (not p1)]
|
||||
[(not p1) (not p2)])))
|
||||
'status)
|
||||
'refuted)
|
||||
|
||||
|
||||
; TPTP 100k idx = 117
|
||||
(check-equal?
|
||||
(dict-ref (saturation
|
||||
(Vars+clausify-list
|
||||
'( [(big_f T0_0 T0_1 (esk3_2 T0_0 T0_1))]
|
||||
[(big_f esk1_0 esk2_0 esk2_0) (not (big_f esk1_0 esk1_0 esk2_0))]
|
||||
[(big_f esk1_0 esk1_0 esk2_0)
|
||||
(big_f esk1_0 esk2_0 esk2_0)
|
||||
(not (big_f esk2_0 esk2_0 T2_0))]
|
||||
[(big_f esk1_0 esk1_0 esk2_0)
|
||||
(big_f esk2_0 T3_0 T3_1)
|
||||
(not (big_f esk1_0 esk2_0 esk2_0))]
|
||||
[(not (big_f esk1_0 esk1_0 esk2_0))
|
||||
(not (big_f esk1_0 esk2_0 esk2_0))
|
||||
(not (big_f esk2_0 esk2_0 T4_0))]
|
||||
[(big_f esk1_0 esk2_0 esk2_0)
|
||||
(not (big_f T5_0 T5_1 (esk3_2 T5_1 T5_0)))
|
||||
(not (big_f esk1_0 esk1_0 esk2_0))]
|
||||
[(big_f esk1_0 esk1_0 esk2_0)
|
||||
(not (big_f T6_0 (esk3_2 T6_0 T6_1) (esk3_2 T6_0 T6_1)))
|
||||
(not (big_f esk1_0 esk2_0 esk2_0))] )))
|
||||
'status)
|
||||
'refuted)
|
||||
|
||||
(check-equal?
|
||||
(dict-ref
|
||||
(saturation
|
||||
(Vars+clausify-list
|
||||
'([(p X) (not (p (p X)))]
|
||||
[(not (p a))]
|
||||
[(not (q a))]
|
||||
[(q X) (not (q (q (q X))))]
|
||||
[(q (q (q (q (q (q (q (q (q (q (q (q (q (q (q a)))))))))))))))])))
|
||||
'status)
|
||||
'refuted)
|
||||
;; This problem shows there may be some loops with implication-removal and factoring!
|
||||
(check-equal?
|
||||
(dict-ref
|
||||
(saturation
|
||||
(Vars+clausify-list
|
||||
'([(not (p X Y)) (p X Z) (p Z Y)]
|
||||
[(p x x)]
|
||||
[(not (q a a a a b b b b c c c c))]
|
||||
[(q A A A A B B B B C C C C) (not (q (q A A A A) (q B B B B) (q C C C C)))]
|
||||
[(q (q a a a a) (q b b b b) (q c c c c))])))
|
||||
'status)
|
||||
'refuted)
|
||||
|
||||
;; Binary rewrite
|
||||
;; This example shows that *not* backward rewriting rules can be a problem:
|
||||
;; Around step 19, there should be immediate resolution to '() with an active clause.
|
||||
;; But because [(not (p a A))] has not been rewritten to [(notp a A)],
|
||||
;; it cannot unify to '() immediately, and must wait for a *resolution* between
|
||||
;; the rule and the clause to pop up from the queue.
|
||||
(replay-on-failure
|
||||
(define res
|
||||
(saturation
|
||||
(map clausify
|
||||
'(((notp A B) (p A B)) ; axiom, binary clause
|
||||
((not (notp A B)) (not (p A B))) ; axiom, converse binary clause
|
||||
((p a A) (q b B) (r c C) (s d D)) ; these two clauses should resolve to '() immediately
|
||||
((not (p A a))) ; Note that 'a A' is to prevent unit-clause rewrites
|
||||
((not (q B b)))
|
||||
((not (r C c)))
|
||||
((not (s D d)))
|
||||
))))
|
||||
(check-equal? (dict-ref res 'status) 'refuted)
|
||||
(when rwtree-in=out?
|
||||
(check > (dict-ref res 'unit-rules) 0)
|
||||
(check-equal? (dict-ref res 'binary-rules) 2)
|
||||
(check > (dict-ref res 'binary-rewrites) 0)))
|
||||
|
||||
;; 'Asymmetric' rules
|
||||
(replay-on-failure
|
||||
(define res
|
||||
(saturation
|
||||
(map clausify
|
||||
'([(not (p A A)) (q A)] ; Not a rule in itself (too general), but enables the next ones
|
||||
[(p a a) (not (q a))] ; rule (p a a) <-> (q a)
|
||||
[(p b b) (not (q b))] ; rule (p b b) <-> (q b)
|
||||
[(p a a) (p b b) (p c c)]
|
||||
[(not (q a)) (remove-me x Y)]
|
||||
[(not (q b)) (remove-me x Y)]
|
||||
[(not (p c c)) (remove-me x Y)]
|
||||
[(not (remove-me X y))] ; defeats urw
|
||||
))))
|
||||
(check-equal? (dict-ref res 'status) 'refuted)
|
||||
(when rwtree-in=out?
|
||||
(check-equal? (dict-ref res 'binary-rules) 4)
|
||||
(check-true (> (dict-ref res 'binary-rewrites) 0))))
|
||||
;; Same but with rules loaded from a file
|
||||
;; TODO
|
||||
#;
|
||||
(replay-on-failure
|
||||
(define res
|
||||
(saturation
|
||||
(map clausify
|
||||
'([(not (p A A)) (q A)] ; Not a rule in itself (too general), but enables the next ones
|
||||
[(p a a) (not (q a))] ; rule (p a a) <-> (q a)
|
||||
[(p b b) (not (q b))] ; rule (p b b) <-> (q b)
|
||||
[(p a a) (p b b) (p c c)]
|
||||
[(not (q a)) (remove-me x Y)]
|
||||
[(not (q b)) (remove-me x Y)]
|
||||
[(not (p c c)) (remove-me x Y)]
|
||||
[(not (remove-me X y))] ; defeats urw
|
||||
))))
|
||||
(check-equal? (dict-ref res 'status) 'refuted)
|
||||
(when rwtree-in=out?
|
||||
(check-equal? (dict-ref res 'binary-rules) 4)
|
||||
(check-true (> (dict-ref res 'binary-rewrites) 0))))
|
||||
|
||||
;; Greedy selection of binary rewrites can lead to failure
|
||||
(replay-on-failure
|
||||
(define res
|
||||
(saturation
|
||||
(map clausify
|
||||
'(; equivalences
|
||||
[(not (q A B C D)) (p A B C)] ; (q A B C D) <=> (p A B C)
|
||||
[(q A B C D) (not (p A B C))]
|
||||
[(not (p A b C)) (t a)] ; (p A b C) <=> (t a)
|
||||
[(p A b C) (not (t a))]
|
||||
[(not (q A B c D)) (s b c)] ; (q A b c D) <=> (s b c)
|
||||
[(q A B c D) (not (s b c))]
|
||||
; inputs
|
||||
; may be rewritten to (s b c)
|
||||
[(q a b c d) (remove-me x Y) (remove-me y Y) (remove-me z Y)]
|
||||
[(not (t a)) (remove-me x Y) (remove-me y Y) (remove-me z Y)]
|
||||
;
|
||||
[(not (remove-me X y))] ; defeats urw
|
||||
))))
|
||||
(check-equal? (dict-ref res 'status) 'refuted)
|
||||
(when rwtree-in=out?
|
||||
(check-equal? (dict-ref res 'binary-rules) 6)
|
||||
(check-true (> (dict-ref res 'binary-rewrites) 0))))
|
||||
|
||||
;; Overlapping rewrites can lead to failures (but not without rewrites)
|
||||
(replay-on-failure
|
||||
(define res
|
||||
(saturation
|
||||
(map clausify
|
||||
'(; equivalences
|
||||
[(not (q A B C D)) (p A B C)] ; (q A B C D) <=> (p A B C)
|
||||
[(q A B C D) (not(p A B C))]
|
||||
[(not (p A b C)) (t a)] ; (p A b C) <=> (t a)
|
||||
[(p A b C) (not (t a))]
|
||||
[(not (q A b c D)) (s b c)] ; (q A b c D) <=> (s b c)
|
||||
[(q A b c D) (not (s b c))]
|
||||
; inputs
|
||||
[(s b c) (remove-me x Y) (remove-me y Y) (remove-me z Y)]
|
||||
[(not (t a)) (remove-me x Y) (remove-me y Y) (remove-me z Y)]
|
||||
;
|
||||
[(not (remove-me X y))] ; defeats urw
|
||||
))))
|
||||
(check-equal? (dict-ref res 'status) 'refuted)
|
||||
(when rwtree-in=out?
|
||||
(check-equal? (dict-ref res 'binary-rules) 6)
|
||||
(check-true (> (dict-ref res 'binary-rewrites) 0))))
|
||||
|
||||
;; Greedy selection of overlapping rewrites can lead to failures
|
||||
(replay-on-failure
|
||||
(define res
|
||||
(saturation
|
||||
(map clausify
|
||||
'(; equivalences
|
||||
[(not (q A B C D)) (p A B C)] ; (q A B C D) <=> (p A B C)
|
||||
[(q A B C D) (not(p A B C))]
|
||||
[(not (p A b C)) (r A C)] ; (p A b C) <=> (r A C)
|
||||
[(p A b C) (not (r A C))]
|
||||
[(not (r A c)) (t a)] ; (r A c) <=> (t a)
|
||||
[(r A c) (not (t a))]
|
||||
[(not (q A b c D)) (s b c)] ; (q A b c D) <=> (s b c)
|
||||
[(q A b c D) (not (s b c))]
|
||||
; inputs
|
||||
[(s b c) (remove-me x Y) (remove-me y Y) (remove-me z Y)]
|
||||
[(not (t a)) (remove-me x Y) (remove-me y Y) (remove-me z Y)]
|
||||
;
|
||||
[(not (remove-me X y))] ; defeats urw
|
||||
))))
|
||||
(check-equal? (dict-ref res 'status) 'refuted)
|
||||
(when rwtree-in=out?
|
||||
(check-equal? (dict-ref res 'binary-rules) 8)
|
||||
(check-true (> (dict-ref res 'binary-rewrites) 0)))))
|
||||
@@ -0,0 +1,34 @@
|
||||
#lang racket/base
|
||||
|
||||
(require "../clause.rkt"
|
||||
"../unification.rkt")
|
||||
|
||||
(define cms current-milliseconds)
|
||||
|
||||
;;; Stress test.
|
||||
;;; There's only one predicate of two arguments.
|
||||
;;; This takes basically exponential time with n.
|
||||
;;; All the time is taken by clausify (safe-factoring, which includes subsumption check)
|
||||
(define (stress n)
|
||||
(define pre (cms))
|
||||
(define cl1
|
||||
(time
|
||||
(clausify
|
||||
(fresh ; ensures the names are adequate variable names
|
||||
(for/list ([i n])
|
||||
`(eq #s(Var ,i) #s(Var ,(+ i 1))))))))
|
||||
(define cl2
|
||||
(time
|
||||
(clausify
|
||||
(fresh
|
||||
(for/list ([i (+ n 1)])
|
||||
`(eq #s(Var ,i) #s(Var ,(+ i 1))))))))
|
||||
(void (time (clause-subsumes cl1 cl2)))
|
||||
(void (time (clause-subsumes cl2 cl1)))
|
||||
(- (cms) pre))
|
||||
|
||||
;; Takes about 10s on my desktop machine for n=40 (subsumes-iter-limit=0).
|
||||
|
||||
(for/list ([n (in-list '(10 20 30 40))])
|
||||
(printf "n = ~a\n" n)
|
||||
(stress n))
|
||||
@@ -0,0 +1,13 @@
|
||||
#lang racket/base
|
||||
|
||||
(require "../timeplus.rkt"
|
||||
rackunit)
|
||||
|
||||
(check-equal? (string-drop-common-prefix '("auiebépo" "auiensrt" "au"))
|
||||
'("iebépo" "iensrt" ""))
|
||||
(check-equal? (string-drop-common-prefix '("auiebépo" "auiensrt" ))
|
||||
'("bépo" "nsrt"))
|
||||
(check-equal? (string-drop-common-prefix '("auiebépo" ))
|
||||
'(""))
|
||||
(check-equal? (string-drop-common-prefix '("" ))
|
||||
'(""))
|
||||
@@ -0,0 +1,81 @@
|
||||
#lang racket/base
|
||||
|
||||
(require "../trie.rkt"
|
||||
rackunit
|
||||
(only-in "../unification.rkt" symbol-variable?)
|
||||
racket/pretty)
|
||||
|
||||
(let ([atrie (make-trie #:variable? symbol-variable?)])
|
||||
(trie-set! atrie
|
||||
'(a X (f Y) c)
|
||||
'A)
|
||||
(trie-set! atrie
|
||||
'(a b (f Y) c)
|
||||
'B)
|
||||
(trie-set! atrie
|
||||
'(a b (f Y) E)
|
||||
'C)
|
||||
(check-equal?
|
||||
(sort (trie-ref atrie '(a b (f (g e)) c)) symbol<?)
|
||||
'(A B C))
|
||||
(check-equal? (trie-ref atrie '(a Y (f (g e)) c))
|
||||
'(A))
|
||||
(check-equal? (trie-ref atrie '(a Y (f (g Y)) c))
|
||||
'(A))
|
||||
(check-equal? (trie-ref atrie '(a Y (f (g Y)) Z))
|
||||
'())
|
||||
(check-equal? (trie-ref atrie '(a b (f Y) (g e)))
|
||||
'(C))
|
||||
(check-equal? (trie-ref atrie '(a (f (g Y)) (f Y) c))
|
||||
'(A))
|
||||
#;(pretty-print (trie-root atrie))
|
||||
#;(displayln (trie-values atrie))
|
||||
(check-equal? (sort (trie-values atrie) symbol<?)
|
||||
'(A B C))
|
||||
(check-equal? (trie-ref atrie '(X X X X)) '())
|
||||
(check-equal? (sort (trie-inverse-ref atrie '(X X X X)) symbol<?)
|
||||
'(A B C))
|
||||
(check-equal? (trie-inverse-ref atrie '(a b (f e) c)) '())
|
||||
|
||||
(check-equal? (sort (trie-both-ref atrie '(a Y (f c) c)) symbol<?)
|
||||
'(A B C))
|
||||
(check-equal? (sort (trie-both-ref atrie '(a e (f (g X)) c)) symbol<?)
|
||||
'(A))
|
||||
(check-equal? (sort (trie-both-ref atrie '(a b (f c) d)) symbol<?)
|
||||
'(C)))
|
||||
|
||||
(let ([atrie (make-trie #:variable? symbol-variable?)])
|
||||
(trie-set! atrie
|
||||
'(eq X0 X1)
|
||||
'A)
|
||||
(trie-set! atrie
|
||||
'(eq X0 (mul X1 one))
|
||||
'B)
|
||||
(trie-set! atrie
|
||||
'(eq X0 (mul X1 X0))
|
||||
'C)
|
||||
(check-equal? (trie-ref atrie '(eq X Y))
|
||||
'(A))
|
||||
(check-equal?
|
||||
(sort (trie-ref atrie '(eq Y (mul Y one))) symbol<?)
|
||||
'(A B C)))
|
||||
|
||||
;; Trie-traversal
|
||||
(let ([atrie (make-trie #:variable? symbol-variable?)])
|
||||
(trie-set! atrie
|
||||
'(a X (f Y) c)
|
||||
'A)
|
||||
(trie-set! atrie
|
||||
'(a b (f Y) c)
|
||||
'B)
|
||||
(trie-set! atrie
|
||||
'(a b (f Y) E)
|
||||
'C)
|
||||
(trie-set! atrie 'X 'D)
|
||||
(trie-set! atrie 'abc 'E)
|
||||
(trie-set! atrie '(a B c) 'F)
|
||||
(trie-set! atrie '(a B c d) 'G)
|
||||
(trie-set! atrie '(a B) 'H)
|
||||
(trie-set! atrie '() 'I)
|
||||
(check-equal? (sort (trie-inverse-ref atrie 'A) symbol<?)
|
||||
'(A B C D E F G H I)))
|
||||
@@ -0,0 +1,69 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/list
|
||||
rackunit
|
||||
"../Clause.rkt"
|
||||
(submod "../Clause.rkt" test)
|
||||
"../clause.rkt"
|
||||
"../unification-tree.rkt")
|
||||
|
||||
|
||||
(let ()
|
||||
(define utree (make-unification-tree))
|
||||
(add-Clause! utree (Clausify '[(p A B) (not (q A x B))]))
|
||||
(check-Clause-set-equivalent?
|
||||
(utree-resolve+unsafe-factors utree (Clausify '[(not (p a b)) (q e x f) (q g x h) (p c d)])
|
||||
#:L-resolvent-pruning? #false)
|
||||
(map Clausify
|
||||
'([(p c d) (q e x f) (q g x h) (not (q a x b))]
|
||||
[(p c d) (p g h) (q e x f) (not (p a b))]
|
||||
[(p c d) (p e f) (q g x h) (not (p a b))])))
|
||||
|
||||
(check-Clause-set-equivalent?
|
||||
(utree-resolve+unsafe-factors utree (Clausify '[(not (p X Y)) (r X Y Y)])
|
||||
#:L-resolvent-pruning? #false)
|
||||
(map Clausify '([(r A B B) (not (q A x B))]))))
|
||||
|
||||
(let ()
|
||||
(define utree (make-unification-tree))
|
||||
(add-Clause! utree (Clausify '[(p A b) (not (q A x c))]))
|
||||
(define C2 (Clausify '[(not (p a B)) (q d x B)]))
|
||||
(check-Clause-set-equivalent?
|
||||
(utree-resolve+unsafe-factors utree C2 #:L-resolvent-pruning? #false)
|
||||
(map Clausify '([(not (q a x c)) (q d x b)]
|
||||
[(p d b) (not (p a c))]))))
|
||||
|
||||
|
||||
(define (utree-remove-subsumed! utree cl)
|
||||
(define C (make-Clause cl))
|
||||
(utree-inverse-find/remove! utree C Clause<=>-subsumes))
|
||||
|
||||
(define (make-utree1)
|
||||
(define utree (make-unification-tree))
|
||||
(for-each
|
||||
(λ (cl) (add-Clause! utree (make-Clause (clausify cl))))
|
||||
'([(p A) (not (q B))]
|
||||
[(q A) (r B)]
|
||||
[(p c) (r b)]))
|
||||
utree)
|
||||
|
||||
(let ()
|
||||
(define utree (make-utree1))
|
||||
(define removed (utree-remove-subsumed! utree (clausify '[(q X)])))
|
||||
(check-equal? (length removed) 1)
|
||||
(check-equal? (length (utree-remove-subsumed! utree (clausify '[(not (q X))]))) 1)
|
||||
(check-equal? (length (utree-remove-subsumed! utree (clausify '[(r X)]))) 1)
|
||||
(check-equal? (append* (trie-values utree)) '()))
|
||||
|
||||
(let ()
|
||||
(define utree (make-utree1))
|
||||
(define removed (utree-remove-subsumed! utree (clausify '[(p d)])))
|
||||
(check-equal? (length removed) 0)
|
||||
(define removed2 (utree-remove-subsumed! utree (clausify '[(p c)])))
|
||||
(check-equal? (length removed2) 1))
|
||||
|
||||
(let ()
|
||||
(define utree (make-utree1))
|
||||
(define removed (utree-remove-subsumed! utree (clausify '[(p X)])))
|
||||
(check-equal? (length removed) 2))
|
||||
|
||||
@@ -0,0 +1,381 @@
|
||||
#lang racket/base
|
||||
|
||||
(require (submod bazaar/order test)
|
||||
racket/match
|
||||
rackunit
|
||||
"../unification.rkt")
|
||||
|
||||
(check-eq? (Var-name->symbol (symbol->Var-name 'C)) 'C)
|
||||
(check-eq? (Var-name->symbol (symbol->Var-name 'X0)) 'X0)
|
||||
(check-eq? (Var-name->symbol (symbol->Var-name 'X1353)) 'X1353)
|
||||
|
||||
|
||||
(check-equal?
|
||||
(find-var-names (Varify '(p D C A B)))
|
||||
(map Var-name (Varify '(D C A B))))
|
||||
(check-equal?
|
||||
(find-var-names (Varify '(p (q D E) C A B E D D A)))
|
||||
(map Var-name (Varify '(D E C A B))))
|
||||
|
||||
(let ()
|
||||
(define-check (check/fail-var-occs<=> p q c)
|
||||
(let ([res (var-occs<=> p q)])
|
||||
(unless (eq? res c)
|
||||
(fail-check (format "Params: ~a ~a \nExpected: ~a\nGot: ~a\n" p q c res)))))
|
||||
(define (check-var-occs<=> p q c)
|
||||
(let ([p (Varify p)] [q (Varify q)])
|
||||
(check/fail-var-occs<=> p q c)
|
||||
(case c
|
||||
[(<) (check/fail-var-occs<=> q p '>)]
|
||||
[(>) (check/fail-var-occs<=> q p '<)]
|
||||
[(= #false) (check/fail-var-occs<=> q p c)])))
|
||||
|
||||
(check-var-occs<=> '(p) '(q) '=)
|
||||
(check-var-occs<=> '(p X) '(q) '>)
|
||||
(check-var-occs<=> '(p X) '(q X) '=)
|
||||
(check-var-occs<=> '(p X X) '(q X) '>)
|
||||
(check-var-occs<=> '(p X Y) '(q X) '>)
|
||||
(check-var-occs<=> '(p X Y) '(q X Z) #false)
|
||||
(check-var-occs<=> '(p X X Y) '(q X Z) #false)
|
||||
(check-var-occs<=> '(p X X Y) '(q X Y) '>)
|
||||
(check-var-occs<=> '(p X X Y) '(q X Y Y) #false))
|
||||
|
||||
(let ()
|
||||
(check equal? (lnot 'auie) `(not auie))
|
||||
(check equal? (lnot (lnot 'auie)) 'auie)
|
||||
(check equal? (lnot lfalse) ltrue)
|
||||
(check equal? (lnot `(not ,lfalse)) lfalse) ; to fix non-reduced values
|
||||
(check equal? (lnot `(not ,ltrue)) ltrue) ; to fix non-reduced values
|
||||
(check equal? (lnot ltrue) lfalse)
|
||||
(check equal? (lnot (lnot ltrue)) ltrue)
|
||||
(check equal? (lnot (lnot lfalse)) lfalse)
|
||||
(check<=> polarity<=> 'a '(not a) '<))
|
||||
|
||||
|
||||
(let ()
|
||||
(define-simple-check (check-atom1<=> a b res)
|
||||
(check<=> atom1<=> (Varify a) (Varify b) res))
|
||||
|
||||
(check-atom1<=> lfalse 'a '<)
|
||||
(check-atom1<=> lfalse lfalse '=)
|
||||
(check-atom1<=> '() '() '=)
|
||||
(check-atom1<=> '(eq b a) '(eq a b) '>) ; lexicographical order
|
||||
(check-atom1<=> '(p X Y) '(p Y X) '=) ; no lex order between variables
|
||||
(check-atom1<=> '(p a X) '(p X a) '=) ; no lex order between variable and symbol
|
||||
(check-atom1<=> '(p A (q B))
|
||||
'(p (q A) B)
|
||||
'=) ; no lex order when variable is involved
|
||||
(check-atom1<=> '(p A (q b))
|
||||
'(p (q A) b)
|
||||
'=) ; ????
|
||||
(check-atom1<=> '(not (eq X0 X1 X1)) ; var-occs=
|
||||
'(not (eq X0 X1 X1))
|
||||
'=)
|
||||
|
||||
(check-atom1<=> '(eq X0 X1 X1)
|
||||
'(not (eq X0 X1 X1))
|
||||
'=) ; negation should NOT count
|
||||
;;; This is very important, otherwise the following problem can end with 'saturated:
|
||||
;;; ((notp A B) (p A B)) ; axiom, binary clause
|
||||
;;; ((not (notp A B)) (not (p A B))) ; axiom, converse binary clause
|
||||
;;; ((p a A)) ; these two clauses should resolve to '() immediately
|
||||
;;; ((not (p A a))) ; Note that 'a A' is to prevent unit-clause rewrites
|
||||
|
||||
|
||||
(check-atom1<=> 'p 'q '<)
|
||||
(check-atom1<=> '(not p) '(not q) '<)
|
||||
|
||||
(check-atom1<=> '(not (eq X0 X1 X1))
|
||||
'(not (eq X1 X0))
|
||||
'>)
|
||||
(check-atom1<=> '(p X Y Z)
|
||||
'(p X Y one)
|
||||
'>)
|
||||
(check-atom1<=> '(p X A one)
|
||||
'(p X Y one)
|
||||
'#false)
|
||||
(check-atom1<=> '(p X one one)
|
||||
'(p X one)
|
||||
'>)
|
||||
(check-atom1<=> '(p X one (q one))
|
||||
'(p X one one)
|
||||
'>)
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
||||
;; Tests for KBO
|
||||
(let ()
|
||||
(define-simple-check (check-KBO1lex<=> a b res)
|
||||
(check<=> KBO1lex<=> (Varify a) (Varify b) res))
|
||||
|
||||
|
||||
(check-KBO1lex<=> lfalse 'a '<)
|
||||
(check-KBO1lex<=> lfalse lfalse '=)
|
||||
|
||||
|
||||
;(check-KBO1lex<=> '() '() '=) ; not a term
|
||||
(check-KBO1lex<=> '(eq b a) '(eq a b) '>) ; lexicographical order
|
||||
(check-KBO1lex<=> '(p X Y) '(p Y X) #false) ; commutativity cannot be oriented
|
||||
(check-KBO1lex<=> '(p a X) '(p X a) #false) ; left->right order: a <=> X -> #false
|
||||
(check-KBO1lex<=> '(p A (q B))
|
||||
'(p (q A) B)
|
||||
'<) ; left->right order: A < (q A)
|
||||
(check-KBO1lex<=> '(p A (q b))
|
||||
'(p (q A) b)
|
||||
'<) ; left->right order: A < (q A)
|
||||
(check-KBO1lex<=> '(not (eq X0 X1 X1)) ; var-occs=
|
||||
'(not (eq X0 X1 X1))
|
||||
'=)
|
||||
|
||||
(check-KBO1lex<=> '(eq X0 X1 X1)
|
||||
'(not (eq X0 X1 X1))
|
||||
'=) ; negation should NOT count
|
||||
;;; This is very important, otherwise the following problem can end with 'saturated:
|
||||
;;; ((notp A B) (p A B)) ; axiom, binary clause
|
||||
;;; ((not (notp A B)) (not (p A B))) ; axiom, converse binary clause
|
||||
;;; ((p a A)) ; these two clauses should resolve to '() immediately
|
||||
;;; ((not (p A a))) ; Note that 'a A' is to prevent unit-clause rewrites
|
||||
|
||||
|
||||
(check-KBO1lex<=> 'p 'q '<) ; lex
|
||||
(check-KBO1lex<=> '(not p) '(not q) '<) ; lex
|
||||
|
||||
(check-KBO1lex<=> '(not (eq X0 X1 X1))
|
||||
'(not (eq X1 X0))
|
||||
'>) ; by var-occs and weight
|
||||
(check-KBO1lex<=> '(p X Y Z)
|
||||
'(p X Y one)
|
||||
#false) ; var-occs incomparable
|
||||
(check-KBO1lex<=> '(p X Y (f Z))
|
||||
'(p X (f Y) one)
|
||||
#false) ; var-occs incomparable
|
||||
(check-KBO1lex<=> '(p X Y (f Z))
|
||||
'(p X (f Y) Z)
|
||||
'<) ; same weight, Y < (f Y)
|
||||
(check-KBO1lex<=> '(p X A one)
|
||||
'(p X Y one)
|
||||
#false)
|
||||
(check-KBO1lex<=> '(p X one one)
|
||||
'(p X one)
|
||||
'>)
|
||||
(check-KBO1lex<=> '(p X one (q one))
|
||||
'(p X one one)
|
||||
'>)
|
||||
|
||||
(check-KBO1lex<=> '(p A (p B C))
|
||||
'(p (p A B) C)
|
||||
'<) ; associativity ok: A < (p A B)
|
||||
)
|
||||
|
||||
(let ()
|
||||
(check-equal? (term-lex2<=> '(p a) '(p b)) '<))
|
||||
|
||||
(let ()
|
||||
(define-simple-check (check-term-lex<=> a b res)
|
||||
(let-values ([(a b) (apply values (fresh (Varify (list a b))))])
|
||||
(check<=> term-lex<=> (Varify a) (Varify b) res)))
|
||||
(check-term-lex<=> 'a (Var 'X) '>)
|
||||
(check-term-lex<=> (Var 'X) (Var 'X) '=)
|
||||
(check-term-lex<=> 'a 'a '=)
|
||||
(check-term-lex<=> 'a 'b '<)
|
||||
|
||||
(define-simple-check (check-literal<=> a b res)
|
||||
(let-values ([(a b) (apply values (fresh (Varify (list a b))))])
|
||||
(check<=> literal<=> (Varify a) (Varify b) res)))
|
||||
(check-literal<=> 'a '(not a) '<)
|
||||
(check-literal<=> 'a 'b '<)
|
||||
(check-literal<=> 'z '(not a) '<)
|
||||
(check-literal<=> '(z b) '(not a) '<)
|
||||
(check-literal<=> 'a 'a '=)
|
||||
(check-literal<=> 'z '(a a) '>)
|
||||
(check-literal<=> '(z z) '(z (a a)) '<))
|
||||
|
||||
(let ()
|
||||
(check-true (literal==? 'a 'a))
|
||||
(check-true (literal==? (Var 'X) (Var 'X)))
|
||||
(check-true (literal==? (Var 'X) #s(Var X))) ; prefab
|
||||
(check-false (literal==? (Var 'X) (Var 'Y)))
|
||||
(check-false (literal==? (fresh (Var 'X)) (Var 'X)))
|
||||
(check-false (literal==? 'X (Var 'X))) ; not considered the same??
|
||||
(check-true (literal==? `(p (f ,(Var 'X) ,(Var 'X)) y) `(p (f ,(Var 'X) ,(Var 'X)) y))))
|
||||
|
||||
|
||||
(let ()
|
||||
(define-check (test-unify t1 t2 subst)
|
||||
(let ([t1 (Varify t1)] [t2 (Varify t2)])
|
||||
(set! subst (subst/#false->imsubst subst))
|
||||
(define sh (unify t1 t2))
|
||||
(define sl (subst/#false->imsubst
|
||||
(and sh
|
||||
(for/list ([(k v) (in-subst sh)])
|
||||
(cons (Var k)
|
||||
(if (already-substed? v)
|
||||
(already-substed-term v)
|
||||
v))))))
|
||||
(unless (equal? sl subst)
|
||||
(fail-check (format "Expected ~a. Got: ~a\nt1 = ~a\nt2 = ~a\n"
|
||||
subst sl
|
||||
t1 t2)))
|
||||
(when sh
|
||||
(define r1 (substitute t1 sh))
|
||||
(define r2 (substitute t2 sh))
|
||||
(unless (equal? r1 r2)
|
||||
(fail-check "r1≠r2" sh r1 r2)))))
|
||||
|
||||
(test-unify '(p X)
|
||||
'(p X)
|
||||
'())
|
||||
(test-unify '(p (f X) X)
|
||||
'(p (f a) a)
|
||||
'((X . a)))
|
||||
(test-unify '(p (f c) (g X))
|
||||
'(p Y Y)
|
||||
#false)
|
||||
(test-unify '(p X (f X))
|
||||
'(p a Y)
|
||||
'((X . a) (Y . (f a))))
|
||||
(test-unify '(p (f X Y) (f Y Z))
|
||||
'(p (f (f a) (f b)) (f (f b) c))
|
||||
'((X . (f a)) (Y . (f b)) (Z . c)))
|
||||
(test-unify '(p X (p X) a)
|
||||
'(p Y (p (p Z)) Z)
|
||||
(if reduce-mgu?
|
||||
'((Z . a) (X . (p a)) (Y . (p a)))
|
||||
'((X . Y) (Y . (p Z)) (Z . a))))
|
||||
(test-unify '(p X (p X) (p (p X)))
|
||||
'(p a Y Z)
|
||||
'((X . a) (Y . (p a)) (Z . (p (p a)))))
|
||||
(test-unify '(p X (p X) (p (p X)))
|
||||
'(p a (p Y) (p (p Z)))
|
||||
'((X . a) (Y . a) (Z . a)))
|
||||
(test-unify '(p (p X) (p X) a)
|
||||
'(p Y (p (p Z)) Z)
|
||||
(if reduce-mgu?
|
||||
'((Z . a) (X . (p a)) (Y . (p (p a))))
|
||||
'((Y . (p X)) (X . (p Z)) (Z . a))))
|
||||
(test-unify '(p X X)
|
||||
'(p a Y)
|
||||
'((X . a) (Y . a)))
|
||||
(test-unify '(p X X)
|
||||
'(p (f Y) Z)
|
||||
'((X . (f Y)) (Z . (f Y))))
|
||||
(test-unify '(p X X) '(p (f Y) Y) #false)
|
||||
(test-unify '(p (f X Y) (g Z Z))
|
||||
'(p (f (f W U) V) W)
|
||||
(if reduce-mgu?
|
||||
'((W . (g Z Z)) (Y . V) (X . (f (g Z Z) U)))
|
||||
'((X . (f W U)) (Y . V) (W . (g Z Z)))))
|
||||
|
||||
(test-unify '(eq X30 (mul X31 (mul X32 (inv (mul X31 X32)))))
|
||||
'(eq (mul X25 one) X26)
|
||||
`((X26 . (mul X31 (mul X32 (inv (mul X31 X32)))))
|
||||
(X30 . (mul X25 one))))
|
||||
(test-unify '(p A B)
|
||||
'(p B A)
|
||||
'((A . B)))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define (test-suite-left-unify left-unify)
|
||||
(define-simple-check (test-left-unify t1 t2 subst)
|
||||
(let ([t1 (Varify t1)] [t2 (Varify t2)])
|
||||
(set! subst (subst/#false->imsubst subst))
|
||||
(define sh (left-unify t1 t2))
|
||||
(define sl (subst/#false->imsubst sh))
|
||||
(check-equal? sl subst
|
||||
(format "Expected ~a. Got: ~at1 = ~a\nt2 = ~a\n"
|
||||
subst sl
|
||||
t1 t2))
|
||||
(when sh
|
||||
(define r1 (left-substitute t1 sh))
|
||||
(check-equal? r1 t2 (format "r1≠t2\nsh=~a\nr1=~a\nt2=~a\n" sh r1 t2)))))
|
||||
|
||||
(test-left-unify '(p (f X) X)
|
||||
'(p (f a) a)
|
||||
'((X . a)))
|
||||
(test-left-unify '(p (f c) (g X))
|
||||
'(p Y Y)
|
||||
#false)
|
||||
(test-left-unify '(p X (f X)) '(p a Y) #false)
|
||||
(test-left-unify '(p (f X Y) (f Y Z))
|
||||
'(p (f (f a) (f b)) (f (f b) c))
|
||||
'((Z . c) (Y . (f b)) (X . (f a))))
|
||||
(test-left-unify '(p X X) '(p a Y) #false)
|
||||
(test-left-unify '(p X X) '(p (f Y) Z) #false)
|
||||
(test-left-unify '(p X X) '(p (f Y) Y) #false)
|
||||
(test-left-unify '(p (f X Y) (g Z Z))
|
||||
'(p (f (f W U) V) W)
|
||||
#false)
|
||||
(test-left-unify '(p X X)
|
||||
'(p A B)
|
||||
#false)
|
||||
; This MUST return false because of the circularity.
|
||||
; The found substitution must be specializing, that is C2[σ] = C2 (and C1[σ] = C2),
|
||||
; otherwise safe factoring can fail, in particular.
|
||||
; Hence we must ensure that vars(C2) ∩ dom(σ) = ø.
|
||||
(test-left-unify '(p A B)
|
||||
'(p B A)
|
||||
#false)
|
||||
(test-left-unify '(p B A)
|
||||
'(p A B)
|
||||
#false)
|
||||
(test-left-unify '(p A A)
|
||||
'(p B B)
|
||||
'((A . B)))
|
||||
(test-left-unify '(p A)
|
||||
'(p A)
|
||||
'())
|
||||
(test-left-unify '(p a)
|
||||
'(p a)
|
||||
'())
|
||||
(test-left-unify '(p A X) ;; WARNING
|
||||
'(p X Y)
|
||||
#false))
|
||||
|
||||
(test-suite-left-unify left-unify)
|
||||
(test-suite-left-unify (λ (t1 t2) (define subst-assoc (left-unify/assoc t1 t2))
|
||||
(and subst-assoc (make-subst subst-assoc)))))
|
||||
|
||||
|
||||
(let ([pat '(_not_ (_not_ #s(Var A)))]
|
||||
[t (fresh (Varify '(q (p (_not_ (_not_ (f A B)))))))])
|
||||
(define s
|
||||
(left-unify-anywhere pat t))
|
||||
(check-equal? (left-substitute pat s)
|
||||
(cadadr t)))
|
||||
|
||||
(let ([t '(q (p (_not_ (_not_ (f A B)))))])
|
||||
(check-equal?
|
||||
(match-anywhere (match-lambda [`(_not_ (_not_ ,x)) `([x . ,x])] [else #false])
|
||||
t)
|
||||
'([x . (f A B)])))
|
||||
|
||||
;; Stress test for unification
|
||||
;; This should take 0ms
|
||||
;; See https://en.wikipedia.org/wiki/Unification_(computer_science)
|
||||
;; #Examples_of_syntactic_unification_of_first-order_terms
|
||||
(let ()
|
||||
(define last-var? #true)
|
||||
(define (stress-unify n)
|
||||
(define A
|
||||
(let left ([d 1])
|
||||
(if (>= d n)
|
||||
(list '* (Var d) (if last-var? (Var (+ d 1)) 'a))
|
||||
(list '* (left (+ d 1)) (Var d)))))
|
||||
(define B
|
||||
(let right ([d 1])
|
||||
(if (>= d n)
|
||||
(list '* (if last-var? (Var (+ d 1)) 'a) (Var d))
|
||||
(list '* (Var d) (right (+ d 1))))))
|
||||
(define subst (time (unify A B)))
|
||||
; Verify that there's only 1 variable in the each rhs
|
||||
(when (and reduce-mgu? last-var?)
|
||||
(check-equal? (length (Vars (map cdr (subst->list subst))))
|
||||
1
|
||||
subst))
|
||||
(time (substitute A subst)))
|
||||
(for ([n (in-range 30 50)])
|
||||
(printf "~a: " n)
|
||||
(stress-unify n)))
|
||||
+218
@@ -0,0 +1,218 @@
|
||||
#lang racket/base
|
||||
|
||||
;**************************************************************************************;
|
||||
;**** Tptp Input/Output Format ****;
|
||||
;**************************************************************************************;
|
||||
|
||||
(require bazaar/debug
|
||||
bazaar/string
|
||||
global
|
||||
racket/dict
|
||||
racket/file
|
||||
racket/format
|
||||
racket/list
|
||||
racket/match
|
||||
racket/port
|
||||
racket/string
|
||||
satore/clause
|
||||
satore/unification)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-global:boolean *tptp-out?* #false
|
||||
"Output is in TPTP format?")
|
||||
|
||||
#|
|
||||
File formats:
|
||||
.rktd: Racket data, one Racket clause per line.
|
||||
.p: Prolog format, with Prolog clauses that contain tptp (FOL) clauses.
|
||||
.tptp: only the tptp clauses, one per line.
|
||||
|
||||
|#
|
||||
|
||||
|
||||
(define (tptp-program-file->clauses program-file)
|
||||
; Not efficient: Loads the whole program as a string then parses it.
|
||||
; It would be more efficient to read it as a stream with an actual parser.
|
||||
; Another possibility is to read it line by line and parse each line as a cnf(…)
|
||||
; but that will file if the cnf(…) is multiline.
|
||||
(tptp-prog->clauses (file->string program-file)))
|
||||
|
||||
(define (tptp-pre-clauses->clauses pre-clauses)
|
||||
(define clauses
|
||||
(for/list ([cl (in-list pre-clauses)])
|
||||
(let loop ([t cl])
|
||||
(match t
|
||||
[(? symbol? x) x]
|
||||
[(? string? x)
|
||||
(string->symbol (string-append "_str_" x))] ; to avoid being interpreted as a variable
|
||||
['() '()]
|
||||
[(list '~ (? symbol? pred) (list a ...) r ...)
|
||||
(cons (list 'not (cons (loop pred) (loop a)))
|
||||
(loop r))]
|
||||
[(list (? symbol? pred) (list a ...) r ...)
|
||||
(cons (cons (loop pred) (loop a))
|
||||
(loop r))]
|
||||
[(list '~ x r ...)
|
||||
(cons (list 'not (loop x))
|
||||
(loop r))]
|
||||
[(list x a ...)
|
||||
(cons (loop x) (loop a))]
|
||||
[else (error "Unrecognized token: " t)]))))
|
||||
(map (compose clausify symbol-variables->Vars) clauses))
|
||||
|
||||
;; Prolog .p program to rkt format
|
||||
(define (tptp-prog->clauses str)
|
||||
|
||||
; hardly tested and not strict enough
|
||||
; It should be mostly robust to line breaking though.
|
||||
; Doesn't parse strings properly (will remove lines that look like comments in multiline strings)
|
||||
(define l
|
||||
(filter
|
||||
(λ (x)
|
||||
(if (list? x)
|
||||
x
|
||||
(begin
|
||||
(assert (memq x '(cnf end_cnf))
|
||||
x)
|
||||
#false)))
|
||||
; Ensure operators are surrounded with spaces
|
||||
; turn racket special symbols (| and ,) into normal symbols.
|
||||
; then use racket's reader to parse it like an s-expression
|
||||
(string->data
|
||||
(regexp-replaces
|
||||
str
|
||||
(list*
|
||||
'[#px"(?:^|\n)\\s*[%#][^\n]*" "\n"] ; prolog and shell/python/eprover full-line comments
|
||||
'[#px"\\bnot\\b" "_not_"] ;; WARNING!!! replace lnot with $not instead (as in TPTP)
|
||||
(map (λ (p) (list (regexp-quote (first p))
|
||||
(string-append " " (regexp-replace-quote (second p)) " ")))
|
||||
'(["|" "" ]
|
||||
["&" "" ]
|
||||
["," "" ]
|
||||
["$false" ""] ; empty literal
|
||||
["~" "~"]
|
||||
["." "end_cnf"]
|
||||
["'" "\""])))))))
|
||||
; first is name, second is type, third is clause, rest is comments(?)
|
||||
(define pre-clauses (map third l))
|
||||
(tptp-pre-clauses->clauses pre-clauses))
|
||||
|
||||
|
||||
;; Simple parser for the proposer output into s-exp clauses.
|
||||
;; The format is expected to be in cnf.
|
||||
(define (tptp-string->clauses str)
|
||||
; TODO: Optimize. This can be veeeery slow for large conjectures.
|
||||
(define pre-clauses
|
||||
(append*
|
||||
; split first to avoid regenerating the whole string after each substitution?
|
||||
(for/list ([str (in-list (string-split str #px"&|\n"))]) ; & and \n play the same role
|
||||
(with-handlers ([exn? (λ (e) (displayln str) (raise e))])
|
||||
(string->data
|
||||
; Ensure operators are surrounded with spaces
|
||||
; turn racket special symbols (| and ,) into normal symbols
|
||||
(regexp-replaces
|
||||
str
|
||||
(list*
|
||||
'[#px"\\bnot\\b" "_not_"] ;; WARNING!!! Instead: replace lnot with $not (as TPTP)
|
||||
(map (λ (p) (list (regexp-quote (first p))
|
||||
(string-append " " (regexp-replace-quote (second p)) " ")))
|
||||
'(["|" ""]
|
||||
["," ""]
|
||||
["~" "~"]
|
||||
["'" "\""])))))))))
|
||||
(tptp-pre-clauses->clauses pre-clauses))
|
||||
|
||||
|
||||
(define (literal->tptp-string lit)
|
||||
(cond
|
||||
[(lnot? lit)
|
||||
(string-append "~ " (literal->tptp-string (second lit)))]
|
||||
[(empty? lit)
|
||||
"$false"]
|
||||
[(list? lit)
|
||||
(string-append (literal->tptp-string (first lit))
|
||||
"("
|
||||
(string-join (map literal->tptp-string (rest lit)) ", ")
|
||||
")")]
|
||||
[(Var? lit) (symbol->string (Var-name->symbol lit))]
|
||||
[else (format "~a" lit)]))
|
||||
|
||||
(define (clause->tptp-string cl)
|
||||
(string-join
|
||||
(map literal->tptp-string (Vars->symbols cl))
|
||||
" | "))
|
||||
|
||||
(define (clauses->tptp-string cls)
|
||||
(string-join (map clause->tptp-string cls) "\n"))
|
||||
|
||||
;; String replacement of tptp names with shorter ones to improve readability
|
||||
(define (tptp-shortener str)
|
||||
(define substs
|
||||
(sort
|
||||
(map (λ (p) (cons (~a (car p)) (~a (cdr p))))
|
||||
; fld_1
|
||||
(append
|
||||
'((multiplicative_identity . _1)
|
||||
(additive_identity . _0)
|
||||
(less_or_equal . ≤)
|
||||
(additive_inverse . –)
|
||||
(multiplicative_inverse . /)
|
||||
(equalish . ≃)
|
||||
(multiply . ×)
|
||||
(product . ×=)
|
||||
(inverse . /)
|
||||
(add . +)
|
||||
)
|
||||
;grp_5
|
||||
'((equalish . ≃)
|
||||
(multiply . ×)
|
||||
(product . ×=)
|
||||
(inverse . /)
|
||||
(identity . _1)
|
||||
)
|
||||
; geo
|
||||
'((convergent_lines . /\\)
|
||||
(unorthogonal_lines . ¬⊥)
|
||||
(orthogonal_through_point . ⊥_thru_pt)
|
||||
(parallel_through_point . //_thru_pt)
|
||||
(distinct_lines . ≠_ln)
|
||||
(apart_point_and_line . ≠_pt_ln)
|
||||
(orthogonal_lines . ⊥)
|
||||
(distinct_points . ≠_pt)
|
||||
(parallel_lines . //)
|
||||
(equal_lines . =_ln)
|
||||
(equal_points . =_pt)))
|
||||
)
|
||||
; forces prefixes to appear later to match longer strings first:
|
||||
> #:key (compose string-length car)))
|
||||
|
||||
|
||||
(string-join
|
||||
(for/list ([line (in-lines (open-input-string str))])
|
||||
(for/fold ([line line])
|
||||
([(from to) (in-dict substs)])
|
||||
(string-replace line from to #:all? #true)))
|
||||
"\n"))
|
||||
|
||||
(define-syntax-rule (with-tptp-shortener body ...)
|
||||
(let ([str (with-output-to-string (λ () body ...))])
|
||||
(displayln (tptp-shortener str))))
|
||||
|
||||
;============;
|
||||
;=== Main ===;
|
||||
;============;
|
||||
|
||||
(module+ main
|
||||
(require global
|
||||
racket/file)
|
||||
|
||||
(define-global *rktd-file* #false
|
||||
"file in rktd format to output in tptp format"
|
||||
file-exists?
|
||||
values)
|
||||
|
||||
(void (globals->command-line))
|
||||
|
||||
(when (*rktd-file*)
|
||||
(displayln (clauses->tptp-string (file->list (*rktd-file*))))))
|
||||
+220
@@ -0,0 +1,220 @@
|
||||
#lang racket/base
|
||||
|
||||
;***************************************************************************************;
|
||||
;**** Trie: Imperfect Discrimination Tree ****;
|
||||
;***************************************************************************************;
|
||||
|
||||
;;; A key is a tree (a list of lists of ...), which is flattened to a list
|
||||
;;; where parenthesis are replaced with symbols.
|
||||
;;; Variables are considered to be unnamed and there is no unification/matching.
|
||||
;;; The only dependency on first-order logic specifics is `variable?`.
|
||||
|
||||
(require bazaar/cond-else
|
||||
racket/list
|
||||
racket/match
|
||||
satore/misc)
|
||||
|
||||
(provide (except-out (all-defined-out) no-value)
|
||||
(rename-out [no-value trie-no-value]))
|
||||
|
||||
;; Default value at the leaves. Should not be visible to the user.
|
||||
(define no-value (string->uninterned-symbol "no-value"))
|
||||
; Tokens used in the keys of the tree
|
||||
(define anyvar (string->uninterned-symbol "¿"))
|
||||
(define sublist-begin (string->uninterned-symbol "<<"))
|
||||
(define sublist-end (string->uninterned-symbol ">>"))
|
||||
|
||||
;; edges: hasheq(key . node?)
|
||||
(struct trie-node (edges value)
|
||||
#:transparent
|
||||
#:mutable)
|
||||
(define (make-node)
|
||||
(trie-node (make-hasheq) no-value))
|
||||
|
||||
;; Trie structure with variables.
|
||||
(struct trie (root variable?))
|
||||
|
||||
(define (make-trie #:constructor [constructor trie]
|
||||
#:variable? [variable? (λ (x) #false)]
|
||||
. other-args)
|
||||
(apply constructor (make-node) variable? other-args))
|
||||
|
||||
;; Updates the value of the node for the given key (or add one if none exists).
|
||||
;; atrie: trie?
|
||||
;; key: list?
|
||||
;; val: any/c
|
||||
(define (trie-update! atrie key update default-val/proc)
|
||||
(match-define (trie root variable?) atrie)
|
||||
; The key is `list`ed because we need a list, and this allows the given key to not be a list.
|
||||
(let node-insert! ([nd root] [key (list key)])
|
||||
(cond/else
|
||||
[(empty? key)
|
||||
; Stop here.
|
||||
(define old-value (trie-node-value nd))
|
||||
(set-trie-node-value! nd (update (if (eq? old-value no-value)
|
||||
(if (thunk? default-val/proc)
|
||||
(default-val/proc)
|
||||
default-val/proc)
|
||||
old-value)))]
|
||||
#:else ; key is a list
|
||||
(define k (car key))
|
||||
(define edges (trie-node-edges nd))
|
||||
#:cond
|
||||
[(pair? k)
|
||||
; Linearize the tree structure of the key.
|
||||
(define key2 (cons sublist-begin (append k (cons sublist-end (cdr key)))))
|
||||
(node-insert! nd key2)]
|
||||
#:else ; nil, atom, variable
|
||||
(let ([k (if (variable? k) anyvar k)])
|
||||
(define nd2 (hash-ref! edges k make-node))
|
||||
(node-insert! nd2 (cdr key))))))
|
||||
|
||||
;; Keep a list of values at the leaves.
|
||||
;; If `trie-insert!` is used, any use of `trie-update!` should be consistent with values being lists.
|
||||
(define (trie-insert! atrie key val)
|
||||
(trie-update! atrie key (λ (old) (cons val old)) '()))
|
||||
|
||||
;; Replacing the current value (if any) for key with val.
|
||||
(define (trie-set! atrie key val)
|
||||
(trie-update! atrie key (λ _ val) #false))
|
||||
|
||||
;; Applies on-leaf at each node that match with key.
|
||||
;; The matching keys of the trie are necessarily no less general than the given key.
|
||||
(define (trie-find atrie key on-leaf)
|
||||
(define variable? (trie-variable? atrie))
|
||||
(let node-ref ([nd (trie-root atrie)] [key (list key)])
|
||||
(cond/else
|
||||
[(empty? key)
|
||||
; Leaf found.
|
||||
(unless (eq? no-value (trie-node-value nd))
|
||||
(on-leaf nd))]
|
||||
#:else
|
||||
(define k (car key))
|
||||
(define var-nd (hash-ref (trie-node-edges nd) anyvar #false))
|
||||
#:cond
|
||||
[(variable? k)
|
||||
(when var-nd
|
||||
; both the key and the node are variables
|
||||
(node-ref var-nd (cdr key)))]
|
||||
#:else
|
||||
(when var-nd
|
||||
; If a variable matches, consider the two paths.
|
||||
(node-ref var-nd (cdr key)))
|
||||
#:cond
|
||||
[(pair? k)
|
||||
; Linearize the tree structure of the key.
|
||||
(define key2 (cons sublist-begin (append k (cons sublist-end (cdr key)))))
|
||||
(node-ref nd key2)]
|
||||
#:else
|
||||
(define nd2 (hash-ref (trie-node-edges nd) k #false))
|
||||
(when nd2
|
||||
(node-ref nd2 (cdr key))))))
|
||||
|
||||
;; Applies the procedure `on-leaf` to any node for which the key is matched by the given key.
|
||||
;; The matching keys of the trie are necessarily no more general than the given key.
|
||||
;; TODO: We could easily maintain a substitution over the branches since there's only one match.
|
||||
;; on-leaf: (-> node? any/c)
|
||||
(define (trie-inverse-find atrie key on-leaf)
|
||||
(define variable? (trie-variable? atrie))
|
||||
(let node-find ([nd (trie-root atrie)] [key (list key)] [depth 0])
|
||||
(define edges (trie-node-edges nd))
|
||||
(cond/else
|
||||
[(> depth 0)
|
||||
; If the depth is positive, that means we are currently matching a variable.
|
||||
; We need to continue through every branch and decrease the depth only if we encounter
|
||||
; a sublist-end, and increase the counter if we encounter a sublist-begin.
|
||||
; Note that key can be empty while depth > 0.
|
||||
(for([(k2 nd2) (in-hash edges)])
|
||||
(node-find nd2 key
|
||||
(cond [(eq? k2 sublist-begin) (+ depth 1)]
|
||||
[(eq? k2 sublist-end) (- depth 1)]
|
||||
[else depth])))]
|
||||
[(empty? key)
|
||||
; Leaf found.
|
||||
(unless (eq? no-value (trie-node-value nd))
|
||||
(on-leaf nd))]
|
||||
#:else
|
||||
(define k (car key))
|
||||
#:cond
|
||||
[(variable? k)
|
||||
;; Anything matches. For sublist we need to keep track of the depth.
|
||||
;; Note that variables in the tree can only be matched if k is a variable.
|
||||
(for ([(k2 nd2) (in-hash edges)])
|
||||
(node-find nd2 (cdr key) (if (eq? k2 sublist-begin) 1 0)))]
|
||||
[(pair? k)
|
||||
; Linearize the tree structure of the key.
|
||||
(define key2 (cons sublist-begin (append k (cons sublist-end (cdr key)))))
|
||||
(node-find nd key2 0)]
|
||||
#:else
|
||||
(define nd2 (hash-ref edges k #false))
|
||||
(when nd2
|
||||
(node-find nd2 (cdr key) 0)))))
|
||||
|
||||
;; Both find and inverse-find at the same time.
|
||||
;; Useful when (full) unification must be performed afterwards.
|
||||
;; WARNING: A LOT OF CODE DUPLICATION WITH THE ABOVE 2 FUNCTIONS.
|
||||
(define (trie-both-find atrie key on-leaf)
|
||||
(define variable? (trie-variable? atrie))
|
||||
(let node-find ([nd (trie-root atrie)] [key (list key)] [depth 0])
|
||||
(define edges (trie-node-edges nd))
|
||||
(cond/else
|
||||
[(> depth 0)
|
||||
; If the depth is positive, that means we are currently matching a variable.
|
||||
; Consume everything until we find a sublist-end at depth 1.
|
||||
; We need to continue through every branch and decrease the depth only if we encounter
|
||||
; a sublist-end, and increase the counter if we encounter a sublist-begin.
|
||||
; Note that key can be empty while depth > 0.
|
||||
(for([(k2 nd2) (in-hash edges)])
|
||||
(node-find nd2 key
|
||||
(cond [(eq? k2 sublist-begin) (+ depth 1)]
|
||||
[(eq? k2 sublist-end) (- depth 1)]
|
||||
[else depth])))]
|
||||
[(empty? key)
|
||||
; Leaf found.
|
||||
(unless (eq? no-value (trie-node-value nd))
|
||||
(on-leaf nd))]
|
||||
#:else
|
||||
(define k (car key))
|
||||
(define var-nd (hash-ref (trie-node-edges nd) anyvar #false))
|
||||
#:cond
|
||||
[(variable? k)
|
||||
;; Anything matches. For sublist we need to keep track of the depth.
|
||||
;; Note that variables in the tree can only be matched if k is a variable.
|
||||
(for ([(k2 nd2) (in-hash edges)])
|
||||
(node-find nd2 (cdr key) (if (eq? k2 sublist-begin) 1 0)))]
|
||||
#:else
|
||||
(when var-nd
|
||||
; The node contains a variable, which thus matches the key.
|
||||
(node-find var-nd (cdr key) 0))
|
||||
#:cond
|
||||
[(pair? k)
|
||||
; Linearize the tree structure of the key.
|
||||
(define key2 (cons sublist-begin (append k (cons sublist-end (cdr key)))))
|
||||
(node-find nd key2 0)]
|
||||
#:else
|
||||
(define nd2 (hash-ref edges k #false))
|
||||
(when nd2
|
||||
(node-find nd2 (cdr key) 0)))))
|
||||
|
||||
|
||||
(define ((make-proc-tree-ref proc) atrie key)
|
||||
(define res '())
|
||||
(proc atrie
|
||||
key
|
||||
(λ (nd) (set! res (cons (trie-node-value nd) res))))
|
||||
res)
|
||||
|
||||
;; Returns a list of values which keys are matched by the given key.
|
||||
;; The matching keys of the trie are necessarily no more general than the given key.
|
||||
;; TODO: We could easily maintain a substitution over the branches since there's only one mach
|
||||
(define trie-inverse-ref (make-proc-tree-ref trie-inverse-find))
|
||||
(define trie-ref (make-proc-tree-ref trie-find))
|
||||
(define trie-both-ref (make-proc-tree-ref trie-both-find))
|
||||
|
||||
(define (trie-values atrie)
|
||||
(let loop ([nd (trie-root atrie)] [res '()])
|
||||
(define edges (trie-node-edges nd))
|
||||
(define val (trie-node-value nd))
|
||||
(for/fold ([res (if (eq? val no-value) res (cons val res))])
|
||||
([(key nd2) (in-hash edges)])
|
||||
(loop nd2 res))))
|
||||
@@ -0,0 +1,346 @@
|
||||
#lang racket/base
|
||||
|
||||
;**************************************************************************************;
|
||||
;**** Unification Tree ****;
|
||||
;**************************************************************************************;
|
||||
|
||||
;;; A trie specialized for unifying literals.
|
||||
;;; This is *different* from "substitution trees"
|
||||
;;; (https://link.springer.com/chapter/10.1007%2F3-540-59200-8_52)
|
||||
|
||||
;;; TODO: This should be probably named a Clause-trie instead, since the
|
||||
;;; major difference with the trie is that we are dealing with Clauses, which
|
||||
;;; are lists of literals, and the same Clause can appear in different leaves
|
||||
;;; of the trie. Unification is only one of the operations performed on Clauses.
|
||||
|
||||
;;; * A literal A unifies with a literal B iff there exists a substitution σ s.t. Aσ = Bσ.
|
||||
;;; * A literal A left-unifies with a literal B iff there exists a substitution σ s.t.
|
||||
;;; Aσ = B and Bσ = B
|
||||
;;; The last requirement ensures that left-unifies => unifies.
|
||||
;;; * We call 'sub-varing' a set of literals As the process of replacing each variable occurrence in
|
||||
;;; the As with a fresh variable. Hence, if B=subvar(A) then the variables in B occur only once
|
||||
;;; each in B.
|
||||
|
||||
(require bazaar/cond-else
|
||||
bazaar/debug
|
||||
bazaar/list
|
||||
bazaar/loop
|
||||
bazaar/mutation
|
||||
(except-in bazaar/order atom<=>)
|
||||
define2
|
||||
global
|
||||
racket/list
|
||||
satore/Clause
|
||||
satore/clause
|
||||
satore/misc
|
||||
satore/trie
|
||||
satore/unification)
|
||||
|
||||
(provide (all-defined-out)
|
||||
(all-from-out satore/trie))
|
||||
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
|
||||
;; WARNING: This cannot be applied to input clauses.
|
||||
;; WARNING: To pass Russell's problem, we must
|
||||
;; do 1-to-N resolution (non-binary resolution), OR, maybe,
|
||||
;; binary resolution + unsafe factoring, but the 'resolutions'
|
||||
;; for factoring must be taken into account too.
|
||||
(define-global:boolean *L-resolvent-pruning?* #false
|
||||
'("Discard clauses for which a literal leads to 0 resolvents."
|
||||
"Currently doesn't apply to input clauses."))
|
||||
|
||||
(define-counter n-L-resolvent-pruning 0)
|
||||
|
||||
;========================;
|
||||
;=== Unification Tree ===;
|
||||
;========================;
|
||||
|
||||
;; TODO: Fix naming convention on operations on unification-tree. (utree-?)
|
||||
|
||||
;; Clause-clause: Clause? -> clause ; extract the clause from the Clause object.
|
||||
;; This module does not need to know what a Clause? is, it only needs to be given this extraction
|
||||
;; function. It is however assumed that the Clause is an immutable struct object (or the mutation
|
||||
;; does not concern Clause-clause).
|
||||
(struct unification-tree trie () #:transparent)
|
||||
|
||||
;; Several leaves may have the same clause-idx but different clauses——well, the same clauses
|
||||
;; but ordered differently. It's named `uclause` to make it clear it's not a well-formed clause
|
||||
;; (stands for unordered-clause).
|
||||
(struct utree-leaf (Clause uclause) #:transparent)
|
||||
|
||||
|
||||
(define (make-unification-tree #:constructor [constructor unification-tree]
|
||||
. other-args)
|
||||
(apply make-trie
|
||||
#:constructor constructor
|
||||
#:variable? Var?
|
||||
other-args))
|
||||
|
||||
;; Each literal of the clause cl is added to the tree, and the leaf value at each literal lite is the
|
||||
;; clause, but where the first literal is lit.
|
||||
;; /!\ Thus the clause is *not* sorted according to `sort-clause`.
|
||||
;; Note: We could also keep the clause unchanged and cons the index of the literal,
|
||||
;; that would avoid using up new cons cells, while keeping the clause intact.
|
||||
(define (add-Clause! utree C)
|
||||
(define cl (Clause-clause C))
|
||||
(zip-loop ([(left lit right) cl])
|
||||
;; *****WARNING*****
|
||||
;; The key must be a list! what if the literal is a mere symbol??
|
||||
(define reordered-clause (cons lit (rev-append left right)))
|
||||
(trie-insert! utree lit (utree-leaf C reordered-clause))))
|
||||
|
||||
(define (unification-tree-Clauses utree)
|
||||
(remove-duplicates (map utree-leaf-Clause (append* (trie-values utree))) eq?))
|
||||
|
||||
;; Calls on-unified for each literal of each clause of utree that unifies with lit.
|
||||
;; If a clause cl has n literals that unify with lit, then `on-unified` is called n times.
|
||||
;; on-unified : utree-leaf? subst lit1 lit2 other-lit2s -> void?
|
||||
(define (find-unifiers utree lit on-unified)
|
||||
(trie-both-find utree lit
|
||||
(λ (nd)
|
||||
(define val (trie-node-value nd))
|
||||
(when (list? val)
|
||||
(for ([lf (in-list val)])
|
||||
(define cl (utree-leaf-uclause lf))
|
||||
; Unify only with the first literal, assuming clauses in node-values
|
||||
; are so that the first literal corresponds to the key
|
||||
; (the path from the root)
|
||||
(define lit2 (first cl))
|
||||
(define subst (unify lit2 lit))
|
||||
(when subst
|
||||
(on-unified lf subst lit lit2 (rest cl))))))))
|
||||
|
||||
;; Returns the set of Clauses that *may* left-unify with lit.
|
||||
;; The returned clauses are sorted according to `sort-clause` and duplicate clauses are removed.
|
||||
(define (unification-tree-ref utree lit)
|
||||
; Node values are lists of rules, and trie-ref returns a list of node-values,
|
||||
; hence the append*.
|
||||
(remove-duplicates (append* (map utree-leaf-Clause (trie-ref utree lit))) eq?))
|
||||
|
||||
;; Helper for the resolve/factors functions below.
|
||||
;; Defines a new set of Clauses, and a helper function that creates new Clauses,
|
||||
;; rewrites them, checks for tautologies and add them to the new-Clauses.
|
||||
(define-syntax-rule (define-add-Clause! C new-Clauses add-Clause! rewriter)
|
||||
(begin
|
||||
(define new-Clauses '())
|
||||
(define (add-Clause! lits subst type parents)
|
||||
(define cl (clause-normalize (substitute lits subst)))
|
||||
(define new-C (make-Clause cl (cons C parents) #:type type))
|
||||
; Rewrite
|
||||
(let ([new-C (rewriter new-C)])
|
||||
(unless (Clause-tautology? new-C)
|
||||
(cons! new-C new-Clauses))))))
|
||||
|
||||
|
||||
(define (utree-resolve/select-literal utree C
|
||||
#:? [rewriter (λ (C) C)]
|
||||
#:? [literal-cost literal-size])
|
||||
|
||||
(define cl (Clause-clause C))
|
||||
;; Choose the costliest negative literal if any (for elimination)
|
||||
(define selected-idx
|
||||
(for/fold ([best-idx #false]
|
||||
[best-cost -inf.0]
|
||||
#:result best-idx)
|
||||
([lit (in-list cl)]
|
||||
[idx (in-naturals)]
|
||||
#:when (lnot? lit)) ; negative literals only
|
||||
(define c (literal-cost lit))
|
||||
(if (> c best-cost)
|
||||
(values idx c)
|
||||
(values best-idx best-cost))))
|
||||
|
||||
(zip-loop ([(left lit right) cl]
|
||||
[resolvents '()]
|
||||
[lit-idx 0]
|
||||
#:result (or resolvents '()))
|
||||
(cond
|
||||
[(or (not selected-idx)
|
||||
(= lit-idx selected-idx))
|
||||
|
||||
(define-add-Clause! C new-Clauses add-Clause! rewriter)
|
||||
|
||||
; Find resolvents
|
||||
(find-unifiers utree
|
||||
(lnot lit)
|
||||
(λ (lf subst nlit lit2 rcl2)
|
||||
(add-Clause! (rev-append left (rev-append right rcl2))
|
||||
subst
|
||||
'res
|
||||
(list (utree-leaf-Clause lf)))))
|
||||
(values (rev-append new-Clauses resolvents)
|
||||
(+ 1 lit-idx))]
|
||||
[else
|
||||
(values resolvents
|
||||
(+ 1 lit-idx))])))
|
||||
|
||||
(define (unsafe-factors C #:? [rewriter (λ (C) C)])
|
||||
(define-add-Clause! C factors add-Clause! rewriter)
|
||||
(define cl (Clause-clause C))
|
||||
|
||||
(zip-loop ([(left lit1 right) cl])
|
||||
(define pax (predicate.arity lit1))
|
||||
(zip-loop ([(left2 lit2 right2) right]
|
||||
; Literals are sorted, so no need to go further.
|
||||
#:break (not (equal? pax (predicate.arity lit2))))
|
||||
(define subst (unify lit1 lit2))
|
||||
; We could do left-unify instead, but then we need to do both sides,
|
||||
; at the risk of generating twice as many clauses, so may not be worth it.
|
||||
(when subst
|
||||
(add-Clause! (rev-append left right) ; remove lit1
|
||||
subst
|
||||
'fac
|
||||
'()))))
|
||||
factors)
|
||||
|
||||
(define (utree-resolve+unsafe-factors/select utree C #:? rewriter #:? literal-cost)
|
||||
(rev-append
|
||||
(unsafe-factors C #:rewriter rewriter)
|
||||
(utree-resolve/select-literal utree C
|
||||
#:rewriter rewriter
|
||||
#:literal-cost literal-cost)))
|
||||
|
||||
;; TODO: Deactivate rewriting inside add-candidates!
|
||||
;; Returns the set of Clauses from resolutions between cl and the clauses in utree,
|
||||
;; as well as the factors
|
||||
(define (utree-resolve+unsafe-factors utree C
|
||||
#:? [rewriter (λ (C) C)]
|
||||
#:! L-resolvent-pruning?)
|
||||
;; Used to prevent pruning by L-resolvent-discard.
|
||||
;; This is used to mark the second literals in unsafe factors.
|
||||
(define lit-marks (make-vector (Clause-n-literals C) #false))
|
||||
(define (mark-literal! idx) (vector-set! lit-marks idx #true))
|
||||
(define (literal-marked? idx) (vector-ref lit-marks idx))
|
||||
|
||||
|
||||
(zip-loop ([(left lit right) (Clause-clause C)]
|
||||
[resolvents+factors '()]
|
||||
[lit-idx 0]
|
||||
#:break (not resolvents+factors) ; shortcut
|
||||
#:result (or resolvents+factors '()))
|
||||
|
||||
(define-add-Clause! C new-Clauses add-Clause! rewriter)
|
||||
|
||||
;; Resolutions
|
||||
(find-unifiers utree
|
||||
(lnot lit)
|
||||
(λ (lf subst nlit lit2 rcl2)
|
||||
(add-Clause! (rev-append left (rev-append right rcl2))
|
||||
subst
|
||||
'res
|
||||
(list (utree-leaf-Clause lf)))))
|
||||
;; Unsafe binary factors
|
||||
;; Somewhat efficient implementation since the literals are sorted by predicate.arity.
|
||||
(define pax (predicate.arity lit))
|
||||
(zip-loop ([(left2 lit2 right2) right]
|
||||
[lit2-idx (+ 1 lit-idx)]
|
||||
#:break (not (equal? pax (predicate.arity lit2))))
|
||||
(define subst (unify lit lit2))
|
||||
(when subst
|
||||
(mark-literal! lit2-idx) ; prevents pruning
|
||||
(add-Clause! (rev-append left right) ; remove lit
|
||||
subst
|
||||
'fac
|
||||
'()))
|
||||
(+ 1 lit2-idx))
|
||||
|
||||
;; L-resolvent 'pruning'
|
||||
;; See the principle of implication modulo resolution:
|
||||
;; "A unifying principle for clause elimination in first-order logic", CADE 26.
|
||||
;; which contains other techniques and short proofs of their soundness.
|
||||
;; We return the empty set of resolution, meaning that the selected clause
|
||||
;; can (must) be discarded, i.e., not added to the active set.
|
||||
(cond [(and L-resolvent-pruning?
|
||||
(empty? new-Clauses)
|
||||
(not (literal-marked? lit-idx)))
|
||||
(++n-L-resolvent-pruning)
|
||||
(values #false (+ 1 lit-idx))]
|
||||
[else
|
||||
(values (rev-append new-Clauses resolvents+factors)
|
||||
(+ 1 lit-idx))])))
|
||||
|
||||
;; Returns the first (in any order) Clause C2 such that
|
||||
;; there is a literal of C2 that left-subunifies on a literal of C,
|
||||
;; and (pred C C2).
|
||||
(define (utree-find/any utree C2 pred)
|
||||
(define tested (make-hasheq)) ; don't test the same C2 twice
|
||||
(define cl2 (Clause-clause C2))
|
||||
(let/ec return
|
||||
(for ([lit (in-list cl2)])
|
||||
(trie-find utree lit
|
||||
(λ (nd)
|
||||
(define val (trie-node-value nd))
|
||||
(when (list? val)
|
||||
(for ([lf (in-list val)])
|
||||
(define C (utree-leaf-Clause lf))
|
||||
(hash-ref! tested
|
||||
C
|
||||
(λ ()
|
||||
(when (pred C C2)
|
||||
(return C))
|
||||
#true)))))))
|
||||
#false))
|
||||
|
||||
;; Return all Clauses C that left-subunify on at least one literal and for which (pred C C2).
|
||||
(define (utree-find/all utree C2 pred)
|
||||
(define tested (make-hasheq)) ; don't test the same C2 twice
|
||||
(define cl2 (Clause-clause C2))
|
||||
(define res '())
|
||||
(for ([lit (in-list cl2)])
|
||||
(trie-find utree lit
|
||||
(λ (nd)
|
||||
(define val (trie-node-value nd))
|
||||
(when (list? val)
|
||||
(for ([lf (in-list val)])
|
||||
(define C (utree-leaf-Clause lf))
|
||||
(hash-ref! tested
|
||||
C
|
||||
(λ ()
|
||||
(when (pred C C2)
|
||||
(set! res (cons C res)))
|
||||
#true)))))))
|
||||
res)
|
||||
|
||||
;; Removes the Clause C from the utree.
|
||||
(define (utree-remove-Clause! utree C)
|
||||
(define cl (Clause-clause C))
|
||||
(for ([lit (in-list cl)])
|
||||
(trie-find utree lit
|
||||
(λ (nd)
|
||||
(define val (trie-node-value nd))
|
||||
(when (list? val)
|
||||
(set-trie-node-value! nd
|
||||
(filter-not (λ (lf2) (eq? C (utree-leaf-Clause lf2)))
|
||||
val)))))))
|
||||
|
||||
;; Finds the leaves for which C loosely left-unifies on some literal and remove those which clause C2
|
||||
;; where (pred C C2).
|
||||
;; Returns the set of Clauses that have been removed.
|
||||
;; pred: Clause? Clause? -> boolean
|
||||
(define (utree-inverse-find/remove! utree C pred)
|
||||
; Since the same Clause may match multiple times,
|
||||
; We use a hash to remember which clauses have already been tested (and if the result
|
||||
; was #true or #false).
|
||||
; Then remove all the leaves of each clause to remove.
|
||||
(define tested (make-hasheq))
|
||||
(define Clauses-to-remove '())
|
||||
(define cl (Clause-clause C))
|
||||
(for ([lit (in-list cl)])
|
||||
(trie-inverse-find utree lit
|
||||
(λ (nd)
|
||||
(define val (trie-node-value nd))
|
||||
(when (list? val)
|
||||
(for ([lf (in-list (trie-node-value nd))])
|
||||
(define C2 (utree-leaf-Clause lf))
|
||||
(hash-ref! tested
|
||||
C2
|
||||
(λ ()
|
||||
(cond [(pred C C2)
|
||||
(cons! C2 Clauses-to-remove)
|
||||
#true]
|
||||
[else #false]))))))))
|
||||
(for ([C2 (in-list Clauses-to-remove)])
|
||||
(utree-remove-Clause! utree C2))
|
||||
Clauses-to-remove)
|
||||
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user