mirror of
https://github.com/RAIRLab/Spectra.git
synced 2025-06-09 14:14:09 +00:00
505 lines
27 KiB
Common Lisp
505 lines
27 KiB
Common Lisp
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
|
|
;;; File: code-for-numbers3.lisp
|
|
;;; The contents of this file are subject to the Mozilla Public License
|
|
;;; Version 1.1 (the "License"); you may not use this file except in
|
|
;;; compliance with the License. You may obtain a copy of the License at
|
|
;;; http://www.mozilla.org/MPL/
|
|
;;;
|
|
;;; Software distributed under the License is distributed on an "AS IS"
|
|
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
|
|
;;; License for the specific language governing rights and limitations
|
|
;;; under the License.
|
|
;;;
|
|
;;; The Original Code is SNARK.
|
|
;;; The Initial Developer of the Original Code is SRI International.
|
|
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
|
|
;;; All Rights Reserved.
|
|
;;;
|
|
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
|
|
|
|
(in-package :snark)
|
|
|
|
;;; SNARK can evaluate arithmetic expressions as if by table lookup
|
|
;;; for procedurally attached relations and functions
|
|
;;;
|
|
;;; most of what SNARK "knows" about numbers is limited by this notion of table lookup;
|
|
;;; few if any more general properties are known
|
|
;;; like (= (+ x 0) x), (= (* x 0) 0), (exists (x) (< x 0)),
|
|
;;; associativity and commutativity of + and *, etc.
|
|
;;;
|
|
;;; this is intended to provide simple arithmetic calculation and not much if any symbolic algebra
|
|
;;;
|
|
;;; SNARK numbers are represented by Lisp rational numbers (integers or ratios)
|
|
;;; and complex numbers with rational real and imaginary parts
|
|
;;;
|
|
;;; floating-point numbers are replaced by rationals when input
|
|
;;;
|
|
;;; SNARK number type hierarchy: number = complex > real > rational > integer
|
|
;;;
|
|
;;; arithmetic relations are encoded in terms of $less
|
|
;;; using lexicographic ordering of complex numbers
|
|
;;; that also enables additive cancellation law
|
|
;;; and multiplicative cancellation law for multiplication by nonzero reals
|
|
|
|
(defvar *sum*)
|
|
(defvar *product*)
|
|
(defvar *less*)
|
|
(defvar *reciprocal*)
|
|
|
|
(defun rnumberp (x)
|
|
;; test for SNARK number, no floats
|
|
(or (rationalp x) (and (complexp x) (rationalp (realpart x)) (rationalp (imagpart x)))))
|
|
|
|
(defun nonzero-rnumberp (x)
|
|
(and (rnumberp x) (neql 0 x)))
|
|
|
|
(defun nonzero-rationalp (x)
|
|
(and (rationalp x) (neql 0 x)))
|
|
|
|
(defun less? (x y)
|
|
;; extend < to total lexicographic ordering of complex numbers so that
|
|
;; a < b or a = b or a > b
|
|
;; a < b iff a+c < b+c
|
|
;; a < b iff a*c < b*c (real c>0)
|
|
;; a < b iff a*c > b*c (real c<0)
|
|
(or (< (realpart x) (realpart y))
|
|
(and (= (realpart x) (realpart y))
|
|
(< (imagpart x) (imagpart y)))))
|
|
|
|
(defun lesseq? (x y)
|
|
(or (= x y) (less? x y)))
|
|
|
|
(defun greater? (x y)
|
|
(less? y x))
|
|
|
|
(defun greatereq? (x y)
|
|
(lesseq? y x))
|
|
|
|
(defun euclidean-quotient (number &optional (divisor 1))
|
|
(mvlet (((values quotient remainder) (truncate number divisor)))
|
|
(if (minusp remainder)
|
|
(if (plusp divisor)
|
|
(values (- quotient 1) (+ remainder divisor))
|
|
(values (+ quotient 1) (- remainder divisor)))
|
|
(values quotient remainder))))
|
|
|
|
(defun euclidean-remainder (number &optional (divisor 1))
|
|
;; 0 <= remainder < abs(divisor)
|
|
(nth-value 1 (euclidean-quotient number divisor)))
|
|
|
|
(defun ceiling-remainder (number &optional (divisor 1))
|
|
(nth-value 1 (ceiling number divisor)))
|
|
|
|
(defun round-remainder (number &optional (divisor 1))
|
|
(nth-value 1 (round number divisor)))
|
|
|
|
(defun declare-arithmetic-characteristic-relation (name pred sort &rest options)
|
|
(apply 'declare-characteristic-relation name pred sort :constraint-theory 'arithmetic options))
|
|
|
|
(defun declare-arithmetic-relation (name arity &rest options)
|
|
(apply 'declare-relation2 name arity
|
|
:constraint-theory 'arithmetic
|
|
`(,@options :sort ((t number)))))
|
|
|
|
(defun declare-arithmetic-function (name arity &rest options &key (sort 'number) &allow-other-keys)
|
|
(apply 'declare-function2 name arity
|
|
:constraint-theory 'arithmetic
|
|
(if (consp sort) options `(:sort (,sort (t number)) ,@options))))
|
|
|
|
(defun declare-code-for-numbers ()
|
|
(declare-constant 0)
|
|
(declare-constant 1)
|
|
(declare-constant -1)
|
|
|
|
(declare-arithmetic-characteristic-relation '$$numberp #'rnumberp 'number)
|
|
(declare-arithmetic-characteristic-relation '$$complexp #'rnumberp 'complex) ;all Lisp numbers are SNARK complex numbers
|
|
(declare-arithmetic-characteristic-relation '$$realp #'rationalp 'real) ;no floats though
|
|
(declare-arithmetic-characteristic-relation '$$rationalp #'rationalp 'rational)
|
|
(declare-arithmetic-characteristic-relation '$$integerp #'integerp 'integer)
|
|
(declare-arithmetic-characteristic-relation '$$naturalp #'naturalp 'natural)
|
|
|
|
(declare-arithmetic-inequality-relations)
|
|
|
|
(setf *sum* (declare-arithmetic-function '$$sum 2
|
|
:associative t
|
|
:commutative t
|
|
:sort 'number :sort-code 'arithmetic-term-sort-computer1
|
|
:rewrite-code (list #'(lambda (x s) (arithmetic-term-rewriter3 x s #'+ 0 none))
|
|
'sum-term-rewriter1)
|
|
:arithmetic-relation-rewrite-code 'sum-rel-number-atom-rewriter))
|
|
|
|
(setf *product* (declare-arithmetic-function '$$product 2
|
|
:associative t
|
|
:commutative t
|
|
:sort 'number :sort-code 'arithmetic-term-sort-computer1
|
|
:rewrite-code (list #'(lambda (x s) (arithmetic-term-rewriter3 x s #'* 1 0))
|
|
#'(lambda (x s) (distributivity-rewriter x s *sum*)))
|
|
:arithmetic-relation-rewrite-code 'product-rel-number-atom-rewriter))
|
|
|
|
(declare-arithmetic-function '$$uminus 1 :sort 'number :sort-code 'arithmetic-term-sort-computer1 :rewrite-code 'uminus-term-rewriter)
|
|
(declare-arithmetic-function '$$difference 2 :sort 'number :sort-code 'arithmetic-term-sort-computer1 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter5 x s *sum* '$$uminus)))
|
|
|
|
(declare-arithmetic-function '$$floor 1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'floor)))
|
|
(declare-arithmetic-function '$$ceiling 1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'ceiling)))
|
|
(declare-arithmetic-function '$$truncate 1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'truncate)))
|
|
(declare-arithmetic-function '$$round 1 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter4 x s #'round)))
|
|
|
|
;; partial, guard against division by zero
|
|
(declare-arithmetic-function '$$quotient_f 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'floor)))
|
|
(declare-arithmetic-function '$$quotient_c 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'ceiling)))
|
|
(declare-arithmetic-function '$$quotient_t 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'truncate)))
|
|
(declare-arithmetic-function '$$quotient_r 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'round)))
|
|
(declare-arithmetic-function '$$quotient_e 2 :sort 'integer :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'euclidean-quotient)))
|
|
(declare-arithmetic-function '$$remainder_f 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'mod)))
|
|
(declare-arithmetic-function '$$remainder_c 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'ceiling-remainder)))
|
|
(declare-arithmetic-function '$$remainder_t 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'rem)))
|
|
(declare-arithmetic-function '$$remainder_r 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'round-remainder)))
|
|
(declare-arithmetic-function '$$remainder_e 2 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rationalp #'euclidean-remainder)))
|
|
|
|
;; partial, guard against division by zero
|
|
(setf *reciprocal* (declare-arithmetic-function '$$reciprocal 1
|
|
:sort 'number :sort-code 'arithmetic-term-sort-computer2
|
|
:rewrite-code #'(lambda (x s) (arithmetic-term-rewriter2 x s #'rnumberp #'/))
|
|
:arithmetic-relation-rewrite-code 'reciprocal-rel-number-atom-rewriter))
|
|
(declare-arithmetic-function '$$quotient 2 :sort 'number :sort-code 'arithmetic-term-sort-computer2 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter5 x s *product* '$$reciprocal)))
|
|
|
|
;; abs of complex numbers might be irrational
|
|
(declare-arithmetic-function '$$abs 1 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter1 x s #'rationalp #'abs)))
|
|
|
|
(declare-arithmetic-function '$$realpart 1 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter1 x s #'rnumberp #'realpart)))
|
|
(declare-arithmetic-function '$$imagpart 1 :sort 'real :sort-code 'arithmetic-term-sort-computer3 :rewrite-code #'(lambda (x s) (arithmetic-term-rewriter1 x s #'rnumberp #'imagpart)))
|
|
nil)
|
|
|
|
(defun declare-arithmetic-inequality-relations ()
|
|
(setf *less* (declare-arithmetic-relation '$$$less 2
|
|
:rewrite-code (list 'irreflexivity-rewriter
|
|
#'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'less?))
|
|
'arithmetic-relation-rewriter
|
|
'term-rel-term-to-0-rel-difference-atom-rewriter)
|
|
:falsify-code 'irreflexivity-falsifier))
|
|
(declare-arithmetic-relation '$$$greater 2 :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter4 x s '$$$less t nil)))
|
|
(declare-arithmetic-relation '$$$lesseq 2 :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter4 x s '$$$less t t)))
|
|
(declare-arithmetic-relation '$$$greatereq 2 :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter4 x s '$$$less nil t)))
|
|
(let ((inputter
|
|
(let ((done nil))
|
|
(function
|
|
(lambda (head args polarity)
|
|
(declare (ignorable head args polarity))
|
|
(unless done
|
|
(setf done t)
|
|
(assert '(forall (x) (not ($$less x x))) :name :$$less-is-irreflexive)
|
|
(assert '(forall (x) (not ($$greater x x))) :name :$$greater-is-irreflexive)
|
|
(assert '(forall (x) ($$lesseq x x)) :name :$$lesseq-is-reflexive)
|
|
(assert '(forall (x) ($$greatereq x x)) :name :$$greatereq-is-reflexive)
|
|
(assert '(forall ((x number) (y number)) (implied-by ($$less x y) ($$$less x y))) :name :solve-$$less-by-$$$less)
|
|
(assert '(forall ((x number) (y number)) (implied-by ($$greater x y) ($$$less y x))) :name :solve-$$greater-by-$$$less)
|
|
(assert '(forall ((x number) (y number)) (implied-by ($$lesseq x y) (not ($$$less y x)))) :name :solve-$$lesseq-by-$$$less)
|
|
(assert '(forall ((x number) (y number)) (implied-by ($$greatereq x y) (not ($$$less x y)))) :name :solve-$$greatereq-by-$$$less)
|
|
(assert '(forall ((x number) (y number)) (implied-by (not ($$less x y)) (not ($$$less x y)))) :name :solve-~$$less-by-$$$less)
|
|
(assert '(forall ((x number) (y number)) (implied-by (not ($$greater x y)) (not ($$$less y x)))) :name :solve-~$$greater-by-$$$less)
|
|
(assert '(forall ((x number) (y number)) (implied-by (not ($$lesseq x y)) ($$$less y x))) :name :solve-~$$lesseq-by-$$$less)
|
|
(assert '(forall ((x number) (y number)) (implied-by (not ($$greatereq x y)) ($$$less x y))) :name :solve-~$$greatereq-by-$$$less))
|
|
none)))))
|
|
(declare-relation '$$less 2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'less?)))
|
|
(declare-relation '$$greater 2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'greater?)))
|
|
(declare-relation '$$lesseq 2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'lesseq?)))
|
|
(declare-relation '$$greatereq 2 :input-code inputter :rewrite-code #'(lambda (x s) (arithmetic-atom-rewriter1 x s #'rnumberp #'greatereq?))))
|
|
nil)
|
|
|
|
(defun arithmetic-term-sort-computer0 (term subst sort-names default-sort-name)
|
|
;; when sort-names is '(integer rational real) and default-sort-name is number
|
|
;; if all arguments are integers then integer
|
|
;; elif all arguments are rationals then rational
|
|
;; elif all arguments are reals then real
|
|
;; else number
|
|
(let ((top-arg-sort (the-sort (pop sort-names))))
|
|
(dolist (arg (args term) top-arg-sort)
|
|
(let ((arg-sort (term-sort arg subst)))
|
|
(when (or (top-sort? arg-sort)
|
|
(loop
|
|
(cond
|
|
((subsort? arg-sort top-arg-sort)
|
|
(return nil))
|
|
((null sort-names)
|
|
(return t))
|
|
(t
|
|
(setf top-arg-sort (the-sort (pop sort-names)))))))
|
|
(return (the-sort default-sort-name)))))))
|
|
|
|
(defun arithmetic-term-sort-computer1 (term subst)
|
|
(arithmetic-term-sort-computer0 term subst '(integer rational real) 'number))
|
|
|
|
(defun arithmetic-term-sort-computer2 (term subst)
|
|
(arithmetic-term-sort-computer0 term subst '(rational real) 'number))
|
|
|
|
(defun arithmetic-term-sort-computer3 (term subst)
|
|
(arithmetic-term-sort-computer0 term subst '(integer rational) 'real))
|
|
|
|
(defun arithmetic-expr-args (x subst pred)
|
|
;; return dereferenced arguments of x if all satisfy pred; otherwise, return none
|
|
(prog->
|
|
(split-if (args x) subst ->* arg)
|
|
(or (funcall pred arg) (return-from arithmetic-expr-args none))))
|
|
|
|
(defun arithmetic-atom-rewriter1 (atom subst pred operator)
|
|
(let ((args (arithmetic-expr-args atom subst pred)))
|
|
(if (eq none args) none (if (apply operator args) true false))))
|
|
|
|
(defun arithmetic-atom-rewriter4 (atom subst newhead reverse negate)
|
|
;; a<=b -> ~(b<a)
|
|
;; a>b -> b<a
|
|
;; a>=b -> ~(a<b)
|
|
(declare (ignorable subst))
|
|
(let* ((args (args atom))
|
|
(atom* (make-compound* (input-relation-symbol newhead (length args)) (if reverse (reverse args) args))))
|
|
(if negate (negate atom*) atom*)))
|
|
|
|
(defun arithmetic-term-rewriter1 (term subst pred operator)
|
|
(let ((args (arithmetic-expr-args term subst pred)))
|
|
(if (eq none args) none (declare-constant (apply operator args)))))
|
|
|
|
(defun arithmetic-term-rewriter2 (term subst pred operator)
|
|
;; like arithmetic-term-rewriter1 but last argument must be nonzero
|
|
(let ((args (arithmetic-expr-args term subst pred)))
|
|
(if (or (eq none args) (eql 0 (first (last args)))) none (declare-constant (apply operator args)))))
|
|
|
|
(defun arithmetic-term-rewriter3 (term subst operator identity absorber)
|
|
;; combines numerical arguments in sum and product terms
|
|
(let* ((head (head term))
|
|
(args (args term))
|
|
(args* (argument-list-a1 head args subst identity)))
|
|
(cond
|
|
((null args*)
|
|
identity)
|
|
((null (rest args*))
|
|
(first args*))
|
|
(t
|
|
(mvlet (((values nums nonnums) (split-if #'rnumberp args* subst)))
|
|
(cond
|
|
((null nums)
|
|
(if (eq args args*) none (make-compound* head args*)))
|
|
(t
|
|
(let ((num (if (null (rest nums)) (first nums) (declare-constant (apply operator nums)))))
|
|
(cond
|
|
((eql absorber num)
|
|
num)
|
|
((eql identity num)
|
|
(make-a1-compound* head identity nonnums))
|
|
((and (eq args args*) (null (rest nums)) (let ((arg1 (first args))) (dereference arg1 subst :if-constant (eql num arg1))))
|
|
none)
|
|
(t
|
|
(make-a1-compound* head identity num nonnums)))))))))))
|
|
|
|
(defun arithmetic-term-rewriter4 (term subst operator)
|
|
;; for floor, ceiling, truncate, and round
|
|
(let ((arg (first (args term))))
|
|
(cond
|
|
((dereference arg subst :if-constant (realp arg))
|
|
(declare-constant (funcall operator arg)))
|
|
((subsort? (term-sort arg subst) (the-sort 'integer))
|
|
arg)
|
|
(t
|
|
none))))
|
|
|
|
(defun arithmetic-term-rewriter5 (term subst op2 op1)
|
|
;; ($$difference a b) -> ($$sum a ($$uminus b))
|
|
;; ($$quotient a b) -> ($$product a ($$reciprocal b))
|
|
(declare (ignorable subst))
|
|
(mvlet (((list a b) (args term)))
|
|
(make-compound (input-function-symbol op2 2) a (make-compound (input-function-symbol op1 1) b))))
|
|
|
|
(defun decompose-product-term (term subst)
|
|
(if (dereference term subst :if-compound-appl t)
|
|
(let ((head (heada term)))
|
|
(if (eq *product* head)
|
|
(mvlet* ((args (args term))
|
|
((values nums nonnums) (split-if #'rnumberp (argument-list-a1 head args subst) subst)))
|
|
(if (and nonnums nums (null (rest nums)) (not (eql 0 (first nums))))
|
|
(values (make-a1-compound* head 1 nonnums) (first nums))
|
|
(values term 1)))
|
|
(values term 1)))
|
|
(values term 1)))
|
|
|
|
(defun sum-term-rewriter1 (term subst)
|
|
;; collect equal arguments into products
|
|
;; ($$sum a a b a) -> ($$sum ($$product 3 a) b)
|
|
;; ($$sum ($$product 2 a b) ($$product b 3 a)) -> ($$product 5 a b))
|
|
(let ((rewritten nil))
|
|
(labels
|
|
((combine-terms (terms)
|
|
(cond
|
|
((null (rest terms))
|
|
terms)
|
|
(t
|
|
(mvlet (((values term1 mult1) (decompose-product-term (first terms) subst)))
|
|
;; combine terms in (rest terms) then find a match for term1 if there is one
|
|
(mvlet* ((mult2 nil)
|
|
((values matches nonmatches) (prog->
|
|
(split-if (combine-terms (rest terms)) subst ->* term2)
|
|
(unless mult2
|
|
(unless (rnumberp term2) ;don't combine numbers
|
|
(mvlet (((values term2 mult) (decompose-product-term term2 subst)))
|
|
(when (equal-p term1 term2 subst)
|
|
(setf mult2 mult))))))))
|
|
(declare (ignorable matches))
|
|
(cond
|
|
(mult2
|
|
(setf rewritten t)
|
|
(let ((mult (declare-constant (+ mult1 mult2))))
|
|
(cond
|
|
((eql 0 mult)
|
|
nonmatches)
|
|
((eql 1 mult)
|
|
(cons term1 nonmatches))
|
|
((dereference term1 subst :if-compound-appl (eq *product* (heada term1)))
|
|
(cons (make-compound* *product* mult (args term1)) nonmatches))
|
|
(t
|
|
(cons (make-compound *product* mult term1) nonmatches)))))
|
|
((eq (rest terms) nonmatches)
|
|
terms)
|
|
(t
|
|
(cons (first terms) nonmatches)))))))))
|
|
(let* ((head (head term))
|
|
(args (argument-list-a1 head (args term) subst))
|
|
(args* (combine-terms args)))
|
|
(if rewritten (make-a1-compound* head 0 args*) none)))))
|
|
|
|
(defun uminus-term-rewriter (term subst)
|
|
;; ($$uminus a) -> ($$product -1 a)
|
|
(declare (ignorable subst))
|
|
(make-compound *product* -1 (first (args term))))
|
|
|
|
(defun arithmetic-relation-rewriter (atom subst)
|
|
(mvlet (((list a b) (args atom)))
|
|
(or (dereference2
|
|
a b subst
|
|
:if-constant*compound (and (rnumberp a)
|
|
(let ((fn (head b)))
|
|
(dolist (fun (function-arithmetic-relation-rewrite-code fn) nil)
|
|
(let ((v (funcall fun atom subst)))
|
|
(unless (eq none v)
|
|
(pushnew (function-code-name fn) *rewrites-used*)
|
|
(return v))))))
|
|
:if-compound*constant (and (rnumberp b)
|
|
(let ((fn (head a)))
|
|
(dolist (fun (function-arithmetic-relation-rewrite-code fn) nil)
|
|
(let ((v (funcall fun atom subst)))
|
|
(unless (eq none v)
|
|
(pushnew (function-code-name fn) *rewrites-used*)
|
|
(return v)))))))
|
|
none)))
|
|
|
|
(defun term-rel-term-to-0-rel-difference-atom-rewriter (atom subst)
|
|
(mvlet ((rel (head atom))
|
|
((list a b) (args atom)))
|
|
(cl:assert (eq *less* rel))
|
|
(cond
|
|
((dereference2
|
|
a b subst
|
|
:if-variable*compound (variable-occurs-p a b subst)
|
|
:if-compound*variable (variable-occurs-p b a subst)
|
|
:if-constant*compound (and (not (rnumberp a)) (constant-occurs-p a b subst))
|
|
:if-compound*constant (and (not (rnumberp b)) (constant-occurs-p b a subst))
|
|
:if-compound*compound t)
|
|
(pushnew (function-code-name *product*) *rewrites-used*)
|
|
(pushnew (function-code-name *sum*) *rewrites-used*)
|
|
(make-compound rel 0 (make-compound *sum* b (make-compound *product* -1 a))))
|
|
(t
|
|
none))))
|
|
|
|
(defun sum-rel-number-atom-rewriter (atom subst)
|
|
;; (eq (sum 2 c) 6) -> (eq c 4) and (less 6 (sum 2 c)) -> (less 4 c) etc.
|
|
(mvlet ((rel (head atom))
|
|
((list a b) (args atom)))
|
|
(cl:assert (or (eq *less* rel) (eq *=* rel)))
|
|
(or (dereference
|
|
a subst
|
|
:if-constant (and (rnumberp a)
|
|
(dereference
|
|
b subst
|
|
:if-compound (and (eq *sum* (head b))
|
|
(let* ((args (args b)) (arg1 (first args)))
|
|
(and (rnumberp arg1)
|
|
(make-compound (head atom) (declare-constant (- a arg1)) (make-a1-compound* *sum* 0 (rest args))))))))
|
|
:if-compound (and (eq *sum* (head a))
|
|
(dereference
|
|
b subst
|
|
:if-constant (and (rnumberp b)
|
|
(let* ((args (args a)) (arg1 (first args)))
|
|
(and (rnumberp arg1)
|
|
(make-compound (head atom) (make-a1-compound* *sum* 0 (rest args)) (declare-constant (- b arg1)))))))))
|
|
none)))
|
|
|
|
(defun product-rel-number-atom-rewriter (atom subst)
|
|
;; like sum-rel-number-atom-rewriter, but don't divide by zero, and reverse arguments when dividing by negative number
|
|
(mvlet ((rel (head atom))
|
|
((list a b) (args atom)))
|
|
(cl:assert (or (eq *less* rel) (eq *=* rel)))
|
|
(or (dereference
|
|
a subst
|
|
:if-constant (and (rnumberp a)
|
|
(dereference
|
|
b subst
|
|
:if-compound (and (eq *product* (head b))
|
|
(let* ((args (args b)) (arg1 (first args)))
|
|
(and (if (eq *less* rel) (nonzero-rationalp arg1) (nonzero-rnumberp arg1))
|
|
(if (and (eq *less* rel) (minusp arg1))
|
|
(make-compound (head atom) (make-a1-compound* *product* 0 (rest args)) (declare-constant (/ a arg1)))
|
|
(make-compound (head atom) (declare-constant (/ a arg1)) (make-a1-compound* *product* 0 (rest args)))))))))
|
|
:if-compound (and (eq *product* (head a))
|
|
(dereference
|
|
b subst
|
|
:if-constant (and (rnumberp b)
|
|
(let* ((args (args a)) (arg1 (first args)))
|
|
(and (if (eq *less* rel) (nonzero-rationalp arg1) (nonzero-rnumberp arg1))
|
|
(if (and (eq *less* rel) (minusp arg1))
|
|
(make-compound (head atom) (declare-constant (/ b arg1)) (make-a1-compound* *product* 0 (rest args)))
|
|
(make-compound (head atom) (make-a1-compound* *product* 0 (rest args)) (declare-constant (/ b arg1))))))))))
|
|
none)))
|
|
|
|
(defun reciprocal-rel-number-atom-rewriter (atom subst)
|
|
(mvlet ((rel (head atom))
|
|
((list a b) (args atom)))
|
|
(cl:assert (or (eq *less* rel) (eq *=* rel)))
|
|
(cond
|
|
((eq *less* rel)
|
|
none)
|
|
(t
|
|
(or (dereference
|
|
a subst
|
|
:if-constant (and (nonzero-rnumberp a)
|
|
(dereference
|
|
b subst
|
|
:if-compound (and (eq *reciprocal* (head b))
|
|
(make-compound (head atom) (declare-constant (/ a)) (arg1 b)))))
|
|
:if-compound (and (eq *reciprocal* (head a))
|
|
(dereference
|
|
b subst
|
|
:if-constant (and (nonzero-rnumberp b)
|
|
(make-compound (head atom) (arg1 a) (declare-constant (/ b)))))))
|
|
none)))))
|
|
|
|
(defmethod checkpoint-theory ((theory (eql 'arithmetic)))
|
|
nil)
|
|
|
|
(defmethod uncheckpoint-theory ((theory (eql 'arithmetic)))
|
|
nil)
|
|
|
|
(defmethod restore-theory ((theory (eql 'arithmetic)))
|
|
nil)
|
|
|
|
(defmethod theory-closure ((theory (eql 'arithmetic)))
|
|
nil)
|
|
|
|
(defmethod theory-assert (atom (theory (eql 'arithmetic)))
|
|
(declare (ignorable atom))
|
|
nil)
|
|
|
|
(defmethod theory-deny (atom (theory (eql 'arithmetic)))
|
|
(declare (ignorable atom))
|
|
nil)
|
|
|
|
(defmethod theory-simplify (wff (theory (eql 'arithmetic)))
|
|
wff)
|
|
|
|
;;; code-for-numbers3.lisp EOF
|