mirror of
https://github.com/google-deepmind/deepmind-research.git
synced 2026-05-28 02:35:47 +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
@@ -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)))
|
||||
Reference in New Issue
Block a user