diff options
| author | Camm Maguire <camm@debian.org> | 2017-05-08 12:58:52 -0400 |
|---|---|---|
| committer | Camm Maguire <camm@debian.org> | 2017-05-08 12:58:52 -0400 |
| commit | 092176848cbfd27b96c323cc30c54dff4c4a6872 (patch) | |
| tree | 91b91b4db76805fd2a09de0745b22080a9ebd335 /books/workshops/2003 | |
Import acl2_7.4dfsg.orig.tar.gz
[dgit import orig acl2_7.4dfsg.orig.tar.gz]
Diffstat (limited to 'books/workshops/2003')
220 files changed, 57505 insertions, 0 deletions
diff --git a/books/workshops/2003/README b/books/workshops/2003/README new file mode 100644 index 0000000..b95d47b --- /dev/null +++ b/books/workshops/2003/README @@ -0,0 +1,4 @@ +# The following do not have any supporting materials with certifiable books: +gamboa-patterson/support +gamboa_lit-programming/support +manolios-vroon diff --git a/books/workshops/2003/austel/abs-type.pdf.gz b/books/workshops/2003/austel/abs-type.pdf.gz Binary files differnew file mode 100644 index 0000000..5d7e9d2 --- /dev/null +++ b/books/workshops/2003/austel/abs-type.pdf.gz diff --git a/books/workshops/2003/austel/abs-type.ps.gz b/books/workshops/2003/austel/abs-type.ps.gz Binary files differnew file mode 100644 index 0000000..1a555ad --- /dev/null +++ b/books/workshops/2003/austel/abs-type.ps.gz diff --git a/books/workshops/2003/austel/slides.pdf.gz b/books/workshops/2003/austel/slides.pdf.gz Binary files differnew file mode 100644 index 0000000..f5440fa --- /dev/null +++ b/books/workshops/2003/austel/slides.pdf.gz diff --git a/books/workshops/2003/austel/slides.ps.gz b/books/workshops/2003/austel/slides.ps.gz Binary files differnew file mode 100644 index 0000000..1a396ef --- /dev/null +++ b/books/workshops/2003/austel/slides.ps.gz diff --git a/books/workshops/2003/austel/support/abs-type.lisp b/books/workshops/2003/austel/support/abs-type.lisp new file mode 100644 index 0000000..b0b1d3b --- /dev/null +++ b/books/workshops/2003/austel/support/abs-type.lisp @@ -0,0 +1,777 @@ +(in-package "ACL2")
+
+#|
+Events accompanying "Implementing abstract types in ACL2",
+by Vernon Austel
+|#
+
+;; Events for the simple example concerning lists.
+(defun listfix (x)
+ (if (endp x)
+ nil
+ (cons (car x) (listfix (cdr x)))))
+
+(defun list= (x y)
+ (equal (listfix x) (listfix y)))
+
+(defequiv list=)
+
+(defthm listfix-listfix
+ (equal (listfix (listfix x))
+ (listfix x)))
+
+(defthm list=-listfix
+ (list= (listfix x) x))
+
+(defcong list= list= (cons x y) 2)
+(defcong list= equal (car x) 1)
+
+(defthm not-consp-list=-nil
+ (implies (not (consp l))
+ (list= l nil))
+ :rule-classes :forward-chaining)
+
+(defthm listfix-append
+ (equal (listfix (append x y))
+ (append (listfix x) (listfix y))))
+
+(defcong list= list= (append x y) 1)
+(defcong list= list= (append x y) 2)
+
+(in-theory (disable list=))
+
+
+(defthm list=-append-nil
+ (list= (append l nil) l))
+
+
+
+
+;; Events concerning the expression evaluation example.
+
+;; the defcong-fix macro
+(progn
+ ;; don't use: (defstub-equiv defcong-equiv2)
+ ;; because this expands into a formula using x, y and z,
+ ;; and this causes problems with variable capture in functional instantiation
+ (encapsulate
+ (((defcong-equiv2 * *) => *))
+
+ (local (defun defcong-equiv2 (x y) (equal x y)))
+
+ (defthm defcong-equiv2-is-an-equivalence
+ (and (booleanp (defcong-equiv2 xxx yyy))
+ (defcong-equiv2 xxx xxx)
+ (implies (defcong-equiv2 xxx yyy)
+ (defcong-equiv2 yyy xxx))
+ (implies (and (defcong-equiv2 xxx yyy)
+ (defcong-equiv2 yyy zzz))
+ (defcong-equiv2 xxx zzz)))
+ :rule-classes (:equivalence))
+ )
+
+
+ (encapsulate
+ (((defcong-equiv1-norm *) => *))
+
+ (local (defun defcong-equiv1-norm (dummy-arg) (declare (ignore dummy-arg)) t))
+
+ (defthm defcong-equiv1-norm-prop
+ (equal (defcong-equiv1-norm (defcong-equiv1-norm xxx))
+ (defcong-equiv1-norm xxx)))
+ )
+
+ (defun defcong-equiv1 (the-value1 the-value2)
+ (equal (defcong-equiv1-norm the-value1) (defcong-equiv1-norm the-value2)))
+ (defequiv defcong-equiv1)
+
+
+ (encapsulate
+ (((defcong-norm-fn *) => *))
+
+ (local (defun defcong-norm-fn (dummy-arg) (declare (ignore dummy-arg)) t))
+
+ (defthm defcong-norm-fn-prop
+ (defcong-equiv2
+ (defcong-norm-fn (defcong-equiv1-norm xxx))
+ (defcong-norm-fn xxx)))
+ )
+
+
+ (defcong defcong-equiv1 defcong-equiv2 (defcong-norm-fn xxx) 1
+ :hints (("Goal" :in-theory (e/d (defcong-equiv1) (defcong-norm-fn-prop))
+ :use ((:instance defcong-norm-fn-prop)
+ (:instance defcong-norm-fn-prop (xxx xxx-equiv))))))
+
+
+ (defmacro if-stable (&rest rest)
+ `(if STABLE-UNDER-SIMPLIFICATIONP
+ ',rest
+ nil))
+
+ (progn
+ (defthm character-listp-first-n-ac
+ (implies (and (character-listp l) (character-listp ac)
+ (<= n (len l)))
+ (character-listp (first-n-ac n l ac)))
+ :hints (("Goal" :expand (first-n-ac n nil ac))))
+
+ (defthm character-listp-take
+ (implies (and (character-listp l) (<= n (len l)))
+ (character-listp (take n l))))
+
+ (in-theory (disable take))
+
+ (defun symchop (sym)
+ (declare (xargs :guard (symbolp sym)))
+ (intern-in-package-of-symbol
+ (coerce (butlast (coerce (symbol-name sym) 'LIST) 1) 'STRING)
+ sym))
+ )
+ (defun symcat (sym suffix)
+ (declare (xargs :guard (and (symbolp sym)
+ (or (symbolp suffix)
+ (stringp suffix)))))
+ (intern-in-package-of-symbol
+ (concatenate 'STRING
+ (symbol-name sym)
+ (if (symbolp suffix)
+ (symbol-name suffix)
+ suffix))
+ sym))
+
+ (defun symchop (sym)
+ (declare (xargs :guard (symbolp sym)))
+ (intern-in-package-of-symbol
+ (coerce (butlast (coerce (symbol-name sym) 'list)
+ 1)
+ 'string)
+ sym))
+
+ (defmacro defcong-fix (equiv1 equiv2 tm n &key (hints 'nil))
+ (let ((defcong-equiv1-norm (symcat (symchop equiv1) 'fix))
+ (xxx (nth n tm)))
+ `(defcong ,equiv1 ,equiv2 ,tm ,n
+ :hints (("Goal"
+ :use (:instance
+ (:functional-instance
+ defcong-equiv1-implies-defcong-equiv2-defcong-norm-fn-1
+ (defcong-equiv2
+ ,equiv2)
+ (defcong-equiv1-norm
+ ,defcong-equiv1-norm)
+ (defcong-equiv1
+ (lambda (x y)
+ (equal (,defcong-equiv1-norm x) (,defcong-equiv1-norm y))))
+ (defcong-norm-fn
+ (lambda (,xxx)
+ ,tm)))
+ (xxx ,xxx)
+ (xxx-equiv ,(symcat xxx '-equiv)))
+ :expand (,equiv1 ,xxx ,(symcat xxx '-equiv)))
+ ,@hints
+
+
+ ;; left to itself, the prover will try induction on the
+ ;; original goal.
+ ;; that strategy fails.
+ ;; we have to make it pick just the one subgoal
+ ;; that needs induction.
+ ;; The particular subgoal varies, so we can't use
+ ;; a literal goalspec.
+ (if-stable :induct t)))))
+ )
+
+
+(defun expr-kind (expr)
+ (cond ((symbolp expr) 'SYMBOL)
+ ((consp expr) 'BINOP)
+ (t 'LIT)))
+
+;; destructors
+(defun binop-op (x)
+ (if (equal (expr-kind x) 'BINOP)
+ (cadr x)
+ nil))
+
+(defun binop-left (expr)
+ (if (equal (expr-kind expr) 'BINOP)
+ (caddr expr)
+ nil))
+
+(defun binop-right (expr)
+ (if (equal (expr-kind expr) 'BINOP)
+ (cadddr expr)
+ nil))
+
+
+;; constructors
+(defun mk-binop (op left right)
+ (list 'BINOP op left right))
+
+(defun litfix (x)
+ (ifix x))
+
+;; fixer
+(defun exprfix (expr)
+ (let ((kind (expr-kind expr)))
+ (case kind
+ (SYMBOL expr)
+
+ (LIT (litfix expr))
+
+ (otherwise
+ (mk-binop (binop-op expr)
+ (exprfix (binop-left expr))
+ (exprfix (binop-right expr)))))))
+
+(defun expr= (x y)
+ (equal (exprfix x) (exprfix y)))
+
+(defequiv expr=)
+
+
+;; congruence rule for the "kind" function.
+(defcong expr= equal (expr-kind expr) 1
+ :hints (("Goal" :expand ((exprfix expr)
+ (exprfix expr-equiv)))))
+
+;; distinguishing between different kinds can be a pain.
+(defthm expr-kind-otherwise
+ (implies (and (not (equal (expr-kind expr) 'lit))
+ (not (equal (expr-kind expr) 'symbol)))
+ (iff (equal (expr-kind expr) 'binop)
+ t)))
+
+(defthm expr-kind-symbol
+ (implies (equal (expr-kind expr) 'SYMBOL)
+ (symbolp expr))
+ :rule-classes :forward-chaining
+ :hints (("Goal" :in-theory (e/d (expr-kind)))))
+
+(defthm expr-kind-lit
+ (implies (equal (expr-kind expr) 'LIT)
+ (not (consp expr)))
+ :rule-classes :forward-chaining
+ :hints (("Goal" :in-theory (e/d (expr-kind)))))
+
+(defthm expr-kind-otherwise-2
+ (implies (and (not (equal (expr-kind expr) 'lit))
+ (not (equal (expr-kind expr) 'symbol)))
+ (consp expr))
+ :rule-classes :forward-chaining
+ :hints (("Goal" :in-theory (e/d (expr-kind)))))
+
+(defthm expand-expr-kind
+ (equal (expr-kind (mk-binop binop left right))
+ 'BINOP)
+ :hints (("Goal" :in-theory (e/d (expr-kind mk-binop)))))
+
+
+
+;; congruences for destructors
+(defcong expr= equal (binop-op expr) 1
+ :hints (("Goal" :expand ((exprfix expr)
+ (exprfix expr-equiv)))))
+
+(defcong expr= expr= (binop-left expr) 1)
+(defcong expr= expr= (binop-right expr) 1)
+
+(defcong expr= expr= (mk-binop bop left right) 2)
+(defcong expr= expr= (mk-binop bop left right) 3)
+
+(defthm exprfix-exprfix
+ (equal (exprfix (exprfix expr))
+ (exprfix expr)))
+
+(defthm expr=-exprfix
+ (expr= (exprfix expr) expr))
+
+
+;; measure lemmas for destructors
+(defthm acl2-count-binop-left
+ (implies (equal (expr-kind expr) 'BINOP)
+ (< (acl2-count (binop-left expr))
+ (acl2-count expr)))
+ :rule-classes (:rewrite :linear))
+
+(defthm acl2-count-binop-right
+ (implies (equal (expr-kind expr) 'BINOP)
+ (< (acl2-count (binop-right expr))
+ (acl2-count expr)))
+ :rule-classes (:rewrite :linear))
+
+;; elimination rules for constructors
+(defthm elim-binop
+ (implies (equal (expr-kind expr) 'BINOP)
+ (expr= (mk-binop (binop-op expr)
+ (binop-left expr)
+ (binop-right expr))
+ expr))
+ :rule-classes (:rewrite :elim))
+
+;; These kinds of expansions are also handy
+(defthm expand-binop-destructors
+ (and (equal (binop-op (mk-binop op left right)) op)
+ (equal (binop-left (mk-binop op left right)) left)
+ (equal (binop-right (mk-binop op left right)) right)))
+
+(defthm integerp-exprfix
+ (equal (integerp (exprfix expr))
+ (and (not (symbolp expr))
+ (not (consp expr)))))
+
+
+(deftheory expr-destructors
+ '(binop-op binop-left binop-right))
+
+(deftheory expr-constructors
+ '(litfix mk-binop))
+
+(in-theory (disable expr-kind))
+(in-theory (disable expr=))
+(in-theory (disable expr-destructors expr-constructors))
+
+
+
+
+
+;; The first example function.
+(defun free-vars (expr)
+ (let ((kind (expr-kind expr)))
+ (case kind
+ (SYMBOL (list expr))
+ (LIT nil)
+ (t (append (free-vars (binop-left expr))
+ (free-vars (binop-right expr)))))))
+
+;; its associated expansion rule
+(defthm expand-free-vars
+ (and (implies (equal (expr-kind expr) 'SYMBOL)
+ (equal (free-vars expr) (list expr)))
+
+ (implies (equal (expr-kind expr) 'LIT)
+ (equal (free-vars expr) nil))
+
+ (equal (free-vars (litfix expr)) nil)
+
+ (equal (free-vars (mk-binop op left right))
+ (append (free-vars left)
+ (free-vars right))))
+ :hints (("Goal" :in-theory (e/d (expr-kind
+ expr-destructors expr-constructors)))))
+
+;; Its congruence theorem
+;; type:
+;; :trans1 (defcong-fix expr= equal (free-vars expr) 1)
+;; at the ACL2 command prompt to see what it turns into
+(defcong-fix expr= equal (free-vars expr) 1)
+
+
+;; We shouldn't need this anymore, although we enable
+;; it for the example inductive proof.
+(in-theory (disable free-vars))
+
+
+#|
+This shows what the congruence proof will look like
+if fixing functions are not used to define the equivalence relation.
+
+(defun expr=-2 (expr y)
+ (let ((kind (expr-kind expr)))
+ (and (equal (expr-kind y) kind)
+ (case kind
+ (SYMBOL (equal y expr))
+
+ (LIT (equal (litfix expr) (litfix y)))
+
+ (otherwise
+ (and (equal (binop-op expr)
+ (binop-op y))
+ (expr=-2 (binop-left expr)
+ (binop-left y))
+ (expr=-2 (binop-right expr)
+ (binop-right y))))))))
+
+
+(defthm expr=-2-thm
+ (iff (expr=-2 x y)
+ (expr= x y))
+ :hints (("Goal"
+ :expand ((exprfix x) (exprfix y))
+ :induct (expr=-2 x y)
+ :in-theory (e/d (expr= expr-kind
+ expr-destructors expr-constructors)))))
+
+(defthm expr=-ind-pat T
+ :rule-classes
+ ((:induction
+ :pattern (expr= x y)
+ :condition t
+ :scheme (expr=-2 x y))))
+
+(defcong expr= equal (free-vars expr) 1
+ :hints (("Goal" :in-theory (e/d (free-vars)))
+ ("Subgoal *1/1" :expand (expr= expr expr-equiv))))
+
+|#
+
+;; The second example function
+(defun eval-expr (expr env)
+ (let ((kind (expr-kind expr)))
+ (case kind
+ (SYMBOL (cdr (assoc expr env)))
+ (LIT (litfix expr))
+ (t (+ (eval-expr (binop-left expr) env)
+ (eval-expr (binop-right expr) env))))))
+
+(defthm expand-eval-expr
+ (and (implies (equal (expr-kind expr) 'SYMBOL)
+ (equal (eval-expr expr env) (cdr (assoc expr env))))
+
+ (implies (equal (expr-kind expr) 'LIT)
+ (equal (eval-expr expr env) (litfix expr)))
+
+ (equal (eval-expr (litfix expr) env) (litfix expr))
+
+ (equal (eval-expr (mk-binop op left right) env)
+ (+ (eval-expr left env)
+ (eval-expr right env))))
+ :hints (("Goal" :in-theory (e/d (expr-destructors expr-constructors)))))
+
+(defthm not-integerp-litfix
+ (implies (not (integerp x))
+ (equal (litfix x) 0))
+ :hints (("Goal" :in-theory (e/d (litfix)))))
+
+(defcong-fix expr= equal (eval-expr expr env) 1)
+
+(in-theory (disable eval-expr))
+
+(defthm true-listp-free-vars
+ (true-listp (free-vars expr))
+ :hints (("Goal" :in-theory (e/d ((:induction free-vars))))))
+
+(defthm consp-append
+ (equal (consp (append x y))
+ (or (consp x) (consp y))))
+
+(defthm env-irrelevant-using-induction
+ (implies (not (consp (free-vars expr)))
+ (equal (eval-expr expr env)
+ (eval-expr expr nil)))
+ :rule-classes nil
+ :hints (("Goal" :in-theory (e/d (eval-expr free-vars)))))
+
+
+;; The constraints for a simple induction on expr=
+(encapsulate
+ ((expr-induct (expr) t))
+
+ (local (defun expr-induct (x) (declare (ignore x)) t))
+
+ (defthm expr-induct-symbol
+ (implies (equal (expr-kind expr) 'SYMBOL)
+ (expr-induct expr)))
+
+ (defthm expr-induct-lit
+ (expr-induct (litfix expr)))
+
+ (defthm expr-induct-binop
+ (implies (and (expr-induct left)
+ (expr-induct right))
+ (expr-induct (mk-binop binop left right))))
+
+ (defcong expr= iff (expr-induct expr) 1)
+ )
+
+
+
+;; the proof that expr-induct is always true.
+(encapsulate
+ nil
+
+ ;; basecases need extra help
+ (local
+ (defthm symbolp-expr-induct
+ (implies (symbolp expr)
+ (expr-induct expr))
+ :hints (("Goal" :in-theory (e/d (expr-kind) (expr-induct-symbol))
+ :use expr-induct-symbol))))
+
+ (local
+ (defthm integerp-expr-induct
+ (implies (integerp expr)
+ (expr-induct expr))
+ :hints (("Goal" :in-theory (e/d (litfix) (expr-induct-lit))
+ :use expr-induct-lit))))
+
+ (local
+ (defthmd expr-induct-thm-exprfix
+ (expr-induct (exprfix expr))
+ :hints (("Goal" :in-theory (e/d () (expr=-implies-iff-expr-induct-1))))))
+
+
+ ;; Then we just allow the congruence rule to fire.
+ (defthm expr-induct-thm
+ (expr-induct expr)
+ :hints (("Goal" :use expr-induct-thm-exprfix)))
+ )
+
+;; prove the same theorem as above using functional instantiation.
+(defthm env-irrelevant
+ (implies (not (consp (free-vars expr)))
+ (equal (eval-expr expr env)
+ (eval-expr expr nil)))
+ :hints (("Goal" :use (:functional-instance
+ expr-induct-thm
+ (expr-induct
+ (lambda (expr)
+ (implies (not (consp (free-vars expr)))
+ (equal (eval-expr expr env)
+ (eval-expr expr nil)))))))))
+
+
+(defmacro defexprthm (name tm)
+ `(defthm ,name
+ ,tm
+ :hints (("Goal"
+ :do-not-induct t
+ :use (:instance
+ (:functional-instance
+ expr-induct-thm
+ (expr-induct (lambda (expr) ,tm))))))))
+
+;; an easier way to do the same thing
+;; (this event will be redundant)
+(defexprthm env-irrelevant
+ (implies (not (consp (free-vars expr)))
+ (equal (eval-expr expr env)
+ (eval-expr expr nil))))
+
+
+
+;; all we know about this function is that it is an
+;; equivalence relation.
+(encapsulate
+ ((expr-fn= (x y) t))
+
+ (local (defun expr-fn= (x y) (equal x y)))
+
+ (defequiv expr-fn=)
+ )
+
+;; these functions serve as placeholders for what
+;; a particular function may do.
+(encapsulate
+ ((expr-symbol-fn (expr) t)
+ (expr-lit-fn (expr) t)
+ (expr-binop-fn (op left $left right $right) t))
+
+ (set-ignore-ok t)
+ (set-irrelevant-formals-ok t)
+
+ (local (defun expr-symbol-fn (expr) t))
+ (local (defun expr-lit-fn (expr) t))
+ (local (defun expr-binop-fn (op left $left right $right) t))
+
+ (defcong expr= expr-fn= (expr-lit-fn expr) 1)
+
+ (defcong expr= expr-fn= (expr-binop-fn op left $left right $right) 2)
+ (defcong expr-fn= expr-fn= (expr-binop-fn op left $left right $right) 3)
+ (defcong expr= expr-fn= (expr-binop-fn op left $left right $right) 4)
+ (defcong expr-fn= expr-fn= (expr-binop-fn op left $left right $right) 5)
+ )
+
+;; now define a "typical" function on expressions.
+(defun expr-fn (expr)
+ (let ((kind (expr-kind expr)))
+ (case kind
+ (SYMBOL (expr-symbol-fn expr))
+ (LIT (expr-lit-fn expr))
+ (t (expr-binop-fn (binop-op expr)
+ (binop-left expr)
+ (expr-fn (binop-left expr))
+ (binop-right expr)
+ (expr-fn (binop-right expr)))))))
+
+
+;; its corresponding expansion
+(defthm expand-expr-fn
+ (and (implies (equal (expr-kind expr) 'SYMBOL)
+ (expr-fn= (expr-fn expr)
+ (expr-symbol-fn expr)))
+
+ (implies (equal (expr-kind expr) 'LIT)
+ (expr-fn= (expr-fn expr)
+ (expr-lit-fn expr)))
+
+ (expr-fn= (expr-fn (litfix expr))
+ (expr-lit-fn (litfix expr)))
+
+ (expr-fn= (expr-fn (mk-binop op left right))
+ (expr-binop-fn op
+ left (expr-fn left)
+ right (expr-fn right))))
+ :hints (("Goal" :in-theory (e/d (expr-kind
+ expr-destructors expr-constructors)))))
+
+;; and its congruence theorem
+;; (similar to the proofs for free-vars and eval-expr)
+(encapsulate
+ nil
+ (local
+ (defthm expr-lit-lemma
+ (implies (and (equal (expr-kind expr) 'LIT)
+ (not (integerp expr)))
+ (expr= expr 0))
+ :rule-classes :forward-chaining
+ :hints (("Goal" :in-theory (e/d (expr= expr-kind))))))
+
+ (defcong-fix expr= expr-fn= (expr-fn expr) 1
+ :hints ((if-stable
+ :in-theory (e/d (litfix) ((expr-fn)))
+ :expand (expr-fn (mk-binop bop (exprfix blt)
+ (exprfix brt))))))
+ )
+
+;; Writing macros like this gets old pretty fast.
+(defun defexpr-fn (expr-fn args expr-fn=
+ expr-symbol-fn
+ expr-lit-fn
+ expr-binop-fn)
+ (declare (xargs :mode :program))
+ `(progn
+ ;; many variables in the BINOP case are unused.
+ ;; ACL2 complains about this.
+ ;; just kludge it for our example.
+ (set-ignore-ok t)
+
+ (defun ,expr-fn ,args
+ (let ((kind (expr-kind expr)))
+ (case kind
+ (SYMBOL ,expr-symbol-fn)
+ (LIT ,expr-lit-fn)
+ (t (let ((op (binop-op expr))
+ (left (binop-left expr))
+ ($left (,expr-fn (binop-left expr)
+ ,@(cdr args)))
+ (right (binop-right expr))
+ ($right (,expr-fn (binop-right expr)
+ ,@(cdr args))))
+ ,expr-binop-fn)))))
+
+ (defthm ,(packn (list 'expand- expr-fn))
+ (and (implies (equal (expr-kind expr) 'SYMBOL)
+ (,expr-fn= (,expr-fn ,@args)
+ ,expr-symbol-fn))
+
+ (implies (equal (expr-kind expr) 'LIT)
+ (,expr-fn= (,expr-fn ,@args)
+ ,expr-lit-fn))
+
+ (,expr-fn= (,expr-fn (litfix expr) ,@(cdr args))
+ (let ((expr (litfix expr)))
+ ,expr-lit-fn))
+
+ (,expr-fn= (,expr-fn (mk-binop op left right) ,@(cdr args))
+ (let (($left (,expr-fn left ,@(cdr args)))
+ ($right (,expr-fn right ,@(cdr args))))
+ ,expr-binop-fn)))
+ :hints (("Goal"
+ :do-not-induct t
+ :use
+ (:functional-instance expand-expr-fn
+ (expr-fn
+ ;; because expr-fn may take more than one arg
+ (lambda (expr)
+ (,expr-fn ,@args)))
+ (expr-fn= ,expr-fn=)
+ (expr-symbol-fn
+ (lambda (expr)
+ ,expr-symbol-fn))
+ (expr-lit-fn
+ (lambda (expr)
+ ,expr-lit-fn))
+ (expr-binop-fn
+ (lambda (op left $left right $right)
+ ,expr-binop-fn))))))
+
+
+ (defthm ,(packn (list 'expr=-implies- expr-fn= '- expr-fn '-1))
+ (implies (expr= expr expr-equiv)
+ (,expr-fn= (,expr-fn expr ,@(cdr args))
+ (,expr-fn expr-equiv ,@(cdr args))))
+ :hints
+ (("Goal"
+ :do-not-induct t
+ :use
+ ;; except for the theorem name,
+ ;; this functional instance is the same as the above
+ (:functional-instance expr=-implies-expr-fn=-expr-fn-1
+ (expr-fn
+ ;; because expr-fn may take more than one arg
+ (lambda (expr)
+ (,expr-fn ,@args)))
+ (expr-fn= ,expr-fn=)
+ (expr-symbol-fn
+ (lambda (expr)
+ ,expr-symbol-fn))
+ (expr-lit-fn
+ (lambda (expr)
+ ,expr-lit-fn))
+ (expr-binop-fn
+ (lambda (op left $left right $right)
+ ,expr-binop-fn)))))
+ :rule-classes ((:congruence)))
+ ))
+
+;; This macro can be made much fancier,
+;; with default arguments and so forth,
+;; but this gives the general idea.
+(defmacro defexpr (expr-fn args expr-fn=
+ &key symbol lit binop)
+ (defexpr-fn expr-fn args expr-fn=
+ symbol lit binop))
+
+
+
+
+;; use the new macro to
+;; define the function
+;; generate its expansion theorem
+;; generate its congruence theorem
+(defexpr variable-free (expr) equal
+ :SYMBOL nil
+ :LIT t
+ :BINOP (and $left $right))
+
+;; not much we can say about this, actually...
+(defexprthm variable-free-lemma
+ (iff (variable-free expr)
+ (not (consp (free-vars expr)))))
+
+;; This would have problems if we constrained expr-symbol-fn above.
+(defexpr expr-subst (expr sbst) expr=
+ :SYMBOL (if (assoc expr sbst)
+ (cdr (assoc expr sbst))
+ expr)
+ :LIT expr
+ :BINOP (mk-binop op $left $right))
+
+(defexprthm eval-expr-expr-subst-nil
+ (equal (eval-expr (expr-subst expr nil) env)
+ (eval-expr expr env)))
+
+
+
+
+;; This is curious, but probably not useful.
+(defthm litfix-elim
+ (implies (equal (expr-kind expr) 'LIT)
+ (expr= (litfix expr) expr))
+ :rule-classes :elim
+ :hints (("Goal" :in-theory (e/d (litfix expr= expr-kind)))))
+
+
+
diff --git a/books/workshops/2003/cowles-gamboa-van-baalen_matrix/matrix.pdf.gz b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/matrix.pdf.gz Binary files differnew file mode 100644 index 0000000..82729c1 --- /dev/null +++ b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/matrix.pdf.gz diff --git a/books/workshops/2003/cowles-gamboa-van-baalen_matrix/matrix.ps.gz b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/matrix.ps.gz Binary files differnew file mode 100644 index 0000000..10656db --- /dev/null +++ b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/matrix.ps.gz diff --git a/books/workshops/2003/cowles-gamboa-van-baalen_matrix/slides.pdf.gz b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/slides.pdf.gz Binary files differnew file mode 100644 index 0000000..8a30ea3 --- /dev/null +++ b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/slides.pdf.gz diff --git a/books/workshops/2003/cowles-gamboa-van-baalen_matrix/slides.ps.gz b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/slides.ps.gz Binary files differnew file mode 100644 index 0000000..08d0446 --- /dev/null +++ b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/slides.ps.gz diff --git a/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/alist2.lisp b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/alist2.lisp new file mode 100644 index 0000000..099f7dc --- /dev/null +++ b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/alist2.lisp @@ -0,0 +1,604 @@ +; The ACL2 two-dimensional Alist Book. +; Copyright (C) 2003 John R. Cowles, University of Wyoming + +; This book is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This book is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this book; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: +; John Cowles +; Department of Computer Science +; University of Wyoming +; Laramie, WY 82071-3682 U.S.A. + + +; Spring 2003 +; Last modified 21 May 2003 + +; This book is similar to the book array2.lisp. + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +To certify at UW: + +:set-cbd "/home/faculty/cowles/acl2/matrix/" ;;pyramid + +:set-cbd "/home/cowles/matrix/" ;;turing + +(certify-book "alist2") +|# +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +To use at UW: + +:set-cbd "/home/faculty/cowles/acl2/matrix/" ;;pyramid + +:set-cbd "/home/cowles/matrix/" ;;turing + +(include-book + "alist2") +|# +(in-package "ACL2") + +;; Logically, an ACL2 two-dimensional array is an alist that satisfies these +;; properties: + +(defun + alist2p (name L) + "Determine if L satisfies the logical properties of an ACL2 array2p. + The ignored argument, name, is there only to make life easier later + when using such standard ACL2 array functions as aref2, aset2, header, + default, etc., that also have such an argument." + (declare (ignore name)(xargs :guard t)) + (and (alistp l) + (let ((header-keyword-list (cdr (assoc-eq :header L)))) + (and (keyword-value-listp header-keyword-list) + (let ((dimensions + (cadr (assoc-keyword :dimensions header-keyword-list)))) + (and (consp dimensions) + (let ((cdr-dim (cdr dimensions))) + (and (consp cdr-dim) + (let ((d1 (car dimensions)) + (d2 (car cdr-dim))) + (and (integerp d1) + (integerp d2) + (< 0 d1) + (< 0 d2) + (bounded-integer-alistp2 L d1 d2))) + )))))))) + +(defthm + array2p-alist2p + (implies (array2p name L) + (alist2p name L))) + +(local + (defthm + assoc-eq-properties + (implies + (and (alistp l) + (assoc-eq x l)) + (and (consp (assoc-eq x l)) + (equal (car (assoc-eq x l)) x))))) + +(local + (defthm + assoc2-properties + (implies + (and (alistp l) + (assoc2 i j l)) + (and (consp (assoc2 i j l)) + (consp (car (assoc2 i j l))) + (equal (car (car (assoc2 i j l))) i) + (equal (cdr (car (assoc2 i j l))) j))))) + +(local + (defthm + assoc-keyword-properties + (implies + (and (alistp l) + (assoc-keyword x l)) + (and (consp (assoc-keyword x l)) + (equal (car (assoc-keyword x l)) x))))) + +(local + (defthm + bounded-integer-alistp2-car-assoc2-properties + (implies + (and (bounded-integer-alistp2 l m n) + (assoc2 i j l)) + (and (integerp (car (car (assoc2 i j l)))) + (integerp (cdr (car (assoc2 i j l)))) + (>= (car (car (assoc2 i j l))) 0) + (>= (cdr (car (assoc2 i j l))) 0) + (< (car (car (assoc2 i j l))) m) + (< (cdr (car (assoc2 i j l))) n))))) + +(local + (defthm alist2p-forward-local + (implies + (alist2p name L) + (and + (alistp L) + (keyword-value-listp (cdr (assoc-eq :header L))) + (consp (cadr (assoc-keyword :dimensions + (cdr (assoc-eq :header L))))) + (consp (cdadr (assoc-keyword :dimensions + (cdr (assoc-eq :header L))))) + (integerp + (car (cadr (assoc-keyword :dimensions + (cdr (assoc-eq :header L)))))) + (integerp + (cadr (cadr (assoc-keyword :dimensions + (cdr (assoc-eq :header L)))))) + (< 0 (car (cadr (assoc-keyword :dimensions + (cdr (assoc-eq :header L)))))) + (< 0 (cadr (cadr (assoc-keyword :dimensions + (cdr (assoc-eq :header L)))))) + (bounded-integer-alistp2 L + (car (cadr (assoc-keyword + :dimensions + (cdr (assoc-eq :header L))))) + (cadr (cadr (assoc-keyword + :dimensions + (cdr (assoc-eq :header L)))))))) + :rule-classes :forward-chaining)) + +(local + (defthm alist2p-header-exists + (implies + (alist2p name L) + (assoc-eq :header L)))) + +(local + (defthm alist2p-cons-1 + (implies + (and (alist2p name L) + (integerp i) + (>= i 0) + (< i (car (dimensions name l))) + (integerp j) + (>= j 0) + (< j (cadr (dimensions name l)))) + (alist2p name (cons (cons (cons i j) val) L))))) + +(local (in-theory (disable alist2p))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;(compress211 name L i x j default) processes array elements +;; L(i x) . . . L(i (- j 1)). + +(local + (defthm + alistp-compress211 + (alistp (compress211 name L i x j default)))) + +(local + (defthm bounded-integer-alistp2-compress211 + (implies + (and (alist2p name L) + (integerp i) + (integerp x) + (integerp k) + (>= x 0) + (>= i 0) + (> k i)) + (bounded-integer-alistp2 (compress211 name L i x j default) + k + j)))) + +(local + (defthm + compress211-assoc2-property-0 + (implies (and (alistp L) + (assoc2 m n L) + (assoc2 m n (compress211 name L i x j default))) + (equal (assoc2 m n (compress211 name L i x j default)) + (assoc2 m n L))))) + +(local + (defthm + compress211-assoc2-property-1 + (implies + (and (not (assoc2 i n (compress211 name L i x j default))) + (alistp L) + (integerp x) + (integerp j) + (integerp n) + (<= x n) + (< n j) + (assoc2 i n L)) + (equal (cdr (assoc2 i n L)) + default)))) + +(local + (defthm + compress211-assoc2-property-2 + (implies + (and (alistp L) + (not (assoc2 m n L))) + (not (assoc2 m n (compress211 name L i x j default)))))) + +(local + (defthm + not-assoc2-compress211 + (implies (and (alistp L) + (not (equal k i))) + (not (assoc2 k m (compress211 name L i x j default))) + ))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;(compress21 name L n i j default) processes array elements +;; L(n 0) . . . L(n (- j 1)) +;; . . . +;; . . . +;; . . . +;; L((- i 1) 0) . . . L((- i 1)(- j 1)) + +(local + (defthm + alistp-append + (implies (and (alistp L1) + (alistp L2)) + (alistp (append L1 L2))))) + +(local + (defthm + alistp-compress21 + (alistp (compress21 name L n i j default)))) + +(local + (defthm + bounded-integer-alistp2-append + (implies (and (bounded-integer-alistp2 L1 i j) + (bounded-integer-alistp2 L2 i j)) + (bounded-integer-alistp2 (append L1 L2) + i + j)))) + +(local + (defthm + bounded-integer-alistp2-compress21 + (implies + (and (alist2p name L) + (integerp i) + (integerp n) + (>= n 0)) + (bounded-integer-alistp2 (compress21 name L n i j default) + i + j)))) + +(local + (defthm + assoc2-append + (equal (assoc2 i j (append L1 L2)) + (if (assoc2 i j L1) + (assoc2 i j L1) + (assoc2 i j L2))))) + +(local + (defthm + compress21-assoc2-property-0 + (implies + (and (alistp L) + (assoc2 k m L) + (assoc2 k m (compress21 name L n i j default))) + (equal (assoc2 k m (compress21 name L n i j default)) + (assoc2 k m L))))) + +(local + (defthm + compress21-assoc2-property-1 + (implies + (and (not (assoc2 k m (compress21 name L n i j default))) + (alistp L) + (integerp i) + (integerp j) + (integerp k) + (integerp m) + (integerp n) + (<= n i) + (<= n k) + (< k i) + (<= 0 m) + (< m j) + (assoc2 k m L)) + (equal (cdr (assoc2 k m L)) + default)) + :hints (("Subgoal *1/5" + :use (:instance + compress211-assoc2-property-1 + (i k) + (n m) + (x 1)))))) + +(local + (defthm + compress21-assoc2-property-2 + (implies + (and (alistp L) + (not (assoc2 k m L))) + (not (assoc2 k m (compress21 name L n i j default)))))) + +(local + (defthm + compress2-assoc2-property-0 + (implies + (and (alistp L) + (assoc2 k m L) + (assoc2 k m (compress2 name L))) + (equal (cdr (assoc2 k m (compress2 name L))) + (cdr (assoc2 k m L)))))) + +(local + (defthm + compress2-assoc2-property-1 + (implies + (and (alist2p name L) + (integerp k) + (integerp m) + (<= 0 k) + (< k (car (dimensions name L))) + (<= 0 m) + (< m (cadr (dimensions name L))) + (assoc2 k m L) + (not (assoc2 k m (compress2 name L)))) + (equal (cdr (assoc2 k m L)) + (cadr (assoc-keyword :default (cdr (assoc-eq :header L)) + )))))) + +(local + (defthm + compress2-assoc2-property-2 + (implies + (and (alistp L) + (not (assoc2 k m L))) + (not (assoc2 k m (compress2 name L)))))) + +(local + (defthm + header-compress2 + (implies + (alist2p name L) + (equal (assoc-eq :header (compress2 name L)) + (assoc-eq :header L))))) + +(defthm + alist2p-compress2 + (implies + (alist2p name L) + (alist2p name (compress2 name L))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((compress2 name L)))) + :hints (("Goal" + :in-theory (enable alist2p)))) + +(defthm + alist2p-compress2-properties + (implies + (alist2p name L) + (and + (equal (header name (compress2 name L)) + (header name L)) + (equal (dimensions name (compress2 name L)) + (dimensions name L)) + (equal (maximum-length name (compress2 name L)) + (maximum-length name L)) + (equal (default name (compress2 name L)) + (default name L))))) + +(local (in-theory (disable compress2))) + +(defthm + alist2p-aset2 + (implies + (and (alist2p name L) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name L))) + (< j (cadr (dimensions name L)))) + (alist2p name (aset2 name L i j val)))) + +(defthm + alist2p-aref2-compress2 + (implies + (and (alist2p name L) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name L))) + (< j (cadr (dimensions name L)))) + (equal (aref2 name (compress2 name L) i j) + (aref2 name L i j)))) + +(defthm + array2p-acons-properties + (and + (equal (header name (cons (cons (cons i j) val) L)) + (header name L)) + (equal (dimensions name (cons (cons (cons i j) val) L)) + (dimensions name L)) + (equal (maximum-length name (cons (cons (cons i j) val) L)) + (maximum-length name L)) + (equal (default name (cons (cons (cons i j) val) L)) + (default name L)))) + +(defthm + alist2p-aset2-properties + (implies + (and (alist2p name L) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name L))) + (< j (cadr (dimensions name L)))) + (and + (equal (header name (aset2 name L i j val)) + (header name L)) + (equal (dimensions name (aset2 name L i j val)) + (dimensions name L)) + (equal (maximum-length name (aset2 name L i j val)) + (maximum-length name L)) + (equal (default name (aset2 name L i j val)) + (default name L))))) + +(defthm + alist2p-consp-header + (implies + (alist2p name L) + (consp (header name L))) + :rule-classes :type-prescription) + +(defthm + alist2p-car-header + (implies + (alist2p name L) + (equal (car (header name L)) + :header))) + +; These two theorems for the ALISR2P-AREF2-ASET2 cases are used to prove a +; combined result, and then exported DISABLEd: +; NOTE: The combined result below can be proved without first proving the +; two cases, but we'll keep these results organized as they were. + +(defthm + alist2p-aref2-aset2-equal + (implies + (and (alist2p name L) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name L))) + (< j (cadr (dimensions name L)))) + (equal (aref2 name (aset2 name L i j val) i j) + val))) + +(defthm + alist2p-aref2-aset2-not-equal + (implies + (and (alist2p name L) + (integerp i1) + (integerp j1) + (>= i1 0) + (>= j1 0) + (< i1 (car (dimensions name L))) + (< j1 (cadr (dimensions name L))) + (integerp i2) + (integerp j2) + (>= i2 0) + (>= j2 0) + (< i2 (car (dimensions name L))) + (< j2 (cadr (dimensions name L))) + (not (and (equal i1 i2) + (equal j1 j2)))) + (equal (aref2 name (aset2 name L i1 j1 val) i2 j2) + (aref2 name L i2 j2)))) + +(defthm + alist2p-aref2-aset2 + (implies + (and (alist2p name L) + (integerp i1) + (integerp j1) + (>= i1 0) + (>= j1 0) + (< i1 (car (dimensions name L))) + (< j1 (cadr (dimensions name L))) + (integerp i2) + (integerp j2) + (>= i2 0) + (>= j2 0) + (< i2 (car (dimensions name L))) + (< j2 (cadr (dimensions name L))) + ) + (equal (aref2 name (aset2 name L i1 j1 val) i2 j2) + (if (and (equal i1 i2) + (equal j1 j2)) + val + (aref2 name l i2 j2))))) + +(in-theory (disable alist2p-aref2-aset2-equal alist2p-aref2-aset2-not-equal)) + +;;; The final form of the :FORWARD-CHAINING lemma for ALIST2P. +;;; A forward definition of (ALIST2P name l), in terms of +;;; HEADER, DIMENSIONS, and MAXIMUM-LENGTH. + +;;; One should normaly DISABLE ALIST2P in favor of this +;;; :FORWARD-CHAINING rule. If allowed to open, ALIST2P can +;;; cause severe performance degradation due to its large size +;;; and many recursive functions. This lemma is designed to be +;;; used with the ALISP2-FUNCTIONS theory DISABLEd. + +;; This forward-chaining rule appears to require the ignored argument, name, +;; in alist2p in order to avoid name as a free variable. +(defthm alist2p-forward-modular + (implies + (alist2p name L) + (and (alistp L) + (keyword-value-listp (cdr (header name L))) + (consp (dimensions name L)) + (consp (cdr (dimensions name L))) + (integerp (car (dimensions name L))) + (integerp (cadr (dimensions name L))) + (< 0 (car (dimensions name L))) + (< 0 (cadr (dimensions name L))) + (bounded-integer-alistp2 L + (car (dimensions name L)) + (cadr (dimensions name L))))) + :rule-classes :forward-chaining) + +(defthm alist2p-linear-modular + (implies + (alist2p name L) + (and (< 0 (car (dimensions name L))) + (< 0 (cadr (dimensions name L))))) + :rule-classes :linear) + +(deftheory + alist2-functions + '(alist2p aset2 aref2 compress2 header dimensions maximum-length + default) +; Matt K. mod 10/30/2015: :doc is no longer supported for deftheory. +; :doc "A theory of all functions specific to 2-dimensional alists. +; This theory must be DISABLEd in order for the lemmas +; exported by the alist2 book to be applicable." + ) + +(deftheory + alist2-lemmas + '(alist2p-compress2 + alist2p-compress2-properties + alist2p-aset2 + alist2p-aset2-properties + alist2p-aref2-compress2 + array2p-acons-properties + alist2p-consp-header + alist2p-car-header + alist2p-aref2-aset2 + alist2p-forward-modular + alist2p-linear-modular)) + +(deftheory + alist2-disabled-lemmas + '(alist2p-aref2-aset2-equal + alist2p-aref2-aset2-not-equal) +; Matt K. mod 10/30/2015: :doc is no longer supported for deftheory. +; :doc "A theory of all rules exported DISABLEd by the alist2 book. +; Note that in order for these rules to be applicable you +; will first need to (DISABLE ALIST2-FUNCTIONS)." + ) + diff --git a/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/array2.lisp b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/array2.lisp new file mode 100644 index 0000000..1ba3767 --- /dev/null +++ b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/array2.lisp @@ -0,0 +1,615 @@ +; The ACL2 two-dimensional Arrays Book. +; Copyright (C) 2003 John R. Cowles, University of Wyoming + +; This book is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This book is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this book; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: +; John Cowles +; Department of Computer Science +; University of Wyoming +; Laramie, WY 82071-3682 U.S.A. + +; Summer and Fall 2002. +; Last modified 19 May 2003 + +; This book is based on a similar book about one-dimensional arrays +; Written by: Bishop Brock +; Computational Logic, Inc. + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +To certify at UW: + +:set-cbd "/home/faculty/cowles/acl2/matrix/" ;;pyramid + +:set-cbd "/home/cowles/matrix/" ;;turing + +(certify-book "array2" + 0 + nil ;;compile-flg + ) +|# +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +To use at UW: + +:set-cbd "/home/faculty/cowles/acl2/matrix/" ;;pyramid + +:set-cbd "/home/cowles/matrix/" ;;turing + +(include-book + "array2") +|# +(in-package "ACL2") + +(local + (defthm + assoc-eq-properties + (implies + (and (alistp l) + (assoc-eq x l)) + (and (consp (assoc-eq x l)) + (equal (car (assoc-eq x l)) x))))) + +(local + (defthm + assoc2-properties + (implies + (and (alistp l) + (assoc2 i j l)) + (and (consp (assoc2 i j l)) + (consp (car (assoc2 i j l))) + (equal (car (car (assoc2 i j l))) i) + (equal (cdr (car (assoc2 i j l))) j))))) + +(local + (defthm + assoc-keyword-properties + (implies + (and (alistp l) + (assoc-keyword x l)) + (and (consp (assoc-keyword x l)) + (equal (car (assoc-keyword x l)) x))))) + +(local + (defthm + bounded-integer-alistp2-car-assoc2-properties + (implies + (and (bounded-integer-alistp2 l m n) + (assoc2 i j l)) + (and (integerp (car (car (assoc2 i j l)))) + (integerp (cdr (car (assoc2 i j l)))) + (>= (car (car (assoc2 i j l))) 0) + (>= (cdr (car (assoc2 i j l))) 0) + (< (car (car (assoc2 i j l))) m) + (< (cdr (car (assoc2 i j l))) n))))) + +(local + (defthm array2p-forward-local + (implies + (array2p name l) + (and + (symbolp name) + (alistp l) + (keyword-value-listp (cdr (assoc-eq :header l))) + (true-listp + (cadr (assoc-keyword :dimensions + (cdr (assoc-eq :header l))))) + (equal + (length (cadr (assoc-keyword :dimensions + (cdr (assoc-eq + :header l))))) + 2) + (integerp + (car (cadr (assoc-keyword :dimensions + (cdr (assoc-eq + :header l)))))) + (integerp + (cadr (cadr (assoc-keyword :dimensions + (cdr (assoc-eq + :header l)))))) + (integerp + (cadr (assoc-keyword :maximum-length + (cdr (assoc-eq :header l))))) + (< 0 + (car (cadr (assoc-keyword + :dimensions + (cdr (assoc-eq :header l)))))) + (< 0 + (cadr (cadr (assoc-keyword + :dimensions + (cdr (assoc-eq :header l)))))) + (< (* (car (cadr (assoc-keyword + :dimensions + (cdr (assoc-eq :header l))))) + (cadr (cadr (assoc-keyword + :dimensions + (cdr (assoc-eq :header l)))))) + (cadr (assoc-keyword + :maximum-length + (cdr (assoc-eq :header l))))) + (<= (cadr (assoc-keyword + :maximum-length + (cdr (assoc-eq :header l)))) + *maximum-positive-32-bit-integer*) + (bounded-integer-alistp2 + l + (car (cadr (assoc-keyword + :dimensions + (cdr (assoc-eq :header l))))) + (cadr (cadr (assoc-keyword + :dimensions + (cdr (assoc-eq :header l)))))))) + :rule-classes :forward-chaining)) + +(local + (defthm array2p-header-exists + (implies + (array2p name l) + (assoc-eq :header l)))) + +(local + (defthm array2p-cons-1 + (implies + (and (array2p name l) + (integerp i) + (>= i 0) + (< i (car (dimensions name l))) + (integerp j) + (>= j 0) + (< j (cadr (dimensions name l)))) + (array2p name (cons (cons (cons i j) val) l))))) + +(local (in-theory (disable array2p))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;(compress211 name L i x j default) processes array elements +;; L(i x) . . . L(i (- j 1)). + +(local + (defthm + alistp-compress211 + (alistp (compress211 name l i x j default)))) + +(local + (defthm bounded-integer-alistp2-compress211 + (implies + (and (array2p name l) + (integerp i) + (integerp x) + (integerp k) + (>= x 0) + (>= i 0) + (> k i)) + (bounded-integer-alistp2 (compress211 name l i x j default) + k + j)))) + +(local + (defthm + compress211-assoc2-property-0 + (implies (and (alistp l) + (assoc2 m n l) + (assoc2 m n (compress211 name l i x j default))) + (equal (assoc2 m n (compress211 name l i x j default)) + (assoc2 m n l))))) + +(local + (defthm + compress211-assoc2-property-1 + (implies + (and (not (assoc2 i n (compress211 name l i x j default))) + (alistp l) + (integerp x) + (integerp j) + (integerp n) + (<= x n) + (< n j) + (assoc2 i n l)) + (equal (cdr (assoc2 i n l)) + default)))) + +(local + (defthm + compress211-assoc2-property-2 + (implies + (and (alistp l) + (not (assoc2 m n l))) + (not (assoc2 m n (compress211 name l i x j default)))))) + +(local + (defthm + not-assoc2-compress211 + (implies (and (alistp l) + (not (equal k i))) + (not (assoc2 k m (compress211 name L i x j default))) + ))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;(compress21 name L n i j default) processes array elements +;; L(n 0) . . . L(n (- j 1)) +;; . . . +;; . . . +;; . . . +;; L((- i 1) 0) . . . L((- i 1)(- j 1)) + +(local + (defthm + alistp-append + (implies (and (alistp l1) + (alistp l2)) + (alistp (append l1 l2))))) + +(local + (defthm + alistp-compress21 + (alistp (compress21 name l n i j default)))) + +(local + (defthm + bounded-integer-alistp2-append + (implies (and (bounded-integer-alistp2 l1 i j) + (bounded-integer-alistp2 l2 i j)) + (bounded-integer-alistp2 (append l1 l2) + i + j)))) + +(local + (defthm + bounded-integer-alistp2-compress21 + (implies + (and (array2p name l) + (integerp i) + (integerp n) + (>= n 0)) + (bounded-integer-alistp2 (compress21 name l n i j default) + i + j)))) + +(local + (defthm + assoc2-append + (equal (assoc2 i j (append l1 l2)) + (if (assoc2 i j l1) + (assoc2 i j l1) + (assoc2 i j l2))))) + +(local + (defthm + compress21-assoc2-property-0 + (implies + (and (alistp l) + (assoc2 k m l) + (assoc2 k m (compress21 name l n i j default))) + (equal (assoc2 k m (compress21 name l n i j default)) + (assoc2 k m l))))) + +(local + (defthm + compress21-assoc2-property-1 + (implies + (and (not (assoc2 k m (compress21 name l n i j default))) + (alistp l) + (integerp i) + (integerp j) + (integerp k) + (integerp m) + (integerp n) + (<= n i) + (<= n k) + (< k i) + (<= 0 m) + (< m j) + (assoc2 k m l)) + (equal (cdr (assoc2 k m l)) + default)) + :hints (("Subgoal *1/5" + :use (:instance + compress211-assoc2-property-1 + (i k) + (n m) + (x 1)))))) + +(local + (defthm + compress21-assoc2-property-2 + (implies + (and (alistp l) + (not (assoc2 k m l))) + (not (assoc2 k m (compress21 name l n i j default)))))) + +(local + (defthm + compress2-assoc2-property-0 + (implies + (and (alistp l) + (assoc2 k m l) + (assoc2 k m (compress2 name l))) + (equal (cdr (assoc2 k m (compress2 name l))) + (cdr (assoc2 k m l)))))) + +(local + (defthm + compress2-assoc2-property-1 + (implies + (and (array2p name l) + (integerp k) + (integerp m) + (<= 0 k) + (< k (car (dimensions name l))) + (<= 0 m) + (< m (cadr (dimensions name l))) + (assoc2 k m l) + (not (assoc2 k m (compress2 name l)))) + (equal (cdr (assoc2 k m l)) + (cadr (assoc-keyword :default (cdr (assoc-eq :header l)) + )))))) + +(local + (defthm + compress2-assoc2-property-2 + (implies + (and (alistp l) + (not (assoc2 k m l))) + (not (assoc2 k m (compress2 name l)))))) + +(local + (defthm + header-compress2 + (implies + (array2p name l) + (equal (assoc-eq :header (compress2 name l)) + (assoc-eq :header l))))) + +(defthm + array2p-compress2 + (implies + (array2p name l) + (array2p name (compress2 name l))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((compress2 name l)))) + :hints (("Goal" + :in-theory (enable array2p)))) + +(defthm + array2p-compress2-properties + (implies + (array2p name l) + (and + (equal (header name (compress2 name l)) + (header name l)) + (equal (dimensions name (compress2 name l)) + (dimensions name l)) + (equal (maximum-length name (compress2 name l)) + (maximum-length name l)) + (equal (default name (compress2 name l)) + (default name l))))) + +(local (in-theory (disable compress2))) + +(defthm + array2p-aset2 + (implies + (and (array2p name l) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l))) + (< j (cadr (dimensions name l)))) + (array2p name (aset2 name l i j val)))) + +(defthm + array2p-aset2-properties + (implies + (and (array2p name l) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l))) + (< j (cadr (dimensions name l)))) + (and + (equal (header name (aset2 name l i j val)) + (header name l)) + (equal (dimensions name (aset2 name l i j val)) + (dimensions name l)) + (equal (maximum-length name (aset2 name l i j val)) + (maximum-length name l)) + (equal (default name (aset2 name l i j val)) + (default name l))))) + +(defthm + aref2-compress2 + (implies + (and (array2p name l) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l))) + (< j (cadr (dimensions name l)))) + (equal (aref2 name (compress2 name l) i j) + (aref2 name l i j)))) + +(defthm + array2p-acons-properties + (and + (equal (header name (cons (cons (cons i j) val) l)) + (header name l)) + (equal (dimensions name (cons (cons (cons i j) val) l)) + (dimensions name l)) + (equal (maximum-length name (cons (cons (cons i j) val) l)) + (maximum-length name l)) + (equal (default name (cons (cons (cons i j) val) l)) + (default name l)))) + +(defthm + array2p-consp-header + (implies + (array2p name l) + (consp (header name l))) + :rule-classes :type-prescription) + +(defthm + array2p-car-header + (implies + (array2p name l) + (equal (car (header name l)) + :header))) + +; These two theorems for the AREF2-ASET2 cases are used to prove a +; combined result, and then exported DISABLEd: + +(defthm + aref2-aset2-equal + (implies + (and (array2p name l) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l))) + (< j (cadr (dimensions name l)))) + (equal (aref2 name (aset2 name l i j val) i j) + val))) + +(defthm + aref2-aset2-not-equal + (implies + (and (array2p name l) + (integerp i1) + (integerp j1) + (>= i1 0) + (>= j1 0) + (< i1 (car (dimensions name l))) + (< j1 (cadr (dimensions name l))) + (integerp i2) + (integerp j2) + (>= i2 0) + (>= j2 0) + (< i2 (car (dimensions name l))) + (< j2 (cadr (dimensions name l))) + (not (and (equal i1 i2) + (equal j1 j2)))) + (equal (aref2 name (aset2 name l i1 j1 val) i2 j2) + (aref2 name l i2 j2)))) + +(defthm + aref2-aset2 + (implies + (and (array2p name l) + (integerp i1) + (integerp j1) + (>= i1 0) + (>= j1 0) + (< i1 (car (dimensions name l))) + (< j1 (cadr (dimensions name l))) + (integerp i2) + (integerp j2) + (>= i2 0) + (>= j2 0) + (< i2 (car (dimensions name l))) + (< j2 (cadr (dimensions name l))) + ) + (equal (aref2 name (aset2 name l i1 j1 val) i2 j2) + (if (and (equal i1 i2) + (equal j1 j2)) + val + (aref2 name l i2 j2))))) + +(in-theory (disable aref2-aset2-equal aref2-aset2-not-equal)) + +;;; The final form of the :FORWARD-CHAINING lemma for ARRAY2P. +;;; A forward definition of (ARRAY2P name l), in terms of +;;; HEADER, DIMENSIONS, and MAXIMUM-LENGTH. +;;; Note that ACL2 also defines a lemma ARRAY2P-FORWARD, but +;;; that lemma is in terms of the expansions of HEADER, +;;; DIMENSIONS, and MAXIMUM-LENGTH. + +;;; One should normaly DISABLE ARRAY2P in favor of this +;;; :FORWARD-CHAINING rule. If allowed to open, ARRAY2P can +;;; cause severe performance degradation due to its large size +;;; and many recursive functions. This lemma is designed to be +;;; used with the ARRAY2-FUNCTIONS theory DISABLEd. + +(defthm array2p-forward-modular + (implies + (array2p name l) + (and (symbolp name) + (alistp l) + (keyword-value-listp (cdr (header name l))) + (true-listp (dimensions name l)) + (equal (length (dimensions name l)) 2) + (integerp (car (dimensions name l))) + (integerp (cadr (dimensions name l))) + (integerp (maximum-length name l)) + (< 0 (car (dimensions name l))) + (< 0 (cadr (dimensions name l))) + (< (* (car (dimensions name l)) + (cadr (dimensions name l))) + (maximum-length name l)) + (<= (maximum-length name l) + *maximum-positive-32-bit-integer*) + (bounded-integer-alistp2 l + (car (dimensions name l)) + (cadr (dimensions name l))))) + :rule-classes :forward-chaining) + +(defthm array2p-linear-modular + (implies + (array2p name l) + (and (< 0 (car (dimensions name l))) + (< 0 (cadr (dimensions name l))) + (< (* (car (dimensions name l)) + (cadr (dimensions name l))) + (maximum-length name l)) + (<= (maximum-length name l) + *maximum-positive-32-bit-integer*))) + :rule-classes :linear) + +(deftheory + array2-functions + '(array2p aset2 aref2 compress2 header dimensions maximum-length + default) +; Matt K. mod 10/30/2015: :doc is no longer supported for deftheory. +; :doc "A theory of all functions specific to 2-dimensional arrays. +; This theory must be DISABLEd in order for the lemmas +; exported by the array2 book to be applicable." + ) + +(deftheory + array2-lemmas + '(array2p-compress2 + array2p-compress2-properties + array2p-aset2 + array2p-aset2-properties + aref2-compress2 + array2p-acons-properties + array2p-consp-header + array2p-car-header + aref2-aset2 + array2p-forward-modular + array2p-linear-modular)) + +(deftheory + array2-disabled-lemmas + '(aref2-aset2-equal + aref2-aset2-not-equal) +; Matt K. mod 10/30/2015: :doc is no longer supported for deftheory. +; :doc "A theory of all rules exported DISABLEd by the array2 book. +; Note that in order for these rules to be applicable you +; will first need to (DISABLE ARRAY2-FUNCTIONS)." + ) + diff --git a/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/matalg.lisp b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/matalg.lisp new file mode 100644 index 0000000..9f4f37e --- /dev/null +++ b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/matalg.lisp @@ -0,0 +1,2705 @@ +; The ACL2 Matrix Algebra Book. Summary of definitions and algebra in matrix.lisp. +; Copyright (C) 2002 Ruben Gamboa and John R. Cowles, University of Wyoming + +; This book is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This book is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this book; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: +; Ruben Gamboa and John Cowles +; Department of Computer Science +; University of Wyoming +; Laramie, WY 82071-3682 U.S.A. + +; Summer and Fall 2002. +; Last modified 17 June 2003. + +; ACL2 Version 2.8 alpha (as of May 11 03) +#| + To certify in + ACL2 Version 2.8 alpha (as of May 11 03) + +(certify-book "matalg" + 0 + t ;;compile-flg + ) +|# +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +At UW: + +:set-cbd "/home/faculty/cowles/acl2/matrix/" ;;pyramid + +:set-cbd "/home/cowles/matrix/" ;; turing +|# + +(in-package "ACL2") + +(include-book "alist2") + +(local (include-book "matrix")) + +(defthm array2p-forward-modular + (implies + (array2p name l) + (and (symbolp name) + (alistp l) + (keyword-value-listp (cdr (header name l))) + (true-listp (dimensions name l)) + (equal (length (dimensions name l)) 2) + (integerp (car (dimensions name l))) + (integerp (cadr (dimensions name l))) + (integerp (maximum-length name l)) + (< 0 (car (dimensions name l))) + (< 0 (cadr (dimensions name l))) + (< (* (car (dimensions name l)) + (cadr (dimensions name l))) + (maximum-length name l)) + (<= (maximum-length name l) + *maximum-positive-32-bit-integer*) + (bounded-integer-alistp2 l + (car (dimensions name l)) + (cadr (dimensions name l))))) + :rule-classes :forward-chaining) + +(defthm array2p-linear-modular + (implies + (array2p name l) + (and (< 0 (car (dimensions name l))) + (< 0 (cadr (dimensions name l))) + (< (* (car (dimensions name l)) + (cadr (dimensions name l))) + (maximum-length name l)) + (<= (maximum-length name l) + *maximum-positive-32-bit-integer*))) + :rule-classes :linear) + +(defthm + alist2p-$arg + (implies (alist2p name l) + (alist2p '$arg l)) + :rule-classes :forward-chaining) + +(defthm + array2p-$arg + (implies (array2p name l) + (array2p '$arg l)) + :rule-classes :forward-chaining) + + +(defthm + not-alist2p-arg$ + (implies (not (alist2p name l)) + (not (alist2p '$arg l))) + :rule-classes :forward-chaining) + +(defthm + not-array2p-arg$ + (implies (and (not (array2p name l)) + (symbolp name)) + (not (array2p '$arg l))) + :rule-classes :forward-chaining) + +(in-theory (disable alist2p array2p aset2 aref2 compress2 header + dimensions maximum-length default)) + +(defthm + sqrt-*-sqrt-<-sq + (implies (and (rationalp x) + (rationalp y) + (>= x 0) + (>= y 0) + (<= x 46340) + (<= y 46340)) + (< (* x y) 2147483647)) + :rule-classes (:rewrite :linear) + :hints (("Goal" + :use (:instance + *-PRESERVES->=-FOR-NONNEGATIVES + (x2 x) + (y2 y) + (x1 46340) + (y1 46340))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Boolean test for a matrix: + +;; The need for the following constant is explained in +;; detail later in this book: + +;; Search for +;; ; Ensuring closure of matrix multiplication. + +(defconst + *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER* + 46340) + +;; To ensure that matrix multiplication is closed, the +;; matrix can have no more that 46,340 rows and no more +;; 46,340 columns. + +(defun + matrixp (m n X) + "Determine if X is a m by n matrix." + (declare (xargs :guard t)) + (and (array2p '$arg X) + (let ((dims (dimensions '$arg X))) + (and (equal m (first dims)) + (equal n (second dims)))) + (<= m *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (<= n *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*))) + +(defmacro + r (M) + "Return the number of rows in the matrix M." + `(car (dimensions '$arg ,M))) + +(defmacro + c (M) + "Return the number of columns in the matrix M." + `(cadr (dimensions '$arg ,M))) + +(defthm + array2p-matrixp + (implies (and (array2p name M) + (<= (r M) *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (<= (c M) *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (matrixp (r M)(c M) M))) + +;;;;;;;;;;;;;;;;;;; +;; Matrix equality: + +(defun + m-=-row (M1 M2 m n) + "Determine if all the following equalities hold: + M1(m 0) = M2(m 0), . . . , M1(m n) = M2(m n); + ie. determine if the m'th row of M1 matches the + m'th row of M2. + All entries are treated as numbers." + (declare (xargs :guard (and (integerp m) + (>= m 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< m (car dims1)) + (< n (cadr dims1)))) + (let ((dims2 (dimensions '$arg2 M2))) + (and (< m (car dims2)) + (< n (cadr dims2))))))) + (if (zp n) + (equal (fix (aref2 '$arg1 M1 m 0)) + (fix (aref2 '$arg2 M2 m 0))) + (and (equal (fix (aref2 '$arg1 M1 m n)) + (fix (aref2 '$arg2 M2 m n))) + (m-=-row M1 M2 m (- n 1))))) + +(defun + m-=-row-1 (M1 M2 m n) + "Determine if all the following equalities hold: + M1(0 0) = M2(0 0), . . . , M1(0 n) = M2(0 n) + . . . + . . . + . . . + M1(m 0) = M2(m 0), . . . , M1(m n) = M2(m n); + ie. determine if rows 0 thru m of M1 matches + rows 0 thru m of M2. + All entries are treated as numbers." + (declare (xargs :guard (and (integerp m) + (>= m 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< m (car dims1)) + (< n (cadr dims1)))) + (let ((dims2 (dimensions '$arg2 M2))) + (and (< m (car dims2)) + (< n (cadr dims2))))))) + (if (zp m) + (m-=-row M1 M2 0 n) + (and (m-=-row M1 M2 m n) + (m-=-row-1 M1 M2 (- m 1) n)))) + +(defun + m-= (M1 M2) + "Determine if the matrices represented by the alists + M1 and M2 are equal (as matrices of numbers)." + (declare (xargs :guard (and (array2p '$arg1 M1) + (array2p '$arg2 M2)))) + (if (mbt (and (alist2p '$arg1 M1) + (alist2p '$arg2 M2))) + (let ((dim1 (dimensions '$arg1 M1)) + (dim2 (dimensions '$arg2 M2))) + (if (and (= (first dim1) + (first dim2)) + (= (second dim1) + (second dim2))) + (m-=-row-1 (compress2 '$arg1 M1) + (compress2 '$arg2 M2) + (- (first dim1) 1) + (- (second dim1) 1)) + nil)) + (equal M1 M2))) + +(defequiv + ;; m-=-is-an-equivalence + m-=) + +(defcong + ;; m-=-implies-equal-alist2p-2 + m-= equal (alist2p name M) 2 + :hints (("Goal" + :use (:theorem + (implies (m-= M M-equiv) + (iff (alist2p name M) + (alist2p name M-equiv) + )))))) + +;;;;;;;;;;;;;;; +;; Zero matrix: + +(defun + m-0 (m n) + "Return an alist representing the m by n matrix whose + elements are all equal to 0. + To use the ACL2 efficient array mechanism to store (m-0 m n), + (* m n)) must be stictly less than 2147483647 which is + the *MAXIMUM-POSITIVE-32-BIT-INTEGER*." + (declare (xargs :guard (and (integerp m) + (integerp n) + (> m 0) + (> n 0)))) + (list (list :HEADER + :DIMENSIONS (list m n) + :MAXIMUM-LENGTH (+ 1 (* m n)) + :DEFAULT 0 + :NAME 'zero-matrix))) + +(defthm + alist2p-m-0 + (implies (and (integerp m) + (integerp n) + (> m 0) + (> n 0)) + (alist2p name (m-0 m n))) + :hints (("Goal" :in-theory (enable alist2p)))) + +(defthm + array2p-m-0 + (implies (and (symbolp name) + (integerp m) + (integerp n) + (> m 0) + (> n 0) + (< (* m n) *MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (array2p name (m-0 m n))) + :hints (("Goal" :in-theory (enable array2p)))) + +(defthm + matrixp-m-0 + (implies (and (integerp m) + (integerp n) + (> m 0) + (> n 0) + (<= m *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (<= n *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (matrixp m n (m-0 m n))) + :hints (("Goal" :in-theory (enable array2p + dimensions + header)))) + +(defthm + aref2-m-0 + (equal (aref2 name (m-0 m n) i j) 0) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + dimensions-m-0 + (equal (dimensions name (m-0 m n))(list m n)) + :hints (("Goal" + :in-theory (enable header dimensions)))) + +(defthm + default-m-0 + (equal (default name (m-0 m n)) + 0) + :hints (("Goal" + :in-theory (enable header default)))) + +(defthm + alist2p-alist2p-m-0 + (implies (alist2p name1 M) + (alist2p name2 (m-0 (car (dimensions + '$arg M)) + (cadr (dimensions + '$arg M)))))) + +(defthm + array2p-array2p-m-0 + (implies (and (array2p name1 M) + (symbolp name2)) + (array2p name2 (m-0 (car (dimensions + '$arg M)) + (cadr (dimensions + '$arg M)))))) + +;;;;;;;;;;;;;;;;;;; +;; Identity matrix: + +(defun + m-1a (n) + "Return alist of length n of the form + ( ((- n 1) . (- n 1)) . 1) . . . ((0 . 0) . 1) )." + (declare (xargs :guard (and (integerp n) + (>= n 0)) + :verify-guards nil)) + (if (zp n) + nil + (acons (cons (- n 1)(- n 1)) 1 (m-1a (- n 1))))) + +(verify-guards m-1a) + +(defun + m-1 (n) + "Return an alist representing the n by n identity matrix. + To use the ACL2 efficient array mechanism to store (m-1 n), + (* n n)) must be stictly less than 2147483647 which is + the *MAXIMUM-POSITIVE-32-BIT-INTEGER*." + (declare (xargs :guard (and (integerp n) + (>= n 0)))) + (cons (list :HEADER + :DIMENSIONS (list n n) + :MAXIMUM-LENGTH (+ 1 (* n n)) + :DEFAULT 0 + :NAME 'identity-matrix) + (m-1a n))) + +(defthm + alist2p-m-1 + (implies (and (integerp n) + (> n 0)) + (alist2p name (m-1 n))) + :hints (("Goal" + :in-theory (enable alist2p)))) + +(defthm + array2p-m-1 + (implies (and (symbolp name) + (integerp n) + (> n 0) + (< (* n n) *MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (array2p name (m-1 n))) + :hints (("Goal" + :in-theory (enable array2p)))) + +(defthm + matrixp-m-1 + (implies (and (integerp n) + (> n 0) + (<= n *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (matrixp n n (m-1 n))) + :hints (("Goal" + :in-theory (enable array2p dimensions header)))) + +(defthm + aref2-m-1-i-i + (implies (and (integerp i) + (integerp n) + (<= 0 i) + (< i n)) + (equal (aref2 name (m-1 n) i i) 1)) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + aref2-m-1-i-j + (implies (not (equal i j)) + (equal (aref2 name (m-1 n) i j) 0)) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + dimensions-m-1 + (equal (dimensions name (m-1 n))(list n n)) + :hints (("Goal" + :in-theory (enable header dimensions)))) + +;;;;;;;;;;;;;;;;;;;;;;;;; +;; Transpose of a matrix: + +(defun + m-trans-a (M) + (declare (xargs :guard (alistp M))) + (if (consp M) + (let ((key (caar M)) + (datum (cdar M))) + (if (consp key) + (acons (cons (cdr key) + (car key)) + datum + (m-trans-a (cdr M))) + (m-trans-a (cdr M)))) + nil)) + +(defun + m-trans (M) + "Return an alist representing the transpose of the matrix + represented by the alist M." + (declare (xargs :guard (array2p '$arg M))) + (cons (list :HEADER + :DIMENSIONS (let ((dims (dimensions '$arg M))) + (list (cadr dims)(car dims))) + :MAXIMUM-LENGTH (maximum-length '$arg M) + :DEFAULT (default '$arg M) + :NAME 'transpose-matrix) + (m-trans-a M))) + +(defthm + alist2p-m-trans + (implies (alist2p name M) + (alist2p name (m-trans M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-trans M)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions)))) + +(defthm + array2p-m-trans + (implies (array2p name M) + (array2p name (m-trans M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-trans M)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + dimensions-m-trans + (equal (dimensions name (m-trans M)) + (list (cadr (dimensions name M)) + (car (dimensions name M)))) + :hints (("Goal" + :in-theory (enable dimensions header)))) + +(defthm + aref2-m-trans + (equal (aref2 name (m-trans M) i j) + (aref2 name M j i)) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + matrixp-m-trans + (implies (matrixp m n X) + (matrixp n m (m-trans X)))) + +(defthm + idempotency-of-m-trans-alist2p + (implies (alist2p name M) + (m-= (m-trans (m-trans M)) M))) + +(defthm + idempotency-of-m-trans-array2p + (implies (array2p name M) + (m-= (m-trans (m-trans M)) M)) + :hints (("Goal'" + :use (:theorem + (implies (array2p '$arg1 M) + (alist2p '$arg1 + (m-trans + (m-trans M)))))))) + +(defcong + ;; M-=-IMPLIES-M-=-M-TRANS-1 + m-= m-= (m-trans M) 1) + +(defthm + m-=-m-trans-m-0 + (implies (and (integerp m) + (integerp n) + (> m 0) + (> n 0)) + (m-= (m-trans (m-0 m n)) + (m-0 n m)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Unary minus of a matrix: + +(defun + m-unary--a (M) + (declare (xargs :guard (alistp M))) + (if (consp M) + (let ((key (caar M)) + (datum (cdar M))) + (if (consp key) + (acons key + (- (fix datum)) + (m-unary--a (cdr M))) + (m-unary--a (cdr M)))) + nil)) + +(defun + m-unary-- (M) + "Return an alist representing the unary minus of the matrix + represented by the alist M." + (declare (xargs :guard (array2p '$arg M))) + (cons (list :HEADER + :DIMENSIONS (dimensions '$arg M) + :MAXIMUM-LENGTH (maximum-length '$arg M) + :DEFAULT (- (fix (default '$arg M))) + :NAME 'unary-minus-matrix) + (m-unary--a M))) + +(defthm + alist2p-m-unary-- + (implies (alist2p name M) + (alist2p name (m-unary-- M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-unary-- M)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions)))) + +(defthm + array2p-m-unary-- + (implies (array2p name M) + (array2p name (m-unary-- M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-unary-- M)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + dimensions-m-unary-- + (equal (dimensions name (m-unary-- M)) + (dimensions name M)) + :hints (("Goal" + :in-theory (enable array2p dimensions header)))) + +(defthm + aref2-m-unary-- + (equal (aref2 name (m-unary-- M) i j) + (- (aref2 name M i j))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + matrixp-m-unary-- + (implies (matrixp m n X) + (matrixp m n (m-unary-- X)))) + +(defthm + idempotency-of-m-unary--_alist2p + (implies (alist2p name M) + (m-= (m-unary-- (m-unary-- M)) M))) + +(defthm + idempotency-of-m-unary--_array2p + (implies (array2p name M) + (m-= (m-unary-- (m-unary-- M)) M))) + +(defcong + ;; M-=-IMPLIES-M-=-M-UNARY---1 + m-= m-= (m-unary-- M) 1) + +(defthm + m-=-m-trans-m-unary-- + (implies (alist2p name M) + (m-= (m-trans (m-unary-- M)) + (m-unary-- (m-trans M))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Scalar multiplication of a matrix: + +(defun + s-*-a (a M) + (declare (xargs :guard (and (acl2-numberp a) + (alistp M)))) + (if (consp M) + (let ((key (caar M)) + (datum (cdar M))) + (if (consp key) + (acons key + (* a (fix datum)) + (s-*-a a (cdr M))) + (s-*-a a (cdr M)))) + nil)) + +(defun + s-* (a M) + "Return an alist representing the multiplication + of the scalar a times the matrix represented by + the alist M." + (declare (xargs :guard (and (acl2-numberp a) + (array2p '$arg M)))) + (cons (list :HEADER + :DIMENSIONS (dimensions '$arg M) + :MAXIMUM-LENGTH (maximum-length '$arg M) + :DEFAULT (* a (fix (default '$arg M))) + :NAME 'scalar-mult-matrix) + (s-*-a a M))) + +(defthm + alist2p-s-* + (implies (alist2p name M) + (alist2p name (s-* a M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((s-* a M)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions)))) + +(defthm + array2p-s-* + (implies (array2p name M) + (array2p name (s-* a M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((s-* a M)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + dimensions-s-* + (equal (dimensions name (s-* a M)) + (dimensions name M)) + :hints (("Goal" + :in-theory (enable array2p dimensions header)))) + +(defthm + aref2-s-* + (equal (aref2 name (s-* a M) i j) + (* a (aref2 name M i j))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + matrixp-s-* + (implies (matrixp m n X) + (matrixp m n (s-* a X)))) + +(defcong + ;; M-=-IMPLIES-M-=-S-*-2 + m-= m-= (s-* a M) 2) + +(defthm + associate-scalars-left-s-* + (implies (alist2p name M) + (m-= (s-* a1 (s-* a2 M)) + (s-* (* a1 a2) M)))) + +(defthm + m-=-s-*-0 + (implies (alist2p name M) + (m-= (s-* 0 M)(m-0 (r M)(c M))))) + +(defthm + m-=-s-*-m-0 + (implies (and (integerp m) + (integerp n) + (> m 0) + (> n 0)) + (m-= (s-* a (m-0 m n))(m-0 m n)))) + +(defthm + m-=-s-*-1 + (implies (alist2p name M) + (m-= (s-* 1 M) M))) + +(defthm + m-=-s-*_-1 + (implies (alist2p name M) + (m-= (s-* -1 M)(m-unary-- M)))) + +(defthm + m-=-m-trans-s-* + (implies (alist2p name M) + (m-= (m-trans (s-* s M)) + (s-* s (m-trans M))))) + +;;;;;;;;;;;;;; +;; Matrix sum: + +(defun + m-binary-+-row (M1 M2 m n) + "Return an alist with the following values: + M1(m 0)+M2(m 0), . . . , M1(m n)+M2(m n); + ie. construct an alist of values representing + the vector sum of the m'th row of M1 and the + m'th row of M2." + (declare (xargs :guard + (and (integerp m) + (>= m 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions + '$arg1 M1))) + (and (< m (first dims1)) + (< n (second dims1)))) + (let ((dims2 (dimensions + '$arg2 M2))) + (and (< m (first dims2)) + (< n (second dims2)))) + ))) + (if (zp n) + (list (cons (cons m 0) + (+ (fix (aref2 '$arg1 M1 m 0)) + (fix (aref2 '$arg2 M2 m 0))))) + (cons (cons (cons m n) + (+ (fix (aref2 '$arg1 M1 m n)) + (fix (aref2 '$arg2 M2 m n)))) + (m-binary-+-row M1 M2 m (- n 1))))) + +(defun + m-binary-+-row-1 (M1 M2 m n) + "Return an alist with all the following values: + M1(0 0)+M2(0 0), . . . , M1(0 n)+M2(0 n) + . . . + . . . + . . . + M1(m 0)+M2(m 0), . . . , M1(m n)+M2(m n); + ie. construct an alist of values representing + the vector sum of rows 0 thru m of M1 with + the corresponding rows 0 thru m of M2." + (declare (xargs :guard + (and (integerp m) + (>= m 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions + '$arg1 M1))) + (and (< m (first dims1)) + (< n (second dims1)))) + (let ((dims2 (dimensions + '$arg2 M2))) + (and (< m (first dims2)) + (< n (second dims2)))) + ))) + (if (zp m) + (m-binary-+-row M1 M2 0 n) + (append (m-binary-+-row M1 M2 m n) + (m-binary-+-row-1 M1 M2 (- m 1) n)))) + +(defun + m-binary-+ (M1 M2) + "Return an alist representing the matrix sum + of the matrices represented by the alists M1 + and M2. This is done by adding a header to an + alist containing the appropriate values." + (declare (xargs :guard + (and (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dim1 (dimensions '$arg1 + M1)) + (dim2 (dimensions '$arg2 + M2))) + (and + (= (first dim1) + (first dim2)) + (= (second dim1) + (second dim2))))) + )) + (let* ((dim1 (dimensions '$arg1 M1)) + (dim2 (dimensions '$arg2 M2)) + (dim11 (first dim1)) + (dim12 (second dim1)) + (dim21 (first dim2)) + (dim22 (second dim2))) + (if (mbt (and (alist2p '$arg1 M1) + (alist2p '$arg2 M2) + (= dim11 dim21) + (= dim12 dim22))) + (cons (list :HEADER + :DIMENSIONS (list dim11 dim12) + :MAXIMUM-LENGTH + (+ 1 (* dim11 dim12)) + :DEFAULT 0 + :NAME 'matrix-sum) + (m-binary-+-row-1 (compress2 '$arg1 M1) + (compress2 '$arg2 M2) + (- dim11 1) + (- dim12 1))) + (+ M1 M2)))) + +(defmacro + m-+ (&rest rst) + (if rst + (if (cdr rst) + (xxxjoin 'm-binary-+ rst) + (car rst)) + 0)) + +(add-binop m-+ m-binary-+) + +(defthm + alist2p-m-+ + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2)))) + (alist2p name (m-+ M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-+ M1 M2)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions)))) + +(defthm + array2p-m-+ + (implies (and (array2p name M1) + (array2p name M2) + (equal (dimensions name M1) + (dimensions name M2))) + (array2p name (m-+ M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-+ M1 M2)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + array2p-m-+-1 + (implies (and (array2p name M1) + (array2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2)))) + (array2p name (m-+ M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-+ M1 M2)))) + :hints (("Goal" + :in-theory (disable m-binary-+ + equal-list-dimensions-array2p) + :use ((:instance + equal-list-dimensions-array2p + (M M1)) + (:instance + equal-list-dimensions-array2p + (M M2)))))) + +(defthm + dimensions-m-+-alist2p + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2)))) + (equal (dimensions name (m-+ M1 M2)) + (list (car (dimensions name M1)) + (cadr (dimensions name M1))))) + :hints (("Goal" + :in-theory (enable alist2p dimensions + header)))) + +(defthm + dimensions-m-+-array2p + (implies (and (array2p name M1) + (array2p name M2) + (equal (dimensions name M1) + (dimensions name M2))) + (equal (dimensions name (m-+ M1 M2)) + (dimensions name M1))) + :hints (("Goal" + :in-theory (disable + equal-list-dimensions-array2p + dimensions-m-+-alist2p) + :use ((:instance + equal-list-dimensions-array2p + (M M1)) + dimensions-m-+-alist2p)))) + +(defthm + matrixp-m-+ + (implies (and (matrixp m n X1) + (matrixp m n X2)) + (matrixp m n (m-+ X1 X2))) + :hints (("Goal" + :in-theory (disable m-binary-+)))) + +(defthm + default-m-+-alist2p + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2)))) + (equal (default name (m-+ M1 M2)) 0)) + :hints (("Goal" + :in-theory (enable alist2p default + header)))) + +(defthm + default-m-+-array2p + (implies (and (array2p name M1) + (array2p name M2) + (equal (dimensions name M1) + (dimensions name M2))) + (equal (default name (m-+ M1 M2)) 0)) + :hints (("Goal" + :in-theory (enable array2p default header)))) + +(defthm + maximum-length-m-+ + (implies (and (array2p name M1) + (array2p name M2) + (equal (dimensions name M1) + (dimensions name M2))) + (equal (maximum-length name (m-+ M1 M2)) + (+ 1 (* (car (dimensions name M1)) + (cadr (dimensions name M1)))))) + :hints (("Goal" + :in-theory (enable array2p maximum-length header)))) + +(defthm + aref2-m-+ + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2))) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name M1))) + (< j (cadr (dimensions name M1)))) + (equal (aref2 name (m-+ M1 M2) i j) + (+ (aref2 name M1 i j) + (aref2 name M2 i j)))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defcong + ;; M-=-IMPLIES-EQUAL-M-+-1 + m-= equal (M-+ M1 M2) 1) + +(defcong + ;; M-=-IMPLIES-EQUAL-M-+-2 + m-= equal (M-+ M1 M2) 2) + +(defthm + commutativity-of-m-+ + (equal (m-+ M1 M2) + (m-+ M2 M1))) + +(defthm + associativity-of-m-+ + (equal (m-+ (m-+ M1 M2) M3) + (m-+ M1 M2 M3)) + :hints (("Goal" + :in-theory (disable commutativity-of-m-+)))) + +(local + (defthm + commutativity-2-of-m-+-lemma + (equal (m-+ (m-+ X Y) Z) + (m-+ (m-+ Y X) Z)) + :rule-classes nil + :hints (("Goal" + :in-theory (disable associativity-of-m-+))))) + +(defthm + commutativity-2-of-m-+ + (equal (m-+ X Y Z) + (m-+ Y X Z)) + :hints (("Goal" + :use commutativity-2-of-m-+-lemma))) + +(defthm + right-m-+-unicity-of-m-0 + (implies (alist2p name M) + (m-= (m-+ M (m-0 (car (dimensions name M)) + (cadr (dimensions name M)))) + M))) + +(defthm + left-m-+-unicity-of-m-0 + (implies (alist2p name M) + (m-= (m-+ (m-0 (car (dimensions name M)) + (cadr (dimensions name M))) + M) + M))) + +(defmacro + m-- (x &optional (y 'nil binary-casep)) + (if binary-casep + `(m-binary-+ ,x (m-unary-- ,y)) + `(m-unary-- ,x))) + +(add-macro-alias m-- m-unary--) + +(add-invisible-fns m-binary-+ m-unary--) +(add-invisible-fns m-unary-- m-unary--) + +(defthm + left-m-+-inverse-of-m-- + (implies (alist2p name M) + (m-= (m-+ (m-- M) M) + (m-0 (car (dimensions name M)) + (cadr (dimensions name M)))))) + +(defthm + right-m-+-inverse-of-m-- + (implies (alist2p name M) + (m-= (m-+ M (m-- M)) + (m-0 (car (dimensions name M)) + (cadr (dimensions name M)))))) + +(local + (defthm + right-m-+-inverse-of-m--_2-lemma + (implies (and (alist2p name X) + (alist2p name Y) + (equal (r X)(r Y)) + (equal (c X)(c Y))) + (m-= (m-+ (m-+ X (m-- X)) Y) + Y)) + :rule-classes nil + :hints (("Goal" + :in-theory (disable m-binary-+ m-= + associativity-of-m-+) + :use (:instance + right-m-+-unicity-of-m-0 + (M Y)))))) + +(defthm + right-m-+-inverse-of-m--_2 + (implies (and (alist2p name X) + (alist2p name Y) + (equal (r X)(r Y)) + (equal (c X)(c Y))) + (m-= (m-+ X (m-- X) Y) + Y)) + :hints (("Goal" + :use right-m-+-inverse-of-m--_2-lemma))) + +(local + (defthm + left-m-+-inverse-of-m--_2-lemma + (implies (and (alist2p name X) + (alist2p name Y) + (equal (r X)(r Y)) + (equal (c X)(c Y))) + (m-= (m-+ (m-+ (m-- X) X) Y) + Y)) + :rule-classes nil + :hints (("Goal" + :in-theory (disable m-binary-+ m-= + associativity-of-m-+) + :use (:instance + right-m-+-unicity-of-m-0 + (M Y)))))) + +(defthm + left-m-+-inverse-of-m--_2 + (implies (and (alist2p name X) + (alist2p name Y) + (equal (r X)(r Y)) + (equal (c X)(c Y))) + (m-= (m-+ (m-- X) X Y) + Y)) + :hints (("Goal" + :use left-m-+-inverse-of-m--_2-lemma))) + +(defthm + uniqueness-of-m-+-inverse + (implies (and (alist2p name X) + (alist2p name Y) + (equal (r X)(r Y)) + (equal (c X)(c Y)) + (m-= (m-+ X Y) + (m-0 (r X)(c X)))) + (m-= X (m-- Y))) + :rule-classes nil + :hints (("Goal" + :in-theory (disable m-binary-+ m-=) + :use ((:instance + right-m-+-unicity-of-m-0 + (M X)) + (:instance + right-m-+-unicity-of-m-0 + (M (m-- Y))))))) + +(defthm + distributivity-of-s-*-over-+ + (implies (alist2p name M) + (m-= (s-* (+ a b) M) + (m-+ (s-* a M)(s-* b m)))) + :hints (("Goal" + :in-theory (disable m-binary-+ + alist2p-m-+) + :use ((:instance + alist2p-m-+ + (M1 (s-* a M)) + (M2 (s-* b M))))))) + +(defthm + distributivity-of-s-*-over-m-+ + (implies (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))) + (alist2p name M1) + (alist2p name M2)) + (m-= (s-* a (m-+ M1 M2)) + (m-+ (s-* a M1)(s-* a M2)))) + :hints (("Goal" + :in-theory (disable m-binary-+ + alist2p-s-*) + :use ((:instance + alist2p-s-* + (M (m-binary-+ M1 M2))) + (:instance + alist2p-s-* + (M M1)) + (:instance + alist2p-s-* + (M M2)) + (:instance + alist2p-m-+ + (M1 (s-* a M1)) + (M2 (s-* a M2))))))) + +(defthm + double-m-+-s-* + (implies (alist2p name M) + (m-= (m-+ M M) + (s-* 2 M))) + :hints (("Goal" + :use (:instance + distributivity-of-s-*-over-+ + (a 1) + (b 1))))) + +(defthm + m-trans-m-+ + (implies (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))) + (alist2p name M1) + (alist2p name M2)) + (m-= (m-trans (m-+ M1 M2)) + (m-+ (m-trans M1)(m-trans M2)))) + :hints (("Goal" + :in-theory (disable m-binary-+)) + ("Subgoal 2" + :in-theory (disable m-binary-+ + alist2p-m-trans) + :use (:instance + alist2p-m-trans + (name '$arg) + (M (m-+ M1 M2)))) + ("Subgoal 1" + :in-theory (disable m-binary-+ + alist2p-m-+) + :use (:instance + alist2p-m-+ + (name '$arg) + (M1 (m-trans M1)) + (M2 (m-trans M2)))))) + +;;;;;;;;;;;;;;;;;; +;; Matrix product: + +(defun + dot (M1 M2 i j k) + "Return the dot product + (M1 i 0)*(M2 0 k) + . . . + (M1 i j)*(M2 j k)." + (declare (xargs :guard (and (integerp i) + (>= i 0) + (integerp j) + (>= j 0) + (integerp k) + (>= k 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< i (first dims1)) + (< j (second dims1)))) + (let ((dims2 (dimensions '$arg1 M2))) + (and (< j (first dims2)) + (< k (second dims2))))))) + (if (zp j) + (* (fix (aref2 '$arg1 M1 i 0)) + (fix (aref2 '$arg2 M2 0 k))) + (+ (* (fix (aref2 '$arg1 M1 i j)) + (fix (aref2 '$arg2 M2 j k))) + (dot M1 M2 i (- j 1) k)))) + +(defun + m-binary-*-row (M1 M2 m j n) + "Return an alist with the following values: + (dot M1 M2 m j 0), . . . , (dot M1 M2 m j n); + ie. construct an alist of values representing + the vector of dot products of the m'th row of M1 + with columns 0 thru n of M2." + (declare (xargs :guard (and (integerp m) + (>= m 0) + (integerp j) + (>= j 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< m (first dims1)) + (< j (second dims1)))) + (let ((dims2 (dimensions '$arg1 M2))) + (and (< j (first dims2)) + (< n (second dims2))))))) + (if (zp n) + (list (cons (cons m 0) + (dot M1 M2 m j 0))) + (cons (cons (cons m n) + (dot M1 M2 m j n)) + (m-binary-*-row M1 M2 m j (- n 1))))) + +(defun + m-binary-*-row-1 (M1 M2 m j n) + "Return an alist with all the following values: + (dot M1 M2 0 j 0), . . . , (dot M1 M2 0 j n) + . . . + . . . + . . . + (dot M1 M2 m j 0), . . . , (dot M1 M2 m j n)." + (declare (xargs :guard (and (integerp m) + (>= m 0) + (integerp j) + (>= j 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< m (first dims1)) + (< j (second dims1)))) + (let ((dims2 (dimensions '$arg1 M2))) + (and (< j (first dims2)) + (< n (second dims2))))))) + (if (zp m) + (m-binary-*-row M1 M2 0 j n) + (append (m-binary-*-row M1 M2 m j n) + (m-binary-*-row-1 M1 M2 (- m 1) j n)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Ensuring closure of matrix multiplication. + +; Let dim1 be the number of rows and dim2 be the number of columns +; in an ACL2 two dimensional array. The product, dim1*dim2, is +; required to fit into 32 bits so that some compilers can lay down +; faster code. Thus, dim1*dim2 <= maximum-positive-32-bit-integer +; = 2^31 - 1 +; = 2,147,483,647. + +; This restriction on the size of dim1*dim2 means that matrices +; representable by ACL2 arrays are NOT closed under matrix +; multiplication, even when the product is mathematically defined. +; To illustrate, suppose dim1*dim2 is required to be no larger than +; 20; M1 is a matrix with 5 rows and 2 columns; and M2 is a matrix +; with 2 rows and 5 columns. Then M1 and M2 would both be +; representable and their product, M1 * M2, would be mathematically +; defined, but not representable (since 25 > 20). + +; Furthermore, when there are more than two matrices involved in a +; matrix multiplication, the final product may be both mathematically +; defined and representable by an ACL2 array, but yet not +; computable in ACL2. Let's illustrate by extending the example given +; above with M1 and M2. Suppose M0 is a matrix with 2 rows and 5 +; colums. Then the product (M0 * M1) * M2 is mathematically defined, +; representable in ACL2, and computable in ACL2 (since both partial +; products (M0 * M1) and (M0 * M1) * M2 are representable in ACL2). +; But the product M0 * (M1 * M2) is mathematically defined, +; representable in ACL2, but NOT computable in ACL2 (since the +; partial product (M1 * M2) is NOT representable in ACL2). + +; One way to prevent this last problem and also ensure closure for +; matrix multiplication is to require that each of dim1 and dim2 +; be less than or equal to 46,340 which is the integer square root +; of 2,147,483,647, the maximum-positive-32-bit-integer. Then +; the product of dim1*dim2 is guarenteed to be less than the +; the maximum-positive-32-bit-integer. Futhermore, with this stronger +; restriction, if the product M1 * . . . * Mn is both mathematically +; defined and representable in ACL2, then, for any way of +; parenthesizing this product, all the partial products are also +; mathematically defined and representable in ACL2. + +; Thus, for matrix multiplication, it is required that both the +; number of rows and the number of columns be less than or equal +; to 46,340. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun m-binary-* (M1 M2) + "Return an alist representing the matrix product + of the matrices represented by the alists M1 + and M2. This is done by adding a header to an + alist containing the appropriate values." + (declare (xargs :guard (and (array2p '$arg1 M1) + (array2p '$arg2 M2) + (= (second (dimensions '$arg1 M1)) + (first (dimensions '$arg2 M2)))))) + (let* ((dim1 (dimensions '$arg1 M1)) + (dim2 (dimensions '$arg2 M2)) + (dim11 (first dim1)) + (dim12 (second dim1)) + (dim21 (first dim2)) + (dim22 (second dim2))) + (if (mbt (and (alist2p '$arg1 M1) + (alist2p '$arg2 M2) + (= dim12 dim21))) + (cons (list :HEADER + :DIMENSIONS + (list dim11 dim22) + :MAXIMUM-LENGTH + (+ 1 (* dim11 dim22)) + :DEFAULT 0 + :NAME 'matrix-product) + (m-binary-*-row-1 (compress2 '$arg1 M1) + (compress2 '$arg2 M2) + (- dim11 1) + (- dim12 1) + (- dim22 1))) + (* M1 M2)))) + +(defmacro + m-* (&rest rst) + (if rst + (if (cdr rst) + (xxxjoin 'm-binary-* rst) + (car rst)) + 1)) + +(add-binop m-* m-binary-*) + +(defthm + alist2p-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2)))) + (alist2p name (m-* M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-* M1 M2)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions + maximum-length)))) + +(defthm + array2p-m-*-1 + (implies (and (array2p name M1) + (array2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2))) + (< (* (first (dimensions name M1)) + (second (dimensions name M2))) + *MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (array2p name (m-* M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-* M1 M2)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + array2p-m-* + (implies (and (array2p name M1) + (array2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2))) + (<= (first (dimensions name M1)) + *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (<= (second (dimensions name M2)) + *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (array2p name (m-* M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-* M1 M2)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + dimensions-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2)))) + (equal (dimensions name (m-* M1 M2)) + (list (first (dimensions name M1)) + (second (dimensions name M2))))) + :hints (("Goal" + :in-theory (enable alist2p dimensions header)))) + +(defthm + matrixp-m-* + (implies (and (matrixp m n X1) + (matrixp n p X2)) + (matrixp m p (m-* X1 X2))) + :hints (("Goal" + :in-theory (disable m-binary-*)))) + +(defthm + default-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2)))) + (equal (default name (m-* M1 M2)) + 0)) + :hints (("Goal" + :in-theory (enable alist2p default header)))) + +(defthm + maximum-length-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2)))) + (equal (maximum-length name (m-* M1 M2)) + (+ 1 (* (first (dimensions name M1)) + (second (dimensions name M2)))))) + :hints (("Goal" + :in-theory (enable alist2p maximum-length header)))) + +(defthm + aref2-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2))) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (first (dimensions name M1))) + (< j (second (dimensions name M2)))) + (equal (aref2 name (m-* M1 M2) i j) + (dot M1 + M2 + i + (+ -1 (second (dimensions name M1))) + j))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defcong + ;; M-=-IMPLIES-EQUAL-M-*-1 + m-= equal (M-* M1 M2) 1) + +(defcong + ;; M-=-IMPLIES-EQUAL-M-*-2 + m-= equal (M-* M1 M2) 2) + +(defthm + left-nullity-of-m-0-for-m-* + (implies (and (alist2p name M1) + (integerp m) + (> m 0)) + (m-= (m-* (m-0 m (first (dimensions name M1))) + M1) + (m-0 m (second (dimensions name M1)))))) + +(defthm + right-nullity-of-m-0-for-m-* + (implies (and (alist2p name M1) + (integerp p) + (> p 0)) + (m-= (m-* M1 + (m-0 (second (dimensions name M1)) + p)) + (m-0 (first (dimensions name M1)) + p)))) + +(defthm + aref2-m-1 + (implies (and (integerp i) + (integerp n) + (<= 0 i) + (< i n)) + (equal (aref2 name (m-1 n) i j) + (if (equal i j) + 1 + 0)))) + +(defthm + left-unity-of-m-1-for-m-* + (implies (alist2p name M1) + (m-= (m-* (m-1 (first (dimensions name M1))) + M1) + M1))) + +(defthm + right-unity-of-m-1-for-m-* + (implies (alist2p name M1) + (m-= (m-* M1 + (m-1 (second (dimensions name M1)))) + M1))) + +(defthm + associativity-of-m-* + (equal (m-* (m-* M1 M2) M3) + (m-* M1 M2 M3))) + +(defthm + left-distributivity-of-m-*-over-m-+ + (m-= (m-* M1 (m-+ M2 M3)) + (m-+ (m-* M1 M2) + (m-* M1 M3)))) + +(defthm + right-distributivity-of-m-*-over-m-+ + (m-= (m-* (m-+ M1 M2) M3) + (m-+ (m-* M1 M3) + (m-* M2 M3)))) + +(local + (defthm + m-*-m--_left-lemma + (implies (and (equal (c M1)(r M2)) + (alist2p name M1) + (alist2p name M2)) + (m-= (m-+ (m-* M1 M2)(m-* (m-- M1) M2)) + (m-0 (r M1)(c M2)))) + :rule-classes nil + :hints (("Goal" + :in-theory (disable m-= m-binary-+ m-binary-*) + :use (:theorem + (m-= (m-+ (m-* M1 M2)(m-* (m-- M1) M2)) + (m-* (m-+ M1 (m-- M1)) M2))))))) + +(defthm + m-*-m--_left + (implies (and (equal (c M1)(r M2)) + (alist2p name M1) + (alist2p name M2)) + (m-= (m-* (m-- M1) M2) + (m-- (m-* M1 M2)))) + :hints (("Goal" + :in-theory (disable m-= m-binary-+ m-binary-*) + :use ((:instance + uniqueness-of-m-+-inverse + (X (m-* (m-- M1) M2)) + (Y (m-* M1 M2))) + m-*-m--_left-lemma)))) + +(local + (defthm + m-*-m--_right-lemma + (implies (and (equal (c M1)(r M2)) + (alist2p name M1) + (alist2p name M2)) + (m-= (m-+ (m-* M1 M2)(m-* M1 (m-- M2))) + (m-0 (r M1)(c M2)))) + :rule-classes nil + :hints (("Goal" + :in-theory (disable m-= m-binary-+ m-binary-*) + :use ((:theorem + (m-= (m-+ (m-* M1 M2)(m-* M1 (m-- M2))) + (m-* M1 (m-+ M2 (m-- M2))))) + (:instance + right-nullity-of-m-0-for-m-* + (p (c M2)))))))) + +(defthm + m-*-m--_right + (implies (and (equal (c M1)(r M2)) + (alist2p name M1) + (alist2p name M2)) + (m-= (m-* M1 (m-- M2)) + (m-- (m-* M1 M2)))) + :hints (("Goal" + :in-theory (disable m-= m-binary-+ m-binary-*) + :use ((:instance + uniqueness-of-m-+-inverse + (X (m-* M1 (m-- M2))) + (Y (m-* M1 M2))) + m-*-m--_right-lemma)))) + +(defthm + m-=-m-trans-m-1 + (implies (and (integerp n) + (> n 0)) + (m-= (m-trans (m-1 n)) + (m-1 n)))) + +(defthm + m-*-s-*-left + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2))) + (m-= (m-* (s-* a M1) M2) + (s-* a (m-* M1 M2)))) + :hints (("Goal" + :in-theory (disable m-binary-*)) + ("Subgoal 2" + :in-theory (disable m-binary-* + alist2p-m-*) + :use (:instance + alist2p-m-* + (name '$arg) + (M1 (s-* a M1)))) + ("Subgoal 1" + :in-theory (disable m-binary-* + alist2p-s-*) + :use (:instance + alist2p-s-* + (name '$arg) + (M (m-* M1 M2)))))) + +(defthm + m-*-s-*-right + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2))) + (m-= (m-* M1 (s-* a M2)) + (s-* a (m-* M1 M2)))) + :hints (("Goal" + :in-theory (disable m-binary-*)) + ("Subgoal 2" + :in-theory (disable m-binary-* + alist2p-m-*) + :use (:instance + alist2p-m-* + (name '$arg) + (M2 (s-* a M2)))) + ("Subgoal 1" + :in-theory (disable m-binary-* + alist2p-s-*) + :use (:instance + alist2p-s-* + (name '$arg) + (M (m-* M1 M2)))))) + +(defthm + m-trans-m-*=m-*-m-trans + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2))) + (m-= (m-trans (m-* M1 M2)) + (m-* (m-trans M2)(m-trans M1)))) + :hints (("Goal" + :in-theory (disable m-binary-*)) + ("Subgoal 2" + :in-theory (disable m-binary-* + alist2p-m-trans) + :use (:instance + alist2p-m-trans + (name '$arg) + (M (m-* M1 M2)))) + ("Subgoal 1" + :in-theory (disable m-binary-* + alist2p-m-*) + :use (:instance + alist2p-m-* + (name '$arg) + (M1 (m-trans M2)) + (M2 (m-trans M1)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Row and column operations on ACL2 arrays: + +(defun + Ri<->Rj-loop (name M i j k) + (declare (xargs :guard (and (array2p name M) + (integerp i) + (integerp j) + (integerp k) + (>= i 0) + (>= j 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims)) + (dims2 (second dims))) + (and (< i dims1) + (< j dims1) + (< k dims2)))))) + (if (zp k) + (let ((temp (aref2 name M i 0))) + (aset2 name + (aset2 name + M + i + 0 + (aref2 name + M + j + 0)) + j + 0 + temp)) + (Ri<->Rj-loop name + (let ((temp (aref2 name M i k))) + (aset2 name + (aset2 name + M + i + k + (aref2 name + M + j + k)) + j + k + temp)) + i + j + (- k 1)))) + +(defun + Ri<->Rj (name M i j) + "Return the result of interchanging + row i and row j in array M." + (declare (xargs :guard (and (array2p name M) + (integerp i) + (integerp j) + (/= i j) + (>= i 0) + (>= j 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims))) + (and (< i dims1) + (< j dims1)))))) + (Ri<->Rj-loop name + M + i + j + (- (second (dimensions name M)) 1))) + +(defun + Ci<->Cj-loop (name M i j k) + (declare (xargs :guard (and (array2p name M) + (integerp i) + (integerp j) + (integerp k) + (>= i 0) + (>= j 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims)) + (dims2 (second dims))) + (and (< i dims2) + (< j dims2) + (< k dims1)))))) + (if (zp k) + (let ((temp (aref2 name M 0 i))) + (aset2 name + (aset2 name + M + 0 + i + (aref2 name + M + 0 + j)) + 0 + j + temp)) + (Ci<->Cj-loop name + (let ((temp (aref2 name M k i))) + (aset2 name + (aset2 name + M + k + i + (aref2 name + M + k + j)) + k + j + temp)) + i + j + (- k 1)))) + +(defun + Ci<->Cj (name M i j) + "Return the result of interchanging + column i and column j in array M." + (declare (xargs :guard (and (array2p name M) + (integerp i) + (integerp j) + (/= i j) + (>= i 0) + (>= j 0) + (let* ((dims (dimensions name M)) + (dims2 (second dims))) + (and (< i dims2) + (< j dims2)))))) + (Ci<->Cj-loop name + M + i + j + (- (first (dimensions name M)) 1))) + +(defun + Ri<-aRi-loop (name M a i k) + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp k) + (>= i 0) + (>= k 0) + (let ((dims (dimensions name M))) + (and (< i (first dims)) + (< k (second dims))))))) + (if (zp k) + (aset2 name + M + i + 0 + (* a (fix (aref2 name + M + i + 0)))) + (Ri<-aRi-loop name + (aset2 name + M + i + k + (* a (fix (aref2 name + M + i + k)))) + a + i + (- k 1)))) + +(defun + Ri<-aRi (name M a i) + "Return the result of replacing each element, + Mij, in row i of array M, with (* a Mij)." + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (>= i 0) + (< i (first (dimensions name M)))))) + (Ri<-aRi-loop name + M + a + i + (- (second (dimensions name M)) 1))) + +(defun + Ci<-aCi-loop (name M a i k) + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp k) + (>= i 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims)) + (dims2 (second dims))) + (and (< i dims2) + (< k dims1)))))) + + (if (zp k) + (aset2 name + M + 0 + i + (* a (fix (aref2 name + M + 0 + i)))) + (Ci<-aCi-loop name + (aset2 name + M + k + i + (* a (fix (aref2 name + M + k + i)))) + a + i + (- k 1)))) + +(defun + Ci<-aCi (name M a i) + "Return the result of replacing each element, + Mji, in column i of array M, with (* a Mji)." + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (>= i 0) + (< i (second (dimensions name M)))))) + (Ci<-aCi-loop name + M + a + i + (- (first (dimensions name M)) 1))) + +(defun + Rj<-aRi+Rj-loop (name M a i j k) + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp j) + (integerp k) + (>= i 0) + (>= j 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims))) + (and (< i dims1) + (< j dims1) + (< k (second dims))))))) + (if (zp k) + (aset2 name + M + j + 0 + (+ (* a (fix (aref2 name + M + i + 0))) + (fix (aref2 name + M + j + 0)))) + (Rj<-aRi+Rj-loop name + (aset2 name + M + j + k + (+ (* a (fix (aref2 name + M + i + k))) + (fix (aref2 name + M + j + k)))) + a + i + j + (- k 1)))) + +(defun + Rj<-aRi+Rj (name M a i j) + "Return the result of replacing each element, + Mjk, in row j of matrix M, with (+ (* a Mik) Mjk)." + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp j) + (/= i j) + (>= i 0) + (>= j 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims))) + (and (< i dims1) + (< j dims1)))))) + (Rj<-aRi+Rj-loop name + M + a + i + j + (- (second (dimensions name M)) 1))) + +(defun + Cj<-aCi+Cj-loop (name M a i j k) + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp j) + (integerp k) + (>= i 0) + (>= j 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims2 (second dims))) + (and (< i dims2) + (< j dims2) + (< k (first dims))))))) + (if (zp k) + (aset2 name + M + 0 + j + (+ (* a (fix (aref2 name + M + 0 + i))) + (fix (aref2 name + M + 0 + j)))) + (Cj<-aCi+Cj-loop name + (aset2 name + M + k + j + (+ (* a (fix (aref2 name + M + k + i))) + (fix (aref2 name + M + k + j)))) + a + i + j + (- k 1)))) + +(defun + Cj<-aCi+Cj (name M a i j) + "Return the result of replacing each element, + Mkj, in column j of matrix M, with (+ (* a Mki) + Mkj)." + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp j) + (/= i j) + (>= i 0) + (>= j 0) + (let* ((dims (dimensions name M)) + (dims2 (second dims))) + (and (< i dims2) + (< j dims2)))))) + + (Cj<-aCi+Cj-loop name + M + a + i + j + (- (first (dimensions name M)) 1))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Matrix inverse and determinant: + +;; Description of algorithm for computing the +;; inverse and determinant. + +;; Input a square matrix M. + +;; let A <- I +;; B <- I +;; C <- M +;; D <- 1 + +;; Row reduce C to I. +;; Apply same row operations to B. +;; Multiply A successively on right by +;; inverse of same row operations. +;; (Done with equivalent column operations.) +;; Modify D according to column operations on A. +;; Ci<->Cj: D <- -1 * D +;; Ci<-aCi: D <- a * D +;; Cj<-aCi+Cj: D <- D + +;; Invariants +;; A * B = I +;; B * M = C +;; D = determinant of A + +;; After termination +;; A = left inverse of B +;; B = left inverse of M (because C contains I +;; after termination) + +;; Prove that after termination A = M: +;; A = A * I = A * (B * M) +;; = (A * B) * M = I * M = M + +;; Thus B is both left and right inverse of M +;; and D is the determinant of M. + +;; Inverse row operations: +;; (Ri<->Rj)^(-1) = Ri<->Rj +;; (Ri<-aRi)^(-1) = Ri<-(/a)Ri +;; (Rj<-aRi+Rj)^(-1) = Rj<-(-a)Ri+Rj + +;; Equivalent row and column operations as +;; applied to identity matrix: I +;; Ri<->Rj(I) = Ci<->Cj(I) +;; Ri<-aRi(I) = Ci<-aCi(I) +;; Rj<-aRi+Rj(I) = Ci<-aCj+Ci(I) + +;; Row operation applied to M is the same as +;; multiplying M on the LEFT by the result +;; of applying the same operation to I. + +;; Column operation applied to M is the same as +;; multiplying M on the RIGHT by the result +;; of applying the same operation to I. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun + zero-column (A B C i1 j i) + "For k = i downto 0, + when k differs from i1 and (aref2 '$C C k j) is a nonzero number then + replace column i1 in A with (aref2 '$C C k j) * column k + column i1, + replace row k in B with (- (aref2 '$C C k j)) * row i1 + row k, + replace row k in C with (- (aref2 '$C C k j)) * row i1 + row k. + When (aref2 '$C C i1 j) = 1, then all other entries in the jth + column of C are modified to 0." + (declare (xargs :guard (and (array2p '$a A) + (array2p '$b B) + (array2p '$c C) + (integerp i) + (>= i 0) + (integerp i1) + (>= i1 0) + (integerp j) + (>= j 0) + (< i (second + (dimensions '$a + A))) + (< i (first + (dimensions '$b + B))) + (< i (first + (dimensions '$c + C))) + (< i1 (second + (dimensions '$a + A))) + (< i1 (first + (dimensions '$b + B))) + (< i1 (first + (dimensions '$c + C))) + (< j (second + (dimensions '$c + C)))))) + (if (zp i) + (if (not (zp i1)) + (let ((val (fix (aref2 '$C C 0 j)))) + (if (= val 0) + (mv A B C) + (mv (Cj<-aCi+Cj '$A A val 0 i1) + (Rj<-aRi+Rj '$B B (- val) i1 0) + (Rj<-aRi+Rj '$C C (- val) i1 0)))) + (mv A B C)) + (if (not (equal i i1)) + (let ((val (fix (aref2 '$C C i j)))) + (if (= val 0) + (zero-column A B C i1 j (- i 1)) + (zero-column (Cj<-aCi+Cj '$A A val i i1) + (Rj<-aRi+Rj '$B B (- val) i1 i) + (Rj<-aRi+Rj '$C C (- val) i1 i) + i1 + j + (- i 1)))) + (zero-column A B C i1 j (- i 1))))) + +(defun + find-non-zero-col (name C i j k) + "Determine if there is a nonzero value among + C(i k), C(i+1) k), . . . , C(j k). + If not, return nil, otherwise return the + first n such that C(n k) is nonzero." + (declare (xargs :measure (let ((i (nfix i)) + (j (nfix j))) + (if (> i j) + 0 + (- (+ j 1) i))) + :guard (and (array2p name C) + (integerp i) + (integerp j) + (integerp k) + (>= k 0) + (< j (first + (dimensions name + C))) + (< k (second + (dimensions name + C)))))) + (let ((i (nfix i)) + (j (nfix j))) + (cond ((> i j) nil) + ((zerop (fix (aref2 name C i k))) + (find-non-zero-col name C (+ i 1) j k)) + (t i)))) + +(defun + find-non-zero-col-1 (name C i j k n) + "Determine if there is a nonzero value among + C(i k) C(i k+1) . . . C(i n) + C(i+1) k) C(i+1 k+1) . . . C(i+1 n) + . . . . + . . . . + . . . . + C(j k) C(j k+1) . . . C(j n) + If not, return nil, otherwise return the + first, obtained by searching column by column, + pair p q, such that C(p q) is nonzero." + (declare (xargs :measure (let ((k (nfix k)) + (n (nfix n))) + (if (> k n) + 0 + (- (+ n 1) k))) + :guard (and (array2p name C) + (integerp i) + (integerp j) + (integerp k) + (integerp n) + (< j (first (dimensions name C))) + (< n (second (dimensions name C)))))) + (let ((k (nfix k)) + (n (nfix n))) + (if (> k n) + nil + (let ((p (find-non-zero-col name C i j k))) + (if p + (list p k) + (find-non-zero-col-1 name + C + i + j + (+ k 1) + n)))))) + +(defun + determinant-inverse-loop (A B C D i j k n) + "Process columns k thru n, + restricted to rows i thru j." + (declare (xargs :measure (let ((k (nfix k)) + (n (nfix n))) + (if (> k n) + 0 + (- (+ n 1) k))) + :guard (and (array2p '$a A) + (array2p '$b B) + (array2p '$c C) + (acl2-numberp D) + (integerp i) + (integerp j) + (integerp k) + (integerp n) + (>= i 0) + (>= j 0) + (>= k 0) + (>= n 0) + (< i (second + (dimensions '$a + A))) + (< i (first + (dimensions '$b + B))) + (< i (first + (dimensions '$c + C))) + (< j (second + (dimensions '$a + A))) + (< j (first + (dimensions '$b + B))) + (< j (first + (dimensions '$c + C))) + (< n (second + (dimensions '$c + C)))) + :verify-guards nil)) + (let ((k (nfix k)) + (n (nfix n)) + (i (nfix i)) + (j (nfix j))) + (if (> k n) + (mv A B C D) + (let + ((indices (find-non-zero-col-1 '$C C i j k n))) + (if indices + (let* + ((p (first indices)) + (q (second indices)) + (val (aref2 '$C C p q))) + (if (= p i) + (mv-let + (A B C) + (zero-column (Ci<-aCi '$A A val i) + (Ri<-aRi '$B B (/ val) i) + (Ri<-aRi '$C C (/ val) i) + i + q + j) + (cond ((= i j) + (mv A B C (* val D))) + ((= q i) + (determinant-inverse-loop A B C + (* val D) + (+ i 1) + j + (+ q 1) + n)) + (t + (determinant-inverse-loop A B C + (* val D) + 0 + j + (+ q 1) + n)))) + (mv-let + (A B C) + (zero-column (Ci<-aCi '$A (Ci<->Cj '$A A i p) val i) + (Ri<-aRi '$B (Ri<->Rj '$B B i p)(/ val) i) + (Ri<-aRi '$C (Ri<->Rj '$C C i p)(/ val) i) + i + q + j) + (cond ((= i j) + (mv A B C (* val (- D)))) + ((= q i) + (determinant-inverse-loop A B C + (* val (- D)) + (+ i 1) + j + (+ q 1) + n)) + (t + (determinant-inverse-loop A B C + 0 + (+ i 1) + j + (+ q 1) + n)))))) + (mv A B C 0)))))) + +(verify-guards determinant-inverse-loop) + +(defun + determinant-inverse (M) + "Return multiple values A, B, C, and D. + If M is a square array, the determinant of + M is returned in D. If the determinant is + nonzero, then the matrix inverse of M is + returned in B." + (declare (xargs :guard (and (array2p '$c M) + (let ((dims (dimensions '$c M))) + (= (first dims) + (second dims)))))) + (let ((dims (dimensions '$c M))) + (if (mbt (and (alist2p '$c M) + (= (first dims) + (second dims)))) + (let ((dim1 (first dims))) + (determinant-inverse-loop (compress2 '$A (m-1 dim1)) + (compress2 '$B (m-1 dim1)) + (compress2 '$C M) + 1 ;; initial value of D + 0 + (- dim1 1) + 0 + (- (second (dimensions '$c M)) 1))) + (mv M (/ M) 1 M)))) + +(defun + determinant (M) + (declare (xargs :guard (and (array2p '$c M) + (let ((dims (dimensions '$c M))) + (= (first dims) + (second dims)))))) + (mv-let (A B C D) + (determinant-inverse M) + (declare (ignore A B C)) + D)) + +(defun + m-/ (M) + (declare (xargs :guard (and (array2p '$c M) + (let ((dims (dimensions '$c M))) + (= (first dims) + (second dims)))))) + (mv-let (A B C D) + (determinant-inverse M) + (declare (ignore A C D)) + B)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Eventually, we will prove that for square matrices +;; whenever the determinant is not 0, then m-/ +;; computes the two-sided inverse; and whenever the +;; determinant is 0 then there is no inverse. +;; Also it will be proved that non-square matrices +;; do not have two-sided inverses. + +;; Meanwhile the definition of singualar given +;; immediately below is replaced by the second one +;; below. + +;; (defun +;; m-singularp (M) +;; (declare (xargs :guard (array2p '$c M))) +;; (not (and (mbt (alist2p '$c M)) +;; (let ((dims (dimensions '$c M))) +;; (= (first dims) +;; (second dims))) +;; (= (determinant M) 0)))) +|#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun + m-singularp (M) + (declare (xargs :guard (array2p '$c M) + :verify-guards nil)) + (not (and (mbt (alist2p '$c M)) + (let ((dims (dimensions '$c M))) + (= (first dims) + (second dims))) + (m-= (m-* M (m-/ M)) + (m-1 (r M))) + (m-= (m-* (m-/ M) M) + (m-1 (r M)))))) + +(defthm + non-singular-implies-square + (implies (not (m-singularp M)) + (equal (equal (c M)(r M)) + t))) + +(defthm + left-m-*-inverse-of-m-/ + (implies (not (m-singularp M)) + (m-= (m-* (m-/ M) M) + (m-1 (r M))))) + +(defthm + right-m-*-inverse-of-m-/ + (implies (not (m-singularp M)) + (m-= (m-* M (m-/ M)) + (m-1 (r M))))) + +(defthm + dimensions-m-/ + (implies (and (alist2p name M) + (equal (first (dimensions name M)) + (second (dimensions name M)))) + (equal (dimensions name (m-/ M)) + (list (car (dimensions name M)) + (car (dimensions name M)))))) + +(defthm + alist2p-m-/ + (implies (and (alist2p name M) + (equal (first (dimensions name M)) + (second (dimensions name M)))) + (alist2p name (m-/ M)))) + +(defthm + array2p-m-/ + (implies (and (array2p name M) + (equal (first (dimensions name M)) + (second (dimensions name M)))) + (array2p name (m-/ M))) + :hints (("Goal" + :in-theory + (disable + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1) + :use + (:instance + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1 + (D 1))))) + +(defthm + matrixp-m-/ + (implies (and (matrixp (r M)(c M) M) + (equal (r M)(c M))) + (matrixp (r M)(c M)(m-/ M))) + :hints (("Goal" + :in-theory + (disable + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1) + :use + (:instance + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1 + (D 1) + (name '$arg))))) + +(verify-guards m-singularp) + +(in-theory (disable matrixp + m-= + m-0 + m-1 + m-trans + m-unary-- + s-* + m-binary-+ + m-binary-* + m-/ + m-singularp)) + +(local (in-theory (enable m-singularp))) + +(defthm + uniqueness-of-m-*-inverse + (implies (and (alist2p name X) + (not (m-singularp Y)) + (equal (r X)(r Y)) + (equal (c X)(c Y)) + (m-= (m-* X Y) + (m-1 (r X)))) + (m-= X (m-/ Y))) + :rule-classes nil + :hints (("Goal" + :in-theory (disable + right-unity-of-m-1-for-m-* + left-unity-of-m-1-for-m-*) + :use ((:instance + M-=-IMPLIES-EQUAL-M-*-1 + (M1 (m-* X Y)) + (M1-equiv (m-1 (r X))) + (M2 (m-/ Y))) + (:instance + right-unity-of-m-1-for-m-* + (name '$arg) + (M1 X)) + (:instance + left-unity-of-m-1-for-m-* + (name '$arg) + (M1 (m-/ Y))))))) + +(defthm + m-/-m-*-lemma + (implies (and (not (m-singularp M1)) + (not (m-singularp M2)) + (equal (c M1)(r M2))) + (m-= (m-* (m-/ M2)(m-* (m-/ M1) M1) M2) + (m-1 (r M1)))) + :rule-classes nil + :hints (("Goal" + :in-theory (disable + ASSOCIATIVITY-OF-M-* + left-unity-of-m-1-for-m-*) + :use (:instance + left-unity-of-m-1-for-m-* + (name '$arg) + (M1 M2))))) + +(defthm + Subgoal-8-hack + (IMPLIES (AND (ALIST2P '$C M1) + (ALIST2P '$C M2) + (EQUAL (CADR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M1))) + (EQUAL (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2))) + (EQUAL (CAR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M2)))) + (ALIST2P NAME (M-* (M-/ M2) + (M-/ M1)))) + :hints (("Goal" + :in-theory (disable ALIST2P-M-*) + :use (:instance + ALIST2P-M-* + (M1 (M-/ M2)) + (M2 (M-/ M1)) + (name '$arg))))) + +(defthm + m-/-m-* + (implies (and (not (m-singularp M1)) + (not (m-singularp M2)) + (not (m-singularp (m-* M1 M2))) + (equal (c M1)(r M2))) + (m-= (m-/ (m-* M1 M2)) + (m-* (m-/ M2)(m-/ M1)))) + :hints (("Goal" + :use ((:instance + uniqueness-of-m-*-inverse + (X (m-* (m-/ M2)(m-/ M1))) + (Y (m-* M1 M2))) + m-/-m-*-lemma)))) + +(defthm + m--_m-0 + (implies (and (integerp m) + (> m 0) + (integerp n) + (> n 0)) + (m-= (m-- (m-0 m n)) + (m-0 m n))) + :hints (("Goal" + :in-theory (disable m-=-s-*-m-0 + m-=-s-*_-1) + :use ((:instance + m-=-s-*-m-0 + (a -1)) + (:instance + m-=-s-*_-1 + (M (m-0 m n))))))) + +(defthm + m-=_s-*_m-- + (implies (alist2p name M) + (m-= (s-* a (m-- M)) + (m-- (s-* a M)))) + :hints (("Goal" + :in-theory (disable + associate-scalars-left-s-*) + :use ((:instance + associate-scalars-left-s-* + (a1 -1) + (a2 a)) + (:instance + associate-scalars-left-s-* + (a1 a) + (a2 -1)))))) + +(defthm + distributivity-of-m--_over-m-+ + (implies (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))) + (alist2p name M1) + (alist2p name M2)) + (m-= (m-- (m-+ M1 M2)) + (m-+ (m-- M1)(m-- M2)))) + :hints (("Goal" + :in-theory + (disable distributivity-of-s-*-over-m-+) + :use (:instance + distributivity-of-s-*-over-m-+ + (a -1))))) + diff --git a/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/matrix.lisp b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/matrix.lisp new file mode 100644 index 0000000..bc42dc1 --- /dev/null +++ b/books/workshops/2003/cowles-gamboa-van-baalen_matrix/support/matrix.lisp @@ -0,0 +1,9871 @@ +; The ACL2 Matrices (Implemented as ACL2 2-D Arrays) Book. +; Copyright (C) 2002 Ruben Gamboa and John R. Cowles, University of Wyoming + +; This book is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This book is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this book; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: +; Ruben Gamboa and John Cowles +; Department of Computer Science +; University of Wyoming +; Laramie, WY 82071-3682 U.S.A. + +; Summer and Fall 2002. +; Last modified 13 June 2003. + +; ACL2 Version 2.8 alpha (as of May 11 03) +#| + To certify in + ACL2 Version 2.8 alpha (as of May 11 03) + +(certify-book "matrix" + 0 + t ;;compile-flg + ) +|# +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +At UW: + +:set-cbd "/home/faculty/cowles/acl2/matrix/" ;;pyramid + +:set-cbd "/home/cowles/matrix/" ;; turing +|# + +(in-package "ACL2") + +#| +(local ;;turing + (include-book + "/home/cowles/acl2-sources/books/arithmetic-2.8/top")) + +(local ;;pyramid + (include-book + "/home/acl2/acl2-2.8/v2-8-alpha-05-11-03/books/arithmetic/top")) +|# + +(local + (include-book "../../../../arithmetic/top")) + +(include-book "array2") + +(include-book "alist2") + +(defthm + compress211-$arg + (implies (syntaxp (not (eq name ''$arg))) + (equal (compress211 name l n i j default) + (compress211 '$arg l n i j default)))) + +(defthm + compress21-$arg + (implies (syntaxp (not (eq name ''$arg))) + (equal (compress21 name l n i j default) + (compress21 '$arg l n i j default)))) + +(defthm + array2p-$arg-equal-parts + (implies (syntaxp (not (eq name ''$arg))) + (and (equal (header name l) + (header '$arg l)) + (equal (dimensions name l) + (dimensions '$arg l)) + (equal (maximum-length name l) + (maximum-length '$arg l)) + (equal (default name l) + (default '$arg l)) + (equal (compress2 name l) + (compress2 '$arg l)) + (equal (aref2 name l i j) + (aref2 '$arg l i j)) + (equal (aset2 name l i j val) + (aset2 '$arg l i j val))))) + +(defthm + array2p-$arg + (implies (array2p name l) + (array2p '$arg l)) + :rule-classes :forward-chaining) + +(defthm + not-array2p-arg$ + (implies (and (not (array2p name l)) + (symbolp name)) + (not (array2p '$arg l))) + :rule-classes :forward-chaining) + +(defthm + alist2p-$arg + (implies (alist2p name l) + (alist2p '$arg l)) + :rule-classes :forward-chaining) + +(defthm + not-alist2p-arg$ + (implies (not (alist2p name l)) + (not (alist2p '$arg l))) + :rule-classes :forward-chaining) + +(in-theory (disable alist2p array2p aset2 aref2 compress2 header + dimensions maximum-length default)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Boolean test for a matrix: + +;; The need for the following constant is explained in +;; detail later in this book: + +;; Search for +;; ; Ensuring closure of matrix multiplication. + +(defconst + *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER* + 46340) + +;; To ensure that matrix multiplication is closed, the +;; matrix can have no more that 46,340 rows and no more +;; 46,340 columns. + +(defun + matrixp (m n X) + "Determine if X is a m by n matrix." + (declare (xargs :guard t)) + (and (array2p '$arg X) + (let ((dims (dimensions '$arg X))) + (and (equal m (first dims)) + (equal n (second dims)))) + (<= m *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (<= n *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*))) + +(defmacro + r (M) + "Return the number of rows in the matrix M." + `(car (dimensions '$arg ,M))) + +(defmacro + c (M) + "Return the number of columns in the matrix M." + `(cadr (dimensions '$arg ,M))) + +(defthm + array2p-matrixp + (implies (and (array2p name M) + (<= (r M) *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (<= (c M) *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (matrixp (r M)(c M) M))) + +;;;;;;;;;;;;;;;;;;; +;; Matrix equality: + +(defun + m-=-row (M1 M2 m n) + "Determine if all the following equalities hold: + M1(m 0) = M2(m 0), . . . , M1(m n) = M2(m n); + ie. determine if the m'th row of M1 matches the + m'th row of M2. + All entries are treated as numbers." + (declare (xargs :guard (and (integerp m) + (>= m 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< m (car dims1)) + (< n (cadr dims1)))) + (let ((dims2 (dimensions '$arg2 M2))) + (and (< m (car dims2)) + (< n (cadr dims2))))))) + (if (zp n) + (equal (fix (aref2 '$arg1 M1 m 0)) + (fix (aref2 '$arg2 M2 m 0))) + (and (equal (fix (aref2 '$arg1 M1 m n)) + (fix (aref2 '$arg2 M2 m n))) + (m-=-row M1 M2 m (- n 1))))) + +(defthm + reflexivity-of-m-=-row + (m-=-row X X m n)) + +(defthm + symmetry-of-m-=-row + (implies (m-=-row M1 M2 m n) + (m-=-row M2 M1 m n))) + +(defthm + transitivity-of-m-=-row + (implies (and (m-=-row M1 M2 m n) + (m-=-row M2 M3 m n)) + (m-=-row M1 M3 m n)) + :rule-classes (:rewrite :forward-chaining)) + +(defthm + m-=-row-compress2 + (implies (and (alist2p name l) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l))) + (< j (cadr (dimensions name l)))) + (m-=-row (compress2 name l) l i j))) + +(defthm + m-=-row-remove-compress2-1 + (implies (and (alist2p name l1) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l1))) + (< j (cadr (dimensions name l1)))) + (equal (m-=-row (compress2 name l1) l2 i j) + (m-=-row l1 l2 i j)))) + +(defthm + m-=-row-remove-compress2-2 + (implies (and (alist2p name l2) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l2))) + (< j (cadr (dimensions name l2)))) + (equal (m-=-row l1 (compress2 name l2) i j) + (m-=-row l1 l2 i j)))) + +(defthm + m-=-row-fix-aref2 + (implies (and (m-=-row M1 M2 m n) + (integerp n) + (integerp j) + (<= 0 j) + (<= j n)) + (equal (fix (aref2 name M1 m j)) + (fix (aref2 name M2 m j)))) + :rule-classes nil) + +(defun + m-=-row-1 (M1 M2 m n) + "Determine if all the following equalities hold: + M1(0 0) = M2(0 0), . . . , M1(0 n) = M2(0 n) + . . . + . . . + . . . + M1(m 0) = M2(m 0), . . . , M1(m n) = M2(m n); + ie. determine if rows 0 thru m of M1 matches + rows 0 thru m of M2. + All entries are treated as numbers." + (declare (xargs :guard (and (integerp m) + (>= m 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< m (car dims1)) + (< n (cadr dims1)))) + (let ((dims2 (dimensions '$arg2 M2))) + (and (< m (car dims2)) + (< n (cadr dims2))))))) + (if (zp m) + (m-=-row M1 M2 0 n) + (and (m-=-row M1 M2 m n) + (m-=-row-1 M1 M2 (- m 1) n)))) + +(defthm + reflexivity-of-m-=-row-1 + (m-=-row-1 X X m n)) + +(defthm + symmetry-of-m-=-row-1 + (implies (m-=-row-1 M1 M2 m n) + (m-=-row-1 M2 M1 m n))) + +(defthm + transitivity-of-m-=-row-1 + (implies (and (m-=-row-1 M1 M2 m n) + (m-=-row-1 M2 M3 m n)) + (m-=-row-1 M1 M3 m n)) + :rule-classes (:rewrite :forward-chaining)) + +(defthm + m-=-row-1-compress2 + (implies (and (alist2p name l) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l))) + (< j (cadr (dimensions name l)))) + (m-=-row-1 (compress2 name l) l i j))) + +(defthm + m-=-row-1-remove-compress2-1 + (implies (and (alist2p name l1) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l1))) + (< j (cadr (dimensions name l1)))) + (equal (m-=-row-1 (compress2 name l1) l2 i j) + (m-=-row-1 l1 l2 i j)))) + +(defthm + m-=-row-1-remove-compress2-2 + (implies (and (alist2p name l2) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l2))) + (< j (cadr (dimensions name l2)))) + (equal (m-=-row-1 l1 (compress2 name l2) i j) + (m-=-row-1 l1 l2 i j)))) + +(defthm + m-=-row-1-fix-aref2 + (implies (and (m-=-row-1 M1 M2 m n) + (integerp m) + (integerp n) + (integerp i) + (integerp j) + (<= 0 i) + (<= 0 j) + (<= i m) + (<= j n)) + (equal (fix (aref2 name M1 i j)) + (fix (aref2 name M2 i j)))) + :rule-classes nil + :hints (("Subgoal *1/2" + :use (:instance + m-=-row-fix-aref2 + (m i))) + ("Subgoal *1/1" + :use (:instance + m-=-row-fix-aref2 + (m 0))))) + +(defun + m-= (M1 M2) + "Determine if the matrices represented by the alists + M1 and M2 are equal (as matrices of numbers)." + (declare (xargs :guard (and (array2p '$arg1 M1) + (array2p '$arg2 M2)))) + (if (mbt (and (alist2p '$arg1 M1) + (alist2p '$arg2 M2))) + (let ((dim1 (dimensions '$arg1 M1)) + (dim2 (dimensions '$arg2 M2))) + (if (and (= (first dim1) + (first dim2)) + (= (second dim1) + (second dim2))) + (m-=-row-1 (compress2 '$arg1 M1) + (compress2 '$arg2 M2) + (- (first dim1) 1) + (- (second dim1) 1)) + nil)) + (equal M1 M2))) + +(defequiv + ;; m-=-is-an-equivalence + m-=) + +(defthm + m-=-compress2 + (implies (alist2p name l) + (m-= (compress2 name l) l))) + +(defthm + m-=-implies-equal-dims + (implies (m-= M1 M2) + (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))))) + :rule-classes nil) + +(defcong + ;; m-=-implies-equal-alist2p-2 + m-= equal (alist2p name M) 2 + :hints (("Goal" + :use (:theorem + (implies (m-= M M-equiv) + (iff (alist2p name M) + (alist2p name M-equiv) + )))))) + +(defthm + m-=-fix-aref2 + (implies (and (m-= M1 M2) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name M1))) + (< j (cadr (dimensions name M1)))) + (equal (fix (aref2 name M1 i j)) + (fix (aref2 name M2 i j)))) + :rule-classes nil + :hints (("Subgoal 3'" + :use (:instance + m-=-row-1-fix-aref2 + (name '$arg) + (m (+ -1 (car (dimensions '$arg M1))) + ) + (n (+ -1 (cadr (dimensions '$arg M1)) + )))) + ("Subgoal 2'" + :use (:instance + m-=-row-1-fix-aref2 + (name '$arg) + (m (+ -1 (car (dimensions '$arg M1))) + ) + (n (+ -1 (cadr (dimensions '$arg M1)) + )))) + ("Subgoal 1'" + :use (:instance + m-=-row-1-fix-aref2 + (name '$arg) + (m (+ -1 (car (dimensions '$arg M1))) + ) + (n (+ -1 (cadr (dimensions '$arg M1)) + )))))) + +;;;;;;;;;;;;;;; +;; Zero matrix: + +(defun + m-0 (m n) + "Return an alist representing the m by n matrix whose + elements are all equal to 0. + To use the ACL2 efficient array mechanism to store (m-0 m n), + (* m n)) must be stictly less than 2147483647 which is + the *MAXIMUM-POSITIVE-32-BIT-INTEGER*." + (declare (xargs :guard (and (integerp m) + (integerp n) + (> m 0) + (> n 0)))) + (list (list :HEADER + :DIMENSIONS (list m n) + :MAXIMUM-LENGTH (+ 1 (* m n)) + :DEFAULT 0 + :NAME 'zero-matrix))) + +(defthm + alist2p-m-0 + (implies (and (integerp m) + (integerp n) + (> m 0) + (> n 0)) + (alist2p name (m-0 m n))) + :hints (("Goal" :in-theory (enable alist2p)))) + +(defthm + array2p-m-0 + (implies (and (symbolp name) + (integerp m) + (integerp n) + (> m 0) + (> n 0) + (< (* m n) *MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (array2p name (m-0 m n))) + :hints (("Goal" :in-theory (enable array2p)))) + +(defthm + sqrt-*-sqrt-<-sq + (implies (and (rationalp x) + (rationalp y) + (>= x 0) + (>= y 0) + (<= x 46340) + (<= y 46340)) + (< (* x y) 2147483647)) + :rule-classes (:rewrite :linear) + :hints (("Goal" + :use (:instance + *-PRESERVES->=-FOR-NONNEGATIVES + (x2 x) + (y2 y) + (x1 46340) + (y1 46340))))) + +(defthm + matrixp-m-0 + (implies (and (integerp m) + (integerp n) + (> m 0) + (> n 0) + (<= m *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (<= n *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (matrixp m n (m-0 m n))) + :hints (("Goal" :in-theory (enable array2p + dimensions + header)))) + +(defthm + aref2-m-0 + (equal (aref2 name (m-0 m n) i j) 0) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + dimensions-m-0 + (equal (dimensions name (m-0 m n))(list m n)) + :hints (("Goal" + :in-theory (enable header dimensions)))) + +(defthm + default-m-0 + (equal (default name (m-0 m n)) + 0) + :hints (("Goal" + :in-theory (enable header default)))) + +(in-theory (disable m-0)) + +(defthm + alist2p-alist2p-m-0 + (implies (alist2p name1 M) + (alist2p name2 (m-0 (car (dimensions + '$arg M)) + (cadr (dimensions + '$arg M)))))) + +(defthm + array2p-array2p-m-0 + (implies (and (array2p name1 M) + (symbolp name2)) + (array2p name2 (m-0 (car (dimensions + '$arg M)) + (cadr (dimensions + '$arg M)))))) + +;;;;;;;;;;;;;;;;;;; +;; Identity matrix: + +(defun + m-1a (n) + "Return alist of length n of the form + ( ((- n 1) . (- n 1)) . 1) . . . ((0 . 0) . 1) )." + (declare (xargs :guard (and (integerp n) + (>= n 0)) + :verify-guards nil)) + (if (zp n) + nil + (acons (cons (- n 1)(- n 1)) 1 (m-1a (- n 1))))) + +(defthm + alistp-m-1a + (alistp (m-1a n))) + +(verify-guards m-1a) + +(defthm + bounded-integer-alistp2->= + (implies (and (bounded-integer-alistp2 l i j) + (integerp m) + (integerp n) + (<= i m) + (<= j n)) + (bounded-integer-alistp2 l m n))) + +(defthm + bounded-integer-alistp2-m-1a + (bounded-integer-alistp2 (m-1a n) n n)) + +(defthm + assoc2-i-i-m-1a + (implies (and (integerp i) + (integerp n) + (>= i 0) + (< i n)) + (and (assoc2 i i (m-1a n)) + (equal (cdr (assoc2 i i (m-1a n))) + 1)))) + +(defthm + assoc2-i-j-m-1a + (implies (not (equal i j)) + (not (assoc2 i j (m-1a n))))) + +(defun + m-1 (n) + "Return an alist representing the n by n identity matrix. + To use the ACL2 efficient array mechanism to store (m-1 n), + (* n n)) must be stictly less than 2147483647 which is + the *MAXIMUM-POSITIVE-32-BIT-INTEGER*." + (declare (xargs :guard (and (integerp n) + (>= n 0)))) + (cons (list :HEADER + :DIMENSIONS (list n n) + :MAXIMUM-LENGTH (+ 1 (* n n)) + :DEFAULT 0 + :NAME 'identity-matrix) + (m-1a n))) + +(defthm + alist2p-m-1 + (implies (and (integerp n) + (> n 0)) + (alist2p name (m-1 n))) + :hints (("Goal" + :in-theory (enable alist2p)))) + +(defthm + array2p-m-1 + (implies (and (symbolp name) + (integerp n) + (> n 0) + (< (* n n) *MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (array2p name (m-1 n))) + :hints (("Goal" + :in-theory (enable array2p)))) + +(defthm + matrixp-m-1 + (implies (and (integerp n) + (> n 0) + (<= n *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (matrixp n n (m-1 n))) + :hints (("Goal" + :in-theory (enable array2p dimensions header)))) + +(defthm + aref2-m-1-i-i + (implies (and (integerp i) + (integerp n) + (<= 0 i) + (< i n)) + (equal (aref2 name (m-1 n) i i) 1)) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + aref2-m-1-i-j + (implies (not (equal i j)) + (equal (aref2 name (m-1 n) i j) 0)) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + dimensions-m-1 + (equal (dimensions name (m-1 n))(list n n)) + :hints (("Goal" + :in-theory (enable header dimensions)))) + +(in-theory (disable m-1)) + +;;;;;;;;;;;;;;;;;;;;;;;;; +;; Transpose of a matrix: + +(defun + m-trans-a (M) + (declare (xargs :guard (alistp M))) + (if (consp M) + (let ((key (caar M)) + (datum (cdar M))) + (if (consp key) + (acons (cons (cdr key) + (car key)) + datum + (m-trans-a (cdr M))) + (m-trans-a (cdr M)))) + nil)) + +(defthm + alistp-m-trans-a + (alistp (m-trans-a M))) + +(defthm + bounded-integer-alistp2-m-trans-a + (implies (bounded-integer-alistp2 l m n) + (bounded-integer-alistp2 (m-trans-a l) + n + m))) + +(defthm + assoc2-m-trans-a + (iff (assoc2 i j (m-trans-a M)) + (assoc2 j i M))) + +(defthm + cdr-assoc2-m-trans-a + (equal (cdr (assoc2 i j (m-trans-a M))) + (cdr (assoc2 j i M)))) + +(defun + m-trans (M) + "Return an alist representing the transpose of the matrix + represented by the alist M." + (declare (xargs :guard (array2p '$arg M))) + (cons (list :HEADER + :DIMENSIONS (let ((dims (dimensions '$arg M))) + (list (cadr dims)(car dims))) + :MAXIMUM-LENGTH (maximum-length '$arg M) + :DEFAULT (default '$arg M) + :NAME 'transpose-matrix) + (m-trans-a M))) + +(defthm + alist2p-m-trans + (implies (alist2p name M) + (alist2p name (m-trans M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-trans M)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions)))) + +(defthm + array2p-m-trans + (implies (array2p name M) + (array2p name (m-trans M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-trans M)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + dimensions-m-trans + (equal (dimensions name (m-trans M)) + (list (cadr (dimensions name M)) + (car (dimensions name M)))) + :hints (("Goal" + :in-theory (enable dimensions header)))) + +(defthm + equal-list-dimensions-array2p + (implies (array2p name M) + (equal (list (car (dimensions name M)) + (cadr (dimensions name M))) + (dimensions name M))) + :hints (("Goal" + :in-theory (enable array2p dimensions header)))) + +(defthm + aref2-m-trans + (equal (aref2 name (m-trans M) i j) + (aref2 name M j i)) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(in-theory (disable m-trans)) + +(defthm + matrixp-m-trans + (implies (matrixp m n X) + (matrixp n m (m-trans X)))) + +(defthm + m-=-row-idempotency-of-m-trans + (m-=-row (m-trans (m-trans M)) M i j)) + +(defthm + m-=-row-1-idempotency-of-m-trans + (m-=-row-1 (m-trans (m-trans M)) M i j)) + +(defthm + array2p-alist2p-$arg2 + (implies (array2p name M) + (alist2p '$arg2 M)) + :hints (("Goal" + :use (:theorem + (implies (array2p name M) + (array2p '$arg2 M)))))) + +(defthm + idempotency-of-m-trans-alist2p + (implies (alist2p name M) + (m-= (m-trans (m-trans M)) M))) + +(defthm + idempotency-of-m-trans-array2p + (implies (array2p name M) + (m-= (m-trans (m-trans M)) M)) + :hints (("Goal'" + :use (:theorem + (implies (array2p '$arg1 M) + (alist2p '$arg1 + (m-trans + (m-trans M)))))))) + +(defthm + remove-last-col-m-=-row-1 + (implies (m-=-row-1 M1 M2 i j) + (m-=-row-1 M1 M2 i (- j 1)))) + +(local + (defthm + m-=-row-1-m-trans-1 + (implies (m-=-row-1 (m-trans M1)(m-trans M2) j i) + (m-=-row-1 M1 M2 i j)))) + +(local + (defthm + m-=-row-1-m-trans-2 + (implies (m-=-row-1 M1 M2 i j) + (m-=-row-1 (m-trans M1)(m-trans M2) j i)) + :hints (("Goal" + :in-theory (disable m-=-row-1-idempotency-of-m-trans) + :use ((:instance + m-=-row-1-m-trans-1 + (M1 (m-trans M1)) + (M2 (m-trans M2)) + (j i) + (i j)) + (:instance + m-=-row-1-idempotency-of-m-trans + (M M1)) + (:instance + m-=-row-1-idempotency-of-m-trans + (M M2))))))) + +(defthm + m-=-row-1-m-trans-iff + (iff (m-=-row-1 (m-trans M1)(m-trans M2) j i) + (m-=-row-1 M1 M2 i j))) + +(local + (in-theory (disable m-=-row-1-m-trans-1 + m-=-row-1-m-trans-2))) + +(defcong + ;; M-=-IMPLIES-M-=-M-TRANS-1 + m-= m-= (m-trans M) 1) + +(defthm + m-=-row-1-m-trans-m-0 + (m-=-row-1 (m-trans (m-0 m n)) + (m-0 n m) + j + i)) + +(defthm + m-=-m-trans-m-0 + (implies (and (integerp m) + (integerp n) + (> m 0) + (> n 0)) + (m-= (m-trans (m-0 m n)) + (m-0 n m)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Unary minus of a matrix: + +(defun + m-unary--a (M) + (declare (xargs :guard (alistp M))) + (if (consp M) + (let ((key (caar M)) + (datum (cdar M))) + (if (consp key) + (acons key + (- (fix datum)) + (m-unary--a (cdr M))) + (m-unary--a (cdr M)))) + nil)) + +(defthm + alistp-m-unary--a + (alistp (m-unary--a M))) + +(defthm + bounded-integer-alistp2-m-unary--a + (implies (bounded-integer-alistp2 l m n) + (bounded-integer-alistp2 (m-unary--a l) m n))) + +(defthm + assoc2-m-unary--a + (iff (assoc2 i j (m-unary--a M)) + (assoc2 i j M))) + +(defthm + cdr-assoc2-m-unary--a + (implies (assoc2 i j M) + (equal (cdr (assoc2 i j (m-unary--a M))) + (- (cdr (assoc2 i j M)))))) + +(defun + m-unary-- (M) + "Return an alist representing the unary minus of the matrix + represented by the alist M." + (declare (xargs :guard (array2p '$arg M))) + (cons (list :HEADER + :DIMENSIONS (dimensions '$arg M) + :MAXIMUM-LENGTH (maximum-length '$arg M) + :DEFAULT (- (fix (default '$arg M))) + :NAME 'unary-minus-matrix) + (m-unary--a M))) + +(defthm + alist2p-m-unary-- + (implies (alist2p name M) + (alist2p name (m-unary-- M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-unary-- M)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions)))) + +(defthm + array2p-m-unary-- + (implies (array2p name M) + (array2p name (m-unary-- M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-unary-- M)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + dimensions-m-unary-- + (equal (dimensions name (m-unary-- M)) + (dimensions name M)) + :hints (("Goal" + :in-theory (enable array2p dimensions header)))) + +(defthm + aref2-m-unary-- + (equal (aref2 name (m-unary-- M) i j) + (- (aref2 name M i j))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(in-theory (disable m-unary--)) + +(defthm + matrixp-m-unary-- + (implies (matrixp m n X) + (matrixp m n (m-unary-- X)))) + +(defthm + m-=-row-idempotency-of-m-unary-- + (m-=-row (m-unary-- (m-unary-- M)) M i j)) + +(defthm + m-=-row-1-idempotency-of-m-unary-- + (m-=-row-1 (m-unary-- (m-unary-- M)) M i j)) + +(defthm + idempotency-of-m-unary--_alist2p + (implies (alist2p name M) + (m-= (m-unary-- (m-unary-- M)) M))) + +(defthm + array2p-alist2p-$arg1-m-unaray-- + (implies (array2p name M) + (alist2p '$arg1 (m-unary-- (m-unary-- M))) + ) + :hints (("Goal" + :use (:theorem + (implies (array2p '$arg1 M) + (alist2p '$arg1 + (m-unary-- + (m-unary-- M)))) + )))) + +(defthm + idempotency-of-m-unary--_array2p + (implies (array2p name M) + (m-= (m-unary-- (m-unary-- M)) M))) + +(defthm + m-=-row-1-m-unary-- + (implies (m-=-row-1 M1 M2 i j) + (m-=-row-1 (m-unary-- M1)(m-unary-- M2) i j))) + +(defcong + ;; M-=-IMPLIES-M-=-M-UNARY---1 + m-= m-= (m-unary-- M) 1) + +(defthm + m-=-row-1-m-trans-m-unary-- + (m-=-row-1 (m-trans (m-unary-- M)) + (m-unary-- (m-trans M)) + i + j)) + +(defthm + m-=-m-trans-m-unary-- + (implies (alist2p name M) + (m-= (m-trans (m-unary-- M)) + (m-unary-- (m-trans M))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Scalar multiplication of a matrix: + +(defun + s-*-a (a M) + (declare (xargs :guard (and (acl2-numberp a) + (alistp M)))) + (if (consp M) + (let ((key (caar M)) + (datum (cdar M))) + (if (consp key) + (acons key + (* a (fix datum)) + (s-*-a a (cdr M))) + (s-*-a a (cdr M)))) + nil)) + +(defthm + alistp-s-*-a + (alistp (s-*-a a M))) + +(defthm + bounded-integer-alistp2-s-*-a + (implies (bounded-integer-alistp2 l m n) + (bounded-integer-alistp2 (s-*-a a l) m n))) + +(defthm + assoc2-s-*-a + (iff (assoc2 i j (s-*-a a M)) + (assoc2 i j M))) + +(defthm + cdr-assoc2-s-*-a + (implies (assoc2 i j M) + (equal (cdr (assoc2 i j (s-*-a a M))) + (* a (cdr (assoc2 i j M)))))) + +(defun + s-* (a M) + "Return an alist representing the multiplication + of the scalar a times the matrix represented by + the alist M." + (declare (xargs :guard (and (acl2-numberp a) + (array2p '$arg M)))) + (cons (list :HEADER + :DIMENSIONS (dimensions '$arg M) + :MAXIMUM-LENGTH (maximum-length '$arg M) + :DEFAULT (* a (fix (default '$arg M))) + :NAME 'scalar-mult-matrix) + (s-*-a a M))) + +(defthm + alist2p-s-* + (implies (alist2p name M) + (alist2p name (s-* a M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((s-* a M)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions)))) + +(defthm + array2p-s-* + (implies (array2p name M) + (array2p name (s-* a M))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((s-* a M)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + dimensions-s-* + (equal (dimensions name (s-* a M)) + (dimensions name M)) + :hints (("Goal" + :in-theory (enable array2p dimensions header)))) + +(defthm + aref2-s-* + (equal (aref2 name (s-* a M) i j) + (* a (aref2 name M i j))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(in-theory (disable s-*)) + +(defthm + matrixp-s-* + (implies (matrixp m n X) + (matrixp m n (s-* a X)))) + +(defthm + m-=-row-1-s-* + (implies (m-=-row-1 M1 M2 i j) + (m-=-row-1 (s-* a M1)(s-* a M2) i j))) + +(defcong + ;; M-=-IMPLIES-M-=-S-*-2 + m-= m-= (s-* a M) 2) + +(defthm + m-=-row-associate-scalars-left-s-* + (m-=-row (s-* a1 (s-* a2 M))(s-* (* a1 a2) M) i j)) + +(defthm + m-=-row-1-associate-scalars-left-s-* + (m-=-row-1 (s-* a1 (s-* a2 M))(s-* (* a1 a2) M) i j)) + +(defthm + associate-scalars-left-s-* + (implies (alist2p name M) + (m-= (s-* a1 (s-* a2 M)) + (s-* (* a1 a2) M)))) + +(defthm + m-=-row-1-s-*-0 + (m-=-row-1 (s-* 0 M)(m-0 (r M)(c M)) i j)) + +(defthm + m-=-s-*-0 + (implies (alist2p name M) + (m-= (s-* 0 M)(m-0 (r M)(c M))))) + +(defthm + m-=-row-1-s-*-m-0 + (m-=-row-1 (s-* a (m-0 m n))(m-0 m n) i j)) + +(defthm + m-=-s-*-m-0 + (implies (and (integerp m) + (integerp n) + (> m 0) + (> n 0)) + (m-= (s-* a (m-0 m n))(m-0 m n)))) + +(defthm + m-=-row-1-s-*-1 + (m-=-row-1 (s-* 1 M) M i j)) + +(defthm + m-=-s-*-1 + (implies (alist2p name M) + (m-= (s-* 1 M) M))) + +(defthm + m-=-row-1-s-*_-1 + (m-=-row-1 (s-* -1 M)(m-unary-- M) i j)) + +(defthm + m-=-s-*_-1 + (implies (alist2p name M) + (m-= (s-* -1 M)(m-unary-- M)))) + +(defthm + m-=-row-1-m-trans-s-* + (m-=-row-1 (m-trans (s-* s M)) + (s-* s (m-trans M)) + i + j)) + +(defthm + m-=-m-trans-s-* + (implies (alist2p name M) + (m-= (m-trans (s-* s M)) + (s-* s (m-trans M))))) + +;;;;;;;;;;;;;; +;; Matrix sum: + +(defun + m-binary-+-row (M1 M2 m n) + "Return an alist with the following values: + M1(m 0)+M2(m 0), . . . , M1(m n)+M2(m n); + ie. construct an alist of values representing + the vector sum of the m'th row of M1 and the + m'th row of M2." + (declare (xargs :guard + (and (integerp m) + (>= m 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions + '$arg1 M1))) + (and (< m (first dims1)) + (< n (second dims1)))) + (let ((dims2 (dimensions + '$arg2 M2))) + (and (< m (first dims2)) + (< n (second dims2)))) + ))) + (if (zp n) + (list (cons (cons m 0) + (+ (fix (aref2 '$arg1 M1 m 0)) + (fix (aref2 '$arg2 M2 m 0))))) + (cons (cons (cons m n) + (+ (fix (aref2 '$arg1 M1 m n)) + (fix (aref2 '$arg2 M2 m n)))) + (m-binary-+-row M1 M2 m (- n 1))))) + +(defthm + m-binary-+-row-remove-compress2-1 + (implies (and (alist2p name l1) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l1))) + (< j (cadr (dimensions name l1)))) + (equal (m-binary-+-row (compress2 name l1) l2 i j) + (m-binary-+-row l1 l2 i j)))) + +(defthm + m-binary-+-row-remove-compress2-2 + (implies (and (alist2p name l2) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l2))) + (< j (cadr (dimensions name l2)))) + (equal (m-binary-+-row l1 (compress2 name l2) i j) + (m-binary-+-row l1 l2 i j)))) + +(defthm + m-=-row-implies-equal-m-binary-+-row-1 + (implies (m-=-row M1 M2 m n) + (equal (m-binary-+-row M1 M3 m n) + (m-binary-+-row M2 M3 m n)))) + +(defthm + m-=-row-implies-equal-m-binary-+-row-2 + (implies (m-=-row M2 M3 m n) + (equal (m-binary-+-row M1 M2 m n) + (m-binary-+-row M1 M3 m n)))) + +(defthm + assoc2-m-binary-+-row + (implies (and (integerp n) + (integerp j) + (>= j 0) + (<= j n)) + (assoc2 m j (m-binary-+-row M1 M2 m n)))) + +(defthm + assoc2=nil-m-binary-+-row + (implies (not (equal i m)) + (equal (assoc2 i j (m-binary-+-row M1 M2 m n)) + nil))) + +(defthm + cdr-assoc2-m-binary-+-row + (implies (and (integerp n) + (integerp j) + (>= j 0) + (<= j n)) + (equal (cdr (assoc2 m j (m-binary-+-row M1 M2 m n))) + (+ (aref2 '$arg1 M1 m j) + (aref2 '$arg2 M2 m j))))) + +(defun + m-binary-+-row-1 (M1 M2 m n) + "Return an alist with all the following values: + M1(0 0)+M2(0 0), . . . , M1(0 n)+M2(0 n) + . . . + . . . + . . . + M1(m 0)+M2(m 0), . . . , M1(m n)+M2(m n); + ie. construct an alist of values representing + the vector sum of rows 0 thru m of M1 with + the corresponding rows 0 thru m of M2." + (declare (xargs :guard + (and (integerp m) + (>= m 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions + '$arg1 M1))) + (and (< m (first dims1)) + (< n (second dims1)))) + (let ((dims2 (dimensions + '$arg2 M2))) + (and (< m (first dims2)) + (< n (second dims2)))) + ))) + (if (zp m) + (m-binary-+-row M1 M2 0 n) + (append (m-binary-+-row M1 M2 m n) + (m-binary-+-row-1 M1 M2 (- m 1) n)))) + +(defthm + alistp-m-binary-+-row-1 + (alistp (m-binary-+-row-1 M1 M2 m n))) + +(defthm + bounded-integerp-alistp2-m-binary-+-row-1 + (implies (and (integerp m) + (integerp n) + (>= i 0) + (>= j 0) + (< i m) + (< j n)) + (bounded-integer-alistp2 (m-binary-+-row-1 M1 M2 i j) + m + n))) + +(defthm + m-binary-+-row-1-remove-compress2-1 + (implies (and (alist2p name l1) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l1))) + (< j (cadr (dimensions name l1)))) + (equal (m-binary-+-row-1 (compress2 name l1) l2 i j) + (m-binary-+-row-1 l1 l2 i j)))) + +(defthm + m-binary-+-row-1-remove-compress2-2 + (implies (and (alist2p name l2) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name l2))) + (< j (cadr (dimensions name l2)))) + (equal (m-binary-+-row-1 l1 (compress2 name l2) i j) + (m-binary-+-row-1 l1 l2 i j)))) + +(defthm + m-=-row-1-implies-equal-m-binary-+-row-1-1 + (implies (m-=-row-1 M1 M2 m n) + (equal (m-binary-+-row-1 M1 M3 m n) + (m-binary-+-row-1 M2 M3 m n)))) + +(defthm + m-=-row-1-implies-equal-m-binary-+-row-1-2 + (implies (m-=-row-1 M2 M3 m n) + (equal (m-binary-+-row-1 M1 M2 m n) + (m-binary-+-row-1 M1 M3 m n)))) + +(defthm + assoc2-m-binary-+-row-1 + (implies (and (integerp m) + (integerp n) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (<= i m) + (<= j n)) + (assoc2 i j (m-binary-+-row-1 M1 M2 m n)))) + +(defthm + assoc2=nil-m-binary-+-row-1 + (implies (and (>= m 0) + (> i m)) + (equal (assoc2 i j (m-binary-+-row-1 M1 M2 m n)) + nil))) + +(local + (defthm + assoc2-append + (equal (assoc2 i j (append L1 L2)) + (if (assoc2 i j L1) + (assoc2 i j L1) + (assoc2 i j L2))))) + +(local + (defthm + cdr-assoc2-m-binary-+-row-1-lemma + (implies (and (equal (cdr (assoc2 i j + (m-binary-+-row-1 M1 M2 + (+ -1 m) n))) + (+ (aref2 '$arg M1 i j) + (aref2 '$arg M2 i j))) + (integerp j) + (<= 0 j) + (<= j n)) + (equal (cdr (assoc2 i j + (append (m-binary-+-row M1 M2 m n) + (m-binary-+-row-1 M1 M2 + (+ -1 m) n)))) + (+ (aref2 '$arg M1 i j) + (aref2 '$arg M2 i j)))))) + +(local (in-theory (disable assoc2-append))) + +(defthm + cdr-assoc2-m-binary-+-row-1 + (implies (and (integerp m) + (integerp n) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (<= i m) + (<= j n)) + (equal (cdr (assoc2 i j (m-binary-+-row-1 M1 M2 m n))) + (+ (aref2 '$arg1 M1 i j) + (aref2 '$arg2 M2 i j))))) + +(local (in-theory (disable cdr-assoc2-m-binary-+-row-1-lemma))) + +(defun + m-binary-+ (M1 M2) + "Return an alist representing the matrix sum + of the matrices represented by the alists M1 + and M2. This is done by adding a header to an + alist containing the appropriate values." + (declare (xargs :guard + (and (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dim1 (dimensions '$arg1 + M1)) + (dim2 (dimensions '$arg2 + M2))) + (and + (= (first dim1) + (first dim2)) + (= (second dim1) + (second dim2))))) + )) + (let* ((dim1 (dimensions '$arg1 M1)) + (dim2 (dimensions '$arg2 M2)) + (dim11 (first dim1)) + (dim12 (second dim1)) + (dim21 (first dim2)) + (dim22 (second dim2))) + (if (mbt (and (alist2p '$arg1 M1) + (alist2p '$arg2 M2) + (= dim11 dim21) + (= dim12 dim22))) + (cons (list :HEADER + :DIMENSIONS (list dim11 dim12) + :MAXIMUM-LENGTH + (+ 1 (* dim11 dim12)) + :DEFAULT 0 + :NAME 'matrix-sum) + (m-binary-+-row-1 (compress2 '$arg1 M1) + (compress2 '$arg2 M2) + (- dim11 1) + (- dim12 1))) + (+ M1 M2)))) + +(defmacro + m-+ (&rest rst) + (if rst + (if (cdr rst) + (xxxjoin 'm-binary-+ rst) + (car rst)) + 0)) + +(add-binop m-+ m-binary-+) + +(defthm + alist2p-m-+ + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2)))) + (alist2p name (m-+ M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-+ M1 M2)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions)))) + +(defthm + array2p-m-+ + (implies (and (array2p name M1) + (array2p name M2) + (equal (dimensions name M1) + (dimensions name M2))) + (array2p name (m-+ M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-+ M1 M2)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + array2p-m-+-1 + (implies (and (array2p name M1) + (array2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2)))) + (array2p name (m-+ M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-+ M1 M2)))) + :hints (("Goal" + :in-theory (disable m-binary-+ + equal-list-dimensions-array2p) + :use ((:instance + equal-list-dimensions-array2p + (M M1)) + (:instance + equal-list-dimensions-array2p + (M M2)))))) + +(defthm + dimensions-m-+-alist2p + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2)))) + (equal (dimensions name (m-+ M1 M2)) + (list (car (dimensions name M1)) + (cadr (dimensions name M1))))) + :hints (("Goal" + :in-theory (enable alist2p dimensions + header)))) + +(defthm + dimensions-m-+-array2p + (implies (and (array2p name M1) + (array2p name M2) + (equal (dimensions name M1) + (dimensions name M2))) + (equal (dimensions name (m-+ M1 M2)) + (dimensions name M1))) + :hints (("Goal" + :in-theory (disable + equal-list-dimensions-array2p + dimensions-m-+-alist2p) + :use ((:instance + equal-list-dimensions-array2p + (M M1)) + dimensions-m-+-alist2p)))) + +(defthm + matrixp-m-+ + (implies (and (matrixp m n X1) + (matrixp m n X2)) + (matrixp m n (m-+ X1 X2))) + :hints (("Goal" + :in-theory (disable m-binary-+)))) + +(defthm + default-m-+-alist2p + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2)))) + (equal (default name (m-+ M1 M2)) 0)) + :hints (("Goal" + :in-theory (enable alist2p default + header)))) + +(defthm + default-m-+-array2p + (implies (and (array2p name M1) + (array2p name M2) + (equal (dimensions name M1) + (dimensions name M2))) + (equal (default name (m-+ M1 M2)) 0)) + :hints (("Goal" + :in-theory (enable array2p default header)))) + +(defthm + maximum-length-m-+ + (implies (and (array2p name M1) + (array2p name M2) + (equal (dimensions name M1) + (dimensions name M2))) + (equal (maximum-length name (m-+ M1 M2)) + (+ 1 (* (car (dimensions name M1)) + (cadr (dimensions name M1)))))) + :hints (("Goal" + :in-theory (enable array2p maximum-length header)))) + +(defthm + aref2-m-+ + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (first (dimensions name M1)) + (first (dimensions name M2))) + (equal (second (dimensions name M1)) + (second (dimensions name M2))) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (car (dimensions name M1))) + (< j (cadr (dimensions name M1)))) + (equal (aref2 name (m-+ M1 M2) i j) + (+ (aref2 name M1 i j) + (aref2 name M2 i j)))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defcong + ;; M-=-IMPLIES-EQUAL-M-+-1 + m-= equal (M-+ M1 M2) 1) + +(defcong + ;; M-=-IMPLIES-EQUAL-M-+-2 + m-= equal (M-+ M1 M2) 2) + +(defthm + commutativity-of-m-binary-+-row + (equal (m-binary-+-row M1 M2 m n) + (m-binary-+-row M2 M1 m n))) + +(defthm + commutativity-of-m-binary-+-row-1 + (equal (m-binary-+-row-1 M1 M2 m n) + (m-binary-+-row-1 M2 M1 m n))) + +(defthm + commutativity-of-m-+ + (equal (m-+ M1 M2) + (m-+ M2 M1))) + +(defthm + aref2-cons + (equal (aref2 name (cons (cons (cons i j) val) lst) m n) + (if (and (equal i m) + (equal j n)) + val + (aref2 name lst m n))) + :hints (("Goal" + :in-theory (enable aref2)))) + +(defthm + aref2-cons-move-header + (equal (aref2 name + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (cons (cons (cons i j) val) lst)) + m + n) + (if (and (equal i m) + (equal j n)) + val + (aref2 name + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + m + n))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + m-binary-+-row-remove-last + (implies (and (>= i 0) + (> n i)) + (equal (m-binary-+-row + M1 + (cons (cons (cons m n) val) M2) + m + i) + (m-binary-+-row M1 + M2 + m + i)))) + +(defthm + associativity-of-m-binary-+-row + (equal (m-binary-+-row (m-binary-+-row M1 M2 m n) + M3 + m + n) + (m-binary-+-row M1 + (m-binary-+-row M2 M3 m n) + m + n))) + +(in-theory (disable commutativity-of-m-binary-+-row + commutativity-of-m-binary-+-row-1)) + +(in-theory (disable associativity-of-m-binary-+-row)) + +(defthm + m-binary-+-row-append-1 + (equal (m-binary-+-row (append (m-binary-+-row M1 + M2 + m + n) + lst) + M3 + m + n) + (m-binary-+-row (m-binary-+-row M1 M2 m n) + M3 + m + n))) + +(defthm + m-binary-+-row-append-2 + (equal (m-binary-+-row M1 + (append (m-binary-+-row M2 + M3 + m + n) + lst) + m + n) + (m-binary-+-row M1 + (m-binary-+-row M2 M3 m n) + m + n))) + +(defthm + m-binary-+-row-cons-1 + (implies (> m i) + (equal (m-binary-+-row + (cons (cons (cons m n) val) lst) + M1 + i + j) + (m-binary-+-row lst M1 i j)))) + +(defthm + m-binary-+-row-cons-1-a + (implies (and (>= j 0) + (> n j)) + (equal (m-binary-+-row + (cons (cons (cons m n) val) lst) + M1 + i + j) + (m-binary-+-row lst M1 i j)))) + +(defthm + m-binary-+-row-cons-1-a-header + (implies (and (>= j 0) + (> n j)) + (equal (m-binary-+-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (cons (cons (cons m n) val) lst)) + M3 + i + j) + (m-binary-+-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + i + j)))) + +(defthm + m-binary-+-row-cons-2 + (implies (> m i) + (equal (m-binary-+-row + M1 + (cons (cons (cons m n) val) lst) + i + j) + (m-binary-+-row M1 lst i j)))) + +(defthm + m-binary-+-row-cons-2-a-header + (implies (and (>= j 0) + (> n j)) + (equal (m-binary-+-row + M1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (cons (cons (cons m n) val) lst)) + i + j) + (m-binary-+-row + M1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + i + j)))) + +(defthm + aref2-append-m-binary-+-row + (implies (and (> m i)) + (equal (aref2 name (append (m-binary-+-row M1 M2 m j) + lst) + i n) + (aref2 name lst i n)))) + +(defthm + aref2-append-m-binary-+-row-header + (implies (and (> m i)) + (equal (aref2 + name + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 M2 m j) + lst)) + i + n) + (aref2 + name + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + i + n)))) + +(defthm + m-binary-+-row-append-3 + (implies (> m i) + (equal (m-binary-+-row (append (m-binary-+-row M1 + M2 + m + n) + lst) + M3 + i + n) + (m-binary-+-row lst + M3 + i + n)))) + +(defthm + m-binary-+-row-append-3-header + (implies (> m i) + (equal (m-binary-+-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 + M2 + m + n) + lst)) + M3 + i + n) + (m-binary-+-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + i + n)))) + +(defthm + m-binary-+-row-append-4 + (implies (> m i) + (equal (m-binary-+-row M3 + (append (m-binary-+-row M1 + M2 + m + n) + lst) + i + n) + (m-binary-+-row M3 + lst + i + n)))) + +(defthm + m-binary-+-row-append-4-header + (implies (> m i) + (equal (m-binary-+-row + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 + M2 + m + n) + lst)) + i + n) + (m-binary-+-row + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + i + n)))) + +(defthm + m-binary-+-row-1-append-1 + (implies (and (>= j 0) + (< j m)) + (equal (m-binary-+-row-1 (append (m-binary-+-row M1 + M2 + m + n) + lst) + M3 + j + n) + (m-binary-+-row-1 lst + M3 + j + n)))) + +(defthm + m-binary-+-row-1-append-1-header + (implies (and (>= j 0) + (< j m)) + (equal (m-binary-+-row-1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 + M2 + m + n) + lst)) + M3 + j + n) + (m-binary-+-row-1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + j + n)))) + +(defthm + m-binary-+-row-1-append-2 + (implies (and (>= j 0) + (< j m)) + (equal (m-binary-+-row-1 M1 + (append (m-binary-+-row M2 + M3 + m + n) + lst) + j + n) + (m-binary-+-row-1 M1 + lst + j + n)))) + +(defthm + m-binary-+-row-1-append-2-header + (implies (and (>= j 0) + (< j m)) + (equal (m-binary-+-row-1 + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 + M2 + m + n) + lst)) + j + n) + (m-binary-+-row-1 + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + j + n)))) + +(in-theory (enable associativity-of-m-binary-+-row)) + +(defthm + associativity-of-m-binary-+-row-1 + (equal (m-binary-+-row-1 (m-binary-+-row-1 M1 M2 m n) M3 m n) + (m-binary-+-row-1 M1 (m-binary-+-row-1 M2 M3 m n) m n))) + +(defthm + dimensions-header + (equal (dimensions name + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst)) + dims) + :hints (("Goal" + :in-theory (enable header dimensions)))) + +(defthm + default-header + (equal (default name + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst)) + default) + :hints (("Goal" + :in-theory (enable header default)))) + +(defthm + alist2p-m-binary-+-header + (implies (and (alist2p name1 M1) + (alist2p name2 M2) + (equal (first (dimensions '$arg M1)) + (first (dimensions '$arg M2))) + (equal (second (dimensions '$arg M1)) + (second (dimensions '$arg M2)) + )) + (alist2p name + (cons (list :HEADER + :DIMENSIONS + (list + (first + (DIMENSIONS '$ARG + M1)) + (second + (dimensions '$arg + M1))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1)))) + :DEFAULT 0 + :NAME 'MATRIX-SUM) + (m-binary-+-row-1 M1 + M2 + (+ -1 + (car (dimensions + '$arg M1))) + (+ -1 + (cadr (dimensions + '$arg M1))) + )))) + :hints (("Goal" + :use alist2p-m-+))) + +(defthm + array2p-m-binary-+-header + (implies (and (array2p name1 M1) + (array2p name2 M2) + (equal (dimensions '$arg M1) + (dimensions '$arg M2)) + (symbolp name)) + (array2p name + (cons (list :HEADER + :DIMENSIONS (DIMENSIONS '$ARG M1) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1)))) + :DEFAULT 0 + :NAME 'MATRIX-SUM) + (m-binary-+-row-1 M1 + M2 + (+ -1 + (car (dimensions + '$arg M1))) + (+ -1 + (cadr (dimensions + '$arg M1))) + )))) + :hints (("Goal" + :use array2p-m-+))) + +(defthm + aref2-m-binary-+-row-1-remove-header-alist2p + (implies (and (alist2p name M1) + (alist2p name M2) + (integerp i) + (integerp j) + (<= 0 i) + (<= 0 j) + (< i (car (dimensions name M1))) + (< j (cadr (dimensions name M1)))) + (equal (aref2 name + (cons (list :HEADER + :DIMENSIONS + (list (first + (DIMENSIONS '$ARG + M1)) + (second + (dimensions '$arg + M1))) + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M1 + M2 + (+ -1 + (car (dimensions + '$arg M1))) + (+ -1 + (cadr (dimensions + '$arg M1))))) + i j) + (aref2 name (m-binary-+-row-1 M1 + M2 + (+ -1 + (car (dimensions + name M1))) + (+ -1 + (cadr (dimensions + name M1)))) + i + j))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + aref2-m-binary-+-row-1-remove-header-array2p + (implies (and (array2p name M1) + (array2p name M2) + (integerp i) + (integerp j) + (<= 0 i) + (<= 0 j) + (< i (car (dimensions name M1))) + (< j (cadr (dimensions name M1)))) + (equal (aref2 name + (cons (list :HEADER + :DIMENSIONS (DIMENSIONS '$ARG M1) + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M1 + M2 + (+ -1 + (car (dimensions + '$arg M1))) + (+ -1 + (cadr (dimensions + '$arg M1))))) + i j) + (aref2 name (m-binary-+-row-1 M1 + M2 + (+ -1 + (car (dimensions + name M1))) + (+ -1 + (cadr (dimensions + name M1)))) + i + j))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defthm + m-binary-+-row-append-1-remove-header + (equal (m-binary-+-row (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 M2 m n) + lst)) + M3 + m + n) + (m-binary-+-row (m-binary-+-row M1 M2 m n) + M3 + m + n)) + :hints (("Goal" + :in-theory + (disable + ASSOCIATIVITY-OF-M-BINARY-+-ROW)))) + +(defthm + m-binary-+-row-append-2-remove-header + (equal (m-binary-+-row M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 M2 m n) + lst)) + m + n) + (m-binary-+-row M3 + (m-binary-+-row M1 M2 m n) + m + n)) + :hints (("Goal" + :in-theory (disable ASSOCIATIVITY-OF-M-BINARY-+-ROW)))) + +(defthm + m-binary-+-row-remove-header-1 + (equal (m-binary-+-row (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row M1 M2 m n)) + M3 + m + n) + (m-binary-+-row (m-binary-+-row M1 M2 m n) + M3 + m + n)) + :hints (("Goal" + :in-theory (disable ASSOCIATIVITY-OF-M-BINARY-+-ROW)))) + +(defthm + m-binary-+-row-remove-header-2 + (equal (m-binary-+-row M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row M1 M2 m n)) + m + n) + (m-binary-+-row M3 + (m-binary-+-row M1 M2 m n) + m + n)) + :hints (("Goal" + :in-theory (disable ASSOCIATIVITY-OF-M-BINARY-+-ROW)))) + +(defthm + m-binary-+-row-1-remove-header-1 + (equal (m-binary-+-row-1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M1 + M2 + m + n)) + M3 + m + n) + (m-binary-+-row-1 + (m-binary-+-row-1 M1 + M2 + m + n) + M3 + m + n)) + :hints (("Goal" + :in-theory (disable associativity-of-m-binary-+-row + associativity-of-m-binary-+-row-1)))) + +(defthm + m-binary-+-row-1-remove-header-2 + (equal (m-binary-+-row-1 + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M1 + M2 + m + n)) + m + n) + (m-binary-+-row-1 + M3 + (m-binary-+-row-1 M1 + M2 + m + n) + m + n)) + :hints (("Goal" + :in-theory (disable associativity-of-m-binary-+-row + associativity-of-m-binary-+-row-1)))) + +(defthm + alist2p-m-binary-+-header-hack + (IMPLIES (AND (ALIST2P '$ARG1 M2) + (ALIST2P '$ARG2 M3) + (EQUAL (CAR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M2))) + (EQUAL (CADR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2))) + (EQUAL (CAR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M3))) + (EQUAL (CADR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M3)))) + (ALIST2P '$ARG2 + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1)))) + '(:DEFAULT 0 :NAME MATRIX-SUM)) + (M-BINARY-+-ROW-1 M2 M3 (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1))))))) + :hints (("Goal" + :in-theory (disable alist2p-m-binary-+-header) + :use (:instance + alist2p-m-binary-+-header + (M1 M2) + (M2 M3))))) + +(defthm + m-binary-+-row-1-remove-compress2-2-hack + (IMPLIES + (AND (ALIST2P '$ARG1 M2) + (ALIST2P '$ARG2 M3) + (EQUAL (CAR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M2))) + (EQUAL (CADR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2))) + (EQUAL (CAR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M3))) + (EQUAL (CADR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M3)))) + (EQUAL + (M-BINARY-+-ROW-1 + M1 + (M-BINARY-+-ROW-1 M2 M3 (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1)))) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1)))) + (M-BINARY-+-ROW-1 + M1 + (COMPRESS2 + '$ARG + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1)))) + '(:DEFAULT 0 :NAME MATRIX-SUM)) + (M-BINARY-+-ROW-1 M2 M3 (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1)))))) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1)))))) + :hints (("Goal" + :in-theory (disable m-binary-+-row-1-remove-compress2-2 + alist2p-m-binary-+-header-hack) + :use ((:instance + m-binary-+-row-1-remove-compress2-2 + (l1 M1) + (name '$arg) + (l2 (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1)))) + '(:DEFAULT 0 :NAME MATRIX-SUM)) + (M-BINARY-+-ROW-1 M2 M3 (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1)))))) + (i (+ -1 (CAR (DIMENSIONS '$ARG M1)))) + (j (+ -1 (CADR (DIMENSIONS '$ARG M1))))) + alist2p-m-binary-+-header-hack)))) + +(defthm + associativity-of-m-+ + (equal (m-+ (m-+ M1 M2) M3) + (m-+ M1 M2 M3)) + :hints (("Goal" + :in-theory (disable commutativity-of-m-+)))) + +(defthm + m-=-row-cons-1-a + (implies (and (>= j 0) + (> n j)) + (equal (m-=-row (cons (cons (cons m n) val) lst) + M1 + i + j) + (m-=-row lst M1 i j)))) + +(defthm + m-=-row-cons-2-a + (implies (and (>= j 0) + (> n j)) + (equal (m-=-row M1 + (cons (cons (cons m n) val) lst) + i + j) + (m-=-row M1 lst i j)))) + +(defthm + m-=-row-cons-1-a-header + (implies (and (>= j 0) + (> n j)) + (equal (m-=-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (cons (cons (cons m n) val) lst)) + M3 + i + j) + (m-=-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + i + j)))) + +(defthm + m-=-row-cons-2-a-header + (implies (and (>= j 0) + (> n j)) + (equal (m-=-row + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (cons (cons (cons m n) val) lst)) + i + j) + (m-=-row + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + i + j)))) + +(defthm + m-=-row-m-binary-+-row-append-1 + (equal (m-=-row (append (m-binary-+-row M1 M2 m n) + lst) + M3 + m + n) + (m-=-row (m-binary-+-row M1 M2 m n) + M3 + m + n))) + +(defthm + m-=-row-m-binary-+-row-append-2 + (equal (m-=-row M3 + (append (m-binary-+-row M1 M2 m n) + lst) + m + n) + (m-=-row M3 + (m-binary-+-row M1 M2 m n) + m + n))) + +(defthm + m-=-row-m-binary-+-row-append-1-remove-header + (equal (m-=-row (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 M2 m n) + lst)) + M3 + m + n) + (m-=-row (m-binary-+-row M1 M2 m n) + M3 + m + n))) + +(defthm + m-=-row-m-binary-+-row-append-2-remove-header + (equal (m-=-row M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 M2 m n) + lst)) + m + n) + (m-=-row M3 + (m-binary-+-row M1 M2 m n) + m + n))) + +(defthm + m-=-row-m-binary-+-row-remove-header-1 + (equal (m-=-row (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row M1 M2 m n)) + M3 + m + n) + (m-=-row (m-binary-+-row M1 M2 m n) + M3 + m + n))) + +(defthm + m-=-row-m-binary-+-row-remove-header-2 + (equal (m-=-row M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row M1 M2 m n)) + m + n) + (m-=-row m3 + (m-binary-+-row M1 M2 m n) + m + n))) + +(defthm + m-=-row-m-binary-+-row-append-3 + (implies (> m i) + (equal (m-=-row (append (m-binary-+-row M1 + M2 + m + n) + lst) + M3 + i + n) + (m-=-row lst + M3 + i + n)))) + +(defthm + m-=-row-m-binary-+-row-append-4 + (implies (> m i) + (equal (m-=-row M3 + (append (m-binary-+-row M1 + M2 + m + n) + lst) + i + n) + (m-=-row M3 + lst + i + n)))) + +(defthm + m-=-row-m-binary-+-row-append-3-header + (implies (> m i) + (equal (m-=-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 + M2 + m + n) + lst)) + M3 + i + n) + (m-=-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + i + n)))) + +(defthm + m-=-row-m-binary-+-row-append-4-header + (implies (> m i) + (equal (m-=-row + m3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 + M2 + m + n) + lst)) + i + n) + (m-=-row + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + i + n)))) + +(defthm + m-=-row-1-m-binary-+-row-append-1 + (implies (and (>= j 0) + (< j m)) + (equal (m-=-row-1 (append (m-binary-+-row M1 + M2 + m + n) + lst) + M3 + j + n) + (m-=-row-1 lst + M3 + j + n)))) + +(defthm + m-=-row-1-m-binary-+-row-append-2 + (implies (and (>= j 0) + (< j m)) + (equal (m-=-row-1 M3 + (append (m-binary-+-row M1 + M2 + m + n) + lst) + j + n) + (m-=-row-1 M3 + lst + j + n)))) + +(defthm + m-=-row-1-m-binary-+-row-append-1-header + (implies (and (>= j 0) + (< j m)) + (equal (m-=-row-1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 + M2 + m + n) + lst)) + M3 + j + n) + (m-=-row-1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + j + n)))) + +(defthm + m-=-row-1-m-binary-+-row-append-2-header + (implies (and (>= j 0) + (< j m)) + (equal (m-=-row-1 + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-+-row M1 + M2 + m + n) + lst)) + j + n) + (m-=-row-1 + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + j + n)))) + +(defthm + m-=-row-1-m-binary-+-row-1-remove-header-1 + (equal (m-=-row-1 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M1 + M2 + m + n)) + M3 + m + n) + (m-=-row-1 (m-binary-+-row-1 M1 M2 m n) + M3 + m + n))) + +(defthm + m-=-row-1-m-binary-+-row-1-remove-header-2 + (equal (m-=-row-1 M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M1 + M2 + m + n)) + m + n) + (m-=-row-1 M3 + (m-binary-+-row-1 M1 M2 m n) + m + n))) + +(defthm + m-=-row-1-m-binary-+-row-1-m-0 + (m-=-row-1 (m-binary-+-row-1 M1 + (m-0 m n) + i + j) + M1 + i + j)) + +(defthm + alist2p-m-0-hack + (IMPLIES (ALIST2P NAME M) + (ALIST2P '$ARG1 + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + '(:DEFAULT 0 :NAME MATRIX-SUM)) + (M-BINARY-+-ROW-1 M + (M-0 (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + (+ -1 (CAR (DIMENSIONS '$ARG M))) + (+ -1 (CADR (DIMENSIONS '$ARG M))))))) + :hints (("Goal" + :in-theory (disable alist2p-m-+) + :use (:instance + alist2p-m-+ + (M1 M) + (M2 (M-0 (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + (name '$arg))))) + +(defthm + ALIST2P-M-BINARY-+-HEADER-m-0-hack + (implies (alist2p '$arg M) + (ALIST2P '$ARG + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + '(:DEFAULT 0 :NAME MATRIX-SUM)) + (M-BINARY-+-ROW-1 M + (M-0 (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + (+ -1 (CAR (DIMENSIONS '$ARG M))) + (+ -1 (CADR (DIMENSIONS '$ARG M))))))) + :hints (("Goal" + :in-theory (disable ALIST2P-M-BINARY-+-HEADER) + :use (:instance + ALIST2P-M-BINARY-+-HEADER + (name1 '$arg) + (name2 '$arg) + (M1 M) + (M2 (M-0 (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))))))) + +(defthm + M-=-ROW-1-REMOVE-COMPRESS2-1-m-0-hack + (IMPLIES (ALIST2P NAME M) + (M-=-ROW-1 + (COMPRESS2 '$ARG + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + '(:DEFAULT 0 :NAME MATRIX-SUM)) + (M-BINARY-+-ROW-1 M + (M-0 (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + (+ -1 (CAR (DIMENSIONS '$ARG M))) + (+ -1 (CADR (DIMENSIONS '$ARG M)))))) + M + (+ -1 (CAR (DIMENSIONS '$ARG M))) + (+ -1 (CADR (DIMENSIONS '$ARG M)))))) + +(defthm + right-m-+-unicity-of-m-0 + (implies (alist2p name M) + (m-= (m-+ M (m-0 (car (dimensions name M)) + (cadr (dimensions name M)))) + M))) + +(defthm + left-m-+-unicity-of-m-0 + (implies (alist2p name M) + (m-= (m-+ (m-0 (car (dimensions name M)) + (cadr (dimensions name M))) + M) + M))) + +(defmacro + m-- (x &optional (y 'nil binary-casep)) + (if binary-casep + `(m-binary-+ ,x (m-unary-- ,y)) + `(m-unary-- ,x))) + +(add-macro-alias m-- m-unary--) + +(add-invisible-fns m-binary-+ m-unary--) +(add-invisible-fns m-unary-- m-unary--) + +(defthm + m-=-row-1-m-binary-+-row-1-m-unary-- + (m-=-row-1 (m-binary-+-row-1 M1 + (m-unary-- M1) + i + j) + (m-0 m n) + i + j)) + +(defthm + left-m-+-inverse-of-m-- + (implies (alist2p name M) + (m-= (m-+ (m-- M) M) + (m-0 (car (dimensions name M)) + (cadr (dimensions name M)))))) + +(defthm + right-m-+-inverse-of-m-- + (implies (alist2p name M) + (m-= (m-+ M (m-- M)) + (m-0 (car (dimensions name M)) + (cadr (dimensions name M)))))) + +(defthm + m-=-row-distributivity-of-s-*-over-+ + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M)) + (< j (c M))) + (m-=-row (s-* (+ a b) M) + (m-+ (s-* a M)(s-* b m)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-+)))) + +(defthm + m-=-row-1-distributivity-of-s-*-over-+ + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M)) + (< j (c M))) + (m-=-row-1 (s-* (+ a b) M) + (m-+ (s-* a M)(s-* b m)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-+)))) + +(defthm + distributivity-of-s-*-over-+ + (implies (alist2p name M) + (m-= (s-* (+ a b) M) + (m-+ (s-* a M)(s-* b m)))) + :hints (("Goal" + :in-theory (disable m-binary-+ + alist2p-m-+) + :use ((:instance + alist2p-m-+ + (M1 (s-* a M)) + (M2 (s-* b M))))))) + +(defthm + m-=-row-distributivity-of-s-*-over-m-+ + (implies (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))) + (alist2p name M1) + (alist2p name M2) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M1)) + (< j (c M1))) + (m-=-row (s-* a (m-+ M1 M2)) + (m-+ (s-* a M1)(s-* a M2)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-+)))) + +(defthm + m-=-row-1-distributivity-of-s-*-over-m-+ + (implies (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))) + (alist2p name M1) + (alist2p name M2) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M1)) + (< j (c M1))) + (m-=-row-1 (s-* a (m-+ M1 M2)) + (m-+ (s-* a M1)(s-* a M2)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-+)))) + +(defthm + distributivity-of-s-*-over-m-+ + (implies (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))) + (alist2p name M1) + (alist2p name M2)) + (m-= (s-* a (m-+ M1 M2)) + (m-+ (s-* a M1)(s-* a M2)))) + :hints (("Goal" + :in-theory (disable m-binary-+ + alist2p-s-*) + :use ((:instance + alist2p-s-* + (M (m-binary-+ M1 M2))) + (:instance + alist2p-s-* + (M M1)) + (:instance + alist2p-s-* + (M M2)) + (:instance + alist2p-m-+ + (M1 (s-* a M1)) + (M2 (s-* a M2))))))) + +(defthm + m-=-row-m-trans-m-+ + (implies (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))) + (alist2p name M1) + (alist2p name M2) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (c M1)) + (< j (r M1))) + (m-=-row (m-trans (m-+ M1 M2)) + (m-+ (m-trans M1)(m-trans M2)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-+)))) + +(defthm + m-=-row-1-m-trans-m-+ + (implies (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))) + (alist2p name M1) + (alist2p name M2) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (c M1)) + (< j (r M1))) + (m-=-row-1 (m-trans (m-+ M1 M2)) + (m-+ (m-trans M1)(m-trans M2)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-+)))) + +(defthm + m-trans-m-+ + (implies (and (equal (car (dimensions name M1)) + (car (dimensions name M2))) + (equal (cadr (dimensions name M1)) + (cadr (dimensions name M2))) + (alist2p name M1) + (alist2p name M2)) + (m-= (m-trans (m-+ M1 M2)) + (m-+ (m-trans M1)(m-trans M2)))) + :hints (("Goal" + :in-theory (disable m-binary-+)) + ("Subgoal 2" + :in-theory (disable m-binary-+ + alist2p-m-trans) + :use (:instance + alist2p-m-trans + (name '$arg) + (M (m-+ M1 M2)))) + ("Subgoal 1" + :in-theory (disable m-binary-+ + alist2p-m-+) + :use (:instance + alist2p-m-+ + (name '$arg) + (M1 (m-trans M1)) + (M2 (m-trans M2)))))) + +;;;;;;;;;;;;;;;;;; +;; Matrix product: + +(defun + dot (M1 M2 i j k) + "Return the dot product + (M1 i 0)*(M2 0 k) + . . . + (M1 i j)*(M2 j k)." + (declare (xargs :guard (and (integerp i) + (>= i 0) + (integerp j) + (>= j 0) + (integerp k) + (>= k 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< i (first dims1)) + (< j (second dims1)))) + (let ((dims2 (dimensions '$arg1 M2))) + (and (< j (first dims2)) + (< k (second dims2))))))) + (if (zp j) + (* (fix (aref2 '$arg1 M1 i 0)) + (fix (aref2 '$arg2 M2 0 k))) + (+ (* (fix (aref2 '$arg1 M1 i j)) + (fix (aref2 '$arg2 M2 j k))) + (dot M1 M2 i (- j 1) k)))) + +(defthm + dot-remove-compress2-1 + (implies (and (alist2p name l1) + (integerp i) + (>= i 0) + (< i (car (dimensions name l1))) + (< j (cadr (dimensions name l1)))) + (equal (dot (compress2 name l1) l2 i j k) + (dot l1 l2 i j k)))) + +(defthm + dot-remove-compress2-2 + (implies (and (alist2p name l2) + (integerp k) + (>= k 0) + (< j (car (dimensions name l2))) + (< k (cadr (dimensions name l2)))) + (equal (dot l1 (compress2 name l2) i j k) + (dot l1 l2 i j k)))) + +(defthm + m-=-row-1-implies-equal-dot-2 + (implies (and (m-=-row-1 M2 M3 n p) + (integerp p) + (integerp j) + (>= j 0) + (>= p j)) + (equal (dot M1 M2 m n j) + (dot M1 M3 m n j))) + :hints (("Goal" + :do-not '(generalize) + :in-theory (disable LEFT-CANCELLATION-FOR-*)))) + +(defun + m-binary-*-row (M1 M2 m j n) + "Return an alist with the following values: + (dot M1 M2 m j 0), . . . , (dot M1 M2 m j n); + ie. construct an alist of values representing + the vector of dot products of the m'th row of M1 + with columns 0 thru n of M2." + (declare (xargs :guard (and (integerp m) + (>= m 0) + (integerp j) + (>= j 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< m (first dims1)) + (< j (second dims1)))) + (let ((dims2 (dimensions '$arg1 M2))) + (and (< j (first dims2)) + (< n (second dims2))))))) + (if (zp n) + (list (cons (cons m 0) + (dot M1 M2 m j 0))) + (cons (cons (cons m n) + (dot M1 M2 m j n)) + (m-binary-*-row M1 M2 m j (- n 1))))) + +(defthm + m-binary-*-row-remove-compress2-1 + (implies (and (alist2p name l1) + (integerp i) + (>= i 0) + (< i (car (dimensions name l1))) + (< j (cadr (dimensions name l1)))) + (equal (m-binary-*-row (compress2 name l1) l2 i j k) + (m-binary-*-row l1 l2 i j k)))) + +(defthm + m-binary-*-row-remove-compress2-2 + (implies (and (alist2p name l2) + (integerp k) + (>= k 0) + (< j (car (dimensions name l2))) + (< k (cadr (dimensions name l2)))) + (equal (m-binary-*-row l1 (compress2 name l2) i j k) + (m-binary-*-row l1 l2 i j k)))) + +(defthm + m-=-row-implies-equal-m-binary-*-row-1 + (implies (m-=-row M1 M2 m n) + (equal (m-binary-*-row M1 M3 m n p) + (m-binary-*-row M2 M3 m n p)))) + +(defthm + m-=row-1-implies-equal-m-binary-*-row-2 + (implies (and (m-=-row-1 M2 M3 n p) + (integerp p) + (>= p 0)) + (equal (m-binary-*-row M1 M2 m n p) + (m-binary-*-row M1 M3 m n p)))) + +(defthm + assoc2-m-binary-*-row + (implies (and (integerp p) + (integerp j) + (>= j 0) + (<= j p)) + (assoc2 m j (m-binary-*-row M1 M2 m n p)))) + +(defthm + assoc2=nil-m-binary-*-row + (implies (not (equal i m)) + (equal (assoc2 i j (m-binary-*-row M1 M2 m n p)) + nil))) + +(defthm + cdr-assoc2-m-binary-*-row + (implies (and (integerp p) + (integerp j) + (>= j 0) + (<= j p)) + (equal (cdr (assoc2 m j (m-binary-*-row M1 M2 m n p))) + (dot M1 M2 m n j)))) + +(defun + m-binary-*-row-1 (M1 M2 m j n) + "Return an alist with all the following values: + (dot M1 M2 0 j 0), . . . , (dot M1 M2 0 j n) + . . . + . . . + . . . + (dot M1 M2 m j 0), . . . , (dot M1 M2 m j n)." + (declare (xargs :guard (and (integerp m) + (>= m 0) + (integerp j) + (>= j 0) + (integerp n) + (>= n 0) + (array2p '$arg1 M1) + (array2p '$arg2 M2) + (let ((dims1 (dimensions '$arg1 M1))) + (and (< m (first dims1)) + (< j (second dims1)))) + (let ((dims2 (dimensions '$arg1 M2))) + (and (< j (first dims2)) + (< n (second dims2))))))) + (if (zp m) + (m-binary-*-row M1 M2 0 j n) + (append (m-binary-*-row M1 M2 m j n) + (m-binary-*-row-1 M1 M2 (- m 1) j n)))) + +(defthm + alistp-m-binary-*-row-1 + (alistp (m-binary-*-row-1 M1 M2 m n p))) + +(defthm + bounded-integerp-alistp2-m-binary-*-row-1 + (implies (and (integerp m) + (integerp n) + (>= i 0) + (>= k 0) + (< i m) + (< k n)) + (bounded-integer-alistp2 (m-binary-*-row-1 M1 M2 i j k) + m + n))) + +(defthm + m-binary-*-row-1-remove-compress2-1 + (implies (and (alist2p name l1) + (integerp i) + (>= i 0) + (< i (car (dimensions name l1))) + (< j (cadr (dimensions name l1)))) + (equal (m-binary-*-row-1 (compress2 name l1) l2 i j k) + (m-binary-*-row-1 l1 l2 i j k)))) + +(defthm + m-binary-*-row-1-remove-compress2-2 + (implies (and (alist2p name l2) + (integerp k) + (>= k 0) + (< j (car (dimensions name l2))) + (< k (cadr (dimensions name l2)))) + (equal (m-binary-*-row-1 l1 (compress2 name l2) i j k) + (m-binary-*-row-1 l1 l2 i j k)))) + +(defthm + m-=-row-1-implies-equal-m-binary-*-row-1-1 + (implies (m-=-row-1 M1 M2 m n) + (equal (m-binary-*-row-1 M1 M3 m n p) + (m-binary-*-row-1 M2 M3 m n p)))) + +(defthm + m-=-row-1-implies-equal-m-binary-*-row-1-2 + (implies (and (m-=-row-1 M2 M3 n p) + (integerp p) + (>= p 0)) + (equal (m-binary-*-row-1 M1 M2 m n p) + (m-binary-*-row-1 M1 M3 m n p)))) + +(defthm + assoc2-m-binary-*-row-1 + (implies (and (integerp m) + (integerp p) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (<= i m) + (<= j p)) + (assoc2 i j (m-binary-*-row-1 M1 M2 m n p)))) + +(defthm + assoc2=nil-m-binary-*-row-1 + (implies (and (>= m 0) + (> i m)) + (equal (assoc2 i j (m-binary-*-row-1 M1 M2 m n p)) + nil))) + +(local (in-theory (enable assoc2-append))) + +(local + (defthm + cdr-assoc2-m-binary-*-row-1-lemma + (implies (and (equal (cdr (assoc2 i + j + (m-binary-*-row-1 M1 + M2 + (+ -1 m) + n + p))) + (dot M1 M2 i n j)) + (integerp j) + (<= 0 j) + (<= j p)) + (equal (cdr (assoc2 i + j + (append (m-binary-*-row M1 + M2 + m + n + p) + (m-binary-*-row-1 M1 + M2 + (+ -1 m) + n + p)))) + (dot M1 M2 i n j))))) + +(local (in-theory (disable assoc2-append))) + +(defthm + cdr-assoc2-m-binary-*-row-1 + (implies (and (integerp m) + (integerp i) + (integerp j) + (integerp p) + (>= i 0) + (>= j 0) + (<= i m) + (<= j p)) + (equal (cdr (assoc2 i j (m-binary-*-row-1 M1 M2 m n p))) + (dot M1 M2 i n j)))) + +(local (in-theory (disable cdr-assoc2-m-binary-*-row-1-lemma))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Ensuring closure of matrix multiplication. + +; Let dim1 be the number of rows and dim2 be the number of columns +; in an ACL2 two dimensional array. The product, dim1*dim2, is +; required to fit into 32 bits so that some compilers can lay down +; faster code. Thus, dim1*dim2 <= maximum-positive-32-bit-integer +; = 2^31 - 1 +; = 2,147,483,647. + +; This restriction on the size of dim1*dim2 means that matrices +; representable by ACL2 arrays are NOT closed under matrix +; multiplication, even when the product is mathematically defined. +; To illustrate, suppose dim1*dim2 is required to be no larger than +; 20; M1 is a matrix with 5 rows and 2 columns; and M2 is a matrix +; with 2 rows and 5 columns. Then M1 and M2 would both be +; representable and their product, M1 * M2, would be mathematically +; defined, but not representable (since 25 > 20). + +; Furthermore, when there are more than two matrices involved in a +; matrix multiplication, the final product may be both mathematically +; defined and representable by an ACL2 array, but yet not +; computable in ACL2. Let's illustrate by extending the example given +; above with M1 and M2. Suppose M0 is a matrix with 2 rows and 5 +; colums. Then the product (M0 * M1) * M2 is mathematically defined, +; representable in ACL2, and computable in ACL2 (since both partial +; products (M0 * M1) and (M0 * M1) * M2 are representable in ACL2). +; But the product M0 * (M1 * M2) is mathematically defined, +; representable in ACL2, but NOT computable in ACL2 (since the +; partial product (M1 * M2) is NOT representable in ACL2). + +; One way to prevent this last problem and also ensure closure for +; matrix multiplication is to require that each of dim1 and dim2 +; be less than or equal to 46,340 which is the integer square root +; of 2,147,483,647, the maximum-positive-32-bit-integer. Then +; the product of dim1*dim2 is guarenteed to be less than the +; the maximum-positive-32-bit-integer. Futhermore, with this stronger +; restriction, if the product M1 * . . . * Mn is both mathematically +; defined and representable in ACL2, then, for any way of +; parenthesizing this product, all the partial products are also +; mathematically defined and representable in ACL2. + +; Thus, for matrix multiplication, it is required that both the +; number of rows and the number of columns be less than or equal +; to 46,340. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun m-binary-* (M1 M2) + "Return an alist representing the matrix product + of the matrices represented by the alists M1 + and M2. This is done by adding a header to an + alist containing the appropriate values." + (declare (xargs :guard (and (array2p '$arg1 M1) + (array2p '$arg2 M2) + (= (second (dimensions '$arg1 M1)) + (first (dimensions '$arg2 M2)))))) + (let* ((dim1 (dimensions '$arg1 M1)) + (dim2 (dimensions '$arg2 M2)) + (dim11 (first dim1)) + (dim12 (second dim1)) + (dim21 (first dim2)) + (dim22 (second dim2))) + (if (mbt (and (alist2p '$arg1 M1) + (alist2p '$arg2 M2) + (= dim12 dim21))) + (cons (list :HEADER + :DIMENSIONS + (list dim11 dim22) + :MAXIMUM-LENGTH + (+ 1 (* dim11 dim22)) + :DEFAULT 0 + :NAME 'matrix-product) + (m-binary-*-row-1 (compress2 '$arg1 M1) + (compress2 '$arg2 M2) + (- dim11 1) + (- dim12 1) + (- dim22 1))) + (* M1 M2)))) + +(defmacro + m-* (&rest rst) + (if rst + (if (cdr rst) + (xxxjoin 'm-binary-* rst) + (car rst)) + 1)) + +(add-binop m-* m-binary-*) + +(defthm + alist2p-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2)))) + (alist2p name (m-* M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-* M1 M2)))) + :hints (("Goal" + :in-theory (enable alist2p header + dimensions + maximum-length)))) + +(defthm + array2p-m-*-1 + (implies (and (array2p name M1) + (array2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2))) + (< (* (first (dimensions name M1)) + (second (dimensions name M2))) + *MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (array2p name (m-* M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-* M1 M2)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + array2p-m-* + (implies (and (array2p name M1) + (array2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2))) + (<= (first (dimensions name M1)) + *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (<= (second (dimensions name M2)) + *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + (array2p name (m-* M1 M2))) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((m-* M1 M2)))) + :hints (("Goal" + :in-theory (enable array2p header + dimensions + maximum-length)))) + +(defthm + dimensions-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2)))) + (equal (dimensions name (m-* M1 M2)) + (list (first (dimensions name M1)) + (second (dimensions name M2))))) + :hints (("Goal" + :in-theory (enable alist2p dimensions header)))) + +(defthm + matrixp-m-* + (implies (and (matrixp m n X1) + (matrixp n p X2)) + (matrixp m p (m-* X1 X2))) + :hints (("Goal" + :in-theory (disable m-binary-*)))) + +(defthm + default-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2)))) + (equal (default name (m-* M1 M2)) + 0)) + :hints (("Goal" + :in-theory (enable alist2p default header)))) + +(defthm + maximum-length-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2)))) + (equal (maximum-length name (m-* M1 M2)) + (+ 1 (* (first (dimensions name M1)) + (second (dimensions name M2)))))) + :hints (("Goal" + :in-theory (enable alist2p maximum-length header)))) + +(defthm + aref2-m-* + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (second (dimensions name M1)) + (first (dimensions name M2))) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (first (dimensions name M1))) + (< j (second (dimensions name M2)))) + (equal (aref2 name (m-* M1 M2) i j) + (dot M1 + M2 + i + (+ -1 (second (dimensions name M1))) + j))) + :hints (("Goal" + :in-theory (enable aref2 header default)))) + +(defcong + ;; M-=-IMPLIES-EQUAL-M-*-1 + m-= equal (M-* M1 M2) 1) + +(defcong + ;; M-=-IMPLIES-EQUAL-M-*-2 + m-= equal (M-* M1 M2) 2) + +(defthm + m-=-row-m-binary-*-row-append-1 + (equal (m-=-row (append (m-binary-*-row M1 M2 m n p) + lst) + M3 + m + p) + (m-=-row (m-binary-*-row M1 M2 m n p) + M3 + m + p))) + +(defthm + m-=-row-m-binary-*-row-append-2 + (equal (m-=-row M3 + (append (m-binary-*-row M1 M2 m n p) + lst) + m + p) + (m-=-row M3 + (m-binary-*-row M1 M2 m n p) + m + p))) + +(defthm + m-=-row-m-binary-*-row-append-1-remove-header + (equal (m-=-row (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 M2 m n p) + lst)) + M3 + m + p) + (m-=-row (m-binary-*-row M1 M2 m n p) + M3 + m + p))) + +(defthm + m-=-row-m-binary-*-row-append-2-remove-header + (equal (m-=-row M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 M2 m n p) + lst)) + m + p) + (m-=-row M3 + (m-binary-*-row M1 M2 m n p) + m + p))) + +(defthm + m-=-row-m-binary-*-row-remove-header-1 + (equal (m-=-row (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row M1 M2 m n p)) + M3 + m + p) + (m-=-row (m-binary-*-row M1 M2 m n p) + M3 + m + p))) + +(defthm + m-=-row-m-binary-*-row-remove-header-2 + (equal (m-=-row M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row M1 M2 m n p)) + m + p) + (m-=-row m3 + (m-binary-*-row M1 M2 m n p) + m + p))) + +(defthm + aref2-append-m-binary-*-row + (implies (and (> m i)) + (equal (aref2 name (append (m-binary-*-row M1 M2 m j k) + lst) + i n) + (aref2 name lst i n)))) + +(defthm + aref2-append-m-binary-*-row-header + (implies (and (> m i)) + (equal (aref2 + name + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 M2 m j k) + lst)) + i + n) + (aref2 + name + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + i + n)))) + +(defthm + m-=-row-m-binary-*-row-append-3 + (implies (> m i) + (equal (m-=-row (append (m-binary-*-row M1 + M2 + m + n + p) + lst) + M3 + i + p) + (m-=-row lst + M3 + i + p)))) + +(defthm + m-=-row-m-binary-*-row-append-4 + (implies (> m i) + (equal (m-=-row M3 + (append (m-binary-*-row M1 + M2 + m + n + p) + lst) + i + p) + (m-=-row M3 + lst + i + p)))) + +(defthm + m-=-row-m-binary-*-row-append-3-header + (implies (> m i) + (equal (m-=-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 + M2 + m + n + p) + lst)) + M3 + i + p) + (m-=-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + i + p)))) + +(defthm + m-=-row-m-binary-*-row-append-4-header + (implies (> m i) + (equal (m-=-row + m3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 + M2 + m + n + p) + lst)) + i + p) + (m-=-row + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + i + p)))) + +(defthm + m-=-row-1-m-binary-*-row-append-1 + (implies (and (>= j 0) + (< j m)) + (equal (m-=-row-1 (append (m-binary-*-row M1 + M2 + m + n + p) + lst) + M3 + j + p) + (m-=-row-1 lst + M3 + j + p)))) + +(defthm + m-=-row-1-m-binary-*-row-append-2 + (implies (and (>= j 0) + (< j m)) + (equal (m-=-row-1 M3 + (append (m-binary-*-row M1 + M2 + m + n + p) + lst) + j + p) + (m-=-row-1 M3 + lst + j + p)))) + +(defthm + m-=-row-1-m-binary-*-row-append-1-header + (implies (and (>= j 0) + (< j m)) + (equal (m-=-row-1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 + M2 + m + n + p) + lst)) + M3 + j + p) + (m-=-row-1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + j + p)))) + +(defthm + m-=-row-1-m-binary-*-row-append-2-header + (implies (and (>= j 0) + (< j m)) + (equal (m-=-row-1 + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 + M2 + m + n + p) + lst)) + j + p) + (m-=-row-1 + M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + j + p)))) + +(defthm + m-=-row-1-m-binary-*-row-1-remove-header-1 + (equal (m-=-row-1 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row-1 M1 + M2 + m + n + p)) + M3 + m + p) + (m-=-row-1 (m-binary-*-row-1 M1 M2 m n p) + M3 + m + p))) + +(defthm + m-=-row-1-m-binary-*-row-1-remove-header-2 + (equal (m-=-row-1 M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row-1 M1 + M2 + m + n + p)) + m + p) + (m-=-row-1 M3 + (m-binary-*-row-1 M1 M2 m n p) + m + p))) + +(defthm + dot-m-0-1 + (equal (dot (m-0 m n) M1 i j k) + 0)) + +(defthm + dot-m-0-2 + (equal (dot M1 (m-0 m n) i j k) + 0)) + +(defthm + m-=-row-m-binary-*-row-m-0-1 + (m-=-row (m-binary-*-row (m-0 m n) + M1 + i + j + k) + (m-0 m p) + i + k)) + +(defthm + m-=-row-m-binary-*-row-m-0-2 + (m-=-row (m-binary-*-row M1 + (m-0 n p) + i + j + k) + (m-0 m p) + i + k)) + +(defthm + m-=-row-1-m-binary-*-row-1-m-0-1 + (m-=-row-1 (m-binary-*-row-1 (m-0 m n) + M1 + i + j + k) + (m-0 m p) + i + k)) + +(defthm + m-=-row-1-m-binary-*-row-1-m-0-2 + (m-=-row-1 (m-binary-*-row-1 M1 + (m-0 n p) + i + j + k) + (m-0 m p) + i + k)) + +(defthm + alist2p-m-binary-*-row-1-header-m-0-hack-1 + (implies (and (ALIST2P NAME M1) + (INTEGERP M) + (< 0 M)) + (ALIST2P name1 + (CONS (LIST* :HEADER :DIMENSIONS + (LIST M (CADR (DIMENSIONS '$ARG M1))) + :MAXIMUM-LENGTH + (+ 1 (* M (CADR (DIMENSIONS '$ARG M1)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-*-ROW-1 (M-0 M (CAR (DIMENSIONS '$ARG M1))) + M1 + (+ -1 M) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1))))))) + :hints (("Goal" + :in-theory (disable Alist2P-M-*) + :use (:instance + Alist2P-M-* + (M1 (m-0 m (first (dimensions name M1)))) + (M2 M1))))) + +(defthm + left-nullity-of-m-0-for-m-* + (implies (and (alist2p name M1) + (integerp m) + (> m 0)) + (m-= (m-* (m-0 m (first (dimensions name M1))) + M1) + (m-0 m (second (dimensions name M1)))))) + +(defthm + alist2p-m-binary-*-row-1-header-m-0-hack-2 + (implies (and (ALIST2P NAME M1) + (INTEGERP p) + (< 0 p)) + (ALIST2P name1 + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) P) + :MAXIMUM-LENGTH + (+ 1 (* P (CAR (DIMENSIONS '$ARG M1)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-*-ROW-1 M1 (M-0 (CADR (DIMENSIONS '$ARG M1)) P) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1))) + (+ -1 P))))) + :hints (("Goal" + :in-theory (disable Alist2P-M-*) + :use (:instance + Alist2P-M-* + (M2 (M-0 (CADR (DIMENSIONS '$ARG M1)) P)))))) + +(defthm + right-nullity-of-m-0-for-m-* + (implies (and (alist2p name M1) + (integerp p) + (> p 0)) + (m-= (m-* M1 + (m-0 (second (dimensions name M1)) + p)) + (m-0 (first (dimensions name M1)) + p)))) + +(defthm + aref2-m-1 + (implies (and (integerp i) + (integerp n) + (<= 0 i) + (< i n)) + (equal (aref2 name (m-1 n) i j) + (if (equal i j) + 1 + 0)))) + +(defthm + dot-m-1-1 + (implies (and (integerp i) + (integerp j) + (integerp m) + (>= i 0) + (>= j 0) + (> m i)) + (equal (dot (m-1 m) M1 i j k) + (if (<= i j) + (fix (aref2 '$arg M1 i k)) + 0)))) + +(defthm + dot-m-1-2 + (implies (and (integerp j) + (integerp k) + (integerp m) + (>= j 0) + (>= k 0) + (> m j)) + (equal (dot M1 (m-1 m) i j k) + (if (<= k j) + (fix (aref2 '$arg M1 i k)) + 0)))) + +(defthm + m-=-row-m-binary-*-row-m-1-1 + (implies (and (integerp i) + (integerp j) + (integerp m) + (>= i 0) + (>= j i) + (> m i)) + (m-=-row (m-binary-*-row (m-1 m) + M1 + i + j + k) + M1 + i + k))) + +(defthm + m-=-row-m-binary-*-row-m-1-2 + (implies (and (integerp j) + (integerp k) + (integerp m) + (>= j k) + (>= k 0) + (> m j)) + (m-=-row (m-binary-*-row M1 + (m-1 m) + i + j + k) + M1 + i + k))) + +(defthm + m-=-row-1-m-binary-*-row-1-m-1-1 + (implies (and (integerp i) + (integerp j) + (integerp m) + (>= i 0) + (>= j i) + (> m i)) + (m-=-row-1 (m-binary-*-row-1 (m-1 m) + M1 + i + j + k) + M1 + i + k))) + +(defthm + m-=-row-1-m-binary-*-row-1-m-1-2 + (implies (and (integerp j) + (integerp k) + (integerp m) + (>= j k) + (>= k 0) + (> m j)) + (m-=-row-1 (m-binary-*-row-1 M1 + (m-1 m) + i + j + k) + M1 + i + k))) + +(defthm + alist2p-m-binary-*-row-1-header-m-1-hack-1 + (IMPLIES (ALIST2P NAME M1) + (ALIST2P name1 + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-*-ROW-1 (M-1 (CAR (DIMENSIONS '$ARG M1))) + M1 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1))))))) + :hints (("Goal" + :in-theory (disable Alist2P-M-*) + :use (:instance + Alist2P-M-* + (M1 (m-1 (first (dimensions name M1)))) + (M2 M1))))) + + +(defthm + left-unity-of-m-1-for-m-* + (implies (alist2p name M1) + (m-= (m-* (m-1 (first (dimensions name M1))) + M1) + M1))) + +(defthm + alist2p-m-binary-*-row-1-header-m-1-hack-2 + (IMPLIES (ALIST2P NAME M1) + (ALIST2P name1 + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M1)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-*-ROW-1 M1 (M-1 (CADR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M1))))))) + :hints (("Goal" + :in-theory (disable Alist2P-M-*) + :use (:instance + Alist2P-M-* + (M2 (m-1 (second (dimensions name M1)))))))) + +(defthm + right-unity-of-m-1-for-m-* + (implies (alist2p name M1) + (m-= (m-* M1 + (m-1 (second (dimensions name M1)))) + M1))) + +(defthm + dot-cons-1 + (implies (and (>= p 0) + (> j p)) + (equal (dot (cons (cons (cons m j) val) + lst) + M3 + m + p + q) + (dot lst + M3 + m + p + q)))) + +(defthm + dot-cons-header-1 + (implies (and (>= p 0) + (> j p)) + (equal (dot (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (cons (cons (cons m j) val) + lst)) + M3 + m + p + q) + (dot (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + m + p + q)))) + +(defthm + dot-cons-m-binary-*-row-append-1 + (implies (> j p) + (equal (dot (cons (cons (cons m j) val) + (append (m-binary-*-row M1 + M2 + m + n + p) + lst)) + M3 + m + p + q) + (dot (cons (cons (cons m j) val) + (m-binary-*-row M1 + M2 + m + n + p)) + M3 + m + p + q)))) + +(defthm + dot-m-binary-*-row-append-1 + (equal (dot (append (m-binary-*-row M1 M2 m n p) + lst) + M3 + m + p + q) + (dot (m-binary-*-row M1 M2 m n p) + M3 + m + p + q))) + +(defthm + dot-m-binary-*-row-append-3 + (implies (> m i) + (equal (dot (append (m-binary-*-row M1 M2 m n p) + lst) + M3 + i + p + q) + (dot lst + M3 + i + p + q)))) + +(defthm + dot-m-binary-*-row-append-3-header + (implies (> m i) + (equal (dot + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 + M2 + m + n + p) + lst)) + M3 + i + p + q) + (dot + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + i + p + q)))) + +(defthm + dot-m-binary-*-row-append-remove-header-1 + (equal (dot (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 M2 m n p) + lst)) + M3 + m + p + q) + (dot (m-binary-*-row M1 M2 m n p) + M3 + m + p + q))) + +(defthm + dot-m-binary-*-row-remove-header-1 + (equal (dot (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row M1 M2 m n p)) + M3 + m + p + q) + (dot (m-binary-*-row M1 M2 m n p) + M3 + m + p + q))) + +(defthm + m-binary-*-row-m-binary-*-row-append-1 + (equal (m-binary-*-row (append (m-binary-*-row M1 M2 m n p) + lst) + M3 + m + p + q) + (m-binary-*-row (m-binary-*-row M1 M2 m n p) + M3 + m + p + q))) + +(defthm + m-binary-*-row-m-binary-*-row-append-1-remove-header + (equal (m-binary-*-row (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 M2 m n p) + lst)) + M3 + m + p + q) + (m-binary-*-row (m-binary-*-row M1 M2 m n p) + M3 + m + p + q))) + +(defthm + m-binary-*-row-m-binary-*-row-remove-header-1 + (equal (m-binary-*-row (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row M1 M2 m n p)) + M3 + m + p + q) + (m-binary-*-row (m-binary-*-row M1 M2 m n p) + M3 + m + p + q))) + +(defthm + m-binary-*-row-m-binary-*-row-append-3 + (implies (> m i) + (equal (m-binary-*-row (append (m-binary-*-row M1 + M2 + m + n + p) + lst) + M3 + i + p + q) + (m-binary-*-row lst + M3 + i + p + q)))) + +(defthm + m-binary-*-row-m-binary-*-row-append-3-header + (implies (> m i) + (equal (m-binary-*-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 + M2 + m + n + p) + lst)) + M3 + i + p + q) + (m-binary-*-row + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + i + p + q)))) + +(defthm + m-binary-*-row-1-m-binary-*-row-append-1 + (implies (and (>= j 0) + (< j m)) + (equal (m-binary-*-row-1 (append (m-binary-*-row M1 + M2 + m + n + p) + lst) + M3 + j + p + q) + (m-binary-*-row-1 lst + M3 + j + p + q)))) + +(defthm + m-binary-*-row-1-m-binary-*-row-append-1-header + (implies (and (>= j 0) + (< j m)) + (equal (m-binary-*-row-1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (append (m-binary-*-row M1 + M2 + m + n + p) + lst)) + M3 + j + p + q) + (m-binary-*-row-1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + lst) + M3 + j + p + q)))) + +(defthm + m-binary-*-row-1-m-binary-*-row-1-remove-header-1 + (equal (m-binary-*-row-1 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row-1 M1 + M2 + m + n + p)) + M3 + m + p + q) + (m-binary-*-row-1 (m-binary-*-row-1 M1 M2 m n p) + M3 + m + p + q))) + +(defthm + m-binary-*-row-1-m-binary-*-row-1-remove-header-2 + (implies (and (integerp q) + (>= q 0)) + (equal (m-binary-*-row-1 M3 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH + max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row-1 M1 + M2 + n + p + q)) + m + n + q) + (m-binary-*-row-1 M3 + (m-binary-*-row-1 M1 M2 n p q) + m + n + q))) + :hints (("Goal" + :use (:instance + m-=-row-1-implies-equal-m-binary-*-row-1-2 + (M1 M3) + (M2 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH + max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row-1 M1 + M2 + n + p + q))) + (M3 (m-binary-*-row-1 M1 M2 n p q)) + (p q))))) + +(defthm + aref2-m-binary-*-row-lemma + (implies (and (>= q i) + (integerp q) + (integerp i) + (>= i j)) + (equal (aref2 name (m-binary-*-row M2 M3 n p q) n j) + (aref2 name (m-binary-*-row M2 M3 n p i) n j))) + :rule-classes nil) + +(defthm + aref2-m-binary-*-row + (implies (and (> q i) + (integerp q) + (integerp i) + (>= i j)) + (equal (aref2 name (m-binary-*-row M2 M3 n p q) n j) + (aref2 name (m-binary-*-row M2 M3 n p i) n j))) + :hints (("Goal" + :use aref2-m-binary-*-row-lemma))) + +(defthm + m-=-row-m-binary-*-row-q>i + (implies (and (integerp q) + (integerp i) + (>= i 0) + (> q i)) + (m-=-row (m-binary-*-row M2 M3 n p q) + (m-binary-*-row M2 M3 n p i) + n + i))) + +(defthm + m-=-row-implies-m-=-row-q>i-lemma + (implies (and (m-=-row M1 M2 n q) + (integerp q) + (integerp i) + (>= q i)) + (m-=-row M1 M2 n i)) + :rule-classes nil) + +(defthm + m-=-row-implies-m-=-row-q>i + (implies (and (m-=-row M1 M2 n q) + (integerp q) + (integerp i) + (> q i)) + (m-=-row M1 M2 n i)) + :hints (("Goal" + :use m-=-row-implies-m-=-row-q>i-lemma))) + +(defthm + m-=-row-append-m-binary-*-row-q>i + (implies (and (integerp q) + (integerp i) + (> q i)) + (m-=-row (append (m-binary-*-row M2 M3 n p q) + lst) + (m-binary-*-row M2 M3 n p q) + n + i)) + :hints (("Goal" + :in-theory (disable m-=-row-implies-m-=-row-q>i) + :use (:instance + m-=-row-implies-m-=-row-q>i + (M1 (append (m-binary-*-row M2 M3 n p q) + lst)) + (M2 (m-binary-*-row M2 M3 n p q)))))) + +(defthm + m-=-row-append-m-binary-*-row-q>i-1 + (implies (and (integerp q) + (integerp i) + (>= i 0) + (> q i)) + (m-=-row (append (m-binary-*-row M2 M3 n p q) + lst) + (m-binary-*-row M2 M3 n p i) + n + i)) + :hints (("Goal" + :in-theory (disable TRANSITIVITY-OF-M-=-ROW) + :use (:instance + TRANSITIVITY-OF-M-=-ROW + (M1 (append (m-binary-*-row M2 M3 n p q) + lst)) + (M2 (m-binary-*-row M2 M3 n p q)) + (M3 (m-binary-*-row M2 M3 n p i)) + (m n) + (n i))))) + +(defthm + m-=-row-m-binary-*-row-1-q>i + (implies (and (> q i) + (integerp n) + (integerp q) + (integerp i) + (>= n 0) + (>= i 0)) + (m-=-row (m-binary-*-row-1 M2 M3 n p q) + (m-binary-*-row-1 M2 M3 n p i) + n + i))) + +(defthm + m-=-row-1-implies-m-=-row + (implies (and (m-=-row-1 M1 M2 n q) + (integerp n) + (>= n 0)) + (m-=-row M1 M2 n q))) + +(defthm + m-=-row-1-implies-m-=-row-q>i + (implies (and (m-=-row-1 M1 M2 n q) + (integerp q) + (integerp i) + (> q i) + (integerp n) + (>= n 0)) + (m-=-row M1 M2 n i)) + :hints (("Goal" + :use m-=-row-implies-m-=-row-q>i))) + +(defthm + m-=-row-1-implies-m-=-row-1-q>i + (implies (and (m-=-row-1 M1 M2 n q) + (integerp q) + (integerp i) + (> q i) + (integerp n) + (>= n 0)) + (m-=-row-1 M1 M2 n i))) + +(defthm + m-=-row-1-append-m-binary-*-row-n>j + (implies (and (>= j 0) + (> n j)) + (m-=-row-1 (append (m-binary-*-row M2 + M3 + n + p + q) + lst) + lst + j + q))) + +(defthm + m-=-row-1-append-m-binary-*-row-n>j-q>i + (implies (and (m-=-row-1 lst1 lst2 j i) + (>= j 0) + (> n j)) + (m-=-row-1 (append (m-binary-*-row M2 + M3 + n + p + q) + lst1) + lst2 + j + i))) + +(defthm + m-=-row-1-m-binary-*-row-1-q>i + (implies (and (> q i) + (integerp q) + (integerp i) + (>= i 0)) + (m-=-row-1 (m-binary-*-row-1 M2 M3 n p q) + (m-binary-*-row-1 M2 M3 n p i) + n + i))) + +(defthm + m-binary-*-row-m-binary-*-row-1-q>i + (implies (and (integerp q) + (integerp i) + (>= i 0) + (> q i)) + (equal (m-binary-*-row M1 + (m-binary-*-row-1 M2 + M3 + n + p + q) + m + n + i) + (m-binary-*-row M1 + (m-binary-*-row-1 M2 + M3 + n + p + i) + m + n + i))) + :hints (("Goal" + :in-theory (disable + m-=row-1-implies-equal-m-binary-*-row-2) + :use (:instance + m-=row-1-implies-equal-m-binary-*-row-2 + (M2 (m-binary-*-row-1 M2 M3 n p q)) + (M3 (m-binary-*-row-1 M2 M3 n p i)) + (p i))))) + +(defthm + m-=-row-implies-equal-m-binary-*-row + (implies (m-=-row (m-binary-*-row M1 M2 m n q) + (m-binary-*-row M3 M4 m p q) + m + q) + (equal (m-binary-*-row M1 M2 m n q) + (m-binary-*-row M3 M4 m p q)))) + +(defthm + m-=-row-1-implies-equal-m-binary-*-row-1 + (implies (m-=-row-1 (m-binary-*-row-1 M1 M2 m n q) + (m-binary-*-row-1 M3 M4 m p q) + m + q) + (equal (m-binary-*-row-1 M1 M2 m n q) + (m-binary-*-row-1 M3 M4 m p q)))) + +(defthm + aref2-append-m-binary-*-row-1 + (implies (and (integerp q) + (>= q 0)) + (equal (aref2 name + (append (m-binary-*-row M2 + M3 + n + p + q) + lst) + n + q) + (aref2 name + (m-binary-*-row M2 + M3 + n + p + q) + n + q)))) + +(defthm + dot-append-m-binary-*-row + (implies (and (>= j 0) + (> n j)) + (equal (dot M1 + (append (m-binary-*-row M2 + M3 + n + p + q) + lst) + m + j + q) + (dot M1 + lst + m + j + q)))) + +(defthm + aref2-m-binary-*-row-0 + (implies (and (integerp q) + (>= q 0)) + (equal (aref2 name + (m-binary-*-row M2 M3 n 0 q) + n + q) + (* (aref2 name M2 n 0) + (aref2 name M3 0 q))))) + +(defthm + dot-m-binary-*-row-1-0 + (implies (and (integerp q) + (>= q 0)) + (equal (dot M1 + (m-binary-*-row-1 M2 + M3 + n + 0 + q) + m + n + q) + (* (aref2 name M3 0 q) + (dot M1 M2 m n 0))))) + +(defthm + aref2-m-binary-*-row-p>0 + (implies (and (integerp p) + (integerp q) + (> p 0) + (>= q 0)) + (equal (+ (* (aref2 name M2 n p) + (aref2 name M3 p q)) + (aref2 name + (m-binary-*-row M2 + M3 + n + (+ -1 p) + q) + n + q)) + (aref2 name + (m-binary-*-row M2 M3 n p q) + n + q)))) + +(defthm + dot-m-binary-*-row-1-p>0 + (implies (and (integerp n) + (integerp p) + (integerp q) + (>= n 0) + (> p 0) + (>= q 0)) + (equal (+ (* (aref2 name M3 p q) + (dot M1 M2 m n p)) + (dot M1 + (m-binary-*-row-1 M2 + M3 + n + (+ -1 p) + q) + m + n + q)) + (dot M1 + (m-binary-*-row-1 M2 + M3 + n + p + q) + m + n + q))) + :hints (("Subgoal *1/4" + :in-theory (disable + aref2-m-binary-*-row-p>0) + :use aref2-m-binary-*-row-p>0) + ("Subgoal *1/1" + :do-not '(generalize)))) + +(defthm + dot-m-binary-*-row-associativity + (implies (and (integerp n) + (integerp p) + (integerp q) + (>= n 0) + (>= p 0) + (>= q 0)) + (equal (dot (m-binary-*-row M1 M2 m n p) + M3 + m + p + q) + (dot M1 + (m-binary-*-row-1 M2 M3 n p q) + m + n + q))) + :hints (("Subgoal *1/4.1" + :in-theory (disable dot-m-binary-*-row-1-p>0) + :use dot-m-binary-*-row-1-p>0))) + +(defthm + m-=-row-m-binary-*-row-associativity + (implies (and (integerp n) + (integerp p) + (integerp q) + (>= n 0) + (>= p 0) + (>= q 0)) + (m-=-row (m-binary-*-row (m-binary-*-row M1 + M2 + m + n + p) + M3 + m + p + q) + (m-binary-*-row M1 + (m-binary-*-row-1 + M2 + M3 + n + p + q) + m + n + q) + m + q))) + +(defthm + m-=-row-1-m-binary-*-row-1-associativity + (implies + (and (integerp n) + (integerp p) + (integerp q) + (>= n 0) + (>= p 0) + (>= q 0)) + (m-=-row-1 (m-binary-*-row-1 (m-binary-*-row-1 M1 + M2 + m + n + p) + M3 + m + p + q) + (m-binary-*-row-1 M1 + (m-binary-*-row-1 M2 + M3 + n + p + q) + m + n + q) + m + q))) + +(defthm + m-binary-*-row-1-associativity + (implies + (and (integerp n) + (integerp p) + (integerp q) + (>= n 0) + (>= p 0) + (>= q 0)) + (equal (m-binary-*-row-1 (m-binary-*-row-1 M1 + M2 + m + n + p) + M3 + m + p + q) + (m-binary-*-row-1 M1 + (m-binary-*-row-1 M2 + M3 + n + p + q) + m + n + q))) + :hints (("Goal" + :in-theory + (disable + m-=-row-1-implies-equal-m-binary-*-row-1) + :use + (:instance + m-=-row-1-implies-equal-m-binary-*-row-1 + (M1 (m-binary-*-row-1 M1 M2 m n p)) + (M2 M3) + (M3 M1) + (M4 (m-binary-*-row-1 M2 M3 n p q)) + (n p) + (p n))))) + +(defthm + alist2p-m-binary-*-row-1-header-hack-1 + (IMPLIES (AND (ALIST2P '$ARG1 M1) + (ALIST2P '$ARG2 M2) + (EQUAL (CADR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M2))) + (EQUAL (CADR (DIMENSIONS '$ARG M2)) + (CAR (DIMENSIONS '$ARG M3)))) + (ALIST2P name + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M3))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M3)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-*-ROW-1 M1 + M2 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M2))) + (+ -1 (CAR (DIMENSIONS '$ARG M3))))))) + :HINTS (("Goal" + :IN-THEORY (ENABLE Alist2P HEADER DIMENSIONS MAXIMUM-LENGTH)))) + +(defthm + alist2p-m-binary-*-row-1-header-hack-2 + (IMPLIES (AND (ALIST2P '$ARG1 M2) + (ALIST2P '$ARG2 M3) + (EQUAL (CADR (DIMENSIONS '$ARG M1)) + (CAR (DIMENSIONS '$ARG M2))) + (EQUAL (CADR (DIMENSIONS '$ARG M2)) + (CAR (DIMENSIONS '$ARG M3)))) + (ALIST2P name + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M2)) + (CADR (DIMENSIONS '$ARG M3))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M2)) + (CADR (DIMENSIONS '$ARG M3)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-*-ROW-1 M2 + M3 + (+ -1 (CAR (DIMENSIONS '$ARG M2))) + (+ -1 (CAR (DIMENSIONS '$ARG M3))) + (+ -1 (CADR (DIMENSIONS '$ARG M3))))))) + :HINTS (("Goal" + :IN-THEORY (ENABLE Alist2P HEADER DIMENSIONS MAXIMUM-LENGTH)))) + +(defthm + associativity-of-m-* + (equal (m-* (m-* M1 M2) M3) + (m-* M1 M2 M3))) + +(defthm + m-binary-*-row-1-m-binary-+-row-1-remove-header-1 + (equal (m-binary-*-row-1 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M1 + M2 + i + j)) + M3 + i + j + k) + (m-binary-*-row-1 (m-binary-+-row-1 M1 M2 i j) + M3 + i + j + k)) + :hints (("Goal" + :use (:instance + m-=-row-1-implies-equal-m-binary-*-row-1-1 + (M1 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M1 + M2 + i + j))) + (M2 (m-binary-+-row-1 M1 M2 i j)) + (m i) + (n j) + (p k))))) + +(defthm + m-binary-*-row-1-m-binary-+-row-1-remove-header-2 + (implies (and (integerp k) + (>= k 0)) + (equal (m-binary-*-row-1 M1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M2 + M3 + j + k)) + i + j + k) + (m-binary-*-row-1 M1 + (m-binary-+-row-1 M2 + M3 + j + k) + i + j + k))) + :hints (("Goal" + :use (:instance + m-=-row-1-implies-equal-m-binary-*-row-1-2 + (M2 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-+-row-1 M2 + M3 + j + k))) + (M3 (m-binary-+-row-1 M2 + M3 + j + k)) + (n j) + (p k) + (m i))))) + +(defthm + m-binary-+-row-1-m-binary-*-row-1-remove-header-1 + (equal (m-binary-+-row-1 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row-1 M1 + M2 + i + j + k)) + M3 + i + k) + (m-binary-+-row-1 (m-binary-*-row-1 M1 M2 i j k) + M3 + i + k)) + :hints (("Goal" + :use (:instance + m-=-row-1-implies-equal-m-binary-+-row-1-1 + (M1 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row-1 M1 + M2 + i + j + k))) + (M2 (m-binary-*-row-1 M1 M2 i j k)) + (m i) + (n k))))) + +(defthm + m-binary-+-row-1-m-binary-*-row-1-remove-header-2 + (equal (m-binary-+-row-1 M1 + (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row-1 M2 + M3 + i + j + k)) + i + k) + (m-binary-+-row-1 M1 + (m-binary-*-row-1 M2 M3 i j k) + i + k)) + :hints (("Goal" + :use (:instance + m-=-row-1-implies-equal-m-binary-+-row-1-2 + (M2 (cons (list :HEADER + :DIMENSIONS dims + :MAXIMUM-LENGTH max-length + :DEFAULT default + :NAME name1) + (m-binary-*-row-1 M2 + M3 + i + j + k))) + (M3 (m-binary-*-row-1 M2 M3 i j k)) + (m i) + (n k))))) + +(defthm + distributivity-aref2-m-binary-+-row + (implies (and (integerp k) + (>= k 0)) + (equal (* x + (aref2 '$arg + (m-binary-+-row M2 + M3 + j + k) + j + k)) + (+ (* x (aref2 '$arg M2 j k)) + (* x (aref2 '$arg M3 j k)))))) + +(defthm + aref2-append-m-binary-+-row-a + (implies (and (integerp k) + (>= k 0)) + (equal (aref2 '$arg (append (m-binary-+-row M2 M3 j k) + lst) + j + k) + (aref2 '$arg (m-binary-+-row M2 M3 j k) j k)))) + +(defthm + aref2-append-m-binary-+-row-b + (implies (and (integerp k) + (>= k 0) + (integerp k1) + (< k k1)) + (equal (aref2 '$arg (append (m-binary-+-row M2 M3 j k1) + lst) + j + k) + (aref2 '$arg (m-binary-+-row M2 M3 j k) j k)))) + +(defthm + dot-remove-cons + (implies (and (>= l 0) + (< l j)) + (equal (dot M1 + (cons (cons (cons j k) val) lst) + i + l + k) + (dot M1 lst i l k)))) + +(defthm + dot-remove-cons-1 + (implies (< k k1) + (equal (dot M1 + (cons (cons (cons j k1) val) lst) + i + l + k) + (dot M1 lst i l k)))) + +(defthm + dot-append-m-binary-+-row + (implies (and (>= l 0) + (< l j)) + (equal (dot M1 + (append (m-binary-+-row M2 M3 j k1) + lst) + i + l + k) + (dot M1 lst i l k)))) + +(defthm + dot-m-binary-+-row-1 + (implies (and (integerp k) + (>= k 0)) + (equal (dot M1 + (m-binary-+-row-1 M2 M3 j k) + i + j + k) + (+ (dot M1 M2 i j k) + (dot M1 M3 i j k))))) + +(defthm + dot-m-binary-+-row-1-a + (implies (and (< k k1) + (integerp k) + (>= k 0) + (integerp k1)) + (equal (dot M1 + (m-binary-+-row-1 M2 M3 j k1) + i + j + k) + (+ (dot M1 M2 i j k) + (dot M1 M3 i j k)))) + :hints (("Goal" + :do-not '(generalize)))) + +(defthm + dot-m-binary-+-row-1-b + (implies (and (<= k k1) + (integerp k) + (>= k 0) + (integerp k1)) + (equal (dot M1 + (m-binary-+-row-1 M2 M3 j k1) + i + j + k) + (+ (dot M1 M2 i j k) + (dot M1 M3 i j k)))) + :hints (("Goal" + :cases ((< k k1))))) + +(defthm + m-binary-*-row-remove-cons + (implies (and (>= l 0) + (< l j)) + (equal (m-binary-*-row M1 + (cons (cons (cons j k1) val) lst) + i + l + k) + (m-binary-*-row M1 lst i l k)))) + +(defthm + m-binary-*-row-remove-cons-1 + (implies (and (>= k 0) + (< k k1)) + (equal (m-binary-*-row M1 + (cons (cons (cons j k1) val) lst) + i + j + k) + (m-binary-*-row M1 lst i j k)))) + +(defthm + distributivity-m-binary-*-append-row-m-binary-+-row + (implies (and (integerp j) + (integerp k) + (>= j 0) + (>= l 0) + (>= k l)) + (equal (m-binary-*-row M1 + (append (m-binary-+-row M2 M3 j l) + (m-binary-+-row-1 M2 M3 (+ -1 j) k)) + i + j + l) + (m-binary-+-row (m-binary-*-row M1 M2 i j l) + (m-binary-*-row M1 M3 i j l) + i + l)))) + +(defthm + distributivity-m-binary-*-row-m-binary-+-row-case-j=0 + (equal (m-binary-*-row M1 + (m-binary-+-row M2 M3 0 k) + i + 0 + k) + (m-binary-+-row (m-binary-*-row M1 M2 i 0 k) + (m-binary-*-row M1 M3 i 0 k) + i + k))) + +(defthm + distributivity-m-binary-*-row-m-binary-+-row-a + (implies (and (integerp k) + (<= l k) + (>= l 0)) + (equal (m-binary-*-row M1 + (m-binary-+-row-1 M2 M3 j k) + i + j + l) + (m-binary-+-row (m-binary-*-row M1 M2 i j l) + (m-binary-*-row M1 M3 i j l) + i + l)))) + +(defthm + distributivity-m-binary-*-row-m-binary-+-row + (equal (m-binary-*-row M1 + (m-binary-+-row-1 M2 M3 j k) + i + j + k) + (m-binary-+-row (m-binary-*-row M1 M2 i j k) + (m-binary-*-row M1 M3 i j k) + i + k))) + +(defthm + m-binary-+-row-1-remove-cons-1 + (implies (and (>= i1 0) + (< i1 i)) + (equal (m-binary-+-row-1 (cons (cons (cons i j) val) + lst1) + lst2 + i1 + j) + (m-binary-+-row-1 lst1 + lst2 + i1 + j)))) + +(defthm + m-binary-+-row-1-remove-cons-2 + (implies (and (>= i1 0) + (< i1 i)) + (equal (m-binary-+-row-1 lst1 + (cons (cons (cons i j) val) + lst2) + i1 + j) + (m-binary-+-row-1 lst1 + lst2 + i1 + j)))) + +(defthm + m-binary-+-row-remove-append-1 + (equal (m-binary-+-row (append (m-binary-*-row M1 M2 i j k) + lst1) + lst2 + i + k) + (m-binary-+-row (m-binary-*-row M1 M2 i j k) + lst2 + i + k))) + +(defthm + m-binary-+-row-remove-append-2 + (equal (m-binary-+-row lst1 + (append (m-binary-*-row M1 M2 i j k) + lst2) + i + k) + (m-binary-+-row lst1 + (m-binary-*-row M1 M2 i j k) + i + k))) + +(defthm + m-binary-+-row-remove-append-1a + (implies (< i1 i) + (equal (m-binary-+-row (append (m-binary-*-row M1 M2 i j k) + lst1) + lst2 + i1 + k) + (m-binary-+-row lst1 + lst2 + i1 + k)))) + +(defthm + m-binary-+-row-remove-append-2a + (implies (< i1 i) + (equal (m-binary-+-row lst1 + (append (m-binary-*-row M1 M2 i j k) + lst2) + i1 + k) + (m-binary-+-row lst1 + lst2 + i1 + k)))) + +(defthm + m-binary-+-row-1-remove-append-1a + (implies (and (> i 0) + (< i1 i)) + (equal (m-binary-+-row-1 (append (m-binary-*-row M1 M2 i j k) + lst1) + lst2 + i1 + k) + (m-binary-+-row-1 lst1 + lst2 + i1 + k)))) + +(defthm + m-binary-+-row-1-remove-append-1b + (implies (and (> i 0) + (< i1 i)) + (equal (m-binary-+-row-1 lst1 + (append (m-binary-*-row M1 M2 i j k) + lst2) + i1 + k) + (m-binary-+-row-1 lst1 + lst2 + i1 + k)))) + +(defthm + left-distributivity-m-binary-*-row-1-m-binary-+-row-1 + (equal (m-binary-*-row-1 M1 + (m-binary-+-row-1 M2 + M3 + j + k) + i + j + k) + (m-binary-+-row-1 (m-binary-*-row-1 M1 + M2 + i + j + k) + (m-binary-*-row-1 M1 + M3 + i + j + k) + i + k))) + +(defthm + alist2p-header-m-binary-*-row-1-crock + (IMPLIES (AND (ALIST2P name1 M1) + (ALIST2P name2 M2)) + (ALIST2P name + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-*-ROW-1 M1 + M2 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M2))) + (+ -1 (CADR (DIMENSIONS '$ARG M2))))))) + :HINTS (("Goal" + :IN-THEORY (ENABLE Alist2P HEADER DIMENSIONS MAXIMUM-LENGTH)))) + +(defthm + alist2p-header-m-binary-*-row-1-crock-1 + (IMPLIES (AND (ALIST2P name1 M1) + (ALIST2P name2 M2)) + (ALIST2P name + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-+-ROW-1 + (M-BINARY-*-ROW-1 M1 + M2 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M2))) + (+ -1 (CADR (DIMENSIONS '$ARG M2)))) + (M-BINARY-*-ROW-1 M1 + M3 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M2))) + (+ -1 (CADR (DIMENSIONS '$ARG M2)))) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M2))))))) + :HINTS (("Goal" + :IN-THEORY (ENABLE Alist2P HEADER DIMENSIONS MAXIMUM-LENGTH)))) + +(defthm + alist2p-header-m-binary-*-row-1-crock-2 + (IMPLIES (AND (ALIST2P name1 M1) + (ALIST2P name2 M2)) + (ALIST2P name + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2)))) + '(:DEFAULT 0 :NAME MATRIX-SUM)) + (M-BINARY-+-ROW-1 + (M-BINARY-*-ROW-1 M1 + M2 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M2))) + (+ -1 (CADR (DIMENSIONS '$ARG M2)))) + (M-BINARY-*-ROW-1 M1 + M3 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M2))) + (+ -1 (CADR (DIMENSIONS '$ARG M2)))) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M2))))))) + :HINTS (("Goal" + :IN-THEORY (ENABLE Alist2P HEADER DIMENSIONS MAXIMUM-LENGTH)))) + +(defthm + alist2p-header-m-binary-*-row-1-crock-3 + (IMPLIES (AND (ALIST2P name1 M1) + (ALIST2P name2 M2)) + (ALIST2P name + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M2)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-*-ROW-1 M1 + M3 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M2))) + (+ -1 (CADR (DIMENSIONS '$ARG M2))))))) + :HINTS (("Goal" + :IN-THEORY (ENABLE Alist2P HEADER DIMENSIONS MAXIMUM-LENGTH)))) + +(defthm + left-distributivity-of-m-*-over-m-+ + (m-= (m-* M1 (m-+ M2 M3)) + (m-+ (m-* M1 M2) + (m-* M1 M3)))) + +(defthm + right-dot-m-binary-+-row + (equal (dot (m-binary-+-row M1 + M2 + i + j) + M3 + i + j + k) + (+ (dot M1 M3 i j k) + (dot M2 M3 i j k)))) + +(defthm + right-distributivity-m-binary-*-row-m-binary-+-row + (equal (m-binary-*-row (m-binary-+-row M1 + M2 + i + j) + M3 + i + j + k) + (m-binary-+-row (m-binary-*-row M1 + M3 + i + j + k) + (m-binary-*-row M2 + M3 + i + j + k) + i + k))) + +(defthm + dot-m-binary-+-row-remove-append + (equal (dot (append (m-binary-+-row M1 + M2 + i + j) + lst) + M3 + i + j + k) + (dot (m-binary-+-row M1 + M2 + i + j) + M3 + i + j + k))) + +(defthm + dot-m-binary-+-row-remove-append-a + (implies (> i i1) + (equal (dot (append (m-binary-+-row M1 + M2 + i + j) + lst) + M3 + i1 + j + k) + (dot lst + M3 + i1 + j + k)))) + +(defthm + m-binary-*-row-m-binary-+-row-remove-append + (equal (m-binary-*-row (append (m-binary-+-row M1 + M2 + i + j) + lst) + M3 + i + j + k) + (m-binary-+-row (m-binary-*-row M1 + M3 + i + j + k) + (m-binary-*-row M2 + M3 + i + j + k) + i + k))) + +(defthm + m-binary-*-row-m-binary-+-row-remove-append-a + (implies (> i i1) + (equal (m-binary-*-row (append (m-binary-+-row M1 + M2 + i + j) + lst) + M3 + i1 + j + k) + (m-binary-*-row lst + M3 + i1 + j + k)))) + +(defthm + m-binary-*-row-1-m-binary-+-row-remove-append-a + (implies (and (>= i1 0) + (> i i1)) + (equal (m-binary-*-row-1 (append (m-binary-+-row M1 + M2 + i + j) + lst) + M3 + i1 + j + k) + (m-binary-*-row-1 lst + M3 + i1 + j + k)))) + +(defthm + right-distributivity-m-binary-*-row-1-m-binary-+-row-1 + (equal (m-binary-*-row-1 (m-binary-+-row-1 M1 + M2 + i + j) + M3 + i + j + k) + (m-binary-+-row-1 (m-binary-*-row-1 M1 + M3 + i + j + k) + (m-binary-*-row-1 M2 + M3 + i + j + k) + i + k))) + +(defthm + alist2p-header-m-binary-*-row-1-crock-4 + (IMPLIES (AND (ALIST2P name1 M1) + (ALIST2P name2 M3)) + (ALIST2P name + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M3))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M3)))) + '(:DEFAULT 0 :NAME MATRIX-PRODUCT)) + (M-BINARY-+-ROW-1 + (M-BINARY-*-ROW-1 M1 + M3 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M3))) + (+ -1 (CADR (DIMENSIONS '$ARG M3)))) + (M-BINARY-*-ROW-1 M2 + M3 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M3))) + (+ -1 (CADR (DIMENSIONS '$ARG M3)))) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M3))))))) + :HINTS (("Goal" + :IN-THEORY (ENABLE Alist2P HEADER DIMENSIONS MAXIMUM-LENGTH)))) + +(defthm + alist2p-header-m-binary-*-row-1-crock-5 + (IMPLIES (AND (ALIST2P name1 M1) + (ALIST2P name2 M3)) + (ALIST2p name + (CONS (LIST* :HEADER :DIMENSIONS + (LIST (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M3))) + :MAXIMUM-LENGTH + (+ 1 + (* (CAR (DIMENSIONS '$ARG M1)) + (CADR (DIMENSIONS '$ARG M3)))) + '(:DEFAULT 0 :NAME MATRIX-SUM)) + (M-BINARY-+-ROW-1 + (M-BINARY-*-ROW-1 M1 + M3 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M3))) + (+ -1 (CADR (DIMENSIONS '$ARG M3)))) + (M-BINARY-*-ROW-1 M2 + M3 + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CAR (DIMENSIONS '$ARG M3))) + (+ -1 (CADR (DIMENSIONS '$ARG M3)))) + (+ -1 (CAR (DIMENSIONS '$ARG M1))) + (+ -1 (CADR (DIMENSIONS '$ARG M3))))))) + :HINTS (("Goal" + :IN-THEORY (ENABLE Alist2P HEADER DIMENSIONS MAXIMUM-LENGTH)))) + +(defthm + right-distributivity-of-m-*-over-m-+ + (m-= (m-* (m-+ M1 M2) M3) + (m-+ (m-* M1 M3) + (m-* M2 M3)))) + +(defthm + m-=-row-1-m-trans-m-1 + (implies (and (integerp n) + (< i n)) + (m-=-row-1 (m-trans (m-1 n)) + (m-1 n) + i + j))) + +(defthm + m-=-m-trans-m-1 + (implies (and (integerp n) + (> n 0)) + (m-= (m-trans (m-1 n)) + (m-1 n)))) + +(defthm + dot-s-*-left=*-dot + (equal (dot (s-* a M1) + M2 + i + k + j) + (* a (dot M1 + M2 + i + k + j)))) + +(defthm + dot-s-*-right=*-dot + (equal (dot M1 + (s-* a M2) + i + k + j) + (* a (dot M1 + M2 + i + k + j)))) + +(defthm + m-=-row-m-*-s-*-left + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2)) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M1)) + (< j (c M2))) + (m-=-row (m-* (s-* a M1) M2) + (s-* a (m-* M1 M2)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-*)))) + +(defthm + m-=-row-m-*-s-*-right + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2)) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M1)) + (< j (c M2))) + (m-=-row (m-* M1 (s-* a M2)) + (s-* a (m-* M1 M2)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-*)))) + +(defthm + m-=-row-1-m-*-s-*-left + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2)) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M1)) + (< j (c M2))) + (m-=-row-1 (m-* (s-* a M1) M2) + (s-* a (m-* M1 M2)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-*)))) + +(defthm + m-=-row-1-m-*-s-*-right + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2)) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M1)) + (< j (c M2))) + (m-=-row-1 (m-* M1 (s-* a M2)) + (s-* a (m-* M1 M2)) + i + j)) + :hints (("Goal" + :in-theory (disable m-binary-*)))) + +(defthm + m-*-s-*-left + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2))) + (m-= (m-* (s-* a M1) M2) + (s-* a (m-* M1 M2)))) + :hints (("Goal" + :in-theory (disable m-binary-*)) + ("Subgoal 2" + :in-theory (disable m-binary-* + alist2p-m-*) + :use (:instance + alist2p-m-* + (name '$arg) + (M1 (s-* a M1)))) + ("Subgoal 1" + :in-theory (disable m-binary-* + alist2p-s-*) + :use (:instance + alist2p-s-* + (name '$arg) + (M (m-* M1 M2)))))) + +(defthm + m-*-s-*-right + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2))) + (m-= (m-* M1 (s-* a M2)) + (s-* a (m-* M1 M2)))) + :hints (("Goal" + :in-theory (disable m-binary-*)) + ("Subgoal 2" + :in-theory (disable m-binary-* + alist2p-m-*) + :use (:instance + alist2p-m-* + (name '$arg) + (M2 (s-* a M2)))) + ("Subgoal 1" + :in-theory (disable m-binary-* + alist2p-s-*) + :use (:instance + alist2p-s-* + (name '$arg) + (M (m-* M1 M2)))))) + +(defthm + dot-m-trans-m-trans + (equal (dot (m-trans M2) + (m-trans M1) + j + k + i) + (dot M1 + M2 + i + k + j))) + +(defthm + m-=-row-m-trans-m-*=m-*-m-trans + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2)) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M1)) + (< j (c M2))) + (m-=-row (m-trans (m-* M1 M2)) + (m-* (m-trans M2)(m-trans M1)) + j + i)) + :hints (("Goal" + :in-theory (disable m-binary-*)))) + +(defthm + m-=-row-1-m-trans-m-*=m-*-m-trans + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2)) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (r M1)) + (< j (c M2))) + (m-=-row-1 (m-trans (m-* M1 M2)) + (m-* (m-trans M2)(m-trans M1)) + j + i)) + :hints (("Goal" + :in-theory (disable m-binary-*)))) + +(defthm + m-trans-m-*=m-*-m-trans + (implies (and (alist2p name M1) + (alist2p name M2) + (equal (c M1)(r M2))) + (m-= (m-trans (m-* M1 M2)) + (m-* (m-trans M2)(m-trans M1)))) + :hints (("Goal" + :in-theory (disable m-binary-*)) + ("Subgoal 2" + :in-theory (disable m-binary-* + alist2p-m-trans) + :use (:instance + alist2p-m-trans + (name '$arg) + (M (m-* M1 M2)))) + ("Subgoal 1" + :in-theory (disable m-binary-* + alist2p-m-*) + :use (:instance + alist2p-m-* + (name '$arg) + (M1 (m-trans M2)) + (M2 (m-trans M1)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Row and column operations on ACL2 arrays: + +(defthm + Ri<->Rj-loop-guard-hack + (IMPLIES (AND (< K (CADR (DIMENSIONS '$ARG M))) + (< I (CAR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 I) + (INTEGERP I) + (integerp k) + (ARRAY2P '$ARG M) + (SYMBOLP NAME)) + (ARRAY2P NAME + (ASET2 '$ARG + M + I + K + (AREF2 '$ARG M J K)))) + :hints (("Goal" + :in-theory (disable ARRAY2P-ASET2) + :use (:instance + ARRAY2P-ASET2 + (L M) + (j k) + (val (AREF2 '$ARG M J K)))))) + +(defthm + Ri<->Rj-loop-guard-hack-1 + (IMPLIES (AND (< K (CADR (DIMENSIONS '$ARG M))) + (< J (CAR (DIMENSIONS '$ARG M))) + (< I (CAR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 J) + (<= 0 I) + (INTEGERP J) + (INTEGERP I) + (integerp k) + (ARRAY2P NAME M)) + (ARRAY2P NAME + (ASET2 '$ARG + (ASET2 '$ARG + M + I + K + (AREF2 '$ARG M J K)) + J + K + (AREF2 '$ARG M I K)))) + :hints (("Goal" + :in-theory (disable ARRAY2P-ASET2) + :use (:instance + ARRAY2P-ASET2 + (L (ASET2 '$ARG + M + I + K + (AREF2 '$ARG M J K))) + (i j) + (j k) + (val (AREF2 '$ARG M I K)))))) + +(defun + Ri<->Rj-loop (name M i j k) + (declare (xargs :guard (and (array2p name M) + (integerp i) + (integerp j) + (integerp k) + (>= i 0) + (>= j 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims)) + (dims2 (second dims))) + (and (< i dims1) + (< j dims1) + (< k dims2)))))) + (if (zp k) + (let ((temp (aref2 name M i 0))) + (aset2 name + (aset2 name + M + i + 0 + (aref2 name + M + j + 0)) + j + 0 + temp)) + (Ri<->Rj-loop name + (let ((temp (aref2 name M i k))) + (aset2 name + (aset2 name + M + i + k + (aref2 name + M + j + k)) + j + k + temp)) + i + j + (- k 1)))) + +(defun + Ri<->Rj (name M i j) + "Return the result of interchanging + row i and row j in array M." + (declare (xargs :guard (and (array2p name M) + (integerp i) + (integerp j) + (/= i j) + (>= i 0) + (>= j 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims))) + (and (< i dims1) + (< j dims1)))))) + (Ri<->Rj-loop name + M + i + j + (- (second (dimensions name M)) 1))) + +(defthm + Ci<->Cj-loop-guard-hack + (IMPLIES (AND (< K (CAR (DIMENSIONS '$ARG M))) + (< I (CADR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 I) + (INTEGERP I) + (integerp k) + (ARRAY2P '$ARG M) + (SYMBOLP NAME)) + (ARRAY2P NAME + (ASET2 '$ARG + M + K + I + (AREF2 '$ARG M K J)))) + :hints (("Goal" + :in-theory (disable ARRAY2P-ASET2) + :use (:instance + ARRAY2P-ASET2 + (L M) + (i k) + (j i) + (val (AREF2 '$ARG M K j)))))) + +(defthm + Ci<->Cj-loop-guard-hack-1 + (IMPLIES (AND (< K (CAR (DIMENSIONS '$ARG M))) + (< J (CADR (DIMENSIONS '$ARG M))) + (< I (CADR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 J) + (<= 0 I) + (INTEGERP J) + (INTEGERP I) + (integerp k) + (ARRAY2P NAME M)) + (ARRAY2P NAME + (ASET2 '$ARG + (ASET2 '$ARG + M + K + I + (AREF2 '$ARG M K J)) + K + J + (AREF2 '$ARG M K I)))) + :hints (("Goal" + :in-theory (disable ARRAY2P-ASET2) + :use (:instance + ARRAY2P-ASET2 + (L (ASET2 '$ARG + M + K + I + (AREF2 '$ARG M K J))) + (i k) + (val (AREF2 '$ARG M K i)))))) + +(defun + Ci<->Cj-loop (name M i j k) + (declare (xargs :guard (and (array2p name M) + (integerp i) + (integerp j) + (integerp k) + (>= i 0) + (>= j 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims)) + (dims2 (second dims))) + (and (< i dims2) + (< j dims2) + (< k dims1)))))) + (if (zp k) + (let ((temp (aref2 name M 0 i))) + (aset2 name + (aset2 name + M + 0 + i + (aref2 name + M + 0 + j)) + 0 + j + temp)) + (Ci<->Cj-loop name + (let ((temp (aref2 name M k i))) + (aset2 name + (aset2 name + M + k + i + (aref2 name + M + k + j)) + k + j + temp)) + i + j + (- k 1)))) + +(defun + Ci<->Cj (name M i j) + "Return the result of interchanging + column i and column j in array M." + (declare (xargs :guard (and (array2p name M) + (integerp i) + (integerp j) + (/= i j) + (>= i 0) + (>= j 0) + (let* ((dims (dimensions name M)) + (dims2 (second dims))) + (and (< i dims2) + (< j dims2)))))) + (Ci<->Cj-loop name + M + i + j + (- (first (dimensions name M)) 1))) + +(defthm + Ri<-aRi-loop-guard-hack + (IMPLIES (AND (< K (CADR (DIMENSIONS '$ARG M))) + (< I (CAR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 I) + (INTEGERP I) + (integerp k) + (ARRAY2P NAME M)) + (ARRAY2P NAME (ASET2 '$ARG M I K 0))) + :hints (("Goal" + :in-theory (disable array2p-aset2) + :use (:instance + array2p-aset2 + (L M) + (j k) + (val 0))))) + +(defthm + Ri<-aRi-loop-guard-hack-1 + (IMPLIES (AND (< K (CADR (DIMENSIONS '$ARG M))) + (< I (CAR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 I) + (integerp k) + (INTEGERP I) + (ARRAY2P NAME M)) + (ARRAY2P NAME + (ASET2 '$ARG + M + I + K + (* A (AREF2 '$ARG M I K))))) + :hints (("Goal" + :in-theory (disable array2p-aset2) + :use (:instance + array2p-aset2 + (L M) + (j k) + (val (* A (AREF2 '$ARG M I K))))))) + +(defun + Ri<-aRi-loop (name M a i k) + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp k) + (>= i 0) + (>= k 0) + (let ((dims (dimensions name M))) + (and (< i (first dims)) + (< k (second dims))))))) + (if (zp k) + (aset2 name + M + i + 0 + (* a (fix (aref2 name + M + i + 0)))) + (Ri<-aRi-loop name + (aset2 name + M + i + k + (* a (fix (aref2 name + M + i + k)))) + a + i + (- k 1)))) + +(defun + Ri<-aRi (name M a i) + "Return the result of replacing each element, + Mij, in row i of array M, with (* a Mij)." + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (>= i 0) + (< i (first (dimensions name M)))))) + (Ri<-aRi-loop name + M + a + i + (- (second (dimensions name M)) 1))) + +(defun + Ci<-aCi-loop (name M a i k) + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp k) + (>= i 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims)) + (dims2 (second dims))) + (and (< i dims2) + (< k dims1)))))) + + (if (zp k) + (aset2 name + M + 0 + i + (* a (fix (aref2 name + M + 0 + i)))) + (Ci<-aCi-loop name + (aset2 name + M + k + i + (* a (fix (aref2 name + M + k + i)))) + a + i + (- k 1)))) + +(defun + Ci<-aCi (name M a i) + "Return the result of replacing each element, + Mji, in column i of array M, with (* a Mji)." + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (>= i 0) + (< i (second (dimensions name M)))))) + (Ci<-aCi-loop name + M + a + i + (- (first (dimensions name M)) 1))) + +(defthm + Rj<-aRi+Rj-loop-guard-hack + (IMPLIES (AND (< K (CADR (DIMENSIONS '$ARG M))) + (< J (CAR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 J) + (INTEGERP J) + (integerp k) + (ARRAY2P NAME M)) + (ARRAY2P NAME + (ASET2 '$ARG + M + J + K + (* A (AREF2 '$ARG M I K))))) + :hints (("Goal" + :in-theory (disable array2p-aset2) + :use (:instance + array2p-aset2 + (L M) + (i j) + (j k) + (val (* A (AREF2 '$ARG M I K))))))) + +(defthm + Rj<-aRi+Rj-loop-guard-hack-1 + (IMPLIES (AND (< K (CADR (DIMENSIONS '$ARG M))) + (< J (CAR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 J) + (INTEGERP J) + (integerp k) + (ARRAY2P NAME M)) + (ARRAY2P NAME + (ASET2 '$ARG + M + J + K + (+ (AREF2 '$ARG M J K) + (* A (AREF2 '$ARG M I K)))))) + :hints (("Goal" + :in-theory (disable array2p-aset2) + :use (:instance + array2p-aset2 + (L M) + (i j) + (j k) + (val (+ (AREF2 '$ARG M J K) + (* A (AREF2 '$ARG M I K)))))))) + +(defun + Rj<-aRi+Rj-loop (name M a i j k) + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp j) + (integerp k) + (>= i 0) + (>= j 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims))) + (and (< i dims1) + (< j dims1) + (< k (second dims))))))) + (if (zp k) + (aset2 name + M + j + 0 + (+ (* a (fix (aref2 name + M + i + 0))) + (fix (aref2 name + M + j + 0)))) + (Rj<-aRi+Rj-loop name + (aset2 name + M + j + k + (+ (* a (fix (aref2 name + M + i + k))) + (fix (aref2 name + M + j + k)))) + a + i + j + (- k 1)))) + +(defun + Rj<-aRi+Rj (name M a i j) + "Return the result of replacing each element, + Mjk, in row j of matrix M, with (+ (* a Mik) Mjk)." + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp j) + (/= i j) + (>= i 0) + (>= j 0) + (let* ((dims (dimensions name M)) + (dims1 (first dims))) + (and (< i dims1) + (< j dims1)))))) + (Rj<-aRi+Rj-loop name + M + a + i + j + (- (second (dimensions name M)) 1))) + +(defthm + Cj<-aCi+Cj-loop-guard-hack + (IMPLIES (AND (< K (CAR (DIMENSIONS '$ARG M))) + (< J (CADR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 J) + (INTEGERP J) + (integerp k) + (ARRAY2P NAME M)) + (ARRAY2P NAME + (ASET2 '$ARG + M + K + J + (* A (AREF2 '$ARG M K I))))) + :hints (("Goal" + :in-theory (disable array2p-aset2) + :use (:instance + array2p-aset2 + (L M) + (i k) + (val (* A (AREF2 '$ARG M K i))))))) + +(defthm + Cj<-aCi+Cj-loop-guard-hack-1 + (IMPLIES (AND (< K (CAR (DIMENSIONS '$ARG M))) + (< J (CADR (DIMENSIONS '$ARG M))) + (< I (CADR (DIMENSIONS '$ARG M))) + (<= 0 K) + (<= 0 J) + (<= 0 I) + (INTEGERP J) + (INTEGERP I) + (integerp k) + (ARRAY2P NAME M)) + (ARRAY2P NAME + (ASET2 '$ARG + M + K + J + (+ (AREF2 '$ARG M K J) + (* A (AREF2 '$ARG M K I)))))) + :hints (("Goal" + :in-theory (disable array2p-aset2) + :use (:instance + array2p-aset2 + (L M) + (i k) + (val (+ (AREF2 '$ARG M K j) + (* A (AREF2 '$ARG M K i)))))))) + +(defun + Cj<-aCi+Cj-loop (name M a i j k) + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp j) + (integerp k) + (>= i 0) + (>= j 0) + (>= k 0) + (let* ((dims (dimensions name M)) + (dims2 (second dims))) + (and (< i dims2) + (< j dims2) + (< k (first dims))))))) + (if (zp k) + (aset2 name + M + 0 + j + (+ (* a (fix (aref2 name + M + 0 + i))) + (fix (aref2 name + M + 0 + j)))) + (Cj<-aCi+Cj-loop name + (aset2 name + M + k + j + (+ (* a (fix (aref2 name + M + k + i))) + (fix (aref2 name + M + k + j)))) + a + i + j + (- k 1)))) + +(defun + Cj<-aCi+Cj (name M a i j) + "Return the result of replacing each element, + Mkj, in column j of matrix M, with (+ (* a Mki) + Mkj)." + (declare (xargs :guard (and (acl2-numberp a) + (array2p name M) + (integerp i) + (integerp j) + (/= i j) + (>= i 0) + (>= j 0) + (let* ((dims (dimensions name M)) + (dims2 (second dims))) + (and (< i dims2) + (< j dims2)))))) + + (Cj<-aCi+Cj-loop name + M + a + i + j + (- (first (dimensions name M)) 1))) + +(local (in-theory (disable ARRAY2P-$ARG-EQUAL-PARTS))) + +(defthm + Ri<->Rj-loop-equal-parts + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (first (dimensions name M))) + (< j (first (dimensions name M))) + (< k (second (dimensions name M)))) + (and (equal (header name (Ri<->Rj-loop name M i j k)) + (header name M)) + (equal (dimensions name (Ri<->Rj-loop name M i j k)) + (dimensions name M)) + (equal (maximum-length name + (Ri<->Rj-loop name M i j k)) + (maximum-length name M)) + (equal (default name (Ri<->Rj-loop name M i j k)) + (default name M))))) + +(defthm + Ci<->Cj-loop-equal-parts + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (second (dimensions name M))) + (< j (second (dimensions name M))) + (< k (first (dimensions name M)))) + (and (equal (header name (Ci<->Cj-loop name M i j k)) + (header name M)) + (equal (dimensions name (Ci<->Cj-loop name M i j k)) + (dimensions name M)) + (equal (maximum-length name + (Ci<->Cj-loop name M i j k)) + (maximum-length name M)) + (equal (default name (Ci<->Cj-loop name M i j k)) + (default name M))))) + +(defthm + Ri<-aRi-loop-equal-parts + (implies (and (alist2p name M) + (integerp i) + (>= i 0) + (< i (first (dimensions name M))) + (< k (second (dimensions name M)))) + (and (equal (header name (Ri<-aRi-loop name M a i k)) + (header name M)) + (equal (dimensions name (Ri<-aRi-loop name M a i k)) + (dimensions name M)) + (equal (maximum-length name + (Ri<-aRi-loop name M a i k)) + (maximum-length name M)) + (equal (default name (Ri<-aRi-loop name M a i k)) + (default name M))))) + +(defthm + Ci<-aCi-loop-equal-parts + (implies (and (alist2p name M) + (integerp i) + (>= i 0) + (< i (second (dimensions name M))) + (< k (first (dimensions name M)))) + (and (equal (header name (Ci<-aCi-loop name M a i k)) + (header name M)) + (equal (dimensions name (Ci<-aCi-loop name M a i k)) + (dimensions name M)) + (equal (maximum-length name + (Ci<-aCi-loop name M a i k)) + (maximum-length name M)) + (equal (default name (Ci<-aCi-loop name M a i k)) + (default name M))))) + +(defthm + Rj<-aRi+Rj-loop-equal-parts + (implies (and (alist2p name M) + (integerp j) + (>= j 0) + (< j (first (dimensions name M))) + (< k (second (dimensions name M)))) + (and (equal (header name + (Rj<-aRi+Rj-loop name M a i j k)) + (header name M)) + (equal (dimensions name + (Rj<-aRi+Rj-loop name M a i j k)) + (dimensions name M)) + (equal (maximum-length name + (Rj<-aRi+Rj-loop name M a i j k)) + (maximum-length name M)) + (equal (default name (Rj<-aRi+Rj-loop name M a i j k)) + (default name M))))) + +(defthm + Cj<-aCi+Cj-loop-equal-parts + (implies (and (alist2p name M) + (integerp j) + (>= j 0) + (< j (second (dimensions name M))) + (< k (first (dimensions name M)))) + (and (equal (header name + (Cj<-aCi+Cj-loop name M a i j k)) + (header name M)) + (equal (dimensions name + (Cj<-aCi+Cj-loop name M a i j k)) + (dimensions name M)) + (equal (maximum-length name + (Cj<-aCi+Cj-loop name M a i j k)) + (maximum-length name M)) + (equal (default name (Cj<-aCi+Cj-loop name M a i j k)) + (default name M))))) + +(defthm + alist2p-Ri<->Rj-loop + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (first (dimensions name M))) + (< j (first (dimensions name M))) + (< k (second (dimensions name M)))) + (alist2p name (Ri<->Rj-loop name M i j k)))) + +(defthm + array2p-Ri<->Rj-loop + (implies (and (array2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (first (dimensions name M))) + (< j (first (dimensions name M))) + (< k (second (dimensions name M)))) + (array2p name (Ri<->Rj-loop name M i j k)))) + +(defthm + alist2p-Ci<->Cj-loop + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (second (dimensions name M))) + (< j (second (dimensions name M))) + (< k (first (dimensions name M)))) + (alist2p name (Ci<->Cj-loop name M i j k)))) + +(defthm + array2p-Ci<->Cj-loop + (implies (and (array2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (second (dimensions name M))) + (< j (second (dimensions name M))) + (< k (first (dimensions name M)))) + (array2p name (Ci<->Cj-loop name M i j k)))) + +(defthm + alist2p-Ri<-aRi-loop + (implies (and (alist2p name M) + (integerp i) + (>= i 0) + (< i (first (dimensions name M))) + (< k (second (dimensions name M)))) + (alist2p name (Ri<-aRi-loop name M a i k)))) + +(defthm + array2p-Ri<-aRi-loop + (implies (and (array2p name M) + (integerp i) + (>= i 0) + (< i (first (dimensions name M))) + (< k (second (dimensions name M)))) + (array2p name (Ri<-aRi-loop name M a i k)))) + +(defthm + alist2p-Ci<-aCi-loop + (implies (and (alist2p name M) + (integerp i) + (>= i 0) + (< i (second (dimensions name M))) + (< k (first (dimensions name M)))) + (alist2p name (Ci<-aCi-loop name M a i k)))) + +(defthm + array2p-Ci<-aCi-loop + (implies (and (array2p name M) + (integerp i) + (>= i 0) + (< i (second (dimensions name M))) + (< k (first (dimensions name M)))) + (array2p name (Ci<-aCi-loop name M a i k)))) + +(defthm + alist2p-Rj<-aRi+Rj-loop + (implies (and (alist2p name M) + (integerp j) + (>= j 0) + (< j (first (dimensions name M))) + (< k (second (dimensions name M)))) + (alist2p name (Rj<-aRi+Rj-loop name M a i j k)))) + +(defthm + array2p-Rj<-aRi+Rj-loop + (implies (and (array2p name M) + (integerp j) + (>= j 0) + (< j (first (dimensions name M))) + (< k (second (dimensions name M)))) + (array2p name (Rj<-aRi+Rj-loop name M a i j k)))) + +(defthm + alist2p-Cj<-aCi+Cj-loop + (implies (and (alist2p name M) + (integerp j) + (>= j 0) + (< j (second (dimensions name M))) + (< k (first (dimensions name M)))) + (alist2p name (Cj<-aCi+Cj-loop name M a i j k)))) + +(defthm + array2p-Cj<-aCi+Cj-loop + (implies (and (array2p name M) + (integerp j) + (>= j 0) + (< j (second (dimensions name M))) + (< k (first (dimensions name M)))) + (array2p name (Cj<-aCi+Cj-loop name M a i j k)))) + +(local (in-theory (enable ARRAY2P-$ARG-EQUAL-PARTS))) + +(defthm + dimensions-Ri<->Rj + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (first (dimensions name M))) + (< j (first (dimensions name M)))) + (equal (dimensions name (Ri<->Rj name M i j)) + (dimensions name M)))) + +(defthm + dimensions-Ci<->Cj + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (second (dimensions name M))) + (< j (second (dimensions name M)))) + (equal (dimensions name (Ci<->Cj name M i j)) + (dimensions name M)))) + +(defthm + dimensions-Ri<-aRi + (implies (and (alist2p name M) + (integerp i) + (>= i 0) + (< i (first (dimensions name M)))) + (equal (dimensions name (Ri<-aRi name M a i)) + (dimensions name M)))) + +(defthm + dimensions-Ci<-aCi + (implies (and (alist2p name M) + (integerp i) + (>= i 0) + (< i (second (dimensions name M)))) + (equal (dimensions name (Ci<-aCi name M a i)) + (dimensions name M)))) + +(defthm + dimensions-Rj<-aRi+Rj + (implies (and (alist2p name M) + (integerp j) + (>= j 0) + (< j (first (dimensions name M)))) + (equal (dimensions name (Rj<-aRi+Rj name M a i j)) + (dimensions name M)))) + +(defthm + dimensions-Cj<-aCi+Cj + (implies (and (alist2p name M) + (integerp j) + (>= j 0) + (< j (second (dimensions name M)))) + (equal (dimensions name (Cj<-aCi+Cj name M a i j)) + (dimensions name M)))) + +(defthm + alist2p-Ri<->Rj + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (first (dimensions name M))) + (< j (first (dimensions name M)))) + (alist2p name (Ri<->Rj name M i j)))) + +(defthm + array2p-Ri<->Rj + (implies (and (array2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (first (dimensions name M))) + (< j (first (dimensions name M)))) + (array2p name (Ri<->Rj name M i j)))) + +(defthm + alist2p-Ci<->Cj + (implies (and (alist2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (second (dimensions name M))) + (< j (second (dimensions name M)))) + (alist2p name (Ci<->Cj name M i j)))) + +(defthm + array2p-Ci<->Cj + (implies (and (array2p name M) + (integerp i) + (integerp j) + (>= i 0) + (>= j 0) + (< i (second (dimensions name M))) + (< j (second (dimensions name M)))) + (array2p name (Ci<->Cj name M i j)))) + +(defthm + alist2p-Ri<-aRi + (implies (and (alist2p name M) + (integerp i) + (>= i 0) + (< i (first (dimensions name M)))) + (alist2p name (Ri<-aRi name M a i)))) + +(defthm + array2p-Ri<-aRi + (implies (and (array2p name M) + (integerp i) + (>= i 0) + (< i (first (dimensions name M)))) + (array2p name (Ri<-aRi name M a i)))) + +(defthm + alist2p-Ci<-aCi + (implies (and (alist2p name M) + (integerp i) + (>= i 0) + (< i (second (dimensions name M)))) + (alist2p name (Ci<-aCi name M a i)))) + +(defthm + array2p-Ci<-aCi + (implies (and (array2p name M) + (integerp i) + (>= i 0) + (< i (second (dimensions name M)))) + (array2p name (Ci<-aCi name M a i)))) + +(defthm + alist2p-Rj<-aRi+Rj + (implies (and (alist2p name M) + (integerp j) + (>= j 0) + (< j (first (dimensions name M)))) + (alist2p name (Rj<-aRi+Rj name M a i j)))) + +(defthm + array2p-Rj<-aRi+Rj + (implies (and (array2p name M) + (integerp j) + (>= j 0) + (< j (first (dimensions name M)))) + (array2p name (Rj<-aRi+Rj name M a i j)))) + +(defthm + alist2p-Cj<-aCi+Cj + (implies (and (alist2p name M) + (integerp j) + (>= j 0) + (< j (second (dimensions name M)))) + (alist2p name (Cj<-aCi+Cj name M a i j)))) + +(defthm + array2p-Cj<-aCi+Cj + (implies (and (array2p name M) + (integerp j) + (>= j 0) + (< j (second (dimensions name M)))) + (array2p name (Cj<-aCi+Cj name M a i j)))) + +(in-theory (disable Ri<->Rj + Ci<->Cj + Ri<-aRi + Ci<-aCi + Rj<-aRi+Rj + Cj<-aCi+Cj)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Matrix inverse and determinant: + +;; Description of algorithm for computing the +;; inverse and determinant. + +;; Input a square matrix M. + +;; let A <- I +;; B <- I +;; C <- M +;; D <- 1 + +;; Row reduce C to I. +;; Apply same row operations to B. +;; Multiply A successively on right by +;; inverse of same row operations. +;; (Done with equivalent column operations.) +;; Modify D according to column operations on A. +;; Ci<->Cj: D <- -1 * D +;; Ci<-aCi: D <- a * D +;; Cj<-aCi+Cj: D <- D + +;; Invariants +;; A * B = I +;; B * M = C +;; D = determinant of A + +;; After termination +;; A = left inverse of B +;; B = left inverse of M (because C contains I +;; after termination) + +;; Prove that after termination A = M: +;; A = A * I = A * (B * M) +;; = (A * B) * M = I * M = M + +;; Thus B is both left and right inverse of M +;; and D is the determinant of M. + +;; Inverse row operations: +;; (Ri<->Rj)^(-1) = Ri<->Rj +;; (Ri<-aRi)^(-1) = Ri<-(/a)Ri +;; (Rj<-aRi+Rj)^(-1) = Rj<-(-a)Ri+Rj + +;; Equivalent row and column operations as +;; applied to identity matrix: I +;; Ri<->Rj(I) = Ci<->Cj(I) +;; Ri<-aRi(I) = Ci<-aCi(I) +;; Rj<-aRi+Rj(I) = Ci<-aCj+Ci(I) + +;; Row operation applied to M is the same as +;; multiplying M on the LEFT by the result +;; of applying the same operation to I. + +;; Column operation applied to M is the same as +;; multiplying M on the RIGHT by the result +;; of applying the same operation to I. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun + zero-column (A B C i1 j i) + "For k = i downto 0, + when k differs from i1 and (aref2 '$C C k j) is a nonzero number then + replace column i1 in A with (aref2 '$C C k j) * column k + column i1, + replace row k in B with (- (aref2 '$C C k j)) * row i1 + row k, + replace row k in C with (- (aref2 '$C C k j)) * row i1 + row k. + When (aref2 '$C C i1 j) = 1, then all other entries in the jth + column of C are modified to 0." + (declare (xargs :guard (and (array2p '$a A) + (array2p '$b B) + (array2p '$c C) + (integerp i) + (>= i 0) + (integerp i1) + (>= i1 0) + (integerp j) + (>= j 0) + (< i (second + (dimensions '$a + A))) + (< i (first + (dimensions '$b + B))) + (< i (first + (dimensions '$c + C))) + (< i1 (second + (dimensions '$a + A))) + (< i1 (first + (dimensions '$b + B))) + (< i1 (first + (dimensions '$c + C))) + (< j (second + (dimensions '$c + C)))))) + (if (zp i) + (if (not (zp i1)) + (let ((val (fix (aref2 '$C C 0 j)))) + (if (= val 0) + (mv A B C) + (mv (Cj<-aCi+Cj '$A A val 0 i1) + (Rj<-aRi+Rj '$B B (- val) i1 0) + (Rj<-aRi+Rj '$C C (- val) i1 0)))) + (mv A B C)) + (if (not (equal i i1)) + (let ((val (fix (aref2 '$C C i j)))) + (if (= val 0) + (zero-column A B C i1 j (- i 1)) + (zero-column (Cj<-aCi+Cj '$A A val i i1) + (Rj<-aRi+Rj '$B B (- val) i1 i) + (Rj<-aRi+Rj '$C C (- val) i1 i) + i1 + j + (- i 1)))) + (zero-column A B C i1 j (- i 1))))) + +(defthm + dimensions-RJ<-ARI+RJ-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP J) + (>= J 0) + (< J (FIRST (DIMENSIONS NAME M)))) + (EQUAL (DIMENSIONS NAME (RJ<-ARI+RJ NAME1 M A I J)) + (DIMENSIONS NAME M))) + :hints (("Goal" + :in-theory (disable dimensions-RJ<-ARI+RJ) + :use (:instance + dimensions-RJ<-ARI+RJ + (name name1))))) + +(DEFTHM + DIMENSIONS-CJ<-ACI+CJ-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP J) + (>= J 0) + (< J (SECOND (DIMENSIONS NAME M)))) + (EQUAL (DIMENSIONS NAME (CJ<-ACI+CJ NAME1 M A I J)) + (DIMENSIONS NAME M))) + :hints (("Goal" + :in-theory (disable dimensions-CJ<-ACI+CJ) + :use (:instance + dimensions-CJ<-ACI+CJ + (name name1))))) + +(DEFTHM + ALIST2P-RJ<-ARI+RJ-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP J) + (>= J 0) + (< J (FIRST (DIMENSIONS NAME M)))) + (ALIST2P NAME (RJ<-ARI+RJ NAME1 M A I J))) + :hints (("Goal" + :in-theory (disable ALIST2P-RJ<-ARI+RJ) + :use (:instance + ALIST2P-RJ<-ARI+RJ + (name name1))))) + +(DEFTHM + ALIST2P-CJ<-ACI+CJ-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP J) + (>= J 0) + (< J (SECOND (DIMENSIONS NAME M)))) + (ALIST2P NAME (CJ<-ACI+CJ NAME1 M A I J))) + :hints (("Goal" + :in-theory (disable ALIST2P-CJ<-ACI+CJ) + :use (:instance + ALIST2P-CJ<-ACI+CJ + (name name1))))) + +(DEFTHM + ARRAY2P-RJ<-ARI+RJ-1 + (IMPLIES (AND (symbolp name1) + (ARRAY2P NAME M) + (INTEGERP J) + (>= J 0) + (< J (FIRST (DIMENSIONS NAME M)))) + (ARRAY2P NAME (RJ<-ARI+RJ NAME1 M A I J))) + :hints (("Goal" + :in-theory (disable Array2P-RJ<-ARI+RJ) + :use (:instance + Array2P-RJ<-ARI+RJ + (name name1))))) + +(DEFTHM + ARRAY2P-CJ<-ACI+CJ-1 + (IMPLIES (AND (symbolp name1) + (ARRAY2P NAME M) + (INTEGERP J) + (>= J 0) + (< J (SECOND (DIMENSIONS NAME M)))) + (ARRAY2P NAME (CJ<-ACI+CJ NAME1 M A I J))) + :hints (("Goal" + :in-theory (disable Array2P-CJ<-ACI+CJ) + :use (:instance + Array2P-CJ<-ACI+CJ + (name name1))))) + +(defthm + dimensions-zero-column-A + (implies (and (alist2p name A) + (integerp i1) + (>= i1 0) + (< i1 (second (dimensions name A)))) + (equal (dimensions name (car (zero-column A B C i1 j i))) + (dimensions name A)))) + +(defthm + alist2p-zero-column-A + (implies (and (alist2p name A) + (integerp i1) + (>= i1 0) + (< i1 (second (dimensions name A)))) + (alist2p name (car (zero-column A B C i1 j i))))) + +(defthm + array2p-zero-column-A + (implies (and (array2p name A) + (integerp i1) + (>= i1 0) + (< i1 (second (dimensions name A)))) + (array2p name (car (zero-column A B C i1 j i))))) + +(defthm + dimensions-zero-column-B + (implies (and (alist2p name B) + (< i (first (dimensions name B)))) + (equal (dimensions name (cadr (zero-column A B C i1 j i))) + (dimensions name B)))) + +(defthm + alist2p-zero-column-B + (implies (and (alist2p name B) + (< i (first (dimensions name B)))) + (alist2p name (cadr (zero-column A B C i1 j i))))) + +(defthm + array2p-zero-column-B + (implies (and (array2p name B) + (< i (first (dimensions name B)))) + (array2p name (cadr (zero-column A B C i1 j i))))) + +(defthm + dimensions-zero-column-C + (implies (and (alist2p name C) + (< i (first (dimensions name C)))) + (equal (dimensions name (caddr (zero-column A B C i1 j i))) + (dimensions name C)))) + +(defthm + alist2p-zero-column-C + (implies (and (alist2p name C) + (< i (first (dimensions name C)))) + (alist2p name (caddr (zero-column A B C i1 j i))))) + +(defthm + array2p-zero-column-C + (implies (and (array2p name C) + (< i (first (dimensions name C)))) + (array2p name (caddr (zero-column A B C i1 j i))))) + +(defun + find-non-zero-col (name C i j k) + "Determine if there is a nonzero value among + C(i k), C(i+1) k), . . . , C(j k). + If not, return nil, otherwise return the + first n such that C(n k) is nonzero." + (declare (xargs :measure (let ((i (nfix i)) + (j (nfix j))) + (if (> i j) + 0 + (- (+ j 1) i))) + :guard (and (array2p name C) + (integerp i) + (integerp j) + (integerp k) + (>= k 0) + (< j (first + (dimensions name + C))) + (< k (second + (dimensions name + C)))))) + (let ((i (nfix i)) + (j (nfix j))) + (cond ((> i j) nil) + ((zerop (fix (aref2 name C i k))) + (find-non-zero-col name C (+ i 1) j k)) + (t i)))) + +(defthm + find-non-zero-col-inequality + (implies (>= j 0) + (<= (find-non-zero-col name C i j k) + j)) + :rule-classes (:rewrite :linear)) + +(defthm + find-non-zero-col-inequality-1 + (implies (and (find-non-zero-col name C i j k) + (integerp i)) + (>= (find-non-zero-col name C i j k) + i)) + :rule-classes (:rewrite :linear)) + +(defthm + aref2-find-non-zero-col + (implies (find-non-zero-col name C i j k) + (and (acl2-numberp + (aref2 name + C + (find-non-zero-col name + C + i + j + k) + k)) + (not (equal + (aref2 name + C + (find-non-zero-col name + C + i + j + k) + k) + 0)))) + :rule-classes :type-prescription) + +(defun + find-non-zero-col-1 (name C i j k n) + "Determine if there is a nonzero value among + C(i k) C(i k+1) . . . C(i n) + C(i+1) k) C(i+1 k+1) . . . C(i+1 n) + . . . . + . . . . + . . . . + C(j k) C(j k+1) . . . C(j n) + If not, return nil, otherwise return the + first, obtained by searching column by column, + pair p q, such that C(p q) is nonzero." + (declare (xargs :measure (let ((k (nfix k)) + (n (nfix n))) + (if (> k n) + 0 + (- (+ n 1) k))) + :guard (and (array2p name C) + (integerp i) + (integerp j) + (integerp k) + (integerp n) + (< j (first (dimensions name C))) + (< n (second (dimensions name C)))))) + (let ((k (nfix k)) + (n (nfix n))) + (if (> k n) + nil + (let ((p (find-non-zero-col name C i j k))) + (if p + (list p k) + (find-non-zero-col-1 name + C + i + j + (+ k 1) + n)))))) + +(defthm + natp-car-find-non-zero-col-1 + (implies (find-non-zero-col-1 name C i j k n) + (and (integerp (car (find-non-zero-col-1 name C i j k n))) + (>= (car (find-non-zero-col-1 name C i j k n)) 0))) + :rule-classes :type-prescription) + +(defthm + natp-cadr-find-non-zero-col-1 + (implies (find-non-zero-col-1 name C i j k n) + (and (integerp (cadr (find-non-zero-col-1 name C i j k n))) + (>= (cadr (find-non-zero-col-1 name C i j k n)) 0))) + :rule-classes :type-prescription) + +(defthm + find-non-zero-col-1-inequality + (implies (>= j 0) + (<= (first (find-non-zero-col-1 name C i j k n)) + j)) + :rule-classes (:rewrite :linear)) + +(defthm + find-non-zero-col-1-inequality-1 + (implies (and (find-non-zero-col-1 name C i j k n) + (integerp i)) + (>= (first (find-non-zero-col-1 name C i j k n)) + i)) + :rule-classes (:rewrite :linear)) + +(defthm + find-non-zero-col-1-inequality-2 + (implies (and (>= n 0)) + (<= (second (find-non-zero-col-1 name C i j k n)) + n)) + :rule-classes (:rewrite :linear)) + +(defthm + find-non-zero-col-1-inequality-3 + (implies (and (find-non-zero-col-1 name C i j k n) + (integerp k)) + (>= (second (find-non-zero-col-1 name C i j k n)) + k)) + :rule-classes (:rewrite :linear)) + +(defthm + type-aref2-find-non-zero-col-1 + (implies (find-non-zero-col-1 name1 C i j k n) + (and (acl2-numberp + (aref2 name + C + (car + (find-non-zero-col-1 name1 + C + i + j + k + n)) + (cadr + (find-non-zero-col-1 name1 + C + i + j + k + n)))) + (not + (equal + (aref2 name + C + (car + (find-non-zero-col-1 name1 + C + i + j + k + n)) + (cadr + (find-non-zero-col-1 name1 + C + i + j + k + n))) + 0)))) + :rule-classes :type-prescription + :hints (("Goal" + :do-not '(generalize)))) + +(DEFTHM + DIMENSIONS-RI<-ARI-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP I) + (>= I 0) + (< I (FIRST (DIMENSIONS NAME M)))) + (EQUAL (DIMENSIONS NAME (RI<-ARI NAME1 M A I)) + (DIMENSIONS NAME M))) + :hints (("Goal" + :in-theory (disable DIMENSIONS-RI<-ARI) + :use (:instance + DIMENSIONS-RI<-ARI + (name name1))))) + +(DEFTHM + DIMENSIONS-CI<-ACI-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP I) + (>= I 0) + (< I (SECOND (DIMENSIONS NAME M)))) + (EQUAL (DIMENSIONS NAME (CI<-ACI NAME1 M A I)) + (DIMENSIONS NAME M))) + :hints (("Goal" + :in-theory (disable DIMENSIONS-CI<-ACI) + :use (:instance + DIMENSIONS-CI<-ACI + (name name1))))) + +(DEFTHM + DIMENSIONS-RI<->RJ-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP I) + (INTEGERP J) + (>= I 0) + (>= J 0) + (< I (FIRST (DIMENSIONS NAME M))) + (< J (FIRST (DIMENSIONS NAME M)))) + (EQUAL (DIMENSIONS NAME (RI<->RJ NAME1 M I J)) + (DIMENSIONS NAME M))) + :hints (("Goal" + :in-theory (disable DIMENSIONS-RI<->RJ) + :use (:instance + DIMENSIONS-RI<->RJ + (name name1))))) + +(DEFTHM + DIMENSIONS-CI<->CJ-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP I) + (INTEGERP J) + (>= I 0) + (>= J 0) + (< I (SECOND (DIMENSIONS NAME M))) + (< J (SECOND (DIMENSIONS NAME M)))) + (EQUAL (DIMENSIONS NAME (CI<->CJ NAME1 M I J)) + (DIMENSIONS NAME M))) + :hints (("Goal" + :in-theory (disable DIMENSIONS-CI<->CJ) + :use (:instance + DIMENSIONS-CI<->CJ + (name name1))))) + +(defthm + lemma-32-hack + (IMPLIES (AND (< J (CADR (DIMENSIONS '$ARG A))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$A A) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< (+ 1 I) + (CADR + (DIMENSIONS + '$a + (CAR (ZERO-COLUMN + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I) + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + (RI<-ARI '$C + (RI<->RJ '$C + C + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + I + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + J)))))) + :rule-classes nil) + +(defthm + lemma-32-hack-1 + (IMPLIES (AND (< J (CADR (DIMENSIONS '$ARG A))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$A A) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< (+ 1 I) + (CADR + (DIMENSIONS + '$arg + (CAR (ZERO-COLUMN + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I) + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + (RI<-ARI '$C + (RI<->RJ '$C + C + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + I + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + J)))))) + :hints (("Goal" + :in-theory (disable NATP-CAR-FIND-NON-ZERO-COL-1) + :use lemma-32-hack))) + +(defthm + lemma-23-hack + (IMPLIES (AND (< J (CADR (DIMENSIONS '$ARG A))) + (<= 0 J) + (<= 0 I) + (INTEGERP J) + (INTEGERP I) + (ARRAY2P '$A A) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< J + (CADR + (DIMENSIONS + '$A + (CAR (ZERO-COLUMN + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I) + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + (RI<-ARI '$C + (RI<->RJ '$C + C + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + I + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + J)))))) + :rule-classes nil) + +(defthm + lemma-23-hack-1 + (IMPLIES (AND (< J (CADR (DIMENSIONS '$ARG A))) + (<= 0 J) + (<= 0 I) + (INTEGERP J) + (INTEGERP I) + (ARRAY2P '$A A) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< J + (CADR + (DIMENSIONS + '$arg + (CAR (ZERO-COLUMN + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I) + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + (RI<-ARI '$C + (RI<->RJ '$C + C + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + I + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + J)))))) + :hints (("Goal" + :in-theory (disable NATP-CAR-FIND-NON-ZERO-COL-1) + :use lemma-23-hack))) + +(defthm + lemma-19-hack + (IMPLIES (AND (< J (CADR (DIMENSIONS '$ARG A))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$A A) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< J + (CADR + (DIMENSIONS '$A + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I))))) + :rule-classes nil) + +(defthm + lemma-19-hack-1 + (IMPLIES (AND (< J (CADR (DIMENSIONS '$ARG A))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$A A) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< J + (CADR + (DIMENSIONS '$Arg + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I))))) + :hints (("Goal" + :in-theory (disable NATP-CAR-FIND-NON-ZERO-COL-1) + :use lemma-19-hack))) + +(defthm + lemma-18-hack + (IMPLIES (AND (< J (CAR (DIMENSIONS '$ARG B))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$B B) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< I + (CAR (DIMENSIONS + '$B + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I))))) + :rule-classes nil) + +(defthm + lemma-18-hack-1 + (IMPLIES (AND (< J (CAR (DIMENSIONS '$ARG B))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$B B) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< I + (CAR (DIMENSIONS + '$arg + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I))))) + :hints (("Goal" + :in-theory (disable NATP-CAR-FIND-NON-ZERO-COL-1) + :use lemma-18-hack))) + +(defthm + lemma-16-hack + (IMPLIES (AND (< J (CAR (DIMENSIONS '$ARG B))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$B B) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< J + (CAR + (DIMENSIONS + '$b + (CADR + (ZERO-COLUMN + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I) + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + (RI<-ARI '$C + (RI<->RJ '$C + C + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + I + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + J)))))) + :rule-classes nil) + +(defthm + lemma-16-hack-1 + (IMPLIES (AND (< J (CAR (DIMENSIONS '$ARG B))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$B B) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< J + (CAR + (DIMENSIONS + '$arg + (CADR + (ZERO-COLUMN + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I) + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + (RI<-ARI '$C + (RI<->RJ '$C + C + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + I + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + J)))))) + :hints (("Goal" + :in-theory (disable NATP-CAR-FIND-NON-ZERO-COL-1) + :use lemma-16-hack))) + +(defthm + lemma-15-hack + (IMPLIES (AND (< J (CAR (DIMENSIONS '$ARG B))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$B B) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< J + (CAR (DIMENSIONS + '$b + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I))))) + :rule-classes nil) + +(defthm + lemma-15-hack-1 + (IMPLIES (AND (< J (CAR (DIMENSIONS '$ARG B))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$B B) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< J + (CAR (DIMENSIONS + '$arg + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I))))) + :hints (("Goal" + :in-theory (disable NATP-CAR-FIND-NON-ZERO-COL-1) + :use lemma-15-hack))) + +(defthm + lemma-15-crock + (IMPLIES (AND (< J (CADR (DIMENSIONS '$ARG A))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$A A) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< I + (CADR + (DIMENSIONS '$a + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I))))) + :rule-classes nil) + +(defthm + lemma-15-crock-1 + (IMPLIES (AND (< J (CADR (DIMENSIONS '$ARG A))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$A A) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< I + (CADR + (DIMENSIONS '$arg + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I))))) + :hints (("Goal" + :in-theory (disable NATP-CAR-FIND-NON-ZERO-COL-1) + :use lemma-15-crock))) + +(defthm + lemma-10-hack + (IMPLIES (AND (< J (CAR (DIMENSIONS '$ARG B))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$B B) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< (+ 1 I) + (CAR + (DIMENSIONS + '$b + (CADR + (ZERO-COLUMN + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I) + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + (RI<-ARI '$C + (RI<->RJ '$C + C + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + I + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + J)))))) + :rule-classes nil) + +(defthm + lemma-10-hack-1 + (IMPLIES (AND (< J (CAR (DIMENSIONS '$ARG B))) + (<= 0 J) + (<= 0 I) + (INTEGERP I) + (ARRAY2P '$B B) + (FIND-NON-ZERO-COL-1 '$C C I J K N) + (NOT (EQUAL (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I))) + (< (+ 1 I) + (CAR + (DIMENSIONS + '$arg + (CADR + (ZERO-COLUMN + (CI<-ACI '$A + (CI<->CJ '$A + A + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + I) + (RI<-ARI '$B + (RI<->RJ '$B + B + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + (RI<-ARI '$C + (RI<->RJ '$C + C + I + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N))) + (/ (AREF2 '$ARG + C + (CAR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)))) + I) + I + (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + J)))))) + :hints (("Goal" + :in-theory (disable NATP-CAR-FIND-NON-ZERO-COL-1) + :use lemma-10-hack))) + +(defthm + lemma-1-hack + (IMPLIES (AND (FIND-NON-ZERO-COL-1 '$C C I J K N) + (< J (CAR (DIMENSIONS '$ARG C))) + (<= 0 J) + (INTEGERP J) + (ARRAY2P '$C C) + (NOT (EQUAL I J)) + (EQUAL (CADR (FIND-NON-ZERO-COL-1 '$C C I J K N)) + I)) + (< (+ 1 I) (CAR (DIMENSIONS '$ARG C))))) + +(defun + determinant-inverse-loop (A B C D i j k n) + "Process columns k thru n, + restricted to rows i thru j." + (declare (xargs :measure (let ((k (nfix k)) + (n (nfix n))) + (if (> k n) + 0 + (- (+ n 1) k))) + :guard (and (array2p '$a A) + (array2p '$b B) + (array2p '$c C) + (acl2-numberp D) + (integerp i) + (integerp j) + (integerp k) + (integerp n) + (>= i 0) + (>= j 0) + (>= k 0) + (>= n 0) + (< i (second + (dimensions '$a + A))) + (< i (first + (dimensions '$b + B))) + (< i (first + (dimensions '$c + C))) + (< j (second + (dimensions '$a + A))) + (< j (first + (dimensions '$b + B))) + (< j (first + (dimensions '$c + C))) + (< n (second + (dimensions '$c + C)))) + :verify-guards nil)) + (let ((k (nfix k)) + (n (nfix n)) + (i (nfix i)) + (j (nfix j))) + (if (> k n) + (mv A B C D) + (let + ((indices (find-non-zero-col-1 '$C C i j k n))) + (if indices + (let* + ((p (first indices)) + (q (second indices)) + (val (aref2 '$C C p q))) + (if (= p i) + (mv-let + (A B C) + (zero-column (Ci<-aCi '$A A val i) + (Ri<-aRi '$B B (/ val) i) + (Ri<-aRi '$C C (/ val) i) + i + q + j) + (cond ((= i j) + (mv A B C (* val D))) + ((= q i) + (determinant-inverse-loop A B C + (* val D) + (+ i 1) + j + (+ q 1) + n)) + (t + (determinant-inverse-loop A B C + (* val D) + 0 + j + (+ q 1) + n)))) + (mv-let + (A B C) + (zero-column (Ci<-aCi '$A (Ci<->Cj '$A A i p) val i) + (Ri<-aRi '$B (Ri<->Rj '$B B i p)(/ val) i) + (Ri<-aRi '$C (Ri<->Rj '$C C i p)(/ val) i) + i + q + j) + (cond ((= i j) + (mv A B C (* val (- D)))) + ((= q i) + (determinant-inverse-loop A B C + (* val (- D)) + (+ i 1) + j + (+ q 1) + n)) + (t + (determinant-inverse-loop A B C + 0 + (+ i 1) + j + (+ q 1) + n)))))) + (mv A B C 0)))))) + +(defthm + mv-nth-1 + (equal (mv-nth 1 L) + (cadr L))) + +(defthm + mv-nth-2 + (equal (mv-nth 2 L) + (caddr L))) + +(verify-guards determinant-inverse-loop) + +(defthm + sq-array2p-m-1 + (IMPLIES (AND (EQUAL (CAR (DIMENSIONS name M)) + (CADR (DIMENSIONS name M))) + (ARRAY2P name M)) + (ARRAY2P name + (M-1 (CAR (DIMENSIONS name M))))) + :hints (("Goal" + :use (:theorem + (implies (array2p name M) + (< (* (first (dimensions name M)) + (second (dimensions name M))) + *MAXIMUM-POSITIVE-32-BIT-INTEGER*)))))) + +(defthm + sq-array2p-m-1-a + (IMPLIES (AND (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + (ARRAY2P name1 M) + (symbolp name)) + (ARRAY2P name + (M-1 (CAR (DIMENSIONS '$ARG M))))) + :hints (("Goal" + :in-theory (disable sq-array2p-m-1) + :use sq-array2p-m-1))) + +(defthm + sq-array2p-compress2 + (IMPLIES (AND (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + (ARRAY2P name M) + (symbolp name1)) + (ARRAY2P name1 + (COMPRESS2 name2 + (M-1 (CAR (DIMENSIONS '$ARG M)))))) + :hints (("Goal" + :in-theory (disable ARRAY2P-COMPRESS2) + :use (:instance + ARRAY2P-COMPRESS2 + (L (M-1 (CAR (DIMENSIONS '$ARG M)))) + (name name1))))) + +(defun + determinant-inverse (M) + "Return multiple values A, B, C, and D. + If M is a square array, the determinant of + M is returned in D. If the determinant is + nonzero, then the matrix inverse of M is + returned in B." + (declare (xargs :guard (and (array2p '$c M) + (let ((dims (dimensions '$c M))) + (= (first dims) + (second dims)))))) + (let ((dims (dimensions '$c M))) + (if (mbt (and (alist2p '$c M) + (= (first dims) + (second dims)))) + (let ((dim1 (first dims))) + (determinant-inverse-loop (compress2 '$A (m-1 dim1)) + (compress2 '$B (m-1 dim1)) + (compress2 '$C M) + 1 ;; initial value of D + 0 + (- dim1 1) + 0 + (- (second (dimensions '$c M)) 1))) + (mv M (/ M) 1 M)))) + +(defun + determinant (M) + (declare (xargs :guard (and (array2p '$c M) + (let ((dims (dimensions '$c M))) + (= (first dims) + (second dims)))))) + (mv-let (A B C D) + (determinant-inverse M) + (declare (ignore A B C)) + D)) + +(defun + m-/ (M) + (declare (xargs :guard (and (array2p '$c M) + (let ((dims (dimensions '$c M))) + (= (first dims) + (second dims)))))) + (mv-let (A B C D) + (determinant-inverse M) + (declare (ignore A C D)) + B)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Eventually, we will prove that for square matrices +;; whenever the determinant is not 0, then m-/ +;; computes the two-sided inverse; and whenever the +;; determinant is 0 then there is no inverse. +;; Also it will be proved that non-square matrices +;; do not have two-sided inverses. + +;; Meanwhile the definition of singualar given +;; immediately below is replaced by the second one +;; below. + +;; (defun +;; m-singularp (M) +;; (declare (xargs :guard (array2p '$c M))) +;; (not (and (mbt (alist2p '$c M)) +;; (let ((dims (dimensions '$c M))) +;; (= (first dims) +;; (second dims))) +;; (= (determinant M) 0)))) +|#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun + m-singularp (M) + (declare (xargs :guard (array2p '$c M) + :verify-guards nil)) + (not (and (mbt (alist2p '$c M)) + (let ((dims (dimensions '$c M))) + (= (first dims) + (second dims))) + (m-= (m-* M (m-/ M)) + (m-1 (r M))) + (m-= (m-* (m-/ M) M) + (m-1 (r M)))))) + +(defthm + non-singular-implies-square + (implies (not (m-singularp M)) + (equal (equal (c M)(r M)) + t))) + +(defthm + left-m-*-inverse-of-m-/ + (implies (not (m-singularp M)) + (m-= (m-* (m-/ M) M) + (m-1 (r M))))) + +(defthm + right-m-*-inverse-of-m-/ + (implies (not (m-singularp M)) + (m-= (m-* M (m-/ M)) + (m-1 (r M))))) + +(DEFTHM + ALIST2P-CI<->CJ-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP I) + (INTEGERP J) + (>= I 0) + (>= J 0) + (< I (SECOND (DIMENSIONS NAME M))) + (< J (SECOND (DIMENSIONS NAME M)))) + (ALIST2P NAME (CI<->CJ NAME1 M I J))) + :HINTS (("Goal" + :IN-THEORY (DISABLE alist2p-CI<->CJ) + :USE (:INSTANCE + alist2p-CI<->CJ + (NAME NAME1))))) + +(DEFTHM + Array2P-CI<->CJ-1 + (IMPLIES (AND (symbolp name1) + (Array2P NAME M) + (INTEGERP I) + (INTEGERP J) + (>= I 0) + (>= J 0) + (< I (SECOND (DIMENSIONS NAME M))) + (< J (SECOND (DIMENSIONS NAME M)))) + (Array2P NAME (CI<->CJ NAME1 M I J))) + :HINTS (("Goal" + :IN-THEORY (DISABLE array2p-CI<->CJ) + :USE (:INSTANCE + array2p-CI<->CJ + (NAME NAME1))))) + +(DEFTHM + ALIST2P-RI<->RJ-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP I) + (INTEGERP J) + (>= I 0) + (>= J 0) + (< I (FIRST (DIMENSIONS NAME M))) + (< J (FIRST (DIMENSIONS NAME M)))) + (ALIST2P NAME (RI<->RJ NAME1 M I J))) + :HINTS (("Goal" + :IN-THEORY (DISABLE alist2p-RI<->RJ) + :USE (:INSTANCE + alist2p-RI<->RJ + (NAME NAME1))))) + +(DEFTHM + Array2P-RI<->RJ-1 + (IMPLIES (AND (symbolp name1) + (Array2P NAME M) + (INTEGERP I) + (INTEGERP J) + (>= I 0) + (>= J 0) + (< I (FIRST (DIMENSIONS NAME M))) + (< J (FIRST (DIMENSIONS NAME M)))) + (Array2P NAME (RI<->RJ NAME1 M I J))) + :HINTS (("Goal" + :IN-THEORY (DISABLE array2p-RI<->RJ) + :USE (:INSTANCE + array2p-RI<->RJ + (NAME NAME1))))) + +(DEFTHM + ALIST2P-RI<-ARI-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP I) + (>= I 0) + (< I (FIRST (DIMENSIONS NAME M)))) + (ALIST2P NAME (RI<-ARI NAME1 M A I))) + :HINTS (("Goal" + :IN-THEORY (DISABLE alist2p-RI<-ARI) + :USE (:INSTANCE + alist2p-RI<-ARI + (NAME NAME1))))) + +(DEFTHM + Array2P-RI<-ARI-1 + (IMPLIES (AND (symbolp name1) + (Array2P NAME M) + (INTEGERP I) + (>= I 0) + (< I (FIRST (DIMENSIONS NAME M)))) + (Array2P NAME (RI<-ARI NAME1 M A I))) + :HINTS (("Goal" + :IN-THEORY (DISABLE array2p-RI<-ARI) + :USE (:INSTANCE + array2p-RI<-ARI + (NAME NAME1))))) + +(DEFTHM + ALIST2P-CI<-ACI-1 + (IMPLIES (AND (ALIST2P NAME M) + (INTEGERP I) + (>= I 0) + (< I (second (DIMENSIONS NAME M)))) + (ALIST2P NAME (CI<-ACI NAME1 M A I))) + :HINTS (("Goal" + :IN-THEORY (DISABLE alist2p-CI<-ACI) + :USE (:INSTANCE + alist2p-CI<-ACI + (NAME NAME1))))) + +(DEFTHM + Array2P-CI<-ACI-1 + (IMPLIES (AND (symbolp name1) + (Array2P NAME M) + (INTEGERP I) + (>= I 0) + (< I (second (DIMENSIONS NAME M)))) + (Array2P NAME (CI<-ACI NAME1 M A I))) + :HINTS (("Goal" + :IN-THEORY (DISABLE array2p-CI<-ACI) + :USE (:INSTANCE + array2p-CI<-ACI + (NAME NAME1))))) + +(defthm + array2p-alist2p-1 + (implies (and (array2p name1 L) + (symbolp name)) + (alist2p name L)) + :hints (("Goal" + :in-theory (disable array2p-alist2p) + :use array2p-alist2p))) + +(defthm + dimensions-DETERMINANT-INVERSE-LOOP-A + (IMPLIES (AND (Alist2P '$A A) + (Alist2P '$B B) + (Alist2P '$C C) + (INTEGERP I) + (INTEGERP J) + (INTEGERP K) + (INTEGERP N) + (<= 0 I) + (<= 0 J) + (<= 0 K) + (<= 0 N) + (< I (CADR (DIMENSIONS '$ARG A))) + (< I (CAR (DIMENSIONS '$ARG B))) + (< I (CAR (DIMENSIONS '$ARG C))) + (< J (CADR (DIMENSIONS '$ARG A))) + (< J (CAR (DIMENSIONS '$ARG B))) + (< J (CAR (DIMENSIONS '$ARG C))) + (< N (CADR (DIMENSIONS '$ARG C)))) + (EQUAL (DIMENSIONS + name + (CAR (DETERMINANT-INVERSE-LOOP A + B + C + D + I + J + K + N))) + (DIMENSIONS name A)))) + +(defthm + dimensions-DETERMINANT-INVERSE-LOOP-B + (IMPLIES (AND (Alist2P '$A A) + (Alist2P '$B B) + (Alist2P '$C C) + (INTEGERP I) + (INTEGERP J) + (INTEGERP K) + (INTEGERP N) + (<= 0 I) + (<= 0 J) + (<= 0 K) + (<= 0 N) + (< I (CADR (DIMENSIONS '$ARG A))) + (< I (CAR (DIMENSIONS '$ARG B))) + (< I (CAR (DIMENSIONS '$ARG C))) + (< J (CADR (DIMENSIONS '$ARG A))) + (< J (CAR (DIMENSIONS '$ARG B))) + (< J (CAR (DIMENSIONS '$ARG C))) + (< N (CADR (DIMENSIONS '$ARG C)))) + (EQUAL (DIMENSIONS + name + (CADR (DETERMINANT-INVERSE-LOOP A + B + C + D + I + J + K + N))) + (DIMENSIONS name B)))) + +(defthm + dimensions-DETERMINANT-INVERSE-LOOP-C + (IMPLIES (AND (Alist2P '$A A) + (Alist2P '$B B) + (Alist2P '$C C) + (INTEGERP I) + (INTEGERP J) + (INTEGERP K) + (INTEGERP N) + (<= 0 I) + (<= 0 J) + (<= 0 K) + (<= 0 N) + (< I (CADR (DIMENSIONS '$ARG A))) + (< I (CAR (DIMENSIONS '$ARG B))) + (< I (CAR (DIMENSIONS '$ARG C))) + (< J (CADR (DIMENSIONS '$ARG A))) + (< J (CAR (DIMENSIONS '$ARG B))) + (< J (CAR (DIMENSIONS '$ARG C))) + (< N (CADR (DIMENSIONS '$ARG C)))) + (EQUAL (DIMENSIONS + name + (CADDR (DETERMINANT-INVERSE-LOOP A + B + C + D + I + J + K + N))) + (DIMENSIONS name C)))) + +(defthm + alist2p-DETERMINANT-INVERSE-LOOP-A + (IMPLIES (AND (Alist2P '$A A) + (Alist2P '$B B) + (Alist2P '$C C) + (INTEGERP I) + (INTEGERP J) + (INTEGERP K) + (INTEGERP N) + (<= 0 I) + (<= 0 J) + (<= 0 K) + (<= 0 N) + (< I (CADR (DIMENSIONS '$ARG A))) + (< I (CAR (DIMENSIONS '$ARG B))) + (< I (CAR (DIMENSIONS '$ARG C))) + (< J (CADR (DIMENSIONS '$ARG A))) + (< J (CAR (DIMENSIONS '$ARG B))) + (< J (CAR (DIMENSIONS '$ARG C))) + (< N (CADR (DIMENSIONS '$ARG C)))) + (alist2p '$a (CAR (DETERMINANT-INVERSE-LOOP A + B + C + D + I + J + K + N)))) + + :hints (("Goal" + :do-not '(generalize)))) + +(defthm + alist2p-DETERMINANT-INVERSE-LOOP-B + (IMPLIES (AND (Alist2P '$A A) + (Alist2P '$B B) + (Alist2P '$C C) + (INTEGERP I) + (INTEGERP J) + (INTEGERP K) + (INTEGERP N) + (<= 0 I) + (<= 0 J) + (<= 0 K) + (<= 0 N) + (< I (CADR (DIMENSIONS '$ARG A))) + (< I (CAR (DIMENSIONS '$ARG B))) + (< I (CAR (DIMENSIONS '$ARG C))) + (< J (CADR (DIMENSIONS '$ARG A))) + (< J (CAR (DIMENSIONS '$ARG B))) + (< J (CAR (DIMENSIONS '$ARG C))) + (< N (CADR (DIMENSIONS '$ARG C)))) + (alist2p '$b (CAdR (DETERMINANT-INVERSE-LOOP A + B + C + D + I + J + K + N)))) + + :hints (("Goal" + :do-not '(generalize)))) + +(defthm + alist2p-DETERMINANT-INVERSE-LOOP-C + (IMPLIES (AND (Alist2P '$A A) + (Alist2P '$B B) + (Alist2P '$C C) + (INTEGERP I) + (INTEGERP J) + (INTEGERP K) + (INTEGERP N) + (<= 0 I) + (<= 0 J) + (<= 0 K) + (<= 0 N) + (< I (CADR (DIMENSIONS '$ARG A))) + (< I (CAR (DIMENSIONS '$ARG B))) + (< I (CAR (DIMENSIONS '$ARG C))) + (< J (CADR (DIMENSIONS '$ARG A))) + (< J (CAR (DIMENSIONS '$ARG B))) + (< J (CAR (DIMENSIONS '$ARG C))) + (< N (CADR (DIMENSIONS '$ARG C)))) + (alist2p '$C (CAddR (DETERMINANT-INVERSE-LOOP A + B + C + D + I + J + K + N)))) + + :hints (("Goal" + :do-not '(generalize)))) + +(defthm + array2p-DETERMINANT-INVERSE-LOOP-A + (IMPLIES (AND (Array2P '$A A) + (Array2P '$B B) + (Array2P '$C C) + (INTEGERP I) + (INTEGERP J) + (INTEGERP K) + (INTEGERP N) + (<= 0 I) + (<= 0 J) + (<= 0 K) + (<= 0 N) + (< I (CADR (DIMENSIONS '$ARG A))) + (< I (CAR (DIMENSIONS '$ARG B))) + (< I (CAR (DIMENSIONS '$ARG C))) + (< J (CADR (DIMENSIONS '$ARG A))) + (< J (CAR (DIMENSIONS '$ARG B))) + (< J (CAR (DIMENSIONS '$ARG C))) + (< N (CADR (DIMENSIONS '$ARG C)))) + (array2p '$a (CAR (DETERMINANT-INVERSE-LOOP A + B + C + D + I + J + K + N)))) + + :hints (("Goal" + :do-not '(generalize)))) + +(defthm + array2p-DETERMINANT-INVERSE-LOOP-B + (IMPLIES (AND (Array2P '$A A) + (Array2P '$B B) + (Array2P '$C C) + (INTEGERP I) + (INTEGERP J) + (INTEGERP K) + (INTEGERP N) + (<= 0 I) + (<= 0 J) + (<= 0 K) + (<= 0 N) + (< I (CADR (DIMENSIONS '$ARG A))) + (< I (CAR (DIMENSIONS '$ARG B))) + (< I (CAR (DIMENSIONS '$ARG C))) + (< J (CADR (DIMENSIONS '$ARG A))) + (< J (CAR (DIMENSIONS '$ARG B))) + (< J (CAR (DIMENSIONS '$ARG C))) + (< N (CADR (DIMENSIONS '$ARG C)))) + (array2p '$b (CAdR (DETERMINANT-INVERSE-LOOP A + B + C + D + I + J + K + N)))) + + :hints (("Goal" + :do-not '(generalize)))) + +(defthm + array2p-DETERMINANT-INVERSE-LOOP-C + (IMPLIES (AND (Array2P '$A A) + (Array2P '$B B) + (Array2P '$C C) + (INTEGERP I) + (INTEGERP J) + (INTEGERP K) + (INTEGERP N) + (<= 0 I) + (<= 0 J) + (<= 0 K) + (<= 0 N) + (< I (CADR (DIMENSIONS '$ARG A))) + (< I (CAR (DIMENSIONS '$ARG B))) + (< I (CAR (DIMENSIONS '$ARG C))) + (< J (CADR (DIMENSIONS '$ARG A))) + (< J (CAR (DIMENSIONS '$ARG B))) + (< J (CAR (DIMENSIONS '$ARG C))) + (< N (CADR (DIMENSIONS '$ARG C)))) + (array2p '$C (CAddR (DETERMINANT-INVERSE-LOOP A + B + C + D + I + J + K + N)))) + + :hints (("Goal" + :do-not '(generalize)))) + +(defthm + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-A + (IMPLIES (ALIST2P '$C M) + (EQUAL (DIMENSIONS + '$ARG + (CAR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAdR (DIMENSIONS '$ARG M)))))) + (LIST (CAR (DIMENSIONS '$ARG M)) + (CAR (DIMENSIONS '$ARG M))))) + :hints (("Goal" + :in-theory (disable dimensions-DETERMINANT-INVERSE-LOOP-A) + :use (:instance + dimensions-DETERMINANT-INVERSE-LOOP-A + (A (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (B (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (C (COMPRESS2 '$ARG M)) + (i 0) + (j (+ -1 (CAR (DIMENSIONS '$ARG M)))) + (k 0) + (n (+ -1 (CAdR (DIMENSIONS '$ARG M)))))))) + +(defthm + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-A-1 + (IMPLIES (and (ALIST2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + (EQUAL (DIMENSIONS + '$ARG + (CAR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M)))))) + (LIST (CAR (DIMENSIONS '$ARG M)) + (CAR (DIMENSIONS '$ARG M))))) + :hints + (("Goal" + :in-theory + (disable + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-A) + :use + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-A))) + +(defthm + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-B + (IMPLIES (ALIST2P '$C M) + (EQUAL (DIMENSIONS + '$ARG + (CAdR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAdR (DIMENSIONS '$ARG M)))))) + (LIST (CAR (DIMENSIONS '$ARG M)) + (CAR (DIMENSIONS '$ARG M))))) + :hints (("Goal" + :in-theory (disable dimensions-DETERMINANT-INVERSE-LOOP-B) + :use (:instance + dimensions-DETERMINANT-INVERSE-LOOP-B + (A (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (B (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (C (COMPRESS2 '$ARG M)) + (i 0) + (j (+ -1 (CAR (DIMENSIONS '$ARG M)))) + (k 0) + (n (+ -1 (CAdR (DIMENSIONS '$ARG M)))))))) + +(defthm + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1 + (IMPLIES (and (ALIST2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + (EQUAL (DIMENSIONS + '$ARG + (CAdR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M)))))) + (LIST (CAR (DIMENSIONS '$ARG M)) + (CAR (DIMENSIONS '$ARG M))))) + :hints + (("Goal" + :in-theory + (disable + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-B) + :use + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-B))) + +(defthm + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-C + (IMPLIES (ALIST2P '$C M) + (EQUAL (DIMENSIONS + '$ARG + (CAddR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR + (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 + (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAdR (DIMENSIONS '$ARG M)))))) + (dimensions '$arg M))) + :hints (("Goal" + :in-theory (disable dimensions-DETERMINANT-INVERSE-LOOP-c) + :use (:instance + dimensions-DETERMINANT-INVERSE-LOOP-c + (A (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (B (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (C (COMPRESS2 '$ARG M)) + (i 0) + (j (+ -1 (CAR (DIMENSIONS '$ARG M)))) + (k 0) + (n (+ -1 (CAdR (DIMENSIONS '$ARG M)))))))) + +(defthm + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-C-1 + (IMPLIES (and (ALIST2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + (EQUAL (DIMENSIONS + '$ARG + (CAddR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR + (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 + (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M)))))) + (dimensions '$arg M))) + :hints + (("Goal" + :in-theory + (disable + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-C) + :use + dimensions-DETERMINANT-INVERSE-LOOP-COMPRESS2-C))) + +(defthm + dimensions-m-/ + (implies (and (alist2p name M) + (equal (first (dimensions name M)) + (second (dimensions name M)))) + (equal (dimensions name (m-/ M)) + (list (car (dimensions name M)) + (car (dimensions name M)))))) + +(defthm + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-A + (IMPLIES (ALIST2P '$C M) + (alist2p name + (CAR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAdR (DIMENSIONS '$ARG M))))))) + :hints (("Goal" + :in-theory (disable alist2p-DETERMINANT-INVERSE-LOOP-A) + :use (:instance + alist2p-DETERMINANT-INVERSE-LOOP-A + (A (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (B (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (C (COMPRESS2 '$ARG M)) + (i 0) + (j (+ -1 (CAR (DIMENSIONS '$ARG M)))) + (k 0) + (n (+ -1 (CAdR (DIMENSIONS '$ARG M)))))))) + +(defthm + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-A-1 + (IMPLIES (and (ALIST2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + (alist2p name + (CAR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))))))) + :hints + (("Goal" + :in-theory + (disable + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-A) + :use + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-A))) + +(defthm + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B + (IMPLIES (ALIST2P '$C M) + (alist2p name + (CAdR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAdR (DIMENSIONS '$ARG M))))))) + :hints (("Goal" + :in-theory (disable alist2p-DETERMINANT-INVERSE-LOOP-B) + :use (:instance + alist2p-DETERMINANT-INVERSE-LOOP-B + (A (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (B (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (C (COMPRESS2 '$ARG M)) + (i 0) + (j (+ -1 (CAR (DIMENSIONS '$ARG M)))) + (k 0) + (n (+ -1 (CAdR (DIMENSIONS '$ARG M)))))))) + +(defthm + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1 + (IMPLIES (and (ALIST2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + (alist2p name + (CAdR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))))))) + :hints + (("Goal" + :in-theory + (disable + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B) + :use + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B))) + +(defthm + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-C + (IMPLIES (ALIST2P '$C M) + (alist2p name + (CAddR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR + (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 + (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAdR (DIMENSIONS '$ARG M))))))) + :hints (("Goal" + :in-theory (disable alist2p-DETERMINANT-INVERSE-LOOP-c) + :use (:instance + alist2p-DETERMINANT-INVERSE-LOOP-c + (A (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (B (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (C (COMPRESS2 '$ARG M)) + (i 0) + (j (+ -1 (CAR (DIMENSIONS '$ARG M)))) + (k 0) + (n (+ -1 (CAdR (DIMENSIONS '$ARG M)))))))) + +(defthm + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-C-1 + (IMPLIES (and (ALIST2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + (alist2p name + (CAddR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR + (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 + (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))))))) + :hints + (("Goal" + :in-theory + (disable + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-C) + :use + alist2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-C))) + +(defthm + alist2p-m-/ + (implies (and (alist2p name M) + (equal (first (dimensions name M)) + (second (dimensions name M)))) + (alist2p name (m-/ M)))) + +(defTHM + ARRAY2P-COMPRESS2-1 + (IMPLIES (ARRAY2P NAME L) + (ARRAY2P NAME (COMPRESS2 NAME1 L)))) + +(defthm + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-A + (IMPLIES (and (Array2P '$C M) + (< (* (CAR (DIMENSIONS '$ARG M)) + (CAR (DIMENSIONS '$ARG M))) + *MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (symbolp name)) + (array2p name + (CAR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAdR (DIMENSIONS '$ARG M))))))) + :hints (("Goal" + :in-theory (disable array2p-DETERMINANT-INVERSE-LOOP-A) + :use (:instance + array2p-DETERMINANT-INVERSE-LOOP-A + (A (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (B (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (C (COMPRESS2 '$ARG M)) + (i 0) + (j (+ -1 (CAR (DIMENSIONS '$ARG M)))) + (k 0) + (n (+ -1 (CAdR (DIMENSIONS '$ARG M)))))))) + +(defthm + array2p-rewrite-linear-1 + (implies (array2p name M) + (< (* (CAR (DIMENSIONS name M)) + (CAdR (DIMENSIONS name M))) + *MAXIMUM-POSITIVE-32-BIT-INTEGER*)) + :rule-classes (:rewrite :linear)) + +(defthm + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-A-1 + (IMPLIES (and (Array2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + (symbolp name)) + (array2p name + (CAR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))))))) + :hints + (("Goal" + :in-theory + (disable + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-A + array2p-rewrite-linear-1) + :use + (array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-A + (:instance + array2p-rewrite-linear-1 + (name '$arg)))))) + +(defthm + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B + (IMPLIES (and (Array2P '$C M) + (< (* (CAR (DIMENSIONS '$ARG M)) + (CAR (DIMENSIONS '$ARG M))) + *MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (symbolp name)) + (array2p name + (CAdR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAdR (DIMENSIONS '$ARG M))))))) + :hints (("Goal" + :in-theory (disable array2p-DETERMINANT-INVERSE-LOOP-B) + :use (:instance + array2p-DETERMINANT-INVERSE-LOOP-B + (A (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (B (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (C (COMPRESS2 '$ARG M)) + (i 0) + (j (+ -1 (CAR (DIMENSIONS '$ARG M)))) + (k 0) + (n (+ -1 (CAdR (DIMENSIONS '$ARG M)))))))) + +(defthm + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1 + (IMPLIES (and (Array2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + (symbolp name)) + (array2p name + (CAdR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))))))) + :hints + (("Goal" + :in-theory + (disable + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B + array2p-rewrite-linear-1) + :use + (array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B + (:instance + array2p-rewrite-linear-1 + (name '$arg)))))) + +(defthm + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-C + (IMPLIES (and (Array2P '$C M) + (< (* (CAR (DIMENSIONS '$ARG M)) + (CAR (DIMENSIONS '$ARG M))) + *MAXIMUM-POSITIVE-32-BIT-INTEGER*) + (symbolp name)) + (array2p name + (CAddR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR + (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 + (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAdR (DIMENSIONS '$ARG M))))))) + :hints (("Goal" + :in-theory (disable array2p-DETERMINANT-INVERSE-LOOP-c) + :use (:instance + array2p-DETERMINANT-INVERSE-LOOP-c + (A (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (B (COMPRESS2 '$ARG + (M-1 (CAR (DIMENSIONS '$ARG M))))) + (C (COMPRESS2 '$ARG M)) + (i 0) + (j (+ -1 (CAR (DIMENSIONS '$ARG M)))) + (k 0) + (n (+ -1 (CAdR (DIMENSIONS '$ARG M)))))))) + +(defthm + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-C-1 + (IMPLIES (and (Array2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M))) + (symbolp name)) + (array2p name + (CAddR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 + '$ARG + (M-1 (CAR + (DIMENSIONS '$ARG M)))) + (COMPRESS2 + '$ARG + (M-1 + (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + D + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 + (CAR (DIMENSIONS '$ARG M))))))) + :hints + (("Goal" + :in-theory + (disable + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-C + array2p-rewrite-linear-1) + :use + (array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-C + (:instance + array2p-rewrite-linear-1 + (name '$arg)))))) + +(defthm + array2p-m-/ + (implies (and (array2p name M) + (equal (first (dimensions name M)) + (second (dimensions name M)))) + (array2p name (m-/ M))) + :hints (("Goal" + :in-theory + (disable + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1) + :use + (:instance + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1 + (D 1))))) + +(defthm + matrixp-m-/ + (implies (and (matrixp (r M)(c M) M) + (equal (r M)(c M))) + (matrixp (r M)(c M)(m-/ M))) + :hints (("Goal" + :in-theory + (disable + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1) + :use + (:instance + array2p-DETERMINANT-INVERSE-LOOP-COMPRESS2-B-1 + (D 1) + (name '$arg))))) + +(in-theory (disable m-binary-* + m-=)) + +(defthm + Subgoal-7-hack + (IMPLIES (AND (ARRAY2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + (ARRAY2P '$ARG1 + (M-* M + (CADR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 '$ARG (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + 1 + 0 + (+ -1 (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 (CAR (DIMENSIONS '$ARG M)))))))) + :hints (("Goal" + :in-theory (disable ARRAY2P-M-*-1 + array2p-rewrite-linear-1) + :use ((:instance + ARRAY2P-M-*-1 + (name '$arg) + (M1 M) + (M2 (CADR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 '$ARG (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + 1 + 0 + (+ -1 (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 (CAR (DIMENSIONS '$ARG M))))))) + (:instance + array2p-rewrite-linear-1 + (name '$arg)))))) + +(defthm + Subgoal-3-hack + (IMPLIES (AND (ARRAY2P '$C M) + (EQUAL (CAR (DIMENSIONS '$ARG M)) + (CADR (DIMENSIONS '$ARG M)))) + (ARRAY2P '$ARG1 + (M-* (CADR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 '$ARG (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + 1 + 0 + (+ -1 (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 (CAR (DIMENSIONS '$ARG M))))) + M))) + :hints (("Goal" + :in-theory (disable ARRAY2P-M-*-1 + array2p-rewrite-linear-1) + :use ((:instance + ARRAY2P-M-*-1 + (name '$arg) + (M2 M) + (M1 (CADR + (DETERMINANT-INVERSE-LOOP + (COMPRESS2 '$ARG (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG (M-1 (CAR (DIMENSIONS '$ARG M)))) + (COMPRESS2 '$ARG M) + 1 + 0 + (+ -1 (CAR (DIMENSIONS '$ARG M))) + 0 + (+ -1 (CAR (DIMENSIONS '$ARG M))))))) + (:instance + array2p-rewrite-linear-1 + (name '$arg)))))) + +(verify-guards m-singularp) + diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/kalman-slides.pdf.gz b/books/workshops/2003/gamboa-cowles-van-baalen/kalman-slides.pdf.gz Binary files differnew file mode 100644 index 0000000..c08cf9c --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/kalman-slides.pdf.gz diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/kalman-slides.ps.gz b/books/workshops/2003/gamboa-cowles-van-baalen/kalman-slides.ps.gz Binary files differnew file mode 100644 index 0000000..20d5b8b --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/kalman-slides.ps.gz diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/kalman.pdf.gz b/books/workshops/2003/gamboa-cowles-van-baalen/kalman.pdf.gz Binary files differnew file mode 100644 index 0000000..2e28acc --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/kalman.pdf.gz diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/kalman.ps.gz b/books/workshops/2003/gamboa-cowles-van-baalen/kalman.ps.gz Binary files differnew file mode 100644 index 0000000..0e04272 --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/kalman.ps.gz diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/support/certify.lsp b/books/workshops/2003/gamboa-cowles-van-baalen/support/certify.lsp new file mode 100644 index 0000000..0d046a8 --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/support/certify.lsp @@ -0,0 +1,18 @@ +;;; Run this script to certify all the books. But first, certify matalg in +;;; ../../cowles-gamboa-van-baalen_matrix/support/. + +(certify-book "linalg" 0) + +:u + +(ld "defpkg.lisp") + +(certify-book "kalman-defs" 1) + +:u + +(certify-book "kalman-proof" 1 t :skip-proofs-okp t :defaxioms-okp t) + +:u + +(certify-book "kalman-demo" 1 t :skip-proofs-okp t :defaxioms-okp t) diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/support/defpkg.lsp b/books/workshops/2003/gamboa-cowles-van-baalen/support/defpkg.lsp new file mode 100644 index 0000000..bd06d48 --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/support/defpkg.lsp @@ -0,0 +1,4 @@ +(defpkg "KALMAN" + (union-eq *acl2-exports* + *common-lisp-symbols-from-main-lisp-package*)) + diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-defs.acl2 b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-defs.acl2 new file mode 100644 index 0000000..3392efc --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-defs.acl2 @@ -0,0 +1,4 @@ +(value :q) +(lp) +(ld "defpkg.lsp") +(certify-book "kalman-defs" ? t) diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-defs.lisp b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-defs.lisp new file mode 100644 index 0000000..4ff1815 --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-defs.lisp @@ -0,0 +1,805 @@ +; The ACL2 Matrix Algebra Book. Summary of definitions and algebra in matrix.lisp. +; Copyright (C) 2002 Ruben Gamboa and John R. Cowles, University of Wyoming + +; This book is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This book is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this book; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: +; Ruben Gamboa and John Cowles +; Department of Computer Science +; University of Wyoming +; Laramie, WY 82071-3682 U.S.A. + +; Summer and Fall 2002. + +#| + To certify in ACL2 Version 2.6: + + (ld ;; Newline to fool dependency scanner + "defpkg.lisp") + (certify-book "kalman-defs" 1) + +|# + +(in-package "KALMAN") + +(include-book "linalg") + + (set-ignore-ok :warn) + (set-irrelevant-formals-ok :warn) + +(defmacro m-id (n) + `(acl2::m-1 ,n)) + +(defmacro m-zero (m n) + `(acl2::m-0 ,m ,n)) + +(defmacro m-matrixp (m n a) + `(acl2::matrixp ,m ,n ,a)) + +(defmacro l (a) + `(acl2::r ,a)) + +(defmacro c (a) + `(acl2::c ,a)) + +(defmacro m-+ (a b) + `(acl2::m-+ ,a ,b)) + +(defmacro m-- (a b) + `(acl2::m-- ,a ,b)) + +(defmacro m-unary-- (a) + `(acl2::m-- ,a)) + +(defmacro m-* (a b) + `(acl2::m-* ,a ,b)) + +(defmacro s-* (k a) + `(acl2::s-* ,k ,a)) + +(defmacro m-inv (a) + `(acl2::m-/ ,a)) + +(defmacro m-trans (a) + `(acl2::m-trans ,a)) + +(defmacro m-singular (a) + `(acl2::m-singularp ,a)) + +(defmacro m-= (a b) + `(acl2::m-= ,a ,b)) + +(defmacro m-dim-p (n) + `(acl2::m-dim-p ,n)) + +(in-theory (disable acl2::m-1 acl2::m-0 acl2::matrixp acl2::m-binary-+ + acl2::m-unary-- acl2::m-binary-* acl2::s-* acl2::m-/ acl2::m-trans + acl2::m-singularp acl2::m-=)) + +(encapsulate + (((x-0) => *) ; initial value of x + ((phi *) => *) ; steps through an iteration of x + ((ww *) => *) ; iteration step noise + ((q *) => *) ; covariance of step noise + ((h *) => *) ; matrix transforming observable to x + ((v *) => *) ; observation noise + ((r *) => *) ; covariance of observation noise + ((xhatmin-0) => *) ; initial guess for best estimate of x + ((pminus-0) => *) ; initial guess for covariance of estimate + ((n) => *) ; dimension of x + ((m) => *) ; dimension of y + ((m-mean *) => *) ; mean of an expression + ) + + + (set-ignore-ok :warn) + (set-irrelevant-formals-ok :warn) + + (local + (defun n () + 1)) + + (local + (defun m () + 1)) + +; Addition by Matt K. April 2016 to accommodate addition of type-set bit for +; the set {1}. + (local (in-theory (disable (:t n) (:t m)))) + + (local + (defun phi (k) + (m-id (n)))) + + (defthm matrix-phi + (m-matrixp (n) (n) (phi k))) + + (defthm numrows-cols-phi + (and (equal (l (phi k)) (n)) + (equal (c (phi k)) (n))) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n (n)) + (acl2::p (phi k))))))) + (local + (defun ww (k) + (m-zero (n) 1))) + + (defthm matrix-w + (m-matrixp (n) 1 (ww k))) + + (defthm numrows-cols-w + (and (equal (l (ww k)) (n)) + (equal (c (ww k)) 1)) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n 1) + (acl2::p (ww k))))))) + + (local + (defun q (k) + (m-zero (n) (n)))) + + (defthm matrix-q + (m-matrixp (n) (n) (q k))) + + (defthm numrows-cols-q + (and (equal (l (q k)) (n)) + (equal (c (q k)) (n))) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n (n)) + (acl2::p (q k))))))) + + (local + (defun x-0 () + (m-zero (n) 1))) + + (local (in-theory (disable (x-0)))) + + (defthm matrix-x-0 + (m-matrixp (n) 1 (x-0))) + + (defthm numrows-cols-x-0 + (and (equal (l (x-0)) (n)) + (equal (c (x-0)) 1)) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n 1) + (acl2::p (x-0))))))) + + (defun x (k) + (if (zp k) + (x-0) + (m-+ (m-* (phi (1- k)) (x (1- k))) + (ww (1- k))))) + + (defthm matrix-x + (m-matrixp (n) 1 (x k))) + + (defthm numrows-cols-x + (and (equal (l (x k)) (n)) + (equal (c (x k)) 1)) + :hints (("Goal" + :use ((:instance matrix-x) + (:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n 1) + (acl2::p (x k))))))) + + (local + (defun mean-x (k) + (x k))) + + (local + (defun h (k) + (m-zero (m) (n)))) + + (defthm matrix-h + (m-matrixp (m) (n) (h k))) + + (defthm numrows-cols-h + (and (equal (l (h k)) (m)) + (equal (c (h k)) (n))) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (m)) + (acl2::n (n)) + (acl2::p (h k))))))) + + (local + (defun v (k) + (m-zero (m) 1))) + + (defthm matrix-v + (m-matrixp (m) 1 (v k))) + + (defthm numrows-cols-v + (and (equal (l (v k)) (m)) + (equal (c (v k)) 1)) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (m)) + (acl2::n 1) + (acl2::p (v k))))))) + + (defun z (k) + (m-+ (m-* (h k) (x k)) + (v k))) + + (local (defthm matrix-x-1 (ACL2::MATRIXP 1 1 (X K)))) + + (defthm matrix-z + (m-matrixp (m) 1 (z k))) + + (defthm numrows-cols-z + (and (equal (l (z k)) (m)) + (equal (c (z k)) 1)) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (m)) + (acl2::n 1) + (acl2::p (z k))))))) + + (local + (defun r (k) + (m-zero (m) (m)))) + + (defthm matrix-r + (m-matrixp (m) (m) (r k))) + + (defthm numrows-cols-r + (and (equal (l (r k)) (m)) + (equal (c (r k)) (m))) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (m)) + (acl2::n (m)) + (acl2::p (r k))))))) + (local + (defun xhatmin-0 () + (x 0))) + + (defthm matrix-xhatmin-0 + (m-matrixp (n) 1 (xhatmin-0)) + :hints (("Goal" + :expand ((xhatmin-0)) + :in-theory (disable (x) (xhatmin-0))))) + + (defthm numrows-cols-xhatmin-0 + (and (equal (l (xhatmin-0)) (n)) + (equal (c (xhatmin-0)) 1)) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n 1) + (acl2::p (xhatmin-0))) + (:instance matrix-xhatmin-0))))) + + (local + (defun pminus-0 () + (m-zero (n) (n)))) + + (defthm matrix-pminus-0 + (m-matrixp (n) (n) (pminus-0)) + :hints (("Goal" + :expand ((pminus-0)) + :in-theory (disable (pminus-0))))) + + (defthm numrows-cols-pminus-0 + (and (equal (l (pminus-0)) (n)) + (equal (c (pminus-0)) (n))) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n (n)) + (acl2::p (pminus-0))) + (:instance matrix-pminus-0))))) + (local + (defun m-mean (m-expr) + m-expr)) + + (defthm matrix-mean + (implies (m-matrixp m n m-expr) + (m-matrixp m n (m-mean m-expr)))) + + (defthm numrows-cols-mean + (and (equal (l (m-mean m-expr)) (l m-expr)) + (equal (c (m-mean m-expr)) (c m-expr)))) + + (defcong + m-= m-= (m-mean x) 1) + + (defthm mean-trans + (equal (m-mean (m-trans p)) + (m-trans (m-mean p)))) + + (defthm mean-+ + (implies (and (equal (l p) (l q)) + (equal (c p) (c q))) + (equal (m-mean (m-+ p q)) + (m-+ (m-mean p) (m-mean q))))) + + (defthm mean-* + (implies (equal (c p) (l q)) + (equal (m-mean (m-* p q)) + (m-* (m-mean p) (m-mean q))))) + + (defthm mean-unary-- + (equal (m-mean (m-unary-- p)) + (m-unary-- (m-mean p)))) + + (defthm mean-delete + (equal (m-mean p) + p)) + + (defthm mean-of-v-vtrans + (m-= (m-mean (m-* (v k) (m-trans (v k)))) + (r k))) + + (defthm mean-of-w-wtrans + (m-= (m-mean (m-* (ww k) (m-trans (ww k)))) + (q k))) + + (defmacro pminus-body (k) + `(if (zp ,k) + (pminus-0) + (m-+ (m-* (phi (1- ,k)) + (m-* (pplus (1- ,k)) + (m-trans (phi (1- ,k))))) + (q (1- ,k))))) + + (defmacro gain-body (k) + `(m-* (pminus-body ,k) + (m-* (m-trans (h ,k)) + (m-inv (m-+ (m-* (h ,k) + (m-* (pminus-body ,k) + (m-trans (h ,k)))) + (r ,k)))))) + + (defun pplus (k) +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. +; ":Doc-Section ACL2::Programming +; +; estimate of error covariance~/~/ +; " + (if (zp k) + (m-* (m-- (m-id (l (x k))) + (m-* (m-* (pminus-0) + (m-* (m-trans (h k)) + (m-inv (m-+ (m-* (h k) + (m-* (pminus-0) + (m-trans (h k)))) + (r k))))) + (h k))) + (pminus-0)) + (m-* (m-- (m-id (l (x k))) + (m-* (gain-body k) + (h k))) + (pminus-body k)))) + + (defun pminus (k) +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. +; ":Doc-Section ACL2::Programming +; +; a priori estimate of error covariance~/~/ +; " + (pminus-body k)) + + (defun gain (k) +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. +; ":Doc-Section ACL2::Programming +; +; Kalman gain modifies observation residual to get better estimate of x~/~/ +; " + (m-* (pminus k) + (m-* (m-trans (h k)) + (m-inv (m-+ (m-* (h k) + (m-* (pminus k) + (m-trans (h k)))) + (r k)))))) + + + + (defthm pplus-recdef + (implies (and (integerp k) + (<= 0 k)) + (equal (pplus k) + (m-* (m-- (m-id (l (x k))) + (m-* (gain k) + (h k))) + (pminus k)))) + :hints (("Goal" + :in-theory (disable x (x) + h (h) + phi (phi) + q (q) + r (r) + (pminus) (pplus) (gain)))) + :rule-classes ((:definition + :clique (pplus pminus gain) + :controller-alist ((pplus t) + (pminus t) + (gain t))))) + + (defthm pminus-recdef + (implies (and (integerp k) + (< 0 k)) + (equal (pminus k) + (m-+ (m-* (phi (1- k)) + (m-* (pplus (1- k)) + (m-trans (phi (1- k))))) + (q (1- k))))) + :hints (("Goal" + :in-theory (disable x (x) + h (h) + phi (phi) + q (q) + r (r) + pplus-recdef (pminus) (pplus) (gain)))) + :rule-classes ((:definition + :clique (pplus pminus gain) + :controller-alist ((pplus t) + (pminus t) + (gain t))))) + + (defthm gain-recdef + (implies (and (integerp k) + (<= 0 k)) + (equal (gain k) + (m-* (pminus k) + (m-* (m-trans (h k)) + (m-inv (m-+ (m-* (h k) + (m-* (pminus k) + (m-trans (h k)))) + (r k))))))) + :hints (("Goal" + :in-theory (disable x (x) + h (h) + phi (phi) + q (q) + r (r) + pplus-recdef (pminus) (pplus) (gain)))) + :rule-classes ((:definition + :clique (pplus pminus gain) + :controller-alist ((pplus t) + (pminus t) + (gain t))))) + + (in-theory (disable (:definition pminus) + (:definition pplus) + (:definition gain))) + + (defmacro xhat-body (k) + `(m-+ (xhatmin ,k) + (m-* (gain ,k) + (m-- (z ,k) + (m-* (h ,k) (xhatmin ,k)))))) + + (defun xhatmin (k) +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. +; ":Doc-Section ACL2::Programming +; +; estimate of x(k) before seeing measurement z(k)~/~/ +; " + (if (zp k) + (xhatmin-0) + (m-* (phi (1- k)) (xhat-body (1- k))))) + + (defun xhat (k) +;;; Legacy doc string replaced Nov. 2014 by auto-generated defxdoc form +;;; see defxdoc form towards in the last part of this file. +; ":Doc-Section ACL2::Programming +; +; estimate of x(k) using measurement z(k)~/~/ +; " + (xhat-body k)) + + (defthm xhatmin-recdef + (implies (and (integerp k) + (< 0 k)) + (equal (xhatmin k) + (m-* (phi (1- k)) (xhat (1- k))))) + :rule-classes ((:definition + :clique (xhat xhatmin) + :controller-alist ((xhat t) + (xhatmin t))))) + + + (in-theory (disable (:definition xhatmin))) + + (defthm dim-p-m + (m-dim-p (m))) + + (defthm dim-p-n + (m-dim-p (n))) + + (local (in-theory (disable n (n) + m (m) + (x) + (xhatmin-0) + (pminus-0)))) + + (encapsulate + () + + (local + (defthm lemma-1 + (implies (zp k) + (m-matrixp (n) 1 (xhatmin k))) + :hints (("Goal" +; :With directives added 3/13/06 by Matt Kaufmann for after v2-9-4. + :expand ((:with xhatmin (xhatmin k)) (n)))))) + + (local + (defthm lemma-2 + (implies (and (not (zp k)) + (m-matrixp (n) 1 (xhat (1- k)))) + (m-matrixp (n) 1 (xhatmin k))))) + + (defthm lemma-2-5 + (acl2::matrixp (m) (m) (acl2::m-/ (ACL2::M-BINARY-+ (ACL2::M-0 (M) (M)) + (ACL2::M-0 (M) (M))))) + :hints (("Goal" + :use ((:instance acl2::matrix-inv + (acl2::P (ACL2::M-BINARY-+ (ACL2::M-0 (M) (M)) + (ACL2::M-0 (M) (M)))) + (acl2::n (m)))) + :in-theory (disable acl2::matrix-inv)))) + + (local + (defthm lemma-3 + (implies (zp k) + (m-matrixp (n) (n) (pplus k))) + :hints (("Goal" +; :With directives added 3/14/06 by Matt Kaufmann for after v2-9-4. + :expand ((:with pplus (pplus k))))))) + + (local + (defthm lemma-4 + (implies (and (not (zp k)) + (m-matrixp (n) (m) (gain k)) + (m-matrixp (n) (n) (pminus k))) + (m-matrixp (n) (n) (pplus k))))) + + (local + (defthm lemma-5 + (implies (zp k) + (m-matrixp (n) (n) (pminus k))) + :hints (("Goal" +; :With directives added 3/14/06 by Matt Kaufmann for after v2-9-4. + :expand ((:with pminus (pminus k))) + :in-theory (disable gain-recdef pplus-recdef pminus-recdef))))) + + (local + (defthm lemma-6 + (implies (and (not (zp k)) + (or (zp (1- k)) + (and (m-matrixp (n) (m) (gain (1- k))) + (m-matrixp (n) (n) (pminus (1- k)))))) + (m-matrixp (n) (n) (pminus k))) + :hints (("Goal" + :expand ((pminus k)) + :in-theory (disable gain-recdef pplus-recdef pminus-recdef)) + ("Subgoal 2" + :use ((:instance lemma-3 (k (1- k)))) + :in-theory (disable lemma-3 pplus-recdef)) + ("Subgoal 1" + :use ((:instance lemma-4 (k (1- k)))) + :in-theory (disable lemma-4))))) + + (local + (defun natural-induction (k) + (if (zp k) + 1 + (1+ (natural-induction (1- k)))))) + + (local + (defthm matrix-gain-pminus + (and (m-matrixp (n) (n) (pminus k)) + (m-matrixp (n) (m) (gain k))) + :hints (("Goal" + :induct (natural-induction k)) + ("Subgoal *1/2" + :use ((:instance lemma-6)) + :in-theory (disable lemma-6 gain-recdef pminus-recdef)) +; :With directives added 3/14/06 by Matt Kaufmann for after v2-9-4. + ("Subgoal *1/2'''" + :expand ((:with gain (gain k)))) + ("Subgoal *1/1" + :expand ((:with gain (gain k)))) + ("Subgoal *1/1'" + :use ((:instance lemma-5)) + :in-theory (disable lemma-5))))) + + (defthm matrix-gain + (m-matrixp (n) (m) (gain k))) + + (defthm numrows-cols-gain + (and (equal (l (gain k)) (n)) + (equal (c (gain k)) (m))) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n (m)) + (acl2::p (gain k))))))) + + + (defthm matrix-pminus + (m-matrixp (n) (n) (pminus k))) + + (defthm numrows-cols-pminus + (and (equal (l (pminus k)) (n)) + (equal (c (pminus k)) (n))) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n (n)) + (acl2::p (pminus k))))))) + + (defthm matrix-pplus + (m-matrixp (n) (n) (pplus k)) + :hints (("Goal" + :use ((:instance lemma-3) + (:instance lemma-4) + (:instance matrix-gain-pminus)) + :in-theory nil))) + + (defthm numrows-cols-pplus + (and (equal (l (pplus k)) (n)) + (equal (c (pplus k)) (n))) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n (n)) + (acl2::p (pplus k))))))) + + + (local + (defthm lemma-7 + (implies (zp k) + (m-matrixp (n) 1 (xhat k))) + :hints (("Goal" :do-not-induct t + :expand ((xhat k))) + ("Goal'" + :use ((:instance lemma-1)) + :in-theory (disable lemma-1))))) + + (local + (defthm lemma-8 + (implies (and (not (zp k)) + (m-matrixp (n) 1 (xhat (1- k)))) + (m-matrixp (n) 1 (xhat k))) + :hints (("Goal" :do-not-induct t + :in-theory (disable xhatmin-recdef gain-recdef)) + ("Goal'" + :use ((:instance lemma-2)) + :in-theory (disable xhatmin-recdef gain-recdef lemma-2)) + ("Goal''" + :expand ((xhat k)))))) + + + (defthm matrix-xhat + (m-matrixp (n) 1 (xhat k)) + :hints (("Goal" + :induct (natural-induction k)) + ("Subgoal *1/2" + :by (:instance lemma-8)) + ("Subgoal *1/1" + :by (:instance lemma-7)))) + + (defthm numrows-cols-xhat + (and (equal (l (xhat k)) (n)) + (equal (c (xhat k)) 1)) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n 1) + (acl2::p (xhat k))))))) + + (defthm matrix-xhatmin + (m-matrixp (n) 1 (xhatmin k)) + :hints (("Goal" + :use ((:instance lemma-1) + (:instance lemma-2) + (:instance matrix-xhat (k (1- k)))) + :in-theory nil))) + + (defthm numrows-cols-xhatmin + (and (equal (l (xhatmin k)) (n)) + (equal (c (xhatmin k)) 1)) + :hints (("Goal" + :use ((:instance acl2::matrix-p-numrows-cols + (acl2::m (n)) + (acl2::n 1) + (acl2::p (xhatmin k))))))) + ) + + (defthm mean-of-x-xhatmin*vtrans + (m-= (m-mean (m-* (m-+ (x k) + (m-unary-- (xhatmin k))) + (m-trans (v k)))) + (m-zero (n) (m)))) + + (defthm mean-of-v*trans-of-x-xhatmin + (m-= (m-mean (m-* (v k) + (m-trans (m-+ (x k) + (m-unary-- (xhatmin k)))))) + (m-zero (m) (n)))) + + (defthm mean-of-x-xhat*wtrans + (m-= (m-mean (m-* (m-+ (x k) + (m-unary-- (xhat k))) + (m-trans (ww k)))) + (m-zero (n) (n)))) + + (defthm mean-of-w*trans-of-x-xhat + (m-= (m-mean (m-* (ww k) + (m-trans (m-+ (x k) + (m-unary-- (xhat k)))))) + (m-zero (n) (n)))) + + (defthm pminus-0-def + (m-= (pminus-0) + (m-mean (m-* (m-- (x 0) (xhatmin-0)) + (m-trans (m-- (x 0) (xhatmin-0)))))) + :hints (("Goal" + :in-theory (disable (pminus-0) + (x) + (xhatmin-0))))) + + ) + +(in-theory (disable mean-* mean-delete)) + +; The forms below were initially generated automatically from +; legacy documentation strings in this file. + +(include-book "xdoc/top" :dir :system) +(defmacro defxdoc (&rest args) + `(acl2::defxdoc ,@args)) + +(defxdoc kalman::gain + :parents (programming) + :short "Kalman gain modifies observation residual to get better estimate of x" + :long "") + +(defxdoc kalman::pminus + :parents (programming) + :short "A priori estimate of error covariance" + :long "") + +(defxdoc kalman::pplus + :parents (programming) + :short "Estimate of error covariance" + :long "") + +(defxdoc kalman::xhat + :parents (programming) + :short "Estimate of x(k) using measurement z(k)" + :long "") + +(defxdoc kalman::xhatmin + :parents (programming) + :short "Estimate of x(k) before seeing measurement z(k)" + :long "") diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-demo.acl2 b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-demo.acl2 new file mode 100644 index 0000000..84d673b --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-demo.acl2 @@ -0,0 +1,4 @@ +(in-package "ACL2") +(ld "defpkg.lsp") +; cert-flags: ? t :skip-proofs-okp t :defaxioms-okp t +(certify-book "kalman-demo" ? t :skip-proofs-okp t :defaxioms-okp t) diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-demo.lisp b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-demo.lisp new file mode 100644 index 0000000..4c7b869 --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-demo.lisp @@ -0,0 +1,161 @@ +; The ACL2 Matrix Algebra Book. Summary of definitions and algebra in matrix.lisp. +; Copyright (C) 2002 Ruben Gamboa and John R. Cowles, University of Wyoming + +; This book is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This book is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this book; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: +; Ruben Gamboa and John Cowles +; Department of Computer Science +; University of Wyoming +; Laramie, WY 82071-3682 U.S.A. + +; Summer and Fall 2002. +; Last modified 1 November 2002. + +#| + To certify in ACL2 Version 2.6 + + (ld ;; Newline to fool dependency scanner + "defpkg.lsp") + (certify-book "kalman-demo" 1) +|# + +(in-package "KALMAN") + +(include-book "kalman-proof") + +(defun kalman-loop-body (xhatmin-prev pminus-prev k) + (let* ((gain (m-* pminus-prev + (m-* (m-trans (h k)) + (m-inv (m-+ (m-* (h k) + (m-* pminus-prev + (m-trans (h k)))) + (r k)))))) + (xhat (m-+ xhatmin-prev + (m-* gain + (m-- (z k) + (m-* (h k) xhatmin-prev))))) + (pplus (m-* (m-- (m-id (n)) + (m-* gain (h k))) + pminus-prev)) + (xhatmin (m-* (phi k) xhat)) + (pminus (m-+ (m-* (phi k) + (m-* pplus + (m-trans (phi k)))) + (q k)))) + (mv gain xhat pplus xhatmin pminus))) + +(encapsulate + () + + (local + (defthm lemma-1 + (implies (and (integerp k) + (<= 0 k) + (equal xhatmin-prev (xhatmin k)) + (equal pminus-prev (pminus k))) + (mv-let (gain xhat pplus xhatmin pminus) + (kalman-loop-body xhatmin-prev pminus-prev k) + (declare (ignore xhat pplus xhatmin pminus)) + (equal gain (gain k)))) + :hints (("Goal" + :in-theory (disable acl2::*-+-right acl2::*-+-left + acl2::right-distributivity-of-m-*-over-m-+ + acl2::left-distributivity-of-m-*-over-m-+))))) + + (local + (defthm lemma-2 + (implies (and (integerp k) + (<= 0 k) + (equal xhatmin-prev (xhatmin k)) + (equal pminus-prev (pminus k))) + (mv-let (gain xhat pplus xhatmin pminus) + (kalman-loop-body xhatmin-prev pminus-prev k) + (declare (ignore gain pplus xhatmin pminus)) + (equal xhat (xhat k)))) + :hints (("Goal" + :in-theory (disable acl2::*-+-right acl2::*-+-left + acl2::right-distributivity-of-m-*-over-m-+ + acl2::left-distributivity-of-m-*-over-m-+))))) + + (local + (defthm lemma-3 + (implies (and (integerp k) + (<= 0 k) + (equal xhatmin-prev (xhatmin k)) + (equal pminus-prev (pminus k))) + (mv-let (gain xhat pplus xhatmin pminus) + (kalman-loop-body xhatmin-prev pminus-prev k) + (declare (ignore gain xhat xhatmin pminus)) + (equal pplus (pplus k)))) + :hints (("Goal" + :in-theory (disable pplus-as-mean + acl2::*-+-right acl2::*-+-left + acl2::right-distributivity-of-m-*-over-m-+ + acl2::left-distributivity-of-m-*-over-m-+))))) + + (local + (defthm lemma-4 + (implies (and (integerp k) + (<= 0 k) + (equal xhatmin-prev (xhatmin k)) + (equal pminus-prev (pminus k))) + (mv-let (gain xhat pplus xhatmin pminus) + (kalman-loop-body xhatmin-prev pminus-prev k) + (declare (ignore gain xhat pplus pminus)) + (equal xhatmin (xhatmin (1+ k))))) + :hints (("Goal" + :in-theory (disable acl2::*-+-right acl2::*-+-left + acl2::right-distributivity-of-m-*-over-m-+ + acl2::left-distributivity-of-m-*-over-m-+))))) + + (local + (defthm lemma-5 + (implies (and (integerp k) + (<= 0 k) + (equal xhatmin-prev (xhatmin k)) + (equal pminus-prev (pminus k))) + (mv-let (gain xhat pplus xhatmin pminus) + (kalman-loop-body xhatmin-prev pminus-prev k) + (declare (ignore gain xhat pplus xhatmin)) + (equal pminus (pminus (1+ k))))) + :hints (("Goal" + :in-theory (disable pplus-as-mean + pminus-as-mean + pminus-as-mean-almost + acl2::*-+-right acl2::*-+-left + acl2::right-distributivity-of-m-*-over-m-+ + acl2::left-distributivity-of-m-*-over-m-+))))) + + (defthm kalman-loop-invariant + (implies (and (integerp k) + (<= 0 k) + (equal xhatmin-prev (xhatmin k)) + (equal pminus-prev (pminus k))) + (mv-let (gain xhat pplus xhatmin pminus) + (kalman-loop-body xhatmin-prev pminus-prev k) + (and (equal gain (gain k)) + (equal xhat (xhat k)) + (equal pplus (pplus k)) + (equal xhatmin (xhatmin (1+ k))) + (equal pminus (pminus (1+ k)))))) + :hints (("Goal" + :use ((:instance lemma-1) + (:instance lemma-2) + (:instance lemma-3) + (:instance lemma-4) + (:instance lemma-5))))) + ) + diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-proof.acl2 b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-proof.acl2 new file mode 100644 index 0000000..e197566 --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-proof.acl2 @@ -0,0 +1,4 @@ +(in-package "ACL2") +(ld "defpkg.lsp") +; cert-flags: ? t :skip-proofs-okp t :defaxioms-okp t +(certify-book "kalman-proof" ? t :skip-proofs-okp t :defaxioms-okp t) diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-proof.lisp b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-proof.lisp new file mode 100644 index 0000000..dc81da3 --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/support/kalman-proof.lisp @@ -0,0 +1,2271 @@ +; The ACL2 Matrix Algebra Book. Summary of definitions and algebra in matrix.lisp. +; Copyright (C) 2002 Ruben Gamboa and John R. Cowles, University of Wyoming + +; This book is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This book is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this book; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: +; Ruben Gamboa and John Cowles +; Department of Computer Science +; University of Wyoming +; Laramie, WY 82071-3682 U.S.A. + +; Summer and Fall 2002. +; Last modified 1 November 2002. + +#| + To certify in ACL2 Version 2.6 + + (ld ;; Newline to fool dependency scanner + "defpkg.lsp") + (certify-book "kalman-proof" 1) +|# + +(in-package "KALMAN") + +(include-book "kalman-defs") + +(defmacro enable-disable (enable-list disable-list) + (list 'union-theories + (cons 'disable disable-list) + `(quote ,enable-list))) + +(defstub best-estimate-of-x (*) => *) + +(defun best-prior-estimate-of-x (k) + (if (zp k) + (xhatmin k) + (m-* (phi (1- k)) + (best-estimate-of-x (1- k))))) + +(defun result-form (y Xp k) + (m-+ Xp + (m-* y + (m-- (z k) + (m-* (h k) + Xp))))) + +(defun result-form-derivative (y Xp k) + (m-+ (s-* 2 (m-mean (m-* (m-- Xp (x k)) + (m-trans (m-- (z k) + (m-* (h k) Xp)))))) + (s-* 2 (m-* y + (m-mean (m-* (m-- (z k) + (m-* (h k) Xp)) + (m-trans (m-- (z k) + (m-* (h k) Xp))))))))) + +(defaxiom best-estimate-of-x-def + (implies (and (m-= (best-prior-estimate-of-x k) Xp) + (m-= (result-form-derivative y Xp k) (m-zero (n) (m)))) + (m-= (best-estimate-of-x k) + (result-form y Xp k)))) + +(skip-proofs + (defthm non-singular-gain-component + (not (m-singular (m-mean (m-* (m-+ (z k) + (m-unary-- (m-* (h k) (xhatmin k)))) + (m-+ (m-trans (z k)) + (m-unary-- (m-* (m-trans (xhatmin k)) + (m-trans (h k))))))))))) + +(skip-proofs + (defthm non-singular-gain-component-2 + (not (m-singular (m-+ (r k) (m-* (h k) (m-* (pminus k) (m-trans (h k))))))))) + +(defthm pminus-as-mean-case-0 + (implies (= k 0) + (m-= (pminus k) + (m-mean (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (x k) (xhatmin k))))))) + :hints (("Goal" + :expand ((pminus k)) + :in-theory (enable-disable (pminus xhatmin) + (x ; added by Matt K. for v2-8, 7/31/03 + (pminus) (xhatmin)))))) + +(encapsulate + () + + (local + (defthm lemma-1 + (implies (and (integerp k) + (< 0 k)) + (equal (m-- (x k) (xhatmin k)) + (m-- (m-+ (m-* (phi (1- k)) (x (1- k))) + (ww (1- k))) + (m-* (phi (1- k)) + (xhat (1- k)))))) + :hints (("Goal" :do-not-induct t + :in-theory (disable xhat))) + :rule-classes nil)) + + (local + (defthm lemma-2 + (implies (and (integerp k) + (< 0 k)) + (equal (m-- (x k) (xhatmin k)) + (m-+ (m-* (phi (1- k)) + (m-- (x (1- k)) + (xhat (1- k)))) + (ww (1- k))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-1) + (:instance (:theorem + (implies (and (m-matrixp (l phi) (c phi) phi) + (m-matrixp (l x) (c x) x) + (m-matrixp (l xhat) (c xhat) xhat) + (m-matrixp (l ww) (c x) ww) + (equal (c phi) (l x)) + (equal (l phi) (l ww)) + (equal (c x) (c ww)) + (equal (c phi) (l xhat)) + (equal (c x) (c xhat)) + (equal (l x) (l xhat))) + (equal (m-- (m-+ (m-* phi x) + ww) + (m-* phi xhat)) + (m-+ (m-* phi (m-- x xhat)) + ww)))) + (phi (phi (1- k))) + (x (x (1- k))) + (ww (ww (1- k))) + (xhat (xhat (1- k)))))) + ("Subgoal 2'" :in-theory nil)) + :rule-classes nil)) + + (local + (defthm lemma-3a + (implies (and (m-matrixp (l a) (c a) a) + (m-matrixp (l b) (c b) b) + (equal (l a) (l b)) + (equal (c a) (c b))) + (m-= (m-* (m-+ a b) + (m-trans (m-+ a b))) + (m-+ (m-* a (m-trans a)) + (m-+ (m-* a (m-trans b)) + (m-+ (m-* b (m-trans a)) + (m-* b (m-trans b))))))) + :rule-classes nil)) + + (local + (defthm lemma-3b-1 + (implies (and (m-= (m-* (m-+ (m-* phi (m-+ x (m-unary-- xhat))) ww) + (m-trans (m-+ (m-* phi (m-+ x (m-unary-- xhat))) ww))) + (m-+ (m-* phi + (m-* (m-+ x (m-unary-- xhat)) + (m-trans (m-* phi + (m-+ x + (m-unary-- xhat)))))) + (m-+ (m-* phi (m-* (m-+ x (m-unary-- xhat)) + (m-trans ww))) + (m-+ (m-* ww + (m-trans (m-* phi + (m-+ x + (m-unary-- xhat))))) + (m-* ww (m-trans ww)))))) + (m-matrixp (l x) (c x) x) + (m-matrixp (l xhat) (c xhat) xhat) + (m-matrixp (l phi) (c phi) phi) + (m-matrixp (l ww) (c ww) ww) + (equal (l phi) (l ww)) + (equal (c x) (c ww)) + (equal (c phi) (l x)) + (equal (c ww) (c xhat)) + (equal (l x) (l xhat))) + (m-= (m-* (m-+ (m-* phi (m-+ x (m-unary-- xhat))) ww) + (m-trans (m-+ (m-* phi (m-+ x (m-unary-- xhat))) ww))) + (m-+ (m-* phi (m-* (m-+ x (m-unary-- xhat)) + (m-* (m-trans (m-+ x (m-unary-- xhat))) + (m-trans phi)))) + (m-+ (m-* phi (m-* (m-+ x (m-unary-- xhat)) (m-trans ww))) + (m-+ (m-* ww (m-* (m-trans (m-+ x (m-unary-- xhat))) + (m-trans phi))) + (m-* ww (m-trans ww))))))) + :hints (("Goal" + :use ((:instance acl2::trans-* + (acl2::p phi) + (acl2::q (m-- x xhat)))) + :in-theory (disable acl2::trans-* + acl2::*-+-right + acl2::*-+-left))) + :rule-classes nil)) + + (local + (defthm lemma-3b + (implies (and (m-matrixp (l x) (c x) x) + (m-matrixp (l xhat) (c xhat) xhat) + (m-matrixp (l phi) (c phi) phi) + (m-matrixp (l ww) (c ww) ww) + (equal (c phi) (l x)) + (equal (l phi) (l ww)) + (equal (c x) (c ww)) + (equal (c phi) (l xhat)) + (equal (c x) (c xhat)) + (equal (l x) (l xhat))) + (m-= (m-* (m-+ (m-* phi (m-- x xhat)) ww) + (m-trans (m-+ (m-* phi (m-- x xhat)) ww))) + (m-+ (m-* (m-* phi (m-- x xhat)) (m-* (m-trans (m-- x xhat)) + (m-trans phi))) + (m-+ (m-* (m-* phi (m-- x xhat)) (m-trans ww)) + (m-+ (m-* ww (m-* (m-trans (m-- x xhat)) + (m-trans phi))) + (m-* ww (m-trans ww))))))) + :hints (("Goal" + :use ((:instance lemma-3a + (a (m-* phi (m-- x xhat))) + (b ww)))) + ("Goal''" + :use ((:instance lemma-3b-1)) + :in-theory (disable acl2::trans-* + acl2::*-+-right + acl2::*-+-left))) + :rule-classes nil)) + + (local + (defthm lemma-3 + (m-= (m-* (m-+ (m-* (phi (1- k)) (m-- (x (1- k)) (xhat (1- k)))) + (ww (1- k))) + (m-trans (m-+ (m-* (phi (1- k)) + (m-- (x (1- k)) (xhat (1- k)))) + (ww (1- k))))) + (m-+ (m-* (m-* (phi (1- k)) + (m-- (x (1- k)) (xhat (1- k)))) + (m-* (m-trans (m-- (x (1- k)) (xhat (1- k)))) + (m-trans (phi (1- k))))) + (m-+ (m-* (m-* (phi (1- k)) + (m-- (x (1- k)) (xhat (1- k)))) + (m-trans (ww (1- k)))) + (m-+ (m-* (ww (1- k)) + (m-* (m-trans (m-- (x (1- k)) + (xhat (1- k)))) + (m-trans (phi (1- k))))) + (m-* (ww (1- k)) (m-trans (ww (1- k)))))))) + :hints (("Goal" + :use ((:instance lemma-3b + (phi (phi (1- k))) + (x (x (1- k))) + (ww (ww (1- k))) + (xhat (xhat (1- k))))))) + :rule-classes nil)) + + (local + (defthm lemma-4a + (m-= (M-MEAN + (ACL2::M-BINARY-* (PHI (+ -1 K)) + (ACL2::M-BINARY-* (ACL2::M-BINARY-+ (X (+ -1 K)) + (ACL2::M-UNARY-- (XHAT (+ -1 K)))) + (ACL2::M-TRANS (WW (+ -1 K)))))) + (m-zero (n) (n))) + :hints (("Goal" :do-not-induct t + :use ((:instance mean-* + (p (phi (+ -1 k))) + (q (m-* (m-+ (x (+ -1 k)) + (m-unary-- (xhat (+ -1 k)))) + (m-trans (ww (+ -1 k)))))) + (:instance mean-of-x-xhat*wtrans + (k (1- k)))) + :in-theory (disable xhat z + acl2::*-+-right + mean-of-x-xhat*wtrans))))) + + (local + (defthm lemma-4b + (m-= (M-MEAN + (ACL2::M-BINARY-* (WW (+ -1 K)) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X (+ -1 K))) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHAT (+ -1 K))))) + (ACL2::M-TRANS (PHI (+ -1 K)))))) + (m-zero (n) (n))) + :hints (("Goal" :do-not-induct t + :use ((:instance mean-* + (p (m-* (ww (+ -1 k)) + (m-+ (m-trans (x (+ -1 k))) + (m-unary-- (m-trans (xhat (+ -1 k))))))) + (q (m-trans (phi (+ -1 k))))) + (:instance mean-of-w*trans-of-x-xhat + (k (1- k)))) + :in-theory (disable xhat z + acl2::*-+-right + mean-of-w*trans-of-x-xhat))))) + + + (local + (defthm lemma-4c + (m-= (M-MEAN + (ACL2::M-BINARY-* (PHI (+ -1 K)) + (ACL2::M-BINARY-* (ACL2::M-BINARY-+ (X (+ -1 K)) + (ACL2::M-UNARY-- (XHAT (+ -1 K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X (+ -1 K))) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHAT (+ -1 K))))) + (ACL2::M-TRANS (PHI (+ -1 K))))))) + (m-* (m-* (phi (1- k)) + (m-mean (m-* (m-+ (x (+ -1 k)) + (m-unary-- (xhat (+ -1 k)))) + (m-trans (m-+ (x (+ -1 k)) + (m-unary-- (xhat (+ -1 k)))))))) + (m-trans (phi (1- k))))) + :hints (("Goal" :do-not-induct t + :use ((:instance mean-* + (p (m-* (phi (1- k)) + (m-* (m-+ (x (+ -1 k)) + (m-unary-- (xhat (+ -1 k)))) + (m-trans (m-+ (x (+ -1 k)) + (m-unary-- (xhat (+ -1 k)))))))) + (q (m-trans (phi (+ -1 k))))) + (:instance mean-* + (p (phi (+ -1 k))) + (q (m-* (m-+ (x (+ -1 k)) + (m-unary-- (xhat (+ -1 k)))) + (m-trans (m-+ (x (+ -1 k)) + (m-unary-- (xhat (+ -1 k)))))))) + (:instance mean-delete + (p (phi (1- k))))) + :in-theory (disable xhat z acl2::*-+-right))))) + + (local + (defthm lemma-4-1 + (acl2::m-= + (m-mean + (acl2::m-binary-+ + (acl2::m-binary-* + (phi (+ -1 k)) + (acl2::m-binary-* + (acl2::m-binary-+ (x (+ -1 k)) + (acl2::m-unary-- (xhat (+ -1 k)))) + (acl2::m-binary-* + (acl2::m-binary-+ (acl2::m-trans (x (+ -1 k))) + (acl2::m-unary-- (acl2::m-trans (xhat (+ -1 k))))) + (acl2::m-trans (phi (+ -1 k)))))) + (acl2::m-binary-+ + (acl2::m-binary-* + (phi (+ -1 k)) + (acl2::m-binary-* (acl2::m-binary-+ (x (+ -1 k)) + (acl2::m-unary-- (xhat (+ -1 k)))) + (acl2::m-trans (ww (+ -1 k))))) + (acl2::m-binary-+ + (acl2::m-binary-* (ww (+ -1 k)) + (acl2::m-trans (ww (+ -1 k)))) + (acl2::m-binary-* + (ww (+ -1 k)) + (acl2::m-binary-* + (acl2::m-binary-+ (acl2::m-trans (x (+ -1 k))) + (acl2::m-unary-- (acl2::m-trans (xhat (+ -1 k))))) + (acl2::m-trans (phi (+ -1 k))))))))) + (acl2::m-binary-+ + (q (+ -1 k)) + (acl2::m-binary-* + (phi (+ -1 k)) + (acl2::m-binary-* + (m-mean + (acl2::m-binary-* + (acl2::m-binary-+ (x (+ -1 k)) + (acl2::m-unary-- (xhat (+ -1 k)))) + (acl2::m-binary-+ (acl2::m-trans (x (+ -1 k))) + (acl2::m-unary-- (acl2::m-trans (xhat (+ -1 k))))))) + (acl2::m-trans (phi (+ -1 k))))))) + :hints (("Goal" :in-theory (disable acl2::*-+-right + acl2::*---right + acl2::*-+-left + acl2::*---left + acl2::right-distributivity-of-m-*-over-m-+ + acl2::left-distributivity-of-m-*-over-m-+ + xhat x z xhatmin-recdef gain-recdef))))) + + (local + (defthm lemma-4 + (m-= (m-mean (m-* (m-+ (m-* (phi (1- k)) (m-- (x (1- k)) (xhat (1- k)))) + (ww (1- k))) + (m-trans (m-+ (m-* (phi (1- k)) + (m-- (x (1- k)) (xhat (1- k)))) + (ww (1- k)))))) + (m-+ (m-* (m-* (phi (1- k)) + (m-mean (m-* (m-- (x (1- k)) (xhat (1- k))) + (m-trans (m-- (x (1- k)) (xhat (1- k))))))) + (m-trans (phi (1- k)))) + (q (1- k)))) + :hints (("Goal" + :use ((:instance lemma-3)) + :in-theory nil) + ("Goal'" + :use ((:theorem (m-= + (m-mean + (m-+ (m-* (m-* (phi (+ -1 k)) + (m-- (x (+ -1 k)) (xhat (+ -1 k)))) + (m-* (m-trans (m-- (x (+ -1 k)) (xhat (+ -1 k)))) + (m-trans (phi (+ -1 k))))) + (m-+ (m-* (m-* (phi (+ -1 k)) + (m-- (x (+ -1 k)) (xhat (+ -1 k)))) + (m-trans (ww (+ -1 k)))) + (m-+ (m-* (ww (+ -1 k)) + (m-* (m-trans (m-- (x (+ -1 k)) (xhat (+ -1 k)))) + (m-trans (phi (+ -1 k))))) + (m-* (ww (+ -1 k)) + (m-trans (ww (+ -1 k)))))))) + (m-+ (m-* (m-* (phi (+ -1 k)) + (m-mean (m-* (m-- (x (+ -1 k)) (xhat (+ -1 k))) + (m-trans (m-- (x (+ -1 k)) (xhat (+ -1 k))))))) + (m-trans (phi (+ -1 k)))) + (q (+ -1 k)))))) + :in-theory (disable acl2::*-+-right + acl2::*---right + acl2::*-+-left + acl2::*---left + acl2::right-distributivity-of-m-*-over-m-+ + acl2::left-distributivity-of-m-*-over-m-+ + acl2::commutativity-2-of-m-+ + xhat + x + z + xhatmin-recdef + gain-recdef))) + :rule-classes nil)) + + (local + (defthm lemma-5 + (implies (and (integerp k) + (< 0 k)) + (m-= (m-mean (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (x k) (xhatmin k))))) + (m-+ (m-* (m-* (phi (1- k)) + (m-mean (m-* (m-- (x (1- k)) (xhat (1- k))) + (m-trans (m-- (x (1- k)) (xhat (1- k))))))) + (m-trans (phi (1- k)))) + (q (1- k))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-2) + (:instance lemma-4)) + :in-theory (disable x xhat xhatmin-recdef + acl2::*-+-right + acl2::*---right + acl2::*-+-left + acl2::*---left + acl2::right-distributivity-of-m-*-over-m-+ + acl2::left-distributivity-of-m-*-over-m-+ + acl2::commutativity-2-of-m-+))) + :rule-classes nil)) + + (defthm pminus-as-mean-almost + (implies (and (integerp k) + (< 0 k) + (m-= (pplus (1- k)) + (m-mean (m-* (m-- (x (1- k)) + (xhat (1- k))) + (m-trans (m-- (x (1- k)) + (xhat (1- k)))))))) + (m-= (pminus k) + (m-mean (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (x k) (xhatmin k))))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-5)) + :in-theory (disable x xhat xhatmin + gain-recdef pplus-recdef xhatmin-recdef + acl2::*-+-right + acl2::*---right + acl2::*-+-left + acl2::*---left + acl2::right-distributivity-of-m-*-over-m-+ + acl2::left-distributivity-of-m-*-over-m-+ + acl2::commutativity-2-of-m-+)))) + ) + +(defthm matrix-*-trans + (implies (and (equal m (l x)) + (equal n (l x)) + (m-matrixp m n x)) + (m-matrixp m n (m-* x (m-trans x))))) + +(defthm id-*-x-useful + (implies (and (equal (l p) n) + (m-matrixp (l p) (c p) p)) + (m-= (m-* (m-id n) p) p)) + :hints (("Goal" + :use ((:instance acl2::id-*-x + (acl2::n (l p)) + (acl2::n2 (c p)) + (acl2::p p))) + :in-theory (disable acl2::id-*-x)))) + +(defthm x-*-id-useful + (implies (and (equal (c p) n) + (m-matrixp (l p) (c p) p)) + (m-= (m-* p (m-id n)) p)) + :hints (("Goal" + :use ((:instance acl2::x-*-id + (acl2::m (l p)) + (acl2::n (c p)) + (acl2::p p))) + :in-theory (disable acl2::x-*-id)))) + +(encapsulate + () + + (local + (defthm lemma-1 + (m-= (m-- (x k) (xhat k)) + (m-- (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-- (x k) (xhatmin k))) + (m-* (gain k) + (v k)))) + :hints (("Goal" :do-not-induct t + :use ((:instance acl2::id-*-x + (acl2::p (x k)) + (acl2::n (n)) + (acl2::n2 1)) + (:instance acl2::id-*-x + (acl2::p (xhatmin k)) + (acl2::n (n)) + (acl2::n2 1))) + :in-theory (disable acl2::id-*-x))) + :rule-classes nil)) + + + (local + (defthm lemma-2a + (implies (and (equal (l a) (l b)) + (equal (c a) (c b)) + (m-matrixp (l b) (c b) b) + (m-matrixp (l a) (c a) a)) + (m-= (m-* (m-- a b) + (m-trans (m-- a b))) + (m-+ (m-* a (m-trans a)) + (m-+ (m-unary-- (m-* a (m-trans b))) + (m-+ (m-unary-- (m-* b (m-trans a))) + (m-* b (m-trans b))))))) + :hints (("Goal" + :use ((:instance acl2::unary---unary-- + (acl2::p (m-* b (m-trans b))))) + :in-theory (disable acl2::unary---unary--))) + :rule-classes nil)) + + (local + (defthm lemma-2 + (m-= (m-* (m-- (x k) (xhat k)) + (m-trans (m-- (x k) (xhat k)))) + (m-+ (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-* (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (x k) (xhatmin k)))) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))) + (m-+ (m-unary-- (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-* (m-* (m-- (x k) (xhatmin k)) + (m-trans (v k))) + (m-trans (gain k))))) + (m-+ (m-unary-- (m-* (gain k) + (m-* (m-* (v k) + (m-trans (m-- (x k) (xhatmin k)))) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k))))))) + (m-* (gain k) + (m-* (m-* (v k) + (m-trans (v k))) + (m-trans (gain k)))))))) + :hints (("Goal" + :use ((:instance lemma-1) + (:instance lemma-2a + (a (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-- (x k) (xhatmin k)))) + (b (m-* (gain k) + (v k))))) + :in-theory (disable x xhat xhatmin + gain-recdef pplus-recdef xhatmin-recdef + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))) + :rule-classes nil)) + + + (local + (defthm lemma-3a1 + (and (equal (l (m-- (x k) (xhatmin k))) (n)) + (equal (c (m-- (m-id (n)) (m-* (gain k) (h k)))) (n))))) + + (local + (defthm lemma-3a + (m-= (m-mean (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))) + (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-* (m-mean (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (x k) (xhatmin k))))) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k))))))) + :hints (("Goal" + :use ((:instance mean-* + (p (m-- (m-id (n)) + (m-* (gain k) (h k)))) + (q (m-* (m-- (x k) (xhatmin k)) + (m-* (m-trans (m-- (x k) (xhatmin k))) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))))) + (:instance mean-* + (p (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (x k) (xhatmin k))))) + (q (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))) + (:instance mean-delete + (p (m-id (n)))) + (:instance mean-delete + (p (m-* (gain k) (h k))))) + :in-theory (disable x xhatmin gain gain-recdef + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ;acl2::trans-* acl2::trans-+ acl2::trans--- + ))))) + + (local + (defthm lemma-3b + (m-= (m-mean (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* (ACL2::M-TRANS (V K)) + (ACL2::M-TRANS (GAIN K))))))) + (m-zero (n) (n))) + :hints (("Goal" :do-not-induct t + :use ((:instance mean-* + (p (m-- (m-id (n)) + (m-* (gain k) (h k)))) + (q (m-* (m-* (m-- (x k) (xhatmin k)) + (m-trans (v k))) + (m-trans (gain k))))) + (:instance mean-* + (p (m-* (m-- (x k) (xhatmin k)) + (m-trans (v k)))) + (q (m-trans (gain k)))) + (:instance mean-of-x-xhatmin*vtrans)) + :in-theory (disable mean-of-x-xhatmin*vtrans + mean-+ + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ))))) + + (local + (defthm lemma-3c + (m-= (M-MEAN + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* + (V K) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K)))))))))) + + + (m-zero (n) (n))) + :hints (("Goal" :do-not-induct t + :use ((:instance mean-* + (p (gain k)) + (q (m-* (m-* (v k) + (m-trans (m-- (x k) (xhatmin k)))) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k))))))) + (:instance mean-* + (p (m-* (v k) + (m-trans (m-- (x k) (xhatmin k))))) + (q (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))) + (:instance mean-of-v*trans-of-x-xhatmin)) + :in-theory (disable mean-of-v*trans-of-x-xhatmin + mean-+ + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ))))) + + + (local + (defthm lemma-3d + (equal (m-mean (m-* (gain k) + (m-* (v k) + (m-* (m-trans (v k)) + (m-trans (gain k)))))) + (m-* (gain k) + (m-* (r k) + (m-trans (gain k))))) + :hints (("Goal" + :use ((:instance mean-* + (p (gain k)) + (q (m-* (m-* (v k) + (m-trans (v k))) + (m-trans (gain k))))) + (:instance mean-* + (p (m-* (v k) + (m-trans (v k)))) + (q (m-trans (gain k)))) + (:instance mean-delete + (p (gain k)))) + :in-theory (disable gain gain-recdef))))) + + + + + (local + (defthm lemma-3e + + (EQUAL + (CAR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* (V K) + (ACL2::M-BINARY-* (ACL2::M-TRANS (V K)) + (ACL2::M-TRANS (GAIN K))))))) + (CAR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-BINARY-+ + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* (ACL2::M-TRANS (V K)) + (ACL2::M-TRANS (GAIN K)))))) + (ACL2::M-BINARY-+ + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* + (V K) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))))))) + :hints (("Goal" + :in-theory (disable gain gain-recdef x xhat xhatmin + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))))) + + (local + (defthm lemma-3f + + (EQUAL + (CADR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* (V K) + (ACL2::M-BINARY-* (ACL2::M-TRANS (V K)) + (ACL2::M-TRANS (GAIN K))))))) + (CADR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-BINARY-+ + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* (ACL2::M-TRANS (V K)) + (ACL2::M-TRANS (GAIN K)))))) + (ACL2::M-BINARY-+ + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* + (V K) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))))))) + :hints (("Goal" + :in-theory (disable gain gain-recdef x xhat xhatmin + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))))) + + (local + (defthm lemma-3g + + (EQUAL + (CAR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* (ACL2::M-TRANS (V K)) + (ACL2::M-TRANS (GAIN K)))))))) + (CAR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-BINARY-+ + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* + (V K) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K)))))))))))) + + :hints (("Goal" + :in-theory (disable gain gain-recdef x xhat xhatmin + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))))) + + (local + (defthm lemma-3h + + (EQUAL + (CADR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* (ACL2::M-TRANS (V K)) + (ACL2::M-TRANS (GAIN K)))))))) + (CADR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-BINARY-+ + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* + (V K) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K)))))))))))) + + :hints (("Goal" + :in-theory (disable gain gain-recdef x xhat xhatmin + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))))) + + (local + (defthm lemma-3i + + (EQUAL + (CAR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* + (V K) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))))) + (CAR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))))) + + :hints (("Goal" + :in-theory (disable gain gain-recdef x xhat xhatmin + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))))) + + (local + (defthm lemma-3j + + (EQUAL + (CADR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* + (V K) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))))) + (CADR + (DIMENSIONS + 'ACL2::$ARG + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))))) + + :hints (("Goal" + :in-theory (disable gain gain-recdef x xhat xhatmin + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))))) + + + + (local + (defthm lemma-3k + + (ACL2::M-= + (ACL2::M-BINARY-+ + (ACL2::M-0 (N) (N)) + (ACL2::M-BINARY-+ + (ACL2::M-0 (N) (N)) + (ACL2::M-BINARY-+ + (ACL2::M-BINARY-* (GAIN K) + (ACL2::M-BINARY-* (R K) + (ACL2::M-TRANS (GAIN K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (M-MEAN + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-TRANS (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K)))))) + (ACL2::M-TRANS + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) + (H K)))))))))) + (ACL2::M-BINARY-+ + (ACL2::M-BINARY-* (GAIN K) + (ACL2::M-BINARY-* (R K) + (ACL2::M-TRANS (GAIN K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (M-MEAN + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))) + + :hints (("Goal" + :in-theory (disable gain gain-recdef x xhat xhatmin + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))))) + + + (local + (DEFTHM + lemma-3l + (ACL2::M-= + (M-MEAN + (ACL2::M-BINARY-+ + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* (V K) + (ACL2::M-BINARY-* (ACL2::M-TRANS (V K)) + (ACL2::M-TRANS (GAIN K))))) + (ACL2::M-BINARY-+ + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* (ACL2::M-TRANS (V K)) + (ACL2::M-TRANS (GAIN K)))))) + (ACL2::M-BINARY-+ + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* + (GAIN K) + (ACL2::M-BINARY-* + (V K) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- + (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K)))))))))))) + (ACL2::M-BINARY-+ + (ACL2::M-BINARY-* (GAIN K) + (ACL2::M-BINARY-* (R K) + (ACL2::M-TRANS (GAIN K)))) + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (GAIN K) (H K)))) + (ACL2::M-BINARY-* + (M-MEAN + (ACL2::M-BINARY-* + (ACL2::M-BINARY-+ (X K) + (ACL2::M-UNARY-- (XHATMIN K))) + (ACL2::M-BINARY-+ (ACL2::M-TRANS (X K)) + (ACL2::M-UNARY-- (ACL2::M-TRANS (XHATMIN K)))))) + (ACL2::M-BINARY-+ + (ACL2::M-1 (N)) + (ACL2::M-UNARY-- (ACL2::M-BINARY-* (ACL2::M-TRANS (H K)) + (ACL2::M-TRANS (GAIN K))))))))) + :INSTRUCTIONS + ((:DV 1) + (:REWRITE MEAN-+) + (:CHANGE-GOAL NIL T) + (:USE LEMMA-3E) + (:USE LEMMA-3F) + (:DV 1) + (:REWRITE LEMMA-3D) + :NX (:REWRITE MEAN-+) + (:CHANGE-GOAL NIL T) + (:USE LEMMA-3G) + (:USE LEMMA-3H) + (:DV 1) + (:REWRITE LEMMA-3B) + :NX (:REWRITE MEAN-+) + (:CHANGE-GOAL NIL T) + (:USE LEMMA-3I) + (:USE LEMMA-3J) + (:DV 1) + (:REWRITE LEMMA-3C) + :NX (:REWRITE LEMMA-3A) + :TOP (:DV 1) + (:REWRITE ACL2::COMMUTATIVITY-2-OF-M-+) + (:DIVE 2) ; changed by Matt K. for v2-9 due to proof-builder DV fix for binops + (:REWRITE ACL2::COMMUTATIVITY-2-OF-M-+) + :TOP (:USE LEMMA-3K)))) + + (local + (defthm lemma-3 + (m-= (m-mean (m-* (m-- (x k) (xhat k)) + (m-trans (m-- (x k) (xhat k))))) + (m-+ (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-* (m-mean (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (x k) (xhatmin k))))) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))) + (m-* (gain k) + (m-* (r k) + (m-trans (gain k)))))) + :hints (("Goal" + :use ((:instance lemma-2)) + :in-theory (disable x xhat xhatmin + gain-recdef pplus-recdef xhatmin-recdef + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + )) + ("Goal'4'" + :by (:instance lemma-3l))) + :rule-classes nil)) + + (local + (defthm lemma-4 + (m-= (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-* (pminus k) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))) + (m-+ (pminus k) + (m-+ (m-unary-- (m-* (gain k) (m-* (h k) (pminus k)))) + (m-+ (m-unary-- (m-* (pminus k) + (m-* (m-trans (h k)) + (m-trans (gain k))))) + (m-* (gain k) + (m-* (h k) + (m-* (pminus k) + (m-* (m-trans (h k)) + (m-trans (gain k)))))))))) + :hints (("Goal" :do-not-induct t + :in-theory (disable gain gain-recdef + pminus pminus-recdef))) + :rule-classes nil)) + + (local + (defthm lemma-5 + (m-= (m-+ (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-* (pminus k) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))) + (m-* (gain k) + (m-* (r k) + (m-trans (gain k))))) + (m-+ (pminus k) + (m-+ (m-unary-- (m-* (gain k) (m-* (h k) (pminus k)))) + (m-+ (m-unary-- (m-* (pminus k) + (m-* (m-trans (h k)) + (m-trans (gain k))))) + (m-+ (m-* (gain k) + (m-* (h k) + (m-* (pminus k) + (m-* (m-trans (h k)) + (m-trans (gain k)))))) + (m-* (gain k) + (m-* (r k) + (m-trans (gain k))))))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-4)) + :in-theory (disable gain gain-recdef + pminus pminus-recdef))) + :rule-classes nil)) + + (local + (defthm lemma-6 + (m-= (m-+ (m-* (gain k) + (m-* (h k) + (m-* (pminus k) + (m-* (m-trans (h k)) + (m-trans (gain k)))))) + (m-* (gain k) + (m-* (r k) + (m-trans (gain k))))) + (m-* (gain k) + (m-* (m-+ (m-* (h k) (m-* (pminus k) (m-trans (h k)))) + (r k)) + (m-trans (gain k))))) + :hints (("Goal" + :in-theory (disable gain gain-recdef pminus pminus-recdef))) + :rule-classes nil)) + + (local + (defthm lemma-7a + (implies (and (not (m-singular x)) + (m-matrixp (l x) (c x) x) + (m-matrixp (l y) (c y) y) + (equal (c v) (l w)) + (equal (c w) (l x)) + (equal (c x) (l y))) + (m-= (m-* v + (m-* w + (m-* (m-inv x) + (m-* x y)))) + (m-* v (m-* w y)))) + :hints (("Goal" + :use ((:instance acl2::assoc-* + (acl2::p (m-inv x)) + (acl2::q x) + (acl2::r y)) + (:instance acl2::inv-*-x + (acl2::p x))) + :in-theory (disable acl2::assoc-* + acl2::inv-*-x)) + ("Goal'4'" + :in-theory (enable acl2::assoc-*))))) + + (local + (defthm lemma-7 + (implies (and (integerp k) (<= 0 k)) + (m-= (m-+ (m-* (gain k) + (m-* (h k) + (m-* (pminus k) + (m-* (m-trans (h k)) + (m-trans (gain k)))))) + (m-* (gain k) + (m-* (r k) + (m-trans (gain k))))) + (m-* (pminus k) + (m-* (m-trans (h k)) (m-trans (gain k)))))) + :hints (("Goal" + :use ((:instance lemma-6)) + :in-theory (disable gain pminus pminus-recdef + acl2::assoc-* + acl2::comm-+ + ACL2::*-+-RIGHT + ACL2::*---RIGHT + ACL2::*-+-left + ACL2::*---left + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::left-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + acl2::COMMUTATIVITY-2-OF-M-+ + )) + ("Goal'''" + :use (:theorem + (implies (and (integerp k) (<= 0 k)) + (m-= (m-* (gain k) + (m-* (m-+ (m-* (h k) + (m-* (pminus k) (m-trans (h k)))) + (r k)) + (m-trans (gain k)))) + (m-* (pminus k) + (m-* (m-trans (h k)) + (m-trans (gain k)))))))) + ("Subgoal 1" + :in-theory (disable gain pminus pminus-recdef + ;acl2::comm-+ + ACL2::*-+-RIGHT + ACL2::*---RIGHT + ACL2::*-+-left + ACL2::*---left + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::left-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + acl2::COMMUTATIVITY-2-OF-M-+ + )) + ) + :rule-classes nil)) + + (local + (defthm lemma-8 + (implies (and (integerp k) (<= 0 k)) + (m-= (m-+ (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-* (pminus k) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))) + (m-* (gain k) + (m-* (r k) + (m-trans (gain k))))) + (m-- (pminus k) + (m-* (gain k) (m-* (h k) (pminus k)))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-5) + (:instance lemma-6) + (:instance lemma-7)) + :in-theory (disable gain gain-recdef + pminus pminus-recdef + acl2::assoc-* + acl2::comm-+ + ACL2::*-+-RIGHT + ACL2::*---RIGHT + ACL2::*-+-left + ACL2::*---left + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::left-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + acl2::COMMUTATIVITY-2-OF-M-+ + acl2::trans-* + acl2::trans-+ + acl2::trans---)) + ("Goal'7'" + :by (:theorem + (m-= (m-+ (pminus k) + (m-+ (m-unary-- (m-* (gain k) (m-* (h k) (pminus k)))) + (m-zero (n) (n)))) + (m-- (pminus k) + (m-* (gain k) + (m-* (h k) (pminus k)))))) + :in-theory (disable pminus pminus-recdef gain gain-recdef))) + :rule-classes nil)) + + (local + (defthm lemma-9-for-lemma-10 + (implies (and (integerp k) (<= 0 k)) + (m-= (m-+ (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-* (pminus k) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))) + (m-* (gain k) + (m-* (r k) + (m-trans (gain k))))) + (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (pminus k)))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-8)) + :in-theory (disable pminus pminus-recdef gain gain-recdef))) + :rule-classes nil)) + + (local + (defthm lemma-10 + (implies (and (integerp k) (<= 0 k)) + (m-= (m-+ (m-* (m-- (m-id (n)) + (m-* (gain k) (h k))) + (m-* (pminus k) + (m-trans (m-- (m-id (n)) + (m-* (gain k) (h k)))))) + (m-* (gain k) + (m-* (r k) + (m-trans (gain k))))) + (pplus k))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-9-for-lemma-10)) + :in-theory (disable pminus pminus-recdef gain gain-recdef))) + :rule-classes nil)) + + (local + (defthm pplus-as-mean-case-0 + (implies (equal k 0) + (m-= (pplus k) + (m-mean (m-* (m-- (x k) (xhat k)) + (m-trans (m-- (x k) (xhat k))))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-3) + (:instance lemma-10) + (:instance pminus-as-mean-case-0)) + :in-theory (disable pminus pminus-recdef gain gain-recdef))) + :rule-classes nil)) + + (local + (defthm pplus-as-mean-almost + (implies (and (integerp k) + (< 0 k) + (m-= (pplus (1- k)) + (m-mean (m-* (m-- (x (1- k)) + (xhat (1- k))) + (m-trans (m-- (x (1- k)) + (xhat (1- k)))))))) + (m-= (pplus k) + (m-mean (m-* (m-- (x k) (xhat k)) + (m-trans (m-- (x k) (xhat k))))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-3) + (:instance lemma-10) + (:instance pminus-as-mean-almost)) + :in-theory (disable gain gain-recdef + pminus pminus-recdef + acl2::assoc-* + acl2::comm-+ + ACL2::*-+-RIGHT + ACL2::*---RIGHT + ACL2::*-+-left + ACL2::*---left + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::left-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + acl2::COMMUTATIVITY-2-OF-M-+ + acl2::trans-* + acl2::trans-+ + acl2::trans---))) + :rule-classes nil)) + + (local + (defun natural-induction (n) + (if (zp n) + 0 + (1+ (natural-induction (1- n)))))) + + (defthm pplus-as-mean + (implies (and (integerp k) + (<= 0 k)) + (m-= (pplus k) + (m-mean (m-* (m-- (x k) (xhat k)) + (m-trans (m-- (x k) (xhat k))))))) + :hints (("Goal" + :induct (natural-induction k)) + ("Subgoal *1/2" + :use ((:instance pplus-as-mean-almost))) + ("Subgoal *1/1" + :use ((:instance pplus-as-mean-case-0))) + )) + + ) + +(defthm pminus-as-mean + (implies (and (integerp k) (<= 0 k)) + (m-= (pminus k) + (m-mean (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (x k) (xhatmin k))))))) + :hints (("Goal" :do-not-induct t + :use ((:instance pminus-as-mean-almost) + (:instance pplus-as-mean (k (1- k)))) + :in-theory (disable pminus-as-mean-almost pplus-as-mean + x xhat xhatmin + gain-recdef pplus-recdef xhatmin-recdef + (pminus) (x) (xhatmin))))) + +(encapsulate + () + + (local + (encapsulate + () + + (local + (defthm lemma-0-1 + (implies (and (m-matrixp (l y) (c y) y) + (m-matrixp (l z) (c z) z) + (equal (c x) (l y)) + (equal (c y) (l z))) + (equal (m-* x (m-mean (m-* y z))) + (m-mean (m-* (m-* x y) z)))) + :hints (("Goal" + :use ((:instance mean-* + (p x) + (q (m-* y z))) + (:instance mean-delete + (p x))))))) + + (local + (defthm lemma-0-2 + (implies (and (m-matrixp (l x) (c x) x) + (m-matrixp (l y) (c y) y) + (equal (c x) (l y)) + (equal (c y) (l z))) + (equal (m-* (m-mean (m-* x y)) z) + (m-mean (m-* x (m-* y z))))) + :hints (("Goal" + :use ((:instance mean-* + (p (m-* x y)) + (q z)) + (:instance mean-delete + (p z))))))) + + (defthm lemma-0 + (implies (and (integerp k) (<= 0 k)) + (m-= (m-* (pminus k) (m-trans (h k))) + (m-mean (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k)))))))) + :hints (("Goal" :do-not-induct t + :use ((:instance pminus-as-mean)) + :in-theory (disable pplus-as-mean pminus-as-mean)))) + + + (defthm lemma-1 + (implies (and (integerp k) (<= 0 k)) + (m-= (m-* (h k) (m-* (pminus k) (m-trans (h k)))) + (m-mean (m-* (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))))))))) + )) + + (local + (encapsulate + () + + (local + (defthm lemma-2-1 + (equal (l (m-* (v k) (m-trans (v k)))) + (l (m-* (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))))))))) + + (local + (defthm lemma-2-2 + (equal (c (m-* (v k) (m-trans (v k)))) + (c (m-* (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))))))))) + + (defthm lemma-2 + (implies (and (integerp k) (<= 0 k)) + (m-= (m-+ (m-* (h k) + (m-* (pminus k) (m-trans (h k)))) + (m-mean (m-* (v k) (m-trans (v k))))) + (m-mean (m-+ (m-* (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))))) + (m-* (v k) (m-trans (v k))))))) + :hints (("Goal" :do-not-induct t + :in-theory '(lemma-1 mean-+ lemma-2-1 lemma-2-2 + acl2::m-=-implies-equal-m-+-1)))) + + )) + + (local + (defthm lemma-3 + (implies (and (integerp k) (<= 0 k)) + (m-= (m-+ (m-* (h k) + (m-* (pminus k) + (m-trans (h k)))) + (r k)) + (m-mean (m-+ (m-* (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))))) + (m-* (v k) (m-trans (v k))))))) + :hints (("Goal" + :use ((:instance mean-of-v-vtrans) + (:instance lemma-2)) + :in-theory '(acl2::m-=-implies-equal-m-+-2))))) + + (local + (encapsulate + nil + + (local + (defthm lemma-4-1 + (implies (and (m-matrixp (l a) (c a) a) + (m-matrixp (l b) (c b) b) + (equal (l a) (l b)) + (equal (c a) (c b))) + (m-= (m-mean (m-* (m-+ a b) (m-trans (m-+ a b)))) + (m-+ (m-mean (m-* a (m-trans a))) + (m-+ (m-mean (m-* a (m-trans b))) + (m-+ (m-mean (m-* b (m-trans a))) + (m-mean (m-* b (m-trans b)))))))))) + + (local + (defthm lemma-4-2 + (m-= (m-mean (m-* (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (m-trans (v k)))) + (m-zero (m) (m))) + :hints (("Goal" :do-not-induct t + :use ((:instance mean-of-x-xhatmin*vtrans) + (:instance acl2::x-*-zero + (acl2::p (h k)) + (acl2::m (n)) + (acl2::n (m))) + (:instance acl2::*-+-right + (acl2::p (h k)) + (acl2::q (m-* (x k) (m-trans (v k)))) + (acl2::r (m-* (m-unary-- (xhatmin k)) + (m-trans (v k))))) + (:instance mean-* + (p (h k)) + (q (m-* (m-- (x k) (xhatmin k)) + (m-trans (v k))))) + (:instance mean-delete + (p (h k)))) + :in-theory (disable mean-of-x-xhatmin*vtrans + acl2::x-*-zero + acl2::*-+-right))))) + + (local + (defthm lemma-4-3 + (m-= (m-mean (m-* (v k) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k)))))) + (m-zero (m) (m))) + :hints (("Goal" :do-not-induct t + :use ((:instance mean-of-v*trans-of-x-xhatmin) + (:instance acl2::zero-*-x + (acl2::p (m-trans (h k))) + (acl2::m (m)) + (acl2::n (n))) + (:instance mean-* + (p (m-* (v k) + (m-trans (m-- (x k) (xhatmin k))))) + (q (m-trans (h k)))) + (:instance mean-delete + (p (m-trans (h k))))) + :in-theory (disable mean-of-v*trans-of-x-xhatmin + acl2::*-+-left + acl2::*-+-right + acl2::*---left + acl2::*---right + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + acl2::x-*-zero)) + ("Goal'7'" + :use ((:theorem + (IMPLIES (m-= (m-mean (m-* (v k) + (m-* (m-- (m-trans (x k)) + (m-trans (xhatmin k))) + (m-trans (h k))))) + (m-* (m-zero (m) (n)) + (m-trans (h k)))) + (m-= (m-mean (m-* (v k) + (m-- (m-* (m-trans (x k)) + (m-trans (h k))) + (m-* (m-trans (xhatmin k)) + (m-trans (h k)))))) + (m-zero (m) (m))))))) + ("Subgoal 1" + :in-theory (enable acl2::*-+-left))))) + + (defthm lemma-4 + (m-= (m-mean (m-* (m-+ (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (v k)) + (m-trans (m-+ (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (v k))))) + (m-mean (m-+ (m-* (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))))) + (m-* (v k) (m-trans (v k)))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-4-1 + (a (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k)))) + (b (v k)))) + :in-theory (disable lemma-4-1 + xhatmin-recdef + mean-of-v-vtrans + mean-unary-- + acl2::trans-* + acl2::trans-+ + acl2::assoc-* + acl2::assoc-+ + acl2::comm-+ + acl2::*-+-left + acl2::*---left + )))) + )) + + (local + (encapsulate + () + + (local + (defthm lemma-5-1 + (implies (and (equal (l a) (l b)) + (equal (c a) (c b)) + (equal (l b) (l c)) + (equal (c b) (c c))) + (m-= (m-+ b (m-+ a c)) + (m-+ a (m-+ b c)))) + :hints (("Goal" + :use ((:instance acl2::assoc-+ + (acl2::p b) + (acl2::q a) + (acl2::r c)) + (:instance acl2::assoc-+ + (acl2::p a) + (acl2::q b) + (acl2::r c))) + :in-theory (disable acl2::assoc-+))))) + + (defthm lemma-5 + (m-= (m-+ (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (v k)) + (m-- (z k) (m-* (h k) (xhatmin k)))) + :hints (("Goal" :do-not-induct t))) + )) + + (local + (defthm lemma-6 + (m-= (m-mean (m-* (m-- (z k) (m-* (h k) (xhatmin k))) + (m-trans (m-- (z k) (m-* (h k) (xhatmin k)))))) + (m-mean (m-+ (m-* (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))))) + (m-* (v k) (m-trans (v k)))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-4) + (:instance lemma-5)) + :in-theory (disable lemma-4 + lemma-5 + z + xhatmin + x + mean-+ + acl2::assoc-+ + acl2::comm-+ + acl2::commutativity-2-of-m-+ + acl2::trans-* + acl2::trans-+ + acl2::trans--- + acl2::*-+-left + acl2::*-+-right + acl2::*---left + acl2::*---right + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))))) + + (local + (defthm lemma-7 + (implies (and (integerp k) (<= 0 k)) + (m-= (m-+ (m-* (h k) + (m-* (pminus k) + (m-trans (h k)))) + (r k)) + (m-mean (m-* (m-- (z k) (m-* (h k) (xhatmin k))) + (m-trans (m-- (z k) (m-* (h k) (xhatmin k)))))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-3) + (:instance lemma-6)) + :in-theory (disable lemma-3 + lemma-6 + z + xhatmin + x + mean-+ + acl2::assoc-+ + acl2::comm-+ + acl2::commutativity-2-of-m-+ + acl2::trans-* + acl2::trans-+ + acl2::trans--- + acl2::*-+-left + acl2::*-+-right + acl2::*---left + acl2::*---right + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+))))) + + (local + (defthm lemma-8 + (implies (and (integerp k) (<= 0 k)) + (m-= (s-* 2 (m-* (gain k) + (m-mean (m-* (m-- (z k) + (m-* (h k) (xhatmin k))) + (m-trans (m-- (z k) + (m-* (h k) (xhatmin k)))))))) + (s-* 2 (m-* (pminus k) (m-trans (h k)))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-7) + (:instance gain-recdef)) + :in-theory (disable lemma-0 lemma-1 lemma-3 lemma-7 + gain-recdef + z + acl2::*-+-right + acl2::*-+-left + acl2::*---right + acl2::*---left + acl2::assoc-+ + acl2::comm-+ + acl2::left-distributivity-of-m-*-over-m-+ + acl2::right-distributivity-of-m-*-over-m-+ + pminus-as-mean)) + ("Goal'5'" + :by (:theorem + (implies (and (integerp k) (<= 0 k)) + (m-= (s-* 2 (m-* (pminus k) + (m-* (m-trans (h k)) + (m-* (m-inv (m-+ + (m-* (h k) + (m-* (pminus k) + (m-trans (h k)))) + (r k))) + (m-+ + (m-* (h k) + (m-* (pminus k) + (m-trans (h k)))) + (r k)))))) + (s-* 2 + (m-* (pminus k) + (m-trans (h k)))))))) + ("Goal'6'" + :use ((:instance acl2::inv-*-x + (acl2::p (m-+ (r k) + (m-* (h k) + (m-* (pminus k) + (m-trans (h k)))))))) + :in-theory (disable lemma-0 lemma-1 lemma-3 lemma-7 + z + acl2::inv-*-x + acl2::*-+-left + acl2::*-+-right + acl2::*---left + acl2::*---right + acl2::assoc-* + acl2::assoc-+ + ;acl2::comm-+ + acl2::k-*---p + acl2::k-*-x-+-y + mean-+ + mean-of-v-vtrans + mean-unary-- + acl2::trans-* + acl2::trans-+ + acl2::unary---+ + pminus-as-mean))))) + + (local + (defthm lemma-9 + (implies (and (integerp k) (<= 0 k)) + (m-= (s-* 2 (m-* (gain k) + (m-mean (m-* (m-- (z k) + (m-* (h k) (xhatmin k))) + (m-trans (m-- (z k) + (m-* (h k) (xhatmin k)))))))) + (s-* 2 (m-mean (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))))))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-0) + (:instance lemma-8)) + :in-theory (disable lemma-0 lemma-8 + gain gain-recdef + z + xhatmin + x + ) + )))) + + (local + (encapsulate + () + + (local + (defthm lemma-10-1 + (implies (and (equal (l a) (l b)) + (equal (c a) (c b)) + (equal (l b) (l c)) + (equal (c b) (c c))) + (m-= (m-+ b (m-+ a c)) + (m-+ a (m-+ b c)))) + :hints (("Goal" + :use ((:instance acl2::assoc-+ + (acl2::p b) + (acl2::q a) + (acl2::r c)) + (:instance acl2::assoc-+ + (acl2::p a) + (acl2::q b) + (acl2::r c))) + :in-theory (disable acl2::assoc-+))))) + + (local + (defthm lemma-10-2 + (equal (m-- (z k) (m-* (h k) (xhatmin k))) + (m-+ (m-* (h k) (m-- (x k) (xhatmin k))) (v k))) + :hints (("Goal" :do-not-induct t)) + )) + + (local + (defthm lemma-10-3 + (m-= (m-trans (m-- (z k) (m-* (h k) (xhatmin k)))) + (m-+ (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k)))) + (m-trans (v k)))) + :hints (("Goal" :do-not-induct t)))) + + (local + (defthm lemma-10-4 + (m-= (m-mean (m-* (m-- (xhatmin k) (x k)) + (m-trans (m-- (z k) + (m-* (h k) (xhatmin k)))))) + (m-mean (m-* (m-- (xhatmin k) (x k)) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k))))))) + :hints (("Goal" :do-not-induct t + :in-theory (disable MEAN-UNARY-- + z + mean-+ + acl2::trans--- + acl2::trans-+ + acl2::trans-* + lemma-10-1 + lemma-10-2 + acl2::*-+-left + acl2::*---left + acl2::*-+-right + acl2::*---right + acl2::left-distributivity-of-m-*-over-m-+ + acl2::right-distributivity-of-m-*-over-m-+ + acl2::comm-+ + )) + + + ("Goal'" + :use ((:instance acl2::*-+-right + (acl2::p (M-- (XHATMIN K) (X K))) + (acl2::q (M-TRANS (M-- (M-* (H K) (X K)) + (M-* (H K) (XHATMIN K))))) + (acl2::r (M-TRANS (V K))))) + :in-theory (disable z + MEAN-UNARY-- + mean-+ + acl2::trans--- + acl2::trans-+ + acl2::trans-* + acl2::*-+-right + acl2::*---right + acl2::*-+-left + acl2::*---left + acl2::comm-+ + acl2::left-distributivity-of-m-*-over-m-+ + acl2::right-distributivity-of-m-*-over-m-+ + )) + + ("Goal'5'" + :by (:theorem + (m-= + (m-mean (m-+ (m-* (m-+ (xhatmin k) (m-unary-- (x k))) + (m-trans (m-+ (m-* (h k) (x k)) + (m-unary-- (m-* (h k) (xhatmin k)))))) + (m-* (m-+ (xhatmin k) (m-unary-- (x k))) + (m-trans (v k))))) + (m-mean (m-* (m-+ (xhatmin k) (m-unary-- (x k))) + (m-trans (m-+ (m-* (h k) (x k)) + (m-unary-- (m-* (h k) (xhatmin k)))))))))) + ("Goal'6'" + :use ((:instance mean-of-x-xhatmin*vtrans) + (:instance mean-unary-- + (p (m-* (m-+ (x k) + (m-unary-- (xhatmin k))) + (m-trans (v k))))) + (:theorem (m-= (m-unary-- (m-* (m-+ (x k) + (m-unary-- (xhatmin k))) + (m-trans (v k)))) + (m-* (m-+ (xhatmin k) (m-unary-- (x k))) + (m-trans (v k)))))) + :in-theory (disable mean-of-x-xhatmin*vtrans + mean-unary--)) + + ("Subgoal 2" + :use ((:instance M-=-IMPLIES-M-=-M-MEAN-1 + (x (m-* (m-- (xhatmin k) (x k)) + (m-trans (v k)))) + (x-equiv (m-unary-- (m-* (m-- (x k) (xhatmin k)) + (m-trans (v k)))))) + ) + :in-theory (disable mean-of-x-xhatmin*vtrans + mean-unary-- + lemma-10-1 + acl2::*-+-left + acl2::*-+-right + acl2::*---left + acl2::*---right + ;acl2::comm-+ + acl2::trans-* + acl2::trans-+ + acl2::trans--- + acl2::left-distributivity-of-m-*-over-m-+ + acl2::right-distributivity-of-m-*-over-m-+ + (:congruence M-=-IMPLIES-M-=-M-MEAN-1) + )) + ))) + + (local + (defthm lemma-10-5 + (implies (and (m-matrixp (l a) (c a) a) + (m-matrixp (l b) (c b) b) + (equal (l a) (l b)) + (equal (c a) (c b))) + (m-= (m-- b a) + (m-unary-- (m-- a b)))))) + + + (local + (defthm lemma-10-6 + (implies (and (m-matrixp (l a) (c a) a) + (m-matrixp (l b) (c b) b) + (m-matrixp (l c) (c c) c) + (equal (l a) (l b)) + (equal (c a) (c b)) + (equal (c b) (l c))) + (m-= (m-unary-- (m-mean (m-* (m-- a b) c))) + (m-mean (m-* (m-- b a) c)))) + :hints (("Goal" + :use ((:instance lemma-10-5) + (:instance M-=-IMPLIES-M-=-M-MEAN-1 + (x (ACL2::M-BINARY-* (ACL2::M-BINARY-+ B (ACL2::M-UNARY-- A)) + C)) + (x-equiv (m-* (m-unary-- (m-- a b)) c))) + ) + :in-theory (disable lemma-10-5 acl2::unary---+ acl2::assoc-+ + m-=-implies-m-=-m-mean-1)) + ("Goal'4'" + :by (:theorem + (implies + (and (acl2::matrixp (car (dimensions 'acl2::$arg a)) + (car (dimensions 'acl2::$arg c)) + a) + (acl2::matrixp (car (dimensions 'acl2::$arg a)) + (car (dimensions 'acl2::$arg c)) + b) + (acl2::matrixp (car (dimensions 'acl2::$arg c)) + (cadr (dimensions 'acl2::$arg c)) + c)) + (acl2::m-= + (acl2::m-unary-- + (m-mean (acl2::m-binary-* (acl2::m-binary-+ a (acl2::m-unary-- b)) + c))) + (m-mean (acl2::m-binary-* + (acl2::m-unary-- (acl2::m-binary-+ a (acl2::m-unary-- b))) + c))))) + :in-theory (disable lemma-10-5 acl2::unary---+ acl2::assoc-+))))) + + (defthm lemma-10 + (m-= (m-mean (m-* (m-- (xhatmin k) (x k)) + (m-trans (m-- (z k) + (m-* (h k) (xhatmin k)))))) + (m-unary-- (m-mean (m-* (m-- (x k) (xhatmin k)) + (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k)))))))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-10-4) + (:instance lemma-10-6 + (a (xhatmin k)) + (b (x k)) + (c (m-trans (m-- (m-* (h k) (x k)) + (m-* (h k) (xhatmin k)))))) + ) + :in-theory (disable lemma-10-2 + lemma-10-3 + lemma-10-4 + lemma-10-5 + lemma-10-6 + z + mean-unary-- + acl2::*---left + acl2::*---right + acl2::*-+-left + acl2::*-+-right + acl2::unary---+ + acl2::trans-* + acl2::trans-+ + acl2::trans--- + acl2::comm-+ + acl2::assoc-+ + ACL2::LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + ACL2::right-DISTRIBUTIVITY-OF-M-*-OVER-M-+ + mean-+)))) + )) + + (defthm gain-minimizes-error + (implies (and (integerp k) (<= 0 k)) + (m-= (result-form-derivative (gain k) (xhatmin k) k) + (m-zero (n) (m)))) + :hints (("Goal" :do-not-induct t + :use ((:instance lemma-9) + (:instance lemma-10) + (:instance gain-recdef)) + :in-theory (disable lemma-9 + lemma-10 + lemma-0 + lemma-1 + lemma-3 + lemma-6 + lemma-7 + lemma-8 + gain-recdef + xhatmin-recdef + acl2::assoc-+ + acl2::*-+-left + acl2::*-+-right + acl2::*---left + acl2::*---right + acl2::assoc-* + acl2::comm-+ + z + acl2::trans-* + acl2::trans-+ + acl2::trans--- + pminus-recdef + ;MINUS-AS-PLUS-INVERSE + )))) + ) + +(defthm xhatmin=best-prior-almost + (implies (m-= (xhat (1- k)) + (best-estimate-of-x (1- k))) + (m-= (xhatmin k) + (best-prior-estimate-of-x k))) + :hints (("Goal" :do-not-induct t + :in-theory (disable xhat z))) + :rule-classes nil) + +(local + (defun natural-induction (k) + (if (zp k) + 1 + (1+ (natural-induction (1- k)))))) + +(defthm result-form-=-xhat + (equal (result-form (gain k) (xhatmin k) k) + (xhat k))) + +(defthm xhat=best-estimate + (implies (and (integerp k) + (<= 0 k)) + (m-= (xhat k) + (best-estimate-of-x k))) + :hints (("Goal" + :induct (natural-induction k)) + ("Subgoal *1/2" + :use ((:instance xhatmin=best-prior-almost) + (:instance best-estimate-of-x-def + (y (gain k)) + (Xp (xhatmin k))) + (:instance gain-minimizes-error)) + :in-theory (disable xhat)) + ("Subgoal *1/1" + :use ((:instance best-estimate-of-x-def + (y (gain 0)) + (Xp (xhatmin 0)) + (k 0))) + :in-theory (disable gain-recdef + (best-prior-estimate-of-x) + (xhatmin) + (gain))) + ) + :rule-classes nil) + +(defthm xhatmin=best-prior + (implies (and (integerp k) + (<= 0 k)) + (m-= (xhatmin k) + (best-prior-estimate-of-x k))) + :hints (("Goal" :do-not-induct t + :use ((:instance xhatmin=best-prior-almost) + (:instance xhat=best-estimate (k (1- k)))) + :in-theory '(best-prior-estimate-of-x zp))) + :rule-classes nil) + diff --git a/books/workshops/2003/gamboa-cowles-van-baalen/support/linalg.lisp b/books/workshops/2003/gamboa-cowles-van-baalen/support/linalg.lisp new file mode 100644 index 0000000..a9c648e --- /dev/null +++ b/books/workshops/2003/gamboa-cowles-van-baalen/support/linalg.lisp @@ -0,0 +1,1079 @@ +; The ACL2 Linear Algebra Book. +; Copyright (C) 2002 Ruben Gamboa and John R. Cowles, University of Wyoming + +; This book is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This book is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this book; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: +; Ruben Gamboa and John Cowles +; Department of Computer Science +; University of Wyoming +; Laramie, WY 82071-3682 U.S.A. + +; Summer and Fall 2002. +; Last modified 16 June 2003. +#| + To certify in + ACL2 Version 2.8 alpha (as of May 11 03) + +(certify-book "linalg" + 0 + nil ;;compile-flg + ) +|# +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +Date: Mon, 23 Sep 2002 12:22:26 -0600 +From: Ruben Gamboa <ruben@cs.uwyo.edu> +To: cowles@cs.uwyo.edu +Subject: linear algebra +|# +#| +~ruben/home/projects/kalman/linalg.lisp +|# +#| + (ld ;; Newline to fool dependency scanner + "defpkg.lsp") + (certify-book "linalg" 1) +|# +#| +(in-package "KALMAN") +|#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +At UW: + +:set-cbd "/home/faculty/cowles/acl2/matrix/" ;;pyramid + +:set-cbd "/home/cowles/matrix/" ;; turing +|# + +(in-package "ACL2") + +#| +(include-book ;;turing + "/home/cowles/acl2-sources/books/arithmetic-2.8/top") + +(include-book ;;pyramid + "/home/acl2/acl2-2.8/v2-8-alpha-05-11-03/books/arithmetic/top") +|# + +(include-book "../../../../arithmetic/top") + +(include-book "../../cowles-gamboa-van-baalen_matrix/support/matalg") + +(ADD-BINOP M-+ M-BINARY-+) +(ADD-MACRO-ALIAS M-- M-UNARY--) +(ADD-BINOP M-* M-BINARY-*) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (encapsulate +;; ((m-matrixp (m n x) t) ;; (matrixp (m n x) t) +;; (l (x) t) ;; (r (x) t) +;; (c (x) t) +;; (m-* (x y) t) +;; (s-* (k x) t) +;; (m-+ (x y) t) +;; (m-- (x y) t) ;; macro for both matrix +;; (m-unary-- (x) t) ;; unary and binary minus +;; (m-trans (x) t) +;; (m-zero (m n) t) ;; (m-0 (m n) t) +;; (m-id (n) t) ;; (m-1 (n) t) +;; (m-singular (x) t) ;; (m-singularp (x) t) +;; (m-inv (x) t)) ;; (m-/ (x) t) +;; ;; (m-= (M N) t) + +;; (local (defun m-matrixp (m n x) +;; (and (consp x) +;; (equal (car x) m) +;; (equal (cadr x) n) +;; (acl2-numberp (caddr x)) +;; (equal (cdddr x) nil)))) +;; (local (defun l (x) (car x))) +;; (local (defun c (x) (cadr x))) +;; (local (defun m-* (x y) (list (car x) (cadr y) (* (caddr x) (caddr y))))) +;; (local (defun s-* (x y) (list (car y) (cadr y) (* x (caddr y))))) +;; (local (defun m-+ (x y) (list (car x) (cadr x) (+ (caddr x) (caddr y))))) +;; (local (defun m-- (x y) (list (car x) (cadr x) (- (caddr x) (caddr y))))) +;; (local (defun m-unary-- (x) (list (car x) (cadr x) (- (caddr x))))) +;; (local (defun m-trans (x) (list (cadr x) (car x) (fix (caddr x))))) +;; (local (defun m-zero (l c) (list l c 0))) +;; (local (defun m-id (l) (list l l 1))) +;; (local (defun m-singular (x) (or (not (equal (car x) (cadr x))) +;; (equal (caddr x) 0)))) +;; (local (defun m-inv (x) (list (car x) (cadr x) (/ (caddr x))))) +|# +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-p-numrows-cols +;; (implies (m-matrixp m n p) +;; (and (equal (l p) m) +;; (equal (c p) n)))) +|# + +(defthm matrix-p-numrows-cols + (implies (matrixp m n p) + (and (equal (r p) m) + (equal (c p) n))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-zero +;; (m-matrixp m n (m-zero m n))) +|# + +(defabbrev + m-dim-p (n) + "Determine if n is a legal matrix dimension." + (and (integerp n) + (> n 0) + (<= n *INT-SQRT-MAXIMUM-POSITIVE-32-BIT-INTEGER*))) + +(defthm matrix-zero + (implies (and (m-dim-p m) + (m-dim-p n)) + (matrixp m n (m-0 m n)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-id +;; (m-matrixp n n (m-id n))) +|# + +(defthm matrix-id + (implies (m-dim-p n) + (matrixp n n (m-1 n)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-trans +;; (implies (and (equal (l p) m) +;; (equal (c p) n)) +;; (m-matrixp n m (m-trans p)))) +|# + +(defthm matrix-trans + (implies (matrixp m n P) + (matrixp n m (m-trans P)))) + +(in-theory (disable MATRIXP-M-TRANS)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-inv +;; (implies (and (equal (l p) n) +;; (equal (c p) n) +;; (not (m-singular p))) +;; (m-matrixp n n (m-inv p)))) +|# + +(defthm matrix-inv + (implies (and (matrixp (r P)(c P) P) + (equal (r P) n) + (equal (c P) n)) + (matrixp n n (m-/ P))) + :hints (("Goal" + :use (:instance + matrixp-m-/ + (M P))))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-* +;; (implies (and (equal (l p) m) +;; (equal (c p) (l q)) +;; (equal (c q) n)) +;; (m-matrixp m n (m-* p q)))) +|# + +(defthm matrix-* + (implies (and (matrixp m (c P) P) + (matrixp (r Q) n Q) + (equal (c P)(r Q))) + (matrixp m n (m-* P Q)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-s* +;; (implies (and (equal (l p) m) +;; (equal (c p) n)) +;; (m-matrixp m n (s-* k p)))) +|# + +(defthm matrix-s* + (implies (matrixp m n P) + (matrixp m n (s-* k p)))) + +(in-theory (disable MATRIXP-S-*)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-+ +;; (implies (and (equal (l p) (l q)) +;; (equal (c p) (c q)) +;; (equal (l p) m) +;; (equal (c p) n)) +;; (m-matrixp m n (m-+ p q)))) +|# + +(defthm matrix-+ + (implies (and (matrixp m n P) + (matrixp m n Q)) + (matrixp m n (m-+ P Q)))) + +(in-theory (disable MATRIXP-M-+)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-- +;; (implies (and (equal (l p) (l q)) +;; (equal (c p) (c q)) +;; (equal (l p) m) +;; (equal (c p) n)) +;; (m-matrixp m n (m-- p q)))) +|# + +(defthm matrix-- + (implies (and (matrixp m n P) + (matrixp m n Q)) + (matrixp m n (m-- P Q)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm matrix-unary-- +;; (implies (and (equal (l p) m) +;; (equal (c p) n)) +;; (m-matrixp m n (m-unary-- p)))) +|# + +(defthm matrix-unary-- + (implies (matrixp m n P) + (matrixp m n (m-- P)))) + +(in-theory (disable MATRIXP-M-UNARY--)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numrows-zero +;; (equal (l (m-zero m n)) m)) +|# + +(defthm numrows-zero + (equal (r (m-0 m n)) m)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numcols-zero +;; (equal (c (m-zero m n)) n)) +|# + +(defthm numcols-zero + (equal (c (m-0 m n)) n)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm zero-*-x +;; (implies (equal (l p) n) +;; (equal (m-* (m-zero m n) p) +;; (m-zero m (c p))))) +|# + +(defthm zero-*-x + (implies (and (matrixp (r P)(c P) P) + (integerp m) + (> m 0) + (equal (r P) n)) + (m-= (m-* (m-0 m n) P) + (m-0 m (c P)))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm x-*-zero +;; (implies (equal (c p) m) +;; (equal (m-* p (m-zero m n)) +;; (m-zero (l p) n)))) +|# + +(defthm x-*-zero + (implies (and (matrixp (r P)(c P) P) + (integerp n) + (> n 0) + (equal (c P) m)) + (m-= (m-* P (m-0 m n)) + (m-0 (r P) n))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm unary---zero +;; (equal (m-unary-- (m-zero m n)) +;; (m-zero m n))) +|# + +(defthm unary---zero + (implies (and (integerp m) + (> m 0) + (integerp n) + (> n 0)) + (m-= (m-- (m-0 m n)) + (m-0 m n)))) + +(in-theory (disable m--_m-0)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm zero-+-x +;; (implies (and (equal (l p) m) +;; (equal (c p) n) +;; (m-matrixp m n p)) +;; (equal (m-+ (m-zero m n) p) p))) +|# + +(defthm zero-+-x + (implies (matrixp m n P) + (m-= (m-+ (m-0 m n) P) P)) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm x-+---x +;; (equal (m-+ p (m-unary-- p)) +;; (m-zero (l p) (c p)))) +|# + +(local (in-theory (enable matrixp))) + +(defthm x-+---x + (implies (matrixp (r P)(c P) P) + (m-= (m-+ P (m-- P)) + (m-0 (r P) (c P)))) + :hints (("Goal" + :in-theory (disable + right-m-+-inverse-of-m--) + :use (:instance + right-m-+-inverse-of-m-- + (M P) + (name '$arg))))) + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm -x-+-x +;; (equal (m-+ (m-unary-- p) p) +;; (m-zero (l p) (c p)))) +|# + +(defthm -x-+-x + (implies (matrixp (r P)(c P) P) + (m-= (m-+ (m-- P) P) + (m-0 (r P) (c P))))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm scalar-*-zero +;; (equal (s-* k (m-zero m n)) +;; (m-zero m n))) +|# + +(defthm scalar-*-zero + (implies (and (integerp m) + (> m 0) + (integerp n) + (> n 0)) + (m-= (s-* k (m-0 m n)) + (m-0 m n)))) + +(in-theory (disable M-=-S-*-M-0)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm zero-trans +;; (equal (m-trans (m-zero m n)) +;; (m-zero n m))) +|# + +(defthm zero-trans + (implies (and (integerp m) + (> m 0) + (integerp n) + (> n 0)) + (m-= (m-trans (m-0 m n)) + (m-0 n m)))) + +(in-theory (disable M-=-M-TRANS-M-0)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numrows-id +;; (equal (l (m-id n)) n)) +|# + +(defthm numrows-id + (equal (r (m-1 n)) n)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numcols-id +;; (equal (c (m-id n)) n)) +|# + +(defthm numcols-id + (equal (c (m-1 n)) n)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm id-*-x +;; (implies (m-matrixp n n2 p) +;; (equal (m-* (m-id n) p) p))) +|# + +(defthm id-*-x + (implies (matrixp n n2 P) + (m-= (m-* (m-1 n) P) P)) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm x-*-id +;; (implies (m-matrixp m n p) +;; (equal (m-* p (m-id n)) p))) +|# + +(defthm x-*-id + (implies (matrixp m n P) + (m-= (m-* P (m-1 n)) P)) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm id-trans +;; (equal (m-trans (m-id n)) +;; (m-id n))) +|# + +(defthm id-trans + (implies (and (integerp n) + (> n 0)) + (m-= (m-trans (m-1 n)) + (m-1 n)))) + +(in-theory (disable M-=-M-TRANS-M-1)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numrows-* +;; (implies (equal (c p) (l q)) +;; (equal (l (m-* p q)) +;; (l p)))) +|# + +(defthm numrows-* + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (c P) (r Q))) + (equal (r (m-* P Q)) + (r P))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numcols-* +;; (implies (equal (c p) (l q)) +;; (equal (c (m-* p q)) +;; (c q)))) +|# + +(defthm numcols-* + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (c P) (r Q))) + (equal (c (m-* P Q)) + (c Q))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm assoc-* +;; (implies (and (equal (c p) (l q)) +;; (equal (c q) (l r))) +;; (equal (m-* (m-* p q) r) +;; (m-* p (m-* q r))))) +|# + +(defthm assoc-* + (implies (and (equal (c p) (r q)) + (equal (c q) (r r))) + (m-= (m-* (m-* P Q) R) + (m-* P (m-* Q R)))) + :rule-classes ((:rewrite + :corollary + (equal (m-* (m-* P Q) R) + (m-* P (m-* Q R)))))) + +(in-theory (disable ASSOCIATIVITY-OF-M-*)) + +#|;;;;;;;;;;;;;;;;;;;;; +;; (defthm numrows-s* +;; (equal (l (s-* k p)) +;; (l p))) +|# + +(defthm numrows-s* + (equal (r (s-* k P)) + (r P))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numcols-s* +;; (equal (c (s-* k p)) +;; (c p))) +|# + +(defthm numcols-s* + (equal (c (s-* k P)) + (c p))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm k-*-x-*-y +;; (implies (equal (c p) (l q)) +;; (equal (m-* (s-* n p) q) +;; (s-* n (m-* p q))))) +|# + +(local (in-theory (enable matrixp))) + +(defthm k-*-x-*-y + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (c P) (r Q))) + (m-= (m-* (s-* n P) Q) + (s-* n (m-* P Q)))) + :hints (("Goal" + :in-theory (disable m-*-s-*-left) + :use (:instance + m-*-s-*-left + (M1 P) + (M2 Q) + (a n) + (name '$arg))))) + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm x-*-k-*-y +;; (implies (equal (c p) (l q)) +;; (equal (m-* p (s-* n q)) +;; (s-* n (m-* p q))))) +|# + +(local (in-theory (enable matrixp))) + +(defthm x-*-k-*-y + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (c P) (r Q))) + (m-= (m-* P (s-* n Q)) + (s-* n (m-* P Q)))) + :hints (("Goal" + :in-theory (disable m-*-s-*-right) + :use (:instance + m-*-s-*-right + (M1 P) + (M2 Q) + (a n) + (name '$arg))))) + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numrows-+ +;; (implies (and (equal (l p) (l q)) +;; (equal (c p) (c q))) +;; (equal (l (m-+ p q)) +;; (l p)))) +|# + +(defthm numrows-+ + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (r P) (r Q)) + (equal (c P) (c Q))) + (equal (r (m-+ P Q)) + (r P))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numcols-+ +;; (implies (and (equal (l p) (l q)) +;; (equal (c p) (c q))) +;; (equal (c (m-+ p q)) +;; (c p)))) +|# + +(defthm numcols-+ + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (r P) (r Q)) + (equal (c P) (c Q))) + (equal (c (m-+ P Q)) + (c P))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm assoc-+ +;; (implies (and (equal (l p) (l q)) +;; (equal (l q) (l r)) +;; (equal (c p) (c q)) +;; (equal (c q) (c r))) +;; (equal (m-+ (m-+ p q) r) +;; (m-+ p (m-+ q r))))) +|# + +(defthm assoc-+ + (implies (and (equal (r P) (r Q)) + (equal (r Q) (r R)) + (equal (c P) (c Q)) + (equal (c Q) (c R))) + (m-= (m-+ (m-+ P Q) R) + (m-+ P (m-+ Q R)))) + :rule-classes ((:rewrite + :corollary + (equal (m-+ (m-+ P Q) R) + (m-+ P (m-+ Q R)))))) + +(in-theory (disable ASSOCIATIVITY-OF-M-+)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm comm-+ +;; (implies (and (equal (l p) (l q)) +;; (equal (c p) (c q))) +;; (equal (m-+ p q) +;; (m-+ q p)))) +|# + +(defthm comm-+ + (implies (and (equal (r P) (r Q)) + (equal (c P) (c Q))) + (m-= (m-+ P Q) + (m-+ Q P))) + :rule-classes ((:rewrite + :corollary + (equal (m-+ P Q) + (m-+ Q P))))) + +(in-theory (disable COMMUTATIVITY-OF-M-+)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm x-+-x +;; (equal (m-+ p p) +;; (s-* 2 p))) +|# + +(local (in-theory (enable matrixp))) + +(defthm x-+-x + (implies (matrixp (r P)(c P) P) + (m-= (m-+ P P) + (s-* 2 P))) + :hints (("Goal" + :in-theory (disable double-m-+-s-*) + :use (:instance + double-m-+-s-* + (M P) + (name '$arg))))) + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm k-*-x-+-y +;; (implies (and (equal (l p) (l q)) +;; (equal (c p) (c q))) +;; (equal (s-* n (m-+ p q)) +;; (m-+ (s-* n p) +;; (s-* n q))))) +|# + +(defthm k-*-x-+-y + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (r P) (r Q)) + (equal (c P) (c Q))) + (m-= (s-* n (m-+ P Q)) + (m-+ (s-* n P) + (s-* n Q)))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm *-+-right +;; (implies (and (equal (l q) (l r)) +;; (equal (c q) (c r)) +;; (equal (c p) (l q))) +;; (equal (m-* p (m-+ q r)) +;; (m-+ (m-* p q) +;; (m-* p r))))) +|# + +(defthm *-+-right + (implies (and (equal (r Q) (r R)) + (equal (c Q) (c R)) + (equal (c P) (r Q))) + (m-= (m-* P (m-+ Q R)) + (m-+ (m-* P Q) + (m-* P R)))) + :rule-classes ((:rewrite + :corollary + (m-= (m-* P (m-+ Q R)) + (m-+ (m-* P Q) + (m-* P R)))))) + +(in-theory + (disable LEFT-DISTRIBUTIVITY-OF-M-*-OVER-M-+)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm *-+-left +;; (implies (and (equal (l q) (l r)) +;; (equal (c q) (c r)) +;; (equal (c q) (l p))) +;; (equal (m-* (m-+ q r) p) +;; (m-+ (m-* q p) +;; (m-* r p))))) +|# + +(defthm *-+-left + (implies (and (equal (r Q) (r R)) + (equal (c Q) (c R)) + (equal (c Q) (r P))) + (m-= (m-* (m-+ Q R) P) + (m-+ (m-* Q P) + (m-* R P)))) + :rule-classes ((:rewrite + :corollary + (m-= (m-* (m-+ Q R) P) + (m-+ (m-* Q P) + (m-* R P)))))) + +(in-theory + (disable RIGHT-DISTRIBUTIVITY-OF-M-*-OVER-M-+)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm minus-as-plus-inverse +;; (implies (and (equal (l p) (l q)) +;; (equal (c p) (c q))) +;; (equal (m-- p q) +;; (m-+ p (m-unary-- q))))) +|# + +; Matt K., after v4-2: +; Commenting out the following rule, which rewrites a term to itself! +; -- Well, instead, given the comment below, I'll just make it not be a rewrite +; rule. +(defthm minus-as-plus-inverse + (equal (m-- P Q) + (m-+ P (m-unary-- Q))) + :rule-classes nil) + +;; m-- is a macro that expands into the second term of the +;; above equality. So the equality above expands into a special +;; case of the reflexivity of equal. +; Matt K. mod: See comment above for why I'm commenting this out. +; (in-theory (disable minus-as-plus-inverse)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm k-*---p +;; (equal (s-* n (m-unary-- p)) +;; (m-unary-- (s-* n p)))) +|# + +(local (in-theory (enable matrixp))) + +(defthm k-*---p + (implies (matrixp (r P)(c P) P) + (m-= (s-* n (m-- P)) + (m-- (s-* n P)))) + :hints (("Goal" + :in-theory (disable m-=_s-*_m--) + :use (:instance + m-=_s-*_m-- + (M P) + (a n) + (name '$arg))))) + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numrows-unary-- +;; (equal (l (m-unary-- p)) +;; (l p))) +|# + +(defthm numrows-unary-- + (equal (r (m-- P)) + (r P))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numcols-unary-- +;; (equal (c (m-unary-- p)) +;; (c p))) +|# + +(defthm numcols-unary-- + (equal (c (m-- P)) + (c P))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm unary---unary-- +;; (implies (m-matrixp m n p) +;; (equal (m-unary-- (m-unary-- p)) +;; p))) +|# + +(defthm unary---unary-- + (implies (matrixp (r P)(c P) P) + (m-= (m-- (m-- P)) + P)) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm unary---+ +;; (equal (m-unary-- (m-+ p q)) +;; (m-+ (m-unary-- p) (m-unary-- q)))) +|# + +(defthm unary---+ + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (r P)(r Q)) + (equal (c P)(c Q))) + (m-= (m-- (m-+ P Q)) + (m-+ (m-- P)(m-- Q)))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm *---left +;; (equal (m-* (m-unary-- p) q) +;; (m-unary-- (m-* p q)))) +|# + +(local (in-theory (enable matrixp))) + +(defthm *---left + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (c P)(r Q))) + (m-= (m-* (m-- P) Q) + (m-- (m-* P Q)))) + :hints (("Goal" + :in-theory (disable M-*-M--_LEFT) + :use (:instance + M-*-M--_LEFT + (M1 P) + (M2 Q) + (name '$arg))))) + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm *---right +;; (equal (m-* p (m-unary-- q)) +;; (m-unary-- (m-* p q)))) +|# + +(local (in-theory (enable matrixp))) + +(defthm *---right + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (c P)(r Q))) + (m-= (m-* P (m-- Q)) + (m-- (m-* P Q)))) + :hints (("Goal" + :in-theory (disable M-*-M--_right) + :use (:instance + M-*-M--_right + (M1 P) + (M2 Q) + (name '$arg))))) + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numrows-trans +;; (equal (l (m-trans p)) (c p))) +|# + +(defthm numrows-trans + (equal (r (m-trans P))(c P))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numcols-trans +;; (equal (c (m-trans p)) (l p))) +|# + +(defthm numcols-trans + (equal (c (m-trans P))(r P))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm trans-*-scalar +;; (equal (m-trans (s-* n p)) +;; (s-* n (m-trans p)))) +|# + +(local (in-theory (enable matrixp))) + +(defthm trans-*-scalar + (implies (matrixp (r P)(c P) P) + (m-= (m-trans (s-* n P)) + (s-* n (m-trans P)))) + :hints (("Goal" + :in-theory (disable M-=-M-TRANS-S-*) + :use (:instance + M-=-M-TRANS-S-* + (s n) + (M P) + (name '$arg))))) + + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm trans--- +;; (equal (m-trans (m-unary-- p)) +;; (m-unary-- (m-trans p)))) +|# + +(local (in-theory (enable matrixp))) + +(defthm trans--- + (implies (matrixp (r P)(c P) P) + (m-= (m-trans (m-- P)) + (m-- (m-trans P)))) + :hints (("Goal" + :in-theory (disable M-=-M-TRANS-M-UNARY--) + :use (:instance + M-=-M-TRANS-M-UNARY-- + (M P) + (name '$arg))))) + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm trans-trans +;; (implies (m-matrixp m n p) +;; (equal (m-trans (m-trans p)) +;; p))) +|# + +(defthm trans-trans + (implies (matrixp (r P)(c P) P) + (m-= (m-trans (m-trans P)) + P)) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm trans-+ +;; (implies (and (equal (l p) (l q)) +;; (equal (c p) (c q))) +;; (equal (m-trans (m-+ p q)) +;; (m-+ (m-trans p) (m-trans q))))) +|# + +(defthm trans-+ + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (r P)(r Q)) + (equal (c P)(c Q))) + (m-= (m-trans (m-+ P Q)) + (m-+ (m-trans P)(m-trans Q)))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm trans-* +;; (implies (equal (c p) (l q)) +;; (equal (m-trans (m-* p q)) +;; (m-* (m-trans q) (m-trans p))))) +|# + +(local (in-theory (enable matrixp))) + +(defthm trans-* + (implies (and (matrixp (r P)(c P) P) + (matrixp (r Q)(c Q) Q) + (equal (c P)(r Q))) + (m-= (m-trans (m-* P Q)) + (m-* (m-trans Q)(m-trans P)))) + :hints (("Goal" + :in-theory (disable + M-TRANS-M-*=M-*-M-TRANS) + :use (:instance + M-TRANS-M-*=M-*-M-TRANS + (M1 P) + (M2 Q) + (name '$arg))))) + +(local (in-theory (disable matrixp))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numrows-inv +;; (implies (equal (c p) (l p)) +;; (equal (l (m-inv p)) (l p)))) +|# + +(defthm numrows-inv + (implies (and (matrixp (r P)(c P) P) + (equal (c P) (r P))) + (equal (r (m-/ P)) (r P))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm numcols-inv +;; (implies (equal (c p) (l p)) +;; (equal (c (m-inv p)) (c p)))) +|# + +(defthm numcols-inv + (implies (and (matrixp (r P)(c P) P) + (equal (c P) (r P))) + (equal (c (m-/ P)) (c P))) + :hints (("Goal" + :in-theory (enable matrixp)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm non-singulars-are-square +;; (implies (not (m-singular p)) +;; (equal (c p) (l p)))) +|# + +(defthm non-singulars-are-square + (implies (not (m-singularp P)) + (equal (c P)(r P)))) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm inv-*-x +;; (implies (and (m-matrixp m n p) +;; (not (m-singular p))) +;; (equal (m-* (m-inv p) p) +;; (m-id (l p))))) +|# + +(defthm inv-*-x + (implies (not (m-singularp P)) + (m-= (m-* (m-/ P) P) + (m-1 (r P))))) + +(in-theory (disable LEFT-M-*-INVERSE-OF-M-/)) + +#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defthm x-*-inv +;; (implies (and (m-matrixp m n p) +;; (not (m-singular p))) +;; (equal (m-* p (m-inv p)) +;; (m-id (l p))))) +|# + +(defthm x-*-inv + (implies (not (m-singularp P)) + (m-= (m-* P (m-/ P)) + (m-1 (r P))))) + +(in-theory (disable RIGHT-M-*-INVERSE-OF-M-/)) + +;; ) diff --git a/books/workshops/2003/gamboa-patterson/polymorphism.pdf.gz b/books/workshops/2003/gamboa-patterson/polymorphism.pdf.gz Binary files differnew file mode 100644 index 0000000..1de82ab --- /dev/null +++ b/books/workshops/2003/gamboa-patterson/polymorphism.pdf.gz diff --git a/books/workshops/2003/gamboa-patterson/polymorphism.ps.gz b/books/workshops/2003/gamboa-patterson/polymorphism.ps.gz Binary files differnew file mode 100644 index 0000000..17a27e0 --- /dev/null +++ b/books/workshops/2003/gamboa-patterson/polymorphism.ps.gz diff --git a/books/workshops/2003/gamboa-patterson/slides.pdf.gz b/books/workshops/2003/gamboa-patterson/slides.pdf.gz Binary files differnew file mode 100644 index 0000000..9b6e9ea --- /dev/null +++ b/books/workshops/2003/gamboa-patterson/slides.pdf.gz diff --git a/books/workshops/2003/gamboa_lit-programming/litproofs.pdf.gz b/books/workshops/2003/gamboa_lit-programming/litproofs.pdf.gz Binary files differnew file mode 100644 index 0000000..b2c03e2 --- /dev/null +++ b/books/workshops/2003/gamboa_lit-programming/litproofs.pdf.gz diff --git a/books/workshops/2003/gamboa_lit-programming/litproofs.ps.gz b/books/workshops/2003/gamboa_lit-programming/litproofs.ps.gz Binary files differnew file mode 100644 index 0000000..30d9530 --- /dev/null +++ b/books/workshops/2003/gamboa_lit-programming/litproofs.ps.gz diff --git a/books/workshops/2003/gamboa_lit-programming/slides.pdf.gz b/books/workshops/2003/gamboa_lit-programming/slides.pdf.gz Binary files differnew file mode 100644 index 0000000..608dcb1 --- /dev/null +++ b/books/workshops/2003/gamboa_lit-programming/slides.pdf.gz diff --git a/books/workshops/2003/greve-wilding-vanfleet/deps.lisp b/books/workshops/2003/greve-wilding-vanfleet/deps.lisp new file mode 100644 index 0000000..a7a4dfe --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/deps.lisp @@ -0,0 +1,8 @@ +;; Silly file to trick cert.pl into including the right books. + +(in-package "ACL2") + +#|| +; Seems to be needed; see support/make-consistency-test.lisp. +(include-book "data-structures/set-theory" :dir :system) +||# diff --git a/books/workshops/2003/greve-wilding-vanfleet/security-policy.pdf.gz b/books/workshops/2003/greve-wilding-vanfleet/security-policy.pdf.gz Binary files differnew file mode 100644 index 0000000..216dcb4 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/security-policy.pdf.gz diff --git a/books/workshops/2003/greve-wilding-vanfleet/security-policy.ps.gz b/books/workshops/2003/greve-wilding-vanfleet/security-policy.ps.gz Binary files differnew file mode 100644 index 0000000..c3df955 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/security-policy.ps.gz diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/.gitignore b/books/workshops/2003/greve-wilding-vanfleet/support/.gitignore new file mode 100644 index 0000000..3a06756 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/.gitignore @@ -0,0 +1,3 @@ +make.lisp +consistency-test.lisp +consistency-test-passed.lisp diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/Makefile b/books/workshops/2003/greve-wilding-vanfleet/support/Makefile new file mode 100644 index 0000000..3be5d36 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/Makefile @@ -0,0 +1,45 @@ +include ../../../../Makefile-generic +BOOKS = firewallworks + +# Avoid provisional certification since we are not using Makefile-deps, +# which is because there is a generated .lisp file. +override ACL2_PCERT = + +separation.cert: separation.lisp + +firewallspec.cert: separation.cert firewallspec.lisp + +consistency-test.lisp: separation.lisp firewallspec.lisp firewallworks.lisp make-consistency-test.lisp + rm -f make.lisp + rm -f consistency-test.lisp + echo "(value :q)" > make.lisp + echo "(load \"make-consistency-test.lisp\")" >> make.lisp + echo "(make-test \"consistency-test.lisp\")" >> make.lisp +# Deleted by Matt K., May 2006, to avoid STATE warning in CMUCL. +# echo '(acl2::value :q)' >> make.lisp + echo '(acl2::exit-lisp)' >> make.lisp + $(ACL2) < make.lisp > consistency.out + +## This book will be certified if the axioms are proved consistent +consistency-test-passed.cert: consistency-test.lisp + rm -f make.lisp + rm -f consistency-test-passed.lisp + rm -f consistency-test-passed.cert + echo "(in-package \"ACL2\")" >> consistency-test-passed.lisp + echo "(value :q) (lp)" > make.lisp + echo "(ld \"consistency-test.lisp\" :ld-error-triples t :ld-error-action :error)" >> make.lisp + echo '(acl2::value :q)' >> make.lisp + echo '(acl2::exit-lisp)' >> make.lisp + $(ACL2) < make.lisp > consistency-test-passed.out + +## This book will be certified if the axioms are proved consistent +compatible.cert: compatible.lisp separation.cert + +## Note: this will fail if the consistency-check is not passed, or the compatibility +## test did not work +firewallworks.cert: firewallspec.cert firewallworks.lisp consistency-test-passed.cert compatible.cert + +newclean: + rm -f consistency-test.lisp make.lisp consistency-test-passed.lisp + +clean: newclean diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/cert_pl_exclude b/books/workshops/2003/greve-wilding-vanfleet/support/cert_pl_exclude new file mode 100644 index 0000000..833501d --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/cert_pl_exclude @@ -0,0 +1,2 @@ +This directory has a custom Makefile, so it is excluded from +certification based on cert.pl. diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/compatible.acl2 b/books/workshops/2003/greve-wilding-vanfleet/support/compatible.acl2 new file mode 100644 index 0000000..178d743 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/compatible.acl2 @@ -0,0 +1,4 @@ +(value :q) +(lp) +(include-book "separation") +(certify-book "compatible" ? t) diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/compatible.lisp b/books/workshops/2003/greve-wilding-vanfleet/support/compatible.lisp new file mode 100644 index 0000000..6217937 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/compatible.lisp @@ -0,0 +1,87 @@ +(in-package "ACL2") + +;; This file demonstrates that our notion of separation implies the +;; "standard" notion presented to us by Vanfleet and derived from +;; previous work. These separation notions are: infiltration, +;; exfiltration, and mediation. +;; +;; Matt July 2002 + +;; Requires: +;; (include-book "separation") + +(defthm subsetp-intersection-equal + (and + (subsetp (intersection-equal a b) a) + (subsetp (intersection-equal a b) b))) + +(defthm member-selectlist-means + (implies + (and + (equal (selectlist l l1) (selectlist l l2)) + (member x l)) + (iff (equal (select x l1) (select x l2)) t)) + :rule-classes :forward-chaining) + +(defthm selectlist-subset + (implies + (and + (equal (selectlist y l1) (selectlist y l2)) + (subsetp x y)) + (iff (equal (selectlist x l1) (selectlist x l2)) t))) + +(defthm infiltration + (implies + (and + (equal (current st1) (current st2)) + (equal (selectlist (segs (current st1)) st1) + (selectlist (segs (current st2)) st2)) + (member x (segs (current st1)))) + (equal (select x (next st1)) + (select x (next st2)))) + :hints (("goal" :use (:instance separation (seg x))))) + +;; Our initial version of exfiltration was quite strong: the segment +;; in question was unchanged assuming that the current partition had +;; no dia segments. This version using these functions would be +;; something like: + +;(defthm exfiltration +; (implies +; (not (intersection-equal (dia y) (segs (current st)))) +; (equal (select y (next st)) +; (select y st))) +; :hints (("goal" :use (:instance separation (seg y))))) + +;; Unfortunately, this formulation forecloses the possibility of +;; free-running counters, interrupt handlers, etc. that change the +;; state of y in a way not dependant on the current partition. This +;; kind of behavior ought to be allowed by this formalization, so we +;; weaken it somewhat. + +; Matt K., after v4-2: +; Commenting out the following rule, which rewrites a term to itself! +#|| +(defthm exfiltration + (implies + (and + (equal (current st1) (current st2)) + (not (intersection-equal (dia y) (segs (current st1))))) + (equal (select y (next st2)) + (select y (next st2)))) + :hints (("goal" :use (:instance separation (seg y))))) +||# + +(defthm mediation + (implies + (and + (equal (current st1) (current st2)) + (equal (selectlist (segs (current st1)) st1) + (selectlist (segs (current st2)) st2)) + (equal (select x st1) (select x st2))) + (equal (select x (next st1)) (select x (next st2)))) + :hints (("goal" :use (:instance separation (seg x))))) + + + + diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/firewallspec.acl2 b/books/workshops/2003/greve-wilding-vanfleet/support/firewallspec.acl2 new file mode 100644 index 0000000..e6aab8a --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/firewallspec.acl2 @@ -0,0 +1,4 @@ +(value :q) +(lp) +(include-book "separation") +(certify-book "firewallspec" ? t) diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/firewallspec.lisp b/books/workshops/2003/greve-wilding-vanfleet/support/firewallspec.lisp new file mode 100644 index 0000000..0dc35f0 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/firewallspec.lisp @@ -0,0 +1,120 @@ +(in-package "ACL2") + +;; Essay on formalizing "black" data. + +;; This file introduces some concepts useful in specifying a firewall. +;; It was not immediately obvious how to formalize the correct +;; operation of a firewall. What makes it difficult is describing +;; what it means for data not to contain sensitive information. We +;; introduce the notion of "black", which is a predicate on a segment +;; name and a system state. The intended interpretation is that black +;; segments do not contain sensitive information that requires +;; protection. + +;; Mostly we leave "black" unspecified. However, we assume that it +;; has the following properties: + +;; 1. If all segments in a system are black, then after the system +;; progresses one step each segment is black. (No "spontaneous +;; generation".) + +;; 2. There exists a function "scrub" that modifies a segment so +;; that it is black. + +;; 3. Elements of system state that are not associated with the +;; segment are irrelevant in deciding whether a segment is black. + +;; Is this approach to modeling reasonable? Assume that each byte of +;; the system has associated with it a "black" bit that tells whether +;; the byte is cleared. Any operation that produces data sets the +;; result's black bit to the "and" of all the input black bits. + +;; Axiom one holds, since any operation will set black bits if every +;; segment in the system has its black bits set. Note that +;; applications are not modeled at this level, but it is worth +;; considering whether this framework could model something like a +;; decryption algorithm. Note that decryption requires keys or +;; algorithms that would not be considered "black" in this framework, +;; so this axiom would not be inconsistent with such models. + +;; Axiom two holds since one can "scrub" a data segment by zeroizing +;; all the data and setting the black bits. (Of course, not under +;; user control.) + +;; Axiom three holds since it is straightforward to tell if a segment +;; is black by checking all its black bits. + +(encapsulate +;; BLACK +;; input: segment name, machine state +;; output: boolean indicating whether segment is cleared + + (((black * *) => *) + +;; SCRUB +;; input: segment name, machine state +;; output machine state in which segment is cleared and other +;; segments are untouched + + ((scrub * *) => *) +) + +;; A "black" segment contains no sensitive information +(local (defun black (segname st) (declare (ignore segname) (ignore st)) t)) + +;; A list of segments is all black +(defun blacklist (segnames st) + (if (consp segnames) + (and + (black (car segnames) st) + (blacklist (cdr segnames) st)) + t)) + +;; A segment to be "scrubbed" +(local (defun scrub (seg st) (declare (ignore seg)) st)) + +;; A list of segments to be "scrubbed" +(defun scrublist (segs st) + (if (consp segs) + (scrublist (cdr segs) (scrub (car segs) st)) + st)) + +(defthm scrub-commutative + (equal + (scrub seg1 (scrub seg2 st)) + (scrub seg2 (scrub seg1 st)))) + +(defthm segment-scrub-different + (implies (not (equal seg1 seg2)) + (equal (select seg1 (scrub seg2 st)) + (select seg1 st)))) +(defthm black-scrub + (equal + (black seg1 (scrub seg2 st)) + (or + (equal seg1 seg2) + (black seg1 st)))) + +(defthm current-scrub + (equal + (current (scrub seg st)) + (current st))) + +;; If every segment is black, then after one step an arbitrary segment +;; is black +(defthm spontaneous-generation + (implies + (blacklist (segslist (allparts)) st) + (black seg (next st)))) + +;; Only the contents of a segment determine its blackness +(defthm black-function-of-segment + (implies + (equal (select x st1) (select x st2)) + (equal (black x st1) (black x st2))) + :rule-classes nil) + +) + + + diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/firewallworks.acl2 b/books/workshops/2003/greve-wilding-vanfleet/support/firewallworks.acl2 new file mode 100644 index 0000000..e977fb1 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/firewallworks.acl2 @@ -0,0 +1,12 @@ +(in-package "ACL2") +(include-book "firewallspec") + +;; [Jared] BOZO wtf...? + +(include-book "consistency-test-passed" :uncertified-okp nil) +:u +(include-book "compatible" :uncertified-okp nil) +:u + +; cert-flags: ? t :defaxioms-okp t +(certify-book "firewallworks" ? t :defaxioms-okp t) diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/firewallworks.lisp b/books/workshops/2003/greve-wilding-vanfleet/support/firewallworks.lisp new file mode 100644 index 0000000..64c7279 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/firewallworks.lisp @@ -0,0 +1,340 @@ +(in-package "ACL2") + +;; (include-book "firewallspec") + +;; Firewall works + +;; We formalize a particular firewall system and use the separation +;; axiom to show that it works. We use the notion of "black" data to +;; describe what is and what is not cleared. + +;; We introduce the firewall system using three axioms. + +;; Note about the axioms consistency +;; --------------------------------- +;; We would like to show that the axioms we've added here are +;; consistent with the axioms added using encapsulate. Although doing +;; this does not guarantee that we've axiomitized things properly, +;; since it's a check on our axioms we'd like to do it. +;; Unfortunately, there seems to be no way to accomplish this +;; conveniently using ACL2 2.6. + +;; So, we do it manually, using code written to work with a Makefile. +;; The makefile is arranged so that if these axioms are inconsistent +;; with the axioms added previously, then an error occurs. We use the +;; witnesses introduced by the encapsulate, which is not the most +;; robust way to do this since it requires foresight when introducing +;; the encapsulates and may limit their use. (Better to have a +;; mechanism that allows a new witness to be introduced when the +;; consistency check is being accomplished.) + +;; We would of course prefer ACL2 to support doing this, and we have +;; suggested this to the ACL2 authors and others. + +;; b, and f are partitions. Their names are meant to suggest "black" +;; and "firewall". +(defaxiom allparts-includes + (and + (member 'b (allparts)) + (member 'f (allparts)))) + +;; When the system is executing partition f, the contents of memory +;; segment "outbox" does not unblacken +(defaxiom firewall-blackens + (implies + (and + (equal (current st) 'f) + (black 'outbox st)) + (black 'outbox (next st)))) + +;; If there is a segment in partition B that is writable from a +;; segment in a non-B partition, then it is called "outbox" and it is +;; only writable from segments that are in partition F and not in +;; partition B. +(defaxiom dia-setup + (implies + (and + (member seg1 (dia seg2)) + (member seg2 (segs 'b)) + (member seg1 (segs p)) + (not (equal p 'b))) + (and + (equal seg2 'outbox) + (equal p 'f) + (not (member seg1 (segs 'b))))) + :rule-classes nil) + +;; Some of the recursive functions we have introduced were added in +;; the scope of an encapsulate. ACL2 will not allow us to use their +;; recursive structure in inductive proofs, because we might have done +;; something fishy. We now provide ACL2 some recursive functions to +;; guide its choice of induction schemes on a few of these functions. + +(defun scrublist-induct (segs st) + (if (consp segs) + (scrublist-induct (cdr segs) (scrub (car segs) st)) + st)) + +(defthm scrublist-induction-scheme + t + :rule-classes ((:induction :pattern (scrublist segs st) + :scheme (scrublist-induct segs st)))) + +(defthm blacklist-induction-scheme + t + :rule-classes ((:induction :pattern (blacklist segs st) + :scheme (len segs)))) + +(defun run-induct (st n) + (if (zp n) st (run-induct (next st) (1- n)))) + +(defthm run-induction-scheme + t + :rule-classes ((:induction :pattern (run st n) + :scheme (run-induct st n)))) + +;; We introduce some underlying useful theorems about our functions + +(defthm remains-black-after-scrublist + (implies + (black seg st) + (black seg (scrublist segs st)))) + +(defthm black-scrublist + (iff + (black x (scrublist list st)) + (or + (member x list) + (black x st)))) + +(defthm scrublist-scrub + (equal + (scrublist list (scrub x st)) + (scrub x (scrublist list st)))) + +(defthm blacklist-scrub + (implies + (blacklist x list) + (blacklist x (scrub y list)))) + +;; Scrubbing the non-black elements yields a system state with all +;; black elements +(defthm scrub-nonblack-means-black + (implies + (blacklist y st) + (blacklist x (scrublist (set-difference-equal x y) st)))) + +; [Removed by Matt K. to handle changes to member, assoc, etc. after ACL2 4.2.] +; (defthm member-equal-is-member +; (equal (member-equal a l) (member a l))) + +(defthm intersection-equal-dia-b-segs-f-helper + (implies + (and + (member x (segs 'b)) + (not (equal x 'outbox)) + (subsetp z (dia x))) + (equal (intersection-equal z (segs 'f)) nil)) + :hints + (("Subgoal *1/3'4'" :use (:instance dia-setup (seg1 z1) (seg2 x) (p 'f)))) + :rule-classes nil) + +(defthm subsetp-append + (subsetp x (append a x))) + +(defthm subsetp-x-x + (subsetp x x) + :hints (("goal" :use (:instance subsetp-append (a nil)) + :in-theory (disable subsetp-append)))) + +(defthm intersection-equal-dia-b-segs-f + (implies + (and + (member x (segs 'b)) + (not (equal x 'outbox))) + (equal (intersection-equal (dia x) (segs 'f)) nil)) + :hints (("goal" :use (:instance intersection-equal-dia-b-segs-f-helper + (z (dia x)))))) + +(defthm select-scrublist + (implies + (not (member a l)) + (equal (select a (scrublist l st)) + (select a st)))) + +(defthm current-scrublist + (equal + (current (scrublist segs st)) + (current st))) + +(defthm selectlist-scrublist + (implies + (equal (intersection-equal x y) nil) + (equal + (selectlist x (scrublist y st)) + (selectlist x st)))) + +(defthm member-set-difference-equal + (iff + (member e (set-difference-equal l1 l2)) + (and + (member e l1) + (not (member e l2))))) + +(defthm intersection-equal-set-difference + (equal + (intersection-equal + (intersection-equal a b) + (set-difference-equal c b)) + nil)) + +;; We will prove that the firewall works by casesplitting on which +;; partition is the current partition. For each of the cases we use +;; the separation axiom to posit a state that is "equivalent" to the +;; actual state with respect to an arbitrary memory segment of b. The +;; following rule helps that proof along by using a free variable +;; match of the equivalent state. + +(defthm black-from-equivalent-allblack + (implies + (and + (equal (select seg (next st)) (select seg (next st2))) + (blacklist (segslist (allparts)) st2)) + (black seg (next st))) + :hints (("goal" :use (:instance black-function-of-segment + (st1 (next st)) + (st2 (next st2)) + (x seg))))) + +;; Now, each of the cases. The current partition is either b, f, or +;; some other partition, and we prove a lemma about each case + +;(defthm firewall-step-kernel +; (implies (and (subsetp segs (segs 'b)) +; (blacklist segs st) +; (equal (current st) (kernel-name))) +; (blacklist segs (next st))) +; :hints (("Subgoal *1/3'" :use +; (:instance separation (seg (car segs)) +; (st1 st) +; (st2 (scrublist (set-difference-equal +; (segslist (allparts)) +; segs) +; st)))))) + +(defthm firewall-step-firewall-helper + (implies (and (subsetp segs (segs 'b)) + (blacklist segs st) + (equal (current st) 'f)) + (blacklist segs (next st))) + :hints (("Subgoal *1/3'" :cases ((equal (car segs) 'outbox))) + ("Subgoal *1/3.2" :use + (:instance separation (seg (car segs)) + (st1 st) + (st2 (scrublist (set-difference-equal + (segslist (allparts)) + segs) + st)))))) + +(defthm firewall-step-firewall + (implies (and (blacklist (segs 'b) st) + (equal (current st) 'f)) + (blacklist (segs 'b) (next st))) + :hints (("goal" :use (:instance firewall-step-firewall-helper + (segs (segs 'b)))))) + + +(defthm firewall-step-black-helper + (implies (and (blacklist (segs 'b) st) + (equal (current st) 'b) + (subsetp segs (segs 'b))) + (blacklist segs (next st))) + :hints (("Subgoal *1/2'" :use + (:instance separation (seg (car segs)) + (st1 st) + (st2 (scrublist (set-difference-equal + (segslist (allparts)) + (segs 'b)) + st)))))) + +(defthm firewall-step-black + (implies (and (blacklist (segs 'b) st) + (equal (current st) 'b)) + (blacklist (segs 'b) (next st))) + :hints (("goal" :use (:instance firewall-step-black-helper + (segs (segs 'b)))))) + +(defthm intersection-equal-segs-b-segs-other-helper + (implies + (and + (not (equal other 'b)) + (not (equal other 'f)) +; (not (equal other (kernel-name))) + (member x (segs 'b)) + (member other (allparts)) + (subsetp z (dia x))) + (equal (intersection-equal z (segs other)) nil)) + :hints (("Subgoal *1/3''" + :use (:instance dia-setup (seg2 x) (seg1 (car z)) + (p other) + ;; (p2 other) obsolete + ))) + :rule-classes nil) + +(defthm intersection-equal-segs-b-segs-other + (implies + (and + (not (equal other 'b)) + (not (equal other 'f)) +; (not (equal other (kernel-name))) + (member x (segs 'b)) + (member other (allparts))) + (equal (intersection-equal (dia x) (segs other)) nil)) + :hints (("goal" :use + (:instance intersection-equal-segs-b-segs-other-helper + (z (dia x)))))) + +(defthm firewall-step-other-helper + (implies (and (blacklist (segs 'b) st) +; (not (equal (current st) (kernel-name))) + (not (equal (current st) 'f)) + (not (equal (current st) 'b)) + (member (current st) (allparts)) + (subsetp segs (segs 'b))) + (blacklist segs (next st))) + :hints (("Subgoal *1/2'" :use + (:instance separation (seg (car segs)) + (st1 st) + (st2 (scrublist (set-difference-equal + (segslist (allparts)) + (segs 'b)) + st)))))) +(defthm firewall-step-other + (implies (and (blacklist (segs 'b) st) +; (not (equal (current st) (kernel-name))) + (not (equal (current st) 'f)) + (not (equal (current st) 'b)) + (member (current st) (allparts))) + (blacklist (segs 'b) (next st))) + :hints (("goal" :use (:instance firewall-step-other-helper + (segs (segs 'b)))))) + + +;; We combine the sublemmas about a single step into a single lemma +;; about a single step +(defthm firewall-step + (implies + (blacklist (segs 'b) st) + (blacklist (segs 'b) (next st))) + :hints (("goal" :use ( ;firewall-step-kernel + firewall-step-black + firewall-step-firewall + firewall-step-other)))) + +;; +;; The firewall system works: Data in partition b is always black +;; +(defthm firewall-works + (implies + (blacklist (segs 'b) st) + (blacklist (segs 'b) (run st n)))) diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/make-consistency-test.lisp b/books/workshops/2003/greve-wilding-vanfleet/support/make-consistency-test.lisp new file mode 100644 index 0000000..0fbc2a5 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/make-consistency-test.lisp @@ -0,0 +1,47 @@ + + +;; This code sets up a file that tests whether the axioms of the file +;; firewallworks.lisp are consistent with the axioms introduced in the +;; encapsulates of the files separation.lisp and firewallspec.lisp. + +;; It would be better if ACL2 provided this capability directly, but +;; with some sneaky coding we arrange things so that ACL2 checks that +;; the axioms are consistent. + +(defun read-forms (ifile) + (let ((form (read ifile nil nil))) + (and + form + (cons form (read-forms ifile))))) + +(defun read-all-forms (file) + (with-open-file + (ifile file :direction :input) + (read-forms ifile))) + +;; The forms we need to execute in the consistency test +(defun test-forms () + `( + (include-book "../../../../data-structures/set-theory") + (ld "separation.lisp") + (puff :x) + (ld "firewallspec.lisp") + (puff :x) + + ;; load all the axioms from the file, changing the axioms to defthms + ,@(remove nil + (mapcar + #'(lambda (x) + (if (equal (car x) 'defaxiom) + `(defthm ,@(cdr x)) + nil)) + (read-all-forms "firewallworks.lisp"))) + (ubt! 1) + (certify-book "consistency-test-passed"))) + +(defun make-test (file) + (with-open-file + (ofile file :direction :output) + (mapcar #'(lambda (x) (format ofile "~%~S" x)) (test-forms)))) + + diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/separation.acl2 b/books/workshops/2003/greve-wilding-vanfleet/support/separation.acl2 new file mode 100644 index 0000000..863bcdf --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/separation.acl2 @@ -0,0 +1,4 @@ +(value :q) +(lp) +(include-book "../../../../data-structures/set-theory") +(certify-book "separation" ? t) diff --git a/books/workshops/2003/greve-wilding-vanfleet/support/separation.lisp b/books/workshops/2003/greve-wilding-vanfleet/support/separation.lisp new file mode 100644 index 0000000..bff2596 --- /dev/null +++ b/books/workshops/2003/greve-wilding-vanfleet/support/separation.lisp @@ -0,0 +1,118 @@ +(in-package "ACL2") + +;; Requires set-theory book +;; (include-book "/accts/dagreve/local/src/acl2-2.6/gcl/books/data-structures/set-theory") + +(encapsulate + +;; DIA +;; input: memory segment +;; output: list of memory segments from which direct interaction +;; is allowed + (((dia *) => *) + +;; CURRENT +;; input: machine state +;; output: name of current partition + ((current *) => *) + +;; ALLPARTS +;; input: none +;; output: list of partition names + ((allparts) => *) + +;; KERNEL-NAME +;; input: none +;; output: name of kernel partition +;; ((kernel-name) => *) + +;; SELECT +;; input: memory segment name, machine state +;; output: memory segment values associated segment name + ((select * *) => *) + +;; NEXT +;; input: machine state +;; output: machine state after one step + ((next *) => *) + +;; SEGS +;; input: partition name +;; output: list of memory segment names associated with partition + ((segs *) => *) + + ) + +;; direct interation allowed: list of segments that can communicate +;; directly with seg +(local (defun dia (seg) (list seg))) + +; (local (defun kernel-name () 'k)) + +;; current partition name of st +(local (defun current (st) (declare (ignore st)) 'b)) + +;; list of partition names in st +(local (defun allparts () '(b f))) + +(defthm current-is-partition + (member (current st) (allparts))) + +;(defthm kernel-is-partition +; (member (kernel-name) (allparts))) + +;; Select a segment from state +(local (defun select (seg st) (declare (ignore seg st)) nil)) + +;; Select a list of segments given a list of segment names +(defun selectlist (segs st) + (if (consp segs) + (cons + (select (car segs) st) + (selectlist (cdr segs) st)) + nil)) + +(local (defun next (st) st)) + +(defun run (st n) + (if (zp n) + st + (run (next st) (1- n)))) + +;; The segments associated with a partition name +(local (defun segs (partname) (declare (ignore partname)) nil)) + +;; The segments associated with a list of partition names +(defun segslist (partnamelist) + (if (consp partnamelist) + (append + (segs (car partnamelist)) + (segslist (cdr partnamelist))) + nil)) + +;; Correctness of underlying separation system +(defthm separation + (let ((segs (intersection-equal (dia seg) (segs (current st1))))) + (implies + (and + (equal (selectlist segs st1) (selectlist segs st2)) + (equal (current st1) (current st2)) + (equal (select seg st1) (select seg st2))) + (equal + (select seg (next st1)) + (select seg (next st2)))))) + +;;; The "kernel" partition is the partition switch code. It is special +;;; in several ways. Part of the specification of its correctness is +;;; that it does not change the state of any of the other partitions. + +;(defthm kernel-touches-nothing +; (implies +; (and +; (member seg (segs p)) +; (not (equal p (kernel-name)))) +; (equal +; (intersection-equal (dia seg) (segs (kernel-name))) +; nil))) + +) diff --git a/books/workshops/2003/greve-wilding_defrecord/defrecord.pdf.gz b/books/workshops/2003/greve-wilding_defrecord/defrecord.pdf.gz Binary files differnew file mode 100644 index 0000000..08cf99d --- /dev/null +++ b/books/workshops/2003/greve-wilding_defrecord/defrecord.pdf.gz diff --git a/books/workshops/2003/greve-wilding_defrecord/defrecord.ps.gz b/books/workshops/2003/greve-wilding_defrecord/defrecord.ps.gz Binary files differnew file mode 100644 index 0000000..cc030a4 --- /dev/null +++ b/books/workshops/2003/greve-wilding_defrecord/defrecord.ps.gz diff --git a/books/workshops/2003/greve-wilding_defrecord/support/defrecord.lisp b/books/workshops/2003/greve-wilding_defrecord/support/defrecord.lisp new file mode 100644 index 0000000..39d4d92 --- /dev/null +++ b/books/workshops/2003/greve-wilding_defrecord/support/defrecord.lisp @@ -0,0 +1,245 @@ +#| + +Typed records in ACL2 + +This file contains an enhancement to the ACL2 standard "records" book. +We introduce the macro "defrecord" to define an accessor and updater +function for a record structure with elements of a particular type. +This facility extends somewhat the hypothesis-less theorems of the +standard ACL2 "records" book. Besides providing a convenient way to +introduce multiple record structures, this macro adds a theorem to the +theorems provided by that book: namely, that the accessor function +returns values of the right "type". + +For example, + + (include-book ;; defeat dependency checker + "XXX/books/misc/records") + + (defun sbp16 (x) + (declare (xargs :guard t)) + (and + (integerp x) + (<= (- (expt 2 15)) x) + (< x (expt 2 15)))) + + (defun fix-sbp16 (x) + (declare (xargs :guard t)) + (if (sbp16 x) x 0)) + + (defrecord sbp :rd getbv :wr putbv :fix fix-sbp16 :typep sbp16) + +The "raw" record structure introduced in the standard records book is +used to define records defined using defrecord, and the functions for +accessing and updating a record that are introduced by defrecord are +proved to have many of the same properties as the records in the +standard records book. In particular, assume that the record +introduced by defrecord has operations (g a r) and (s a v r) that get +and set elements of record r for address a and value v. We prove the +following lemmas, each of which also holds of "raw" records: + +(defthm g-same-s + (equal (g a (s a v r)) + v)) + +(defthm g-diff-s + (implies (not (equal a b)) + (equal (g a (s b v r)) + (g a r)))) + +(defthm s-same-g + (equal (s a (g a r) r) + r)) + +(defthm s-same-s + (equal (s a y (s a x r)) + (s a y r))) + +(defthm s-diff-s + (implies (not (equal a b)) + (equal (s b y (s a x r)) + (s a x (s b y r)))) + :rule-classes ((:rewrite :loop-stopper ((b a s))))) + +In addition, the defrecord macro proves one additional lemma that is +not provable about raw records: + +(defthm typep-g + (typep (g a r))) + +for a typep predicate provided by the user. + +What makes this implementation of records interesting is that it has +the peculiar property that each of the lemmas has no "type" +hypotheses. This makes reasoning about operations considerably +easier, but the implementation of the record operations is obscure, to +say the least. We are interested in providing an implementation to +show that the theorems listed above are consistent. + +(Historical Note: Matt Kaufmann of AMD proposed a challenge problem to +the ACL2 list in March, 2000 to define a "get" and "set" function +without hypotheses, based on a request of Rob Sumner's. Kaufmann +released his version, which uses a bizarre record implementation to +avoid the type hypotheses. (We posted our independantly-derived +solution to the challenge to the ACL2 list in Mar 2000, which uses a +strikingly similar approach. Is there basically only one way to +implement these functions?) An improved version that exploits the +total order of ACL2 objects was developed by Kaufmann and Sumners and +presented at the 2002 ACL2 workshop, and this book is incorporated +into the standard ACL2 books. In 2002 we realized that we needed data +element type information - for example, that a memory returns only +bit-vectors - and wanted to continue to avoid unnecessary hypotheses. +This led us to create this enhancement.) + +David Greve and Matt Wilding +November 2002 + +|# + +(in-package "ACL2") + +(include-book "../../../../misc/records") + +(defthm equal-s-record-equality + (implies + (and + (equal rec2 rec1) + (equal v (g a rec1))) + (and (iff (equal rec1 (s a v rec2)) t) + (iff (equal (s a v rec2) rec1) t)))) + +(defun symbol-list-to-string (list) + (declare (type (satisfies symbol-listp) list)) + (if (consp list) + (concatenate 'string (symbol-name (car list)) (symbol-list-to-string (cdr list))) + "")) + +(defmacro join-symbols (witness &rest rst) + `(intern-in-package-of-symbol (symbol-list-to-string (list ,@rst)) ,witness)) + +(defmacro defrecord (name &key (rd 'nil) (wr 'nil) (fix 'ifix) (default '0) (typep 'integerp)) + + (let* ((base name) + (rd (if (null rd) (join-symbols name name '-rd) rd)) + (wr (if (null wr) (join-symbols name name '-wr) wr)) + (wf (join-symbols name 'wf- typep)) + (zp (join-symbols name typep '-zp)) + (wf-forward (join-symbols name wf '-forward)) + ) + + `(encapsulate + () + + (defun ,zp (x) + (declare (type t x)) + (equal (,fix x) ,default)) + + (defun ,wf (x) + (declare (type t x)) + (and (consp x) + (,typep (car x)) + (not (,zp (car x))) + (not (,wf (cdr x))))) + + (in-theory (disable (,zp) (,wf))) + + (defthm ,wf-forward + (implies (,wf x) + (and (consp x) + (,typep (car x)) + (not (,zp (car x))) + (not (,wf (cdr x))))) + :rule-classes (:forward-chaining)) + + (defun ,wr (a v m) + (declare (type t a v m)) + (let ((x (g a m))) + (if (,wf x) + (if (,zp v) + (s a (cdr x) m) + (s a (cons (,fix v) (cdr x)) m)) + (if (,zp v) m + (s a (cons (,fix v) x) m))))) + + (defun ,rd (a m) + (declare (type t a m)) + (let ((x (g a m))) + (if (,wf x) (car x) + ,default))) + + + (defthm ,(join-symbols base rd '-same- wr '-hyps) + (implies (equal a b) + (equal (,rd a (,wr b v r)) + (,fix v)))) + + (defthm ,(join-symbols base rd '-diff- wr '-hyps) + (implies (not (equal a b)) + (equal (,rd a (,wr b v r)) + (,rd a r)))) + + (defthm ,(join-symbols base wr '-same- rd '-hyps) + (implies (equal a b) + (equal (,wr a (,rd b r) r) + r))) + + (defthm ,(join-symbols base wr '-diff- wr '-hyps) + (implies (not (equal a b)) + (equal (,wr b y (,wr a x r)) + (,wr a x (,wr b y r)))) + :rule-classes ((:rewrite :loop-stopper ((b a ,wr))))) + + (defthm ,(join-symbols base wr '-same- wr '-hyps) + (implies (equal a b) + (equal (,wr a y (,wr b x r)) + (,wr a y r)))) + + (defthm ,(join-symbols base rd '-of- wr '-redux) + (equal (,rd a (,wr b v r)) + (if (equal b a) (,fix v) + (,rd a r))) + :hints (("goal" :in-theory (disable ,fix ,rd ,wr)))) + + (defthm ,(join-symbols base wr '-same- rd) + (equal (,wr a (,rd a r) r) + r)) + + (defthm ,(join-symbols base wr '-same- wr) + (equal (,wr a y (,wr a x r)) + (,wr a y r))) + + (defthm ,(join-symbols base typep '- rd) + (and (,typep (,rd a r)) + (equal (,fix (,rd a r)) + (,rd a r)))) + + (defun ,(join-symbols base wr '==r-hyp) (v a r) + (declare (type t v a r)) + (equal (,fix v) (,rd a r))) + + (defthm ,(join-symbols base wr '==r) + (implies + (and + (,(join-symbols base wr '==r-hyp) v a r1) + (equal r2 r1)) + (and (iff (equal r1 (,wr a v r2)) t) + (iff (equal (,wr a v r2) r1) t)))) + + (defun ,(join-symbols base wr '== wr '-hyp) (v1 v2) + (declare (type t v1 v2)) + (equal (,fix v1) (,fix v2))) + + (in-theory (disable (,(join-symbols base wr '== wr '-hyp)))) + + (defthm ,(join-symbols base wr '== wr) + (implies + (and + (equal a1 a2) + (,(join-symbols base wr '== wr '-hyp) v1 v2) + (equal r2 r1)) + (iff (equal (,wr a1 v1 r1) (,wr a2 v2 r2)) t))) + + (in-theory (disable ,(join-symbols base rd '-of- wr '-redux) + ,rd ,wr)) + + ))) diff --git a/books/workshops/2003/greve-wilding_mbe/mbe.pdf.gz b/books/workshops/2003/greve-wilding_mbe/mbe.pdf.gz Binary files differnew file mode 100644 index 0000000..a96a335 --- /dev/null +++ b/books/workshops/2003/greve-wilding_mbe/mbe.pdf.gz diff --git a/books/workshops/2003/greve-wilding_mbe/mbe.ps.gz b/books/workshops/2003/greve-wilding_mbe/mbe.ps.gz Binary files differnew file mode 100644 index 0000000..68b8859 --- /dev/null +++ b/books/workshops/2003/greve-wilding_mbe/mbe.ps.gz diff --git a/books/workshops/2003/greve-wilding_mbe/support/README b/books/workshops/2003/greve-wilding_mbe/support/README new file mode 100644 index 0000000..e6d128b --- /dev/null +++ b/books/workshops/2003/greve-wilding_mbe/support/README @@ -0,0 +1,23 @@ +These files contain an optimized version of a program that searches +for a path in a graph. It is the subject of 2 ACL2 workshop papers, +one in 2000 by Matt Wilding and one in 2003 by David Greve and Matt +Wilding, that describe using ACL2 features to build fast and +verifiable software. + +A makefile creates books from two files + + fpst.lisp - definition of the optimized pathfinder and proof that + it is equivalent to previously distributed version + + run-fpst.lisp - definitions that provide for benchmarking the + pathfinder + +Currently-unreleased ACL2 2.8 builds these books in about 2 minutes. + +This proof relies upon books developed by J Moore that are freely +available and documented in the chapter "An Exercise in Graph Theory" +in the book "Computer-Aided Reasoning: ACL2 Case Studies". + +David Greve +Matt Wilding +June 2003
\ No newline at end of file diff --git a/books/workshops/2003/greve-wilding_mbe/support/fpst.lisp b/books/workshops/2003/greve-wilding_mbe/support/fpst.lisp new file mode 100644 index 0000000..5fd4a8f --- /dev/null +++ b/books/workshops/2003/greve-wilding_mbe/support/fpst.lisp @@ -0,0 +1,905 @@ +(in-package "ACL2") + +#| + +A Verified Pathfinder +--------------------- + +These files contain an optimized version of a program that searches +for a path in a graph. It is the subject of 2 ACL2 workshop papers, +one in 2000 by Matt Wilding and one in 2003 by David Greve and Matt +Wilding, that describe using ACL2 features to build fast and +verifiable versions of these programs. + +The initial version of this file introduced a stobj representing the +state that was proved equal to a (proved) pathfinding implementation +of J Moore's, and is documented in the 2000 paper. Subsequently, the +proof was updated to work with the publically-released version of +Moore's proof distributed with the ACL2 book chapter in which Moore +wrote about this example. An issue identified and discussed at length +in Wilding's 2000 paper is the need to add complexity to some programs +in order to prove termination. In ACL2, sometimes this complexity +would not be necessary if there were some way to ensure that the +guards to the function would be met. Wilding required an axiom in his +2000 example to prove that the fastest possible implementation of the +otherwise-proved program was correct. The axiom was justified with an +informal argument, but its use highlighted a weakness in ACL2. + +In 2003, Matt Kaufmann asked us to try out an experimental feature of +ACL2, MBE (which stands for "must be equal"). This feature allows the +introduction of executable versions of functions that can be justified +by appeal to their guards. This led us to reimplement the pathfinding +program and associated proof yet again to demonstrate how this fast +implementation can now be proved correct with no assumptions. + +This book certifies in experimental ACL2 2.8 in about 2 minutes. See +the companion file "run-fpst.lisp" for functions that support the +running the pathfinding program. + +Matt Wilding and David Greve +February 2003 + + +Some original documentation for this program: + +xx Stobj-Based Linear Find Path +xx +xx Matt Wilding +xx July 1999 + +xx J Moore developed an example in 1998 of a linear path search. He +xx wrote the example of in some detail, and it is a wonderful example +xx of doing a small software proof using ACL2. Subsequently, inspired +xx he writes in large part by our executable formal model work, J +xx added stobjs to ACL2. +xx +xx This file contains a linear path search program written in ACL2 +xx that uses stobjs for data structures. My goal in doing this is to +xx use stobjs in a context besides microprocessor models to explore +xx how practical this mechanism is for writing efficient, analyzable +xx code. DSH suggested doing something softwarish with stobj last +xx January. +xx +xx We implement a pathfinding algorithm that employs stobjs. It runs +xx fast and is proved correct. Given a graph with numbered nodes and +xx edges, the program finds a path between two nodes if possible. +xx +xx For example, for a graph with nodes +xx +xx 0 (with edges to 1 and 2), +xx 1 (with no edges), +xx 2 (with edges to each of the nodes), and +xx 3 (with an edge to 1) +xx +xx the program finds a path between nodes 0 and 3: +xx +xx ACL2 !>(assign g '((0 1 2) (1) (2 0 1 2 3) (3 1))) +xx ((0 1 2) (1) (2 0 1 2 3) (3 1)) +xx ACL2 !>(linear-find-st 0 3 (@ g) st) +xx ((0 2 3) <st>) +xx +xx J Moore proved a similar program correct in 1999. He documented +xx his example in a chapter titled "An Exercise in Graph Theory" in +xx the book "Using the ACL2 Theorem Prover: ACL2 Case Studies", +xx published by Kluwer in 2000. It is an interesting example of a +xx multiply-recursive program that has been proved correct using ACL2. + +xx Matt Wilding reimplemented Moore's program using stobjs to +xx represent the state of the computation. This optimization avoided +xx datastructure accesses that were not linear time operations. ACL2 +xx was used to verify that the optimized version calculates the same +xx path as the previously-verified version in Moore's paper. This +xx example is documented in "Using a Single-Threaded Object to Speed a +xx Verified Graph Pathfinder" presented to the 2nd ACL2 Workshop in +xx 2000. + +|# + +; This example assumes J Moore's linear-find-path proof. +(include-book "../../../1999/graph/linear-find-path") +(include-book "../../../../ordinals/e0-ordinal") +(set-well-founded-relation e0-ord-<) + +(set-verify-guards-eagerness 2) + +;; We introduce a version of J's lfns that does not do the irrelevant +;; check. The irrelevancy of the subset check is something J points +;; out in the comments of his example, and he proves the neccessary +;; lemmas, but he doesn't bother to fix it. We go ahead and get it +;; out of the way so it doesn't complicate our later proofs + +(defthm linear-find-next-step-simpler + (equal + (linear-find-next-step c stack b g mt) + (cond + ((endp c) (mv 'failure mt)) + ((markedp (car c) mt) + (linear-find-next-step (cdr c) stack b g mt)) + ((equal (car c) b) + (mv (rev (cons b stack)) + mt)) + (t (mv-let (temp new-mt) + (linear-find-next-step (neighbors (car c) g) + (cons (car c) stack) + b g + (mark (car c) mt)) + (cond + ((eq temp 'failure) + (linear-find-next-step (cdr c) stack b g new-mt)) + (t (mv temp mt))))))) + :rule-classes :definition) + +(in-theory (disable linear-find-next-step)) + +;; We introduce a stobj that has many of the datastructures we need to +;; write our version of this program. There are two operations that +;; we particularly want to optimize: detecting whether a node has been +;; marked, and finding the neighbors of a node. We implement the +;; datastuctures that are involved in these operations, the graph and +;; the mark list, using stobj arrays. We also add to the stobj a status +;; bit to indicate failure and success so as to avoid using mv-let. + +;; Note that the stack is handled somewhat less efficiently because of +;; its constant-time operations. We could speed things further by +;; implementing the stack as something other than a list to avoid gc. + +;; maximum number of nodes in the graph +(defmacro maxnode () '2500) + +;; +(defstobj st + (g :type (array list (2500)) :initially nil) ; list of edges + (marks :type (array (integer 0 1) (2500)) :initially 0) ; visited? + (stack :type (satisfies true-listp)) ; path + (status :type (integer 0 1) :initially 0)) ; 0 = success, 1 = failure + +;; indicies into datastructure +(defmacro gindex () 0) +(defmacro marksindex () 1) +(defmacro stackindex () 2) +(defmacro statusindex () 3) + +;; Some miscellaneous rules that will be useful about st + +(defthm <=-cancel + (equal + (<= a (+ y b)) + (<= (- a y) b)) + :rule-classes nil) + +(defthm <-cancel + (implies + (syntaxp (quotep y)) + (equal + (< (+ y b) a) + (< b (+ (- a y))))) + :hints (("goal" :use <=-cancel))) + +(defmacro bounded-natp (a max) + `(and (integerp ,a) (<= 0 ,a) (< ,a ,max))) + +(defthm integerp-nth-marksp + (implies + (and + (marksp l) + (integerp i) + (<= 0 i) + (< i (len l))) + (acl2-numberp (nth i l)))) + +;; We introduce the notion of the number of unmarked nodes in the +;; graph, which will be used as a measure function to prove +;; termination of our algorithm. + +(defun number-unmarked1 (st i) + (declare (xargs :stobjs st + :guard (and (stp st) (bounded-natp i (1+ (maxnode)))) + :measure (max 0 (nfix (- (maxnode) i))))) + (if (and (integerp i) (< i (maxnode))) + (if (= (marksi i st) 1) + (number-unmarked1 st (1+ i)) + (1+ (number-unmarked1 st (1+ i)))) + 0)) + +(defun number-unmarked (st) + (declare (xargs :stobjs st + :guard (stp st))) + (number-unmarked1 st 0)) + +;; Some facts about number-unmarked + +(defthm number-unmarked1-update-nth-other + (implies + (not (equal j (marksindex))) + (equal + (number-unmarked1 (update-nth j v st) i) + (number-unmarked1 st i)))) + +(defthm number-unmarked1-above + (implies + (and + (< i k) + (bounded-natp i (maxnode))) + (equal + (number-unmarked1 (list nil (update-nth i 1 l)) k) + (number-unmarked1 (list nil l) k)))) + +(defthm number-unmarked1-marked + (implies + (and + (<= k i) + (bounded-natp i (maxnode)) + (bounded-natp k (maxnode))) + (equal + (number-unmarked1 (list nil (update-nth i 1 l)) k) + (if (equal (nth i l) 1) + (number-unmarked1 (list nil l) k) + (1- (number-unmarked1 (list nil l) k)))))) + +(defthm number-unmarked1-hack + (equal + (number-unmarked1 st k) + (number-unmarked1 (list nil (nth (marksindex) st)) k)) + :rule-classes nil) + +(defthm number-unmarked1-update-nth-1-update-nth + (implies + (and + (<= k i) + (bounded-natp i (maxnode)) + (bounded-natp k (maxnode))) + (equal + (number-unmarked1 (update-nth (marksindex) (update-nth i 1 (nth (marksindex) st)) st) k) + (if (equal (nth i (nth (marksindex) st)) 1) + (number-unmarked1 st k) + (1- (number-unmarked1 st k))))) + :hints (("goal" + :use ((:instance number-unmarked1-hack + (st (update-nth (marksindex) (update-nth i 1 (nth (marksindex) st)) st))) + number-unmarked1-hack)))) + +(defun measure-st (c st) + (declare (xargs :stobjs st + :guard (stp st))) + (cons + (1+ (number-unmarked st)) + (len c))) + +(defun numberlistp (l max) + (declare (xargs :guard (integerp max))) + (if (consp l) + (and + (bounded-natp (car l) max) + (numberlistp (cdr l) max)) + (equal l nil))) + +(defthm true-listp-numberlistp + (implies + (numberlistp l n) + (true-listp l))) + +;; A graph is an alist with nodes as keys and edge lists as values +(defun graphp1-st (st i) + (declare (xargs :stobjs st + :measure (max 0 (nfix (- (maxnode) i))))) + (if (and (bounded-natp i (maxnode)) (stp st)) + (and + (numberlistp (gi i st) (maxnode)) + (graphp1-st st (1+ i))) + t)) + +(defun graphp-st (st) + (declare (xargs :stobjs st)) + (and + (stp st) + (graphp1-st st 0))) + +;; We want to use a reverse function. We might use "rev", but no +;; guard is proved for it. Since we don't want to modify anything +;; outside this proof, we add our own. + +(defun myrev (x) + (declare (xargs :guard (true-listp x))) + (if (endp x) + nil + (append (myrev (cdr x)) (list (car x))))) + +(defthm true-listp-myrev + (true-listp (myrev l))) + +(defthm true-listp-update-nth-rewrite + (implies + (true-listp l) + (true-listp (update-nth i v l)))) + +(defun repeat (n v) + (if (and (integerp n) (< 0 n)) (cons v (repeat (1- n) v)) nil)) + +(defthm len-repeat + (equal (len (repeat n v)) (nfix n))) + +(defthm nlistp-update-nth + (implies + (not (consp l)) + (equal (update-nth i v l) (append (repeat i nil) (list v))))) + +(defmacro coerce-node (x) + `(let ((nx (nfix ,x))) (if (<= (maxnode) nx) 0 nx))) + +(in-theory (disable update-nth nth)) + +(in-theory (disable number-unmarked1)) + +#| +;; Comment from the July, 1999 version of this proof: + +xx ;; Finally, the stobj-based algorithm. + +xx ;This is a good example of when we wish we could use the guards in +xx ;the logic. The st argument is guarded with graphp-st, which +xx ;potentially provides us with an important fact needed for the +xx ;termination proof: when marking a previously-unmarked node, we are +xx ;in fact in the mark array's range. However, guards are not usable +xx ;in a proof about the logic, so we are left to our own devices. +xx ;The most obvious thing to do is to guard the body of the function +xx ;by adding (graphp-st st) to it, but this is obviously very +xx ;inefficient. My solution is to coerce the pointer to be in range +xx ;before its use: it'll slow down execution a bit, but during proof +xx ;with the assumption of correct type it'll be quickly simplified +xx ;away. + +xx ;This problem would be eliminated by the addition of defbody to +xx ;ACL2, as J and Matt have talked about doing. + +xx ;; Just as J in his example, we first introduce a version that has +xx ;; an irrelevant check in it that eases the measure proof. After +xx ;; proving that the check is in fact irrelevant, we add the +xx ;; "real" definition. + +xx ;; c is the list of neighbors being explored, b is the goal node + +|# + +;; Feb 2003 - We have updated this function to exploit MBE, an +;; experimental feature that is expected to be part of ACL2 2.8. The +;; executable version omits the guards needed to prove termination. +;; When we prove the guards of this function, we will be obliged to +;; prove that, assuming the function arguments meet the assumed +;; guards, the two versions are identical. + +(defun linear-find-next-step-st-mbe (c b st) + (declare (xargs :stobjs st + :measure (measure-st c st) + :guard (and (graphp-st st) + (bounded-natp b (maxnode)) + (numberlistp c (maxnode))) + :verify-guards nil)) + (mbe + :logic + (if (endp c) st + (let ((cur (coerce-node (car c))) + (temp (number-unmarked st))) + (cond + ((equal (marksi cur st) 1) + (linear-find-next-step-st-mbe (cdr c) b st)) + ((equal cur b) + (let ((st (update-status 0 st))) + (update-stack (myrev (cons (car c) (stack st))) st))) + (t (let ((st (update-marksi cur 1 st))) + (let ((st (update-stack (cons (car c) (stack st)) st))) + (let ((st (linear-find-next-step-st-mbe (gi cur st) b st))) + (if (or (<= temp (number-unmarked st)) ; always nil + (equal (status st) 0)) + st + (let ((st (update-stack (cdr (stack st)) st))) + (linear-find-next-step-st-mbe (cdr c) b st)))))))))) + :exec + (if (endp c) st + (cond + ((equal (marksi (car c) st) 1) + (linear-find-next-step-st-mbe (cdr c) b st)) + ((equal (car c) b) + (let ((st (update-status 0 st))) + (update-stack (myrev (cons b (stack st))) st))) + (t (let ((st (update-marksi (car c) 1 st))) + (let ((st (update-stack (cons (car c) (stack st)) st))) + (let ((st (linear-find-next-step-st-mbe (gi (car c) st) b st))) + (if (equal (status st) 0) + st + (let ((st (update-stack (cdr (stack st)) st))) + (linear-find-next-step-st-mbe (cdr c) b st))))))))))) + +;; We prove a bunch of lemmas needed for the guard proof of lfns-st + +(defthm true-listp-linear-find-next-step-st-mbe + (implies + (true-listp st) + (true-listp (linear-find-next-step-st-mbe c b st)))) + +(defthm number-unmarked-positive + (<= 0 (number-unmarked st)) + :rule-classes :linear) + +(in-theory (disable number-unmarked)) + +(defthm marksp-append + (implies + (true-listp x) + (equal + (marksp (append x y)) + (and (marksp x) (marksp y))))) + +(defthm marksp-repeat + (equal + (marksp (repeat n x)) + (or + (zp n) + (bounded-natp x 2)))) + +(defthm marksp1-update-nth + (implies + (and + (integerp v) (<= 0 v) (<= v 1) + (<= i (len l)) + (marksp l)) + (marksp (update-nth i v l))) + :hints (("goal" :in-theory (enable update-nth)))) + +(defthm nth-0-linear-find-next-step-st-mbe + (equal + (nth (gindex) (linear-find-next-step-st-mbe c b st)) + (nth (gindex) st))) + +(defthm marksp1-linear-find-next-step-st-mbe + (implies + (and + (marksp (nth (marksindex) st)) + (equal (len (nth (marksindex) st)) (maxnode))) + (and + (marksp (nth (marksindex) (linear-find-next-step-st-mbe c b st))) + (equal (len (nth (marksindex) (linear-find-next-step-st-mbe c b st))) + (maxnode))))) + +(in-theory (disable len true-listp graphp1-st)) + +(defthm true-listp-cdr + (implies + (true-listp l) + (true-listp (cdr l)))) + +(defthm true-listp-stack + (implies + (true-listp (nth (stackindex) st)) + (true-listp (nth (stackindex) (linear-find-next-step-st-mbe c b st))))) + +(defthm integerp-status + (implies + (integerp (nth (statusindex) st)) + (integerp (nth (statusindex) (linear-find-next-step-st-mbe c b st))))) + +(defthm status-linear1 + (implies + (<= 0 (nth (statusindex) st)) + (<= 0 (nth (statusindex) (linear-find-next-step-st-mbe c b st)))) + :rule-classes (:linear :rewrite)) + +(defthm status-linear2 + (implies + (not (< 1 (nth (statusindex) st))) + (not (< 1 (nth (statusindex) (linear-find-next-step-st-mbe c b st))))) + :rule-classes (:linear :rewrite)) + +(defthm len-linear-find-next-step-st-mbe + (implies + (equal (len st) 4) + (equal (len (linear-find-next-step-st-mbe c b st)) 4))) + +(defthm stp-linear-find-next-step-st-mbe + (implies + (stp st) + (stp (linear-find-next-step-st-mbe c b st)))) + +(defthm stp-update-nth + (implies + (stp st) + (and + (equal (stp (update-nth (gindex) v st)) + (and + (gp v) + (equal (len v) (maxnode)))) + (equal (stp (update-nth (marksindex) v st)) + (and + (marksp v) + (equal (len v) (maxnode)))) + (equal (stp (update-nth (stackindex) v st)) + (stackp v)) + (equal (stp (update-nth (statusindex) v st)) + (statusp v))))) + +(defthm neighbors-graphp-st + (implies + (and + (graphp1-st st i) + (<= i j) + (< j (maxnode)) + (bounded-natp i (maxnode)) + (bounded-natp j (maxnode)) + (stp st)) + (numberlistp (nth j (nth (gindex) st)) (maxnode))) + :hints (("goal" :in-theory (enable graphp1-st)))) + +(defthm graphp1-st-update-nth-other + (implies + (and + (graphp1-st st i) + (stp st) + (not (equal j 0)) + (bounded-natp j 5)) + (graphp1-st (update-nth j marks st) i)) + :hints (("goal" :in-theory (enable graphp1-st)))) + +(defthm graphp-st-update-nth-other + (implies + (and + (graphp-st st) + (stp st) + (not (equal j 0)) + (bounded-natp j 5)) + (equal + (graphp-st (update-nth j marks st)) + (stp (update-nth j marks st)))) + :hints (("goal" :in-theory (enable graphp-st)))) + +(defthm graphp1-st-linear-find-next-step-st-mbe + (implies + (and + (graphp1-st st i) + (stp st)) + (graphp1-st (linear-find-next-step-st-mbe c b st) i))) + +(defthm graphp-st-linear-find-next-step-st-mbe + (implies + (graphp-st st) + (graphp-st (linear-find-next-step-st-mbe c b st)))) + +(defthm consp-of-truelistp + (implies + (true-listp l) + (iff (consp l) l))) + +(defthm len-append + (equal (len (append x y)) (+ (len x) (len y))) + :hints (("goal" :in-theory (enable len)))) + +(defthm len-myrev + (equal (len (myrev x)) (len x)) + :hints (("goal" :in-theory (enable len)))) + +(defthm len-stack + (<= (len (nth (stackindex) st)) + (len (nth (stackindex) (linear-find-next-step-st-mbe c b st)))) + :hints (("Subgoal *1/3.1" :expand (LINEAR-FIND-NEXT-STEP-ST-MBE C 0 ST)) + ("goal" :in-theory (enable len)))) + +(defthm len-linear + (<= 0 (len l)) + :rule-classes :linear + :hints (("goal" :in-theory (enable len)))) + +(defthm len-bound-hack + (equal + (< 0 (len l)) + (not (equal (len l) 0)))) + +(defthm equal-len-0 + (equal + (equal (len l) 0) + (not (consp l))) + :hints (("goal" :in-theory (enable len)))) + +(defthm stack-hack + (implies + (and + (nth (stackindex) st) + (true-listp (nth (stackindex) st))) + (nth (stackindex) (linear-find-next-step-st-mbe c b st))) + :hints (("goal" :use len-stack + :in-theory (set-difference-theories (enable len) + '(len-stack))))) +(defthm linear-unmarked-not-increased + (>= (number-unmarked1 st 0) + (number-unmarked1 (linear-find-next-step-st-mbe c b st) 0)) + :rule-classes :linear) + +;; The simpler version of the algorithm is equivalent to the one we +;; just proved. + +(defthm linear-find-next-step-st-mbe-simpler + (implies + (and + (graphp-st st) + (bounded-natp b (maxnode)) + (numberlistp c (maxnode))) + (equal + (linear-find-next-step-st-mbe c b st) + (if (endp c) st + (cond + ((equal (marksi (car c) st) 1) + (linear-find-next-step-st-mbe (cdr c) b st)) + ((equal (car c) b) + (let ((st (update-status 0 st))) + (update-stack (myrev (cons b (stack st))) st))) + (t (let ((st (update-marksi (car c) 1 st))) + (let ((st (update-stack (cons (car c) (stack st)) st))) + (let ((st (linear-find-next-step-st-mbe (gi (car c) st) b st))) + (if (equal (status st) 0) + st + (let ((st (update-stack (cdr (stack st)) st))) + (linear-find-next-step-st-mbe (cdr c) b st))))))))))) + :hints (("goal" :in-theory (enable number-unmarked))) + :rule-classes nil) + +;; We verify the guards of our program, which includes an obligation +;; to show that the unguarded executable version is identical to the +;; logical version of the definition body. +(verify-guards linear-find-next-step-st-mbe + :hints (("goal" :use linear-find-next-step-st-mbe-simpler))) + + +;; Now we prove that our stobj representation and J's alist +;; representation are equivalence. "equivalent" means... + +(defun graph-equivp1 (alist st i) + (declare (xargs :measure (max 0 (- (maxnode) (nfix i))) + :verify-guards nil + :stobjs st)) + (if (< (nfix i) (maxnode)) + (and + (equal (neighbors i alist) (gi i st)) + (graph-equivp1 alist st (1+ (nfix i)))) + t)) + +(defun graph-equivp (alist st) + (declare (xargs :verify-guards nil + :stobjs st)) + (graph-equivp1 alist st 0)) + +(defun mark-equivp1 (list st i) + (declare (xargs :measure (max 0 (- (maxnode) (nfix i))) + :verify-guards nil + :stobjs st)) + (if (< (nfix i) (maxnode)) + (and + (iff (member i list) (equal (marksi i st) 1)) + (mark-equivp1 list st (1+ (nfix i)))) + t)) + +(defun mark-equivp (list st) + (declare (xargs :verify-guards nil + :stobjs st)) + (mark-equivp1 list st 0)) + +(defun equiv (stack g mt st) + (declare (xargs :stobjs st + :verify-guards nil)) + (and + (equal stack (stack st)) + (graph-equivp g st) + (mark-equivp mt st))) + +(in-theory (disable graph-equivp mark-equivp)) + +(defthm stack-of-failed-search + (implies + (not (equal (nth (statusindex) (linear-find-next-step-st-mbe c b st)) 0)) + (equal (nth (stackindex) (linear-find-next-step-st-mbe c b st)) (stack st))) + :hints (("goal" :in-theory (enable number-unmarked)))) + +(defthm graph-equivp1-update-nth-other + (implies + (not (zp i)) + (equal (graph-equivp1 g (update-nth i v st) j) + (graph-equivp1 g st j)))) + +(defthm graph-equivp-update-nth-other + (implies + (not (zp i)) + (equal (graph-equivp g (update-nth i v st)) + (graph-equivp g st))) + :hints (("goal" :in-theory (enable graph-equivp)))) + +(defthm graph-equivp-linear-find-next-step-st-mbe + (equal (graph-equivp g (linear-find-next-step-st-mbe c b st)) + (graph-equivp g st)) + :hints (("goal" :in-theory (enable linear-find-next-step-st-mbe)))) + +(defthm mark-equivp1-update-nth-other + (implies + (not (equal i (marksindex))) + (equal (mark-equivp1 g (update-nth i v st) j) + (mark-equivp1 g st j)))) + +(defthm mark-equivp-update-nth-other + (implies + (not (equal i (marksindex))) + (equal (mark-equivp g (update-nth i v st)) + (mark-equivp g st))) + :hints (("goal" :in-theory (enable mark-equivp)))) + +(set-irrelevant-formals-ok :warn) + +;; We need to show ACL2 how to induct on the merged definitions +;; This is pretty tricky due to the multiply recursive nature of +;; the program. + +; Because a recursive call of lfns contains a value that is a function +; of another recursive call, the inductive schema definition appears +; in the proof obligations that get generated. We've arranged for the +; schema definition to compute exactly what the stobj version does so +; that the induction we use is the right one. + +(defun induct-equiv (c b st stack g mt) + (declare (xargs :stobjs st + :measure (measure-st c st) + :guard (and (graphp-st st) + (bounded-natp b (maxnode)) + (numberlistp c (maxnode))) + :verify-guards nil + :hints (("goal" :in-theory (enable number-unmarked len))))) + (if (endp c) st + (let ((cur (coerce-node (car c))) + (temp (number-unmarked st))) ; note for "irrelevant" check + (cond + ((equal (marksi cur st) 1) + (induct-equiv (cdr c) b st stack g mt)) + ((equal cur b) + (let ((st (update-status 0 st))) + (update-stack (myrev (cons (car c) (stack st))) st))) + (t (let ((st (update-marksi cur 1 st))) + (let ((st (update-stack (cons (car c) (stack st)) st))) + (let ((st (induct-equiv (gi cur st) b st (cons (car c) stack) + g (cons (car c) mt)))) + (if (or (<= temp (number-unmarked st)) ; always nil + (equal (status st) 0)) + st + (let ((st (update-stack (cdr (stack st)) st))) + (mv-let (temp2 new-mt) + (linear-find-next-step (neighbors (car c) g) + (cons (car c) stack) + b g + (mark (car c) mt)) + (declare (ignore temp2)) + (induct-equiv (cdr c) b st stack g new-mt)))))))))))) + +(defthm induct-equiv-is-lfns-st + (equal + (induct-equiv c b st stack g mt) + (linear-find-next-step-st-mbe c b st)) + :hints (("goal" :induct (induct-equiv c b st stack g mt) + :in-theory (set-difference-theories + (enable induct-equiv linear-find-next-step-st-mbe number-unmarked) + '(FIND-NEXT-STEP-AVOIDING-CONS + STEP1 REV binary-append step2))))) + +(defthm nth-mark-equivp1 + (implies + (and + (mark-equivp1 mt st i) + (bounded-natp i (maxnode)) + (bounded-natp j (maxnode)) + (<= i j)) + (iff + (equal (nth j (nth (marksindex) st)) 1) + (member j mt)))) + +(defthm nth-mark-equivp + (implies + (and + (mark-equivp mt st) + (bounded-natp j (maxnode))) + (iff + (equal (nth j (nth (marksindex) st)) 1) + (member j mt))) + :hints (("goal" :in-theory (set-difference-theories (enable mark-equivp) + '(mark-equivp1))))) +(defthm mark-equivp1-above1 + (implies + (and + (< i j) + (integerp i) + (integerp j)) + (equal + (mark-equivp1 (cons i mt) st j) + (mark-equivp1 mt st j)))) + +(defthm mark-equivp1-above2 + (implies + (and + (< i j) + (bounded-natp i (maxnode)) + (integerp j)) + (equal + (mark-equivp1 mt (update-nth (marksindex) (update-nth i 1 (nth (marksindex) st)) st) j) + (mark-equivp1 mt st j)))) + +(defthm mark-equivp1-add + (implies + (and + (mark-equivp1 mt st j) + (<= j i) + (bounded-natp j (maxnode)) + (integerp i)) + (mark-equivp1 (cons i mt) (update-nth (marksindex) (update-nth i 1 (nth (marksindex) st)) st) j)) + :hints (("goal" :expand + (:free (x) + (mark-equivp1 (cons x mt) + (update-nth (marksindex) (update-nth x 1 (nth (marksindex) st)) + st) + x))))) + +(defthm mark-equivp-add + (implies + (and + (mark-equivp mt st) + (integerp i) + (<= 0 i)) + (mark-equivp (cons i mt) (update-nth (marksindex) (update-nth i 1 (nth (marksindex) st)) st))) + :hints (("goal" :in-theory (set-difference-theories (enable mark-equivp) + '(mark-equivp1))))) +(defthm nth-graph-equivp1 + (implies + (and + (graph-equivp1 g st i) + (bounded-natp i (maxnode)) + (bounded-natp j (maxnode)) + (<= i j)) + (equal + (neighbors j g) + (gi j st)))) + +(defthm nth-graph-equivp + (implies + (and + (graph-equivp g st) + (bounded-natp j (maxnode))) + (equal + (neighbors j g) + (gi j st))) + :hints (("goal" :in-theory (enable graph-equivp)))) + +(defthm graphp-st-means-stp + (implies + (graphp-st st) + (stp st)) + :rule-classes :forward-chaining) + +(defthm true-listp-cons + (equal + (true-listp (cons a b)) + (true-listp b)) + :hints (("goal" :in-theory (enable true-listp)))) + +(defthm myrev-is-rev + (equal (myrev x) (rev x))) + +;;; The stobj implementation of lfp works just like the original +;;; list-based one. + +(defthm implementations-same + (implies + (and + (equiv stack g mt st) + (graphp-st st) + (not (equal (status st) 0)) + (numberlistp c (maxnode)) + (numberlistp stack (maxnode)) + (bounded-natp b (maxnode))) + (let ((st (linear-find-next-step-st-mbe c b st))) + (mv-let (temp marks) (linear-find-next-step c stack b g mt) + (or + (and (not (equal (status st) 0)) (equal temp 'failure) (mark-equivp marks st)) + (and (equal (status st) 0) (not (equal temp 'failure)) (equal temp (stack st))))))) + :hints (("goal" :in-theory (enable linear-find-next-step-st-mbe linear-find-next-step + number-unmarked) + :induct (induct-equiv c b st stack g mt))) + :rule-classes nil) diff --git a/books/workshops/2003/greve-wilding_mbe/support/run-fpst.lisp b/books/workshops/2003/greve-wilding_mbe/support/run-fpst.lisp new file mode 100644 index 0000000..a009c8b --- /dev/null +++ b/books/workshops/2003/greve-wilding_mbe/support/run-fpst.lisp @@ -0,0 +1,425 @@ +(in-package "ACL2") + +#| + +We introduce functions for loading the datastructure of the +stobj-based pathfinding program and prove that the loading and +calculating of this optimized program works just like the original +implementation. + +See also "fpst.lisp". + +Matt Wilding and David Greve +Updated February, 2003 + +|# + +;; Assumes the "find path - stobj" program is loaded +(include-book "fpst") + +(set-verify-guards-eagerness 2) + +;; We want to prove the guards of the functions we need from J's +;; proof. However, some of the functions are not guard-provable +;; because the guards weren't in place. In this case, we add a +;; function with the same body and the needed guards, and use that +;; instead. + +(defun myall-nodes (g) + (declare (xargs :guard (alistp g))) + (cond ((endp g) nil) + (t (cons (car (car g)) + (myall-nodes (cdr g)))))) + +(defthm myall-nodes-is-all-nodes + (equal + (myall-nodes g) + (all-nodes g))) + +; mygraph1p is just like J's graph1p, except that the node and the +; children are in-range naturals. +(defun mygraph1p (g nodes) + (declare (xargs :guard (and (true-listp nodes) (alistp g)))) + (cond ((endp g) t) + (t (and (consp (car g)) + (true-listp (cdr (car g))) + (numberlistp (car g) (maxnode)) ; needed for stobj version + (subsetp (cdr (car g)) nodes) + (no-duplicatesp (cdr (car g))) + (mygraph1p (cdr g) nodes))))) + +(defthm mygraph1p-is-graph1p + (implies + (mygraph1p g nodes) + (graph1p g nodes))) + +(defun mygraphp (g) + (declare (xargs :guard (alistp g))) + (and (alistp g) + (eqlable-listp (myall-nodes g)) + (no-duplicatesp (myall-nodes g)) + (mygraph1p g (myall-nodes g)))) + +(defthm mygraphp-is-graphp + (implies + (mygraphp g) + (graphp g))) + +(defun myneighbors (node g) + (declare (xargs :guard (alistp g))) + (cond ((endp g) nil) + ((equal node (car (car g))) + (cdr (car g))) + (t (myneighbors node (cdr g))))) + +(defthm myneighbors-is-neighbors + (equal + (myneighbors n g) + (neighbors n g))) + +(defthm consp-neighbors + (implies + (mygraph1p g l) + (iff + (consp (neighbors i g)) + (neighbors i g)))) + +(defthm gp-update-nth + (implies + (and + (gp g) + (listp v) + (bounded-natp i max)) + (gp (update-nth i v g))) + :hints (("goal" :in-theory (enable update-nth)))) + + +;; Now, some functions that allow us to load the stobj with +;; values in the datastructures used by J's implementation. + +(defun load-graph1 (g i st) + (declare (xargs :stobjs st + :guard (and (stp st) (alistp g) + (bounded-natp i (1+ (maxnode))) + (mygraphp g)) + :measure (max 0 (nfix (- (maxnode) i))))) + (if (or (not (integerp i)) (not (< i (maxnode)))) + st + (let + ((st (update-gi i (myneighbors i g) st))) + (load-graph1 g (1+ i) st)))) + +(defun load-graph (g st) + (declare (xargs :stobjs st + :guard (and (stp st) (alistp g) (mygraphp g)))) + (load-graph1 g 0 st)) + +(defun init-marks1 (i st) + (declare (xargs :stobjs st + :guard (and (stp st) (bounded-natp i (1+ (maxnode)))) + :measure (max 0 (nfix (- (maxnode) i))))) + (if (or (not (integerp i)) (not (< i (maxnode)))) + st + (let + ((st (update-marksi i 0 st))) + (init-marks1 (1+ i) st)))) + +;; Some rules about our loading functions +(defthm stp-load-graph1 + (implies + (and + (stp st) + (mygraphp g) + (integerp i) + (<= 0 i)) + (stp (load-graph1 g i st)))) + +(defthm stp-init-marks1 + (implies + (and + (stp st) + (integerp i) + (<= 0 i)) + (stp (init-marks1 i st)))) + +(defthm nth-init-marks1-other + (implies + (not (equal i (marksindex))) + (equal (nth i (init-marks1 j st)) + (nth i st)))) + +(defun init-marks (st) + (declare (xargs :stobjs st :guard (stp st))) + (init-marks1 0 st)) + +(defun load-st (g st) + (declare (xargs :stobjs st + :guard (and (stp st) (alistp g) (mygraphp g)))) + (let ((st (load-graph g st))) + (let ((st (init-marks st))) + (let ((st (update-status 1 st))) + (let ((st (update-stack nil st))) + st))))) + +(defthm graph-equivp-only-on-g + (implies + (equal (nth (gindex) st1) (nth (gindex) st2)) + (equal + (graph-equivp1 g st1 i) + (graph-equivp1 g st2 i))) + :rule-classes nil) + +(defthm graph-equivp1-init-marks + (equal + (graph-equivp1 g (init-marks1 i st) i) + (graph-equivp1 g st i)) + :hints (("goal" :use (:instance graph-equivp-only-on-g + (st1 (init-marks1 i st)) (st2 st))))) +(defthm graphp1-equal-graphs + (implies + (and + (equal (nth (gindex) st1) (nth (gindex) st2)) + (stp st1) + (stp st2)) + (iff + (graphp1-st st1 i) + (graphp1-st st2 i))) + :hints (("goal" :in-theory (enable graphp1-st))) + :rule-classes nil) + +(defthm graphp1-st-lesser + (implies + (and + (graphp1-st st i) + (bounded-natp i j)) + (graphp1-st st j)) + :hints (("goal" :in-theory (enable graphp1-st)))) + +(defthm graphp1-st-init-marks + (implies + (and + (stp st) + (integerp i) + (<= 0 i)) + (equal + (graphp1-st (init-marks1 i st) i) + (graphp1-st st i))) + :hints (("goal" :use (:instance graphp1-equal-graphs + (st1 (init-marks1 i st)) (st2 st)) + :in-theory (disable stp)))) + +(defthm nth-0-load-graph1-above + (implies + (and + (bounded-natp i j) + (integerp j)) + (equal + (nth i (nth (gindex) (load-graph1 g j st))) + (nth i (nth (gindex) st))))) + +(defthm graph-equivp1-load-graph1 + (implies + (bounded-natp i (maxnode)) + (graph-equivp1 g (load-graph1 g i st) i)) + :hints (("Subgoal *1/3'" :expand (:free (x) (LOAD-GRAPH1 G x ST))) + ("Subgoal *1/3''" :expand (:free (x n) (GRAPH-EQUIVP1 G x n))))) + +(defthm nth-1-init-marks-above + (implies + (and + (bounded-natp i j) + (integerp j)) + (equal + (nth i (nth (marksindex) (init-marks1 j st))) + (nth i (nth (marksindex) st))))) + +(defthm mark-equivp1-init-marks1 + (implies + (and + (integerp i) + (<= 0 i)) + (mark-equivp1 nil (init-marks1 i st) i))) + +(defthm equiv-load-st + (equiv nil g nil (load-st g st)) + :hints (("goal" :in-theory (set-difference-theories + (enable graph-equivp mark-equivp) + '(graph-equivp1 mark-equivp1 init-marks1))))) + +(defthm numberlistp-neighbors + (implies + (mygraph1p g n) + (numberlistp (neighbors i g) (maxnode)))) + +(defthm graph1p-st-load-graph1 + (implies + (and + (mygraphp g) + (integerp i) + (<= 0 i)) + (graphp1-st (load-graph1 g i st) i)) + :hints (("goal" :in-theory (enable load-graph1 graphp1-st)))) + +(defun linear-find-st (a b g st) + (declare (xargs :stobjs st + :guard (and (stp st) + (bounded-natp a (maxnode)) + (bounded-natp b (maxnode)) + (alistp g) + (mygraphp g)))) + (let ((st (load-st g st))) + (let ((st (linear-find-next-step-st-mbe (list a) b st))) + (if (not (equal (status st) 0)) + (mv 'failure st) + (mv (stack st) st))))) + +(defthm nth-init-marks1 + (implies + (and + (integerp j) + (integerp i) + (<= 0 i) + (<= j i) + (< i (maxnode))) + (equal (nth i (nth (marksindex) (init-marks1 j st))) + 0)) + :hints (("goal" :expand ((INIT-MARKS1 I ST))))) + +(defthm linear-find-next-step-st-mbe-base + (implies + (and + (equal (nth i (nth (marksindex) st)) 0) + (bounded-natp i (maxnode)) + (equal (stack st) nil)) + (equal (nth (stackindex) (linear-find-next-step-st-mbe (list i) i st)) (list i))) + :hints (("goal" :expand (linear-find-next-step-st-mbe (list i) i st)))) + +(defthm nth-load-graph1 + (implies + (and + (integerp i) + (<= 0 i) + (not (equal i (gindex)))) + (equal (nth i (load-graph1 g j st)) + (nth i st)))) + +;; **************** +;; Main lemma +;; **************** +;; Our implementation returns the same value as the original +;; list-based one when we load the stobj using the functions +;; of this file. +(defthm linear-find-st-linear-find-path + (implies + (and + (bounded-natp a (maxnode)) + (bounded-natp b (maxnode)) + (mygraphp g) + (stp st)) + (equal + (car (linear-find-st a b g st)) + (linear-find-path a b g))) + :hints (("goal" :use ((:instance implementations-same (stack nil) (mt nil) (c (list a)) + (st (load-st g st))) + equiv-load-st) + :in-theory (disable linear-find-path-is-find-path equiv-load-st stp)))) + +#| +ACL2 !>(assign g '((0 1 2) (1) (2 0 1 2 3) (3 1))) + ((0 1 2) (1) (2 0 1 2 3) (3 1)) +ACL2 !>(mygraphp (@ g)) +T +ACL2 !>(stp st) +T +ACL2 !>(linear-find-st 0 3 (@ g) st) +((0 2 3) <st>) +ACL2 !>(linear-find-path 0 3 (@ g)) +(0 2 3) + +|# + +;; Some functions for building graphs + +;; Generate a graph with nodes numbered curr though last and edges +;; from each node to the list all +(defun completeg-helper (curr last all) + (declare (xargs :verify-guards t)) + (declare (xargs :measure (nfix (- (1+ (nfix last)) (nfix curr))))) + (if (<= (nfix curr) (nfix last)) + (cons + (cons curr all) + (completeg-helper (1+ (nfix curr)) last all)) + nil)) + +;; Generate a list of naturals from curr to last +(defun listofnats (curr last) + (declare (xargs :verify-guards t + :measure (nfix (- (1+ (nfix last)) (nfix curr))))) + (if (<= (nfix curr) (nfix last)) + (cons + curr + (listofnats (1+ (nfix curr)) last)) + nil)) + +;; Generate a complete graph with nodes 0 to size-1 +(defun completeg (size) + (declare (xargs :verify-guards t)) + (completeg-helper 0 (1- (nfix size)) (listofnats 0 (1- (nfix size))))) + +;; Generate a "bad" graph with n nodes. Nodes 0..n-1 are a complete +;; graph, and node n is disconnected +(defun badg (size) + (declare (xargs :verify-guards t)) + (cons + (list size) + (completeg size))) + +#| + +The pathfinder can be run from the ACL2 read-eval-print loop. + +First, load this book + + ACL2 !>(include-book + "run-fpst") + Loading /accts/dagreve/local/src/acl2-2.8a/books/arithmetic/equalities.o + start address -T 1827ecc Finished loading /accts/dagreve/local/src/acl2-2.8a/books/arithmetic/equalities.o + Loading /accts/dagreve/local/src/acl2-2.8a/books/arithmetic/rational-listp.o + + ... + + Summary + Form: ( INCLUDE-BOOK ; manual editing by Matt K. to avoid Makefile-deps dependency + "run-fpst" ...) + Rules: NIL + Warnings: None + Time: 1.49 seconds (prove: 0.00, print: 0.00, other: 1.49) + "/accts/dagreve/ACL/challenges/graph/run-fpst.lisp" + +Next, load the datastructure with a graph. In this example, we load a +graph with 1,000 nodes and 1,000,000 edges, which takes about a minute. + + ACL2 !>(load-st (badg 1000) st) + <st> + +We try to find a non-existent path so that the program traverses all +the edges. This requires less than a second. + + ACL2 !>(linear-find-next-step-st-mbe (list 0) 1000 st) + <st> + ACL2 !>(status st) + 1 + +We reset the marks array and search for an existing path. Note that +it's not guaranteed to be the shortest one, only a valid one. + + ACL2 !>(init-marks st) + <st> + ACL2 !>(linear-find-next-step-st-mbe (list 0) 6 st) + <st> + ACL2 !>(status st) + 0 + ACL2 !>(stack st) + (0 1 2 3 4 5 6) + +|# diff --git a/books/workshops/2003/hbl/dynamic-hbl.pdf.gz b/books/workshops/2003/hbl/dynamic-hbl.pdf.gz Binary files differnew file mode 100644 index 0000000..28382cb --- /dev/null +++ b/books/workshops/2003/hbl/dynamic-hbl.pdf.gz diff --git a/books/workshops/2003/hbl/dynamic-hbl.ps.gz b/books/workshops/2003/hbl/dynamic-hbl.ps.gz Binary files differnew file mode 100644 index 0000000..20b30ae --- /dev/null +++ b/books/workshops/2003/hbl/dynamic-hbl.ps.gz diff --git a/books/workshops/2003/hbl/hanbing-slides.pdf.gz b/books/workshops/2003/hbl/hanbing-slides.pdf.gz Binary files differnew file mode 100644 index 0000000..285df95 --- /dev/null +++ b/books/workshops/2003/hbl/hanbing-slides.pdf.gz diff --git a/books/workshops/2003/hbl/hanbing-slides.ps.gz b/books/workshops/2003/hbl/hanbing-slides.ps.gz Binary files differnew file mode 100644 index 0000000..74a8cef --- /dev/null +++ b/books/workshops/2003/hbl/hanbing-slides.ps.gz diff --git a/books/workshops/2003/hbl/support/sol1.lisp b/books/workshops/2003/hbl/support/sol1.lisp new file mode 100644 index 0000000..4841a1f --- /dev/null +++ b/books/workshops/2003/hbl/support/sol1.lisp @@ -0,0 +1,1813 @@ +; A Solution to the Rockwell challenge +; Hanbing Liu (version for submission to ACL2 workshop) +; March 26th, 2003 + + +; Abstract +; Rockwell challenge is about reasoning effectively about updates to dynamic +; data structures in a linear address space. +; +; Dynamic Datastructures in ACL2: A Challenge +; +; David Greve and Matt Wilding +; Nov. 2002 +; http://hokiepokie.org/docs/festival02.txt +; a local copy is in http://melton.csres.utexas.edu + +; The key is to +; (1) recover the notion of objects being independent entities and +; (2) reduce update-on-the fly operations to simpler operations that apply a +; corresponding sequence of updates. + +; START OF THE SCRIPT +; +; This file contains the proofs of the concrete problem. 3 properties as +; described below + +; We assume that two books have been loaded, part of the ACL2 +; distribution: + + +; 1. Problem Set Up +; ***************************** +; (acl2::set-match-free-error nil) ; +(in-package "ACL2") +(include-book "misc/records" :dir :system) +(include-book "arithmetic/top-with-meta" :dir :system) + +(defun seq-int (start len) + (if (zp len) + nil + (cons start + (seq-int (1+ start) (1- len))))) + +(defun unique (list) + (if (consp list) + (and (not (member (car list) (cdr list))) + (unique (cdr list))) + t)) + +;; We introduce two data structures. +;; "A" nodes have 4 words. +;; Words 0 and 3 are scalars and words 1 and 2 are A node pointers. + +;; Collect addresses in the first n nodes of an a structure +(defun a-collect (ptr n ram) + (declare (xargs :measure (nfix n))) + + ; +---+ + ; 0: | | + ; +---+ + ; 1: | o-+--> a-node + ; +---+ + ; 2: | o-+--> a-node + ; +---+ + ; 3: | | + ; +---+ + + (if (zp n) + nil + (if (zp ptr) + nil + (append + (seq-int ptr 4) + (a-collect (g (+ 1 ptr) ram) (1- n) ram) + (a-collect (g (+ 2 ptr) ram) (1- n) ram) + )))) + +;; "B" nodes have 3 words. Word 2 is an integer, words 0 and 1 are +;; B-node pointers. "0" is a null pointer + +;; Collect addresses from the first n nodes of a b structure +(defun b-collect (ptr n ram) + (declare (xargs :measure (nfix n))) + + ; +---+ + ; 0: | o-+--> b-node + ; +---+ + ; 1: | o-+--> b-node + ; +---+ + ; 2: | | + ; +---+ + + (if (zp n) + nil + (if (zp ptr) + nil + (append + (seq-int ptr 3) + (b-collect (g ptr ram) (1- n) ram) + (b-collect (g (+ 1 ptr) ram) (1- n) ram) + )))) + +;; Crawl through at most n nodes in an "a" structure along the second +;; pointer. Modify word 0 of each node by adding word 2 to it. +(defun a-mark-objects (addr n ram) + (declare (xargs :measure (nfix n))) + (if (zp n) ram + (if (zp addr) ram + (let ((ram (s addr (+ (g addr ram) (g (+ 2 addr) ram)) ram))) + (a-mark-objects (g (+ addr 2) ram) (1- n) ram))))) + +;; Crawl through at most n nodes in an "b" structure along the pointer +;; in the first field + +(defun b-mark-objects (addr n ram) + (declare (xargs :measure (nfix n))) + (if (zp n) ram + (if (zp addr) ram + (let ((ram (s (+ 2 addr) 0 ram))) + (b-mark-objects (g addr ram) (1- n) ram))))) + + +(defun compose-bab (ptr1 n1 ptr2 n2 ptr3 n3 ram) + (let ((ram (b-mark-objects ptr1 n1 ram))) + (let ((ram (a-mark-objects ptr2 n2 ram))) + (let ((ram (b-mark-objects ptr3 n3 ram))) + ram)))) + + + +; 2. Proof of property I +; ***************************** +; +; 2.1 Problem Analysis +; ***************************** +; Difficulty: +; Data structures in linear addressed space. +; Abtraction at high level language hides many important assumption. +; (1) Independent entity. +; (2) Well-formness + +(defun make-ram-config (addr n ram) + (list addr n ram)) + +(defun addr (rm-config) + (car rm-config)) +(defun n (rm-config) + (cadr rm-config)) +(defun ram (rm-config) + (caddr rm-config)) + +;; Comment: Introduce RAM-configuration to rephrase the problem in +;; RAM-configuration. The structural equivalence on RCs is used to capture +;; the "shape" of the object at addr being the same. + +(defun rc-s (x v rc) + (let ((addr (addr rc)) + (n (n rc)) + (ram (ram rc))) + (make-ram-config addr n (s x v ram)))) + + +; Strategy: +; To prove (g addr (s addrx v mem)) = (g addr mem) +; The only way we know is to prove +; addr!=addrx +; +; Update on the fly is hard. Thus let's reduce it to +; apply a sequnce of updates. +; +; If we can prove addr not member of updated cells, then we prove the final +; result + +(defun collect-A-updates-dynamic (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) nil + (if (zp addr) nil + (let* ((rc1 (rc-s addr (+ (g addr ram) (g (+ 2 addr) ram)) rc)) + (ram (ram rc1)) + (addr (addr rc1)) + (n (n rc1))) + (append + (list addr) + (collect-A-updates-dynamic (make-ram-config (g (+ 2 addr) ram) (1- n) + ram)))))))) + +(defun apply-A-update (addr ram) + (s addr (+ (g addr ram) (g (+ 2 addr) ram)) ram)) + + +(defun apply-A-updates (seq ram) + (if (endp seq) ram + (apply-A-updates (cdr seq) (apply-A-update (car seq) ram)))) + + +(defthm a-mark-objects-alt-definition + (equal (a-mark-objects addr n ram) + (apply-a-updates (collect-a-updates-dynamic + (make-ram-config addr n ram)) + ram)) + :rule-classes :definition) + +; The above theorem ''a-mark-objects-alt-definition'' +; Reduce the a-mark-objects to apply dynamic + + + +; And we know: +(defun a-updates-w (l) + (if (endp l) nil + (cons (car l) (a-updates-w (cdr l))))) + +(defthm apply-a-updates-equal + (implies (not (member x (a-updates-w updates))) + (equal (g x (apply-a-updates updates ram)) + (g x ram)))) + + +; Thus to prove the final goal +; +; (defthm rd-read-over-a-mark-objects +; (implies +; (let ((list (a-collect ptr n ram))) +; (and (not (member addr list)) +; (unique list))) +; (equal (g addr (a-mark-objects ptr n ram)) +; (g addr ram))) +; +; We need to show the following: *P1* +; (implies (not (member addr (a-collect-1 rc))) +; (not (member addr +; (a-updates-w +; (collect-a-udpate-dynamic rc))))) +; +; where a-collect-1 is + +(defun a-collect-1 (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) nil + (if (zp addr) nil + (append + (seq-int addr 4) + (a-collect-1 (make-ram-config (g (+ 1 addr) ram) (1- n) ram)) + (a-collect-1 (make-ram-config (g (+ 2 addr) ram) (1- n) ram))))))) + + +(defthm a-collect-1-alt-definition + (equal (a-collect addr n ram) + (a-collect-1 (make-ram-config addr n ram))) + :rule-classes :definition) + +; However *P1* is not true. +; We can only a similar *P1* style lemma for + +(defun collect-a-updates-static (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) nil + (if (zp addr) nil + (append + (list addr) + (collect-A-updates-static + (make-ram-config (g (+ 2 addr) ram) (1- n) + ram))))))) + + + + +; Now the Major Task is to show +; (collect-a-updates-dynamic rc) == (collect-A-updates-static rc) +; under the condition of (uniqueness (a-collect-1 rc)) + +; We have the observation that "uniqueness" is not the fundamental reason. +; We need to characterize the "shape" of object does not change, in order to +; prove +; (collect-a-updates-dynamic rc) == (collect-A-updates-static rc) + +; Define structural Equivalent. +; +; Basically, if two objects are structural equivalent, they occupied the same +; range of memory and their components are structural equivalent to each other. +; +(defun struct-equiv-A-ram-config1 (addr1 n1 ram1 addr2 n2 ram2) + (declare (xargs :measure (nfix n1))) + (and (equal addr1 addr2) + (equal n1 n2) + (cond ((zp n1) t) + ((zp addr1) t) + (t (and + (struct-equiv-A-ram-config1 + (g (+ addr1 1) ram1) + (- n1 1) + ram1 + (g (+ addr2 1) ram2) + (- n2 1) + ram2) + (struct-equiv-A-ram-config1 + (g (+ addr1 2) ram1) + (- n1 1) + ram1 + (g (+ addr2 2) ram2) + (- n2 1) + ram2)))))) + +(defun struct-equiv-A-ram-config (rc1 rc2) + (struct-equiv-A-ram-config1 (addr rc1) (n rc1) (ram rc1) + (addr rc2) (n rc2) (ram rc2))) + + +(defthm struct-equiv-A-ram-config1-reflexive + (struct-equiv-A-ram-config1 x1 x2 x3 x1 x2 x3)) + +(defthm struct-equiv-A-ram-config1-symentric + (iff (struct-equiv-A-ram-config1 x12 x22 x32 x11 x21 x31) + (struct-equiv-A-ram-config1 x11 x21 x31 x12 x22 x32))) + +(defthm struct-equiv-A-ram-config1-transitive + (implies (and (struct-equiv-A-ram-config1 x11 x21 x31 x12 x22 x32) + (struct-equiv-A-ram-config1 x12 x22 x32 x13 x23 x33)) + (struct-equiv-A-ram-config1 x11 x21 x31 x13 x23 x33))) + +(defequiv struct-equiv-A-ram-config) + +; For "shape" not change, we need to introduce the concept of link cell and +; data cells. and show structural equivalent state, these two set do not +; change. + +(defun A-collect-link-cells-static (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) nil + (if (zp addr) nil + (append (list (+ addr 1) + (+ addr 2)) + (A-collect-link-cells-static + (make-ram-config (g (+ 1 addr) ram) + (1- n) + ram)) + (A-collect-link-cells-static + (make-ram-config (g (+ 2 addr) ram) + (1- n) + ram))))))) + +(defthm rc-config-accessor + (and (equal (addr (make-ram-config addr n ram)) addr) + (equal (n (make-ram-config addr n ram)) n) + (equal (ram (make-ram-config addr n ram)) ram))) + +(in-theory (disable make-ram-config ram n addr)) + +(defcong struct-equiv-A-ram-config equal (n rc) 1) +(defcong struct-equiv-A-ram-config equal (addr rc) 1) + +(defun cong-induct (rc rc-equiv) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) (list rc rc-equiv) + (if (zp addr) (list rc rc-equiv) + (list (cong-induct (make-ram-config (g (+ 1 addr) ram) + (1- n) + ram) + (make-ram-config (g (+ 1 (addr rc-equiv)) (ram + rc-equiv)) + (1- (n rc-equiv)) + (ram rc-equiv))) + (cong-induct (make-ram-config (g (+ 2 addr) ram) + (1- n) + ram) + (make-ram-config (g (+ 2 (addr rc-equiv)) (ram + rc-equiv)) + (1- (n rc-equiv)) + (ram rc-equiv)))))))) + + +(defthm member-append-1 + (implies (not (member x a)) + (iff (member x (append a b)) + (member x b)))) + +(defthm member-append-2 + (implies (not (member x b)) + (iff (member x (append a b)) + (member x a)))) + +(defthm member-append-3 + (implies (member x b) + (member x (append a b)))) + +(defthm member-append-4 + (implies (member x a) + (member x (append a b)))) + + + +(defcong struct-equiv-A-ram-config equal (A-collect-link-cells-static rc) 1 + :hints (("Goal" :induct (cong-induct rc rc-equiv)))) + +; Now we can state the condition under which the "shape" does not change after +; an update. + +(defthm set-non-link-cells-collect-equal + (implies (not (member x (a-collect-link-cells-static rc))) + (struct-equiv-A-ram-config (rc-s x v rc) rc)) + :hints (("Goal" :induct (a-collect-link-cells-static rc)))) + + +(defun A-collect-data-cells-static (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) nil + (if (zp addr) nil + (append (list addr + (+ addr 3)) + (A-collect-data-cells-static + (make-ram-config (g (+ 1 addr) ram) + (1- n) + ram)) + (A-collect-data-cells-static + (make-ram-config (g (+ 2 addr) ram) + (1- n) + ram))))))) + + +(defcong struct-equiv-A-ram-config equal (A-collect-data-cells-static rc) 1 + :hints (("Goal" :induct (cong-induct rc rc-equiv)))) + + +; We can prove +; under the condition that link cells and data cells do not overlap +; collect-dynamic == collect-static +; + +(defthm addr-member-a-collect-data-cells-static + (let ((n (n rc)) + (addr (addr rc))) + (implies (and (not (zp n)) + (not (zp addr))) + (member addr (a-collect-data-cells-static rc))))) + + +(defthm accessor-rc-s + (and (equal (addr (rc-s x v rc)) (addr rc)) + (equal (n (rc-s x v rc)) (n rc)))) + + + +(defun overlap (a b) + (if (endp a) nil + (or (member (car a) b) + (overlap (cdr a) b)))) + + +(defthm addr-not-a-member-a-collect-link-cells-static + (let ((n (n rc)) + (addr (addr rc))) + (implies (and (not (zp n)) + (not (zp addr)) + (not (overlap (a-collect-data-cells-static rc) + (a-collect-link-cells-static rc)))) + (not (member addr (a-collect-link-cells-static rc)))))) + + +(defthm struct-equiv-A-ram-config1-implies-struct-equiv-A-ram-config1 + (and (implies (and (struct-equiv-A-ram-config1 addr1 n1 ram1 addr2 n2 ram2) + (not (zp n1)) + (not (zp addr1))) + (struct-equiv-A-ram-config + (make-ram-config (g (+ 2 addr1) ram1) (1- n1) ram1) + (make-ram-config (g (+ 2 addr2) ram2) (1- n2) ram2))) + (implies (and (struct-equiv-A-ram-config1 addr1 n1 ram1 addr2 n2 ram2) + (not (zp addr1)) + (not (zp n1))) + (struct-equiv-A-ram-config + (make-ram-config (g (+ 1 addr1) ram1) (1- n1) ram1) + (make-ram-config (g (+ 1 addr2) ram2) (1- n2) ram2))))) + +;; Comment: this is saying if structural equivalent, then branches are +;; structural equivalent. + +(defthm struct-equiv-A-ram-config-implies-struct-equiv-A-ram-config-1 + (let ((addr1 (addr rc1)) + (n1 (n rc1)) + (ram1 (ram rc1)) + (addr2 (addr rc2)) + (n2 (n rc2)) + (ram2 (ram rc2))) + (and (implies (and (struct-equiv-A-ram-config rc1 rc2) + (not (zp (addr rc1))) + (not (zp (n rc1)))) + (struct-equiv-A-ram-config + (make-ram-config (g (+ 2 addr1) ram1) (1- n1) ram1) + (make-ram-config (g (+ 2 addr2) ram2) (1- n2) ram2))) + (implies (and (struct-equiv-A-ram-config rc1 rc2) + (not (zp (addr rc1))) + (not (zp (n rc1)))) + (struct-equiv-A-ram-config + (make-ram-config (g (+ 1 addr1) ram1) (1- n1) ram1) + (make-ram-config (g (+ 1 addr2) ram2) (1- n2) ram2)))))) + +(defthm struct-equiv-A-ram-config-implies-struct-equiv-A-ram-config-1-instance + (let* ((rc1 (rc-s (addr rc) (+ (g (addr rc) (ram rc)) + (g (+ 2 (addr rc)) (ram rc))) rc)) + (rc2 rc) + (addr1 (addr rc1)) + (n1 (n rc1)) + (ram1 (ram rc1)) + (addr2 (addr rc2)) + (n2 (n rc2)) + (ram2 (ram rc2))) + (and (implies (and (struct-equiv-A-ram-config rc1 rc2) + (not (zp (addr rc1))) + (not (zp (n rc1)))) + (struct-equiv-A-ram-config + (make-ram-config (g (+ 2 addr1) ram1) (1- n1) ram1) + (make-ram-config (g (+ 2 addr2) ram2) (1- n2) ram2))) + (implies (and (struct-equiv-A-ram-config rc1 rc2) + (not (zp (addr rc1))) + (not (zp (n rc1)))) + (struct-equiv-A-ram-config + (make-ram-config (g (+ 1 addr1) ram1) (1- n1) ram1) + (make-ram-config (g (+ 1 addr2) ram2) (1- n2) ram2)))))) + +;; Comments: this is bad. that I need to explicitly instantiate the lemma + +(defthm struct-equiv-A-ram-config-implies-struct-equiv-A-ram-config-1-instance-2 + (implies (and (not (overlap (a-collect-data-cells-static rc) + (a-collect-link-cells-static rc))) + (not (zp (addr rc))) + (not (zp (n rc)))) + (struct-equiv-A-ram-config + (MAKE-RAM-CONFIG (G (+ 2 (ADDR RC)) + (RAM (RC-S (ADDR RC) + (+ (G (ADDR RC) (RAM RC)) + (G (+ 2 (ADDR RC)) (RAM RC))) + RC))) + (+ -1 (N RC)) + (RAM (RC-S (ADDR RC) + (+ (G (ADDR RC) (RAM RC)) + (G (+ 2 (ADDR RC)) (RAM RC))) + RC))) + (MAKE-RAM-CONFIG (G (+ 2 (ADDR RC)) + (RAM RC)) + (+ -1 (N RC)) + (RAM RC)))) + :hints (("Goal" :in-theory (disable struct-equiv-A-ram-config rc-s) + :use + struct-equiv-A-ram-config-implies-struct-equiv-A-ram-config-1-instance))) + + +(defthm overlap-append-1 + (implies (overlap a b) + (overlap (append c a) b))) + +(defthm overlap-append-2 + (implies (overlap a b) + (overlap a (append d b)))) + + +(defthm overlap-append-3-cons + (implies (overlap a b) + (overlap a (cons x b)))) + + + +(defthm not-overlap-not-overlap-branch + (implies (and (not (overlap (a-collect-data-cells-static rc) + (a-collect-link-cells-static rc))) + (not (zp (n rc))) + (not (zp (addr rc)))) + (not (overlap (a-collect-data-cells-static + (make-ram-config (G (+ 2 (ADDR RC)) (RAM RC)) + (+ -1 (N RC)) + (RAM RC))) + (a-collect-link-cells-static + (make-ram-config (G (+ 2 (ADDR RC)) (RAM RC)) + (+ -1 (N RC)) + (RAM RC)))))) + :hints (("Goal" :do-not '(generalize)))) + + +(defcong struct-equiv-A-ram-config equal (collect-A-updates-static rc) 1 + :hints (("Goal" :induct (cong-induct rc rc-equiv)))) + + +(defthm not-overlap-implies-collect-a-update-dynamic-equal-static + (implies (not (overlap (a-collect-data-cells-static rc) + (a-collect-link-cells-static rc))) + (equal (collect-a-updates-dynamic rc) + (collect-a-updates-static rc))) + :hints (("Goal" :induct (collect-a-updates-dynamic rc) + :do-not '(generalize) + :in-theory (disable rc-s struct-equiv-A-ram-config)))) + +; After we proved the above +; (equal (collect-a-updates-dynamic rc) +; (collect-a-updates-static rc)) +; +; We need to show (unique (a-collect-1 rc) implies not overlap link + data + + + +; But let us prove the following fact before we move on to show UNIQUE implies NOT OVERLAP +; That is a *P1* style property for collect-a-updates-static +(defthm inrange-seen + (implies (and (not (zp l)) + (integerp x) + (integerp y) + (integerp l) + (< y (+ x l)) + (<= x y)) + (member y (seq-int x l))) + :hints (("Goal" :do-not '(generalize)))) + +(defthm mem-collect-a-updates-static-mem-a-collect-1 + (implies (member x (a-updates-w (collect-a-updates-static rc))) + (member x (a-collect-1 rc))) + :rule-classes ((:rewrite :corollary + (implies (not (member x (a-collect-1 rc))) + (not (member x (a-updates-w (collect-a-updates-static rc)))))))) + +; and this fact + +(defthm not-overlap-g-a-mark + (let ((rc (make-ram-config addr n ram))) + (implies (and (not (overlap (a-collect-data-cells-static rc) + (a-collect-link-cells-static rc))) + (not (member x (a-updates-w (collect-a-updates-static rc))))) + (equal (g x (a-mark-objects addr n ram)) + (g x ram))))) + + +; TO SHOW UNIQUE implies not overlap +(defthm seq-int-1-equal + (equal (seq-int x 1) + (list x)) + :hints (("Goal" :expand (seq-int x 1)))) + + +#| ;; just to show as not closely related result. +(defthm mem-a-collect-mem-link-or-data + (implies (and (member x (a-collect-1 rc)) + (not (member x (a-collect-data-cells-static rc)))) + (member x (a-collect-link-cells-static rc)))) +; either be link or data, possibly being both +|# + +(defthm subset-append-1 + (implies (and (subsetp a b) + (subsetp c b)) + (subsetp (append a c) b))) + +(defthm subset-append-2 + (implies (subsetp a b) + (subsetp a (append c b)))) + +(defthm subset-append-3 + (implies (and (subsetp a b) + (subsetp c d)) + (subsetp (append a c) + (append b d)))) + +(defthm subsetp-link-all + (subsetp (a-collect-link-cells-static rc) + (a-collect-1 rc))) + + +(defthm subsetp-data-all + (subsetp (a-collect-data-cells-static rc) + (a-collect-1 rc))) + + +(defthm member-subsetp + (implies (and (member x a) + (subsetp a b)) + (member x b))) + +(defthm shared-member-not-unique + (implies (and (member x a) + (member x b)) + (not (unique (append a b))))) + +(defthm mem-link-mem-all + (implies (member x (a-collect-link-cells-static rc)) + (member x (a-collect-1 rc))) + :rule-classes :forward-chaining) + +(defthm mem-data-mem-all + (implies (member x (a-collect-data-cells-static rc)) + (member x (a-collect-1 rc))) + :rule-classes :forward-chaining) + + + +(defthm member-link-data-not-unique-lemma + (implies (and (member x (a-collect-data-cells-static rc1)) + (member x (a-collect-link-cells-static rc2))) + (not (unique (append (a-collect-1 rc1) + (a-collect-1 rc2)))))) + + +(defthm not-unique-append + (implies (not (unique a)) + (not (unique (append a b))))) + +(defthm not-unique-append-2 + (implies (not (unique b)) + (not (unique (append a b))))) + +(defthm member-link-data-not-unique + (implies (and (member x (a-collect-data-cells-static rc)) + (member x (a-collect-link-cells-static rc))) + (not (unique (a-collect-1 rc))))) + + +(defun overlap-witness (a b) + (if (endp a) + nil + (if (member (car a) b) + (car a) + (overlap-witness (cdr a) b)))) + +(defthm overlap-witness-mem-a + (implies (overlap a b) + (member (overlap-witness a b) a)) + :rule-classes :forward-chaining) + +(defthm overlap-witness-mem-b + (implies (overlap a b) + (member (overlap-witness a b) b)) + :rule-classes :forward-chaining) + + +(defthm unique-implies-no-overlap + (implies (overlap (a-collect-data-cells-static rc) + (a-collect-link-cells-static rc)) + (not (unique (a-collect-1 rc)))) + :hints (("Goal" :do-not '(generalize))) + :rule-classes ((:rewrite :corollary + (implies (unique (a-collect-1 rc)) + (not (overlap (a-collect-data-cells-static rc) + (a-collect-link-cells-static rc))))))) +;; Finally w proved +;; (implies (overlap (a-collect-data-cells-static rc) +;; (a-collect-link-cells-static rc)) +;; (not (unique (a-collect-1 rc)))) + +(defthm a-collect-unique-implies-not-changed + (implies (and (unique (a-collect addr n ram)) + (not (member x (a-collect addr n ram)))) + (equal (g x (a-mark-objects addr n ram)) + (g x ram)))) + + +;---------------------------------------------------- +; Finally we have the first proof for A + +; Very similar for B data structure. Comment skipped + +(defun collect-B-updates-dynamic (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc))) + (if (zp n) nil + (if (zp addr) nil + (let* ((rc1 (rc-s (+ 2 addr) 0 rc)) + (ram (ram rc1)) + (addr (addr rc1)) + (n (n rc1))) + (append + (list addr) + (collect-B-updates-dynamic (make-ram-config (g addr ram) (1- n) + ram)))))))) + +(defun apply-B-update (addr ram) + (s (+ 2 addr) 0 ram)) + +(defun apply-B-updates (seq ram) + (if (endp seq) ram + (apply-B-updates (cdr seq) (apply-B-update (car seq) ram)))) + + +(defthm B-mark-object-alt-definition + (equal (B-mark-objects addr n ram) + (apply-B-updates (collect-B-updates-dynamic + (make-ram-config addr n ram)) ram)) + :rule-classes :definition) + + +(defun collect-B-updates-static (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) nil + (if (zp addr) nil + (append + (list addr) + (collect-B-updates-static (make-ram-config (g addr ram) (1- n) + ram))))))) + + + +(defun struct-equiv-B-ram-config1 (addr1 n1 ram1 addr2 n2 ram2) + (declare (xargs :measure (nfix n1))) + (and (equal addr1 addr2) + (equal n1 n2) + (cond ((zp n1) t) + ((zp addr1) t) + (t (and + (struct-equiv-B-ram-config1 + (g addr1 ram1) + (- n1 1) + ram1 + (g addr2 ram2) + (- n2 1) + ram2) + (struct-equiv-B-ram-config1 + (g (+ addr1 1) ram1) + (- n1 1) + ram1 + (g (+ addr2 1) ram2) + (- n2 1) + ram2)))))) + +(defun struct-equiv-B-ram-config (rc1 rc2) + (struct-equiv-B-ram-config1 (addr rc1) (n rc1) (ram rc1) + (addr rc2) (n rc2) (ram rc2))) + + +(defthm struct-equiv-B-ram-config1-reflexive + (struct-equiv-B-ram-config1 x1 x2 x3 x1 x2 x3)) + +(defthm struct-equiv-B-ram-config1-symentric + (iff (struct-equiv-B-ram-config1 x12 x22 x32 x11 x21 x31) + (struct-equiv-B-ram-config1 x11 x21 x31 x12 x22 x32))) + +(defthm struct-equiv-B-ram-config1-transitive + (implies (and (struct-equiv-B-ram-config1 x11 x21 x31 x12 x22 x32) + (struct-equiv-B-ram-config1 x12 x22 x32 x13 x23 x33)) + (struct-equiv-B-ram-config1 x11 x21 x31 x13 x23 x33))) + +(defequiv struct-equiv-B-ram-config) + + +(defun B-collect-link-cells-static (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) nil + (if (zp addr) nil + (append (list addr + (+ addr 1)) + (B-collect-link-cells-static + (make-ram-config (g addr ram) + (1- n) + ram)) + (B-collect-link-cells-static + (make-ram-config (g (+ 1 addr) ram) + (1- n) + ram))))))) + + + + +(defcong struct-equiv-B-ram-config equal (n rc) 1) +(defcong struct-equiv-B-ram-config equal (addr rc) 1) + + +(defun cong-induct-B (rc rc-equiv) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) (list rc rc-equiv) + (if (zp addr) (list rc rc-equiv) + (list (cong-induct-B (make-ram-config (g addr ram) + (1- n) + ram) + (make-ram-config (g (addr rc-equiv) + (ram rc-equiv)) + (1- (n rc-equiv)) + (ram rc-equiv))) + (cong-induct-B (make-ram-config (g (+ 1 addr) ram) + (1- n) + ram) + (make-ram-config (g (+ 1 (addr rc-equiv)) (ram + rc-equiv)) + (1- (n rc-equiv)) + (ram rc-equiv)))))))) + +(defcong struct-equiv-B-ram-config equal (B-collect-link-cells-static rc) 1 + :hints (("Goal" :induct (cong-induct-B rc rc-equiv)))) + + + +(defthm B-set-non-link-cells-collect-equal + (implies (not (member x (B-collect-link-cells-static rc))) + (struct-equiv-B-ram-config (rc-s x v rc) rc)) + :hints (("Goal" :induct (B-collect-link-cells-static rc)))) + + + + + +(defun B-collect-data-cells-static (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) nil + (if (zp addr) nil + (append (list (+ addr 2)) + (B-collect-data-cells-static + (make-ram-config (g addr ram) + (1- n) + ram)) + (B-collect-data-cells-static + (make-ram-config (g (+ 1 addr) ram) + (1- n) + ram))))))) + + + +(defcong struct-equiv-B-ram-config equal (B-collect-data-cells-static rc) 1 + :hints (("Goal" :induct (cong-induct-B rc rc-equiv)))) + +;----------------------------- + + + + +(defthm addr-member-B-collect-data-cells-static + (let ((n (n rc)) + (addr (addr rc))) + (implies (and (not (zp n)) + (not (zp addr))) + (member (+ 2 addr) (B-collect-data-cells-static rc))))) + +(defthm addr-not-B-member-a-collect-link-cells-static + (let ((n (n rc)) + (addr (addr rc))) + (implies (and (not (zp n)) + (not (zp addr)) + (not (overlap (b-collect-data-cells-static rc) + (b-collect-link-cells-static rc)))) + (not (member (+ 2 addr) (B-collect-link-cells-static rc)))))) + +(defthm unique-B-collect-1-struct-equiv-B-ram-config + (implies (and (not (overlap (b-collect-data-cells-static rc) + (b-collect-link-cells-static rc))) + (not (zp (n rc))) + (not (zp (addr rc)))) + (struct-equiv-B-ram-config (rc-s (+ 2 (addr rc)) any rc) rc)) + :hints (("Goal" :do-not '(generalize)))) + + + + +(defthm struct-equiv-B-ram-config1-implies-struct-equiv-B-ram-config1 + (and (implies (and (struct-equiv-B-ram-config1 addr1 n1 ram1 addr2 n2 ram2) + (not (zp n1)) + (not (zp addr1))) + (struct-equiv-B-ram-config + (make-ram-config (g addr1 ram1) (1- n1) ram1) + (make-ram-config (g addr2 ram2) (1- n2) ram2))) + (implies (and (struct-equiv-B-ram-config1 addr1 n1 ram1 addr2 n2 ram2) + (not (zp addr1)) + (not (zp n1))) + (struct-equiv-B-ram-config + (make-ram-config (g (+ 1 addr1) ram1) (1- n1) ram1) + (make-ram-config (g (+ 1 addr2) ram2) (1- n2) ram2))))) + + +(defthm struct-equiv-B-ram-config-implies-struct-equiv-B-ram-config-1 + (let ((addr1 (addr rc1)) + (n1 (n rc1)) + (ram1 (ram rc1)) + (addr2 (addr rc2)) + (n2 (n rc2)) + (ram2 (ram rc2))) + (and (implies (and (struct-equiv-B-ram-config rc1 rc2) + (not (zp (addr rc1))) + (not (zp (n rc1)))) + (struct-equiv-B-ram-config + (make-ram-config (g addr1 ram1) (1- n1) ram1) + (make-ram-config (g addr2 ram2) (1- n2) ram2))) + (implies (and (struct-equiv-B-ram-config rc1 rc2) + (not (zp (addr rc1))) + (not (zp (n rc1)))) + (struct-equiv-B-ram-config + (make-ram-config (g (+ 1 addr1) ram1) (1- n1) ram1) + (make-ram-config (g (+ 1 addr2) ram2) (1- n2) ram2)))))) + + +(defthm struct-equiv-B-ram-config-implies-struct-equiv-B-ram-config-1-instance + (let* ((rc1 (rc-s (+ 2 (addr rc)) 0 rc)) + (rc2 rc) + (addr1 (addr rc1)) + (n1 (n rc1)) + (ram1 (ram rc1)) + (addr2 (addr rc2)) + (n2 (n rc2)) + (ram2 (ram rc2))) + (and (implies (and (struct-equiv-B-ram-config rc1 rc2) + (not (zp (addr rc1))) + (not (zp (n rc1)))) + (struct-equiv-B-ram-config + (make-ram-config (g addr1 ram1) (1- n1) ram1) + (make-ram-config (g addr2 ram2) (1- n2) ram2))) + (implies (and (struct-equiv-B-ram-config rc1 rc2) + (not (zp (addr rc1))) + (not (zp (n rc1)))) + (struct-equiv-B-ram-config + (make-ram-config (g (+ 1 addr1) ram1) (1- n1) ram1) + (make-ram-config (g (+ 1 addr2) ram2) (1- n2) ram2)))))) + + +(defthm struct-equiv-B-ram-config-implies-struct-equiv-B-ram-config-1-instance-2 + (implies (and (not (overlap (b-collect-data-cells-static rc) + (b-collect-link-cells-static rc))) + (not (zp (addr rc))) + (not (zp (n rc)))) + (struct-equiv-B-ram-config + (MAKE-RAM-CONFIG (G (ADDR RC) + (RAM (RC-S (+ 2 (addr RC)) 0 RC))) + (+ -1 (N RC)) + (RAM (RC-S (+ 2 (ADDR RC)) 0 RC))) + (MAKE-RAM-CONFIG (G (ADDR RC) + (RAM RC)) + (+ -1 (N RC)) + (RAM RC)))) + :hints (("Goal" :in-theory (disable struct-equiv-B-ram-config rc-s) + :use + struct-equiv-B-ram-config-implies-struct-equiv-B-ram-config-1-instance))) + +;---------------------------------------------------- + +(defthm overlap-cons + (iff (overlap c (cons x d)) + (or (member x c) + (overlap c d)))) + +(defthm overlap-app-app + (implies (overlap a b) + (overlap (append a c) (append b d)))) + + +(defthm not-overlap-not-overlap-branch-B + (implies (and (not (overlap (b-collect-data-cells-static rc) + (b-collect-link-cells-static rc))) + (not (zp (n rc))) + (not (zp (addr rc)))) + (not (overlap (b-collect-data-cells-static + (make-ram-config (G (ADDR RC) (RAM RC)) + (+ -1 (N RC)) + (RAM RC))) + (b-collect-link-cells-static + (make-ram-config (G (ADDR RC) (RAM RC)) + (+ -1 (N RC)) + (RAM RC)))))) + :hints (("Goal" :do-not '(generalize)))) + + +(defcong struct-equiv-B-ram-config equal (collect-B-updates-static rc) 1 + :hints (("Goal" :induct (cong-induct-B rc rc-equiv)))) + + + +(defthm not-overlap-implies-collect-B-update-dynamic-equal-static + (implies (not (overlap (B-collect-data-cells-static rc) + (B-collect-link-cells-static rc))) + (equal (collect-B-updates-dynamic rc) + (collect-B-updates-static rc))) + :hints (("Goal" :induct (collect-B-updates-dynamic rc) + :do-not '(generalize) + :in-theory (disable rc-s struct-equiv-B-ram-config)))) + + +(defun b-updates-w (updates) + (if (endp updates) + nil + (cons (+ 2 (car updates)) + (b-updates-w (cdr updates))))) + +(defthm apply-B-updates-equal + (implies (not (member x (b-updates-w updates))) + (equal (g x (apply-B-updates updates ram)) + (g x ram)))) + + +(defthm not-overlap-g-B-mark + (let ((rc (make-ram-config addr n ram))) + (implies (and (not (overlap (B-collect-data-cells-static rc) + (B-collect-link-cells-static rc))) + (not (member x (b-updates-w (collect-B-updates-static rc))))) + (equal (g x (B-mark-objects addr n ram)) + (g x ram))))) + + +;--------------------------------------------------- +(defun B-collect-1 (rc) + (declare (xargs :measure (nfix (n rc)))) + (let ((n (n rc)) + (addr (addr rc)) + (ram (ram rc))) + (if (zp n) nil + (if (zp addr) nil + (append + (seq-int addr 3) + (B-collect-1 (make-ram-config (g addr ram) (1- n) ram)) + (B-collect-1 (make-ram-config (g (+ 1 addr) ram) (1- n) ram))))))) + + +(defthm B-collect-1-alt-definition + (equal (B-collect addr n ram) + (B-collect-1 (make-ram-config addr n ram))) + :rule-classes :definition) + +;---------------------------------------------------- + +(defthm mem-collect-B-updates-static-mem-B-collect-1 + (implies (member x (b-updates-w (collect-B-updates-static rc))) + (member x (B-collect-1 rc))) + :rule-classes ((:rewrite :corollary + (implies (not (member x (b-collect-1 rc))) + (not (member x (b-updates-w (collect-b-updates-static rc)))))))) + +;--------------------------------------------------- + +(defthm subsetp-link-all-b + (subsetp (b-collect-link-cells-static rc) + (b-collect-1 rc))) + + +(defthm subsetp-data-all-b + (subsetp (b-collect-data-cells-static rc) + (b-collect-1 rc))) + + + +(defthm mem-link-mem-all-b + (implies (member x (b-collect-link-cells-static rc)) + (member x (b-collect-1 rc))) + :rule-classes :forward-chaining) + +(defthm mem-data-mem-all-b + (implies (member x (b-collect-data-cells-static rc)) + (member x (b-collect-1 rc))) + :rule-classes :forward-chaining) + + + +(defthm member-link-data-not-unique-lemma-b + (implies (and (member x (b-collect-data-cells-static rc1)) + (member x (b-collect-link-cells-static rc2))) + (not (unique (append (b-collect-1 rc1) + (b-collect-1 rc2)))))) + + +(defthm member-link-data-not-unique-b + (implies (and (member x (b-collect-data-cells-static rc)) + (member x (b-collect-link-cells-static rc))) + (not (unique (b-collect-1 rc))))) + + +(defthm unique-implies-no-overlap-b + (implies (overlap (b-collect-data-cells-static rc) + (b-collect-link-cells-static rc)) + (not (unique (b-collect-1 rc)))) + :hints (("Goal" :do-not '(generalize))) + :rule-classes ((:rewrite :corollary + (implies (unique (b-collect-1 rc)) + (not (overlap (b-collect-data-cells-static rc) + (b-collect-link-cells-static rc))))))) + + +(defthm b-collect-unique-implies-not-changed + (implies (and (unique (b-collect addr n ram)) + (not (member x (b-collect addr n ram)))) + (equal (g x (b-mark-objects addr n ram)) + (g x ram)))) + + +; 3. Proof of property II +; ***************************** +; +; 3.1 Proof Analysis +; The key point is to prove that update one objects maintain the structural +; equivalent with respect to another object. +; +; Successively reduce composition of X-mark to a composition of apply-X-updates + +; 3.2 Proof Scipts + +; Similarly introduce +(defun collect-bab-updates-dynamic (addr1 n1 addr2 n2 addr3 n3 ram) + (let* ((rc1 (make-ram-config addr1 n1 ram)) + (rc2 (make-ram-config addr2 n2 (apply-B-updates + (collect-B-updates-dynamic rc1) + (ram rc1)))) + (rc3 (make-ram-config addr3 n3 (apply-A-updates + (collect-A-updates-dynamic rc2) + (ram rc2))))) + (list (collect-B-updates-dynamic rc1) + (collect-A-updates-dynamic rc2) + (collect-B-updates-dynamic rc3)))) + + + +(defun apply-bab-updates (l ram) + (apply-B-updates (caddr l) + (apply-a-updates (cadr l) + (apply-B-updates (car l) ram)))) + +(defthm equal-compose-bab-apply-bab + (equal (compose-bab addr1 n1 addr2 n2 addr3 n3 ram) + (apply-bab-updates (collect-bab-updates-dynamic + addr1 n1 addr2 n2 addr3 n3 ram) ram))) + +; Now we need to prove +; +; (defthm unique-equal-collect-dynamic-to-static +; (implies (unique (append (b-collect-1 (make-ram-config addr1 n1 ram)) +; (a-collect-1 (make-ram-config addr2 n2 ram)) +; (b-collect-1 (make-ram-config addr3 n3 ram)))) +; (equal (collect-bab-updates-dynamic addr1 n1 addr2 n2 addr3 n3 ram) +; (collect-bab-updates-static addr1 n1 addr2 n2 addr3 n3 ram))) +; + +; The idea is to successively reduce collect-X-updates-dynamic to +; collect-X-updates-static +; We need to show perservation of structural equivalence with respect to one +; object after updates to other objects +; + + +(defthm make-ram-config-is-struct-equiv-a-ram-config + (STRUCT-EQUIV-A-RAM-CONFIG (MAKE-RAM-CONFIG (ADDR RC) + (N RC) + (RAM RC)) + RC)) + +(defthm make-ram-config-is-struct-equiv-b-ram-config + (STRUCT-EQUIV-B-RAM-CONFIG (MAKE-RAM-CONFIG (ADDR RC) + (N RC) + (RAM RC)) + RC)) + + +(defthm struct-equiv-a-ram-config-apply-B-update + (implies (not (member (+ 2 x) (a-collect-link-cells-static rc))) + (struct-equiv-a-ram-config + (make-ram-config (addr rc) + (n rc) + (apply-B-update x (ram rc))) + rc))) + +(defun no-overlap-induct-A (l rc) + (if (endp l) + (list l rc) + (no-overlap-induct-A (cdr l) + (make-ram-config (addr rc) + (n rc) + (apply-B-update (car l) (ram rc)))))) + + + +(defthm no-overlap-implies-A-struct-equiv-lemma + (implies (not (overlap (b-updates-w l) + (a-collect-link-cells-static rc))) + (struct-equiv-A-ram-config + (make-ram-config (addr rc) + (n rc) + (apply-B-updates l (ram rc))) + rc)) + :hints (("Goal" :do-not '(generalize) + :in-theory (disable apply-B-update struct-equiv-A-ram-config) + :induct (no-overlap-induct-A l rc)))) + +; above is about structure equivalent with respect to A after unrelated B updates +; Similarly for B after A, B after B, (and A after A) + + +(defthm struct-equiv-B-ram-config-apply-A-update + (implies (not (member x (B-collect-link-cells-static rc))) + (struct-equiv-B-ram-config + (make-ram-config (addr rc) + (n rc) + (apply-A-update x (ram rc))) + rc))) + +(defun no-overlap-induct-B (l rc) + (if (endp l) + (list l rc) + (no-overlap-induct-B (cdr l) + (make-ram-config (addr rc) + (n rc) + (apply-A-update (car l) (ram rc)))))) + + +(defthm no-overlap-implies-B-struct-equiv-lemma + (implies (not (overlap (a-updates-w l) + (B-collect-link-cells-static rc))) + (struct-equiv-B-ram-config + (make-ram-config (addr rc) + (n rc) + (apply-A-updates l (ram rc))) + rc)) + :hints (("Goal" :do-not '(generalize) + :in-theory (disable apply-A-update struct-equiv-B-ram-config) + :induct (no-overlap-induct-B l rc)))) + +;---------- +; A after A +(defthm struct-equiv-a-ram-config-apply-A-update + (implies (not (member x (a-collect-link-cells-static rc))) + (struct-equiv-a-ram-config + (make-ram-config (addr rc) + (n rc) + (apply-A-update x (ram rc))) + rc))) + + +(defthm no-overlap-implies-A-struct-equiv-2-lemma + (implies (not (overlap (a-updates-w l) + (a-collect-link-cells-static rc))) + (struct-equiv-A-ram-config + (make-ram-config (addr rc) + (n rc) + (apply-A-updates l (ram rc))) + rc)) + :hints (("Goal" :do-not '(generalize) + :in-theory (disable apply-A-update struct-equiv-A-ram-config) + :induct (no-overlap-induct-B l rc)))) + + +(defthm no-overlap-implies-A-struct-equiv-2 + (implies (not (overlap (a-updates-w l) + (a-collect-link-cells-static (make-ram-config addr n ram)))) + (struct-equiv-A-ram-config + (make-ram-config addr + n + (apply-A-updates l ram)) + (make-ram-config addr n ram))) + :hints (("Goal" :do-not-induct t + :use ((:instance no-overlap-implies-A-struct-equiv-2-lemma + (rc (make-ram-config addr n ram)))) + :in-theory (disable struct-equiv-A-ram-config)))) + + +;--- +; B after B + +(defthm struct-equiv-B-ram-config-apply-B-update + (implies (not (member (+ 2 x) (B-collect-link-cells-static rc))) + (struct-equiv-B-ram-config + (make-ram-config (addr rc) + (n rc) + (apply-B-update x (ram rc))) + rc))) + + +(defthm no-overlap-implies-B-struct-equiv-2-lemma + (implies (not (overlap (b-updates-w l) + (B-collect-link-cells-static rc))) + (struct-equiv-B-ram-config + (make-ram-config (addr rc) ;; (addr rc) doesn't match + (n rc) + (apply-B-updates l (ram rc))) + rc)) + :hints (("Goal" :do-not '(generalize) + :in-theory (disable apply-B-update struct-equiv-B-ram-config) + :induct (no-overlap-induct-A l rc)))) + + +; Colloray from the result of property 1 +(defthm collect-dynamic-equal-static-A-1 + (implies (unique (a-collect-1 rc1)) + (equal (collect-A-updates-dynamic rc1) + (collect-A-updates-static rc1)))) + + +(in-theory (disable struct-equiv-A-ram-config apply-A-update)) + +(defthm collect-dynamic-equal-static-A-2 + (implies (and (unique (a-collect-1 rc1)) + (struct-equiv-A-ram-config rc2 rc1)) + (equal (collect-A-updates-dynamic rc2) + (collect-A-updates-static rc1))) + :hints (("Goal" :use ((:instance collect-dynamic-equal-static-A-1 + (rc1 rc2))) + :do-not-induct t))) + + +(defthm collect-dynamic-equal-static-B-1 + (implies (unique (b-collect-1 rc)) + (equal (collect-B-updates-dynamic rc) + (collect-B-updates-static rc)))) + +(in-theory (disable struct-equiv-B-ram-config apply-B-update)) + + +(defthm collect-dynamic-equal-static-B-2 + (implies (and (unique (b-collect-1 rc1)) + (struct-equiv-B-ram-config rc2 rc1)) + (equal (collect-B-updates-dynamic rc2) + (collect-B-updates-static rc1))) + :hints (("Goal" :use ((:instance collect-dynamic-equal-static-B-1 + (rc rc2))) + :do-not-induct t))) + +;---- +(defthm unique-append-f-1 + (implies (unique (append a b)) + (unique a)) + :rule-classes :forward-chaining) + +(defthm unique-append-f-2 + (implies (unique (append a b)) + (unique b)) + :rule-classes :forward-chaining) + +(defthm subset-b-updates-w-all + (subsetp (b-updates-w (collect-B-updates-static rc)) + (b-collect-1 rc))) + + +(defthm overlap-subset + (implies (and (overlap a c) + (subsetp a b) + (subsetp c d)) + (overlap b d))) + + +(defthm unique-implies-no-overlap-B-data-A-link + (implies (unique (append (b-collect-1 rc2) + (a-collect-1 rc1))) + (not (overlap (b-updates-w (collect-B-updates-static rc2)) + (a-collect-link-cells-static rc1)))) + :hints (("Goal" :in-theory (disable + overlap-subset + a-collect-1 b-collect-1) + :do-not-induct t + :use ((:instance overlap-subset + (a (b-updates-w + (collect-B-updates-static rc2))) + (b (b-collect-1 rc2)) + (c (a-collect-link-cells-static rc1)) + (d (a-collect-1 rc1)))))) + :rule-classes :forward-chaining) + + + +(defthm collect-dynamic-equal-static-A-2-instance + (implies (unique (append (b-collect-1 (make-ram-config addr1 n1 ram)) + (a-collect-1 (make-ram-config addr2 n2 ram)))) + (equal (collect-A-updates-dynamic + (make-ram-config addr2 n2 + (apply-b-updates (collect-B-updates-static + (make-ram-config addr1 n1 ram)) + ram))) + (collect-A-updates-static + (make-ram-config addr2 n2 ram)))) + :hints (("Goal" :use ((:instance no-overlap-implies-A-struct-equiv-lemma + (l (collect-B-updates-static + (make-ram-config addr1 n1 ram))) + (rc (make-ram-config addr2 n2 ram))))))) + +; +; This above is an important step towards, +; (equal (collect-bab-updates-dynamic addr1 n1 addr2 n2 addr3 n3 ram) +; (collect-bab-updates-static addr1 n1 addr2 n2 addr3 n3 ram))) +; + +; next we need to prove +; (equal (collect-B-updates-dynamic +; (make-ram-config addr3 n3 +; (apply-A-updates +; (collect-A-updates-static +; (make-ram-config addr2 n2 ram)) +; (apply-b-updates +; (collect-B-updates-static +; (make-ram-config addr1 n1 ram)) ram)))) +; (collect-B-updates-static +; (make-ram-config addr3 n3 ram)))) +; We prove this by establishing reducing inner most of apply-X-updates to +; structural-equivalence to original state + +(defthm unique-implies-no-overlap-B-data-B-link + (implies (unique (append (B-collect-1 rc1) + (B-collect-1 rc2))) + (not (overlap (b-updates-w (collect-B-updates-static rc1)) + (B-collect-link-cells-static rc2)))) + :hints (("Goal" :in-theory (disable + overlap-subset + a-collect-1 b-collect-1) + :do-not-induct t + :use ((:instance overlap-subset + (A (b-updates-w + (collect-B-updates-static rc1))) + (c (B-collect-link-cells-static rc2)) + (b (B-collect-1 rc1)) + (d (B-collect-1 rc2)))))) + :rule-classes :forward-chaining) + + + +(defthm collect-dynamic-equal-static-B-3-instance-lemma-1 + (implies (unique (append (b-collect-1 (make-ram-config addr1 n1 ram)) + (b-collect-1 (make-ram-config addr3 n3 ram)))) + (struct-equiv-B-ram-config + (make-ram-config addr3 n3 + (apply-b-updates (collect-B-updates-static + (make-ram-config addr1 n1 ram)) + ram)) + (make-ram-config addr3 n3 ram))) + :hints (("Goal" :use ((:instance no-overlap-implies-B-struct-equiv-2-lemma + (l (collect-B-updates-static + (make-ram-config addr1 n1 ram))) + (rc (make-ram-config addr3 n3 ram)))))) + :rule-classes :forward-chaining) + + + + +(defthm subset-a-updates-w-all + (subsetp (a-updates-w (collect-a-updates-static rc)) + (a-collect-1 rc))) + + +(defthm unique-implies-no-overlap-A-data-B-link + (implies (unique (append (a-collect-1 rc1) + (b-collect-1 rc2))) + (not (overlap (a-updates-w (collect-A-updates-static rc1)) + (B-collect-link-cells-static rc2)))) + :hints (("Goal" :in-theory (disable + overlap-subset + a-collect-1 b-collect-1) + :do-not-induct t + :use ((:instance overlap-subset + (A (a-updates-w + (collect-A-updates-static rc1))) + (b (a-collect-1 rc1)) + (c (b-collect-link-cells-static rc2)) + (d (b-collect-1 rc2)))))) + :rule-classes :forward-chaining) + + +(defthm collect-dynamic-equal-static-B-3-instance-lemma-2 + (implies (unique (append (a-collect-1 (make-ram-config addr2 n2 ram)) + (b-collect-1 (make-ram-config addr3 n3 ram)))) + (struct-equiv-B-ram-config + (make-ram-config addr3 n3 + (apply-a-updates (collect-A-updates-static + (make-ram-config addr2 n2 ram)) + ram)) + (make-ram-config addr3 n3 ram))) + :hints (("Goal" :use ((:instance no-overlap-implies-B-struct-equiv-lemma + (l (collect-A-updates-static + (make-ram-config addr2 n2 ram))) + (rc (make-ram-config addr3 n3 ram)))))) + :rule-classes :forward-chaining) + + +(defthm collect-dynamic-equal-static-B-3-instance-lemma-3 + (implies (unique (append (b-collect-1 (make-ram-config addr1 n1 ram)) + (a-collect-1 (make-ram-config addr2 n2 ram)))) + (struct-equiv-A-ram-config + (make-ram-config addr2 n2 + (apply-b-updates (collect-B-updates-static + (make-ram-config addr1 n1 ram)) + ram)) + (make-ram-config addr2 n2 ram))) + :hints (("Goal" :use ((:instance no-overlap-implies-A-struct-equiv-lemma + (l (collect-B-updates-static + (make-ram-config addr1 n1 ram))) + (rc (make-ram-config addr2 n2 ram)))))) + :rule-classes :forward-chaining) + + + +(defthm unique-append + (implies (unique (append a b c)) + (unique (append a c))) + :hints (("Goal" :do-not '(generalize))) + :rule-classes :forward-chaining) + +(defthm subsetp-append-x + (subsetp x (append x l))) + +(defthm unique-append-f-3 + (implies (unique (append a b c)) + (unique (append a b))) + :rule-classes :forward-chaining) + +(defcong struct-equiv-B-ram-config equal (b-collect-1 rc) 1 + :hints (("Goal" :induct (cong-induct-B rc rc-equiv) + :in-theory (enable struct-equiv-B-ram-config)))) + + +(defcong struct-equiv-A-ram-config equal (a-collect-1 rc) 1 + :hints (("Goal" :induct (cong-induct rc rc-equiv) + :in-theory (enable struct-equiv-A-ram-config)))) + +(defthm collect-dynamic-equal-static-B-3-instance-lemma + (implies (unique (append (b-collect-1 (make-ram-config addr1 n1 ram)) + (a-collect-1 (make-ram-config addr2 n2 ram)) + (b-collect-1 (make-ram-config addr3 n3 ram)))) + (struct-equiv-B-ram-config + (make-ram-config addr3 n3 + (apply-A-updates + (collect-A-updates-static + (make-ram-config addr2 n2 ram)) + (apply-b-updates (collect-B-updates-static + (make-ram-config addr1 + n1 + ram)) ram))) + (make-ram-config addr3 n3 ram))) + :hints (("Goal" :in-theory (disable + collect-dynamic-equal-static-B-3-instance-lemma-2) + :use ((:instance collect-dynamic-equal-static-B-3-instance-lemma-2 + (ram (apply-b-updates (collect-B-updates-static + (make-ram-config addr1 n1 + ram)) ram))))))) + + +;---------------------- +(defthm collect-dynamic-equal-static-B-3-instance + (implies (unique (append (b-collect-1 (make-ram-config addr1 n1 ram)) + (a-collect-1 (make-ram-config addr2 n2 ram)) + (b-collect-1 (make-ram-config addr3 n3 ram)))) + (equal (collect-B-updates-dynamic + (make-ram-config addr3 n3 + (apply-A-updates + (collect-A-updates-static + (make-ram-config addr2 n2 ram)) + (apply-b-updates + (collect-B-updates-static + (make-ram-config addr1 n1 ram)) ram)))) + (collect-B-updates-static + (make-ram-config addr3 n3 ram)))) + :hints (("Goal" :use ((:instance collect-dynamic-equal-static-B-2 + (rc2 + (make-ram-config addr3 n3 + (apply-A-updates + (collect-A-updates-static + (make-ram-config addr2 n2 ram)) + (apply-b-updates + (collect-B-updates-static + (make-ram-config addr1 n1 ram)) ram)))) + (rc1 (make-ram-config addr3 n3 ram)))))) + :rule-classes :forward-chaining) + +;------ +(defun collect-bab-updates-static (addr1 n1 addr2 n2 addr3 n3 ram) + (let* ((rc1 (make-ram-config addr1 n1 ram)) + (rc2 (make-ram-config addr2 n2 ram)) + (rc3 (make-ram-config addr3 n3 ram))) + (list (collect-B-updates-static rc1) + (collect-A-updates-static rc2) + (collect-B-updates-static rc3)))) + + + +(defthm unique-equal-collect-dynamic-to-static + (implies (unique (append (b-collect-1 (make-ram-config addr1 n1 ram)) + (a-collect-1 (make-ram-config addr2 n2 ram)) + (b-collect-1 (make-ram-config addr3 n3 ram)))) + (equal (collect-bab-updates-dynamic addr1 n1 addr2 n2 addr3 n3 ram) + (collect-bab-updates-static addr1 n1 addr2 n2 addr3 n3 ram))) + :hints (("Goal" :in-theory (disable + apply-B-updates + apply-B-update + apply-A-updates + apply-A-update + struct-equiv-A-ram-config + struct-equiv-B-ram-config)))) + + +(defthm not-mem-append-f-1 + (implies (not (member x (append a b))) + (not (member x a))) + :rule-classes :forward-chaining) + +(defthm not-mem-append-f-2 + (implies (not (member x (append a b))) + (not (member x b))) + :rule-classes :forward-chaining) + + +(defthm read-over-bab + (implies + (let ((list (append (b-collect ptr1 n1 ram) + (a-collect ptr2 n2 ram) + (b-collect ptr3 n3 ram) + ))) + (and + (not (member addr list)) + (unique list))) + (equal + (g addr (compose-bab ptr1 n1 ptr2 n2 ptr3 n3 ram)) + (g addr ram)))) + + +; 4. Proof of property III +; ***************************** +; +(in-theory (enable apply-A-update apply-B-update)) +(defun a-data-cell-w-r (l) + (if (endp l) nil + (append (list (car l) (+ 2 (car l))) + (a-data-cell-w-r (cdr l))))) + +(defun b-data-cell-w-r (l) + (if (endp l) nil + (append (list (car l) (+ 2 (car l))) + (b-data-cell-w-r (cdr l))))) + +;; Introduce the concept of cells that will be used. + + +(defthm g-after-apply-Bs + (implies (not (member x (b-data-cell-w-r l2))) + (equal (g x (apply-B-updates l2 ram)) + (g x ram))) + :hints (("Goal" :do-not '(generalize)))) + + +(defthm s-after-apply-Bs + (implies (not (member x (b-data-cell-w-r l2))) + (equal (s x any (apply-B-updates l2 ram)) + (apply-B-updates l2 (s x any ram)))) + :hints (("Goal" :do-not '(generalize)))) + + +(defthm apply-A-after-apply-Bs + (implies (and (not (member a1 (b-data-cell-w-r l2))) + (not (member (+ 2 a1) (b-data-cell-w-r l2)))) + (equal (apply-A-update a1 (apply-B-updates l2 ram)) + (apply-B-updates l2 (apply-A-update a1 ram)))) + :hints (("Goal" :do-not '(generalize)))) + + +(defthm apply-update-ram + (implies (not (overlap (a-data-cell-w-r l1) (b-data-cell-w-r l2))) + (equal (apply-B-updates l2 (apply-A-updates l1 ram)) + (apply-A-updates l1 (apply-B-updates l2 ram)))) + :hints (("Goal" :in-theory (disable apply-A-update) + :do-not '(generalize)))) + + +(defthm subsetp-a-data-cell-w-r + (subsetp (a-data-cell-w-r (collect-a-updates-static rc1)) + (a-collect-1 rc1))) + +(defthm subsetp-b-data-cell-w-r + (subsetp (b-data-cell-w-r (collect-b-updates-static rc1)) + (b-collect-1 rc1))) + + +(defthm unqiue-app-implies-w-r-w-r-no-overlap + (implies (unique (append (a-collect-1 rc1) + (b-collect-1 rc2))) + (not (overlap (a-data-cell-w-r (collect-A-updates-static rc1)) + (b-data-cell-w-r (collect-B-updates-static rc2))))) + :hints (("Goal" :in-theory (disable overlap-subset) + :use ((:instance overlap-subset + (a (a-data-cell-w-r + (collect-A-updates-static rc1))) + (b (a-collect-1 rc1)) + (c (b-data-cell-w-r + (collect-B-updates-static rc2))) + (d (b-collect-1 rc2))))))) + + +(defthm |Subgoal *1/3'4'| + (IMPLIES (not (member x (append l2 l1))) + (equal (UNIQUE (APPEND l1 (CONS x l2))) + (unique (append l1 l2)))) + :hints (("Goal" :do-not '(generalize)))) + +(defthm unique-append-rev + (implies (unique (append a b)) + (unique (append b a)))) + + +(defthm a-mark-over-b-mark + (implies + (let ((list (append (a-collect ptr1 n1 ram) + (b-collect ptr2 n2 ram)))) + (unique list)) + (equal + (a-mark-objects ptr1 n1 (b-mark-objects ptr2 n2 ram)) + (b-mark-objects ptr2 n2 (a-mark-objects ptr1 n1 ram))))) + +; 5. Generalization +; ***************************** +; In sol2.lisp diff --git a/books/workshops/2003/hbl/support/sol2.lisp b/books/workshops/2003/hbl/support/sol2.lisp new file mode 100644 index 0000000..0fd14aa --- /dev/null +++ b/books/workshops/2003/hbl/support/sol2.lisp @@ -0,0 +1,3010 @@ +;(acl2::set-match-free-error nil) +(in-package "ACL2") +(include-book "misc/records" :dir :system) +(include-book "arithmetic/top-with-meta" :dir :system) +(include-book "ordinals/e0-ordinal" :dir :system) +(set-well-founded-relation e0-ord-<) +;------------------- +;; use record book instead of using list + +(defmacro make-rc (ptrs ram map) + `(s 'ptrs ,ptrs (s 'ram ,ram (s 'map ,map nil)))) + + +;; not this ptrs is expected to a list of 3 turples +;; (typ addr n) + +(defmacro ptrs (rc) `(g 'ptrs ,rc)) +(defmacro ram (rc) `(g 'ram ,rc)) +(defmacro getmap (rc) `(g 'map ,rc)) + +(defmacro set-ptrs (ptrs rc) `(s 'ptrs ,ptrs ,rc)) +(defmacro set-ram (ram rc) `(s 'ram ,ram ,rc)) +(defmacro set-map (map rc) `(s 'map ,map ,rc)) + +(defun set-equal (a b) + (and (subsetp a b) + (subsetp b a))) + +(defthm subsetp-append + (subsetp a (append b a))) + +(defthm append-nil-x-x + (equal (append nil a) a)) + +(defthm subsetp-reflexive + (subsetp a a) + :hints (("Goal" + :use ((:instance subsetp-append (b nil)))))) + +(defthm subsetp-transitive + (implies (and (subsetp a b) + (subsetp b c)) + (subsetp a c))) + +(defequiv set-equal) + +(defun seq-int (start len) + (if (zp len) + nil + (cons (+ 0 start) + (seq-int (1+ start) (1- len))))) + +(defun struct-equiv-1-aux-m (typ-or-typs n mode) + (cond ((equal mode 'ATOM) + (cons (+ 1 (nfix n)) 0)) + ((equal mode 'LIST) + (cons (+ 1 (nfix n)) (len typ-or-typs))) + (t 0))) + +(defun struct-equiv-1-aux (typ-or-typs ptr-or-ptrs n ram1 ram2 map mode) + (declare (xargs :measure (struct-equiv-1-aux-m typ-or-typs n mode))) + (let ((typ typ-or-typs) + (ptr ptr-or-ptrs) + (typs typ-or-typs) + (ptrs ptr-or-ptrs)) + (cond ((equal mode 'ATOM) + (let* ((desc (cdr (assoc-equal typ map))) + (size (len desc))) + (if (zp n) t + (if (zp ptr) t + (if (not (assoc-equal typ map)) t + (if (not (equal (g ptr ram1) + (g ptr ram2))) nil + (let ((addr (g ptr ram1))) + (struct-equiv-1-aux desc + (seq-int addr size) + (- n 1) + ram1 ram2 map 'LIST)))))))) + ((equal mode 'LIST) + (if (endp typs) t + (if (not (assoc-equal (car typs) map)) + (struct-equiv-1-aux + (cdr typs) (cdr ptrs) n ram1 ram2 map 'LIST) + (and (struct-equiv-1-aux (car typs) (car ptrs) n ram1 ram2 map 'ATOM) + (struct-equiv-1-aux (cdr typs) (cdr ptrs) n ram1 ram2 map 'LIST))))) + (t t)))) + +(defun struct-equiv-1 (typ addr n ram1 ram2 map) + (struct-equiv-1-aux typ addr n ram1 ram2 map 'ATOM)) + +(defun struct-equiv-1-list (typs addrs n ram1 ram2 map) + (struct-equiv-1-aux typs addrs n ram1 ram2 map 'LIST)) + +;-------- +(defun typ (ptrs) (car ptrs)) +(defun addr (ptrs) (cadr ptrs)) +(defun n (ptrs) (caddr ptrs)) + +(defun typ-list (ptrs) + (if (endp ptrs) nil + (cons (typ (car ptrs)) (typ-list (cdr ptrs))))) + +(defun addr-list (ptrs) + (if (endp ptrs) nil + (cons (addr (car ptrs)) (addr-list (cdr ptrs))))) + +(defun n-list (ptrs) + (if (endp ptrs) nil + (cons (n (car ptrs)) (n-list (cdr ptrs))))) + +(defun all-struct-equiv-1 (typs addrs ns ram1 ram2 map) + (if (endp typs) t + (and (struct-equiv-1 (car typs) (car addrs) (car ns) ram1 ram2 map) + (all-struct-equiv-1 (cdr typs) (cdr addrs) (cdr ns) ram1 ram2 map)))) + +(defun struct-equiv (rc1 rc2) + (and (set-equal (ptrs rc1) (ptrs rc2)) + (equal (getmap rc1) (getmap rc2)) + (all-struct-equiv-1 (typ-list (ptrs rc1)) + (addr-list (ptrs rc1)) + (n-list (ptrs rc1)) + (ram rc1) (ram rc2) (getmap rc1)))) + +;------------- prove this a equivalence relation ---- + +(defthm struct-equiv-1-aux-reflexive + (struct-equiv-1-aux typ-of-typs ptr-or-ptrs n ram ram map mode)) + +(defthm struct-equiv-1-aux-symentric + (implies (struct-equiv-1-aux typ-of-typs ptr-or-ptrs n ram1 ram2 map mode) + (struct-equiv-1-aux typ-of-typs ptr-or-ptrs n ram2 ram1 map mode))) + +(defthm struct-equiv-1-aux-implies-g-ptr-equal + (implies (and (struct-equiv-1-aux typ ptr n ram1 ram2 map mode) + (not (zp n)) + (not (zp ptr)) + (equal mode 'ATOM) + (assoc-equal typ map)) + (equal (g ptr ram1) (g ptr ram2))) + :rule-classes :forward-chaining) + +(defthm struct-equiv-1-aux-transitive + (implies (and (struct-equiv-1-aux typ-of-typs ptr-or-ptrs n + ram1 ram2 map mode) + (struct-equiv-1-aux typ-of-typs ptr-or-ptrs n + ram2 ram3 map mode)) + (struct-equiv-1-aux typ-of-typs ptr-or-ptrs n + ram1 ram3 map mode))) + +(defthm all-struct-equiv-1-reflexive + (all-struct-equiv-1 typs addrs ns ram ram map)) + +(defthm all-struct-equiv-1-symentric + (implies (all-struct-equiv-1 typs addrs ns ram1 ram2 map) + (all-struct-equiv-1 typs addrs ns ram2 ram1 map))) + +(defthm all-struct-equiv-1-transitive + (implies (and (all-struct-equiv-1 typs addrs ns ram1 ram2 map) + (all-struct-equiv-1 typs addrs ns ram2 ram3 map)) + (all-struct-equiv-1 typs addrs ns ram1 ram3 map))) + + +;------------ + +(in-theory (disable struct-equiv-1)) + +(defthm all-struct-equiv-1-mem + (implies (and (member ptr ptrs) + (not (struct-equiv-1 (typ ptr) (addr ptr) (n ptr) ram1 ram2 map))) + (not (all-struct-equiv-1 (typ-list ptrs) (addr-list ptrs) (n-list ptrs) + ram1 ram2 map)))) + + + +(defthm all-struct-equiv-1-subsetp + (implies (and (subsetp ptrs2 ptrs1) + (all-struct-equiv-1 (typ-list ptrs1) + (addr-list ptrs1) + (n-list ptrs1) + ram1 ram2 map)) + (all-struct-equiv-1 (typ-list ptrs2) + (addr-list ptrs2) + (n-list ptrs2) + ram1 ram2 map))) + + + +(defthm struct-equiv-transitive + (implies (and (struct-equiv rc1 rc2) + (struct-equiv rc2 rc3)) + (struct-equiv rc1 rc3))) + +;; (in-theory (disable set-equal)) + +(defequiv struct-equiv) + + +;-------------- + +(defun collect-link-cells-1-aux + (typ-or-typs ptr-or-ptrs n ram map mode) + (declare (xargs :measure (struct-equiv-1-aux-m typ-or-typs n mode))) + (let ((typ typ-or-typs) + (ptr ptr-or-ptrs) + (typs typ-or-typs) + (ptrs ptr-or-ptrs)) + (cond ((equal mode 'ATOM) + (let* ((desc (cdr (assoc-equal typ map))) + (size (len desc))) + (if (zp n) nil + (if (zp ptr) nil + (if (not (assoc-equal typ map)) + nil + (let ((addr (g ptr ram))) + (cons ptr (collect-link-cells-1-aux desc + (seq-int addr size) + (- n 1) + ram map 'LIST)))))))) + + ((equal mode 'LIST) + (if (endp typs) nil + (if (not (assoc-equal (car typs) map)) ;; skip non pointer + (collect-link-cells-1-aux (cdr typs) (cdr ptrs) n ram map 'LIST) + (append (collect-link-cells-1-aux (car typs) + (car ptrs) + n + ram map 'ATOM) + (collect-link-cells-1-aux (cdr typs) + (cdr ptrs) + n + ram map 'LIST))))) + (t nil)))) + + +;--------------- +(defun collect-link-cells-1 (typ addr n ram map) + (collect-link-cells-1-aux typ addr n ram map 'ATOM)) + +(defun collect-link-cells-1-list (typs addrs n ram map) + (collect-link-cells-1-aux typs addrs n ram map 'LIST)) + + +(defun all-collect-link-cells-1 (typs addrs ns ram map) + (if (endp typs) + nil + (append (collect-link-cells-1 (car typs) (car addrs) (car ns) ram map) + (all-collect-link-cells-1 (cdr typs) (cdr addrs) (cdr ns) ram map)))) + +;--------------- + +(defun collect-link-cells (rc) + (all-collect-link-cells-1 (typ-list (ptrs rc)) + (addr-list (ptrs rc)) + (n-list (ptrs rc)) + (ram rc) (getmap rc))) + + +;; next task (defcong struct-equiv + +(defthm member-append-1 + (implies (member x b) + (member x (append a b)))) + +(defthm member-append-2 + (implies (member x a) + (member x (append a b)))) + +(defthm subsetp-append-x-1 + (implies (subsetp a b) + (subsetp (append a c) + (append b c)))) + +(defthm subsetp-append-x-2 + (implies (subsetp a b) + (subsetp (append c a) + (append c b)))) + + + +(defcong set-equal set-equal (append a b) 1) +(defcong set-equal set-equal (append a b) 2) + +(defthm subsetp-append-b + (subsetp a (append a b))) + +(defthm subsetp-collect-link-cells-1-subsetp + (implies (member ptr ptrs) + (subsetp (collect-link-cells-1 (typ ptr) + (addr ptr) + (n ptr) + ram map) + (all-collect-link-cells-1 (typ-list ptrs) + (addr-list ptrs) + (n-list ptrs) + ram map))) + :hints (("Goal" :in-theory (disable collect-link-cells-1) + :do-not '(generalize)))) + +(in-theory (disable typ addr n)) + +(defthm subsetp-merged-still-subsetp + (implies (and (subsetp a b) + (subsetp c b)) + (subsetp (append a c) b))) + + +(defthm subsetp-all-collect-link-cells-1-subsetp + (implies (subsetp ptrs1 ptrs2) + (subsetp (all-collect-link-cells-1 (typ-list ptrs1) + (addr-list ptrs1) + (n-list ptrs1) + ram map) + (all-collect-link-cells-1 (typ-list ptrs2) + (addr-list ptrs2) + (n-list ptrs2) + ram map))) + :hints (("Goal" :in-theory (disable collect-link-cells-1)))) + + + +(defthm set-equal-collect-link-cells-1-set-equal + (implies (and (set-equal ptrs1 ptrs2) + ;; Added for mod to ACL2 v2-8 that does better matching for + ;; calls of equivalence relations against the current context: + (syntaxp (not (term-order ptrs1 ptrs2)))) + (set-equal (all-collect-link-cells-1 (typ-list ptrs1) + (addr-list ptrs1) + (n-list ptrs1) + ram map) + (all-collect-link-cells-1 (typ-list ptrs2) + (addr-list ptrs2) + (n-list ptrs2) + ram map)))) + + +(defthm struct-equiv-1-aux-implies-collect-link-cells-aux-equal + (implies (struct-equiv-1-aux typ-or-typs ptr-or-ptrs n ram1 ram2 map mode) + (equal (collect-link-cells-1-aux typ-or-typs ptr-or-ptrs n + ram1 map mode) + (collect-link-cells-1-aux typ-or-typs ptr-or-ptrs n + ram2 map mode)))) + + +(defthm struct-equiv-1-equal-collect-link-cells-1-equal + (implies (all-struct-equiv-1 typs addrs ns ram1 ram2 map) + (equal (all-collect-link-cells-1 typs + addrs + ns + ram1 map) + (all-collect-link-cells-1 typs + addrs + ns + ram2 map))) + :hints (("Goal" :in-theory (enable struct-equiv-1)))) + + +;-------------- +(in-theory (disable set-equal)) + + +(defcong struct-equiv set-equal (collect-link-cells rc) 1) + +;-- need to prove update to the non link cell keep the struct-equiv + +(defthm not-member-append-f-1 + (implies (not (member x (append a b))) + (not (member x a))) + :rule-classes :forward-chaining) + +(defthm not-member-append-f-2 + (implies (not (member x (append a b))) + (not (member x b))) + :rule-classes :forward-chaining) + + +(defun struct-equiv-1-induct (addrx typ-or-typs ptr-or-ptrs n ram map mode) + (declare (xargs :measure (struct-equiv-1-aux-m typ-or-typs n mode))) + (let ((typ typ-or-typs) + (ptr ptr-or-ptrs) + (typs typ-or-typs) + (ptrs ptr-or-ptrs)) + (cond ((equal mode 'ATOM) + (let* ((desc (cdr (assoc-equal typ map))) + (size (len desc))) + (if (zp n) t + (if (zp ptr) t + (if (not (assoc-equal typ map)) t + (if (equal addrx ptr) t + (let ((addr (g ptr ram))) + (struct-equiv-1-induct addrx desc (seq-int addr size) + (- n 1) ram map 'LIST)))))))) + ((equal mode 'LIST) + (if (endp typs) t + (if (not (assoc-equal (car typs) map)) + (struct-equiv-1-induct addrx (cdr typs) (cdr ptrs) n ram map 'LIST) + (list (struct-equiv-1-induct addrx (car typs) (car ptrs) n ram map 'ATOM) + (struct-equiv-1-induct addrx (cdr typs) (cdr ptrs) n ram map 'LIST))))) + (t (list addrx typ-or-typs ptr-or-ptrs n ram map mode))))) + + +(defthm struct-equiv-1-aux-atom-implies-member + (implies (AND + (NOT (ZP N)) + (NOT (ZP ADDR)) + (ASSOC-EQUAL TYP MAP)) + (MEMBER ADDR + (COLLECT-LINK-CELLS-1-AUX TYP ADDR N RAM MAP + 'ATOM))) + :hints (("Goal" :expand (COLLECT-LINK-CELLS-1-AUX TYP ADDR N RAM MAP 'ATOM)))) + +(defthm struct-equiv-1-aux-s-add-v-struct-equiv-1-aux + (implies (not (member addr (collect-link-cells-1-aux + typ-or-typs ptr-or-ptrs n ram map mode))) + (struct-equiv-1-aux typ-or-typs ptr-or-ptrs n + (s addr any ram) ram map mode)) + :hints (("Goal" :induct (struct-equiv-1-induct addr typ-or-typs ptr-or-ptrs n ram + map mode) + :do-not '(generalize)))) + +;----------------------- + +(defthm all-struct-equiv-1-s-add-v-all-struct-equiv-1 + (implies (not (member addr (all-collect-link-cells-1 + typs ptrs ns ram map))) + (all-struct-equiv-1 typs ptrs ns + (s addr any ram) ram map)) + :hints (("Goal" :in-theory (enable struct-equiv-1)))) + + +(defthm struct-equiv-preserved-if-update-non-link-cell + (implies (not (member addr (collect-link-cells rc))) + (struct-equiv (set-ram (s addr v (ram rc)) rc) + rc))) + +;----------------------- + +;; +;; done with the proof that (s addr v ram) preserve struct-equiv +;; so far, we have +;; +;; (defcong struct-equiv set-equal (collect-link-cells rc) 1) +;; +;; and +;; +;; struct-equiv-preserved-if-update-non-link-cell +;; + + +; +;--- define the generic mark algorithm, that only change data cells +; + +;; +;; we need to be able to tell that data cell value only depend on data cells +;; + + +(defun collect-data-cells-1-aux (typ-or-typs ptr-or-ptrs n ram map mode) + (declare (xargs :measure (struct-equiv-1-aux-m typ-or-typs n mode))) + (let ((typ typ-or-typs) + (ptr ptr-or-ptrs) + (typs typ-or-typs) + (ptrs ptr-or-ptrs)) + (cond ((equal mode 'ATOM) + (let* ((desc (cdr (assoc-equal typ map))) + (size (len desc))) + (if (zp n) nil + (if (zp ptr) nil + (if (not (assoc-equal typ map)) + nil + ;; maybe I should modify it so that it matches with + ;; collect-updates. i.e. collect data cells here in one + ;; batch. Still want a try with the other proof. + (let ((addr (g ptr ram))) + (collect-data-cells-1-aux desc + (seq-int addr size) + (- n 1) + ram map 'LIST))))))) + ((equal mode 'LIST) + (if (endp typs) nil + (if (not (assoc-equal (car typs) map)) + ;; this is a data cell, recorded it. + (cons (car ptrs) + (collect-data-cells-1-aux (cdr typs) (cdr ptrs) + n ram map 'LIST)) + (append (collect-data-cells-1-aux (car typs) + (car ptrs) + n + ram map 'ATOM) + (collect-data-cells-1-aux (cdr typs) + (cdr ptrs) + n + ram map 'LIST))))) + (t nil)))) + + +;----------- + +(defun collect-data-cells-1 (typ addr n ram map) + (collect-data-cells-1-aux typ addr n ram map 'ATOM)) + +(defun collect-data-cells-1-list (typs addrs n ram map) + (collect-link-cells-1-aux typs addrs n ram map 'LIST)) + + +(defun all-collect-data-cells-1 (typs addrs ns ram map) + (if (endp typs) + nil + (append (collect-data-cells-1 (car typs) (car addrs) (car ns) ram map) + (all-collect-data-cells-1 (cdr typs) (cdr addrs) (cdr ns) ram map)))) + +;------------ + +(defun collect-data-cells (rc) + (all-collect-data-cells-1 (typ-list (ptrs rc)) + (addr-list (ptrs rc)) + (n-list (ptrs rc)) + (ram rc) (getmap rc))) + +;; prove (defcong .... ) + +(defthm subsetp-collect-data-cells-1-subsetp + (implies (member ptr ptrs) + (subsetp (collect-data-cells-1 (typ ptr) + (addr ptr) + (n ptr) + ram map) + (all-collect-data-cells-1 (typ-list ptrs) + (addr-list ptrs) + (n-list ptrs) + ram map))) + :hints (("Goal" :in-theory (disable collect-data-cells-1) + :do-not '(generalize)))) + + +(defthm subsetp-all-collect-data-cells-1-subsetp + (implies (subsetp ptrs1 ptrs2) + (subsetp (all-collect-data-cells-1 (typ-list ptrs1) + (addr-list ptrs1) + (n-list ptrs1) + ram map) + (all-collect-data-cells-1 (typ-list ptrs2) + (addr-list ptrs2) + (n-list ptrs2) + ram map))) + :hints (("Goal" :in-theory (disable collect-data-cells-1)))) + + +(defthm set-equal-collect-data-cells-1-set-equal + (implies (and (set-equal ptrs1 ptrs2) + ;; Added for mod to ACL2 v2-8 that does better matching for + ;; calls of equivalence relations against the current context: + (syntaxp (not (term-order ptrs1 ptrs2)))) + (set-equal (all-collect-data-cells-1 (typ-list ptrs1) + (addr-list ptrs1) + (n-list ptrs1) + ram map) + (all-collect-data-cells-1 (typ-list ptrs2) + (addr-list ptrs2) + (n-list ptrs2) + ram map))) + :hints (("Goal" :in-theory (enable set-equal)))) + + +(defthm struct-equiv-1-aux-implies-collect-data-cells-aux-equal + (implies (struct-equiv-1-aux typ-or-typs ptr-or-ptrs n ram1 ram2 map mode) + (equal (collect-data-cells-1-aux typ-or-typs ptr-or-ptrs n + ram1 map mode) + (collect-data-cells-1-aux typ-or-typs ptr-or-ptrs n + ram2 map mode)))) + + +(defthm struct-equiv-1-equal-collect-data-cells-1-equal + (implies (all-struct-equiv-1 typs addrs ns ram1 ram2 map) + (equal (all-collect-data-cells-1 typs + addrs + ns + ram1 map) + (all-collect-data-cells-1 typs + addrs + ns + ram2 map))) + :hints (("Goal" :in-theory (enable struct-equiv-1)))) + +(defcong struct-equiv set-equal (collect-data-cells rc) 1) + +;---------------- +;; +;; the problem here is how to characterize all possible updates? +;; +;; A constraint function is good. However to argue it can model all possible +;; computation need some efforts. +;; +;; Because in this mark function, we update in the pre-order, once we reach +;; some node, we update, then we continue, etc. +;; +;; It is hard to argue that we could implement all kinds of update order, +;; because it is possible that the data value depends on the order we do them. +;; +;; In J's model, the value of new data fills only depends on the old data +;; within the same node. +;; +;; In my model, I want to extend that to all possible data fields reachable. +;; +;; Then I have to face this problem. +;; + + + +;; say only change up + +(encapsulate + ((new-field-value (typ ptr i n ram map) t)) + (local (defun new-field-value (typ ptr i n ram map) + (declare (ignore typ ptr i n ram map)) + 0)) + (defthm new-field-value-s-commutes + (implies (not (member addr (append (collect-data-cells-1 typ ptr n ram map) + (collect-link-cells-1 typ ptr n ram map)))) + (equal (new-field-value typ ptr i n (s addr val ram) map) + (new-field-value typ ptr i n ram map))))) + +;; +;; This is to say, any write outside the reachable data+link fields, +;; doesn't matter to the new-field-value +;; + +(defun single-update1 (typ ptr i n ram map) + (declare (xargs :measure (nfix (- (len (cdr (assoc-equal typ map))) + (nfix i))))) + (let* ((descriptor (cdr (assoc-equal typ map))) + (i (nfix i)) + (slot-typ (nth i descriptor)) + (addr (g ptr ram))) + (if (zp ptr) ram + (if (< i (len descriptor)) + (if (assoc-equal slot-typ map) + ;; a struct type, meaning a ptr in the (car addrs) + ;; don't touch link cells + (single-update1 typ ptr (+ i 1) n ram map) + ;; else not a struct type, update the value + (let ((ram (s (+ addr i) (new-field-value typ ptr i n ram map) ram))) + ;; let the new value depends on the changes to the previous slos + (single-update1 typ ptr (+ i 1) n ram map))) + ram)))) + +;; (defstub single-update2 (types addr size ram map) ram) ;; update in inorder +;; (defstub single-update3 (type ptr size ram map) ram) ;; update in postorder + +;; +;; chose not to deal with those now. +;; +;; +;; assume our constainted new-value is so powerful that it can emulates all +;; possible changes with in-order and post-order updates, arbitary updates. +;; +;; not so sure. this is possible, +;; +;; I could find a particular way of updating memory that cause the program +;; enter into a loop, however oracle in the single-updates have to garantee to +;; provide us an initial ram to result in the same loop.... +;; it is possible, because oracle can detect if the initial ram config is ... +;; +;; + +(defun mark-1-aux (typ-or-typs ptr-or-ptrs n ram map mode) + (declare (xargs :measure (struct-equiv-1-aux-m typ-or-typs n mode))) + (let ((typ typ-or-typs) + (ptr ptr-or-ptrs) + (typs typ-or-typs) + (ptrs ptr-or-ptrs)) + (cond ((equal mode 'ATOM) + (let* ((desc (cdr (assoc-equal typ map))) + (size (len desc))) + (if (zp n) ram + (if (zp ptr) ram + (if (not (assoc-equal typ map)) ;; not bound + ram + (let* ((addr (g ptr ram)) + (new-ram (single-update1 typ ptr 0 n ram map))) + (mark-1-aux desc + (seq-int addr size) + (- n 1) + new-ram map 'LIST))))))) + ((equal mode 'LIST) + (if (endp typs) + ram + (if (not (assoc-equal (car typs) map)) + (mark-1-aux (cdr typs) (cdr ptrs) n ram map 'LIST) + (let ((new-ram (mark-1-aux (car typs) + (car ptrs) + n + ram map 'ATOM))) + (mark-1-aux (cdr typs) + (cdr ptrs) + n + new-ram map 'LIST))))) + (t ram)))) + + +;--- mark-1 +(defun mark-1 (typ addr n ram map) + (mark-1-aux typ addr n ram map 'ATOM)) + +(defun mark-1-list (typs addrs n ram map) + (mark-1-aux typs addrs n ram map 'LIST)) + +;------------- + +(defun all-mark-1 (typs addrs ns ram map) + (if (endp typs) + ram + (all-mark-1 (cdr typs) (cdr addrs) (cdr ns) + (mark-1 (car typs) (car addrs) (car ns) ram map) + map))) + +;------------- + +(defun mark (rc) + (all-mark-1 (typ-list (ptrs rc)) + (addr-list (ptrs rc)) + (n-list (ptrs rc)) + (ram rc) + (getmap rc))) + +;------------ +;; +;; update is of this format (type ptr i n), +;; new-value depends on these +;; + +;; relevence analysis problem. + +(defun m-collect-updates (typ map i ram) + (declare (ignore ram)) + (nfix (- (len (cdr (assoc-equal typ map))) + (nfix i)))) + + +(defun make-update (typ ptr i n) + (list typ ptr i n)) + +(defun gtyp (update) (car update)) +(defun gptr (update) (cadr update)) +(defun gi (update) (caddr update)) +(defun gn (update) (caddr (cdr update))) + +(defthm make-update-accessor + (and (equal (gtyp (make-update typ ptr i n)) typ) + (equal (gptr (make-update typ ptr i n)) ptr) + (equal (gi (make-update typ ptr i n)) i) + (equal (gn (make-update typ ptr i n)) n))) + +(in-theory (disable make-update gtyp gptr gi gn)) + + +(defun collect-updates-from-single-update1 (typ ptr i n ram map) + (declare (xargs :measure (m-collect-updates typ map i ram))) + (let* ((descriptor (cdr (assoc-equal typ map))) + (i (nfix i)) + (slot-typ (nth i descriptor)) + (addr (g ptr ram))) + (if (zp ptr) nil + (if (< i (len descriptor)) + (if (assoc-equal slot-typ map) + ;; a struct type, meaning a ptr in the (car addrs) + ;; don't touch link cells + (collect-updates-from-single-update1 typ ptr (+ i 1) n ram map) + ;; else not a struct type, update the value + (let ((new-ram (s (+ addr i) (new-field-value typ ptr i n ram map) ram))) + ;; let the new value depends on the changes to the previous slos + (cons (make-update typ ptr i n) + (collect-updates-from-single-update1 typ ptr (+ i 1) n + new-ram map)))) + nil)))) + + +(defun collect-updates-zdynamic-1-aux (typ-or-typs ptr-or-ptrs n ram map mode) + (declare (xargs :measure (struct-equiv-1-aux-m typ-or-typs n mode))) + (let ((typ typ-or-typs) + (ptr ptr-or-ptrs) + (typs typ-or-typs) + (ptrs ptr-or-ptrs)) + (cond ((equal mode 'ATOM) + (let* ((desc (cdr (assoc-equal typ map))) + (size (len desc))) + (if (zp n) nil + (if (zp ptr) nil + (if (not (assoc-equal typ map)) ;; not bound + nil + (let* ((addr (g ptr ram)) + (new-ram (single-update1 typ ptr 0 n ram map))) + (append (collect-updates-from-single-update1 + typ ptr 0 n ram map) + (collect-updates-zdynamic-1-aux + desc + (seq-int addr size) + (- n 1) + new-ram map 'LIST)))))))) + ((equal mode 'LIST) + (if (endp typs) + nil + (if (not (assoc-equal (car typs) map)) + (collect-updates-zdynamic-1-aux + (cdr typs) (cdr ptrs) n ram map 'LIST) + (let ((new-ram (mark-1-aux (car typs) + (car ptrs) + n + ram map 'ATOM))) + (append (collect-updates-zdynamic-1-aux + (car typs) (car ptrs) n ram map 'ATOM) + (collect-updates-zdynamic-1-aux (cdr typs) + (cdr ptrs) + n + new-ram map 'LIST)))))) + (t nil)))) + + +;---------- prove apply-dynamic update equal to mark on the fly +; +; update is a (typ ptr i n) +; +; + +(defun apply-update (update ram map) + (let ((typ (gtyp update)) + (ptr (gptr update)) + (i (gi update)) + (n (gn update))) + (let ((addr (g ptr ram))) + (s (+ addr i) (new-field-value typ ptr i n ram map) ram)))) + + +(defun apply-updates (updates ram map) + (if (endp updates) ram + (apply-updates (cdr updates) (apply-update (car updates) ram map) map))) + + +(defthm apply-updates-collect-updates-from-single-update1-is-single-update1 + (equal (single-update1 typ ptr i n ram map) + (apply-updates (collect-updates-from-single-update1 + typ ptr i n ram map) + ram map))) + + +(defthm apply-updates-append + (equal (apply-updates (append updates1 updates2) ram map) + (apply-updates updates2 + (apply-updates updates1 ram map) map))) + +(in-theory (disable apply-update)) + +(defthm apply-updates-collect-dynamic-is-mark + (equal (mark-1-aux typ-or-typs ptr-or-ptrs n ram map mode) + (apply-updates (collect-updates-zdynamic-1-aux + typ-or-typs ptr-or-ptrs n ram map mode) + ram map)) + :hints (("Goal" :do-not '(generalize)))) + +; +;-------------------- +; + +(defun collect-updates-dynamic-1 (typ ptr n ram map) + (collect-updates-zdynamic-1-aux typ ptr n ram map 'ATOM)) + +(defun collect-updates-dynamic-1-list (typs ptrs n ram map) + (collect-updates-zdynamic-1-aux typs ptrs n ram map 'LIST)) + + +;-------------------- + +(defun all-collect-updates-dynamic-1 (typs ptrs ns ram map) + (if (endp typs) + nil + (append (collect-updates-dynamic-1 (car typs) (car ptrs) (car ns) + ram map) + (all-collect-updates-dynamic-1 + (cdr typs) (cdr ptrs) (cdr ns) + (mark-1 (car typs) (car ptrs) (car ns) ram map) + map)))) + +;-------------- + +(defun collect-updates-dynamic (rc) + (all-collect-updates-dynamic-1 (typ-list (ptrs rc)) + (addr-list (ptrs rc)) + (n-list (ptrs rc)) + (ram rc) + (getmap rc))) + +;-------------- + +(defthm all-mark-1-is-apply-update-1 + (equal (all-mark-1 typs addrs ns ram map) + (apply-updates (all-collect-updates-dynamic-1 typs addrs ns ram map) + ram map))) + + +(defthm apply-equal-mark + (equal (mark rc) + (apply-updates (collect-updates-dynamic rc) + (ram rc) (getmap rc)))) + +;-------------- +;; +;; next is to prove struct-equiv, +;; is if data cell doesn't overlap with link cell, +;; then collect-dyanmic is collect-static +;; + + +(defun overlap (a b) + (if (endp a) nil + (or (member (car a) b) + (overlap (cdr a) b)))) + +(defun update-2-w (update ram) + (let ((ptr (gptr update)) + (i (gi update))) + (+ i (g ptr ram)))) + +(defun updates-2-ws (updates ram map) + (if (endp updates) + nil + (cons (update-2-w (car updates) ram) + (updates-2-ws (cdr updates) (apply-update (car updates) ram map) + map)))) + +(defthm member-append + (implies (member x a) + (member x (append a b)))) + +(defthm inrange-seen + (implies (and (not (zp l)) + (integerp x) + (integerp y) + (integerp l) + (< y (+ x l)) + (<= x y)) + (member y (seq-int x l))) + :hints (("Goal" :do-not '(generalize)))) + +(defthm consp-car-append + (implies (consp l) + (equal (car (append l x)) + (car l)))) + + +(defthm consp-implies-consp + (implies (and (consp (append a b)) + (not (consp b))) + (consp a)) + :rule-classes :forward-chaining) + + +;---------------------------------- +; +; very awkward, because our collect-data-cell doesn't match our collect-updates. +; +; collect-data-cell, record the data cell, in collect-data-cell-1-list +; while collect-updates-dymanic collect data-cell in collect-data-cell-1 +; + +(defthm first-update-must-be-a-data-field + (implies (consp (collect-updates-from-single-update1 TYP PTR I N RAM MAP)) + (not (assoc-equal (nth (gi (car (collect-updates-from-single-update1 TYP PTR i N RAM MAP))) + (cdr (assoc-equal typ map))) + map))) + :hints (("Goal" :do-not '(generalize)))) + +; +; proved that first update must be a data cell, we can't claim more, +; because the second update would be a data cell in a modified ram. +; we can't show that data cell is a data cell in the original ram. +; +; unless we have already shown that there is no overlap between data cell and +; link cell. +; + +;-------------- + +(defun pos (x l) + (if (endp l) 0 + (if (equal (car l) x) 0 + (+ 1 (pos x (cdr l)))))) + + +(defun not-assoc-equal-induct (typx typs ptrs) + (if (endp typs) + (list typx typs) + (if (equal (car typs) typx) + (list typx typs ptrs) + (not-assoc-equal-induct typx (cdr typs) (cdr ptrs))))) + +(defthm not-assoc-equal-must-be-in-collect-data-cell-list + (implies (and (member typx typs) + (not (assoc-equal typx map))) + (member (nth (pos typx typs) ptrs) + (collect-data-cells-1-aux typs + ptrs + n + ram map 'LIST))) + :hints (("Goal" :induct (not-assoc-equal-induct typx typs ptrs)))) + + +;; +;; we need to prove (nth (gi ....)) is such a typx +;; we probably don't have to prove the general case with i in the theorem. +;; + +;--- First: prove member (gi ..) + +(defthm update-typ-i-is-in-range-1 + (implies (consp (collect-updates-from-single-update1 + TYP PTR I N RAM MAP)) + (<= (nfix i) (gi (car (collect-updates-from-single-update1 typ ptr i n ram + map))))) + :hints (("Goal" :do-not '(generalize))) + :rule-classes :linear) + +(defthm update-typ-i-is-in-range-2 + (implies (consp (collect-updates-from-single-update1 + TYP PTR I N RAM MAP)) + (< (gi (car (collect-updates-from-single-update1 typ ptr i n ram + map))) + (len (cdr (assoc-equal typ map))))) + :hints (("Goal" :do-not '(generalize))) + :rule-classes :linear) + + +(defthm nth-member + (implies (and (<= 0 i) + (< i (len l))) + (member (nth i l) l))) + +(defun mycdrn (i l) + (if (zp i) + l + (mycdrn (- i 1) (cdr l)))) + + +(defthm member-nth-cdrn-2 + (implies (and (integerp i) + (integerp j) + (<= 0 i) + (<= i j) + (< j (len l))) + (member (nth j l) + (mycdrn i l)))) + + +(defthm integerp-gi-g-ptr-car-collect-update-from-single-update1 + (implies (consp (collect-updates-from-single-update1 typ ptr i n ram map)) + (integerp (gi (car (collect-updates-from-single-update1 + typ ptr i n ram map))))) + :rule-classes :forward-chaining) + +(defthm first-update-typ-is-member-of-sig + (implies (consp (collect-updates-from-single-update1 typ ptr i n ram map)) + (member (nth (gi (car (collect-updates-from-single-update1 + typ ptr i n ram map))) + (cdr (assoc-equal typ map))) + (mycdrn i (cdr (assoc-equal typ map))))) + :hints (("Goal" :do-not '(generalize))) + :rule-classes :forward-chaining) + + +;------------------ +; +; Because we already have (member (nth (pos typx) ...) in data cells +; +; next we need to prove (nth (pos (nth (gi ...)) is (nth (gi ...)) +; +;------------------ + +(defthm pos-mycdrn + (implies (and (integerp i) + (<= 0 i) + (< i (len l))) + (equal (pos (nth i l) + (mycdrn i l)) 0))) + + +(defthm assoc-equal-not-equal-nth-gi + (implies (and (consp (collect-updates-from-single-update1 typ ptr i n ram map)) + (assoc-equal typx map)) + (not (equal (nth (gi (car (collect-updates-from-single-update1 + typ ptr i n ram map))) + (cdr (assoc-equal typ map))) + typx)))) + + +(defthm pos-mycdrn-2 + (implies (and (integerp i) + (<= 0 i) + (< i (len l)) + (not (equal x (nth i l)))) + (equal (+ 1 (pos x (mycdrn i (cdr l)))) + (pos x + (mycdrn i l))))) + + + + +(defthm pos-is-gi + (implies (and (consp (collect-updates-from-single-update1 typ ptr i n ram map)) + (integerp i) + (<= 0 i)) + (equal (+ i (pos (nth (gi (car + (collect-updates-from-single-update1 + typ ptr i n ram map))) + (cdr (assoc-equal typ map))) + (mycdrn i (cdr (assoc-equal typ map))))) + (gi (car (collect-updates-from-single-update1 + typ ptr i n ram map)))))) + + +(defthm nth-pos-mycdrn + (implies (and (integerp i) + (integerp j) + (<= 0 i) + (<= 0 j)) + (equal (nth i (mycdrn j l)) + (nth (+ j i) l)))) + + + +(defthm nth-pos-is-nth-gi + (implies (and (consp (collect-updates-from-single-update1 typ ptr i n ram map)) + (integerp i) + (<= 0 i)) + (equal (nth (pos (nth (gi (car (collect-updates-from-single-update1 + typ ptr i n ram map))) + (cdr (assoc-equal typ map))) + (mycdrn i (cdr (assoc-equal typ map)))) + (mycdrn i ptrs)) + (nth (gi (car (collect-updates-from-single-update1 + typ ptr i n ram map))) + ptrs)))) + + + + + + +(defthm member-x-collect-data-cells-1-aux + (implies (member x (collect-data-cells-1-aux (mycdrn i typs) + (mycdrn i ptrs) + n + ram map 'LIST)) + (member x (collect-data-cells-1-aux typs ptrs n ram map + 'LIST)))) + + + +(defthm first-update-is-in-data-cells-colllect-lemma + (implies (and (consp (collect-updates-from-single-update1 TYP PTR I N RAM MAP)) + (<= 0 i) + (integerp i)) + (member + (nth (gi (car (collect-updates-from-single-update1 + typ ptr i n ram map))) ptrs) + (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + ptrs + (- n 1) + ram map 'LIST))) + :hints (("Goal" :in-theory (disable not-assoc-equal-must-be-in-collect-data-cell-list) + :use ((:instance + not-assoc-equal-must-be-in-collect-data-cell-list + (typx (nth (gi (car (collect-updates-from-single-update1 + typ ptr i n ram map))) + (cdr (assoc-equal typ map)))) + (typs (mycdrn i (cdr (assoc-equal typ map)))) + (ptrs (mycdrn i ptrs)) + (n (- n 1)))) + :do-not-induct t))) + + +(defun nth-i-seq-int-induct (i addr l) + (if (zp i) + (list i addr l) + (if (zp l) + (list i addr l) + (nth-i-seq-int-induct (- i 1) + (+ addr 1) + (- l 1))))) + + +(defthm seq-int-1-equal + (equal (seq-int x 1) + (list (+ 0 x))) + :hints (("Goal" :expand (seq-int x 1)))) + + +(defthm nth-i-seq-int + (implies (and (<= 0 i) + (< i l) + (integerp l) + (integerp i)) + (equal (nth i (seq-int addr l)) + (+ addr i))) + :hints (("Goal" :do-not '(generalize) + :induct (nth-i-seq-int-induct i addr l)))) + +(defthm gptr-is-g-ptr-car-collect-update-from-single-update1 + (implies (consp (collect-updates-from-single-update1 typ ptr i n ram map)) + (equal (gptr (car (collect-updates-from-single-update1 + typ ptr i n ram map))) + ptr))) + + +(defthm first-update-is-in-data-cells-colllect + (implies (and (consp (collect-updates-from-single-update1 TYP PTR I N RAM MAP)) + (integerp i) + (<= 0 i)) + (member + (update-2-w + (car (collect-updates-from-single-update1 typ ptr i n ram map)) ram) + (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ + map)))) + (- n 1) + ram map 'LIST))) + :hints (("Goal" :in-theory (disable first-update-is-in-data-cells-colllect-lemma) + :use ((:instance + first-update-is-in-data-cells-colllect-lemma + (ptrs (seq-int (g ptr ram) + (len (cdr (assoc-equal typ map)))))) + (:instance nth-i-seq-int + (i (gi (car (collect-updates-from-single-update1 + typ ptr i n ram map)))) + (l (len (cdr (assoc-equal typ map)))))) + :do-not-induct t))) + + + +(in-theory (disable collect-updates-from-single-update1 update-2-w)) + + +(defthm first-update-is-in-data-cells + (implies (consp (collect-updates-zdynamic-1-aux typs ptrs n ram map mode)) + (member + (update-2-w + (car (collect-updates-zdynamic-1-aux typs ptrs n ram map mode)) ram) + (collect-data-cells-1-aux typs ptrs n ram map mode))) + :hints (("Goal" :do-not '(generalize)) + ("Subgoal *1/12.1" :cases + ((consp + (collect-updates-zdynamic-1-aux + (CAR TYPS) PTRS1 N RAM MAP 'ATOM)))) + ("Subgoal *1/10.1" :cases + ((consp + (collect-updates-zdynamic-1-aux + (CAR TYPS) PTRS1 N RAM MAP 'ATOM)))) + ("Subgoal *1/5" + :expand (COLLECT-UPDATES-ZDYNAMIC-1-AUX TYPS PTRS N RAM MAP 'ATOM) + :cases ((consp (COLLECT-UPDATES-FROM-SINGLE-UPDATE1 TYPS PTRS 0 N RAM MAP)))) + ("Subgoal *1/4" + :expand (COLLECT-UPDATES-ZDYNAMIC-1-AUX TYPS PTRS N RAM MAP 'ATOM) + :cases ((consp (COLLECT-UPDATES-FROM-SINGLE-UPDATE1 TYPS PTRS 0 N RAM MAP)))))) + + +(defthm member-implies-not-member + (implies (and (not (overlap a b)) + (member x a)) + (not (member x b)))) + +(defthm not-overlap-data-link-implies-first-step-does-not-update-link-cell + (implies (and (not (overlap (collect-data-cells-1-aux typs ptrs n ram map mode) + (collect-link-cells-1-aux typs ptrs n ram map mode))) + (consp (collect-updates-zdynamic-1-aux typs ptrs n ram map mode))) + (not (member + (update-2-w (car (collect-updates-zdynamic-1-aux typs ptrs n + ram map mode)) ram) + (collect-link-cells-1-aux typs ptrs n ram map mode))))) + + +;------------ proved that if data, link doesn't overlap, +;------------ apply updates perserve the consistent state. + +(defthm first-update-1-in-collect-data-cell-1 + (implies (consp (collect-updates-dynamic-1 typ ptr n ram map)) + (member (update-2-w + (car (collect-updates-dynamic-1 typ ptr n ram map)) ram) + (collect-data-cells-1 typ ptr n ram map)))) + + +(defthm not-consp-collect-updates-dynamic-1-mark-1-is-no-op + (implies (not (consp (collect-updates-dynamic-1 typ ptr n ram map))) + (equal (mark-1 typ ptr n ram map) + ram))) + +(defthm all-collect-updates-dynamic-1-opener + (implies (consp typs) + (equal (all-collect-updates-dynamic-1 typs ptrs ns ram map) + (append (collect-updates-dynamic-1 + (car typs) (car ptrs) (car ns) ram map) + (all-collect-updates-dynamic-1 (cdr typs) (cdr ptrs) + (cdr ns) + (mark-1 (car typs) + (car ptrs) + (car ns) + ram map) + map)))) + :hints (("Goal" :in-theory (disable collect-updates-dynamic-1 mark-1)))) + +(in-theory (disable all-collect-updates-dynamic-1-opener)) + +(defthm first-update-1-in-all-collect-data-cell-1 + (implies (consp (all-collect-updates-dynamic-1 typs ptrs ns ram map)) + (member (update-2-w + (car (all-collect-updates-dynamic-1 typs ptrs ns ram map)) ram) + (all-collect-data-cells-1 typs ptrs ns ram map))) + :hints (("Goal" :in-theory (cons 'all-collect-updates-dynamic-1-opener + (disable collect-updates-dynamic-1 + update-2-w mark-1 + collect-data-cells-1)) + :do-not '(generalize)) + ("Subgoal *1/3" :cases ((consp (collect-updates-dynamic-1 + (car typs) (car ptrs) (car ns) ram + map)))) + ("Subgoal *1/2" :cases ((consp (collect-updates-dynamic-1 + (car typs) (car ptrs) (car ns) ram + map)))))) + + +(defthm first-update-in-collect-data-cell + (implies (consp (collect-updates-dynamic rc)) + (member (update-2-w + (car (collect-updates-dynamic rc)) (ram rc)) + (collect-data-cells rc)))) + +;---------------- + +(defthm first-update-not-in-collect-link-cell + (implies (and (consp (collect-updates-dynamic rc)) + (not (overlap (collect-data-cells rc) + (collect-link-cells rc)))) + (not (member (update-2-w + (car (collect-updates-dynamic rc)) (ram rc)) + (collect-link-cells rc))))) + + +;------------------ + +(defthm struct-equiv-preserved-if-update-non-link-cell + (implies (not (member addr (collect-link-cells rc))) + (struct-equiv (set-ram (s addr v (ram rc)) rc) + rc))) + +(defthm struct-equiv-preserved-if-apply-update-non-link-cell + (implies (not (member (update-2-w update (ram rc)) + (collect-link-cells rc))) + (struct-equiv (set-ram (apply-update update (ram rc) (getmap rc)) + rc) + rc)) + :hints (("Goal" :in-theory (list* 'apply-update + 'update-2-w + (disable struct-equiv + collect-link-cells))))) + + + +;; +;; this can't be proved, easily. +;; + +; +;(defthm struct-equiv-apply-updates +; (implies (not (overlap (collect-data-cells rc) +; (collect-link-cells rc))) +; (struct-equiv +; (apply-updates (collect-updates-dynamic rc) +; (ram rc) (getmap rc)) +; rc)) +; :hints (("Goal" :in-theory (disable collect-updates-dynamic +; collect-link-cells +; collect-data-cells +; struct-equiv)))) +; + + +;; +;; because, we can't prove a (defcong equal collect-update-dynamic ...) +;; unless we know no-overlap +;; + +;; we set out to prove +; +; (defthm not-overlap-and-collect-dynamic-is-collect-static +; (implies (not (overlap (collect-data-cells rc) +; (collect-link-cells rc))) +; (equal (collect-update-dynamic rc) +; (collect-update-static rc)))) +; + +(defun collect-updates-from-single-update1-static (typ ptr i n ram map) + (declare (xargs :measure (m-collect-updates typ map i ram))) + (let* ((descriptor (cdr (assoc-equal typ map))) + (i (nfix i)) + (slot-typ (nth i descriptor))) + (if (zp ptr) nil + (if (< i (len descriptor)) + (if (assoc-equal slot-typ map) + ;; a struct type, meaning a ptr in the (car addrs) + ;; don't touch link cells + (collect-updates-from-single-update1-static typ ptr (+ i 1) n ram map) + ;; else not a struct type, update the value + ;; let the new value depends on the changes to the previous slos + (cons (make-update typ ptr i n) + (collect-updates-from-single-update1-static + typ ptr (+ i 1) n ram map))) + nil)))) + +(defun collect-updates-static-1-aux (typ-or-typs ptr-or-ptrs n ram map mode) + (declare (xargs :measure (struct-equiv-1-aux-m typ-or-typs n mode))) + (let ((typ typ-or-typs) + (ptr ptr-or-ptrs) + (typs typ-or-typs) + (ptrs ptr-or-ptrs)) + (cond ((equal mode 'ATOM) + (let* ((desc (cdr (assoc-equal typ map))) + (size (len desc))) + (if (zp n) nil + (if (zp ptr) nil + (if (not (assoc-equal typ map)) ;; not bound + nil + (let* ((addr (g ptr ram))) + (append (collect-updates-from-single-update1-static + typ ptr 0 n ram map) + (collect-updates-static-1-aux + desc + (seq-int addr size) + (- n 1) + ram map 'LIST)))))))) + ((equal mode 'LIST) + (if (endp typs) + nil + (if (not (assoc-equal (car typs) map)) + (collect-updates-static-1-aux + (cdr typs) (cdr ptrs) n ram map 'LIST) + (append (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map 'ATOM) + (collect-updates-static-1-aux (cdr typs) + (cdr ptrs) + n + ram map 'LIST))))) + (t nil)))) + + +;-------------------- +(defthm collect-updates-from-single-update1-static-is-independent-of-ram + (equal (collect-updates-from-single-update1-static + typ ptr i n AnyRam map) + (collect-updates-from-single-update1-static + typ ptr i n ram map)) + :hints (("Goal" :do-not '(generalize))) + :rule-classes nil) + + + +(defthm struct-equiv-1-aux-implies-collect-static-updates-1-aux-equal + (implies (struct-equiv-1-aux typ-or-typs ptr-or-ptrs n ram1 ram2 map mode) + (equal (collect-updates-static-1-aux typ-or-typs ptr-or-ptrs n + ram1 map mode) + (collect-updates-static-1-aux typ-or-typs ptr-or-ptrs n + ram2 map mode))) + :hints (("Subgoal *1/6" + :use ((:instance + collect-updates-from-single-update1-static-is-independent-of-ram + (i 0) (typ typ-or-typs) (ptr ptr-or-ptrs) (anyRam ram1) (ram ram2)))))) + +;; i need a strong theorem that establish equal after an update to the non-link +;; cell + + +(defthm not-change-link-collect-updates-from-single-update1-static-not-changed + (equal (collect-updates-from-single-update1-static + typ ptr i n (s addr v ram) map) + (collect-updates-from-single-update1-static + typ ptr i n ram map))) + + +(defthm not-change-link-cell-collect-update-static-1-aux-not-changed + (implies (not (member addr (collect-link-cells-1-aux typ-or-typs ptr-or-ptrs + n ram map mode))) + (equal (collect-updates-static-1-aux typ-or-typs ptr-or-ptrs + n (s addr v ram) map mode) + (collect-updates-static-1-aux typ-or-typs ptr-or-ptrs + n ram map mode))) + :hints (("Goal" :in-theory (disable + collect-updates-from-single-update1-static)))) + +;-------------------- +;; ready to prove the most important theorem +;; collect-dynamic is collect-static +;; when data cell and link cell doesn't overlap + + +(defun not-change-induct (typ ptr i n AnyRam ram map) + (declare (xargs :measure (m-collect-updates typ map i ram))) + (let* ((descriptor (cdr (assoc-equal typ map))) + (i (nfix i)) + (slot-typ (nth i descriptor)) + (addr (g ptr AnyRam))) + (if (zp ptr) (list typ ptr i n anyRam ram map) + (if (< i (len descriptor)) + (if (assoc-equal slot-typ map) + ;; a struct type, meaning a ptr in the (car addrs) + ;; don't touch link cells + (not-change-induct typ ptr (+ i 1) n AnyRam ram map) + ;; else not a struct type, update the value + (let ((new-ram (s (+ addr i) (new-field-value typ ptr i n AnyRam map) AnyRam))) + ;; let the new value depends on the changes to the previous slos + (not-change-induct typ ptr (+ i 1) n new-ram ram map))) + (list typ ptr i n anyRam ram map))))) + + + +(defthm not-change-link-collect-updates-from-single-update1-is-statick-not-changed + (equal (collect-updates-from-single-update1 + typ ptr i n AnyRam map) + (collect-updates-from-single-update1-static + typ ptr i n ram map)) + :hints (("Goal" :do-not '(generalize) + :induct (not-change-induct typ ptr i n AnyRam ram map)) + ("Subgoal *1/3" :expand (collect-updates-from-single-update1 + typ ptr i n AnyRam map)) + ("Subgoal *1/2" :expand (collect-updates-from-single-update1 + typ ptr i n AnyRam map)) + ("Subgoal *1/1" :expand (collect-updates-from-single-update1 + typ ptr i n AnyRam map)))) + +(in-theory (disable collect-updates-from-single-update1 + collect-updates-from-single-update1-static)) + + +(defthm not-overlap-append + (implies (not (overlap (append a b) + (append c d))) + (not (overlap a c)))) + + +(defthm not-overlap-append-2 + (implies (not (overlap (append a b) + (append c d))) + (not (overlap b d)))) + + +;------------------ + +;; We proved the following +;(thm +; (implies (and (not (overlap (collect-data-cells-1-aux typs ptrs n ram map mode) +; (collect-link-cells-1-aux typs ptrs n ram map mode))) +; (consp (collect-updates-zdynamic-1-aux typs ptrs n ram map mode))) +; (not (member +; (update-2-w (car (collect-updates-zdynamic-1-aux typs ptrs n +; ram map mode)) ram) +; (collect-link-cells-1-aux typs ptrs n ram map mode))))) + +;--- prove more general theorem using the above + +;; 1/4.1 + +(defthm overlap-lemma + (implies (overlap a b) + (overlap a (cons x b)))) + +;------------------- + +;; why the following skip-proofs are true. +; +; because we can show +; +; (apply-updates (collect-updates-static-1-aux ...) gives struct-equiv state +; by showing applying first update, give you a struct-equiv state +; and the collect-updates-static-1-aux from that state is not changed. +; thus apply the second update +; +; +; current approach is to prove if no overlap then, collect-updates-static-1-aux +; is a subset of data links. +; + +(defun subset-induct (typ-or-typs ptr-or-ptrs n ram map mode) + (declare (xargs :measure (struct-equiv-1-aux-m typ-or-typs n mode))) + (let ((typ typ-or-typs) + (ptr ptr-or-ptrs) + (typs typ-or-typs) + (ptrs ptr-or-ptrs)) + (cond ((equal mode 'ATOM) + (let* ((desc (cdr (assoc-equal typ map))) + (size (len desc))) + (if (zp n) nil + (if (zp ptr) nil + (if (not (assoc-equal typ map)) ;; not bound + nil + (let* ((addr (g ptr ram))) + (subset-induct + desc (seq-int addr size) + (- n 1) + (apply-updates + (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + map 'LIST))))))) + + ((equal mode 'LIST) + (if (endp typs) + nil + (if (not (assoc-equal (car typs) map)) + (subset-induct (cdr typs) (cdr ptrs) n ram map 'LIST) + (list (subset-induct (car typs) (car ptrs) n ram map 'ATOM) + (subset-induct (cdr typs) (cdr ptrs) + n (apply-updates + (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map 'ATOM) + ram map) + map 'LIST))))) + (t (list typs ptrs n ram map mode))))) + + +(defthm subsetp-cons + (implies (subsetp x l) + (subsetp x (cons y l)))) + + +;-------------------------- + +(defthm struct-equiv-1-aux-preserved-if-apply-update-non-link-cell + (implies (not (member (update-2-w update ram) + (collect-link-cells-1-aux typs ptrs n ram map mode))) + (struct-equiv-1-aux + typs ptrs n (apply-update update ram map) ram map + mode)) + :hints (("Goal" :in-theory (enable apply-update update-2-w)))) + + +(defthm subsetp-update-2-ws + (implies (and (subsetp (updates-2-ws updates ram map) l) + (consp updates)) + (member (update-2-w (car updates) ram) l)) + :rule-classes :forward-chaining) + +(defthm member-overlap-2 + (implies (and (not (overlap a b)) + (member x a)) + (not (member x b))) + :rule-classes :forward-chaining) + + +(defthm subsetp-not-member-link-instance + (implies (and (not (overlap (collect-data-cells-1-aux + typ-or-typs ptr-or-ptrs n ram map mode) + (collect-link-cells-1-aux + typ-or-typs ptr-or-ptrs n ram map mode))) + (consp updates) + (subsetp (updates-2-ws updates ram map) + (collect-data-cells-1-aux + typ-or-typs ptr-or-ptrs n ram map mode))) + (not (member (update-2-w (car updates) ram) + (collect-link-cells-1-aux + typ-or-typs ptr-or-ptrs n ram map mode)))) + :hints (("Goal" :in-theory (disable collect-data-cells-1-aux + collect-link-cells-1-aux + subsetp overlap)))) + + +(defthm apply-updates-nil-is-not-changed + (implies (not (consp updates)) + (equal (apply-updates updates ram map) ram))) + + +(defthm struct-equiv-1-aux-preserved-if-apply-update-non-link-cell-instance + (implies (and (not (overlap (collect-data-cells-1-aux + typ-or-typs ptr-or-ptrs n ram map mode) + (collect-link-cells-1-aux + typ-or-typs ptr-or-ptrs n ram map mode))) + (consp updates) + (subsetp (updates-2-ws updates ram map) + (collect-data-cells-1-aux + typ-or-typs ptr-or-ptrs n ram map mode))) + (struct-equiv-1-aux + typ-or-typs ptr-or-ptrs n (apply-update (car updates) ram map) ram map + mode)) + :hints (("Goal" :cases ((not (consp updates)))))) + + +(defthm collect-link-cells-1-aux-apply-updates-collect-links-updates-instance + (implies (and (not (overlap (collect-data-cells-1-aux typs ptrs n + ram map mode) + (collect-link-cells-1-aux typs ptrs n + ram map mode))) + (consp updates) + (subsetp (updates-2-ws updates ram map) + (collect-data-cells-1-aux + typs ptrs n ram map mode))) + (equal (collect-link-cells-1-aux typs ptrs n + (apply-update (car updates) ram + map) + map + mode) + (collect-link-cells-1-aux typs ptrs n + ram map mode))) + :hints (("Goal" :use ((:instance + struct-equiv-1-aux-implies-collect-link-cells-aux-equal + (ram1 (apply-update (car updates) ram map)) + (ram2 ram) + (typ-or-typs typs) (ptr-or-ptrs ptrs)))))) + + + + + +(defthm collect-link-cells-1-aux-apply-updates-collect-data-updates-instance + (implies (and (not (overlap (collect-data-cells-1-aux typs ptrs n + ram map mode) + (collect-link-cells-1-aux typs ptrs n + ram map mode))) + (consp updates) + (subsetp (updates-2-ws updates ram map) + (collect-data-cells-1-aux + typs ptrs n ram map mode))) + (equal (collect-data-cells-1-aux typs ptrs n + (apply-update (car updates) ram + map) + map + mode) + (collect-data-cells-1-aux typs ptrs n + ram map mode))) + :hints (("Goal" :use ((:instance + struct-equiv-1-aux-implies-collect-data-cells-aux-equal + (ram1 (apply-update (car updates) ram map)) + (ram2 ram) + (typ-or-typs typs) (ptr-or-ptrs ptrs)))))) + + + +(defthm apply-updates-struct-equiv-1-aux + (implies (and (not (overlap (collect-data-cells-1-aux typ-or-typs ptr-or-ptrs n ram map mode) + (collect-link-cells-1-aux typ-or-typs ptr-or-ptrs n ram map mode))) + (consp updates) + (subsetp (updates-2-ws updates ram map) + (collect-data-cells-1-aux + typ-or-typs ptr-or-ptrs n ram map mode))) + (struct-equiv-1-aux + typ-or-typs ptr-or-ptrs n + (apply-updates updates ram map) + ram map + mode)) + :hints (("Goal" :do-not '(generalize)))) + + +; shared + +;------------------------- + +(defthm subsetp-collect-data-cells-1-collect-data-cells-1 + (implies (consp typs) + (subsetp (collect-data-cells-1-aux + (car typs) (car ptrs) n ram map 'ATOM) + (collect-data-cells-1-aux + typs ptrs n ram map 'LIST)))) + + +(defthm apply-updates-struct-equiv-1-aux-instance + (implies (and (not (overlap (collect-data-cells-1-aux + typs ptrs n ram map 'LIST) + (collect-link-cells-1-aux + typs ptrs n ram map 'LIST))) + (consp updates) + (subsetp (updates-2-ws updates ram map) + (collect-data-cells-1-aux + (car typs) (car ptrs) n ram map 'ATOM))) + (struct-equiv-1-aux + typs ptrs n + (apply-updates updates ram map) + ram map + 'LIST))) + +(defthm apply-updates-struct-equiv-1-aux-instance-1-instance + (implies (and (not (overlap (collect-data-cells-1-aux typs ptrs n ram map 'LIST) + (collect-link-cells-1-aux typs ptrs n ram map + 'LIST))) + (not (endp typs)) + (assoc-equal (car typs) map) + (subsetp (updates-2-ws updates ram map) + (collect-data-cells-1-aux + (car typs) (car ptrs) n ram map 'ATOM))) + (struct-equiv-1-aux (cdr typs) (cdr ptrs) n + (apply-updates updates + ram map) + ram map 'LIST)) + :hints (("Goal" :in-theory (disable apply-updates-struct-equiv-1-aux-instance) + :use apply-updates-struct-equiv-1-aux-instance))) + + + +(defthm struct-equiv-1-aux-implies-collect-data-equal-instance + (implies (struct-equiv-1-aux (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) + ram map) + ram map 'LIST) + (equal (collect-data-cells-1-aux + (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) ram map) map 'LIST) + (collect-data-cells-1-aux + (cdr typs) (cdr ptrs) n ram map 'LIST)))) + + +(defthm struct-equiv-1-aux-implies-collect-link-equal-instance + (implies (struct-equiv-1-aux (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) + ram map) + ram map 'LIST) + (equal (collect-link-cells-1-aux + (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) ram map) map 'LIST) + (collect-link-cells-1-aux + (cdr typs) (cdr ptrs) n ram map 'LIST)))) + + +(defthm struct-equiv-1-aux-implies-collect-static-equal-instance + (implies (struct-equiv-1-aux (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) + ram map) + ram map 'LIST) + (equal (collect-updates-static-1-aux + (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) ram map) map 'LIST) + (collect-updates-static-1-aux + (cdr typs) (cdr ptrs) n ram map 'LIST)))) + + +;; solved 1-7-2-1 + +(defthm updates-2-ws-append + (equal (updates-2-ws (append updates1 updates2) + ram map) + (append (updates-2-ws updates1 ram map) + (updates-2-ws updates2 + (apply-updates updates1 ram map) map)))) + + +;; solved 1-7-1-1 + + + + +;; because our induction in collect-data-cells and collect-updates doesn't +;; match well. This proof is complicated. + +(defun collect-data-cells-from-single-node (typ ptr i ram map) + (declare (xargs :measure (m-collect-updates typ map i ram))) + (let* ((descriptor (cdr (assoc-equal typ map))) + (i (nfix i)) + (slot-typ (nth i descriptor)) + (addr (g ptr ram))) + (if (zp ptr) nil + (if (< i (len descriptor)) + (if (assoc-equal slot-typ map) + ;; a struct type, meaning a ptr in the (car addrs) + ;; don't touch link cells + (collect-data-cells-from-single-node typ ptr (+ i 1) ram map) + ;; else not a struct type, update the value + (cons (+ i addr) + (collect-data-cells-from-single-node + typ ptr (+ i 1) ram map))) + nil)))) + + + +;; prove a more general one than +;; subsetp-collect-data-cells-from-single-node-collect-data-cells + +(defthm nth-i-equal-car-mycdrn-i + (implies (and (< i (len l)) + (<= 0 i)) + (equal (nth i l) + (car (mycdrn i l))))) + + +(defthm member-collect-data-cells-1-aux + (implies (and (not (assoc-equal (car (mycdrn i typs)) map)) + (< i (len typs)) + (<= 0 i)) + (member (+ i addr) + (collect-data-cells-1-aux + (mycdrn i typs) + (seq-int (+ i addr) + (len (mycdrn i typs))) + n + ram map 'LIST)))) + + +(defthm subsetp-collect-data-1-aux-mycdrn + (implies (and (consp typs) + (integerp i) + (<= 0 i)) + (subsetp (collect-data-cells-1-aux + (cdr typs) + (seq-int (+ 1 addr) + (len (cdr typs))) + n + ram map 'LIST) + (collect-data-cells-1-aux + typs + (seq-int addr + (len typs)) + n + ram map 'LIST))) + :hints (("Goal" :do-not '(generalize)))) + + +(defthm mycdrn-i-cdr + (equal (mycdrn i (cddr typs)) + (cdr (mycdrn i (cdr typs))))) + + +(defthm subsetp-collect-data-1-aux-mycdrn-2 + (implies (and (consp typs) + (integerp i) + (<= 0 i) + (assoc-equal (car typs) map)) + (subsetp (collect-data-cells-1-aux + (cdr typs) + (seq-int (+ 1 addr) + (len (cdr typs))) + n + ram map 'LIST) + (collect-data-cells-1-aux + typs + (cons any + (seq-int (+ 1 addr) + (len (cdr typs)))) + n + ram map 'LIST))) + :hints (("Goal" :do-not '(generalize)))) + +(defthm subsetp-collect-data-cells-from-single-node-collect-data-cells-lemma + (implies (and (integerp i) + (<= 0 i)) + (subsetp (collect-data-cells-from-single-node + typ ptr i ram map) + (collect-data-cells-1-aux + (mycdrn i (cdr (assoc-equal typ map))) + (seq-int (+ i (g ptr ram)) (len (mycdrn i (cdr (assoc-equal typ map))))) + (- n 1) + ram map 'LIST))) + :hints (("Goal" :do-not '(generalize)))) + + +(defthm seq-int-fix + (equal (seq-int (fix addr) len) + (seq-int addr len))) + +(defthm subsetp-collect-data-cells-from-single-node-collect-data-cells + (subsetp (collect-data-cells-from-single-node + typ ptr 0 ram map) + (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST)) + :hints (("Goal" + :in-theory (disable subsetp-collect-data-cells-from-single-node-collect-data-cells-lemma) + :use ((:instance + subsetp-collect-data-cells-from-single-node-collect-data-cells-lemma + (i 0)))))) + +;----------- +(defun induct-collect-updates (typ ptr i n ram map) + (declare (xargs :measure (m-collect-updates typ map i ram))) + (let* ((descriptor (cdr (assoc-equal typ map))) + (i (nfix i)) + (slot-typ (nth i descriptor)) + (addr (g ptr ram))) + (if (zp ptr) nil + (if (< i (len descriptor)) + (if (assoc-equal slot-typ map) + ;; a struct type, meaning a ptr in the (car addrs) + ;; don't touch link cells + (induct-collect-updates typ ptr (+ i 1) n ram map) + ;; else not a struct type, update the value + (let ((new-ram (s (+ addr i) (new-field-value typ ptr i n ram map) ram))) + ;; let the new value depends on the changes to the previous slos + (induct-collect-updates typ ptr (+ i 1) n + new-ram map))) + nil)))) + +#| +;; a general statement. easy to prove but not so good. +(defthm collect-data-cells-from-single-node-not-affected-by-lemma + (implies (equal (g ptr ram2) (g ptr ram1)) + (equal (collect-data-cells-from-single-node + typ ptr i ram2 map) + (collect-data-cells-from-single-node + typ ptr i ram1 map)))) +;; free variables. not good. so write a more specific one. +|# + + +(defthm collect-data-cells-from-single-node-not-affected-by-lemma-2 + (implies (not (equal addr ptr)) + (equal (collect-data-cells-from-single-node + typ ptr i (s addr anyValue ram) map) + (collect-data-cells-from-single-node + typ ptr i ram map)))) + + +(defthm member-not-member-implies-not-equal-f + (implies (and (not (member x l)) + (member y l)) + (not (equal x y))) + :rule-classes :forward-chaining) + + + +;; not a very good one. +(defthm collect-data-cells-from-single-node-not-affected-by + (implies (and (not (member ptr (collect-data-cells-from-single-node + typ ptr i ram map))) + (member addr (collect-data-cells-from-single-node + typ ptr i ram map))) + (equal (collect-data-cells-from-single-node + typ ptr i (s addr anyValue ram) map) + (collect-data-cells-from-single-node + typ ptr i ram map)))) + +(defthm collect-updates-from-single-update1-static-opener + (implies (zp ptr) + (equal (collect-updates-from-single-update1-static + typ ptr i n ram map) nil)) + :hints (("Goal" :expand + (collect-updates-from-single-update1-static + typ ptr i n ram map)))) + +(defthm collect-updates-from-single-update1-static-opener-2 + (implies (and (<= (LEN (CDR (ASSOC-EQUAL TYP MAP))) I) + (integerp i)) + (equal (collect-updates-from-single-update1-static + typ ptr i n ram map) nil)) + :hints (("Goal" :expand + (collect-updates-from-single-update1-static + typ ptr i n ram map)))) +#| +(defthm collect-updates-from-single-update1-static-opener-3 + (implies (zp n) + (equal (collect-updates-from-single-update1-static + typ ptr i n ram map) nil)) + :hints (("Goal" :expand + (collect-updates-from-single-update1-static + typ ptr i n ram map)))) +|# + + +(defthm equal-collect-data-cells-from-single-node-equal-updates-2-ws + (implies (and (not (member ptr (collect-data-cells-from-single-node + typ ptr i ram map))) + (integerp i) + (<= 0 i)) + (equal (updates-2-ws (collect-updates-from-single-update1-static + typ ptr i n ram map) ram map) + (collect-data-cells-from-single-node + typ ptr i ram map))) + :hints (("Goal" :induct (induct-collect-updates typ ptr i n ram map) + :in-theory (enable update-2-w make-update apply-update gptr gi gn gtyp) + :do-not '(generalize fertilize) + :expand (collect-updates-from-single-update1-static + typ ptr i n ram map)))) + + +(defthm not-member-forward-chaining + (implies (and (subsetp a b) + (not (member x b))) + (not (member x a))) + :rule-classes :forward-chaining) + + +(defthm subsetp-collect-updates-from-single-update-1-static + (implies (not (member ptr (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ + map)))) + (- n 1) ram map 'LIST))) + (subsetp (updates-2-ws (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST))) + :hints (("Goal" :in-theory (disable subsetp-collect-data-cells-from-single-node-collect-data-cells) + :use subsetp-collect-data-cells-from-single-node-collect-data-cells))) + + + +(defthm not-overlap-not-member-x + (implies (not (overlap a (cons x b))) + (not (member x a))) + :rule-classes :forward-chaining) + + +(defthm not-overlap-implies-not-member + (implies (not (overlap (collect-data-cells-1-aux typ ptr n ram map 'ATOM) + (collect-link-cells-1-aux typ ptr n ram map 'ATOM))) + (not (member ptr (collect-data-cells-1-aux + typ ptr n ram map 'ATOM)))) + :hints (("Goal" :expand (collect-link-cells-1-aux typ ptr n ram map 'ATOM))) + :rule-classes :forward-chaining) + + +;; I should modify the definition of collect-updates-from-single-update1-static +;; to return nil when n is zero + +(defthm subsetp-collect-updates-from-single-update-collect-data-1-aux + (implies (and (not (overlap (collect-data-cells-1-aux typ ptr n ram map 'ATOM) + (collect-link-cells-1-aux typ ptr n ram map + 'ATOM))) + (not (zp n))) + (subsetp (updates-2-ws (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + (collect-data-cells-1-aux typ ptr n ram map 'ATOM))) + :hints (("Goal" :expand (collect-data-cells-1-aux typ ptr n ram map 'ATOM)))) + + +(defthm apply-updates-struct-equiv-1-aux-instance-2 + (implies (not (overlap (collect-data-cells-1-aux + typ ptr n ram map 'ATOM) + (collect-link-cells-1-aux + typ ptr n ram map 'ATOM))) + (struct-equiv-1-aux + typ ptr n + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + ram map + 'ATOM)) + :hints (("Goal" :cases ((not (zp n)))) + ("Subgoal 1" :cases ((consp (collect-updates-from-single-update1-static + typ ptr 0 n ram map)))))) + + + +(defthm apply-updates-struct-equiv-1-aux-instance-2-instance + (implies (and (not (overlap (collect-data-cells-1-aux typ ptr n ram map 'ATOM) + (collect-link-cells-1-aux typ ptr n ram map 'ATOM))) + (assoc-equal typ map) + (not (zp n)) + (not (zp ptr))) + (struct-equiv-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + ram + map 'LIST)) + :hints (("Goal" :in-theory (disable apply-updates-struct-equiv-1-aux-instance-2) + :use apply-updates-struct-equiv-1-aux-instance-2))) + +;----------------------- concrete instantiations + +(defthm struct-equiv-1-aux-implies-collect-data-equal-instance-2 + (implies (struct-equiv-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + ram + map 'LIST) + (equal (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + map 'LIST) + (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST)))) + + +(defthm struct-equiv-1-aux-implies-collect-link-equal-instance-2 + (implies (struct-equiv-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + ram + map 'LIST) + (equal (collect-link-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + map 'LIST) + (collect-link-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST)))) + + + +(defthm struct-equiv-1-aux-implies-collect-update-static-equal-instance-2 + (implies (struct-equiv-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + ram + map 'LIST) + (equal (collect-updates-static-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + map 'LIST) + (collect-updates-static-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST)))) + + + + +;------------------------- + +;; because our induction in collect-data-cells and collect-updates doesn't +;; match well. This proof is complicated. + +(defun collect-data-cells-from-single-node (typ ptr i ram map) + (declare (xargs :measure (m-collect-updates typ map i ram))) + (let* ((descriptor (cdr (assoc-equal typ map))) + (i (nfix i)) + (slot-typ (nth i descriptor)) + (addr (g ptr ram))) + (if (zp ptr) nil + (if (< i (len descriptor)) + (if (assoc-equal slot-typ map) + ;; a struct type, meaning a ptr in the (car addrs) + ;; don't touch link cells + (collect-data-cells-from-single-node typ ptr (+ i 1) ram map) + ;; else not a struct type, update the value + (cons (+ i addr) + (collect-data-cells-from-single-node + typ ptr (+ i 1) ram map))) + nil)))) + + + +;; prove a more general one than +;; subsetp-collect-data-cells-from-single-node-collect-data-cells + +(defthm nth-i-equal-car-mycdrn-i + (implies (and (< i (len l)) + (<= 0 i)) + (equal (nth i l) + (car (mycdrn i l))))) + + +(defthm member-collect-data-cells-1-aux + (implies (and (not (assoc-equal (car (mycdrn i typs)) map)) + (< i (len typs)) + (<= 0 i)) + (member (+ i addr) + (collect-data-cells-1-aux + (mycdrn i typs) + (seq-int (+ i addr) + (len (mycdrn i typs))) + n + ram map 'LIST)))) + + +(defthm subsetp-collect-data-1-aux-mycdrn + (implies (and (consp typs) + (integerp i) + (<= 0 i)) + (subsetp (collect-data-cells-1-aux + (cdr typs) + (seq-int (+ 1 addr) + (len (cdr typs))) + n + ram map 'LIST) + (collect-data-cells-1-aux + typs + (seq-int addr + (len typs)) + n + ram map 'LIST))) + :hints (("Goal" :do-not '(generalize)))) + + +(defthm mycdrn-i-cdr + (equal (mycdrn i (cddr typs)) + (cdr (mycdrn i (cdr typs))))) + + +(defthm subsetp-collect-data-1-aux-mycdrn-2 + (implies (and (consp typs) + (integerp i) + (<= 0 i) + (assoc-equal (car typs) map)) + (subsetp (collect-data-cells-1-aux + (cdr typs) + (seq-int (+ 1 addr) + (len (cdr typs))) + n + ram map 'LIST) + (collect-data-cells-1-aux + typs + (cons any + (seq-int (+ 1 addr) + (len (cdr typs)))) + n + ram map 'LIST))) + :hints (("Goal" :do-not '(generalize)))) + +(defthm subsetp-collect-data-cells-from-single-node-collect-data-cells-lemma + (implies (and (integerp i) + (<= 0 i)) + (subsetp (collect-data-cells-from-single-node + typ ptr i ram map) + (collect-data-cells-1-aux + (mycdrn i (cdr (assoc-equal typ map))) + (seq-int (+ i (g ptr ram)) (len (mycdrn i (cdr (assoc-equal typ map))))) + (- n 1) + ram map 'LIST))) + :hints (("Goal" :do-not '(generalize)))) + + +(defthm seq-int-fix + (equal (seq-int (fix addr) len) + (seq-int addr len))) + +(defthm subsetp-collect-data-cells-from-single-node-collect-data-cells + (subsetp (collect-data-cells-from-single-node + typ ptr 0 ram map) + (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST)) + :hints (("Goal" + :in-theory (disable subsetp-collect-data-cells-from-single-node-collect-data-cells-lemma) + :use ((:instance + subsetp-collect-data-cells-from-single-node-collect-data-cells-lemma + (i 0)))))) + +;----------- +(defun induct-collect-updates (typ ptr i n ram map) + (declare (xargs :measure (m-collect-updates typ map i ram))) + (let* ((descriptor (cdr (assoc-equal typ map))) + (i (nfix i)) + (slot-typ (nth i descriptor)) + (addr (g ptr ram))) + (if (zp ptr) nil + (if (< i (len descriptor)) + (if (assoc-equal slot-typ map) + ;; a struct type, meaning a ptr in the (car addrs) + ;; don't touch link cells + (induct-collect-updates typ ptr (+ i 1) n ram map) + ;; else not a struct type, update the value + (let ((new-ram (s (+ addr i) (new-field-value typ ptr i n ram map) ram))) + ;; let the new value depends on the changes to the previous slos + (induct-collect-updates typ ptr (+ i 1) n + new-ram map))) + nil)))) + +#| +;; a general statement. easy to prove but not so good. +(defthm collect-data-cells-from-single-node-not-affected-by-lemma + (implies (equal (g ptr ram2) (g ptr ram1)) + (equal (collect-data-cells-from-single-node + typ ptr i ram2 map) + (collect-data-cells-from-single-node + typ ptr i ram1 map)))) +;; free variables. not good. so write a more specific one. +|# + + +(defthm collect-data-cells-from-single-node-not-affected-by-lemma-2 + (implies (not (equal addr ptr)) + (equal (collect-data-cells-from-single-node + typ ptr i (s addr anyValue ram) map) + (collect-data-cells-from-single-node + typ ptr i ram map)))) + + +(defthm member-not-member-implies-not-equal-f + (implies (and (not (member x l)) + (member y l)) + (not (equal x y))) + :rule-classes :forward-chaining) + + + +;; not a very good one. +(defthm collect-data-cells-from-single-node-not-affected-by + (implies (and (not (member ptr (collect-data-cells-from-single-node + typ ptr i ram map))) + (member addr (collect-data-cells-from-single-node + typ ptr i ram map))) + (equal (collect-data-cells-from-single-node + typ ptr i (s addr anyValue ram) map) + (collect-data-cells-from-single-node + typ ptr i ram map)))) + +(defthm collect-updates-from-single-update1-static-opener + (implies (zp ptr) + (equal (collect-updates-from-single-update1-static + typ ptr i n ram map) nil)) + :hints (("Goal" :expand + (collect-updates-from-single-update1-static + typ ptr i n ram map)))) + +(defthm collect-updates-from-single-update1-static-opener-2 + (implies (and (<= (LEN (CDR (ASSOC-EQUAL TYP MAP))) I) + (integerp i)) + (equal (collect-updates-from-single-update1-static + typ ptr i n ram map) nil)) + :hints (("Goal" :expand + (collect-updates-from-single-update1-static + typ ptr i n ram map)))) + + + +(defthm equal-collect-data-cells-from-single-node-equal-updates-2-ws + (implies (and (not (member ptr (collect-data-cells-from-single-node + typ ptr i ram map))) + (integerp i) + (<= 0 i)) + (equal (updates-2-ws (collect-updates-from-single-update1-static + typ ptr i n ram map) ram map) + (collect-data-cells-from-single-node + typ ptr i ram map))) + :hints (("Goal" :induct (induct-collect-updates typ ptr i n ram map) + :in-theory (enable update-2-w make-update apply-update gptr gi gn gtyp) + :do-not '(generalize fertilize) + :expand (collect-updates-from-single-update1-static + typ ptr i n ram map)))) + + +(defthm not-member-forward-chaining + (implies (and (subsetp a b) + (not (member x b))) + (not (member x a))) + :rule-classes :forward-chaining) + + +(defthm subsetp-collect-updates-from-single-update-1-static + (implies (not (member ptr (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ + map)))) + (- n 1) ram map 'LIST))) + (subsetp (updates-2-ws (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST))) + :hints (("Goal" :in-theory (disable subsetp-collect-data-cells-from-single-node-collect-data-cells) + :use subsetp-collect-data-cells-from-single-node-collect-data-cells))) + + + +(defthm not-overlap-not-member-x + (implies (not (overlap a (cons x b))) + (not (member x a))) + :rule-classes :forward-chaining) + + + +(defthm subsetp-collect-updates-static-1-aux-data-cells + (implies (not (overlap (collect-data-cells-1-aux typ-or-typs + ptr-or-ptrs n ram map mode) + (collect-link-cells-1-aux typ-or-typs + ptr-or-ptrs n ram map mode))) + (subsetp (updates-2-ws (collect-updates-static-1-aux typ-or-typs + ptr-or-ptrs + n ram map mode) ram map) + (collect-data-cells-1-aux typ-or-typs ptr-or-ptrs + n ram map mode))) + :hints (("Goal" :induct (subset-induct + typ-or-typs ptr-or-ptrs n ram map mode) + :do-not '(generalize)))) + +;; this is important result + + + +;--- this above the important result we want to show --- +(defun prefix (a b) + (if (endp a) t + (if (endp b) nil + (and (equal (car a) (car b)) + (prefix (cdr a) (cdr b)))))) + +(defthm prefix-subsetp + (implies (prefix updates2 updates1) + (subsetp (updates-2-ws updates2 ram map) + (updates-2-ws updates1 ram map)))) + +(defthm prefix-append + (prefix a (append a b))) + +(defthm subsetp-collect-updates-static-1-aux + (implies (and (not (endp typs)) + (assoc-equal (car typs) map)) + (subsetp (updates-2-ws (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map 'ATOM) ram map) + (updates-2-ws (collect-updates-static-1-aux + typs ptrs n ram map 'LIST) ram map)))) + + +(defthm apply-updates-struct-equiv-1-aux-instance-1 + (implies (and (not (overlap (collect-data-cells-1-aux typs ptrs n ram map 'LIST) + (collect-link-cells-1-aux typs ptrs n ram map + 'LIST))) + (not (endp typs)) + (assoc-equal (car typs) map)) + (struct-equiv-1-aux typs ptrs n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) + ram map) + ram map 'LIST)) + :hints (("Goal" :do-not '(generalize) + :cases ((consp (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map 'ATOM)))) + ("Subgoal 1" :use ((:instance subsetp-transitive + (a (updates-2-ws + (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) ram map)) + (b (updates-2-ws + (collect-updates-static-1-aux + typs ptrs n ram map 'LIST) ram + map)) + (c (collect-data-cells-1-aux + typs ptrs n ram map 'LIST))))))) + + +;----------------- +; +; need to instantiate it again to get the version I wanted. +; +#| +(defthm apply-updates-struct-equiv-1-aux-instance-1-instance + (implies (and (not (overlap (collect-data-cells-1-aux typs ptrs n ram map 'LIST) + (collect-link-cells-1-aux typs ptrs n ram map + 'LIST))) + (not (endp typs)) + (assoc-equal (car typs) map)) + (struct-equiv-1-aux (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) + ram map) + ram map 'LIST)) + :hints (("Goal" :in-theory (disable apply-updates-struct-equiv-1-aux-instance-1) + :use apply-updates-struct-equiv-1-aux-instance-1))) + +;; now I have what I want. + +;; instantiate some of struct-equiv-1-aux-implies-collect-XXX-equal + +(defthm struct-equiv-1-aux-implies-collect-data-equal-instance + (implies (struct-equiv-1-aux (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) + ram map) + ram map 'LIST) + (equal (collect-data-cells-1-aux + (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) ram map) map 'LIST) + (collect-data-cells-1-aux + (cdr typs) (cdr ptrs) n ram map 'LIST)))) + +(defthm struct-equiv-1-aux-implies-collect-link-equal-instance + (implies (struct-equiv-1-aux (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) + ram map) + ram map 'LIST) + (equal (collect-link-cells-1-aux + (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) ram map) map 'LIST) + (collect-link-cells-1-aux + (cdr typs) (cdr ptrs) n ram map 'LIST)))) +|# + +(defthm struct-equiv-1-aux-implies-collect-update-static-1-aux-equal-instance + (implies (struct-equiv-1-aux (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) + ram map) + ram map 'LIST) + (equal (collect-updates-static-1-aux + (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) ram map) map 'LIST) + (collect-updates-static-1-aux + (cdr typs) (cdr ptrs) n ram map 'LIST)))) + + + +(defthm mark-1-aux-equal-is-if-dynamic-equal-static + (implies (equal (collect-updates-zdynamic-1-aux typ ptr n ram map 'ATOM) + (collect-updates-static-1-aux typ ptr n ram map 'ATOM)) + (equal (mark-1-aux typ ptr n ram map 'ATOM) + (apply-updates (collect-updates-static-1-aux + typ ptr n ram map 'ATOM) ram map)))) + +;------------------------------- + + + + +(defthm lemma-1-7-2-1 + (implies (and (not (overlap (collect-data-cells-1-aux typs ptrs n ram map 'list) + (collect-link-cells-1-aux typs ptrs n ram map 'list))) + (equal (collect-updates-zdynamic-1-aux (car typs) + (car ptrs) n ram map + 'ATOM) + (collect-updates-static-1-aux (car typs) + (car ptrs) n ram map + 'ATOM)) + (not (endp typs)) + (assoc-equal (car typs) map)) + (not (overlap (collect-data-cells-1-aux + (cdr typs) (cdr ptrs) n + (mark-1-aux (car typs) (car ptrs) n ram map 'ATOM) + map 'LIST) + (collect-link-cells-1-aux + (cdr typs) (cdr ptrs) n + (mark-1-aux (car typs) (car ptrs) n ram map 'ATOM) + map 'LIST)))) + :hints (("Goal" :in-theory (disable apply-updates-collect-dynamic-is-mark)))) + + + + +;; (in-theory (disable mark-1-aux-equal-is-if-dynamic-equal-static)) + +#| +(defthm struct-equiv-1-aux-implies-collect-update-static-1-aux-equal-instance + (implies (struct-equiv-1-aux (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) + ram map) + ram map 'LIST) + (equal (collect-updates-static-1-aux + (cdr typs) (cdr ptrs) n + (apply-updates (collect-updates-static-1-aux + (car typs) (car ptrs) n ram map + 'ATOM) ram map) map 'LIST) + (collect-updates-static-1-aux + (cdr typs) (cdr ptrs) n ram map 'LIST)))) +|# + +(defthm lemma-1-7-1-1 + (implies (and (not (overlap (collect-data-cells-1-aux typs ptrs n ram map 'list) + (collect-link-cells-1-aux typs ptrs n ram map + 'list))) + (not (endp typs)) + (assoc-equal (car typs) map) + (equal (collect-updates-zdynamic-1-aux (car typs) + (car ptrs) n ram map + 'ATOM) + (collect-updates-static-1-aux (car typs) + (car ptrs) n ram map + 'ATOM)) + (equal (collect-updates-zdynamic-1-aux (cdr typs) + (cdr ptrs) n + (mark-1-aux (car typs) + (car ptrs) + n + ram map + 'ATOM) + map 'LIST) + (collect-updates-static-1-aux (cdr typs) + (cdr ptrs) n + (mark-1-aux (car typs) + (car ptrs) + n + ram map + 'ATOM) + map 'LIST))) + (equal (collect-updates-zdynamic-1-aux (cdr typs) + (cdr ptrs) n + (mark-1-aux (car typs) + (car ptrs) + n + ram map + 'ATOM) + map 'LIST) + (collect-updates-static-1-aux (cdr typs) + (cdr ptrs) n + ram + map 'LIST))) + :hints (("Goal" :in-theory (disable + apply-updates-collect-dynamic-is-mark)))) + + + +;--------------- prove the two lemmas that deal with recursion +;--------------- mode = LIST. + +;--------------- mode = ATOM +#| +(skip-proofs + (defthm subsetp-collect-updates-from-single-update-collect-data-1-aux + (implies (not (overlap (collect-data-cells-1-aux typ ptr n ram map 'ATOM) + (collect-link-cells-1-aux typ ptr n ram map 'ATOM))) + (subsetp (updates-2-ws (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + (collect-data-cells-1-aux typ ptr n ram map 'ATOM))))) +|# + + +(defthm subsetp-collect-updates-from-single-update-collect-updates-static-1-aux + (implies (and (assoc-equal typ map) + (not (zp n)) + (not (zp ptr))) + (subsetp (updates-2-ws (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + (updates-2-ws (collect-updates-static-1-aux + typ ptr n ram map 'ATOM) ram map))) + :hints (("Goal" :expand (collect-updates-static-1-aux typ ptr n ram map + 'ATOM)))) + +;--------------- +#| +(defthm apply-updates-struct-equiv-1-aux-instance-2 + (implies (and (not (overlap (collect-data-cells-1-aux typ ptr n ram map 'ATOM) + (collect-link-cells-1-aux typ ptr n ram map 'ATOM))) + (assoc-equal typ map) + (not (zp ptr))) + (struct-equiv-1-aux typ ptr n + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) + ram map) + ram map 'ATOM)) + :hints (("Goal" + :cases ((consp (collect-updates-from-single-update1-static + typ ptr 0 n ram map)))) + ("Subgoal 1" + :use ((:instance subsetp-transitive + (a (updates-2-ws + (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map)) + (b (updates-2-ws + (collect-updates-static-1-aux + typ ptr n ram map 'ATOM) ram ram)) + (c (collect-data-cells-1-aux + typ ptr n ram map 'ATOM))))))) + +|# +#| +; instantiate the about again + + +(defthm apply-updates-struct-equiv-1-aux-instance-2-instance + (implies (and (not (overlap (collect-data-cells-1-aux typ ptr n ram map 'ATOM) + (collect-link-cells-1-aux typ ptr n ram map 'ATOM))) + (assoc-equal typ map) + (not (zp n)) + (not (zp ptr))) + (struct-equiv-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + ram + map 'LIST)) + :hints (("Goal" :in-theory (disable apply-updates-struct-equiv-1-aux-instance-2) + :use apply-updates-struct-equiv-1-aux-instance-2))) + +;----------------------- concrete instantiations + +(defthm struct-equiv-1-aux-implies-collect-data-equal-instance-2 + (implies (struct-equiv-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + ram + map 'LIST) + (equal (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + map 'LIST) + (collect-data-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST)))) + + +(defthm struct-equiv-1-aux-implies-collect-link-equal-instance-2 + (implies (struct-equiv-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + ram + map 'LIST) + (equal (collect-link-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + map 'LIST) + (collect-link-cells-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST)))) + + +(defthm struct-equiv-1-aux-implies-collect-update-static-equal-instance-2 + (implies (struct-equiv-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + ram + map 'LIST) + (equal (collect-updates-static-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + (apply-updates (collect-updates-from-single-update1-static + typ ptr 0 n ram map) ram map) + map 'LIST) + (collect-updates-static-1-aux + (cdr (assoc-equal typ map)) + (seq-int (g ptr ram) (len (cdr (assoc-equal typ map)))) + (- n 1) + ram map 'LIST)))) + +|# +;--------------------------------------- + + +(defthm collect-updates-zdynamic-1-aux-is-collect-updates-static-1-aux + (implies (not (overlap (collect-data-cells-1-aux typ-or-typs ptr-or-ptrs + n ram map mode) + (collect-link-cells-1-aux typ-or-typs ptr-or-ptrs + n ram map mode))) + (equal (collect-updates-zdynamic-1-aux typ-or-typs ptr-or-ptrs + n ram map mode) + (collect-updates-static-1-aux typ-or-typs ptr-or-ptrs + n ram map mode))) + :hints (("Goal" :induct (collect-updates-zdynamic-1-aux typ-or-typs + ptr-or-ptrs + n ram map mode) + :in-theory (disable + APPLY-UPDATES-COLLECT-DYNAMIC-IS-MARK) + :do-not '(generalize)))) + + + +;------------------ done at last !!! ------- +; +; we now have this result and a theorem that +; (updates-2-ws (collect-updates-static-1-aux ..) is a subset of +; (collect-static-data ..) +; + + +(defthm g-over-apply-update-lemma + (implies (not (equal addr (update-2-w update ram))) + (equal (g addr (apply-update update ram map)) + (g addr ram))) + :hints (("Goal" :in-theory (enable apply-update + update-2-w + gtyp gptr gi gn)))) + +(defthm g-over-apply-updates-lemma + (implies (not (member addr (updates-2-ws updates ram map))) + (equal (g addr (apply-updates updates ram map)) + (g addr ram)))) + + +(defthm g-over-mark-1-aux-lemma + (implies (and (not (overlap (collect-data-cells-1-aux typ-or-typs ptr-or-ptrs + n ram map mode) + (collect-link-cells-1-aux typ-or-typs ptr-or-ptrs + n ram map mode))) + (not (member addr + (updates-2-ws (collect-updates-static-1-aux + typ-or-typs ptr-or-ptrs + n ram map mode) ram map)))) + (equal (g addr (mark-1-aux typ-or-typs ptr-or-ptrs + n ram map mode)) + (g addr ram)))) + + + +(defthm g-over-mark-1-aux + (implies (and (not (overlap (collect-data-cells-1-aux typ-or-typs ptr-or-ptrs + n ram map mode) + (collect-link-cells-1-aux typ-or-typs ptr-or-ptrs + n ram map mode))) + (not (member addr + (collect-data-cells-1-aux typ-or-typs ptr-or-ptrs + n ram map mode)))) + (equal (g addr (mark-1-aux typ-or-typs ptr-or-ptrs + n ram map mode)) + (g addr ram))) + :hints (("Goal" :in-theory (disable subsetp-collect-updates-static-1-aux-data-cells) + :use subsetp-collect-updates-static-1-aux-data-cells))) + + +;------------ done! ------------- +(defun collect-updates-static-1 (typ ptr n ram map) + (collect-updates-static-1-aux typ ptr n ram map 'ATOM)) + + +(defun collect-updates-static-1-list (typs ptrs n ram map) + (collect-updates-static-1-aux typs ptrs n ram map 'LIST)) + + +(defun all-collect-updates-static-1 (typs ptrs ns ram map) + (if (endp typs) + nil + (append (collect-updates-static-1 (car typs) (car ptrs) (car ns) ram map) + (all-collect-updates-static-1 + (cdr typs) (cdr ptrs) (cdr ns) ram map)))) + + +(defun collect-updates-static (rc) + (all-collect-updates-static-1 (typ-list (ptrs rc)) + (addr-list (ptrs rc)) + (n-list (ptrs rc)) + (ram rc) + (getmap rc))) + + + + +;---------------------------------- + +; (defthm g-over-mark +; (implies (and (not (overlap (collect-data-cells rc) +; (collect-link-cells rc))) +; (not (member addr (updates-2-ws (collect-updates-static rc))))) +; (equal (g addr (mark rc)) +; (g addr (ram rc))))) + + + + + + + + + + + + + + + + + diff --git a/books/workshops/2003/hendrix/hendrix-slides.pdf.gz b/books/workshops/2003/hendrix/hendrix-slides.pdf.gz Binary files differnew file mode 100644 index 0000000..8aba330 --- /dev/null +++ b/books/workshops/2003/hendrix/hendrix-slides.pdf.gz diff --git a/books/workshops/2003/hendrix/hendrix-slides.ps.gz b/books/workshops/2003/hendrix/hendrix-slides.ps.gz Binary files differnew file mode 100644 index 0000000..ffdee59 --- /dev/null +++ b/books/workshops/2003/hendrix/hendrix-slides.ps.gz diff --git a/books/workshops/2003/hendrix/hendrix.pdf.gz b/books/workshops/2003/hendrix/hendrix.pdf.gz Binary files differnew file mode 100644 index 0000000..be4a139 --- /dev/null +++ b/books/workshops/2003/hendrix/hendrix.pdf.gz diff --git a/books/workshops/2003/hendrix/hendrix.ps.gz b/books/workshops/2003/hendrix/hendrix.ps.gz Binary files differnew file mode 100644 index 0000000..79c72e9 --- /dev/null +++ b/books/workshops/2003/hendrix/hendrix.ps.gz diff --git a/books/workshops/2003/hendrix/support/madd.lisp b/books/workshops/2003/hendrix/support/madd.lisp new file mode 100644 index 0000000..eb09c85 --- /dev/null +++ b/books/workshops/2003/hendrix/support/madd.lisp @@ -0,0 +1,156 @@ +;;;;; Matrix addition. +;;;;; Defines m+ and basic properties. This includes associativity, +;;;;; commutativity, a definition by column operations, and properties +;;;;; involving mentry and mzero. +(in-package "ACL2") + +(include-book "mdefthms") + +(defmacro m+-guard (m n) + `(and (matrixp ,m) + (matrixp ,n) + (equal (row-count ,m) (row-count ,n)) + (equal (col-count ,m) (col-count ,n)))) + +(defun m+ (m n) + (declare (xargs :guard (m+-guard m n) + :verify-guards nil)) + (if (m-emptyp m) + (m-empty) + (row-cons (v+ (row-car m) (row-car n)) + (m+ (row-cdr m) (row-cdr n))))) + +(defthm m-emptyp-m+ + (equal (m-emptyp (m+ m n)) + (m-emptyp m))) + +(defthm row-count-m+ + (equal (row-count (m+ m n)) + (row-count m))) + +(defthm col-count-m+ + (implies (matrixp m) + (equal (col-count (m+ m n)) + (col-count m))) + :hints (("Goal" :induct (m+ m n)))) + +(defthm matrixp-m+ + (implies (matrixp m) + (matrixp (m+ m n)))) + +(verify-guards m+) + + +(defthm col-count-m+ + (implies (matrixp m) + (equal (col-count (m+ m n)) + (col-count m)))) + +(defthm row-count-m+ + (equal (row-count (m+ m n)) + (row-count m))) + +(local + (defthm col-car-m+ + (implies (and (matrixp m) (matrixp n)) + (equal (col-car (m+ m n)) + (v+ (col-car m) (col-car n)))) + :hints (("Goal" :induct (m+ m n)) + ("Subgoal *1/2.2" :expand ((v+ (row-car m) (row-car n))))))) + +(defun m+-by-col-recursion (m n) + (declare (xargs :guard (m+-guard m n) + :guard-hints + (("Subgoal 2" + :cases ((m-emptyp (col-cdr m)))) + ("Subgoal 2.2'4'" + :cases ((m-emptyp (col-cdr n)))) + ("Subgoal 1" :cases ((m-emptyp (col-cdr m))))))) + (if (or (m-emptyp m) (m-emptyp n)) + nil + (m+-by-col-recursion (col-cdr m) (col-cdr n)))) + +(defthm m+-by-col-def + (implies (and (matrixp m) + (matrixp n)) + (equal (m+ m n) + (if (m-emptyp m) + (m-empty) + (col-cons (v+ (col-car m) (col-car n)) + (m+ (col-cdr m) (col-cdr n)))))) + :hints (("Goal" :in-theory (enable row-cons-def) + :induct (m+ m n))) + :rule-classes :definition) + +(defthm m+-assoc + (implies (and (m+-guard m n) + (matrixp p)) + (equal (m+ (m+ m n) p) + (m+ m (m+ n p)))) + :hints (("Goal" :induct (and (m+ m n) + (m+ n p))))) +(defthm m+-assoc2 + (implies (and (m+-guard m n) + (matrixp p)) + (equal (m+ m (m+ n p)) + (m+ n (m+ m p)))) + :hints (("Goal" :induct (and (m+ m n) + (m+ n p))))) + +(defthm m+-comm + (implies (m+-guard m n) + (equal (m+ m n) + (m+ n m))) + :hints (("Goal" :induct (m+ m n)))) + +;;;; Properties about adding zero to a matrix. +;;;; These currently use (mzero (row-count m) (col-count m)) in +;;;; their definition. This may not match as much as we would like, +;;;; so it may be smart to change this to (mzero r c) and add +;;;; appropriate conditions. +(include-book "mzero") + +(defthm m+zero + (implies (matrixp m) + (equal (m+ m (mzero (row-count m) (col-count m))) m)) + :hints (("Goal" :induct (m+ m m)) +; :With directed added 3/13/06 by Matt Kaufmann for after v2-9-4. + ("Subgoal *1/2'''" :expand ((:with mzero (mzero 1 (col-count m))))))) + +(defthm zero+m + (implies (matrixp m) + (equal (m+ (mzero (row-count m) (col-count m)) m) m)) + :hints (("Goal" :induct (m+ m m)) +; :With directed added 3/13/06 by Matt Kaufmann for after v2-9-4. + ("Subgoal *1/2'''" :expand ((:with mzero (mzero 1 (col-count m))))))) + +;;;; Properties related to mentry +(include-book "mentry") + +(defthm row-m+ + (implies (and (matrixp m) + (matrixp n)) + (equal (row i (m+ m n)) + (if (< (nfix i) (row-count m)) + (v+ (row i m) (row i n)) + nil))) + :hints (("Goal" :induct (and (and (row i m) + (m+ m n)))))) + +(defthm col-m+ + (implies (and (matrixp m) + (matrixp n)) + (equal (col i (m+ m n)) + (if (< (nfix i) (col-count m)) + (v+ (col i m) (col i n)) + nil))) + :hints (("Goal" :induct (m+ m n)))) + +(defthm entry-m+ + (implies (and (matrixp m) + (matrixp n)) + (equal (mentry r c (m+ m n)) + (if (and (< (nfix r) (row-count m)) + (< (nfix c) (col-count m))) + (+ (mentry r c m) (mentry r c n)) + nil)))) diff --git a/books/workshops/2003/hendrix/support/matrices.lisp b/books/workshops/2003/hendrix/support/matrices.lisp new file mode 100644 index 0000000..773ae24 --- /dev/null +++ b/books/workshops/2003/hendrix/support/matrices.lisp @@ -0,0 +1,15 @@ +;;;;; Top level book that includes all matrix operations. + +(in-package "ACL2") + +(include-book "vector") +(include-book "mdefuns") +(include-book "mdefthms") +(include-book "mentry") +(include-book "mzero") +(include-book "madd") +(include-book "mscal") +(include-book "msub") +(include-book "mid") +(include-book "mmult") +(include-book "mtrans") diff --git a/books/workshops/2003/hendrix/support/mdefthms.lisp b/books/workshops/2003/hendrix/support/mdefthms.lisp new file mode 100644 index 0000000..6d35a78 --- /dev/null +++ b/books/workshops/2003/hendrix/support/mdefthms.lisp @@ -0,0 +1,651 @@ +;;;;; Basic theorems for low level matrix operations. The other books are designed to +;;;;; be provable using the theorems defined here without relying on the implementation +;;;;; details. + +(in-package "ACL2") + +(include-book "mdefuns") + +;;; If the length of an variable is zero, it is an atom. +(defthm len-atom + (implies (equal (len x) 0) + (atom x)) + :rule-classes :forward-chaining) + +;;; We know that the length of a cons is at least one. +(defthm len-consp + (implies (consp l) + (< 0 (len l))) + :rule-classes :type-prescription) + +;;;; Low level theorems used in proving public theorems. +;;;; Not currently documented. +(local + (defthm mvectorp-col-car-local + (implies (and (vector-list-of-lenp m i) + (< 0 i)) + (mvectorp (col-car m))) + :rule-classes ((:rewrite :match-free :once)))) + +(local + (defthm vector-list-col-cdr + (implies (vector-list-of-lenp m (+ 1 i)) + (vector-list-of-lenp (col-cdr m) i)))) + +(local + (defthm vector-list-col-cons-nil + (implies (mvectorp l) + (vector-list-of-lenp (col-cons-impl l nil) 1)))) + +(local + (defthm vector-list-col-cons + (implies (and (vector-list-of-lenp m i) + (mvectorp l) + (equal (len l) (len m))) + (vector-list-of-lenp (col-cons-impl l m) (1+ i))))) + +(local + (defthm len-car-col-cdr + (implies (and (vector-list-of-lenp m i) + (< 0 i) + (consp m)) + (equal (len (car (col-cdr m))) + (1- i))) + :rule-classes ((:rewrite :match-free :once)))) + +(local + (defthm len-car-col-cons + (implies (consp l) + (equal (len (car (col-cons-impl l m))) + (1+ (len (car m))))))) + +(local + (defthm consp-col-car-local + (implies (and (vector-list-of-lenp m i) + (< 0 i)) + (equal (consp (col-car m)) + (consp m))) + :rule-classes ((:rewrite :match-free :once)))) + +(local + (defthm consp-col-cdr + (implies (and (vector-list-of-lenp m i) + (< 1 i) + (consp m)) + (consp (col-cdr m))) + :rule-classes ((:rewrite :match-free :once)))) + +(local + (defthm consp-col-cons-impl + (implies (consp l) + (consp (col-cons-impl l m))) + :rule-classes ((:rewrite :match-free :once)))) + +(local + (defthm col-cons-impl-atom + (implies (vector-list-of-lenp m 1) + (equal (col-cons-impl (col-car m) nil) + m)))) + +(local + (defthm col-cons-impl-elim + (implies (and (vector-list-of-lenp m i) + (< 0 i)) + (equal (col-cons-impl (col-car m) (col-cdr m)) + m)) + :rule-classes ((:rewrite :match-free :once)))) + +;;;;;Type rules + +;;;; Type rules for row car, cdr, cons + +(defthm m-empty-nil + (implies (and (m-emptyp m) + (matrixp m)) + (equal m nil)) + :rule-classes :forward-chaining) + +(defthm car-vector-type + (implies (and (mvectorp l) + (consp l)) + (acl2-numberp (car l))) + :rule-classes (:type-prescription :rewrite)) + +(defthm mvectorp-row-car + (implies (matrixp m) + (mvectorp (row-car m))) + :rule-classes (:type-prescription :rewrite)) + +(defthm consp-row-car + (implies (and (case-split (not (m-emptyp m))) + (matrixp m)) + (consp (row-car m))) + :rule-classes (:type-prescription :rewrite)) + +(defthm matrixp-row-cdr + (implies (matrixp m) + (matrixp (row-cdr m)))) + +(defthm matrixp-row-cons + (implies (and (matrixp m) + (mvectorp l) + (consp l) + (or (m-emptyp m) + (equal (col-count m) (len l)))) + (matrixp (row-cons l m)))) + +;;;; Col car, cdr, cons type rules +(defthm mvectorp-col-car + (implies (matrixp m) + (mvectorp (col-car m))) + :rule-classes (:type-prescription :rewrite)) + +(defthm consp-col-car + (implies (and (not (m-emptyp m)) + (matrixp m)) + (consp (col-car m))) + :rule-classes (:type-prescription :rewrite)) + +(defthm matrixp-col-cdr + (implies (matrixp m) + (matrixp (col-cdr m)))) + +(defthm matrixp-col-cons + (implies (col-cons-guard l m) + (matrixp (col-cons l m)))) + + +(defthm empty-row-cdr-col-cdr + (implies (matrixp m) + (equal (m-emptyp (row-cdr (col-cdr m))) + (or (m-emptyp (row-cdr m)) + (m-emptyp (col-cdr m)))))) + +(local + (defthm vector-list-1-not-consp-col-cdr + (implies (vector-list-of-lenp m 1) + (not (consp (col-cdr m)))))) + +(defthm empty-col-cdr-row-cdr + (implies (matrixp m) + (equal (m-emptyp (col-cdr (row-cdr m))) + (or (m-emptyp (col-cdr m)) + (m-emptyp (row-cdr m)))))) + +;;;; Theorems necessary to admit common recursion scheme for matrix operations. + +(defthm acl2-count-col-cdr + (implies (not (m-emptyp m)) + (< (acl2-count (col-cdr m)) + (acl2-count m)))) + +(defthm acl2-count-row-cdr + (implies (not (m-emptyp m)) + (< (acl2-count (row-cdr m)) + (acl2-count m)))) + +;;;; The row-cons or col-cons is never an m-empty +(defthm not-empty-row-cons + (not (m-emptyp (row-cons r m)))) + +(defthm not-empty-col-cons + (not (m-emptyp (col-cons c m)))) + +;;;;; Logical definitions are provided for the basic functions since they +;;;;; are disabled by this package. Row-cdr, row-cons, col-cdr, and col-cons +;;;;; are not actually enabled as they are not normally needed, however they +;;;;; can be used in special circumstances. I also added induction rules that +;;;;; can be used in induction heuristics. + +;;;; Logical definitions for row-car, row-cdr, and row-cons. + +(defun row-car-recursion (m) + (declare (xargs :guard (matrixp m))) + (if (m-emptyp m) + nil + (row-car-recursion (col-cdr m)))) + +(defthm row-car-def + (implies (matrixp m) + (equal (row-car m) + (if (m-emptyp m) + nil + (cons (car (col-car m)) (row-car (col-cdr m)))))) + :rule-classes ((:definition + :clique (col-car row-car col-cdr) + :controller-alist ((col-car t) + (row-car t) + (col-cdr t))) + (:induction :pattern (row-car m) + :scheme (row-car-recursion m)))) + +(defun row-cdr-recursion (m) + (declare (xargs :guard (matrixp m))) + (if (or (m-emptyp (row-cdr m)) + (m-emptyp (col-cdr m))) + nil + (row-cdr-recursion (col-cdr m)))) + +(defthmd row-cdr-def + (implies (matrixp m) + (equal (row-cdr m) + (if (endp (cdr (col-car m))) + nil + (col-cons (cdr (col-car m)) + (row-cdr (col-cdr m)))))) + :rule-classes ((:definition + :clique (col-car row-cdr col-cdr col-cons) + :controller-alist ((col-car t) + (row-cdr t) + (col-cdr t) + (col-cons t t))) + (:induction :pattern (row-cdr m) + :scheme (row-cdr-recursion m)))) + +(defun row-cons-recursion (l m) + (declare (xargs :guard (row-cons-guard l m))) + (cond ((endp (cdr l)) nil) + ((m-emptyp m) (row-cons-recursion (cdr l) m)) + (t (row-cons-recursion (cdr l) (col-cdr m))))) + +(defthmd row-cons-def + (implies (row-cons-guard l m) + (equal (row-cons l m) + (col-cons (cons (car l) (col-car m)) + (if (endp (cdr l)) + nil + (row-cons (cdr l) (col-cdr m)))))) + :rule-classes ((:definition + :clique (col-car col-cdr row-cons col-cons) + :controller-alist ((col-car t) + (col-cdr t) + (row-cons t t) + (col-cons t t))) + (:induction :pattern (row-cons l m) + :scheme (row-cons-recursion l m)))) + +;;;; Logical definitions for col-car, col-cdr, col-cons + +(defun col-car-recursion (m) + (declare (xargs :guard (matrixp m))) + (if (m-emptyp m) + nil + (col-car-recursion (row-cdr m)))) + +(defthm col-car-def + (implies (matrixp m) + (equal (col-car m) + (if (m-emptyp m) + nil + (cons (car (row-car m)) (col-car (row-cdr m)))))) + :rule-classes ((:definition + :clique (col-car row-car row-cdr) + :controller-alist ((col-car t) + (row-car t) + (row-cdr t))) + (:induction :pattern (col-car m) + :scheme (col-car-recursion m)))) + +(defun col-cdr-recursion (m) + (declare (xargs :guard (matrixp m))) + (if (or (m-emptyp (col-cdr m)) + (m-emptyp (row-cdr m))) + nil + (col-cdr-recursion (row-cdr m)))) + +(defthmd col-cdr-def + (implies (matrixp m) + (equal (col-cdr m) + (if (endp (cdr (row-car m))) + nil + (row-cons (cdr (row-car m)) + (col-cdr (row-cdr m)))))) + :rule-classes ((:definition + :clique (row-car row-cdr col-cdr row-cons) + :controller-alist ((row-car t) + (row-cdr t) + (col-cdr t) + (row-cons t t))) + (:induction :pattern (col-cdr m) + :scheme (col-cdr-recursion m)))) + +(defun col-cons-recursion (l m) + (declare (xargs :guard (col-cons-guard l m))) + (cond ((endp (cdr l)) nil) + ((m-emptyp m) (col-cons (cdr l) m)) + (t (col-cons-recursion (cdr l) (row-cdr m))))) + +(defthmd col-cons-def + (implies (col-cons-guard l m) + (equal (col-cons l m) + (row-cons (cons (car l) (row-car m)) + (if (endp (cdr l)) + nil + (col-cons (cdr l) (row-cdr m)))))) + :rule-classes ((:definition + :clique (row-car row-cdr row-cons col-cons) + :controller-alist ((row-car t) + (row-cdr t) + (row-cons t t) + (col-cons t t))) + (:induction :pattern (col-cons l m) + :scheme (col-cons-recursion l m)))) + + +;;;;; Row and column simplification rules + +;;;; Simple row operation reductions + +(defthm row-car-row-cons + (equal (row-car (row-cons l m)) l)) + +(defthm row-cdr-empty + (implies (and (equal (row-count m) 1) + (matrixp m)) + (equal (row-cdr m) nil))) + +(defthm row-cdr-row-cons + (equal (row-cdr (row-cons l m)) m)) + +(defthm row-cons-elim-nil + (implies (and (m-emptyp (row-cdr m)) + (matrixp m) + (not (m-emptyp m))) + (equal (row-cons (row-car m) nil) + m))) + +(defthm row-cons-elim + (implies (not (m-emptyp m)) + (equal (row-cons (row-car m) (row-cdr m)) + m)) + :rule-classes :rewrite) + +;;;; Simple column operation reductions + +(local + (defthm col-car-col-cons-impl + (implies (mvectorp l) + (equal (col-car (col-cons-impl l m)) + l)))) + +(defthm col-car-col-cons + (implies (col-cons-guard l m) + (equal (col-car (col-cons l m)) l))) + +(local + (defthm col-cdr-col-cons-impl-nil + (equal (col-cdr (col-cons-impl l nil)) nil))) + +(local + (defthm col-cdr-col-cons-impl + (implies (and (mvectorp l) + (>= (len l) (len m)) + (and (vector-list-of-lenp m i) + (< 0 i))) + (equal (col-cdr (col-cons-impl l m)) m)) + :rule-classes ((:rewrite :match-free :once)))) + +(defthm col-cdr-empty + (implies (equal (col-count m) 1) + (equal (col-cdr m) nil))) + +(defthm col-cdr-col-cons + (implies (col-cons-guard l m) + (equal (col-cdr (col-cons l m)) m))) + +(defthm col-cons-elim-nil + (implies (and (m-emptyp (col-cdr m)) + (matrixp m) + (not (m-emptyp m))) + (equal (col-cons (col-car m) nil) + m))) + +(defthm col-cons-elim + (implies (and (matrixp m) + (not (m-emptyp m))) + (equal (col-cons (col-car m) (col-cdr m)) + m))) + +;;;; Joint row col reductions. + +;;;; The first four are not enabled, because they should be handled +;;;; by the logical definitions of row-car and col-car. +(defthmd row-car-col-cdr + (implies (matrixp m) + (equal (row-car (col-cdr m)) + (cdr (row-car m))))) + +(defthmd col-car-row-cdr + (implies (matrixp m) + (equal (col-car (row-cdr m)) + (cdr (col-car m))))) + +(defthmd row-car-col-cons + (implies (consp l) + (equal (row-car (col-cons l m)) + (cons (car l) (row-car m))))) + +(defthmd col-car-row-cons + (implies (consp l) + (equal (col-car (row-cons l m)) + (cons (car l) (col-car m))))) + +;;;; The car of row-car equals the car of col-car. It may be a good +;;;; idea to convert this to a single term, but for now a forward-chaining +;;;; rule is used. +(defthm car-row-car-car-col-car + (equal (car (row-car m)) + (car (col-car m))) + :rule-classes ((:forward-chaining + :trigger-terms ((car (row-car m)) (car (col-car m)))))) + +(local + (defthm not-col-cdr-local + (implies (vector-list-of-lenp m 1) + (not (col-cdr m))))) + +;;;; col-cdr row-cdr can be rotated, but it is not clear when this is +;;;; a good idea, so forward-chaining is used in lieu of rewriting. +(defthm col-cdr-row-cdr + (implies (matrixp m) + (equal (col-cdr (row-cdr m)) + (row-cdr (col-cdr m)))) + :rule-classes ((:forward-chaining + :trigger-terms ((col-cdr (row-cdr m)) + (row-cdr (col-cdr m)))))) + +(defthm col-cdr-row-cons + (implies (row-cons-guard l m) + (equal (col-cdr (row-cons l m)) + (if (equal (len l) 1) + nil + (row-cons (cdr l) (col-cdr m)))))) + +;;;; As a general rule, row operations are kept on the outside, so this is +;;;; not normally enabled. +(defthmd row-cdr-col-cons + (implies (col-cons-guard l m) + (equal (row-cdr (col-cons l m)) + (if (equal (len l) 1) + nil + (col-cons (cdr l) (row-cdr m)))))) + +;;;; Theorems relating row-cons and col-cons together. + +(defthm col-cons-row-cons-unit + (implies (and (equal (len l) 1) + (mvectorp l)) + (equal (col-cons l nil) + (row-cons l nil)))) + +(defthm col-cons-row-cons + (implies (and (matrixp m) + (consp k) + (or (case-split (m-emptyp m)) + (equal (col-count m) (len k))) + (equal (1+ (row-count m)) (len l))) + (equal (col-cons l (row-cons k m)) + (if (m-emptyp m) + (row-cons (cons (car l) k) nil) + (row-cons (cons (car l) k) (col-cons (cdr l) m)))))) + +(defthm row-cons-col-cons-empty + (implies (and (mvectorp k) + (consp k) + (mvectorp l) + (equal (len l) 1)) + (equal (row-cons l (col-cons k nil)) + (col-cons (cons (car l) k) nil)))) + +;;;; Row ops are kept on outside, so not normally enabled +(defthmd row-cons-col-cons + (implies (and (matrixp m) + (not (m-emptyp m)) + (mvectorp k) + (equal (len k) (row-count m)) + (mvectorp l) + (equal (len l) (1+ (col-count m)))) + (equal (row-cons l (col-cons k m)) + (col-cons (cons (car l) k) (row-cons (cdr l) m))))) + +;;;; Theorems for row-count + +(defthm row-count-type + (and (integerp (row-count m)) + (<= 0 (row-count m))) + :rule-classes :type-prescription) + +(defthm row-count-type-not-empty + (implies (not (m-emptyp m)) + (< 0 (row-count m))) + :rule-classes :type-prescription) + +(defun row-count-recursion (m) + (declare (xargs :guard (matrixp m))) + (if (m-emptyp m) + 0 + (row-count-recursion (row-cdr m)))) + +;;; Row count's logical definition +(defthm row-count-def + (equal (row-count m) + (if (m-emptyp m) + 0 + (1+ (row-count (row-cdr m))))) + :rule-classes :definition) + +(defthm row-count-implies-empty + (equal (equal (row-count m) 0) + (m-emptyp m))) + +(defthm row-count-implies-not-empty + (equal (< 0 (row-count m)) + (not (m-emptyp m)))) + +(local + (defthm len-col-cdr + (implies (and (vector-list-of-lenp m i) + (< 1 i)) + (equal (len (col-cdr m)) + (len m))) + :rule-classes ((:rewrite :match-free :once)))) + +(defthm row-count-col-cdr + (implies (and (case-split (not (m-emptyp (col-cdr m)))) + (matrixp m)) + (equal (row-count (col-cdr m)) + (row-count m)))) + +(local + (defthm len-col-cons + (equal (len (col-cons-impl l m)) + (len l)))) + +(defthm row-count-col-cons + (implies (consp l) + (equal (row-count (col-cons l m)) + (len l)))) + +(defthm row-count-row-cdr-col-cdr + (implies (and (matrixp m) + (not (m-emptyp (col-cdr m)))) + (equal (row-count (row-cdr (col-cdr m))) + (row-count (row-cdr m))))) + +(defthm len-col-car + (implies (matrixp m) + (equal (len (col-car m)) + (row-count m)))) + +(defthmd <=-len-col-car + (<= (len (col-car m)) + (row-count m))) + +(defthmd <=-row-count-col-cdr + (<= (row-count (col-cdr m)) + (row-count m))) + +;;;; Theorems for column count. + +(defthm col-count-type + (and (integerp (col-count m)) + (<= 0 (col-count m))) + :rule-classes :type-prescription) + +(defthm col-count-type-not-empty + (implies (and (not (m-emptyp m)) + (matrixp m)) + (< 0 (col-count m))) + :rule-classes :type-prescription) + +(defun col-count-recursion (m) + (declare (xargs :guard (matrixp m))) + (if (m-emptyp m) + 0 + (col-count-recursion (col-cdr m)))) + +;;; Column count's logical definition. +(defthm col-count-def + (implies (matrixp m) + (equal (col-count m) + (if (m-emptyp m) + 0 + (1+ (col-count (col-cdr m)))))) + :rule-classes :definition) + +(defthm col-count-implies-empty + (implies (matrixp m) + (equal (equal (col-count m) 0) + (m-emptyp m)))) + +(defthm col-count-implies-not-empty + (implies (matrixp m) + (equal (< 0 (col-count m)) + (not (m-emptyp m))))) + +(defthm col-count-row-cdr + (implies (and (case-split (not (m-emptyp (row-cdr m)))) + (matrixp m)) + (equal (col-count (row-cdr m)) + (col-count m)))) + +(defthm col-count-row-cons + (equal (col-count (row-cons l m)) + (len l))) + +(defthm col-count-col-cdr-row-cdr + (implies (and (matrixp m) + (not (m-emptyp (row-cdr m)))) + (equal (col-count (col-cdr (row-cdr m))) + (col-count (col-cdr m))))) + +(defthm len-row-car + (equal (len (row-car m)) + (col-count m))) + +;;; Disable low level functions. +(in-theory (disable matrixp m-emptyp + vector-list-of-lenp + row-car row-cdr row-cons + col-car col-cdr col-cons + row-count col-count)) diff --git a/books/workshops/2003/hendrix/support/mdefuns.lisp b/books/workshops/2003/hendrix/support/mdefuns.lisp new file mode 100644 index 0000000..2c77947 --- /dev/null +++ b/books/workshops/2003/hendrix/support/mdefuns.lisp @@ -0,0 +1,127 @@ +;;;;; Implement low level operations for matrices. No theorems other than those +;;;;; necessary for guard verification are proven. See mdefthms.lisp for theorems. +(in-package "ACL2") + +(include-book "vector") + +;;; Returns true if l is a true-list where each element is a vector +;;; of length n. +(defun vector-list-of-lenp (l n) + (declare (xargs :verify-guards t)) + (if (consp l) + (and (mvectorp (car l)) + (equal (len (car l)) n) + (vector-list-of-lenp (cdr l) n)) + (eq l nil))) + +;;;; A Matrix is represented as a true-list of true-lists of numbers +;;;; where each list has the same length. In contrast to traditional +;;;; mathematics, it is possible for a list to contain 0 rows and +;;;; columns in which case it is the empty matrix. The empty matrix +;;;; is the only matrix with zero rows or columns, all other matrices +;;;; must contain at least one row and column. + +;;; Returns true if m is a matrix. +(defun matrixp (m) + (declare (xargs :verify-guards t)) + (or (eq m nil) + (and (consp m) + (consp (car m)) + (vector-list-of-lenp m (len (car m)))))) + +;;; Returns the m-empty. +(defun m-empty () + (declare (xargs :verify-guards t)) + nil) + +;;; Returns true if m is an atom (this more general definition of +;;; an empty matrix is needed so that termination checking is +;;; easier). +(defun m-emptyp (m) + (declare (xargs :guard (matrixp m))) + (endp m)) + +;;; Return the number of rows in the matrix m. +(defun row-count (m) + (declare (xargs :guard (matrixp m))) + (len m)) + +;;; Return the number of columns in the matrix m. +(defun col-count (m) + (declare (xargs :guard (matrixp m))) + (len (car m))) + +;;; Returns the top row of the matrix. +(defun row-car (m) + (declare (xargs :guard (matrixp m))) + (car m)) + +;;; Returns a matrix with the top row removed. +(defun row-cdr (m) + (declare (xargs :guard (matrixp m))) + (cdr m)) + +;;; Guard for "consing" a row (vector) to a matrix. +(defmacro row-cons-guard (l m) + `(and (matrixp ,m) + (mvectorp ,l) + (consp ,l) + (or (m-emptyp ,m) + (equal (col-count ,m) (len ,l))))) + +;;; Adds a new row r to the matrix m. The existing rows are moved down +;;; one row. If m is the m-empty, then r is expected to be of +;;; length greater than zero. Otherwise, r is expected to be the same +;;; length as the number of columns in the matrix. +(defun row-cons (r m) + (declare (xargs :guard (row-cons-guard r m))) + (cons r m)) + +;;; Returns the leftmost column of the matrix. +(defun col-car (m) + (declare (xargs :guard (matrixp m))) + (if (or (endp m) (endp (car m))) + nil + (cons (caar m) (col-car (cdr m))))) + +;;; Returns a matrix with the leftmost column removed. +(defun col-cdr (m) + (declare (xargs :guard (matrixp m))) + (if (or (endp m) (endp (cdar m))) + nil + (cons (cdar m) (col-cdr (cdr m))))) + +;;; Implementation function for col-cons (below). +(defun col-cons-impl (l m) + (declare (xargs :guard (and (true-listp l) + (true-listp m)))) + (if (consp l) + (cons (cons (car l) (car m)) (col-cons-impl (cdr l) (cdr m))) + nil)) + +(defmacro col-cons-guard (l m) + `(and (matrixp ,m) + (mvectorp ,l) + (consp ,l) + (or (m-emptyp ,m) + (equal (row-count ,m) (len ,l))))) + +(local + (defthm vector-list-is-true-list + (implies (vector-list-of-lenp m i) + (true-listp m)) + :rule-classes :forward-chaining)) + +;;; Adds a new column c to the matrix m. The existing rows are moved +;;; down one row. If m is the m-empty, then c is expected to be of +;;; length greater than zero. Otherwise, c is expected to be the same +;;; length as the number of rows in the matrix. + +;;; The implementation using col-cons-impl so that it is guaranteed to +;;; always return something considered not to be the empty matrix even +;;; if the guards are violated. +(defun col-cons (l m) + (declare (xargs :guard (col-cons-guard l m))) + (if (consp l) + (col-cons-impl l m) + (cons nil nil))) diff --git a/books/workshops/2003/hendrix/support/mentry.lisp b/books/workshops/2003/hendrix/support/mentry.lisp new file mode 100644 index 0000000..4f4729e --- /dev/null +++ b/books/workshops/2003/hendrix/support/mentry.lisp @@ -0,0 +1,118 @@ +;;;;; Provides indexed access to rows, columns and entries in a matrix. +(in-package "ACL2") + +;;; If (nfix i) is greater then the length of a list, then the nth equals nil. +(defthm nth-over + (implies (<= (len l) (nfix i)) + (equal (nth i l) nil))) + +(include-book "mdefthms") + +(defmacro row-guard (i m) + `(and (matrixp ,m) + (integerp ,i) + (<= 0 ,i) + (< ,i (row-count ,m)))) + +;;; Returns row at index i in matrix m. +(defun row (i m) + (declare (xargs :guard (row-guard i m))) + (cond ((m-emptyp m) nil) + ((zp i) (row-car m)) + (t (row (1- i) (row-cdr m))))) + +;;; Provide an alterate definition of row that uses col-cdr instead of row-cdr. +(defthm row-by-col-def + (implies (matrixp m) + (equal (row i m) + (if (or (m-emptyp m) + (>= (nfix i) (row-count m))) + nil + (cons (nth i (col-car m)) + (row i (col-cdr m)))))) + :hints (("Goal" :induct (row i m))) + :rule-classes :definition) + +(defthm mvectorp-row + (implies (matrixp m) + (mvectorp (row i m))) + :rule-classes (:rewrite :type-prescription)) + +(defthm len-row + (implies (matrixp m) + (equal (len (row i m)) + (if (< (nfix i) (row-count m)) + (col-count m) + 0))) + :hints (("Goal" :induct (row i m)))) + +(defthm consp-row + (implies (matrixp m) + (equal (consp (row i m)) + (< (nfix i) (row-count m)))) + :hints (("Subgoal *1/6" + :cases ((< (1- i) (row-count (row-cdr m))))))) + +(defmacro col-guard (i m) + `(and (matrixp ,m) + (integerp ,i) + (<= 0 ,i) + (< ,i (col-count ,m)))) + +(defun col (i m) + (declare (xargs :guard (col-guard i m))) + (cond ((m-emptyp m) nil) + ((zp i) (col-car m)) + (t (col (1- i) (col-cdr m))))) + +(defthm col-by-row-def + (implies (matrixp m) + (equal (col i m) + (if (or (m-emptyp m) + (>= (nfix i) (col-count m))) + nil + (cons (nth i (row-car m)) + (col i (row-cdr m)))))) + :hints (("Goal" :induct (col i m))) + :rule-classes :definition) + +(defthm mvectorp-col + (implies (matrixp m) + (mvectorp (col i m))) + :rule-classes (:rewrite :type-prescription)) + +(defthm len-col + (implies (matrixp m) + (equal (len (col i m)) + (if (< (nfix i) (col-count m)) + (row-count m) + 0)))) + +(defthm consp-col + (implies (matrixp m) + (equal (consp (col i m)) + (< (nfix i) (col-count m)))) + :hints (("Subgoal *1/6" + :cases ((< (1- i) (col-count (col-cdr m))))))) + +(defmacro mentry-guard (r c m) + `(and (matrixp ,m) + (integerp ,r) + (<= 0 ,r) + (< ,r (row-count ,m)) + (integerp ,c) + (<= 0 ,c) + (< ,c (col-count ,m)))) + +;;; Return the entry at the specified row and column +(defun mentry (r c m) + (declare (xargs :guard (mentry-guard r c m))) + (nth c (row r m))) + +;;; Provide an alterate equivalent definition of mentry. +(defthmd mentry-by-col + (implies (matrixp m) + (equal (mentry r c m) + (nth r (col c m)))) + :rule-classes :definition) + diff --git a/books/workshops/2003/hendrix/support/mid.lisp b/books/workshops/2003/hendrix/support/mid.lisp new file mode 100644 index 0000000..2fe7c26 --- /dev/null +++ b/books/workshops/2003/hendrix/support/mid.lisp @@ -0,0 +1,53 @@ +;;;;; Identity matrix +;;;;; TODO: Tie this into mentry operations. +(in-package "ACL2") + +(include-book "mdefthms") + +(defmacro mid-guard (n) + `(and (integerp ,n) + (<= 0 ,n))) + +(defun mid (n) + (declare (xargs :guard (mid-guard n) + :verify-guards nil)) + (cond ((zp n) nil) + ((zp (1- n)) '((1))) + (t (let ((zero-row (vzero (1- n)))) + (row-cons (cons 1 zero-row) + (col-cons zero-row + (mid (1- n)))))))) + +(local + (defthm id-bootstrap + (and (matrixp (mid n)) + (equal (row-count (mid n)) + (nfix n)) + (equal (col-count (mid n)) + (nfix n))))) + +(defthm matrix-id + (matrixp (mid n))) + +(defthm m-empty-id + (equal (m-emptyp (mid n)) + (zp n))) + +(defthm row-count-id + (equal (row-count (mid n)) + (nfix n))) + +(defthm col-count-id + (equal (col-count (mid n)) + (nfix n))) + +(verify-guards mid) + +(defthm id-by-col-def + (equal (mid n) + (cond ((zp n) nil) + ((zp (1- n)) (col-cons '(1) nil)) + (t (col-cons (cons 1 (vzero (1- n))) + (row-cons (vzero (1- n)) + (mid (1- n))))))) + :rule-classes :definition) diff --git a/books/workshops/2003/hendrix/support/mmult.lisp b/books/workshops/2003/hendrix/support/mmult.lisp new file mode 100644 index 0000000..f13c875 --- /dev/null +++ b/books/workshops/2003/hendrix/support/mmult.lisp @@ -0,0 +1,446 @@ +;;;;; Matrix multiplication and vector matrix multiplication. +;;;;; This includes col* (normally called multiplication of a matrix +;;;;; by a vector in math), row* (multiplication of a vector by each row +;;;;; in a matrix), and and matrix multiplication. +;;;;; Basic properties are proven as well as relations to the mzero, madd, +;;;;; mid, and mentry books. This includes the group properties. + +(in-package "ACL2") + +(include-book "mdefthms") + +;;;; Definition of col* and basic properties +(defmacro col*-guard (r m) + `(and (matrixp ,m) + (mvectorp ,r) + (or (m-emptyp ,m) + (equal (len ,r) (row-count ,m))))) + +;;; Returns list containing dot product of each column in m and r. +(defun col* (r m) + (declare (xargs :guard (col*-guard r m))) + (if (m-emptyp m) + nil + (cons (dot* r (col-car m)) + (col* r (col-cdr m))))) + +(defthm mvectorp-col* + (mvectorp (col* r m)) + :rule-classes (:rewrite :type-prescription)) + +(defthm consp-col* + (implies (not (m-emptyp m)) + (consp (col* r m))) + :rule-classes :type-prescription) + +(defthm len-col* + (implies (matrixp m) + (equal (len (col* r m)) + (col-count m)))) + +(defthm col*-by-row-def + (implies (matrixp m) + (equal (col* l m) + (if (m-emptyp m) + nil + (v+ (sv* (car l) (row-car m)) + (col* (cdr l) (row-cdr m)))))) + :hints (("Goal" :induct (col* l m))) + :rule-classes :definition) + +;;;; Definition of row* and basic properties + +(defmacro row*-guard (c m) + `(and (matrixp ,m) + (mvectorp ,c) + (or (m-emptyp ,m) + (equal (len ,c) (col-count ,m))))) + +;;; Returns list containing dot product of each row in m and c. +(defun row* (c m) + (declare (xargs :guard (row*-guard c m))) + (if (m-emptyp m) + nil + (cons (dot* c (row-car m)) + (row* c (row-cdr m))))) + +(defthm mvectorp-row* + (mvectorp (row* c m)) + :rule-classes (:rewrite :type-prescription)) + +(defthm consp-row* + (implies (not (m-emptyp m)) + (consp (row* c m))) + :rule-classes :type-prescription) + +(defthm len-row* + (implies (matrixp m) + (equal (len (row* c m)) + (row-count m)))) + +(defthm row*-by-col-def + (implies (matrixp m) + (equal (row* l m) + (if (m-emptyp m) + nil + (v+ (sv* (car l) (col-car m)) + (row* (cdr l) (col-cdr m)))))) + :hints (("Goal" :induct (row* l m))) + :rule-classes :definition) + +;;; The dot product of col* and row* are related. +(defthm dot*-col* + (implies (and (matrixp m) + (or (m-emptyp m) + (and (equal (len k) (col-count m)) + (equal (len l) (row-count m))))) + (equal (dot* k (col* l m)) + (dot* l (row* k m)))) + :hints (("Goal" :induct (row-cons k m) + +; Added by Matt Kaufmann, 2/25/06, to accommodate fix for runic designators +; to match their spec, where disabling the name of a defthm disables all rules +; generated for that defthm (in this case, row-cons-def). + + :in-theory (enable (:induction row-cons-def)))) + :rule-classes ((:forward-chaining + :trigger-terms ((dot* k (col* l m)) + (dot* l (row* k m)))))) + +;;;; Definition of m* and basic properties +(defmacro m*-guard (m n) + `(and (matrixp ,m) + (matrixp ,n) + (equal (col-count ,m) (row-count ,n)))) + +(defun m* (m n) + (declare (xargs :guard (m*-guard m n) + :verify-guards nil)) + (if (or (m-emptyp m) (m-emptyp n)) + (m-empty) + (row-cons (col* (row-car m) n) + (if (m-emptyp (row-cdr m)) + (m-empty) + (m* (row-cdr m) n))))) + +(local + (defthm m*-bootstrap + (implies (and (matrixp m) + (matrixp n)) + (and (matrixp (m* m n)) + (equal (col-count (m* m n)) + (if (m-emptyp m) 0 (col-count n))))) + :hints (("Goal" :induct (m* m n))))) + +(verify-guards m*) + +(defthm matrixp-m* + (implies (and (matrixp m) + (matrixp n)) + (matrixp (m* m n)))) + +(defthm col-count-m* + (implies (and (matrixp m) + (matrixp n)) + (equal (col-count (m* m n)) + (if (m-emptyp m) + 0 + (col-count n))))) + +(defthm row-count-m* + (equal (row-count (m* m n)) + (if (m-emptyp n) 0 (row-count m)))) + +(defthm m-empty-m* + (equal (m-emptyp (m* m n)) + (or (m-emptyp m) + (m-emptyp n)))) + +(defthm m*-by-col-def + (implies (and (matrixp m) + (matrixp n) + (or (m-emptyp m) + (m-emptyp n) + (equal (col-count m) (row-count n)))) + (equal (m* m n) + (if (or (m-emptyp m) (m-emptyp n)) + (m-empty) + (col-cons (row* (col-car n) m) + (m* m (col-cdr n)))))) + :hints (("Goal" :induct (m* m n))) + :rule-classes :definition) + +(defthm col*-m* + (implies (and (matrixp m) + (matrixp n) + (equal (len l) (row-count m)) + (equal (col-count m) (row-count n))) + (equal (col* l (m* m n)) + (col* (col* l m) n))) + :hints (("Goal" :induct (col* l n)) + ("Subgoal *1/2" + :cases ((m-emptyp m))) + ("Subgoal *1/2.2" + :use (:instance dot*-col* (k (col-car n)))))) + +(defthm row*-m* + (implies (and (matrixp m) + (matrixp n) + (mvectorp l) + (equal (len l) (col-count n)) + (equal (col-count m) (row-count n))) + (equal (row* l (m* m n)) + (row* (row* l n) m))) + :hints (("Goal" :induct (row* l m)) + ("Subgoal *1/2" + :use (:instance dot*-col* + (k l) + (l (row-car m)) + (m n))))) + +(defthm m*-assoc + (implies (and (matrixp m) + (matrixp n) + (matrixp p) + (equal (col-count m) (row-count n)) + (equal (col-count n) (row-count p))) + (equal (m* (m* m n) p) + (m* m (m* n p)))) + :hints (("Goal" :induct (m* m n)))) + +(include-book "mzero") + +(defthm col*-zero-left + (implies (matrixp m) + (equal (col* (vzero r) m) + (vzero (col-count m))))) + +(defthm col*-zero-right + (equal (col* l (mzero r c)) + (if (zp r) nil (vzero c))) + :hints (("Goal" :induct (vzero c)))) + +(defthm row*-zero-left + (implies (matrixp m) + (equal (row* (vzero c) m) + (vzero (row-count m)))) + :hints (("Goal" :induct (row* l m)))) + +(defthm row*-zero-right + (equal (row* l (mzero r c)) + (if (zp c) nil (vzero r))) + :hints (("Goal" :induct (vzero r)))) + +(defthm m*-zero-left + (implies (and (matrixp m) + (equal (row-count m) c)) + (equal (m* (mzero r c) m) + (mzero r (col-count m))))) + +(defthm m*-zero-right + (implies (and (matrixp m) + (if (zp c) + (m-emptyp m) + (equal (col-count m) r))) + (equal (m* m (mzero r c)) + (mzero (row-count m) c)))) + +(include-book "madd") + +(defthm dist-col*-v+ + (implies (and (matrixp m) + (or (m-emptyp m) + (equal (len j) (row-count m)))) + (equal (col* (v+ j k) m) + (v+ (col* j m) (col* k m))))) + +(defthm dist-col*-m+ + (implies (and (matrixp m) + (matrixp n) + (equal (row-count m) (row-count n)) + (equal (col-count m) (col-count n)) + (or (m-emptyp m) + (equal (len l) (row-count m)))) + (equal (col* l (m+ m n)) + (v+ (col* l m) (col* l n)))) + :hints (("Goal" :induct (m+-by-col-recursion m n)))) + +(defthm dist-row*-v+ + (implies (and (matrixp m) + (or (m-emptyp m) + (equal (len j) (col-count m)))) + (equal (row* (v+ j k) m) + (v+ (row* j m) (row* k m)))) + :hints (("Goal" :induct (row* k m)))) + +(defthm dist-row*-m+ + (implies (and (matrixp m) + (matrixp n) + (equal (row-count m) (row-count n)) + (equal (col-count m) (col-count n)) + (or (m-emptyp m) + (equal (len l) (col-count m)))) + (equal (row* l (m+ m n)) + (v+ (row* l m) (row* l n)))) + :hints (("Goal" :induct (m+ m n)))) + +(defthm dist-m*+ + (implies (and (matrixp m) + (matrixp n) + (matrixp p) + (equal (col-count m) (row-count n)) + (equal (row-count n) (row-count p)) + (equal (col-count n) (col-count p))) + (equal (m* m (m+ n p)) + (m+ (m* m n) (m* m p)))) + :hints (("Goal" :induct (m* m n)))) + +(defthm dist-m+* + (implies (and (matrixp m) + (matrixp n) + (matrixp p) + (equal (row-count m) (row-count n)) + (equal (col-count m) (col-count n)) + (equal (col-count n) (row-count p))) + (equal (m* (m+ m n) p) + (m+ (m* m p) (m* n p)))) + :hints (("Goal" :induct (m+ m n)))) + +(include-book "mscal") +(defthm dist-col*-sv* + (implies (and (matrixp m) + (or (m-emptyp m) + (equal (len l) (row-count m)))) + (equal (col* (sv* a l) m) + (sv* a (col* l m))))) + +(defthm dist-col*-sm* + (implies (and (matrixp m) + (or (m-emptyp m) + (equal (len l) (row-count m)))) + (equal (col* l (sm* a m)) + (sv* a (col* l m)))) + :hints (("Subgoal *1/3.2" + :use (:instance sm*-by-col-def (s a))))) + +(defthm dist-row*-sv* + (implies (and (matrixp m) + (or (m-emptyp m) + (equal (len l) (col-count m)))) + (equal (row* (sv* a l) m) + (sv* a (row* l m)))) + :hints (("Goal" :induct (row* l m)))) + +(defthm dist-row*-sm* + (implies (and (matrixp m) + (or (m-emptyp m) + (equal (len l) (col-count m)))) + (equal (row* l (sm* a m)) + (sv* a (row* l m)))) + :hints (("Goal" :induct (row* l m)))) + +(defthm dist-m*-sm*-left + (implies (and (matrixp m) + (matrixp n) + (equal (col-count m) (row-count n))) + (equal (m* (sm* a m) n) + (sm* a (m* m n)))) + :hints (("Goal" :induct (m* m n)))) + +(defthm dist-m*-sm*-right + (implies (and (matrixp m) + (matrixp n) + (equal (col-count m) (row-count n))) + (equal (m* m (sm* a n)) + (sm* a (m* m n)))) + :hints (("Goal" :induct (m* m n)))) + +(include-book "mid") + +(defthm col*-1-left + (implies (matrixp m) + (equal (col* (cons 1 (vzero r)) m) + (row-car m))) + :hints (("Goal" :induct (row-car m)) + ("Subgoal *1/2.5.2" :expand ((dot* (col-car m) (cons 1 (vzero r))))))) + +(defthm col*-id + (implies (and (mvectorp l) + (equal (len l) n)) + (equal (col* l (mid n)) l))) + +(defthm row*-1-left + (implies (matrixp m) + (equal (row* (cons 1 (vzero c)) m) + (col-car m))) + :hints (("Goal" :induct (col-car m)))) + +(defthm row*-id + (implies (and (mvectorp l) + (equal (len l) n)) + (equal (row* l (mid n)) l))) + +(defthm m*-id-left + (implies (and (matrixp m) + (equal (row-count m) n)) + (equal (m* (mid n) m) m)) + :hints (("Goal" :induct (col* l m)))) + +(defthm m*-id-right + (implies (and (matrixp m) + (equal (col-count m) n)) + (equal (m* m (mid n)) m)) + :hints (("Goal" :induct (row* l m)))) + +(include-book "mentry") + +(defthm nth-col* + (implies (matrixp m) + (equal (nth i (col* v m)) + (if (< (nfix i) (col-count m)) + (dot* v (col (nfix i) m)) + nil))) + :hints (("Goal" :induct (col i m)) +; :With directive added 3/14/06 by Matt Kaufmann for after v2-9-4. + ("Subgoal *1/2'''" :expand (:with col* (col* v m))))) + +(defthm col-m* + (implies (and (matrixp m) + (matrixp n)) + (equal (col i (m* m n)) + (if (< (nfix i) (col-count n)) + (row* (col i n) m) + nil))) + :hints (("Goal" :induct (m* m n)) +; :With directive added 3/14/06 by Matt Kaufmann for after v2-9-4. + ("Subgoal *1/2" :expand (:with col* (col* (row-car m) n))))) + +(defthm nth-row* + (implies (matrixp m) + (equal (nth i (row* v m)) + (if (< (nfix i) (row-count m)) + (dot* v (row i m)) + nil))) + :hints (("Goal" :induct (row i m)) +; :With directive added 3/14/06 by Matt Kaufmann for after v2-9-4. + ("Subgoal *1/2" :expand (:with row* (row* v m))))) + +(defthm row-m* + (implies (and (matrixp m) + (matrixp n)) + (equal (row i (m* m n)) + (if (< (nfix i) (row-count m)) + (col* (row i m) n) + nil))) + :hints (("Goal" :induct (row i m)) +; :With directive added 3/14/06 by Matt Kaufmann for after v2-9-4. + ("Subgoal *1/2.1'" :expand (:with m* (m* m n))))) + +(defthm entry-m* + (implies (and (matrixp m) + (matrixp n)) + (equal (mentry r c (m* m n)) + (if (and (< (nfix r) (row-count m)) + (< (nfix c) (col-count n))) + (dot* (row r m) (col c n)) + nil)))) diff --git a/books/workshops/2003/hendrix/support/mscal.lisp b/books/workshops/2003/hendrix/support/mscal.lisp new file mode 100644 index 0000000..7242631 --- /dev/null +++ b/books/workshops/2003/hendrix/support/mscal.lisp @@ -0,0 +1,139 @@ +;;;;; Matrix multiplication by a scalar. +;;;;; This includes basic properties, collecting multiple multiplications, +;;;;; and relations to mzero, madd, and mentry book contents. +(in-package "ACL2") + +(include-book "mdefthms") + +(defun sm* (s m) + (declare (xargs :guard (and (acl2-numberp s) + (matrixp m)) + :verify-guards nil)) + (if (m-emptyp m) + (m-empty) + (row-cons (sv* s (row-car m)) + (sm* s (row-cdr m))))) + +(local + (defthm sm*-bootstrap + (implies (matrixp m) + (and (matrixp (sm* s m)) + (equal (col-count (sm* s m)) + (col-count m)))) + :hints (("Goal" :induct (sm* s m))))) + +(defthm m-empty-sm* + (equal (m-emptyp (sm* s m)) + (m-emptyp m))) + +(verify-guards sm*) + +(defthm matrix-sm* + (implies (matrixp m) + (matrixp (sm* s m)))) + +(defthm col-count-sm* + (implies (matrixp m) + (equal (col-count (sm* s m)) + (col-count m)))) + +(defthm row-count-sm* + (equal (row-count (sm* s m)) + (row-count m))) + +(defthm sm*-1 + (implies (matrixp m) + (equal (sm* 1 m) m))) + +(defthm sm*-sm* + (implies (matrixp m) + (equal (sm* a (sm* b m)) + (sm* (* a b) m)))) + +(local + (defthm col-car-sm* + (implies (matrixp m) + (equal (col-car (sm* s m)) + (sv* s (col-car m)))) + :hints (("Goal" :in-theory (enable col-car-row-cons)) + ("Subgoal *1/3" :expand ((sv* s (row-car m))))))) + +(defthm sm*-by-col-def + (implies (matrixp m) + (equal (sm* s m) + (if (m-emptyp m) + (m-empty) + (col-cons (sv* s (col-car m)) + (sm* s (col-cdr m)))))) + :hints (("Subgoal *1/1.3'" + :use (:instance row-cons-def + (l (list (* s (car (col-car m))))) + (m (sm* s (row-cdr m)))))) + :rule-classes :definition) + +;;;; Properties about scalar multiplication and zero. +(include-book "mzero") + +(defthm sm*-0-left + (implies (matrixp m) + (equal (sm* 0 m) + (mzero (row-count m) (col-count m)))) + :hints (("Goal" :induct (sm* 0 m)))) + +(defthm sm*-0-right + (equal (sm* s (mzero r c)) + (mzero r c)) + :hints (("Goal" :induct (vzero r)))) + +;;;; Properties about scalar multiplication and addition. +(include-book "madd") + +(defthm sm*-collect + (implies (matrixp m) + (equal (m+ m m) + (sm* 2 m)))) + +(defthm sm*-collect-left + (implies (matrixp m) + (equal (m+ (sm* a m) m) + (sm* (1+ a) m)))) + +(defthm sm*-collect-right + (implies (matrixp m) + (equal (m+ m (sm* a m)) + (sm* (1+ a) m)))) + +(defthm sm*-collect-both + (implies (matrixp m) + (equal (m+ (sm* a m) (sm* b m)) + (sm* (+ a b) m)))) + +(defthm sm*-dist + (implies (m+-guard m n) + (equal (sm* a (m+ m n)) + (m+ (sm* a m) (sm* a n)))) + :hints (("Goal" :induct (m+ m n)))) + +;;;; Properties about scalar multiplication and entries. +(include-book "mentry") + +(defthm row-sm* + (implies (matrixp m) + (equal (row i (sm* a m)) + (sv* a (row (nfix i) m)))) + :hints (("Goal" :induct (row i m)) +; :With directive added 3/14/06 by Matt Kaufmann for after v2-9-4. + ("Subgoal *1/2'''" :expand ((:with sm* (sm* a m)))))) + +(defthm col-sm* + (implies (matrixp m) + (equal (col i (sm* a m)) + (sv* a (col i m))))) + +(defthm entry-sm* + (implies (matrixp m) + (equal (mentry r c (sm* a m)) + (if (and (< (nfix r) (row-count m)) + (< (nfix c) (col-count m))) + (* a (mentry r c m)) + nil)))) diff --git a/books/workshops/2003/hendrix/support/msub.lisp b/books/workshops/2003/hendrix/support/msub.lisp new file mode 100644 index 0000000..63bad02 --- /dev/null +++ b/books/workshops/2003/hendrix/support/msub.lisp @@ -0,0 +1,15 @@ +;;;;; Matrix negation and subtration. +;;;;; +;;;;; Both operations are implemented as a single macro, +;;;;; so this book is really short. + +(in-package "ACL2") + +(include-book "mdefthms") +(include-book "madd") +(include-book "mscal") + +(defmacro m- (m &optional (n 'nil binary-casep)) + (if binary-casep + `(m+ ,m (sm* -1 ,n)) + `(sm* -1 ,m))) diff --git a/books/workshops/2003/hendrix/support/mtrans.lisp b/books/workshops/2003/hendrix/support/mtrans.lisp new file mode 100644 index 0000000..3bea448 --- /dev/null +++ b/books/workshops/2003/hendrix/support/mtrans.lisp @@ -0,0 +1,124 @@ +;;;;; Matrix transpose +;;;;; Contains definition of matrix transpose and basis properties. +;;;;; Includes relations with mzero, madd, mid, mmult, and mentry. +(in-package "ACL2") + +(include-book "mdefthms") + +(defun mtrans (m) + (declare (xargs :guard (matrixp m) + :verify-guards nil)) + (if (m-emptyp m) + (m-empty) + (col-cons (row-car m) (mtrans (row-cdr m))))) + +(defthm m-emptyp-mtrans + (equal (m-emptyp (mtrans m)) + (m-emptyp m))) + +(defthm row-count-mtrans + (implies (matrixp m) + (equal (row-count (mtrans m)) + (col-count m)))) + +(defthm matrixp-mtrans + (implies (matrixp m) + (matrixp (mtrans m)))) + +(local + (defun col-cdr-recurse (m) + (if (m-emptyp m) + 0 + (col-cdr-recurse (col-cdr m))))) + +(defthm col-count-mtrans + (implies (matrixp m) + (equal (col-count (mtrans m)) + (row-count m))) + :hints (("Subgoal *1/3" + :use (:instance col-count-def + (m (col-cons (row-car m) + (mtrans (row-cdr m)))))))) + +(verify-guards mtrans) + +(defthm mtrans-by-col-def + (implies (matrixp m) + (equal (mtrans m) + (if (m-emptyp m) + (m-empty) + (row-cons (col-car m) + (mtrans (col-cdr m)))))) + :hints (("Goal" :induct (mtrans m))) + :rule-classes :definition) + +(defthm mtrans-mtrans + (implies (matrixp m) + (equal (mtrans (mtrans m)) + m))) + +(include-book "mzero") + +(defthm mtrans-zero + (equal (mtrans (mzero r c)) + (mzero c r))) + +(include-book "madd") + +(defthm distr+mtrans + (implies (and (matrixp m) + (matrixp n)) + (equal (mtrans (m+ m n)) + (m+ (mtrans m) (mtrans n)))) + :hints (("Goal" :induct (m+ m n)))) + +(include-book "mid") + +(defthm mtrans-id + (equal (mtrans (mid n)) + (mid n))) + +(include-book "mscal") + +(defthm sm*-trans + (implies (matrixp m) + (equal (mtrans (sm* s m)) + (sm* s (mtrans m))))) + +(include-book "mmult") + +(defthm col*-mtrans + (implies (row*-guard l m) + (equal (col* l (mtrans m)) + (row* l m)))) + +(defthm row*-mtrans + (implies (col*-guard l m) + (equal (row* l (mtrans m)) + (col* l m)))) + +(defthm mtrans-m* + (implies (m*-guard m n) + (equal (mtrans (m* m n)) + (m* (mtrans n) (mtrans m)))) + :hints (("Goal" :induct (m* m n)))) + +(include-book "mentry") + +(defthm row-trans + (implies (matrixp m) + (equal (row i (mtrans m)) + (col i m)))) + +(defthm col-trans + (implies (matrixp m) + (equal (col i (mtrans m)) + (row i m))) +; :With directive added 3/14/06 by Matt Kaufmann for after v2-9-4. + :hints (("Goal" :expand (:with mtrans (mtrans m))))) + +(defthm entry-trans + (implies (matrixp m) + (equal (mentry r c (mtrans m)) + (mentry c r m))) + :hints (("Subgoal *1/2.4'" :use (:instance row-by-col-def (i c))))) diff --git a/books/workshops/2003/hendrix/support/mzero.lisp b/books/workshops/2003/hendrix/support/mzero.lisp new file mode 100644 index 0000000..8387efc --- /dev/null +++ b/books/workshops/2003/hendrix/support/mzero.lisp @@ -0,0 +1,56 @@ +;;;;; Contains method for generating a zero matrix (matrix where all entries are 0). +;;;;; Also contains theorems for row-count, col-count and a logical definition in terms +;;;;; of col-cons. +(in-package "ACL2") + +(include-book "mdefthms") + +(defmacro mzero-guard (r c) + `(and (integerp ,r) + (integerp ,c) + (<= 0 ,r) + (<= 0 ,c))) + +;;; Creates a zero matrix with r rows and c columns if r and c are positive integers. +;;; Otherwise creates the m-empty. +(defun mzero (r c) + (declare (xargs :guard (mzero-guard r c) + :verify-guards nil)) + (if (or (zp r) (zp c)) + nil + (row-cons (vzero c) + (mzero (1- r) c)))) + +(local + (defthm zero-bootstrap + (and (matrixp (mzero r c)) + (equal (col-count (mzero r c)) + (if (or (zp c) (zp r)) 0 c))))) + +(verify-guards mzero) + +(defthm matrixp-zero + (matrixp (mzero r c))) + +(defthm m-empty-zero + (equal (m-emptyp (mzero r c)) + (or (zp r) (zp c)))) + +(defthm col-count-zero + (equal (col-count (mzero r c)) + (if (or (zp c) (zp r)) 0 c))) + +(defthm row-count-zero + (equal (row-count (mzero r c)) + (if (or (zp c) (zp r)) 0 r))) + +(defthm zero-by-col-def + (equal (mzero r c) + (if (or (zp r) (zp c)) + nil + (col-cons (vzero r) + (if (= c 1) + nil + (mzero r (1- c)))))) + :hints (("Goal" :induct (mzero r c))) + :rule-classes :definition) diff --git a/books/workshops/2003/hendrix/support/vector.lisp b/books/workshops/2003/hendrix/support/vector.lisp new file mode 100644 index 0000000..42f272d --- /dev/null +++ b/books/workshops/2003/hendrix/support/vector.lisp @@ -0,0 +1,255 @@ +;;;;; Some functions for mathematical vectors. +;;;;; +;;;;; Includes functions for creating zero vector, vector addition, negation, +;;;;; subtraction, multiplication by scalar, and dot product and basic +;;;;; theorems about those functions. + +(in-package "ACL2") + +(include-book "../../../../arithmetic/top-with-meta") + +;;; Returns true if v is a true-list of numbers. +(defun mvectorp (v) + (declare (xargs :verify-guards t)) + (if (consp v) + (and (acl2-numberp (car v)) + (mvectorp (cdr v))) + (eq v nil))) + +(defthm vector-is-true-list + (implies (mvectorp l) + (true-listp l)) + :rule-classes :compound-recognizer) + +;;;; Zero vector and basic theorems. + +;;; Returns a list of length len of zeros - a zero vector. +(defun vzero (len) + (declare (xargs :guard (and (integerp len) (<= 0 len)))) + (if (zp len) + nil + (cons 0 (vzero (1- len))))) + +;;; Theorem proving the zero vector is a vector. +(defthm mvectorp-vzero + (mvectorp (vzero n)) + :rule-classes (:rewrite :type-prescription)) + +(defthm consp-vzero + (equal (consp (vzero n)) + (not (zp n)))) + +;;; Length of zero vector equals its argument. +(defthm len-vzero + (equal (len (vzero n)) + (nfix n))) + +;;;; Vector addition and basic properties. + +;;; v+ (vector addition) should take two lists of equal length. +(defmacro v+-guard (k l) + `(and (mvectorp ,k) + (mvectorp ,l) + (equal (len ,k) (len ,l)))) + +;;; Returns the sum of two vectors - Recursively iterates down each argument. +(defun v+ (k l) + (declare (xargs :guard (v+-guard k l))) + (if (endp k) + nil + (cons (+ (car k) (car l)) + (v+ (cdr k) (cdr l))))) + +(defthm mvectorp-v+ + (mvectorp (v+ k l))) + +(defthm consp-v+ + (equal (consp (v+ k l)) + (consp k))) + +(defthm len-v+ + (equal (len (v+ k l)) + (len k))) + +;;;; Vector addition is associative and commutative. +(defthm v+-assoc + (implies (<= (len j) (len k)) + (equal (v+ (v+ j k) l) + (v+ j (v+ k l))))) + +(defthm v+-assoc2 + (implies (equal (len j) (len k)) + (equal (v+ j (v+ k l)) + (v+ k (v+ j l))))) + +(defthm v+-comm + (implies (equal (len k) (len l)) + (equal (v+ k l) + (v+ l k)))) + +;;;; Adding the zero vector to a vector does not affect the vector if +;;;; the lengths are the same. + +(defthm v+-nil + (implies (mvectorp v) + (equal (v+ v nil) v))) + +(defthm v+-zero-left + (implies (and (mvectorp v) + (equal (len v) n)) + (equal (v+ (vzero n) v) v))) + +(defthm v+zero-right + (implies (and (mvectorp v) + (equal (len v) n)) + (equal (v+ v (vzero n)) v)) + :hints (("Goal" :induct (nth n v)))) + +(defthm nth-v+ + (equal (nth i (v+ u v)) + (if (< (nfix i) (len u)) + (+ (nth i u) (nth i v)) + nil)) + :hints (("Goal" :induct (and (nth i u) + (v+ u v))))) + +;;;; Multiplication of a vector by a scalar. + +(defun sv* (s v) + (declare (xargs :guard (and (acl2-numberp s) (mvectorp v)))) + (if (endp v) + nil + (cons (* s (car v)) + (sv* s (cdr v))))) + +(defthm vector-sv* + (mvectorp (sv* s v))) + +(defthm len-sv* + (equal (len (sv* s v)) + (len v))) + +(defthm consp-sv* + (equal (consp (sv* s v)) + (consp v))) + +;;;; Multiplying by zero results in a zero vector. +(defthm sv*-0-left + (equal (sv* 0 v) + (vzero (len v)))) + +(defthm sv*-0-right + (equal (sv* s (vzero n)) + (vzero n))) + +;;; Multiplying by 1 does not change a vector. +(defthm sv*-1 + (implies (mvectorp v) + (equal (sv* 1 v) v))) + +;;; Collect 2 scalar multiplications into a single multiplication. +(defthm sv*-sv* + (equal (sv* a (sv* b l)) + (sv* (* a b) l))) + +;;;; Collect vector addition where one vector is a scalar multiple of +;;;; the other into a single scalar multiplication. +(defthm sv*-collect + (equal (v+ v v) + (sv* 2 v))) + +(defthm sv*-collect-left + (equal (v+ (sv* a v) v) + (sv* (1+ a) v))) + +(defthm sv*-collect-right + (equal (v+ v (sv* a v)) + (sv* (1+ a) v))) + +(defthm sv*-collect-both + (equal (v+ (sv* a v) (sv* b v)) + (sv* (+ a b) v))) + +(local + (defthm sv*-dist-nil + (equal (sv* a (v+ u nil)) + (sv* a u)))) + +(defthm sv*-dist + (equal (sv* a (v+ u v)) + (v+ (sv* a u) (sv* a v)))) + +(defthm nth-sv* + (equal (nth i (sv* a v)) + (if (< (nfix i) (len v)) + (* a (nth i v)) + nil))) + +;;; Define v- to negate with a single argument and subtract with binary +;;; arguments. +(defmacro v- (l &optional (k 'nil binary-casep)) + (if binary-casep + `(v+ ,l (sv* -1 ,k)) + `(sv* -1 ,l))) + +;;;; Dot product function and basic theorems. +(defun dot* (u v) + (declare (xargs :guard (and (mvectorp u) + (mvectorp v) + (equal (len u) (len v))))) + (if (endp u) + 0 + (+ (* (car u) (car v)) + (dot* (cdr u) (cdr v))))) + +(defthm numberp-dot* + (acl2-numberp (dot* l k)) + :rule-classes :type-prescription) + +(defthm dot*-nil-left + (equal (dot* l nil) 0)) + +(defthm dot*-nil-right + (equal (dot* nil l) 0)) + +(defthm dot*-comm + (equal (dot* l k) + (dot* k l))) + +;;; This is used for generating the induction. It seems like an easier +;;; way to do this should exist, but I do not yet understand the +;;; induction heuristics. +(local + (defun zero-dot*-recursion (n l) + (if (zp n) + l + (zero-dot*-recursion (1- n) (cdr l))))) + +(defthm dot*-zero-left + (equal (dot* (vzero n) l) 0) + :hints (("Goal" :induct (zero-dot*-recursion n l)))) + +(defthm dot*-zero-right + (equal (dot* l (vzero n)) 0) + :hints (("Goal" :induct (nth n l)))) + +;;; Distribute the dot product of vector addition. +(defthm dist-dot*-v+-left + (implies (equal (len j) (len k)) + (equal (dot* (v+ k l) j) + (+ (dot* k j) (dot* l j))))) + +(defthm dist-dot*-v+-right + (implies (equal (len j) (len k)) + (equal (dot* j (v+ k l)) + (+ (dot* j k) (dot* j l))))) + +;;; Distribute the dot production of scalar vector multiplication. +(defthm dot*-sv*-left + (equal (dot* (sv* a l) k) + (* a (dot* l k)))) + +(defthm dot*-sv*-right + (equal (dot* l (sv* a k)) + (* a (dot* l k)))) + diff --git a/books/workshops/2003/kaufmann/LICENSE b/books/workshops/2003/kaufmann/LICENSE new file mode 100644 index 0000000..df9647c --- /dev/null +++ b/books/workshops/2003/kaufmann/LICENSE @@ -0,0 +1,2 @@ +Copyright (C) 2002, Matt Kaufmann +License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. diff --git a/books/workshops/2003/kaufmann/deps.lisp b/books/workshops/2003/kaufmann/deps.lisp new file mode 100644 index 0000000..2d26787 --- /dev/null +++ b/books/workshops/2003/kaufmann/deps.lisp @@ -0,0 +1,16 @@ +;; Silly file to trick cert.pl into including the right books. + +(in-package "ACL2") + +#|| +(include-book "misc/file-io" :dir :system) +(include-book "misc/rtl-untranslate" :dir :system) +(include-book "misc/symbol-btree" :dir :system) +(include-book "ordinals/e0-ordinal" :dir :system) +(include-book "rtl/rel4/lib/rtl" :dir :system) +(include-book "rtl/rel4/lib/rtlarr" :dir :system) +(include-book "rtl/rel4/lib/simplify-model-helpers" :dir :system) +(include-book "rtl/rel4/lib/top" :dir :system)) +(include-book "rtl/rel4/lib/util" :dir :system) +(include-book "rtl/rel4/support/bvecp-helpers" :dir :system) +||# diff --git a/books/workshops/2003/kaufmann/paper.pdf.gz b/books/workshops/2003/kaufmann/paper.pdf.gz Binary files differnew file mode 100644 index 0000000..2385559 --- /dev/null +++ b/books/workshops/2003/kaufmann/paper.pdf.gz diff --git a/books/workshops/2003/kaufmann/paper.ps.gz b/books/workshops/2003/kaufmann/paper.ps.gz Binary files differnew file mode 100644 index 0000000..356c292 --- /dev/null +++ b/books/workshops/2003/kaufmann/paper.ps.gz diff --git a/books/workshops/2003/kaufmann/slides.pdf.gz b/books/workshops/2003/kaufmann/slides.pdf.gz Binary files differnew file mode 100644 index 0000000..6a71fb6 --- /dev/null +++ b/books/workshops/2003/kaufmann/slides.pdf.gz diff --git a/books/workshops/2003/kaufmann/slides.ps.gz b/books/workshops/2003/kaufmann/slides.ps.gz Binary files differnew file mode 100644 index 0000000..9d088dc --- /dev/null +++ b/books/workshops/2003/kaufmann/slides.ps.gz diff --git a/books/workshops/2003/kaufmann/slides4.pdf.gz b/books/workshops/2003/kaufmann/slides4.pdf.gz Binary files differnew file mode 100644 index 0000000..78b2ff8 --- /dev/null +++ b/books/workshops/2003/kaufmann/slides4.pdf.gz diff --git a/books/workshops/2003/kaufmann/slides4.ps.gz b/books/workshops/2003/kaufmann/slides4.ps.gz Binary files differnew file mode 100644 index 0000000..82fb954 --- /dev/null +++ b/books/workshops/2003/kaufmann/slides4.ps.gz diff --git a/books/workshops/2003/kaufmann/support/Makefile b/books/workshops/2003/kaufmann/support/Makefile new file mode 100644 index 0000000..3079301 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/Makefile @@ -0,0 +1,2 @@ +DIRS = input rtl/tool rtl +include ../../../../Makefile-subdirs diff --git a/books/workshops/2003/kaufmann/support/README b/books/workshops/2003/kaufmann/support/README new file mode 100644 index 0000000..3f54316 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/README @@ -0,0 +1,9 @@ +These supporting materials allow you to run the tool described in the paper "A +Tool for Simplifying Files of ACL2 Definitions", on the small example described +in that paper. This directory should be placed under +books/workshops/2003/kaufmann/. It is organized into these subdirectories. + +input/ contains all input files +output/ contains copies of files generated from input/ by running make + when standing in input/ +rtl/ rtl example from final section of the paper [see README] diff --git a/books/workshops/2003/kaufmann/support/input/.gitignore b/books/workshops/2003/kaufmann/support/input/.gitignore new file mode 100644 index 0000000..de31371 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/.gitignore @@ -0,0 +1,4 @@ +check.txt +defs-eq.lisp +defs-out.lisp +lemmas-out.lisp
\ No newline at end of file diff --git a/books/workshops/2003/kaufmann/support/input/Makefile b/books/workshops/2003/kaufmann/support/input/Makefile new file mode 100644 index 0000000..a83c8df --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/Makefile @@ -0,0 +1,55 @@ +include ../../../../../Makefile-generic + +# Avoid provisional certification since we are not using Makefile-deps +# (because there are generated .lisp files): +override ACL2_PCERT = + +BOOKS = defs-in inputs lemmas-in defs-out defs-eq lemmas-out + +all: check.txt + +# Compare generated .lisp files against expected files, in ../output/ directory. +check.txt: defs-eq.cert defs-out.cert lemmas-in.cert defs-in.cert inputs.cert lemmas-out.cert + @diff defs-out.lisp ../output/defs-out.lisp || (echo "diff of input/defs-out.lisp with output/defs-out.lisp failed" ; exit 1) + @diff defs-eq.lisp ../output/defs-eq.lisp || (echo "diff of input/defs-eq.lisp with output/defs-eq.lisp failed" ; exit 1) + @diff lemmas-out.lisp ../output/lemmas-out.lisp || (echo "diff of input/lemmas-out.lisp with output/lemmas-out.lisp failed" ; exit 1) + touch check.txt + +# Dependencies: + +# Created manually: + +defs-eq.lisp lemmas-out.lisp: defs-out.lisp + +defs-out.lisp: defs-in.cert lemmas-in.lisp ../../../../../misc/simplify-defuns.cert + $(ACL2) < defs-out.cmds > defs-out.lisp.out + +clean: clean-more + +clean-more: + rm -f defs-out.lisp defs-eq.lisp lemmas-out.lisp check.txt + +# Created with make dependencies after a successful run: + +defs-in.cert: defs-in.lisp +defs-in.cert: defs-in.acl2 +defs-in.cert: inputs.cert + +inputs.cert: inputs.lisp + +lemmas-in.cert: lemmas-in.lisp +lemmas-in.cert: defs-in.cert + +defs-out.cert: defs-out.lisp +defs-out.cert: defs-out.acl2 +defs-out.cert: inputs.cert + +defs-eq.cert: defs-eq.lisp +defs-eq.cert: defs-eq.acl2 +defs-eq.cert: defs-in.cert +defs-eq.cert: defs-out.cert + +lemmas-out.cert: lemmas-out.lisp +lemmas-out.cert: defs-out.cert +lemmas-out.cert: lemmas-in.cert +lemmas-out.cert: defs-eq.cert diff --git a/books/workshops/2003/kaufmann/support/input/cert_pl_exclude b/books/workshops/2003/kaufmann/support/input/cert_pl_exclude new file mode 100644 index 0000000..833501d --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/cert_pl_exclude @@ -0,0 +1,2 @@ +This directory has a custom Makefile, so it is excluded from +certification based on cert.pl. diff --git a/books/workshops/2003/kaufmann/support/input/defs-eq.acl2 b/books/workshops/2003/kaufmann/support/input/defs-eq.acl2 new file mode 100644 index 0000000..31c8367 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/defs-eq.acl2 @@ -0,0 +1,9 @@ +(value :q) + +(LP) + +(include-book "defs-in") + +(include-book "defs-out") + +(certify-book "defs-eq" ? t) diff --git a/books/workshops/2003/kaufmann/support/input/defs-in.acl2 b/books/workshops/2003/kaufmann/support/input/defs-in.acl2 new file mode 100644 index 0000000..663dd9a --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/defs-in.acl2 @@ -0,0 +1,7 @@ +(value :q) + +(LP) + +(include-book "inputs") + +(certify-book "defs-in" ? t) diff --git a/books/workshops/2003/kaufmann/support/input/defs-in.lisp b/books/workshops/2003/kaufmann/support/input/defs-in.lisp new file mode 100644 index 0000000..51e908e --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/defs-in.lisp @@ -0,0 +1,41 @@ +(in-package "ACL2") + +(defun %g1 (x y) + (cond + ((zp x) x) + ((< 0 (f1 x)) y) + (t 23))) + +(in-theory (disable %g1)) + +(defun %g2 (x y) + (if (atom x) + (%g1 x y) + (%g2 (cdr x) y))) + +(in-theory (disable %g2)) + +(mutual-recursion + (defun %reg1 (n) + (declare (xargs :measure (make-ord 1 (1+ (nfix n)) 0))) + (if (zp n) + 0 + (logxor (%wire1 (1- n)) + (input1 (1- n))))) + (defun %reg2 (n) + (declare (xargs :measure (make-ord 1 (1+ (nfix n)) 1))) + (if (zp n) + (%reg1 n) + (logand (%wire1 (1- n)) + (%wire2 (1- n))))) + (defun %wire1 (n) + (declare (xargs :measure (make-ord 1 (1+ (nfix n)) 2))) + (logior (%reg1 n) (input2 n))) + (defun %wire2 (n) + (declare (xargs :measure (make-ord 1 (1+ (nfix n)) 3))) + (lognot (%wire1 n)))) + +(in-theory (disable %g1 %g2 %reg1 %reg2 %wire1 %wire2 + logand logior logxor + ; Not disabled: f1 lognot + )) diff --git a/books/workshops/2003/kaufmann/support/input/defs-out.acl2 b/books/workshops/2003/kaufmann/support/input/defs-out.acl2 new file mode 100644 index 0000000..5eb7586 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/defs-out.acl2 @@ -0,0 +1,7 @@ +(value :q) + +(LP) + +(include-book "inputs") + +(certify-book "defs-out" ? t) diff --git a/books/workshops/2003/kaufmann/support/input/defs-out.cmds b/books/workshops/2003/kaufmann/support/input/defs-out.cmds new file mode 100644 index 0000000..c4a7506 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/defs-out.cmds @@ -0,0 +1,22 @@ +(value :q) + +(LP) + +(include-book "defs-in") +(include-book "../../../../../misc/simplify-defuns") +(transform-defuns "defs-in.lisp" + :out-defs "defs-out.lisp" + ;; can also specify + ;; :defs-extra <list of initial events for :out-defs> + :equalities "defs-eq.lisp" + ;; can also specify + ;; :eq-extra <list of initial events for :equalities> + :thm-file-pairs '(("lemmas-in.lisp" "lemmas-out.lisp" + ;; Initial events for lemmas-out.lisp: + (include-book "defs-out") + (local (include-book "lemmas-in")) + (local (include-book "defs-eq")) + (local (in-theory (theory + '%-removal-theory)))))) +(value :q) +(good-bye) diff --git a/books/workshops/2003/kaufmann/support/input/inputs.lisp b/books/workshops/2003/kaufmann/support/input/inputs.lisp new file mode 100644 index 0000000..bdcdf73 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/inputs.lisp @@ -0,0 +1,7 @@ +(in-package "ACL2") + +(defun f1 (x) + (+ x x)) + +(defstub input1 (n) t) +(defstub input2 (n) t) diff --git a/books/workshops/2003/kaufmann/support/input/lemmas-in.lisp b/books/workshops/2003/kaufmann/support/input/lemmas-in.lisp new file mode 100644 index 0000000..47d1ed2 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/input/lemmas-in.lisp @@ -0,0 +1,8 @@ +(in-package "ACL2") + +(include-book "defs-in") + +(defthm %lemma-1 + (implies (true-listp x) + (equal (%g2 x y) nil)) + :hints (("Goal" :in-theory (enable %g1 %g2)))) diff --git a/books/workshops/2003/kaufmann/support/output/cert_pl_exclude b/books/workshops/2003/kaufmann/support/output/cert_pl_exclude new file mode 100644 index 0000000..1d46140 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/output/cert_pl_exclude @@ -0,0 +1,8 @@ +cert_pl_exclude + +The presence of this file tells cert.pl not to try to build any of the books in +this directory. + +This directory contains books not to be certified. Rather, they are +here for comparison with files that are generated; see the `diff' +calls in ../input/Makefile. diff --git a/books/workshops/2003/kaufmann/support/output/defs-eq.lisp b/books/workshops/2003/kaufmann/support/output/defs-eq.lisp new file mode 100644 index 0000000..6db5c93 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/output/defs-eq.lisp @@ -0,0 +1,188 @@ +(IN-PACKAGE "ACL2") + +(LOCAL (DEFUN %%SUB1-INDUCTION (N) + (IF (ZP N) + N (%%SUB1-INDUCTION (1- N))))) + +(LOCAL (DEFUN %%AND-TREE-FN (ARGS LEN) + (DECLARE (XARGS :MODE :PROGRAM)) + (IF (< LEN 20) + (CONS 'AND ARGS) + (LET* ((LEN2 (FLOOR LEN 2))) + (LIST 'AND + (%%AND-TREE-FN (TAKE LEN2 ARGS) LEN2) + (%%AND-TREE-FN (NTHCDR LEN2 ARGS) + (- LEN LEN2))))))) + +(LOCAL (DEFMACRO %%AND-TREE (&REST ARGS) + (%%AND-TREE-FN ARGS (LENGTH ARGS)))) + +(LOCAL (DEFTHEORY THEORY-0 (THEORY 'MINIMAL-THEORY))) + +(LOCAL (DEFTHM G1-BODY-IS-%G1-BODY_S + (EQUAL (IF (ZP X) X Y) + (COND ((ZP X) X) + ((< 0 (F1 X)) Y) + (T 23))) + :HINTS (("Goal" :DO-NOT '(PREPROCESS))) + :RULE-CLASSES NIL)) + +(DEFTHM G1-IS-%G1 (EQUAL (G1 X Y) (%G1 X Y)) + :HINTS (("Goal" :EXPAND ((:FREE (X Y) (%G1 X Y)) + (:FREE (X Y) (G1 X Y))) + :IN-THEORY (THEORY 'THEORY-0) + :DO-NOT '(PREPROCESS) + :USE G1-BODY-IS-%G1-BODY_S))) + +(LOCAL (DEFTHEORY THEORY-1 + (UNION-THEORIES '(G1-IS-%G1) + (THEORY 'THEORY-0)))) + +(LOCAL (DEFUN %%G2 (X Y) + (IF (CONSP X) + (%%G2 (CDR X) Y) + (%G1 X Y)))) + +(LOCAL (DEFTHM %%G2-IS-G2 (EQUAL (%%G2 X Y) (G2 X Y)) + :HINTS (("Goal" :IN-THEORY (UNION-THEORIES '((:INDUCTION %%G2)) + (THEORY 'THEORY-1)) + :DO-NOT '(PREPROCESS) + :EXPAND ((%%G2 X Y) (G2 X Y)) + :INDUCT T)))) + +(DEFTHM G2-IS-%G2 (EQUAL (G2 X Y) (%G2 X Y)) + :HINTS (("Goal" :BY (:FUNCTIONAL-INSTANCE %%G2-IS-G2 (%%G2 %G2)) + :DO-NOT '(PREPROCESS) + :EXPAND ((%G2 X Y))))) + +(LOCAL (DEFTHEORY THEORY-2 + (UNION-THEORIES '(G2-IS-%G2) + (THEORY 'THEORY-1)))) + +(LOCAL (DEFUN %%P2 (N) + (DECLARE (XARGS :NORMALIZE NIL)) + (%%AND-TREE (EQUAL (WIRE2 N) (%WIRE2 N)) + (EQUAL (WIRE1 N) (%WIRE1 N)) + (EQUAL (REG2 N) (%REG2 N)) + (EQUAL (REG1 N) (%REG1 N))))) + +(LOCAL + (DEFTHM + %%P2-PROPERTY + (IMPLIES (%%P2 N) + (%%AND-TREE (EQUAL (WIRE2 N) (%WIRE2 N)) + (EQUAL (WIRE1 N) (%WIRE1 N)) + (EQUAL (REG2 N) (%REG2 N)) + (EQUAL (REG1 N) (%REG1 N)))) + :HINTS (("Goal" :IN-THEORY (UNION-THEORIES '(%%P2) + (THEORY 'MINIMAL-THEORY)))))) + +(LOCAL + (DEFTHEORY %%P2-IMPLIES-F-IS-%F-THEORY + (UNION-THEORIES (SET-DIFFERENCE-THEORIES (CURRENT-THEORY :HERE) + (CURRENT-THEORY '%%P2)) + (THEORY 'MINIMAL-THEORY)))) + +(LOCAL + (ENCAPSULATE NIL + (LOCAL (IN-THEORY (DISABLE %%P2-PROPERTY))) + (LOCAL (DEFTHM REG1-IS-%REG1-BASE + (IMPLIES (ZP N) + (EQUAL (REG1 N) (%REG1 N))) + :HINTS (("Goal" :EXPAND ((REG1 N) (%REG1 N)))))) + (LOCAL (DEFTHM REG2-IS-%REG2-BASE + (IMPLIES (ZP N) + (EQUAL (REG2 N) (%REG2 N))) + :HINTS (("Goal" :EXPAND ((REG2 N) (%REG2 N)))))) + (LOCAL (DEFTHM WIRE1-IS-%WIRE1-BASE + (IMPLIES (ZP N) + (EQUAL (WIRE1 N) (%WIRE1 N))) + :HINTS (("Goal" :EXPAND ((WIRE1 N) (%WIRE1 N)))))) + (LOCAL (DEFTHM WIRE2-IS-%WIRE2-BASE + (IMPLIES (ZP N) + (EQUAL (WIRE2 N) (%WIRE2 N))) + :HINTS (("Goal" :EXPAND ((WIRE2 N) (%WIRE2 N)))))) + (DEFTHM %%P2-BASE (IMPLIES (ZP N) (%%P2 N)) + :INSTRUCTIONS (:PROMOTE :X-DUMB (:S :NORMALIZE NIL))))) + +(LOCAL + (ENCAPSULATE + NIL + (LOCAL (IN-THEORY (DISABLE %%P2 %%P2-BASE))) + (LOCAL (DEFLABEL %%INDUCTION-START)) + (LOCAL (DEFTHM REG1-IS-%REG1-INDUCTION_STEP + (IMPLIES (AND (NOT (ZP N)) (%%P2 (1- N))) + (EQUAL (REG1 N) (%REG1 N))) + :INSTRUCTIONS (:PROMOTE (:DV 1) + :X-DUMB + :NX :X-DUMB + :TOP (:S :NORMALIZE NIL + :BACKCHAIN-LIMIT 1000 + :EXPAND :LAMBDAS + :REPEAT 4)))) + (LOCAL (DEFTHM REG2-IS-%REG2-INDUCTION_STEP + (IMPLIES (AND (NOT (ZP N)) (%%P2 (1- N))) + (EQUAL (REG2 N) (%REG2 N))) + :INSTRUCTIONS (:PROMOTE (:DV 1) + :X-DUMB + :NX :X-DUMB + :TOP (:S :NORMALIZE NIL + :BACKCHAIN-LIMIT 1000 + :EXPAND :LAMBDAS + :REPEAT 4)))) + (LOCAL (DEFTHM WIRE1-IS-%WIRE1-INDUCTION_STEP + (IMPLIES (AND (NOT (ZP N)) (%%P2 (1- N))) + (EQUAL (WIRE1 N) (%WIRE1 N))) + :INSTRUCTIONS (:PROMOTE (:DV 1) + :X-DUMB + :NX :X-DUMB + :TOP (:S :NORMALIZE NIL + :BACKCHAIN-LIMIT 1000 + :EXPAND :LAMBDAS + :REPEAT 4)))) + (LOCAL (DEFTHM WIRE2-IS-%WIRE2-INDUCTION_STEP + (IMPLIES (AND (NOT (ZP N)) (%%P2 (1- N))) + (EQUAL (WIRE2 N) (%WIRE2 N))) + :INSTRUCTIONS (:PROMOTE (:DV 1) + :X-DUMB + :NX :X-DUMB + :TOP (:S :NORMALIZE NIL + :BACKCHAIN-LIMIT 1000 + :EXPAND :LAMBDAS + :REPEAT 4)))) + (DEFTHM %%P2-INDUCTION_STEP + (IMPLIES (AND (NOT (ZP N)) (%%P2 (1- N))) + (%%P2 N)) + :INSTRUCTIONS (:PROMOTE :X-DUMB (:S :NORMALIZE NIL))))) + +(LOCAL + (DEFTHM + %%P2-HOLDS (%%P2 N) + :HINTS + (("Goal" :INDUCT (%%SUB1-INDUCTION N) + :DO-NOT '(PREPROCESS) + :IN-THEORY (UNION-THEORIES '(%%P2-BASE %%P2-INDUCTION_STEP + (:INDUCTION %%SUB1-INDUCTION)) + (THEORY 'MINIMAL-THEORY)))))) + +(ENCAPSULATE + NIL + (LOCAL (IN-THEORY (UNION-THEORIES '(%%P2-HOLDS) + (THEORY '%%P2-IMPLIES-F-IS-%F-THEORY)))) + (DEFTHM REG1-IS-%REG1 (EQUAL (REG1 N) (%REG1 N)) + :HINTS (("Goal" :DO-NOT '(PREPROCESS)))) + (DEFTHM REG2-IS-%REG2 (EQUAL (REG2 N) (%REG2 N)) + :HINTS (("Goal" :DO-NOT '(PREPROCESS)))) + (DEFTHM WIRE1-IS-%WIRE1 + (EQUAL (WIRE1 N) (%WIRE1 N)) + :HINTS (("Goal" :DO-NOT '(PREPROCESS)))) + (DEFTHM WIRE2-IS-%WIRE2 + (EQUAL (WIRE2 N) (%WIRE2 N)) + :HINTS (("Goal" :DO-NOT '(PREPROCESS))))) + +(DEFTHEORY %-REMOVAL-THEORY + (UNION-THEORIES '(G1-IS-%G1 G2-IS-%G2 + WIRE2-IS-%WIRE2 WIRE1-IS-%WIRE1 + REG2-IS-%REG2 REG1-IS-%REG1) + (THEORY 'MINIMAL-THEORY))) + diff --git a/books/workshops/2003/kaufmann/support/output/defs-out.lisp b/books/workshops/2003/kaufmann/support/output/defs-out.lisp new file mode 100644 index 0000000..acde187 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/output/defs-out.lisp @@ -0,0 +1,33 @@ +(IN-PACKAGE "ACL2") + +(SET-IGNORE-OK T) + +(SET-IRRELEVANT-FORMALS-OK T) + +(SET-BOGUS-MUTUAL-RECURSION-OK T) + +(DEFUND G1 (X Y) (IF (ZP X) X Y)) + +(DEFUND G2 (X Y) + (IF (CONSP X) (G2 (CDR X) Y) (G1 X Y))) + +(MUTUAL-RECURSION + (DEFUND REG1 (N) + (DECLARE (XARGS :MEASURE (MAKE-ORD 1 (1+ (NFIX N)) 0))) + (IF (ZP N) + 0 + (LOGXOR (WIRE1 (+ -1 N)) + (INPUT1 (+ -1 N))))) + (DEFUND REG2 (N) + (DECLARE (XARGS :MEASURE (MAKE-ORD 1 (1+ (NFIX N)) 1))) + (IF (ZP N) + (REG1 N) + (LOGAND (WIRE1 (+ -1 N)) + (WIRE2 (+ -1 N))))) + (DEFUND WIRE1 (N) + (DECLARE (XARGS :MEASURE (MAKE-ORD 1 (1+ (NFIX N)) 2))) + (LOGIOR (REG1 N) (INPUT2 N))) + (DEFUND WIRE2 (N) + (DECLARE (XARGS :MEASURE (MAKE-ORD 1 (1+ (NFIX N)) 3))) + (+ -1 (- (WIRE1 N))))) + diff --git a/books/workshops/2003/kaufmann/support/output/lemmas-out.lisp b/books/workshops/2003/kaufmann/support/output/lemmas-out.lisp new file mode 100644 index 0000000..09a4ef5 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/output/lemmas-out.lisp @@ -0,0 +1,15 @@ +(IN-PACKAGE "ACL2") + +(INCLUDE-BOOK "defs-out") + +(LOCAL (INCLUDE-BOOK "lemmas-in")) + +(LOCAL (INCLUDE-BOOK "defs-eq")) + +(LOCAL (IN-THEORY (THEORY '%-REMOVAL-THEORY))) + +(DEFTHM LEMMA-1 + (IMPLIES (TRUE-LISTP X) + (EQUAL (G2 X Y) NIL)) + :HINTS (("Goal" :USE %LEMMA-1))) + diff --git a/books/workshops/2003/kaufmann/support/rtl/.gitignore b/books/workshops/2003/kaufmann/support/rtl/.gitignore new file mode 100644 index 0000000..9b51ab5 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/.gitignore @@ -0,0 +1,4 @@ +bvecp.lisp +model-defs.lisp +model-eq.lisp +model.lisp
\ No newline at end of file diff --git a/books/workshops/2003/kaufmann/support/rtl/Makefile b/books/workshops/2003/kaufmann/support/rtl/Makefile new file mode 100644 index 0000000..dc46154 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/Makefile @@ -0,0 +1,123 @@ +TOP_MODULE = FOO +TOP_FILE = foo.v + +run: + @echo "Using ACL2=$(ACL2)" + $(MAKE) diffs.out + +diffs.out: bvecp.cert + rm -f diffs.out + diff model.lisp results/model.lisp > diffs.out + diff bvecp.lisp results/bvecp.lisp >> diffs.out + diff model-eq.lisp results/model-eq.lisp >> diffs.out + @if [ ! -z "`head -1 diffs.out`" ] ; then \ + echo "**ERROR**: Found unexpected results." ;\ + exit 1 ;\ + fi + +BOOKS_DIR = ../../../../.. +LIB_DIR = $(BOOKS_DIR)/rtl/rel4/lib + +include $(BOOKS_DIR)/Makefile-generic + +# Avoid provisional certification since we are not using Makefile-deps +# (because there are generated .lisp files): +override ACL2_PCERT = + +INHIBIT = (assign inhibit-output-lst (list (quote prove) (quote proof-tree) (quote warning) (quote observation) (quote event))) + +model-eq.lisp bvecp.lisp: model-defs.lisp + +# The following target writes out not only file model-defs.lisp, but +# also files model-eq.lisp and bvecp.lisp. +model-defs.lisp: tool/simplify-defuns.cert tool/wrapper.cert bvecp-raw.cert + echo "Running transform-defuns." + echo '(acl2::value :q)' > workxxx + echo '(acl2::lp)' >> workxxx + echo '(include-book "tool/simplify-defuns")' >> workxxx + echo '(include-book "tool/wrapper")' >> workxxx + echo '(simplify-model)' >> workxxx + echo '(acl2::value :q)' >> workxxx + echo '(acl2::exit-lisp)' >> workxxx + $(ACL2) < workxxx > model.lisp.out + rm -f workxxx + +model.lisp: model-defs.lisp model-macro-aliases.lsp + cat model-defs.lisp model-macro-aliases.lsp > model.lisp + +clean-extra: + -rm -f model.lisp model-defs.lisp model-eq.lisp model.lisp bvecp.lisp + +clean: clean-extra + +bvecp-raw.cert: bvecp-raw.lisp +bvecp-raw.cert: model-raw.cert +bvecp-raw.cert: ../../../../../rtl/rel4/lib/top.cert +bvecp-raw.cert: ../../../../../rtl/rel4/support/bvecp-helpers.cert +bvecp-raw.cert: cert.acl2 +bvecp-raw.cert: pkgs.lsp + +bvecp.cert: bvecp.lisp +bvecp.cert: model.cert +bvecp.cert: model-eq.cert +bvecp.cert: bvecp-raw.cert +bvecp.cert: ../../../../../rtl/rel4/support/bvecp-helpers.cert +bvecp.cert: cert.acl2 +bvecp.cert: pkgs.lsp + +common.cert: common.lisp +common.cert: ../../../../../rtl/rel4/lib/rtl.cert +common.cert: ../../../../../rtl/rel4/lib/rtlarr.cert +common.cert: ../../../../../rtl/rel4/lib/util.cert +common.cert: ../../../../../misc/symbol-btree.cert +common.cert: ../../../../../misc/rtl-untranslate.cert +common.cert: cert.acl2 +common.cert: pkgs.lsp + +model-defs.cert: model-defs.lisp +model-defs.cert: ../../../../../ordinals/e0-ordinal.cert +model-defs.cert: common.cert +model-defs.cert: model-macros.cert +model-defs.cert: cert.acl2 +model-defs.cert: pkgs.lsp + +model-eq.cert: model-eq.lisp +model-eq.cert: bvecp-raw.cert +model-eq.cert: ../../../../../rtl/rel4/lib/top.cert +model-eq.cert: ../../../../../rtl/rel4/lib/simplify-model-helpers.cert +model-eq.cert: model-raw.cert +model-eq.cert: model.cert +model-eq.cert: cert.acl2 +model-eq.cert: pkgs.lsp + +model-macros.cert: model-macros.lisp +model-macros.cert: cert.acl2 +model-macros.cert: pkgs.lsp + +model-raw.cert: model-raw.lisp +model-raw.cert: ../../../../../ordinals/e0-ordinal.cert +model-raw.cert: common.cert +model-raw.cert: cert.acl2 +model-raw.cert: pkgs.lsp + +model.cert: model.lisp +model.cert: ../../../../../ordinals/e0-ordinal.cert +model.cert: common.cert +model.cert: model-macros.cert +model.cert: cert.acl2 +model.cert: pkgs.lsp + +package-defs.cert: package-defs.lisp +package-defs.cert: package-defs.acl2 + +# Added manually, since cert.acl2 contains (ld "pkgs.lsp"), which contains +# (include-book "package-defs"): + +bvecp-raw.cert: package-defs.cert +bvecp.cert: package-defs.cert +common.cert: package-defs.cert +model-defs.cert: package-defs.cert +model-eq.cert: package-defs.cert +model-macros.cert: package-defs.cert +model-raw.cert: package-defs.cert +model.cert: package-defs.cert diff --git a/books/workshops/2003/kaufmann/support/rtl/README b/books/workshops/2003/kaufmann/support/rtl/README new file mode 100644 index 0000000..e4f69df --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/README @@ -0,0 +1,8 @@ +Type "make" to generate and certify files in the current directory that should +agree with the files in the results/ subdirectory, essentially: + +model.lisp simplified version of input file model-raw.lisp +model-eq.lisp proofs of equivalence of model-raw and model functions +bvecp.lisp proofs of bvecp lemmas about model functions, originally proved + for model-raw functions + diff --git a/books/workshops/2003/kaufmann/support/rtl/bvecp-raw.lisp b/books/workshops/2003/kaufmann/support/rtl/bvecp-raw.lisp new file mode 100644 index 0000000..cfc8b6f --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/bvecp-raw.lisp @@ -0,0 +1,33 @@ +(in-package "ACL2") + +(set-inhibit-warnings "SUBSUME" "THEORY" "DISABLE" "NON-REC") + +(include-book "model-raw") + +(local (include-book "rtl/rel4/lib/top" :dir :system)) + +(local + (include-book "rtl/rel4/support/bvecp-helpers" :dir :system)) + +(local + (in-theory + (set-difference-theories + (current-theory :here) + (union-theories + '(bvecp) + (union-theories (theory 'ACL2::RTL-OPERATORS-AFTER-MACRO-EXPANSION) + (theory 'ACL2::MODEL-RAW-DEFS)))))) + +(local (defthm bvecp-if + (equal (bvecp (if x y z) n) + (if x (bvecp y n) (bvecp z n))))) + +(local (in-theory (enable log=))) + +(defbvecp FOO$RAW::out1 (n) + 1 :hints (("Goal" :expand ((FOO$RAW::out1 n))))) + +(defbvecp FOO$RAW::out2 (n) + 4 :hints + (("Goal" :expand ((FOO$RAW::out2 n)) + :induct (sub1-induction n)))) diff --git a/books/workshops/2003/kaufmann/support/rtl/cert.acl2 b/books/workshops/2003/kaufmann/support/rtl/cert.acl2 new file mode 100644 index 0000000..ddcacb5 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/cert.acl2 @@ -0,0 +1,3 @@ +(acl2::value :q) +(acl2::lp) +(ld "pkgs.lsp") diff --git a/books/workshops/2003/kaufmann/support/rtl/common.lisp b/books/workshops/2003/kaufmann/support/rtl/common.lisp new file mode 100644 index 0000000..9598a90 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/common.lisp @@ -0,0 +1,134 @@ +(in-package "ACL2") + +(set-inhibit-warnings "THEORY" "DISABLE" "NON-REC") + +(include-book "rtl/rel4/lib/rtl" :dir :system) + +(include-book "rtl/rel4/lib/rtlarr" :dir :system) + +(include-book "rtl/rel4/lib/util" :dir :system) + +(include-book "misc/symbol-btree" :dir :system) + +(include-book "misc/rtl-untranslate" :dir :system) + +(deftheory rtl-operators-after-macro-expansion + *rtl-operators-after-macro-expansion*) + +(local + (in-theory + (set-difference-theories (current-theory :here) + (theory 'rtl-operators-after-macro-expansion)))) + +(defmacro ww (n) (list 'ww$ n '$path)) + +(defmacro sel (n) (list 'sel$ n '$path)) + +(defmacro in3 (n) (list 'in3$ n '$path)) + +(defmacro in2 (n) (list 'in2$ n '$path)) + +(defmacro in1 (n) (list 'in1$ n '$path)) + +(defmacro in0 (n) (list 'in0$ n '$path)) + +(ENCAPSULATE + ( + (ww$ (n $path) t) + + (sel$ (n $path) t) + + (in3$ (n $path) t) + + (in2$ (n $path) t) + + (in1$ (n $path) t) + + (in0$ (n $path) t) + + ) + + (local (defun ww$ (n $path) + (declare (ignore n $path)) + 0)) + + (local (defun sel$ (n $path) + (declare (ignore n $path)) + 0)) + + (local (defun in3$ (n $path) + (declare (ignore n $path)) + 0)) + + (local (defun in2$ (n $path) + (declare (ignore n $path)) + 0)) + + (local (defun in1$ (n $path) + (declare (ignore n $path)) + 0)) + + (local (defun in0$ (n $path) + (declare (ignore n $path)) + 0)) + + (defbvecp ww (n) 3) + + (defbvecp sel (n) 2) + + (defbvecp in3 (n) 1) + + (defbvecp in2 (n) 1) + + (defbvecp in1 (n) 1) + + (defbvecp in0 (n) 1) + +) + +(add-macro-alias ww ww$) + +(add-macro-alias sel sel$) + +(add-macro-alias in3 in3$) + +(add-macro-alias in2 in2$) + +(add-macro-alias in1 in1$) + +(add-macro-alias in0 in0$) + +(deflabel start-of-loop-defs) + +(set-ignore-ok t) + +(set-irrelevant-formals-ok t) + +(deflabel end-of-loop-defs) + +(deflabel start-of-clock-defs) + +(defun clk (n) + (declare (ignore n)) + 1) + +(deflabel end-of-clock-defs) + +(deftheory loop-defs + (set-difference-theories (current-theory 'end-of-loop-defs) + (current-theory 'start-of-loop-defs))) + +(deftheory + clock-defs + (set-difference-theories + (union-theories (function-theory 'end-of-clock-defs) + (executable-counterpart-theory 'end-of-clock-defs)) + (union-theories (function-theory 'start-of-clock-defs) + (executable-counterpart-theory 'start-of-clock-defs)))) + +(table rtl-tbl 'sigs-btree + (symbol-alist-to-btree + (dollar-alist '(ww sel in3 in2 in1 in0 + out1 FOO$RAW::OUT1 out2 FOO$RAW::OUT2) + nil))) + diff --git a/books/workshops/2003/kaufmann/support/rtl/model-macro-aliases.lsp b/books/workshops/2003/kaufmann/support/rtl/model-macro-aliases.lsp new file mode 100644 index 0000000..40b6fa2 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/model-macro-aliases.lsp @@ -0,0 +1,18 @@ +(add-macro-alias out1 out1$) + +(add-macro-alias out2 out2$) + +(deflabel model-end-of-defs) + +(deftheory tmp-names 'nil) + +(deftheory + model-defs + (union-theories (set-difference-theories (current-theory 'model-end-of-defs) + (current-theory 'model-start-of-defs)) + (union-theories (theory 'loop-defs) + (theory 'clock-defs)))) + +(in-theory (set-difference-theories (current-theory :here) + (theory 'model-defs))) + diff --git a/books/workshops/2003/kaufmann/support/rtl/model-macros.lisp b/books/workshops/2003/kaufmann/support/rtl/model-macros.lisp new file mode 100644 index 0000000..8e19a6e --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/model-macros.lisp @@ -0,0 +1,8 @@ +(in-package "ACL2") + +(defmacro out1 (n) + (list 'out1$ n '$path)) + +(defmacro out2 (n) + (list 'out2$ n '$path)) + diff --git a/books/workshops/2003/kaufmann/support/rtl/model-raw.lisp b/books/workshops/2003/kaufmann/support/rtl/model-raw.lisp new file mode 100644 index 0000000..8fb0a9a --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/model-raw.lisp @@ -0,0 +1,76 @@ +(in-package "ACL2") + +(include-book "ordinals/e0-ordinal" :dir :system) +(set-well-founded-relation e0-ord-<) + +(set-inhibit-warnings "THEORY" "DISABLE" "NON-REC") + +(include-book "common") + +(local + (in-theory + (set-difference-theories (current-theory :here) + (theory 'rtl-operators-after-macro-expansion)))) + +(defmacro FOO$RAW::out1 (n) + (list 'FOO$RAW::out1$ n '$path)) + +(defmacro FOO$RAW::out2 (n) + (list 'FOO$RAW::out2$ n '$path)) + +(set-irrelevant-formals-ok t) + +(set-ignore-ok t) + +(deflabel model-raw-start-of-defs) + +(set-bogus-mutual-recursion-ok t) + +(MUTUAL-RECURSION + +(defun FOO$RAW::out2$ (n $path) + (declare (xargs :normalize + nil :measure (cons (1+ (nfix n)) 0))) + (if (zp n) + (reset 'ACL2::OUT2 4) + (mod+ (cat (n! 0 1) + 1 (bits (ww (1- n)) 2 0) + 3) + (n! 1 4) + 4))) + +(defun FOO$RAW::out1$ (n $path) + (declare (xargs :normalize + nil :measure (cons (1+ (nfix n)) 1))) + (bind case-select (bits (sel n) 1 0) + (if1 (log= (n! 0 2) case-select) + (bitn (in0 n) 0) + (if1 (log= (n! 1 2) case-select) + (bitn (in1 n) 0) + (if1 (log= (n! 2 2) case-select) + (bitn (in2 n) 0) + (if1 (log= (n! 3 2) case-select) + (bitn (in3 n) 0) + (n! 0 1))))))) + +) + +(add-macro-alias FOO$RAW::out1 FOO$RAW::out1$) + +(add-macro-alias FOO$RAW::out2 FOO$RAW::out2$) + +(deflabel model-raw-end-of-defs) + +(deftheory raw-tmp-names 'nil) + +(deftheory + model-raw-defs + (union-theories + (set-difference-theories (current-theory 'model-raw-end-of-defs) + (current-theory 'model-raw-start-of-defs)) + (union-theories (theory 'loop-defs) + (theory 'clock-defs)))) + +(in-theory (set-difference-theories (current-theory :here) + (theory 'model-raw-defs))) + diff --git a/books/workshops/2003/kaufmann/support/rtl/package-defs.acl2 b/books/workshops/2003/kaufmann/support/rtl/package-defs.acl2 new file mode 100644 index 0000000..e5ce1fd --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/package-defs.acl2 @@ -0,0 +1,3 @@ +(acl2::value :q) +(acl2::lp) +(certify-book "package-defs" ? t) diff --git a/books/workshops/2003/kaufmann/support/rtl/package-defs.lisp b/books/workshops/2003/kaufmann/support/rtl/package-defs.lisp new file mode 100644 index 0000000..98f4828 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/package-defs.lisp @@ -0,0 +1,33 @@ +(in-package "ACL2") + +;;Miscellaneous symbols that are not in *acl2-exports*: + +(defmacro other-acl2-symbols () + ''(local-defun local-defthm local-in-theory + $path ; path argument of signal functions + )) + +(defmacro rtl-symbols () + ''(log= log<> log< log<= log> log>= lnot logand1 logior1 logxor1 shft lshft + rshft cat mulcat bitn bits setbits setbitn mod+ mod* mod- bind + case-select if1 cond1 reset reset2 land lior lxor lcat n! arr0 natp1 + as ag mk-bvarr mk-bvec ag2 as2 + unknown unknown2)) + +;;Functions that are defined in the FP library: + +(defmacro fp-symbols () + ''(natp fl cg fl-half bvecp bv-arrp sumbits sigm kap tau lamt lamg lamz lam1 lam2 lam3 lam4 lam0 lamb + expo sgn sig + exactp fp+ bias esgnf eexpof esigf erepp eencodingp eencode edecode ndecode rebias-expo isgnf iexpof isigf + nrepp drepp irepp nencodingp dencodingp iencodingp nencode dencode iencode ddecode idecode trunc away re + near near-witness near+ sticky oddr kp inf minf ieee-mode-p rnd flip rnd-const drnd)) + +;;ACL2 symbols that are imported by all packages: + +(defmacro shared-symbols () + '(union-eq *acl2-exports* + (union-eq *common-lisp-symbols-from-main-lisp-package* + (union-eq (other-acl2-symbols) + (union-eq (fp-symbols) + (rtl-symbols)))))) diff --git a/books/workshops/2003/kaufmann/support/rtl/pkgs.lsp b/books/workshops/2003/kaufmann/support/rtl/pkgs.lsp new file mode 100644 index 0000000..0868f4b --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/pkgs.lsp @@ -0,0 +1,23 @@ +(in-package "ACL2") + +(defconst *old2new-pkg-alist* + '(("FOO$RAW" . "ACL2"))) + +(include-book "package-defs") + +(defconst *defrom-imports* 'nil) + +(defconst *loop-vars* 'nil) + +(defconst *loop-fns* 'nil) + +(defconst *all-imports* + (append *loop-vars* *defrom-imports* + *loop-fns* (shared-symbols))) + +(defconst *foo-inputs* + '(in0 in1 in2 in3 sel ww clk)) + +(defpkg "FOO$RAW" + (append *foo-inputs* *all-imports*)) + diff --git a/books/workshops/2003/kaufmann/support/rtl/results/bvecp.lisp b/books/workshops/2003/kaufmann/support/rtl/results/bvecp.lisp new file mode 100644 index 0000000..1cfc0c9 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/results/bvecp.lisp @@ -0,0 +1,19 @@ +(in-package "ACL2") + +(include-book "model") + +(local (include-book "model-eq")) + +(local (include-book "bvecp-raw")) + +(local (include-book "rtl/rel4/support/bvecp-helpers" + :dir :system)) + +(defbvecp out1 (n) + 1 + :hints (("Goal" :use foo$raw::bvecp$out1))) + +(defbvecp out2 (n) + 4 + :hints (("Goal" :use foo$raw::bvecp$out2))) + diff --git a/books/workshops/2003/kaufmann/support/rtl/results/cert_pl_exclude b/books/workshops/2003/kaufmann/support/rtl/results/cert_pl_exclude new file mode 100644 index 0000000..dd7b6c6 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/results/cert_pl_exclude @@ -0,0 +1,8 @@ +cert_pl_exclude + +The presence of this file tells cert.pl not to try to build any of the books in +this directory. + +This directory contains books not to be certified. Rather, they are +here for comparison with files that are generated; see the `diff' +calls in ../Makefile. diff --git a/books/workshops/2003/kaufmann/support/rtl/results/model-eq.lisp b/books/workshops/2003/kaufmann/support/rtl/results/model-eq.lisp new file mode 100644 index 0000000..ac1b32f --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/results/model-eq.lisp @@ -0,0 +1,161 @@ +(in-package "ACL2") + +(local (defun %%sub1-induction (n) + (if (zp n) + n (%%sub1-induction (1- n))))) + +(local (defun %%and-tree-fn (args len) + (declare (xargs :mode :program)) + (if (< len 20) + (cons 'and args) + (let* ((len2 (floor len 2))) + (list 'and + (%%and-tree-fn (take len2 args) len2) + (%%and-tree-fn (nthcdr len2 args) + (- len len2))))))) + +(local (defmacro %%and-tree (&rest args) + (%%and-tree-fn args (length args)))) + +(local (include-book "bvecp-raw")) + +(local (include-book "rtl/rel4/lib/top" + :dir :system)) + +(local (include-book "rtl/rel4/lib/simplify-model-helpers" + :dir :system)) + +(include-book "model-raw") + +(include-book "model") + +(local (table user-defined-functions-table + nil nil :clear)) + +(local (disable-forcing)) + +(local (deftheory theory-0 (theory 'minimal-theory))) + +(local (defmacro %%p0-equalities nil + '(%%and-tree (equal (out1$ n $path) + (foo$raw::out1$ n $path)) + (equal (out2$ n $path) + (foo$raw::out2$ n $path))))) + +(local (defun %%p0-aux (n $path) + (declare (xargs :normalize nil)) + (%%p0-equalities))) + +(local (defun-sk %%p0 (n) + (forall ($path) (%%p0-aux n $path)))) + +(local (defthm %%p0-implies-%%p0-aux + (implies (%%p0 n) (%%p0-aux n $path)))) + +(local (encapsulate + nil + (local (defthm %%p0-property-lemma + (implies (%%p0-aux n $path) + (%%p0-equalities)) + :rule-classes nil + :instructions ((:dv 1) + (:expand nil) + :top + (:generalize ((%%p0-equalities) eqs)) + :s))) + (defthm %%p0-property + (implies (%%p0 n) (%%p0-equalities)) + :instructions ((:use %%p0-property-lemma) + (:generalize ((%%p0-equalities) eqs)) + :prove)))) + +(local + (deftheory %%p0-implies-f-is-%f-theory + (union-theories (set-difference-theories (current-theory :here) + (current-theory '%%p0)) + (theory 'minimal-theory)))) + +(local + (encapsulate + nil + (local (in-theory (disable %%p0-property))) + (local (defthm out2$-is-out2$-base + (implies (zp n) + (equal (out2$ n $path) + (foo$raw::out2$ n $path))) + :hints (("Goal" :expand ((out2$ n $path) + (foo$raw::out2$ n $path)))))) + (local (defthm out1$-is-out1$-base + (implies (zp n) + (equal (out1$ n $path) + (foo$raw::out1$ n $path))) + :hints (("Goal" :expand ((out1$ n $path) + (foo$raw::out1$ n $path)))))) + (defthm %%p0-base (implies (zp n) (%%p0 n)) + :instructions (:promote :x-dumb (:s :normalize nil))))) + +(local + (encapsulate + nil + (local (in-theory (disable %%p0 %%p0-base))) + (local (deflabel %%induction-start)) + (local (defthm out2$-is-out2$-induction_step + (implies (and (not (zp n)) (%%p0 (1- n))) + (equal (out2$ n $path) + (foo$raw::out2$ n $path))) + :instructions (:promote (:dv 1) + :x-dumb + :nx :x-dumb + :top (:s :normalize nil + :backchain-limit 1000 + :expand :lambdas + :repeat 4)))) + (local (defthm out1$-is-out1$-induction_step + (implies (and (not (zp n)) (%%p0 (1- n))) + (equal (out1$ n $path) + (foo$raw::out1$ n $path))) + :instructions (:promote (:dv 1) + :x-dumb + :nx :x-dumb + :top (:s :normalize nil + :backchain-limit 1000 + :expand :lambdas + :repeat 4)))) + (defthm %%p0-induction_step + (implies (and (not (zp n)) (%%p0 (1- n))) + (%%p0 n)) + :instructions (:promote :x-dumb (:s :normalize nil))))) + +(local + (defthm + %%p0-holds (%%p0 n) + :hints + (("Goal" :induct (%%sub1-induction n) + :do-not '(preprocess) + :in-theory (union-theories '(%%p0-base %%p0-induction_step + (:induction %%sub1-induction)) + (theory 'minimal-theory)))))) + +(ENCAPSULATE + ( + ) + + (local (in-theory (union-theories '(%%p0-holds) + (theory '%%p0-implies-f-is-%f-theory)))) + + (defthm out2$-is-out2$ + (equal (out2$ n $path) + (foo$raw::out2$ n $path)) + :hints (("Goal" :do-not '(preprocess)))) + + (defthm out1$-is-out1$ + (equal (out1$ n $path) + (foo$raw::out1$ n $path)) + :hints (("Goal" :do-not '(preprocess)))) + +) + +(deftheory %-removal-theory + (union-theories '(out1$-is-out1$ out2$-is-out2$) + (theory 'minimal-theory))) + diff --git a/books/workshops/2003/kaufmann/support/rtl/results/model.lisp b/books/workshops/2003/kaufmann/support/rtl/results/model.lisp new file mode 100644 index 0000000..2b32103 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/results/model.lisp @@ -0,0 +1,59 @@ +(in-package "ACL2") + +(include-book "ordinals/e0-ordinal" + :dir :system) + +(set-well-founded-relation e0-ord-<) + +(set-inhibit-warnings "THEORY" "DISABLE" "NON-REC") + +(include-book "common") + +(include-book "model-macros") + +(set-irrelevant-formals-ok t) + +(set-ignore-ok t) + +(deflabel model-start-of-defs) + +(set-bogus-mutual-recursion-ok t) + +(MUTUAL-RECURSION + +(defun out2$ (n $path) + (declare (xargs :normalize nil + :measure (cons (1+ (nfix n)) 0))) + (if (zp n) + (reset 'out2 4) + (bits (+ 1 (ww (+ -1 n))) 3 0))) + +(defun out1$ (n $path) + (declare (xargs :normalize nil + :measure (cons (1+ (nfix n)) 1))) + (cond1 ((log= 0 (sel n)) (in0 n)) + ((log= 1 (sel n)) (in1 n)) + ((log= 2 (sel n)) (in2 n)) + ((log= 3 (sel n)) (in3 n)) + (t 0))) + +) + +(add-macro-alias out1 out1$) + +(add-macro-alias out2 out2$) + +(deflabel model-end-of-defs) + +(deftheory tmp-names 'nil) + +(deftheory + model-defs + (union-theories (set-difference-theories (current-theory 'model-end-of-defs) + (current-theory 'model-start-of-defs)) + (union-theories (theory 'loop-defs) + (theory 'clock-defs)))) + +(in-theory (set-difference-theories (current-theory :here) + (theory 'model-defs))) + diff --git a/books/workshops/2003/kaufmann/support/rtl/tool/Makefile b/books/workshops/2003/kaufmann/support/rtl/tool/Makefile new file mode 100644 index 0000000..d5fc0f5 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/tool/Makefile @@ -0,0 +1,2 @@ +include ../../../../../../Makefile-generic +-include Makefile-deps diff --git a/books/workshops/2003/kaufmann/support/rtl/tool/file-io-pkgs.lisp b/books/workshops/2003/kaufmann/support/rtl/tool/file-io-pkgs.lisp new file mode 100644 index 0000000..6fb5c3e --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/tool/file-io-pkgs.lisp @@ -0,0 +1,188 @@ +(in-package "ACL2") + +; There are two ways in which we want to print forms respecting packages. When +; generating definitions originally, we may prefer to view the symbols as +; package-less (although they will actually be ACL2 or built-in symbols) and +; simply port the entire form to a new package, which might not even exist. In +; the other case we have a form that is considered to have real symbols in it, +; and we want to print out an equal form that however has a package prefix. So +; we have write-list-into-pkgs, which prints pkg-name::form when presented with +; (:pkg pkg-name . form), and write-list-using-pkgs, which prints form as an +; equal form using pkg-name::form'. + +(include-book "misc/file-io" :dir :system) + +(set-state-ok t) +(program) + +(defun change-pkg-for-form (form state) + (if (and (consp form) + (member-eq (car form) '(defun defthm)) + (consp (cdr form)) + (symbolp (cadr form))) + (let ((package-name (symbol-package-name (cadr form)))) + (if (equal package-name "ACL2") + (value nil) + (in-package-fn package-name state))) + (value nil))) + +(mutual-recursion + +(defun pprint-object-or-string-using-pkg (obj indent channel state) + (cond + ((stringp obj) + (princ$ obj channel state)) + ((and (consp obj) + (eq (car obj) 'encapsulate) + (consp (cdr obj))) + (pprogn (princ$ "(ENCAPSULATE" channel state) + (newline channel state) + (princ$ " (" channel state) + (newline channel state) + (write-objects-using-pkgs (cadr obj) (+ indent 2) channel state) + (princ$ " )" channel state) + (newline channel state) + (newline channel state) + (write-objects-using-pkgs (cddr obj) (+ indent 1) channel state) + (princ$ ")" channel state))) + ((and (consp obj) + (eq (car obj) 'mutual-recursion)) + (pprogn (princ$ "(MUTUAL-RECURSION" channel state) + (newline channel state) + (newline channel state) + (write-objects-using-pkgs (cdr obj) indent channel state) + (princ$ ")" channel state))) + (t + (mv-let (erp val state) + (state-global-let* + ((write-for-read t)) + (er-let* + ((new-pkg (change-pkg-for-form obj state))) + (pprogn + (if new-pkg + (pprogn (spaces indent 0 channel state) + (princ$ new-pkg channel state) + (princ$ "::" channel state) + (newline channel state)) + state) + (if (int= indent 0) ; optimization + state + (spaces indent 0 channel state)) + (ppr2 (ppr1 obj (print-base) (print-radix) (- 80 indent) 0 state t) + indent channel state t) + (if new-pkg + (in-package-fn "ACL2" state) + (value nil))))) + (declare (ignore erp val)) + state)))) + +(defun write-objects-using-pkgs (list indent channel state) + (if (consp list) + (pprogn (pprint-object-or-string-using-pkg (car list) indent channel + state) + (newline channel state) + (newline channel state) + (write-objects-using-pkgs (cdr list) indent channel state) + state) + state)) + +) + +(defun write-list-using-pkgs (list fname ctx state) + (mv-let (channel state) + (open-output-channel fname :character state) + (if channel + (mv-let + (col state) + (fmt1 "Writing file ~x0~%" (list (cons #\0 fname)) + 0 (standard-co state) state nil) + (declare (ignore col)) + (let ((state (write-objects-using-pkgs list 0 channel state))) + (pprogn (close-output-channel channel state) + (value :invisible)))) + (er soft ctx + "Unable to open file ~s0 for :character output." + fname)))) + +; Now for write-list-into-pkgs. + +(mutual-recursion + +(defun pprint-object-or-string-into-pkg (obj indent channel state) + (cond + ((stringp obj) + (princ$ obj channel state)) + ((and (consp obj) + (eq (car obj) 'encapsulate) + (consp (cdr obj))) + (pprogn (princ$ "(ENCAPSULATE" channel state) + (newline channel state) + (princ$ " (" channel state) + (newline channel state) + (write-objects-into-pkgs (cadr obj) (+ indent 2) channel state) + (princ$ " )" channel state) + (newline channel state) + (newline channel state) + (write-objects-into-pkgs (cddr obj) (+ indent 1) channel state) + (princ$ ")" channel state))) + ((and (consp obj) + (eq (car obj) 'mutual-recursion)) + (pprogn (princ$ "(MUTUAL-RECURSION" channel state) + (newline channel state) + (newline channel state) + (write-objects-into-pkgs (cdr obj) indent channel state) + (princ$ ")" channel state))) + (t + (mv-let (erp val state) + (state-global-let* + ((write-for-read t)) + (let* ((new-pkg (and (consp obj) + (eq (car obj) :pkg) + (consp (cdr obj)) + (stringp (cadr obj)) + (cadr obj))) + (form (if new-pkg (cddr obj) obj))) + (pprogn + (if new-pkg + (pprogn (spaces indent 0 channel state) + (princ$ new-pkg channel state) + (princ$ "::" channel state) + (newline channel state)) + state) + (if (int= indent 0) ; optimization + state + (spaces indent 0 channel state)) + (ppr2 (ppr1 form (print-base) (print-radix) (- 80 indent) 0 + state t) + indent channel state t) + (value nil)))) + (declare (ignore erp val)) + state)))) + +(defun write-objects-into-pkgs (list indent channel state) + (if (consp list) + (pprogn (pprint-object-or-string-into-pkg (car list) indent channel + state) + (newline channel state) + (newline channel state) + (write-objects-into-pkgs (cdr list) indent channel state) + state) + state)) + +) + +(defun write-list-into-pkgs (list fname ctx state) + (mv-let (channel state) + (open-output-channel fname :character state) + (if channel + (mv-let + (col state) + (fmt1 "Writing file ~x0~%" (list (cons #\0 fname)) + 0 (standard-co state) state nil) + (declare (ignore col)) + (let ((state (write-objects-into-pkgs list 0 channel state))) + (pprogn (close-output-channel channel state) + (value :invisible)))) + (er soft ctx + "Unable to open file ~s0 for :character output." + fname)))) diff --git a/books/workshops/2003/kaufmann/support/rtl/tool/simplify-defuns.lisp b/books/workshops/2003/kaufmann/support/rtl/tool/simplify-defuns.lisp new file mode 100644 index 0000000..c9a1ce1 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/tool/simplify-defuns.lisp @@ -0,0 +1,1181 @@ +; simplify-defuns.lisp -- see simplify-defuns.txt for documentation +; Copyright (C) 2002 Matt Kaufmann +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; TABLE OF CONTENTS +;;; ----------------- +;;; Term Simplification +;;; Creating/Destroying % Symbols +;;; Definition and Lemma Generation (except lemmas for mutual-recursion) +;;; Lemma Generation for Mutual-recursion +;;; Translating Lemmas +;;; Top Level Routines +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "ACL2") + +(program) +(set-state-ok t) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Term Simplification +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun simplify-term1 (ttree term hyps equiv thints prove-assumptions ctx wrld + state) + +; Adapted from tool2-fn in books/misc/expander.lisp. + + (prog2$ + (initialize-brr-stack state) + (let* ((ens (ens state)) + (saved-pspv (make-pspv ens wrld state + :displayed-goal term ; from, e.g., thm-fn + :user-supplied-term term ;from, e.g., prove + :orig-hints thints)) ;from, e.g., prove + (new-lit (fcons-term* 'equal (fcons-term* 'hide 'xxx) term)) + (current-clause (add-literal new-lit + (dumb-negate-lit-lst hyps) t))) + (er-let* ;from waterfall1 + ((pair + (find-applicable-hint-settings + *initial-clause-id* + current-clause + nil saved-pspv ctx + thints wrld nil state))) + (let ((hint-settings (car pair)) + (thints (cdr pair))) + (mv-let + (hint-settings state) + (cond ((null hint-settings) + (mv nil state)) + (t (thanks-for-the-hint nil hint-settings nil state))) ;BB + (er-let* ((pspv (load-hint-settings-into-pspv + t hint-settings saved-pspv nil wrld ctx state))) + (cond + ((intersectp-eq + '(:do-not-induct :do-not :induct :use :cases :by) + (strip-cars hint-settings)) + (er soft ctx + "It makes no sense for SIMPLIFY-TERM to be given hints for ~ + \"Goal\" that include any of :do-not-induct, :do-not, ~ + :induct, :use, :cases, or :by. The hint ~p0 is therefore ~ + illegal." + (cons "Goal" hint-settings))) + (t (pprogn + (initialize-proof-tree ;from waterfall + *initial-clause-id* + (list (list (implicate (conjoin hyps) term))) + ctx + state) + (let* ;from simplify-clause1 + ((rcnst + (change rewrite-constant + (access prove-spec-var pspv :rewrite-constant) + :force-info + (if (ffnnamep-lst 'if current-clause) + 'weak + t))) + (pts nil)) + (mv-let + (contradictionp type-alist fc-pair-lst) + (forward-chain current-clause + pts + (access rewrite-constant + rcnst :force-info) + nil wrld ens (match-free-override wrld) + state) + (declare (ignore fc-pair-lst)) + (cond + (contradictionp + (er soft ctx + "Contradiction found in hypotheses using type-set ~ + reasoning!")) + (t + (sl-let ;from simplify-clause1 + (contradictionp simplify-clause-pot-lst) + (setup-simplify-clause-pot-lst current-clause + (pts-to-ttree-lst + pts) + nil ; fc-pair-lst ;; RBK: + type-alist + rcnst + wrld state + (initial-step-limit + wrld state)) + (cond + (contradictionp + (er soft ctx + "Contradiction found in hypotheses using linear ~ + reasoning!")) + (t + +; We skip the call of process-equational-polys in simplify-clause1; I think +; that we can assume that by the time this is called, that call wouldn't have +; any effect anyhow. By the way, we skipped remove-trivial-equivalence +; earlier. + +; Now we continue as in rewrite-clause. + + (let ((local-rcnst + (change rewrite-constant rcnst + :current-literal + (make current-literal + :not-flg nil + :atm term))) + (gstack (initial-gstack 'simplify-clause + nil + current-clause))) + (sl-let + (rewritten-term ttree) + (rewrite-entry + (rewrite term nil 1) + :rdepth (rewrite-stack-limit wrld) + :obj '? + :fnstack nil + :ancestors nil + :backchain-limit 500 + :step-limit step-limit + :geneqv + (cadr (car (last (getprop + equiv + 'congruences + nil + 'current-acl2-world + wrld)))) + :pequiv-info nil) + (sl-let + (bad-ass ttree) + (resume-suspended-assumption-rewriting + ttree + nil + gstack + simplify-clause-pot-lst + local-rcnst + wrld + state + step-limit) + (cond + (bad-ass + (er soft ctx + "Generated false assumption, ~p0! So, ~ + rewriting is aborted, just as it would be ~ + in the course of a regular ACL2 proof." + bad-ass)) + (prove-assumptions + (mv-let + (pairs pspv state) + (process-assumptions + 0 + (change prove-spec-var saved-pspv + :tag-tree + (set-cl-ids-of-assumptions + ttree *initial-clause-id*)) + wrld state) + (er-let* + ((ttree + (accumulate-ttree-and-step-limit-into-state + (access prove-spec-var pspv :tag-tree) + step-limit + state)) + (thints (value thints))) + (er-let* + ((new-ttree + (prove-loop1 1 nil pairs pspv + thints ens wrld ctx state))) + (value (cons rewritten-term + (cons-tag-trees + ttree + new-ttree))))))) + (t + (value (cons rewritten-term + ttree)))))))))))))))))))))))) + +(defun simplify-term* (remaining-iters ttree term hyps equiv thints + prove-assumptions ctx wrld state) + (if (zp remaining-iters) + (value (list* term t ttree)) + (er-let* + ((term-ttree (simplify-term1 ttree term hyps equiv thints + prove-assumptions ctx wrld state))) + (if (equal term (car term-ttree)) + (value (list* term nil ttree)) + (simplify-term* (1- remaining-iters) (cdr term-ttree) (car term-ttree) + hyps equiv thints prove-assumptions ctx wrld state))))) + +(defun simplify-term + (repeat-limit translate-flg inhibit-output form hyps equiv hints + prove-assumptions ctx wrld state) + (state-global-let* + ((inhibit-output-lst + (if inhibit-output + (union-eq '(proof-tree prove) (@ inhibit-output-lst)) + (@ inhibit-output-lst)))) + (let ((name-tree 'simplify-term)) + (er-let* + ((thints (translate-hints name-tree hints ctx wrld state)) + (thyps (if translate-flg + (translate-term-lst hyps t t t ctx wrld state) + (value hyps))) + (term (if translate-flg + (translate form t t t ctx wrld state) + (value form)))) + (simplify-term* repeat-limit nil term hyps equiv thints prove-assumptions + ctx wrld state))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Creating/Destroying % Symbols +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; All the code for dealing with % should be in this section. So, it should be +; easy enough to modify the code to use other naming schemes. + +; Each pkg-alist argument is an alist associating old package names with new +; package names. + +(defun old2new (sym pkg-alist) + (let ((name (symbol-name sym))) + (if (eq pkg-alist t) + (let ((len (length name))) + (if (and (not (int= len 0)) + (eq (char name 0) #\%)) + (intern-in-package-of-symbol (subseq name 1 len) sym) + sym)) + (let* ((pkg (symbol-package-name sym)) + (pair (assoc-equal pkg pkg-alist))) + (if pair + (intern$ name (cdr pair)) + sym))))) + +(defun old2new-list (sym-list pkg-alist acc) + +; NOTE: Reverses the list. + + (if (endp sym-list) + acc + (old2new-list + (cdr sym-list) + pkg-alist + (cons (old2new (car sym-list) pkg-alist) + acc)))) + +(mutual-recursion + +(defun old2new-term (term pkg-alist) + (cond + ((variablep term) term) + ((fquotep term) term) + ((flambdap (ffn-symb term)) + +; ((lambda (vars) body) . args) + + (let ((vars (lambda-formals (ffn-symb term))) + (body (lambda-body (ffn-symb term))) + (args (fargs term))) + (fcons-term (make-lambda vars (old2new-term body pkg-alist)) + (old2new-term-lst args pkg-alist nil)))) + (t + (fcons-term (old2new (ffn-symb term) pkg-alist) + (old2new-term-lst (fargs term) pkg-alist nil))))) + +(defun old2new-term-lst (x pkg-alist acc) + (cond ((endp x) (reverse acc)) + (t (old2new-term-lst (cdr x) + pkg-alist + (cons (old2new-term (car x) pkg-alist) acc))))) + +) + +(defconst *%%p* "%%P") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Definition and Lemma Generation (except lemmas for mutual-recursion) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun sublis-fn! (alist term) + (mv-let (erp new-term) + (sublis-fn alist term nil) + (assert$ (null erp) + new-term))) + +(defun %f-is-f-lemmas-rev (%f f formals-decls orig-body + untranslated-new-body + translated-new-body + counter old-theory wrld) + +; Conses, in reverse order, all new lemmas for proving %f-is-f. This should +; not be called for mutually recursive functions. + + (let* ((%f-name (symbol-name %f)) + (f-name (symbol-name f)) + (%%f-name (concatenate 'string "%" %f-name)) + (%%f (intern-in-package-of-symbol %%f-name %f)) + (f-body-is-%f-body_s + (intern-in-package-of-symbol + (concatenate 'string f-name "-BODY-IS-" %f-name "-BODY_S") + %f)) + (%%f-is-f + (intern-in-package-of-symbol + (concatenate 'string %%f-name "-IS-" f-name) + %f)) + (f-is-%f + (intern-in-package-of-symbol + (concatenate 'string f-name "-IS-" %f-name) + %f)) + (new-theory + (intern (concatenate 'string "THEORY-" + (coerce (explode-atom (1+ counter) 10) + 'string)) + "ACL2")) + (recp + +; We use %f below even though f might be slightly better, because that way only +; the input defs need to be included. + + (getprop %f 'recursivep nil 'current-acl2-world wrld)) + (formals (car formals-decls)) + (%%f-formals (cons %%f formals)) + ( %f-formals (cons %f formals)) + ( f-formals (cons f formals)) + (equal-bodies (and (not recp) + (equal untranslated-new-body orig-body)))) + +; The lemmas below are in reverse order. + + `((local + (deftheory ,new-theory + (union-theories '(,f-is-%f) + (theory ',old-theory)))) + + (defthm ,f-is-%f + (equal ,f-formals + ,%f-formals) + :hints (,(if recp + `("Goal" + :by + (:functional-instance + ,%%f-is-f + (,%%f ,%f)) + :do-not '(preprocess) ; avoid dumb clausifier + :expand (,%f-formals)) + `("Goal" :expand + +; Uh oh: simplification can replace a formal with a constant. Since %f and f +; are non-recursive, it is safe to cause all calls to be expanded. + + ((:free ,formals ,%f-formals) + (:free ,formals ,f-formals)) + :in-theory (theory ',old-theory) + :do-not '(preprocess) ; avoid dumb clausifier + ,@(and (not equal-bodies) + `(:use ,f-body-is-%f-body_s)))))) + + ,@(cond + (recp `((local + (defthm ,%%f-is-f + (equal ,%%f-formals + ,f-formals) + :hints (("Goal" + :in-theory + (union-theories + '((:induction ,%%f)) + (theory ',old-theory)) + :do-not '(preprocess) ; avoid dumb clausifier + :expand (,%%f-formals ,f-formals) + :induct t)))) + (local + (defun ,%%f ,formals + ,@(cdr formals-decls) ; to include original measure etc. + ,(untranslate (sublis-fn! (list (cons %f %%f)) + translated-new-body) + nil wrld))))) + (equal-bodies nil) + (t `((local + (defthm ,f-body-is-%f-body_s + +; Presumably the same simplification that created %body_s from %body should +; prove this theorem. + + (equal ,untranslated-new-body ,orig-body) + :hints (("Goal" :do-not '(preprocess) ; avoid dumb clausifier + )) + :rule-classes nil)))))))) + +(defun get-state-value (sym state) + (if (f-boundp-global sym state) + (f-get-global sym state) + nil)) + +(defun simplify-repeat-limit (state) + +; This supplies the number of iterations of our calls to the rewriter. + + (or (get-state-value 'simplify-repeat-limit state) + +; We could play with this limit. But see the comment about +; simplify-repeat-limit in f-is-%f-induction-step-lemmas. + + 3)) + +(defun simplify-inhibit (state) + (let ((val (get-state-value 'simplify-inhibit state))) + (case val + ((t) nil) + ((nil) '(prove proof-tree warning observation event summary)) + (otherwise val)))) + +(defun simplify-defun (info def lemmas counter old-theory pkg-alist ens wrld + state) + +; Def is (defun %foo ...) or (defund %foo ...). + +; We return (mv erp new-def lemmas-out counter latest-theory state), where +; lemmas-out extends lemmas but is equal to lemmas if info is 'mut-rec. +; Except, if def is not intended to be simplified, new-def is nil. + +; WARNING: This function does not modify the declare forms of def, even if %f +; is mentioned in those declare forms. + + (declare (ignore ens)) + (let* ((fn (cadr def)) + (new-fn (old2new fn pkg-alist)) + (orig-body (car (last def)))) + (if (eq new-fn fn) + (mv nil nil lemmas counter old-theory state) + (mv-let + (erp simp state) + (simplify-term (simplify-repeat-limit state) + t ; translate-flg + (simplify-inhibit state) + orig-body + nil ;hyps + 'equal ; equiv + nil ; hints + t ; prove-assumptions + 'simplify-defun wrld state) + (if erp + (mv-let (erp val state) + (er soft 'simplify-defun + "Simplification failed for the definition of ~x0." + fn) + (declare (ignore erp val)) + (mv t nil nil counter old-theory state)) + (let* ((new-body (car simp)) + (untranslated-new-body + (untranslate new-body nil wrld)) + (new-body-stripped (old2new-term new-body pkg-alist)) + (untranslated-new-body-stripped + (untranslate new-body-stripped nil wrld)) + (formals-decls (butlast (cddr def) 1)) + (new-lemmas + (if (eq info 'mut-rec) + nil + (%f-is-f-lemmas-rev fn new-fn formals-decls + orig-body + untranslated-new-body + new-body + counter old-theory wrld))) + (first-new-lemma (car new-lemmas)) + (new-theory-p + (case-match first-new-lemma + (('local ('deftheory . &)) + t) + (& nil))) + (new-theory + (if new-theory-p + (cadr (cadr first-new-lemma)) + old-theory)) + (new-counter (if new-theory-p (1+ counter) counter))) + (mv nil + `(;;,(if (enabled-runep (list :definition fn) ens wrld) 'defun 'defund) + defun + ,new-fn + ,@formals-decls + ,untranslated-new-body-stripped) + (append new-lemmas lemmas) + new-counter + new-theory + state))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Lemma Generation for Mutual-recursion +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun mut-rec-formals (defs formals) + +; We return a list containing the formal parameters common to all the defs +; (each of the form (defun ...)) if there is one, else nil. We will be +; assuming that recursion is on the first and the others are unchangeable. + + (if (endp defs) + formals + (let* ((def (car defs)) + (new-formals (and (true-listp def) (caddr def)))) + (and (or (null formals) + (equal formals new-formals)) + (mut-rec-formals (cdr defs) new-formals))))) + +(defun f-is-%f-list (defs formals pkg-alist acc) + +; Returns a list of (equal (f . formals) (%f . formals)) in forward order. + + (if (endp defs) + acc + (f-is-%f-list (cdr defs) + formals + pkg-alist + (let* ((%f (cadar defs)) + (f (old2new %f pkg-alist))) + (if (eq %f f) + acc + (cons `(equal (,f ,@formals) + (,%f ,@formals)) + acc)))))) + +(defun f-is-%f-base-lemmas (f-is-%f-list formals zp-formals acc) + +; Result is in correct order if f-is-%f-list is in reverse order. + + (if (endp f-is-%f-list) + acc + (f-is-%f-base-lemmas + (cdr f-is-%f-list) + formals zp-formals + (cons (let* ((equality (car f-is-%f-list)) + ( f (car (cadr equality))) + (%f (car (caddr equality))) + (lemma-name + (intern-in-package-of-symbol + (concatenate 'string + (symbol-name f) + "-IS-" + (symbol-name %f) + "-BASE") + f))) + `(local + (defthm ,lemma-name + (implies ,zp-formals + ,equality) + +; Experimentation shows that it can be valuable first to expand without doing +; any real simplification, and then to rewrite. We have seen assumptions get +; generated when we allow the current-theory in "Goal". + + :hints (("Goal" :expand (( ,f ,@formals) + (,%f ,@formals)))) +#| + :hints (("Goal" :expand (( ,f ,@formals) + (,%f ,@formals)) + :do-not '(preprocess) + :in-theory (theory 'minimal-theory)) + '(:computed-hint-replacement + t + :in-theory (current-theory :here))) +|# + ))) + acc)))) + +(defun f-is-%f-induction-step-lemmas (f-is-%f-list formals hyp acc) + +; Result is in correct order if %f-is-f-list is in reverse order. + + (if (endp f-is-%f-list) + acc + (f-is-%f-induction-step-lemmas + (cdr f-is-%f-list) + formals hyp + (cons (let* ((equality (car f-is-%f-list)) + ( f (car (cadr equality))) + (%f (car (caddr equality))) + (lemma-name + (intern-in-package-of-symbol + (concatenate 'string + (symbol-name f) + "-IS-" + (symbol-name %f) + "-INDUCTION_STEP") + f)) + (f-formals (cons f formals)) + (%f-formals (cons %f formals))) + `(local + (defthm ,lemma-name + (implies ,hyp + (equal ,f-formals ,%f-formals)) + :instructions + (:promote + (:dv 1) + :x-dumb :nx :x-dumb :top + (:s :normalize nil :backchain-limit 1000 + :expand :lambdas + :repeat + +; Probably 3 is enough, because of simplify-repeat-limit. At any rate, we need +; at least 1 in order to apply the earlier such lemmas to the body of f. + + 4))))) + acc)))) + +(defun f-is-%f-lemmas-mut-rec (f-is-%f-list formals acc) + +; Result is in correct order if f-is-%f-list is in reverse order. + + (if (endp f-is-%f-list) + acc + (f-is-%f-lemmas-mut-rec + (cdr f-is-%f-list) + formals + (cons (let* ((equality (car f-is-%f-list)) + ( f (car (cadr equality))) + (%f (car (caddr equality))) + (lemma-name + (intern-in-package-of-symbol + (concatenate 'string + (symbol-name f) + "-IS-" + (symbol-name %f)) + f))) + `(defthm ,lemma-name + (equal (,f ,@formals) (,%f ,@formals)) + :hints (("Goal" :do-not '(preprocess))))) + acc)))) + +(defun mutual-recursion-lemmas (formals f-is-%f-list counter old-theory) + +; The lemmas need to be returned in reverse order. + + (let* ((%%p-name (concatenate 'string + *%%p* + (coerce (explode-atom counter 10) + 'string))) + (%%p (intern %%p-name "ACL2")) + (%%p-aux (intern (concatenate 'string %%p-name "-AUX") "ACL2")) + (%%p-implies-%%p-aux + (intern (concatenate 'string %%p-name "-IMPLIES-" %%p-name "-AUX") + "ACL2")) + (%%p-property-lemma + (intern (concatenate 'string %%p-name "-PROPERTY-LEMMA") "ACL2")) + (%%p-equalities + (intern (concatenate 'string %%p-name "-EQUALITIES") "ACL2")) + (formal (car formals)) + (%%p-formal (list %%p formal)) + (%%p-property (intern (concatenate 'string %%p-name "-PROPERTY") + "ACL2")) + (%%p-base (intern (concatenate 'string + %%p-name + "-BASE") + "ACL2")) + (%%p-induction-step (intern (concatenate 'string + %%p-name + "-INDUCTION_STEP") + "ACL2")) + (not-zp-formal `(not (zp ,formal))) + (%%p-formal-minus-1 `(,%%p (1- ,formal))) + (induction-hyp `(and ,not-zp-formal ,%%p-formal-minus-1)) + (%%p-holds (intern (concatenate 'string + %%p-name + "-HOLDS") + "ACL2")) + (%%p-implies-f-is-%f-theory + (intern (concatenate 'string + %%p-name + "-IMPLIES-F-IS-%F-THEORY") + "ACL2")) + (new-theory + (intern (concatenate 'string "THEORY-" + (coerce (explode-atom (1+ counter) 10) + 'string)) + "ACL2"))) + +; Again, these lemmas are returned in reverse order. + + `((local + (deftheory ,new-theory + (union-theories (set-difference-theories + (current-theory :here) + (current-theory ',%%p-holds)) + (theory ',old-theory)))) + + (encapsulate + () + (local (in-theory (union-theories + '(,%%p-holds) + (theory ',%%p-implies-f-is-%f-theory)))) + ,@(f-is-%f-lemmas-mut-rec f-is-%f-list formals nil)) + + (local + (defthm ,%%p-holds + ,%%p-formal + :hints (("Goal" :induct (%%sub1-induction ,formal) + :do-not '(preprocess) + :in-theory (union-theories '(,%%p-base + ,%%p-induction-step + (:induction %%sub1-induction)) + (theory 'minimal-theory)))))) + + (local + (encapsulate + () + + (local (in-theory (disable ,%%p + ,%%p-base ; just an optimization + ))) + + (local (deflabel %%induction-start)) + + ,@(f-is-%f-induction-step-lemmas f-is-%f-list formals induction-hyp + nil) + + (defthm ,%%p-induction-step + (implies ,induction-hyp + ,%%p-formal) + :instructions + (:promote :x-dumb (:s :normalize nil))) + )) + + (local + (encapsulate + () + + (local + (in-theory (disable ,%%p-property))) + + ,@(f-is-%f-base-lemmas f-is-%f-list formals `(zp ,formal) nil) + + (defthm ,%%p-base + (implies (zp ,formal) + ,%%p-formal) + :instructions + (:promote :x-dumb (:s :normalize nil))) + )) + + (local + (deftheory ,%%p-implies-f-is-%f-theory + (union-theories (set-difference-theories (current-theory :here) + (current-theory ',%%p)) + (theory 'minimal-theory)))) + + (local + (encapsulate + () + + (local (defthm ,%%p-property-lemma + (implies (,%%p-aux ,@formals) + (,%%p-equalities)) + :rule-classes nil + :instructions + ((:dv 1) + (:expand nil) + :top + (:generalize ((,%%p-equalities) eqs)) + :s))) + + (defthm ,%%p-property + (implies (,%%p ,formal) + (,%%p-equalities)) + :instructions + ((:use ,%%p-property-lemma) + (:generalize ((,%%p-equalities) eqs)) + :prove)))) + + (local + (defthm ,%%p-implies-%%p-aux + (implies (,%%p ,formal) + (,%%p-aux ,@formals)))) + + (local + (defun-sk ,%%p (,formal) + (forall ,(cdr formals) (,%%p-aux ,@formals)))) + + (local + (defun ,%%p-aux ,formals + (declare (xargs :normalize nil)) + (,%%p-equalities))) + + (local (defmacro ,%%p-equalities () + '(%%AND-TREE ,@f-is-%f-list)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Translating Lemmas +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun my-translate-rule-class-alist (token alist seen orig-name corollary + pkg-alist ctx wrld state) + (cond + ((null alist) + (value (alist-to-keyword-alist seen nil))) + (t + (er-let* + ((val (case (car alist) + (:COROLLARY + (value corollary)) + (:HINTS + (value nil)) + (:INSTRUCTIONS + (value nil)) + (:OTF-FLG + (value (cadr alist))) + (:TRIGGER-FNS + (value (reverse (old2new-list + (cadr alist) + pkg-alist + nil)))) + (:TRIGGER-TERMS + (er-let* + ((terms (translate-term-lst (cadr alist) + t t t ctx wrld state))) + (value (old2new-term-lst terms pkg-alist nil)))) + (:TYPED-TERM + (er-let* + ((term (translate (cadr alist) t t t ctx wrld state))) + (value (old2new-term term pkg-alist)))) + (:BACKCHAIN-LIMIT-LST + (value (cadr alist))) + (:MATCH-FREE + (value (cadr alist))) + (:CLIQUE + (let ((clique (cond ((null (cadr alist)) nil) + ((atom (cadr alist)) + (old2new (cadr alist) pkg-alist)) + (t (old2new-list + (cadr alist) + pkg-alist + nil))))) + (value clique))) + (:TYPE-SET + (value (cadr alist))) + #| + (:CONTROLLER-ALIST + (value (cadr alist))) + (:LOOP-STOPPER + (value (cadr alist))) + (:PATTERN + (er-let* + ((term (translate (cadr alist) t t t ctx wrld state))) +; known-stobjs = t (stobjs-out = t) + (value term))) + (:CONDITION + (er-let* + ((term (translate (cadr alist) t t t ctx wrld state))) +; known-stobjs = t (stobjs-out = t) + (value term))) + (:SCHEME + (er-let* + ((term (translate (cadr alist) t t t ctx wrld state))) +; known-stobjs = t (stobjs-out = t) + (value term))) +|# + (otherwise + (er soft ctx + "The key ~x0 is not yet implemented for rule class ~ + translation." + (car alist)))))) + (my-translate-rule-class-alist + token + (cddr alist) + (if val + (let ((new-seen (cons (cons (car alist) val) seen))) + (if (eq (car alist) :COROLLARY) + (cons (cons :HINTS `(("Goal" + :use + +; !! This is dicey, because the original rule may have more than one +; :type-prescription corollary. But if that is the case, we will get an error +; when we try to prove this theorem, and we should see the error. + + (,token ,orig-name)))) + new-seen) + new-seen)) + seen) + orig-name corollary + pkg-alist ctx wrld state))))) + +(defun my-translate-rule-class1 (name class pkg-alist ctx wrld state) + (let ((orig-corollary (cadr (assoc-keyword :corollary (cdr class))))) + (er-let* + ((corollary + (cond (orig-corollary + (translate orig-corollary t t t ctx wrld state)) + (t (value nil)))) +; known-stobjs = t (stobjs-out = t) + (alist + (my-translate-rule-class-alist (car class) + (cdr class) + nil + name + (and corollary + (untranslate + (old2new-term corollary pkg-alist) + t wrld)) + pkg-alist ctx wrld state))) + (value (cons (car class) alist))))) + +(defun my-translate-rule-class (name x pkg-alist ctx wrld state) + (cond + ((symbolp x) (value x)) + (t (my-translate-rule-class1 name x pkg-alist ctx wrld state)))) + +(defun my-translate-rule-classes1 (name classes pkg-alist ctx wrld state) + (cond + ((atom classes) + (value nil)) + (t (er-let* + ((class (my-translate-rule-class name (car classes) pkg-alist ctx wrld + state)) + (rst (my-translate-rule-classes1 name (cdr classes) pkg-alist ctx wrld + state))) + (value (cons class rst)))))) + +(defun my-translate-rule-classes (name classes pkg-alist ctx wrld state) + (cond ((atom classes) (value classes)) + (t (my-translate-rule-classes1 name classes pkg-alist ctx wrld state)))) + +(defun old2new-term-from-lemma (lemma pkg-alist ctx wrld state) + (case-match lemma + (('defbvecp name formals width ':HINTS &) + (value `(defbvecp ,(old2new name pkg-alist) ,formals ,width + :hints (("Goal" + :use + ,(intern-in-package-of-symbol + (concatenate 'string + (if (consp width) + "BV-ARRP$" + "BVECP$") + (symbol-name name)) + name)))))) + ((defthm name formula . other) + (cond + ((member-eq defthm '(defthm defthmd)) + (let ((new-name (old2new name pkg-alist))) + (if (eq name new-name) + (value nil) + (let ((rcs (cadr (assoc-keyword :rule-classes other)))) + (er-let* + ((term (translate formula t t t ctx wrld state)) + (classes (my-translate-rule-classes name rcs pkg-alist ctx wrld + state))) + (value `(,defthm ,new-name + ,(untranslate (old2new-term term pkg-alist) t wrld) + :hints (("Goal" :use ,name)) + ,@(and classes + (list :rule-classes + classes))))))))) + (t (value nil)))) + (& (value nil)))) + +(defun old2new-term-from-lemmas (lemmas pkg-alist acc ctx wrld state) + (if (endp lemmas) + (value (reverse acc)) + (er-let* ((new-lemma (old2new-term-from-lemma (car lemmas) pkg-alist + ctx wrld state))) + (old2new-term-from-lemmas + (cdr lemmas) + pkg-alist + (if new-lemma (cons new-lemma acc) acc) + ctx wrld state)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Top Level Routines +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun simplify-defuns (defs all-defs acc lemmas counter old-theory pkg-alist + ens wrld state) + (cond + ((endp defs) + (let ((formals (mut-rec-formals all-defs nil))) + (if formals + (let* ((new-lemmas ; ((local (deftheory new-theory ...)) ...) + (mutual-recursion-lemmas formals + (f-is-%f-list all-defs formals + pkg-alist nil) + counter + old-theory)) + (new-deftheory (cadr (car new-lemmas)))) + (mv nil + (cons 'mutual-recursion (reverse acc)) + (append new-lemmas lemmas) + (1+ counter) + (cadr new-deftheory) + state)) + (mv-let (erp val state) + (er soft 'simplify-defuns + "Did not find a unique singleton list of formals for the ~ + mutual-recursion nest starting with:~%~x0." + (car all-defs)) + (declare (ignore erp val)) + (mv t nil nil counter old-theory state))))) + (t (mv-let + (erp def new-lemmas counter new-theory state) + (simplify-defun 'mut-rec (car defs) lemmas counter old-theory pkg-alist + ens wrld state) + (if erp + (mv t nil nil counter new-theory state) + (simplify-defuns (cdr defs) all-defs + (if def (cons def acc) acc) + new-lemmas counter + new-theory pkg-alist ens wrld state)))))) + +(defun simplify-form (form lemmas counter old-theory pkg-alist ens wrld state) + (let ((car-form (and (consp form) (car form)))) + (case car-form + ((defun defund) (simplify-defun nil form lemmas counter old-theory + pkg-alist ens wrld state)) + (mutual-recursion + (simplify-defuns (cdr form) (cdr form) nil lemmas counter old-theory + pkg-alist ens wrld state)) + (defuns (mv-let (erp val state) + (er soft 'simplify-form + "Simplify-form does not yet handle DEFUNS, but it ~ + could.") + (declare (ignore erp val)) + (mv t nil nil counter old-theory state))) + (otherwise (mv nil nil lemmas counter old-theory state))))) + +(defun simplify-forms (forms defs lemmas counter old-theory pkg-alist ens wrld + state) + (cond ((endp forms) + (pprogn + (newline *standard-co* state) + (mv nil + (reverse defs) + (case-match lemmas + ((('local ('deftheory . &)) + . &) + (cdr lemmas)) + (& lemmas)) + state))) + (t (mv-let (erp simp-form lemmas new-counter new-theory state) + (simplify-form (car forms) lemmas counter old-theory + pkg-alist ens wrld state) + (cond + (erp (mv t nil nil state)) + (simp-form (simplify-forms + (cdr forms) (cons simp-form defs) lemmas + new-counter new-theory pkg-alist ens wrld + state)) + (t (simplify-forms (cdr forms) defs lemmas new-counter + new-theory pkg-alist ens wrld + state))))))) + +(defun final-deftheory-1 (lemmas acc) + (cond + ((endp lemmas) + acc) + ((eq (caar lemmas) 'defthm) + (final-deftheory-1 (cdr lemmas) (cons (cadar lemmas) acc))) + ((eq (caar lemmas) 'encapsulate) + (final-deftheory-1 (cdr lemmas) + (final-deftheory-1 (cddar lemmas) acc))) + (t + (final-deftheory-1 (cdr lemmas) acc)))) + +(defun final-deftheory (lemmas) + `(deftheory %-removal-theory + (union-theories + ',(final-deftheory-1 lemmas nil) + (theory 'minimal-theory)))) + +(defun initial-equality-events (in-defs out-defs) + +; Returns an initial list of events, in forward order, for the f-is-%f lemmas. +; Matt K. mod for v2-9.1: Remove support for pre-v2-7. + + (declare (ignore out-defs)) + (list (car in-defs) ; first out-def is in-package + '(local + (defun %%sub1-induction (n) + (if (zp n) + n + (%%sub1-induction (1- n))))) + '(local + (defun %%and-tree-fn (args len) + (declare (xargs :mode :program)) + (if (< len 20) + (cons 'and args) + (let* ((len2 (floor len 2))) + (list 'and + (%%and-tree-fn (take len2 args) len2) + (%%and-tree-fn (nthcdr len2 args) (- len len2))))))) + '(local + (defmacro %%and-tree (&rest args) + (%%and-tree-fn args (length args)))))) + +(include-book "file-io-pkgs") + +(defun write-lemma-file (infile outfile initial-events final-events pkg-alist ctx state) + (er-let* + ((in-lemmas (read-list infile ctx state)) + (out-lemmas (old2new-term-from-lemmas in-lemmas pkg-alist + nil ctx (w state) state))) + (write-list-using-pkgs (cons (car in-lemmas) ; in-package form + (append initial-events out-lemmas final-events)) + outfile ctx state))) + +(defun write-lemma-files (thm-file-pairs erp pkg-alist ctx state) + (if (endp thm-file-pairs) + (mv erp nil state) + (mv-let (erp val state) + (let ((pair (car thm-file-pairs))) + (write-lemma-file (nth 0 pair) (nth 1 pair) (nth 2 pair) (nth 3 pair) + pkg-alist ctx state)) + (declare (ignore val)) + (write-lemma-files (cdr thm-file-pairs) erp pkg-alist ctx state)))) + +(defun transform-defuns-fn (in-defs-file ; %f definitions + out-defs-file ; f definitions + equalities-file ; thms (equal (%f ..) (f ..)) + extra-initial-events-for-defs + extra-final-events-for-defs + extra-initial-events-for-lemmas + extra-final-events-for-lemmas + thm-file-pairs ; (.. ( infile ; thms (.. %f ..) + ; outfile ; thms (.. f ..) + ; initial-events + ; final-events + ; ) .. + ; ) + pkg-alist + state) + (let ((ctx 'transform-defuns) + (first-lemma '(local + (deftheory theory-0 (theory 'minimal-theory))))) + (mv-let + (erp in-defs state) + (read-list in-defs-file ctx state) + (if erp + (silent-error state) + (mv-let + (erp out-defs lemmas state) + (if (or out-defs-file equalities-file) + (simplify-forms in-defs nil (list first-lemma) 0 'theory-0 + pkg-alist (ens state) (w state) state) + (mv nil nil nil state)) + (if erp + (silent-error state) + (er-progn + (if out-defs-file + (write-list-using-pkgs + (cons (car in-defs) ; in-package form + (append extra-initial-events-for-defs + out-defs + extra-final-events-for-defs)) + out-defs-file ctx state) + (value nil)) + (if equalities-file + (write-list-using-pkgs + (append + (initial-equality-events in-defs out-defs) + extra-initial-events-for-lemmas + (reverse (cons (final-deftheory lemmas) + lemmas)) + extra-final-events-for-lemmas) + equalities-file ctx state) + (value nil)) + (write-lemma-files thm-file-pairs nil pkg-alist ctx state)))))))) + +(defmacro transform-defuns (in-defs-file pkg-alist + &key out-defs equalities + defs-pre defs-post eq-pre eq-post thm-file-pairs) + `(transform-defuns-fn ,in-defs-file ,out-defs ,equalities + ,defs-pre ,defs-post ,eq-pre ,eq-post ,thm-file-pairs + ,pkg-alist state)) diff --git a/books/workshops/2003/kaufmann/support/rtl/tool/wrapper.lisp b/books/workshops/2003/kaufmann/support/rtl/tool/wrapper.lisp new file mode 100644 index 0000000..e8075b8 --- /dev/null +++ b/books/workshops/2003/kaufmann/support/rtl/tool/wrapper.lisp @@ -0,0 +1,68 @@ +(in-package "ACL2") + +; This macro is developed to make it easy to call transform-defuns in the +; Makefile in support/rtl/, after ld-ing pkgs.lisp there. + +(defmacro simplify-model () + (let* ((rel4 "rtl/rel4/") + (rel4-lib (concatenate 'string rel4 "lib/")) + (rel4-lib-top (concatenate 'string rel4-lib "top")) + (rel4-support (concatenate 'string rel4 "support/")) + (bvecp-helpers (concatenate 'string rel4-support "bvecp-helpers")) + (simplify-model-helpers + (concatenate 'string rel4-lib "simplify-model-helpers"))) + `(state-global-let* + ((print-case :downcase set-print-case)) + (ld + '((INCLUDE-BOOK + "tool/simplify-defuns") + (INCLUDE-BOOK + "bvecp-raw") + (INCLUDE-BOOK + ,rel4-lib-top :dir :system) + (INCLUDE-BOOK + ,simplify-model-helpers :dir :system) + (DISABLE-FORCING) + (TRANSFORM-DEFUNS + "model-raw.lisp" *OLD2NEW-PKG-ALIST* + :out-defs "model-defs.lisp" + :defs-pre `((include-book + "ordinals/e0-ordinal" :dir :system) + (set-well-founded-relation e0-ord-<) + (SET-INHIBIT-WARNINGS "THEORY" "DISABLE" "NON-REC") + (INCLUDE-BOOK + "common") + (INCLUDE-BOOK + "model-macros") + (SET-IRRELEVANT-FORMALS-OK T) + (SET-IGNORE-OK T) + (DEFLABEL MODEL-START-OF-DEFS) + (SET-BOGUS-MUTUAL-RECURSION-OK T)) + :equalities "model-eq.lisp" + :eq-pre '((LOCAL (INCLUDE-BOOK + "bvecp-raw")) + (LOCAL (INCLUDE-BOOK + ,rel4-lib-top :dir :system)) + (LOCAL (INCLUDE-BOOK + ,simplify-model-helpers :dir :system)) + (INCLUDE-BOOK + "model-raw") + (INCLUDE-BOOK + "model") + +; We have seen cases where things blow up at %%P0-PROPERTY-LEMMA because of an +; attempt to untranslate during preprocess-clause with sigs-btree set. + + (LOCAL (TABLE USER-DEFINED-FUNCTIONS-TABLE NIL NIL :clear)) + (LOCAL (DISABLE-FORCING))) + :thm-file-pairs + '(("bvecp-raw.lisp" + "bvecp.lisp" + ((INCLUDE-BOOK + "model") + (LOCAL (INCLUDE-BOOK + "model-eq")) + (LOCAL (INCLUDE-BOOK + "bvecp-raw")) + (LOCAL (INCLUDE-BOOK + ,bvecp-helpers :dir :system))))))))))) diff --git a/books/workshops/2003/manolios-vroon/ordinals.pdf.gz b/books/workshops/2003/manolios-vroon/ordinals.pdf.gz Binary files differnew file mode 100644 index 0000000..b79b95b --- /dev/null +++ b/books/workshops/2003/manolios-vroon/ordinals.pdf.gz diff --git a/books/workshops/2003/manolios-vroon/ordinals.ps.gz b/books/workshops/2003/manolios-vroon/ordinals.ps.gz Binary files differnew file mode 100644 index 0000000..659c15a --- /dev/null +++ b/books/workshops/2003/manolios-vroon/ordinals.ps.gz diff --git a/books/workshops/2003/matlin-mccune/final.pdf.gz b/books/workshops/2003/matlin-mccune/final.pdf.gz Binary files differnew file mode 100644 index 0000000..2a81650 --- /dev/null +++ b/books/workshops/2003/matlin-mccune/final.pdf.gz diff --git a/books/workshops/2003/matlin-mccune/final.ps.gz b/books/workshops/2003/matlin-mccune/final.ps.gz Binary files differnew file mode 100644 index 0000000..61f678a --- /dev/null +++ b/books/workshops/2003/matlin-mccune/final.ps.gz diff --git a/books/workshops/2003/matlin-mccune/matlin.ppt.gz b/books/workshops/2003/matlin-mccune/matlin.ppt.gz Binary files differnew file mode 100644 index 0000000..28d8ab1 --- /dev/null +++ b/books/workshops/2003/matlin-mccune/matlin.ppt.gz diff --git a/books/workshops/2003/matlin-mccune/slides.pdf.gz b/books/workshops/2003/matlin-mccune/slides.pdf.gz Binary files differnew file mode 100644 index 0000000..3465e9d --- /dev/null +++ b/books/workshops/2003/matlin-mccune/slides.pdf.gz diff --git a/books/workshops/2003/matlin-mccune/slides.ps.gz b/books/workshops/2003/matlin-mccune/slides.ps.gz Binary files differnew file mode 100644 index 0000000..c77d885 --- /dev/null +++ b/books/workshops/2003/matlin-mccune/slides.ps.gz diff --git a/books/workshops/2003/matlin-mccune/support/simp.lisp b/books/workshops/2003/matlin-mccune/support/simp.lisp new file mode 100644 index 0000000..60bdbb1 --- /dev/null +++ b/books/workshops/2003/matlin-mccune/support/simp.lisp @@ -0,0 +1,908 @@ +;; +;; Material in this ACL2 book is described in a short paper +;; +;; "Encapsulation for Practical Simplification Procedures" +;; by Olga Shumsky Matlin and William McCune +;; +;; submitted to the Fourth International Workshop on the +;; ACL2 Theorem Prover and Its Applications (ACL2-2003) +;; +;; For more information contact +;; Olga Shumsky Matlin (matlin@mcs.anl.gov) +;; William McCune (mccune@mcs.anl.gov) +;; +;; +;; Direct Incorporation Algorithm: +;; +;; While(Q) +;; C = dequeue(Q) +;; C = rewrite(C,S) +;; if (C != True) +;; for each D in S rewritable by C +;; remove D from S +;; add to Q D simplified by C +;; S = S + C +;; +;; Limbo Incorporation Algorithm: +;; +;; preprocess(C, S, Limbo): +;; C = rewrite(C, S+Limbo) +;; if (C != TRUE) +;; return Limbo +;; else +;; return Limbo+C +;; +;; Loop1: Initial Limbo Computation +;; while(Q) +;; C = dequeue(Q) +;; Limbo = preprocess(C, S, Limbo); +;; +;; Loop2: Limbo Processing +;; while(Limbo) +;; C = dequeue(Limbo) +;; for each D in S rewritable by C +;; S = remove D from S +;; Limbo = preprocess(D, S, Limbo+C) +;; S = S + C +;; + +(in-package "ACL2") +(include-book "../../../../ordinals/e0-ordinal") +(set-well-founded-relation e0-ord-<) + +(encapsulate + + ;;----------------- Signatures (constrained functions) + + ( + (simplify (x y) t) ; simplify x by element of list y + + (true-symbolp (x) t) ; expression x is a true-symbolp + + (ceval (x i) t) ; evaluate clause x in interpretation i + + (scount (x) t) ; size evaluator for measure functions + ) + + ;;------------------- Witnesses + + (local (defun simplify (x y) + (declare (xargs :guard t) + (ignore y)) + x)) + + (local (defun true-symbolp (x) + (declare (xargs :guard t) + (ignore x)) + t)) + + (local (defun ceval (x i) + (declare (xargs :guard t) + (ignore x i)) + t)) + + (local (defun scount (x) + (declare (xargs :guard t)) + (acl2-count x))) + + ;;------------------- Properties and Exported Functions + + (defthm scount-natural + (and (integerp (scount x)) + (<= 0 (scount x))) + :rule-classes :type-prescription) + + (defthm scount-simplify + (or (equal (simplify x y) x) + (< (scount (simplify x y)) + (scount x))) + :rule-classes nil) + + (defthm simplify-idempotent + (equal (simplify (simplify x y) y) + (simplify x y))) + + (defthm simplify-subset + (implies (and (not (equal (simplify a x) a)) + (subsetp-equal x y)) + (not (equal (simplify a y) a))) + :rule-classes ((:rewrite :match-free :all))) + + (defthm simplify-append + (implies (and (equal (simplify a x) a) + (equal (simplify a y) a)) + (equal (simplify a (append x y)) a))) + + (defthm ceval-boolean + (or (equal (ceval x i) t) + (equal (ceval x i) nil)) + :rule-classes :type-prescription) + + (defthm true-symbolp-ceval + (implies (true-symbolp x) + (ceval x i))) + + (defun ceval-list (x i) + (declare (xargs :guard (true-listp x) +; Added by Matt Kaufmann after v3-6-1 to because of restriction on guard +; verification for functions depending on signature functions: + :verify-guards nil)) + (if (endp x) + t + (and (ceval (car x) i) (ceval-list (cdr x) i)))) + +; The following was added by Matt Kaufmann after ACL2 Version 3.4 because of +; a soundness bug fix; see ``subversive'' in :doc note-3-5. + (defthm ceval-list-type + (booleanp (ceval-list x i)) + :rule-classes :type-prescription) + + (defthm simplify-sound + (implies (ceval-list y i) + (equal (ceval (simplify x y) i) + (ceval x i)))) + + ) ;; end of encapsulate + +; Added by Matt Kaufmann after v3-6-1 (see comment for (defun ceval-list ...) +; above): +(verify-guards ceval-list) + +(defun rewritable (x y) + (declare (xargs :guard t)) + (not (equal (simplify x y) x))) + +(defthm scount-simplify-rewritable + (implies (rewritable x y) + (< (scount (simplify x y)) (scount x))) + :hints (("goal" :use scount-simplify))) + +(defthm simplified-not-rewritable + (not (rewritable (simplify x y) y))) + +(defthm simplify-subset-restated + (implies (and (rewritable a x) + (subsetp-equal x y)) + (rewritable a y)) + :rule-classes ((:rewrite :match-free :all))) + +(defthm simplify-append-restated + (implies (and (not (rewritable a x)) + (not (rewritable a y))) + (not (rewritable a (append x y))))) + +(in-theory (disable rewritable)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Direct Formalization +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; produces a list of Ds in S, such that D is rewritable by X +(defun extract-rewritables (x s) + (declare (xargs :guard (true-listp s))) + (cond ((endp s) nil) + ((rewritable (car s) (list x)) + (cons (car s) (extract-rewritables x (cdr s)))) + (t (extract-rewritables x (cdr s))))) + +;; produces a list of Ds in S, such that D is rewritable by X +;; D is simplified by x before being placed on the list +(defun extract-n-simplify-rewritables (x s) + (declare (xargs :guard (true-listp s))) + (cond ((endp s) nil) + ((rewritable (car s) (list x)) + (cons (simplify (car s) (list x)) + (extract-n-simplify-rewritables x (cdr s)))) + (t (extract-n-simplify-rewritables x (cdr s))))) + +;; removes from S elements rewritable by X +(defun remove-rewritables (x s) + (declare (xargs :guard (true-listp s))) + (cond ((endp s) nil) + ((rewritable (car s) (list x)) + (remove-rewritables x (cdr s))) + (t (cons (car s) (remove-rewritables x (cdr s)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; For the proof of termination of direct-incorporation: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun lcount (x) + (declare (xargs :guard (true-listp x))) + (if (endp x) + 0 + (+ 1 (scount (car x)) (lcount (cdr x))))) + +(defthm extract-consp + (implies (not (consp (extract-rewritables x s))) + (not (consp (extract-n-simplify-rewritables x s))))) + +(local + (include-book "../../../../arithmetic/top-with-meta")) + +(defthm small-sum-<-large-sum + (implies (and (< x y) + (< u v)) + (< (+ u x) (+ y v)))) + +(defthm lcount-extract + (implies (consp (extract-rewritables x s)) + (< (lcount (extract-n-simplify-rewritables x s)) + (lcount (extract-rewritables x s))))) + +(defthm lcount-remove + (implies (true-listp s) + (equal (lcount (remove-rewritables x s)) + (- (lcount s) + (lcount (extract-rewritables x s)))))) + +(defthm lcount-append + (implies (true-listp x) + (equal (lcount (append x y)) + (+ (lcount x) (lcount y))))) + +(defthm inequality-helper + (implies (and (<= x y) + (< u v)) + (< (+ x u (- v)) y))) + +(defthm less-n-greater-equal + (implies (and (<= (scount q1) (scount x)) + (<= (scount x) (scount q1))) + (equal (scount q1) (scount x))) + :rule-classes ((:rewrite :match-free :all))) + +(defthm scount-simplify-combined + (<= (scount (simplify x y)) (scount x)) + :hints (("goal" :use scount-simplify))) + +;;;;;; end of termination proof preparations +(defun direct-incorporation (q s) + (declare + (xargs + :guard (and (true-listp q) (true-listp s)) + :measure (cons (+ 1 (lcount q) (lcount s)) (+ 1 (lcount q))) + :hints (("subgoal 2" + :cases + ((consp (extract-rewritables (simplify (car q) s) s)) + (not (consp (extract-rewritables (simplify (car q) s) s)))))))) + (cond ((or (not (true-listp q)) (not (true-listp s))) 'INPUT-ERROR) + ((endp q) s) + ((true-symbolp (simplify (car q) s)) (direct-incorporation (cdr q) s)) + (t (direct-incorporation + (append (cdr q) + (extract-n-simplify-rewritables (simplify (car q) s) s)) + (cons (simplify (car q) s) + (remove-rewritables (simplify (car q) s) s)))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Proving Correctness of Naive Formalization: +;; the simple processing function produces a clean database +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; x neither rewrites, nor is rewritable by, anything in s +(defun mutually-irreducible-el-list (x s) + (declare (xargs :guard (true-listp s))) + (cond ((endp s) t) + ((or (rewritable x (list (car s))) + (rewritable (car s) (list x))) nil) + (t (mutually-irreducible-el-list x (cdr s))))) + +(defun irreducible-list (s) + (declare (xargs :guard (true-listp s))) + (cond ((endp s) t) + ((mutually-irreducible-el-list (car s) (cdr s)) + (irreducible-list (cdr s))) + (t nil))) + +(defthm remove-rewritables-mutually-irreducible-el-list + (implies (mutually-irreducible-el-list x s) + (mutually-irreducible-el-list x (remove-rewritables y s)))) + +(defthm remove-rewritables-irreducible + (implies (irreducible-list s) + (irreducible-list (remove-rewritables x s)))) + +(defthm subsetp-append-1 + (subsetp-equal s (append x s))) + +(defthm subsetp-cons + (subsetp-equal s (cons x s)) + :hints (("goal" + :do-not-induct t + :in-theory (disable subsetp-append-1) + :use ((:instance subsetp-append-1 (x (list x))))))) + +(defthm forward-simplify-irreducible + (implies (and (irreducible-list s) + (not (rewritable x s))) + (mutually-irreducible-el-list x (remove-rewritables x s)))) + +;; top level correctness proof for direct-incorporation +(defthm direct-incorporation-is-irreducible + (implies (irreducible-list s) + (irreducible-list (direct-incorporation q s)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Proving Soundness of Naive Formalization +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defthm ceval-append-1 + (implies (not (ceval-list x i)) + (not (ceval-list (append x y) i)))) + +(defthm ceval-append-2 + (implies (not (ceval-list y i)) + (not (ceval-list (append x y) i)))) + +(defthm ceval-append-3 + (implies (and (ceval-list x i) + (ceval-list y i)) + (ceval-list (append x y) i))) + +(defthm ceval-remove-rewritables + (implies (ceval-list s i) + (ceval-list (remove-rewritables x s) i))) + +(defthm ceval-extract-n-simp-1 + (implies (and (ceval x i) + (ceval-list s i)) + (ceval-list (extract-n-simplify-rewritables x s) i))) + +(defthm ceval-extract-n-simp-2 + (implies (and (ceval-list (remove-rewritables x s) i) + (ceval x i) + (not (ceval-list s i))) + (not (ceval-list (extract-n-simplify-rewritables x s) i)))) + +(defthm direct-incorporation-sound-iff + (implies (and (true-listp q) + (true-listp s)) + (iff (and (ceval-list q i) (ceval-list s i)) + (ceval-list (direct-incorporation q s) i))) + :hints (("Subgoal *1/2" + :in-theory (disable true-symbolp-ceval) + :use ((:instance true-symbolp-ceval + (x (simplify (car q) s))))) + ("subgoal *1/3.6" + :use ((:instance ceval-extract-n-simp-2 + (x (simplify (car q) s)))))) + :rule-classes nil) + +;; top soundness lemma +(defthm direct-incorporation-is-sound + (implies (and (true-listp q) + (true-listp s)) + (equal (ceval-list (direct-incorporation q s) i) + (and (ceval-list q i) (ceval-list s i)))) + :hints (("goal" :use direct-incorporation-sound-iff))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Limbo-Based Formalization +;; +;; processing with forward and backward +;; demodulation/subsumption in two separate loops, +;; using a limbo list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun preprocess (x s l) + (declare (xargs :guard (and (true-listp s) + (true-listp l)))) + (if (true-symbolp (simplify x (append s l))) + l + (append l (list (simplify x (append s l)))))) + +(defun initial-limbo (q s l) + (declare (xargs :guard (and (true-listp q) + (true-listp s) + (true-listp l)))) + (if (endp q) + l + (initial-limbo (cdr q) s (preprocess (car q) s l)))) + +(defthm limbo-true-list + (implies (true-listp l) + (true-listp (initial-limbo q s l)))) + +(defun preprocess-list (d s r) + (declare (xargs :guard (and (true-listp d) + (true-listp s) + (true-listp r)))) + (if (endp d) + r + (preprocess-list (cdr d) s (preprocess (car d) + (append s (cdr d)) + r)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; For the proof of termination of limbo-process: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; auxiliary function; this function is easier to reason about +;; than preprocess-list, so it is used in the correctness proof as well +(defun special-ppd (d s r) + (declare (xargs :guard (and (true-listp d) + (true-listp s) + (true-listp r)))) + (if (endp d) + nil + (let ((e (simplify (car d) (append s (cdr d) r)))) + (if (true-symbolp e) + (special-ppd (cdr d) s r) + (cons e (special-ppd (cdr d) s (append r (list e)))))))) + +;; auxiliary function: every element of x is rewritable by something in y +(defun rewritable-list-by-list (x y) + (declare (xargs :guard (and (true-listp x) + (true-listp y)))) + (cond ((endp x) t) + ((rewritable (car x) y) + (rewritable-list-by-list (cdr x) y)) + (t nil))) + +(defthm subsetp-append-2 + (subsetp-equal s (append s r))) + +(defthm subsetp-append-3 + (subsetp-equal s (append s c r)) + :hints (("goal" + :use ((:instance subsetp-append-2 (r (append c r))))))) + +(defthm scount-rewritable-append + (implies (rewritable d s) + (< (scount (simplify d (append s r))) + (scount d)))) + +(defthm lcount-special-ppd-consp + (implies (and (consp d) + (true-listp d) + (rewritable-list-by-list d s)) + (< (lcount (special-ppd d s r)) + (lcount d)))) + +(defthm append-nil + (implies (true-listp r) + (equal (append r nil) r))) + +(defthm append-multiple + (equal (append (append d s) r) + (append d s r))) + +(defthm preprocess-list-special-ppd + (implies (true-listp r) + (equal (preprocess-list d s r) + (append r (special-ppd d s r))))) + +;; auxiliary function: all elements of l are writable by x +(defun all-rewritable-list (l x) + (declare (xargs :guard (true-listp l))) + (cond ((endp l) t) + ((rewritable (car l) (list x)) (all-rewritable-list (cdr l) x)) + (t nil))) + +(defthm extract-all-rewritable + (all-rewritable-list (extract-rewritables x s) x)) + +(defthm all-rewritable-append ;; 3 inductions, hint required + (implies (all-rewritable-list d x) + (rewritable-list-by-list d (append s (cons x l)))) + :hints (("goal" :do-not fertilize))) + +;;;;;; end of termination proof preparations + +(defun process-limbo (l s) + (declare + (xargs + :guard (and (true-listp l) (true-listp s)) + :measure (cons (+ 1 (lcount l) (lcount s)) (+ 1 (lcount l))) + :hints (("subgoal 1" + :cases ((consp (extract-rewritables (car l) s)) + (not (consp (extract-rewritables (car l) s)))))))) + (cond ((or (not (true-listp l)) (not (true-listp s))) 'INPUT-ERROR) + ((endp l) s) + (t (process-limbo + (append + (cdr l) + (preprocess-list (extract-rewritables (car l) s) + (append (remove-rewritables (car l) s) l) + nil)) + (cons (car l) + (remove-rewritables (car l) s)))))) + +;; two-loop processing function +(defun limbo-incorporation (q s) + (declare (xargs :guard (and (true-listp q) (true-listp s)))) + (process-limbo (initial-limbo q s nil) s)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Proving Correctness: +;; the split processing function produces a clean +;; (irreducible) database +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; no element of l is rewritable by an element in s +(defun irreducible-list-by-list (l s) + (declare (xargs :guard (and (true-listp l) (true-listp s)))) + (cond ((endp l) t) + ((rewritable (car l) s) nil) + (t (irreducible-list-by-list (cdr l) s)))) + +;; x rewrites nothing in l +(defun irreducible-list-by-el (x l) + (declare (xargs :guard (true-listp l))) + (cond ((endp l) t) + ((rewritable (car l) (list x)) nil) + (t (irreducible-list-by-el x (cdr l))))) + +;; forall A,B in L, pos[A]<pos[B] -> A does not rewrite B +(defun irreducible-tail-by-head (l) + (declare (xargs :guard (true-listp l))) + (cond ((endp l) t) + ((irreducible-list-by-el (car l) (cdr l)) + (irreducible-tail-by-head (cdr l))) + (t nil))) + +;;;;;;;;;; +(defthm irreducible-list-by-list-append-el + (implies (and (irreducible-list-by-list l s) + (not (rewritable x s))) + (irreducible-list-by-list (append l (list x)) s))) + +(defthm rewritable-element-by-list-append-left + (implies (rewritable x s) + (rewritable x (append s l)))) + +(defthm simplify-not-rewritable-append-left + (not (rewritable (simplify x (append s l)) s)) + :hints (("Goal" :use ((:instance rewritable-element-by-list-append-left + (x (simplify x (append s l)))))))) + +;; mini-goal +(defthm limbo-irreducible-list-by-list + (implies (irreducible-list-by-list l s) + (irreducible-list-by-list (initial-limbo q s l) s))) + +;;;;;;;;;; + +(defthm append-irreducible-list-by-el + (implies (and (irreducible-list-by-el x l) + (not (rewritable y (list x)))) + (irreducible-list-by-el x (append l (list y))))) + +(defthm not-rewritable-cons + (implies (not (rewritable x (cons l1 l2))) + (not (rewritable x (list l1)))) + :rule-classes ((:rewrite :match-free :all))) + +(defthm append-irreducible-tail-by-head + (implies (and (not (rewritable x l)) + (irreducible-tail-by-head l)) + (irreducible-tail-by-head (append l (list x))))) + +(defthm rewritable-element-by-list-append-right + (implies (rewritable x l) + (rewritable x (append s l)))) + +(defthm simplify-not-rewritable-append-right + (not (rewritable (simplify x (append s l)) l)) + :hints (("Goal" :use ((:instance rewritable-element-by-list-append-right + (x (simplify x (append s l)))))))) + +;; mini-goal +(defthm limbo-irreducible-tail-by-head + (implies (irreducible-tail-by-head l) + (irreducible-tail-by-head (initial-limbo q s l)))) + +;;;;;;;;;; +(defthm remove-rewritables-subset + (subsetp-equal (remove-rewritables x s) s)) + +(defthm irreducible-cons-remove-rewritables + (implies (and (irreducible-list-by-list l s) + (irreducible-list-by-el x l)) + (irreducible-list-by-list l (cons x (remove-rewritables x s)))) + :hints (("subgoal *1/2" + :use ((:instance simplify-append-restated + (a (car l)) + (x (list x)) + (y (remove-rewritables x s))))))) + +(defthm irreducible-cons + (implies (and (irreducible-list-by-list l s) + (irreducible-list-by-el x l)) + (irreducible-list-by-list l (cons x s))) + :hints (("Subgoal *1/2" + :use ((:instance simplify-append-restated + (a (car l)) + (x (list x)) + (y s)))))) + +(defthm irreducible-list-by-list-append-2 + (implies (and (irreducible-list-by-list l1 s) + (irreducible-list-by-list l2 s)) + (irreducible-list-by-list (append l1 l2) s))) + +(defthm irreducible-list-by-el-append-cons + (implies (and (not (rewritable x1 (list l1))) + (irreducible-list-by-el l1 (append l2 x2))) + (irreducible-list-by-el l1 (append l2 (cons x1 x2))))) + +(defthm irreducible-tail-by-head-append-cons + (implies (and (not (rewritable x1 l)) + (irreducible-tail-by-head (append l x2)) + (irreducible-list-by-el x1 x2)) + (irreducible-tail-by-head (append l (cons x1 x2))))) + +(defthm irreducible-tail-by-head-append + (implies (and (true-listp l) + (true-listp x) + (irreducible-tail-by-head l) + (irreducible-tail-by-head x) + (irreducible-list-by-list x l)) + (irreducible-tail-by-head (append l x)))) + +;;;;;;;;;; + +(defthm member-append-all ;; several inductions + (member-equal x (append s (cons x (append l d2 r))))) + +(defthm rewritable-by-member + (implies (and (not (rewritable x l)) + (member-equal y l)) + (not (rewritable x (list y)))) + :rule-classes nil) + +(defthm rewritable-simplify-append-all + (not (rewritable (simplify y (append s (cons x (append l d2 r)))) (list x))) + :hints (("goal" + :use ((:instance + rewritable-by-member + (x (simplify y (append s (cons x (append l d2 r))))) + (y x) + (l (append s (cons x (append l d2 r))))))))) + +;; mini-goal +(defthm special-irreducible-x + (irreducible-list-by-el x (special-ppd d (append s (cons x l)) r))) + +;;;;;;;;;; + +;; mini-goal +(defthm special-irreducible-s + (irreducible-list-by-list (special-ppd d (append s (cons x l)) r) s)) + +;;;;;;;;;; + +(defthm subsetp-append-4 + (subsetp-equal l (append l d2 r))) + +(defthm subsetp-cons-2 + (implies (subsetp-equal l z) + (subsetp-equal l (cons x z)))) + +(defthm subsetp-append-5 + (implies (subsetp-equal l z) + (subsetp-equal l (append x z)))) + +(defthm rewritable-element-by-list-append-all + (implies (rewritable y l) + (rewritable y (append s (cons x (append l d2 r)))))) + +(defthm simplify-not-rewritable-append-all + (not (rewritable + (simplify y (append s (cons x (append l d2 r)))) + l)) + :hints (("goal" + :use ((:instance + rewritable-element-by-list-append-all + (y (simplify y (append s (cons x (append l d2 r)))))))))) + +;; mini-goal +(defthm special-irreducible-l + (irreducible-list-by-list (special-ppd d (append s (cons x l)) r) l)) + +;;;;;;;;;; + +(defthm append-subset-7 + (subsetp-equal r (append l d2 r))) + +(defthm rewritable-element-by-list-append-last + (implies + (rewritable y r) + (rewritable y (append s (cons x (append l d2 r)))))) + +(defthm simplify-not-rewritable-append-last + (not (rewritable + (simplify y (append s (cons x (append l d2 r)))) r)) + :hints (("goal" + :in-theory (disable rewritable-element-by-list-append-last) + :use ((:instance + rewritable-element-by-list-append-last + (y (simplify y (append s (cons x (append l d2 r)))))))))) + +(defthm irreducible-list-by-list-append-1 + (implies (not (irreducible-list-by-list x l)) + (not (irreducible-list-by-list x (append l z))))) + +;; mini-mini-goal +(defthm special-irreducible-r + (irreducible-list-by-list (special-ppd d (append s (cons x l)) r) r) + :hints (("goal" :do-not generalize))) + +(defthm irreducible-member + (implies (and (not (irreducible-list-by-el x l)) + (member-equal x s)) + (not (irreducible-list-by-list l s))) + :rule-classes nil) + +(defthm member-append-el + (member-equal x (append r (list x)))) + +(defthm special-head-tail-helper + (implies + (irreducible-tail-by-head + (special-ppd d (append s (cons x l)) (append r (list y)))) + (irreducible-list-by-el + y (special-ppd d (append s (cons x l)) (append r (list y))))) + :hints (("goal" + :do-not-induct t + :use ((:instance + irreducible-member + (x y) + (l (special-ppd d (append s (cons x l)) + (append r (list y)))) + (s (append r (list y)))))))) + +;; mini-goal +(defthm special-ppd-irreducible-tail-by-head + (irreducible-tail-by-head (special-ppd d (append s (cons x l)) r))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defthm process-limbo-irreducible ;; main theorem of subsection + (implies (and (irreducible-list s) + (irreducible-tail-by-head l) + (irreducible-list-by-list l s)) + (irreducible-list (process-limbo l s))) + :hints (("goal" :induct (process-limbo l s)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; top level correctness proof for limbo-incorporation +(defthm limbo-incorporation-is-irreducible + (implies (irreducible-list s) + (irreducible-list (limbo-incorporation q s))) + :hints (("Goal" + :do-not-induct t + :in-theory (disable process-limbo-irreducible) + :use ((:instance process-limbo-irreducible + (l (initial-limbo q s nil))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Proving Soundness of Two-Step Formalization: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Computation of initial-limbo list is sound +(defthm limbo-sound-l + (implies (and (not (ceval-list l i)) + (ceval-list s i)) + (not (ceval-list (initial-limbo q s l) i)))) + +(defthm limbo-sound-1 + (implies (and (not (ceval-list q i)) + (ceval-list s i) + (ceval-list l i)) + (not (ceval-list (initial-limbo q s l) i))) + :hints (("Subgoal *1/2.2" + :in-theory (disable true-symbolp-ceval) + :use ((:instance true-symbolp-ceval + (x (SIMPLIFY (CAR Q) (APPEND S L)))))))) + +(defthm limbo-sound + (implies (and (ceval-list q i) (ceval-list s i) (ceval-list l i)) + (ceval-list (initial-limbo q s l) i))) + +;; Incorporating the limbo list is sound + +;; positive direction + +(defthm ceval-extract + (implies (ceval-list s i) + (ceval-list (extract-rewritables x s) i))) + +(defthm special-ppd-sound-1 + (implies (and (ceval-list d i) + (ceval-list s i) + (ceval-list r i)) + (ceval-list (special-ppd d s r) i))) + +(defthm process-limbo-sound + (implies (and (ceval-list l i) + (ceval-list s i)) + (ceval-list (process-limbo l s) i))) + +;; negative direction + +(defthm special-ppd-sound-2 + (implies (and (ceval-list r i) + (ceval-list s i) + (not (ceval-list d i))) + (not (ceval-list (special-ppd d s r) i))) + :hints (("Subgoal *1/2" + :in-theory (disable true-symbolp-ceval) + :use ((:instance true-symbolp-ceval + (x (simplify (car d) (append s (cdr d) r)))))))) + +(defthm extract-remove-together + (implies (and (ceval-list (extract-rewritables x s) i) + (ceval-list (remove-rewritables x s) i)) + (ceval-list s i)) + :rule-classes ((:rewrite :match-free :all))) + +(defthm ceval-append-big-helper + (implies + (and (true-listp l) + (true-listp s) + (ceval-list r i) + (not (ceval-list (append l s) i))) + (not (ceval-list (append l + (special-ppd (extract-rewritables x s) + (append (remove-rewritables x s) + (cons x l)) + r) + (cons x (remove-rewritables x s))) + i))) + :hints (("goal" :do-not-induct t + :cases ((and (ceval x i) + (ceval-list l i) + (ceval-list (remove-rewritables x s) i)) + (not (and (ceval x i) + (ceval-list l i) + (ceval-list (remove-rewritables x s) i))))) + ("subgoal 2" + :in-theory (disable special-ppd-sound-2) + :use ((:instance + special-ppd-sound-2 + (d (extract-rewritables x s)) + (s (append (remove-rewritables x s) (cons x l)))))))) + +(defthm process-limbo-sound-append + (implies (and (true-listp l) + (true-listp s) + (not (ceval-list (append l s) i))) + (not (ceval-list (process-limbo l s) i))) + :hints (("goal" :induct (process-limbo l s)))) + + +;; putting things together +(defthm split-process-sound-1 + (implies (and (true-listp s) + (ceval-list q i) + (ceval-list s i)) + (ceval-list (limbo-incorporation q s) i))) + +(defthm split-process-sound-2 + (implies (and (true-listp s) + (not (ceval-list q i)) + (ceval-list s i)) + (not (ceval-list (limbo-incorporation q s) i)))) + +(defthm limbo-incorporation-sound-iff + (implies (true-listp s) + (iff (and (ceval-list q i) (ceval-list s i)) + (ceval-list (limbo-incorporation q s) i))) + :hints (("Goal" :use (split-process-sound-1 split-process-sound-2))) + :rule-classes nil) + +;; top soundness lemma +(defthm limbo-incorporation-is-sound + (implies (true-listp s) + (equal (ceval-list (limbo-incorporation q s) i) + (and (ceval-list q i) (ceval-list s i)))) + :hints (("goal" + :in-theory (disable limbo-incorporation) + :use limbo-incorporation-sound-iff))) + diff --git a/books/workshops/2003/moore_rockwell/report.pdf.gz b/books/workshops/2003/moore_rockwell/report.pdf.gz Binary files differnew file mode 100644 index 0000000..5c8cd9f --- /dev/null +++ b/books/workshops/2003/moore_rockwell/report.pdf.gz diff --git a/books/workshops/2003/moore_rockwell/report.ps.gz b/books/workshops/2003/moore_rockwell/report.ps.gz Binary files differnew file mode 100644 index 0000000..c0a268e --- /dev/null +++ b/books/workshops/2003/moore_rockwell/report.ps.gz diff --git a/books/workshops/2003/moore_rockwell/support/memory-taggings.lisp b/books/workshops/2003/moore_rockwell/support/memory-taggings.lisp new file mode 100644 index 0000000..8c7a79e --- /dev/null +++ b/books/workshops/2003/moore_rockwell/support/memory-taggings.lisp @@ -0,0 +1,1513 @@ +; Memory Taggings and Dynamic Data Structures} + +; J Strother Moore + +; Department of Computer Science +; University of Texas at Austin +; Austin, Texas 78701 +; moore@cs.utexas.edu + +; This book is described in the above paper. I have kept comments pretty +; sparse. + +; (certify-book "memory-taggings") + +(in-package "ACL2") + +; This file is presumed to be located at: + +; /projects/acl2/v2-8/books/workshops/2003/moore_rockwell/support/ + +(include-book "../../../../misc/records") +(include-book "../../../../arithmetic/top-with-meta") +(include-book "../../../../ordinals/e0-ordinal") +(set-well-founded-relation e0-ord-<) + +(defun seq-int (start len) + (if (zp len) + nil + (cons start + (seq-int (1+ start) (1- len))))) + +(defun unique (list) + (if (consp list) + (and (not (member (car list) (cdr list))) + (unique (cdr list))) + t)) + +(mutual-recursion + +(defun collect (typ ptr n ram dcl) + (declare (xargs :measure (cons (+ 1 (nfix n)) 0))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp n) + nil + (if (zp ptr) + nil + (if (atom descriptor) + nil + (append (seq-int ptr (len descriptor)) + (collect-lst typ + ptr + 0 + (- n 1) + ram + dcl))))))) + +(defun collect-lst (typ ptr i n ram dcl) + (declare (xargs :measure + (cons (+ 1 (nfix n)) + (nfix (- (len (cdr (assoc typ dcl))) (nfix i)))))) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + +; It makes life a little simpler if we always know that ptr is non-zero. + + (cond ((zp ptr) nil) + ((<= (len descriptor) i) nil) + ((symbolp slot-typ) + (append (collect slot-typ + (g (+ ptr i) ram) + n ram dcl) + (collect-lst typ + ptr + (+ 1 i) + n ram dcl))) + (t (collect-lst typ + ptr + (+ 1 i) + n ram dcl))))) +) + +; We next deal with marking arbitrary (non-pointer) elements in a +; given data structure at address ptr of type typ with a given +; descriptor. We need a constrained function to denote the value we +; wish to put into field i of that data structure. In actual +; applications we may wish the value to be a function of other fields, +; so we allow the function to see the ram. + +; We originally declared an unconstrained function to compute the new +; value: + +; (defstub new-field-value (typ ptr i ram) t). + +; But then we needed the fact that + +; (NEW-FIELD-VALUE TYP PTR K (S ADDR VAL RAM)) +; = +; (NEW-FIELD-VALUE TYP PTR K RAM) + +; in order to prove that we could commute an independent s out of the +; marking pass. So we provide the following constraint. + +(encapsulate + (((new-field-value * * * * *) => *)) + (local (defun new-field-value (typ ptr i ram dcl) + (declare (ignore typ ptr i ram dcl)) + 0)) + (defthm new-field-value-s-commutes + (implies (not (member addr (seq-int ptr (len (cdr (assoc typ dcl)))))) + (equal (new-field-value typ ptr i (s addr val ram) dcl) + (new-field-value typ ptr i ram dcl))))) + +; This contraint says that the new field value is impervious to writes +; ``far away'' from the field being smashed. More precisely, the the +; new field value is invariant under writes to locations outside the +; (immediate) data object. This means that it is permitted for the +; the new field value to look at other fields immediately within the +; data object. + +(defun s* (typ ptr i ram dcl) + (declare (xargs :measure (nfix (- (len (cdr (assoc typ dcl))) + (nfix i))))) + (let* ((descriptor (cdr (assoc typ dcl))) + (i (nfix i)) + (slot-typ (nth i descriptor))) + (cond + ((zp ptr) ram) + ((< i (len descriptor)) + (cond ((symbolp slot-typ) + (s* typ ptr (+ 1 i) ram dcl)) + (t (let ((ram (s (+ ptr i) + (new-field-value typ ptr i ram dcl) + ram))) + (s* typ ptr (+ 1 i) ram dcl))))) + (t ram)))) + +(mutual-recursion + +(defun mark (typ ptr n ram dcl) + (declare (xargs :measure (cons (+ 1 (nfix n)) 0))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp n) + ram + (if (zp ptr) + ram + (if (atom descriptor) + ram + (let ((ram (s* typ ptr 0 ram dcl))) + (mark-lst typ + ptr + 0 + (- n 1) + ram + dcl))))))) + +(defun mark-lst (typ ptr i n ram dcl) + (declare (xargs :measure + (cons (+ 1 (nfix n)) + (nfix (- (len (cdr (assoc typ dcl))) + (nfix i)))))) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond ((zp ptr) ram) + ((<= (len descriptor) i) ram) + ((symbolp slot-typ) + (let ((ram (mark slot-typ + (g (+ ptr i) ram) + n ram dcl))) + (mark-lst typ + ptr + (+ 1 i) + n ram dcl))) + (t (mark-lst typ + ptr + (+ 1 i) + n ram dcl))))) +) + +(defun compose-bab (typ1 ptr1 n1 typ2 ptr2 n2 typ3 ptr3 n3 ram dcl) + (let ((ram (mark typ1 ptr1 n1 ram dcl))) + (let ((ram (mark typ2 ptr2 n2 ram dcl))) + (let ((ram (mark typ3 ptr3 n3 ram dcl))) + ram)))) + +; Utility Functions and Lemmas + +(defthm g-s + (equal (g x (s y v r)) + (if (equal x y) + v + (g x r)))) + +(defthm member-append + (iff (member e (append a b)) + (or (member e a) + (member e b)))) + +; [Removed by Matt K. to handle changes to member, assoc, etc. after ACL2 4.2.] +; (defun intersectp (x y) +; (declare (xargs :guard (and (eqlable-listp x) +; (eqlable-listp y)))) +; (cond ((endp x) nil) +; ((member (car x) y) t) +; (t (intersectp (cdr x) y)))) + +(defthm unique-append + (iff (unique (append a b)) + (and (unique a) + (unique b) + (not (intersectp a b))))) + +(defthm intersectp-append-1 + (iff (intersectp c (append a b)) + (or (intersectp c a) + (intersectp c b)))) + +(defthm intersectp-append-2 + (iff (intersectp (append a b) c) + (or (intersectp a c) + (intersectp b c)))) + +; (SET-MATCH-FREE-ERROR NIL) + +(defthm member-intersection-1 + (implies (and (not (intersectp b a)) + (member ptr b)) + (not (member ptr a)))) + +(encapsulate + nil + (local + (defthm intersectp-commutes-1 + (implies (not (member a1 b)) + (equal (intersectp b (cons a1 a2)) + (intersectp b a2))))) + + (local + (defthm intersectp-commutes-2 + (implies (member a1 b) + (intersectp b (cons a1 a2))))) + + (defthm intersectp-commutes + (iff (intersectp a b) + (intersectp b a)))) + +(defthm member-seq-int + (implies (integerp j) + (iff (member i (seq-int j n)) + (if (zp n) + nil + (and (integerp i) + (<= j i) + (< i (+ j n))))))) + +; --------------------------------------------------------------------------- +; Some key properties of s* + +(defthm s*-s-commutes + (implies (not (member addr (seq-int ;(+ i ptr) + ptr + (len (cdr (assoc typ dcl)))))) + (equal (s* typ ptr i (s addr val ram) dcl) + (s addr val (s* typ ptr i ram dcl))))) + +(defthm g-s* + (implies (not (member addr (seq-int ptr (len (cdr (assoc typ dcl)))))) + (equal (g addr (s* typ ptr i ram dcl)) + (g addr ram)))) + +(defthm member-intersection-2 + (implies (and (not (intersectp a b)) + (member e b)) + (not (member e a)))) + +(defthm new-field-value-s* + (implies (and (integerp i2) + (<= 0 i2) + (not (intersectp + (seq-int (+ i2 ptr2) + (- (len (cdr (assoc typ2 dcl))) i2)) + (seq-int ptr1 (len (cdr (assoc typ1 dcl))))))) + (equal (new-field-value typ1 ptr1 i1 (s* typ2 ptr2 i2 ram dcl) dcl) + (new-field-value typ1 ptr1 i1 ram dcl)))) + +(defthm subsetp-seq-int + (implies (and (not (zp ptr1)) + (integerp i1) + (<= 0 i1)) + (subsetp (seq-int (+ i1 ptr1) + (+ (- i1) n1)) + (seq-int ptr1 n1)))) + +(defthm intersectp-subsetp + (implies (and (not (intersectp a b)) + (subsetp a1 a)) + (not (intersectp b a1))) + :rule-classes ((:rewrite :match-free :all))) + +(defthm s*-s*-commutes + (implies (and (not (zp ptr1)) + (not (zp ptr2)) + (integerp i1) + (<= 0 i1) + (integerp i2) + (<= 0 i2) + (not (intersectp (seq-int ptr1 ;(+ i1 ptr1) + (len (cdr (assoc typ1 dcl)))) + (seq-int ptr2 ;(+ i2 ptr2) + (len (cdr (assoc typ2 dcl))))))) + (equal (s* typ1 ptr1 i1 (s* typ2 ptr2 i2 ram dcl) dcl) + (s* typ2 ptr2 i2 (s* typ1 ptr1 i1 ram dcl) dcl))) + :rule-classes ((:rewrite :loop-stopper ((typ1 typ2))))) + + + + +; --------------------------------------------------------------------------- +; More Proof-Specific Lemmas + +; Next I eliminate the mutual recursion and deal just with the +; fundamental functions collect-lst and mark-lst. I rename them ral +; and mal for brevity. + +(defun collect-fn (fn typ ptr i n ram dcl) + (declare (xargs :measure + (if (equal fn :ALL) + (cons (+ 1 (nfix n)) + (nfix (- (len (cdr (assoc typ dcl))) (nfix i)))) + (cons (+ 1 (nfix n)) 0)))) + (if (equal fn :ALL) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond ((zp ptr) nil) + ((<= (len descriptor) i) nil) + ((symbolp slot-typ) + (append (collect-fn :ONE slot-typ + (g (+ ptr i) ram) + i + n ram dcl) + (collect-fn :ALL typ + ptr + (+ 1 i) + n ram dcl))) + (t (collect-fn :ALL typ + ptr + (+ 1 i) + n ram dcl)))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp n) + nil + (if (zp ptr) + nil + (if (atom descriptor) + nil + (append (seq-int ptr (len descriptor)) + (collect-fn :ALL typ + ptr + 0 + (- n 1) + ram + dcl)))))))) + +(defun mark-fn (fn typ ptr i n ram dcl) + (declare (xargs :measure + (if (equal fn :ALL) + (cons (+ 1 (nfix n)) + (nfix (- (len (cdr (assoc typ dcl))) + (nfix i)))) + (cons (+ 1 (nfix n)) 0)))) + + (if (equal fn :ALL) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond ((zp ptr) ram) + ((<= (len descriptor) i) ram) + ((symbolp slot-typ) + (let ((ram (mark-fn :ONE slot-typ + (g (+ ptr i) ram) + i n ram dcl))) + (mark-fn :ALL typ + ptr + (+ 1 i) + n ram dcl))) + (t (mark-fn :ALL typ + ptr + (+ 1 i) + n ram dcl)))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp n) + ram + (if (zp ptr) + ram + (if (atom descriptor) + ram + (let ((ram (s* typ ptr 0 ram dcl))) + (mark-fn :ALL typ + ptr + 0 + (- n 1) + ram + dcl)))))))) + +(defun s*-tags-ok (typ ptr i dcl tags) + (declare (xargs :measure (nfix (- (len (cdr (assoc typ dcl))) + (nfix i))))) + (let* ((descriptor (cdr (assoc typ dcl))) + (i (nfix i)) + (slot-typ (nth i descriptor))) + (cond + ((zp ptr) t) + ((< i (len descriptor)) + (cond ((symbolp slot-typ) + (cond ((equal (g (+ ptr i) tags) :PTR) + (s*-tags-ok typ ptr (+ 1 i) dcl tags)) + (t nil))) + ((equal (g (+ ptr i) tags) :DATA) + (s*-tags-ok typ ptr (+ 1 i) dcl tags)) + (t nil))) + (t t)))) + +(defun tags-ok-fn (fn typ ptr i n ram dcl tags) + (declare (xargs :measure + (if (equal fn :ALL) + (cons (+ 1 (nfix n)) + (nfix (- (len (cdr (assoc typ dcl))) (nfix i)))) + (cons (+ 1 (nfix n)) 0)))) + (if (equal fn :ALL) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond ((zp ptr) t) + ((<= (len descriptor) i) t) + ((symbolp slot-typ) + (cond + ((equal (g (+ ptr i) tags) :PTR) + (and (tags-ok-fn :ONE slot-typ + (g (+ ptr i) ram) + i + n ram dcl tags) + (tags-ok-fn :ALL typ + ptr + (+ 1 i) + n ram dcl tags))) + (t nil))) + ((equal (g (+ ptr i) tags) :DATA) + (tags-ok-fn :ALL typ + ptr + (+ 1 i) + n ram dcl tags)) + (t nil))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp n) + t + (if (zp ptr) + t + (if (atom descriptor) + t + (and (s*-tags-ok typ ptr 0 dcl tags) + (tags-ok-fn :ALL typ + ptr + 0 + (- n 1) + ram + dcl tags)))))))) + +(defthm auto-open-collect-fn + (implies (if (equal fn :ALL) + (< (nfix i) (len (cdr (assoc typ dcl)))) + (not (zp n))) + (equal (collect-fn fn typ ptr i n ram dcl) + (if (equal fn :ALL) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond + ((zp ptr) nil) + ((symbolp slot-typ) + (append (collect-fn :ONE slot-typ + (g (+ ptr i) ram) + i + n ram dcl) + (collect-fn :ALL typ + ptr + (+ 1 i) + n ram dcl))) + (t (collect-fn :ALL typ + ptr + (+ 1 i) + n ram dcl)))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp ptr) + nil + (if (atom descriptor) + nil + (append (seq-int ptr (len descriptor)) + (collect-fn :ALL typ + ptr + 0 + (- n 1) + ram + dcl))))))))) + +(defthm auto-open-mark-fn + (implies (if (equal fn :ALL) + (< (nfix i) (len (cdr (assoc typ dcl)))) + (not (zp n))) + (equal (mark-fn fn typ ptr i n ram dcl) + (if (equal fn :ALL) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond ((zp ptr) ram) + ((<= (len descriptor) i) ram) + ((symbolp slot-typ) + (let ((ram (mark-fn :ONE slot-typ + (g (+ ptr i) ram) + i n ram dcl))) + (mark-fn :ALL typ + ptr + (+ 1 i) + n ram dcl))) + (t (mark-fn :ALL typ + ptr + (+ 1 i) + n ram dcl)))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp n) + ram + (if (zp ptr) + ram + (if (atom descriptor) + ram + (let ((ram (s* typ ptr 0 ram dcl))) + (mark-fn :ALL typ + ptr + 0 + (- n 1) + ram + dcl)))))))))) + +(defthm auto-open-tags-ok-fn + (implies (if (equal fn :ALL) + (< (nfix i) (len (cdr (assoc typ dcl)))) + (not (zp n))) + (equal (tags-ok-fn fn typ ptr i n ram dcl tags) + (if (equal fn :ALL) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond ((zp ptr) t) + ((symbolp slot-typ) + (cond + ((equal (g (+ ptr i) tags) :PTR) + (and (tags-ok-fn :ONE slot-typ + (g (+ ptr i) ram) + i + n ram dcl tags) + (tags-ok-fn :ALL typ + ptr + (+ 1 i) + n ram dcl tags))) + (t nil))) + ((equal (g (+ ptr i) tags) :DATA) + (tags-ok-fn :ALL typ + ptr + (+ 1 i) + n ram dcl tags)) + (t nil))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp ptr) + t + (if (atom descriptor) + t + (and (s*-tags-ok typ ptr 0 dcl tags) + (tags-ok-fn :ALL typ + ptr + 0 + (- n 1) + ram + dcl tags))))))))) + + +(defthm assoc-append + (equal (append (append a b) c) + (append a (append b c)))) + +(defthm equal-len-0 + (equal (equal (len x) 0) + (not (consp x)))) + +(defthm collect-s + (implies (and (tags-ok-fn fn typ ptr i n ram dcl tags) + (equal (g addr tags) :DATA)) + (equal (collect-fn fn typ ptr i n (s addr val ram) dcl) + (collect-fn fn typ ptr i n ram dcl)))) + +(defthm intersectp-seq-int-cons + (implies (and (not (zp ptr1)) + (integerp ptr2) + (<= ptr1 ptr2) + (< ptr2 (+ (nfix n) ptr1))) + (intersectp (seq-int ptr1 n) + (cons ptr2 lst)))) + +(defthm tags-ok-fn-s + (implies (equal (g ptr1 tags) :DATA) + (equal (tags-ok-fn fn typ ptr i n + (s ptr1 val ram) + dcl tags) + (tags-ok-fn fn typ ptr i n + ram dcl tags)))) + +(defthm collect-fn-s* + (implies (and (tags-ok-fn fn typ ptr i n ram dcl tags) + (s*-tags-ok typ1 ptr1 k1 dcl tags)) + (equal (collect-fn fn typ ptr i n + (s* typ1 ptr1 k1 ram dcl) + dcl) + (collect-fn fn typ ptr i n ram dcl)))) + +(defthm hack2a + (implies (and (integerp k) + (integerp kmax) + (<= 0 k) + (< k kmax) + (integerp ptr)) + (member (+ k ptr) (seq-int ptr kmax)))) + +(defthm hack2b + (implies (and (not (intersectp a b)) + (member e b)) + (not (member e a)))) + +(defthm hack2 + (implies + (and (not (intersectp a + (seq-int ptr1 k1max))) + (not (zp ptr1)) + (integerp k1) + (<= 0 k1) + (< k1 k1max) + (integerp k1max)) + (not (member (+ k1 ptr1) a)))) + +(defthm unique-seq-int-lemma + (implies (< e ptr) + (not (member e (seq-int ptr n))))) + +(defthm unique-seq-int + (unique (seq-int ptr n))) + +(defthm intersectp-hack1 + (implies (intersectp a b) + (intersectp a (cons ptr1 b)))) + +(defthm intersectp-x-x + (iff (intersectp x x) + (consp x))) + +(defthm consp-seq-int + (equal (consp (seq-int ptr n)) + (not (zp n)))) + +(defthm tags-ok-fn-s* + (implies (s*-tags-ok typ ptr i dcl tags) + (equal (tags-ok-fn fn1 typ1 ptr1 i1 n1 + (s* typ ptr i ram dcl) + dcl tags) + (tags-ok-fn fn1 typ1 ptr1 i1 n1 ram dcl tags)))) + +(defthm g-s*-new + (implies (and (s*-tags-ok typ ptr i dcl tags) + (equal (g ptr1 tags) :ptr)) + (equal (g ptr1 (s* typ ptr i ram dcl)) + (g ptr1 ram)))) + + +(defun tags-ok-fn-mark-fn-hint (fn typ ptr i n ram dcl tags + fn1 typ1 ptr1 i1 n1) + (declare (xargs :measure + (if (equal fn :ALL) + (cons (+ 1 (nfix n)) + (nfix (- (len (cdr (assoc typ dcl))) + (nfix i)))) + (cons (+ 1 (nfix n)) 0)))) + + (if (equal fn :ALL) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond ((zp ptr) (list tags fn1 typ1 ptr1 i1 n1)) + ((<= (len descriptor) i) ram) + ((symbolp slot-typ) + (let ((ram1 (mark-fn :ONE slot-typ + (g (+ ptr i) ram) + i n ram dcl))) + (list + (tags-ok-fn-mark-fn-hint :ONE slot-typ + (g (+ ptr i) ram) + i n ram dcl tags + fn1 typ1 ptr1 i1 n1) + (tags-ok-fn-mark-fn-hint :ONE slot-typ + (g (+ ptr i) ram) + i n ram dcl tags + :ALL typ ptr (+ i 1) n) + (tags-ok-fn-mark-fn-hint :ALL typ + ptr + (+ 1 i) + n ram1 dcl tags + fn1 typ1 ptr1 i1 n1) + ))) + (t (tags-ok-fn-mark-fn-hint :ALL typ + ptr + (+ 1 i) + n ram dcl tags + fn1 typ1 ptr1 i1 n1)))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp n) + ram + (if (zp ptr) + ram + (if (atom descriptor) + ram + (let ((ram (s* typ ptr 0 ram dcl))) + (tags-ok-fn-mark-fn-hint :ALL typ + ptr + 0 + (- n 1) + ram + dcl tags + fn1 typ1 ptr1 i1 n1)))))))) + +(defthm tags-ok-fn-mark-fn + (implies (tags-ok-fn fn2 typ2 ptr2 i2 n2 ram dcl tags) + (equal (tags-ok-fn fn1 typ1 ptr1 i1 n1 + (mark-fn fn2 typ2 ptr2 i2 n2 ram dcl) + dcl tags) + (tags-ok-fn fn1 typ1 ptr1 i1 n1 ram dcl tags))) + :hints (("Goal" + :induct + (tags-ok-fn-mark-fn-hint fn2 typ2 ptr2 i2 n2 ram dcl tags + fn1 typ1 ptr1 i1 n1)))) + + +; Generalized Challenge Theorem 1 (first of two parts) +(defthm g-mark-fn-1 + (implies (and (tags-ok-fn fn typ ptr i n ram dcl tags) + (equal (g addr tags) :PTR)) + (equal (g addr (mark-fn fn typ ptr i n ram dcl)) + (g addr ram))) + :hints (("Goal" :induct (mark-fn fn typ ptr i n ram dcl)))) + +(defthm collect-fn-mark-fn + (implies (and (tags-ok-fn fn1 typ1 ptr1 i1 n1 ram dcl tags) + (tags-ok-fn fn2 typ2 ptr2 i2 n2 ram dcl tags)) + (equal (collect-fn fn1 typ1 ptr1 i1 n1 + (mark-fn fn2 typ2 ptr2 i2 n2 ram dcl) + dcl) + (collect-fn fn1 typ1 ptr1 i1 n1 ram dcl))) + :hints (("Goal" :induct (mark-fn fn2 typ2 ptr2 i2 n2 ram dcl)))) + +; Generalized Challenge Theorem 1 (second part) +(defthm g-mark-fn-2 + (implies (and (not (member addr (collect-fn fn typ ptr i n ram dcl))) + (tags-ok-fn fn typ ptr i n ram dcl tags)) + (equal (g addr (mark-fn fn typ ptr i n ram dcl)) + (g addr ram))) + :hints (("Goal" :induct (mark-fn fn typ ptr i n ram dcl)))) + +; Now I will relate collect and collect-lst to collect-fn, etc. + +(defthm collect-is-collect-fn-main + (equal (collect-fn fn typ ptr i n ram dcl) + (if (equal fn :ALL) + (collect-lst typ ptr i n ram dcl) + (collect typ ptr n ram dcl))) + :rule-classes nil) + +(defthm collect-is-collect-fn + (and (equal (collect typ ptr n ram dcl) + (collect-fn :ONE typ ptr i n ram dcl)) + (equal (collect-lst typ ptr i n ram dcl) + (collect-fn :ALL typ ptr i n ram dcl))) + :hints (("Goal" :use ((:instance collect-is-collect-fn-main (fn ':ONE)) + (:instance collect-is-collect-fn-main (fn :ALL)))))) + +(defthm mark-is-mark-fn-main + (equal (mark-fn fn typ ptr i n ram dcl) + (if (equal fn :ALL) + (mark-lst typ ptr i n ram dcl) + (mark typ ptr n ram dcl))) + :rule-classes nil) + +(defthm mark-is-mark-fn + (and (equal (mark typ ptr n ram dcl) + (mark-fn :ONE typ ptr i n ram dcl)) + (equal (mark-lst typ ptr i n ram dcl) + (mark-fn :ALL typ ptr i n ram dcl))) + :hints (("Goal" :use ((:instance mark-is-mark-fn-main (fn ':ONE)) + (:instance mark-is-mark-fn-main (fn :ALL)))))) + +; Generalized Challenge Theorem 2 +(defthm read-over-bab + (implies + (and (tags-ok-fn :ONE typ1 ptr1 i n1 ram dcl tags) + (tags-ok-fn :ONE typ2 ptr2 i n2 ram dcl tags) + (tags-ok-fn :ONE typ3 ptr3 i n3 ram dcl tags) + (not (member addr (append (collect typ1 ptr1 n1 ram dcl) + (collect typ2 ptr2 n2 ram dcl) + (collect typ3 ptr3 n3 ram dcl))))) + (equal + (g addr (compose-bab typ1 ptr1 n1 + typ2 ptr2 n2 + typ3 ptr3 n3 + ram dcl)) + (g addr ram))) + :hints (("Goal" :restrict ((g-mark-fn-2 ((tags tags))) + (TAGS-OK-FN-MARK-FN ((tags tags))) + (COLLECT-FN-MARK-FN ((tags tags))))))) + +(defthm mark-fn-s + (implies (and (equal (g addr tags) :DATA) + (not (member addr + (collect-fn fn typ ptr i n ram dcl))) + (tags-ok-fn fn typ ptr i n ram dcl tags)) + (equal (mark-fn fn typ ptr i n (s addr val ram) dcl) + (s addr val (mark-fn fn typ ptr i n ram dcl)))) + :hints (("Goal" :induct (mark-fn fn typ ptr i n ram dcl)))) + +(defthm new-field-value-s* + (implies + (and + (integerp i2) + (<= 0 i2) + (not + (intersectp (seq-int (+ i2 ptr2) + (- (len (cdr (assoc typ2 dcl))) i2)) + (seq-int ptr1 (len (cdr (assoc typ1 dcl))))))) + (equal + (new-field-value typ1 ptr1 i1 (s* typ2 ptr2 i2 ram dcl) + dcl) + (new-field-value typ1 ptr1 i1 ram dcl)))) + +(defthm new-field-value-mark-fn + (implies (and (not (intersectp (seq-int ptr2 + (len (cdr (assoc typ2 dcl)))) + (collect-fn fn typ ptr i n ram dcl))) + (tags-ok-fn fn typ ptr i n ram dcl tags)) + (equal + (new-field-value typ2 + ptr2 i2 (mark-fn fn typ ptr i n ram dcl) + dcl) + (new-field-value typ2 ptr2 i2 ram dcl))) + :hints (("Goal" :induct (mark-fn fn typ ptr i n ram dcl)))) + +; It ain't pretty, but I'm just trying to finish! + +(defthm mark-fn-s* + (implies (and (not (intersectp (seq-int ptr2 ;(+ ptr2 i2) + (len (cdr (assoc typ2 dcl))) ;(- i2) + ) + (collect-fn fn typ ptr i n ram dcl))) + (tags-ok-fn fn typ ptr i n ram dcl tags) + (s*-tags-ok typ2 ptr2 i2 dcl tags)) + (equal (mark-fn fn typ ptr i n (s* typ2 ptr2 i2 ram dcl) dcl) + (s* typ2 ptr2 i2 (mark-fn fn typ ptr i n ram dcl) dcl))) + :hints (("Goal" :restrict ((new-field-value-mark-fn ((tags tags))) + (mark-fn-s ((tags tags))))))) + +(defthm g-mark-fn + (implies (and (not (member ptr2 + (collect-fn fn typ ptr i n ram dcl))) + (tags-ok-fn fn typ ptr i n ram dcl tags)) + (equal (g ptr2 (mark-fn fn + typ ptr i n ram + dcl)) + (g ptr2 ram))) + :hints (("Goal" :induct (MARK-FN FN TYP PTR I N RAM DCL)))) + +; Generalized Challenge Theorem 3 + +(defthm mark-fn-mark-fn + (implies (and (tags-ok-fn fn1 typ1 ptr1 i1 n1 ram dcl tags) + (tags-ok-fn fn2 typ2 ptr2 i2 n2 ram dcl tags) + (not (intersectp (collect-fn fn1 typ1 ptr1 i1 n1 ram dcl) + (collect-fn fn2 typ2 ptr2 i2 n2 ram dcl)))) + (equal (mark-fn fn1 typ1 ptr1 i1 n1 + (mark-fn fn2 typ2 ptr2 i2 n2 ram dcl) + dcl) + (mark-fn fn2 typ2 ptr2 i2 n2 + (mark-fn fn1 typ1 ptr1 i1 n1 ram dcl) + dcl))) + :hints (("Goal" + :induct (MARK-FN FN2 TYP2 PTR2 I2 N2 RAM DCL) + :restrict ((g-mark-fn ((tags tags))) + (MARK-FN-S* ((tags tags))))))) + +; ---- + +; What makes the above work relevant to the Rockwell challenge, which +; may be characterized by its focus on the collection of relevant +; addresses and their disjointness? The key observations are two. + +; First, if the collection of addresses is unique, then there exists a +; tagging that satisfies tags-ok-fn. The idea is that if the collection +; is unique, each address is visited only once and the tagging can +; assign which ever tag is used. + +; Second, if you have a tagging for each of two pointers and the corresponding +; collections are disjoint, you can assemble a tagging that works for both. +; The idea here is that you take one of the working taggings and move into it +; all the taggings from the other one, exploiting the disjointness to know that +; you have not disturbed the other tagging. + +; I prove the second result first. + +(defun merge-tags (addrs tags1 tags2) + (cond ((endp addrs) tags2) + (t (s (car addrs) + (g (car addrs) tags1) + (merge-tags (cdr addrs) tags1 tags2))))) + +(defthm g-merge-tags + (equal (g addr (merge-tags addrs tags1 tags2)) + (if (member addr addrs) + (g addr tags1) + (g addr tags2)))) + +(defthm merge-tags-append + (equal (merge-tags (append a b) tags1 tags2) + (merge-tags a tags1 (merge-tags b tags1 tags2)))) + +(defthm merge-tags-s + (equal (merge-tags a tags1 (s addr (g addr tags1) tags)) + (s addr (g addr tags1) (merge-tags a tags1 tags))) + :hints (("Subgoal *1/2''" :cases ((equal (car a) addr))))) + +(defthm merge-tags-commutes + (equal (merge-tags a tags1 (merge-tags b tags1 tags2)) + (merge-tags b tags1 (merge-tags a tags1 tags2)))) + +(defthm s*-tags-ok-merge-tags-1 + (implies (and (s*-tags-ok typ ptr i dcl tags) + (not (intersectp addrs + (seq-int ptr (len (cdr (assoc typ dcl))))))) + (s*-tags-ok typ ptr i dcl + (merge-tags addrs tags1 tags)))) + +(defthm s*-tags-ok-s + (implies (force + (not (member addr (seq-int (+ ptr (nfix i)) + (- (len (cdr (assoc typ dcl))) + (nfix i)))))) + (equal (s*-tags-ok typ ptr i dcl (s addr val tags)) + (s*-tags-ok typ ptr i dcl tags)))) + +; I just proved the theorem below. When I first tried it, I used the +; hypothesis that addr was not a member of + +; (collect-fn fn typ ptr i n ram dcl). + +; But that is not a theorem. I then changed that collection to + +; (append +; (if (equal fn :ALL) +; (seq-int ptr (len (cdr (assoc typ dcl)))) +; nil) +; (collect-fn fn typ ptr i n ram dcl)) + +; You might ask why I need the stronger hypothesis? Suppose we use +; the weaker hypothesis. Then it might be that addr is ptr and fn is +; :ALL. The reason is that ptr does not generally occur in the :ALL +; collection from ptr. So if we smash ptr with (s addr val tags) -- +; when addr is ptr -- then the :ALL collect ends up treating ptr as of +; type val. instead of its old type. Because I will need this +; hypothesis repeatedly, I define a stronger version of collect-fn. + +(defun kollect-fn (fn typ ptr i n ram dcl) + (append + (if (equal fn :ALL) + (seq-int (+ ptr (nfix i)) + (- (len (cdr (assoc typ dcl))) + (nfix i))) + nil) + (collect-fn fn typ ptr i n ram dcl))) + +(defthm tags-ok-fn-s-tags + (implies (not (member addr (kollect-fn fn typ ptr i n ram dcl))) + (equal (tags-ok-fn fn typ ptr i n ram dcl + (s addr tag tags)) + (tags-ok-fn fn typ ptr i n ram dcl tags)))) + +(defthm s*-tags-ok-merge-tags + (implies (not (intersectp addrs + (seq-int (+ ptr (nfix i)) + (- (len (cdr (assoc typ dcl))) + (nfix i))))) + (equal (s*-tags-ok typ ptr i dcl (merge-tags addrs tag1 tags)) + (s*-tags-ok typ ptr i dcl tags)))) + + +(defthm tags-ok-fn-merge-tags-2 + (implies (not (intersectp addrs + (kollect-fn fn typ ptr i n ram dcl))) + (equal (tags-ok-fn fn typ ptr i n ram dcl + (merge-tags addrs tags1 tags)) + (tags-ok-fn fn typ ptr i n ram dcl tags)))) + +(defthm s*-tags-ok-merge-tags-2 + (implies (and (not (zp ptr)) + (integerp i) + (<= 0 i) + (< i (len (cdr (assoc typ dcl))))) + (equal (s*-tags-ok typ ptr i dcl + (merge-tags + (seq-int (+ i ptr) + (- (len (cdr (assoc typ dcl))) + i)) + tags1 tags2)) + (s*-tags-ok typ ptr i dcl tags1)))) + +(defthm s*-tags-ok-merge-tags-2-0 + (implies (and (not (zp ptr)) + (consp (cdr (assoc typ dcl)))) + (equal (s*-tags-ok typ ptr 0 dcl + (merge-tags + (seq-int ptr + (len (cdr (assoc typ dcl)))) + tags1 tags2)) + (s*-tags-ok typ ptr 0 dcl tags1))) + :hints (("Goal" :use (:instance s*-tags-ok-merge-tags-2 (i 0))))) + +(defthm s-merge-tags-noop-1 + (implies (member addr addrs) + (equal (s addr (g addr tags1) (merge-tags addrs tags1 tags2)) + (merge-tags addrs tags1 tags2))) + :hints (("Goal" :induct (member addr addrs)))) + +(defthm s-merge-tags-noop-2 + (implies (not (member addr addrs)) + (equal (s addr (g addr tags2) (merge-tags addrs tags1 tags2)) + (merge-tags addrs tags1 tags2))) + :hints (("Goal" :induct (member addr addrs)))) + +(defthm s-merge-tags-noop-val-1 + (implies (and (member addr addrs) + (equal (g addr tags1) val)) + (equal (s addr val (merge-tags addrs tags1 tags2)) + (merge-tags addrs tags1 tags2)))) + +(defthm s-merge-tags-noop-val-2 + (implies (and (not (member addr addrs)) + (equal (g addr tags2) val)) + (equal (s addr val (merge-tags addrs tags1 tags2)) + (merge-tags addrs tags1 tags2)))) + +(defthm merge-tags-s-commutes-val + (implies (equal (g addr tags1) val) + (equal (merge-tags a tags1 (s addr val tags2)) + (s addr val (merge-tags a tags1 tags2))))) + +(defthm s-merge-tags-noop-val-kb-hack + (implies (and (member addr addrs1) + (equal (g addr tags1) val)) + (equal (s addr + val + (merge-tags addrs3 + tags1 + (merge-tags addrs2 + tags1 + (merge-tags addrs1 tags1 tags2)))) + (merge-tags addrs3 + tags1 + (merge-tags addrs2 + tags1 + (merge-tags addrs1 tags1 tags2)))))) + +(defun tags-ok-fn-merge-tags-3-hint (fn typ ptr i n ram dcl tags addrs2) + (declare (xargs :measure + (if (equal fn :ALL) + (cons (+ 1 (nfix n)) + (nfix (- (len (cdr (assoc typ dcl))) (nfix i)))) + (cons (+ 1 (nfix n)) 0)))) + (if (equal fn :ALL) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond ((zp ptr) (list addrs2)) + ((<= (len descriptor) i) t) + ((symbolp slot-typ) + (cond + ((equal (g (+ ptr i) tags) :PTR) + (list (tags-ok-fn-merge-tags-3-hint + :ONE slot-typ (g (+ ptr i) ram) i n ram dcl tags + (cons (+ ptr i) + (append (kollect-fn :ALL typ ptr (+ i 1) n ram dcl) + addrs2))) + + (tags-ok-fn-merge-tags-3-hint + :ONE slot-typ (g (+ ptr i) ram) i n ram dcl tags + (append (kollect-fn :ALL typ ptr (+ i 1) n ram dcl) + addrs2)) + + (tags-ok-fn-merge-tags-3-hint + :ALL typ ptr (+ 1 i) n ram dcl tags + (cons (+ ptr i) + (append (collect-fn :ONE + (nth i (cdr (assoc typ dcl))) + (g (+ ptr i) ram) + i n ram dcl) + addrs2))) + + (tags-ok-fn-merge-tags-3-hint + :ALL typ ptr (+ 1 i) n ram dcl tags + (append (collect-fn :ONE + (nth i (cdr (assoc typ dcl))) + (g (+ ptr i) ram) + i n ram dcl) + addrs2)))) + (t nil))) + ((equal (g (+ ptr i) tags) :DATA) + (list (tags-ok-fn-merge-tags-3-hint + :ALL typ ptr (+ 1 i) n ram dcl tags + (cons (+ ptr i) + addrs2)) + (tags-ok-fn-merge-tags-3-hint + :ALL typ ptr (+ 1 i) n ram dcl tags + addrs2))) + + (t nil))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp n) + t + (if (zp ptr) + t + (if (atom descriptor) + t + (list (s*-tags-ok typ ptr 0 dcl tags) + (tags-ok-fn-merge-tags-3-hint + :ALL typ ptr 0 (- n 1) ram dcl tags + addrs2)))))))) + +(defthm tags-ok-fn-merge-tags-3-main-lemma + (equal (tags-ok-fn fn typ ptr i n ram dcl + (merge-tags (append (kollect-fn fn typ ptr i n ram dcl) + addrs2) + tags1 + tags2)) + (tags-ok-fn fn typ ptr i n ram dcl tags1)) + :hints (("Goal" + :induct + (tags-ok-fn-merge-tags-3-hint fn typ ptr i n ram dcl tags1 addrs2)) + ("Subgoal *1/10" :in-theory (disable merge-tags-commutes))) + :rule-classes nil) + +(defthm true-listp-kollect-fn + (true-listp (kollect-fn fn typ ptr i n ram dcl))) + +(defthm append-right-id + (implies (true-listp lst) (equal (append lst nil) lst))) + +; The following theorem establishes that if you have a tagging for a +; given pointer then merging preserves it as a tagging. This +; preservation is assured provided the good tagging is first of the +; two taggings merged. Note that tags-ok-fn-merge-tags-2 handles the +; other case. That is, if the merging maps over a list that has no +; intersection with the kollection, then the second tagging is +; preserved. + +(defthm tags-ok-fn-merge-tags-3 + (equal (tags-ok-fn fn typ ptr i n ram dcl + (merge-tags (kollect-fn fn typ ptr i n ram dcl) + tags1 + tags2)) + (tags-ok-fn fn typ ptr i n ram dcl tags1)) + :hints (("Goal" :in-theory (disable kollect-fn) + :use (:instance tags-ok-fn-merge-tags-3-main-lemma + (addrs2 nil))))) + +(defthm tags-ok-fn-merge-tags-3-corollary + (equal (tags-ok-fn :ONE typ ptr i n ram dcl + (merge-tags (collect-fn :ONE typ ptr i n ram dcl) + tags1 + tags2)) + (tags-ok-fn :ONE typ ptr i n ram dcl tags1)) + :hints (("Goal" + :use (:instance tags-ok-fn-merge-tags-3-main-lemma + (addrs2 nil) + (fn :ONE))))) + + +; Next, I turn to the problem of generating a tagging. I will use +; merge-tags to define the constructor. This allows me to decompose +; the recursive into simple recursion instead of reflexive recursion. + +(defun s*-tags-witness (typ ptr i dcl) + (declare (xargs :measure (nfix (- (len (cdr (assoc typ dcl))) + (nfix i))))) + (let* ((descriptor (cdr (assoc typ dcl))) + (i (nfix i)) + (slot-typ (nth i descriptor))) + (cond + ((zp ptr) nil) + ((< i (len descriptor)) + (cond ((symbolp slot-typ) + (s (+ ptr i) :PTR + (s*-tags-witness typ ptr (+ 1 i) dcl))) + (t + (s (+ ptr i) :DATA + (s*-tags-witness typ ptr (+ 1 i) dcl))))) + (t nil)))) + +(defthm g-s*-tags-witness + (implies (and (not (zp ptr)) + (integerp i) + (<= 0 i) + (< i (len (cdr (assoc typ dcl))))) + (EQUAL (G addr + (S*-TAGS-WITNESS TYP PTR I DCL)) + (if (member addr + (seq-int (+ ptr i) + (- (len (cdr (assoc typ dcl))) i))) + (if (symbolp (nth (- addr ptr) + (cdr (assoc typ dcl)))) + :PTR + :DATA) + nil)))) + +(defthm s*-tags-ok-s-unforced + (implies + (not (member addr + (seq-int (+ ptr (nfix i)) + (- (len (cdr (assoc typ dcl))) + (nfix i))))) + (equal (s*-tags-ok typ ptr i dcl (s addr val tags)) + (s*-tags-ok typ ptr i dcl tags)))) + +(in-theory (disable s*-tags-ok-s)) + +(defthm s*-tags-ok-s*-tags-witness + (s*-tags-ok typ ptr i dcl + (s*-tags-witness typ ptr i dcl))) + +(defun tags-witness-fn (fn typ ptr i n ram dcl) + (declare (xargs :measure + (if (equal fn :ALL) + (cons (+ 1 (nfix n)) + (nfix (- (len (cdr (assoc typ dcl))) (nfix i)))) + (cons (+ 1 (nfix n)) 0)))) + (if (equal fn :ALL) + (let* ((descriptor (cdr (assoc typ dcl))) + (slot-typ (nth i descriptor)) + (i (nfix i))) + (cond ((zp ptr) nil) + ((<= (len descriptor) i) nil) + ((symbolp slot-typ) + (s (+ ptr i) :PTR + (merge-tags (collect-fn :ONE slot-typ + (g (+ ptr i) ram) + i + n ram dcl) + (tags-witness-fn :ONE slot-typ + (g (+ ptr i) ram) + i + n ram dcl) + (tags-witness-fn :ALL typ + ptr + (+ 1 i) + n ram dcl)))) + (t + (s (+ ptr i) :DATA + (tags-witness-fn :ALL typ + ptr + (+ 1 i) + n ram dcl))))) + (let ((descriptor (cdr (assoc typ dcl)))) + (if (zp n) + nil + (if (zp ptr) + nil + (if (atom descriptor) + nil + (merge-tags (seq-int ptr (len (cdr (assoc typ dcl)))) + (s*-tags-witness typ ptr 0 dcl) + (tags-witness-fn :ALL typ + ptr + 0 + (- n 1) + ram + dcl)))))))) + +(defthm weird-optimization-lemma-1 + (implies (and (not (member addr addrs)) + (equal (g addr tags2) val)) + (equal (merge-tags addrs + (s addr val tags1) + tags2) + (merge-tags addrs + tags1 + tags2)))) + +(defthm weird-optimization + (implies (and (not (zp ptr)) + (integerp i) + (<= 0 i) + (< i (len (cdr (assoc typ dcl)))) + (tags-ok-fn :ALL typ ptr i n ram dcl tags)) + (equal (merge-tags (seq-int (+ ptr i) + (- (len (cdr (assoc typ dcl))) i)) + (s*-tags-witness typ ptr i dcl) + tags) + tags)) + :hints + +; Subgoal numbers changed by Matt K. for v2-9 (probably needed because of +; change to call-stack). + + (("Subgoal *1/2.7''" :expand (SEQ-INT (+ I PTR) 1)) + ("Subgoal *1/1.7''" :expand (SEQ-INT (+ I PTR) 1)))) + +(defthm weird-optimization-corollary + (implies (and (not (zp ptr)) + (consp (cdr (assoc typ dcl))) + (tags-ok-fn :ALL typ ptr 0 n ram dcl tags)) + (equal (merge-tags (seq-int ptr + (len (cdr (assoc typ dcl)))) + (s*-tags-witness typ ptr 0 dcl) + tags) + tags)) + :hints (("Goal" :use (:instance weird-optimization (i 0))))) + + +(defthm weird-optimization-part-2 + (implies (and (not (zp ptr)) + (integerp i) + (<= 0 i) + (< i (len (cdr (assoc typ dcl)))) + (tags-ok-fn :ALL typ ptr i n ram dcl tags)) + (s*-tags-ok typ ptr i dcl tags))) + +(defthm positive-len + (equal (< 0 (len x)) + (consp x))) + +(defthm unique-implies-tags-exists + (implies (unique (kollect-fn fn typ ptr i n ram dcl)) + (tags-ok-fn fn typ ptr i n ram dcl + (tags-witness-fn fn typ ptr i n ram dcl)))) + + +(in-theory (disable kollect-fn)) + +; Now we assemble the various pieces. + +(defthm g-mark-fn-2-via-kollect-fn + (implies (and (unique (kollect-fn fn typ ptr i n ram dcl)) + (not (member addr (collect-fn fn typ ptr i n ram dcl)))) + (equal (g addr (mark-fn fn typ ptr i n ram dcl)) + (g addr ram))) + :hints (("Goal" :use unique-implies-tags-exists + :in-theory (disable unique-implies-tags-exists))) + :rule-classes nil) + +(defthm collect-fn-mark-fn-via-kollect-fn + (implies (and (unique (kollect-fn fn2 typ2 ptr2 i2 n2 ram dcl)) + (unique (kollect-fn fn1 typ1 ptr1 i1 n1 ram dcl)) + (not (intersectp (kollect-fn fn2 typ2 ptr2 i2 n2 ram dcl) + (kollect-fn fn1 typ1 ptr1 i1 n1 ram dcl)))) + (equal (collect-fn fn1 typ1 ptr1 i1 n1 + (mark-fn fn2 typ2 ptr2 i2 n2 ram dcl) + dcl) + (collect-fn fn1 typ1 ptr1 i1 n1 ram dcl))) + + :hints (("Goal" + :use + ((:instance unique-implies-tags-exists + (fn fn2) (typ typ2) (ptr ptr2) (i i2) (n n2)) + (:instance unique-implies-tags-exists + (fn fn1) (typ typ1) (ptr ptr1) (i i1) (n n1)) + (:instance + collect-fn-mark-fn + (tags (merge-tags + (kollect-fn fn2 typ2 ptr2 i2 n2 ram dcl) + (TAGS-WITNESS-FN FN2 TYP2 PTR2 I2 N2 RAM DCL) + (TAGS-WITNESS-FN FN1 TYP1 PTR1 I1 N1 RAM DCL))))) + :in-theory (disable unique-implies-tags-exists + collect-fn-mark-fn))) + :rule-classes nil) + +; Now I get rid of kollect-fn by focusing on the fn=:ONE case only. + +(defthm challenge-theorem-1-lemma + (implies (and (not (member addr (collect-fn :ONE typ ptr i n ram dcl))) + (unique (collect-fn :ONE typ ptr i n ram dcl))) + (equal (g addr (mark-fn :ONE typ ptr i n ram dcl)) + (g addr ram))) + + :hints (("Goal" :use + (:instance g-mark-fn-2-via-kollect-fn (fn :ONE)) + :in-theory (enable kollect-fn)))) + +(defthm challenge-theorem-1 + (implies (and (not (member addr (collect typ ptr n ram dcl))) + (unique (collect typ ptr n ram dcl))) + (equal (g addr (mark typ ptr n ram dcl)) + (g addr ram)))) + +(defthm challenge-theorem-2-lemma + (implies (unique (append (collect-fn :ONE typ2 ptr2 i2 n2 ram dcl) + (collect-fn :ONE typ1 ptr1 i1 n1 ram dcl))) + (equal (collect-fn :ONE typ1 ptr1 i1 n1 + (mark-fn :ONE typ2 ptr2 i2 n2 ram dcl) + dcl) + (collect-fn :ONE typ1 ptr1 i1 n1 ram dcl))) + + :hints (("Goal" :use + (:instance collect-fn-mark-fn-via-kollect-fn + (fn2 :ONE) + (fn1 :ONE)) + :in-theory (enable kollect-fn)))) + +(defthm challenge-theorem-2 + (implies + (and (unique (append (collect typ1 ptr1 n1 ram dcl) + (collect typ2 ptr2 n2 ram dcl) + (collect typ3 ptr3 n3 ram dcl))) + (not (member addr (append (collect typ1 ptr1 n1 ram dcl) + (collect typ2 ptr2 n2 ram dcl) + (collect typ3 ptr3 n3 ram dcl))))) + (equal + (g addr (compose-bab typ1 ptr1 n1 + typ2 ptr2 n2 + typ3 ptr3 n3 + ram dcl)) + (g addr ram)))) + + +(defthm challenge-theorem-3 + (implies (unique (append (collect typ1 ptr1 n1 ram dcl) + (collect typ2 ptr2 n2 ram dcl))) + (equal (mark typ1 ptr1 n1 (mark typ2 ptr2 n2 ram dcl) + dcl) + (mark typ2 ptr2 n2 (mark typ1 ptr1 n1 ram dcl) + dcl))) + :hints + (("Goal" + :use + ((:instance unique-implies-tags-exists (fn :ONE) + (typ typ1) + (ptr ptr1) + (i i) + (n n1)) + (:instance unique-implies-tags-exists (fn :ONE) + (typ typ2) + (ptr ptr2) + (i i) + (n n2)) + (:instance + mark-fn-mark-fn (fn1 :ONE) + (fn2 :ONE) + (i2 i) + (i1 i) + (tags (merge-tags (collect-fn :ONE typ1 ptr1 i n1 ram dcl) + (tags-witness-fn :ONE typ1 ptr1 i n1 ram dcl) + (tags-witness-fn :ONE typ2 ptr2 i n2 ram dcl))))) + :in-theory + (e/d (kollect-fn) + (unique-implies-tags-exists mark-fn-mark-fn))))) + + +; This theorem is proved just to illustrate the basic link between +; unique disjoint collection and the existence of a consistent tagging +; for two pointer structures. + +(defthm unique-collection-implies-exists-ok-tagging + (implies (unique (append (collect typ1 ptr1 n1 ram dcl) + (collect typ2 ptr2 n2 ram dcl))) + (let ((tags + (merge-tags (collect typ1 ptr1 n1 ram dcl) + (tags-witness-fn :ONE typ1 ptr1 0 n1 ram dcl) + (tags-witness-fn :ONE typ2 ptr2 0 n2 ram dcl)))) + (and (tags-ok-fn :ONE typ1 ptr1 0 n1 ram dcl tags) + (tags-ok-fn :ONE typ2 ptr2 0 n2 ram dcl tags)))) + :hints + (("Goal" + :use ((:instance collect-is-collect-fn + (typ typ1) (ptr ptr1) (i 0) (n n1)) + (:instance collect-is-collect-fn + (typ typ2) (ptr ptr2) (i 0) (n n2)) + (:instance unique-implies-tags-exists + (fn :ONE) (typ typ1) (ptr ptr1) (i 0) (n n1)) + (:instance unique-implies-tags-exists + (fn :ONE) (typ typ2) (ptr ptr2) (i 0) (n n2)) + (:instance mark-fn-mark-fn + (fn1 :ONE) + (fn2 :ONE) + (i2 0) + (i1 0) + (tags + (merge-tags + (collect-fn :ONE typ1 ptr1 0 n1 ram dcl) + (tags-witness-fn :ONE typ1 ptr1 0 n1 ram dcl) + (tags-witness-fn :ONE typ2 ptr2 0 n2 ram dcl))))) + :in-theory (e/d (kollect-fn) + (unique-implies-tags-exists + mark-fn-mark-fn + collect-is-collect-fn))))) + + diff --git a/books/workshops/2003/moore_vcg/report.pdf.gz b/books/workshops/2003/moore_vcg/report.pdf.gz Binary files differnew file mode 100644 index 0000000..50a0798 --- /dev/null +++ b/books/workshops/2003/moore_vcg/report.pdf.gz diff --git a/books/workshops/2003/moore_vcg/report.ps.gz b/books/workshops/2003/moore_vcg/report.ps.gz Binary files differnew file mode 100644 index 0000000..8bb55c3 --- /dev/null +++ b/books/workshops/2003/moore_vcg/report.ps.gz diff --git a/books/workshops/2003/moore_vcg/support/README b/books/workshops/2003/moore_vcg/support/README new file mode 100644 index 0000000..ba50c33 --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/README @@ -0,0 +1,11 @@ +; Tail-Recursive Completion of Inductive Assertions +; in an Operational Semantics Setting + +; J Strother Moore + +; This directory contains supporting material for the paper above. +; To recertify the books here, type make to the linux prompt or +; get into ACL2 while standing on this directory and type + +; (ld "certify.lsp" :ld-pre-eval-print t) + diff --git a/books/workshops/2003/moore_vcg/support/certify.lsp b/books/workshops/2003/moore_vcg/support/certify.lsp new file mode 100644 index 0000000..93d7d98 --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/certify.lsp @@ -0,0 +1,172 @@ + +;(certify-book "defpun") +;(u) + +(defpkg "LABEL" '(nil t)) +(defpkg "JVM" '(nil t)) +(defpkg "M5" + (set-difference-equal + (union-eq + '(JVM::SCHEDULED + JVM::UNSCHEDULED + JVM::REF + JVM::LOCKED + JVM::S_LOCKED + JVM::UNLOCKED + JVM::AALOAD + JVM::AASTORE + JVM::ACONST_NULL + JVM::ALOAD + JVM::ALOAD_0 + JVM::ALOAD_1 + JVM::ALOAD_2 + JVM::ALOAD_3 + JVM::ANEWARRAY + JVM::ARETURN + JVM::ARRAYLENGTH + JVM::ASTORE + JVM::ASTORE_0 + JVM::ASTORE_1 + JVM::ASTORE_2 + JVM::ASTORE_3 + JVM::BALOAD + JVM::BASTORE + JVM::BIPUSH + JVM::CALOAD + JVM::CASTORE + JVM::DUP + JVM::DUP_X1 + JVM::DUP_X2 + JVM::DUP2 + JVM::DUP2_X1 + JVM::DUP2_X2 + JVM::GETFIELD + JVM::GETSTATIC + JVM::GOTO + JVM::GOTO_W + JVM::I2B + JVM::I2C + JVM::I2L + JVM::I2S + JVM::IADD + JVM::IALOAD + JVM::IAND + JVM::IASTORE + JVM::ICONST_M1 + JVM::ICONST_0 + JVM::ICONST_1 + JVM::ICONST_2 + JVM::ICONST_3 + JVM::ICONST_4 + JVM::ICONST_5 + JVM::IDIV + JVM::IF_ACMPEQ + JVM::IF_ACMPNE + JVM::IF_ICMPEQ + JVM::IF_ICMPGE + JVM::IF_ICMPGT + JVM::IF_ICMPLE + JVM::IF_ICMPLT + JVM::IF_ICMPNE + JVM::IFEQ + JVM::IFGE + JVM::IFGT + JVM::IFLE + JVM::IFLT + JVM::IFNE + JVM::IFNONNULL + JVM::IFNULL + JVM::IINC + JVM::ILOAD + JVM::ILOAD_0 + JVM::ILOAD_1 + JVM::ILOAD_2 + JVM::ILOAD_3 + JVM::IMUL + JVM::INEG + JVM::INSTANCEOF + JVM::INVOKESPECIAL + JVM::INVOKESTATIC + JVM::INVOKEVIRTUAL + JVM::IOR + JVM::IREM + JVM::IRETURN + JVM::ISHL + JVM::ISHR + JVM::ISTORE + JVM::ISTORE_0 + JVM::ISTORE_1 + JVM::ISTORE_2 + JVM::ISTORE_3 + JVM::ISUB + JVM::IUSHR + JVM::IXOR + JVM::JSR + JVM::JSR_W + JVM::L2I + JVM::LADD + JVM::LALOAD + JVM::LAND + JVM::LASTORE + JVM::LCMP + JVM::LCONST_0 + JVM::LCONST_1 + JVM::LDC + JVM::LDC_W + JVM::LDC2_W + JVM::LDIV + JVM::LLOAD + JVM::LLOAD_0 + JVM::LLOAD_1 + JVM::LLOAD_2 + JVM::LLOAD_3 + JVM::LMUL + JVM::LNEG + JVM::LOR + JVM::LREM + JVM::LRETURN + JVM::LSHL + JVM::LSHR + JVM::LSTORE + JVM::LSTORE_0 + JVM::LSTORE_1 + JVM::LSTORE_2 + JVM::LSTORE_3 + JVM::LSUB + JVM::LUSHR + JVM::LXOR + JVM::MONITORENTER + JVM::MONITOREXIT + JVM::MULTIANEWARRAY + JVM::NEW + JVM::NEWARRAY + JVM::NOP + JVM::POP + JVM::POP2 + JVM::PUTFIELD + JVM::PUTSTATIC + JVM::RET + JVM::RETURN + JVM::SALOAD + JVM::SASTORE + JVM::SIPUSH + JVM::SWAP + ASSOC-EQUAL LEN NTH ZP SYNTAXP + QUOTEP FIX NFIX E0-ORDINALP E0-ORD-<) + (union-eq *acl2-exports* + *common-lisp-symbols-from-main-lisp-package*)) + '(PC PROGRAM PUSH POP RETURN REVERSE STEP ++))) +(certify-book "m5" 3) +(u) (u) (u) (u) + +(include-book "m5") +(certify-book "utilities" 1) +(u) (u) + +(include-book "utilities") +(certify-book "demo" 1) +(u) (u) + +(include-book "utilities") +(certify-book "vcg-examples" 1) +(u) (u) diff --git a/books/workshops/2003/moore_vcg/support/demo.acl2 b/books/workshops/2003/moore_vcg/support/demo.acl2 new file mode 100644 index 0000000..4b92f00 --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/demo.acl2 @@ -0,0 +1,7 @@ +(value :q) + +(lp) + +(include-book "utilities") + +(certify-book "demo" ? t) diff --git a/books/workshops/2003/moore_vcg/support/demo.lisp b/books/workshops/2003/moore_vcg/support/demo.lisp new file mode 100644 index 0000000..8d07589 --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/demo.lisp @@ -0,0 +1,714 @@ +; Copyright (C) 2001, Regents of the University of Texas +; Written by J Strother Moore +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. + +; This book proves the correctness of a recursive static method +; for factorial on M5. + +#| +; Certification Instructions. + +(include-book + "utilities") + +(certify-book "demo" 1) + +J Moore + +Here is the Java for a factorial method. + +class Demo { + + static int ans; + + public static int fact(int n){ + if (n>0) + {return n*fact(n-1);} + else return 1; + } + + public static void main(String[] args){ + int k = 4; + ans = fact(k+1); + return; + } + } + +If you put this into Demo.java and run + +% javac Demo.java +% javap -o Demo + +you get the following: + +Compiled from Demo.java +synchronized class Demo extends java.lang.Object + /* ACC_SUPER bit set */ +{ + static int ans; + public static int fact(int); + public static void main(java.lang.String[]); + Demo(); +} + +Method int fact(int) + 0 iload_0 + 1 ifle 13 + 4 iload_0 + 5 iload_0 + 6 iconst_1 + 7 isub + 8 invokestatic #5 <Method int fact(int)> + 11 imul + 12 ireturn + 13 iconst_1 + 14 ireturn + +Method void main(java.lang.String[]) + 0 iconst_4 + 1 istore_1 + 2 iload_1 + 3 iconst_1 + 4 iadd + 5 invokestatic #5 <Method int fact(int)> + 8 putstatic #4 <Field int ans> + 11 return + +Method Demo() + 0 aload_0 + 1 invokespecial #3 <Method java.lang.Object()> + 4 return + +Below is the output of jvm2acl2 for M5. + +|# + +(in-package "M5") + +(defconst *Demo-class-table-in-tagged-form* + (make-class-def + (list + (make-class-decl + "Demo" + '("java.lang.Object") + '() + '("ans") + '() + (list + '("<init>" () nil + (aload_0) + (invokespecial "java.lang.Object" "<init>" 0) + (return)) + '("fact" (int) nil + (iload_0) + (ifle LABEL::TAG_0) + (iload_0) + (iload_0) + (iconst_1) + (isub) + (invokestatic "Demo" "fact" 1) + (imul) + (ireturn) + (LABEL::TAG_0 iconst_1) + (ireturn)) + '("main" (java.lang.String[]) nil + (iconst_4) + (istore_1) + (iload_1) + (iconst_1) + (iadd) + (invokestatic "Demo" "fact" 1) + (putstatic "Demo" "ans" nil) + (return))) + '(REF -1))))) + +(defconst *Demo-main* + '((iconst_4) + (istore_1) + (iload_1) + (iconst_1) + (iadd) + (invokestatic "Demo" "fact" 1) + (putstatic "Demo" "ans" nil) + (return))) + +(defun Demo-ms () + (make-state + (make-tt (push (make-frame 0 + nil + nil + *Demo-main* + 'UNLOCKED + "Demo") + nil)) + nil + *Demo-class-table-in-tagged-form*)) + +(defun Demo () + (m5_load (Demo-ms))) + +; Here is the state created by (Demo): +#| +(((0 ((0 NIL NIL + ((ICONST_4) + (ISTORE_1) + (ILOAD_1) + (ICONST_1) + (IADD) + (INVOKESTATIC "Demo" "fact" 1) + (PUTSTATIC "Demo" "ans" NIL) + (RETURN)) + UNLOCKED "Demo")) + SCHEDULED NIL)) + ((0 ("java.lang.Class" ("<name>" . "java.lang.Object")) + ("java.lang.Object" ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0))) + (1 ("java.lang.Class" ("<name>" . "ARRAY")) + ("java.lang.Object" ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0))) + (2 ("java.lang.Class" ("<name>" . "java.lang.Thread")) + ("java.lang.Object" ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0))) + (3 ("java.lang.Class" ("<name>" . "java.lang.String")) + ("java.lang.Object" ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0))) + (4 ("java.lang.Class" ("<name>" . "java.lang.Class")) + ("java.lang.Object" ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0))) + (5 ("java.lang.Class" ("<name>" . "Demo") + ("ans" . 0)) + ("java.lang.Object" ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0)))) + (("java.lang.Object" NIL ("monitor" "mcount" "wait-set") + NIL NIL (("<init>" NIL NIL (RETURN))) + (REF 0)) + ("ARRAY" ("java.lang.Object") + (("<array>" . *ARRAY*)) + NIL NIL NIL (REF 1)) + ("java.lang.Thread" + ("java.lang.Object") + NIL NIL NIL + (("run" NIL NIL (RETURN)) + ("start" NIL NIL NIL) + ("stop" NIL NIL NIL) + ("<init>" NIL NIL (ALOAD_0) + (INVOKESPECIAL "java.lang.Object" "<init>" 0) + (RETURN))) + (REF 2)) + ("java.lang.String" + ("java.lang.Object") + ("strcontents") + NIL NIL + (("<init>" NIL NIL (ALOAD_0) + (INVOKESPECIAL "java.lang.Object" "<init>" 0) + (RETURN))) + (REF 3)) + ("java.lang.Class" ("java.lang.Object") + NIL NIL NIL + (("<init>" NIL NIL (ALOAD_0) + (INVOKESPECIAL "java.lang.Object" "<init>" 0) + (RETURN))) + (REF 4)) + ("Demo" ("java.lang.Object") + NIL ("ans") + NIL + (("<init>" NIL NIL (ALOAD_0) + (INVOKESPECIAL "java.lang.Object" "<init>" 0) + (RETURN)) + ("fact" (INT) + NIL (ILOAD_0) + (IFLE 12) + (ILOAD_0) + (ILOAD_0) + (ICONST_1) + (ISUB) + (INVOKESTATIC "Demo" "fact" 1) + (IMUL) + (IRETURN) + (ICONST_1) + (IRETURN)) + ("main" (|JAVA.LANG.STRING[]|) + NIL (ICONST_4) + (ISTORE_1) + (ILOAD_1) + (ICONST_1) + (IADD) + (INVOKESTATIC "Demo" "fact" 1) + (PUTSTATIC "Demo" "ans" NIL) + (RETURN))) + (REF 5)))) +|# + +; But in the paper we discuss it component by component and +; define constants for each. Note that we can write ICONST_4 or +; ICONST\_4 in Common Lisp. We use the latter so that we can +; pick these forms up and dump them into LaTeX. + +(defconst *Demo-thread-table* + (list + (cons 0 + (make-thread + (push + (make-frame + 0 + nil + nil + '((ICONST\_4) + (ISTORE\_1) + (ILOAD\_1) + (ICONST\_1) + (IADD) + (INVOKESTATIC "Demo" "fact" 1) + (PUTSTATIC "Demo" "ans" NIL) + (RETURN)) + 'UNLOCKED + "Demo") + nil) + 'SCHEDULED + nil)))) + +(defconst *Demo-heap* + '((0 . (("java.lang.Class" + ("<name>" . "java.lang.Object")) + ("java.lang.Object" + ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0)))) + (1 . (("java.lang.Class" + ("<name>" . "ARRAY")) + ("java.lang.Object" + ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0)))) + (2 . (("java.lang.Class" + ("<name>" . "java.lang.Thread")) + ("java.lang.Object" + ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0)))) + (3 . (("java.lang.Class" + ("<name>" . "java.lang.String")) + ("java.lang.Object" + ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0)))) + (4 . (("java.lang.Class" + ("<name>" . "java.lang.Class")) + ("java.lang.Object" + ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0)))) + (5 . (("java.lang.Class" + ("<name>" . "Demo") + ("ans" . 0)) + ("java.lang.Object" + ("monitor" . 0) + ("mcount" . 0) + ("wait-set" . 0)))))) + +(defconst *Demo-class-table* + '(("java.lang.Object" + NIL + ("monitor" "mcount" "wait-set") + NIL + NIL + (("<init>" NIL NIL (RETURN))) + (REF 0)) + ("ARRAY" + ("java.lang.Object") + (("<array>" . *ARRAY*)) + NIL + NIL + NIL + (REF 1)) + ("java.lang.Thread" + ("java.lang.Object") + NIL + NIL + NIL + (("run" NIL NIL (RETURN)) + ("start" NIL NIL NIL) + ("stop" NIL NIL NIL) + ("<init>" NIL NIL (ALOAD\_0) + (INVOKESPECIAL "java.lang.Object" "<init>" 0) + (RETURN))) + (REF 2)) + ("java.lang.String" + ("java.lang.Object") + ("strcontents") + NIL + NIL + (("<init>" NIL NIL + (ALOAD\_0) + (INVOKESPECIAL "java.lang.Object" "<init>" 0) + (RETURN))) + (REF 3)) + ("java.lang.Class" + ("java.lang.Object") + NIL + NIL + NIL + (("<init>" NIL NIL + (ALOAD\_0) + (INVOKESPECIAL "java.lang.Object" "<init>" 0) + (RETURN))) + (REF 4)) + ("Demo" + ("java.lang.Object") + NIL + ("ans") + NIL + (("<init>" NIL NIL + (ALOAD\_0) + (INVOKESPECIAL "java.lang.Object" "<init>" 0) + (RETURN)) + ("fact" (INT) NIL + (ILOAD\_0) + (IFLE 12) + (ILOAD\_0) + (ILOAD\_0) + (ICONST\_1) + (ISUB) + (INVOKESTATIC "Demo" "fact" 1) + (IMUL) + (IRETURN) + (ICONST\_1) + (IRETURN)) + ("main" (|JAVA.LANG.STRING[]|) NIL + (ICONST\_4) + (ISTORE\_1) + (ILOAD\_1) + (ICONST\_1) + (IADD) + (INVOKESTATIC "Demo" "fact" 1) + (PUTSTATIC "Demo" "ans" NIL) + (RETURN))) + (REF 5)))) + +(defconst *Demo-state* + (make-state *demo-thread-table* + *demo-heap* + *demo-class-table*)) + +(defthm demo-state-is-demo + (equal (Demo) + *Demo-state*) + :rule-classes nil) + +; The Mathematical Function + +(defun factorial (n) + (if (zp n) + 1 + (* n (factorial (- n 1))))) + +(defthm integerp-factorial + (integerp (factorial n)) + :rule-classes :type-prescription) + +; A Schedule that Runs fact to Completion + +(defun fact-sched (th n) + (if (zp n) + (repeat th 5) + (append (repeat th 7) + (fact-sched th (- n 1)) + (repeat th 2)))) + +(defthm len-repeat + (equal (len (repeat th n)) (nfix n))) + +(defthm len-append + (equal (len (append a b)) + (+ (len a) (len b)))) + +(defthm len-fact-sched + (equal (len (fact-sched th n)) + (+ 5 (* 9 (nfix n))))) + +; Playing Around with Main + +; This schedule executes main to termination. + +(defun main-sched (th) + (append (repeat th 5) + (fact-sched th 5) + (repeat th 2))) + +(defthm sample-execution + (equal (static-field-value "Demo" "ans" + (run (main-sched 0) *Demo-state*)) + 120) + :rule-classes nil) + +#| + +; Below is a fact-test function. I define it in raw Lisp rather +; than ACL2 so that I can time the execution of the JVM model +; without timing the construction of the schedule. To define +; this function, exit the loop with :q and do these two forms. + +(in-package "M5") +(compile + (defun fact-test (n) + (format t "Computing schedule for ~a.~%" n) + (let ((sched (append (repeat 0 1) + (fact-sched 0 n) + (repeat 0 2)))) + (format t "Schedule length: ~a.~%" (len sched)) + (time + (static-field-value + "Demo" "ans" + (run sched + (make-state + (list + (cons 0 + (make-thread + (push + (make-frame + 0 + (list n) + nil + '((ILOAD\_0) + (INVOKESTATIC "Demo" "fact" 1) + (PUTSTATIC "Demo" "ans" NIL) + (RETURN)) + 'UNLOCKED + "Demo") + nil) + 'SCHEDULED + nil))) + *demo-heap* + *demo-class-table*))))))) +; Allocate additional bignum space +(si::allocate 'lisp::bignum 400 t) +T + +; Then do things like (fact-test 17) or (fact-test 1000). On a 797 +; MHz Pentium III, the latter requires a schedule of length 9008 and +; takes 0.100 seconds to execute, provided no (BIGNUM) gcs occur. +; This gives a simulation speed of 90K JVM bytecodes per second. + +|# + +; Proving Fact Correct + +(defconst *fact-def* + '("fact" (INT) NIL + (ILOAD_0) ;;; 0 + (IFLE 12) ;;; 1 + (ILOAD_0) ;;; 4 + (ILOAD_0) ;;; 5 + (ICONST_1) ;;; 6 + (ISUB) ;;; 7 + (INVOKESTATIC "Demo" "fact" 1) ;;; 8 + (IMUL) ;;; 11 + (IRETURN) ;;; 12 + (ICONST_1) ;;; 13 + (IRETURN))) ;;; 14 + +(defun poised-to-invoke-fact (th s n) + (and (equal (status th s) 'SCHEDULED) + (equal (next-inst th s) '(invokestatic "Demo" "fact" 1)) + (equal n (top (stack (top-frame th s)))) + (intp n) + (equal (lookup-method "fact" "Demo" (class-table s)) + *fact-def*))) + +(defun induction-hint (th s n) + (if (zp n) + s + (induction-hint + th + (make-state ;;; (run (repeat th 7) s) + (bind + th + (make-thread + (push + (make-frame + 8 + (list (top (stack (top-frame th s)))) + (push (- (top (stack (top-frame th s))) 1) + (push (top (stack (top-frame th s))) + nil)) + (method-program *fact-def*) + 'UNLOCKED + "Demo") + (push (make-frame (+ 3 (pc (top (call-stack th s)))) + (locals (top (call-stack th s))) + (pop (stack (top (call-stack th s)))) + (program (top (call-stack th s))) + (sync-flg (top (call-stack th s))) + (cur-class (top (call-stack th s)))) + (pop (call-stack th s)))) + 'scheduled + (rref th s)) + (thread-table s)) + (heap s) + (class-table s)) + (- n 1)))) + +; The make-state in the induction-hint above is equivalent to +; (run (repeat th 7) s), under the hypotheses that s is poised to +; invoke fact and that n is non-0. We prove that below, just to +; demonstrate this claim. The import of this claim is that we +; could use this to help generate the induction hint, i.e., the +; make-state is not "magic." + +(defthm induction-hint-explanation + (implies (and (poised-to-invoke-fact th s n) + (not (zp n))) + (equal (run (repeat th 7) s) + (make-state ;;; (run (repeat th 7) s) + (bind + th + (make-thread + (push + (make-frame + 8 + (list (top (stack (top-frame th s)))) + (push (- (top (stack (top-frame th s))) 1) + (push (top (stack (top-frame th s))) + nil)) + (method-program *fact-def*) + 'UNLOCKED + "Demo") + (push (make-frame (+ 3 (pc (top (call-stack th s)))) + (locals (top (call-stack th s))) + (pop (stack (top (call-stack th s)))) + (program (top (call-stack th s))) + (sync-flg (top (call-stack th s))) + (cur-class (top (call-stack th s)))) + (pop (call-stack th s)))) + 'scheduled + (rref th s)) + (thread-table s)) + (heap s) + (class-table s)))) + :rule-classes nil) + +(defthm fact-is-correct + (implies (poised-to-invoke-fact th s n) + (equal + (run (fact-sched th n) s) + (modify th s + :pc (+ 3 (pc (top-frame th s))) + :stack (push (int-fix (factorial n)) + (pop (stack (top-frame th s))))))) + :hints (("Goal" + :induct (induction-hint th s n)))) + +(in-theory (disable fact-sched)) + +(defthm weak-version-of-fact-is-correct + (implies (poised-to-invoke-fact th s n) + (equal (top + (stack + (top-frame + th + (run (fact-sched th n) s)))) + (int-fix (factorial n))))) + +; Symbolic Computation and Use of fact as a Subroutine + +(defthm symbolic-computation + (implies + (intp (+ 1 k)) + (equal + (nth 3 + (locals + (top-frame 0 + (run (append (repeat 0 4) + (fact-sched 0 (+ 1 k)) + (repeat 0 2)) + (make-state + (make-tt + (push + (make-frame 0 + (list v0 v1 v2 k) + stk + '((iconst_2) + (iload_3) + (iconst_1) + (iadd) + (invokestatic "Demo" "fact" 1) + (imul) + (istore_3)) + 'UNLOCKED + "Test") + nil)) + *demo-heap* + *demo-class-table*))))) + + (int-fix (* 2 (factorial (+ 1 k))))))) + +; In the steps below we demonstrate the key steps in the +; simplification above, to check the claims made in the paper. + +(defun alpha (pc locals stk) + (make-state + (make-tt + (push (make-frame pc + locals + stk + '((iconst_2) + (iload_3) + (iconst_1) + (iadd) + (invokestatic "Demo" "fact" 1) + (imul) + (istore_3)) + 'UNLOCKED + "Test") + nil)) + *demo-heap* + *demo-class-table*)) + +(defthm symbolic-computation-step1 + (implies + (intp (+ 1 k)) + (equal (run (append (repeat 0 4) + (fact-sched 0 (+ 1 k)) + (repeat 0 2)) + (alpha 0 (list v0 v1 v2 k) stk)) + (run (repeat 0 2) + (run (fact-sched 0 (+ 1 k)) + (run (repeat 0 4) + (alpha 0 (list v0 v1 v2 k) stk))))))) + +(defthm symbolic-computation-step2 + (implies + (intp (+ 1 k)) + (equal (run (repeat 0 4) + (alpha 0 (list v0 v1 v2 k) stk)) + (alpha 4 (list v0 v1 v2 k) + (push (+ 1 k) (push 2 stk)))))) + +(defthm symbolic-computation-step3 + (implies + (intp (+ 1 k)) + (equal (run (fact-sched 0 (+ 1 k)) + (alpha 4 (list v0 v1 v2 k) + (push (+ 1 k) (push 2 stk)))) + (alpha 7 (list v0 v1 v2 k) + (push (int-fix (factorial (+ 1 k))) + (push 2 stk)))))) + + +(defthm symbolic-computation-step4 + (implies + (intp (+ 1 k)) + (equal (run (repeat 0 2) + (alpha 7 (list v0 v1 v2 k) + (push (int-fix (factorial (+ 1 k))) + (push 2 stk)))) + (alpha 9 (list v0 v1 v2 + (int-fix + (* 2 (factorial (+ 1 k))))) stk)))) + diff --git a/books/workshops/2003/moore_vcg/support/m5.acl2 b/books/workshops/2003/moore_vcg/support/m5.acl2 new file mode 100644 index 0000000..3113f2e --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/m5.acl2 @@ -0,0 +1,160 @@ +(value :q) + +(lp) + +(defpkg "LABEL" '(nil t)) +(defpkg "JVM" '(nil t)) + +(DEFPKG "M5" + (set-difference-equal + (union-eq '(JVM::SCHEDULED + JVM::UNSCHEDULED + JVM::REF + JVM::LOCKED + JVM::S_LOCKED + JVM::UNLOCKED + JVM::AALOAD + JVM::AASTORE + JVM::ACONST_NULL + JVM::ALOAD + JVM::ALOAD_0 + JVM::ALOAD_1 + JVM::ALOAD_2 + JVM::ALOAD_3 + JVM::ANEWARRAY + JVM::ARETURN + JVM::ARRAYLENGTH + JVM::ASTORE + JVM::ASTORE_0 + JVM::ASTORE_1 + JVM::ASTORE_2 + JVM::ASTORE_3 + JVM::BALOAD + JVM::BASTORE + JVM::BIPUSH + JVM::CALOAD + JVM::CASTORE + JVM::DUP + JVM::DUP_X1 + JVM::DUP_X2 + JVM::DUP2 + JVM::DUP2_X1 + JVM::DUP2_X2 + JVM::GETFIELD + JVM::GETSTATIC + JVM::GOTO + JVM::GOTO_W + JVM::I2B + JVM::I2C + JVM::I2L + JVM::I2S + JVM::IADD + JVM::IALOAD + JVM::IAND + JVM::IASTORE + JVM::ICONST_M1 + JVM::ICONST_0 + JVM::ICONST_1 + JVM::ICONST_2 + JVM::ICONST_3 + JVM::ICONST_4 + JVM::ICONST_5 + JVM::IDIV + JVM::IF_ACMPEQ + JVM::IF_ACMPNE + JVM::IF_ICMPEQ + JVM::IF_ICMPGE + JVM::IF_ICMPGT + JVM::IF_ICMPLE + JVM::IF_ICMPLT + JVM::IF_ICMPNE + JVM::IFEQ + JVM::IFGE + JVM::IFGT + JVM::IFLE + JVM::IFLT + JVM::IFNE + JVM::IFNONNULL + JVM::IFNULL + JVM::IINC + JVM::ILOAD + JVM::ILOAD_0 + JVM::ILOAD_1 + JVM::ILOAD_2 + JVM::ILOAD_3 + JVM::IMUL + JVM::INEG + JVM::INSTANCEOF + JVM::INVOKESPECIAL + JVM::INVOKESTATIC + JVM::INVOKEVIRTUAL + JVM::IOR + JVM::IREM + JVM::IRETURN + JVM::ISHL + JVM::ISHR + JVM::ISTORE + JVM::ISTORE_0 + JVM::ISTORE_1 + JVM::ISTORE_2 + JVM::ISTORE_3 + JVM::ISUB + JVM::IUSHR + JVM::IXOR + JVM::JSR + JVM::JSR_W + JVM::L2I + JVM::LADD + JVM::LALOAD + JVM::LAND + JVM::LASTORE + JVM::LCMP + JVM::LCONST_0 + JVM::LCONST_1 + JVM::LDC + JVM::LDC_W + JVM::LDC2_W + JVM::LDIV + JVM::LLOAD + JVM::LLOAD_0 + JVM::LLOAD_1 + JVM::LLOAD_2 + JVM::LLOAD_3 + JVM::LMUL + JVM::LNEG + JVM::LOR + JVM::LREM + JVM::LRETURN + JVM::LSHL + JVM::LSHR + JVM::LSTORE + JVM::LSTORE_0 + JVM::LSTORE_1 + JVM::LSTORE_2 + JVM::LSTORE_3 + JVM::LSUB + JVM::LUSHR + JVM::LXOR + JVM::MONITORENTER + JVM::MONITOREXIT + JVM::MULTIANEWARRAY + JVM::NEW + JVM::NEWARRAY + JVM::NOP + JVM::POP + JVM::POP2 + JVM::PUTFIELD + JVM::PUTSTATIC + JVM::RET + JVM::RETURN + JVM::SALOAD + JVM::SASTORE + JVM::SIPUSH + JVM::SWAP + ASSOC-EQUAL LEN NTH ZP SYNTAXP + QUOTEP FIX NFIX E0-ORDINALP E0-ORD-<) + (union-eq *acl2-exports* + *common-lisp-symbols-from-main-lisp-package*)) + '(PC PROGRAM PUSH POP RETURN REVERSE STEP ++))) + +(certify-book "m5" ? t) diff --git a/books/workshops/2003/moore_vcg/support/m5.lisp b/books/workshops/2003/moore_vcg/support/m5.lisp new file mode 100644 index 0000000..80a75ec --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/m5.lisp @@ -0,0 +1,3032 @@ +; Copyright (C) 2001, Regents of the University of Texas +; Written by J Strother Moore and George Porter +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. + +; M5.lisp +; J Strother Moore <moore@cs.utexas.edu> +; George Porter <george@cs.utexas.edu> +; +; Fixed arithmetic work by Robert Krug <rkrug@cs.utexas.edu> +; Support for Arrays by Hanbing Liu <hbl@cs.utexas.edu> +; +; $Id: m5.lisp,v 1.1 2001/07/10 17:37:06 george Exp $ + +#| + +(defpkg "LABEL" '(nil t)) +(defpkg "JVM" '(nil t)) + +(DEFPKG "M5" + (set-difference-equal + (union-eq '(JVM::SCHEDULED + JVM::UNSCHEDULED + JVM::REF + JVM::LOCKED + JVM::S_LOCKED + JVM::UNLOCKED + JVM::AALOAD + JVM::AASTORE + JVM::ACONST_NULL + JVM::ALOAD + JVM::ALOAD_0 + JVM::ALOAD_1 + JVM::ALOAD_2 + JVM::ALOAD_3 + JVM::ANEWARRAY + JVM::ARETURN + JVM::ARRAYLENGTH + JVM::ASTORE + JVM::ASTORE_0 + JVM::ASTORE_1 + JVM::ASTORE_2 + JVM::ASTORE_3 + JVM::BALOAD + JVM::BASTORE + JVM::BIPUSH + JVM::CALOAD + JVM::CASTORE + JVM::DUP + JVM::DUP_X1 + JVM::DUP_X2 + JVM::DUP2 + JVM::DUP2_X1 + JVM::DUP2_X2 + JVM::GETFIELD + JVM::GETSTATIC + JVM::GOTO + JVM::GOTO_W + JVM::I2B + JVM::I2C + JVM::I2L + JVM::I2S + JVM::IADD + JVM::IALOAD + JVM::IAND + JVM::IASTORE + JVM::ICONST_M1 + JVM::ICONST_0 + JVM::ICONST_1 + JVM::ICONST_2 + JVM::ICONST_3 + JVM::ICONST_4 + JVM::ICONST_5 + JVM::IDIV + JVM::IF_ACMPEQ + JVM::IF_ACMPNE + JVM::IF_ICMPEQ + JVM::IF_ICMPGE + JVM::IF_ICMPGT + JVM::IF_ICMPLE + JVM::IF_ICMPLT + JVM::IF_ICMPNE + JVM::IFEQ + JVM::IFGE + JVM::IFGT + JVM::IFLE + JVM::IFLT + JVM::IFNE + JVM::IFNONNULL + JVM::IFNULL + JVM::IINC + JVM::ILOAD + JVM::ILOAD_0 + JVM::ILOAD_1 + JVM::ILOAD_2 + JVM::ILOAD_3 + JVM::IMUL + JVM::INEG + JVM::INSTANCEOF + JVM::INVOKESPECIAL + JVM::INVOKESTATIC + JVM::INVOKEVIRTUAL + JVM::IOR + JVM::IREM + JVM::IRETURN + JVM::ISHL + JVM::ISHR + JVM::ISTORE + JVM::ISTORE_0 + JVM::ISTORE_1 + JVM::ISTORE_2 + JVM::ISTORE_3 + JVM::ISUB + JVM::IUSHR + JVM::IXOR + JVM::JSR + JVM::JSR_W + JVM::L2I + JVM::LADD + JVM::LALOAD + JVM::LAND + JVM::LASTORE + JVM::LCMP + JVM::LCONST_0 + JVM::LCONST_1 + JVM::LDC + JVM::LDC_W + JVM::LDC2_W + JVM::LDIV + JVM::LLOAD + JVM::LLOAD_0 + JVM::LLOAD_1 + JVM::LLOAD_2 + JVM::LLOAD_3 + JVM::LMUL + JVM::LNEG + JVM::LOR + JVM::LREM + JVM::LRETURN + JVM::LSHL + JVM::LSHR + JVM::LSTORE + JVM::LSTORE_0 + JVM::LSTORE_1 + JVM::LSTORE_2 + JVM::LSTORE_3 + JVM::LSUB + JVM::LUSHR + JVM::LXOR + JVM::MONITORENTER + JVM::MONITOREXIT + JVM::MULTIANEWARRAY + JVM::NEW + JVM::NEWARRAY + JVM::NOP + JVM::POP + JVM::POP2 + JVM::PUTFIELD + JVM::PUTSTATIC + JVM::RET + JVM::RETURN + JVM::SALOAD + JVM::SASTORE + JVM::SIPUSH + JVM::SWAP + ASSOC-EQUAL LEN NTH ZP SYNTAXP + QUOTEP FIX NFIX E0-ORDINALP E0-ORD-<) + (union-eq *acl2-exports* + *common-lisp-symbols-from-main-lisp-package*)) + '(PC PROGRAM PUSH POP RETURN REVERSE STEP ++))) + +(certify-book "m5" 3) + +J & George +|# + +(in-package "M5") + +(include-book "../../../../ordinals/e0-ordinal") +(set-well-founded-relation e0-ord-<) + +; ----------------------------------------------------------------------------- +; Utilities + +(defun push (obj stack) (cons obj stack)) +(defun top (stack) (car stack)) +(defun pop (stack) (cdr stack)) + +(defun popn (n stack) + (if (zp n) + stack + (popn (- n 1) (pop stack)))) + +(defun bound? (x alist) (assoc-equal x alist)) + +(defun bind (x y alist) + (cond ((endp alist) (list (cons x y))) + ((equal x (car (car alist))) + (cons (cons x y) (cdr alist))) + (t (cons (car alist) (bind x y (cdr alist)))))) + +(defun binding (x alist) (cdr (assoc-equal x alist))) + +(defun op-code (inst) (car inst)) +(defun arg1 (inst) (car (cdr inst))) +(defun arg2 (inst) (car (cdr (cdr inst)))) +(defun arg3 (inst) (car (cdr (cdr (cdr inst))))) + +(defun nullrefp (ref) + (equal ref '(ref -1))) + +; Imported from ACL2 + +(defun reverse (x) + (if (consp x) + (append (reverse (cdr x)) (list (car x))) + nil)) + +; The following are constants and functions related to fixed integer sizes + +(defconst *largest-integer-value* (- (expt 2 31) 1)) +(defconst *largest-long-value* (- (expt 2 63) 1)) +(defconst *most-negative-integer* (- (expt 2 31))) +(defconst *most-negative-long* (- (expt 2 63))) + +; Coerce x to an unsigned integer which will fit in n bits. +(defun u-fix (x n) + (mod (ifix x) (expt 2 n))) + +; Coerce x to a signed integer which will fit in n bits. +(defun s-fix (x n) + (let ((temp (mod (ifix x) (expt 2 n)))) + (if (< temp (expt 2 (1- n))) + temp + (- temp (expt 2 n))))) + +(defun byte-fix (x) + (s-fix x 8)) + +(defun ubyte-fix (x) + (u-fix x 8)) + +(defun short-fix (x) + (s-fix x 16)) + +(defun int-fix (x) + (s-fix x 32)) + +(defun uint-fix (x) + (u-fix x 32)) + +(defun long-fix (x) + (s-fix x 64)) + +(defun ulong-fix (x) + (u-fix x 64)) + +(defun char-fix (x) + (u-fix x 16)) + +(defun 6-bit-fix (x) + (u-fix x 6)) + +(defun 5-bit-fix (x) + (u-fix x 5)) + +(defun expt2 (n) + (expt 2 n)) + +(defun shl (x n) + (* x (expt2 n))) + +(defun shr (x n) + (floor (* x (expt2 (- n))) 1)) + +; ----------------------------------------------------------------------------- +; States + +(defun make-state (thread-table heap class-table) + (list thread-table heap class-table)) +(defun thread-table (s) (nth 0 s)) +(defun heap (s) (nth 1 s)) +(defun class-table (s) (nth 2 s)) + +(defun make-thread (call-stack status rref) + (list call-stack status rref)) + +(defun call-stack (th s) + (nth 0 (binding th (thread-table s)))) + +(defun status (th s) + (nth 1 (binding th (thread-table s)))) + +(defun rref (th s) + (nth 2 (binding th (thread-table s)))) + +; ----------------------------------------------------------------------------- +; Class Declarations and the Class Table + +; The class table of a state is an alist. Each entry in a class table is +; a "class declaration" and is of the form + +; (class-name super-class-names fields defs) + +; Note that the definition below of the Thread class includes a 'run' method, +; which most applications will override. The definition is consistent +; with the default run method provided by the Thread class [O'Reily] + +(defun make-class-decl (name superclasses fields sfields cp methods href) + (list name superclasses fields sfields cp methods href)) + +(defun class-decl-name (dcl) + (nth 0 dcl)) +(defun class-decl-superclasses (dcl) + (nth 1 dcl)) +(defun class-decl-fields (dcl) + (nth 2 dcl)) +(defun class-decl-sfields (dcl) + (nth 3 dcl)) +(defun class-decl-cp (dcl) + (nth 4 dcl)) +(defun class-decl-methods (dcl) + (nth 5 dcl)) +(defun class-decl-heapref (dcl) + (nth 6 dcl)) + +(defun base-class-def () + (list (make-class-decl "java.lang.Object" + nil + '("monitor" "mcount" "wait-set") + '() + '() + '(("<init>" () nil (RETURN))) + '(REF -1)) + (make-class-decl "ARRAY" + '("java.lang.Object") + '(("<array>" . *ARRAY*)) + '() + '() + '() + '(REF -1)) + (make-class-decl "java.lang.Thread" + '("java.lang.Object") + '() + '() + '() + '(("run" () nil + (RETURN)) + ("start" () nil ()) + ("stop" () nil ()) + ("<init>" () + nil + (aload_0) + (invokespecial "java.lang.Object" "<init>" 0) + (return))) + '(REF -1)) + (make-class-decl "java.lang.String" + '("java.lang.Object") + '("strcontents") + '() + '() + '(("<init>" () + nil + (aload_0) + (invokespecial "java.lang.Object" "<init>" 0) + (return))) + '(REF -1)) + (make-class-decl "java.lang.Class" + '("java.lang.Object") + '() + '() + '() + '(("<init>" () + nil + (aload_0) + (invokespecial "java.lang.Object" "<init>" 0) + (return))) + '(REF -1)))) + +(defun make-class-def (list-of-class-decls) + (append (base-class-def) list-of-class-decls)) + +; ----------------------------------------------------------------------------- +; A Constant Pool +; +; There is one constant pool per class + +; A constant pool is a list of entries. Each entry is either: +; +; '(INT n) +; Where n is a 32-bit number, in the range specified by the JVM spec +; +; '(STRING (REF -1) "Hello, World!") +; The 3rd element (a string) is resolved to a heap reference the +; first time it is used. Once it is resolved, its reference is placed +; as the second element (displacing the null ref currently there). + +(defun cp-make-int-entry (n) + (list 'INT n)) + +(defun cp-make-string-entry (str) + (list 'STRING '(REF -1) str)) + +(defun cp-string-resolved? (entry) + (not (equal (cadr (caddr entry)) -1))) + +(defun retrieve-cp (class-name class-table) + (class-decl-cp (bound? class-name class-table))) + +(defun update-ct-string-ref (class idx newval ct) + (let* ((class-entry (bound? class ct)) + (oldstrval (caddr (nth idx (retrieve-cp class ct)))) + (newstrentry (list 'STRING newval oldstrval)) + (new-cp (update-nth idx + newstrentry + (class-decl-cp class-entry))) + (new-class-entry + (make-class-decl (class-decl-name class-entry) + (class-decl-superclasses class-entry) + (class-decl-fields class-entry) + (class-decl-sfields class-entry) + new-cp + (class-decl-methods class-entry) + (class-decl-heapref class-entry)))) + (bind class (cdr new-class-entry) ct))) + +; ----------------------------------------------------------------------------- +; Thread Tables +; +; A "thread table" might be used to represent threads in m5. It consists of +; a reference, a call stack, a flag to indicate whether its call-stack +; should be stepped by the scheduler, and a ref to the original object +; in the heap. +; +; Thread table: +; ((n . (call-stack flag reverse-ref)) +; (n+1 . (call-stack flag reverse-ref))) +; +; The flags 'SCHEDULED and 'UNSCHEDULED correspond to two of the +; four states threads can be in (according to [O'Reily]). For our +; model, this will suffice. + +(defun make-tt (call-stack) + (bind 0 (list call-stack 'SCHEDULED nil) nil)) + +(defun addto-tt (call-stack status heapRef tt) + (bind (len tt) (list call-stack status heapRef) tt)) + +(defun mod-thread-scheduling (th sched tt) + (let* ((thrd (binding th tt)) + (oldcs (car thrd)) + (oldhr (caddr thrd)) + (newTH (list oldcs sched oldhr))) + (bind th newTH tt))) + +(defun schedule-thread (th tt) + (mod-thread-scheduling th 'SCHEDULED tt)) + +(defun unschedule-thread (th tt) + (mod-thread-scheduling th 'UNSCHEDULED tt)) + +(defun rrefToThread (ref tt) + (cond ((endp tt) nil) + ((equal ref (cadddr (car tt))) (caar tt)) + (t (rrefToThread ref (cdr tt))))) + +; ---------------------------------------------------------------------------- +; Helper function for determining if an object is a 'Thread' object + +(defun in-list (item list) + (cond ((endp list) nil) + ((equal item (car list)) t) + (t (in-list item (cdr list))))) + +(defun isThreadObject? (class-name class-table) + (let* ((class (bound? class-name class-table)) + (psupers (class-decl-superclasses class)) + (supers (cons class-name psupers))) + (or (in-list "java.lang.Thread" supers) + (in-list "java.lang.ThreadGroup" supers)))) + +; ---------------------------------------------------------------------------- +; Helper functions for locking and unlocking objects + +; lock-object and unlock-object will obtain a lock on an instance +; of an object, using th as the locking id (a thread owns a lock). If th +; already has a lock on an object, then the mcount of the object is +; incremented. Likewise if you unlock an object with mcount > 0, then +; the lock will be decremented. Note: you must make sure that th can +; and should get the lock, since this function will blindly go ahead and +; get the lock + +(defun lock-object (th obj-ref heap) + (let* ((obj-ref-num (cadr obj-ref)) + (instance (binding (cadr obj-ref) heap)) + (obj-fields (binding "java.lang.Object" instance)) + (new-mcount (+ 1 (binding "mcount" obj-fields))) + (new-obj-fields + (bind "monitor" th + (bind "mcount" new-mcount obj-fields))) + (new-object (bind "java.lang.Object" new-obj-fields instance))) + (bind obj-ref-num new-object heap))) + +(defun unlock-object (th obj-ref heap) + (let* ((obj-ref-num (cadr obj-ref)) + (instance (binding (cadr obj-ref) heap)) + (obj-fields (binding "java.lang.Object" instance)) + (old-mcount (binding "mcount" obj-fields)) + (new-mcount (ACL2::max 0 (- old-mcount 1))) + (new-monitor (if (zp new-mcount) + 0 + th)) + (new-obj-fields + (bind "monitor" new-monitor + (bind "mcount" new-mcount obj-fields))) + (new-object (bind "java.lang.Object" new-obj-fields instance))) + (bind obj-ref-num new-object heap))) + +; objectLockable? is used to determine if th can unlock instance. This +; occurs when either mcount is zero (nobody has a lock), or mcount is +; greater than zero, but monitor is equal to th. This means that th +; already has a lock on the object, and when the object is locked yet again, +; monitor will remain the same, but mcount will be incremented. +; +; objectUnLockable? determins if a thread can unlock an object (ie if it +; has a lock on that object) +(defun objectLockable? (instance th) + (let* ((obj-fields (binding "java.lang.Object" instance)) + (monitor (binding "monitor" obj-fields)) + (mcount (binding "mcount" obj-fields))) + (or (zp mcount) + (equal monitor th)))) + +(defun objectUnLockable? (instance th) + (let* ((obj-fields (binding "java.lang.Object" instance)) + (monitor (binding "monitor" obj-fields))) + (equal monitor th))) + +; ----------------------------------------------------------------------------- +; Frames + +(defun make-frame (pc locals stack program sync-flg cur-class) + (list pc locals stack program sync-flg cur-class)) + +(defun top-frame (th s) (top (call-stack th s))) + +(defun pc (frame) (nth 0 frame)) +(defun locals (frame) (nth 1 frame)) +(defun stack (frame) (nth 2 frame)) +(defun program (frame) (nth 3 frame)) +(defun sync-flg (frame) (nth 4 frame)) +(defun cur-class (frame) (nth 5 frame)) + +; ----------------------------------------------------------------------------- +; Method Declarations + +; The methods component of a class declaration is a list of method definitions. +; A method definition is a list of the form + +; (name formals sync-status . program) + +; We never build these declarations but just enter list constants for them, + +; Note the similarity to our old notion of a program definition. We +; will use strings to name methods now. + +; sync-status is 't' if the method is synchronized, 'nil' if not + +; Method definitions will be constructed by expressions such as: +; (Note: all of the symbols below are understood to be in the pkg "JVM".) + +; ("move" (dx dy) nil +; (load this) +; (load this) +; (getfield "Point" "x") +; (load dx) +; (add) +; (putfield "Point" "x") ; this.x = this.x + dx; +; (load :this) +; (load :this) +; (getfield "Point" "y") +; (load dy) +; (add) +; (putfield "Point" "y") ; this.y = this.y + dy; +; (push 1) +; (xreturn))) ; return 1; + +; Provided this method is defined in the class "Point" it can be invoked by + +; (invokevirtual "Point" "move" 2) + +; This assumes that the stack, at the time of invocation, contains an +; reference to an object of type "Point" and two numbers, dx and dy. + +; If a method declaration has an empty list for the program (ie- there are +; no bytecodes associated with the method), then the method is considered +; native. Native methods are normally written in something like C or +; assembly language. The JVM would normally ensure that the correct number +; and type of arguments are passed to the native method, and would then hand +; over control to C. In our model, we simply "hardwire" invokevirtual to +; to handle these methods. +; * Note that a method in Java will never have 0 bytecodes, since even if +; it has no body, it will consist of at least the (xreturn) bytecode. + +; The accessors for methods are: + +(defun method-name (m) + (nth 0 m)) +(defun method-formals (m) + (nth 1 m)) +(defun method-sync (m) + (nth 2 m)) +(defun method-program (m) + (cdddr m)) +(defun method-isNative? (m) + (equal '(NIL) + (method-program m))) + +; The Standard Modify + +(defun suppliedp (key args) + (cond ((endp args) nil) + ((equal key (car args)) t) + (t (suppliedp key (cdr args))))) + +(defun actual (key args) + (cond ((endp args) nil) + ((equal key (car args)) (cadr args)) + (t (actual key (cdr args))))) + +(defmacro modify (th s &rest args) + (list 'make-state + (cond + ((or (suppliedp :call-stack args) + (suppliedp :pc args) + (suppliedp :locals args) + (suppliedp :stack args) + (suppliedp :program args) + (suppliedp :sync-flg args) + (suppliedp :cur-class args) + (suppliedp :status args)) + (list 'bind + th + (list 'make-thread + (cond + ((suppliedp :call-stack args) + (actual :call-stack args)) + ((and (suppliedp :status args) + (null (cddr args))) + (list 'call-stack th s)) + (t + (list 'push + (list 'make-frame + (if (suppliedp :pc args) + (actual :pc args) + (list 'pc (list 'top-frame th s))) + (if (suppliedp :locals args) + (actual :locals args) + (list 'locals (list 'top-frame th s))) + (if (suppliedp :stack args) + (actual :stack args) + (list 'stack (list 'top-frame th s))) + (if (suppliedp :program args) + (actual :program args) + (list 'program (list 'top-frame th s))) + (if (suppliedp :sync-flg args) + (actual :sync-flg args) + (list 'sync-flg (list 'top-frame th s))) + (if (suppliedp :cur-class args) + (actual :cur-class args) + (list 'cur-class + (list 'top-frame th s)))) + (list 'pop (list 'call-stack th s))))) + (if (suppliedp :status args) + (actual :status args) + (list 'status th s)) + (list 'rref th s)) + (list 'thread-table s))) + ((suppliedp :thread-table args) + (actual :thread-table args)) + (t (list 'thread-table s))) + (if (suppliedp :heap args) + (actual :heap args) + (list 'heap s)) + (if (suppliedp :class-table args) + (actual :class-table args) + (list 'class-table s)))) + +; ----------------------------------------------------------------------------- +; Helper functions related to building instances of objects + +(defun deref (ref heap) + (binding (cadr ref) heap)) + +(defun field-value (class-name field-name instance) + (binding field-name + (binding class-name instance))) + +(defun build-class-field-bindings (field-names) + (if (endp field-names) + nil + (cons (cons (car field-names) 0) + (build-class-field-bindings (cdr field-names))))) + +(defun build-class-object-field-bindings () + '(("monitor" . 0) ("monitor-count" . 0) ("wait-set" . nil))) + +(defun build-immediate-instance-data (class-name class-table) + (cons class-name + (build-class-field-bindings + (class-decl-fields + (bound? class-name class-table))))) + +(defun build-an-instance (class-names class-table) + (if (endp class-names) + nil + (cons (build-immediate-instance-data (car class-names) class-table) + (build-an-instance (cdr class-names) class-table)))) + +(defun build-class-data (sfields) + (cons "java.lang.Class" + (build-class-field-bindings + (cons "<name>" sfields)))) + +(defun build-a-class-instance (sfields class-table) + (list (build-class-data sfields) + (build-immediate-instance-data "java.lang.Object" class-table))) + + +; ----------------------------------------------------------------------------- +; Arrays + +(defun value-of (obj) + (cdr obj)) + +(defun superclasses-of (class ct) + (class-decl-superclasses (bound? class ct))) + +(defun array-content (array) + (value-of (field-value "ARRAY" "<array>" array))) + +(defun array-type (array) + (nth 0 (array-content array))) + +(defun array-bound (array) + (nth 1 (array-content array))) + +(defun array-data (array) + (nth 2 (array-content array))) + +(defun element-at (index array) + (nth index (array-data array))) + +(defun makearray (type bound data class-table) + (cons (list "ARRAY" + (cons "<array>" (cons '*array* (list type bound data)))) + (build-an-instance + (superclasses-of "ARRAY" class-table) + class-table))) + +(defun set-element-at (value index array class-table) + (makearray (array-type array) + (array-bound array) + (update-nth index value (array-data array)) + class-table)) + +(defun primitive-type (type) + (cond ((equal type 'T_BYTE) t) + ((equal type 'T_SHORT) t) + ((equal type 'T_INT) t) + ((equal type 'T_LONG) t) + ((equal type 'T_FLOAT) t) + ((equal type 'T_DOUBLE) t) + ((equal type 'T_CHAR) t) + ((equal type 'T_BOOLEAN) t) + (t nil))) + +(defun atype-to-identifier (atype-num) + (cond ((equal atype-num 4) 'T_BOOLEAN) + ((equal atype-num 5) 'T_CHAR) + ((equal atype-num 6) 'T_FLOAT) + ((equal atype-num 7) 'T_DOUBLE) + ((equal atype-num 8) 'T_BYTE) + ((equal atype-num 9) 'T_SHORT) + ((equal atype-num 10) 'T_INT) + ((equal atype-num 11) 'T_LONG) + (t nil))) + +(defun identifier-to-atype (ident) + (cond ((equal ident 'T_BOOLEAN) 4) + ((equal ident 'T_CHAR) 5) + ((equal ident 'T_FLOAT) 6) + ((equal ident 'T_DOUBLE) 7) + ((equal ident 'T_BYTE) 8) + ((equal ident 'T_SHORT) 9) + ((equal ident 'T_INT) 10) + ((equal ident 'T_LONG) 11) + (t nil))) + +(defun default-value1 (type) + (if (primitive-type type) + 0 + nil)) + +(defun init-array (type count) + (if (zp count) + nil + (cons (default-value1 type) (init-array type (- count 1))))) + +; The following measure is due to J +(defun natural-sum (lst) + (cond ((endp lst) 0) + (t (+ (nfix (car lst)) (natural-sum (cdr lst)))))) + +(mutual-recursion + + ; makemultiarray2 :: num, counts, s, ac --> [refs] + (defun makemultiarray2 (car-counts cdr-counts s ac) + (declare (xargs :measure (cons (len (cons car-counts cdr-counts)) + (natural-sum (cons car-counts cdr-counts))))) + (if (zp car-counts) + (mv (heap s) ac) + (mv-let (new-addr new-heap) + (makemultiarray cdr-counts s) + (makemultiarray2 (- car-counts 1) + cdr-counts + (make-state (thread-table s) + new-heap + (class-table s)) + (cons (list 'REF new-addr) ac))))) + + ; makemultiarray :: [counts], s --> addr, new-heap + (defun makemultiarray (counts s) + (declare (xargs :measure (cons (+ 1 (len counts)) + (natural-sum counts)))) + (if (<= (len counts) 1) + + ; "Base case" Handles initializing the final dimension + (mv (len (heap s)) + (bind (len (heap s)) + (makearray 'T_REF + (car counts) + (init-array 'T_REF (car counts)) + (class-table s)) + (heap s))) + + ; "Recursive Case" + (mv-let (heap-prime lst-of-refs) + (makemultiarray2 (car counts) + (cdr counts) + s + nil) + (let* ((obj (makearray 'T_REF + (car counts) + lst-of-refs + (class-table s))) + (new-addr (len heap-prime)) + (new-heap (bind new-addr obj heap-prime))) + (mv new-addr new-heap))))) +) + +; ----------------------------------------------------------------------------- +; Instruction length table -- PCs are now in bytes, not # of instructions + +(defun inst-length (inst) + (case (op-code inst) + (AALOAD 1) + (AASTORE 1) + (ACONST_NULL 1) + (ALOAD 2) + (ALOAD_0 1) + (ALOAD_1 1) + (ALOAD_2 1) + (ALOAD_3 1) + (ANEWARRAY 3) + (ARETURN 1) + (ARRAYLENGTH 1) + (ASTORE 2) + (ASTORE_0 1) + (ASTORE_1 1) + (ASTORE_2 1) + (ASTORE_3 1) + (BALOAD 1) + (BASTORE 1) + (BIPUSH 2) + (CALOAD 1) + (CASTORE 1) + (DUP 1) + (DUP_X1 1) + (DUP_X2 1) + (DUP2 1) + (DUP2_X1 1) + (DUP2_X2 1) + (GETFIELD 3) + (GETSTATIC 3) + (GOTO 3) + (GOTO_W 5) + (I2B 1) + (I2C 1) + (I2L 1) + (I2S 1) + (IADD 1) + (IALOAD 1) + (IAND 1) + (IASTORE 1) + (ICONST_M1 1) + (ICONST_0 1) + (ICONST_1 1) + (ICONST_2 1) + (ICONST_3 1) + (ICONST_4 1) + (ICONST_5 1) + (IDIV 1) + (IF_ACMPEQ 3) + (IF_ACMPNE 3) + (IF_ICMPEQ 3) + (IF_ICMPGE 3) + (IF_ICMPGT 3) + (IF_ICMPLE 3) + (IF_ICMPLT 3) + (IF_ICMPNE 3) + (IFEQ 3) + (IFGE 3) + (IFGT 3) + (IFLE 3) + (IFLT 3) + (IFNE 3) + (IFNONNULL 3) + (IFNULL 3) + (IINC 3) + (ILOAD 2) + (ILOAD_0 1) + (ILOAD_1 1) + (ILOAD_2 1) + (ILOAD_3 1) + (IMUL 1) + (INEG 1) + (INSTANCEOF 3) + (INVOKESPECIAL 3) + (INVOKESTATIC 3) + (INVOKEVIRTUAL 3) + (IOR 1) + (IREM 1) + (IRETURN 1) + (ISHL 1) + (ISHR 1) + (ISTORE 2) + (ISTORE_0 1) + (ISTORE_1 1) + (ISTORE_2 1) + (ISTORE_3 1) + (ISUB 1) + (IUSHR 1) + (IXOR 1) + (JSR 3) + (JSR_W 5) + (L2I 1) + (LADD 1) + (LALOAD 1) + (LAND 1) + (LASTORE 1) + (LCMP 1) + (LCONST_0 1) + (LCONST_1 1) + (LDC 2) + (LDC_W 3) + (LDC2_W 3) + (LDIV 1) + (LLOAD 2) + (LLOAD_0 1) + (LLOAD_1 1) + (LLOAD_2 1) + (LLOAD_3 1) + (LMUL 1) + (LNEG 1) + (LOR 1) + (LREM 1) + (LRETURN 1) + (LSHL 1) + (LSHR 1) + (LSTORE 2) + (LSTORE_0 1) + (LSTORE_1 1) + (LSTORE_2 1) + (LSTORE_3 1) + (LSUB 1) + (LUSHR 1) + (LXOR 1) + (MONITORENTER 1) + (MONITOREXIT 1) + (MULTIANEWARRAY 4) + (NEW 3) + (NEWARRAY 2) + (NOP 1) + (POP 1) + (POP2 1) + (PUTFIELD 3) + (PUTSTATIC 3) + (RET 2) + (RETURN 1) + (SALOAD 1) + (SASTORE 1) + (SIPUSH 3) + (SWAP 1) + (t 1))) + + +; ============================================================================= +; JVM INSTRUCTIONS BEGIN HERE +; ============================================================================= + +; ----------------------------------------------------------------------------- +; (AALOAD) Instruction + +(defun execute-AALOAD (inst th s) + (let* ((index (top (stack (top-frame th s)))) + (arrayref (top (pop (stack (top-frame th s))))) + (array (deref arrayref (heap s)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (element-at index array) + (pop (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (AASTORE) Instruction + +(defun execute-AASTORE (inst th s) + (let* ((value (top (stack (top-frame th s)))) + (index (top (pop (stack (top-frame th s))))) + (arrayref (top (pop (pop (stack (top-frame th s))))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (pop (pop (pop (stack (top-frame th s))))) + :heap (bind (cadr arrayref) + (set-element-at value + index + (deref arrayref (heap s)) + (class-table s)) + (heap s))))) + +; ----------------------------------------------------------------------------- +; (ACONST_NULL) Instruction + +(defun execute-ACONST_NULL (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push '(REF -1) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (ALOAD idx) Instruction - load a reference from the locals + +(defun execute-ALOAD (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (nth (arg1 inst) + (locals (top-frame th s))) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (ALOAD_X) Instruction - load a reference from the locals +; covers ALOAD_{0, 1, 2, 3} + +(defun execute-ALOAD_X (inst th s n) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (nth n (locals (top-frame th s))) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (ANEWARRAY) Instruction + +(defun execute-ANEWARRAY (inst th s) + (let* ((type 'T_REF) + (count (top (stack (top-frame th s)))) + (addr (len (heap s))) + (obj (makearray type + count + (init-array type count) + (class-table s)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (list 'REF addr) + (pop (stack (top-frame th s)))) + :heap (bind addr + obj + (heap s))))) + +; ----------------------------------------------------------------------------- +; (ARETURN) Instruction - return a reference to the preceeding frame + +(defun execute-ARETURN (inst th s) + (declare (ignore inst)) + (let* ((val (top (stack (top-frame th s)))) + (obj-ref (nth 0 (locals (top-frame th s)))) + (sync-status (sync-flg (top-frame th s))) + (class (cur-class (top-frame th s))) + (ret-ref (class-decl-heapref (bound? class (class-table s)))) + (new-heap (cond ((equal sync-status 'LOCKED) + (unlock-object th obj-ref (heap s))) + ((equal sync-status 'S_LOCKED) + (unlock-object th ret-ref (heap s))) + (t (heap s)))) + (s1 (modify th s + :call-stack (pop (call-stack th s)) + :heap new-heap))) + (modify th s1 + :stack (push val (stack (top-frame th s1)))))) + +; ----------------------------------------------------------------------------- +; (ARRAYLENGTH) Instruction + +(defun execute-ARRAYLENGTH (inst th s) + (let* ((arrayref (top (stack (top-frame th s)))) + (array (deref arrayref (heap s)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (array-bound array) + (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (ASTORE idx) Instruction - store a reference into the locals + +(defun execute-ASTORE (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :locals (update-nth (arg1 inst) + (top (stack (top-frame th s))) + (locals (top-frame th s))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (ASTORE_X) Instruction - store a reference into the locals +; covers ASTORE_{0, 1, 2, 3} + +(defun execute-ASTORE_X (inst th s n) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :locals (update-nth n + (top (stack (top-frame th s))) + (locals (top-frame th s))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (BALOAD) Instruction + +(defun execute-BALOAD (inst th s) + (let* ((index (top (stack (top-frame th s)))) + (arrayref (top (pop (stack (top-frame th s))))) + (array (deref arrayref (heap s))) + (element (if (equal (array-type array) + 'T_BOOLEAN) + (ubyte-fix (element-at index array)) + (byte-fix (element-at index array))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push element + (pop (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (BASTORE) Instruction + +(defun execute-BASTORE (inst th s) + (let* ((value (top (stack (top-frame th s)))) + (index (top (pop (stack (top-frame th s))))) + (arrayref (top (pop (pop (stack (top-frame th s)))))) + (element (if (equal (array-type (deref arrayref (heap s))) + 'T_BYTE) + (byte-fix value) + (u-fix value 1)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (pop (pop (pop (stack (top-frame th s))))) + :heap (bind (cadr arrayref) + (set-element-at element + index + (deref arrayref (heap s)) + (class-table s)) + (heap s))))) + +; ----------------------------------------------------------------------------- +; (BIPUSH const) Instruction + +(defun execute-BIPUSH (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (byte-fix (arg1 inst)) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (CALOAD) Instruction + +(defun execute-CALOAD (inst th s) + (let* ((index (top (stack (top-frame th s)))) + (arrayref (top (pop (stack (top-frame th s))))) + (array (deref arrayref (heap s)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (char-fix (element-at index array)) + (pop (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (CASTORE) Instruction + +(defun execute-CASTORE (inst th s) + (let* ((value (top (stack (top-frame th s)))) + (index (top (pop (stack (top-frame th s))))) + (arrayref (top (pop (pop (stack (top-frame th s))))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (pop (pop (pop (stack (top-frame th s))))) + :heap (bind (cadr arrayref) + (set-element-at (char-fix value) + index + (deref arrayref (heap s)) + (class-table s)) + (heap s))))) + +; ----------------------------------------------------------------------------- +; (DUP) Instruction + +(defun execute-DUP (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (top (stack (top-frame th s))) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (DUP_X1) Instruction + +(defun execute-DUP_X1 (inst th s) + (let* ((val1 (top (stack (top-frame th s)))) + (val2 (top (pop (stack (top-frame th s))))) + (stack_prime (pop (pop (stack (top-frame th s)))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push val1 (push val2 (push val1 stack_prime)))))) + +; ----------------------------------------------------------------------------- +; (DUP_X2) Instruction + +(defun execute-DUP_X2 (inst th s) + (let* ((val1 (top (stack (top-frame th s)))) + (val2 (top (pop (stack (top-frame th s))))) + (val3 (top (popn 2 (stack (top-frame th s))))) + (stack_prime (popn 3 (stack (top-frame th s))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push val1 + (push val2 + (push val3 + (push val1 stack_prime))))))) + +; ----------------------------------------------------------------------------- +; (DUP2) Instruction + +(defun execute-DUP2 (inst th s) + (let* ((val1 (top (stack (top-frame th s)))) + (val2 (top (pop (stack (top-frame th s))))) + (stack_prime (pop (pop (stack (top-frame th s)))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push val1 + (push val2 + (push val1 + (push val2 stack_prime))))))) + +; ----------------------------------------------------------------------------- +; (DUP2_X1) Instruction + +(defun execute-DUP2_X1 (inst th s) + (let* ((val1 (top (stack (top-frame th s)))) + (val2 (top (pop (stack (top-frame th s))))) + (val3 (top (popn 2 (stack (top-frame th s))))) + (stack_prime (popn 3 (stack (top-frame th s))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push val1 + (push val2 + (push val3 + (push val1 + (push val2 stack_prime)))))))) + +; ----------------------------------------------------------------------------- +; (DUP2_X2) Instruction + +(defun execute-DUP2_X2 (inst th s) + (let* ((val1 (top (stack (top-frame th s)))) + (val2 (top (pop (stack (top-frame th s))))) + (val3 (top (popn 2 (stack (top-frame th s))))) + (val4 (top (popn 3 (stack (top-frame th s))))) + (stack_prime (popn 4 (stack (top-frame th s))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push val1 + (push val2 + (push val3 + (push val4 + (push val1 + (push val2 stack_prime))))))))) + +; ----------------------------------------------------------------------------- +; (GETFIELD "class" "field" ?long-flag?) Instruction + +(defun execute-GETFIELD (inst th s) + (let* ((class-name (arg1 inst)) + (field-name (arg2 inst)) + (long-flag (arg3 inst)) + (instance (deref (top (stack (top-frame th s))) (heap s))) + (field-value (field-value class-name field-name instance))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (if long-flag + (push 0 (push field-value + (pop (stack (top-frame th s))))) + (push field-value + (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (GETSTATIC "class" "field" ?long-flag?) Instruction + +(defun static-field-value (class-name field-name s) + (let* ((class-ref (class-decl-heapref + (bound? class-name (class-table s)))) + (instance (deref class-ref (heap s)))) + (field-value "java.lang.Class" field-name instance))) + +(defun execute-GETSTATIC (inst th s) + (let* ((class-name (arg1 inst)) + (field-name (arg2 inst)) + (long-flag (arg3 inst)) + (class-ref (class-decl-heapref + (bound? class-name (class-table s)))) + (instance (deref class-ref (heap s))) + (field-value (field-value "java.lang.Class" field-name instance))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (if long-flag + (push 0 (push field-value (stack (top-frame th s)))) + (push field-value (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (GOTO pc) Instruction + +(defun execute-GOTO (inst th s) + (modify th s + :pc (+ (arg1 inst) (pc (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (GOTO_W pc) Instruction + +(defun execute-GOTO_W (inst th s) + (modify th s + :pc (+ (arg1 inst) (pc (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (I2B) Instruction - int to byte narrowing conversion + +(defun execute-I2B (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (byte-fix (top (stack (top-frame th s)))) + (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (I2C) Instruction - int to char narrowing conversion + +(defun execute-I2C (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (char-fix (top (stack (top-frame th s)))) + (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (I2L) Instruction - int to long conversion + +(defun execute-I2L (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (long-fix (top (stack (top-frame th s)))) + (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (I2S) Instruction - int to short narrowing conversion + +(defun execute-I2S (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (short-fix (top (stack (top-frame th s)))) + (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (IADD) Instruction + +(defun execute-IADD (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (int-fix + (+ (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s))))) + (pop (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (IALOAD) Instruction + +(defun execute-IALOAD (inst th s) + (let* ((index (top (stack (top-frame th s)))) + (arrayref (top (pop (stack (top-frame th s))))) + (array (deref arrayref (heap s)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (element-at index array) + (pop (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (IAND) Instruction + +(defun execute-IAND (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (logand (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (pop (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (IASTORE) Instruction + +(defun execute-IASTORE (inst th s) + (let* ((value (top (stack (top-frame th s)))) + (index (top (pop (stack (top-frame th s))))) + (arrayref (top (pop (pop (stack (top-frame th s))))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (pop (pop (pop (stack (top-frame th s))))) + :heap (bind (cadr arrayref) + (set-element-at value + index + (deref arrayref (heap s)) + (class-table s)) + (heap s))))) + +; ----------------------------------------------------------------------------- +; (ICONST_X) Instruction - push a certain constant onto the stack +; covers ICONST_{M1, 0, 1, 2, 3, 4, 5} + +(defun execute-ICONST_X (inst th s n) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push n (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IDIV) Instruction + +(defun execute-IDIV (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (int-fix + (truncate (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s))))) + (pop (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (IF_ACMPEQ pc) Instruction + +(defun execute-IF_ACMPEQ (inst th s) + (modify th s + :pc (if (equal (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (IF_ACMPNE pc) Instruction + +(defun execute-IF_ACMPNE (inst th s) + (modify th s + :pc (if (equal (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (+ (inst-length inst) (pc (top-frame th s))) + (+ (arg1 inst) (pc (top-frame th s)))) + :stack (pop (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (IF_ICMPEQ pc) Instruction + +(defun execute-IF_ICMPEQ (inst th s) + (modify th s + :pc (if (equal (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (IF_ICMPGE pc) Instruction + +(defun execute-IF_ICMPGE (inst th s) + (modify th s + :pc (if (>= (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (IF_ICMPGT pc) Instruction + +(defun execute-IF_ICMPGT (inst th s) + (modify th s + :pc (if (> (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (IF_ICMPLT pc) Instruction + +(defun execute-IF_ICMPLT (inst th s) + (modify th s + :pc (if (< (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (IF_ICMPLE pc) Instruction + +(defun execute-IF_ICMPLE (inst th s) + (modify th s + :pc (if (<= (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (IF_ICMPNE pc) Instruction + +(defun execute-IF_ICMPNE (inst th s) + (modify th s + :pc (if (equal (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (+ (inst-length inst) (pc (top-frame th s))) + (+ (arg1 inst) (pc (top-frame th s)))) + :stack (pop (pop (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (IFEQ pc) Instruction + +(defun execute-IFEQ (inst th s) + (modify th s + :pc (if (equal (top (stack (top-frame th s))) 0) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IFGE pc) Instruction + +(defun execute-IFGE (inst th s) + (modify th s + :pc (if (>= (top (stack (top-frame th s))) 0) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IFGT pc) Instruction + +(defun execute-IFGT (inst th s) + (modify th s + :pc (if (> (top (stack (top-frame th s))) 0) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IFLE pc) Instruction + +(defun execute-IFLE (inst th s) + (modify th s + :pc (if (<= (top (stack (top-frame th s))) 0) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IFLT pc) Instruction + +(defun execute-IFLT (inst th s) + (modify th s + :pc (if (< (top (stack (top-frame th s))) 0) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IFNE pc) Instruction + +(defun execute-IFNE (inst th s) + (modify th s + :pc (if (equal (top (stack (top-frame th s))) 0) + (+ (inst-length inst) (pc (top-frame th s))) + (+ (arg1 inst) (pc (top-frame th s)))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IFNONNULL pc) Instruction + +(defun execute-IFNONNULL (inst th s) + (modify th s + :pc (if (equal (top (stack (top-frame th s))) '(REF -1)) + (+ (inst-length inst) (pc (top-frame th s))) + (+ (arg1 inst) (pc (top-frame th s)))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IFNULL pc) Instruction + +(defun execute-IFNULL (inst th s) + (modify th s + :pc (if (equal (top (stack (top-frame th s))) '(REF -1)) + (+ (arg1 inst) (pc (top-frame th s))) + (+ (inst-length inst) (pc (top-frame th s)))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IINC idx const) Instruction - Increment local variable by a constant + +(defun execute-IINC (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :locals (update-nth (arg1 inst) + (int-fix + (+ (arg2 inst) + (nth (arg1 inst) + (locals (top-frame th s))))) + (locals (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (ILOAD idx) Instruction - Push a local onto the stack + +(defun execute-ILOAD (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (nth (arg1 inst) + (locals (top-frame th s))) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (ILOAD_X) Instruction - Push a local onto the stack +; covers ILOAD_{0, 1, 2, 3} + +(defun execute-ILOAD_X (inst th s n) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (nth n (locals (top-frame th s))) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (IMUL) Instruction + +(defun execute-IMUL (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (int-fix + (* (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s))))) + (pop (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (INEG) Instruction +; Because of the way the JVM represents 2's complement ints, +; the negation of the most negative int is itself + +(defun execute-INEG (inst th s) + (let* ((result (if (equal (top (stack (top-frame th s))) + *most-negative-integer*) + *most-negative-integer* + (- (top (stack (top-frame th s))))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push result (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (INSTANCEOF) Instruction + +(defun execute-INSTANCEOF (inst th s) + (let* ((ref (top (stack (top-frame th s)))) + (obj (deref ref (heap s))) + (obj-class (caar obj)) + (obj-supers (cons obj-class (class-decl-superclasses + (bound? obj-class (class-table s))))) + (value (if (nullrefp ref) + 0 + (if (member-equal (arg1 inst) obj-supers) + 1 + 0)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push value (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (IOR) Instruction + +(defun execute-IOR (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (logior (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (pop (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (IREM) Instruction + +(defun execute-IREM (inst th s) + (let* ((val1 (top (pop (stack (top-frame th s))))) + (val2 (top (stack (top-frame th s)))) + (result (- val1 (* (truncate val1 val2) val2)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push result + (pop (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (IRETURN) Instruction - return an int + +(defun execute-IRETURN (inst th s) + (declare (ignore inst)) + (let* ((val (top (stack (top-frame th s)))) + (obj-ref (nth 0 (locals (top-frame th s)))) + (sync-status (sync-flg (top-frame th s))) + (class (cur-class (top-frame th s))) + (ret-ref (class-decl-heapref (bound? class (class-table s)))) + (new-heap (cond ((equal sync-status 'LOCKED) + (unlock-object th obj-ref (heap s))) + ((equal sync-status 'S_LOCKED) + (unlock-object th ret-ref (heap s))) + (t (heap s)))) + (s1 (modify th s + :call-stack (pop (call-stack th s)) + :heap new-heap))) + (modify th s1 + :stack (push val (stack (top-frame th s1)))))) + +; ----------------------------------------------------------------------------- +; (ISHL) Instruction + +(defun execute-ISHL (inst th s) + (let* ((val1 (top (pop (stack (top-frame th s))))) + (val2 (top (stack (top-frame th s)))) + (shiftval (5-bit-fix val2)) + (result (shl val1 shiftval))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (int-fix result) + (pop (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (ISHR) Instruction + +(defun execute-ISHR (inst th s) + (let* ((val1 (top (pop (stack (top-frame th s))))) + (val2 (top (stack (top-frame th s)))) + (shiftval (5-bit-fix val2)) + (result (shr val1 shiftval))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (int-fix result) + (pop (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (ISTORE idx) Instruction - store an int into the locals + +(defun execute-ISTORE (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :locals (update-nth (arg1 inst) + (top (stack (top-frame th s))) + (locals (top-frame th s))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (ISTORE_X) Instruction - store an int into the locals +; covers ISTORE_{0, 1, 2, 3} + +(defun execute-ISTORE_X (inst th s n) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :locals (update-nth n + (top (stack (top-frame th s))) + (locals (top-frame th s))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (ISUB) Instruction + +(defun execute-ISUB (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (int-fix (- (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s))))) + (pop (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (IUSHR) Instruction + +(defun execute-IUSHR (inst th s) + (let* ((val1 (top (pop (stack (top-frame th s))))) + (val2 (top (stack (top-frame th s)))) + (shiftval (5-bit-fix val2)) + (result (shr val1 shiftval))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (int-fix result) + (pop (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (IXOR) Instruction + +(defun execute-IXOR (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (logxor (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s)))) + (pop (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (JSR) Instruction + +(defun execute-JSR (inst th s) + (modify th s + :pc (+ (arg1 inst) (pc (top-frame th s))) + :stack (push (list 'RETURNADDRESS + (+ (inst-length inst) + (pc (top-frame th s)))) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (JSR_W) Instruction + +(defun execute-JSR_W (inst th s) + (modify th s + :pc (+ (arg1 inst) (pc (top-frame th s))) + :stack (push (list 'RETURNADDRESS + (+ (inst-length inst) + (pc (top-frame th s)))) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (INVOKESPECIAL "class" "name" n) Instruction + +(defun class-name-of-ref (ref heap) + (car (car (deref ref heap)))) + +(defun bind-formals (n stack) + (if (zp n) + nil + (cons (top stack) + (bind-formals (- n 1) (pop stack))))) + +(defun lookup-method-in-superclasses (name classes class-table) + (cond ((endp classes) nil) + (t (let* ((class-name (car classes)) + (class-decl (bound? class-name class-table)) + (method (bound? name (class-decl-methods class-decl)))) + (if method + method + (lookup-method-in-superclasses name (cdr classes) + class-table)))))) + +(defun lookup-method (name class-name class-table) + (lookup-method-in-superclasses name + (cons class-name + (class-decl-superclasses + (bound? class-name class-table))) + class-table)) + +(defun execute-INVOKESPECIAL (inst th s) + (let* ((method-name (arg2 inst)) + (nformals (arg3 inst)) + (obj-ref (top (popn nformals (stack (top-frame th s))))) + (instance (deref obj-ref (heap s))) + (obj-class-name (arg1 inst)) + (closest-method + (lookup-method method-name + obj-class-name + (class-table s))) + (prog (method-program closest-method)) + (s1 (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (popn (+ nformals 1) + (stack (top-frame th s))))) + (tThread (rrefToThread obj-ref (thread-table s)))) + (cond + ((method-isNative? closest-method) + (cond ((equal method-name "start") + (modify tThread s1 :status 'SCHEDULED)) + ((equal method-name "stop") + (modify tThread s1 + :status 'UNSCHEDULED)) + (t s))) + ((and (method-sync closest-method) + (objectLockable? instance th)) + (modify th s1 + :call-stack + (push (make-frame 0 + (reverse + (bind-formals (+ nformals 1) + (stack (top-frame th s)))) + nil + prog + 'LOCKED + (arg1 inst)) + (call-stack th s1)) + :heap (lock-object th obj-ref (heap s)))) + ((method-sync closest-method) + s) + (t + (modify th s1 + :call-stack + (push (make-frame 0 + (reverse + (bind-formals (+ nformals 1) + (stack (top-frame th s)))) + nil + prog + 'UNLOCKED + (arg1 inst)) + (call-stack th s1))))))) + +; ----------------------------------------------------------------------------- +; (INVOKESTATIC "class" "name" n) Instruction + +(defun execute-INVOKESTATIC (inst th s) + (let* ((class (arg1 inst)) + (method-name (arg2 inst)) + (nformals (arg3 inst)) + (obj-ref (class-decl-heapref (bound? class (class-table s)))) + (instance (deref obj-ref (heap s))) + (closest-method + (lookup-method method-name + (arg1 inst) + (class-table s))) + (prog (method-program closest-method)) + (s1 (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (popn nformals (stack (top-frame th s)))))) + (cond + ((and (method-sync closest-method) + (objectLockable? instance th)) + (modify th s1 + :call-stack + (push (make-frame 0 + (reverse + (bind-formals nformals + (stack (top-frame th s)))) + nil + prog + 'S_LOCKED + (arg1 inst)) + (call-stack th s1)) + :heap (lock-object th obj-ref (heap s)))) + ((method-sync closest-method) + s) + (t + (modify th s1 + :call-stack + (push (make-frame 0 + (reverse + (bind-formals nformals + (stack (top-frame th s)))) + nil + prog + 'UNLOCKED + (arg1 inst)) + (call-stack th s1))))))) + +; ----------------------------------------------------------------------------- +; (INVOKEVIRTUAL "class" "name" n) Instruction + +(defun execute-INVOKEVIRTUAL (inst th s) + (let* ((method-name (arg2 inst)) + (nformals (arg3 inst)) + (obj-ref (top (popn nformals (stack (top-frame th s))))) + (instance (deref obj-ref (heap s))) + (obj-class-name (class-name-of-ref obj-ref (heap s))) + (closest-method + (lookup-method method-name + obj-class-name + (class-table s))) + (prog (method-program closest-method)) + (s1 (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (popn (+ nformals 1) + (stack (top-frame th s))))) + (tThread (rrefToThread obj-ref (thread-table s)))) + (cond + ((method-isNative? closest-method) + (cond ((equal method-name "start") + (modify tThread s1 :status 'SCHEDULED)) + ((equal method-name "stop") + (modify tThread s1 + :status 'UNSCHEDULED)) + (t s))) + ((and (method-sync closest-method) + (objectLockable? instance th)) + (modify th s1 + :call-stack + (push (make-frame 0 + (reverse + (bind-formals (+ nformals 1) + (stack (top-frame th s)))) + nil + prog + 'LOCKED + (arg1 inst)) + (call-stack th s1)) + :heap (lock-object th obj-ref (heap s)))) + ((method-sync closest-method) + s) + (t + (modify th s1 + :call-stack + (push (make-frame 0 + (reverse + (bind-formals (+ nformals 1) + (stack (top-frame th s)))) + nil + prog + 'UNLOCKED + (arg1 inst)) + (call-stack th s1))))))) + +; ----------------------------------------------------------------------------- +; (L2I) Instruction - long to int narrowing conversion + +(defun execute-L2I (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (int-fix (top (pop (stack (top-frame th s))))) + (pop (pop (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (LADD) Instruction - Add to longs from the top of the stack + +(defun execute-LADD (inst th s) + (let* ((val1 (top (pop (stack (top-frame th s))))) + (val2 (top (popn 3 (stack (top-frame th s)))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (long-fix (+ val1 val2)) + (popn 4 (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (LALOAD) Instruction + +(defun execute-LALOAD (inst th s) + (let* ((index (top (stack (top-frame th s)))) + (arrayref (top (pop (stack (top-frame th s))))) + (array (deref arrayref (heap s)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (element-at index array) + (pop (pop (stack (top-frame th s))))))))) + +; ----------------------------------------------------------------------------- +; (LAND) Instruction + +(defun execute-LAND (inst th s) + (let* ((val1 (top (pop (stack (top-frame th s))))) + (val2 (top (popn 3 (stack (top-frame th s)))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (logand val1 val2) + (popn 4 (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (LASTORE) Instruction + +(defun execute-LASTORE (inst th s) + (let* ((value (top (pop (stack (top-frame th s))))) + (index (top (pop (pop (stack (top-frame th s)))))) + (arrayref (top (popn 3 (stack (top-frame th s)))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (popn 4 (stack (top-frame th s))) + :heap (bind (cadr arrayref) + (set-element-at value + index + (deref arrayref (heap s)) + (class-table s)) + (heap s))))) + +; ----------------------------------------------------------------------------- +; (LCMP) Instruction - compare two longs +; val1 > val2 --> 1 +; val1 = val2 --> 0 +; val1 < val2 --> -1 + +(defun execute-LCMP (inst th s) + (let* ((val2 (top (pop (stack (top-frame th s))))) + (val1 (top (popn 3 (stack (top-frame th s))))) + (result (cond ((> val1 val2) 1) + ((< val1 val2) -1) + (t 0)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push result + (popn 4 (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (LCONST_X) Instruction - push a certain long constant onto the stack +; covers LCONST_{0, 1} + +(defun execute-LCONST_X (inst th s n) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push n (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (LDC) Instruction + +(defun set-instance-field (class-name field-name value instance) + (bind class-name + (bind field-name value + (binding class-name instance)) + instance)) + +(defun execute-LDC (inst th s) + (let* ((class (cur-class (top-frame th s))) + (cp (retrieve-cp class (class-table s))) + (entry (nth (arg1 inst) cp)) + (value (cadr entry))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push value (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (LDC2_W) Instruction + +(defun execute-LDC2_W (inst th s) + (let* ((class (cur-class (top-frame th s))) + (cp (retrieve-cp class (class-table s))) + (entry (nth (arg1 inst) cp)) + (value (cadr entry))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push value (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (LDIV) Instruction + +(defun execute-LDIV (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push + (long-fix + (truncate (top (popn 3 (stack (top-frame th s)))) + (top (pop (stack (top-frame th s)))))) + (popn 4 (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (LLOAD idx) Instruction - Push a long local onto the stack + +(defun execute-LLOAD (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (nth (arg1 inst) + (locals (top-frame th s))) + (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (LLOAD_X) Instruction - Push a long local onto the stack +; covers LLOAD_{0, 1, 2, 3} + +(defun execute-LLOAD_X (inst th s n) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (nth n (locals (top-frame th s))) + (stack (top-frame th s)))))) + +; ----------------------------------------------------------------------------- +; (LMUL) Instruction + +(defun execute-LMUL (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (ulong-fix + (* (top (pop (stack (top-frame th s)))) + (top (popn 3 (stack (top-frame th s)))))) + (popn 4 (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (LNEG) Instruction +; Because of the way the JVM represents 2's complement ints, +; the negation of the most negative int is itself + +(defun execute-LNEG (inst th s) + (let* ((result (if (equal (top (pop (stack (top-frame th s)))) + *most-negative-long*) + *most-negative-long* + (- (top (pop (stack (top-frame th s)))))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push result (popn 2 (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (LOR) Instruction + +(defun execute-LOR (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (logior (top (pop (stack (top-frame th s)))) + (top (popn 3 (stack (top-frame th s))))) + (popn 4 (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (LREM) Instruction + +(defun execute-LREM (inst th s) + (let* ((val1 (top (pop (stack (top-frame th s))))) + (val2 (top (popn 3 (stack (top-frame th s))))) + (result (- val1 (* (truncate val1 val2) val2)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push result + (popn 4 (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (LRETURN) Instruction - return a long + +(defun execute-LRETURN (inst th s) + (declare (ignore inst)) + (let* ((val (top (pop (stack (top-frame th s))))) + (obj-ref (nth 0 (locals (top-frame th s)))) + (sync-status (sync-flg (top-frame th s))) + (class (cur-class (top-frame th s))) + (ret-ref (class-decl-heapref (bound? class (class-table s)))) + (new-heap (cond ((equal sync-status 'LOCKED) + (unlock-object th obj-ref (heap s))) + ((equal sync-status 'S_LOCKED) + (unlock-object th ret-ref (heap s))) + (t (heap s)))) + (s1 (modify th s + :call-stack (pop (call-stack th s)) + :heap new-heap))) + (modify th s1 + :stack (push 0 (push val (stack (top-frame th s1))))))) + +; ----------------------------------------------------------------------------- +; (LSHL) Instruction + +(defun execute-LSHL (inst th s) + (let* ((val1 (top (popn 2 (stack (top-frame th s))))) + (val2 (top (stack (top-frame th s)))) + (shiftval (6-bit-fix val2)) + (result (shl val1 shiftval))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (long-fix result) + (popn 3 (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (LSHR) Instruction + +(defun execute-LSHR (inst th s) + (let* ((val1 (top (popn 2 (stack (top-frame th s))))) + (val2 (top (stack (top-frame th s)))) + (shiftval (6-bit-fix val2)) + (result (shr val1 shiftval))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (long-fix result) + (popn 3 (pop (stack (top-frame th s))))))))) + +; ----------------------------------------------------------------------------- +; (LSTORE idx) Instruction - store a long into the locals + +(defun execute-LSTORE (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :locals (update-nth (arg1 inst) + (top (pop (stack (top-frame th s)))) + (locals (top-frame th s))) + :stack (popn 2 (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (LSTORE_X) Instruction - store a long into the locals +; covers LSTORE_{0, 1, 2, 3} + +(defun execute-LSTORE_X (inst th s n) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :locals (update-nth n + (top (pop (stack (top-frame th s)))) + (locals (top-frame th s))) + :stack (popn 2 (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (LSUB) Instruction + +(defun execute-LSUB (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push + (ulong-fix (- (top (popn 3 (stack (top-frame th s)))) + (top (pop (stack (top-frame th s)))))) + (popn 4 (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (LUSHR) Instruction + +(defun execute-LUSHR (inst th s) + (let* ((val1 (top (popn 2 (stack (top-frame th s))))) + (val2 (top (stack (top-frame th s)))) + (shiftval (6-bit-fix val2)) + (result (shr val1 shiftval))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (long-fix result) + (popn 3 (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (LXOR) Instruction + +(defun execute-LXOR (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push 0 + (push (logxor (top (pop (stack (top-frame th s)))) + (top (popn 3 (stack (top-frame th s))))) + (popn 4 (stack (top-frame th s))))))) + +; ----------------------------------------------------------------------------- +; (MONITORENTER) Instruction + +(defun execute-MONITORENTER (inst th s) + (let* ((obj-ref (top (stack (top-frame th s)))) + (instance (deref obj-ref (heap s)))) + (cond + ((objectLockable? instance th) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (pop (stack (top-frame th s))) + :heap (lock-object th obj-ref (heap s)))) + (t s)))) + +; ----------------------------------------------------------------------------- +; (MONITOREXIT) Instruction + +(defun execute-MONITOREXIT (inst th s) + (let* ((obj-ref (top (stack (top-frame th s)))) + (instance (deref obj-ref (heap s)))) + (cond + ((objectUnLockable? instance th) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (pop (stack (top-frame th s))) + :heap (unlock-object th obj-ref (heap s)))) + (t s)))) + +; ----------------------------------------------------------------------------- +; (MULTIANEWARRAY) Instruction + +(defun execute-MULTIANEWARRAY (inst th s) + (let* ((dimentions (arg1 inst)) + (counts (reverse (take dimentions (stack (top-frame th s)))))) + (mv-let (addr new-heap) + (makemultiarray counts s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (list 'REF addr) + (nthcdr dimentions (stack (top-frame th s)))) + :heap new-heap)))) + +; ----------------------------------------------------------------------------- +; (NEW "class") Instruction + +(defun execute-NEW (inst th s) + (let* ((class-name (arg1 inst)) + (class-table (class-table s)) + (closest-method (lookup-method "run" class-name class-table)) + (prog (method-program closest-method)) + (new-object (build-an-instance + (cons class-name + (class-decl-superclasses + (bound? class-name class-table))) + class-table)) + (new-address (len (heap s))) + (s1 (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (list 'REF new-address) + (stack (top-frame th s))) + :heap (bind new-address new-object (heap s))))) + (if (isThreadObject? class-name class-table) + (modify nil s1 + :thread-table + (addto-tt + (push + (make-frame 0 + (list (list 'REF new-address)) + nil + prog + 'UNLOCKED + class-name) + nil) + 'UNSCHEDULED + (list 'REF new-address) + (thread-table s1))) + s1))) + +; ----------------------------------------------------------------------------- +; (NEWARRAY) Instruction + +(defun execute-NEWARRAY (inst th s) + (let* ((type (arg1 inst)) + (count (top (stack (top-frame th s)))) + (addr (len (heap s))) + (obj (makearray type + count + (init-array type count) + (class-table s)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (list 'REF addr) + (pop (stack (top-frame th s)))) + :heap (bind addr + obj + (heap s))))) + +; ----------------------------------------------------------------------------- +; (NOP) Instruction + +(defun execute-NOP (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (POP) Instruction + +(defun execute-POP (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (pop (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (POP2) Instruction + +(defun execute-POP2 (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (popn 2 (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (PUTFIELD "class" "field" ?long-flag?) Instruction + +(defun execute-PUTFIELD (inst th s) + (let* ((class-name (arg1 inst)) + (field-name (arg2 inst)) + (long-flag (arg3 inst)) + (value (if long-flag + (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s))))) + (instance (if long-flag + (deref (top (popn 2 (stack (top-frame th s)))) (heap s)) + (deref (top (pop (stack (top-frame th s)))) (heap s)))) + (address (cadr (if long-flag + (top (popn 2 (stack (top-frame th s)))) + (top (pop (stack (top-frame th s)))))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (if long-flag + (popn 3 (stack (top-frame th s))) + (pop (pop (stack (top-frame th s))))) + :heap (bind address + (set-instance-field class-name + field-name + value + instance) + (heap s))))) + +; ----------------------------------------------------------------------------- +; (PUTSTATIC "class" "field" ?long-flag?) Instruction + +(defun execute-PUTSTATIC (inst th s) + (let* ((class-name (arg1 inst)) + (field-name (arg2 inst)) + (long-flag (arg3 inst)) + (class-ref (class-decl-heapref + (bound? class-name (class-table s)))) + (value (if long-flag + (top (pop (stack (top-frame th s)))) + (top (stack (top-frame th s))))) + (instance (deref class-ref (heap s)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (if long-flag + (popn 2 (stack (top-frame th s))) + (pop (stack (top-frame th s)))) + :heap (bind (cadr class-ref) + (set-instance-field "java.lang.Class" + field-name + value + instance) + (heap s))))) + +; ----------------------------------------------------------------------------- +; (RET) Instruction + +(defun execute-RET (inst th s) + (let* ((ret-addr (nth (arg1 inst) (locals (top-frame th s)))) + (addr (cadr ret-addr))) + (modify th s :pc addr))) + +; ----------------------------------------------------------------------------- +; (RETURN) Instruction - Void Return + +(defun execute-RETURN (inst th s) + (declare (ignore inst)) + (let* ((obj-ref (nth 0 (locals (top-frame th s)))) + (sync-status (sync-flg (top-frame th s))) + (class (cur-class (top-frame th s))) + (ret-ref (class-decl-heapref (bound? class (class-table s)))) + (new-heap (cond ((equal sync-status 'LOCKED) + (unlock-object th obj-ref (heap s))) + ((equal sync-status 'S_LOCKED) + (unlock-object th ret-ref (heap s))) + (t (heap s))))) + (modify th s + :call-stack (pop (call-stack th s)) + :heap new-heap))) + +; ----------------------------------------------------------------------------- +; (SALOAD) Instruction + +(defun execute-SALOAD (inst th s) + (let* ((index (top (stack (top-frame th s)))) + (arrayref (top (pop (stack (top-frame th s))))) + (array (deref arrayref (heap s)))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (element-at index array) + (pop (pop (stack (top-frame th s)))))))) + +; ----------------------------------------------------------------------------- +; (SASTORE) Instruction + +(defun execute-SASTORE (inst th s) + (let* ((value (top (stack (top-frame th s)))) + (index (top (pop (stack (top-frame th s))))) + (arrayref (top (pop (pop (stack (top-frame th s))))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (pop (pop (pop (stack (top-frame th s))))) + :heap (bind (cadr arrayref) + (set-element-at (short-fix value) + index + (deref arrayref (heap s)) + (class-table s)) + (heap s))))) + +; ----------------------------------------------------------------------------- +; (SIPUSH const) Instruction + +(defun execute-SIPUSH (inst th s) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push (short-fix (arg1 inst)) + (stack (top-frame th s))))) + +; ----------------------------------------------------------------------------- +; (SWAP) Instruction + +(defun execute-SWAP (inst th s) + (let* ((val1 (top (stack (top-frame th s)))) + (val2 (top (pop (stack (top-frame th s)))))) + (modify th s + :pc (+ (inst-length inst) (pc (top-frame th s))) + :stack (push val2 + (push val1 + (pop (pop (stack (top-frame th s))))))))) + +; ----------------------------------------------------------------------------- +; Putting it all together + +(defun index-into-program (byte-offset program) + (declare (xargs :measure (len program))) + (if (endp program) + nil + (if (zp byte-offset) + (car program) + (index-into-program (- byte-offset + (inst-length (car program))) + (cdr program))))) + +(defun next-inst (th s) + (index-into-program (pc (top-frame th s)) + (program (top-frame th s)))) + +(defun do-inst (inst th s) + (case (op-code inst) + (AALOAD (execute-AALOAD inst th s)) + (AASTORE (execute-AASTORE inst th s)) + (ACONST_NULL (execute-ACONST_NULL inst th s)) + (ALOAD (execute-ALOAD inst th s)) + (ALOAD_0 (execute-ALOAD_X inst th s 0)) + (ALOAD_1 (execute-ALOAD_X inst th s 1)) + (ALOAD_2 (execute-ALOAD_X inst th s 2)) + (ALOAD_3 (execute-ALOAD_X inst th s 3)) + (ANEWARRAY (execute-ANEWARRAY inst th s)) + (ARETURN (execute-ARETURN inst th s)) + (ARRAYLENGTH (execute-ARRAYLENGTH inst th s)) + (ASTORE (execute-ASTORE inst th s)) + (ASTORE_0 (execute-ASTORE_X inst th s 0)) + (ASTORE_1 (execute-ASTORE_X inst th s 1)) + (ASTORE_2 (execute-ASTORE_X inst th s 2)) + (ASTORE_3 (execute-ASTORE_X inst th s 3)) + (BALOAD (execute-BALOAD inst th s)) + (BASTORE (execute-BASTORE inst th s)) + (BIPUSH (execute-BIPUSH inst th s)) + (CALOAD (execute-CALOAD inst th s)) + (CASTORE (execute-CASTORE inst th s)) + (DUP (execute-DUP inst th s)) + (DUP_X1 (execute-DUP_X1 inst th s)) + (DUP_X2 (execute-DUP_X2 inst th s)) + (DUP2 (execute-DUP2 inst th s)) + (DUP2_X1 (execute-DUP2_X1 inst th s)) + (DUP2_X2 (execute-DUP2_X2 inst th s)) + (GETFIELD (execute-GETFIELD inst th s)) + (GETSTATIC (execute-GETSTATIC inst th s)) + (GOTO (execute-GOTO inst th s)) + (GOTO_W (execute-GOTO_W inst th s)) + (I2B (execute-I2B inst th s)) + (I2C (execute-I2C inst th s)) + (I2L (execute-I2L inst th s)) + (I2S (execute-I2S inst th s)) + (IADD (execute-IADD inst th s)) + (IALOAD (execute-IALOAD inst th s)) + (IAND (execute-IAND inst th s)) + (IASTORE (execute-IASTORE inst th s)) + (ICONST_M1 (execute-ICONST_X inst th s -1)) + (ICONST_0 (execute-ICONST_X inst th s 0)) + (ICONST_1 (execute-ICONST_X inst th s 1)) + (ICONST_2 (execute-ICONST_X inst th s 2)) + (ICONST_3 (execute-ICONST_X inst th s 3)) + (ICONST_4 (execute-ICONST_X inst th s 4)) + (ICONST_5 (execute-ICONST_X inst th s 5)) + (IDIV (execute-IDIV inst th s)) + (IF_ACMPEQ (execute-IF_ACMPEQ inst th s)) + (IF_ACMPNE (execute-IF_ACMPNE inst th s)) + (IF_ICMPEQ (execute-IF_ICMPEQ inst th s)) + (IF_ICMPGE (execute-IF_ICMPGE inst th s)) + (IF_ICMPGT (execute-IF_ICMPGT inst th s)) + (IF_ICMPLE (execute-IF_ICMPLE inst th s)) + (IF_ICMPLT (execute-IF_ICMPLT inst th s)) + (IF_ICMPNE (execute-IF_ICMPNE inst th s)) + (IFEQ (execute-IFEQ inst th s)) + (IFGE (execute-IFGE inst th s)) + (IFGT (execute-IFGT inst th s)) + (IFLE (execute-IFLE inst th s)) + (IFLT (execute-IFLT inst th s)) + (IFNE (execute-IFNE inst th s)) + (IFNONNULL (execute-IFNONNULL inst th s)) + (IFNULL (execute-IFNULL inst th s)) + (IINC (execute-IINC inst th s)) + (ILOAD (execute-ILOAD inst th s)) + (ILOAD_0 (execute-ILOAD_X inst th s 0)) + (ILOAD_1 (execute-ILOAD_X inst th s 1)) + (ILOAD_2 (execute-ILOAD_X inst th s 2)) + (ILOAD_3 (execute-ILOAD_X inst th s 3)) + (IMUL (execute-IMUL inst th s)) + (INEG (execute-INEG inst th s)) + (INSTANCEOF (execute-INSTANCEOF inst th s)) + (INVOKESPECIAL (execute-INVOKESPECIAL inst th s)) + (INVOKESTATIC (execute-INVOKESTATIC inst th s)) + (INVOKEVIRTUAL (execute-INVOKEVIRTUAL inst th s)) + (IOR (execute-IOR inst th s)) + (IREM (execute-IREM inst th s)) + (IRETURN (execute-IRETURN inst th s)) + (ISHL (execute-ISHL inst th s)) + (ISHR (execute-ISHR inst th s)) + (ISTORE (execute-ISTORE inst th s)) + (ISTORE_0 (execute-ISTORE_X inst th s 0)) + (ISTORE_1 (execute-ISTORE_X inst th s 1)) + (ISTORE_2 (execute-ISTORE_X inst th s 2)) + (ISTORE_3 (execute-ISTORE_X inst th s 3)) + (ISUB (execute-ISUB inst th s)) + (IUSHR (execute-IUSHR inst th s)) + (IXOR (execute-IXOR inst th s)) + (JSR (execute-JSR inst th s)) + (JSR_W (execute-JSR_W inst th s)) + (L2I (execute-L2I inst th s)) + (LADD (execute-LADD inst th s)) + (LALOAD (execute-LALOAD inst th s)) + (LAND (execute-LAND inst th s)) + (LASTORE (execute-LASTORE inst th s)) + (LCMP (execute-LCMP inst th s)) + (LCONST_0 (execute-LCONST_X inst th s 0)) + (LCONST_1 (execute-LCONST_X inst th s 1)) + (LDC (execute-LDC inst th s)) + (LDC_W (execute-LDC inst th s)) + (LDC2_W (execute-LDC2_W inst th s)) + (LDIV (execute-LDIV inst th s)) + (LLOAD (execute-LLOAD inst th s)) + (LLOAD_0 (execute-LLOAD_X inst th s 0)) + (LLOAD_1 (execute-LLOAD_X inst th s 1)) + (LLOAD_2 (execute-LLOAD_X inst th s 2)) + (LLOAD_3 (execute-LLOAD_X inst th s 3)) + (LMUL (execute-LMUL inst th s)) + (LNEG (execute-LNEG inst th s)) + (LOR (execute-LOR inst th s)) + (LREM (execute-LREM inst th s)) + (LRETURN (execute-LRETURN inst th s)) + (LSHL (execute-LSHL inst th s)) + (LSHR (execute-LSHR inst th s)) + (LSTORE (execute-LSTORE inst th s)) + (LSTORE_0 (execute-LSTORE_X inst th s 0)) + (LSTORE_1 (execute-LSTORE_X inst th s 1)) + (LSTORE_2 (execute-LSTORE_X inst th s 2)) + (LSTORE_3 (execute-LSTORE_X inst th s 3)) + (LSUB (execute-LSUB inst th s)) + (LUSHR (execute-LUSHR inst th s)) + (LXOR (execute-LXOR inst th s)) + (MONITORENTER (execute-MONITORENTER inst th s)) + (MONITOREXIT (execute-MONITOREXIT inst th s)) + (MULTIANEWARRAY (execute-MULTIANEWARRAY inst th s)) + (NEW (execute-NEW inst th s)) + (NEWARRAY (execute-NEWARRAY inst th s)) + (NOP (execute-NOP inst th s)) + (POP (execute-POP inst th s)) + (POP2 (execute-POP2 inst th s)) + (PUTFIELD (execute-PUTFIELD inst th s)) + (PUTSTATIC (execute-PUTSTATIC inst th s)) + (RET (execute-RET inst th s)) + (RETURN (execute-RETURN inst th s)) + (SALOAD (execute-SALOAD inst th s)) + (SASTORE (execute-SASTORE inst th s)) + (SIPUSH (execute-SIPUSH inst th s)) + (SWAP (execute-SWAP inst th s)) + (HALT s) + (otherwise s))) + +(defun step (th s) + (if (equal (status th s) 'SCHEDULED) + (do-inst (next-inst th s) th s) + s)) + +(defun run (sched s) + (if (endp sched) + s + (run (cdr sched) (step (car sched) s)))) + +; Begin the simulator +; + +(defun ack2 (num n lst) + (if (zp n) + lst + (ack2 num (- n 1) (cons num lst)))) + +(defun ack0 (n) + (ack2 0 n nil)) + +(acl2::set-state-ok t) + +(defun sim-loop (s acl2::state) + (declare (acl2::xargs :mode :program)) + (prog2$ + (acl2::cw "~%>>") ;;; Print prompt + (acl2::mv-let + (flg cmd acl2::state) + (acl2::read-object acl2::*standard-oi* acl2::state) ;;; read next command + (declare (ignore flg)) + (cond + ((equal cmd :q) (acl2::value t)) ;;; quit on :q + ((and (consp cmd) ;;; recognize (step i) and (step i j) + (acl2::eq (car cmd) 'step) ;;; where i and j are integers + (true-listp cmd) + (consp (cdr cmd)) + (integerp (cadr cmd)) + (or (acl2::null (cddr cmd)) + (and (integerp (caddr cmd)) + (acl2::null (cdddr cmd))))) + (let ((thread (cadr cmd)) + (n (if (cddr cmd) (caddr cmd) 1))) + (sim-loop (run (ack2 thread n nil) s) acl2::state))) + (t (acl2::mv-let (flg val acl2::state) + (acl2::simple-translate-and-eval cmd + (list (cons 's s)) + nil + "Your command" 'sim + (acl2::w acl2::state) + acl2::state + nil) + (prog2$ + (cond (flg nil) + (t (acl2::cw "~x0~%" (cdr val)))) + (sim-loop s acl2::state)))))))) + +(defun sim (s acl2::state) + (declare (acl2::xargs :mode :program)) + (prog2$ + (acl2::cw "~%M5 Simulator.~%~%") + (sim-loop s acl2::state))) + +; A small assembler to resolve labels into relative byte addresses +; +; Labels are symbols in the "LABEL" package. Examples include: +; LABEL::JUMP LABEL::FOR LABEL::START1 +; +; To denote the jump-to point, insert a label before the opcode +; +; '((aconst_null) '((aconst_null) +; (goto LABEL::TARGET) (goto 5) +; (iconst_0) =====> (iconst_0) +; (iconst_2) (iconst_2) +; (LABEL::TARGET ADD) (add) +; (ireturn)) (ireturn)) + +(defun isLabel? (sym) + (and (symbolp sym) + (equal (symbol-package-name sym) "LABEL"))) + +(defun isLabeledInst? (inst) + (isLabel? (car inst))) + +(defun gen_label_alist (bytecodes cur_pc label_alist) + (if (endp bytecodes) + label_alist + (let* ((bare_inst (if (isLabeledInst? (car bytecodes)) + (cdr (car bytecodes)) + (car bytecodes)))) + (gen_label_alist (cdr bytecodes) + (+ cur_pc + (inst-length bare_inst)) + (if (isLabeledInst? (car bytecodes)) + (bind (car (car bytecodes)) + cur_pc + label_alist) + label_alist))))) + +(defun resolve_labels (bytecodes cur_pc label_alist) + (if (endp bytecodes) + nil + (let* ((inst (car bytecodes)) + (bare-inst (if (isLabeledInst? inst) + (cdr inst) + inst)) + (resolved-inst (if (isLabel? (arg1 bare-inst)) + (list (op-code bare-inst) + (- (binding (arg1 bare-inst) + label_alist) + cur_pc)) + bare-inst))) + (append (list resolved-inst) + (resolve_labels (cdr bytecodes) + (+ cur_pc + (inst-length bare-inst)) + label_alist))))) + +; resolve_basic_block takes a method and resolves all of the labels +; +; note that the JVM restricts jumps to within the method + +(defun resolve_basic_block (bytecodes) + (resolve_labels bytecodes + 0 + (gen_label_alist bytecodes 0 nil))) + +; The following functions are used to strip a state down to resolve +; all of the basic blocks and build up the newly resolved state + +; resolving thread tables +; +(defun assemble_frame (frame) + (make-frame (pc frame) + (locals frame) + (stack frame) + (resolve_basic_block (program frame)) + (sync-flg frame) + (cur-class frame))) + +(defun assemble_call_stack (cs) + (if (endp cs) + nil + (cons (assemble_frame (car cs)) + (assemble_call_stack (cdr cs))))) + +(defun assemble_thread (thread) + (list (assemble_call_stack (car thread)) + (cadr thread) + (caddr thread))) + +(defun assemble_thread_table (tt) + (if (endp tt) + nil + (cons (cons (caar tt) + (assemble_thread (cdar tt))) + (assemble_thread_table (cdr tt))))) + +; resolving class tables +; +(defun assemble_method (method) + (append (list (method-name method) + (method-formals method) + (method-sync method)) + (resolve_basic_block (method-program method)))) + +(defun assemble_methods (methods) + (if (endp methods) + nil + (cons (assemble_method (car methods)) + (assemble_methods (cdr methods))))) + +(defun assemble_class (class) + (make-class-decl (class-decl-name class) + (class-decl-superclasses class) + (class-decl-fields class) + (class-decl-sfields class) + (class-decl-cp class) + (assemble_methods (class-decl-methods class)) + (class-decl-heapref class))) + +(defun assemble_class_table (ct) + (if (endp ct) + nil + (cons (assemble_class (car ct)) + (assemble_class_table (cdr ct))))) + +(defun assemble_state (s) + (make-state (assemble_thread_table (thread-table s)) + (heap s) + (assemble_class_table (class-table s)))) + +; ----------------------------------------------------------------------------- +; load_class_library: a utility for populating the heap with Class and +; String objects + +(defun make-string-obj (class cpentry s idx) + (let* ((new-object (build-an-instance + (cons "java.lang.String" + (class-decl-superclasses + (bound? "java.lang.String" (class-table s)))) + (class-table s))) + (stuffed-obj (set-instance-field "java.lang.String" + "strcontents" + (caddr cpentry) + new-object)) + (new-address (len (heap s)))) + (modify th s + :heap (bind new-address stuffed-obj (heap s)) + :class-table (update-ct-string-ref + class + idx + (list 'REF new-address) + (class-table s))))) + + +(defun resolve-string-constants (class cp s idx) + (cond ((endp cp) s) + ((equal (caar cp) 'STRING) + (resolve-string-constants class + (cdr cp) + (make-string-obj class (car cp) s idx) + (+ idx 1))) + (t (resolve-string-constants class (cdr cp) s (+ idx 1))))) + + +(defun gen_class_obj (class s) + (let* ((new-state (resolve-string-constants class + (retrieve-cp class (class-table s)) + s + 0)) + (new-heap (heap new-state)) + (new-ct (class-table new-state)) + (new-object (build-a-class-instance + (class-decl-sfields (bound? class new-ct)) + new-ct)) + (stuffed-obj (set-instance-field "java.lang.Class" + "<name>" + class + new-object)) + (new-address (len new-heap)) + (old-class-ent (bound? class new-ct)) + (new-class-ent + (make-class-decl (class-decl-name old-class-ent) + (class-decl-superclasses old-class-ent) + (class-decl-fields old-class-ent) + (class-decl-sfields old-class-ent) + (class-decl-cp old-class-ent) + (class-decl-methods old-class-ent) + (list 'REF new-address))) + (new-class-table (bind class + (cdr new-class-ent) + new-ct))) + (make-state (thread-table s) + (bind new-address stuffed-obj new-heap) + new-class-table))) + +(defun ld_class_lib (classes s) + (if (endp classes) + s + (ld_class_lib (cdr classes) (gen_class_obj (car classes) s)))) + +(defun load_class_library (s) + (ld_class_lib (strip-cars (class-table s)) s)) + +; ----------------------------------------------------------------------------- +; m5_load: both load and resolve a given state + +(defun m5_load (s) + (load_class_library (assemble_state s))) + diff --git a/books/workshops/2003/moore_vcg/support/utilities.acl2 b/books/workshops/2003/moore_vcg/support/utilities.acl2 new file mode 100644 index 0000000..af0e795 --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/utilities.acl2 @@ -0,0 +1,7 @@ +(value :q) + +(lp) + +(include-book "m5") + +(certify-book "utilities" ? t) diff --git a/books/workshops/2003/moore_vcg/support/utilities.lisp b/books/workshops/2003/moore_vcg/support/utilities.lisp new file mode 100644 index 0000000..ea8c44b --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/utilities.lisp @@ -0,0 +1,209 @@ +; Copyright (C) 2001, Regents of the University of Texas +; Written by J Strother Moore +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. + +#| +; Certification Instructions. + +(include-book + "m5") + +(certify-book "utilities" 1) + +J Moore +|# + +(in-package "M5") + +; Here we develop the general theory for proving things about the +; M5 bytecode. + +; Arithmetic + +(include-book "../../../../arithmetic/top-with-meta") + +; We prove a few things about int arithmetic. We ought to prove +; many more, but I just put enough here to get the factorial +; proof to go through. + +(include-book "../../../../ihs/quotient-remainder-lemmas") + +(defun intp (x) + (and (integerp x) + (<= (- (expt 2 31)) x) + (< x (expt 2 31)))) + +(defthm int-lemma0 + (implies (intp x) + (integerp x)) + :rule-classes (:rewrite :forward-chaining)) + +(defthm int-lemma1 + (intp (int-fix x))) + +(local (in-theory (cons 'zp (disable mod)))) + +(defthm int-lemma2 + (implies (and (intp x) + (not (zp x))) + (equal (int-fix (+ -1 x)) + (+ -1 x)))) + +(defthm int-lemma3 + (implies (and (intp x) + (not (zp x))) + (intp (+ -1 x)))) + +(defthm int-lemma4a + (implies (and (integerp x) + (integerp y)) + (equal (int-fix (* x (int-fix y))) + (int-fix (* x y))))) + +(defthm int-lemma5a + (implies (and (integerp x) + (integerp y)) + (equal (int-fix (+ x (int-fix y))) + (int-fix (+ x y))))) + +; This is a special case of the above. I need a more general +; handling of this, but this will do for the moment. + +(defthm int-lemma5a1 + (implies (and (integerp x1) + (integerp x2) + (integerp y)) + (equal (int-fix (+ x1 x2 (int-fix y))) + (int-fix (+ x1 x2 y)))) + :hints (("Goal" :use (:instance int-lemma5a (x (+ x1 x2)))))) + +(defthm int-lemma6 + (implies (intp x) + (equal (int-fix x) x))) + +(in-theory (disable intp int-fix)) + +(defthm int-lemma4b + (implies (and (integerp x) + (integerp y)) + (equal (int-fix (* (int-fix y) x)) + (int-fix (* y x))))) + +(defthm int-lemma5b + (implies (and (integerp x) + (integerp y)) + (equal (int-fix (+ (int-fix y) x)) + (int-fix (+ y x))))) + +; Structures + +(defthm states + (and (equal (thread-table (make-state tt h c)) tt) + (equal (heap (make-state tt h c)) h) + (equal (class-table (make-state tt h c)) c))) + +(in-theory (disable make-state thread-table heap class-table)) + +(defthm frames + (and + (equal (pc (make-frame pc l s prog sync-flg cur-class)) + pc) + (equal (locals (make-frame pc l s prog sync-flg cur-class)) + l) + (equal (stack (make-frame pc l s prog sync-flg cur-class)) + s) + (equal (program (make-frame pc l s prog sync-flg cur-class)) + prog) + (equal (sync-flg (make-frame pc l s prog sync-flg cur-class)) + sync-flg) + (equal (cur-class (make-frame pc l s prog sync-flg cur-class)) + cur-class))) + +(in-theory + (disable make-frame pc locals stack program sync-flg cur-class)) + +(defthm stacks + (and (equal (top (push x s)) x) + (equal (pop (push x s)) s))) + +(in-theory (disable push top pop)) + +; Mappings + +(defthm assoc-equal-bind + (equal (assoc-equal key1 (bind key2 val alist)) + (if (equal key1 key2) + (cons key1 val) + (assoc-equal key1 alist)))) + +(defthm bind-bind + (equal (bind x v (bind x w a)) + (bind x v a))) + +; Semi-Ground Terms + +(defthm bind-formals-opener + (implies (and (integerp n) + (<= 0 n)) + (equal (bind-formals (+ 1 n) stack) + (cons (top stack) + (bind-formals n (pop stack)))))) + +(defthm nth-opener + (and (equal (nth 0 lst) (car lst)) + (implies (and (integerp n) + (<= 0 n)) + (equal (nth (+ 1 n) lst) + (nth n (cdr lst)))))) + +(in-theory (disable nth)) + +(defthm popn-opener + (implies (and (integerp n) + (<= 0 n)) + (equal (popn (+ 1 n) stack) + (popn n (pop stack))))) + +(defun repeat (th n) + (if (zp n) + nil + (cons th (repeat th (- n 1))))) + +(defthm repeat-opener + (implies (and (integerp n) + (<= 0 n)) + (equal (repeat th (+ 1 n)) + (cons th (repeat th n))))) + +; The nil conjunct below is needed because we will disable run. + +(defthm run-opener + (and (equal (run nil s) s) + (equal (run (cons th sched) s) + (run sched (step th s)))) + :hints (("Goal" :in-theory (disable step)))) + +;(in-theory (enable top pop push lookup-method)) + +; Step Stuff + +(defthm step-opener + (implies (consp (next-inst th s)) + (equal (step th s) + (if (equal (status th s) 'SCHEDULED) + (do-inst (next-inst th s) th s) + s))) + :hints (("Goal" :in-theory (disable do-inst)))) + +(in-theory (disable step)) + +; Clocks + + + +(defthm run-append + (equal (run (append sched1 sched2) s) + (run sched2 (run sched1 s)))) + +(in-theory (disable run)) + diff --git a/books/workshops/2003/moore_vcg/support/vcg-examples.acl2 b/books/workshops/2003/moore_vcg/support/vcg-examples.acl2 new file mode 100644 index 0000000..ce63104 --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/vcg-examples.acl2 @@ -0,0 +1,6 @@ +(value :q) + +(lp) + +(include-book "utilities") +(certify-book "vcg-examples" ? t) diff --git a/books/workshops/2003/moore_vcg/support/vcg-examples.lisp b/books/workshops/2003/moore_vcg/support/vcg-examples.lisp new file mode 100644 index 0000000..d3e17a4 --- /dev/null +++ b/books/workshops/2003/moore_vcg/support/vcg-examples.lisp @@ -0,0 +1,904 @@ +; Copyright (C) 2003, Regents of the University of Texas +; Written by J Strother Moore +; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2. + +; Use of Tail-Recursion to Propagate Inductive Assertions +; J Strother Moore +; February 26, 2003 + +; cd /u/moore/m5/tolquhon +; (include-book "utilities") +; (ld "vcg-examples.lisp" :ld-pre-eval-print t) + +; Certification: +; (include-book "utilities") +; (certify-book "vcg-examples" 1) + +; --------------------------------------------------------------------------- +; Preliminaries + +; This first part is just ``prelude''. It has nothing to do with the +; specific programs we will verify. + +(in-package "M5") + +(include-book "../../../../misc/defpun") + +(defmacro defpun (g args &rest tail) + `(acl2::defpun ,g ,args ,@tail)) + +;(ACL2::SET-MATCH-FREE-ERROR NIL) + +(defthm update-nth-opener + (and (equal (update-nth 0 x a) (cons x (cdr a))) + (implies (not (zp n)) + (equal (update-nth n x a) + (cons (car a) (update-nth (- n 1) x (cdr a))))))) + +; --------------------------------------------------------------------------- +; Some Preliminaries for Our First Program + +(defthm int-evenp-inv-a + (implies (intp i) + (iff (evenp (int-fix (- i 2))) + (evenp i))) + :hints + (("Goal" :in-theory (e/d (intp int-fix) + (floor))))) + +(defthm int-evenp-inv-b + (implies (intp i) + (iff (evenp (- i 2)) + (evenp i))) + :hints + (("Goal" :in-theory (e/d (intp int-fix) + (floor))))) + +(in-theory (disable evenp)) + +(defthm int-lemma2a + (implies (and (intp x) + (<= 0 x)) + (equal (int-fix (+ -2 x)) + (+ -2 x))) + :hints (("Goal" :in-theory (e/d (intp) nil)))) + +(defthm int-lemma2b + (implies (and (intp x) + (<= 0 x)) + (intp (+ -2 x))) + :hints (("Goal" :in-theory (e/d (intp) nil)))) + +; --------------------------------------------------------------------------- +; Our First Program + +; Below is an m5 program that decrements its first local, n, by 2 and +; iterates until the result is 0. On each iteration it adds 1 to a +; local variable, a, which is initialized to 0. The program ends with +; a HALT instruction, which puts the machine in an infinite loop, i.e., +; executing HALT doesn't change the pc and the machine "stops." Later +; we deal with the more realistic situation of a RETURN to some caller. +; We will prove that if the program below reaches the HALT instruction, +; the initial value, n0, of n was even and the result on the stack is +; n0/2. This program does not terminate when n0 is odd. + +; To make the program slightly simpler to deal with, I only consider +; the case where n0 is a non-negative int. (Java programmers will note +; that the program actually halts for even negative ints, because of +; wrap-around.) + +(defconst *flat-prog* + '((iconst_0) ; 0 + (istore_1) ; 1 a := 0; + (iload_0) ; 2 top of loop: + (ifeq 14) ; 3 if n=0, goto 17; + (iload_1) ; 6 + (iconst_1) ; 7 + (iadd) ; 8 + (istore_1) ; 9 a := a+1; + (iload_0) ;10 + (iconst_2) ;11 + (isub) ;12 + (istore_0) ;13 n := n-2; + (goto -12) ;14 goto top of loop + (iload_1) ;17 + (halt))) ;18 + +; Here is the ``semantics'' of the loop, in the case in interest. + +(defun halfa (n a) + (declare (xargs :measure (nfix n))) + (if (zp n) + a + (halfa (- n 2) (int-fix (+ a 1))))) + +; --------------------------------------------------------------------------- +; The Assertions at the Three Cut Points + +; We will use a classic ``inductive assertion'' method. The following +; function takes a state, s, and the ``initial'' value of n, n0, and +; states the assertions we wish to attach to pcs 0, 2, and 18. These +; are the so-called ``cut points'' of my choice: the entry to the +; program, the top of the loop, and exit from the program. + +; The particular assertions are not my main interest in this paper. +; You can read them if you want. The real nugget in this paper is not +; the assertions but the fact that I use tail recursion by step to +; propagate assertions from the cut points to all the pcs. + +; That said, let me note that the assertions are complicated because +; they have to handle the fact that halfa tracks the program only as +; long as n stays non-negative. Things would be simpler if I assumed +; that n0 was even. But I like illustrating the capability of +; establishing conditions that hold for n0 in the event of +; termination. + +(defun flat-pre-condition (n0 n) + (and (equal n n0) + (intp n0) + (<= 0 n0))) + +(defun flat-loop-invariant (n0 n a) + (and (intp n0) + (<= 0 n0) + (intp n) + (if (and (<= 0 n) + (evenp n)) + (equal (halfa n a) + (halfa n0 0)) + (not (evenp n))) + (iff (evenp n0) (evenp n)))) + +(defun flat-post-condition (n0 value) + (and (evenp n0) + (equal value (halfa n0 0)))) + +(defun flat-assertion (n0 th s) + (let ((n (nth 0 (locals (top-frame th s)))) + (a (nth 1 (locals (top-frame th s))))) + (and (equal (program (top-frame th s)) *flat-prog*) + (case (pc (top-frame th s)) + (0 (flat-pre-condition n0 n)) + (2 (flat-loop-invariant n0 n a)) + (18 (let ((value (top (stack (top-frame th s))))) + (flat-post-condition n0 value))) + (otherwise nil))))) + +; Observe that the output condition is that n0 is even and that the +; top of the stack contains the semantic expression (halfa n0 0). +; We will later convert this to n0/2. + +; --------------------------------------------------------------------------- +; The Invariant -- The Only New Idea in this Note + +; Here is the new idea. I define the invariant for the program by +; using defpun. The assertions are attached at the three cut points +; and all other statements inherit the invariant of the next +; statement. + +(defpun flat-inv (n0 th s) + (if (or (equal (pc (top-frame th s)) 0) + (equal (pc (top-frame th s)) 2) + (equal (pc (top-frame th s)) 18)) + (flat-assertion n0 th s) + (flat-inv n0 th (step th s)))) + +; In one sense, the next lemma is just a technical lemma to force +; flat-inv to keep opening if it hasn't reached a cut point yet. But +; in another sense, this lemma highlights the nice feature of this +; approach. Suppose that in our function flat-assertion we had failed +; to supply a cut point for some loop. Then we'll get a stack +; overflow from the repeated indefinite application of this rewrite +; rule. But we do not have to prove we've cut every loop, because the +; flat-inv function is tail recursive and so was admitted by defpun. + +; In the past when I've used the classic inductive invariant approach +; and used recursion in flat-inv to avoid an assertion at every pc, I +; had to invent some kind of measure (``distance to the next cut +; point'') to prove that I had cut every loop. That annoyed me +; because in the classic inductive invariant approach that burden is +; merely pragmatic -- you had to cut every loop or you couldn't +; generate verification conditions. But you didn't have to prove you +; had cut every loop. In my past attempts to mimic this, I had to +; prove more stuff! + +(defthm flat-inv-opener + (implies (and (equal pc (pc (top-frame th s))) + (syntaxp (quotep pc)) + (not (equal pc 0)) + (not (equal pc 2)) + (not (equal pc 18))) + (equal (flat-inv n0 th s) + (flat-inv n0 th (step th s))))) + +; --------------------------------------------------------------------------- +; The Verification Conditions + +(defthm VC1 + (implies (flat-pre-condition n0 n) (flat-loop-invariant n0 n 0))) + + +(defthm VC2 + (implies (and (flat-loop-invariant n0 n a) + (not (equal n 0))) + (flat-loop-invariant n0 (int-fix (- n 2)) (int-fix (+ 1 a))))) + +(defthm VC3 + (implies (and (flat-loop-invariant N0 n a) + (EQUAL n 0)) + (flat-post-condition N0 a))) + +(in-theory (disable flat-pre-condition + flat-loop-invariant + flat-post-condition)) + +; --------------------------------------------------------------------------- +; Using the VCs in the Operational Semantics + +; So here is the key theorem of the inductive invariant approach, showing +; that inv is an invariant. + +(defthm flat-inv-step + (implies (flat-inv n0 th s) + (flat-inv n0 th (step th s)))) + +; We can immediately conclude that flat-inv is an invariant under run, +; as long as the only thread we step is th. + +(defun mono-threadedp (th sched) + (if (endp sched) + t + (and (equal th (car sched)) + (mono-threadedp th (cdr sched))))) + +(defthm flat-inv-run + (implies (and (mono-threadedp th sched) + (flat-inv n0 th s)) + (flat-inv n0 th (run sched s))) + :rule-classes nil + :hints (("Goal" :in-theory (e/d (run)(flat-inv-def))))) + +; And so we're done. If we plug in an initial state satisfying the +; invariant we get a final state satisfying it. If the final state is +; supposed to have pc 18, then we can read out what the invariant +; tells us about that cut point. + +(defthm flat-main + (let ((s1 (run sched s0))) + (implies (and (intp n0) + (<= 0 n0) + (equal (pc (top-frame th s0)) 0) + (equal (locals (top-frame th s0)) (list n0 any)) + (equal (program (top-frame th s0)) *flat-prog*) + (mono-threadedp th sched) + (equal (pc (top-frame th s1)) 18)) + (and (evenp n0) + (equal (top (stack (top-frame th s1))) + (halfa n0 0))))) + + :hints (("Goal" :use + (:instance flat-inv-run + (n0 n0) + (s s0) + (th th) + (sched sched)) + :in-theory (enable flat-pre-condition flat-post-condition))) + :rule-classes nil) + +; --------------------------------------------------------------------------- +; Getting Rid of the Semantic Function + +; Now, following our standard paradigm, we get rid of halfa and +; introduce n/2 instead. There is nothing new here, but I have to +; fight intp and int-fix. + +(defthm int-back + (implies (and (intp (+ a x)) + (integerp a) + (<= 0 a) + (integerp x) + (<= 0 x) + (integerp y) + (<= 0 y) + (<= y x)) + (intp (+ y a))) + :hints (("Goal" :in-theory (enable intp)))) + +(defthm halfa-is-half + (implies (and (intp n) + (<= 0 n) + (evenp n) + (integerp a) + (<= 0 a) + (intp (+ (/ n 2) a))) + (equal (halfa n a) + (+ (/ n 2) a))) + :hints (("Goal" :in-theory (enable evenp)))) + +(defthm intp-half-n + (implies (and (intp n) + (<= 0 n) + (evenp n)) + (intp (* 1/2 n))) + :hints (("Goal" :in-theory (enable evenp intp)))) + +; --------------------------------------------------------------------------- +; The (Partial) Correctness Theorem for Half + +; The following theorem summarizes what we now know. Start with a a +; state running *flat-prog* from pc 0 with initial n=n0 and run it +; under an arbitrary mono-threaded schedule to get to s1. Suppose n0 +; is a non-negative int and the pc of s1 is 18. + +; Then we conclude that n0 is even and that the top of the stack is +; n0/2. + +(defthm flat-is-partially-correct + (let ((s1 (run sched s0))) + (implies (and (intp n0) + (<= 0 n0) + (equal (pc (top-frame th s0)) 0) + (equal (locals (top-frame th s0)) (list n0 any)) + (equal (program (top-frame th s0)) *flat-prog*) + (mono-threadedp th sched) + (equal (pc (top-frame th s1)) 18)) + (and (evenp n0) + (equal (top (stack (top-frame th s1))) + (/ n0 2))))) + :rule-classes nil + :hints (("Goal" + :use ((:instance flat-main))))) + +; Note that at no point in this exercise have we counted instructions +; or defined a clock or schedule generator. + +; --------------------------------------------------------------------------- +; Dealing with Return + +(defconst *half-prog* + '((iconst_0) ; 0 + (istore_1) ; 1 a := 0; + (iload_0) ; 2 top of loop: + (ifeq 14) ; 3 if n=0, goto 17; + (iload_1) ; 6 + (iconst_1) ; 7 + (iadd) ; 8 + (istore_1) ; 9 a := a+1; + (iload_0) ;10 + (iconst_2) ;11 + (isub) ;12 + (istore_0) ;13 n := n-2; + (goto -12) ;14 goto top of loop + (iload_1) ;17 + (ireturn))) ;18 return a; + +(defun sdepth (stk) + (declare (xargs :hints (("Goal" :in-theory (enable pop))))) + (if (endp stk) + 0 + (+ 1 (sdepth (pop stk))))) + +(defun half-assertion (n0 d0 th s) + (cond + ((< (sdepth (call-stack th s)) d0) + (let ((value (top (stack (top-frame th s))))) + (flat-post-condition n0 value))) + (t + (let ((n (nth 0 (locals (top-frame th s)))) + (a (nth 1 (locals (top-frame th s))))) + (and (equal (sdepth (call-stack th s)) d0) + (equal (program (top-frame th s)) *half-prog*) + (equal (sync-flg (top-frame th s)) 'UNLOCKED) + (case (pc (top-frame th s)) + (0 (flat-pre-condition n0 n)) + (2 (flat-loop-invariant n0 n a)) + (18 (let ((value (top (stack (top-frame th s))))) + (flat-post-condition n0 value))) + (otherwise nil))))))) + +(defpun half-inv (n0 d0 th s) + (if (or (< (sdepth (call-stack th s)) d0) + (equal (pc (top-frame th s)) 0) + (equal (pc (top-frame th s)) 2) + (equal (pc (top-frame th s)) 18)) + (half-assertion n0 d0 th s) + (half-inv n0 d0 th (step th s)))) + +(defthm half-inv-opener + (implies (and (equal pc (pc (top-frame th s))) + (syntaxp (quotep pc)) + (not (equal pc 0)) + (not (equal pc 2)) + (not (equal pc 18))) + (equal (half-inv n0 d0 th s) + (if (< (sdepth (call-stack th s)) d0) + (half-assertion n0 d0 th s) + (half-inv n0 d0 th (step th s)))))) + +(defthm half-inv-step + (implies (and (integerp d0) + (< 1 d0) + (<= d0 (sdepth (call-stack th s))) + (half-inv n0 d0 th s)) + (half-inv n0 d0 th (step th s))) + :hints (("Goal" :in-theory (disable halfa-is-half)))) + +(defun run-to-return (sched th d0 s) + (cond ((endp sched) s) + ((<= d0 (sdepth (call-stack th s))) + (run-to-return (cdr sched) th d0 (step (car sched) s))) + (t s))) + +(defthm half-inv-run-to-return + (implies (and (mono-threadedp th sched) + (integerp d0) + (< 1 d0) + (half-inv n0 d0 th s)) + (half-inv n0 d0 th (run-to-return sched th d0 s))) + :rule-classes nil + :hints (("Goal" :in-theory (disable half-inv-def)))) + +; And so we're done. If we plug in an initial state satisfying the +; invariant we get a final state satisfying it. If the final state is +; supposed to have pc 18, then we can read out what the invariant +; tells us about that cut point. + +(defthm half-main + (let ((s1 (run-to-return sched th (sdepth (call-stack th s0)) s0))) + (implies (and (intp n0) + (<= 0 n0) + (equal (pc (top-frame th s0)) 0) + (equal (locals (top-frame th s0)) (list n0 any)) + (equal (program (top-frame th s0)) *half-prog*) + (equal (sync-flg (top-frame th s0)) 'unlocked) + (< 1 (sdepth (call-stack th s0))) + (mono-threadedp th sched) + (< (sdepth (call-stack th s1)) + (sdepth (call-stack th s0)))) + (and (evenp n0) + (equal (top (stack (top-frame th s1))) + (halfa n0 0))))) + :hints (("Goal" :use + (:instance half-inv-run-to-return + (n0 n0) + (d0 (sdepth (call-stack th s0))) + (s s0) + (th th) + (sched sched)) + :in-theory (enable flat-pre-condition + flat-post-condition))) + :rule-classes nil) + +(defthm half-partially-correct + (let ((s1 (run-to-return sched th (sdepth (call-stack th s0)) s0))) + (implies (and (intp n0) + (<= 0 n0) + (equal (pc (top-frame th s0)) 0) + (equal (locals (top-frame th s0)) (list n0 any)) + (equal (program (top-frame th s0)) *half-prog*) + (equal (sync-flg (top-frame th s0)) 'unlocked) + (< 1 (sdepth (call-stack th s0))) + (mono-threadedp th sched) + (< (sdepth (call-stack th s1)) + (sdepth (call-stack th s0)))) + (and (evenp n0) + (equal (top (stack (top-frame th s1))) + (/ n0 2))))) + :hints (("Goal" :use half-main)) + :rule-classes nil) + +; --------------------------------------------------------------------------- +; Doing a Sum Program + +; To re-illustrate the same methodology, without worrying about +; demonstrating that we can conclude things about the input if we're +; told we terminate, here is a program that sums the ints from n0 down +; to 0. + +(defconst *sum-prog* + ; We name local[0] n and local[1] a. + '((iconst_0) ; 0 + (istore_1) ; 1 a := 0; + (iload_0) ; 2 top of loop: + (ifeq 14) ; 3 if n=0, goto 17; + (iload_0) ; 6 + (iload_1) ; 7 + (iadd) ; 8 + (istore_1) ; 9 a := n+a; + (iload_0) ;10 + (iconst_m1) ;11 + (iadd) ;12 + (istore_0) ;13 n := n-1; + (goto -12) ;14 goto top of loop + (iload_1) ;17 + (ireturn))) ;18 return a; + +(defun suma (n a) + (if (zp n) + a + (suma (- n 1) (int-fix (+ n a))))) + +(defun sum-pre-condition (n0 n) + (and (equal n n0) + (intp n0) + (<= 0 n0))) + +(defun sum-loop-invariant (n0 n a) + (and (intp n0) + (intp n) + (<= 0 n) + (<= n n0) + (equal (suma n a) + (suma n0 0)))) + +(defun sum-post-condition (n0 value) + (equal value (suma n0 0))) + +(defun sum-assertion (n0 d0 th s) + (cond ((< (sdepth (call-stack th s)) d0) + (let ((value (top (stack (top-frame th s))))) + (sum-post-condition n0 value))) + (t + (let ((n (nth 0 (locals (top-frame th s)))) + (a (nth 1 (locals (top-frame th s))))) + (and (equal (sdepth (call-stack th s)) d0) + (equal (program (top-frame th s)) *sum-prog*) + (equal (sync-flg (top-frame th s)) 'UNLOCKED) + (case (pc (top-frame th s)) + (0 (sum-pre-condition n0 n)) + (2 (sum-loop-invariant n0 n a)) + (18 (let ((value (top (stack (top-frame th s))))) + (sum-post-condition n0 value))) + (otherwise nil))))))) + +(defpun sum-inv (n0 d0 th s) + (if (or (< (sdepth (call-stack th s)) d0) + (equal (pc (top-frame th s)) 0) + (equal (pc (top-frame th s)) 2) + (equal (pc (top-frame th s)) 18)) + (sum-assertion n0 d0 th s) + (sum-inv n0 d0 th (step th s)))) + +(defthm sum-inv-opener + (implies (and (equal pc (pc (top-frame th s))) + (syntaxp (quotep pc)) + (not (equal pc 0)) + (not (equal pc 2)) + (not (equal pc 18))) + (equal (sum-inv n0 d0 th s) + (if (< (sdepth (call-stack th s)) d0) + (sum-assertion n0 d0 th s) + (sum-inv n0 d0 th (step th s)))))) + +(defthm sum-VC1 + (implies (sum-pre-condition n0 n) (sum-loop-invariant n0 n 0))) + +(defthm sum-VC2 + (implies (and (sum-loop-invariant n0 n a) + (not (equal n 0))) + (sum-loop-invariant n0 (int-fix (- n 1)) (int-fix (+ n a))))) + +(defthm sum-VC3 + (implies (and (sum-loop-invariant N0 n a) + (EQUAL n 0)) + (sum-post-condition N0 a))) + +(in-theory (disable sum-pre-condition + sum-loop-invariant + sum-post-condition)) + +(defthm sum-inv-step + (implies (and (integerp d0) + (< 1 d0) + (<= d0 (sdepth (call-stack th s))) + (sum-inv n0 d0 th s)) + (sum-inv n0 d0 th (step th s)))) + +(defthm sum-inv-run-to-return + (implies (and (mono-threadedp th sched) + (integerp d0) + (< 1 d0) + (sum-inv n0 d0 th s)) + (sum-inv n0 d0 th (run-to-return sched th d0 s))) + :rule-classes nil + :hints (("Goal" :in-theory (disable sum-inv-def)))) + +(defthm sum-main + (let ((s1 (run-to-return sched th (sdepth (call-stack th s0)) s0))) + (implies (and (intp n0) + (<= 0 n0) + (equal (pc (top-frame th s0)) 0) + (equal (locals (top-frame th s0)) (list n0 any)) + (equal (program (top-frame th s0)) *sum-prog*) + (equal (sync-flg (top-frame th s0)) 'unlocked) + (< 1 (sdepth (call-stack th s0))) + (mono-threadedp th sched) + (< (sdepth (call-stack th s1)) + (sdepth (call-stack th s0)))) + (equal (top (stack (top-frame th s1))) + (suma n0 0)))) + :hints (("Goal" :use + (:instance sum-inv-run-to-return + (n0 n0) + (d0 (sdepth (call-stack th s0))) + (s s0) + (th th) + (sched sched)) + :in-theory (enable sum-pre-condition + sum-post-condition))) + :rule-classes nil) + +; We don't bother to eliminate suma, though we could if we hacked around +; with intp long enough! + +; --------------------------------------------------------------------------- +; A Recursive Method + +; Now let's do recursive factorial. We'll bring in the clocked work +; we have already done, just to have the *demo-state* etc. + +(include-book "demo") + +(defun ! (n) + (if (zp n) + 1 + (* n (! (- n 1))))) + +; Here is the (redundant) definition of the program. + +(defconst *fact-def* + '("fact" (INT) NIL + (ILOAD_0) ;;; 0 + (IFLE 12) ;;; 1 + (ILOAD_0) ;;; 4 + (ILOAD_0) ;;; 5 + (ICONST_1) ;;; 6 + (ISUB) ;;; 7 + (INVOKESTATIC "Demo" "fact" 1) ;;; 8 + (IMUL) ;;; 11 + (IRETURN) ;;; 12 + (ICONST_1) ;;; 13 + (IRETURN))) ;;; 14 + +; The following function recognizes the call stack (cs) of a call of +; the "fact" method on n0. The function is not applied to the +; top-most frame, because the constraints on the frame are so +; pc-sensitive and the top-most frame may have "any" pc. So the +; function actually recognizes the rest of the "fact" call stack. +; Here is a picture of the entire call stack. + +; ------------------- top-most frame +; pc: any +; locals: (n) 5 <- suppose n=5 +; stack: any +; program: fact prog +; ------------------- caller-frame +; pc: 11 +; locals: (n+1) 6 this is caller-frame 3 +; stack: (n+1) +; program: fact prog +; ------------------- caller-frame +; pc: 11 +; locals: (n+2) 7 this is caller-frame 2 +; stack: (n+2) +; program: fact prog +; ------------------- caller-frame +; ... +; ------------------- caller-frame +; pc: 11 +; locals: (n0) 8 <- suppose n0 = 8 ; this is caller frame 1 +; stack: (n0) +; program: fact prog +; ------------------- the frame below called fact on n0 +; ... this is caller frame 0 + +; Note that there are n0-n fact caller frames. We number them from +; n0-n down to 1. Caller frame 0 is actually the ``external'' entry +; into fact on n0. We don't know (or care) whether fact or some other +; program is running there. Let k be the number of the caller frame. +; Then note that the value of n in that frame is n0-k+1. + +(defun fact-caller-framesp (cs n0 k) + (declare (xargs :measure (acl2-count k))) + (cond ((zp k) t) + ((and (equal (pc (top cs)) 11) + (equal (program (top cs)) (cdddr *fact-def*)) + (equal (sync-flg (top cs)) 'UNLOCKED) + (intp (nth 0 (locals (top cs)))) + (equal (+ n0 (- k)) (- (nth 0 (locals (top cs))) 1)) + (equal (nth 0 (locals (top cs))) + (top (stack (top cs))))) + (fact-caller-framesp (pop cs) n0 (- k 1))) + (t nil))) + +(defun fact-assertion (n0 d0 th s) + (cond + ((< (sdepth (call-stack th s)) d0) + (equal (top (stack (top-frame th s))) + (int-fix (! n0)))) + (t + (let ((n (nth 0 (locals (top-frame th s))))) + (and (equal (program (top-frame th s)) (cdddr *fact-def*)) + (equal (lookup-method "fact" "Demo" (class-table s)) + *fact-def*) + (equal (sync-flg (top-frame th s)) 'UNLOCKED) + (intp n0) + (intp n) + (<= 0 n) + (<= n n0) + (equal (sdepth (call-stack th s)) (+ d0 (- n0 n))) + (fact-caller-framesp (pop (call-stack th s)) n0 (- n0 n)) + (case (pc (top-frame th s)) + (0 t) + ((12 14) (equal (top (stack (top-frame th s))) + (int-fix (! n)))) + (otherwise nil))))))) + +(defpun fact-inv (n0 d0 th s) + (if (or (< (sdepth (call-stack th s)) d0) + (equal (pc (top-frame th s)) 0) + (equal (pc (top-frame th s)) 12) + (equal (pc (top-frame th s)) 14)) + (fact-assertion n0 d0 th s) + (fact-inv n0 d0 th (step th s)))) + +(defthm fact-inv-opener + (implies (and (equal pc (pc (top-frame th s))) + (syntaxp (quotep pc)) + (not (equal pc 0)) + (not (equal pc 12)) + (not (equal pc 14))) + (equal (fact-inv n0 d0 th s) + (if (< (sdepth (call-stack th s)) d0) + (fact-assertion n0 d0 th s) + (fact-inv n0 d0 th (step th s)))))) + +; These next three lemmas are technical. The first two force +; substitutions. The last opens the stack predicate when we're +; returning and need to know what we're being told about the caller. + +(DEFTHM KB-HACK1 + (IMPLIES + (AND + (FACT-CALLER-FRAMESP + (POP (POP (CADR (ASSOC-EQUAL TH (THREAD-TABLE S))))) + N0 + (+ -1 N0 (- NNN))) + (EQUAL + NNN + (+ -1 + (CAR (LOCALS (TOP (POP (CADR (ASSOC-EQUAL TH (THREAD-TABLE S)))))))))) + (FACT-CALLER-FRAMESP + (POP (POP (CADR (ASSOC-EQUAL TH (THREAD-TABLE S))))) + N0 + (+ + N0 + (- + (CAR (LOCALS (TOP (POP (CADR (ASSOC-EQUAL TH (THREAD-TABLE S)))))))))))) + +(defthm kb-hack2 + (implies + (and (integerp n) + (EQUAL + tos + (INT-FIX + (! (CAR (LOCALS (TOP (CADR (ASSOC-EQUAL TH (THREAD-TABLE S)))))))))) + + (EQUAL + (INT-FIX (* tos n)) + (INT-FIX + (* (! (CAR (LOCALS (TOP (CADR (ASSOC-EQUAL TH (THREAD-TABLE S))))))) + n))))) + +(defthm fact-caller-framesp-opener-1 + (implies (and (syntaxp + (equal cs + '(POP (CAR (CDR (ASSOC-EQUAL TH (THREAD-TABLE S))))))) + (EQUAL (PC (TOP (CADR (ASSOC-EQUAL TH (THREAD-TABLE S))))) pc0) + (syntaxp (or (equal pc0 ''12) (equal pc0 ''14)))) + (equal (fact-caller-framesp cs n0 k) + (COND ((ZP K) T) + ((AND (EQUAL (PC (TOP CS)) 11) + (EQUAL (PROGRAM (TOP CS)) + (CDDDR *FACT-DEF*)) + (EQUAL (SYNC-FLG (TOP CS)) 'UNLOCKED) + (INTP (NTH 0 (LOCALS (TOP CS)))) + (EQUAL (+ N0 (- K)) + (- (NTH 0 (LOCALS (TOP CS))) 1)) + (EQUAL (NTH 0 (LOCALS (TOP CS))) + (TOP (STACK (TOP CS))))) + (FACT-CALLER-FRAMESP (POP CS) + N0 (- K 1))) + (T NIL))))) + +(defthm fact-inv-step + (implies (and (integerp d0) + (< 1 d0) + (<= d0 (sdepth (call-stack th s))) + (fact-inv n0 d0 th s)) + (fact-inv n0 d0 th (step th s)))) + +(defthm fact-inv-run-to-return + (implies (and (mono-threadedp th sched) + (integerp d0) + (< 1 d0) + (fact-inv n0 d0 th s)) + (fact-inv n0 d0 th (run-to-return sched th d0 s))) + :rule-classes nil + :hints (("Goal" :in-theory (disable fact-inv-def)))) + +; Here is the main theorem. It opens by letting s1 be a run-to-return +; of s0. That particular call runs s0 with an abitrarily long +; schedule, sched. Note that run-to-return does not always return a +; state that has returned to a shorter call-stack depth -- if the +; schedule is exhausted before that happens, the final state may still +; be as deep or deeper than the initial state. In any case, s0 is the +; initial state and s1 is the final state. + +; Now let's read the hypotheses of the implication. There are five +; blocks of hypotheses. The first says that n0 is a positive intp. +; The second says that the top-frame of thread th of s0 is a call of +; our "fact" method on n0. The third says that the depth of the +; call-stack of thread th is greater than 1. That means there is a +; frame under the call of "fact". We will call that frame the +; ``caller's frame.'' Of course, if s1 has a shorter call-stack than +; s0, then the caller's frame will be its top-frame, since +; run-to-return stops as soon as we've returned to that depth. The +; fourth says the schedule consists of nothing but th steps. Note +; that otherwise we say nothing about the schedule -- it may be +; arbitrarily long. The fifth block says that the depth of the call +; stack of s1 is less than that of s0, so we know the initial state +; did run long enough to return and hence, the caller's frame is the +; top-frame of s1. + +; Then the conclusion is that (int-fix (! n0)) is on top of +; the stack of the caller's frame. + +(defthm fact-main + (let ((s1 (run-to-return sched th (sdepth (call-stack th s0)) s0))) + (implies (and (intp n0) + (<= 0 n0) + + (equal (pc (top-frame th s0)) 0) + (equal (locals (top-frame th s0)) (list n0)) + (equal (program (top-frame th s0)) + (cdddr *fact-def*)) + (equal (sync-flg (top-frame th s0)) 'unlocked) + (equal (lookup-method "fact" "Demo" (class-table s0)) + *fact-def*) + + (< 1 (sdepth (call-stack th s0))) + + (mono-threadedp th sched) + + (< (sdepth (call-stack th s1)) + (sdepth (call-stack th s0)))) + (equal (top (stack (top-frame th s1))) + (int-fix (! n0))))) + + :hints (("Goal" + :use + (:instance fact-inv-run-to-return + (n0 n0) + (d0 (sdepth (call-stack th s0))) + (s s0) + (th th) + (sched sched)))) + :rule-classes nil) + +; --------------------------------------------------------------------------- +; The Basic Relation Between Run-to-Return and Run + +(defun sched-to-return (sched th d0 s) + (cond ((endp sched) sched) + ((<= d0 (sdepth (call-stack th s))) + (sched-to-return (cdr sched) th d0 (step (car sched) s))) + (t sched))) + +(defthm run-to-return-v-run + (equal (run sched s) + (run (sched-to-return sched th d0 s) + (run-to-return sched th d0 s))) + :rule-classes nil) + +; I need to develop the compositional rules. diff --git a/books/workshops/2003/ray-matthews-tuttle/handouts.pdf.gz b/books/workshops/2003/ray-matthews-tuttle/handouts.pdf.gz Binary files differnew file mode 100644 index 0000000..c5f9167 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/handouts.pdf.gz diff --git a/books/workshops/2003/ray-matthews-tuttle/handouts.ps.gz b/books/workshops/2003/ray-matthews-tuttle/handouts.ps.gz Binary files differnew file mode 100644 index 0000000..df1e66f --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/handouts.ps.gz diff --git a/books/workshops/2003/ray-matthews-tuttle/ltl-redux.pdf.gz b/books/workshops/2003/ray-matthews-tuttle/ltl-redux.pdf.gz Binary files differnew file mode 100644 index 0000000..6dca40e --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/ltl-redux.pdf.gz diff --git a/books/workshops/2003/ray-matthews-tuttle/ltl-redux.ps.gz b/books/workshops/2003/ray-matthews-tuttle/ltl-redux.ps.gz Binary files differnew file mode 100644 index 0000000..14dc5d0 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/ltl-redux.ps.gz diff --git a/books/workshops/2003/ray-matthews-tuttle/slides.pdf.gz b/books/workshops/2003/ray-matthews-tuttle/slides.pdf.gz Binary files differnew file mode 100644 index 0000000..8840ad9 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/slides.pdf.gz diff --git a/books/workshops/2003/ray-matthews-tuttle/slides.ps.gz b/books/workshops/2003/ray-matthews-tuttle/slides.ps.gz Binary files differnew file mode 100644 index 0000000..e7408b3 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/slides.ps.gz diff --git a/books/workshops/2003/ray-matthews-tuttle/support/apply-total-order.lisp b/books/workshops/2003/ray-matthews-tuttle/support/apply-total-order.lisp new file mode 100644 index 0000000..6d03373 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/apply-total-order.lisp @@ -0,0 +1,111 @@ +(in-package "ACL2") + +#| + + apply-total-order.lisp + ~~~~~~~~~~~~~~~~~~~~~~ + +In this book, we describe some simple functions like insert and drop +on a totally ordered list, and provide rules to manipulate them. The +functions that we introduce are insert, drop, memberp, orderedp, and +uniquep. Then we prove some theorems that we wish to export from this +book. + +|# + +(include-book "total-order") + +(defun memberp (a x) + (and (consp x) + (or (equal a (first x)) + (memberp a (rest x))))) + +(defun drop (a x) + (cond ((endp x) ()) + ((equal a (first x)) + (drop a (rest x))) + (t (cons (first x) + (drop a (rest x)))))) + +(defun insert (a x) + (cond ((endp x) (list a)) + ((equal a (first x)) x) + ((<< a (first x)) (cons a x)) + (t (cons (first x) + (insert a (rest x)))))) + +(defun orderedp (x) + (or (endp (rest x)) + (and (<< (first x) (second x)) + (orderedp (rest x))))) + +(defun uniquep (x) + (or (endp x) + (and (not (memberp (first x) (rest x))) + (uniquep (rest x))))) + +;;;; some simple properties about insert, drop, and member + +(defthm memberp-insert-same + (equal (memberp a (insert a x)) T)) + +(defthm memberp-insert-diff + (implies (not (equal a b)) + (equal (memberp a (insert b x)) + (memberp a x)))) + +(defthm memberp-drop-same + (equal (memberp a (drop a x)) nil)) + +(defthm memberp-drop-diff + (implies (not (equal a b)) + (equal (memberp a (drop b x)) + (memberp a x)))) + +(defthm ordered-implies-unique + (implies (orderedp x) + (uniquep x)) + :rule-classes (:forward-chaining + :rewrite)) + +(defthm memberp-yes-reduce-insert + (implies (and (orderedp x) + (memberp a x)) + (equal (insert a x) x))) + +(defthm memberp-no-reduce-drop + (implies (and (true-listp x) + (not (memberp a x))) + (equal (drop a x) x))) + +(local +(defthm drop-is-monotonic + (implies (and (orderedp x) + (<< y (first x)) + (consp (drop a x))) + (<< y (first (drop a x))))) +) + +(defthm drop-preserves-orderedp + (implies (orderedp x) + (orderedp (drop a x)))) + +(defthm insert-preserves-orderedp + (implies (orderedp x) + (orderedp (insert a x)))) + +(defthm drop-of-insert-is-same + (implies (and (true-listp x) + (not (memberp a x))) + (equal (drop a (insert a x)) x))) + +(defthm insert-of-drop-is-same + (implies (and (orderedp x) + (true-listp x) + (memberp a x)) + (equal (insert a (drop a x)) x))) + +(defthm insert-returns-true-lists + (implies (true-listp x) + (true-listp (insert a x))) + :rule-classes :type-prescription) diff --git a/books/workshops/2003/ray-matthews-tuttle/support/bis.lisp b/books/workshops/2003/ray-matthews-tuttle/support/bis.lisp new file mode 100644 index 0000000..571dd42 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/bis.lisp @@ -0,0 +1,156 @@ +(in-package "ACL2")
+
+#|
+
+ bisimulation implies matching paths in ACL2
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+OK, the following book is an ACL2 formalization (i.e. hack) for demonstrating
+that bisimilarity implies that any infinite path from one state can be matched
+by an infinite path in the other state. Roughly, we would like to prove the
+following:
+
+(1) (implies (bisimilar x y)
+ (forall p : (path x)
+ (exists p' : (path y)
+ (match p p'))))
+
+But, this is a non-trivial higher-order theorem. First, the notion that x and y
+are bisimilar is in fact a higher-order statement that there exists a relation
+between states which can be proven to be a bisimulation. We "prove" this in
+ACL2 by creating an encapsulation which constrains the set of universally
+quantified functions in the above theorem and then show that we can construct
+another function which is the witness for the (exists p' ..) and claim that we
+have proven the intended theorem (1).
+
+While this is not a closed-form theorem in ACL2, there is a reasonable argument
+that the definitions and theorems in this book do demonstrate that any
+application of the higher-order theorem (1) can be "simulated" by a series of
+first-order definitions and theorems in ACL2 (which is about the best we could
+hope for). Further, the events in this file could be wrapped up into a macro
+which performed the necessary instantiation of (1) and generated the
+corresponding definitions and theorems.
+
+|# ; |
+
+; The following two are now built-in (different variable name, though).
+
+; (defun natp (n)
+; (and (integerp n)
+; (>= n 0))))
+
+; (defthm natp-compound-recognizer
+; (iff (natp n)
+; (and (integerp n)
+; (>= n 0)))
+; :rule-classes :compound-recognizer)
+
+(in-theory (disable natp))
+
+; The following two are now built-in (different variable name, though).
+
+; (local ; ACL2 primitive
+; (defun posp (n)
+; (and (integerp n)
+; (> n 0))))
+
+; (defthm posp-compound-recognizer
+; (iff (posp n)
+; (and (integerp n)
+; (> n 0)))
+; :rule-classes :compound-recognizer)
+
+(in-theory (disable posp))
+
+(encapsulate
+ (((transit * *) => *) ;; a transition relation between states
+ ((label *) => *) ;; a labeling of atomic prop.s to states
+ ((bisim * *) => *) ;; a bisimulation relation between states
+
+ ;; we need a witnessing function for the choice in the bisimulation
+ ;; we could use defun-sk, but choose to just go ahead and constrain
+ ;; it here since the encapsulate is handy..
+ ((bisim-witness * * *) => *)
+
+ ;; an arbitrary path from a given initial state for the path
+ ((path * *) => *))
+
+ (local (defun transit (x y)
+ (declare (ignore x y))
+ t))
+
+ (local (defun label (x)
+ (declare (ignore x))
+ t))
+
+ (local (defun bisim (x y)
+ (declare (ignore x y))
+ t))
+
+ (local (defun bisim-witness (x y z)
+ (declare (ignore x y z))
+ t))
+
+ (defthm bisim-is-symmetric
+ (implies (bisim x y)
+ (bisim y x)))
+
+ (defthm bisim-preserves-labels
+ (implies (bisim x y)
+ (equal (label x) (label y))))
+
+ (defthm bisim-witness-is-always-step
+ (implies (transit x z)
+ (transit y (bisim-witness x y z))))
+
+ (defthm bisim-states-can-match-transit
+ (implies (and (bisim x y)
+ (transit x z))
+ (bisim z (bisim-witness x y z))))
+
+ (local (defun path (x n)
+ (declare (ignore n))
+ x))
+
+ (defthm path-starts-at-x
+ (equal (path x 0) x))
+
+ (defthm path-takes-steps
+ (implies (posp n)
+ (transit (path x (1- n))
+ (path x n))))
+)
+
+;; We construct a "matching" path from some arbitrary y
+
+(defun path+ (y i x)
+ (if (zp i) y
+ (bisim-witness (path x (1- i))
+ (path+ y (1- i) x)
+ (path x i))))
+
+(defun matches (x y i)
+ (equal (label (path x i))
+ (label (path+ y i x))))
+
+(defthm path+-starts-at-y
+ (equal (path+ y 0 x) y))
+
+(defthm path+-takes-steps
+ (implies (posp i)
+ (transit (path+ y (1- i) x)
+ (path+ y i x))))
+
+(defthm bisim-implies-bisim-along-path
+ (implies (and (natp i)
+ (bisim x y))
+ (bisim (path x i)
+ (path+ y i x)))
+ :rule-classes ((:forward-chaining
+ :trigger-terms ((path+ y i x)))))
+
+(defthm bisim-implies-matches
+ (implies (and (natp i)
+ (bisim x y))
+ (matches x y i)))
+
diff --git a/books/workshops/2003/ray-matthews-tuttle/support/bisimilarity.lisp b/books/workshops/2003/ray-matthews-tuttle/support/bisimilarity.lisp new file mode 100644 index 0000000..f01e2cb --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/bisimilarity.lisp @@ -0,0 +1,2780 @@ +(in-package "ACL2") + +;; The following two lines are added for portability to v2-7. + + +#| + + bisimilarity.lisp + ~~~~~~~~~~~~~~~~~ + +We take a step back now, and define the concepts of bisimilarity inside +ACL2. The text-book definition of bisimilarity is as follows. A relation B +between states of two Kripke Structures m and n is a bisimilarity relation if +for every initial state of m there is an initial state in n such that B holds, +and for every pair of states in which B holds, there is a next state for which +B holds. Two models are said to be bisimulation equivalent if such a relation +exists between the two models. + +The theory of bisimulation, frankly, is a higher order theory and, ACL2 (my +apologies to Matt and J) cannot deal with it. However, we do what feeble +efforts we can possibly master, and try to do as much work as possible with the +encapsulations in ACL2. However, I strongly believe that treatment like this in +ACL2 is nothing more than a hack. + +As an afterthought, we implement bisimilarity here, with respect to a given +collection of variables. What this means is that two states will be called +bisimilar if they have the same value for the given set of variables in the +label, and for every next state of these states, the next states are bisimilar +wrt the same set of variables. This is useful for reduction algorithms for +model-checking that we are interested in, and will let us do away with +hand-waving statements of the form that two states are bisimilar with labelling +restricted to C. + +|# + +;; Since we do not want to see ACL2 reduce mv-nth 0 to car etc. we do the +;; following tricks. I should ask Matt to have these as macro's or as a syntaxp +;; hypothesis and disable mv-nth. + +(defthm mv-nth-0-reduce + (equal (mv-nth 0 (mv x y z)) x)) + +(defthm mv-nth-1-reduce + (equal (mv-nth 1 (mv x y z)) y)) + +(defthm mv-nth-2-reduce + (equal (mv-nth 2 (mv x y z)) z)) + +(in-theory (disable mv-nth)) ;; We do not need to disable mv since mv is a + ;; macro. + +;; End of macros for mv-nth. + +;; The book ltl is included here since I will use the Kripke Structures there +;; to define my bisimilarity. + +(include-book "ltl") + +;; These two rules are found to be expensive, which is obvious given what these +;; rules are. I disable them here and in cone-of-influence.lisp and the proof +;; is much much faster. + +(in-theory (disable subset-of-empty-is-empty + subset-of-nil-is-nil)) + +;; Now we encapsulate the property of bisimilarity for two states. Briefly, two +;; states are bisimilar if they have labels equal within vars, and for every +;; next state of one, there exists a next state of another that is bisimilar. + +(encapsulate + (((bisimilar * * * * *) => *) + ((bisimilar-transition-witness-m->n * * * * * *) => *) + ((bisimilar-initial-state-witness-m->n * * * *) => *) + ((bisimilar-transition-witness-n->m * * * * * *) => *) + ((bisimilar-initial-state-witness-n->m * * * *) => *) + ((bisimilar-equiv * * *) => *)) + + (local + (defun bisimilar (p m q n vars) + (declare (ignore vars)) + (and (equal p q) + (equal m n))) + ) + + (local + (defun bisimilar-transition-witness-m->n (p r m q n vars) + (declare (ignore p m q n vars)) + r) + ) + + (local + (defun bisimilar-initial-state-witness-m->n (s m n vars) + (declare (ignore m n vars)) + s) + ) + + + (local + (defun bisimilar-transition-witness-n->m (p m q r n vars) + (declare (ignore p m q n vars)) + r) + ) + + (local + (defun bisimilar-initial-state-witness-n->m (m s n vars) + (declare (ignore m n vars)) + s) + ) + + (local + (defun bisimilar-equiv (m n vars) + (declare (ignore vars)) + (equal m n)) + ) + + + ;; If two Kripke Structures m and n are equivalent with respect to a bisimilar + ;; relation B, then for every initial-state of m there is a initial-state of n + ;; that is bisimilar. + + (defthm bisimilar-equiv-implies-init->init-m->n + (implies (and (bisimilar-equiv m n vars) + (memberp s (initial-states m))) + (memberp (bisimilar-initial-state-witness-m->n s m n vars) + (initial-states n)))) + + (defthm bisimilar-equiv-implies-bisimilar-initial-states-m->n + (implies (and (bisimilar-equiv m n vars) + (memberp s (initial-states m))) + (bisimilar s m + (bisimilar-initial-state-witness-m->n s m n vars) + n vars))) + + ;; And the same result holds for n to m + + (defthm bisimilar-equiv-implies-init->init-n->m + (implies (and (bisimilar-equiv m n vars) + (memberp s (initial-states n))) + (memberp (bisimilar-initial-state-witness-n->m m s n vars) + (initial-states m)))) + + (defthm bisimilar-equiv-implies-bisimilar-initial-states-n->m + (implies (and (bisimilar-equiv m n vars) + (memberp s (initial-states n))) + (bisimilar (bisimilar-initial-state-witness-n->m m s n vars) + m s n vars))) + + ;; Bisimilar states have the same label with respect to vars. I just use + ;; set-equality because they might not have "equal" labels. BTW, I might not + ;; need the modelp hypothesis here. But I plug it in, just so that I can keep + ;; the (functional instance of) bisimilarity relation as simple as possible. + + (defthm bisimilar-states-have-labels-equal + (implies (and (bisimilar p m q n vars) + (modelp m) + (modelp n)) + (set-equal (set-intersect (label-of p m) vars) + (set-intersect (label-of q n) vars)))) + + + + ;; Of course bisimilarity witness is a member of states of the corresponding model. + + (defthm bisimilar-witness-member-of-states-m->n + (implies (and (bisimilar p m q n vars) + (next-statep p r m) + (memberp r (states m))) + (memberp (bisimilar-transition-witness-m->n p r m q n vars) + (states n)))) + + ;; Again this part may not be required. + + (defthm bisimilar-witness-member-of-states-n->m + (implies (and (bisimilar p m q n vars) + (next-statep q r n) + (memberp r (states n))) + (memberp (bisimilar-transition-witness-n->m p m q r n vars) + (states m)))) + + ;; And if two states are bisimilar, then for every next state of one, there is + ;; a next state of another which is bisimilar. + + (defthm bisimilar-witness-matches-transition-m->n + (implies (and (bisimilar p m q n vars) + (next-statep p r m)) + (next-statep q (bisimilar-transition-witness-m->n p r m q n vars) + n))) + + (defthm bisimilar-witness-produces-bisimilar-states-m->n + (implies (and (bisimilar p m q n vars) + (next-statep p r m)) + (bisimilar r m + (bisimilar-transition-witness-m->n p r m q n vars) + n vars))) + + ;; Again this part may not be required. + + (defthm bisimilar-witness-matches-transition-n->m + (implies (and (bisimilar p m q n vars) + (next-statep q r n)) + (next-statep p (bisimilar-transition-witness-n->m p m q r n vars) + m))) + + + + (defthm bisimilar-witness-produces-bisimilar-states-n->m + (implies (and (bisimilar p m q n vars) + (next-statep q r n)) + (bisimilar (bisimilar-transition-witness-n->m p m q r n vars) + m r n vars))) + +) + +;; The next phase of the book is to show that if two Kripke Structures are +;; bisim-equiv, then for each periodic path of one, there exists a periodic +;; path of another that has the same labels within vars. This finally will show +;; that for any LTL formula restricted to the variable set in vars, the +;; evaluation of the formula wrt bisimilar structures is identical. + + +;; In find-matching-path-for-path, we create a finite path in n that is +;; bisimilar to a (finite) path in m. + +(defun find-matching-path-for-path-m->n (path m q n vars) + (cond ((endp path) nil) + ((endp (rest path)) (list q)) + (t (cons q (find-matching-path-for-path-m->n + (rest path) m + (bisimilar-transition-witness-m->n + (first path) (second path) m q n vars) + n vars))))) + +;; And a similar function from n to m. This is really unfortunate. We could +;; have gotten rid of this duplication if we could rely on symmetry. But I want +;; the encapsulation to provide me with as little constraint as possible. + +(defun find-matching-path-for-path-n->m (p m path n vars) + (cond ((endp path) nil) + ((endp (rest path)) (list p)) + (t (cons p (find-matching-path-for-path-n->m + (bisimilar-transition-witness-n->m + p m (first path) (second path) n vars) + m (rest path) + n vars))))) + + +;; The function to handle periodic paths is rather complicated, and needs to be +;; decomposed. Here is our solution. + +(defun snoc (x e) + (if (endp x) (list e) + (cons (first x) (snoc (rest x) e)))) + +(defun del-last (x) + (if (endp x) nil + (if (endp (rest x)) nil + (cons (first x) (del-last (rest x)))))) + +(defthm del-last-snoc-reduction + (implies (true-listp x) + (equal (del-last (snoc x e)) x))) + + +(defun find-prefix (cycle seen witness path) + (cond ((endp path) nil) + ((endp seen) path) ;; should not arise + ((equal witness (first seen)) nil) + (t (append (first-n (len cycle) path) (find-prefix + cycle (rest seen) witness + (last-n (len cycle) path)))))) + +(defun find-cycle (cycle seen witness path) + (cond ((endp seen) nil) ;; should not arise + ((endp path) nil) + ((equal witness (first seen)) path) + (t (find-cycle cycle (rest seen) witness (last-n (len cycle) path))))) + +;; ACL2 is really stupid in arithmetic. I just add Robert's collection of +;; arithmetic books to get it thru with what I want. I need arithmetic really for +;; very weird reasons, but well, what the heck, I dont want to deal with +;; arithmetic myself any ways. + +(local +(include-book "../../../../arithmetic-2/meta/top") +) + +(local +(defthm len-of-snoc-is-more + (< (len x) (len (snoc x e))) + :rule-classes :linear) +) + +;; The following function determines a weird path in n, when given a cycle in +;; m. The weird path is a finite path compatible with n, and can be thought of +;; as the append of the prefix and cycle. + +(defun find-matching-prefix-and-cycle-for-cycle-m->n (cycle m seen q states n vars path) + (declare (xargs :measure (nfix (- (1+ (len states)) (len seen))))) + ;; for termination using Pigeon-hole arguments + (if (< (len states) (len seen)) (mv seen q path) + (let* ((path-produced (find-matching-path-for-path-m->n + cycle m q n vars)) + (node-witness (bisimilar-transition-witness-m->n + (last-val cycle) (first cycle) m + (last-val path-produced) n vars))) + (if (memberp node-witness seen) + (mv (snoc seen node-witness) node-witness (append path path-produced)) + (find-matching-prefix-and-cycle-for-cycle-m->n cycle m (snoc seen node-witness) + node-witness states n + vars (append path + path-produced)))))) + +(defun find-matching-prefix-and-cycle-for-cycle-n->m (seen q states m cycle n vars path) + (declare (xargs :measure (nfix (- (1+ (len states)) (len seen))))) + ;; for termination using Pigeon-hole arguments + (if (< (len states) (len seen)) (mv seen q path) + (let* ((path-produced (find-matching-path-for-path-n->m + q m cycle n vars)) + (node-witness (bisimilar-transition-witness-n->m + (last-val path-produced) m + (last-val cycle) (first cycle) n vars))) + (if (memberp node-witness seen) + (mv (snoc seen node-witness) node-witness (append path path-produced)) + (find-matching-prefix-and-cycle-for-cycle-n->m (snoc seen node-witness) + node-witness states m + cycle n + vars (append path + path-produced)))))) + + +;; And we pick up the prefix from the weird path + +(defun find-matching-prefix-for-cycle-m->n (cycle m q n vars) + (mv-let (seen witness path) + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n vars nil) + (find-prefix cycle (del-last seen) witness path))) + +(defun find-matching-prefix-for-cycle-n->m (q m cycle n vars) + (mv-let (seen witness path) + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m cycle n vars nil) + (find-prefix cycle (del-last seen) witness path))) + + +;; and also the cycle. + +(defun find-matching-cycle-for-cycle-m->n (cycle m q n vars) + (mv-let (seen witness path) + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n vars nil) + (find-cycle cycle (del-last seen) witness path))) + +(defun find-matching-cycle-for-cycle-n->m (q m cycle n vars) + (mv-let (seen witness path) + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m cycle n vars nil) + (find-cycle cycle (del-last seen) witness path))) + +;; So we can now produce the matching periodic path by appending the prefix +;; after the matching path for the prefix and the cycle as we obtained. + +(defun find-matching-periodic-path-m->n (ppath m n vars) + (let* ((init-p (initial-state ppath)) + (prefix-p (prefix ppath)) + (first-p (first prefix-p)) + (cycle-p (cycle ppath)) + (init-q (bisimilar-initial-state-witness-m->n init-p m n vars)) + (first-q (bisimilar-transition-witness-m->n init-p first-p m init-q n + vars)) + (match-path (find-matching-path-for-path-m->n prefix-p m first-q n + vars)) + (last-p (last-val prefix-p)) + (last-q (last-val match-path)) + (first-cp (first cycle-p)) + (first-cq (bisimilar-transition-witness-m->n last-p first-cp m last-q + n vars)) + (match-prefix (find-matching-prefix-for-cycle-m->n + cycle-p m first-cq n vars)) + (match-cycle (find-matching-cycle-for-cycle-m->n + cycle-p m first-cq n vars))) + (>_ :initial-state init-q + :prefix (append match-path match-prefix) + :cycle match-cycle))) + +(defun find-matching-periodic-path-n->m (m ppath n vars) + (let* ((init-q (initial-state ppath)) + (prefix-q (prefix ppath)) + (first-q (first prefix-q)) + (cycle-q (cycle ppath)) + (init-p (bisimilar-initial-state-witness-n->m m init-q n vars)) + (first-p (bisimilar-transition-witness-n->m init-p m init-q first-q n + vars)) + (match-path (find-matching-path-for-path-n->m first-p m prefix-q n + vars)) + (last-q (last-val prefix-q)) + (last-p (last-val match-path)) + (first-cq (first cycle-q)) + (first-cp (bisimilar-transition-witness-n->m last-p m last-q first-cq + n vars)) + (match-prefix (find-matching-prefix-for-cycle-n->m + first-cp m cycle-q n vars)) + (match-cycle (find-matching-cycle-for-cycle-n->m + first-cp m cycle-q n vars))) + (>_ :initial-state init-p + :prefix (append match-path match-prefix) + :cycle match-cycle))) + + +;; Now we bite the bullet and start showing that this dirty bad function suits +;; our purpose. Any suggestions for improvement will be greatly appreciated. + +;; Let us define the general concept of what we mean by two paths (or segments +;; being bisimilar. + + +(local +(defun bisimilar-segments-p (p m q n vars) + (if (endp p) (endp q) + (and (consp q) + (bisimilar (first p) m (first q) n vars) + (bisimilar-segments-p (rest p) m (rest q) n vars)))) +) + +;; And of course we can then define when a sequence of segments appended +;; together is bisimilar. + + +(local +(defun bisimilar-segments-sequence-p (p m q n vars) + (declare (xargs :measure (len q))) + (if (endp q) T + (if (or (endp p) (< (len q) (len p))) nil + (and (bisimilar-segments-p p m (first-n (len p) q) n vars) + (bisimilar-segments-sequence-p p m (last-n (len p) q) n vars))))) +) + +(local +(defun bisimilar-segments-sequence-p-2 (p m q n vars) + (declare (xargs :measure (len p))) + (if (endp p) T + (if (or (endp q) (< (len p) (len q))) nil + (and (bisimilar-segments-p (first-n (len q) p) m q n vars) + (bisimilar-segments-sequence-p-2 (last-n (len q) p) m q n vars))))) +) + + +;; Of course now, we know that find-matching-path produces a bisimilar path. + +(local +(defthm find-matching-path-produces-bisimilar-segments + (implies (and (compatible-path-p p m) + (bisimilar (first p) m q n vars)) + (bisimilar-segments-p + p m + (find-matching-path-for-path-m->n p m q n vars) + n vars))) +) + +(local +(defthm find-matching-path-produces-bisimilar-segments-2 + (implies (and (compatible-path-p q n) + (bisimilar p m (first q) n vars)) + (bisimilar-segments-p + (find-matching-path-for-path-n->m p m q n vars) + m q + n vars))) +) + +;; and bisimilar paths have the same length. + +(local +(defthm bisimilar-to-length + (implies (bisimilar-segments-p p m q n vars) + (equal (len p) (len q))) + :rule-classes :forward-chaining) +) + +(local +(defthm len-of-append + (equal (len (append x y)) + (+ (len x) (len y)))) +) + +(local +(defthm last-n-is-true-listp + (implies (true-listp p) + (true-listp (last-n i p)))) +) + +(local +(defthm first-last-append-reduction-2 + (implies (<= i (len x)) + (equal (append x y) + (append (first-n i x) (append (last-n i x) y))))) +) + +(local +(defthm first-n-reduced + (implies (and (equal (len x) i) + (true-listp x)) + (equal (first-n i x) x))) +) + +(local +(defthm last-n-reduced + (implies (and (<= (len x) i) + (integerp i) + (true-listp x)) + (equal (last-n i x) nil))) +) + +;; and bisimilar segements would also be bisimilar-segments-sequence. + +(local +(defthm bisimilar-segments-are-bisimilar-segment-sequences + (implies (and (bisimilar-segments-p p m q n vars) + (true-listp p) + (true-listp q) + (consp p)) + (bisimilar-segments-sequence-p p m q n vars)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :induct (bisimilar-segments-sequence-p p m q n vars) + :do-not-induct t))) +) + +(local +(defthm bisimilar-segments-are-bisimilar-segment-sequences-2 + (implies (and (bisimilar-segments-p p m q n vars) + (true-listp p) + (true-listp q) + (consp q)) + (bisimilar-segments-sequence-p-2 p m q n vars)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :induct (bisimilar-segments-sequence-p-2 p m q n vars) + :do-not-induct t))) +) + +;; which when appended will produce bisimilar segments sequence. + +(local +(defthm append-of-bisimilar-segments-produces-bisimilar-segment-list + (implies (and (bisimilar-segments-p p m r n vars) + (consp p) + (true-listp r) + (true-listp p) + (true-listp q) + (bisimilar-segments-sequence-p p m q n vars)) + (bisimilar-segments-sequence-p p m (append q r) n vars)) + :hints (("Goal" + :do-not '(generalize eliminate-destructors) + :do-not-induct t + :induct (bisimilar-segments-sequence-p p m q n vars)))) +) + +(local +(defthm append-of-bisimilar-segments-produces-bisimilar-segment-list-2 + (implies (and (bisimilar-segments-p r m q n vars) + (consp q) + (true-listp r) + (true-listp p) + (true-listp q) + (bisimilar-segments-sequence-p-2 p m q n vars)) + (bisimilar-segments-sequence-p-2 (append p r) m q n vars)) + :hints (("Goal" + :do-not '(generalize eliminate-destructors) + :do-not-induct t + :induct (bisimilar-segments-sequence-p-2 p m q n vars)))) +) + +;; and the prefix of bisimilar segements sequence is a +;; bisimialr-segments-sequence + +(local +(defthm prefix-produces-bisimilar-segment-list + (implies (bisimilar-segments-sequence-p p m q n vars) + (bisimilar-segments-sequence-p p m (find-prefix p seen witness q) n + vars))) +) + +(local +(defthm prefix-produces-bisimilar-segment-list-2 + (implies (bisimilar-segments-sequence-p-2 p m q n vars) + (bisimilar-segments-sequence-p-2 (find-prefix q seen witness p) m q n + vars))) + +) + +;; and so is the cycle. + +(local +(defthm cycle-produces-bisimilar-segment-list + (implies (bisimilar-segments-sequence-p p m q n vars) + (bisimilar-segments-sequence-p p m (find-cycle p seen witness q) n + vars))) +) + +(local +(defthm cycle-produces-bisimilar-segment-list-2 + (implies (bisimilar-segments-sequence-p-2 p m q n vars) + (bisimilar-segments-sequence-p-2 (find-cycle q seen witness p) m q n + vars))) +) + +;; Also the last-vals of compatible paths is bisimilar. + +(local +(defthm last-vals-are-bisimilar + (implies (and (compatible-path-p path m) + (consp path) + (bisimilar (first path) m q n vars)) + (bisimilar (last-val path) m + (last-val (find-matching-path-for-path-m->n path m q n + vars)) + n vars))) +) + +(local +(defthm last-vals-are-bisimilar-2 + (implies (and (compatible-path-p path n) + (consp path) + (bisimilar p m (first path) n vars)) + (bisimilar (last-val (find-matching-path-for-path-n->m p m path n + vars)) + m (last-val path) + n vars))) +) + + + +(local +(defthm true-listp-append-reduction + (implies (true-listp y) + (true-listp (append x y)))) +) + +;; and therefore, finally, the segment produced by find-prefix-and-cycle is +;; bisimilar segments sequence-p + +(local +(defthm matching-prefix-and-cycle-produces-bisimilar-segment-list + (implies (and (consp cycle) + (true-listp path) + (bisimilar-segments-sequence-p cycle m path n vars) + (compatible-path-p cycle m) + (next-statep (last-val cycle) (first cycle) m) + (bisimilar (first cycle) m q n vars)) + (bisimilar-segments-sequence-p + cycle m + (mv-nth + 2 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q + states n vars path)) + n vars))) +) + +(local +(defthm matching-prefix-and-cycle-produces-bisimilar-segment-list-2 + (implies (and (consp cycle) + (true-listp path) + (bisimilar-segments-sequence-p-2 path m cycle n vars) + (compatible-path-p cycle n) + (next-statep (last-val cycle) (first cycle) n) + (bisimilar q m (first cycle) n vars)) + (bisimilar-segments-sequence-p-2 + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path)) + m cycle + n vars)) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n + vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + + +;; which means that the prefix is bisimilar segments sequence + +(local +(defthm find-matching-prefix-is-bisimilar-segments-p + (implies (and (consp cycle) + (compatible-path-p cycle m) + (next-statep (last-val cycle) (car cycle) m) + (bisimilar (first cycle) m q n vars)) + (bisimilar-segments-sequence-p + cycle m (find-matching-prefix-for-cycle-m->n cycle m q n vars) n + vars))) +) + +(local +(defthm find-matching-prefix-is-bisimilar-segments-p-2 + (implies (and (consp cycle) + (compatible-path-p cycle n) + (next-statep (last-val cycle) (car cycle) n) + (bisimilar q m (first cycle) n vars)) + (bisimilar-segments-sequence-p-2 + (find-matching-prefix-for-cycle-n->m q m cycle n vars) m cycle n + vars))) +) + +;; and so is the cycle. + +(local +(defthm find-matching-cycle-is-bisimilar-segments-p + (implies (and (consp cycle) + (compatible-path-p cycle m) + (next-statep (last-val cycle) (car cycle) m) + (bisimilar (first cycle) m q n vars)) + (bisimilar-segments-sequence-p + cycle m (find-matching-cycle-for-cycle-m->n cycle m q n vars) n + vars))) + +) + +(local +(defthm find-matching-cycle-is-bisimilar-segments-p-2 + (implies (and (consp cycle) + (compatible-path-p cycle n) + (next-statep (last-val cycle) (car cycle) n) + (bisimilar q m (first cycle) n vars)) + (bisimilar-segments-sequence-p-2 + (find-matching-cycle-for-cycle-n->m q m cycle n vars) m cycle n + vars))) + +) + +;; Now of course, a periodic path is bisimilar to another if the following +;; holds. + +(local +(defun bisimilar-periodic-paths-p (p m q n vars) + (and (bisimilar (initial-state p) m (initial-state q) n vars) + (or (and (bisimilar-segments-p (prefix p) m + (first-n (len (prefix p)) (prefix q)) + n vars) + (bisimilar-segments-sequence-p + (cycle p) m + (last-n (len (prefix p)) (prefix q)) n vars) + (bisimilar-segments-sequence-p (cycle p) m (cycle q) n vars)) + (and (bisimilar-segments-p (first-n (len (prefix q)) (prefix p)) m + (prefix q) n vars) + (bisimilar-segments-sequence-p-2 (last-n (len (prefix q)) + (prefix p)) + m (cycle q) n vars) + (bisimilar-segments-sequence-p-2 + (cycle p) m (cycle q) n vars))))) + +) + +;; We need to show that find-matching-periodic-path-m->ns produce +;; bisimilar-periodic-paths-p. + + +;; And we need to append things the other way around to get it through. + +(local +(in-theory (disable find-matching-prefix-for-cycle-m->n + find-matching-cycle-for-cycle-m->n + find-matching-prefix-for-cycle-n->m + find-matching-cycle-for-cycle-n->m)) +) + +(local +(defthm find-matching-path-for-path-has-same-len + (equal (len (find-matching-path-for-path-m->n p m q n vars)) + (len p))) +) + +(local +(defthm find-matching-path-for-path-has-same-len-2 + (equal (len (find-matching-path-for-path-n->m p m q n vars)) + (len q))) +) + +(local +(defthm find-matching-periodic-path-m->n-produces-bisimilar-periodic-paths + (implies (and (compatible-ppath-p ppath m) + (bisimilar-equiv m n vars)) + (bisimilar-periodic-paths-p ppath m + (find-matching-periodic-path-m->n + ppath m n + vars) + n vars)) + :hints (("Goal" + :do-not-induct t))) +) + +(local +(defthm find-matching-periodic-path-m->n-produces-bisimilar-periodic-paths-2 + (implies (and (compatible-ppath-p ppath n) + (bisimilar-equiv m n vars)) + (bisimilar-periodic-paths-p + (find-matching-periodic-path-n->m m ppath n + vars) + m ppath + n vars)) + :hints (("Goal" + :do-not-induct t))) +) + +;; Now let us prove that bisimilar periodic paths have labels equal. + + +(local + (in-theory (disable set-equal set-intersect)) + ) + +(local +(defthm bisimilar-segments-have-equal-labels + (implies (and (bisimilar-segments-p p m q n vars) + (modelp m) + (modelp n)) + (equal-label-segments-p p m q n vars))) +) + +(local +(defthm bisimilar-segments-sequence-p-have-equal-labels + (implies (and (bisimilar-segments-sequence-p p m q n vars) + (modelp m) + (modelp n)) + (equal-label-segments-sequence-p-small-p p m q n vars))) +) + +(local +(defthm bisimilar-segments-sequence-p-have-equal-labels-2 + (implies (and (bisimilar-segments-sequence-p-2 p m q n vars) + (modelp m) + (modelp n)) + (equal-label-segments-sequence-p-large-p p m q n vars))) +) + +(local +(defthm bisimilar-periodic-paths-have-equal-labels + (implies (and (bisimilar-periodic-paths-p p m q n vars) + (modelp m) + (modelp n)) + (equal-labels-periodic-path-p p m q n vars))) +) + +(local +(in-theory (disable bisimilar-periodic-paths-p equal-labels-periodic-path-p)) +) + +(local +(defthm ppath-and-its-matching-ppath-have-same-labels + (implies (and (compatible-ppath-p ppath m) + (bisimilar-equiv m n vars) + (modelp m) + (modelp n)) + (equal-labels-periodic-path-p + ppath m (find-matching-periodic-path-m->n ppath m n vars) n vars)) + :hints (("Goal" + :in-theory (disable compatible-ppath-p + find-matching-periodic-path-m->n)))) + +) + +(local +(defthm ppath-and-its-matching-ppath-have-same-labels-2 + (implies (and (compatible-ppath-p ppath n) + (bisimilar-equiv m n vars) + (modelp m) + (modelp n)) + (equal-labels-periodic-path-p + (find-matching-periodic-path-n->m m ppath n vars) m ppath n vars)) + :hints (("Goal" + :in-theory (disable compatible-ppath-p + find-matching-periodic-path-n->m)))) + +) + + +;; OK let us now think over what I proved so far. Briefly I have proved that if +;; P is a periodic path in m, and m and n are bisimilar-equivalent, then there +;; is a periodic path which has the same labels. Now what do we need to +;; prove? We need to prove that the periodic path we have proved to have the +;; same label must be a path of n. That is it is compatible with n. If we do +;; that, then we would know that for every path in m there is a path in n that +;; has the same labels. hence we will know that ltl-semantics of m and n for a +;; restricted formula f is same. + + +;; Unfortunately, this property (though trivial intuitively) is not an easy +;; property for a theorem-proving exercise. It needs a lot of work showing (for +;; example) pigeon-hole principle. I will discuss the issues as we get +;; there. For now, let us start proving each of the constraints of +;; compatible-ppath-p separately. There is no real mystery here, --- I took a +;; printout of ltl.lisp, and decided to prove each of the constraints +;; separately. + +;; To prove these constraints separately, I will bear in mind that in the final +;; theorem compatible-ppath-p is going to be enabled. This being a recursive +;; function, we will have to be careful that in the lemmas, we do not have +;; compatible-ppath-p as a hypothesis. + +;; The first theorem in our agenda is to show that initial-state of matching +;; ppath is a member of initial states. That is obvious, from the constraints +;; of bisimilar-initial-state-witness. + + +;; The next theorem is to show that the prefix is a consp. This is because we +;; start with a matching-path of a consp prefix and append of a consp with +;; something is a consp. This is established by the next two theorems. + +(local +(defthm prefix-is-a-consp + (equal (consp (find-matching-path-for-path-m->n path m q n vars)) + (consp path))) +) + +(local +(defthm prefix-is-a-consp-2 + (equal (consp (find-matching-path-for-path-n->m q m path n vars)) + (consp path))) +) + + +(local +(defthm append-expands-to-consp + (equal (consp (append x y)) + (if (consp x) T (consp y)))) +) + +;; The next constraint says that the first of the prefix is next state of +;; init. This is trivial from property of bisimilar-transition-witness and the +;; fact that inits of the two models are bisimilar. + + + +;; The next constraint is to show that the cycle is a consp. In other words, we +;; have to show the consp property for find-matching-cycle-for-cyle. Now why +;; is the cycle consp. Roughly, the reason is as follows. The length of the +;; path produced by prefix and cycle is (len seen) * (len cycle). And the +;; witness is a member of path. seen. Hence the cycle produced is a consp by +;; the next two theorems. + +(local +(defthm last-n-len-reduction + (implies (and (equal (len path) (+ i j)) + (integerp i) + (integerp j) + (<= 0 i) + (<= 0 j)) + (equal (len (last-n i path)) + j))) +) + +(local +(defthm witness-member-of-seen-implies-consp + (implies (and (memberp witness seen) + (consp cycle) + (force (equal (len path) (* (len cycle) (len seen))))) + (consp (find-cycle cycle seen witness path)))) +) + +;; However, this leads us to two more proof requirements. Why should the +;; witness be a member of seen, and why should the length of the big path be +;; the product of the length of seen and cycle. We address these two issues +;; below. + +(local +(defthm snoc-produces-memberp + (memberp e (snoc x e))) +) + +(local +(defthm snoc-len-reduction + (equal (len (snoc x e)) + (1+ (len x)))) +) + +;; We show that the value returned as the seen list has 1 less than what we +;; need, and this will just be figured out by deducting 1 again from the seen +;; list since we remove the last guy. + +(local +(defthm len-of-path-is-product-of-two + (implies (equal (len path) (* (len cycle) (1- (len seen)))) + (equal (len (mv-nth + 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path))) + (* (len cycle) + (1- (len (mv-nth + 0 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars + path)))))))) + +) + +(local +(defthm len-of-path-is-product-of-two-2 + (implies (equal (len path) (* (len cycle) (1- (len seen)))) + (equal (len (mv-nth + 2 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path))) + (* (len cycle) + (1- (len (mv-nth + 0 + (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars + path)))))))) + +) + + +(local +(defthm del-last-len-reduction + (implies (consp x) + (equal (len (del-last x)) + (1- (len x))))) +) + +;; And finally that the seen list is consp + +(local +(defthm seen-list-is-consp + (implies (memberp q seen) + (consp (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path)))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-m->n cycle m seen + q states n + vars path)))) + +) + +(local +(defthm seen-list-is-consp-2 + (implies (memberp q seen) + (consp (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path)))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-n->m seen + q states m + cycle n + vars path)))) + +) + +;; Now why should the witness be a member of the seen? The reason is kind of a +;; pigeon-hole argument. The high-level argument is that witness is producing a +;; a member of states all the time, and a new guy every time it produces a +;; non-member of seen so it will exhaust out eventually. + + +;; First a few reductions using snoc and uniquep. I am lucky that uniquep is +;; already in records which helps a lot. + +(local +(defthm snoc-member-reduction + (equal (memberp a (snoc x e)) + (or (memberp a x) + (equal a e)))) +) + +(local +(defthm uniquep-snoc-reduction + (implies (and (uniquep seen) + (not (memberp e seen))) + (uniquep (snoc seen e)))) +) + +(local +(defthm memberp-del-last-reduction + (equal (memberp a (del-last (snoc x e))) + (memberp a x))) +) + +(local +(defthm uniquep-dellast-reduction + (implies (uniquep x) + (uniquep (del-last (snoc x e))))) +) + +(local +(defthm not-memberp-del-reduction + (implies (not (memberp e x)) + (not (memberp e (del-last x))))) +) + +(local +(defthm uniquep-del-last-true + (implies (uniquep x) + (uniquep (del-last x)))) +) + +;; So now, we can show that the seen list is uniquep. + +(local +(defthm del-last-seen-is-unique-p + (implies (uniquep seen) + (uniquep (del-last (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path))))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm del-last-seen-is-unique-p-2 + (implies (uniquep seen) + (uniquep (del-last (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path))))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm len-<-states-implies-<witness-memberp + (implies (case-split (<= (len (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path))) + (len states))) + (memberp (mv-nth 1 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path)) + (del-last (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path)))))) +) + +(local +(defthm len-<-states-implies-<witness-memberp-2 + (implies (case-split (<= (len (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path))) + (len states))) + (memberp (mv-nth 1 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path)) + (del-last (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path)))))) +) + +(local +(in-theory (enable subset)) +) + +;; Again, we need to define del. This is because it will be used in the +;; induction hint. I am rpetty sure this is not the shortest path to the proof, +;; but this is how I would have reasoned without ACL2. + +(local +(defun del (e x) + (if (endp x) nil + (if (equal e (car x)) (cdr x) + (cons (car x) (del e (cdr x)))))) +) + +(local +(defthm uniquep-to-not-member + (implies (uniquep x) + (not (memberp e (del e x))))) +) + +(local +(defthm member-del-reduction + (implies (not (equal a e)) + (equal (memberp a (del e y)) + (memberp a y)))) +) + +(local +(defthm del-subset-reduction + (implies (and (uniquep x) + (subset x y)) + (subset (del e x) (del e y)))) +) + +(local +(defthm len-del-reduction + (implies (memberp e x) + (equal (len (del e x)) + (1- (len x))))) +) + +(local +(defun induction-hint (x y) + (if (endp x) y + (induction-hint (rest x) (del (first x) y)))) +) + +(local +(defthm not-memberp-del-reduction-2 + (implies (not (memberp e x)) + (subset x (del e x)))) +) + +(local +(defthm unique-p-del-subset-reduction + (implies (and (uniquep x) + (not (memberp e x)) + (subset x y)) + (subset x (del e y))) + :hints (("Goal" + :do-not-induct t + :use ((:instance subset-is-transitive + (y (del e x)) + (z (del e y))))))) +) + +(local +(defthm uniquep-subset-reduction + (implies (and (uniquep x) + (subset x y)) + (<= (len x) (len y))) + :hints (("Goal" + :induct (induction-hint x y)))) +) + +(local +(defthm car-append-reduction + (equal (car (append x y)) + (if (consp x) (car x) (car y)))) +) + +(local +(defthm consp-to-car-find-matching-path + (implies (consp path) + (equal (car (find-matching-path-for-path-m->n path m q n vars)) + q))) +) + +(local +(defthm consp-to-car-find-matching-path-2 + (implies (consp path) + (equal (car (find-matching-path-for-path-n->m q m path n vars)) + q))) +) + +(local +(defthm last-val-append-reduction + (equal (last-val (append x y)) + (if (consp y) (last-val y) (last-val x)))) +) + +(local +(defthm subset-snoc-reduction + (implies (and (subset x y) + (memberp e y)) + (subset (snoc x e) y))) +) + +(local +(defthm last-val-bisimilar-reduction + (implies (and (bisimilar (first cycle) m q n vars) + (consp cycle) + (compatible-path-p cycle m)) + (bisimilar (last-val cycle) m (last-val + (find-matching-path-for-path-m->n + cycle m q n vars)) + n vars))) +) + +(local +(defthm last-val-bisimilar-reduction-2 + (implies (and (bisimilar q m (first cycle) n vars) + (consp cycle) + (compatible-path-p cycle n)) + (bisimilar (last-val (find-matching-path-for-path-n->m q m cycle n + vars)) + m + (last-val cycle) + n vars))) +) + +(local +(defthm find-matching-path-produces-compatible-path + (implies (and (compatible-path-p cycle m) + (consp cycle) + (memberp q (states n)) + (bisimilar (first cycle) m q n vars)) + (compatible-path-p (find-matching-path-for-path-m->n + cycle m q n vars) + n))) +) + +(local +(defthm find-matching-path-produces-compatible-path-2 + (implies (and (compatible-path-p cycle n) + (consp cycle) + (memberp q (states m)) + (bisimilar q m (first cycle) n vars)) + (compatible-path-p (find-matching-path-for-path-n->m + q m cycle n vars) + m))) +) + +;; And finally, I am saying that seen list is a subset of states. (Basically a +;; slightly stronger thing, but that is ok.) + + +(local +(defthm seen-list-subset-of-states + (implies (and (subset seen (states n)) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (next-statep (last-val cycle) (first cycle) m) + (compatible-path-p cycle m)) + (subset (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path)) + (states n))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm seen-list-subset-of-states-2 + (implies (and (subset seen (states m)) + (bisimilar q m (first cycle) n vars) + (consp cycle) + (next-statep (last-val cycle) (first cycle) n) + (compatible-path-p cycle n)) + (subset (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path)) + (states m))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +;; And also that witness is a member of states. + +(local +(defthm witness-member-of-states + (implies (and (memberp q (states n)) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (next-statep (last-val cycle) (first cycle) m) + (compatible-path-p cycle m)) + (memberp (mv-nth 1 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path)) + (states n))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q states n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm witness-member-of-states-2 + (implies (and (memberp q (states m)) + (bisimilar q m (first cycle) n vars) + (consp cycle) + (next-statep (last-val cycle) (first cycle) n) + (compatible-path-p cycle n)) + (memberp (mv-nth 1 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path)) + (states m))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-n->m + seen q states m cycle n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm subset-remains-for-del + (implies (subset x y) + (subset (del-last x) y))) +) + +(local +(defthm del-creates-subset + (subset (del-last x) x)) +) + +(local +(defthm memberp-to-subset + (implies (memberp q states) + (subset (list q) states)) + :rule-classes nil) +) + +(local +(defthm uniquep-and-=-and-implies-member + (implies (and (uniquep x) + (equal (len x) (len y)) + (subset x y) + (memberp e y)) + (memberp e x)) + :hints (("Goal" + :induct (induction-hint x y)))) +) + +;; Then finally, I am done. I am saying here that the matching cycle is a +;; consp. Matt might just not like the use hints I force, but there seems to be +;; no simpler route. I would be interested to know if someone can simplify this +;; proof. + +(local +(defthm find-matching-cycle-for-cycle-is-consp + (implies (and (memberp q (states n)) + (consp cycle) + (compatible-path-p cycle m) + (bisimilar (first cycle) m q n vars) + (next-statep (last-val cycle) (first cycle) m)) + (consp (find-matching-cycle-for-cycle-m->n cycle m q n vars))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :expand (find-matching-cycle-for-cycle-m->n cycle m q n vars) + :do-not-induct t + :in-theory (disable witness-member-of-seen-implies-consp) + :use ((:instance witness-member-of-seen-implies-consp + (witness (mv-nth 1 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) + n vars nil))) + (seen (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (path (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (:instance uniquep-subset-reduction + (x (del-last (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n vars nil)))) + (y (states n))) + (:instance uniquep-and-=-and-implies-member + (x (del-last (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) + n vars nil)))) + (y (states n)) + (e (mv-nth 1 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) + n vars nil)))))))) +) + + +(local +(defthm find-matching-cycle-for-cycle-is-consp-2 + (implies (and (memberp q (states m)) + (consp cycle) + (compatible-path-p cycle n) + (bisimilar q m (first cycle) n vars) + (next-statep (last-val cycle) (first cycle) n)) + (consp (find-matching-cycle-for-cycle-n->m q m cycle n vars))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :expand (find-matching-cycle-for-cycle-n->m q m cycle n vars) + :do-not-induct t + :in-theory (disable witness-member-of-seen-implies-consp) + :use ((:instance witness-member-of-seen-implies-consp + (witness (mv-nth 1 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m cycle + n vars nil))) + (seen (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil)))) + (path (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil)))) + (:instance uniquep-subset-reduction + (x (del-last (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil)))) + (y (states m))) + (:instance uniquep-and-=-and-implies-member + (x (del-last (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle + n vars nil)))) + (y (states m)) + (e (mv-nth 1 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n vars nil)))))))) +) + +;; The next theorem in our agenda is to prove that the prefix of the matching +;; path is compatible-path-p. Notice we have already proved that +;; find-matching-path produces a compatible-path-p. So we need to prove that +;; prefix-and-cycle produces the same, and then say that append of two "good" +;; compatible paths is a compatible path. + +(local +(defthm compatible-path-append-reduction + (implies (force (and (true-listp x) + (true-listp y))) + (equal (compatible-path-p (append x y) m) + (if (not (consp x)) (compatible-path-p y m) + (if (not (consp y)) (compatible-path-p x m) + (and (compatible-path-p x m) + (compatible-path-p y m) + (next-statep (last-val x) (first y) m))))))) +) + + +;; While we are at it, let us show that the first-n and last-n are +;; compatible-paths + +(local +(defthm consp-and-i>=-first-n-reduction + (implies (and (consp p) + (integerp i) + (< 0 i)) + (equal (car (first-n i p)) + (car p)))) +) + +(local +(defthm compatible-path-first-n-reduction + (implies (and (compatible-path-p p m) + (integerp i) + (<= 0 i) + (<= i (len p))) + (compatible-path-p (first-n i p) m)) + :hints (("Goal" + :induct (first-n i p) + :in-theory (enable zp) + :do-not '(eliminate-destructors generalize) + :do-not-induct t) + ("Subgoal *1/2" + :cases ((zp (1- i)))))) +) + +(local +(defthm compatible-path-last-n-reduction + (implies (and (compatible-path-p p m) + (integerp i) + (<= 0 i) + (<= i (len p))) + (compatible-path-p (last-n i p) m)) + :hints (("Goal" + :induct (last-n i p) + :in-theory (enable zp) + :do-not '(eliminate-destructors generalize) + :do-not-induct t) + ("Subgoal *1/2" + :cases ((zp (1- i)))))) +) + +;; The theorems above just say that if we could (somehow) prove that +;; find-prefix-and-cycle produces a compatible path then I would immediately +;; know that the prefix and cycle are both compatible. + +;; Now why should find-prefix-and-cycle produce a compatible path? For +;; something to be a compatible path, what we need is that every state in the +;; path is a member of states and the next state is a next-statep. So let us +;; prove these properties separately. + +;; Informally here is what happens. I know that the last-val of +;; find-matching-path is bisimilar to last-val of cycle. and is a member of +;; states. Hence, the bisimilar witness it produces with the first of cycle is +;; a next-statep (Notice that next-statep is true for last-val and car of +;; cycle.) Hence the paths produced by recursive calls can be appended together +;; to produce a compatible path if path (the initial segment of the accumulator +;; is known to be a compatible path. + + +(local +(defthm last-val-of-find-matching-prefix-is-member-of-states + (implies (and (bisimilar (first cycle) m q n vars) + (consp cycle) + (compatible-path-p cycle m) + (memberp q (states n))) + (memberp (last-val (find-matching-path-for-path-m->n + cycle m q n vars)) + (states n)))) +) + +(local +(defthm find-prefix-and-cycle-produces-compatible-path + (implies (and (bisimilar (first cycle) m q n vars) + (compatible-path-p path n) + (compatible-path-p (append path + (find-matching-path-for-path-m->n + cycle m q n vars)) + n) + (consp cycle) + (memberp q (states n)) + (next-statep (last-val cycle) (car cycle) m) + (compatible-path-p cycle m)) + (compatible-path-p (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q (states n) n vars path)) + n)) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q (states n) n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm find-prefix-and-cycle-produces-compatible-path-2 + (implies (and (bisimilar q m (first cycle) n vars) + (compatible-path-p path m) + (compatible-path-p (append path + (find-matching-path-for-path-n->m + q m cycle n vars)) + m) + (consp cycle) + (memberp q (states m)) + (next-statep (last-val cycle) (car cycle) n) + (compatible-path-p cycle n)) + (compatible-path-p (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q (states m) m cycle n vars path)) + m)) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-n->m + seen q (states m) m cycle n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +;; Now that we know that find-prefix-and-cycle-is-a-compatible-path-p, and also +;; that first-n of a compatible path is a compatible path, and also append +;; produces compatible paths, we should be able to prove that +;; find-matching-prefix and find-matching-cycle produce compatible paths. + +;; Well, it does not seem to be as simple as it looks. The problem is in +;; getting the induction working right. + +;; To do work with find-matching-prefix we define the index such that +;; find-prefix produces that index. + + +(local +(defun find-prefix-index (cycle seen witness path) + (cond ((endp path) 0) + ((endp seen) (len path)) + ((equal witness (first seen)) 0) + (t (+ (len cycle) + (find-prefix-index cycle (rest seen) witness (last-n (len cycle) path)))))) +) + +(local +(defthm first-n+-reduction + (implies (and (integerp i) + (integerp j) + (<= 0 i) + (<= 0 j)) + (equal (first-n (+ i j) x) + (append (first-n i x) (first-n j (last-n i x)))))) +) + +(local +(defthm last-n+-reduction + (implies (and (integerp i) + (integerp j) + (<= 0 i) + (<= 0 j)) + (equal (last-n (+ i j) x) + (last-n j (last-n i x))))) +) + +(local +(defthm find-prefix-with-index + (implies (and (true-listp path) + (equal (len path) (* (len cycle) (len seen)))) + (equal (find-prefix cycle seen witness path) + (first-n (find-prefix-index cycle seen witness path) path)))) +) + +(local +(defthm find-cycle-with-index + (implies (and (equal (len path) (* (len cycle) (len seen))) + (true-listp path)) + (equal (find-cycle cycle seen witness path) + (last-n (find-prefix-index cycle seen witness path) path)))) +) + +(local +(defthm index-is-an-integer->=0 + (and (integerp (find-prefix-index cycle seen witness path)) + (<= 0 (find-prefix-index cycle seen witness path))) + :rule-classes :type-prescription) +) + +(local +(defthm prefix-and-cycle-produces-true-listp + (implies (true-listp path) + (true-listp (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m q seen states n vars path))))) +) + +(local +(defthm prefix-and-cycle-produces-true-listp-2 + (implies (true-listp path) + (true-listp (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + q seen states m cycle n vars path))))) +) + +(local +(in-theory (enable find-matching-cycle-for-cycle-m->n + find-matching-prefix-for-cycle-m->n)) +) + +(local +(defthm last-consp-implies-first-<=len + (implies (and (consp (last-n i x)) + (integerp i)) + (<= i (len x))) + :rule-classes :linear) +) + +(local +(defthm find-matching-prefix-is-a-compatible-path + (implies (and (compatible-path-p cycle m) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (memberp q (states n)) + (next-statep (last-val cycle) (car cycle) m)) + (compatible-path-p (find-matching-prefix-for-cycle-m->n cycle m q n + vars) + n)) + :hints (("Goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize) + :in-theory (disable compatible-path-first-n-reduction + find-matching-cycle-for-cycle-is-consp) + :use ((:instance compatible-path-first-n-reduction + (i (find-prefix-index cycle + (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars + nil))) + + (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (m n) + (p (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (:instance find-matching-cycle-for-cycle-is-consp))))) +) + +(local +(defthm find-matching-cycle-is-a-compatible-path + (implies (and (compatible-path-p cycle m) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (memberp q (states n)) + (next-statep (last-val cycle) (car cycle) m)) + (compatible-path-p (find-matching-cycle-for-cycle-m->n cycle m q n + vars) + n)) + :hints (("Goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize) + :in-theory (disable compatible-path-first-n-reduction + find-matching-cycle-for-cycle-is-consp) + :use ((:instance compatible-path-last-n-reduction + (i (find-prefix-index cycle + (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars + nil))) + + (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (m n) + (p (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (:instance find-matching-cycle-for-cycle-is-consp))))) +) + +(local +(in-theory (enable find-matching-prefix-for-cycle-n->m + find-matching-cycle-for-cycle-n->m)) +) + +(local +(defthm find-matching-prefix-is-a-compatible-path-2 + (implies (and (compatible-path-p cycle n) + (bisimilar q m (first cycle) n vars) + (consp cycle) + (memberp q (states m)) + (next-statep (last-val cycle) (car cycle) n)) + (compatible-path-p (find-matching-prefix-for-cycle-n->m q m cycle n + vars) + m)) + :hints (("Goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize) + :in-theory (disable compatible-path-first-n-reduction + find-matching-cycle-for-cycle-is-consp-2) + :use ((:instance compatible-path-first-n-reduction + (i (find-prefix-index cycle + (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) + q + (states + m) m + cycle n + vars + nil))) + + (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states + m) + m + cycle n + vars nil)) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q + (states m) m + cycle n + vars nil)))) + (p (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil)))) + (:instance find-matching-cycle-for-cycle-is-consp-2))))) +) + + +(local +(defthm find-matching-cycle-is-a-compatible-path-2 + (implies (and (compatible-path-p cycle n) + (bisimilar q m (first cycle) n vars) + (consp cycle) + (memberp q (states m)) + (next-statep (last-val cycle) (car cycle) n)) + (compatible-path-p (find-matching-cycle-for-cycle-n->m q m cycle n + vars) + m)) + :hints (("Goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize) + :in-theory (disable compatible-path-last-n-reduction + find-matching-cycle-for-cycle-is-consp-2) + :use ((:instance compatible-path-last-n-reduction + (i (find-prefix-index + cycle + (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) + q + (states + m) m + cycle n + vars + nil))) + + (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states + m) + m + cycle n + vars nil)) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q + (states m) m + cycle n + vars nil)))) + (p (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil)))) + (:instance find-matching-cycle-for-cycle-is-consp-2))))) +) + +(local +(defthm consp-last-next-state-p-reduction + (implies (and (compatible-path-p (append p q) m) + (true-listp p) + (true-listp q) + (consp p) + (consp q)) + (next-statep (last-val p) (first q) m)) + :rule-classes nil) +) + +(local +(defthm append-of-prefix-and-cycle-is-weird-path + (implies (and (compatible-path-p cycle m) + (next-statep (last-val cycle) (first cycle) m) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (true-listp cycle) + (memberp q (states n))) + (equal (append (find-matching-prefix-for-cycle-m->n cycle m q n + vars) + (find-matching-cycle-for-cycle-m->n cycle m q n + vars)) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n cycle m + (list q) + q + (states n) n + vars nil)))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable find-matching-cycle-for-cycle-is-consp) + :use ((:instance first-last-append-reduction + (n (find-prefix-index cycle + (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars + nil))) + + (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (x (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (:instance find-matching-cycle-for-cycle-is-consp))))) +) + +(local +(defthm append-of-prefix-and-cycle-is-weird-path-2 + (implies (and (compatible-path-p cycle n) + (next-statep (last-val cycle) (first cycle) n) + (bisimilar q m (first cycle) n vars) + (consp cycle) + (true-listp cycle) + (memberp q (states m))) + (equal (append (find-matching-prefix-for-cycle-n->m q m cycle n + vars) + (find-matching-cycle-for-cycle-n->m q m cycle n + vars)) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m (list q) + q + (states m) m + cycle n + vars nil)))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable find-matching-cycle-for-cycle-is-consp-2) + :use ((:instance first-last-append-reduction + (n (find-prefix-index cycle + (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q + (states m) + m + cycle n + vars + nil))) + + (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states + m) + m + cycle n + vars nil)) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q + (states m) m + cycle n + vars nil)))) + (x (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil)))) + (:instance find-matching-cycle-for-cycle-is-consp-2))))) +) + +(local +(in-theory (disable append-of-prefix-and-cycle-is-weird-path + append-of-prefix-and-cycle-is-weird-path-2)) +) + +(local +(defthm matching-cycle-is-true-listp + (true-listp (find-matching-cycle-for-cycle-m->n cycle m q n vars))) +) + +(local +(defthm matching-cycle-is-true-listp-2 + (true-listp (find-matching-cycle-for-cycle-n->m q m cycle n vars))) +) + +(local +(defthm matching-prefix-is-true-listp + (true-listp (find-matching-prefix-for-cycle-m->n cycle m q n vars))) +) + +(local +(defthm matching-prefix-is-true-listp-2 + (true-listp (find-matching-prefix-for-cycle-n->m q m cycle n vars))) +) + +(local +(defthm next-state-of-prefix-is-first-cycle + (implies (and (compatible-path-p cycle m) + (next-statep (last-val cycle) (first cycle) m) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (true-listp cycle) + (memberp q (states n))) + (implies (consp (find-matching-prefix-for-cycle-m->n cycle m q n + vars)) + (next-statep (last-val (find-matching-prefix-for-cycle-m->n + cycle m q n vars)) + (first (find-matching-cycle-for-cycle-m->n + cycle m q n vars)) + n))) + :otf-flg t + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable find-prefix-with-index + find-prefix-and-cycle-produces-compatible-path + find-matching-prefix-for-cycle-m->n + find-matching-cycle-for-cycle-m->n + find-cycle-with-index + find-matching-cycle-for-cycle-is-consp + find-matching-prefix-and-cycle-for-cycle-m->n) + :use ((:instance append-of-prefix-and-cycle-is-weird-path) + (:instance find-matching-cycle-for-cycle-is-consp) + (:instance find-prefix-and-cycle-produces-compatible-path + (seen (list q)) + (path nil)) + (:instance consp-last-next-state-p-reduction + (m n) + (p (find-matching-prefix-for-cycle-m->n + cycle m q n vars)) + (q (find-matching-cycle-for-cycle-m->n + cycle m q n vars))))))) +) + +(local +(defthm next-state-of-prefix-is-first-cycle-2 + (implies (and (compatible-path-p cycle n) + (next-statep (last-val cycle) (first cycle) n) + (bisimilar q m (first cycle) n vars) + (consp cycle) + (true-listp cycle) + (memberp q (states m))) + (implies (consp (find-matching-prefix-for-cycle-n->m q m cycle n + vars)) + (next-statep (last-val (find-matching-prefix-for-cycle-n->m + q m cycle n vars)) + (first (find-matching-cycle-for-cycle-n->m + q m cycle n vars)) + m))) + :otf-flg t + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable find-prefix-with-index + find-prefix-and-cycle-produces-compatible-path-2 + find-matching-prefix-for-cycle-n->m + find-matching-cycle-for-cycle-n->m + find-cycle-with-index + find-matching-cycle-for-cycle-is-consp-2 + find-matching-prefix-and-cycle-for-cycle-n->m) + :use ((:instance append-of-prefix-and-cycle-is-weird-path-2) + (:instance find-matching-cycle-for-cycle-is-consp-2) + (:instance find-prefix-and-cycle-produces-compatible-path-2 + (seen (list q)) + (path nil)) + (:instance consp-last-next-state-p-reduction +;; (m n) + (p (find-matching-prefix-for-cycle-n->m + q m cycle n vars)) + (q (find-matching-cycle-for-cycle-n->m + q m cycle n vars))))))) +) + +;; So we have proved that matching-path is consp and that find-matching-prefix +;; is compatible. Now we need to prove that last-val of matching-path and first +;; of find-matching-prefix are next-states. Why is that? This is because +;; last-val of find-matching-prefix is bisimilar to last-val of prefix, and we +;; know that car of find-matching-prefix is the bisimilar witness. + + +(local +(defthm car-of-prefix-and-cycle + (implies (and (bisimilar (first cycle) m q n vars) + (force (<= (len seen) (len (states n)))) + (compatible-path-p path n) + (compatible-path-p (append path + (find-matching-path-for-path-m->n + cycle m q n vars)) + n) + (consp cycle) + (memberp q (states n)) + (next-statep (last-val cycle) (car cycle) m) + (compatible-path-p cycle m)) + (equal (car (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q (states n) n vars path))) + (if (consp path) (car path) q))) + :otf-flg t + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-m->n cycle m seen q (states + n) n + vars + path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm car-of-prefix-and-cycle-2 + (implies (and (bisimilar q m (first cycle) n vars) + (force (<= (len seen) (len (states m)))) + (compatible-path-p path m) + (compatible-path-p (append path + (find-matching-path-for-path-n->m + q m cycle n vars)) + m) + (consp cycle) + (memberp q (states m)) + (next-statep (last-val cycle) (car cycle) n) + (compatible-path-p cycle n)) + (equal (car (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q (states m) m cycle n vars path))) + (if (consp path) (car path) q))) + :otf-flg t + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-n->m seen q (states + m) + m + cycle n + vars + path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(in-theory (disable find-matching-prefix-for-cycle-m->n + find-matching-cycle-for-cycle-m->n + find-matching-prefix-for-cycle-n->m + find-matching-cycle-for-cycle-n->m)) +) + +(local +(defthm matching-prefix-consp + (implies (and (compatible-path-p cycle m) + (next-statep (last-val cycle) (first cycle) m) + (bisimilar (first cycle) m q n vars) + (true-listp cycle) + (consp cycle) + (memberp q (states n)) + (consp (find-matching-prefix-for-cycle-m->n cycle m q n vars))) + (equal (car (find-matching-prefix-for-cycle-m->n cycle m q n vars)) + (car (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n vars nil))))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable car-of-prefix-and-cycle + car-append-reduction + find-prefix-with-index find-cycle-with-index) + :use ((:instance append-of-prefix-and-cycle-is-weird-path) + (:instance car-append-reduction + (x (find-matching-prefix-for-cycle-m->n + cycle m q n vars)) + (y (find-matching-cycle-for-cycle-m->n + cycle m q n vars))))))) + +) + +(local +(defthm matching-prefix-consp-2 + (implies (and (compatible-path-p cycle n) + (next-statep (last-val cycle) (first cycle) n) + (bisimilar q m (first cycle) n vars) + (true-listp cycle) + (consp cycle) + (memberp q (states m)) + (consp (find-matching-prefix-for-cycle-n->m q m cycle n vars))) + (equal (car (find-matching-prefix-for-cycle-n->m q m cycle n vars)) + (car (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m cycle n vars nil))))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable car-of-prefix-and-cycle-2 + car-append-reduction + find-prefix-with-index find-cycle-with-index) + :use ((:instance append-of-prefix-and-cycle-is-weird-path-2) + (:instance car-append-reduction + (x (find-matching-prefix-for-cycle-n->m + q m cycle n vars)) + (y (find-matching-cycle-for-cycle-n->m + q m cycle n vars))))))) + +) + +(local +(defthm matching-prefix-not-consp + (implies (and (compatible-path-p cycle m) + (next-statep (last-val cycle) (first cycle) m) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (true-listp cycle) + (memberp q (states n)) + (not (consp (find-matching-prefix-for-cycle-m->n cycle m q n + vars)))) + (equal (find-matching-cycle-for-cycle-m->n cycle m q n vars) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n vars nil)))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :use append-of-prefix-and-cycle-is-weird-path))) +) + +(local +(defthm matching-prefix-not-consp-2 + (implies (and (compatible-path-p cycle n) + (next-statep (last-val cycle) (first cycle) n) + (bisimilar q m (first cycle) n vars) + (consp cycle) + (true-listp cycle) + (memberp q (states m)) + (not (consp (find-matching-prefix-for-cycle-n->m q m cycle n + vars)))) + (equal (find-matching-cycle-for-cycle-n->m q m cycle n vars) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m cycle n vars nil)))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :use append-of-prefix-and-cycle-is-weird-path-2))) +) + +;; The next and final property should be that the next state of the last of the +;; cycle is the first of the cycle. Once I do that, I would go home-free with +;; the final theorems. + + +(local +(defthm witness-is-next-state-of-last-val + (implies (and (consp cycle) + (true-listp cycle) + (subset seen (states n)) + (uniquep seen) + (compatible-path-p cycle m) + (memberp q (states n)) + (bisimilar (first cycle) m q n vars) + (next-statep (last-val cycle) (first cycle) m)) + (next-statep (last-val + (mv-nth 2 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q (states n) n vars path))) + (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q (states n) n vars path)) + n))) +) + +(local +(defthm witness-is-next-state-of-last-val-2 + (implies (and (consp cycle) + (true-listp cycle) + (subset seen (states m)) + (uniquep seen) + (compatible-path-p cycle n) + (memberp q (states m)) + (bisimilar q m (first cycle) n vars) + (next-statep (last-val cycle) (first cycle) n)) + (next-statep (last-val + (mv-nth 2 + (find-matching-prefix-and-cycle-for-cycle-n->m + seen q (states m) m cycle n vars path))) + (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-n->m + seen q (states m) m cycle n vars path)) + m))) +) + +;; OK, so we have proved that the witness is the next state of the +;; last-val. Now of course, we have to know that the witness is the first thing +;; that is picked up by find-cycle. + + +(local +(defun seen-compatible-with-path (cycle seen path) + (if (endp seen) (endp path) + (and (equal (car path) (car seen)) + (seen-compatible-with-path cycle (rest seen) (last-n (len cycle) path))))) +) + +(local +(defthm consp-len-consp + (implies (and (consp cycle) + (<= (len cycle) (len q))) + (consp q)) + :rule-classes nil) +) + +(local +(defthm consp-last-n-append-reduction + (implies (and (consp q) + (consp p)) + (consp (last-n (len q) (append p q))))) +) + +(local +(defthm car-to-car-for-append + (implies (and (seen-compatible-with-path cycle seen (append p q)) + (consp seen) + (force (consp p))) + (equal (car p) (car seen)))) +) + +(local +(defthm snoc-car + (equal (car (snoc x e)) + (if (consp x) (car x) e))) +) + +(local +(defthm last-n-not-consp + (not (consp (last-n (len p) p)))) +) + +(local +(defthm last-append-reduction + (implies (and (integerp i) + (<= 0 i) + (<= i (len p))) + (equal (last-n i (append p q)) + (append (last-n i p) q)))) +) + +(local +(defthm len-<-1=>not-consp + (implies (< (len x) 1) + (not (consp x)))) +) + +(local +(defthm snoc-append-compatible-reduction + (implies (and (seen-compatible-with-path cycle seen path) + (equal e (car q)) + (consp q) + (force (equal (len path) (* (len cycle) (len seen)))) + (force (<= (len cycle) (len path))) + (equal (len cycle) (len q))) + (seen-compatible-with-path cycle (snoc seen e) (append path q))) + :otf-flg t + :hints (("Goal" + :induct (seen-compatible-with-path cycle seen path) + :in-theory (disable first-last-append-reduction-2) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm find-prefix-and-cycle-has-seen-compatible + (implies (and (consp cycle) + (memberp q seen) + (true-listp seen) + (equal (len path) (* (len cycle) (1- (len seen)))) + (seen-compatible-with-path cycle seen (append path + (find-matching-path-for-path-m->n + cycle m q n vars))) + (bisimilar (first cycle) m q n vars) + (<= (len seen) (len (states n))) + (next-statep (last-val cycle) (first cycle) m) + (compatible-path-p cycle m)) + (seen-compatible-with-path cycle + (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q (states n) n vars + path))) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q (states n) n vars + path)))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m seen q (states n) n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm find-prefix-and-cycle-has-seen-compatible-2 + (implies (and (consp cycle) + (memberp q seen) + (true-listp seen) + (equal (len path) (* (len cycle) (1- (len seen)))) + (seen-compatible-with-path cycle seen (append path + (find-matching-path-for-path-n->m + q m cycle n vars))) + (bisimilar q m (first cycle) n vars) + (<= (len seen) (len (states m))) + (next-statep (last-val cycle) (first cycle) n) + (compatible-path-p cycle n)) + (seen-compatible-with-path cycle + (del-last (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-n->m + seen q (states m) m + cycle n vars + path))) + (mv-nth 2 (find-matching-prefix-and-cycle-for-cycle-n->m + seen q (states m) m + cycle n vars + path)))) + :hints (("Goal" + :induct (find-matching-prefix-and-cycle-for-cycle-n->m + seen q (states m) m cycle n vars path) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + + +(local +(defthm car-is-witness + (implies (and (consp (find-cycle cycle seen witness path)) + (seen-compatible-with-path cycle seen path)) + (equal (car (find-cycle cycle seen witness path)) + witness))) +) + +(local +(defthm last-val-of-cycle-is-last-val-of-prefix-and-cycle + (implies (and (compatible-path-p cycle m) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (next-statep (last-val cycle) (first cycle) m) + (true-listp cycle) + (memberp q (states n))) + (equal (last-val (find-matching-cycle-for-cycle-m->n + cycle m q n vars)) + (last-val (mv-nth 2 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n vars + nil))))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable find-matching-prefix-and-cycle-for-cycle-m->n) + :use ((:instance append-of-prefix-and-cycle-is-weird-path) + (:instance find-matching-cycle-for-cycle-is-consp) + (:instance last-val-append-reduction + (x (find-matching-prefix-for-cycle-m->n + cycle m q n vars)) + (y (find-matching-cycle-for-cycle-m->n + cycle m q n vars))))))) +) + +(local +(defthm last-val-of-cycle-is-last-val-of-prefix-and-cycle-2 + (implies (and (compatible-path-p cycle n) + (bisimilar q m (first cycle) n vars) + (consp cycle) + (next-statep (last-val cycle) (first cycle) n) + (true-listp cycle) + (memberp q (states m))) + (equal (last-val (find-matching-cycle-for-cycle-n->m + q m cycle n vars)) + (last-val (mv-nth 2 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m cycle n vars + nil))))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable find-matching-prefix-and-cycle-for-cycle-n->m) + :use ((:instance append-of-prefix-and-cycle-is-weird-path-2) + (:instance find-matching-cycle-for-cycle-is-consp-2) + (:instance last-val-append-reduction + (x (find-matching-prefix-for-cycle-n->m + q m cycle n vars)) + (y (find-matching-cycle-for-cycle-n->m + q m cycle n vars))))))) +) + +(local +(in-theory (disable find-prefix-with-index find-cycle-with-index)) +) + +(local +(defthm del-last-has-len-<=-states + (implies (and (compatible-path-p cycle m) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (next-statep (last-val cycle) (first cycle) m) + (true-listp cycle) + (memberp q (states n))) + (<= (len (del-last + (mv-nth 0 (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n vars nil)))) + (len (states n)))) + :hints (("Goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize) + :in-theory (disable uniquep-subset-reduction + del-last-seen-is-unique-p) + :use ((:instance uniquep-subset-reduction + (x (del-last + (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n vars + nil)))) + (y (states n))) + (:instance del-last-seen-is-unique-p + (seen (list q)) + (states (states n)) + (path nil))))) + :rule-classes :linear) +) + +(local +(defthm next-state-of-last-of-find-cycle-is-first-of-find-cycle + (implies (and (compatible-path-p cycle m) + (bisimilar (first cycle) m q n vars) + (consp cycle) + (next-statep (last-val cycle) (first cycle) m) + (true-listp cycle) + (memberp q (states n))) + (next-statep (last-val (find-matching-cycle-for-cycle-m->n + cycle m q n vars)) + (first (find-matching-cycle-for-cycle-m->n + cycle m q n vars)) + n)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :in-theory (disable find-matching-cycle-for-cycle-is-consp + uniquep-subset-reduction + last-val-of-cycle-is-last-val-of-prefix-and-cycle + car-is-witness + witness-is-next-state-of-last-val) + :do-not-induct t + :expand (find-matching-cycle-for-cycle-m->n cycle m q n vars) + :use ((:instance find-matching-cycle-for-cycle-is-consp) + (:instance witness-is-next-state-of-last-val + (path nil) + (seen (del-last + (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil))))) + (:instance car-is-witness + (seen (del-last + (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (witness (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil))) + (path (mv-nth 2 + (find-matching-prefix-and-cycle-for-cycle-m->n + cycle m (list q) q (states n) n + vars nil)))) + (:instance + last-val-of-cycle-is-last-val-of-prefix-and-cycle))) + ("Subgoal 2.2" + :in-theory (disable find-prefix-and-cycle-has-seen-compatible) + :use ((:instance find-prefix-and-cycle-has-seen-compatible + (seen (list q)) + (path nil)))) + ("Subgoal 1" + :in-theory (enable find-matching-cycle-for-cycle-m->n)))) +) + +(local +(defthm next-state-of-last-of-find-cycle-is-first-of-find-cycle-2 + (implies (and (compatible-path-p cycle n) + (bisimilar q m (first cycle) n vars) + (consp cycle) + (next-statep (last-val cycle) (first cycle) n) + (true-listp cycle) + (memberp q (states m))) + (next-statep (last-val (find-matching-cycle-for-cycle-n->m + q m cycle n vars)) + (first (find-matching-cycle-for-cycle-n->m + q m cycle n vars)) + m)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :in-theory (disable find-matching-cycle-for-cycle-is-consp-2 + uniquep-subset-reduction + last-val-of-cycle-is-last-val-of-prefix-and-cycle-2 + car-is-witness + witness-is-next-state-of-last-val-2) + :do-not-induct t + :expand (find-matching-cycle-for-cycle-n->m q m cycle n vars) + :use ((:instance find-matching-cycle-for-cycle-is-consp-2) + (:instance witness-is-next-state-of-last-val-2 + (path nil) + (seen (del-last + (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil))))) + (:instance car-is-witness + (seen (del-last + (mv-nth 0 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil)))) + (witness (mv-nth 1 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil))) + (path (mv-nth 2 + (find-matching-prefix-and-cycle-for-cycle-n->m + (list q) q (states m) m + cycle n + vars nil)))) + (:instance + last-val-of-cycle-is-last-val-of-prefix-and-cycle-2))) + ("Subgoal 2.2" + :in-theory (disable find-prefix-and-cycle-has-seen-compatible-2) + :use ((:instance find-prefix-and-cycle-has-seen-compatible-2 + (seen (list q)) + (path nil)))) + ("Subgoal 1" + :in-theory (enable find-matching-cycle-for-cycle-n->m)))) +) + +(local +(in-theory (disable witness-is-next-state-of-last-val + witness-is-next-state-of-last-val-2 + consp-last-n-append-reduction + car-to-car-for-append + snoc-car + last-n-not-consp + last-n-append-reduction + len-<-1=>not-consp + snoc-append-compatible-reduction + find-prefix-and-cycle-has-seen-compatible + find-prefix-and-cycle-has-seen-compatible-2 + car-is-witness + last-val-of-cycle-is-last-val-of-prefix-and-cycle + last-val-of-cycle-is-last-val-of-prefix-and-cycle-2)) +) + +(local +(defthm matching-ppath-is-compatible + (implies (and (compatible-ppath-p p m) + (modelp m) + (modelp n) + (bisimilar-equiv m n vars)) + (compatible-ppath-p (find-matching-periodic-path-m->n p m n vars) + n)) + :hints (("Goal" + :in-theory (disable modelp-characterization) + :use ((:instance modelp-characterization) + (:instance modelp-characterization (m n)))))) + +) + +(local +(defthm matching-ppath-is-compatible-2 + (implies (and (compatible-ppath-p p n) + (modelp n) + (modelp m) + (bisimilar-equiv m n vars)) + (compatible-ppath-p (find-matching-periodic-path-n->m m p n vars) + m)) + :hints (("Goal" + :in-theory (disable modelp-characterization) + :use ((:instance modelp-characterization) + (:instance modelp-characterization (m n)))))) +) + +(local +(in-theory (disable compatible-ppath-p find-matching-periodic-path-m->n + modelp-characterization restricted-formulap + find-matching-periodic-path-n->m)) +) + +(local +(defthm bisimilar-models-have-same-ltl-semantics-1 + (implies (and (bisimilar-equiv m n vars) + (modelp m) + (modelp n) + (subset vars (variables m)) + (subset vars (variables n)) + (restricted-formulap f vars)) + (implies (ltl-semantics f m) + (ltl-semantics f n))) + :hints (("Goal" + :cases ((compatible-ppath-p (ltl-semantics-witness f n) n))) + ("Subgoal 1" + :in-theory (disable ltl-semantics-necc ltl-semantics-necc-expanded + ltl-ppath-semantics-cannot-distinguish-between-equal-labels + matching-ppath-is-compatible-2 + ppath-and-its-matching-ppath-have-same-labels-2) + :use ((:instance ppath-and-its-matching-ppath-have-same-labels-2 + (ppath (ltl-semantics-witness f n))) + (:instance ltl-semantics-necc-expanded + (ppath (find-matching-periodic-path-n->m + m (ltl-semantics-witness f n) n vars))) + (:instance matching-ppath-is-compatible-2 + (p (ltl-semantics-witness f n))) + (:instance + ltl-ppath-semantics-cannot-distinguish-between-equal-labels + (p (find-matching-periodic-path-n->m + m (ltl-semantics-witness f n) n vars)) + (q (ltl-semantics-witness f n))))))) +) + +(local +(defthm bisimilar-models-have-same-ltl-semantics-2 + (implies (and (bisimilar-equiv m n vars) + (modelp m) + (modelp n) + (subset vars (variables m)) + (subset vars (variables n)) + (restricted-formulap f vars)) + (implies (ltl-semantics f n) + (ltl-semantics f m))) + :hints (("Goal" + :cases ((compatible-ppath-p (ltl-semantics-witness f m) m))) + ("Subgoal 1" + :in-theory (disable ltl-semantics-necc ltl-semantics-necc-expanded + ltl-ppath-semantics-cannot-distinguish-between-equal-labels + matching-ppath-is-compatible + ppath-and-its-matching-ppath-have-same-labels) + :use ((:instance ppath-and-its-matching-ppath-have-same-labels + (ppath (ltl-semantics-witness f m))) + (:instance ltl-semantics-necc-expanded + (m n) + (ppath (find-matching-periodic-path-m->n + (ltl-semantics-witness f m) m n vars))) + (:instance matching-ppath-is-compatible + (p (ltl-semantics-witness f m))) + (:instance + ltl-ppath-semantics-cannot-distinguish-between-equal-labels + (q (find-matching-periodic-path-m->n + (ltl-semantics-witness f m) m n vars)) + (p (ltl-semantics-witness f m))))))) +) + +(local +(in-theory (disable ltl-semantics ltl-semantics-necc ltl-semantics-necc-expanded)) +) + +(DEFTHM bisimilar-models-have-same-ltl-semantics + (implies (and (bisimilar-equiv m n vars) + (restricted-formulap f vars) + (subset vars (variables m)) + (subset vars (variables n)) + (modelp m) + (modelp n)) + (equal (ltl-semantics f m) + (ltl-semantics f n))) + :hints (("Goal" + :use ((:instance bisimilar-models-have-same-ltl-semantics-1) + (:instance bisimilar-models-have-same-ltl-semantics-2)))) + :rule-classes nil) + + + + + diff --git a/books/workshops/2003/ray-matthews-tuttle/support/certify.lsp b/books/workshops/2003/ray-matthews-tuttle/support/certify.lsp new file mode 100644 index 0000000..1d649ac --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/certify.lsp @@ -0,0 +1,123 @@ +#| + + certify.lisp + ~~~~~~~~~~~~ + +The collection of events below provides a proof of our compositional reduction +algorithm in ACL2. The script works in v2-7, but takes an inordinate amount of +time (about 24 hours on a 1.8GHz P3 machine running GCL on top of +linux). Admittedly, the proof is not optimized and the rewrite rules are not +that great, but I am too tired to look at that at this moment. + +To see the proof silently go thru, just type (ld "certify.lisp") and that will +work. To see ACL2 work thru the proof, simply comment out the first line of +this file and do the ld. + +|# + +(set-inhibit-output-lst '(proof-tree prove)) + +(ubt! 1) + +;; This is simply Pete's total order book. I have it in the directory so that I +;; dont have to change the path-names in the different books that call it. + +(certify-book "total-order") +(u) + +;; We add some other functionality to total-order, including keys etc. to +;; support reasoning about vectors. We use this book here since it has +;; definitions of memberp. + +(certify-book "apply-total-order") +(u) + +;; This is the records book provide with the distribution of ACL2. This book is +;; terribly important for us, since everything we do is with respect to this book. + +(certify-book "records") +(u) + +;; We just define a collection of functions for flat sets in ACL2. This book is +;; used in the context of our proof. This is not intended to be a general-purpose +;; book on (even flat) sets. + +(certify-book "sets") +(u) + +;; This book models the syntax and semantics of LTL. We have managed to define +;; the semantics with respect to eventually periodic paths. Of course, we moved +;; the actual function in concrete-ltl.lisp. Please see the accompanying note +;; for concrete-ltl, and the actual file ltl.lisp, for explanation as to what we +;; did and why. + +(certify-book "ltl") +(u) + +;; Just a trivial book justifying that conjunctive reduction is sound. + +(certify-book "conjunction") +(u) + +;; This is one hell of a book. It should be cleaned up when I have time, but I +;; have not done that yet. This book proves that bisimilar Kripke Structures +;; have the same ltl-semantics. Notice we needed to define bisimilarity with +;; respect to vars. For explanation, please refer to our paper. + +(certify-book "bisimilarity") +(u) + +;; We define the bisimulation relation for circuit models, which are special +;; types of Kripke Structures built out of our finite state machine +;; representations defined below. + +(certify-book "circuit-bisim") +(u) + +;; In this book, we model circuits or finite state machines. These are +;; efficient representations of Kripke Structures. + +(certify-book "circuits") +(u) + +;; This book verifies the cone of influence reduction implementation in ACL2. + +(certify-book "cone-of-influence") +(u) + +;; This book proves the final theorem about compositional reductions. + +(certify-book "reductions") +(u) + +;; This does not have any technical material at all. But the book allows us to +;; rewrite the ltl-semantics function into a function that we can efficiently +;; execute. In the underlying lisp, we replace calls to this efficient function +;; ltl-semantics-hack by a sys-call calling the external model checker (SMV). + +(certify-book "impl-hack" 0 t :defaxioms-okp t) +(u) + +;; Note: The book concrete-ltl is not used in the rest of the materials any +;; more. The book is present simply as a demonstration that we could actually +;; define the semantics of LTL. The proof of the theorem +;; ltl-ppath-semantics-cannot-distinguish-between-equal-labels used to take a +;; lot of time with v2-6, and considering the relative slowdown between v2-6 +;; and v2-7, I did not experiment with that proof on v2-7 using +;; concrete-ltl. The proof has therefore been removed from this book. I do wish +;; to leave the comment here that the proof is not very trivial (actually I +;; also simplified the theorem a lot when I changed from concrete-ltl-semantics +;; to ltl-ppath-semantics which has the property encapsulated.) although very +;; simple at the high level. The proof simply inducts using the induction +;; suggested by concrete-ltl-semantics. However, I still find reasoning about +;; mutually recursive functions difficult in ACL2, and I did not want to +;; clutter the scripts with those theorems. (After all, if an implementation of +;; ltl-ppath-semantics does not satisfy that theorem, then we need to change +;; the definition rather than the theorem...:->) + + +(certify-book "concrete-ltl") +(u) + +(set-inhibit-output-lst '(proof-tree)) + diff --git a/books/workshops/2003/ray-matthews-tuttle/support/circuit-bisim.lisp b/books/workshops/2003/ray-matthews-tuttle/support/circuit-bisim.lisp new file mode 100644 index 0000000..3740910 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/circuit-bisim.lisp @@ -0,0 +1,726 @@ +(in-package "ACL2") + +#| + + circuit-bisim.lisp + ~~~~~~~~~~~~~~~~~~ + +In this book, we define a specific bisimilarity relation +evaluation-eq. Roughly, two "circuit states" are evaluation-eq if they match on +a specific collection of variables. We prove that evaluation-eq is a +bisimilarity relation. In a later book, we will prove that this bisimilarity +relation holds between the "Kripke Structure of a circuit" and the "Kripke +Structure of the cone of influence of the circuit". That will enable us to +prove that the two kripke structures satisfy the same LTL formula when +restricted by vars. + +|# + +(include-book "ltl") + +(in-theory (disable subset-of-empty-is-empty + subset-of-nil-is-nil)) + +(in-theory (enable subset set-intersect)) + +(defun evaluation-eq (p q vars) + (if (endp vars) T + (and (equal (<- p (first vars)) + (<- q (first vars))) + (evaluation-eq p q (rest vars))))) + +;; We prove evaluation-eq is symmetric here, but I dont want to deal with loop +;; stoppers so we prove it only for the purpose of use hints. + +(defthm evaluation-eq-is-symmetric + (equal (evaluation-eq p q vars) + (evaluation-eq q p vars)) + :rule-classes nil) + +(defun evaluation-eq-member-p (st states vars) + (if (endp states) nil + (if (evaluation-eq st (first states) vars) T + (evaluation-eq-member-p st (rest states) vars)))) + +(defun evaluation-eq-member (st states vars) + (if (endp states) nil + (if (evaluation-eq st (first states) vars) + (first states) + (evaluation-eq-member st (rest states) vars)))) + +(defthm member-is-memberp + (implies (evaluation-eq-member-p p states vars) + (memberp (evaluation-eq-member p states vars) + states))) + +(defthm member-is-evaluation-eq + (implies (evaluation-eq-member-p p states vars) + (evaluation-eq p (evaluation-eq-member p states vars) + vars))) + +(defun-sk strict-evaluation-p (st vars) + (forall v (implies (not (memberp v vars)) + (not (<- st v))))) + +(defthm strict-evaluation-p-expanded + (implies (and (strict-evaluation-p st vars) + (not (memberp v vars))) + (not (<- st v))) + :hints (("Goal" + :use strict-evaluation-p-necc))) + +(defun strict-evaluation-list-p (vars states) + (if (endp states) T + (and (strict-evaluation-p (first states) vars) + (strict-evaluation-list-p vars (rest states))))) + +(defun evaluation-p (st vars) + (if (endp vars) T + (and (booleanp (<- st (first vars))) + (evaluation-p st (rest vars))))) + +(defun only-evaluations-p (states vars) + (if (endp states) T + (and (evaluation-p (first states) vars) + (only-evaluations-p (rest states) vars)))) + +;; I think we can remove the all-evaluations-p from defun-sk to +;; defun. But I am feeling lazy at least now to do it. + +(defun-sk all-evaluations-p (states vars) + (forall st + (implies (evaluation-p st vars) + (evaluation-eq-member-p st states vars)))) + +(defun evaluation-eq-subset-p (m-states n-states vars) + (if (endp m-states) T + (and (evaluation-eq-member-p (first m-states) n-states vars) + (evaluation-eq-subset-p (rest m-states) n-states vars)))) + +(defthm evaluation-eq-subset-to-member + (implies (and (evaluation-eq-subset-p m-states n-states vars) + (memberp p m-states)) + (evaluation-eq-member-p p n-states vars))) + +(defun truthp-label (label s) + (if (endp label) t + (and (equal (<- s (first label)) T) + (truthp-label (rest label) s)))) + +(defun only-truth-p (states m) + (if (endp states) T + (and (truthp-label (label-of (first states) m) (first states)) + (only-truth-p (rest states) m)))) + +(defun all-truthsp-label (label s vars) + (if (endp vars) T + (and (implies (equal (<- s (car vars)) T) + (memberp (car vars) label)) + (all-truthsp-label label s (rest vars))))) + +(defthm all-truthsp-label-expanded + (implies (and (all-truthsp-label label s vars) + (memberp v vars) + (equal (<- s v) T)) + (memberp v label))) + +(defun only-all-truths-p (states m vars) + (if (endp states) T + (and (all-truthsp-label (label-of (first states) m) (first states) vars) + (only-all-truths-p (rest states) m vars)))) + +(defun label-subset-vars (states m vars) + (if (endp states) T + (and (subset (label-of (first states) m) vars) + (label-subset-vars (rest states) m vars)))) + +(defthm label-subset-subset-reduction + (implies (and (label-subset-vars states m vars) + (memberp p states)) + (subset (label-of p m) vars))) + +;; Now for a few properties governing the next state. + +(defun-sk well-formed-transition-p (states-m trans-m states-n trans-n vars) + (forall (p q) + (implies (and (evaluation-eq p q vars) + (evaluation-p p vars) + (memberp p states-m) + (memberp q states-n) + (evaluation-p q vars)) + (evaluation-eq-subset-p (<- trans-m p) + (<- trans-n q) + vars)))) + +(defthm well-formed-transition-p-expanded + (implies (and (well-formed-transition-p states-m trans-m states-n trans-n vars) + (evaluation-eq p q vars) + (evaluation-p p vars) + (memberp p states-m) + (memberp q states-n) + (evaluation-p q vars)) + (evaluation-eq-subset-p (<- trans-m p) (<- trans-n q) vars)) + :hints (("Goal" + :use well-formed-transition-p-necc))) + +(in-theory (disable well-formed-transition-p well-formed-transition-p-necc)) + + +(defun transition-subset-p (states states-prime trans) + (if (endp states) T + (and (subset (<- trans (first states)) states-prime) + (transition-subset-p (rest states) states-prime trans)))) + +(defthm transition-subset-p-expanded + (implies (and (transition-subset-p states states-prime trans) + (memberp p states) + (memberp r (<- trans p))) + (memberp r states-prime))) + + +(defun circuit-modelp (m) + (and (only-evaluations-p (states m) (variables m)) + (all-evaluations-p (states m) (variables m)) + (strict-evaluation-list-p (variables m) (states m)) + (only-all-truths-p (states m) m (variables m)) + (only-truth-p (states m) m) + (label-subset-vars (states m) m (variables m)) + (transition-subset-p (states m) (states m) (transition m)) + (subset (initial-states m) (states m)) + (consp (states m)) + (next-states-in-states m (states m)))) + +;; And here is our bisimilarity relation + +(defun c-bisim-equiv (m n vars) + (and (circuit-modelp m) + (circuit-modelp n) + (subset vars (variables m)) + (subset vars (variables n)) + (well-formed-transition-p (states m) (transition m) (states n) (transition n) vars) + (well-formed-transition-p (states n) (transition n) (states m) (transition m) vars) + (evaluation-eq-subset-p (initial-states m) (initial-states n) vars) + (evaluation-eq-subset-p (initial-states n) (initial-states m) vars))) + + +(local +(defun circuit-bisim (p m q n vars) + (and (circuit-modelp m) + (circuit-modelp n) + (memberp p (states m)) + (memberp q (states n)) + (well-formed-transition-p (states m) (transition m) (states n) (transition n) vars) + (well-formed-transition-p (states n) (transition n) (states m) (transition m) vars) + (evaluation-eq-subset-p (initial-states m) (initial-states n) vars) + (evaluation-eq-subset-p (initial-states n) (initial-states m) vars) + (subset vars (variables m)) + (subset vars (variables n)) + (evaluation-eq p q vars))) +) + +;; Now that we have defined a bisimilar relation between circuit models, let us +;; prove that this is actually a bisimilar relation. + +;; So what do we need to have? Given two circuit models m and m', we need to +;; show that the bisimilarity witness from m to m' and from m' to m. + +(local +(defun c-bisimilar-initial-state-witness-m->n (s m n vars) + (declare (ignore m)) + (evaluation-eq-member s (initial-states n) vars)) +) + +(local +(defun c-bisimilar-initial-state-witness-n->m (m s n vars) + (declare (ignore n)) + (evaluation-eq-member s (initial-states m) vars)) +) + +(defthm all-evaluations-considers-an-evaluation-a-member + (implies (and (evaluation-p st vars) + (all-evaluations-p states vars)) + (evaluation-eq-member-p st states vars)) + :hints (("Goal" + :use all-evaluations-p-necc))) + +(in-theory (disable all-evaluations-p all-evaluations-p-necc)) + + +(local +(defthm c-bisimilar-equiv-implies-init->init-n->m + (implies (and (c-bisim-equiv m n vars) + (memberp s (initial-states n))) + (memberp (c-bisimilar-initial-state-witness-n->m m s n vars) + (initial-states m)))) +) + +(local +(defthm c-bisimilar-equiv-implies-init->init-m->n + (implies (and (c-bisim-equiv m n vars) + (memberp s (initial-states m))) + (memberp (c-bisimilar-initial-state-witness-m->n s m n vars) + (initial-states n)))) +) + +(local +(defthm subset-transitive-member + (implies (and (memberp s init) + (subset init states)) + (memberp s states))) +) + +(local +(defthm c-bisimilar-equiv-implies-bisimilar-initial-states-m->n + (implies (and (c-bisim-equiv m n vars) + (memberp s (initial-states m))) + (circuit-bisim s m + (c-bisimilar-initial-state-witness-m->n s m n vars) + n vars)) + :otf-flg t + :hints (("Goal" + :do-not '(generalize eliminate-destructors) + :do-not-induct t + :in-theory (disable member-is-memberp + evaluation-eq-subset-to-member) + :use ((:instance evaluation-eq-subset-to-member + (p s) + (m-states (initial-states m)) + (n-states (initial-states n))) + (:instance member-is-memberp + (p s) + (states (initial-states n))))))) +) + +(local +(defthm c-bisimilar-equiv-implies-bisimilar-initial-states-n->m + (implies (and (c-bisim-equiv m n vars) + (memberp s (initial-states n))) + (circuit-bisim (c-bisimilar-initial-state-witness-n->m m s n vars) + m s n vars)) + :otf-flg t + :hints (("Goal" + :do-not '(generalize eliminate-destructors) + :do-not-induct t + :in-theory (disable member-is-memberp + evaluation-eq-subset-to-member) + :use ((:instance evaluation-eq-subset-to-member + (p s) + (m-states (initial-states n)) + (n-states (initial-states m))) + (:instance member-is-memberp + (p s) + (states (initial-states m))) + (:instance + evaluation-eq-is-symmetric + (p (evaluation-eq-member s (initial-states m) vars)) + (q s)))))) +) + + +;; Now we go to our first difficult proof, showing that bisimilar +;; states have equal labels. + +;; (label-of s m) are only truths. + +(defthm truthp-label-from-only-truthp + (implies (and (only-truth-p states m) + (memberp s states)) + (truthp-label (label-of s m) s))) + +;; And all truths are present in the label. + +(defthm all-truths-p-from-only-all-truths-p + (implies (and (only-all-truths-p states m vars) + (memberp s states)) + (all-truthsp-label (label-of s m) s vars))) + +;; For every variable in (and vars label) they re members of vars and label. + +(defthm memberp-to-intersect-reduction + (implies (memberp v (set-intersect x y)) + (and (memberp v x) + (memberp v y))) + :rule-classes :forward-chaining) + +;; Since they are in vars, they must evaluate the same way in q. + +(defthm evaluation-eq-vars-reduction + (implies (and (evaluation-eq p q vars) + (memberp v vars)) + (equal (<- p v) + (<- q v)))) + +;; Thus, variables in (label-of p m) and vars will evaluate to T in q. + +(defthm variables-in-label-are-T-in-q + (implies (and (memberp v (set-intersect label vars)) + (truthp-label label p) + (evaluation-eq p q vars)) + (equal (<- q v) T))) + +(defthm only-truthsp-and-subset-to-subset + (implies (and (equal (<- q v) T) + (memberp v vars) + (subset vars variables) + (all-truthsp-label label q variables)) + (memberp v label))) + +(defthm truthp-label-to-subset + (implies (and (memberp v (set-intersect lp vars)) + (truthp-label lp p) + (evaluation-eq p q vars) + (subset vars variables) + (all-truthsp-label lq q variables)) + (memberp v lq))) + +;; And let us do a little trick to get ACL2 from memberp to subset + + +(defthm truthp-label-is-a-subset + (implies (and (truthp-label lp p) + (evaluation-eq p q vars) + (subset vars variables) + (all-truthsp-label lq q variables)) + (subset (set-intersect lp vars) + lq))) + +(local +(defthm subset-intersect-reduction + (implies (and (subset lp lq) + (subset lp vars)) + (subset lp (set-intersect lq vars)))) +) + +(local +(defthm truthp-label-intersect-is-a-subset + (implies (and (truthp-label lp p) + (evaluation-eq p q vars) + (subset vars variables) + (all-truthsp-label lq q variables)) + (subset (set-intersect lp vars) + (set-intersect lq vars)))) +) + +(local +(defthm c-bisimilar-states-have-labels-equal-aux + (implies (circuit-bisim p m q n vars) + (subset (set-intersect (label-of p m) vars) + (set-intersect (label-of q n) vars))) + :hints (("Goal" + :in-theory (disable truthp-label-intersect-is-a-subset) + :use ((:instance truthp-label-intersect-is-a-subset + (lp (label-of p m)) + (lq (label-of q n)) + (variables (variables n))))))) +) + +(local +(in-theory (enable set-equal)) +) + +(local +(defthm c-bisimilar-states-have-labels-equal + (implies (circuit-bisim p m q n vars) + (set-equal (set-intersect (label-of q n) vars) + (set-intersect (label-of p m) vars))) + :hints (("Goal" + :in-theory (disable c-bisimilar-states-have-labels-equal-aux) + :use ((:instance c-bisimilar-states-have-labels-equal-aux + (p q) + (m n) + (n m) + (q p)) + (:instance c-bisimilar-states-have-labels-equal-aux))) + ("Goal'''" + :use evaluation-eq-is-symmetric))) +) + +;; Now we start with the next states. + +(local +(defun c-bisimilar-transition-witness-m->n (p r m q n vars) + (declare (ignore p m)) + (evaluation-eq-member r (<- (transition n) q) vars)) +) + +(local +(defun c-bisimilar-transition-witness-n->m (p m q r n vars) + (declare (ignore q n)) + (evaluation-eq-member r (<- (transition m) p) vars)) +) + +(defthm evaluationp-for-subset + (implies (and (evaluation-p st variables) + (subset vars variables)) + (evaluation-p st vars))) + +(defthm evaluation-p-only-evaluations-reduction + (implies (and (only-evaluations-p states vars) + (memberp p states)) + (evaluation-p p vars))) + +(defthm r-is-evaluation-eq-member-p + (implies (and (evaluation-eq p q vars) + (well-formed-transition-p states-m trans-m states-n trans-n vars) + (memberp p states-m) + (memberp q states-n) + (evaluation-p p vars) + (evaluation-p q vars) + (memberp r (<- trans-m p))) + (evaluation-eq-member-p r (<- trans-n q) vars)) + :hints (("Goal" + :in-theory (disable well-formed-transition-p-expanded) + :use well-formed-transition-p-expanded))) + +(local +(defthm c-bisimilar-witness-member-of-states-m->n + (implies (and (circuit-bisim p m q n vars) + (next-statep p r m) + (memberp r (states m))) + (memberp (c-bisimilar-transition-witness-m->n p r m q n vars) + (states n))) + :hints (("Goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize) + :in-theory (enable next-statep)) + ("Goal'" + :in-theory (disable evaluationp-for-subset + r-is-evaluation-eq-member-p) + :use ((:instance r-is-evaluation-eq-member-p + (states-m (states m)) + (states-n (states n)) + (trans-m (transition m)) + (trans-n (transition n))) + (:instance evaluationp-for-subset + (st p) + (variables (variables m))) + (:instance evaluationp-for-subset + (st q) + (variables (variables n))))))) +) + +(local +(defthm c-bisimilar-witness-member-of-states-n->m + (implies (and (circuit-bisim p m q n vars) + (next-statep q r n) + (memberp r (states n))) + (memberp (c-bisimilar-transition-witness-n->m p m q r n vars) + (states m))) + :otf-flg t + :hints (("Goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize) + :in-theory (enable next-statep)) + ("Goal'" + :in-theory (disable evaluationp-for-subset + only-evaluations-p + all-evaluations-p + evaluation-p + subset + r-is-evaluation-eq-member-p) + :use ((:instance r-is-evaluation-eq-member-p + (states-n (states m)) + (states-m (states n)) + (q p) + (p q) + (trans-m (transition n)) + (trans-n (transition m))) + (:instance evaluationp-for-subset + (st p) + (variables (variables m))) + (:instance evaluationp-for-subset + (st q) + (variables (variables n))))) + ("Goal'''" + :use evaluation-eq-is-symmetric))) +) + +(local +(defthm c-bisimilar-witness-matches-transition-m->n + (implies (and (circuit-bisim p m q n vars) + (next-statep p r m)) + (next-statep q (c-bisimilar-transition-witness-m->n p r m q n vars) + n)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (enable next-statep)) + ("Goal'" + :in-theory (disable evaluationp-for-subset + r-is-evaluation-eq-member-p) + :use ((:instance r-is-evaluation-eq-member-p + (states-m (states m)) + (states-n (states n)) + (trans-m (transition m)) + (trans-n (transition n))) + (:instance evaluationp-for-subset + (st p) + (variables (variables m))) + (:instance evaluationp-for-subset + (st q) + (variables (variables n))))))) +) + +(local +(defthm c-bisimilar-witness-matches-transition-n->m + (implies (and (circuit-bisim p m q n vars) + (next-statep q r n)) + (next-statep p (c-bisimilar-transition-witness-n->m p m q r n vars) + m)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (enable next-statep)) + ("Goal'" + :in-theory (disable evaluationp-for-subset + only-evaluations-p + all-evaluations-p + evaluation-p + subset + r-is-evaluation-eq-member-p) + :use ((:instance r-is-evaluation-eq-member-p + (q p) + (p q) + (states-n (states m)) + (states-m (states n)) + (trans-m (transition n)) + (trans-n (transition m))) + (:instance evaluationp-for-subset + (st p) + (variables (variables m))) + (:instance evaluationp-for-subset + (st q) + (variables (variables n))))) + ("Goal'''" + :use evaluation-eq-is-symmetric))) +) + +(local +(defthm c-bisimilar-witness-produces-bisimilar-states-m->n + (implies (and (circuit-bisim p m q n vars) + (next-statep p r m)) + (circuit-bisim r m + (c-bisimilar-transition-witness-m->n p r m q n vars) + n vars)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (enable next-statep)) + ("Goal'" + :in-theory (disable evaluationp-for-subset + r-is-evaluation-eq-member-p) + :use ((:instance r-is-evaluation-eq-member-p + (states-m (states m)) + (states-n (states n)) + (trans-m (transition m)) + (trans-n (transition n))) + (:instance evaluationp-for-subset + (st p) + (variables (variables m))) + (:instance evaluationp-for-subset + (st q) + (variables (variables n))))))) +) + +(local +(defthm c-bisimilar-witness-produces-bisimilar-states-n->m + (implies (and (circuit-bisim p m q n vars) + (next-statep q r n)) + (circuit-bisim + (c-bisimilar-transition-witness-n->m p m q r n vars) + m r n vars)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (enable next-statep)) + ("Goal'" + :in-theory (disable evaluationp-for-subset + only-evaluations-p + all-evaluations-p + evaluation-p + subset + r-is-evaluation-eq-member-p) + :use ((:instance r-is-evaluation-eq-member-p + (q p) + (p q) + (states-n (states m)) + (states-m (states n)) + (trans-m (transition n)) + (trans-n (transition m))) + (:instance evaluationp-for-subset + (st p) + (variables (variables m))) + (:instance evaluationp-for-subset + (st q) + (variables (variables n))))) + ("Subgoal 3" + :use evaluation-eq-is-symmetric) + ("Subgoal 2" + :use evaluation-eq-is-symmetric) + ("Subgoal 1" + :use ((:instance evaluation-eq-is-symmetric + (p (evaluation-eq-member r (<- (transition m) p) + vars)) + (q r)))))) +) + +(local +(defthm circuit-modelp-is-modelp + (implies (circuit-modelp m) + (and (subset (initial-states m) (states m)) + (consp (states m)) + (next-states-in-states m (states m))))) +) + +(local +(in-theory (disable circuit-bisim circuit-modelp c-bisim-equiv + c-bisimilar-initial-state-witness-m->n + set-equal + c-bisimilar-transition-witness-m->n + c-bisimilar-initial-state-witness-n->m + c-bisimilar-transition-witness-n->m)) +) + +(local +(include-book "bisimilarity") +) + +(DEFTHM circuit-bisim-implies-same-ltl-semantics + (implies (and (circuit-modelp m) + (circuit-modelp n) + (c-bisim-equiv m n vars) + (subset vars (variables m)) + (subset vars (variables n)) + (restricted-formulap f vars)) + (equal (ltl-semantics f m) + (ltl-semantics f n))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :use + ((:functional-instance + bisimilar-models-have-same-ltl-semantics + (bisimilar-equiv (lambda (m n vars) + (c-bisim-equiv m n vars))) + (modelp (lambda (m) (circuit-modelp m))) + (bisimilar (lambda (p m q n vars) + (circuit-bisim + p m q n vars))) + (bisimilar-initial-state-witness-m->n + (lambda (s m n vars) + (c-bisimilar-initial-state-witness-m->n + s m n vars))) + (bisimilar-initial-state-witness-n->m + (lambda (m s n vars) + (c-bisimilar-initial-state-witness-n->m + m s n vars))) + (bisimilar-transition-witness-m->n + (lambda (p r m q n vars) + (c-bisimilar-transition-witness-m->n + p r m q n vars))) + (bisimilar-transition-witness-n->m + (lambda (p m q r n vars) + (c-bisimilar-transition-witness-n->m + p m q r n vars)))))))) + + diff --git a/books/workshops/2003/ray-matthews-tuttle/support/circuits.lisp b/books/workshops/2003/ray-matthews-tuttle/support/circuits.lisp new file mode 100644 index 0000000..0edb124 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/circuits.lisp @@ -0,0 +1,1146 @@ +(in-package "ACL2") + +#| + + circuits.lisp + ~~~~~~~~~~~~~ + +In this book, we discuss a procedure to construct Kripke Structures from +"circuit descriptions. A circuit in our world is a collection of variables, a +collection of equations, and a collection of equations. An equation is a +boolean evaluator of the current circuit valuaes producing the next state +function. We show that under certain "well-formed-ness constraints", our +procedure produces a valid model, in terms of the circuit-modelp predicate +defined earlier. + +|# + + +(include-book "circuit-bisim") + + +;; A circuit is a collection of variables, equations and initial states. We +;; will add equations to the macros, and tell you what is a good circuit. + +(defmacro equations (c) `(<- ,c :equations)) + +;; Now we define what it means for the equations to be consistent with the +;; variables of the circuit. + +(defun find-variables (equation) + (cond ((and (atom equation) (not (booleanp equation))) + (list equation)) + ((and (equal (len equation) 3) (memberp (second equation) '(& +))) + (set-union (find-variables (first equation)) + (find-variables (third equation)))) + ((and (equal (len equation) 2) (equal (first equation) '~)) + (find-variables (second equation))) + (t nil))) + +(defun-sk consistent-equation-record-p (vars equations) + (forall (v equation) + (implies (and (uniquep vars) + (memberp v vars) + (memberp equation (<- equations v))) + (subset (find-variables equation) vars)))) + +(defun cons-list-p (vars equations) + (if (endp vars) T + (and (consp (<- equations (first vars))) + (cons-list-p (rest vars) equations)))) + +;; OK, now let us define the function circuitp. + +(defun circuitp (C) + (and (only-evaluations-p (initial-states C) (variables C)) + (strict-evaluation-list-p (variables C) (initial-states C)) + (uniquep (variables C)) + (cons-list-p (variables C) (equations C)) + (consistent-equation-record-p (variables C) (equations C)))) + +;; Now let us try to create a Kripke Structure from the circuit. We need to +;; show that under (circuitp C), the kripke structure we produce is a +;; circuit-model-p. + +(defun assign-T (v states) + (if (endp states) nil + (cons (-> (first states) v T) + (assign-T v (rest states))))) + +(defun assign-nil (v states) + (if (endp states) nil + (cons (-> (first states) v nil) + (assign-nil v (rest states))))) + +;; Now we create all the states of the model. + +(defun create-all-evaluations (vars states) + (if (endp vars) states + (let ((rec-states (create-all-evaluations (cdr vars) states))) + (append (assign-t (car vars) rec-states) + (assign-nil (car vars) rec-states))))) + +;; Now let us create the label function. + +(defun label-fn-of-st (st vars) + (if (endp vars) nil + (if (equal (<- st (first vars)) T) + (cons (first vars) + (label-fn-of-st st (rest vars))) + (label-fn-of-st st (rest vars))))) + +(defun create-label-fn (states vars label) + (if (endp states) label + (create-label-fn (rest states) vars + (-> label (first states) + (label-fn-of-st (first states) vars))))) + +;; And finally the transitions. + +(defun apply-equation (equation st) + (cond ((atom equation) (if (booleanp equation) + equation + (<- st equation))) + ((equal (len equation) 2) + (case (first equation) + (~ (not (apply-equation (second equation) st))) + (t nil))) + ((equal (len equation) 3) + (case (second equation) + (& (and (apply-equation (first equation) st) + (apply-equation (third equation) st))) + (+ (or (apply-equation (first equation) st) + (apply-equation (third equation) st))) + (t nil))) + (t nil))) + +(defun produce-next-state (vars st equations) + (if (endp vars) st + (-> (produce-next-state (rest vars) st equations) + (first vars) + (apply-equation (<- equations (first vars)) st)))) + +(defun consistent-p-equations (vars eqn equations) + (if (endp vars) T + (and (memberp (<- eqn (first vars)) (<- equations (first vars))) + (consistent-p-equations (rest vars) eqn equations)))) + +(defun-sk next-state-is-ok (p q vars equations) + (exists eqn (and (consistent-p-equations vars eqn equations) + (evaluation-eq q (produce-next-state vars p eqn) vars)))) + +(defun create-next-states-of-p (p states vars equations) + (if (endp states) nil + (if (next-state-is-ok p (first states) vars equations) + (cons (first states) (create-next-states-of-p + p (rest states) vars equations)) + (create-next-states-of-p p (rest states) vars equations)))) + +(defun create-next-states (states states-prime vars equations) + (if (endp states) () + (-> + (create-next-states (rest states) states-prime vars equations) + (first states) + (create-next-states-of-p (first states) states-prime vars equations)))) + +(defun create-kripke (C) + (let ((vars (variables C)) + (equations (equations C)) + (initial-states (initial-states C))) + (let* ((states (create-all-evaluations vars (list ()))) + (label-fn (create-label-fn (set-union initial-states states) vars ())) + (transition (create-next-states (set-union initial-states states) + (set-union initial-states states) + vars equations))) + (>_ :states (set-union initial-states states) + :initial-states initial-states + :label-fn label-fn + :transition transition + :variables vars)))) + + +;; Since I have defined the Kripke model for a circuit, let us prove that it is +;; a circuit-model-p. + +;; We start with the initial states. + +;; The theorem that initial-states are subsets of states is trivial by +;; union. So there is nothing to prove. + +(local +(defthm initial-states-are-subset-of-states + (subset (initial-states (create-kripke C)) (states (create-kripke C)))) +) + +;; END of proofs on initial-states. + +;; OK, let us prove that create-label-fn is a valid label function. + +(local +(defthm label-fn-is-subset + (subset (label-fn-of-st st vars) vars)) +) + +(local +(defthm label-fn-of-st-is-truth-p-label + (truthp-label (label-fn-of-st st vars) st)) +) + +(local +(defthm label-fn-of-st-is-all-truths-p-label + (all-truthsp-label (label-fn-of-st st vars) st vars)) +) + +(local +(defun abs-only-all-truths-p (states label vars) + (if (endp states) T + (and (all-truthsp-label (<- label (first states)) (first states) vars) + (abs-only-all-truths-p (rest states) label vars)))) +) + +(local +(defthm abs-concrete-only-all-truthsp-reduction + (equal (only-all-truths-p states m vars) + (abs-only-all-truths-p states (label-fn m) vars)) + :hints (("Goal" + :in-theory (enable label-of)))) +) + +;; And now let us just prove abs-all-truthsp-label for the label-fn + + +(local +(defthm create-label-fn-does-not-mess-with-non-members + (implies (not (memberp s states)) + (equal (<- (create-label-fn states vars label) s) + (<- label s)))) +) + +(local +(defthm create-label-fn-creates-an-all-truthsp-label + (implies (memberp s states) + (equal (<- (create-label-fn states vars label) s) + (label-fn-of-st s vars)))) +) + +(local +(defthm label-fn-is-abs-only--all-truthsp + (abs-only-all-truths-p states (create-label-fn states vars label) vars) + :hints (("Subgoal *1/3" + :cases ((memberp (car states) (cdr states))) + :do-not-induct t))) +) + +(local +(defthm label-fn-is-only-all-truthsp + (only-all-truths-p (states (create-kripke C)) (create-kripke C) + (variables C))) +) + +(local +(in-theory (disable abs-concrete-only-all-truthsp-reduction)) +) + +(local +(defun abs-label-subset-vars (states label vars) + (if (endp states) T + (and (subset (<- label (first states)) vars) + (abs-label-subset-vars (rest states) label vars)))) +) + +(local +(defthm abs-label-subset-vars-is-same-as-concrete + (equal (label-subset-vars states m vars) + (abs-label-subset-vars states (label-fn m) vars)) + :hints (("Goal" + :in-theory (enable label-of)))) +) + +(local +(defthm create-label-fn-is-abs-label-subset-vars + (abs-label-subset-vars states (create-label-fn states vars label) vars) + :hints (("Subgoal *1/3" + :cases ((memberp (car states) (cdr states))) + :do-not-induct t))) +) + +(local +(defthm label-fn-is-label-subset-vars + (label-subset-vars (states (create-kripke C)) (create-kripke C) (variables + C))) +) + +(local +(in-theory (disable abs-label-subset-vars-is-same-as-concrete)) +) + +(local +(defun abs-only-truth-p (states label) + (if (endp states) T + (and (truthp-label (<- label (first states)) (first states)) + (abs-only-truth-p (rest states) label)))) +) + +(local +(defthm only-truth-p-abs-reduction + (equal (only-truth-p states m) + (abs-only-truth-p states (label-fn m))) + :hints (("Goal" + :in-theory (enable label-of)))) +) + +(local +(defthm label-fn-is-abs-only-truth-p + (abs-only-truth-p states (create-label-fn states vars label)) + :hints (("Subgoal *1/3" + :cases ((memberp (car states) (cdr states)))))) +) + +(local +(defthm label-fn-is-only-truth-p + (only-truth-p (states (create-kripke C)) (create-kripke C))) +) + +(local +(in-theory (disable only-truth-p-abs-reduction)) +) + +;; END of proofs for label function. + +;; Let us now work with the transition function. + +(local +(defthm create-next-states-is-subset-of-states-aux + (implies (memberp q (create-next-states-of-p p states vars equations)) + (memberp q states))) +) + +(local +(defthm create-next-states-of-p-subset-helper + (implies (subset states-prime (create-next-states-of-p p states vars + equations)) + (subset states-prime states))) +) + + +(local +(defthm create-next-states-is-subset-of-states + (subset (create-next-states-of-p p states vars equations) + states) + :hints (("Goal" + :use ((:instance create-next-states-of-p-subset-helper + (states-prime (create-next-states-of-p p states + vars equations))))))) +) + +(local +(defthm not-memberp-next-states-reduction + (implies (not (memberp s states)) + (equal (<- (create-next-states states states-prime vars equations) + s) + nil))) +) + +(local +(defthm memberp-next-state-reduction + (implies (memberp s states) + (equal (<- (create-next-states states states-prime vars equations) + s) + (create-next-states-of-p s states-prime vars equations))) + :hints (("Subgoal *1/3" + :cases ((equal s (car states)))))) +) + +(local +(defthm transition-subset-p-for-next-state + (transition-subset-p states states-prime + (create-next-states states states-prime vars equations)) + :hints (("Subgoal *1/2" + :cases ((memberp (car states) (cdr states)))))) +) + +(local +(defthm transition-subset-p-holds-for-kripke + (transition-subset-p (states (create-kripke C)) + (states (create-kripke C)) + (transition (create-kripke C)))) +) + +(local +(defthm next-states-in-states-concretized + (equal (next-states-in-states m states) + (transition-subset-p states (states m) (transition m))) + :hints (("Goal" + :in-theory (enable next-states-in-states)))) +) + +(local +(defthm next-states-in-states-holds-for-create-kripke + (next-states-in-states (create-kripke C) (states (create-kripke C)))) +) + + +;; END of proofs for transition function. + +;; BEGIN proofs for states + +;; first states is a consp + +(local +(defthm consp-states-for-consp-vars + (implies (consp states) + (consp (create-all-evaluations vars states)))) +) + +;; The following theorem is a hack. This theorem is known as a +;; type-prescription rule for append. Unfortunately, we need it as a rewrite +;; rule. + +(local +(in-theory (enable set-union)) +) + +(local +(defthm consp-union-reduction + (implies (consp y) + (consp (set-union x y)))) +) + +(local +(defthm create-kripke-is-consp-states + (consp (states (create-kripke C)))) +) + +;; OK let us prove that everything is boolean with create-all-evaluations + +(local +(defthm only-evaluations-p-union-reduction + (implies (and (only-evaluations-p init vars) + (only-evaluations-p states vars)) + (only-evaluations-p (set-union init states) vars))) +) + +;; OK that takes care of the set-union part. Now we only need to show the +;; create-all-evaluations produces only-evaluations-p + +(local +(defun boolean-p-states (v states) + (if (endp states) T + (and (booleanp (<- (first states) v)) + (boolean-p-states v (rest states))))) +) + +(local +(defun boolean-list-p-states (vars states) + (if (endp vars) T + (and (boolean-p-states (first vars) states) + (boolean-list-p-states (rest vars) states)))) +) + +;; Now can we prove that boolean-p-states holds for create-all-evaluations? + +(local +(defthm assign-t-produces-boolean-p + (boolean-p-states v (assign-T v states))) +) + +(local +(defthm assign-nil-produces-boolean-p + (boolean-p-states v (assign-nil v states))) +) + +(local +(defthm assign-T-remains-same-for-not-v + (implies (not (equal v v-prime)) + (equal (boolean-p-states v (assign-T v-prime states)) + (boolean-p-states v states)))) +) + +(local +(defthm assign-nil-remains-same-for-not-v + (implies (not (equal v v-prime)) + (equal (boolean-p-states v (assign-nil v-prime states)) + (boolean-p-states v states)))) +) + +(local +(defthm boolean-p-append-reduction + (equal (boolean-p-states v (append states states-prime)) + (and (boolean-p-states v states) + (boolean-p-states v states-prime)))) +) + +(local +(defthm boolean-p-create-non-member-reduction + (implies (not (memberp v vars)) + (equal (boolean-p-states v (create-all-evaluations vars states)) + (boolean-p-states v states))) + :hints (("Goal" + :induct (create-all-evaluations vars states) + :do-not-induct t))) +) + +(local +(defthm create-all-evaluations-for-member-is-boolean + (implies (memberp v vars) + (boolean-p-states v (create-all-evaluations vars states))) + :hints (("Goal" + :induct (create-all-evaluations vars states) + :do-not-induct t) + ("Subgoal *1/2" + :cases ((equal v (car vars)))))) +) + +(local +(defthm create-all-evaluations-is-boolean-list-p-aux + (implies (subset vars vars-prime) + (boolean-list-p-states vars + (create-all-evaluations vars-prime states)))) +) + +(local +(defthm create-all-evaluations-is-boolean-list-p + (boolean-list-p-states vars (create-all-evaluations vars states))) +) + +;; Can we prove that if we produce a boolean list then it is an evaluation? + +(local +(defun evaluation-witness-variable (vars st) + (if (endp vars) nil + (if (not (booleanp (<- st (first vars)))) + (first vars) + (evaluation-witness-variable (rest vars) st)))) +) + +(local +(defthm evaluation-p-from-witness + (implies (booleanp (<- st (evaluation-witness-variable vars st))) + (evaluation-p st vars))) +) + +(local +(defthm boolean-list-p-to-boolean-vars + (implies (and (boolean-list-p-states vars states) + (memberp v vars)) + (boolean-p-states v states))) +) + +(local +(defthm boolean-p-states-implies-boolean-v + (implies (and (boolean-p-states v states) + (memberp st states)) + (booleanp (<- st v)))) +) + +(local +(defthm boolean-p-states-to-evaluation-p + (implies (and (boolean-list-p-states vars states) + (memberp st states)) + (evaluation-p st vars))) +) + +(local +(defthm boolean-p-states-to-only-evaluation-p-aux + (implies (and (boolean-list-p-states vars states) + (subset states-prime states)) + (only-evaluations-p states-prime vars))) +) + +(local +(defthm boolean-p-states-to-only-evaluations-p + (implies (boolean-list-p-states vars states) + (only-evaluations-p states vars))) +) + +(local +(defthm create-all-evaluations-is-only-evaluations-p + (only-evaluations-p (create-all-evaluations vars states) vars)) +) + +(local +(defthm create-kripke-is-only-evaluations-p + (implies (circuitp C) + (only-evaluations-p (states (create-kripke C)) (variables C)))) +) + +;; The final predicate is all-evaluations-p. This is tricky, since it is +;; defined using defun-sk. We try to create a witness for all-evaluations-p. + +(local +(defun find-matching-states (st vars states) + (cond ((endp vars) states) + ((equal (<- st (first vars)) T) + (assign-t (first vars) + (find-matching-states st (rest vars) states))) + (t (assign-nil (first vars) + (find-matching-states st (rest vars) states))))) +) + +;; Let us first prove find-matching-states is a consp + +(local +(defthm find-matching-states-is-consp + (implies (consp states) + (consp (find-matching-states st vars states)))) +) + +;; Now let us prove that for every member of find-matching-states it is +;; evaluation-eq to st. + +(local +(defthm nth-member-reduction + (implies (and (< i (len x)) + (consp x)) + (memberp (nth i x) x))) +) + +(local +(defthm nth-member-reduction-2 + (implies (and (>= i (len x)) + (integerp i)) + (equal (nth i x) nil)) + :hints (("Goal" + :in-theory (enable zp)))) +) + +(local +(defthm assign-nil-produces-nil-member + (implies (memberp q (assign-nil v states)) + (equal (<- q v) nil))) +) + +(local +(defthm assign-t-produces-t-member + (implies (memberp q (assign-t v states)) + (equal (<- q v) t))) +) + +(local +(defthm assign-nil-produces-nil + (implies (and (consp states) + (integerp i)) + (not (<- (nth i (assign-nil v states)) v))) + :otf-flg t + :hints (("Goal" + :cases ((>= i (len (assign-nil v states)))) + :do-not-induct t) + ("Subgoal 2" + :in-theory (disable nth-member-reduction) + :use ((:instance nth-member-reduction + (x (assign-nil v states))))))) +) + +(local +(defthm assign-t-has-same-len + (equal (len (assign-t v states)) + (len states))) +) + +(local +(defthm assign-nil-has-same-len + (equal (len (assign-nil v states)) + (len states))) +) + +(local +(defthm len-consp-reduction + (implies (and (equal (len x) (len y)) + (consp x)) + (consp y))) +) + +(local +(defthm assign-t-produces-t + (implies (and (consp states) + (< i (len states)) + (integerp i)) + (equal (<- (nth i (assign-t v states)) v) t)) + :otf-flg t + :hints (("Goal" + :in-theory (disable nth-member-reduction) + :use ((:instance nth-member-reduction + (x (assign-t v states))))))) +) + +(local +(defthm assign-t-does-not-fuss + (implies (and (consp states) + (< i (len states)) + (integerp i) + (not (equal v v-prime))) + (equal (<- (nth i (assign-t v states)) v-prime) + (<- (nth i states) v-prime)))) +) + +(local +(defthm assign-nil-does-not-fuss + (implies (and (consp states) + (< i (len states)) + (integerp i) + (not (equal v v-prime))) + (equal (<- (nth i (assign-nil v states)) v-prime) + (<- (nth i states) v-prime)))) +) + +(local +(defthm len-of-find-matching-states-is-same + (equal (len (find-matching-states st vars states)) + (len states))) +) + +(local +(defthm find-matching-state-produces-equivalent-assignment + (implies (and (memberp v vars) + (consp states) + (integerp i) + (< i (len states)) + (evaluation-p st vars)) + (equal (<- (nth i (find-matching-states st vars states)) v) + (<- st v))) + :otf-flg t + :hints (("Goal" + :induct (find-matching-states st vars states) + :do-not '(eliminate-destructors generalize) + :do-not-induct t) + ("Subgoal *1/3.1" + :cases ((equal v (car vars)))) + ("Subgoal *1/2.1" + :cases ((equal v (car vars)))))) +) + +(local +(defun falsifier-evaluation-eq (p q vars) + (if (endp vars) nil + (if (not (equal (<- p (first vars)) + (<- q (first vars)))) + (first vars) + (falsifier-evaluation-eq p q (rest vars))))) +) + +(local +(defthm falsifier-means-evaluation-eq + (implies (equal (<- p (falsifier-evaluation-eq p q vars)) + (<- q (falsifier-evaluation-eq p q vars))) + (evaluation-eq p q vars))) +) + +(local +(defthm falsifier-not-member-to-evaluation-eq + (implies (not (memberp (falsifier-evaluation-eq p q vars) vars)) + (evaluation-eq p q vars))) +) + +(local +(defthm find-matching-states-evaluation-eq + (implies (and (consp states) + (integerp i) + (< i (len states)) + (evaluation-p st vars)) + (evaluation-eq (nth i (find-matching-states st vars states)) + st vars)) + :hints (("Goal" + :cases ((not (memberp + (falsifier-evaluation-eq + (nth i (find-matching-states st vars states)) + st vars) + vars)))))) +) + +(local +(defthm find-matching-is-evaluation-eq-concretized + (implies (and (consp states) + (evaluation-p st vars)) + (evaluation-eq (car (find-matching-states st vars states)) + st vars)) + :hints (("Goal" + :in-theory (disable find-matching-states-evaluation-eq) + :use ((:instance find-matching-states-evaluation-eq + (i 0)))))) +) + +(local +(defthm memberp-append-reduction + (equal (memberp a (append x y)) + (or (memberp a x) + (memberp a y)))) +) + +(local +(defthm member-assign-t-reduction + (implies (memberp e x) + (memberp (-> e v t) + (assign-t v x)))) +) + +(local +(defthm assign-t-subset-reduction + (implies (subset x y) + (subset (assign-t v x) + (assign-t v y)))) +) + +(local +(defthm member-assign-nil-reduction + (implies (memberp e x) + (memberp (-> e v nil) + (assign-nil v x)))) +) + +(local +(defthm assign-nil-subset-reduction + (implies (subset x y) + (subset (assign-nil v x) + (assign-nil v y)))) +) + +(local +(defthm append-subset-reduction-1 + (implies (subset x y) + (subset x (append y z)))) +) + +(local +(defthm append-subset-reduction-2 + (implies (subset x y) + (subset x (append z y)))) +) + +(local +(defthm find-matching-subset-reduction + (subset (find-matching-states st vars states) + (create-all-evaluations vars states))) +) + +(local +(defthm car-of-find-matching-is-member-of-all-evaluations + (implies (consp states) + (memberp (car (find-matching-states st vars states)) + (create-all-evaluations vars states)))) +) + +(local +(defthm evaluation-eq-memberp-from-memberp + (implies (and (evaluation-eq p q vars) + (memberp q states)) + (evaluation-eq-member-p p states vars))) +) + +(local +(defthm evalaution-eq-symmetry-hack + (implies (and (evaluation-eq p q vars) + (memberp p states)) + (evaluation-eq-member-p q states vars)) + :hints (("Goal" + :in-theory (disable evaluation-eq evaluation-eq-member-p + evaluation-eq-memberp-from-memberp) + :use ((:instance evaluation-eq-memberp-from-memberp + (p q) + (q p)) + (:instance evaluation-eq-is-symmetric))))) +) + +(local +(in-theory (disable evaluation-eq-memberp-from-memberp)) +) + +(local +(defthm create-all-evaluations-is-evaluation-eq-memberp + (implies (and (evaluation-p st vars) + (consp states)) + (evaluation-eq-member-p st (create-all-evaluations vars states) + vars)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable evalaution-eq-symmetry-hack) + :use ((:instance evalaution-eq-symmetry-hack + (q st) + (states (create-all-evaluations vars states)) + (p (car (find-matching-states st vars + states)))))))) +) + +(local +(defthm consp-states-to-all-evaluations-p + (implies (consp states) + (all-evaluations-p (create-all-evaluations vars states) vars)) + :hints (("Goal" + :use ((:instance (:definition all-evaluations-p) + (states (create-all-evaluations vars states))))))) +) + +(local +(defthm append-evaluation-eq-member-reduction + (implies (evaluation-eq-member-p st states vars) + (evaluation-eq-member-p st (set-union init states) vars))) +) + +(local +(defthm all-evaluations-p-union-reduction + (implies (all-evaluations-p states vars) + (all-evaluations-p (set-union init states) vars)) + :hints (("Goal" + :use ((:instance all-evaluations-p-necc) + (:instance (:definition all-evaluations-p) + (states (set-union init states))))))) +) + +(local +(defthm create-kripke-is-all-evaluations-p + (all-evaluations-p (states (create-kripke C)) + (variables c))) +) + +(local +(defthm variables-of-create-kripke-are-original-vars + (equal (variables (create-kripke C)) + (variables C))) +) + +(local +(defthm strict-evaluations-list-to-evaluation + (implies (and (strict-evaluation-list-p vars states) + (memberp st states)) + (strict-evaluation-p st vars))) +) + +(local +(defthm strict-evaluations-append-reduction + (implies (and (strict-evaluation-list-p vars states) + (strict-evaluation-list-p vars states-prime)) + (strict-evaluation-list-p vars (append states states-prime)))) +) + +(local +(defthm strict-evaluation-list-p-nth-reduction + (implies (and (strict-evaluation-list-p vars states) + (integerp i) + (< i (len states)) + (consp states)) + (strict-evaluation-p (nth i states) vars))) +) + +(local +(defthm assign-t-strict-evaluations-reduction + (implies (and (strict-evaluation-list-p vars states) + (memberp v vars) + (consp states) + (integerp i) + (< i (len states)) + (not (memberp v-prime vars))) + (not (<- (nth i (assign-t v states)) v-prime))) + :hints (("Goal" + :do-not-induct t + :in-theory (disable assign-t-does-not-fuss) + :use ((:instance assign-t-does-not-fuss) + (:instance strict-evaluation-p-necc + (v v-prime) + (st (nth i states))))))) +) + +(local +(defthm assign-nil-strict-evaluations-reduction + (implies (and (strict-evaluation-list-p vars states) + (memberp v vars) + (consp states) + (integerp i) + (< i (len states)) + (not (memberp v-prime vars))) + (not (<- (nth i (assign-nil v states)) v-prime))) + :hints (("Goal" + :do-not-induct t + :in-theory (disable assign-nil-does-not-fuss) + :use ((:instance assign-nil-does-not-fuss) + (:instance strict-evaluation-p-necc + (v v-prime) + (st (nth i states))))))) +) + +(local +(defthm strict-evaluations-assign-t-reduction + (implies (and (integerp i) + (consp states) + (strict-evaluation-list-p vars states) + (memberp v vars) + (< i (len states))) + (strict-evaluation-p (nth i (assign-t v states)) vars))) +) + +(local +(defthm strict-evaluations-assign-nil-reduction + (implies (and (integerp i) + (consp states) + (strict-evaluation-list-p vars states) + (memberp v vars) + (< i (len states))) + (strict-evaluation-p (nth i (assign-nil v states)) vars))) +) + +(local +(defun find-index (st states) + (if (endp states) 0 + (if (equal st (first states)) 0 + (1+ (find-index st (rest states)))))) +) + +(local +(defthm find-index-is-memberp + (implies (memberp st states) + (equal (nth (find-index st states) states) + st))) +) + +(local +(defthm find-index-returns-<-len + (implies (memberp st states) + (< (find-index st states) (len states))) + :rule-classes :linear) +) + +(local +(defthm strict-evaluation-for-memberp-assign-t + (implies (and (consp states) + (strict-evaluation-list-p vars states) + (memberp v vars) + (memberp st (assign-t v states))) + (strict-evaluation-p st vars)) + :hints (("Goal" + :do-not-induct t + :in-theory (disable assign-t-strict-evaluations-reduction + strict-evaluation-p) + :use ((:instance strict-evaluations-assign-t-reduction + (i (find-index st (assign-t v states)))))))) +) + +(local +(defthm strict-evaluation-for-memberp-assign-nil + (implies (and (consp states) + (strict-evaluation-list-p vars states) + (memberp v vars) + (memberp st (assign-nil v states))) + (strict-evaluation-p st vars)) + :hints (("Goal" + :do-not-induct t + :in-theory (disable assign-nil-strict-evaluations-reduction + strict-evaluation-p) + :use ((:instance strict-evaluations-assign-nil-reduction + (i (find-index st (assign-nil v states)))))))) +) + +(local +(in-theory (disable strict-evaluation-p)) +) + +(local +(defthm strict-evaluations-for-assign-t + (implies (and (consp states) + (strict-evaluation-list-p vars states) + (memberp v vars)) + (strict-evaluation-list-p vars (assign-t v states)))) +) + +(local +(defthm strict-evaluations-for-assign-nil + (implies (and (consp states) + (strict-evaluation-list-p vars states) + (memberp v vars)) + (strict-evaluation-list-p vars (assign-nil v states)))) +) + +(local +(defun null-list-p (states) + (if (endp states) T + (and (null (first states)) + (null-list-p (rest states))))) +) + +(local +(defthm strict-evaluation-p-cons-reduction + (implies (strict-evaluation-p st vars) + (strict-evaluation-p (-> st v t) (cons v vars))) + :hints (("Goal" + :expand (strict-evaluation-p (-> st v t) (cons v vars))))) +) + +(local +(defthm strict-evaluation-p-cons-reduction-2 + (implies (strict-evaluation-p st vars) + (strict-evaluation-p (-> st v nil) (cons v vars))) + :hints (("Goal" + :expand (strict-evaluation-p (-> st v nil) (cons v vars))))) +) + +(local +(defthm strict-evaluation-p-assign-reduction-t + (implies (strict-evaluation-list-p vars states) + (strict-evaluation-list-p (cons v vars) (assign-t v states)))) +) + +(local +(defthm strict-evaluation-p-assign-reduction-nil + (implies (strict-evaluation-list-p vars states) + (strict-evaluation-list-p (cons v vars) (assign-nil v states)))) +) + +(local +(defthm nil-is-strict-evaluation-p + (strict-evaluation-p nil vars) + :hints (("Goal" + :in-theory (enable strict-evaluation-p)))) +) + +(local +(defthm null-list-p-is-strict-evaluation-p + (implies (null-list-p states) + (strict-evaluation-list-p vars states))) +) + +(local +(defthm create-evaluations-is-strict-evaluation-list-p + (implies (and (consp states) + (null-list-p states) + (uniquep vars)) + (strict-evaluation-list-p + vars (create-all-evaluations vars states))) + :otf-flg t + :hints (("Goal" + :induct (create-all-evaluations vars states) + :do-not '(eliminate-destructors generalize) + :do-not-induct t) + ("Subgoal *1/2" + :in-theory (disable strict-evaluation-p-assign-reduction-t + strict-evaluation-p-assign-reduction-nil) + :use ((:instance strict-evaluation-p-assign-reduction-t + (states (create-all-evaluations (cdr vars) states)) + (vars (cdr vars)) + (v (car vars))) + (:instance strict-evaluation-p-assign-reduction-nil + (states (create-all-evaluations (cdr vars) states)) + (vars (cdr vars)) + (v (car vars))))))) +) + +(local +(defthm strict-evaluation-set-union-reduction + (implies (and (strict-evaluation-list-p vars init) + (strict-evaluation-list-p vars states)) + (strict-evaluation-list-p vars (set-union init states))) + :hints (("Goal" + :in-theory (enable set-union)))) +) + +(local +(defthm strict-evaluation-list-p-holds + (implies (circuitp C) + (strict-evaluation-list-p (variables C) (states (create-kripke C))))) +) + +(local +(in-theory (disable create-kripke)) +) + +(DEFTHM create-kripke-produces-circuit-model + (implies (circuitp C) + (circuit-modelp (create-kripke C)))) + diff --git a/books/workshops/2003/ray-matthews-tuttle/support/concrete-ltl.lisp b/books/workshops/2003/ray-matthews-tuttle/support/concrete-ltl.lisp new file mode 100644 index 0000000..c4da3ba --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/concrete-ltl.lisp @@ -0,0 +1,308 @@ +(in-package "ACL2") + +#| + + concrete-ltl.lisp + ~~~~~~~~~~~~~~~~~ + +In this book, we define functions to reason about concrete semantics of +LTL. This book is shipped with the certification of our compositional reduction +paper for the purpose of demonstration. We first define a mutually recusrive +clique that defines the semantics of LTL and then we define a single recursive +function to justify that definition. We then go ahead and prove some properties +about the functions. Our goal is to prove the properties that are necessary +about the mutually recursive4 clique as the properties we wish to export about +semantics of LTL. For conjunctive and cone of influence reductions, we need +basically two properties. + +(1) That the ltl semantics can be decomposed over conjunction. (Obvious from +definition) + +(2) That it is oblivious to paths that are bisimilar. + +We have removed the second part of the theorems from this book, primarily +because it was taking a humongous amount of time in v2-6, and I did not have +the guts to see how much time it takes to prove in v2-7. And further, we +contend that if we have defined the semantics of ltl such that the theorem +cannot be proved, then we need to consider redefining the semantics of +LTL. (This book, I hope will provide enough evidence that the semantics can be +defined.) Hence we reasoned completely using a function that is encapsulated +and known to satisfy this property. If the reader feels unsatisfied with this, +we can provide the actual theorems about ltl-periodic-path-emantics, (which are +actually slightly more general than those I exported from the constrained +functions). + +|# + +(include-book "ltl") + +;; Added for compatibility with previous versions of ACL2. + +(include-book "../../../../ordinals/e0-ordinal") +(set-well-founded-relation e0-ord-<) + +(mutual-recursion + +(defun ltl-periodic-path-semantics (f init prefix cycle label) + (declare (xargs :measure (cons (1+ (acl2-count f)) 0))) + (cond ((atom f) + (if (ltl-constantp f) + (equal f 'true) + (memberp f (<- label init)))) + ((equal (len f) 3) + (case (second f) + (& (and (ltl-periodic-path-semantics (first f) init prefix cycle + label) + (ltl-periodic-path-semantics (third f) init prefix cycle + label))) + (+ (or (ltl-periodic-path-semantics (first f) init prefix cycle + label) + (ltl-periodic-path-semantics (third f) init prefix cycle + label))) + (U (let* ((found-and-index + (find-state-satisfying-formula + (third f) init prefix cycle label + (+ 1 (len prefix) (len cycle)))) + (found (first found-and-index)) + (index (second found-and-index))) + (if (not found) + nil + (ltl-periodic-path-semantics* (first f) init prefix + cycle label index)))) + (W (let* ((found-and-index + (find-state-satisfying-formula + (third f) init prefix cycle label + (+ 1 (len prefix) (len cycle)))) + (found (first found-and-index)) + (index (second found-and-index))) + (if (not found) + (ltl-periodic-path-semantics* (first f) init prefix + cycle label + (+ 1 (len prefix) (len cycle))) + (ltl-periodic-path-semantics* (first f) init prefix + cycle label index)))) + (t nil))) + ((equal (len f) 2) + (case (first f) + (~ (not (ltl-periodic-path-semantics (second f) init prefix cycle + label))) + (G (ltl-periodic-path-semantics* (second f) init prefix + cycle label + (+ 1 (len prefix) (len cycle)))) + (F (let* ((found-and-index + (find-state-satisfying-formula + (second f) init prefix cycle label + (+ 1 (len prefix) (len cycle)))) + (found (first found-and-index))) + (if found t nil))) + (X (ltl-periodic-path-semantics (second f) (first prefix) + (if (endp (rest prefix)) + cycle + (rest prefix)) + cycle + label)) + (t nil))) + (t nil))) + +(defun ltl-periodic-path-semantics* (f init prefix cycle label dist) + (declare (xargs :measure (cons (1+ (acl2-count f)) (nfix dist)))) + (if (zp dist) t + (and (ltl-periodic-path-semantics f init prefix cycle label) + (ltl-periodic-path-semantics* f (first prefix) + (if (endp (rest prefix)) + cycle + (rest prefix)) + cycle label (1- dist))))) + +(defun find-state-satisfying-formula (f init prefix cycle label dist) + (declare (xargs :measure (cons (1+ (acl2-count f)) (nfix dist)))) + (cond ((zp dist) (list nil 0)) + ((ltl-periodic-path-semantics f init prefix cycle label) + (list t 0)) + (t (let* ((found-and-index + (find-state-satisfying-formula + f (first prefix) + (if (endp (rest prefix)) cycle (rest prefix)) + cycle label (1- dist))) + (found (first found-and-index)) + (ndx (second found-and-index))) + (list found (1+ ndx)))))) + +) + +;; Now we have ther semantics of LTL that we will call the spec. We now proceed +;; to define a singly recursive version that is equivalent to the spec. Our +;; proofs will be using the singly recursive definition critically in order to +;; get us to what we want. + +(defun ltl-semantics-single-recursion (f init prefix cycle label dist index) + (declare (xargs :measure (cons (1+ (acl2-count f)) (if (equal index 0) 0 (nfix dist))) + :otf-flg nil)) + + (if (equal index 0) + (cond ((atom f) + (if (ltl-constantp f) + (equal f 'true) + (memberp f (<- label init)))) + ((equal (len f) 3) + (case (second f) + (& (and (ltl-semantics-single-recursion (first f) init prefix cycle + label dist 0) + (ltl-semantics-single-recursion (third f) init prefix cycle + label dist 0))) + (+ (or (ltl-semantics-single-recursion (first f) init prefix cycle + label dist 0) + (ltl-semantics-single-recursion (third f) init prefix cycle + label dist 0))) + (U (let* ((found-and-index + (ltl-semantics-single-recursion + (third f) init prefix cycle label + (+ 1 (len prefix) (len cycle)) + 2)) + (found (first found-and-index)) + (ndx (second found-and-index))) + (if (not found) + nil + (ltl-semantics-single-recursion (first f) init prefix + cycle label ndx 1)))) + (W (let* ((found-and-index + (ltl-semantics-single-recursion + (third f) init prefix cycle label + (+ 1 (len prefix) (len cycle)) + 2)) + (found (first found-and-index)) + (ndx (second found-and-index))) + (if (not found) + (ltl-semantics-single-recursion (first f) init prefix + cycle label + (+ 1 (len prefix) (len + cycle)) + 1) + (ltl-semantics-single-recursion (first f) init prefix + cycle label ndx 1)))) + (t nil))) + ((equal (len f) 2) + (case (first f) + (~ (not (ltl-semantics-single-recursion (second f) init prefix cycle + label dist 0))) + (G (ltl-semantics-single-recursion (second f) init prefix + cycle label + (+ 1 (len prefix) (len cycle)) 1)) + (F (let* ((found-and-index + (ltl-semantics-single-recursion + (second f) init prefix cycle label + (+ 1 (len prefix) (len cycle)) + 2)) + (found (first found-and-index))) + (if found T nil))) + (X (ltl-semantics-single-recursion (second f) (first prefix) + (if (endp (rest prefix)) + cycle + (rest prefix)) + cycle + label dist 0)) + (t nil))) + (t nil)) + (if (equal index 1) + (if (zp dist) t + (and (ltl-semantics-single-recursion f init prefix cycle label dist 0) + (ltl-semantics-single-recursion f (first prefix) + (if (endp (rest prefix)) + cycle + (rest prefix)) + cycle label (1- dist) + 1))) + (if (equal index 2) + (cond ((zp dist) (list nil 0)) + ((ltl-semantics-single-recursion f init prefix cycle label dist 0) + (list t 0)) + (t (let* ((found-and-index + (ltl-semantics-single-recursion + f (first prefix) + (if (endp (rest prefix)) cycle (rest prefix)) + cycle label (1- dist) 2)) + (found (first found-and-index)) + (ndx (second found-and-index))) + (list found (1+ ndx))))) + nil)))) + + +;; So do we believe that this big hodge-podge is same as the mutually recursive +;; code? Well, let us prove it. + +(local + ;; [Jared] added this because the following proof broke when I built it into ACL2. + (in-theory (disable FOLD-CONSTS-IN-+))) + +(defthm single-and-mutually-recursive-code-same + (equal (ltl-semantics-single-recursion f init prefix cycle label dist index) + (if (equal index 0) + (ltl-periodic-path-semantics f init prefix cycle label) + (if (equal index 1) + (ltl-periodic-path-semantics* f init prefix cycle label dist) + (if (equal index 2) + (find-state-satisfying-formula f init prefix cycle + label dist) + nil)))) + :rule-classes nil) + +(defthm ltl-semantics-is-boolean + (if (not (equal i 2)) + (booleanp (ltl-semantics-single-recursion f init prefix cycle label + dist i)) + (and (booleanp (first (ltl-semantics-single-recursion f init prefix + cycle label dist + i))) + (integerp (second (ltl-semantics-single-recursion f init prefix + cycle label dist + i))))) + :rule-classes nil) + +(defthm ltl-semantics-0-is-boolean + (booleanp (ltl-semantics-single-recursion f init prefix cycle label dist 0)) + :hints (("Goal" + :use ((:instance single-and-mutually-recursive-code-same + (index 0))))) + :rule-classes :type-prescription) + +(defthm ltl-semantics-1-boolean + (booleanp (ltl-semantics-single-recursion f init prefix cycle label dist 1)) + :hints (("Goal" + :use ((:instance single-and-mutually-recursive-code-same + (index 1))))) + :rule-classes :type-prescription) + +(defthm ltl-semantics->2-boolean + (implies (and (not (equal i 0)) + (not (equal i 1)) + (not (equal i 2))) + (not (ltl-semantics-single-recursion f init prefix cycle label + dist i))) + :rule-classes :type-prescription) + +(defthm ltl-semantics-2-boolean + (booleanp (first (ltl-semantics-single-recursion f init prefix cycle label + dist 2))) + :hints (("Goal" + :use ((:instance ltl-semantics-is-boolean + (i 2))))) + :rule-classes :type-prescription) + +(defthm ltl-semantics-2-integer + (integerp (second (ltl-semantics-single-recursion f init prefix cycle label + dist 2))) + :hints (("Goal" + :use ((:instance ltl-semantics-is-boolean + (i 2))))) + :rule-classes :type-prescription) + +(defthm ltl-periodic-path-semantics-decomposed-for-conjunction + (implies (and ;; (ltl-formulap f) + (equal (len f) 3) + (equal (second f) '&)) + (equal (ltl-periodic-path-semantics f init prefix cycle label) + (and (ltl-periodic-path-semantics (first f) init prefix cycle + label) + (ltl-periodic-path-semantics (third f) init prefix cycle + label)))) + :rule-classes nil) diff --git a/books/workshops/2003/ray-matthews-tuttle/support/cone-of-influence.lisp b/books/workshops/2003/ray-matthews-tuttle/support/cone-of-influence.lisp new file mode 100644 index 0000000..890141b --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/cone-of-influence.lisp @@ -0,0 +1,1976 @@ +(in-package "ACL2") + +;; The following two lines are added for portability to v2-7.... + + +#| + + cone-of-influence.lisp + ~~~~~~~~~~~~~~~~~~~~~~ + +We implement a cone of influence reduction algorithm. Cone of influence is +(roughly) elimination of redundant variables. Given a collection of V variables, +we determine the closure V*, V =< V* =< (variables C) and a collection +E =< (equations C), such that for every variable in V*, the equation in E for +that variable corresponds to the equation in (equations C). We then claim that +the Kripke structure created from the cone-of-influence reduced circuit is +bisimilar with respect to V* to the Kripke Structure created from the original +circuit. + +|# + + +(include-book "circuits") + +;; Here are the two culprit rules that I need to disable to get the proof +;; faster. Just shows how naive a user I was when I did this proof. + +(in-theory (disable subset-of-nil-is-nil + subset-of-empty-is-empty)) + +(defun find-variables* (equation-list) + (if (endp equation-list) nil + (set-union (find-variables (first equation-list)) + (find-variables* (rest equation-list))))) + +(defun find-all-variables-1-pass (vars equations) + (if (endp vars) nil + (set-union (find-variables* (<- equations (first vars))) + (find-all-variables-1-pass (rest vars) equations)))) + +;; The following function find-all-variables is a difficult function to +;; admit. It computes the closure of a given set of variables (vars) with +;; respect to a collection of variables (variables) and a collection of +;; equations. + +(local +(in-theory (enable set-union)) +) + +(local +(defthm len-set-union-more-than-y + (<= (len y) + (len (set-union x y))) + :rule-classes :linear) +) + +(local +(defthm uniquep-member-reduction + (equal (memberp e (set-union x y)) + (or (memberp e x) + (memberp e y)))) +) + +(local +(defthm uniquep-union-reduction + (implies (and (uniquep x) + (uniquep y)) + (uniquep (set-union x y)))) +) + +(local +(defthm find-variables-is-unique + (uniquep (find-variables equations))) +) + +(local +(defthm find-variables*-is-unique + (uniquep (find-variables* equations))) +) + +(local +(defthm find-all-variables-1-pass-is-unique + (uniquep (find-all-variables-1-pass vars equations))) +) + +(defun del (e x) + (if (endp x) x + (if (equal e (first x)) + (rest x) + (cons (first x) (del e (rest x)))))) + +(local +(defthm len-del-reduction-1 + (implies (memberp e x) + (equal (len (del e x)) + (1- (len x)))) + :hints (("Goal" + :in-theory (enable len)))) +) + +(defun induction-hint-for-len-<= (x y) + (if (endp x) (list x y) + (induction-hint-for-len-<= (cdr x) (del (car x) y)))) + +(local +(defthm del-not-member-reduction + (implies (not (memberp e x)) + (equal (del e x) x))) +) + +(local +(defthm member-del-reduction + (implies (not (equal v e)) + (equal (memberp v (del e y)) + (memberp v y)))) +) + +(local +(defthm subset-del-member + (implies (and (not (memberp e x)) + (subset x y)) + (subset x (del e y)))) +) + +(local +(defthm uniquep-del-reduction + (implies (uniquep x) + (uniquep (del e x)))) +) + +(local +(defthm uniquep-and-subset-implies-len-<= + (implies (and (uniquep x) + (uniquep y) + (subset x y)) + (<= (len x) + (len y))) + :hints (("Goal" + :induct (induction-hint-for-len-<= x y) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm subset-from-union + (implies (and (subset x z) + (subset y z)) + (subset (set-union x y) z))) +) + +(local +(defthm subset-from-union-2 + (implies (and (subset (set-union x y) z) + (uniquep x) + (uniquep y)) + (and (subset x z) + (subset y z)))) +) + +(local +(include-book "../../../../arithmetic-2/meta/top") +) + +(local +(defthm del-e-to-cons-subset + (implies (subset (del e y) x) + (subset y (cons e x)))) +) + +(local +(defthm len-equal-to-set-equal + (implies (and (equal (len x) (len y)) + (uniquep x) + (uniquep y) + (subset x y)) + (subset y x)) + :hints (("Goal" + :induct (induction-hint-for-len-<= x y) + :do-not '(eliminate-destructors generalize) + :do-not-induct t) + ("Subgoal *1/2.1" + :in-theory (disable del-e-to-cons-subset) + :use ((:instance del-e-to-cons-subset + (e (car x)) + (x (cdr x))))))) +) + +(defun find-all-variables (vars variables equations) + (declare (xargs :measure (nfix (- (len variables) (len vars))) + :hints (("Goal" + :do-not-induct t + :in-theory (enable set-equal) + :do-not '(eliminate-destructors generalize))))) + (if (or (not (uniquep variables)) + (not (uniquep vars)) + (not (subset vars variables))) + vars + (let ((new-vars (set-union (find-all-variables-1-pass vars equations) + vars))) + (if (not (subset new-vars variables)) nil + (if (set-equal vars new-vars) vars + (find-all-variables new-vars variables equations)))))) + +(defun find-all-equations (vars equations eq-rec) + (if (endp vars) eq-rec + (find-all-equations (rest vars) equations + (-> eq-rec + (first vars) + (<- equations (first vars)))))) + +(defun remove-duplicate-occurrences (x) + (cond ((endp x) x) + ((memberp (first x) (rest x)) (remove-duplicate-occurrences (rest x))) + (t (cons (first x) (remove-duplicate-occurrences (rest x)))))) + +(defun corresponding-state (init vars) + (if (endp vars) nil + (-> (corresponding-state init (rest vars)) + (first vars) + (<- init (first vars))))) + +(defun corresponding-states (inits vars) + (if (endp inits) nil + (cons (corresponding-state (first inits) vars) + (corresponding-states (rest inits) vars)))) + +(defun cone-variables (vars C) + (find-all-variables + (set-intersect (remove-duplicate-occurrences vars) + (variables C)) + (variables C) + (equations C))) + +(defun cone-of-influence-reduction (C vars) + (let ((variables (cone-variables vars C))) + (>_ :variables variables + :initial-states (corresponding-states (initial-states C) variables) + :equations (find-all-equations variables (equations C) ())))) + +;; OK, so we have implemented the cone of influence reduction. Let us prove +;;that create-kripke of this reduced model is bisim-equiv to create-Kripke of +;; C. + +;; Notice that for the bisimilarity proof to go through, the variables that we +;; choose are the variables in the cone. So proving that the variables are subset +;; of the variables of cone is trivial. On the other hand, we need to prove that +;; the variables are subset of the original collection of variables. + +(local +(defthm find-all-variables-subset-of-variables + (implies (and (uniquep vars) + (uniquep variables) + (subset vars variables)) + (subset (find-all-variables vars variables equations) variables)) + :hints (("Goal" + :in-theory (disable subset-of-nil-is-nil + subset-of-empty-is-empty)))) +) + +;; OK, so we know find-all-variables-is-a-subset. We need to prove that vars is +;; a subset and uniquep, though. Now, vars is really remove-duplicates of +;; (set-intersect (remove-duplicates vars) (variables C)) + +(local +(defthm member-remove-duplicate-reduction + (equal (memberp e (remove-duplicate-occurrences x)) + (memberp e x))) +) + +(local +(defthm unique-duplicate-reduction + (uniquep (remove-duplicate-occurrences x))) +) + +(local +(defthm uniquep-intersect-reduction + (implies (and (uniquep x) + (uniquep y)) + (uniquep (set-intersect x y)))) +) + +(local +(defthm find-all-variables-is-unique + (implies (uniquep vars) + (uniquep (find-all-variables vars variables equations))) + :hints (("Goal" + :in-theory (disable subset-of-empty-is-empty)))) +) + +(local +(defthm subset-remove-reduction + (equal (subset (remove-duplicate-occurrences x) y) + (subset x y))) +) + +(local +(defthm subset-set-intersect-reduction + (equal (subset (set-intersect (remove-duplicate-occurrences x) y) z) + (subset (set-intersect x y) z)) + :hints (("Goal" + :in-theory (disable subset-of-empty-is-empty)))) +) + +;; And now check that we have done the trick. + +(local +(defthm variables-are-subset-of-original + (implies (circuitp C) + (subset (cone-variables vars C) + (variables (create-kripke C)))) + :hints (("Goal" + :in-theory (disable subset-of-nil-is-nil + subset-of-empty-is-empty) + :do-not-induct t))) +) + +(local +(defthm variables-are-subset-of-cone + (subset (cone-variables vars C) + (variables (create-kripke + (cone-of-influence-reduction C vars)))) + :hints (("Goal" + :in-theory (disable cone-variables)))) +) + +;; OK, so we have proved that the vars are subset of variables. Let us now work +;; on the initial states. + +(local +(defthm evaluation-eq-subset-reduction + (implies (and (subset vars-prime vars) + (evaluation-eq p q vars)) + (evaluation-eq p q vars-prime))) +) + +(local +(defthm evaluation-eq-member-subset-reduction + (implies (and (evaluation-eq-member-p init inits vars) + (subset vars-prime vars)) + (evaluation-eq-member-p init inits vars-prime))) +) + +(local +(defthm evaluation-eq-subset-subset-reduction + (implies (and (evaluation-eq-subset-p inits states vars) + (subset vars-prime vars)) + (evaluation-eq-subset-p inits states vars-prime))) +) + +(local +(defthm corresponding-states-are-evaluation-eq + (implies (uniquep vars) + (evaluation-eq init (corresponding-state init vars) vars))) +) + +(local +(defthm corresponding-state-is-member-of-corresponding-states + (implies (memberp init inits) + (memberp (corresponding-state init vars) + (corresponding-states inits vars)))) +) + +(local +(defthm evaluation-eq-memberp-of-corresponding-states + (implies (and (uniquep vars) + (memberp init inits)) + (evaluation-eq-member-p init (corresponding-states inits vars) + vars))) +) + +(local +(defthm evaluation-eq-subsets-reduction + (implies (uniquep vars) + (evaluation-eq-subset-p inits (corresponding-states inits vars) + vars))) +) + + +(local +(defthm initial-states-are-evaluation-eq + (implies (circuitp C) + (evaluation-eq-subset-p + (initial-states (create-kripke C)) + (initial-states + (create-kripke + (cone-of-influence-reduction C vars))) + (cone-variables vars C))) + :hints (("Goal" + :in-theory (disable subset-of-nil-is-nil + subset-of-empty-is-empty)))) +) + +(local +(defthm corresponding-states-are-evaluation-eq-2 + (implies (uniquep vars) + (evaluation-eq (corresponding-state init vars) init vars))) +) + +(local +(defthm evaluation-eq-memberp-of-corresponding-states-2 + (implies (and (uniquep vars) + (memberp init (corresponding-states inits vars))) + (evaluation-eq-member-p init inits + vars))) +) + +(local +(defthm evaluation-eq-subsets-reduction-2 + (implies (uniquep vars) + (evaluation-eq-subset-p (corresponding-states inits vars) inits + vars))) +) + +(local +(defthm initial-states-are-evaluation-eq-2 + (implies (circuitp C) + (evaluation-eq-subset-p + (initial-states + (create-kripke + (cone-of-influence-reduction C vars))) + (initial-states (create-kripke C)) + (cone-variables vars C)))) +) + +;; END of work on initial states. + +;; OK, now let us work on showing that cone-of-influence-reduction produces a +;; circuit model. This will follow if the cone of influence reduction actually +;; produces a circuit. We prove that in the lemmas below. + +;; We first prove that the initial states are only evaluations of the variables. + +(local +(defthm initial-states-are-evaluations-p + (implies (and (evaluation-p p variables) + (subset vars variables) + (uniquep variables)) + (evaluation-p (corresponding-state p vars) vars))) +) + +(local +(defthm corresponding-states-only-evaluations-p + (implies (and (only-evaluations-p init variables) + (subset vars variables) + (uniquep variables)) + (only-evaluations-p (corresponding-states init vars) vars))) +) + +(local +(defthm initial-states-of-cone-of-influence-are-only-evaluations-p + (implies (circuitp C) + (only-evaluations-p + (initial-states + (cone-of-influence-reduction C vars)) + (variables + (cone-of-influence-reduction C vars))))) +) + +;; Next we work on strict-evaluation-list-p. + +(local +(defthm not-memberp-to-corresponding-state + (implies (not (memberp v vars)) + (not (<- (corresponding-state init vars) v)))) +) + +(local +(defthm corresponding-state-strict-evaluation-p + (strict-evaluation-p (corresponding-state init vars) vars)) +) + +(local +(in-theory (disable strict-evaluation-p)) +) + +(local +(defthm initial-states-strict-evaluation-list-p + (strict-evaluation-list-p vars (corresponding-states inits vars))) +) + +(local +(defthm initial-cone-of-influence-states-are-strict-evaluation-list-p + (strict-evaluation-list-p + (variables + (cone-of-influence-reduction C vars)) + (initial-states + (cone-of-influence-reduction C vars))) + :hints (("Goal" + :in-theory (disable cone-variables)))) +) + +(local +(defthm variables-of-cone-are-unique-p + (implies (circuitp C) + (uniquep + (variables + (cone-of-influence-reduction C vars))))) +) + + +;; We come here to cons-list-p. + + +(local +(defun equation-equal-p (eqn-orig eqn-cone vars) + (if (endp vars) T + (and (equal (<- eqn-orig (first vars)) + (<- eqn-cone (first vars))) + (equation-equal-p eqn-orig eqn-cone (rest vars))))) +) + +(local +(defthm cons-list-p-equation-equal-reduction + (implies (equation-equal-p eqn-orig eqn-cone vars) + (equal (cons-list-p vars eqn-cone) + (cons-list-p vars eqn-orig)))) +) + +(local +(defthm find-equations-for-not-member-p + (implies (not (memberp v vars)) + (equal (<- (find-all-equations vars equations eqn-rec) v) + (<- eqn-rec v)))) +) + +(local +(defthm cons-list-p-subset-reduction + (implies (and (cons-list-p vars equations) + (subset vars-prime vars)) + (cons-list-p vars-prime equations))) +) + +(local +(defthm equations-of-cone-and-orig-are-equal + (implies (uniquep vars) + (equation-equal-p equations + (find-all-equations + vars equations eqn-rec) + vars)) + :hints (("Goal" + :induct (find-all-equations vars equations eqn-rec) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +(local +(defthm equations-of-cone-are-cons-list-p + (implies (circuitp C) + (cons-list-p (variables + (cone-of-influence-reduction C vars)) + (equations + (cone-of-influence-reduction C vars)))) + :hints (("Goal" + :in-theory (disable find-all-equations find-all-variables + cons-list-p-equation-equal-reduction) + :use ((:instance cons-list-p-equation-equal-reduction + (eqn-orig (equations C)) + (eqn-cone + (equations + (cone-of-influence-reduction C vars))) + (vars (variables + (cone-of-influence-reduction C vars)))))))) +) + +(local +(defthm find-variables-variables*-reduction + (implies (memberp equation equations) + (subset (find-variables equation) + (find-variables* equations)))) +) + +(local +(defthm find-variables-1-pass-reduction + (implies (and (memberp v vars) + (memberp equation (<- equations v))) + (subset (find-variables equation) + (find-all-variables-1-pass vars equations))) + :hints (("Subgoal *1/2" + :do-not-induct t + :do-not '(eliminate-destructors generalize) + :cases ((equal v (car vars)))) + ("Subgoal *1/2.1" + :in-theory (disable find-variables-variables*-reduction) + :use ((:instance find-variables-variables*-reduction + (equations (<- equations (first vars))))))) + :rule-classes nil) +) + +(local +(defthm find-all-variables-computes-closure + (implies (and (memberp v (find-all-variables vars variables equations)) + (uniquep variables) + (subset vars variables) + (uniquep vars) + (memberp equation (<- equations v))) + (subset (find-variables equation) + (find-all-variables vars variables equations))) + :hints (("Goal" + :induct (find-all-variables vars variables equations) + :do-not '(eliminate-destructors generalize) + :do-not-induct t) + ("Subgoal *1/2" + :in-theory (enable set-equal) + :use find-variables-1-pass-reduction))) +) + +(local +(in-theory (disable find-all-variables)) +) + +(local +(defthm find-all-variables-is-equation-record-p + (implies (and (subset vars variables) + (uniquep vars) + (uniquep variables)) + (consistent-equation-record-p + (find-all-variables vars variables equations) + equations)) + :otf-flg t + :hints (("Goal" + :do-not-induct t + :in-theory (disable find-all-variables-computes-closure) + :use ((:instance (:definition consistent-equation-record-p) + (vars (find-all-variables vars variables + equations))) + (:instance find-all-variables-computes-closure + (v (mv-nth 0 + (consistent-equation-record-p-witness + (find-all-variables vars variables + equations) + equations))) + (equation + (mv-nth 1 + (consistent-equation-record-p-witness + (find-all-variables vars variables + equations) + equations)))))))) +) + +;; So we have proved that find-all-variables produces a consistent record for +;; the original equations. Now we have to prove that if two equations are +;; equation-equal-p, then they are consistent-equation-record-p at the same +;; time. + +(local +(in-theory (disable consistent-equation-record-p)) +) + +(local +(defthm equation-equal-p-member-reduction + (implies (and (equation-equal-p eqn-orig eqn-cone vars) + (memberp v vars)) + (equal (<- eqn-cone v) + (<- eqn-orig v)))) +) + +(local +(defthm consistent-eqn-record-p-expanded + (implies (and (consistent-equation-record-p vars eqn-orig) + (uniquep vars) + (memberp v vars) + (memberp equation (<- eqn-orig v))) + (subset (find-variables equation) + vars)) + :hints (("Goal" + :use ((:instance consistent-equation-record-p-necc + (equations eqn-orig)))))) +) + +(local +(defthm equation-equal-p-to-consistent + (implies (and (equation-equal-p eqn-orig eqn-cone vars) + (uniquep vars) + (consistent-equation-record-p vars eqn-orig)) + (consistent-equation-record-p vars eqn-cone)) + :hints (("Goal" + :do-not-induct t + :in-theory (disable consistent-equation-record-p + consistent-equation-record-p-necc + mv-nth) + :expand (consistent-equation-record-p vars eqn-cone) + :use ((:instance consistent-equation-record-p-necc + (equation eqn-orig)))))) +) + +(local +(in-theory (disable consistent-equation-record-p + consistent-equation-record-p-necc)) +) + +(local +(defthm cone-of-influence-reduction-is-consistent + (implies (circuitp C) + (consistent-equation-record-p + (variables (cone-of-influence-reduction C vars)) + (equations (cone-of-influence-reduction C vars)))) + :hints (("Goal" + :use ((:instance equation-equal-p-to-consistent + (eqn-orig (equations C)) + (eqn-cone + (equations (cone-of-influence-reduction C vars))) + (vars (variables (cone-of-influence-reduction C vars)))))))) + +) + +(local +(defthm cone-of-influence-reduction-is-circuit-p + (implies (circuitp C) + (circuitp (cone-of-influence-reduction C vars))) + :hints (("Goal" + :in-theory (disable circuitp cone-of-influence-reduction) + :expand (circuitp (cone-of-influence-reduction C vars))))) +) + +(local +(defthm cone-of-influence-reduction-produces-circuit-model + (implies (circuitp C) + (circuit-modelp (create-kripke (cone-of-influence-reduction C vars)))) + :hints (("Goal" + :in-theory (disable circuitp circuit-modelp + create-kripke + cone-of-influence-reduction)))) +) + +;; OK, so the last thing we need to prove is that the transitions of m and n +;; are well-formed-transition-p. That means that we have to prove that if two +;; states are evaluation-eq with respect to vars, then the next states are +;; evaluation-eq with respect to vars. + +;; For simplifying the project let us first start with original circuit and get +;; to the cone of influence reduction. + +;; OK, so what do we need? Let us first prove that if r is in next-states of p, +;; then there exists an equation consistent with equations that takes from p to +;; r. + +;; We start with a couple of theorems about evaluation-eq + +(local +(defthm evaluation-eq-is-reflexive + (evaluation-eq x x vars)) +) + +(local +(defthm evaluation-eq-is-transitive + (implies (and (evaluation-eq p q vars) + (evaluation-eq q r vars)) + (evaluation-eq p r vars))) +) + +;; Now to the argument. If r is in next states of p, then there is an equation +;; taking p to r. + +;; We first prove that r is a valid next state of p. + +(local +(defthm next-state-member-implies-consistent-equation + (implies (memberp r (create-next-states-of-p p states vars equations)) + (next-state-is-ok p r vars equations))) +) + +;; Now if next-state-is-ok, then we know that there is a consistent equation +;; that takes p to r. + +(local +(defthm next-state-is-ok-to-consistent-p-equation + (implies (next-state-is-ok p r vars equations) + (consistent-p-equations + vars + (next-state-is-ok-witness p r vars equations) + equations))) +) + +(local +(defthm next-state-is-ok-p-to-actual + (implies (next-state-is-ok p r vars equations) + (evaluation-eq r (produce-next-state vars p + (next-state-is-ok-witness + p r vars equations)) + vars))) +) + +(local +(defthm thus-r-is-evaluation-eq-to-s + (implies (and (next-state-is-ok p r vars-orig equations-orig) + (evaluation-eq (produce-next-state vars-orig p + (next-state-is-ok-witness p r vars-orig + equations-orig)) + s + vars-cone) + (subset vars-cone vars-orig)) + (evaluation-eq r s vars-cone)) + :hints (("Goal" + :in-theory (disable next-state-is-ok-p-to-actual + evaluation-eq-subset-reduction + next-state-is-ok) + :do-not-induct t + :use ((:instance next-state-is-ok-p-to-actual + (vars vars-orig) + (equations equations-orig)) + (:instance evaluation-eq-subset-reduction + (p r) + (q (PRODUCE-NEXT-STATE + VARS-ORIG P + (NEXT-STATE-IS-OK-WITNESS P R VARS-ORIG + EQUATIONS-ORIG))) + (vars vars-orig) + (vars-prime vars-cone)))))) +) + +;; Thus r is evaluation-eq with respect to s if we can show that +;; produce-next-state produces something evaluation-eq to s. Now to show that +;; this implies r is evaluation-eq-member-p of transition of q, we need to show +;; that s is a member of states-cone and that there is a consistent equation +;; with respect to cone that takes q to s. Let us see that this analysis is +;; accurate. + + +(local +(defthm next-state-is-ok-from-consistent-eqn + (implies (and (consistent-p-equations vars eqn equations) + (evaluation-eq q (produce-next-state vars p eqn) vars)) + (next-state-is-ok p q vars equations))) +) + +(local +(in-theory (disable next-state-is-ok)) +) + +(local +(defthm memberp-of-next-state-from-consistent-equation + (implies (and (memberp s states-cone) + (next-state-is-ok q s vars-cone equations-cone)) + (memberp s (create-next-states-of-p q states-cone vars-cone + equations-cone)))) +) + +(local +(defthm memberp-not-using-next-states + (implies (and (memberp s states-cone) + (consistent-p-equations vars-cone eqn equations-cone) + (evaluation-eq s (produce-next-state vars-cone q eqn) vars-cone)) + (memberp s (create-next-states-of-p q states-cone vars-cone equations-cone)))) +) + +;; OK, so now, how do we show that s is a member of states? This is because +;; states are all-evaluations-p, and s is an evaluation-p as we will see. + + +(local +(defthm member-of-next-states-from-all-evaluations-p + (implies (and (all-evaluations-p states-cone vars-cone) + (evaluation-p s vars-cone) + (consistent-p-equations vars-cone eqn equations-cone) + (evaluation-eq s (produce-next-state vars-cone q eqn) vars-cone)) + (memberp + (evaluation-eq-member s states-cone vars-cone) + (create-next-states-of-p q states-cone vars-cone equations-cone))) + :hints (("Goal" + :do-not-induct t + :in-theory (disable memberp-not-using-next-states) + :use ((:instance memberp-not-using-next-states + (s (evaluation-eq-member s states-cone vars-cone))) + (:instance evaluation-eq-is-symmetric + (p s) + (q (evaluation-eq-member s states-cone vars-cone)) + (vars vars-cone)))))) +) + +(local +(defthm evaluation-eq-and-memberp-to-evaluation-eq-memberp + (implies (and (memberp q states) + (evaluation-eq p q vars)) + (evaluation-eq-member-p p states vars))) +) + +(defthm evaluation-eq-memberp-from-all-evaluations-p + (implies (and (all-evaluations-p states-cone vars-cone) + (evaluation-p s vars-cone) + (consistent-p-equations vars-cone eqn equations-cone) + (evaluation-eq s (produce-next-state vars-cone q eqn) + vars-cone)) + (evaluation-eq-member-p + s (create-next-states-of-p q states-cone vars-cone equations-cone) + vars-cone)) + :hints (("Goal" + :do-not-induct t + :in-theory (disable + evaluation-eq-and-memberp-to-evaluation-eq-memberp) + :use ((:instance evaluation-eq-and-memberp-to-evaluation-eq-memberp + (q (evaluation-eq-member s states-cone vars-cone)) + (p s) + (vars vars-cone) + (states (create-next-states-of-p + q states-cone vars-cone + equations-cone))))))) + +(local +(defthm evaluation-eq-and-memberp-to-memberp + (implies (and (evaluation-eq p q vars) + (evaluation-eq-member-p q states vars)) + (evaluation-eq-member-p p states vars))) +) + +(local +(defthm next-state-of-orig-to-evaluation-eq-member-p + (implies (and (memberp r (create-next-states-of-p p states-orig vars-orig + equations-orig)) + (evaluation-eq (produce-next-state vars-orig p + (next-state-is-ok-witness p r vars-orig + equations-orig)) + s + vars-cone) + (subset vars-cone vars-orig) + (all-evaluations-p states-cone vars-cone) + (evaluation-p s vars-cone) + (consistent-p-equations vars-cone eqn equations-cone) + (evaluation-eq s (produce-next-state vars-cone q eqn) + vars-cone)) + (evaluation-eq-member-p + r (create-next-states-of-p q states-cone vars-cone equations-cone) + vars-cone)) + :hints (("Goal" + :do-not-induct t + :in-theory (disable thus-r-is-evaluation-eq-to-s) + :use thus-r-is-evaluation-eq-to-s))) +) + +;; The theorem above guarantees that if we can get an s and an eqn with the +;; properties mentioned then we will be done. Our choice of s is +;; (produce-next-state vars-cone q eqn). Hence the only thing to prove is that +;; we can get a corresponding equation for s. + +(local +(defun create-corresponding-equation (vars equation-record vars-prime eqn eq-rec) + (if (endp vars) eq-rec + (-> (create-corresponding-equation (rest vars) equation-record vars-prime + eqn eq-rec) + (first vars) + (if (memberp (first vars) vars-prime) + (<- eqn (first vars)) + (first (<- equation-record (first vars))))))) +) + +;; OK, so why is this equation consistent with the cone? The argument is that +;; the cone of influence is well-formed-equation-record-p, and equation-equal-p +;; with respect to the variables of the cone. + +(local +(defthm equation-equal-to-set-reduction + (implies (not (memberp v vars)) + (equal (equation-equal-p eqn-orig (-> eqn-cone v a) vars) + (equation-equal-p eqn-orig eqn-cone vars)))) +) + +(local +(defthm create-corresponding-equation-is-equation-equal + (implies (and (subset vars-cone vars-orig) + (uniquep vars-cone)) + (equation-equal-p eqn-orig (create-corresponding-equation + vars-cone eqn-cone + vars-orig eqn-orig eq-rec) + + vars-cone))) +) + +(local +(defthm cons-consistent-eqn + (implies (and (consistent-p-equations vars eqn equation-record) + (memberp equation (<- equation-record v))) + (consistent-p-equations (cons v vars) (-> eqn v equation) + equation-record)) + :hints (("Subgoal *1/4" + :cases ((equal v (car vars)))))) +) + +(local +(defthm consistent-p-equation-memberp-reduction + (implies (and (consistent-p-equations vars eqn equations) + (memberp v vars)) + (memberp (<- eqn v) (<- equations v)))) +) + +(local +(defthm consistent-set-not-member + (implies (not (memberp v vars)) + (equal (consistent-p-equations vars (-> eqn v a) equations) + (consistent-p-equations vars eqn equations)))) +) + +(local +(defthm equation-equal-p-to-consistent-equation + (implies (and (equation-equal-p eqn-orig eqn-cone vars) + (consistent-p-equations vars eqn eqn-orig)) + (consistent-p-equations vars eqn eqn-cone))) +) + +(local +(defthm consistent-p-equations-to-consistent-p-equations + (implies (and (consistent-p-equations vars-orig eqn eqn-orig) + (cons-list-p vars-cone eqn-cone) + (equation-equal-p eqn-orig eqn-cone vars-cone) + (uniquep vars-orig) + (uniquep vars-cone)) + (consistent-p-equations + vars-cone + (create-corresponding-equation vars-cone eqn-cone vars-orig eqn + eq-rec) + eqn-cone)) + :otf-flg t + :hints (("Goal" + :induct (create-corresponding-equation vars-cone eqn-cone + vars-orig eqn eq-rec) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +;; OK so now we have created an equation eqn that is consistent with respect to +;; the cone. So the final proof requirement is that s is evaluation-eq to the +;; application of this equation. + +(local +(defun closed-eqn-record-p (eqn vars vars-prime) + (if (endp vars) T + (and (subset (find-variables (<- eqn (first vars))) vars-prime) + (closed-eqn-record-p eqn (rest vars) vars-prime)))) +) + +;; This predicate ensures that the variables of eqn are subsets of +;; vars-prime. Now let us show that this notion follows from equation-record-p. + +(local +(defthm closed-eqn-record-p-from-consistent-equation-record-p + (implies (and (consistent-equation-record-p vars-prime equations) + (uniquep vars-prime) + (subset vars vars-prime) + (consistent-p-equations vars eqn equations)) + (closed-eqn-record-p eqn vars vars-prime)) + :hints (("Subgoal *1/5" + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) +) + +;; And thus, by concretizing it, we have the following theorem: + +(local +(defthm closed-eqn-record-p-true-concretized + (implies (and (consistent-equation-record-p vars equations) + (uniquep vars) + (consistent-p-equations vars eqn equations)) + (closed-eqn-record-p eqn vars vars))) +) + +(local +(defthm apply-equation-produces-equal + (implies (and (evaluation-p p vars) + (evaluation-p q vars) + (subset (find-variables equation) vars) + (evaluation-eq p q vars)) + (equal (apply-equation equation p) + (apply-equation equation q))) + :hints (("Goal" + :induct (apply-equation equation p)))) +) + +(local +(defthm produce-next-state-not-memberp-vars-reduction + (implies (not (memberp v vars)) + (equal (<- (produce-next-state vars p equations) v) + (<- p v)))) +) + +(local +(defthm produce-next-state-vars-reduction + (implies (and (memberp v vars) + (uniquep vars)) + (equal (<- (produce-next-state vars p equations) v) + (apply-equation (<- equations v) p)))) +) + +(local +(defthm evaluation-eq-set-reduction + (implies (and (evaluation-eq p q vars) + (not (memberp v vars))) + (evaluation-eq (-> p v a) (-> q v b) vars))) +) + +(local +(defthm produce-next-state-is-evaluation-eq + (implies (and (evaluation-p p vars-prime) + (uniquep vars-prime) + (evaluation-p q vars-prime) + (uniquep vars-prime) + (uniquep vars) + (subset vars vars-prime) + (evaluation-eq p q vars-prime) + (closed-eqn-record-p eqn-cone vars vars-prime) + (equation-equal-p eqn-orig eqn-cone vars)) + (evaluation-eq + (produce-next-state vars p eqn-orig) + (produce-next-state vars q eqn-cone) + vars)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :in-theory (disable apply-equation-produces-equal)) + ("Subgoal *1/6" + :use ((:instance apply-equation-produces-equal + (vars vars-prime) + (equation (<- eqn-cone (first vars)))))))) +) + +(local +(defthm produce-next-state-is-evaluation-eq-concretized + (implies (and (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (uniquep vars-cone) + (consistent-equation-record-p vars-cone equations-cone) + (consistent-p-equations vars-cone eqn-cone equations-cone) + (equation-equal-p eqn-orig eqn-cone vars-cone)) + (evaluation-eq + (produce-next-state vars-cone p eqn-orig) + (produce-next-state vars-cone q eqn-cone) + vars-cone))) +) + +(local +(defthm produce-next-state-evaluation-eq-reduction + (implies (and (uniquep vars-orig) + (uniquep vars-cone) + (subset vars-cone vars-orig)) + (evaluation-eq (produce-next-state vars-orig p eqn-orig) + (produce-next-state vars-cone p eqn-orig) + vars-cone))) +) + +(local +(defthm produce-next-state-fully-concretized + (implies (and (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (uniquep vars-orig) + (uniquep vars-cone) + (subset vars-cone vars-orig) + (consistent-equation-record-p vars-cone equations-cone) + (consistent-p-equations vars-cone eqn-cone equations-cone) + (equation-equal-p eqn-orig eqn-cone vars-cone)) + (evaluation-eq (produce-next-state vars-orig p eqn-orig) + (produce-next-state vars-cone q eqn-cone) + vars-cone)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (disable evaluation-eq-is-transitive + produce-next-state-is-evaluation-eq-concretized) + :use ((:instance produce-next-state-is-evaluation-eq-concretized) + (:instance evaluation-eq-is-transitive + (p (produce-next-state vars-orig p eqn-orig)) + (q (produce-next-state vars-cone p eqn-orig)) + (r (produce-next-state vars-cone q eqn-cone)) + (vars vars-cone)))))) +) + +(local +(defthm produce-next-state-for-equation-of-choice + (implies (and (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (cons-list-p vars-cone equations-cone) + (uniquep vars-orig) + (uniquep vars-cone) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-p-equations vars-orig eqn-orig equations-orig) + (consistent-equation-record-p vars-cone equations-cone) + (subset vars-cone vars-orig)) + (evaluation-eq + (produce-next-state vars-orig p eqn-orig) + (produce-next-state + vars-cone q + (create-corresponding-equation + vars-cone equations-cone vars-orig eqn-orig eq-rec)) + vars-cone))) +) + +(local +(in-theory (disable apply-equation-produces-equal)) +) + +(local +(defthm boolean-p-apply-equation + (implies (and (evaluation-p p vars) + (subset (find-variables equation) vars)) + (booleanp (apply-equation equation p))) + :hints (("Goal" + :induct (apply-equation equation p)))) +) + +(local +(defthm evaluation-p-set-reduction + (implies (and (booleanp a) + (evaluation-p p vars)) + (evaluation-p (-> p v a) vars)) + :hints (("Subgoal *1/4" + :cases ((equal v (car vars)))))) +) + +(local +(defthm produce-next-state-is-evaluation-p + (implies (and (evaluation-p p vars-prime) + (subset vars vars-prime) + (uniquep vars) + (uniquep vars-prime) + (closed-eqn-record-p eqn vars vars-prime)) + (evaluation-p (produce-next-state vars p eqn) vars-prime))) +) + +(local +(defthm next-state-is-evaluation-p-concretized + (implies (and (evaluation-p p vars) + (uniquep vars) + (consistent-equation-record-p vars equations) + (consistent-p-equations vars eqn equations)) + (evaluation-p (produce-next-state vars p eqn) vars))) +) + +(local +(defthm r-is-evaluation-eq-member-p-with-respect-to-states + (implies (and (memberp r (create-next-states-of-p p states-orig vars-orig + equations-orig)) + (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig) + (evaluation-p p vars-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (cons-list-p vars-cone equations-cone) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-equation-record-p vars-cone equations-cone) + (all-evaluations-p states-cone vars-cone)) + (evaluation-eq-member-p + r (create-next-states-of-p q states-cone vars-cone equations-cone) + vars-cone)) + :otf-flg t + :hints (("Goal" + :do-not-induct t + :in-theory (disable next-state-of-orig-to-evaluation-eq-member-p) + :use ((:instance next-state-of-orig-to-evaluation-eq-member-p + (s (produce-next-state vars-orig p + (next-state-is-ok-witness p r vars-orig + equations-orig))) + (eqn (create-corresponding-equation + vars-cone equations-cone vars-orig + (next-state-is-ok-witness p r vars-orig + equations-orig) + eq-rec))))) + ("Subgoal 2" + :in-theory (disable evaluationp-for-subset + next-state-is-evaluation-p-concretized) + :use ((:instance next-state-is-evaluation-p-concretized + (eqn (next-state-is-ok-witness + p r vars-orig equations-orig)) + (equations equations-orig) + (vars vars-orig)) + (:instance evaluationp-for-subset + (st (PRODUCE-NEXT-STATE + VARS-ORIG P + (NEXT-STATE-IS-OK-WITNESS P R VARS-ORIG + EQUATIONS-ORIG))) + (variables vars-orig) + (vars vars-cone)))) + ("Subgoal 1" + :in-theory (disable + consistent-p-equations-to-consistent-p-equations) + :use ((:instance consistent-p-equations-to-consistent-p-equations + (eqn-orig equations-orig) + (eqn-cone equations-cone) + (eqn (next-state-is-ok-witness p r vars-orig + equations-orig))))))) + +) + +(local +(defthm evaluation-eq-subset-p-orig->cone + (implies (and (subset l (create-next-states-of-p p states-orig vars-orig + equations-orig)) + (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig) + (evaluation-p p vars-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (cons-list-p vars-cone equations-cone) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-equation-record-p vars-cone equations-cone) + (all-evaluations-p states-cone vars-cone)) + (evaluation-eq-subset-p + l (create-next-states-of-p q states-cone vars-cone equations-cone) + vars-cone))) +) + +(local +(defthm evaluation-eq-subset-orig->cone-concretized + (implies (and (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig) + (only-evaluations-p states-orig vars-orig) + (memberp p states-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (cons-list-p vars-cone equations-cone) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-equation-record-p vars-cone equations-cone) + (all-evaluations-p states-cone vars-cone)) + (evaluation-eq-subset-p + (create-next-states-of-p p states-orig vars-orig + equations-orig) + (create-next-states-of-p q states-cone vars-cone equations-cone) + vars-cone)) + :hints (("Goal" + :in-theory (disable evaluation-eq-subset-p-orig->cone) + :use ((:instance evaluation-eq-subset-p-orig->cone + (l (create-next-states-of-p p states-orig vars-orig + equations-orig))))))) +) + +(local +(defthm equation-equal-is-symmetric + (equal (equation-equal-p eqn-orig eqn-cone vars) + (equation-equal-p eqn-cone eqn-orig vars)) + :rule-classes nil) +) + +(local +(defthm equation-equal-to-set-reduction-2 + (implies (not (memberp v vars)) + (equal (equation-equal-p (-> eqn-orig v a) eqn-cone vars) + (equation-equal-p eqn-orig eqn-cone vars)))) +) + +(local +(defthm memberp-to-create-equation-reduction + (implies (and (memberp v vars-cone) + (memberp v vars-orig)) + (equal (<- (create-corresponding-equation vars-orig eqn-orig + vars-cone eqn-cone + eq-rec) + v) + (<- eqn-cone v))) + :hints (("Subgoal *1/3.2" + :cases ((equal v (car vars-orig)))))) +) + +(local +(defthm not-memberp-to-create-equation + (implies (not (memberp v vars-orig)) + (equal (<- (create-corresponding-equation vars-orig eqn-orig + vars-cone eqn-cone eq-rec) + v) + (<- eq-rec v)))) +) + +(local +(defthm memberp-equation-reduction-2 + (implies (and (not (memberp v vars-cone)) + (memberp v vars-orig)) + (equal (<- (create-corresponding-equation vars-orig eqn-orig + vars-cone eqn-cone eq-rec) + v) + (first (<- eqn-orig v)))) + :hints (("Subgoal *1/3" + :cases ((equal v (car vars-orig)))))) +) + +(local +(defthm create-corresponding-equation-is-equation-equal-2 + (implies (and (subset vars-cone vars-orig) + (subset vars vars-cone) + (uniquep vars-orig) + (uniquep vars-cone)) + (equation-equal-p (create-corresponding-equation + vars-orig eqn-orig + vars-cone eqn-cone eq-rec) + eqn-cone vars)) + :otf-flg t + :hints (("Goal" + :do-not '(eliminate-destructors generalize)))) +) + +(local +(defthm produce-next-state-for-equation-of-choice-2 + (implies (and (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (cons-list-p vars-orig equations-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-p-equations vars-cone eqn-cone equations-cone) + (consistent-equation-record-p vars-cone equations-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig)) + (evaluation-eq + (produce-next-state + vars-orig p + (create-corresponding-equation + vars-orig equations-orig vars-cone eqn-cone eq-rec)) + (produce-next-state vars-cone q eqn-cone) + vars-cone))) +) + +(local +(defthm and-thus-for-vars-cone + (implies (and (all-evaluations-p states-orig vars-orig) + (evaluation-p r vars-orig) + (subset vars-cone vars-orig) + (consistent-p-equations vars-orig eqn equations-orig) + (evaluation-eq r (produce-next-state vars-orig p eqn) + vars-orig)) + (evaluation-eq-member-p + r (create-next-states-of-p p states-orig vars-orig equations-orig) + vars-cone)) + :hints (("Goal" + :in-theory (disable evaluation-eq-member-subset-reduction) + :use ((:instance evaluation-eq-member-subset-reduction + (init r) + (vars vars-orig) + (vars-prime vars-cone) + (inits (create-next-states-of-p + p states-orig vars-orig + equations-orig))))))) +) + +(local +(defthm thus-r-is-evaluation-eq-to-s-2 + (implies (and (next-state-is-ok q s vars-cone equations-cone) + (evaluation-eq (produce-next-state + vars-cone q + (next-state-is-ok-witness q s vars-cone + equations-cone)) + r + + vars-cone)) + (evaluation-eq s r vars-cone)) + :rule-classes nil) +) + +;; and then suitably polish it + + +(local +(defthm thus-polished-r-is-evaluation-eq-to-s-2 + (implies (and (memberp s (create-next-states-of-p q states-cone vars-cone + equations-cone)) + (evaluation-eq r (produce-next-state + vars-cone q + (next-state-is-ok-witness + q s vars-cone equations-cone)) + vars-cone)) + (evaluation-eq r s vars-cone)) + :hints (("Goal" + :do-not-induct t + :in-theory (disable next-state-is-ok + next-state-member-implies-consistent-equation) + :use ((:instance next-state-member-implies-consistent-equation + (p q) + (r s) + (vars vars-cone) + (states states-cone) + (equations equations-cone)) + (:instance thus-r-is-evaluation-eq-to-s-2) + (:instance evaluation-eq-is-symmetric + (p r) + (q s) + (vars vars-cone)) + (:instance evaluation-eq-is-symmetric + (p r) + (vars vars-cone) + (q (produce-next-state + vars-cone q + (next-state-is-ok-witness + q s vars-cone equations-cone)))))))) +) + +(local +(defthm evaluation-eq-member-p-from-memberp + (implies (and (evaluation-eq s r vars) + (evaluation-eq-member-p r states vars)) + (evaluation-eq-member-p s states vars))) +) + +(local +(defthm next-state-of-orig-to-evaluation-eq-member-p-2 + (implies (and (memberp s (create-next-states-of-p q states-cone vars-cone + equations-cone)) + (evaluation-eq r (produce-next-state + vars-cone q + (next-state-is-ok-witness q s vars-cone + equations-cone)) + vars-cone) + (uniquep vars-orig) + (uniquep vars-cone) + (subset vars-cone vars-orig) + (all-evaluations-p states-orig vars-orig) + (evaluation-p r vars-orig) + (consistent-p-equations vars-orig eqn equations-orig) + (evaluation-eq r (produce-next-state vars-orig p eqn) + vars-orig)) + (evaluation-eq-member-p + s (create-next-states-of-p p states-orig vars-orig equations-orig) + vars-cone)) + :hints (("Goal" + :do-not-induct t + :in-theory (disable ;; produce-next-state-evaluation-eq-reduction + and-thus-for-vars-cone + thus-polished-r-is-evaluation-eq-to-s-2) + :use ((:instance thus-polished-r-is-evaluation-eq-to-s-2) + (:instance and-thus-for-vars-cone) + (:instance evaluation-eq-is-symmetric + (p r) + (q s) + (vars vars-cone)))))) +) + +(local +(defthm consistent-p-equations-to-consistent-p-equations-2 + (implies (and (consistent-p-equations vars-cone eqn equations-cone) + (cons-list-p vars-orig equations-orig) + (equation-equal-p equations-orig equations-cone vars-cone) + (uniquep vars-orig) + (uniquep vars-cone)) + (consistent-p-equations + vars-orig + (create-corresponding-equation + vars-orig equations-orig vars-cone eqn eqn-rec) + equations-orig)) + :hints (("Goal" + :induct (create-corresponding-equation + vars-orig equations-orig vars-cone eqn eqn-rec) + :do-not-induct t) + ("Subgoal *1/2" + :use ((:instance consistent-p-equation-memberp-reduction + (vars vars-cone) + (v (car vars-orig)) + (equations equations-cone)))))) +) + +(local +(defthm next-state-cone->orig-thus-settled + (implies (and (memberp s (create-next-states-of-p q states-cone vars-cone + equations-cone)) + (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig) + (evaluation-p p vars-orig) + (evaluation-p q vars-cone) + (all-evaluations-p states-orig vars-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (cons-list-p vars-orig equations-orig) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (consistent-equation-record-p vars-cone equations-cone) + (all-evaluations-p states-cone vars-cone)) + (evaluation-eq-member-p + s (create-next-states-of-p p states-orig vars-orig equations-orig) + vars-cone)) + :otf-flg t + :hints (("Goal" + :do-not-induct t + :in-theory (disable + consistent-p-equations-to-consistent-p-equations-2 + next-state-of-orig-to-evaluation-eq-member-p-2) + :use ((:instance next-state-of-orig-to-evaluation-eq-member-p-2 + (r (produce-next-state + vars-orig p + (create-corresponding-equation + vars-orig equations-orig vars-cone + (next-state-is-ok-witness q s vars-cone + equations-cone) + eq-rec))) + (eqn (create-corresponding-equation + vars-orig equations-orig vars-cone + (next-state-is-ok-witness q s vars-cone + equations-cone) + eq-rec))) + (:instance next-state-is-evaluation-p-concretized + (vars vars-orig) + (equations equations-orig) + (eqn (create-corresponding-equation + vars-orig equations-orig vars-cone + (next-state-is-ok-witness q s vars-cone + equations-cone) + eq-rec))) + (:instance consistent-p-equations-to-consistent-p-equations-2 + (eqn-rec eq-rec) + (eqn (next-state-is-ok-witness q s vars-cone + equations-cone))))))) + +) + +(local +(defthm next-state-cone->orig-concretized + (implies (and (subset l (create-next-states-of-p q states-cone vars-cone + equations-cone)) + (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig) + (evaluation-p p vars-orig) + (evaluation-p q vars-cone) + (all-evaluations-p states-orig vars-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (cons-list-p vars-orig equations-orig) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (consistent-equation-record-p vars-cone equations-cone) + (all-evaluations-p states-cone vars-cone)) + (evaluation-eq-subset-p + l (create-next-states-of-p p states-orig vars-orig equations-orig) + vars-cone))) +) + +(local +(defthm and-fully-concretized-cone->orig + (implies (and (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig) + (only-evaluations-p states-orig vars-orig) + (only-evaluations-p states-cone vars-cone) + (memberp p states-orig) + (memberp q states-cone) + (evaluation-p q vars-cone) + (all-evaluations-p states-orig vars-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (cons-list-p vars-orig equations-orig) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (consistent-equation-record-p vars-cone equations-cone) + (all-evaluations-p states-cone vars-cone)) + (evaluation-eq-subset-p + (create-next-states-of-p q states-cone vars-cone + equations-cone) + (create-next-states-of-p p states-orig vars-orig equations-orig) + vars-cone)) + :hints (("Goal" + :in-theory (disable next-state-cone->orig-concretized) + :use ((:instance next-state-cone->orig-concretized + (l (create-next-states-of-p q states-cone vars-cone + equations-cone))))))) +) + +(local +(in-theory (disable create-next-states-of-p)) +) + +(local +(defthm not-member-p-to-next-states + (implies (not (memberp p states)) + (equal (<- (create-next-states states states-prime vars equations) + p) + nil))) +) + +(local +(defthm create-next-states-to-next-state-of-p + (implies (memberp p states) + (equal (<- (create-next-states states states-prime vars equations) + p) + (create-next-states-of-p p states-prime vars equations))) + :hints (("Subgoal *1/3" + :cases ((equal p (car states)))))) +) + +(local +(defthm well-formed-transition-p-aux-orig->cone + (implies (and (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig) + (only-evaluations-p states-orig vars-orig) + (memberp p states-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (cons-list-p vars-cone equations-cone) + (memberp q states-cone) + (only-evaluations-p states-cone vars-cone) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-equation-record-p vars-cone equations-cone) + (all-evaluations-p states-cone vars-cone)) + (evaluation-eq-subset-p + (<- (create-next-states states-orig states-orig vars-orig + equations-orig) + P) + (<- (create-next-states states-cone states-cone vars-cone + equations-cone) + Q) + vars-cone))) +) + +(local +(defthm well-formed-transition-p-aux-cone->orig + (implies (and (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq p q vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig) + (only-evaluations-p states-orig vars-orig) + (only-evaluations-p states-cone vars-cone) + (memberp p states-orig) + (memberp q states-cone) + (evaluation-p q vars-cone) + (all-evaluations-p states-orig vars-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (cons-list-p vars-orig equations-orig) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (consistent-equation-record-p vars-cone equations-cone) + (all-evaluations-p states-cone vars-cone)) + (evaluation-eq-subset-p + (<- (create-next-states states-cone states-cone vars-cone + equations-cone) + q) + (<- (create-next-states states-orig states-orig vars-orig + equations-orig) + p) + vars-cone))) +) + +(local +(defthm well-formed-transition-p-aux-cone->orig-concretized + (implies (and (evaluation-p p vars-cone) + (evaluation-p q vars-cone) + (evaluation-eq q p vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (subset vars-cone vars-orig) + (only-evaluations-p states-orig vars-orig) + (only-evaluations-p states-cone vars-cone) + (memberp p states-orig) + (memberp q states-cone) + (evaluation-p q vars-cone) + (all-evaluations-p states-orig vars-orig) + (uniquep vars-orig) + (uniquep vars-cone) + (cons-list-p vars-orig equations-orig) + (equation-equal-p equations-orig equations-cone vars-cone) + (consistent-equation-record-p vars-orig equations-orig) + (consistent-equation-record-p vars-cone equations-cone) + (all-evaluations-p states-cone vars-cone)) + (evaluation-eq-subset-p + (<- (create-next-states states-cone states-cone vars-cone + equations-cone) + q) + (<- (create-next-states states-orig states-orig vars-orig + equations-orig) + p) + vars-cone)) + :hints (("Goal" + :in-theory (disable and-fully-concretized-cone->orig + evaluation-eq-subset-p + evaluation-eq-member-p + next-state-cone->orig-concretized + well-formed-transition-p-aux-cone->orig) + :use ((:instance well-formed-transition-p-aux-cone->orig) + (:instance evaluation-eq-is-symmetric + (vars vars-cone)))))) +) + +(local +(in-theory (disable create-all-evaluations find-all-variables + only-evaluations-p + all-evaluations-p + strict-evaluation-p + only-all-truths-p + label-subset-vars + transition-subset-p + next-states-in-states + cons-list-p + consistent-equation-record-p + uniquep + subset + find-all-equations create-label-fn)) +) + +(local +(in-theory (enable well-formed-transition-p)) +) + +(local +(defthm orig-cone-cone-is-well-formed-transition-p + (implies (circuitp C) + (well-formed-transition-p + (states (create-kripke C)) + (transition (create-kripke C)) + (states + (create-kripke + (cone-of-influence-reduction C vars))) + (transition + (create-kripke + (cone-of-influence-reduction C vars))) + (cone-variables vars C))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize fertilize) + :do-not-induct t + :in-theory (disable well-formed-transition-p-aux-orig->cone + create-kripke-produces-circuit-model) + :use ((:instance well-formed-transition-p-aux-orig->cone + (states-orig (states (create-kripke C))) + (states-cone (states + (create-kripke + (cone-of-influence-reduction + C vars)))) + (vars-orig (variables C)) + (vars-cone (variables + (cone-of-influence-reduction C vars))) + (equations-orig (equations C)) + (equations-cone (equations + (cone-of-influence-reduction C + vars))) + (p (car (well-formed-transition-p-witness + (states (create-kripke C)) + (transition (create-kripke C)) + (states (create-kripke + (cone-of-influence-reduction C + vars))) + (transition + (create-kripke + (cone-of-influence-reduction C vars))) + (variables (cone-of-influence-reduction C + vars))))) + (q (mv-nth 1 + (well-formed-transition-p-witness + (states (create-kripke C)) + (transition (create-kripke C)) + (states (create-kripke + (cone-of-influence-reduction C + vars))) + (transition + (create-kripke + (cone-of-influence-reduction C vars))) + (variables (cone-of-influence-reduction C + vars)))))) + (:instance create-kripke-produces-circuit-model) + (:instance create-kripke-produces-circuit-model + (C (cone-of-influence-reduction C vars))) + (:instance cone-of-influence-reduction-is-circuit-p))))) +) + +(local +(defthm cone-orig-is-well-formed-transition-p + (implies (circuitp C) + (well-formed-transition-p + (states + (create-kripke + (cone-of-influence-reduction C vars))) + (transition + (create-kripke + (cone-of-influence-reduction C vars))) + (states (create-kripke C)) + (transition (create-kripke C)) + (cone-variables vars C))) + :hints (("Goal" + :do-not '(eliminate-destructors generalize fertilize) + :do-not-induct t + :in-theory (disable well-formed-transition-p-aux-orig->cone + create-kripke-produces-circuit-model) + :use ((:instance well-formed-transition-p-aux-cone->orig-concretized + (states-orig (states (create-kripke C))) + (states-cone (states + (create-kripke + (cone-of-influence-reduction + C vars)))) + (vars-orig (variables C)) + (vars-cone (variables + (cone-of-influence-reduction C vars))) + (equations-orig (equations C)) + (equations-cone (equations + (cone-of-influence-reduction C + vars))) + (q (car (well-formed-transition-p-witness + (states (create-kripke + (cone-of-influence-reduction C vars))) + (transition (create-kripke + (cone-of-influence-reduction + C vars))) + (states (create-kripke C)) + (transition (create-kripke C)) + + (variables (cone-of-influence-reduction C + vars))))) + (p (mv-nth 1 + (well-formed-transition-p-witness + (states (create-kripke + (cone-of-influence-reduction C vars))) + (transition (create-kripke + (cone-of-influence-reduction + C vars))) + (states (create-kripke C)) + (transition (create-kripke C)) + (variables (cone-of-influence-reduction C + vars)))))) + + (:instance create-kripke-produces-circuit-model) + (:instance create-kripke-produces-circuit-model + (C (cone-of-influence-reduction C vars))) + (:instance cone-of-influence-reduction-is-circuit-p))))) +) + +(local +(in-theory (disable well-formed-transition-p create-kripke + cone-of-influence-reduction + ltl-semantics + cone-variables + circuit-modelp circuitp)) +) + +(local +(defthm cone-of-influence-is-c-bisimi-equiv + (implies (circuitp C) + (c-bisim-equiv (create-kripke C) + (create-kripke (cone-of-influence-reduction C vars)) + (cone-variables vars C)))) +) + +(local +(in-theory (disable c-bisim-equiv)) +) + +(local +(defthm restricted-formula-of-vars-is-also-true-for-subset + (implies (and (restricted-formulap f vars) + (subset vars vars-prime)) + (restricted-formulap f vars-prime))) +) + +(DEFTHM cone-of-influence-reduction-is-sound + (implies (and (restricted-formulap f (cone-variables vars C)) + (circuitp C)) + (equal (ltl-semantics f + (create-kripke (cone-of-influence-reduction C + vars))) + (ltl-semantics f (create-kripke C)))) + :hints (("Goal" + :in-theory (disable restricted-formulap + circuit-bisim-implies-same-ltl-semantics) + :use ((:instance circuit-bisim-implies-same-ltl-semantics + (n (create-kripke (cone-of-influence-reduction C + vars))) + (m (create-kripke C)) + (vars (cone-variables vars C))))))) + +;; So we are done. Let us prove a couple of handy theorems. + +(DEFTHM cone-of-influence-reduction-is-sound-generalized + (implies (and (subset interesting-vars (cone-variables vars C)) + (circuitp C) + (restricted-formulap f interesting-vars)) + (equal (ltl-semantics f (create-kripke + (cone-of-influence-reduction C vars))) + (ltl-semantics f (create-kripke C))))) + + diff --git a/books/workshops/2003/ray-matthews-tuttle/support/conjunction.lisp b/books/workshops/2003/ray-matthews-tuttle/support/conjunction.lisp new file mode 100644 index 0000000..b349a0d --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/conjunction.lisp @@ -0,0 +1,99 @@ +(in-package "ACL2") + +#| + + conjunction.lisp + ~~~~~~~~~~~~~~~~ + +In this book, we prove the theorems on conjunctive reductions of LTL +formula. In particular, we prove that if an ltl-formula f is the conjunction of +formuals f1 and f2, then the semantics of f with respect to a model m will be +the conjunction of semantics of f1 and f2 wrt m. + +|# + + +(include-book "ltl") + +(local +(defthm ltl-conjunction-reduction-1 + (implies (and (ltl-formulap f) + (equal (len f) 3) + (equal (second f) '&) + (ltl-semantics (first f) m) + (ltl-semantics (third f) m)) + (ltl-semantics f m)) + :hints (("Goal" + :in-theory (disable compatible-ppath-p) + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :cases ((compatible-ppath-p (ltl-semantics-witness + f m) m))))) + +) + +(local +(defthm ltl-conjunction-reduction-2 + (implies (and (ltl-formulap f) + (equal (len f) 3) + (equal (second f) '&) + (ltl-semantics f m)) + (ltl-semantics (first f) m)) + :hints (("Goal" + :in-theory (disable compatible-ppath-p) + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :cases ((compatible-ppath-p (ltl-semantics-witness (first f) m) m))) + ("Subgoal 1" + :in-theory (disable compatible-ppath-p ltl-semantics-necc + ltl-ppath-semantics-can-be-decomposed-over-conjunctions + ltl-semantics) + :expand (ltl-semantics (first f) m) + :use ((:instance ltl-semantics-necc + (ppath (ltl-semantics-witness (first f) m))) + (:instance + ltl-ppath-semantics-can-be-decomposed-over-conjunctions + (p (ltl-semantics-witness (first f) m))))))) +) + +(local +(defthm ltl-conjunction-reduction-3 + (implies (and (ltl-formulap f) + (equal (len f) 3) + (equal (second f) '&) + (ltl-semantics f m)) + (ltl-semantics (third f) m)) + :hints (("Goal" + :in-theory (disable compatible-ppath-p) + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :cases ((compatible-ppath-p (ltl-semantics-witness (third f) m) m))) + ("Subgoal 1" + :in-theory (disable compatible-ppath-p + ltl-semantics-necc + ltl-ppath-semantics-can-be-decomposed-over-conjunctions + ltl-semantics) + :expand (ltl-semantics (third f) m) + :use ((:instance ltl-semantics-necc + (ppath (ltl-semantics-witness (third f) m))) + (:instance + ltl-ppath-semantics-can-be-decomposed-over-conjunctions + (p (ltl-semantics-witness (third f) m))))))) +) + +(local +(in-theory (disable ltl-semantics ltl-formulap + ltl-semantics-necc)) +) + +(DEFTHM ltl-semantics-is-decomposed-over-conjunction + (implies (and (ltl-formulap f) + (equal (len f) 3) + (equal (second f) '&)) + (equal (ltl-semantics f m) + (and (ltl-semantics (first f) m) + (ltl-semantics (third f) m)))) + :hints (("Goal" + :use ((:instance ltl-conjunction-reduction-1) + (:instance ltl-conjunction-reduction-2) + (:instance ltl-conjunction-reduction-3))))) diff --git a/books/workshops/2003/ray-matthews-tuttle/support/impl-hack.acl2 b/books/workshops/2003/ray-matthews-tuttle/support/impl-hack.acl2 new file mode 100644 index 0000000..1f73a72 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/impl-hack.acl2 @@ -0,0 +1,3 @@ +(in-package "ACL2") +; cert-flags: ? t :defaxioms-okp t +(certify-book "impl-hack" ? t :defaxioms-okp t) diff --git a/books/workshops/2003/ray-matthews-tuttle/support/impl-hack.lisp b/books/workshops/2003/ray-matthews-tuttle/support/impl-hack.lisp new file mode 100644 index 0000000..6104fae --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/impl-hack.lisp @@ -0,0 +1,81 @@ +(in-package "ACL2") + +#| + + impl-hack.lisp + ~~~~~~~~~~~~~~ + +This book is an implementation hack. The whole state of affairs is extremely +stupid here. What I want to do is the following. When we are asked whether a +(constant) formula is true of a (constant) circuit or not, we will apply the +compositional reduction (by evaluating that function) and then do +a series of model-checking on the reduced circuit. Since we are willing to rely +on an external model-checker, we want a hack function to be evaluated in common +lisp, where it will be redefined as an external system call. In order for that +to occur, we define the function with a guard of T and then set it up so that +the rewriter just makes multiple calls to this function for the model-checking +purpose. + +|# + +(include-book "reductions") + +;; The following function is the hack. It does not matter what it returns, +;;since we will disable it, and use the defining axiom for our work. But it is +;;important to have the function defined with a guard of T so that ACL2 dares +;; to look into the common lisp for its implementation. + +(defun ltl-semantics-hack (C f) + (declare (xargs :guard t + :verify-guards t)) + (list C f)) + +(defun ltl-semantics-hack* (list) + (if (endp list) T + (and (ltl-semantics-hack (second (first list)) + (first (first list))) + (ltl-semantics-hack* (rest list))))) + +(in-theory (disable ltl-semantics-hack (:definition ltl-semantics-hack))) + +(defaxiom ltl-semantics-hack-revealed + (equal (ltl-semantics-for-circuit C f) + (ltl-semantics-hack C f))) + +(local +(defthm ltl-semantocs-hack*-revealed + (equal (ltl-semantics-hack* list) + (ltl-semantics-for-circuits* list)) + :hints (("Goal" + :induct (ltl-semantics-for-circuits* list)))) +) + +;; The following theorem rewrites the ltl-semantics-for-circuit into this hack* +;; function. + +(DEFTHM ltl-semantics-hack-*-from-ltl-semantics-* + (implies (syntaxp (and (quotep C) + (quotep f))) + (implies (and (circuitp C) + (ltl-formulap f) + (subset (create-restricted-var-set f) (variables C))) + (equal (ltl-semantics-for-circuit C f) + (ltl-semantics-hack* (compositional-reduction C + f))))) + :hints (("Goal" + :in-theory (disable circuitp ltl-semantics-for-circuit + compositional-reduction)))) + +;; Which then is opened up for a series of evaluations of the hack function. + +(DEFTHM ltl-semantics-hack-revealed-for-rewriting + (implies (syntaxp (quotep list)) + (equal (ltl-semantics-hack* list) + (if (endp list) T + (and (ltl-semantics-hack (second (first list)) + (first (first list))) + (ltl-semantics-hack* (rest list))))))) + +(in-theory (disable ltl-semantics-hack* (:definition ltl-semantics-hack*) + (:type-prescription ltl-semantics-hack*))) + diff --git a/books/workshops/2003/ray-matthews-tuttle/support/ltl.lisp b/books/workshops/2003/ray-matthews-tuttle/support/ltl.lisp new file mode 100644 index 0000000..279234f --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/ltl.lisp @@ -0,0 +1,479 @@ +(in-package "ACL2") + +;; The following two lines are added for portability to v2-7.... + + +#| + + ltl.lisp + ~~~~~~~~ + +In this book, we discuss the syntax of LTL formula and its semantics with +respect to a Kripke Structure. The standard semantics of LTL involve operations +with respect to an inifinitary object, namely the path. However, ACL2 does not +allow such objects. Thus, we need to define the semantics of LTL with respect +to a Kripke Structure directly. However, this requires a tableau construction +which is easy to get wrong and harder to prove theorems about, even if +specified correctly. + +We have chosen to take a middle ground based on (John Matthews's) +discussions with Ernie Cohen. The idea is to define the semantics of LTL with +respect to eventually periodic paths. (We defer the proof now that any +verification of semantics over eventually periodic paths corresponds to a +verification over infinite paths and this might not be possible to do in +ACL2.) However, for the moment the semantics are with respect to eventually +periodic paths and the semantics for a Kripke Structure are given by +quantifying over all compatible paths. + +The current book is produced to prove compositional reductions for +model-checking. The goal is to verify that the composition reductions are +correct given that the underlying model-checking routines are correct. Given +this assumption, we take further liberties and encapsulate the ltl semantics +over periodic paths as an underlying model-checking routine, exporting theorems +that are required to verify the reductions. The point in the case is that if +for a real LTL semantics function these constraints are not satisfied for +periodic paths, then the functions (and not the theorems) need to be changed, +making encapsulate a viable option in order to not get bogged down in +implementation of a model-checking routine for ltl. + +Questions and comments are welcome. -- Sandip. + +|# + +(set-match-free-default :once) + +(include-book "sets") + + + + +;; We now define the syntax of an LTL formula. For purpose of reductions, we +;; also define a restricted formula over a subset of variables. + +(defun ltl-constantp (f) + (or (equal f 'true) + (equal f 'false))) + +(defun ltl-variablep (f) + (and (symbolp f) + (not (memberp f '(+ & U W X F G))))) + +;; So an LTL formula is either (i) a constant 'True or 'False, (ii) a variable +;; which is a quote or a symbol other than the LTL operator symbol, or of the +;; form (P + Q), (P & Q), (P U Q), (P W Q), (~ P), (F P), (G P), (X P), where P +;; and Q are LTL formulas. + + +(defun ltl-formulap (f) + (cond ((atom f) (or (ltl-constantp f) + (ltl-variablep f))) + ((equal (len f) 3) + (and (memberp (second f) '(+ & U W)) + (ltl-formulap (first f)) + (ltl-formulap (third f)))) + ((equal (len f) 2) + (and (memberp (first f) '(~ X F G)) + (ltl-formulap (second f)))) + (t nil))) + +;; A formula is called resctricted with respect to a collection vars of +;; variables if it mentions no variable other than those in vars. Here is the +;; recursive definition. + +(defun restricted-formulap (f v-list) + (cond ((atom f) (or (ltl-constantp f) + (and (ltl-variablep f) + (memberp f v-list)))) + ((equal (len f) 3) (and (memberp (second f) '(& + U W)) + (restricted-formulap (first f) v-list) + (restricted-formulap (third f) v-list))) + ((equal (len f) 2) (and (memberp (first f) '(~ X F G)) + (restricted-formulap (second f) v-list))) + (t nil))) + +;; Now we show the obvious thing that a restricted formula is also an ltl +;; formula. + +(defthm restricted-formula-is-an-ltl-formula + (implies (restricted-formulap f v-list) + (ltl-formulap f)) + :rule-classes :forward-chaining) + +;; Given an LTL formula, can we create a v-list such that the LTL-formula is a +;; restricted formula over the variables in v-list? The function +;; create-restricted-var-set attempts that. + +(defun create-restricted-var-set (f) + (cond ((atom f) (if (ltl-constantp f) nil (list f))) + ((equal (len f) 3) (set-union (create-restricted-var-set (first f)) + (create-restricted-var-set (third f)))) + ((equal (len f) 2) (create-restricted-var-set (second f))) + (t nil))) + +;; And show that we have been successful + +(local +(defthm restricted-formulap-append-reduction + (implies (restricted-formulap f vars) + (restricted-formulap f (set-union vars vars-prime))) + :hints (("Goal" + :in-theory (enable set-union)))) +) + +(local +(defthm restricted-formulap-append-reduction-2 + (implies (restricted-formulap f vars) + (restricted-formulap f (set-union vars-prime vars))) + :hints (("Goal" + :in-theory (enable set-union)))) +) + +(defthm ltl-formula-is-a-restricted-formula + (implies (ltl-formulap f) + (restricted-formulap f (create-restricted-var-set f))) + :rule-classes :forward-chaining) + +;; OK, so we are done with syntax of LTL for mow. We will revisit this section +;; and add different restricted models when we do proofs of different +;; reductions. + +;; We turn our attention to models. + +;; First this handy collection of functions that might help us. +;; NOTE TO MYSELF: I should write some utilities in ACL2 that will allow me to +;; load the accessor and updater macros easily. I will have to think about it +;; at aome point. + +;; Here are the accessors and updaters as macros. A Kripke structure is a +;; record of states, initial-states, transition and label-fn. + +(defmacro initial-states (m) `(<- ,m :initial-states)) +(defmacro transition (m) `(<- ,m :transition)) +(defmacro label-fn (m) `(<- ,m :label-fn)) +(defmacro states (m) `(<- ,m :states)) +(defmacro variables (m) `(<- ,m :variables)) + +;; A periodic path is a record of initial-state, (finite) prefix, and (finite) +;; cycle. + +;; NOTE TO MYSELF: The initial state might not be required. It is difficult to +;; estimate what is considered standard for Kripke structures. I have heard +;; Professor Emerson talk about Kripke Structures with initial states and +;; Kripke Structures without initial states (and so in Dr. Clarke's Book). I +;; follow the "with initial states" in that jargon, though I do believe that we +;; can modify the theorems for Kripke Structures "without initial states". The +;; reason for this choice is that I think the stronger requirements of "without +;; initial states" should not bother us at this time. + +(defmacro initial-state (p) `(<- ,p :initial-state)) +(defmacro cycle (p) `(<- ,p :cycle)) +(defmacro prefix (p) `(<- ,p :prefix)) + +(defmacro >_ (&rest upds) `(update nil ,@upds)) + +(defun next-statep (p q m) + (memberp q (<- (transition m) p))) + +(defun initial-statep (p m) + (memberp p (initial-states m))) + +(defun label-of (s m) + (<- (label-fn m) s)) + +(in-theory (disable next-statep initial-statep label-of)) + +;; The predicate modelp here precisely describes what we expect a Kripke +;; Structure to look like. + +(defun next-states-in-states (m states) + (if (endp states) T + (and (subset (<- (transition m) (first states)) + (states m)) + (next-states-in-states m (rest states))))) + +(defthm next-states-in-states-clarified-aux + (implies (and (memberp p states) + (next-states-in-states m states) + (next-statep p q m)) + (memberp q (states m))) + :hints (("Goal" + :in-theory (enable next-statep)))) + +(defthm next-states-in-states-clarified + (implies (and (next-states-in-states m (states m)) + (memberp p (states m)) + (next-statep p q m)) + (memberp q (states m)))) + +(in-theory (disable next-states-in-states-clarified-aux + next-states-in-states)) + +(encapsulate + (((modelp *) => *)) + + (local + (defun modelp (m) + (and (subset (initial-states m) (states m)) + (consp (states m)) + (next-states-in-states m (states m))))) + + (defthm modelp-characterization + (implies (modelp m) + (and (subset (initial-states m) (states m)) + (consp (states m)) + (next-states-in-states m (states m))))) +) + + +;; We define a periodic path to be compatible with a model if (a) its initial +;; state is in the initial states of the model, (b) its prefix is a compatible +;; path wrt the model, and (c) its cycle is a compatible cycle with respect to +;; the prefix. + +(defun last-val (x) + (cond ((endp x) nil) + ((endp (rest x)) (first x)) + (t (last-val (rest x))))) + +(defun compatible-path-p (path model) + (cond ((endp path) (null path)) + ((endp (rest path)) (and (memberp (first path) (states model)) + (null (rest path)))) + (t (and (next-statep (first path) (second path) model) + (memberp (first path) (states model)) + (compatible-path-p (rest path) model))))) + +(defthm compatible-path-is-true-listp + (implies (compatible-path-p path model) + (true-listp path))) + +(defthm compatible-paths-have-only-states + (implies (and (compatible-path-p path m) + (memberp s path)) + (memberp s (states m)))) + +(defun compatible-ppath-p (ppath model) + (let ((init (initial-state ppath)) + (prefix (prefix ppath)) + (cycle (cycle ppath))) + (and (memberp init (initial-states model)) + (consp prefix) + (next-statep init (first prefix) model) + (consp cycle) + (next-statep (last-val prefix) (first cycle) model) + (compatible-path-p prefix model) + (compatible-path-p cycle model) + (next-statep (last-val cycle) (first cycle) model)))) + +(defun labels-equal-along-paths (p m q n vars) + (if (endp p) T + (and (set-equal (set-intersect (label-of (first p) m) vars) + (set-intersect (label-of (first q) n) vars)) + (labels-equal-along-paths (rest p) m (rest q) n vars)))) + +(defun state-at-aux (n cycle) + (declare (xargs :measure (nfix n))) + (cond ((endp cycle) nil) ;; for termination + ((< (nfix n) (len cycle)) (nth n cycle)) + (t (state-at-aux (- n (len cycle)) cycle)))) + +(defun state-at (n ppath) + (let ((init (initial-state ppath)) + (prefix (prefix ppath)) + (cycle (cycle ppath))) + (cond ((zp n) init) + ((< (1- n) (len prefix)) (nth (1- n) prefix)) + (t (state-at-aux (- n (1+ (len prefix))) cycle))))) + + +;; Now we are ready to define ltl semantics. We will define LTL semantics as an +;; encapsulated function with the properties we need exported out. + + +(defun labels-equal-for-paths (p m q n vars) + (if (endp p) (endp q) + (and (equal (set-intersect (label-of (first p) m) vars) + (set-intersect (label-of (first q) n) vars)) + (labels-equal-for-paths (rest p) m (rest q) n vars)))) + + +(defun first-n (n lst) + (if (zp n) nil + (cons (first lst) (first-n (1- n) (rest lst))))) + +(defun last-n (n lst) + (if (zp n) lst + (last-n (1- n) (rest lst)))) + +(defthm first-last-append-reduction + (implies (<= n (len x)) + (equal (append (first-n n x) + (last-n n x)) + x))) + +(defthm len-of-last-n-is-len-minus-n + (implies (and (not (zp n)) + (<= n (len x))) + (equal (len (last-n n x)) (- (len x) n)))) + +(defthm append-of-nil-is-x + (implies (true-listp x) + (equal (append x nil) x))) + + +(local +(include-book "../../../../arithmetic-2/meta/top") +) + +(defthm first-n-append-reduction + (implies (and (equal i (len y)) + (true-listp y)) + (equal (first-n i (append y z)) + y))) + + +(defthm last-n-append-reduction + (implies (equal i (len x)) + (equal (last-n i (append x y)) + y))) + +(defun equal-label-segments-p (p m q n vars) + (if (endp p) (endp q) + (and (consp q) + (set-equal (set-intersect (label-of (first p) m) vars) + (set-intersect (label-of (first q) n) vars)) + (equal-label-segments-p (rest p) m (rest q) n vars)))) + +(defthm len-of-last-n-expanded + (implies (and (integerp i) + (< 0 i) + (<= i (len x))) + (< (len (last-n i x)) + (len x))) + :rule-classes :linear) + +(defthm consp-to-len-expanded + (implies (consp x) + (< 0 (len x))) + :rule-classes :linear) + +(defun equal-label-segments-sequence-p-small-p (p m q n vars) + (declare (xargs :measure (len q))) + (if (endp q) T + (if (or (endp p) (< (len q) (len p))) nil + (and (equal-label-segments-p p m (first-n (len p) q) n vars) + (equal-label-segments-sequence-p-small-p + p m + (last-n (len p) q) n vars))))) + +(defun equal-label-segments-sequence-p-large-p (p m q n vars) + (declare (xargs :measure (len p))) + (if (endp p) T + (if (or (endp q) (< (len p) (len q))) nil + (and (equal-label-segments-p (first-n (len q) p) m q n vars) + (equal-label-segments-sequence-p-large-p + (last-n (len q) p) m q n vars))))) + +(defun equal-labels-periodic-path-p (p m q n vars) + (and (set-equal (set-intersect (label-of (initial-state p) m) vars) + (set-intersect (label-of (initial-state q) n) vars)) + (or (and (equal-label-segments-p (prefix p) m + (first-n (len (prefix p)) (prefix q)) + n vars) + (equal-label-segments-sequence-p-small-p + (cycle p) m + (last-n (len (prefix p)) (prefix q)) + n vars) + (equal-label-segments-sequence-p-small-p + (cycle p) m (cycle q) + n vars)) + (and (equal-label-segments-p + (first-n (len (prefix q)) (prefix p)) + m (prefix q) n vars) + (equal-label-segments-sequence-p-large-p + (last-n + (len (prefix q)) + (prefix p)) m + (cycle q) n vars) + (equal-label-segments-sequence-p-large-p + (cycle p) m (cycle q) n vars))))) + + +;; Now we define the semantics of ltl. The semantics function is the +;; concrete-ltl-semantics provided below. And I need not emphasize that the +;; function is a mess. + +;; We have decided to snip out part of this book from here. I have actually +;; proved that concrete-ltl-semantics satisfies the theorem +;; ltl-ppath-semantics-cannot-distinguish-between-equal-labels. Actually we +;; proved a more general version of the theorem, and equal-labels-periodic-path-p +;; is too restrictive. However, as we will see in the sequel, that is all that we +;; would need. The proof simply is to induct with the structure of the formula +;; f. However, it turned out that the proof in this case became extremely +;; cluttered, mainly because to prove a theorem about mutually recursive +;; function, we need to prove a theorem about all the functions in the +;; clique. (The corresponding statements for the different other functions are not +;; very elegant in our case.) To see how bad theorems can become look at the +;; file bisimilarity.lisp. Further, we note that we will never actually +;; execute the function ltl-ppath-semantics. (Indeed the function we would have +;; hoped to execute would be the model checking function ltl-semantics, but +;; that is defined using defun-sk and hence we have lost all hopes of executing +;; it. The reason for our going to such lengths to define +;; concrete-ltl-semantics is to justify that we can indeed do what we want with +;; eventually periodic paths. Henceforth, however, we will simply use the +;; following encapsulated function ltl-ppath-semantcs, where we assume the +;; version of ltl-ppath-semantics-cannot-distinguish-between-equal-labels, that +;; we export from the encapsulate. If a reader of the script feels unsatisfied, +;; we can provide the actual theorems about concrete-ltl-semantics. + + +(encapsulate + (((ltl-ppath-semantics * * *) => *)) + + (local + (defun ltl-ppath-semantics (f ppath m) + (declare (ignore f ppath m)) + T) + ) + + (defthm ltl-ppath-semantics-returns-boolean + (or (equal (ltl-ppath-semantics f ppath m) T) + (equal (ltl-ppath-semantics f ppath m) nil)) + :rule-classes :type-prescription) + + (defthm ltl-ppath-semantics-cannot-distinguish-between-equal-labels + (implies (and (equal-labels-periodic-path-p p m q n vars) + (subset vars (variables m)) + (subset vars (variables n)) + (compatible-ppath-p p m) + (compatible-ppath-p q n) + (restricted-formulap f vars)) + (equal (ltl-ppath-semantics f p m) + (ltl-ppath-semantics f q n)))) + + (defthm ltl-ppath-semantics-can-be-decomposed-over-conjunctions + (implies (and (ltl-formulap f) + (equal (len f) 3) + (equal (second f) '&) + (compatible-ppath-p p m)) + (equal (ltl-ppath-semantics f p m) + (and (ltl-ppath-semantics (first f) p m) + (ltl-ppath-semantics (third f) p m))))) + + +) + +(defun-sk ltl-semantics (f m) + (forall ppath + (implies (compatible-ppath-p ppath m) + (ltl-ppath-semantics f ppath m)))) + +(defthm ltl-semantics-necc-expanded + (implies (and (ltl-semantics f m) + (compatible-ppath-p ppath m)) + (ltl-ppath-semantics f ppath m)) + :hints (("Goal" + :use ltl-semantics-necc))) + +(in-theory (disable ltl-semantics-necc)) + diff --git a/books/workshops/2003/ray-matthews-tuttle/support/records.lisp b/books/workshops/2003/ray-matthews-tuttle/support/records.lisp new file mode 100644 index 0000000..7705c11 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/records.lisp @@ -0,0 +1,299 @@ +(in-package "ACL2") + + +#| + + records.lisp + ~~~~~~~~~~~~ + +We define properties of a generic record accessor function and updater +function. The basic functions are (g a r) and (s a v r) where a is an +address/key, v is a value, r is a record, and (g a r) returns the +value set to address a in record r, and (s a v r) returns a new record +with address a set to value v in record r. + +We normalize the record structures (which allows the 'equal-ity based +rewrite rules) as alists where the keys (cars) are ordered using +Pete's total-order added to ACL2. We define a set of -aux functions +which assume well-formed records -- defined by rcdp -- and then prove +the desired properties using hypothesis assuming well-formed objects. + +We then remove these well-formed object hypothesis by defining a invertible +mapping (acl2->rcd) from any ACL2 object to a well-formed records. We then +prove the desired properties using the proper translations of the -aux +functions to the acl2 objects, and subsequently remove the well-founded +hypothesis. + +|# + +(include-book "apply-total-order") + +;; BEGIN records definitions. + +(defun rcdp (x) + (or (null x) + (and (consp x) + (consp (car x)) + (rcdp (cdr x)) + (cdar x) + (or (null (cdr x)) + (<< (caar x) (caadr x)))))) + +(defun ifrp (x) ;; ill-formed rcdp + (or (not (rcdp x)) + (and (consp x) + (null (cdr x)) + (consp (car x)) + (null (caar x)) + (ifrp (cdar x))))) + +(defun acl2->rcd (x) + (if (ifrp x) (list (cons nil x)) x)) + +(defun rcd->acl2 (x) + (if (ifrp x) (cdar x) x)) + +(defun g-aux (a x) + (cond ((or (endp x) + (<< a (caar x))) + nil) + ((equal a (caar x)) + (cdar x)) + (t + (g-aux a (cdr x))))) + +(defun g (a x) + (g-aux a (acl2->rcd x))) + +(defun s-aux (a v r) + (cond ((or (endp r) + (<< a (caar r))) + (if v (cons (cons a v) r) r)) + ((equal a (caar r)) + (if v (cons (cons a v) (cdr r)) (cdr r))) + (t + (cons (car r) (s-aux a v (cdr r)))))) + +(defun s (a v x) + (rcd->acl2 (s-aux a v (acl2->rcd x)))) + +(defun keys-aux (x) + (cond ((endp x) + ()) + (t (cons (caar x) + (keys-aux (cdr x)))))) + +(defun keys (x) + (keys-aux (acl2->rcd x))) + + + +;;;; basic property of records ;;;; + +(local +(defthm rcdp-implies-true-listp + (implies (rcdp x) + (true-listp x)) + :rule-classes (:forward-chaining + :rewrite))) + + +;;;; initial properties of s-aux and g-aux ;;;; + +(local +(defthm s-aux-is-bounded + (implies (and (rcdp r) + (s-aux a v r) + (<< e a) + (<< e (caar r))) + (<< e (caar (s-aux a v r)))))) + +(local +(defthm s-aux-preserves-rcdp + (implies (rcdp r) + (rcdp (s-aux a v r))))) + +(local +(defthm g-aux-same-s-aux + (implies (rcdp r) + (equal (g-aux a (s-aux a v r)) + v)))) + +(local +(defthm g-aux-diff-s-aux + (implies (and (rcdp r) + (not (equal a b))) + (equal (g-aux a (s-aux b v r)) + (g-aux a r))))) + +(local +(defthm s-aux-same-g-aux + (implies (rcdp r) + (equal (s-aux a (g-aux a r) r) + r)))) + +(local +(defthm s-aux-same-s-aux + (implies (rcdp r) + (equal (s-aux a y (s-aux a x r)) + (s-aux a y r))))) + +(local +(defthm s-aux-diff-s-aux + (implies (and (rcdp r) + (not (equal a b))) + (equal (s-aux b y (s-aux a x r)) + (s-aux a x (s-aux b y r)))) + :rule-classes ((:rewrite :loop-stopper ((b a s)))))) + +(local +(defthm s-aux-non-nil-cannot-be-nil + (implies (and v (rcdp r)) + (s-aux a v r)))) + +(local +(defthm g-aux-is-nil-for-<< + (implies (and (rcdp r) + (<< a (caar r))) + (equal (g-aux a r) nil)))) + +(local +(defthm g-keys-aux-relationship + (implies (rcdp r) + (iff (memberp a (keys-aux r)) + (g-aux a r))))) + +(local +(defthm s-keys-aux-reduction + (implies (rcdp r) + (equal (keys-aux (s-aux a v r)) + (if v + (insert a (keys-aux r)) + (drop a (keys-aux r))))))) + +(local +(defthm keys-aux-are-ordered + (implies (rcdp r) + (orderedp (keys-aux r))))) + + +;;;; properties of acl2->rcd and rcd->acl2 ;;;; + +(local +(defthm acl2->rcd-rcd->acl2-of-rcdp + (implies (rcdp x) + (equal (acl2->rcd (rcd->acl2 x)) + x)))) + +(local +(defthm acl2->rcd-returns-rcdp + (rcdp (acl2->rcd x)))) + +(local +(defthm acl2->rcd-preserves-equality + (iff (equal (acl2->rcd x) (acl2->rcd y)) + (equal x y)))) + +(local +(defthm rcd->acl2-acl2->rcd-inverse + (equal (rcd->acl2 (acl2->rcd x)) x))) + +(local +(defthm rcd->acl2-of-record-non-nil + (implies (and r (rcdp r)) + (rcd->acl2 r)))) + +(in-theory (disable acl2->rcd rcd->acl2)) + + +;;;; final properties of record g(et) and s(et) ;;;; + +(defthm g-same-s + (equal (g a (s a v r)) + v)) + +(defthm g-diff-s + (implies (not (equal a b)) + (equal (g a (s b v r)) + (g a r)))) + +;;;; NOTE: I often use the following instead of the above rules +;;;; to force ACL2 to do a case-split. In some cases, I will +;;;; disable this rule ACL2 is sluggish or if the number of cases +;;;; is unreasonable + +(defthm g-of-s-redux + (equal (g a (s b v r)) + (if (equal a b) v (g a r)))) + +(in-theory (disable g-of-s-redux)) + +(defthm s-same-g + (equal (s a (g a r) r) + r)) + +(defthm s-same-s + (equal (s a y (s a x r)) + (s a y r))) + +(defthm s-diff-s + (implies (not (equal a b)) + (equal (s b y (s a x r)) + (s a x (s b y r)))) + :rule-classes ((:rewrite :loop-stopper ((b a s))))) + +(defthm g-keys-relationship + (iff (memberp a (keys r)) + (g a r))) + +(defthm s-keys-reduction + (equal (keys (s a v r)) + (if v + (insert a (keys r)) + (drop a (keys r))))) + +(defthm keys-are-ordered + (orderedp (keys r))) + +(defthm g-of-nil-is-nil + (not (g a nil))) + +(defthm s-non-nil-cannot-be-nil + (implies v (s a v r)) + :hints (("Goal" + :in-theory (disable rcd->acl2-of-record-non-nil) + :use (:instance rcd->acl2-of-record-non-nil + (r (s-aux a v (acl2->rcd r))))))) + +(defthm non-nil-if-g-non-nil + (implies (g a r) r) + :rule-classes :forward-chaining) + + +(defthm s-same-g-back-chaining + (implies (equal v (g a r)) + (equal (s a v r) r))) + + +;; We disable s and g, assuming the rules proven in this book are sufficient to +;; manipulate record terms which are encountered + +(in-theory (disable s g keys)) + +(defmacro <- (x a) `(g ,a ,x)) + +(defmacro -> (x a v) `(s ,a ,v ,x)) + +(defun update-macro (upds result) + (declare (xargs :guard (keyword-value-listp upds))) + (if (endp upds) result + (update-macro (cddr upds) + (list 's (car upds) (cadr upds) result)))) + +(defmacro update (old &rest updates) + (declare (xargs :guard (keyword-value-listp updates))) + (update-macro updates old)) + + + + diff --git a/books/workshops/2003/ray-matthews-tuttle/support/reductions.lisp b/books/workshops/2003/ray-matthews-tuttle/support/reductions.lisp new file mode 100644 index 0000000..fe4382e --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/reductions.lisp @@ -0,0 +1,392 @@ +(in-package "ACL2") + +#| + + reductions.lisp + ~~~~~~~~~~~~~~~ + +In this book, we use the conjunctive reduction and cone of influence reduction +compositionally to provide reduction algorithms for circuits. + +|# + +(local +(include-book "conjunction") +) + +(include-book "cone-of-influence") + + +(defun ltl-semantics-for-circuit (C f) + (ltl-semantics f (create-kripke C))) + +(defun ltl-semantics-for-circuits* (list) + (if (endp list) T + (and (ltl-semantics-for-circuit (second (first list)) + (first (first list))) + (ltl-semantics-for-circuits* (rest list))))) + + +(defun reduce-problem-conjunction (f C) + (if (and (equal (len f) 3) + (equal (second f) '&)) + (append (reduce-problem-conjunction (first f) C) + (reduce-problem-conjunction (third f) C)) + (list (list f C)))) + +(defun reduce-problem-cone (f C) + (let ((vars (create-restricted-var-set f))) + (cone-of-influence-reduction C vars))) + +(defun reduce-problem-cone* (list) + (if (endp list) nil + (cons (list (first (first list)) + (reduce-problem-cone (first (first list)) (second (first list)))) + (reduce-problem-cone* (rest list))))) + + +(defun compositional-reduction (C f) + (let ((list (reduce-problem-conjunction f C))) + (reduce-problem-cone* list))) + +;; OK, so let us dispatch the obligations for conjunction first. + +(local +(in-theory (disable ltl-semantics create-kripke ltl-formulap)) +) + +(local +(defthm ltl-semantics*-append-reduction + (equal (ltl-semantics-for-circuits* (append x y)) + (and (ltl-semantics-for-circuits* x) + (ltl-semantics-for-circuits* y)))) +) + +(local +(defthm conjunction-produces-correct-list + (implies (ltl-formulap f) + (equal (ltl-semantics-for-circuits* + (reduce-problem-conjunction f C)) + (ltl-semantics-for-circuit C f))) + :otf-flg t + :hints (("Goal" + :induct (reduce-problem-conjunction f C) + :do-not-induct t + :in-theory (enable ltl-formulap) + :do-not '(eliminate-destructors generalize)))) +) + +;; To work with reduce-problems-cone, we need to assume that the variables in f +;; are subsets of the variables in cone of influence reduction. We show that +;; assuming that the variables are subsets of variables of the circuit. We need +;; to show though that the variables of cone will be a superset of vars if we +;; start with a collection of vars that are subset of the variables of the +;; circuit. + +(local +(encapsulate + () + (defthm not-memberp-union-reduction + (implies (and (not (memberp e x)) + (not (memberp e y))) + (not (memberp e (set-union x y)))) + :hints (("Goal" + :in-theory (enable set-union)))) + + (local + (defthm uniquep-set-union-reduction + (implies (and (uniquep x) + (uniquep y)) + (uniquep (set-union x y))) + :hints (("Goal" + :in-theory (enable set-union)))) + ) + + (local + (in-theory (disable consistent-equation-record-p)) + ) + + (local + (defthm consistent-equation-record-p-expanded + (implies (and (consistent-equation-record-p vars equations) + (uniquep vars) + (memberp v vars) + (memberp equation (<- equations v))) + (subset (find-variables equation) + vars)) + :hints (("Goal" + :use consistent-equation-record-p-necc))) + ) + + (local + (in-theory (disable consistent-equation-record-p-necc)) + ) + + (local + (defthm set-union-subset-reduction + (implies (and (subset x z) + (subset y z)) + (subset (set-union x y) z)) + :hints (("Goal" + :in-theory (enable set-union)))) + ) + + (local + (defthm find-variables*-subset-of-variables + (implies (and (consistent-equation-record-p variables equations) + (uniquep variables) + (memberp v variables) + (subset equation-list (<- equations v))) + (subset (find-variables* equation-list) + variables)) + :hints (("Goal" + :in-theory (disable find-variables) + :induct (find-variables* equation-list) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) + ) + + (local + (defthm find-variables*-is-subset-concretized + (implies (and (consistent-equation-record-p variables equations) + (memberp v variables) + (uniquep variables)) + (subset (find-variables* (<- equations v)) variables))) + ) + + (local + (in-theory (disable find-variables*-subset-of-variables)) + ) + + (local + (defthm find-variables-1-pass-is-subset + (implies (and (consistent-equation-record-p variables equations) + (subset vars variables) + (uniquep variables)) + (subset (find-all-variables-1-pass vars equations) + variables))) + ) + + (local + (defthm memberp-union-reduction-1 + (implies (memberp e x) + (memberp e (set-union y x))) + :hints (("Goal" + :in-theory (enable set-union)))) + ) + + (local + (defthm memberp-find-all-variables-reduction + (implies (and (consistent-equation-record-p variables equations) + (subset vars variables) + (memberp v vars)) + (memberp v (find-all-variables vars variables equations))) + :otf-flg t + :hints (("Goal" + :induct (find-all-variables vars variables equations) + :do-not '(eliminate-destructors generalize) + :do-not-induct t))) + ) + + (local + (defthm find-all-variables-produces-subset + (implies (and (consistent-equation-record-p variables equations) + (subset vars variables) + (subset vars-prime vars)) + (subset vars-prime (find-all-variables vars variables equations)))) + ) + + (local + (defthm set-intersect-is-subset + (implies (and (subset vars variables) + (subset vars vars-prime)) + (subset vars (set-intersect vars-prime variables)))) + ) + + (local + (defthm memberp-remove-reduction + (equal (memberp e (remove-duplicate-occurrences variables)) + (memberp e variables))) + ) + + (local + (defthm remove-duplicates-is-subset + (implies (subset vars variables) + (subset vars (remove-duplicate-occurrences variables)))) + ) + + (local + (defthm cone-variables-are-subset + (implies (and (consistent-equation-record-p variables equations) + (subset vars variables)) + (subset vars (find-all-variables + (set-intersect + (remove-duplicate-occurrences vars) + variables) + variables equations))) + :hints (("Goal" + :do-not-induct t + :in-theory (disable find-all-variables-produces-subset) + :use ((:instance find-all-variables-produces-subset + (vars-prime vars) + (vars (set-intersect + (remove-duplicate-occurrences vars) + variables))))))) + ) + + (local + (defthm circuitp-to-cone-variables + (implies (and (circuitp C) + (subset vars (variables C))) + (subset vars (cone-variables vars C)))) + ) + + (local + (in-theory (disable circuitp cone-variables cone-of-influence-reduction)) + ) + + (defthm cone-of-influence-reduction-for-specific + (implies (and (circuitp C) + (ltl-formulap f) + (subset (create-restricted-var-set f) + (variables C))) + (equal (ltl-semantics-for-circuit (cone-of-influence-reduction + C (create-restricted-var-set + f)) + f) + (ltl-semantics-for-circuit C f))) + :hints (("Goal" + :do-not-induct t + :in-theory (disable cone-of-influence-reduction-is-sound-generalized) + :use ((:instance cone-of-influence-reduction-is-sound-generalized + (interesting-vars (create-restricted-var-set f)) + (vars (create-restricted-var-set f))))))) + + ) +) + +(local +(in-theory (disable ltl-semantics-for-circuit create-restricted-var-set + cone-of-influence-reduction + circuitp ltl-formulap)) +) + +(local +(defthm reduce-problem-cone-reduction + (implies (and (circuitp C) + (ltl-formulap f) + (subset (create-restricted-var-set f) (variables C))) + (equal (ltl-semantics-for-circuit (reduce-problem-cone f C) + f) + (ltl-semantics-for-circuit C f)))) +) + +(local +(in-theory (disable reduce-problem-cone)) +) + +(local +(defun well-formed-problems-p (list) + (if (endp list) T + (and (ltl-formulap (first (first list))) + (circuitp (second (first list))) + (subset (create-restricted-var-set (first (first list))) + (variables (second (first list)))) + (well-formed-problems-p (rest list))))) +) + +(local +(defthm reduce-problem-cone*-reduction + (implies (well-formed-problems-p list) + (equal (ltl-semantics-for-circuits* (reduce-problem-cone* list)) + (ltl-semantics-for-circuits* list))) + :otf-flg t + :hints (("Goal" + :in-theory (enable reduce-problem-cone*) + :do-not '(eliminate-destructors generalize)))) +) + +(local +(defthm subset-member-reduction + (implies (and (subset (set-union x y) z) + (memberp e x)) + (memberp e z)) + :hints (("Goal" + :in-theory (enable set-union)))) +) + +(local +(defthm subset-member-reduction-2 + (implies (and (subset (set-union x y) z) + (memberp e y)) + (memberp e z)) + :hints (("Goal" + :in-theory (enable set-union)))) +) + +(local +(defthm set-union-subset-reduction + (implies (subset (set-union x y) z) + (subset x z)) + :hints (("Goal" + :in-theory (enable set-union)))) +) + +(local +(defthm set-union-subset-reduction-2 + (implies (subset (set-union x y) z) + (subset y z)) + :hints (("Goal" + :in-theory (enable set-union)))) +) + +(local +(defthm conjunction-has-variables-subset-1 + (implies (and (ltl-formulap f) + (equal (len f) 3) + (subset (create-restricted-var-set f) vars)) + (subset (create-restricted-var-set (first f)) vars)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (enable create-restricted-var-set ltl-formulap) + :expand (create-restricted-var-set f)))) +) +(local +(defthm conjunction-has-variables-subset-2 + (implies (and (ltl-formulap f) + (equal (len f) 3) + (subset (create-restricted-var-set f) vars)) + (subset (create-restricted-var-set (third f)) vars)) + :hints (("Goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory (enable create-restricted-var-set ltl-formulap) + :expand (create-restricted-var-set f)))) +) + +(local +(defthm well-formed-append-reduction + (implies (and (force (well-formed-problems-p first)) + (force (well-formed-problems-p second))) + (well-formed-problems-p (append first second)))) +) + +(local +(defthm conjunction-produces-well-formed-problems + (implies (and (circuitp C) + (ltl-formulap f) + (subset (create-restricted-var-set f) (variables C))) + (well-formed-problems-p (reduce-problem-conjunction f C))) + :hints (("Goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize) + :induct (reduce-problem-conjunction f C)))) +) + +(DEFTHM compositional-reduction-is-sound + (implies (and (circuitp C) + (ltl-formulap f) + (subset (create-restricted-var-set f) (variables C))) + (equal (ltl-semantics-for-circuits* (compositional-reduction C f)) + (ltl-semantics-for-circuit C f)))) diff --git a/books/workshops/2003/ray-matthews-tuttle/support/sets.lisp b/books/workshops/2003/ray-matthews-tuttle/support/sets.lisp new file mode 100644 index 0000000..2e3a4ff --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/sets.lisp @@ -0,0 +1,137 @@ +(in-package "ACL2") + +#| + + sets.lisp + ~~~~~~~~~ + +In this book, we discuss the basic theory of flat sets. We define the functions +subset, set-intersect, set-union and set-equal, and prove properties of these +functions. I include the records book here, just so that I dont have two +set-memberp functions. I do not know if this is going to be useful, but now I +am not feeling like I want to do much (what with feeling drowsy and depressed +and all) and so I thought this would just be an interesting exercise and be +useful later, since anyway I would need to reason about sets in model-checking. + +|# + +(include-book "records") + +(defun subset (x y) + (if (endp x) T + (and (memberp (first x) y) + (subset (rest x) y)))) + +(defun set-intersect (x y) + (cond ((endp x) nil) + ((memberp (first x) y) + (cons (first x) (set-intersect (rest x) y))) + (t (set-intersect (rest x) y)))) + +(defun set-union (x y) + (cond ((endp x) y) + ((memberp (first x) y) + (set-union (rest x) y)) + (t (cons (first x) (set-union (rest x) y))))) + +(defun set-equal (x y) + (and (subset x y) + (subset y x))) + +;; We prove that set-equal is an equivalence relation. + +(local +(defthm proper-subset-is-a-subset + (implies (subset x y) + (subset x (cons a y)))) +) + +(defthm subset-is-reflexive + (subset x x)) + +(defthm subset-is-transitive + (implies (and (subset x y) + (subset y z)) + (subset x z))) + +(defthm subset-of-empty-is-empty + (implies (and (not (consp x)) + (subset y X)) + (not (consp y)))) + + +;; Just prove that set-equal is an equivalence now, should be trivial. + +(defequiv set-equal) + +;; We have got reflexivity, and transitivity so far for subset, show that it is +;; anti-symmetric. + +(defthm subset-is-antisymmetric + (implies (and (subset x y) + (subset y x)) + (set-equal x y)) + :rule-classes :forward-chaining) + +;; This completes the properties of subset relation. + + +;; Now show how union and intersection work with subset. + +(defthm intersect-is-a-subset-1 + (subset (set-intersect x y) x)) + +(defthm intersect-is-a-subset-2 + (subset (set-intersect x y) y)) + +(defthm union-is-a-subset-1 + (subset x (set-union x y))) + +(defthm union-is-a-subset-2 + (subset y (set-union x y))) + +;; This completes interaction of union and intersection with subset. + +;; Now show interaction between subset and memberp functions + +(defthm superset-contains-everything + (implies (and (memberp e x) + (subset x y)) + (memberp e y)) + :rule-classes :forward-chaining) + +;; And let us do the consp of subset reduction + +(defthm subset-of-nil-is-nil + (implies (and (not (consp y)) + (subset x y)) + (not (consp x)))) + +;; This completes interaction between subset and memberp. + +;; Now we define a proper subset and show it is irreflexive. + +(defun proper-subset (x y) + (and (subset x y) + (not (subset y x)))) + +(defthm proper-subset-is-irreflexive + (not (proper-subset x x))) + +(defthm proper-subset-is-transitive + (implies (and (proper-subset x y) + (proper-subset y z)) + (proper-subset x z))) + +(defthm proper-subset-is-stronger-than-subset + (implies (proper-subset x y) + (subset x y))) + +;; So I think we have proved enough theorems about sets for now, and we disable +;; all the functions. + +(in-theory (disable proper-subset set-union set-equal set-intersect)) + +;; Note: Unfortunately we cannot disable subset, since it is used everywhere +;; else. It might be worthwhile to do a more thorough job of the rewrite rules +;; and at least try doing it. But I am not sure. diff --git a/books/workshops/2003/ray-matthews-tuttle/support/total-order.lisp b/books/workshops/2003/ray-matthews-tuttle/support/total-order.lisp new file mode 100644 index 0000000..b0887c6 --- /dev/null +++ b/books/workshops/2003/ray-matthews-tuttle/support/total-order.lisp @@ -0,0 +1,33 @@ +; This total order book, put together by Matt Kaufmann, is culled from events +; contributed by Pete Manolios and also benefits from contributions by Rob +; Sumners. + +(in-package "ACL2") + +(defun << (x y) + (declare (xargs :guard t)) + (and (lexorder x y) + (not (equal x y)))) + +(defthm <<-irreflexive + (not (<< x x))) + +(defthm <<-transitive + (implies (and (<< x y) + (<< y z)) + (<< x z))) + +(defthm <<-asymmetric + (implies (<< x y) + (not (<< y x)))) + +(defthm <<-trichotomy + (implies (and (not (<< y x)) + (not (equal x y))) + (<< x y))) + +(defthm <<-implies-lexorder + (implies (<< x y) + (lexorder x y))) + +(in-theory (disable <<)) diff --git a/books/workshops/2003/schmaltz-al-sammane-et-al/combining.pdf.gz b/books/workshops/2003/schmaltz-al-sammane-et-al/combining.pdf.gz Binary files differnew file mode 100644 index 0000000..848b0d3 --- /dev/null +++ b/books/workshops/2003/schmaltz-al-sammane-et-al/combining.pdf.gz diff --git a/books/workshops/2003/schmaltz-al-sammane-et-al/combining.ps.gz b/books/workshops/2003/schmaltz-al-sammane-et-al/combining.ps.gz Binary files differnew file mode 100644 index 0000000..41d09b4 --- /dev/null +++ b/books/workshops/2003/schmaltz-al-sammane-et-al/combining.ps.gz diff --git a/books/workshops/2003/schmaltz-al-sammane-et-al/math-slides.pdf.gz b/books/workshops/2003/schmaltz-al-sammane-et-al/math-slides.pdf.gz Binary files differnew file mode 100644 index 0000000..7027167 --- /dev/null +++ b/books/workshops/2003/schmaltz-al-sammane-et-al/math-slides.pdf.gz diff --git a/books/workshops/2003/schmaltz-al-sammane-et-al/math-slides.ps.gz b/books/workshops/2003/schmaltz-al-sammane-et-al/math-slides.ps.gz Binary files differnew file mode 100644 index 0000000..ce3fa91 --- /dev/null +++ b/books/workshops/2003/schmaltz-al-sammane-et-al/math-slides.ps.gz diff --git a/books/workshops/2003/schmaltz-al-sammane-et-al/support/acl2link.txt b/books/workshops/2003/schmaltz-al-sammane-et-al/support/acl2link.txt new file mode 100644 index 0000000..33076a9 --- /dev/null +++ b/books/workshops/2003/schmaltz-al-sammane-et-al/support/acl2link.txt @@ -0,0 +1,56 @@ +****************************************************************************** + + ACL2-MATHEMATICA LINK + + TIMA - VDS, Grenoble, France + + Al Sammane Ghiath, Borrione Dominique, Ostier Pierre + + Schmaltz Julien and Toma Diana + +***************************************************************************** + +acl2link is an executable that links Mathematica and ACL2 through a pipe. + +----------------------------------------------------------- +INSTALL + +To install the link, just execute: + + +In[1]:= Install["acl2link"] + + +in Mathematica. You will get: + + +Out[1]= LinkObject[./acl2link, 1, 1] + +In[2]:= + +Now, you can call ACL2 in Mathematica through the functions + +callAcl2["string"], + +where string is send to ACL2 and the last line of the ACL2 message is returned. +For instance: + +In[2]:= callAcl2["(defthm foo (equal x x) :rule-classes nil)"] + +Out[2]= FOO + +In[3]:= + +------------------------------------------------------------ +UNINSTALL + +To uninstall acl2link (before exiting mathematica), execute : + +closeAcl2[] + + +In[4]:= closeAcl2[] + +Out[4]= 0 + + diff --git a/books/workshops/2003/schmaltz-al-sammane-et-al/support/consistency.lisp b/books/workshops/2003/schmaltz-al-sammane-et-al/support/consistency.lisp new file mode 100644 index 0000000..c17a9c5 --- /dev/null +++ b/books/workshops/2003/schmaltz-al-sammane-et-al/support/consistency.lisp @@ -0,0 +1,85 @@ +;------------------------------------------------------------------------------------ +; +; File: consistency.lisp +; April 2003 +; Authors: Toma Diana and Schmaltz Julien +; TIMA - VDS, Grenoble, France +; Functions checking the consistency of hypotheses +; +;------------------------------------------------------------------------------------ + + +(in-package "ACL2") + + +; we use the expander book +(include-book "../../../../misc/expander") + +(set-state-ok t) + +(program) + + +; consistency returns nil in case of errors when calling tool1-fn +; normally returns the list of contradictory constraints of L +; Note that at call, L contains a contradiction + +(defun consistency (L Ih i state) + (if (and (true-listp L) + (true-listp Ih) + (integerp i) + (< 0 i)) + (cond ((endp L) ; last step of the algorithm + (value Ih)); L empty means that L is the minal set and now Ih = L + ((< (length L) i) (value nil)) ;error: i out of L range + ((endp Ih) ; first step(s) of the algorithm (at call Ih is empty) + (mv-let (erp val state) + (tool1-fn (subseq L 0 i) state nil t nil t t) + (if erp + (value nil) ; tool1-fn error case + (if (nth 1 val) ; is either a list of consistent constraints or nil + (consistency L Ih (+ i 1) state) + ; if no contradictions in L[0 .. i], proceed with L[0 .. i+1] + ; else the added constraint is removed from L and added to Ih + (consistency (remove (nth (- i 1) L) L) + (cons (nth (- i 1) L) Ih) 1 state))))) + (t (mv-let (erp val state) ; one step of the algorithm + (tool1-fn Ih state nil t nil t t) + (if erp + (value nil) ; tool1-fn error case + (if (nth 1 val) + (mv-let (erp1 val1 state) + (tool1-fn (append Ih (subseq L 0 i)) + state nil t nil t t) + ; check of the consistency of the union of Ih and L[0 .. i] + (if erp1 + (value nil) ; tool1-fn error case + (if (nth 1 val1) + (consistency L Ih (+ i 1) state) + (consistency (remove (nth (- i 1) L) L) + (cons (nth (- i 1) L) Ih) 1 state)))) + (value Ih)))))) + (value nil))) + + + +; check-consistency returns t if l is consistent +; else it calls consistency + +(defun check-consistency (l state) + (if (true-listp l) + (cond ((endp l) (value nil)) + (t (mv-let (erp val state) + (tool1-fn l state nil t nil t t) + (if erp + (value nil) ; tool1-fn error case + (if (nth 1 val) + (value t) ; l contains no contradictions + (consistency l nil 1 state)))))) + ; l is not consistent and + ; we call consistency to extract the set of contradictory hyps + (value nil))) + +(logic) + + diff --git a/books/workshops/2003/schmaltz-borrione/schmaltz-borrione-final.pdf.gz b/books/workshops/2003/schmaltz-borrione/schmaltz-borrione-final.pdf.gz Binary files differnew file mode 100644 index 0000000..0840da6 --- /dev/null +++ b/books/workshops/2003/schmaltz-borrione/schmaltz-borrione-final.pdf.gz diff --git a/books/workshops/2003/schmaltz-borrione/schmaltz-borrione-final.ps.gz b/books/workshops/2003/schmaltz-borrione/schmaltz-borrione-final.ps.gz Binary files differnew file mode 100644 index 0000000..b156b14 --- /dev/null +++ b/books/workshops/2003/schmaltz-borrione/schmaltz-borrione-final.ps.gz diff --git a/books/workshops/2003/schmaltz-borrione/schmaltz-presentation.pdf.gz b/books/workshops/2003/schmaltz-borrione/schmaltz-presentation.pdf.gz Binary files differnew file mode 100644 index 0000000..386c66d --- /dev/null +++ b/books/workshops/2003/schmaltz-borrione/schmaltz-presentation.pdf.gz diff --git a/books/workshops/2003/schmaltz-borrione/schmaltz-presentation.ps.gz b/books/workshops/2003/schmaltz-borrione/schmaltz-presentation.ps.gz Binary files differnew file mode 100644 index 0000000..bf22e6c --- /dev/null +++ b/books/workshops/2003/schmaltz-borrione/schmaltz-presentation.ps.gz diff --git a/books/workshops/2003/schmaltz-borrione/support/arbiter.lisp b/books/workshops/2003/schmaltz-borrione/support/arbiter.lisp new file mode 100644 index 0000000..ade2277 --- /dev/null +++ b/books/workshops/2003/schmaltz-borrione/support/arbiter.lisp @@ -0,0 +1,505 @@ +;------------------------------------------------------------------------ +; +; File : arbiter.lisp +; Author : Julien Schmaltz +; April 2003 +; TIMA-VDS +; Grenoble, France +; +;------------------------------------------------------------------------ + + +(in-package "ACL2") + +; my little book on inequalities +(include-book "inequalities") + +; the book on decoder and select +(include-book "decoder") + +; my book with the needed predicates +(include-book "predicates") + +;-------------------------------------------------------------------------- + +; Bus Arbitration Modeling + + +;------------------------------------------------------------------------------ +; +; first step of the algorithm +; +;----------------------------------------------------------------------------- + +; function that returns the number of the first line containing at least one +; request or 0 + +(defun stage_P (L) + (cond ((endp L) 0) + ((no_requestp_matrix L) 0) + ((not (no_requestp (car L))) 0) + (t + (+ 1 (stage_P (cdr L)))))) + +; ACL2 finds that the result is a positive integer + +;------------------------------------------------------------------------------ + +; Verification of this step + +;------------------------------------------------------------------------------ + + +; this step is correct if: + + +; stage_P returns an integer + +;(defthm integerp_stage_P +; (integerp (stage_P L))) +; proven during definition + +; stage_P returns a positive + +;(defthm stage_P_>=0 +; (<= 0 (stage_P L))) + +; stage number <= master number - 1 + +(defthm stage_p_<=_len_L-1 + (implies (and (consp L) (not (no_requestp_matrix L))) + (<= (stage_P L) (- (len L) 1)))) +; Prove 0.05 + +; or stage number < master number + +(defthm stage_p_<_len_L + (implies (and (consp L) (not (no_requestp_matrix L))) + (< (stage_P L) (len L)))) +; Prove 0.03 + +; any line before the chosen one RLINE contains no pending request + +(defthm prior_scheme + (implies (and (equal (stage_P L) i) + (< j i) (<= 0 j)) + (no_requestp (nth j L))) + :rule-classes ((:rewrite :match-free :all))) +; Prove 0.08 + +; A chosen stage contains at least one request + +(defthm chosen_stage_not_empty + (implies (and (equal (stage_P L) i) (not (no_requestp_matrix L))) + (not (no_requestp (nth i L))))) +; Prove 0.19 + +(in-theory (disable stage_P)) + + +;------------------------------------------------------------------------------ +; +; Second step of the algorithm +; +;----------------------------------------------------------------------------- + +; computation of the next requesting master to be granted the bus according to +; a round robin scheme + +(defun round_robin (RLINE Last_Granted) + (cond ((no_requestp RLINE) 0) + ((no_requestp (lastn (1+ Last_Granted) RLINE)) + (find_next_1 (firstn (1+ Last_Granted) RLINE))) + (t + (+ (1+ Last_Granted) (find_next_1 (lastn (1+ Last_Granted) RLINE)))))) + +; Type-presciption: acl2-numberp + +;------------------------------------------------------------------------------ + +; Verification of this step + +;------------------------------------------------------------------------------ + +; round_robin returns an integer if its inputs are integers + +(defthm integerp_round_robin + (implies (integerp Last_Granted) ;(<= 0 Last_Granted)) + (integerp (round_robin RLINE Last_Granted)))) +; Prove 0.01 + +; if inputs are positive then rounb_robin is positive + +(defthm round_robin_>=_0 + (implies (<= 0 Last_Granted) + (<= 0 (round_robin RLINE Last_Granted)))) +; Prove 0.02 + +; If RLINE has no request then round_robin returns 0 + +(defthm no_req_=>_round_robin_=_0 + (implies (no_requestp RLINE) + (equal (round_robin RLINE Last_Granted) 0))) + +; we prove that round_robin returns an integer less than the length of RLINE + +; if the last part of the list L containing at least one request +; contains no request, then the first part of the list contains at least one +; request + +(defthm lemma_for_round_robin_<_case_2 + (implies (and (not (no_requestp L)) (no_requestp (lastn n L))) + (not (no_requestp (firstn n L)))) + :hints (("GOAL" :in-theory (enable no_requestp lastn firstn)))) +; Prove 0.32 + +;(defthm round_robin_<_N_case_1 +; (implies (and (no_requestp RLINE) (equal (len RLINE) N) (consp RLINE)) +; (< (round_robin RLINE Last_Granted) N))) + +(defthm lemma1_case_2 + (implies (and (not (no_requestp (firstn n L))) + (list_of_1_and_0 (firstn n L))) + (<= (find_next_1 (firstn n L)) (len (firstn n L)))) + :hints (("GOAL" :use (:instance find_next_1_<_len_L (L (firstn n L))) + :in-theory (disable find_next_1_<_len_L))) + :rule-classes ((:rewrite :match-free :all))) +; Prove 0.33 + +(defthm lemma2_case_2 + (implies (and (<= a b) (< b c)) + (< a c)) + :rule-classes ((:rewrite :match-free :all))) + +(defthm lemma3_case_2 + (implies (and (<= 0 n) (< n (len L))) + (< (len (firstn n L)) (len L)))) +; Prove 0.02 + +(defthm lemma4_case_2 + (implies (and (not (no_requestp (firstn n L))) + (< n (len L)) (<= 0 n) + (list_of_1_and_0 (firstn n L))) + (< (find_next_1 (firstn n L)) (len L))) + :hints (("GOAL" :use (:instance lemma1_case_2) + :do-not-induct t + :in-theory (disable len-firstn lemma1_case_2)))) +; Prove 0.26 + +(defthm round_robin_<_N_case_2 + (implies (and (no_requestp (lastn (1+ Last_Granted) RLINE)) + (< (1+ Last_Granted) (len RLINE)) + (not (no_requestp RLINE)) + (list_of_1_and_0 (firstn (1+ Last_Granted) RLINE)) + (< 0 (1+ Last_Granted))) + (< (round_robin RLINE Last_Granted) (len RLINE))) + :hints (("GOAL" :do-not-induct t + :in-theory (disable firstn)))) +; Prove 0.05 + +(defthm lemma1_case_3 + (implies (and (not (no_requestp (lastn n L))) + (list_of_1_and_0 (lastn n L))) + (< (find_next_1 (lastn n L)) (len (lastn n L)))) + :hints (("GOAL" :use (:instance find_next_1_<_len_L (L (lastn n L))) + :in-theory (disable find_next_1_<_len_L)))) +; subsume but useful +; Prove 0.01 + +;(defthm lemma2_case_3 +; (implies (and (integerp n) (< 0 n) (< n (len L)) (consp L)) +; (<= (len (lastn n L)) (- (len L) n)))) ; USELESS + +;(defthm lemma3_case_3 +; (implies (and (< a b) (<= b c)) +; (< a c)) +; :rule-classes ((:rewrite :match-free :all))) ; USELESS + +(defthm lemma4_case_3 + (implies (and (integerp n) (< 0 n) (< n (len L)) + (list_of_1_and_0 (lastn n L)) + (not (no_requestp (lastn n L))) + (consp L)) + (< (find_next_1 (lastn n L)) (- (len L) n))) + :hints (("GOAL" :use (:instance lemma1_case_3) + :do-not-induct t + :in-theory (disable lemma1_case_3)))) +; Prove 0.19 + +(defthm lemma5_case_3 + (implies (and (integerp n) (< 0 n) (< n (len L)) + (list_of_1_and_0 (lastn n L)) + (not (no_requestp (lastn n L))) + (consp L)) + (< (+ n (find_next_1 (lastn n L))) (len L))) + :hints (("GOAL" :use (:instance lemma4_case_3) + :do-not-induct t + :in-theory (disable lemma4_case_3)))) +; Prove 0.06 + +(defthm round_robin_<_N_case_3 + (implies (and (not (no_requestp (lastn (1+ Last_Granted) RLINE))) + (not (no_requestp RLINE)) + (integerp Last_Granted) (<= 0 Last_Granted) + (list_of_1_and_0 (lastn (1+ Last_Granted) RLINE)) + (consp (lastn (1+ Last_Granted) RLINE)) + (< (1+ Last_Granted) (len RLINE))) + (< (round_robin RLINE Last_Granted) (len RLINE))) + :hints (("GOAL" :use (:instance lemma5_case_3 (n (1+ Last_Granted)) + (L RLINE)) + :do-not-induct t + :in-theory (disable lemma5_case_3)))) +; Prove 0.06 + +(defthm list_REQ_=>_list_last + (implies (and (list_of_1_and_0 L) (consp L) + (integerp n) (< 0 n) (< n (len L))) + (list_of_1_and_0 (lastn n L))) + :hints (("GOAL" :in-theory (enable lastn)))) +; Prove 0.80 + +(defthm round_robin_<_N + (implies (and (integerp Last_Granted) (consp RLINE) (<= 0 Last_Granted) + (< (1+ Last_Granted) (len RLINE)) (not (no_requestp RLINE)) + (<= 0 Last_Granted) (list_of_1_and_0 RLINE)) + (< (round_robin RLINE Last_Granted) (len RLINE))) + :hints (("GOAL" :use (:instance round_robin_<_N_case_3) + :do-not-induct t + :in-theory (disable firstn round_robin_<_N_case_3)))) +; Prove 0.24 + +(defthm round_robin_<=N-1 + (implies (and (integerp Last_Granted) (consp RLINE) (<= 0 Last_Granted) + (< (1+ Last_Granted) (len RLINE)) (not (no_requestp RLINE)) + (<= 0 Last_Granted) (list_of_1_and_0 RLINE)) + (<= (round_robin RLINE Last_Granted) (1- (len RLINE)))) + :hints (("GOAL" :use (:instance round_robin_<_N) + :in-theory (disable firstn round_robin_<_N)))) +; Prove 0.25 + +; No_Deadlock + +(defthm find_not_equal_last_granted + (implies (and (not (equal last_granted i)) (equal (nth i L) 1) + (< i last_granted) + (integerp last_granted) (integerp i) (<= 0 i)) + (not (equal (find_next_1 L) last_granted))) + :hints (("GOAL" :in-theory (enable find_next_1))) + :rule-classes ((:rewrite :match-free :all))) +; Prove 0.24 + +(defthm lemma1_no_deadlock + (implies (and (integerp last_granted) + (integerp i) + (equal (nth last_granted RLINE) 1) + (equal (nth i RLINE) 1) + (list_of_1_and_0 RLINE) + (<= 0 i) + (< i (1+ last_granted)) + (not (equal last_granted i))) + (not (equal (round_robin RLINE Last_Granted) Last_Granted))) + :hints (("GOAL" :use (:instance find_not_equal_last_granted + (L (firstn (1+ Last_Granted) RLINE))) + :in-theory (disable find_not_equal_last_granted firstn))) + :rule-classes ((:rewrite :match-free :all))) +; prove 0.24 + +(defthm lemma2_no_deadlock + (implies (and (integerp i) (integerp n) (< 0 n)) + (implies (and (no_requestp (lastn n L)) (equal (nth i L) 1)) + (< i n))) + :hints (("GOAL" :in-theory (enable lastn no_requestp))) + :rule-classes ((:rewrite :match-free :all)) +) +; Prove 0.32 + +(defthm no_deadlock + (implies (and (integerp i) (<= 0 i) + (equal (nth Last_Granted RLINE) 1) (list_of_1_and_0 RLINE) + (not (equal Last_granted i))) + (implies (equal (nth i RLINE) 1) + (not (equal (round_robin RLINE Last_Granted) Last_Granted)))) + :hints (("GOAL" :use lemma1_no_deadlock + :in-theory (disable lemma1_no_deadlock firstn))) + :rule-classes ((:rewrite :match-free :all)) +) + +; Prove 0.90 + +(in-theory (disable round_robin)) + +;------------------------------------------------------------------------------ +; +; Third step of the algorithm +; +;----------------------------------------------------------------------------- + + +; computation of the number of the new granted master + +(defun master_num (MREQ N Last_Granted) + (+ (* (stage_P MREQ) N) + (round_robin (nth (stage_P MREQ) MREQ) Last_Granted))) + +; type-prescription: acl2-numberp + +;------------------------------------------------------------------------------ + +; Verification of this step + +;------------------------------------------------------------------------------ + +; master_num returns an integer + +(defthm int+int=int + (implies (and (integerp a) (integerp b)) + (integerp (+ a b)))) ; not subsume, +; Prove 0.00 + +(defthm integerp_master_num + (implies (and (integerp N) + (integerp last_granted)) + (integerp (master_num MREQ N last_granted)))) +; Prove 0.04 + +; master_num >= 0 + +(defthm pos+pos=pos + (implies (and (<= 0 a) (<= 0 b)) + (<= 0 (+ a b)))); not subsume + +(defthm master_num_>=0 + (implies (and (integerp N) (< 0 N) + (integerp Last_Granted) (<= 0 Last_Granted)) + (<= 0 (master_num MREQ N Last_Granted)))) +; Prove 0.03 + +;the default_master (number 0) is chosen when necessary + +(defthm default_master_master_num + (implies (no_requestp_matrix MREQ) + (equal (master_num MREQ N Last_Granted) 0)) + :hints (("GOAL" :in-theory (enable stage_P round_robin)))) +; Prove 0.24 + +; the computed number is strictly less than the number of masters +; number of masters = N * P + + +(defthm len_nth_uni_list + (implies (and (integerp p) (<= 0 p) + (< p (len l)) + (uniform_listp l) + (consp (cdr l))) + (equal (len (nth p l)) + (len (car l))))) +; Prove 0.35 + +(defthm master_num_<_P*N + (implies (and ;(< 0 (stage_p MREQ)) + (integerp N) (< 0 N) + (integerp Last_Granted) (<= 0 Last_Granted) + (integerp P) (equal P (len MREQ)) + (equal (len (car MREQ)) N) + (consp MREQ) + (not (no_requestp_matrix MREQ)) + (uniform_listp MREQ) + (consp (cdr MREQ)) + (< (1+ Last_Granted) N) + (list_of_1_and_0 (nth (stage_P MREQ) MREQ)) + ) + (< (master_num MREQ N Last_Granted) (* P N))) + :hints (("GOAL" :use ((:instance stage_P_<_len_L (L MREQ)) + (:instance round_robin_<=N-1 + (RLINE (nth (stage_P MREQ) MREQ)))) + :in-theory (e/d () + (COMMUTATIVITY-OF-* COMMUTATIVITY-OF-+ + uniform_listp no_requestp_matrix + stage_P_<_len_L + firstn nth + round_robin_<=N-1))))) +; the proof require the inequalities book +; Prove 0.60 + +(in-theory (disable master_num)) + +;------------------------------------------------------------------------------ +; +; Last step of the algorithm +; +;----------------------------------------------------------------------------- + +; builds the ouptut vector + +(defun arbiter (N P MREQ Last_Granted) + (select (* N P) (master_num MREQ N Last_Granted))) + +;------------------------------------------------------------------------------ + +; Verification de cette etape + +;------------------------------------------------------------------------------ + +; arbiter returns a true-list +; found during definition +;(defthm true-listp_AHB_Arbiter +; (true-listp (AHB_Arbiter N P MREQ Last_Granted))) + +; length of arbiter is the number of masters = N*P + +(defthm len_arbiter + (implies (and (integerp N) (< 0 N) (integerp P) (<= 0 P)) + (equal (len (arbiter N P MREQ Last_Granted)) (* N P)))) +; Prove 0.02 + +; arbiter is a cons-pair + +(defthm consp_arbiter + (implies (and (integerp N) (< 0 N) (integerp P) (< 0 P)) + (consp (arbiter N P MREQ Last_Granted)))) +; Prove 0.00 + +; The bit at 1 is the desired one + +(defthm nth_arbiter_=_1 + (implies (and (integerp N) (< 0 N) + (integerp Last_Granted) (<= 0 Last_granted) + (integerp P) + (equal P (len MREQ)) + (equal (len (car MREQ)) N) + (not (no_requestp_matrix MREQ)) + (uniform_listp MREQ) + (< (1+ Last_granted) N) + (consp MREQ) + (consp (cdr MREQ)) + (list_of_1_and_0 (nth (stage_P MREQ) MREQ)) + ) + (equal (nth (master_num MREQ N Last_granted) + (arbiter N P MREQ Last_granted)) 1)) + :hints (("GOAL" :use (:instance master_num_<_P*N) + :do-not-induct t + :in-theory (disable master_num_<_P*N + DISTRIBUTIVITY + )))) +; Prove 1.43 + +; we prove the mutual exlusion, i.e. all other bits are 0 + +(defthm nth_arbiter_=_0 + (implies (and (integerp N) + (equal P (len MREQ)) + (integerp i) (<= 0 i) (< i (* P N)) + (not (equal i (master_num MREQ N last_Granted))) + ) + (equal (nth i + (arbiter N P MREQ Last_granted)) 0))) +; Prove 0.03 + +(in-theory (disable arbiter)) +;------------------------------------------------------------------------------ +;Summary +;Form: (CERTIFY-BOOK "arbiter" ...) +;Rules: NIL +;Warnings: Guards, Subsume, Non-rec and Compiled file +;Time: 13.76 seconds (prove: 5.47, print: 0.55, other: 7.74) +; "/h3/schmaltz/These/ACL2_Workshop/2003/Support/arbiter.lisp" diff --git a/books/workshops/2003/schmaltz-borrione/support/decoder.lisp b/books/workshops/2003/schmaltz-borrione/support/decoder.lisp new file mode 100644 index 0000000..022faac --- /dev/null +++ b/books/workshops/2003/schmaltz-borrione/support/decoder.lisp @@ -0,0 +1,218 @@ +;------------------------------------------------------------------------ +; +; File : decoder.lisp +; Author : Julien Schmaltz +; +; April 2003 +; TIMA-VDS +; Grenoble, France +; +;------------------------------------------------------------------------ + +(in-package "ACL2") + +; book on arithmetics +(include-book "../../../../arithmetic/top") + +(include-book "../../../../arithmetic-2/floor-mod/floor-mod") + +;------------------------------------------------------------------------- +; +; +; SELECT +; +; +;------------------------------------------------------------------------ + +; function that builds a list of bits where +; the first element is the least significant bit +; the bit at position sel is '1' and others are '0' + +(defun select (Card_S SEL) + (cond ((not (integerp Card_S)) nil) + ((<= Card_S 0) nil) + ((equal SEL 0) + (cons 1 (select (1- Card_S) (1- SEL)))) + (t + (cons 0 (select (1- Card_S) (1- SEL)))))) + +;---------------------------------------------------------------------------- +; +; +; LEMMAS ON SELECT +; +;---------------------------------------------------------------------------- + + +; 1- select returns a true-list +; (ACL2 finds that when accepting the definition) + +;(defthm true-listp_select +; (true-listp (select a b))) + +; 2- the length of the list is equal to Card_S + +(defthm len_select + (implies (and (integerp Card_S) (<= 0 Card_S)) + (equal (len (select Card_S sel)) Card_S))) +; Prove 0.03 + +; 3- select returns a cons-pair when Card_S> 0 + +(defthm consp_select + (implies (and (integerp Card_S) (< 0 Card_S)) + (consp (select Card_S sel))) + :hints (("GOAL" :expand (select 1 sel)))) +; Prove 0.03 + +; 4- if (integerp Card_S) and (< 0 Card_S) then (car (select Card_S0)) is 1 +; this lemma is needed to ease the proof of the next theorem + +(defthm car_select_=_1 + (implies (and (integerp Card_S) (< 0 Card_S)) + (equal (car (select Card_S 0)) 1))) +; Prove 0.01 + +; 5- the i'th bit of (select Card_S i) is 1 +; That proofs that the selection of the slave is correct +; SLAVE CHOICE CORRECTNESS +(defthm ith_select_=_1 + (implies (and (integerp i) (integerp Card_S) + (>= i 0) (> Card_S i)) + (equal (nth i (select Card_S i )) 1))) +; Prove 0.06 + +; 6- if p is not equal to i, then (car (select a i)) is 0 +; lemma needed for the proof of the UNICITY theorem + +(defthm car_select_=_0 + (implies (and (integerp Card_S) (< 0 Card_S) (not (equal i 0))) + (equal (car (select Card_S i)) 0)) + :hints (("GOAL" + :expand (select 1 I)))) +; Prove 0.06 + +; 7- The p'th is 0 + +; function suggesting the induction scheme for the proof of the UNICITY theorem + +(local + (defun function_hint_th2_select (p Card_S sel) + (cond ((zp p) 0) + ((and (not (integerp Card_S)) + (not (integerp sel))) + 0) + (t (+ 1 (function_hint_th2_select (1- p) + (1- Card_S) + (1- sel)))))) +) + +; UNIQUENESS OF THE SELECTION +(defthm pth_select_=_0 + (implies (and (integerp p) (integerp Card_S) + (<= 0 p) (< p Card_S) + (not (equal p i))) + (equal (nth p (select Card_S i)) 0)) + :hints (("GOAL" + :induct (function_hint_th2_select p Card_S i)))) +; Prove 0.10 + +(in-theory (disable select)) +;------------------------------------------------------------------------- +; +; +; DECODER +; +; +;------------------------------------------------------------------------ + + +;-------------------------------------------------------------------------- +; +; function modeling the address decoder +; Card_S = number of slaves +; ADDR = Global address of data +; MEM_SIZE = memory size of each unit + +; the local address UNADDR is equal to ADDR mod MEM_SIZE +; the slave number i that possed the datum at ADDR is HADDR/MEM_SIZE + +(defun decoder (MEM_SIZE Card_S HADDR) + (select Card_S (floor HADDR MEM_SIZE))) + +; when accepting the function ACL2 finds that this function returns a true-list + +;------------------------------------------------------------------------- +; +; PREUVE DE AHB_DECODER +; +;------------------------------------------------------------------------ + + +; lemma stating that (floor ADDR MEM_SIZE) < Card_S +; if ADDR = Card_S * MEM_SIZE +; lemma needed for the proof of the next theorem + +(defthm floor_<_Card_S + (implies (and (< HADDR (* Card_S MEM_SIZE)) + (integerp HADDR) (integerp MEM_SIZE) + (< 0 MEM_SIZE) (< 0 Card_S) (<= 0 ADDR) + (integerp Card_S)) + (< (floor HADDR MEM_SIZE) Card_S)) + :hints (("GOAL" :in-theory (disable floor COMMUTATIVITY-OF-* FLOOR-MOD-ELIM + DISTRIBUTIVITY-OF-/-OVER-* + FUNCTIONAL-SELF-INVERSION-OF-/)))) +; Prove 1.70 + +; decoder returns 1 + +(defthm decoder_nth_1 + (implies (and (< HADDR (* Card_S MEM_SIZE)) + (integerp HADDR) (integerp MEM_SIZE) + (< 0 MEM_SIZE) (< 0 Card_S) (<= 0 HADDR) + (integerp Card_S)) + (equal (nth (floor HADDR MEM_SIZE) + (decoder MEM_SIZE Card_S HADDR)) 1)) + :hints (("GOAL" + :in-theory (disable floor )))) +; Prove 0.11 + +; decoder returns 0 + +(defthm decoder_nth_0 + (implies (and (integerp p) (integerp Card_S) + (<= 0 p) (< p Card_S) + (not (equal p (floor HADDR MEM_SIZE)))) + (equal (nth p (decoder MEM_SIZE Card_S HADDR)) 0)) + :hints (("GOAL" :in-theory (disable floor)))) +; Prove 0.02 + + +; DECODER returns a true-list +; (already found by ACL2) +;(defthm true-listp_DECODER +; (true-listp (DECODER MEM_SIZE Card_S ADDR))) + +; the length of DECODER is its second operand + +(defthm len_DECODER + (implies (and (integerp Card_S) (<= 0 Card_S)) + (equal (len (DECODER MEM_SIZE Card_S HADDR)) Card_S))) + +; DECODER is a conspair + +(defthm consp_DECODER + (implies (and (integerp Card_S) (< 0 Card_S)) + (consp (DECODER MEM_SIZE Card_S HADDR)))) + + +(in-theory (disable DECODER)) + +;------------------------------------------------------------------------ + +;Summary +;Form: (CERTIFY-BOOK "decoder" ...) +;Rules: NIL +;Warnings: Guards and Non-rec +;Time: 7.41 seconds (prove: 2.48, print: 0.24, other: 4.69) +; "/h3/schmaltz/These/ACL2_Workshop/2003/Support/decoder.lisp" diff --git a/books/workshops/2003/schmaltz-borrione/support/inequalities.lisp b/books/workshops/2003/schmaltz-borrione/support/inequalities.lisp new file mode 100644 index 0000000..8c883a7 --- /dev/null +++ b/books/workshops/2003/schmaltz-borrione/support/inequalities.lisp @@ -0,0 +1,100 @@ +;------------------------------------------------------------------------ +; +; File : inequalities.lisp +; Author : Julien Schmaltz +; April 2003 +; TIMA - VDS +; Grenoble, France +;------------------------------------------------------------------------ + +(in-package "ACL2") + + +(include-book "../../../../arithmetic/top") + + +;----------------------------------------------------------------------- +; +; +; Conclusion to reach: a*b + c < P*b +; +; Hypotheses : a, b, c, P are naturals +; a <= P - 1 +; c <= b - 1 +; +; +; +; Intermediate Theorem: a*b + c <= P*b - 1 +; +;------------------------------------------------------------------------- + +; the "majorant" of the sum is the sum of the majorants + +(defthm maj_sum_=_sum_maj + (implies (and (integerp a) (integerp b) + (integerp alpha) (<= 0 a) (<= a alpha)) + (<= (+ a b) (+ alpha b)))) +; Prove 0.00 + +; for positives the majorant of the product is the product of the majorants + +(defthm maj_prod_=_prod_maj + (implies (and (integerp a) (integerp b) (< 0 b) + (integerp alpha) (<= 0 a) (<= a alpha)) + (<= (* a b) (* alpha b))) + :hints (("GOAL" :in-theory (disable COMMUTATIVITY-OF-* DISTRIBUTIVITY)))) +; Prove 0.01 + +; PROOF OF THE INTERMEDIATE THEOREM + +(defthm lemma1 + (implies (and (integerp a) (integerp b) (integerp c) + (<= 0 a) (< 0 b) (integerp alpha) (<= (* a b) (* alpha b))) + (<= (+ (* a b) c) (+ (* alpha b) c)))) +; Prove 0.00 + +(defthm lemma2 + (implies (and (integerp a) (integerp b) (integerp c) + (<= 0 a) (< 0 b) (integerp alpha) (<= a alpha)) + (<= (+ (* a b) c) (+ (* alpha b) c))) + :hints (("GOAL" :use (:instance maj_prod_=_prod_maj) + :in-theory (disable maj_prod_=_prod_maj COMMUTATIVITY-OF-+)))) +; Prove 0.13 + +(defthm lemma3 + (implies (and (integerp a) (integerp b) (integerp c) + (<= 0 a) (< 0 b) (integerp alpha) (<= a alpha) + (<= c (1- b))) + (<= (+ (* a b) c) (+ (* alpha b) (1- b)))) + :hints (("GOAL" :use (:instance lemma2) + :in-theory (disable lemma2)))) +; Prove 0.03 + +(defthm intermediate_theorem + (implies (and (integerp a) (integerp b) (integerp c) + (<= 0 a) (< 0 b) (<= 0 c) (<= c (1- b)) + (<= a (1- P)) (integerp P)) + (<= (+ (* a b) c) (+ (* (1- P) b) (1- b)))) + :hints (("GOAL" :use (:instance lemma3 (alpha (1- P)) ) + :in-theory (disable COMMUTATIVITY-OF-* DISTRIBUTIVITY + COMMUTATIVITY-OF-+ lemma3)))) + +; final theorem + +(defthm final_theorem + (implies (and (integerp a) (integerp b) (integerp c) + (<= 0 a) (< 0 b) (<= 0 c) (<= c (1- b)) + (<= a (1- P)) (integerp P)) + (< (+ (* a b) c) (* P b))) + :hints (("GOAL" :use (:instance intermediate_theorem) + :in-theory (disable intermediate_theorem)))) + +; Prove 0.05 + +;Summary +;Form: (CERTIFY-BOOK "inequalities" ...) +;Rules: NIL +;Warnings: None +;Time: 3.71 seconds (prove: 0.26, print: 0.04, other: 3.41) +; "/h3/schmaltz/These/ACL2_Workshop/2003/Support/inequalities.lisp" + diff --git a/books/workshops/2003/schmaltz-borrione/support/predicates.lisp b/books/workshops/2003/schmaltz-borrione/support/predicates.lisp new file mode 100644 index 0000000..f2d2f75 --- /dev/null +++ b/books/workshops/2003/schmaltz-borrione/support/predicates.lisp @@ -0,0 +1,160 @@ +;------------------------------------------------------------------------ +; +; File : predicates.lisp +; Author : Julien Schmaltz +; April 2003 +; TIMA-VDS +; Grenoble, France +; +;------------------------------------------------------------------------ + + +(in-package "ACL2") + +; ACL2 books on lists +(include-book "../../../../data-structures/list-defuns") + +(include-book "../../../../data-structures/list-defthms") + + +;------------------------------------------------------------------------------ +; +; +; Some predicates used in modeling and proofs +; +; +;------------------------------------------------------------------------------ +; +; recognizer of a list of 0 +; +; +(defun no_requestp (REQ) + (cond ((endp REQ) t) + ((equal (car REQ) 1) nil) + (t (and (equal (car REQ) 0) + (no_requestp (cdr REQ)))))) + +; if no_requestp then the car of L is 0 + +(defthm car_no_requestp + (implies (and (no_requestp L) (consp L)) + (equal (car L) 0))) + +; if no_requestp then L is a list of 0 + +(defthm no_requestp_th1 + (implies (and (no_requestp L) (consp L) (< i (len L))) + (equal (nth i L) 0))) +; prove 0.07 + +(defthm no_requestp_th2 + (implies (no_requestp L) + (not (equal (nth i L) 1)))) +; Prove 0.03 + +(defthm not_no_requestp_cdr_=>_not_no_requestp_L + (implies (not (no_requestp (cdr L))) + (not (no_requestp L)))) + +(in-theory (disable no_requestp)) + +;------------------------------------------------------------------------------ +; recognizer of a matrix with no requests + +(defun no_requestp_matrix (M) + (cond ((endp M) t) + ((no_requestp (car M)) + (no_requestp_matrix (cdr M))) + (t + nil))) + +;------------------------------------------------------------------------------ + +; recognizer of a list of 1 and 0, i.e. a bit vector + +(defun list_of_1_and_0 (L) + (if (endp (cdr L)) + (or (equal (car L) 0) (equal (car L) 1)) + (and (or (equal (car L) 0) (equal (car L) 1)) + (list_of_1_and_0 (cdr L))))) + +(defthm list_of_1_and_0_cdr + (implies (and (list_of_1_and_0 L) (consp (cdr L))) + (list_of_1_and_0 (cdr L)))) + +(defthm list_REQ_=>_list_first + (implies (and (list_of_1_and_0 L) (not (zp n))) + (list_of_1_and_0 (firstn n L)))) +; Prove 0.08 + +;------------------------------------------------------------------------------ + +; function that returns the last elements af a list form the n + 1 + +(defun lastn (n L) + (cond ((endp L) nil) + ((zp n) L) + (t + (lastn (1- n) (cdr L))))) + +(defthm len_lastn + (implies (and (integerp n) (< 0 n) (consp L) (< n (len L))) + (equal (len (lastn n L)) (- (len L) n)))) +; Prove 0.09 + +(defthm lastn_no_requestp + (implies (and (no_requestp L) (consp L)) + (and (no_requestp (firstn n L)) + (no_requestp (lastn n L)))) + :hints (("GOAL" :in-theory (enable no_requestp)))) +; Prove 0.22 + +(defthm len_firstn_2 + (<= (len (firstn n L)) (len L))) +; Prove 0.01 + +(in-theory (disable lastn)) +;------------------------------------------------------------------------------ + +; function that returns the position of the first '1' in the list L + +(defun find_next_1 (L) + (cond ((endp L) 0) + ((equal (car L) 1) + 0) + (t + (+ 1 (find_next_1 (cdr L)))))) + +; FIND_NEXT_ONE < (LEN L) + +(defthm find_next_1_<_len_L + (implies (and (not (no_requestp L)) (list_of_1_and_0 L)) + (< (find_next_1 L) (len L))) + :hints (("GOAL" :in-theory (enable no_requestp)))) +; Prove 0.11 + +(in-theory (disable find_next_1)) +;------------------------------------------------------------------------------ + +; recognizer of a list composed of list with the same length + +(defun uniform_listp (L) + (cond ((endp (cdr L)) t) + ((not (equal (len (car L)) (len (cadr L)))) nil) + (t + (uniform_listp (cdr L))))) + +; if uniform_list len (len (car l)) = (len (cadr L)) + +(defthm l_uni_=>_len_car_=_len_cadr + (implies (and (consp (cdr L)) (uniform_listp L)) + (equal (len (car L)) (len (cadr l))))) + + +;-------------------------------------------------------------------------------- +;Summary +;Form: (CERTIFY-BOOK "predicates" ...) +;Rules: NIL +;Warnings: Guards +;Time: 2.14 seconds (prove: 0.52, print: 0.23, other: 1.39) +; "/h3/schmaltz/These/ACL2_Workshop/2003/Support/predicates.lisp" diff --git a/books/workshops/2003/schmaltz-borrione/support/transfers.lisp b/books/workshops/2003/schmaltz-borrione/support/transfers.lisp new file mode 100644 index 0000000..17c0915 --- /dev/null +++ b/books/workshops/2003/schmaltz-borrione/support/transfers.lisp @@ -0,0 +1,412 @@ +;------------------------------------------------------------------------ +; +; File : transfers.lisp +; Author : Julien Schmaltz +; July 2003 +; TIMA-VDS +; Grenoble, France +; +;------------------------------------------------------------------------ + + +(in-package "ACL2") + +(include-book "decoder") +(include-book "arbiter") + + +;----------------------------------------------------------------------- +; +; Modeling the two interfaces +; +;---------------------------------------------------------------------- + +(defun slave_interface (HSEL HWRITE HADDR HWDATA SD MEM_SIZE) + (if (equal HSEL 1) + (list (list (if (equal HWRITE 1) + 'read + 'write) + (mod HADDR MEM_SIZE) HWDATA) + (list SD)) + + nil)) + +(defun O-slave (x) + (nth 0 (nth 0 x))) + +(defun L-slave (x) + (nth 1 (nth 0 x))) + +(defun D-slave (x) + (nth 2 (nth 0 x))) + +(defun HRDATA (x) + (nth 0 (nth 1 x))) + +(defun master_interface (O L D HRDATA HGRANT) + (if (equal HGRANT 1) + (list (list (if (equal O 'Read) + 1 + 0) + L + D) + (list HRDATA)) + nil)) + +(defun HWRITE (x) + (nth 0 (nth 0 x))) + +(defun HADDR (x) + (nth 1 (nth 0 x))) + +(defun HWDATA (x) + (nth 2 (nth 0 x))) + +(defun D-master (x) + (nth 0 (nth 1 x))) + +;----------------------------------------------------------------------- +; +; Modeling transfers +; +;---------------------------------------------------------------------- + +; a transfer from a master to a slave is the result of the slave interface +; function applied on the result of the master interface function + +(defun trans_M_to_S (O L D N Card_S P Last_Granted MREQ Slave_Number + SD MEM_SIZE) + (slave_interface + (nth Slave_Number + (decoder MEM_SIZE Card_S + (HADDR + (Master_interface O L D SD + (nth (master_num MREQ N Last_Granted) + (arbiter N P MREQ Last_Granted)))))) + (HWRITE + (Master_interface O L D SD + (nth (master_num MREQ N Last_Granted) + (arbiter N P MREQ Last_Granted)))) + (HADDR + (Master_interface O L D SD + (nth (master_num MREQ N Last_Granted) + (arbiter N P MREQ Last_Granted)))) + (HWDATA + (Master_interface O L D SD + (nth (master_num MREQ N Last_Granted) + (arbiter N P MREQ Last_Granted)))) + SD MEM_SIZE)) + +; the function returns a true-list + + +; a transfer from a slave to a master is the result of the master interface +; function applied on the result of the slave interface function + +(defun trans_S_to_M (O L D SD MEM_SIZE Card_S MREQ N P + HWRITE HADDR HWDATA Slave_Number Last_granted) + (master_interface O L D + (HRDATA + (slave_interface + (nth Slave_Number + (decoder MEM_SIZE Card_S L)) + HWRITE + HADDR + HWDATA + SD + MEM_SIZE)) + (nth (master_num MREQ N Last_Granted) + (arbiter N P MREQ Last_Granted)))) +; returns a true-list + + + +; validation of transmission of the address and the data +; from the master to the slave + +(defthm trans_M_to_S_thm + (implies (and + ; P is the number of priority level(s) + (integerp P) (equal P (len MREQ)) + ; N is the length of each level + (equal (len (car MREQ)) N) + ; at least one master + (integerp N) (< 0 N) + ; each level has the same length + (uniform_listp MREQ) + ; the last owner has a valid number + (integerp Last_Granted) (<= 0 Last_Granted) + (< (+ 1 Last_granted) N) + ; at least one request + (not (no_requestp_matrix MREQ)) + (consp MREQ) (consp (cdr MREQ)) + ; each level is a line of bits + (list_of_1_and_0 (nth (stage_P MREQ) MREQ)) + ; at least one slave unit + (integerp Card_S) (< 0 Card_S) + ; L is a valid address + (integerp L) (<= 0 L) (< L (* Card_S MEM_SIZE)) + ; the size of the slave memory is at least one + (integerp MEM_SIZE) (< 0 MEM_SIZE) + ; the slave is active + (equal Slave_Number (floor L MEM_SIZE)) + ) + (and (equal (L-slave + (trans_M_to_S O L D N Card_S P Last_Granted MREQ + Slave_Number 'undef MEM_SIZE)) + (mod L MEM_SIZE)) + (equal (D-slave + (trans_M_to_S O L D N Card_S P Last_Granted MREQ + Slave_Number 'undef MEM_SIZE)) + D))) + :hints (("GOAL" ;:use (:instance decoder_nth_1 (ADDR L)) + :in-theory (disable ;decoder_nth_1 + floor floor-mod-elim nth)))) + +; Prove 5.05 + +; Validation of the read transmission + +(defthm trans_M_to_S_read + (implies (and + ; P is the number of priority level(s) + (integerp P) (equal P (len MREQ)) + ; N is the length of each level + (equal (len (car MREQ)) N) + ; at least one master + (integerp N) (< 0 N) + ; each level has the same length + (uniform_listp MREQ) + ; the last owner has a valid number + (integerp Last_Granted) (<= 0 Last_Granted) + (< (+ 1 Last_granted) N) + ; at least one request + (not (no_requestp_matrix MREQ)) + (consp MREQ) (consp (cdr MREQ)) + ; each level is a line of bits + (list_of_1_and_0 (nth (stage_P MREQ) MREQ)) + ; at least one slave unit + (integerp Card_S) (< 0 Card_S) + ; L is a valid address + (integerp L) (<= 0 L) (< L (* Card_S MEM_SIZE)) + ; the size of the slave memory is at least one + (integerp MEM_SIZE) (< 0 MEM_SIZE) + ; the slave is active + (equal Slave_Number (floor L MEM_SIZE)) + ; the operation is 'read + ;(equal O 'read) + ) + (equal (O-slave + (trans_M_to_S 'read L D N Card_S P Last_Granted MREQ + Slave_Number 'undef MEM_SIZE)) + 'read))) + +; Prove 0.65 + +; validation of the write transmission + +(defthm trans_M_to_S_write + (implies (and + ; P is the number of priority level(s) + (integerp P) (equal P (len MREQ)) + ; N is the length of each level + (equal (len (car MREQ)) N) + ; at least one master + (integerp N) (< 0 N) + ; each level has the same length + (uniform_listp MREQ) + ; the last owner has a valid number + (integerp Last_Granted) (<= 0 Last_Granted) + (< (+ 1 Last_granted) N) + ; at least one request + (not (no_requestp_matrix MREQ)) + (consp MREQ) (consp (cdr MREQ)) + ; each level is a line of bits + (list_of_1_and_0 (nth (stage_P MREQ) MREQ)) + ; at least one slave unit + (integerp Card_S) (< 0 Card_S) + ; L is a valid address + (integerp L) (<= 0 L) (< L (* Card_S MEM_SIZE)) + ; the size of the slave memory is at least one + (integerp MEM_SIZE) (< 0 MEM_SIZE) + ; the slave is active + (equal Slave_Number (floor L MEM_SIZE)) + ; the operation is 'write + ;(equal O 'write) + ) + (equal (O-slave + (trans_M_to_S 'write L D N Card_S P Last_Granted MREQ + Slave_Number 'undef MEM_SIZE)) + 'write))) + +; Prove 0.63 + +(defthm trans_S_to_M_thm + (implies (and + ; P is the number of priority level(s) + (integerp P) (equal P (len MREQ)) + ; N is the length of each level + (equal (len (car MREQ)) N) + ; at least one master + (integerp N) (< 0 N) + ; each level has the same length + (uniform_listp MREQ) + ; the last owner has a valid number + (integerp Last_Granted) (<= 0 Last_Granted) + (< (+ 1 Last_granted) N) + ; at least one request + (not (no_requestp_matrix MREQ)) + (consp MREQ) (consp (cdr MREQ)) + ; each level is a line of bits + (list_of_1_and_0 (nth (stage_P MREQ) MREQ)) + ; at least one slave unit + (integerp Card_S) (< 0 Card_S) + ; L is a valid address + (integerp L) (<= 0 L) (< L (* Card_S MEM_SIZE)) + ; the size of the slave memory is at least one + (integerp MEM_SIZE) (< 0 MEM_SIZE) + ; the slave is active + (equal Slave_Number (floor L MEM_SIZE)) + ) + (equal (D-master + (trans_S_to_M O L D SD MEM_SIZE Card_S MREQ N P HWRITE HADDR + HWDATA Slave_Number Last_Granted)) + SD))) +; Prove 4.48 + + +(in-theory (disable trans_S_to_M trans_M_to_S)) + +; to get a complete transfer a slave application is needed +; we define a small memory + +(defun slave_memory (MEMO O UNADDR D) + (cond ((equal O 'write) + (list (put-nth UNADDR D MEMO) D)) + ((equal O 'read) + (list MEMO (nth UNADDR MEMO))))) + + +(defun single_transfer (O L D N P Card_S Last_Granted MREQ Slave_Number + MEM_SIZE MEMO) + (list + (trans_S_to_M O L D + (nth 1 + (slave_memory MEMO + (O-slave + (trans_M_to_S O L D N Card_S P Last_Granted + MREQ Slave_Number 'undef MEM_SIZE)) + (L-slave + (trans_M_to_S O L D N Card_S P Last_Granted + MREQ Slave_Number 'undef MEM_SIZE)) + (D-slave + (trans_M_to_S O L D N Card_S P Last_Granted + MREQ Slave_Number 'undef MEM_SIZE)))) + MEM_SIZE Card_S MREQ N P O L D + Slave_Number Last_Granted) + (nth 0 + (slave_memory MEMO + (O-slave + (trans_M_to_S O L D N Card_S P Last_Granted + MREQ Slave_Number 'undef MEM_SIZE)) + (L-slave + (trans_M_to_S O L D N Card_S P Last_Granted + MREQ Slave_Number 'undef MEM_SIZE)) + (D-slave + (trans_M_to_S O L D N Card_S P Last_Granted + MREQ Slave_Number 'undef MEM_SIZE)))))) + +; returns a true-list +; a read example +;ACL2 !>(single_transfer 'Read 2 23 2 2 2 0 '((1 0) (1 0) (0 0)) 0 4 '(0 0 33 0 0 0 0 0)) +;(((0 0 0) (33)) (0 0 33 0 0 0 0 0)) +; a write example +;ACL2 !>(single_transfer 'Write 2 23 2 2 2 0 '((1 0) (1 0) (0 0)) 0 4 '(0 0 33 0 0 0 0 0)) +;(((0 0 0) (23)) (0 0 23 0 0 0 0 0)) + +; the read data by the master is the (nth (mod L MEM_SIZE) MEMO) + +(defthm single_read_transfer + (implies (and + ; P is the number of priority level(s) + (integerp P) (equal P (len MREQ)) + ; N is the length of each level + (equal (len (car MREQ)) N) + ; at least one master + (integerp N) (< 0 N) + ; each level has the same length + (uniform_listp MREQ) + ; the last owner has a valid number + (integerp Last_Granted) (<= 0 Last_Granted) + (< (+ 1 Last_granted) N) + ; at least one request + (not (no_requestp_matrix MREQ)) + (consp MREQ) (consp (cdr MREQ)) + ; each level is a line of bits + (list_of_1_and_0 (nth (stage_P MREQ) MREQ)) + ; at least one slave unit + (integerp Card_S) (< 0 Card_S) + ; L is a valid address + (integerp L) (<= 0 L) (< L (* Card_S MEM_SIZE)) + ; the size of the slave memory is at least one + (integerp MEM_SIZE) (< 0 MEM_SIZE) + ; the slave is active + (equal Slave_Number (floor L MEM_SIZE)) + ; the operation is 'read + (equal O 'read) + ) + (equal (D-Master + (nth 0 + (single_transfer O L D N P Card_S Last_Granted MREQ + Slave_Number MEM_SIZE MEMO))) + (nth (mod L MEM_SIZE) MEMO))) + :hints (("GOAL" :use trans_M_to_S_read + :do-not-induct t + :in-theory (disable D-master O-slave L-slave D-slave mod + trans_M_to_S floor-mod-elim len)))) + +; Prove 5.25 + +; a write transfer is a (put-nth (mod ADDR MEM_SIZE) DATA MEMO) + +(defthm single_write_transfer + (implies (and + ; P is the number of priority level(s) + (integerp P) (equal P (len MREQ)) + ; N is the length of each level + (equal (len (car MREQ)) N) + ; at least one master + (integerp N) (< 0 N) + ; each level has the same length + (uniform_listp MREQ) + ; the last owner has a valid number + (integerp Last_Granted) (<= 0 Last_Granted) + (< (+ 1 Last_granted) N) + ; at least one request + (not (no_requestp_matrix MREQ)) + (consp MREQ) (consp (cdr MREQ)) + ; each level is a line of bits + (list_of_1_and_0 (nth (stage_P MREQ) MREQ)) + ; at least one slave unit + (integerp Card_S) (< 0 Card_S) + ; L is a valid address + (integerp L) (<= 0 L) (< L (* Card_S MEM_SIZE)) + ; the size of the slave memory is at least one + (integerp MEM_SIZE) (< 0 MEM_SIZE) + ; the slave is active + (equal Slave_Number (floor L MEM_SIZE)) + ; the operation is 'read + (equal O 'write) + ; mem_size is the size of memo + (equal (len MEMO) MEM_SIZE) + ) + (equal (nth (mod L MEM_SIZE) + (nth 1 (single_transfer O L D N P Card_S Last_Granted MREQ + Slave_Number MEM_SIZE MEMO))) + D)) + :hints (("GOAL" :use trans_M_to_S_write + :do-not-induct t + :in-theory (disable D-master O-slave L-slave D-slave mod + floor-mod-elim len nth trans_M_to_S_write)))) +; Prove 6.70 + diff --git a/books/workshops/2003/sumners/fair.pdf.gz b/books/workshops/2003/sumners/fair.pdf.gz Binary files differnew file mode 100644 index 0000000..f73ccba --- /dev/null +++ b/books/workshops/2003/sumners/fair.pdf.gz diff --git a/books/workshops/2003/sumners/fair.ps.gz b/books/workshops/2003/sumners/fair.ps.gz Binary files differnew file mode 100644 index 0000000..3d86cc6 --- /dev/null +++ b/books/workshops/2003/sumners/fair.ps.gz diff --git a/books/workshops/2003/sumners/slides.pdf.gz b/books/workshops/2003/sumners/slides.pdf.gz Binary files differnew file mode 100644 index 0000000..0d6add5 --- /dev/null +++ b/books/workshops/2003/sumners/slides.pdf.gz diff --git a/books/workshops/2003/sumners/slides.ps.gz b/books/workshops/2003/sumners/slides.ps.gz Binary files differnew file mode 100644 index 0000000..3575e2d --- /dev/null +++ b/books/workshops/2003/sumners/slides.ps.gz diff --git a/books/workshops/2003/sumners/support/README b/books/workshops/2003/sumners/support/README new file mode 100644 index 0000000..a57a6d4 --- /dev/null +++ b/books/workshops/2003/sumners/support/README @@ -0,0 +1,22 @@ +The following books should certify in v2-7, v2-8, etc. The definitions in n2n.lisp test +the version since there are a couple of functions whose definitions change from v2-7 to +v2-8 (see n2n.lisp for details). + +fair1.lisp -- a "book" demonstrating the logical equivalence between our fair + env. assumptions and a straightforward statement of (fair-selection) +example1.lisp -- a simple example application of the straightforward fair selector + defined in fair1.lisp. + -- the fair selector in fair2.lisp is a better book to use than + fair1.lisp because it does not require the (fair-selection) + constant predicate as an hypothesis to liveness and other theorems. +simple.lisp -- a simple fair selector over bounded naturals + -- only provided for exposition, this is completely subsumed + by fair2.lisp +n2n.lisp -- an invertible function from the "nice" or "good" ACL2 objects + to natural numbers +fair2.lisp -- an unconditional fair selection environment for "nice" ACL2 objects +example2.lisp -- a simple example application of the unconditional fair selector in + fair2.lisp +example3.lisp -- a more complex application of the unconditional fair selector in + fair2.lisp +cfair.lisp -- a conditional fair selector for "nice" ACL2 objects diff --git a/books/workshops/2003/sumners/support/cfair.lisp b/books/workshops/2003/sumners/support/cfair.lisp new file mode 100644 index 0000000..a148641 --- /dev/null +++ b/books/workshops/2003/sumners/support/cfair.lisp @@ -0,0 +1,437 @@ +(in-package "ACL2") +(set-match-free-default :all) + +#| cfair.lisp + +This book defines a "conditional" fair selector which is restricted to select +only "legal" inputs specified for the system. Complications arise in defining +this type of fairness. In particular, the fair selection is now dependent on +the system state and as such, the definition of fair-run will be mutually +recursive with run (or alternatively, they could be merged into a single "run" +function which updates a pair of system state with fair selector state). Given +this added complexity, we do not suggest the use of this selector, but instead +suggest the use of the strong selector in fair.lisp which affords a cleaner +composition. We provide the definition of this selector nonetheless since it +may prove useful in some contexts. + +|# + +(include-book "n2n") +(include-book "../../../../ordinals/e0-ordinal") +(set-well-founded-relation e0-ord-<) + +(encapsulate + (((legal-input * *) => *) + ((legal-witness *) => *)) + + (local (defun legal-input (s i) (equal (nfix s) (nfix i)))) + (local (defun legal-witness (s) (nfix s))) + + (defthm legal-witness-is-legal + (legal-input s (legal-witness s))) + (defthm legal-witness-is-nice + (nicep (legal-witness s))) +) + +(defun legal-in-lst (s lst) + (and (consp lst) + (if (legal-input s (nat->nice (first lst))) + (first lst) + (legal-in-lst s (rest lst))))) + +(defun drop-lst (lst n) + (cond ((endp lst) ()) + ((equal n (first lst)) + (drop-lst (rest lst) n)) + (t (cons (first lst) + (drop-lst (rest lst) n))))) + +(defun pos-in-lst (lst n) + (cond ((endp lst) nil) + ((equal n (first lst)) 0) + (t (and (pos-in-lst (rest lst) n) + (1+ (pos-in-lst (rest lst) n)))))) + +(defthm impossible-case-for-ctr + (implies (equal ctr (nice->nat (legal-witness s))) + (legal-input s (nat->nice ctr)))) + +(defun find-ndx (s top ctr) + (declare (xargs :measure + (let ((goal (nice->nat (legal-witness s)))) + (cons (1+ (nfix (- goal top))) + (nfix (if (>= goal ctr) + (- goal ctr) + (+ 1 (- top ctr) goal))))))) + (cond ((or (not (natp ctr)) + (not (natp top)) + (> ctr top)) + 0) + ((legal-input s (nat->nice ctr)) + ctr) + ((< ctr top) + (find-ndx s top (1+ ctr))) + (t + (find-ndx s (1+ top) 0)))) + +(defun snoc (e x) + (if (endp x) (list e) + (cons (first x) (snoc e (rest x))))) + +(defun step-env (s hold top ctr) + (declare (xargs :measure + (let ((goal (nice->nat (legal-witness s)))) + (cons (1+ (nfix (- goal top))) + (nfix (if (>= goal ctr) + (- goal ctr) + (+ 1 (- top ctr) goal))))))) + (cond ((or (not (natp ctr)) + (not (natp top)) + (> ctr top)) + (list hold 1 0)) + ((legal-input s (nat->nice ctr)) + (if (= top ctr) + (list hold (1+ top) 0) + (list hold top (1+ ctr)))) + ((< ctr top) + (step-env s (snoc ctr hold) top (1+ ctr))) + (t + (step-env s (snoc top hold) (1+ top) 0)))) + +;; we now prove some theorems about these functions which we will need in the +;; following encapsulate + +(defun in-lst (e x) + (and (consp x) + (or (equal e (first x)) + (in-lst e (rest x))))) + +(defthm legal-in-lst-is-in-lst + (implies (legal-in-lst s x) + (in-lst (legal-in-lst s x) x))) + +(defthm drop-lst-<=-len + (<= (len (drop-lst lst e)) + (len lst)) + :rule-classes :linear) + +(defthm drop-lst-<-len-in-lst + (implies (in-lst e lst) + (< (len (drop-lst lst e)) + (len lst))) + :rule-classes :linear) + +(defthm pos-in-lst-<=-drop-lst + (implies (and (in-lst a lst) + (not (equal a b))) + (<= (pos-in-lst (drop-lst lst b) a) + (pos-in-lst lst a))) + :rule-classes :linear) + +(defthm pos-in-lst-<-not-legal-in-lst-help + (implies (and (nat-listp lst) + (in-lst a lst) + (legal-input s (nat->nice a)) + (not (equal a (legal-in-lst s lst)))) + (< (pos-in-lst (drop-lst lst (legal-in-lst s lst)) a) + (pos-in-lst lst a))) + :rule-classes nil) + +(defthm pos-in-lst-<-not-legal-in-lst + (let ((a (nice->nat i))) + (implies (and (nicep i) + (nat-listp lst) + (in-lst a lst) + (legal-input s i) + (not (equal a (legal-in-lst s lst)))) + (< (pos-in-lst (drop-lst lst (legal-in-lst s lst)) a) + (pos-in-lst lst a)))) + :hints (("Goal" :use + (:instance pos-in-lst-<-not-legal-in-lst-help + (a (nice->nat i))))) + :rule-classes :linear) + +(defthm pos-in-lst-iff-in-lst + (iff (pos-in-lst x n) + (in-lst n x))) + +(defthm in-lst-of-drop-lst + (equal (in-lst n (drop-lst lst a)) + (and (not (equal n a)) + (in-lst n lst)))) + +(defun env-ctr (goal top ctr) + (declare (xargs :measure + (cons (1+ (nfix (- goal top))) + (nfix (if (>= goal ctr) + (- goal ctr) + (+ 1 (- top ctr) goal)))))) + (cond ((or (not (natp ctr)) + (not (natp top)) + (not (natp goal)) + (> ctr top)) + 0) + ((equal ctr goal) + 1) + ((< ctr top) + (1+ (env-ctr goal top (1+ ctr)))) + (t + (1+ (env-ctr goal (1+ top) 0))))) + +(defun env-msr (i hold top ctr) + (let ((ndx (nice->nat i))) + (or (pos-in-lst hold ndx) + (+ (len hold) + (env-ctr ndx top ctr))))) + +(defthm <=-env-msr-drop-lst + (implies (not (equal (nice->nat i) ndx)) + (<= (env-msr i (drop-lst hold ndx) top ctr) + (env-msr i hold top ctr))) + :rule-classes :linear) + +(defthm <-env-msr-if-not-selected + (let ((ndx (legal-in-lst s hold))) + (implies (and ndx + (nicep i) + (nat-listp hold) + (legal-input s i) + (not (equal (nice->nat i) ndx))) + (< (env-msr i (drop-lst hold ndx) top ctr) + (env-msr i hold top ctr)))) + :rule-classes :linear) + +(defthm pos-in-lst-snoc-unchanged + (implies (in-lst ndx hold) + (equal (pos-in-lst (snoc e hold) ndx) + (pos-in-lst hold ndx)))) + +(defthm in-lst-of-snoc-rewrite + (equal (in-lst ndx (snoc e hold)) + (or (equal ndx e) + (in-lst ndx hold)))) + +(defthm pos-in-lst-hold-step-env-unchanged + (implies (in-lst ndx hold) + (equal (pos-in-lst (car (step-env s hold top ctr)) ndx) + (pos-in-lst hold ndx)))) + +(defthm in-lst-hold-step-env-unchanged + (implies (in-lst ndx hold) + (in-lst ndx (car (step-env s hold top ctr))))) + +(defthm len-of-snoc + (equal (len (snoc e x)) + (1+ (len x)))) + +(defthm <=-env-msr-in-lst-case + (let ((hold+ (car (step-env s hold top ctr)))) + (implies (and (natp top) + (natp ctr) + (<= ctr top) + (natp goal) + (not (in-lst goal hold)) + (in-lst goal hold+)) + (<= (pos-in-lst hold+ goal) + (+ (len hold) + (env-ctr goal top ctr))))) + :rule-classes :linear) + +(defthm <=-env-msr-not-in-lst-case + (let* ((nxt (step-env s hold top ctr)) + (hold+ (first nxt)) + (top+ (second nxt)) + (ctr+ (third nxt))) + (implies (and (natp top) + (natp ctr) + (<= ctr top) + (natp goal) + (not (in-lst goal hold+)) + (not (equal goal (find-ndx s top ctr)))) + (<= (+ (len hold+) + (env-ctr goal top+ ctr+)) + (+ (len hold) + (env-ctr goal top ctr))))) + :rule-classes :linear) + +(defthm <=-env-msr-step-env + (let* ((nxt (step-env s hold top ctr)) + (hold+ (first nxt)) + (top+ (second nxt)) + (ctr+ (third nxt))) + (implies (and (natp top) + (natp ctr) + (<= ctr top) + (not (equal (nice->nat i) + (find-ndx s top ctr)))) + (<= (env-msr i hold+ top+ ctr+) + (env-msr i hold top ctr)))) + :rule-classes :linear) + +(defthm if-in-lst-and-not-legal-in-lst + (implies (and (nicep i) + (nat-listp lst) + (in-lst (nice->nat i) lst) + (legal-input s i)) + (legal-in-lst s lst))) + +(defthm not-in-hold+-if-legal-input + (implies (and (nicep i) + (not (in-lst (nice->nat i) hold)) + (legal-input s i)) + (not (in-lst (nice->nat i) + (car (step-env s hold top ctr)))))) + +(defthm nat-listp-of-snoc + (implies (and (natp e) + (nat-listp x)) + (nat-listp (snoc e x)))) + +(defthm <-env-ctr-step-env-main + (let* ((nxt (step-env s hold top ctr)) + (hold+ (first nxt)) + (top+ (second nxt)) + (ctr+ (third nxt))) + (implies (and (natp top) + (natp ctr) + (<= ctr top) + (nicep i) + (nat-listp hold) + (legal-input s i) + (not (in-lst (nice->nat i) hold+)) + (not (equal (nice->nat i) + (find-ndx s top ctr)))) + (< (+ (len hold+) + (env-ctr (nice->nat i) top+ ctr+)) + (+ (len hold) + (env-ctr (nice->nat i) top ctr))))) + :rule-classes :linear) + +(defthm <-env-msr-step-env + (let* ((nxt (step-env s hold top ctr)) + (hold+ (first nxt)) + (top+ (second nxt)) + (ctr+ (third nxt))) + (implies (and (natp top) + (natp ctr) + (<= ctr top) + (nicep i) + (nat-listp hold) + (legal-input s i) + (not (legal-in-lst s hold)) + (not (equal (nice->nat i) + (find-ndx s top ctr)))) + (< (env-msr i hold+ top+ ctr+) + (env-msr i hold top ctr)))) + :rule-classes :linear) + +(defthm drop-lst-preserves-nat-listp + (implies (nat-listp x) + (nat-listp (drop-lst x e)))) + +(defun good-env (e) + (let ((hold (first e)) + (top (second e)) + (ctr (third e))) + (and (natp top) + (natp ctr) + (<= ctr top) + (nat-listp hold)))) + +(defthm step-env-preserves-env-inv + (implies (nat-listp hold) + (good-env (step-env s hold top ctr)))) + +(defthm legal-in-lst-is-legal-input + (implies (and (nat-listp x) + (legal-in-lst s x)) + (legal-input s (nat->nice (legal-in-lst s x))))) + +(defthm find-ndx-is-legal-input + (implies (and (natp ctr) + (natp top) + (<= ctr top)) + (legal-input s (nat->nice (find-ndx s top ctr))))) + +(defthm transfer-nice->nat-over + (implies (and (nicep i) + (not (equal (nat->nice n) i))) + (not (equal (nice->nat i) n)))) + +(encapsulate + (((fair-select * *) => *) + ((fair-measure * *) => *) + ((fair-update * *) => *) + ((env-inv *) => *) + ((env-init) => *)) + + (local + (defun env-init () + (list () 0 0))) + + (local + (defun env-inv (e) (good-env e))) + + (local + (defun fair-update (e s) + (let ((hold (first e)) + (top (second e)) + (ctr (third e))) + (let ((ndx (legal-in-lst s hold))) + (if ndx + (list (drop-lst hold ndx) top ctr) + (step-env s hold top ctr)))))) + + (local + (defun fair-select (e s) + (let ((hold (first e)) + (top (second e)) + (ctr (third e))) + (nat->nice (or (legal-in-lst s hold) + (find-ndx s top ctr)))))) + + (local + (defun fair-measure (e i) + (let ((hold (first e)) + (top (second e)) + (ctr (third e))) + (env-msr i hold top ctr)))) + + ;; the following are the exported theorems for our constrained functions + ;; defining a fair environment. + + (defthm env-init-satisfies-invariant + (env-inv (env-init))) + + (defthm fair-update-preserves-env + (implies (env-inv e) + (env-inv (fair-update e s)))) + + (defthm fair-select-must-be-legal + (implies (env-inv e) + (legal-input s (fair-select e s)))) + + (defthm fair-measure-is-natural + (implies (env-inv e) + (natp (fair-measure e i)))) + + (defthm fair-measure-may-decrease + (implies (and (env-inv e) + (nicep i) + (not (equal (fair-select e s) i))) + (<= (fair-measure (fair-update e s) i) + (fair-measure e i))) + :hints (("Goal" :in-theory (disable env-msr))) + :rule-classes (:linear :rewrite)) + + (defthm fair-measure-must-decrease-strictly + (implies (and (env-inv e) + (nicep i) + (not (equal (fair-select e s) i)) + (legal-input s i)) + (< (fair-measure (fair-update e s) i) + (fair-measure e i))) + :hints (("Goal" :in-theory (disable env-msr))) + :rule-classes (:linear :rewrite)) +) + diff --git a/books/workshops/2003/sumners/support/example1.lisp b/books/workshops/2003/sumners/support/example1.lisp new file mode 100644 index 0000000..408b414 --- /dev/null +++ b/books/workshops/2003/sumners/support/example1.lisp @@ -0,0 +1,113 @@ +(in-package "ACL2") +(set-match-free-default :all) + +#| example1.lisp + +We present a simple example to demonstrate the use of the fair environment in +fair1.lisp in proving a liveness property using the fair environment assumption +provided in fair1.lisp. The example in this file is a trivial "system", but +demonstrates the key concepts in using the fair input assumption environment in +fair1.lisp to prove a simple liveness property. The key idea is to use the +fair-measure to define a terminating measure for a function which is the +witness to proving the liveness property. This approach requires the addition +of the (fair-selection) assumption which is an unfortunate need. Since usage +of the fair2.lisp file does not require this assumption, we generally believe +the user should use the fair2.lisp book instead (as in example2.lisp). + +|# + +(include-book "fair1") + +;; the following macro defines the functions env and env-measure + +(define-env) + +(encapsulate (((upper-bound) => *)) + (local (defun upper-bound () 1)) + (defthm upper-bound-positive-natural + (and (integerp (upper-bound)) + (> (upper-bound) 0)) + :rule-classes :type-prescription)) + +(defun sys-step (s i) + (let ((s (if (= s i) (1+ s) s))) + (if (<= s (upper-bound)) s 0))) + +(defun sys-init () 0) + +(defun run (n) + (if (zp n) (sys-init) + (let ((n (1- n))) + (sys-step (run n) (env n))))) + +(defthm run-n-is-natural + (natp (run n)) + :rule-classes :type-prescription) + +(defthm run-n-is-bounded + (<= (run n) (upper-bound)) + :rule-classes :linear) + +(defun good (s) + (= s (upper-bound))) + +(defmacro lexprod (&rest r) + (cond ((endp r) 0) + ((endp (rest r)) (first r)) + (t `(cons (lexprod ,@(butlast r 1)) + ,(car (last r)))))) + +(defun good-measure (n) + (lexprod + (if (natp n) 1 2) + (1+ (nfix (- (upper-bound) (run n)))) + (env-measure (run n) n))) + +(in-theory (disable (good-measure))) + +;; the following is just a rewrite rule we need from linear arithmetic (which +;; does not "rewrite") +(local +(defthm linear-factoid3 + (implies (and (integerp x) + (integerp y)) + (equal (+ (- y) y x) x)))) + +(defun good-time (n) + (declare (xargs :measure (good-measure n))) + (cond ((not (fair-selection)) 0) + ((not (natp n)) (good-time 0)) + ((good (run n)) n) + (t (good-time (1+ n))))) + +(in-theory (disable good (good-time))) + +(defthm good-of-good-time + (implies (fair-selection) + (good (run (good-time n))))) + +(defthm good-time->= + (implies (and (integerp n) + (fair-selection)) + (>= (good-time n) n)) + :rule-classes :linear) + +(defthm good-time-is-natp + (natp (good-time n)) + :rule-classes :type-prescription) + +(defun time>= (y x) + (and (natp y) (implies (natp x) (>= y x)))) + +(defun-sk eventually-good (x) + (exists (y) (and (time>= y x) (good (run y))))) + +(defthm progress-or-liveness + (implies (fair-selection) + (eventually-good n)) + :hints (("Goal" :use (:instance eventually-good-suff + (x n) + (y (good-time n)))))) + + + diff --git a/books/workshops/2003/sumners/support/example2.lisp b/books/workshops/2003/sumners/support/example2.lisp new file mode 100644 index 0000000..5fc5557 --- /dev/null +++ b/books/workshops/2003/sumners/support/example2.lisp @@ -0,0 +1,113 @@ +(in-package "ACL2") +(set-match-free-default :all) + +#| example2.lisp + +We present a simple example to demonstrate the use of the fair environment in +fair2.lisp in proving a liveness property using the fair environment assumption +provided in fair2.lisp. The example in this file is a trivial "system", but +demonstrates the key concepts in using the fair input assumption environment in +fair.lisp to prove a simple liveness property. The key idea is to use the +fair-measure to define a terminating measure for a function which is the +witness to proving the liveness property. It is the author's belief (with some +applications supporting this belief) that for most systems, the forms from the +defun of good-time on could be re-used for any liveness proof with little or no +modification and that the only item needed to be changed for a particular +system would be the measure for the function good-time. + +A more thorough (but complicated) demonstration of this is found in +example3.lisp. + +|# + +(include-book "fair2") + +;; the following macro defines the functions env and env-measure + +(define-env) + +(encapsulate (((upper-bound) => *)) + (local (defun upper-bound () 1)) + (defthm upper-bound-positive-natural + (and (integerp (upper-bound)) + (> (upper-bound) 0)) + :rule-classes :type-prescription)) + +(defun sys-step (s i) + (let ((s (if (= s i) (1+ s) s))) + (if (<= s (upper-bound)) s 0))) + +(defun sys-init () 0) + +(defun run (n) + (if (zp n) (sys-init) + (let ((n (1- n))) + (sys-step (run n) (env n))))) + +(defthm run-n-is-natural + (natp (run n)) + :rule-classes :type-prescription) + +(defthm run-n-is-bounded + (<= (run n) (upper-bound)) + :rule-classes :linear) + +(defun good (s) + (= s (upper-bound))) + +(defmacro lexprod (&rest r) + (cond ((endp r) 0) + ((endp (rest r)) (first r)) + (t `(cons (lexprod ,@(butlast r 1)) + ,(car (last r)))))) + +(defun good-measure (n) + (lexprod + (if (natp n) 1 2) + (1+ (nfix (- (upper-bound) (run n)))) + (env-measure (run n) n))) + +(in-theory (disable (good-measure))) + +;; the following is just a rewrite rule we need from linear arithmetic (which +;; does not "rewrite") +(local + (defthm linear-factoid3 + (implies (and (integerp x) + (integerp y)) + (equal (+ (- y) y x) x)))) + +(defun good-time (n) + (declare (xargs :measure (good-measure n))) + (cond ((not (natp n)) (good-time 0)) + ((good (run n)) n) + (t (good-time (1+ n))))) + +(in-theory (disable good (good-time))) + +(defthm good-of-good-time + (good (run (good-time n)))) + +(defthm good-time->= + (implies (integerp n) + (>= (good-time n) n)) + :rule-classes :linear) + +(defthm good-time-is-natp + (natp (good-time n)) + :rule-classes :type-prescription) + +(defun time>= (y x) + (and (natp y) (implies (natp x) (>= y x)))) + +(defun-sk eventually-good (x) + (exists (y) (and (time>= y x) (good (run y))))) + +(defthm progress-or-liveness + (eventually-good n) + :hints (("Goal" :use (:instance eventually-good-suff + (x n) + (y (good-time n)))))) + + + diff --git a/books/workshops/2003/sumners/support/example3.lisp b/books/workshops/2003/sumners/support/example3.lisp new file mode 100644 index 0000000..5847b22 --- /dev/null +++ b/books/workshops/2003/sumners/support/example3.lisp @@ -0,0 +1,349 @@ +(in-package "ACL2") +(set-match-free-default :all) + +#| example3.lisp + +We present a slightly more complex model which uses the fair environment in +fair2.lisp. This example is a mutual exclusion model where the state of the +system is abstracted into a process pointer and a list of program counters (one +for each process). This is a fairly simple system to define, but has a subtle +argument for progress because the "arbiter" does not wait until a process +reaches its critical section. The function good-measure is the key to the +argument and utilizes two calls of env-measure (one for the arbitrary node in +the property (pick-pr) and another for the current node selected by the +arbiter). + +|# + +(include-book "fair2") +(include-book "../../../../ordinals/e0-ordinal") +(set-well-founded-relation e0-ord-<) + +;; the following macro defines the functions env and env-measure + +(define-env) + +; The following was removed with the addition of natp-compound-recognizer to +; ACL2 2.9.2. +;(defthm posp-compound-recognizer +; (iff (posp x) +; (and (integerp x) +; (> x 0))) +; :rule-classes :compound-recognizer) + +(in-theory (disable posp)) + +(encapsulate + (((last-pr) => *) + ((crit-pc) => *) + ((last-pc) => *)) + + (local (defun last-pr () 0)) + (local (defun crit-pc () 1)) + (local (defun last-pc () 2)) + + (defthm last-pr-natp + (natp (last-pr)) + :rule-classes :type-prescription) + + (defthm crit-pc-posp + (posp (crit-pc)) + :rule-classes :type-prescription) + + (defthm last-pc-posp + (posp (last-pc)) + :rule-classes :type-prescription) + + (defthm last-pc-gt-crit-pc + (< (crit-pc) (last-pc))) +) + +(defun prp (x) + (and (natp x) (<= x (last-pr)))) + +(defthm prp-forward + (implies (prp x) + (and (natp x) + (<= x (last-pr)))) + :rule-classes :forward-chaining) + +(defthm prp-backward1 + (implies (and (natp x) + (<= x (last-pr))) + (prp x))) + +(defthm prp-backward2 + (implies (not (and (natp x) + (<= x (last-pr)))) + (not (prp x)))) + +(in-theory (disable prp (prp))) + +(defun pcp (x) + (and (natp x) (<= x (last-pc)))) + +(defthm pcp-forward + (implies (pcp x) + (and (natp x) + (<= x (last-pc)))) + :rule-classes :forward-chaining) + +(defthm pcp-backward1 + (implies (and (natp x) + (<= x (last-pc))) + (pcp x))) + +(defthm pcp-backward2 + (implies (not (and (natp x) + (<= x (last-pc)))) + (not (pcp x)))) + +(in-theory (disable pcp (pcp))) + +(defun getp (n l) + (if (zp n) + (if (endp l) 0 (car l)) + (getp (1- n) (cdr l)))) + +(defun setp (n v l) + (if (zp n) + (cons v (cdr l)) + (cons (if (endp l) 0 (car l)) + (setp (1- n) v (cdr l))))) + +(defthm getp-of-setp + (equal (getp n (setp m v l)) + (if (equal (nfix n) (nfix m)) + v + (getp n l)))) + +(defthm getp-of-atom + (implies (atom l) + (equal (getp n l) 0))) + +(defun pc-listp (l) + (or (null l) + (and (consp l) + (pcp (car l)) + (pc-listp (cdr l))))) + +(defthm setp-pc-listp + (implies (and (pc-listp l) + (pcp v)) + (pc-listp (setp n v l)))) + +(defthm getp-of-pc-listp1 + (implies (pc-listp l) + (pcp (getp n l))) + :rule-classes (:type-prescription + :rewrite)) + +(defthm getp-of-pc-listp2 + (implies (pc-listp l) + (natp (getp n l))) + :rule-classes :type-prescription) + +(defthm getp-of-pc-listp3 + (implies (pc-listp l) + (<= (getp n l) (last-pc))) + :rule-classes :linear) + +(defun next-pr (x) + (let ((x (1+ x))) (if (> x (last-pr)) 0 x))) + +(defun next-pc (x) + (let ((x (1+ x))) (if (> x (last-pc)) 0 x))) + +(defun in-crit (p) + (>= p (crit-pc))) + +(defun sys-step (s i) + (if (prp i) + (let* ((ndx (car s)) + (prs (cdr s)) + (p (getp i prs)) + (p+ (next-pc p)) + (p+ (if (and (in-crit p+) (/= i ndx)) p p+)) + (prs (setp i p+ prs)) + (n+ (next-pr ndx)) + (ndx (if (and (not (in-crit p+)) (= i ndx)) n+ ndx))) + (cons ndx prs)) + s)) + +(in-theory (disable (sys-step) (next-pr) (next-pc) (in-crit))) + +(defun sys-init () (cons 0 ())) + +(defun run (n) + (if (zp n) (sys-init) + (let ((n (1- n))) + (sys-step (run n) (env n))))) + +(in-theory (disable (run) (env))) + +;; the following is just a rewrite rule we need from linear arithmetic (which +;; does not "rewrite") +(local + (defthm linear-factoid3 + (implies (and (integerp x) + (integerp y)) + (equal (+ (- y) y x) x)))) + +(local +(defthm expand-run-1+ + (implies (natp n) + (equal (run (1+ n)) + (sys-step (run n) (env n)))) + :hints (("Goal" :in-theory (disable sys-step))))) + +(defthm pc-listp-cdr-run + (pc-listp (cdr (run n))) + :rule-classes :type-prescription) + +(defthm natp-car-run + (natp (car (run n))) + :rule-classes :type-prescription) + +(defthm car-run-<=-last-pr + (<= (car (run n)) (last-pr)) + :rule-classes :linear) + +(defthm prp-car-run + (prp (car (run n))) + :rule-classes :type-prescription) + +(encapsulate + (((pick-pr) => *)) + (local (defun pick-pr () 0)) + + (defthm pick-pr-natp + (natp (pick-pr)) + :rule-classes :type-prescription) + + (defthm pick-pr-<=-last-pr + (<= (pick-pr) (last-pr))) + + (defthm pick-pr-is-prp + (prp (pick-pr))) +) + +(defun good (s) + (in-crit (getp (pick-pr) (cdr s)))) + +(in-theory (disable (good))) + +(defthm natp-is-nicep + (implies (natp x) + (nicep x)) + :rule-classes :type-prescription) + +(defthm prp-not-equal1 + (implies (and (prp x) + (not (prp y))) + (not (equal x y)))) + +(defthm prp-not-equal2 + (implies (and (prp x) + (not (prp y))) + (not (equal y x)))) + +(defthm natp-pick-pr-- + (implies (and (natp y) + (<= y (pick-pr))) + (natp (- (pick-pr) y))) + :hints (("Goal" :in-theory (enable natp))) + :rule-classes :type-prescription) + +(defthm natp-last-pr--1 + (implies (and (natp y) + (<= y (last-pr)) + (natp a) + (natp b)) + (natp (+ (last-pr) a b (- y)))) + :hints (("Goal" :in-theory (enable natp))) + :rule-classes :type-prescription) + +(defthm natp-last-pr--2 + (implies (and (natp y) + (<= y (last-pr)) + (natp a) + (natp b)) + (natp (+ a (last-pr) b (- y)))) + :hints (("Goal" :in-theory (enable natp))) + :rule-classes :type-prescription) + +(defthm natp-last-pr--3 + (implies (and (natp y) + (<= y (last-pr)) + (natp a) + (natp b)) + (natp (+ a b (last-pr) (- y)))) + :hints (("Goal" :in-theory (enable natp))) + :rule-classes :type-prescription) + +(defmacro lexprod (&rest r) + (cond ((endp r) 0) + ((endp (rest r)) (first r)) + (t `(cons (lexprod ,@(butlast r 1)) + ,(car (last r)))))) + +(defun good-measure (n) + (let* ((s (run n)) + (ndx (car s)) + (prs (cdr s)) + (nogo (not (equal ndx (pick-pr))))) + (lexprod + (if (natp n) 1 2) + (nfix (- (crit-pc) (getp (pick-pr) prs))) + (if nogo 2 1) + (if nogo + (if (> ndx (pick-pr)) + (+ (- (last-pr) ndx) + (1+ (pick-pr))) + (- (pick-pr) ndx)) + 0) + (if nogo + (- (last-pc) (getp ndx prs)) + 0) + (env-measure ndx n)))) + +(in-theory (disable (good-measure))) + +(defun good-time (n) + (declare (xargs :measure (good-measure n) + :hints (("Subgoal 1" + :use ((:instance last-pc-gt-crit-pc) + (:instance pick-pr-<=-last-pr)) + :in-theory (disable last-pc-gt-crit-pc + pick-pr-<=-last-pr + getp setp))))) + (cond ((not (natp n)) (good-time 0)) + ((good (run n)) n) + (t (good-time (1+ n))))) + +(in-theory (disable good (good-time))) + +(defthm good-of-good-time + (good (run (good-time n)))) + +(defthm good-time->= + (implies (integerp n) + (>= (good-time n) n)) + :rule-classes :linear) + +(defthm good-time-is-natp + (natp (good-time n)) + :rule-classes :type-prescription) + +(defun time>= (y x) + (and (natp y) (implies (natp x) (>= y x)))) + +(defun-sk eventually-good (x) + (exists (y) (and (time>= y x) (good (run y))))) + +(defthm progress-or-liveness + (eventually-good n) + :hints (("Goal" :use (:instance eventually-good-suff + (x n) + (y (good-time n)))))) + diff --git a/books/workshops/2003/sumners/support/fair1.lisp b/books/workshops/2003/sumners/support/fair1.lisp new file mode 100644 index 0000000..68e6dd8 --- /dev/null +++ b/books/workshops/2003/sumners/support/fair1.lisp @@ -0,0 +1,239 @@ +(in-package "ACL2") +(set-match-free-default :all) + +(include-book "../../../../ordinals/e0-ordinal") +(set-well-founded-relation e0-ord-<) + +#| fair1.lisp + +This "book" provides an equivalence proof between a straightforward statement +of "fair input selection" using defun-sk and the existence of a fair measure +function which decreases with every step. In order to use the measure function +introduced in this book, one would need to introduce (fair-selection) +assumptions in any theorems which required the properties of the environment +measure function. Because of this, we do not recommend using this book, and +instead recommend using the book fair2.lisp. + +|# + +(encapsulate ;; arbitrary environment input sequence + (((env1 *) => *)) + (local (defun env1 (x) x))) + +; The following was removed with the addition of natp-compound-recognizer to +; ACL2 2.9.2. +;(defthm natp-compound-recognizer +; (iff (natp x) +; (and (integerp x) +; (>= x 0))) +; :rule-classes :compound-recognizer) + +(in-theory (disable natp)) + +(defun time>= (y x) + (and (natp y) (implies (natp x) (>= y x)))) + +(defun next1* (i n k) + (declare (xargs :measure (nfix (- k n)))) + (if (or (equal (env1 n) i) (zp (- k n))) n (next1* i (1+ n) k))) + +(defthm next1*-natp + (implies (natp n) (natp (next1* i n k))) + :rule-classes :type-prescription) + +(defthm next1*> + (>= (next1* i n k) n) + :rule-classes :linear) + +(defthm next1*-property + (implies (and (natp n) (natp k1) (natp k2) + (>= k1 n) (>= k2 n) + (equal (env1 k1) i) + (equal (env1 k2) i)) + (equal (equal (next1* i n k1) + (next1* i n k2)) + t))) + +(defun-sk exists-future (i x) + (exists y (and (time>= y x) (equal (env1 y) i)))) + +(defun-sk fair-selection () + (forall (i x) (exists-future i x))) + +(defun next1 (i n) + (next1* i n (exists-future-witness i n))) + +(defthm next1-natp + (implies (natp n) + (natp (next1 i n))) + :rule-classes :type-prescription) + +(defthm next1> + (>= (next1 i n) n) + :rule-classes :linear) + +(defthm next1-no-change + (implies (and (natp n) + (fair-selection) + (not (equal (env1 n) i))) + (equal (next1 i (1+ n)) + (next1 i n))) + :hints (("Goal" + :use ((:instance fair-selection-necc (x n)) + (:instance fair-selection-necc (x (1+ n)))) + :in-theory (disable fair-selection-necc)))) + +(defun env1-measure (i n) + (if (natp n) (- (next1 i n) n) (next1 i 0))) + +(defthm env1-measure-natural + (natp (env1-measure i n)) + :hints (("Goal" :in-theory (enable natp)))) + +(defthm env1-measure-decreases + (implies (and (natp n) + (fair-selection) + (not (equal (env1 n) i))) + (< (env1-measure i (1+ n)) + (env1-measure i n))) + :hints (("Goal" :in-theory (disable fair-selection)))) + +(in-theory (disable fair-selection)) + +#| + +IMPORTANT NOTE: + +We include an extra "k" parameter to the functions env and env-measure, to +allow the use of multiple independent fair selectors. We generally use the +following macro define-env to define a fair environment with support for +multiple fair selectors for "fields" in an input. These "fields" of the input +are defined using the "s" and "g" operators from the records book: +books/misc/records.lisp. These operators could be replaced with updaters and +accessors of your choosing, but the properties of "s" and "g" should hold (or +suitable equivalent properties) and "g" should be a free accessor in that the +range of "g" should be the ACL2 universe. This is necessary to ensure that the +modeling of the fair selector is not inadvertently and inappropriately +constrained. + +|# + +(encapsulate + (((env! * *) => *) + ((env-measure! * * *) => *)) + +(local (defun env! (k n) (declare (ignore k)) + (env1 n))) +(local (defun env-measure! (k i n) (declare (ignore k)) + (env1-measure i n))) + +(defthm env-measure!-is-natural + (natp (env-measure! k i n)) + :rule-classes (:type-prescription :rewrite)) + +(defthm env-measure!-decreases + (implies (and (fair-selection) + (natp n) + (not (equal i (env! k n)))) + (< (env-measure! k i (1+ n)) + (env-measure! k i n))) + :rule-classes (:linear :rewrite)) +) + +(defun mk-env-body (keys) + (if (endp keys) '(env! 0 n) + `(s (quote ,(first keys)) + (env! (quote ,(first keys)) n) + ,(mk-env-body (rest keys))))) + +(defmacro define-env (&rest keys) + (declare (xargs :guard (symbol-listp keys))) + `(progn (defun env (n) ,(mk-env-body keys)) + ,(if (endp keys) + '(defun env-measure (i n) + (env-measure! 0 i n)) + '(defun env-measure (k i n) + (env-measure! k i n))))) + +#| + +We conclude this book with a "proof" that the existence of a fair-measure +implies (fair-selection) -- we proved the other direction above. This other +direction is not relevant to the output of this file, so we make all of the +following forms local. + +|# + +(local +(defstub env1-msr$ (i n) t)) + +(local +(defun-sk env1-msr$-property () + (forall (i n) + (and (natp (env1-msr$ i n)) + (implies (and (natp n) + (not (equal (env1 n) i))) + (< (env1-msr$ i (1+ n)) + (env1-msr$ i n))))))) + +(local +(defthm env1-msr$-is-natural + (implies (env1-msr$-property) + (natp (env1-msr$ i n))) + :hints (("Goal" + :use (:instance env1-msr$-property-necc) + :in-theory (disable env1-msr$-property-necc))) + :rule-classes :type-prescription)) + +(local +(defthm env1-msr$-decreases + (implies (and (env1-msr$-property) + (natp n) + (not (equal (env1 n) i))) + (< (env1-msr$ i (1+ n)) + (env1-msr$ i n))) + :hints (("Goal" + :use (:instance env1-msr$-property-necc) + :in-theory (disable env1-msr$-property-necc))) + :rule-classes :linear)) + +(local +(in-theory (disable env1-msr$-property))) + +(local +(defun witness1$ (i x) + (declare (xargs :measure (cons (if (natp x) 1 2) + (if (env1-msr$-property) + (env1-msr$ i x) + 0)))) + (cond ((not (env1-msr$-property)) 0) + ((not (natp x)) (witness1$ i 0)) + ((equal (env1 x) i) x) + (t (witness1$ i (1+ x)))))) + +(local +(defthm witness1$-is-env1 + (implies (env1-msr$-property) + (equal (env1 (witness1$ i x)) i)))) + +(local +(defthm witness1$-in-future + (implies (and (natp x) + (env1-msr$-property)) + (>= (witness1$ i x) x)) + :rule-classes :linear)) + +(local +(in-theory (disable exists-future exists-future-suff))) + +(local +(defthm env1-msr$-property-implies-fair-selection + (implies (env1-msr$-property) + (fair-selection)) + :hints (("Goal" + :use ((:instance exists-future-suff + (i (mv-nth 0 (fair-selection-witness))) + (x (mv-nth 1 (fair-selection-witness))) + (y (witness1$ (mv-nth 0 (fair-selection-witness)) + (mv-nth 1 (fair-selection-witness)))))) + :in-theory (enable fair-selection))))) diff --git a/books/workshops/2003/sumners/support/fair2.lisp b/books/workshops/2003/sumners/support/fair2.lisp new file mode 100644 index 0000000..e19a559 --- /dev/null +++ b/books/workshops/2003/sumners/support/fair2.lisp @@ -0,0 +1,164 @@ +(in-package "ACL2") +(set-match-free-default :all) + +(include-book "../../../../ordinals/e0-ordinal") +(set-well-founded-relation e0-ord-<) + +#| fair.lisp + +This book defines a basic strong (i.e. unconditional) fair selector over the +nice objects (as defined in n2n.lisp). The relevant properties about env$ and +env-measure! are defined at the end of the file. We expect this fair selector +will be sufficient in most cases, but for "weak" fairness, one should consult +weak.lisp. + +|# + +(include-book "n2n") + +(defun fair-ctr (goal ctr top) + (declare (xargs :measure + (cons (1+ (nfix (- goal top))) + (nfix (if (>= goal ctr) + (- goal ctr) + (+ 1 (- top ctr) goal)))))) + (cond ((not (and (natp ctr) + (natp top) + (natp goal) + (<= ctr top))) + 0) + ((equal ctr goal) 1) + ((< ctr top) + (1+ (fair-ctr goal (1+ ctr) top))) + (t + (1+ (fair-ctr goal 0 (1+ top)))))) + +(defun fair-select (f) + (nat->nice (car f))) + +(defun fair-measure (i f) + (fair-ctr (nice->nat i) (car f) (cdr f))) + +(defun fair-step (f) + (let ((a (car f)) (d (cdr f))) + (if (< a d) (cons (1+ a) d) (cons 0 (1+ d))))) + +(defun fair-inv (f) + (and (consp f) + (natp (car f)) + (natp (cdr f)) + (<= (car f) (cdr f)))) + +(defun fair-init () + (cons 0 0)) + +(defmacro selectp (i) `(nicep ,i)) + +;; ACL2 is actually able to infer this already, but we include it here for +;; better correspondence with the paper + +(local +(defthm fair-measure-natural + (natp (fair-measure i f)) + :rule-classes :type-prescription)) + +(local +(defthm fair-measure-decreases + (implies (and (selectp i) + (fair-inv f) + (not (equal i (fair-select f)))) + (< (fair-measure i (fair-step f)) + (fair-measure i f))) + :rule-classes :linear)) + +(local +(defthm fair-inv-is-invariant + (implies (fair-inv f) + (fair-inv (fair-step f))))) + +(in-theory (disable fair-step fair-inv fair-measure fair-select)) + +(defun fair-run (n) + (if (zp n) (fair-init) (fair-step (fair-run (1- n))))) + +(defthm fair-inv-of-fair-run + (fair-inv (fair-run n))) + +(local +(defthm linear-factoid1 + (implies (and (natp n) + (natp x)) + (equal (+ n (- n) x) x)))) + +(local +(defthm linear-factoid2 + (implies (and (natp n) + (natp x)) + (equal (+ (- n) n x) x)))) + +(local +(defthm fair-run-of-1+ + (implies (natp n) + (equal (fair-run (1+ n)) + (fair-step (fair-run n)))))) + +(in-theory (disable fair-run)) +(in-theory (enable (:induction fair-run))) + +(in-theory (disable (fair-run) (fair-step) (fair-select))) + +#| + +IMPORTANT NOTE: + +We include an extra "k" parameter to the functions env and env-measure, to +allow the use of multiple independent fair selectors. We generally use the +following macro define-env to define a fair environment with support for +multiple fair selectors for "fields" in an input. These "fields" of the input +are defined using the "s" and "g" operators from the records book: +books/misc/records.lisp. These operators could be replaced with updaters and +accessors of your choosing, but the properties of "s" and "g" should hold (or +suitable equivalent properties) and "g" should be a free accessor in that the +range of "g" should be the ACL2 universe. This is necessary to ensure that the +modeling of the fair selector is not inadvertently and inappropriately +constrained. + +|# + +(encapsulate + (((env! * *) => *) + ((env-measure! * * *) => *)) + +(local (defun env! (k n) (declare (ignore k)) + (fair-select (fair-run n)))) +(local (defun env-measure! (k i n) (declare (ignore k)) + (fair-measure i (fair-run n)))) + +(defthm env-measure!-is-natural + (natp (env-measure! k i n)) + :rule-classes (:type-prescription :rewrite)) + +(defthm env-measure!-decreases + (implies (and (selectp i) + (natp n) + (not (equal i (env! k n)))) + (< (env-measure! k i (1+ n)) + (env-measure! k i n))) + :rule-classes (:linear :rewrite)) +) + +(defun mk-env-body (keys) + (if (endp keys) '(env! 0 n) + `(s (quote ,(first keys)) + (env! (quote ,(first keys)) n) + ,(mk-env-body (rest keys))))) + +(defmacro define-env (&rest keys) + (declare (xargs :guard (symbol-listp keys))) + `(progn (defun env (n) ,(mk-env-body keys)) + ,(if (endp keys) + '(defun env-measure (i n) + (env-measure! 0 i n)) + '(defun env-measure (k i n) + (env-measure! k i n))))) + diff --git a/books/workshops/2003/sumners/support/n2n.lisp b/books/workshops/2003/sumners/support/n2n.lisp new file mode 100644 index 0000000..ac31bbf --- /dev/null +++ b/books/workshops/2003/sumners/support/n2n.lisp @@ -0,0 +1,448 @@ +(in-package "ACL2") +(set-match-free-default :all) +; cert_param: (non-acl2r) + +#| n2n.lisp + +This book defines the function nice->nat (and its inverse nat->nice) which +defines an invertible mapping from the set of so-called "nice" objects to the +natural numbers. This mapping is used to lift a fair selector of natural +numbers to a fair selector on "nice" objects. Nice objects are basically a +countable subset of the ACL2 universe consisting of strings, numbers, +characters, booleans, keywords, and conses of nice objects. We only include the +keywords and booleans instead of all symbols due to the inability to construct +an arbitrary symbol in ACL2. + +|# + +; The following was removed with the addition of natp-compound-recognizer to +; ACL2 2.9.2. +;(defthm natp-compound-recognizer +; (iff (natp x) +; (and (integerp x) +; (>= x 0))) +; :rule-classes :compound-recognizer) + +(in-theory (disable natp)) + +; The definition of bitp here was deleted April 2016 by Matt K. now that bitp +; is defined in ACL2. + +(defun ncdr (n) + (if (or (zp n) (= n 1)) 0 (1+ (ncdr (- n 2))))) + +(defun ncar (n) + (if (or (zp n) (= n 1)) n (ncar (- n 2)))) + +(defun lsh (n) + (if (zp n) 0 (+ (lsh (1- n)) 2))) + +(defun ncons (b n) (+ b (lsh n))) + +(local +(defthm linear-factoid1 + (implies (and (natp n) + (natp x)) + (equal (+ (- n) n x) x)))) + +(local +(defthm linear-factoid2 + (implies (and (natp x) + (natp y) + (natp z)) + (equal (+ x y z) + (+ y x z))))) + +(defthm ncar-of-+2-reduce + (implies (natp n) + (equal (ncar (+ 2 n)) + (ncar n))) + :rule-classes nil) + +(defthm ncar-of-1+-lsh + (equal (ncar (1+ (lsh n))) 1) + :hints (("Subgoal *1/2'" + :use (:instance ncar-of-+2-reduce + (n (1+ (lsh (+ -1 n))))) + :in-theory (disable ncar)))) + +(defthm ncar-of-lsh+0 + (equal (ncar (lsh n)) 0)) + +(defthm ncdr-of-lhs+0 + (implies (natp n) + (equal (ncdr (lsh n)) n))) + +(defthm ncdr-of-+2-reduce + (implies (natp n) + (equal (ncdr (+ 2 n)) + (1+ (ncdr n))))) + +(defthm ncdr-of-lhs+1 + (implies (natp n) + (equal (ncdr (1+ (lsh n))) n)) + :hints (("Subgoal *1/3'" + :use (:instance ncdr-of-+2-reduce + (n (1+ (lsh (1- n))))) + :in-theory (disable ncdr)))) + +(defthm ncar-of-ncons-reduce + (implies (and (natp n) + (bitp b)) + (equal (ncar (ncons b n)) b))) + +(defthm ncdr-of-ncons-reduce + (implies (and (natp n) + (bitp b)) + (equal (ncdr (ncons b n)) n))) + +(defthm ncons-reconstruct + (implies (natp n) + (equal (ncons (ncar n) (ncdr n)) n))) + +(defthm implies-not-zp-<-ncdr + (implies (not (zp x)) + (< (ncdr x) x)) + :rule-classes :linear) + +(defun nlen (x) + (if (zp x) 0 (1+ (nlen (ncdr x))))) + +(defthm not-zp-ncons-1 + (not (zp (ncons 1 x)))) + +(defthm natp-ncar-propagate + (implies (natp x) + (natp (ncar x))) + :hints (("Subgoal *1/2" :in-theory (enable zp natp))) + :rule-classes :type-prescription) + +(defthm bitp-ncar-propagate + (implies (natp x) + (bitp (ncar x))) + :hints (("Subgoal *1/2" :in-theory (enable zp natp)))) + +(defthm natp-ncons-propagate + (implies (natp b) + (natp (ncons b n))) + :rule-classes :type-prescription) + +(defthm bitp-implies-natp + (implies (bitp x) (natp x))) + +(local (in-theory (disable linear-factoid1 linear-factoid2))) +(in-theory (disable ncons ncar ncdr bitp)) + +; Matt K. mod for v2-9.1: Remove support for pre-v2.8. + +(defun nicep (x) + (or (stringp x) + (characterp x) + (acl2-numberp x) + (symbolp x) + (and (consp x) + (nicep (car x)) + (nicep (cdr x))))) + +(defun simplep (x) + (or (null x) + (and (consp x) + (simplep (car x)) + (simplep (cdr x))))) + +; Modified slightly 12/4/2012 by Matt K. to be redundant with new ACL2 +; definition. +(defun nat-listp (l) + (declare (xargs :guard t)) + (cond ((atom l) + (eq l nil)) + (t (and (natp (car l)) + (nat-listp (cdr l)))))) + +(defun nat->list (n) + (if (zp n) () (cons nil (nat->list (1- n))))) + +(defun list->nat (x) + (if (endp x) 0 (1+ (list->nat (cdr x))))) + +(defthm nat->list-inverse + (implies (natp x) + (equal (list->nat (nat->list x)) + x))) + +(defthm nat->list-simplep + (simplep (nat->list n))) + +(defun clist->simple (x) + (if (endp x) () + (cons (nat->list (char-code (car x))) + (clist->simple (cdr x))))) + +(defun simple->clist (x) + (if (endp x) () + (cons (code-char (list->nat (car x))) + (simple->clist (cdr x))))) + +(defthm clist->simple-inverse + (implies (character-listp x) + (equal (simple->clist (clist->simple x)) + x))) + +(defthm clist->simple-simplep + (simplep (clist->simple x))) + +(defun nice-count (x) + (cond ((null x) 0) + ((characterp x) 0) + ((integerp x) + (if (>= x 0) 0 1)) + ((rationalp x) + (+ 1 + (nice-count (numerator x)) + (nice-count (denominator x)))) + ((complex-rationalp x) + (+ 1 + (nice-count (realpart x)) + (nice-count (imagpart x)))) + ((stringp x) 1) + ((symbolp x) 2) + ((consp x) + (+ 1 + (nice-count (car x)) + (nice-count (cdr x)))) + (t 0))) + +(defun natural-tag () (nat->list 1)) +(defun negative-tag () (nat->list 2)) +(defun rational-tag () (nat->list 3)) +(defun complex-tag () (nat->list 4)) +(defun character-tag () (nat->list 5)) +(defun string-tag () (nat->list 6)) +(defun symbol-tag () (nat->list 7)) +(defun cons-tag () (nat->list 8)) +(defun nil-tag () nil) +(defun t-tag () (cons nil nil)) + +(defun nice->simple (x) + (declare (xargs :measure (nice-count x))) + (cond ((eq x nil) (nil-tag)) + ((eq x t) (t-tag)) + ((integerp x) + (if (>= x 0) + (cons (natural-tag) + (nat->list x)) + (cons (negative-tag) + (nat->list (- x))))) + ((rationalp x) + (cons (rational-tag) + (cons (nice->simple (numerator x)) + (nice->simple (denominator x))))) + ((complex-rationalp x) + (cons (complex-tag) + (cons (nice->simple (realpart x)) + (nice->simple (imagpart x))))) + ((characterp x) + (cons (character-tag) + (nat->list (char-code x)))) + ((stringp x) + (cons (string-tag) + (clist->simple (coerce x 'list)))) + ((symbolp x) + (cons (symbol-tag) + (cons (nice->simple (symbol-package-name x)) + (nice->simple (symbol-name x))))) + ((consp x) + (cons (cons-tag) + (cons (nice->simple (car x)) + (nice->simple (cdr x))))) + (t nil))) + +(defun strfix (x) (if (stringp x) x "")) + +(defun simple->nice (x) + (cond ((equal x (nil-tag)) nil) + ((equal x (t-tag)) t) + ((equal (car x) (natural-tag)) + (list->nat (cdr x))) + ((equal (car x) (negative-tag)) + (- (list->nat (cdr x)))) + ((equal (car x) (rational-tag)) + (/ (simple->nice (cadr x)) + (simple->nice (cddr x)))) + ((equal (car x) (complex-tag)) + (complex (simple->nice (cadr x)) + (simple->nice (cddr x)))) + ((equal (car x) (character-tag)) + (code-char (list->nat (cdr x)))) + ((equal (car x) (string-tag)) + (coerce (simple->clist (cdr x)) 'string)) + ((equal (car x) (symbol-tag)) + (intern$ (strfix (simple->nice (cddr x))) + (strfix (simple->nice (cadr x))))) + ((equal (car x) (cons-tag)) + (cons (simple->nice (cadr x)) + (simple->nice (cddr x)))) + (t nil))) + +(defthm nice->simple-inverse + (implies (nicep x) + (equal (simple->nice (nice->simple x)) + x))) + +(defthm nice->simple-simplep + (simplep (nice->simple x))) + +(defthm simple->nice-nicep + (nicep (simple->nice x))) + +;; we now use ncons to map simple-trees into natural numbers + +(defun interleave (x y) + (declare (xargs :measure (+ (nlen x) (nlen y)))) + (if (or (not (natp x)) + (not (natp y)) + (and (= x 0) (= y 0))) + 0 + (ncons 1 + (ncons (ncar x) + (ncons (ncar y) + (interleave (ncdr x) + (ncdr y))))))) + +(defun extract1 (x) + (declare (xargs :measure (nlen x))) + (if (zp x) + 0 + (ncons (ncar (ncdr x)) + (extract1 (ncdr (ncdr (ncdr x))))))) + +(defun extract2 (x) + (declare (xargs :measure (nlen x))) + (if (zp x) + 0 + (ncons (ncar (ncdr (ncdr x))) + (extract2 (ncdr (ncdr (ncdr x))))))) + +(defthm extract1-of-interleave + (implies (and (natp x) + (natp y)) + (equal (extract1 (interleave x y)) x))) + +(defthm extract2-of-interleave + (implies (and (natp x) + (natp y)) + (equal (extract2 (interleave x y)) y))) + +(defthm extract1-<=-propagate + (<= (nlen (extract1 x)) (nlen x)) + :rule-classes :linear) + +(defthm extract2-<=-propagate + (<= (nlen (extract2 x)) (nlen x)) + :rule-classes :linear) + +(defun simple->nat (x) + (if (consp x) + (ncons 1 (interleave (simple->nat (car x)) + (simple->nat (cdr x)))) + 0)) + +(defun nat->simple (x) + (declare (xargs :measure (nlen x))) + (if (and (not (zp x)) + (= (ncar x) 1)) + (cons (nat->simple (extract1 (ncdr x))) + (nat->simple (extract2 (ncdr x)))) + nil)) + +(defthm simple->nat-inverse + (implies (simplep x) + (equal (nat->simple (simple->nat x)) + x))) + +(defthm simple->nat-is-natp + (natp (simple->nat x))) + +(defthm nat->simplep-is-simplep + (simplep (nat->simple x))) + +(defun nice->nat (x) + (simple->nat (nice->simple x))) + +(defun nat->nice (x) + (simple->nice (nat->simple x))) + +(defthm nice->nat-inverse + (implies (nicep x) + (equal (nat->nice (nice->nat x)) + x))) + +(defthm nice->nat-is-natural + (natp (nice->nat x)) + :rule-classes (:type-prescription :rewrite)) + +(defthm nat->nice-is-nicep + (nicep (nat->nice x))) + +(defthm nice->simple-atom-implies-nil + (implies (nicep x) + (equal (atom (nice->simple x)) (not x)))) + +(defthm ncons-of-1-not-equal-0 + (not (equal (ncons 1 x) 0)) + :hints (("Goal" :in-theory (enable ncons)))) + +(defthm simple->nat-0-implies-atom + (equal (equal (simple->nat x) 0) (atom x))) + +(defthm nice->nat-0-implies-nil + (implies (nicep x) + (equal (equal (nice->nat x) 0) (not x))) + :hints (("Goal" :in-theory (disable nice->simple nicep simple->nat)))) + +(in-theory (disable nat->nice nice->nat)) + +;; NOTE -- we conclude this book with a simple trick using defun-sk to get a +;; predicate recognizing the natural numbers which are in the range of +;; nice->nat and using this predicate to prove the additional property required +;; to show that nat->nice and nice->nat are bijective on this range and the +;; nice objects. We do not use the following properties in the books this book +;; supports, but others may find this useful and at least this little logic +;; trick may have other applications: + +(defun-sk nice-natp (x) + (exists y (and (nicep y) (equal (nice->nat y) x)))) + +(defthm nice-natp-implies-natp + (implies (nice-natp x) + (natp x))) + +(defthm nice->nat-is-nice-natp + (implies (nicep x) + (nice-natp (nice->nat x))) + :hints (("Goal" :use (:instance nice-natp-suff + (y x) + (x (nice->nat x))) + :in-theory (disable nice-natp-suff)))) + +(defthm nat->nice-inverse + (implies (nice-natp x) + (equal (nice->nat (nat->nice x)) + x)) + :hints (("Goal" :use (:instance nice->nat-inverse + (x (nice-natp-witness x))) + :in-theory (disable nice->nat-inverse)))) + + +(defun nice-nat (x) + (nice->nat (nat->nice x))) + +(defthm nice-natp-of-nice-nat + (nice-natp (nice-nat x))) + +(in-theory (disable nice-natp)) + + + + + diff --git a/books/workshops/2003/sumners/support/simple.lisp b/books/workshops/2003/sumners/support/simple.lisp new file mode 100644 index 0000000..9061b82 --- /dev/null +++ b/books/workshops/2003/sumners/support/simple.lisp @@ -0,0 +1,133 @@ +(in-package "ACL2") +(set-match-free-default :all) + +#| simple.lisp + +This book defines a basic fair selector over a bounded set of natural +numbers. Note that this selector is completely subsumed by the fair selector +defined in fair.lisp which defines a fair selector over a superset of the +objects selected by the functions in this book. Thus, this book is included +solely for the purposes of exposition and completeness, but we do not suggest +the use of this book. + +|# + +; The following was removed with the addition of natp-compound-recognizer to +; ACL2 2.9.2. +;(defthm natp-compound-recognizer +; (iff (natp x) +; (and (integerp x) +; (>= x 0))) +; :rule-classes :compound-recognizer) + +(in-theory (disable natp)) + +(encapsulate + (((upper-bound) => *)) + + (local (defun upper-bound () 1)) + + (defthm upper-bound-positive-natural + (and (integerp (upper-bound)) + (> (upper-bound) 0)) + :rule-classes :type-prescription) +) + +(defun selectp (i) + (and (natp i) (< i (upper-bound)))) + +(defun fair-select (f) f) + +(defun fair-measure (i f) + (if (selectp i) + (if (< i f) + (+ i (- (upper-bound) f)) + (- i f)) + 0)) + +(defun fair-step (f) + (let ((f (1+ f))) (if (< f (upper-bound)) f 0))) + +(defun fair-inv (f) (selectp f)) + +(defun fair-init () 0) + +(local +(defthm fair-measure-natural + (implies (fair-inv f) + (natp (fair-measure i f))) + :hints (("Goal" :in-theory (enable natp))))) + +(local +(defthm fair-measure-decreases + (implies (and (selectp i) + (fair-inv f) + (not (equal i (fair-select f)))) + (< (fair-measure i (fair-step f)) + (fair-measure i f))) + :rule-classes :linear)) + +(local +(defthm fair-inv-is-invariant + (implies (fair-inv f) + (fair-inv (fair-step f))))) + +(in-theory (disable (fair-inv) (selectp))) + +(local +(defthm fair-inv-of-init + (fair-inv 0))) + +(in-theory (disable fair-step fair-inv fair-measure fair-select)) + + +(defun fair-run (n) + (if (zp n) (fair-init) (fair-step (fair-run (1- n))))) + +(defthm fair-inv-of-fair-run + (fair-inv (fair-run n))) + +(local +(defthm linear-factoid1 + (implies (and (natp n) + (natp x)) + (equal (+ n (- n) x) x)))) + +(local +(defthm linear-factoid2 + (implies (and (natp n) + (natp x)) + (equal (+ (- n) n x) x)))) + +(local +(defthm fair-run-of-1+ + (implies (natp n) + (equal (fair-run (1+ n)) + (fair-step (fair-run n)))))) + +(in-theory (disable fair-run)) +(in-theory (enable (:induction fair-run))) + +(in-theory (disable (fair-run) (fair-step) (fair-select))) + +(encapsulate + (((env *) => *) + ((env-measure * *) => *)) + +(local (defun env (n) + (fair-select (fair-run n)))) +(local (defun env-measure (i n) + (fair-measure i (fair-run n)))) + +(defthm env-measure+-is-natural + (natp (env-measure i n)) + :rule-classes (:type-prescription :rewrite)) + +(defthm env-measure+-decreases + (implies (and (selectp i) + (natp n) + (not (equal i (env n)))) + (< (env-measure i (1+ n)) + (env-measure i n))) + :rule-classes (:linear :rewrite)) +) diff --git a/books/workshops/2003/sustik/dickson.pdf.gz b/books/workshops/2003/sustik/dickson.pdf.gz Binary files differnew file mode 100644 index 0000000..2ac795c --- /dev/null +++ b/books/workshops/2003/sustik/dickson.pdf.gz diff --git a/books/workshops/2003/sustik/dickson.ps.gz b/books/workshops/2003/sustik/dickson.ps.gz Binary files differnew file mode 100644 index 0000000..a0f3aeb --- /dev/null +++ b/books/workshops/2003/sustik/dickson.ps.gz diff --git a/books/workshops/2003/sustik/dicksonslides.pdf.gz b/books/workshops/2003/sustik/dicksonslides.pdf.gz Binary files differnew file mode 100644 index 0000000..ed103c5 --- /dev/null +++ b/books/workshops/2003/sustik/dicksonslides.pdf.gz diff --git a/books/workshops/2003/sustik/dicksonslides.ps.gz b/books/workshops/2003/sustik/dicksonslides.ps.gz Binary files differnew file mode 100644 index 0000000..157ba99 --- /dev/null +++ b/books/workshops/2003/sustik/dicksonslides.ps.gz diff --git a/books/workshops/2003/sustik/support/dickson.lisp b/books/workshops/2003/sustik/support/dickson.lisp new file mode 100644 index 0000000..e771388 --- /dev/null +++ b/books/workshops/2003/sustik/support/dickson.lisp @@ -0,0 +1,1056 @@ +(in-package "ACL2") + +#| + +Updated : 09-08-03 +By : Daron Vroon + +File : dickson.lisp +Authors : Matyas, Sandip +Date created: 2002-04-24 +Revision : $Id: dickson.lisp,v 1.62 2003/07/04 01:06:26 sustik Exp $ + +The constructive proof described in the dickson.dvi file is formulated +in this file. An embedding of monomial sets to ordinals is defined +such that if a monomial sequence is such that no monomial divides +another one further in the sequence, then the corresponding ordinal +sequence assigned to the monomial sets forming proper subsequences is +decreasing according to e0-ord-<. This will establish by the +well-foundedness of ordinals that there can be no infinitely +decreasing sequence of such monomials. The direct formulation uses +the ordinals in Cantor normal form as defined in the 'ordinals' book +by written by Panagiotis Manolios and Daron Vroon and the mapping is +lifted to the ACL2 ordinals in a subsequent step. + +I am thankful to Sandip Ray for his contributions early in the +project. His insight lead to simplify the proof attempt by realizing +independence of certain lemmas. + +|# + +;; (set-match-free-error nil) + +;(include-book "ordinal-arith" :skip-proofs-okp nil) +(include-book "../../../../ordinals/ordinals") +;(include-book "../../../../ordinals/e0-ordinal") + +(defun o-min (x y) + (if (o< x y) x y)) + +;; We start by defining a recognizer for k-tuple of naturals, which is the +;; representation of monomials so far as we are concerned. + +(defun natural-tuplep (k x) + (cond ((zp k) (null x)) + ((not (natp (first x))) nil) + (T (natural-tuplep (1- k) (rest x))))) + +(defthm natural-tuplep-length + (implies (and (natural-tuplep k x) + (natp k)) + (equal (length x) k))) + +;; The function partial-tuple-<= is the partial order on tuples which +;; coincides with monomial divisibility. + +(defun partial-tuple-<= (k x y) + (cond ((zp k) t) + ((< (car y) (car x)) nil) + (t (partial-tuple-<= (1- k) (cdr x) (cdr y))))) + +;; We prove now that it is indeed a partial order, namely it is +;; reflexive, transitive, and antisymmetric. + +(defthm partial-tuple-<=-transitivity + (implies (and (partial-tuple-<= k x y) + (partial-tuple-<= k y z)) + (partial-tuple-<= k x z)) + :rule-classes :forward-chaining) + +(defthm partial-tuple-<=-reflexivity + (partial-tuple-<= k x x)) + +(defthm partial-tuple-<=-antisymmetry + (implies (and (partial-tuple-<= k x y) + (partial-tuple-<= k y x) + (natural-tuplep k x) + (natural-tuplep k y)) + (equal x y)) + :rule-classes :forward-chaining) + +;; We define a recognizer for a set of k-tuples. + +(defun tuple-setp (k A) + (cond ((atom A) (equal A nil)) + ((not (natural-tuplep k (first A))) nil) + (T (tuple-setp k (rest A))))) + +;; (tuple-setp 1 '((1) (2) (3))) +;; (tuple-setp 3 '((1 2 3) (1 2 2) (3 1 1) (3 4 1) (2 0 2))) + +;; We now define a recognizer of the membership of a tuple in a tuple +;; set. + +(defun tuple-in-set (x S) + (cond ((endp S) nil) + ((equal x (first S)) T) + (T (tuple-in-set x (rest S))))) + +;; (tuple-in-set '(1 2 3) '((2 2 5) (8 1 3) (1 2 3) (4 3 4))) + +;; And then we can now define a subset relation on tuple sets in the +;; natural way. + +(defun tuple-set-subsetp (A B) + (cond ((endp A) T) + ((not (tuple-in-set (first A) B)) nil) + (T (tuple-set-subsetp (rest A) B)))) + +;; (tuple-set-subsetp '((1 2) (3 4) (4 5)) '((3 4) (4 5) (1 4) (2 3) (1 2))) + +;; We prove now, that the subset relation is transitive and reflexive, +;; more for sanity check than anything else. Note that we cannot prove +;; anti-symmetry here, since we are not using set equality, but just +;; the vanilla equality. + +(defthm tuple-set-subsetp-transitive + (implies (and (tuple-set-subsetp A B) + (tuple-set-subsetp B C)) + (tuple-set-subsetp A C)) + :rule-classes :forward-chaining) + +(defthm subset-cons + (implies (tuple-set-subsetp A B) + (tuple-set-subsetp A (cons e B)))) + +(defthm tuple-set-subsetp-reflexive + (tuple-set-subsetp x x)) + +(in-theory (disable subset-cons)) + +(defun tuple-set-filter (S i) + (cond ((endp S) NIL) + ((and (consp (first S)) (<= (first (first S)) i)) + (cons (first S) (tuple-set-filter (rest S) i))) + (T (tuple-set-filter (rest S) i)))) + +;; (tuple-set-filter '((1 2 3) (1 2 2) (3 1 1) (3 4 1) (2 0 2)) 2) + +(defthm tuple-set-filter-creates-tuple-set + (implies (and (tuple-setp k S) + (natp i)) + (tuple-setp k (tuple-set-filter S i)))) + +(defthm tuple-set-filter-monoton + (implies (and (natp i) + (natp j) + (<= i j)) + (tuple-set-subsetp (tuple-set-filter S i) + (tuple-set-filter S j)))) + +(defthm tuple-set-filter-element + (implies (and (tuple-in-set x S) + (consp x) + (<= (car x) i) + (natp i)) + (tuple-in-set x (tuple-set-filter S i)))) + +(defthm tuple-set-filter-preserves-subset + (implies (and (natp i) + (tuple-set-subsetp A B)) + (tuple-set-subsetp (tuple-set-filter A i) + (tuple-set-filter B i)))) + +(defun tuple-set-projection (S) + (cond ((endp S) NIL) + ((consp (first S)) (cons (rest (first S)) + (tuple-set-projection (rest S)))) + (T (tuple-set-projection (rest S))))) + +;; (tuple-set-projection '((1 2 3) (1 2 2) (3 1 1) (3 4 1) (2 0 2))) + +(defthm tuple-set-projection-creates-tuple-set + (implies (and (tuple-setp k S) + (natp i)) + (tuple-setp (1- k) (tuple-set-projection S)))) + +(defthm tuple-set-projection-element + (implies (and (tuple-in-set x S) + (consp x)) + (tuple-in-set (rest x) (tuple-set-projection S)))) + +(defthm tuple-set-projection-preserves-subset + (implies (tuple-set-subsetp A B) + (tuple-set-subsetp (tuple-set-projection A) + (tuple-set-projection B)))) + +(defun tuple-set-filter-projection (S i) + (tuple-set-projection (tuple-set-filter S i))) + +(defun tuple-set-max-first (S) + (cond ((endp S) 0) + ((and (consp (first S)) (natp (first (first S)))) + (max (first (first S)) + (tuple-set-max-first (rest S)))) + (T (tuple-set-max-first (rest S))))) + +(defthm tuple-set-max-first-property + (implies (and (tuple-in-set x S) + (consp x) + (natp (first x))) + (<= (first x) (tuple-set-max-first S)))) + +(defthm tuple-set-filter-max + (implies (and (tuple-setp k S) + (natp k) + (not (zp k)) + (<= (tuple-set-max-first S) i)) + (equal (tuple-set-filter S i) S))) + +(in-theory (disable tuple-set-filter)) +(in-theory (disable tuple-set-projection)) + +(defthm tuple-set-max-first-subset + (implies (tuple-set-subsetp A B) + (<= (tuple-set-max-first A) + (tuple-set-max-first B))) + :rule-classes :linear) + +(in-theory (disable tuple-set-max-first)) + +(defun tuple-set-min-first (S) + (cond ((endp S) (omega)) + ((and (consp (first S)) (natp (first (first S)))) + (o-min (first (first S)) + (tuple-set-min-first (rest S)))) + (T (tuple-set-min-first (rest S))))) + +;; (tuple-set-min-first '((1 2 3) (1 2 2) (3 1 1) (3 4 1) (2 0 2))) +;; (tuple-set-min-first '( nil )) + +(defthm tuple-set-min-first-produces-ordinal + (o-p (tuple-set-min-first S))) + +(defthm tuple-set-min-first-property + (implies (and (tuple-in-set x S) + (consp x) + (natp (first x))) + (<= (tuple-set-min-first S) (first x))) + :hints (("goal" :in-theory (enable o<)))) + +(defthm tuple-set-min-first-nat + (implies (and (posp k) + (tuple-setp k S) + (consp S)) + (natp (tuple-set-min-first S))) + :rule-classes ((:rewrite :match-free :all) + (:forward-chaining :trigger-terms ((tuple-setp k S))))) + +(defthm technical-tuple-set-min-first-non-empty + (implies (and (posp k) + (tuple-setp k S) + (tuple-in-set x S)) + (natp (tuple-set-min-first S))) + :rule-classes ((:forward-chaining + :match-free :all + :trigger-terms ((tuple-setp k S) + (tuple-in-set x S))))) + +(defun tuple-set->ordinal-partial-sum (k S i) + (declare (xargs :measure (o+ (o* (omega) (nfix k)) + (nfix (- (tuple-set-max-first S) i))))) + (cond ((or (not (natp k)) (not (natp i))) 0) + ((zp k) 0) + ((equal k 1) + (tuple-set-min-first S)) + ((<= (tuple-set-max-first S) i) + (o^ (omega) + (o+ (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection S) + 0) + 1))) + (T (o+ + (o^ (omega) + (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-filter-projection S i) + 0)) + (tuple-set->ordinal-partial-sum k S (1+ i)))))) + +(defun tuple-set->ordinal (k S) + (if (and (natp k) + (tuple-setp k S)) + (tuple-set->ordinal-partial-sum k S 0) + 0)) + +;; (tuple-set->ordinal 1 '((5) (3) (4) (2) (3))) +;; (tuple-set->ordinal 2 '((2 5) (3 3) (2 4) (4 2) (3 1))) +;; (tuple-set->ordinal 3 '((1 2 3) (1 2 2) (3 1 1) (3 4 1) (2 0 2))) +;; (tuple-set->ordinal 3 '((1 2 3) (1 2 2) (3 1 1) (3 4 1) (2 0 2))) + +(defthm tuple-set->ordinal-partial-sum-produces-ordinal + (o-p (tuple-set->ordinal-partial-sum k A i)) + :rule-classes ((:rewrite) + (:forward-chaining + :trigger-terms ((tuple-set->ordinal-partial-sum K A i))))) + +(defthm tuple-set->ordinal-produces-ordinal + (o-p (tuple-set->ordinal k A))) + +(defthm tuple-set->ordinal-partial-sum-k=1 + (implies (and (tuple-setp 1 S) + (natp i)) + (equal (tuple-set->ordinal-partial-sum 1 S i) + (tuple-set-min-first S)))) + +(in-theory (disable tuple-set->ordinal-partial-sum)) + +(defthm technical-5 + (implies (and (tuple-setp k S) + (natp k) + (natp i)) + (o<= (tuple-set->ordinal-partial-sum k S (1+ i)) + (tuple-set->ordinal-partial-sum k S i))) + :hints (("Goal" :expand (tuple-set->ordinal-partial-sum k S i)) + ("Subgoal 4'" :expand (tuple-set->ordinal-partial-sum 0 S (1+ i))) + ("Subgoal 1'" :expand (tuple-set->ordinal-partial-sum k S (1+ i))))) + +(defthm tuple-set-subset-consp + (implies (and (tuple-set-subsetp a b) + (consp a)) + (consp b)) + :rule-classes :forward-chaining) + +(encapsulate + () + (local + (defthm l1 + (implies (and (consp a) + (consp (car a)) + (natp (caar a)) + (o<= (tuple-set-min-first b) + (tuple-set-min-first (cdr a))) + (tuple-setp 1 a) + (tuple-setp 1 b) + (tuple-set-subsetp a b)) + (o<= (tuple-set-min-first b) + (tuple-set-min-first a))) + :hints (("goal" + :do-not-induct t + :in-theory (disable tuple-set-min-first-property) + :use ((:instance tuple-set-min-first-property + (x (car a)) + (S B))))) + :rule-classes :forward-chaining)) + + (defthm subset-tuple-set-min-first-<= + (implies (and (tuple-setp 1 a) + (tuple-setp 1 b) + (tuple-set-subsetp a b)) + (o<= (tuple-set-min-first b) + (tuple-set-min-first a))))) + +(defun map-lemma-1.1-induction-hint (k A B i) + (declare (xargs :measure (o+ (o* (omega) (nfix k)) (nfix (- (tuple-set-max-first B) i))))) + (cond ((not (natp i)) A) + ((zp k) B) + ((equal 1 k) 0) + ((<= (tuple-set-max-first B) i) + (map-lemma-1.1-induction-hint + (1- k) + (tuple-set-projection A) + (tuple-set-projection B) + 0)) + (T (list (map-lemma-1.1-induction-hint + (1- k) + (tuple-set-filter-projection A i) + (tuple-set-filter-projection B i) + 0) + (map-lemma-1.1-induction-hint + k A B (1+ i)))))) + +(in-theory (enable tuple-set-min-first-property)) + +(defthm tuple-set-min-first-upper-bound + (o<= (tuple-set-min-first S) (omega))) + +(in-theory (disable tuple-set-min-first-property)) + +(defthm map-lemma-1.1 + (implies (and (tuple-setp k A) + (tuple-setp k B) + (tuple-set-subsetp A B) + (natp k) + (natp i)) + (o<= (tuple-set->ordinal-partial-sum + k B i) + (tuple-set->ordinal-partial-sum + k A i))) + :hints (("Goal" + :do-not generalize + :induct (map-lemma-1.1-induction-hint k A B i)) + ("Subgoal *1/4" + :expand ((tuple-set->ordinal-partial-sum k B i) + (tuple-set->ordinal-partial-sum k A i))) + ("Subgoal *1/4.1'" + :in-theory (disable |a <= b & c <= d => a+c <= b+d|) + :use (:instance |a <= b & c <= d => a+c <= b+d| + (a (O^ (OMEGA) + (TUPLE-SET->ORDINAL-PARTIAL-SUM + (+ -1 K) + (TUPLE-SET-PROJECTION + (TUPLE-SET-FILTER B I)) + 0))) + (b (O^ (OMEGA) + (TUPLE-SET->ORDINAL-PARTIAL-SUM + (+ -1 K) + (TUPLE-SET-PROJECTION A) + 0))) + (c (TUPLE-SET->ORDINAL-PARTIAL-SUM K B (+ 1 I))) + (d (O^ (OMEGA) + (O+ (TUPLE-SET->ORDINAL-PARTIAL-SUM + (+ -1 K) + (TUPLE-SET-PROJECTION A) + 0) + 1))))) + ("Subgoal *1/4.1''" + :expand (TUPLE-SET->ORDINAL-PARTIAL-SUM K A (+ 1 I))) + ("Subgoal *1/3" + :expand ((tuple-set->ordinal-partial-sum k A i) + (tuple-set->ordinal-partial-sum k B i))) + ("Subgoal *1/1''" + :expand ((TUPLE-SET->ORDINAL-PARTIAL-SUM 0 B I) + (TUPLE-SET->ORDINAL-PARTIAL-SUM 0 A I))))) + +(in-theory (disable map-lemma-1.1)) + +(defthm map-lemma-1 + (implies (and (tuple-setp k A) + (tuple-setp k B) + (tuple-set-subsetp A B) + (natp k)) + (o<= (tuple-set->ordinal k B) + (tuple-set->ordinal k A))) + :hints (("Goal" + :do-not-induct t + :expand ((tuple-set->ordinal k B) + (tuple-set->ordinal k A)) + :use (:instance map-lemma-1.1 (i 0))))) + +(in-theory (disable tuple-set->ordinal)) + +(defthm map-lemma-2 + (implies (and (tuple-setp k A) + (natp k) + (< 1 k) + (natp i)) + (o<= (tuple-set->ordinal (1- k) + (tuple-set-filter-projection A (1+ i))) + (tuple-set->ordinal (1- k) + (tuple-set-filter-projection A i))))) + +(defthm map-lemma-2.1 + (implies (and (tuple-setp k A) + (natp k) + (< 1 k) + (natp i)) + (o<= (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter A (1+ i))) + 0) + (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter A i)) + 0))) + :hints (("Goal" + :use (:instance map-lemma-1.1 + (k (1- k)) + (i 0) + (A (tuple-set-filter-projection A i)) + (B (tuple-set-filter-projection A (1+ i))))))) + + +(defun map-lemma-3.1-induction-hint (A i) + (declare (xargs :measure (nfix (- (tuple-set-max-first A) i)))) + (cond ((not (natp i)) A) + ((<= (tuple-set-max-first A) i) T) + (T (list (map-lemma-3.1-induction-hint A (1+ i)))))) + +(encapsulate + () + + (local + (defthm l1 + (implies + (and (natp i) + (< i (tuple-set-max-first a)) + (o<= (tuple-set->ordinal-partial-sum k a (+ 1 i)) + (o* (o^ (omega) + (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection (tuple-set-filter a (+ 1 i))) + 0)) + (omega))) + (tuple-setp k a) + (posp k) + (< 1 k)) + (o<= (o^ (omega) + (o+ (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection (tuple-set-filter a (+ 1 i))) + 0) + 1)) + (o^ (omega) + (o+ (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection + (tuple-set-filter a i)) + 0) + 1)))))) + + (local + (defthm l2 + (implies + (and (natp i) + (< i (tuple-set-max-first a)) + (o<= (tuple-set->ordinal-partial-sum k a (+ 1 i)) + (o* (o^ (omega) + (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection (tuple-set-filter a (+ 1 i))) + 0)) + (omega))) + (tuple-setp k a) + (posp k) + (< 1 k)) + (o<= (tuple-set->ordinal-partial-sum k a (+ 1 i)) + (o^ (omega) + (o+ (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection (tuple-set-filter a i)) + 0) + 1)))) + :hints (("goal" + :use ((:instance |a <= b & b <= c => a <= c| + (a (tuple-set->ordinal-partial-sum k a (+ 1 i))) + (b (o* (o^ (omega) + (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection (tuple-set-filter a (+ 1 i))) + 0)) + (omega))) + (c (o^ (omega) + (o+ (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection + (tuple-set-filter a i)) + 0) + 1))))))))) + (local + (defthm l3 + (implies + (and (natp i) + (< i (tuple-set-max-first a)) + (o<= (tuple-set->ordinal-partial-sum k a (+ 1 i)) + (o* (o^ (omega) + (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection (tuple-set-filter a (+ 1 i))) + 0)) + (omega))) + (tuple-setp k a) + (posp k) + (< 1 k)) + (o<= (o+ (o^ (omega) + (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-filter-projection a i) + 0)) + (tuple-set->ordinal-partial-sum k a (+ 1 i))) + (o+ (o^ (omega) + (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-filter-projection a i) + 0)) + (o^ (omega) + (o+ (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-filter-projection a i) + 0) + 1))))) + :hints (("goal" + :do-not-induct t + :in-theory (disable l2 |a < b <=> c+a < c+b|) + :use (l2 + (:instance |a < b <=> c+a < c+b| + (c (o^ (omega) + (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-filter-projection a i) + 0))) + (b (tuple-set->ordinal-partial-sum k a (+ 1 i))) + (a (o^ (omega) + (o+ (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-filter-projection a i) + 0) + 1))))))))) + + (defthm map-lemma-3.1 + (implies (and (tuple-setp k A) + (posp k) + (< 1 k) + (natp i)) + (o<= (tuple-set->ordinal-partial-sum k A i) + (o^ (omega) (o+ (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-filter-projection A i) + 0) + 1)))) + :hints (("Goal" + :induct (map-lemma-3.1-induction-hint A i)) + ("Subgoal *1/2''" + :expand (tuple-set->ordinal-partial-sum k A i) + :in-theory (disable l3) + :use ((:instance l3))) + ("Subgoal *1/1'" + :expand (TUPLE-SET->ORDINAL-PARTIAL-SUM K A I))))) + +(defthm map-lemma-3.2 + (implies (and (tuple-setp k A) + (natp k) + (< 1 k) + (natp i)) + (o< (o^ (omega) (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-filter-projection A i) + 0)) + (tuple-set->ordinal-partial-sum k A i))) + :hints (("Goal" + :expand (tuple-set->ordinal-partial-sum k A i)) + ("Subgoal 2" ; Matt K. mod 5/2016 (type-set bit for {1}) + :expand (tuple-set->ordinal-partial-sum k A (+ 1 i))))) + +(defthm map-lemma-3.3 + (implies (and (tuple-setp k A) + (tuple-setp k B) + (natp k) + (natp i) + (< 1 k) + (o< (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter A i)) + 0) + (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter B i)) + 0))) + (o< (tuple-set->ordinal-partial-sum k A i) + (tuple-set->ordinal-partial-sum k B i))) + :hints (("Goal" + :do-not-induct t + :in-theory (disable |a <= b & b < c => a < c|) + :use (map-lemma-3.1 + (:instance map-lemma-3.2 + (a b)) + (:instance |a <= b & b < c => a < c| + (a (o* (o^ (omega) + (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection (tuple-set-filter a i)) + 0)) + (omega))) + (b (o^ (omega) + (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-projection (tuple-set-filter b i)) + 0))) + (c (tuple-set->ordinal-partial-sum k b i))) + (:instance |a <= b => c^a <= c^b| + (a (o+ (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-filter-projection a i) + 0) + 1)) + (b (tuple-set->ordinal-partial-sum + (+ -1 k) + (tuple-set-filter-projection b i) + 0)) + (c (omega))))))) + +(defthm map-lemma-3.4 + (implies (and (tuple-setp k A) + (tuple-setp k B) + (posp k) + (natp i) + (< 1 k) + (equal (tuple-set->ordinal-partial-sum k A i) + (tuple-set->ordinal-partial-sum k B i))) + (equal (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter A i)) + 0) + (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter B i)) + 0))) + :hints (("Goal" :use (map-lemma-3.3 + (:instance map-lemma-3.3 + (A B) + (B A)))))) + +(in-theory (disable map-lemma-3.4)) + +(defthm map-lemma-3.5 + (implies (and (tuple-setp k A) + (tuple-setp k B) + (posp k) + (natp i) + (< 1 k) + (equal (tuple-set->ordinal-partial-sum k A i) + (tuple-set->ordinal-partial-sum k B i))) + (equal (tuple-set->ordinal-partial-sum k A (1+ i)) + (tuple-set->ordinal-partial-sum k B (1+ i)))) + :hints ; Matt K. mod 5/2016 (type-set bit for {1}): avoid subgoal hints + (("Goal" + :do-not-induct t + :in-theory (disable |a^(b+c) = a^b * a^c|) + :use map-lemma-3.4 + :expand ((tuple-set->ordinal-partial-sum k a i) + (tuple-set->ordinal-partial-sum k b i) + (tuple-set->ordinal-partial-sum k a (+ 1 i)) + (tuple-set->ordinal-partial-sum k b (+ 1 i)))))) + +(defun map-lemma-3.6-induction-hint (i j) + (cond ((not (natp i)) nil) + ((not (natp j)) nil) + ((<= j i) nil) + (T (map-lemma-3.6-induction-hint i (1- j))))) + +(defthm map-lemma-3.6 + (implies (and (tuple-setp k A) + (tuple-setp k B) + (natp k) + (< 1 k) + (natp i) + (natp j) + (<= i j) + (equal (tuple-set->ordinal-partial-sum k A i) + (tuple-set->ordinal-partial-sum k B i))) + (equal (equal (tuple-set->ordinal-partial-sum k A j) + (tuple-set->ordinal-partial-sum k B j)) + T)) + :hints (("Goal" + :induct (map-lemma-3.6-induction-hint i j)) + ("Subgoal *1/2'" + :use (:instance map-lemma-3.5 + (i (+ -1 j)))))) + +(defthm map-lemma-3.7 + (implies (and (tuple-setp k A) + (tuple-setp k B) + (natp k) + (< 1 k) + (natp i) + (natp j) + (<= i j) + (equal (tuple-set->ordinal-partial-sum k A i) + (tuple-set->ordinal-partial-sum k B i))) + (equal (equal (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter A j)) + 0) + (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter B j)) + 0)) + T)) + :hints (("Goal" + :use (map-lemma-3.6 + (:instance map-lemma-3.4 + (i j)))))) + +(defthm map-lemma-3 + (implies (and (tuple-setp k A) + (tuple-setp k B) + (natp k) + (natp i) + (< 1 k) + (equal (tuple-set->ordinal-partial-sum k A 0) + (tuple-set->ordinal-partial-sum k B 0))) + (equal (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter A i)) + 0) + (tuple-set->ordinal-partial-sum + (1- k) + (tuple-set-projection (tuple-set-filter B i)) + 0))) + :hints (("Goal" + :use (:instance map-lemma-3.7 + (i 0) + (j i))))) + +(defun exists-partial-tuple-<=-set-witness (k S x) + (cond ((endp S) nil) + ((partial-tuple-<= k (first S) x) (first S)) + (t (exists-partial-tuple-<=-set-witness k (rest S) x)))) + +(defun exists-partial-tuple-<=-set (k S x) + (let ((w (exists-partial-tuple-<=-set-witness k S x))) + (and (natural-tuplep k w) + (tuple-in-set w S) + (partial-tuple-<= k w x)))) + +(defthm exists-partial-tuple-<=-set-suff + (implies (and (tuple-setp k S) + (tuple-in-set w S) + (partial-tuple-<= k w x)) + (exists-partial-tuple-<=-set k S x))) + +(defthm exists-partial-tuple-<=-set-impl + (implies (and (natp k) + (<= 1 k) + (natural-tuplep k x) + (tuple-setp k S) + (exists-partial-tuple-<=-set k S x)) + (and (equal (natural-tuplep + k + (exists-partial-tuple-<=-set-witness k S x)) + T) + (equal (tuple-in-set + (exists-partial-tuple-<=-set-witness k S x) + S) + T) + (partial-tuple-<= + k + (exists-partial-tuple-<=-set-witness k S x) + x)))) + +(in-theory (disable exists-partial-tuple-<=-set)) + +(defun exists-projection-filter-inverse-witness (S v i) + (cond ((endp S) nil) + ((and (equal v (rest (first S))) + (<= (first (first S)) i)) (first S)) + (T (exists-projection-filter-inverse-witness (rest S) v i)))) + +(defun exists-projection-filter-inverse (S v i) + (let ((w (exists-projection-filter-inverse-witness S v i))) + (and (tuple-in-set w S) + (equal v (rest w)) + (<= (first w) i)))) + +(defthm exists-projection-filter-inverse-suff + (implies (and (tuple-in-set w S) + (equal v (rest w)) + (<= (first w) i)) + (exists-projection-filter-inverse S v i))) + +(defthm exists-projection-filter-inverse-impl + (implies (and (tuple-setp k S) + (natural-tuplep (1- k) v) + (<= 1 k) + (exists-projection-filter-inverse S v i)) + (and (equal (natural-tuplep + k + (exists-projection-filter-inverse-witness S v i)) + T) + (equal (tuple-in-set + (exists-projection-filter-inverse-witness S v i) + S) + T) + (equal (rest (exists-projection-filter-inverse-witness S v i)) + v) + (<= (first (exists-projection-filter-inverse-witness S v i)) + i)))) + +(in-theory (enable tuple-set-filter)) +(in-theory (enable tuple-set-projection)) + +(defthm map-lemma-4.1.1 + (implies (and (tuple-setp k A) + (natural-tuplep (1- k) u) + (natp i) + (natp k) + (< 1 k) + (tuple-in-set u (tuple-set-projection (tuple-set-filter A i)))) + (exists-projection-filter-inverse A u i))) + +(defthm map-lemma-4.1 + (implies (and (tuple-setp k A) + (natural-tuplep (1- k) u) + (natp i) + (natp k) + (< 1 k) + (tuple-in-set u (tuple-set-projection (tuple-set-filter A i)))) + (and (equal (rest (exists-projection-filter-inverse-witness A u i)) + u) + (<= (first + (exists-projection-filter-inverse-witness A u i)) i)))) + +(defthm map-lemma-4.2 + (implies (and (tuple-setp k S) + (natp k) + (<= 2 k) + (natural-tuplep k v) + (tuple-in-set v S)) + (tuple-in-set + (cdr v) + (tuple-set-projection (tuple-set-filter S (car v)))))) + +(in-theory (disable tuple-set-filter)) +(in-theory (disable tuple-set-projection)) + +(defun map-lemma-4-induction-hint (A B v k) + (cond ((zp k) nil) + ((< k 2) (list A B v)) + (T (map-lemma-4-induction-hint + (tuple-set-projection (tuple-set-filter A (first v))) + (tuple-set-projection (tuple-set-filter B (first v))) + (rest v) + (1- k))))) + +(in-theory (disable map-lemma-4.1)) + +(defthm partial-tuple-<=-decomposition + (implies (and (natural-tuplep k x) + (natural-tuplep k y) + (<= (first x) (first y)) + (partial-tuple-<= (1- k) (rest x) (rest y))) + (partial-tuple-<= k x y))) + +(in-theory (disable map-lemma-3)) + +(defthm tuple-set-min-first-special + (implies (and (tuple-setp 1 S) + (o< (tuple-set-min-first S) (omega))) + (tuple-in-set (list (tuple-set-min-first S)) S))) + +(defthm map-lemma-4 + (implies (and (tuple-setp k A) + (tuple-setp k B) + (tuple-set-subsetp A B) + (natural-tuplep k v) + (tuple-in-set v B) + (equal (tuple-set->ordinal-partial-sum k A 0) + (tuple-set->ordinal-partial-sum k B 0)) + (natp k) + (<= 1 k)) + (exists-partial-tuple-<=-set k A v)) + :hints (("Goal" + :induct (map-lemma-4-induction-hint A B v k)) + ("Subgoal *1/3.2" + :use ((:instance map-lemma-4.1 + (i (car v)) + (u (exists-partial-tuple-<=-set-witness + (+ -1 k) + (tuple-set-projection + (tuple-set-filter A (car v))) + (cdr v)))))) + ("Subgoal *1/3.2''" + :use ((:instance + exists-partial-tuple-<=-set-suff + (S A) + (w (EXISTS-PROJECTION-FILTER-INVERSE-WITNESS + A + (EXISTS-PARTIAL-TUPLE-<=-SET-WITNESS + (+ -1 K) + (TUPLE-SET-PROJECTION (TUPLE-SET-FILTER A (CAR V))) + (CDR V)) + (CAR V))) + (x v)))) + ("Subgoal *1/3.1" + :use ((:instance map-lemma-3 + (i (car v))))) + ("Subgoal *1/2'''" + :use ((:instance tuple-set-min-first-property + (x v) + (S B)) + (:instance exists-partial-tuple-<=-set-suff + (k 1) + (S A) + (w (list (TUPLE-SET-MIN-FIRST A))) + (x v)))) + ("Subgoal *1/2.1''" + :use ((:instance tuple-set-min-first-special + (S A)))) + + ("Subgoal *1/2.1'5'" + :use ((:instance tuple-set-min-first-nat + (k 1) + (S B)))))) + +(defthm map-lemma-4-alt + (implies (and (tuple-setp k A) + (tuple-setp k B) + (tuple-set-subsetp A B) + (natural-tuplep k v) + (tuple-in-set v B) + (equal (tuple-set->ordinal k A) + (tuple-set->ordinal k B)) + (natp k) + (<= 1 k)) + (exists-partial-tuple-<=-set k A v)) + :hints (("Goal" + :use map-lemma-4) + ("Goal'" + :expand ((TUPLE-SET->ORDINAL K A) + (TUPLE-SET->ORDINAL K B))) + ("Goal'''" + :expand (TUPLE-SET->ORDINAL K NIL)))) + +(defthm tuple-set-subsetp-with-cdr + (implies (tuple-set-subsetp A B) + (tuple-set-subsetp (cdr A) B))) + +(defthm tuple-set-subsetp-idempotent + (tuple-set-subsetp S S)) + +(in-theory (disable map-lemma-1)) +(in-theory (disable map-lemma-4)) + +(defthm dickson-map-thm.1 + (implies (and (tuple-setp k S) + (consp S) + (natp k) + (<= 1 k)) + (o<= (tuple-set->ordinal k S) + (tuple-set->ordinal k (rest S)))) + :hints (("Goal" :use ((:instance map-lemma-1 (A (rest S)) (B S)))))) + +(defthm dickson-map-thm + (implies (and (tuple-setp k S) + (consp S) + (natp k) + (<= 1 k) + (not (exists-partial-tuple-<=-set + k (rest S) (first S)))) + (o< (tuple-set->ordinal k S) + (tuple-set->ordinal k (rest S)))) + :hints (("Goal" + :use ((:instance |b <= a & a <= b => a = b| + (a (TUPLE-SET->ORDINAL K S)) + (b (TUPLE-SET->ORDINAL K (CDR S)))) + (:instance map-lemma-1 (A (rest S)) (B S)) + (:instance map-lemma-4-alt + (A (rest S)) + (B S) + (v (first S))))))) + +;(defun old-map (k S) +; (ctoa (tuple-set->ordinal k S))) + +;(in-theory (disable tuple-set->ordinal)) + +;(defthm dickson-map-thm-alt +; (implies (and (tuple-setp k S) +; (consp S) +; (natp k) +; (<= 1 k) +; (not (exists-partial-tuple-<=-set +; k (rest S) (first S)))) +; (e0-ord-< (old-map k S) +; (old-map k (rest S))))) + diff --git a/books/workshops/2003/toma-borrione/sha-form-slides.pdf.gz b/books/workshops/2003/toma-borrione/sha-form-slides.pdf.gz Binary files differnew file mode 100644 index 0000000..a026250 --- /dev/null +++ b/books/workshops/2003/toma-borrione/sha-form-slides.pdf.gz diff --git a/books/workshops/2003/toma-borrione/sha-form-slides.ps.gz b/books/workshops/2003/toma-borrione/sha-form-slides.ps.gz Binary files differnew file mode 100644 index 0000000..1af5fc3 --- /dev/null +++ b/books/workshops/2003/toma-borrione/sha-form-slides.ps.gz diff --git a/books/workshops/2003/toma-borrione/sha-form.pdf.gz b/books/workshops/2003/toma-borrione/sha-form.pdf.gz Binary files differnew file mode 100644 index 0000000..79ab25a --- /dev/null +++ b/books/workshops/2003/toma-borrione/sha-form.pdf.gz diff --git a/books/workshops/2003/toma-borrione/sha-form.ps.gz b/books/workshops/2003/toma-borrione/sha-form.ps.gz Binary files differnew file mode 100644 index 0000000..596a20e --- /dev/null +++ b/books/workshops/2003/toma-borrione/sha-form.ps.gz diff --git a/books/workshops/2003/toma-borrione/support/bv-op-defthms.lisp b/books/workshops/2003/toma-borrione/support/bv-op-defthms.lisp new file mode 100644 index 0000000..c2a58d6 --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/bv-op-defthms.lisp @@ -0,0 +1,717 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of bit-vectors as lists +; Theorems of bit-vectors operations +;------------------------------------------ + + +(in-package "ACL2") + + +(include-book "bv-op-defuns") + +; theorems on bvp + +(defthm bvp-true-listp + (implies (bvp l) (true-listp l))) + +(defthm bvp-append + (implies (and (bvp l) (bvp l1)) + (bvp (append l l1)))) + +(defthm revappend-is-bvp + (implies (and (bvp i)(bvp j)) + (bvp (revappend i j)))) + +(defthm reverse-is-bvp + (implies (bvp i) (bvp (reverse i)))) + +(defthm bvp-make-list-0 + (bvp (make-list n :initial-element 0 ))) + +(defthm bvp-make-list-ac-0 + (bvp (make-list-ac n 0 nil ))) + +(defthm bvp-make-list-ac-1 + (bvp (make-list-ac n 1 nil ))) + +(defthm bvp-firstn +(implies (bvp l) (bvp (firstn n l)))) + +(defthm bvp-nthcdr +(implies (bvp l) (bvp (nthcdr n l)))) + +; theorems on wvp + +(defthm wvp-append +(implies (and (wvp m w) (wordp l w)) + (wvp (append m (list l)) w)) +:hints (("goal" :induct (wvp m w) ))) + + +;(SET-MATCH-FREE-ERROR NIL) + +(defthm nth-wvp + (implies (and (integerp j) (<= 0 j) (wvp m i)) + (bvp (nth j m )) )) + +(defthm len-nth-wvp + (implies (and (integerp j) (<= 0 j) + (wvp m i) (< j (len m) )) + (equal (len (nth j m )) i))) + + +(defthm len-car-wvp + (implies (and (wvp m i) (not (endp m))) + (equal (len ( car m )) i))) + +;(SET-MATCH-FREE-ERROR t) + +(defthm wordp-nth + (implies (and (integerp j) (<= 0 j) + (< j (len m) ) (wvp m i)) + (wordp (nth j m) i))) + + +;theorems on bit-vector <-> integer conversions + +(defthm integerp-bv-int-little-endian + (implies (bvp v) + (and (integerp (bv-int-little-endian v)) + (<= 0 (bv-int-little-endian v))))) + + +(defthm integerp-bv-int-big-endian + (implies (bvp v) + (and (integerp (bv-int-big-endian v)) + (<= 0 (bv-int-big-endian v))))) + + +(defthm int-bv-little-endian-is-bvp + (implies (and (integerp i)(<= 0 i)) + (bvp (int-bv-little-endian i)))) + + +(defthm len-bv-int-little-endian + (implies (and (bvp m)) + (<= (bv-int-little-endian m) + (- (expt 2 (len m)) 1)))) + + +(local +(defthm len-bv-int-little-endian-reverse + (implies (and (bvp m)) + (<= (bv-int-little-endian (reverse m)) + (- (expt 2 (len (reverse m))) 1))) + :hints (("Goal" :in-theory (disable len-reverse reverse ))))) + + +(defthm len-int-bv-little-endian-max + (implies (and (integerp i)(<= 0 i) ) + (< i (expt 2 (len (int-bv-little-endian i)))))) + + +(defthm len-int-bv-little-endian-min + (implies (and (integerp i)(< 1 i) ) + (<= (expt 2 ( - (len (int-bv-little-endian i)) 1)) i))) + + +(defthm len-int-bv-little-endian-2y-1 + (implies (and (integerp y)(< 0 y) ) + (equal (len (int-bv-little-endian (- (expt 2 y) 1) )) y ))) + + +(local +(defthm len-int-bv-little-endian-1-aux +(IMPLIES (AND (INTEGERP l) (< 0 l)) + (<= (LEN (INT-BV-little-endian l )) + (LEN (INT-BV-little-endian (+ 1 l))))))) + +(local +(defthm len-int-bv-little-endian-1 +(IMPLIES (AND (INTEGERP l) (<= 0 l)) + (<= (LEN (INT-BV-little-endian l )) + (LEN (INT-BV-little-endian (+ 1 l))))) +:hints +(( "goal" + :do-not-induct t + :use (len-int-bv-little-endian-1-aux) + :in-theory (disable int-bv-little-endian ))))) + + + +(local +(defthm len-int-bv-little-endian-k+1 +(IMPLIES (AND (INTEGERP K) (INTEGERP I) + (<= K I) (<= 1 K)) + (<= (LEN (INT-BV-little-endian (+ I (- K)))) + (LEN (INT-BV-little-endian (+ 1 I (- K)))))))) + + +(local +(defthm interm +(IMPLIES (AND (<= (LEN (INT-BV-little-endian (+ 1 I (- K)))) + (LEN (INT-BV-little-endian I))) + (<= (LEN (INT-BV-little-endian (+ I (- K)))) + (LEN (INT-BV-little-endian (+ 1 I (- K)))))) + (<= (LEN (INT-BV-little-endian (+ I (- K)))) + (LEN (INT-BV-little-endian I)))))) + + +(defthm len-int-bv-little-endian-k +(IMPLIES (AND (INTEGERP I) (INTEGERP k) + (<= k I) (<= 0 k)) + (<= (LEN (INT-BV-little-endian (- I k))) + (LEN (INT-BV-little-endian i)))) +:hints +(("goal" + :do-not '(generalize) + :induct (rec-by-sub1 k) + :in-theory (disable int-bv-little-endian )))) + + +(defthm len-int-bv-little-endian-i<=j + (implies (and (integerp i)(<= 0 i) (integerp j)(<= 0 j) (<= i j) ) + (<= (len (int-bv-little-endian i)) + (len (int-bv-little-endian j)) )) +:hints +(("goal" + :use (:instance len-int-bv-little-endian-k ( i j) (k (- j i))) + :in-theory (disable int-bv-little-endian )))) + + +(defthm len-int-bv-little-endian-i<=2y-1 + (implies (and (integerp i)(<= 0 i) (<= i (- (expt 2 y) 1)) + (integerp y)(< 0 y) ) + (<= (len (int-bv-little-endian i)) y )) +:hints +(("goal" + :use ((:instance len-int-bv-little-endian-i<=j (i i) (j (- (expt 2 y) 1))) + len-int-bv-little-endian-2y-1) + :do-not-induct t + :in-theory (disable int-bv-little-endian)))) + + +(defthm int-bv-big-endian-is-bvp + (implies (and (integerp i)(<= 0 i)) + (bvp (int-bv-big-endian i)))) + + +(defthm len-bv-int-big-endian + (implies (bvp m) + (<= (bv-int-big-endian m) (- (expt 2 (len m)) 1))) +:hints +(("goal'" + :do-not-induct t + :use (len-bv-int-little-endian-reverse ) + :in-theory (disable reverse )))) + + +(defthm len-int-bv-big-endian-max + (implies (and (integerp i)(<= 0 i) ) + (< i (expt 2 (len (int-bv-big-endian i)))))) + + +(defthm len-int-bv-big-endian-min + (implies (and (integerp i)(< 1 i) ) + (<= (expt 2 (- (len (int-bv-big-endian i)) 1)) i))) + + +(defthm len-int-bv-big-endian-2y-1 + (implies (and (integerp y)(< 0 y) ) + (equal (len (int-bv-big-endian (- (expt 2 y) 1) )) y ))) + + +(defthm len-int-bv-big-endian-i<=j + (implies (and (integerp i)(<= 0 i) (integerp j)(<= 0 j) (<= i j) ) + (<= (len (int-bv-big-endian i)) (len (int-bv-big-endian j)) )) +:hints +(("goal" + :in-theory (disable int-bv-little-endian )))) + + +(defthm len-int-bv-big-endian-i<=2y-1 + (implies (and (integerp i)(<= 0 i) (<= i (- (expt 2 y) 1)) + (integerp y)(< 0 y) ) + (<= (len (int-bv-big-endian i)) y )) +:hints +(("goal" + :do-not-induct t + :in-theory (disable int-bv-little-endian )))) + + +(defthm bv-int-int-bv-i=i-little-endian + (IMPLIES (AND (INTEGERP I) (<= 0 I)) + (EQUAL (BV-INT-LITTLE-ENDIAN (INT-BV-LITTLE-ENDIAN I)) i))) + + +(defthm bv-int-int-bv-i=i-big-endian + (IMPLIES (AND (INTEGERP I) (<= 0 I)) + (EQUAL (BV-INT-big-ENDIAN (INT-BV-big-ENDIAN I)) i))) + + +(local +(defthm bv-int-app-little-endian-base +(IMPLIES (AND (INTEGERP I) (<= 0 I)) + (EQUAL (BV-INT-LITTLE-ENDIAN (APPEND (INT-BV-LITTLE-ENDIAN I) + (list 0))) + (BV-INT-LITTLE-ENDIAN (INT-BV-LITTLE-ENDIAN I)))))) + + +(local +(defthm bv-int-app-little-endian +(IMPLIES (bvp m) + (EQUAL (BV-INT-LITTLE-ENDIAN (APPEND m (list 0))) + (BV-INT-LITTLE-ENDIAN m ))))) + + +(local +(defthm aux-append-m1-m2 +(IMPLIES (AND (TRUE-LISTP MLAC) + (TRUE-LISTP IBLEN)) + (EQUAL (BV-INT-LITTLE-ENDIAN (APPEND IBLEN MLAC '(0))) + (BV-INT-LITTLE-ENDIAN (APPEND IBLEN MLAC)))))) + + +(local +(defthm n+1-make-list +(implies (and (INTEGERP N) (<= 1 N)) + (equal (make-list n :initial-element k ) + (append (make-list (- n 1) :initial-element k ) (list k)))))) + + +(local +(defthm bv-int-app-int-bv-little-endian-simplif1 +(IMPLIES (AND (integerp i) (<= 0 i) (integerp n) (<= 0 n)) + (EQUAL (BV-INT-LITTLE-ENDIAN (APPEND (INT-BV-LITTLE-ENDIAN i) + (MAKE-LIST n :initial-element 0))) + (BV-INT-LITTLE-ENDIAN (INT-BV-LITTLE-ENDIAN i)))) +:hints (( "goal" :induct (rec-by-sub1 n))))) + + +(defthm bv-int-app-int-bv-little-endian + (IMPLIES (AND (integerp i) (<= 0 i) (integerp n) (<= 0 n)) + (EQUAL (BV-INT-little-ENDIAN (APPEND (INT-BV-little-ENDIAN i) + (MAKE-LIST n :initial-element 0))) + i))) + + +(defthm bv-int-app-int-bv-big-endian + (IMPLIES (AND (integerp i) (<= 0 i) (integerp n) (<= 0 n)) + (EQUAL (BV-INT-BIG-ENDIAN (APPEND (MAKE-LIST n :initial-element 0) + (INT-BV-BIG-ENDIAN i))) + i))) + +;theorems on bv-to-n + +(defthm bvp-bv-to-n + (implies (and (bvp v) (integerp n) (<= 0 n)) + (bvp (bv-to-n v n)))) + +(defthm len-bv-to-n + (implies (and (bvp v) (integerp n) (<= 0 n)) + (equal (len (bv-to-n v n)) n))) + +(defthm wordp-bv-to-n + (implies (and (bvp v) (integerp n) (<= 0 n)) + (wordp (bv-to-n v n) n)) +:hints +(("goal" + :use (bvp-bv-to-n len-bv-to-n) ))) + +;theorems on bv-and + +(defthm comutativity-of-bv-a + (equal (bv-a x y) (bv-a y x))) + + +(defthm bv-a-is-bvp + (bvp (bv-a x y))) + + +(defthm len-bv-a + (implies (and (bvp x) (bvp y) (EQUAL (LEN X) (len y))) + (and (equal (len (bv-a x y)) (len x) ) + (equal (len (bv-a x y)) (len y))))) + + +(defthm wordp-bv-a + (implies (and (bvp x) (bvp y)(EQUAL (LEN X) (len y) )) + (and (wordp (bv-a x y) (len y)) + (wordp (bv-a x y) (len x)))) +:hints (("goal" :use (len-bv-a bv-a-is-bvp)))) + + +(defthm wordp-binary-bv-and-word + (implies (and (wordp x w) (wordp y w) + (integerp w) (<= 0 w)) + (wordp (binary-bv-and x y) w))) + + +(defthm comutativity-of-bv-and + (equal (bv-and x y) (bv-and y x))) + + +(defthm bv-and-is-bvp + (bvp (bv-and x y))) + + +(defthm len-bv-and + (implies (and (bvp x) (bvp y)) + (equal (len (bv-and x y)) + (if (<= (len x) (len y)) + (len y) + (len x)))) +:hints (("goal" :in-theory (disable N+1-MAKE-LIST)))) + + +(defthm wordp-bv-and + (implies (and (bvp x) (bvp y)) + (wordp (bv-and x y) (if (<= (len x) (len y)) + (len y) + (len x)))) +:hints (("goal" :use (len-bv-and bv-and-is-bvp)))) + + +;theorems on bv-or + +(defthm comutativity-of-bv-o + (equal (bv-o x y) (bv-o y x))) + + +(defthm bv-o-is-bvp + (bvp (bv-o x y))) + + +(defthm len-bv-o + (implies (and (bvp x) (bvp y) (EQUAL (LEN X) (len y))) + (and (equal (len (bv-o x y)) (len x) ) + (equal (len (bv-o x y)) (len y))))) + + +(defthm wordp-bv-o + (implies (and (bvp x) (bvp y)(EQUAL (LEN X) (len y) )) + (and (wordp (bv-o x y) (len y)) + (wordp (bv-o x y) (len x)))) +:hints (("goal" :use (len-bv-o bv-o-is-bvp)))) + + +(defthm wordp-binary-bv-or-word + (implies (and (wordp x w) (wordp y w) + (integerp w) (<= 0 w)) + (wordp (binary-bv-or x y) w))) + + +(defthm comutativity-of-bv-or + (equal (bv-or x y) (bv-or y x))) + + +(defthm bv-or-is-bvp + (bvp (bv-or x y))) + + +(defthm len-bv-or + (implies (and (bvp x) (bvp y)) + (equal (len (bv-or x y)) + (if (<= (len x) (len y)) + (len y) + (len x)))) +:hints (("goal" :in-theory (disable N+1-MAKE-LIST)))) + + +(defthm wordp-bv-or + (implies (and (bvp x) (bvp y)) + (wordp (bv-or x y) (if (<= (len x) (len y)) + (len y) + (len x)))) +:hints (("goal" :use (len-bv-or bv-or-is-bvp)))) + + +;theorems on bv-xor + +(defthm comutativity-of-bv-xo + (equal (bv-xo x y) (bv-xo y x))) + + +(defthm bv-xo-is-bvp + (bvp (bv-xo x y))) + + +(defthm len-bv-xo + (implies (and (bvp x) (bvp y) (EQUAL (LEN X) (len y))) + (and (equal (len (bv-xo x y)) (len x) ) + (equal (len (bv-xo x y)) (len y))))) + + +(defthm wordp-bv-xo + (implies (and (bvp x) (bvp y)(EQUAL (LEN X) (len y) )) + (and (wordp (bv-xo x y) (len y)) + (wordp (bv-xo x y) (len x)))) +:hints (("goal" :use (len-bv-xo bv-xo-is-bvp)))) + + +(defthm wordp-binary-bv-xor-word + (implies (and (wordp x w) (wordp y w) + (integerp w) (<= 0 w)) + (wordp (binary-bv-xor x y) w))) + + +(defthm comutativity-of-bv-xor + (equal (bv-xor x y) (bv-xor y x))) + + +(defthm bv-xor-is-bvp + (bvp (bv-xor x y))) + + +(defthm len-bv-xor + (implies (and (bvp x) (bvp y)) + (equal (len (bv-xor x y)) + (if (<= (len x) (len y)) + (len y) + (len x)))) +:hints (("goal" :in-theory (disable N+1-MAKE-LIST )))) + + +(defthm wordp-bv-xor + (implies (and (bvp x) (bvp y)) + (wordp (bv-xor x y) (if (<= (len x) (len y)) + (len y) + (len x)))) +:hints (("goal" :use (len-bv-xor bv-xor-is-bvp)))) + + +;theorems on bv-not + +(defthm bv-not-is-bvp + (bvp (bv-not x))) + + +(defthm len-bv-not + (implies (bvp x) + (equal (len (bv-not x)) (len x)))) + + +(defthm wordp-bv-not + (implies (bvp x) + (wordp (bv-not x) (len x)))) + + +;theorems on plus + +(local +(defthm aux +(implies (and (integerp i)(integerp j) (integerp z) (<= 0 i) (<= 0 j) (< 0 z)) + (and (<= 0 (mod (+ i j) z)) (integerp (mod (+ i j) z)))))) + + +(local +(defthm aux1 +(implies (and (bvp x) (<= 0 (bv-int-big-endian x)) + (<= (bv-int-big-endian x) (expt 2 i)) + (bvp y) (<= 0 (bv-int-big-endian y)) + (<= (bv-int-big-endian y) (expt 2 i)) + (integerp i) (<= 0 i)) +(BVP (INT-BV-BIG-ENDIAN (MOD (+ (BV-INT-BIG-ENDIAN X) + (BV-INT-BIG-ENDIAN Y)) + (EXPT 2 I))))) +:hints +(("goal" + :in-theory (disable int-bv-big-endian bv-int-big-endian) + :use ((:instance integerp-BV-INT-BIG-ENDIAN (v x)) + (:instance integerp-BV-INT-BIG-ENDIAN (v y)) + (:instance int-bv-big-endian-is-bvp + (i (MOD (+ (BV-INT-BIG-ENDIAN X) (BV-INT-BIG-ENDIAN Y)) + (EXPT 2 I))))) )))) + + +(defthm bvp-binary-plus + (implies (and (bvp x) (<= 0 (bv-int-big-endian x)) + (<= (bv-int-big-endian x) (expt 2 i)) + (bvp y) (<= 0 (bv-int-big-endian y)) + (<= (bv-int-big-endian y) (expt 2 i)) + (integerp i) (<= 0 i)) + (bvp (binary-plus i x y))) +:hints ( +("goal" + :use (:instance bvp-bv-to-n + (v (INT-BV-BIG-ENDIAN (MOD (+ (BV-INT-BIG-ENDIAN X) + (BV-INT-BIG-ENDIAN Y)) (EXPT 2 I)))) (n i)) + :in-theory (disable int-bv-big-endian bv-int-big-endian)))) + + +(defthm len-binary-plus + (implies (and (bvp x) (<= 0 (bv-int-big-endian x)) + (<= (bv-int-big-endian x) (expt 2 i)) + (bvp y) (<= 0 (bv-int-big-endian y)) + (<= (bv-int-big-endian y) (expt 2 i)) + (integerp i) (<= 0 i)) + (equal (len (binary-plus i x y)) i)) +:hints +(("goal" + :in-theory (disable int-bv-big-endian bv-int-big-endian)))) + + +(defthm wordp-binary-plus + (implies (and (bvp x) (<= 0 (bv-int-big-endian x)) + (<= (bv-int-big-endian x) (expt 2 i)) + (bvp y) (<= 0 (bv-int-big-endian y)) + (<= (bv-int-big-endian y) (expt 2 i)) + (integerp i) (<= 0 i)) + (wordp (binary-plus i x y) i)) +:hints +(("goal" + :in-theory (disable binary-plus int-bv-big-endian bv-int-big-endian)))) + + +(defthm wordp-binary-plus-word + (implies (and (wordp x w) (wordp y w) + (integerp w) (<= 0 w)) + (wordp (binary-plus w x y) w)) +:hints +(("goal" + :use ((:instance len-bv-int-big-endian (m x)) + (:instance len-bv-int-big-endian (m y))) + :in-theory (disable binary-plus )))) + + +;theorems on shift functions + +(defthm bvp-<< + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (bvp (<< x n w)))) + + +(defthm len-<< + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (equal (len (<< x n w)) w ))) + + +(defthm wordp-<< + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (wordp (<< x n w) w)) +:hints (("goal" :use (bvp-<< len-<<)))) + + +(defthm bvp->> + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (bvp (>> x n w) ))) + + +(defthm len->> + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (equal (len (>> x n w)) w ))) + + +(defthm wordp->> + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (wordp (>> x n w) w)) +:hints (("goal" :use (bvp->> len->>)))) + +(defthm wordp-shr + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (wordp (shr n x w) w)) +:hints (("goal" :in-theory (disable >> wordp)))) + +(defthm bvp-rotr + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (bvp (rotr n x w) )) +:hints (("goal" +:in-theory (disable >> << binary-bv-or ) +))) + +(defthm len-rotr + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (equal (len (rotr n x w) ) w)) +:hints (("goal" +:in-theory (disable >> << binary-bv-or len wordp ) +))) + +(defthm wordp-rotr + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (wordp (rotr n x w) w)) +:hints (("goal" +:in-theory (disable rotr len ) +))) + +(defthm bvp-rotl + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (bvp (rotl n x w) )) +:hints (("goal" +:in-theory (disable >> << binary-bv-or ) +))) + +(defthm len-rotl + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (equal (len (rotl n x w) ) w)) +:hints (("goal" +:in-theory (disable >> << binary-bv-or len wordp ) +))) + +(defthm wordp-rotl + (implies (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) (wordp (rotl n x w) w)) +:hints (("goal" +:in-theory (disable rotl len ) +))) + + +(defthm rotl->rotr + (implies (and (wordp x w) + (integerp n) + (< 0 n)(integerp w) + (<= 0 w) + (<= n w)) + (equal (rotl n x w) (rotr (- w n) x w))) +) + + +(defthm rotr->rotl + (implies (and (wordp x w) + (integerp n) + (<= 0 n)(integerp w) + (<= 0 w) + (<= n w)) + (equal (rotr n x w) (rotl (- w n) x w)))) diff --git a/books/workshops/2003/toma-borrione/support/bv-op-defuns.lisp b/books/workshops/2003/toma-borrione/support/bv-op-defuns.lisp new file mode 100644 index 0000000..68a00ad --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/bv-op-defuns.lisp @@ -0,0 +1,335 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of bit-vectors as lists +; Definitions of bit-vectors operations +;------------------------------------------ + + +(in-package "ACL2") + + +(include-book "misc") + +; Added by Matt K. in v2-9 to eliminate stack overflows in GCL in, at least, +; the proofs of last64-padding-1-256=length and last128-padding-512=length. +(set-verify-guards-eagerness 2) + +;----def bit + +; The definition of bitp here was deleted April 2016 by Matt K. now that +; bitp is defined in ACL2. + + +;--- bit operations + +; or +(defun b-or (x y) + (if (and (bitp x) (bitp y)) + (if (or (equal x 1) (equal y 1)) + 1 + 0) + nil)) + +; and +(defun b-and (x y) + (if (and (bitp x) (bitp y)) + (if (and (equal x 1) (equal y 1)) + 1 + 0) + nil)) + +;not +(defun b-not (x) + (if (bitp x) + (if (equal x 0) + 1 + 0) + nil)) + +;xor +(defun b-xor (x y) + (if (and (bitp x) (bitp y)) + (if (or (and (equal x 1) (equal y 1)) + (and (equal x 0) (equal y 0))) + 0 + 1) + nil)) + +;----- def of a bit-vector + +(defun bvp (m) + (if (true-listp m) + (if (endp m) + t + (and (bitp (car m)) + (bvp (cdr m)))) + nil)) + +;------ word of len i + +(defun wordp (w i) + (and (bvp w) (integerp i) (<= 0 i) + (equal (len w) i))) + + +;------ vector of words each one with len i + +(defun wvp (m i) + (if (and (true-listp m) (integerp i) (<= 0 i)) + (if (endp m) + t + (and (wordp (car m) i) (wvp (cdr m) i))) + nil)) + + + + + +; transforms a bit-vector into the positive integer corresponding at the little-endian interpretation +; we treat only the unsigned case + +(defun bv-int-little-endian (v) + (if (bvp v) + (if (endp v) + 0 + (+ (car v) (* 2 ( bv-int-little-endian (cdr v))))) + nil)) + +; Added by Matt K. to balance the earlier call of set-verify-guards-eagerness, +; since guard verification fails for the function bv-int-big-endian just +; below. +(set-verify-guards-eagerness 1) + +; transforms v into the positive integer corresponding at the big-endian interpretation + +(defun bv-int-big-endian (v) + (bv-int-little-endian ( reverse v))) + +; transforms a positive integer into the bit-vector corresponding to the little-endian interpretation +; we treat only the unsigned case + +(defun int-bv-little-endian(i) + (if (and (integerp i) + (<= 0 i)) + (if (equal (floor i 2) 0) + (list (mod i 2)) + (cons (mod i 2) (int-bv-little-endian (floor i 2)))) + nil)) + + +; transforms i into the bit-vector corresponding at the big-endian interpretation of i + +(defun int-bv-big-endian (i) + (reverse (int-bv-little-endian i))) + +; transforms a bit-vector v into a bit-vector of len n, if n is bigger then v's length. if not, returns the last n bits of v (v is considered in big-endian representation) + +(defun bv-to-n (v n) + (if (and (bvp v) + (integerp n) + (<= 0 n)) + (if (>= n (len v)) + (append (make-list (- n (len v)) :initial-element 0) v) + (nthcdr (- (len v) n) v)) + nil)) + + +;and between two bit-vectors with the same length + +(defun bv-a (x y) + (if (and (bvp x) (bvp y) + (equal (len x) (len y))) + (if (endp x) nil + (cons (b-and (car x) (car y)) + (bv-a (cdr x) (cdr y)))) + nil)) + + + +;and between two bit-vectors with arbitrary length + +(defun binary-bv-and (x y) + (if (and (bvp x) (bvp y)) + (if (<= (len x) (len y)) + (bv-a (bv-to-n x (len y)) y) + (bv-a x (bv-to-n y (len x)))) + nil)) + + +(defun bv-and-macro (lst) + (if (consp lst) + (if (consp (cdr lst)) + (list 'binary-bv-and (car lst) + (bv-and-macro (cdr lst))) + (car lst)) + nil)) + +(defmacro bv-and (&rest args) + (bv-and-macro args)) + + + +;or between two bit-vectors with the same length + +(defun bv-o (x y) + (if (and (bvp x) (bvp y) + (equal (len x) (len y))) + (if (endp x) nil + (cons (b-or (car x) (car y)) + (bv-o (cdr x) (cdr y)))) + nil)) + +;or between two bit-vectors with arbitrary length + +(defun binary-bv-or (x y) + (if (and (bvp x) (bvp y)) + (if (<= (len x) (len y)) + (bv-o (bv-to-n x (len y)) y) + (bv-o x (bv-to-n y (len x)))) + nil)) + +(defun bv-or-macro (lst) + (if (consp lst) + (if (consp (cdr lst)) + (list 'binary-bv-or (car lst) + (bv-or-macro (cdr lst))) + (car lst)) + nil)) + +(defmacro bv-or (&rest args) + (bv-or-macro args)) + + + +;xor between two bit-vectors with the same length + +(defun bv-xo (x y) + (if (and (bvp x) (bvp y) + (equal (len x) (len y))) + (if (endp x) nil + (cons (b-xor (car x) (car y)) + (bv-xo (cdr x) (cdr y)))) + nil)) + + + +;xor between two bit-vectors with arbitrary length + +(defun binary-bv-xor (x y) + (if (and (bvp x) (bvp y)) + (if (<= (len x) (len y)) + (bv-xo (bv-to-n x (len y)) y) + (bv-xo x (bv-to-n y (len x)))) + nil)) + +(defun bv-xor-macro (lst) + (if (consp lst) + (if (consp (cdr lst)) + (list 'binary-bv-xor (car lst) + (bv-xor-macro (cdr lst))) + (car lst)) + nil)) + +(defmacro bv-xor (&rest args) + (bv-xor-macro args)) + + +; not of a bit-vector x + +(defun bv-not (x) + (if (bvp x) + (if (endp x) + nil + (cons (b-not (car x)) (bv-not (cdr x)))) + nil)) + + + +; addition modulo (2 pow i) of two bit-vectors x and y + +(defun binary-plus (i x y ) + (if (and (bvp x) (<= 0 (bv-int-big-endian x)) + (<= (bv-int-big-endian x) (expt 2 i)) + (bvp y) (<= 0 (bv-int-big-endian y)) + (<= (bv-int-big-endian y) (expt 2 i)) + (integerp i) (<= 0 i)) + (bv-to-n (int-bv-big-endian (mod (+ (bv-int-big-endian x) + (bv-int-big-endian y)) (expt 2 i))) i) + nil)) + + +(defun plus-macro (i lst ) + (if (and (consp lst) (integerp i) (<= 0 i)) + (if (consp (cdr lst)) + (list 'binary-plus i (car lst) + (plus-macro i (cdr lst) )) + (car lst)) + nil)) + +(defmacro plus (i &rest args ) + (plus-macro i args )) + +;auxiliary shift operations + +(defun << (x n w) + (if (and (wordp x w ) + (integerp n) + (<= 0 n) (integerp w) + (<= 0 w) + (<= n w)) + (cond ((zp n) x) + ((endp x ) nil) + (t (append (nthcdr n x) (make-list n :initial-element 0) ))) + nil)) + +;ACL2 !>(<< '(1 1 1 1) 2 4) +;(1 1 0 0) + + +(defun >> ( x n w) + (if (and (wordp x w) + (integerp n) + (<= 0 n)(integerp w) + (<= 0 w) + (<= n w)) + (cond ((zp n) x) + ((endp x ) nil) + (t (append (make-list n :initial-element 0) (firstn (- (len x) n) x) ) )) + nil)) + +;ACL2 !>(>> '(1 1 1 1) 2 4) +;(0 0 1 1) + +;right shift of x with n elements on w bits + +(defun shr (n x w) + (if (and (wordp x w) + (integerp n) + (<= 0 n)(integerp w) + (<= 0 w) + (<= n w)) + (>> x n w) nil)) + + +;rotate right (circular right shift) of x with n elements on w bits + +(defun rotr (n x w) + (if (and (wordp x w) + (integerp n) + (<= 0 n)(integerp w) + (<= 0 w) + (<= n w)) + (bv-or (>> x n w) (<< x (- w n) w)) nil)) + +;rotate left (circular left shift) of x with n elements on w bits + +(defun rotl (n x w) + (if (and (wordp x w) + (integerp n) + (<= 0 n)(integerp w) + (<= 0 w) + (<= n w)) + (bv-or (<< x n w) (>> x (- w n) w)) nil)) diff --git a/books/workshops/2003/toma-borrione/support/misc.lisp b/books/workshops/2003/toma-borrione/support/misc.lisp new file mode 100644 index 0000000..a73a52e --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/misc.lisp @@ -0,0 +1,142 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of SHAs +; Some definitions on lists needed for the modelization of SHA +;------------------------------------------ + + +(in-package "ACL2") + +(include-book "../../../../arithmetic/equalities") +(include-book "../../../../arithmetic/inequalities") +(include-book "../../../../arithmetic-2/floor-mod/floor-mod") +(include-book "../../../../data-structures/list-defuns") +(include-book "../../../../data-structures/list-defthms") + +; help for recursion in theorem demonstration +(defun rec-by-sub1 (k) +(if (and (integerp k) (<= 1 k)) (rec-by-sub1 (- k 1)) t)) + +(defun rec-by-subn (n l) + (if (and (integerp n) (< 0 n) (true-listp l) (not (endp l))) + (rec-by-subn n (nthcdr n l)) t)) + +;gives the list of elements of l from the i-th position to the j-th possition +(defun segment (i j l) + (if (and (integerp i) + (<= 0 i)(integerp j) + (<= 0 j) + (true-listp l)) + (firstn (- j i) (nthcdr i l)) + nil)) + +;ACL2 !>(segment 2 5 '( 0 1 2 3 4 5 6 7 8 9)) +;(2 3 4) + +;replace the nth element of l with x + +(defun repl ( n x l) + (if (and (integerp n) + (<= 0 n) + (true-listp l)) + (cond ((endp l) nil) + ((zp n) (cons x (cdr l) )) + (t (cons (car l) (repl (- n 1) x (cdr l) )))) + + nil)) + +;ACL2 !>(repl 2 10 '( 0 1 2 3 4 5 6 7 8 9)) +;(0 1 10 3 4 5 6 7 8 9) + + +;verifies if all elements of l are the same length + +(defun el-of-eq-len (l) + (if (true-listp l) + (if (or (endp l) (endp (cdr l))) t + (and (equal (len (car l)) (len (cadr l))) + (el-of-eq-len (cdr l)))) + nil)) + +;ACL2 !>( el-of-eq-len '((1 2) 0 )) +;NIL +;ACL2 !>( el-of-eq-len '((1 2) (0 3) )) +;T + +; theorems for make-list + +(DEFTHM BINARY-APPEND-make-list-ac + (implies (consp b) + (EQUAL (BINARY-APPEND (make-list-ac i k B) C) + (make-list-ac i k (BINARY-APPEND B C))))) +(defthm append-make-list +(IMPLIES (AND (INTEGERP I) (<= 0 I)) + (EQUAL + (make-list-ac I k (LIST K)) + (APPEND (make-list-ac I k NIL) (LIST K))))) + +(defthm inverse-make-list +(implies (and (INTEGERP N) (<= 0 N)) + (equal (cons k (make-list n :initial-element k )) + (append (make-list n :initial-element k ) (list k))))) + +(local +(defthm n+1-make-list +(implies (and (INTEGERP N) (<= 1 N)) + (equal (make-list n :initial-element k ) + (append (make-list (- n 1) :initial-element k ) (list k)))))) + +(defthm append-make-list-i-j +(IMPLIES (AND (INTEGERP i) (<= 0 i)(INTEGERP j) (<= 0 j)) + (EQUAL (APPEND (MAKE-LIST i :initial-element k) + (make-list j :initial-element k)) + (make-list (+ i j) :initial-element k )))) + +(defthm revappend-make-list +(implies (and (integerp n) (<= 0 n)) + (equal (REVAPPEND (MAKE-LIST n :initial-element k) nil) + (make-list n :initial-element k ))) +:hints (( "goal" :induct (rec-by-sub1 n)) +("Subgoal *1/1'" :use (:instance append-make-list-i-j (i (1- n)) (j 1))))) + +(defthm len-app-make +(IMPLIES + (AND (true-listP X) + (true-listP Y) + (<= (LEN Y) (LEN X))) + (equal (len (APPEND (MAKE-LIST-AC (+ (LEN X) (- (LEN Y))) 0 NIL) Y)) + (len x) ))) + + +;theorems for segment +(defthm segment-append + (implies (and (integerp k) (<= 0 k)(integerp j) (<= 0 j) (<= k j) + (true-listp l1) (true-listp l2) (<= (len l1) k) ) + (equal (segment k j (append l1 l2)) + (segment (- k (len l1)) (- j (len l1)) l2)))) + +(defthm segment-cons + (implies (and (integerp j) (<= 0 j) (true-listp l2)) + (equal (segment 1 j (cons l1 l2)) (segment 0 (- j 1) l2)))) + + +(defthm segment-0 + (implies (and (integerp j) (<= 0 j) (true-listp l)) + (equal (segment 0 j l) (firstn j l)))) + +;modified SIMPLIFY-MOD-+-MOD from floor-mod book + (DEFTHM SIMPLIFY-MOD-+-MOD1 + (IMPLIES (AND + (INTEGERP (/ Y Z)) + (FM-GUARD (W X) (Y Z))) + (AND (EQUAL (MOD (+ W (MOD X Y)) Z) + (MOD (+ W X) Z)) + (EQUAL (MOD (+ (MOD X Y) W) Z) + (MOD (+ W X) Z)) + (EQUAL (MOD (+ W (- (MOD X Y))) Z) + (MOD (+ W (- X)) Z)) + (EQUAL (MOD (+ (MOD X Y) (- W)) Z) + (MOD (+ X (- W)) Z))))) diff --git a/books/workshops/2003/toma-borrione/support/padding-1-256.lisp b/books/workshops/2003/toma-borrione/support/padding-1-256.lisp new file mode 100644 index 0000000..39a069d --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/padding-1-256.lisp @@ -0,0 +1,239 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of SHAs +; Padding function for SHA-1 and SHA-256 +;------------------------------------------ + +;I strongly recommend after charging the book to do :comp t in order to accelerate the computation + +(IN-PACKAGE "ACL2") + +(include-book "bv-op-defthms") + +;---padding +;for sha-1 and sha-256 + +;Let M be a message of length len bits. The purpose of padding is to extend M to a multiple of 512 bits. To obtain the padded message, append the bit 1 to the end of message M, followed by k zero bits, where k is the smallest, non-negative solution to the equation (len+1+k) mod 512 = 448. Then append the 64-bit binary representation of number len. + +;For example, the (8-bit ASCII) message ``abc'' has the length 8*3=24, so the message is padded with one bit, then 448-(24+1)=423 zero bits, and then the message length, to become the 512-bit padded message: + +;ACL2 !>(padding-1-256 ' (0 1 1 0 0 0 0 1 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 )) +;(0 1 1 0 0 0 0 1 0 1 1 0 +; 0 0 1 0 0 1 1 0 0 0 1 1 1 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) + +(defun padding-1-256 (m) + (if (and (bvp m) + (< (len m) (expt 2 64))) + (if (<= (mod (1+ (len m)) 512) 448) + (append m (list 1) + (make-list (- 448 (mod (1+ (len m)) 512)):initial-element 0 ) + (bv-to-n (int-bv-big-endian (len m)) 64)) + (append m (list 1) + (make-list (- 960 (mod (1+ (len m)) 512)):initial-element 0 ) + (bv-to-n (int-bv-big-endian (len m)) 64))) + nil)) + + +(defthm bvp-padding-1-256 + (bvp (padding-1-256 m))) + + +(local +(defthm 2n<i + (implies (and (integerp n) (< 0 n) (integerp i) + (< n i) (integerp (* i (/ n))) ) + (<= 2 (* i (/ n) ))))) + +(local +(defthm n<=i + (implies (and (integerp n) (< 0 n) (integerp i) + (equal (mod i n) 0) (< 0 i) ) + (<= n i) ))) + + +(defthm len-padding-1-256 + (implies (and (bvp m) + (< (len m) (expt 2 64))) + (<= 512 (len (padding-1-256 m)))) +:hints +(("Goal" + :in-theory (disable mod MOD-ZERO ASSOCIATIVITY-OF-+ )) +("subgoal 2" + :use (:instance simplify-mod-+-mod1 (w (+ 1025 (len m))) + (x (+ 1 (len m))) (y 512) (z 512) )) +("subgoal 1" + :use (:instance simplify-mod-+-mod1 (w (+ 513 (len m))) + (x (+ 1 (len m))) (y 512) (z 512) )))) + + + +(defthm len-padding-1-256-mod-512=0 + (implies (bvp m) + (equal (mod (len (padding-1-256 m)) 512) 0)) +:hints +(("Goal" + :in-theory (disable MOD-ZERO int-bv-big-endian )) +("subgoal 2" + :use (:instance simplify-mod-+-mod1 (w (+ 1025 (len m))) + (x (+ 1 (len m))) (y 512) (z 512) )) +("subgoal 1" + :use (:instance simplify-mod-+-mod1 (w (+ 513 (len m))) + (x (+ 1 (len m))) (y 512) (z 512) )))) + + + +(local +(defthm last-256-aux + (implies (and (BVP M) + (< (LEN M) 18446744073709551616) + (< 448 (MOD (+ 1 (LEN M)) 512)) + (<= (nfix (+ 1 (LEN M) 960 (- (MOD (+ 1 (LEN M)) 512)))) (LEN M))) + (<= 961 (MOD (+ 1 (LEN M)) 512))))) + + + +(defthm last64-padding-1-256=length + (implies (and (bvp m) (< (len m) (expt 2 64))) + (equal (bv-int-big-endian + (nthcdr (- (len (padding-1-256 m)) 64) + (padding-1-256 m))) + (len m))) +:hints +(("Goal" + :in-theory (disable bv-int-big-endian int-bv-big-endian )) +("subgoal 2.2" :use last-256-aux))) + + + +(defthm end-message-padding-1-256 + (implies (and (bvp m) (< (len m) (expt 2 64))) + (equal (nth (len m) (padding-1-256 m)) 1)) +:hints +(("Goal" + :in-theory (disable bv-int-big-endian int-bv-big-endian )))) + + + +(defthm first-padding-1-256=message + (implies (and (bvp m) (< (len m) (expt 2 64))) + (equal (firstn ( len m) (padding-1-256 m)) m)) +:hints +(("Goal" + :in-theory (disable bv-int-big-endian int-bv-big-endian nthcdr )))) + + + +(defthm 0-fill-padding-1-256 + (implies (and (bvp m) (< (len m) (expt 2 64))) + (equal (segment (1+ (len m)) + (- (len (padding-1-256 m)) 64) + (padding-1-256 m)) + (make-list (- (len (padding-1-256 m)) (+ 65 (len m))) + :initial-element 0)))) + + +; For message "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq", with length 448 + +;ACL2 !>(padding-1-256 '(0 1 1 0 0 0 0 1 +; 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 0 1 1 0 +; 0 1 0 0 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 +; 0 1 1 0 0 1 0 0 0 1 1 0 0 1 0 1 0 1 1 0 +; 0 0 1 1 0 1 1 0 0 1 0 0 0 1 1 0 0 1 0 1 +; 0 1 1 0 0 1 1 0 0 1 1 0 0 1 0 0 0 1 1 0 +; 0 1 0 1 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 1 +; 0 1 1 0 0 1 0 1 0 1 1 0 0 1 1 0 0 1 1 0 +; 0 1 1 1 0 1 1 0 1 0 0 0 0 1 1 0 0 1 1 0 +; 0 1 1 0 0 1 1 1 0 1 1 0 1 0 0 0 0 1 1 0 +; 1 0 0 1 0 1 1 0 0 1 1 1 0 1 1 0 1 0 0 0 +; 0 1 1 0 1 0 0 1 0 1 1 0 1 0 1 0 0 1 1 0 +; 1 0 0 0 0 1 1 0 1 0 0 1 0 1 1 0 1 0 1 0 +; 0 1 1 0 1 0 1 1 0 1 1 0 1 0 0 1 0 1 1 0 +; 1 0 1 0 0 1 1 0 1 0 1 1 0 1 1 0 1 1 0 0 +; 0 1 1 0 1 0 1 0 0 1 1 0 1 0 1 1 0 1 1 0 +; 1 1 0 0 0 1 1 0 1 1 0 1 0 1 1 0 1 0 1 1 +; 0 1 1 0 1 1 0 0 0 1 1 0 1 1 0 1 0 1 1 0 +; 1 1 1 0 0 1 1 0 1 1 0 0 0 1 1 0 1 1 0 1 +; 0 1 1 0 1 1 1 0 0 1 1 0 1 1 1 1 0 1 1 0 +; 1 1 0 1 0 1 1 0 1 1 1 0 0 1 1 0 1 1 1 1 +; 0 1 1 1 0 0 0 0 0 1 1 0 1 1 1 0 0 1 1 0 +; 1 1 1 1 0 1 1 1 0 0 0 0 0 1 1 1 0 0 0 1)) +;Padding has 1024 bits +; (0 1 1 0 +; 0 0 0 1 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 +; 0 1 1 0 0 1 0 0 0 1 1 0 0 0 1 0 0 1 1 0 +; 0 0 1 1 0 1 1 0 0 1 0 0 0 1 1 0 0 1 0 1 +; 0 1 1 0 0 0 1 1 0 1 1 0 0 1 0 0 0 1 1 0 +; 0 1 0 1 0 1 1 0 0 1 1 0 0 1 1 0 0 1 0 0 +; 0 1 1 0 0 1 0 1 0 1 1 0 0 1 1 0 0 1 1 0 +; 0 1 1 1 0 1 1 0 0 1 0 1 0 1 1 0 0 1 1 0 +; 0 1 1 0 0 1 1 1 0 1 1 0 1 0 0 0 0 1 1 0 +; 0 1 1 0 0 1 1 0 0 1 1 1 0 1 1 0 1 0 0 0 +; 0 1 1 0 1 0 0 1 0 1 1 0 0 1 1 1 0 1 1 0 +; 1 0 0 0 0 1 1 0 1 0 0 1 0 1 1 0 1 0 1 0 +; 0 1 1 0 1 0 0 0 0 1 1 0 1 0 0 1 0 1 1 0 +; 1 0 1 0 0 1 1 0 1 0 1 1 0 1 1 0 1 0 0 1 +; 0 1 1 0 1 0 1 0 0 1 1 0 1 0 1 1 0 1 1 0 +; 1 1 0 0 0 1 1 0 1 0 1 0 0 1 1 0 1 0 1 1 +; 0 1 1 0 1 1 0 0 0 1 1 0 1 1 0 1 0 1 1 0 +; 1 0 1 1 0 1 1 0 1 1 0 0 0 1 1 0 1 1 0 1 +; 0 1 1 0 1 1 1 0 0 1 1 0 1 1 0 0 0 1 1 0 +; 1 1 0 1 0 1 1 0 1 1 1 0 0 1 1 0 1 1 1 1 +; 0 1 1 0 1 1 0 1 0 1 1 0 1 1 1 0 0 1 1 0 +; 1 1 1 1 0 1 1 1 0 0 0 0 0 1 1 0 1 1 1 0 +; 0 1 1 0 1 1 1 1 0 1 1 1 0 0 0 0 0 1 1 1 +; 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0)
\ No newline at end of file diff --git a/books/workshops/2003/toma-borrione/support/padding-384-512.lisp b/books/workshops/2003/toma-borrione/support/padding-384-512.lisp new file mode 100644 index 0000000..a1e0d0c --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/padding-384-512.lisp @@ -0,0 +1,189 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of SHAs +; Padding function for SHA-384 and SHA-512 +;------------------------------------------ + +;I strongly recommend after charging the book to do :comp t in order to accelerate the computation + +(IN-PACKAGE "ACL2") + +(include-book "bv-op-defthms") + +;---padding +;for sha-512 and sha-384 +;Let M be a message of length len bits. The purpose of padding is to extend M to a multiple of 1024 bits. To obtain the padded message, append the bit 1 to the end of message M, followed by k zero bits, where k is the smallest, non-negative solution to the equation (len+1+k) mod 1024 = 896. Then append the 128-bit binary representation of number len. + +;For example, the (8-bit ASCII) message ``abc'' has the length 8*3=24, so the message is padded with one bit, then 896-(24+1)=871 zero bits, and then the message length, to become the 1024-bit padded message: + +;ACL2 !>(padding-512 ' (0 1 1 0 0 0 0 1 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 )) +;(0 1 1 0 +; 0 0 0 1 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 +; 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +; 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) + +(local +(defthm 2n<i + (implies (and (integerp n) (< 0 n) (integerp i) + (< n i) (integerp (* i (/ n))) ) + (<= 2 (* i (/ n) ))))) + +(local +(defthm n<=i + (implies (and (integerp n) (< 0 n) (integerp i) + (equal (mod i n) 0) (< 0 i) ) + (<= n i) ))) + + + +(defun padding-512 (m) + (if (and (bvp m) + (< (len m) (expt 2 128))) + (if (<= (mod (1+ (len m)) 1024) 896) + (append m (list 1) + (make-list (- 896 (mod (1+ (len m)) 1024)) + :initial-element 0) + (bv-to-n (int-bv-big-endian (len m)) 128)) + (append m (list 1) + (make-list (- 1920 (mod (1+ (len m)) 1024)) + :initial-element 0 ) + (bv-to-n (int-bv-big-endian (len m)) 128))) + nil)) + + +(defthm bvp-padding-512 + (bvp (padding-512 m))) + + +(defthm len-padding-512 + (implies (and (bvp m) + (< (len m) (expt 2 128))) + (<= 1024 (len (padding-512 m)))) +:hints +(("Goal" + :in-theory (disable mod MOD-ZERO ASSOCIATIVITY-OF-+ )) +("subgoal 2" + :use (:instance simplify-mod-+-mod1 (w (+ 1921 (len m))) + (x (+ 1 (len m))) (y 1024) (z 1024) )) +("subgoal 1" + :use (:instance simplify-mod-+-mod1 (w (+ 897 (len m))) + (x (+ 1 (len m))) (y 1024) (z 1024) )))) + + + +(defthm len-padding-512-mod-1024=0 + (implies (bvp m) + (equal (mod (len (padding-512 m)) 1024) 0)) +:hints +(("Goal" + :in-theory (disable MOD-ZERO int-bv-big-endian )) +("subgoal 2" + :use (:instance simplify-mod-+-mod1 (w (+ 2049 (len m))) + (x (+ 1 (len m))) (y 1024) (z 1024) )) +("subgoal 1" + :use (:instance simplify-mod-+-mod1 (w (+ 1025 (len m))) + (x (+ 1 (len m))) (y 1024) (z 1024) )))) + + +(local +(defthm last-512-aux + (implies (and (BVP M) + (< (LEN M) 340282366920938463463374607431768211456) + (< 896 (MOD (+ 1 (LEN M)) 1024)) + (<= (NFIX (+ 1 (LEN M) + 1920 (- (MOD (+ 1 (LEN M)) 1024)))) + (LEN M))) + (<= 1921 (MOD (+ 1 (LEN M)) 1024) )))) + + + +(defthm last128-padding-512=length + (implies (and (bvp m) (< (len m) (expt 2 128))) + (equal (bv-int-big-endian + (nthcdr (- (len (padding-512 m)) 128) + (padding-512 m))) + (len m))) +:hints +(("Goal" + :in-theory (disable bv-int-big-endian int-bv-big-endian )) +("subgoal 2.2" :use last-512-aux))) + + + +(defthm end-message-padding-512 + (implies (and (bvp m) (< (len m) (expt 2 128))) + (equal (nth (len m) (padding-512 m)) 1)) +:hints +(("Goal" + :in-theory (disable bv-int-big-endian int-bv-big-endian )))) + + + +(defthm first-padding-512=message + (implies (and (bvp m) (< (len m) (expt 2 128))) + (equal (firstn ( len m) (padding-512 m)) m)) +:hints +(("Goal" + :in-theory (disable bv-int-big-endian int-bv-big-endian nthcdr )))) + + + +(defthm 0-fill-padding-512 + (implies (and (bvp m) (< (len m) (expt 2 128))) + (equal (segment (1+ (len m)) + (- (len (padding-512 m)) 128) + (padding-512 m)) + (make-list (- (len (padding-512 m)) (+ 129 (len m))) + :initial-element 0)))) + diff --git a/books/workshops/2003/toma-borrione/support/parsing.lisp b/books/workshops/2003/toma-borrione/support/parsing.lisp new file mode 100644 index 0000000..c6a14e6 --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/parsing.lisp @@ -0,0 +1,164 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of SHAs +; General parsing and its application to SHAs +;------------------------------------------ + + + +(IN-PACKAGE "ACL2") + +(include-book "padding-1-256") +(include-book "padding-384-512") + +;---parsing + +; parses the message m into blocks of n elements + + +(local +(defthm 2n<i + (implies (and (integerp n) (< 0 n) (integerp i) + (< n i) (integerp (* i (/ n))) ) + (<= 2 (* i (/ n) ))))) + + +(local +(defthm n<=i + (implies (and (integerp n) (< 0 n) (integerp i) + (equal (mod i n) 0) (< 0 i) ) + (<= n i) ))) + + +(defun parsing (m n) + (if (and (integerp n) + (<= 0 n) + (true-listp m)) + (cond ((endp m) nil) + ((zp n) nil) + (t (cons (firstn n m) (parsing (nthcdr n m) n)))) + nil)) + +;ACL2 !>(parsing '(0 1 2 3 4 5 6 7) 3) +;((0 1 2) (3 4 5) (6 7)) + + +(defthm true-listp-car-parsing + (implies (and (true-listp l) (integerp n) (<= 0 n)) + (true-listp (car (parsing l n)) ))) + + + +(defthm bvp-car-parsing + (implies (and (bvp l) (integerp n) (<= 0 n)) + (bvp (car (parsing l n)) ))) + + +(local +(defthm len-consp-nthcdr + (implies (and (integerp n) (< 0 n) (true-listp l)(consp (nthcdr n l))) + (< n (len l))))) + + +(defthm car-parsing + (implies (and (true-listp l) (integerp n) (<= 0 n)) + (equal (car (parsing l n)) (firstn n l)))) + + +(defthm parsing-right-len + (implies (and (true-listp l) (integerp n) (< 0 n) + (equal (mod (len l) n) 0)) + (el-of-eq-len (parsing l n))) +:hints +(("goal" + :do-not '(generalize) + :induct (rec-by-subn n l )) +("subgoal *1/1.4''" + :use (len-consp-nthcdr (:instance 2n<i (n n) (i (len l))))))) + + +(defthm len-car-parsing + (implies (and (true-listp l) (integerp n) (< 0 n) + (<= n (len l))) + (equal (len (car (parsing l n))) n))) + + +(defthm wordp-car-parsing + (implies (and (bvp l) (integerp n) (< 0 n) (<= n (len l) )) + (wordp (car (parsing l n) ) n))) + + +(defthm wvp-parsing + (implies (and (bvp m) (equal (mod (len m) n) 0) (integerp n) (< 0 n)) + (wvp (parsing m n) n)) +:hints (("subgoal *1/5" :use (:instance n<=i (i (len m) ))))) + + +(defthm len-parsing + (implies (and (true-listp m) (equal (mod (len m) n) 0) + (integerp n) (< 0 n)) + (equal (len (parsing m n)) (/ (len m) n))) +:hints (("subgoal *1/5" :use (:instance n<=i (i (len m) ))))) + + +(defthm parsing-512-is-good +(implies (and (bvp m) + (< (len m) (expt 2 64))) + (and (el-of-eq-len (parsing (padding-1-256 m) 512)) + (equal (len (car (parsing (padding-1-256 m) 512))) 512))) +:hints +(("goal" + :use ((:instance parsing-right-len (l (padding-1-256 m)) (n 512) ) + len-padding-1-256-mod-512=0) + :in-theory (disable el-of-eq-len parsing padding-1-256 )) +("subgoal 1" :use len-padding-1-256 ))) + + +(defthm wvp-parsing-512 + (implies (and (bvp m) + (< (len m) (expt 2 64))) + (wvp (parsing (padding-1-256 m) 512) 512)) +:hints +(("goal" + :use ( len-padding-1-256-mod-512=0) + :in-theory (disable mod parsing padding-1-256 )))) + + +(defthm len-parsing-512 + (implies (and (bvp m) + (< (len m) (expt 2 64))) + (<= 1 (len (parsing (padding-1-256 m) 512)))) +:hints +(("goal" + :use ( len-padding-1-256-mod-512=0 + (:instance len-parsing (m (padding-1-256 m)) (n 512)) + len-padding-1-256 ) + :in-theory (disable parsing padding-1-256 len )))) + + + +(defthm parsing-1024-is-good +(implies (and (bvp m) + (< (len m) (expt 2 128))) + (and (el-of-eq-len (parsing (padding-512 m) 1024)) + (equal (len (car (parsing (padding-512 m) 1024))) 1024 ))) +:hints +(("goal" + :use ((:instance parsing-right-len (l (padding-512 m)) (n 1024) ) + len-padding-512-mod-1024=0) + :in-theory (disable el-of-eq-len parsing padding-512 )) +("subgoal 1" :use len-padding-512 ))) + + +(defthm wvp-parsing-1024 + (implies (and (bvp m) + (< (len m) (expt 2 128))) + (wvp (parsing (padding-512 m) 1024) 1024)) +:hints +(("goal" + :use ( len-padding-512-mod-1024=0) + :in-theory (disable mod parsing padding-512 )))) + diff --git a/books/workshops/2003/toma-borrione/support/sha-1.lisp b/books/workshops/2003/toma-borrione/support/sha-1.lisp new file mode 100644 index 0000000..0960246 --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/sha-1.lisp @@ -0,0 +1,430 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of SHA-1 +; Message digest functions and theorems +;------------------------------------------ + +;I strongly recommend after charging the book to do :comp t in order to accelerate the computation + +; For a message M with length less than (expt 2 64) sha-1 returns a message digest of 160 bits (five words each of 32 bits). + +;For message "abc" +;ACL2 !>(sha-1 '(0 1 1 0 0 0 0 1 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 )) + +;((1 0 1 0 1 0 0 1 1 0 0 1 +; 1 0 0 1 0 0 1 1 1 1 1 0 0 0 1 1 0 1 1 0) +; (0 1 0 0 0 1 1 1 0 0 0 0 +; 0 1 1 0 1 0 0 0 0 0 0 1 0 1 1 0 1 0 1 0) +; (1 0 1 1 1 0 1 0 0 0 1 1 +; 1 1 1 0 0 0 1 0 0 1 0 1 0 1 1 1 0 0 0 1) +; (0 1 1 1 1 0 0 0 0 1 0 1 +; 0 0 0 0 1 1 0 0 0 0 1 0 0 1 1 0 1 1 0 0) +; (1 0 0 1 1 1 0 0 1 1 0 1 0 +; 0 0 0 1 1 0 1 1 0 0 0 1 0 0 1 1 1 0 1)) +;For the message "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" (448 bits) +;ACL2 !>(sha-1 '(0 1 1 0 0 0 0 1 +; 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 0 1 1 0 +; 0 1 0 0 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 +; 0 1 1 0 0 1 0 0 0 1 1 0 0 1 0 1 0 1 1 0 +; 0 0 1 1 0 1 1 0 0 1 0 0 0 1 1 0 0 1 0 1 +; 0 1 1 0 0 1 1 0 0 1 1 0 0 1 0 0 0 1 1 0 +; 0 1 0 1 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 1 +; 0 1 1 0 0 1 0 1 0 1 1 0 0 1 1 0 0 1 1 0 +; 0 1 1 1 0 1 1 0 1 0 0 0 0 1 1 0 0 1 1 0 +; 0 1 1 0 0 1 1 1 0 1 1 0 1 0 0 0 0 1 1 0 +; 1 0 0 1 0 1 1 0 0 1 1 1 0 1 1 0 1 0 0 0 +; 0 1 1 0 1 0 0 1 0 1 1 0 1 0 1 0 0 1 1 0 +; 1 0 0 0 0 1 1 0 1 0 0 1 0 1 1 0 1 0 1 0 +; 0 1 1 0 1 0 1 1 0 1 1 0 1 0 0 1 0 1 1 0 +; 1 0 1 0 0 1 1 0 1 0 1 1 0 1 1 0 1 1 0 0 +; 0 1 1 0 1 0 1 0 0 1 1 0 1 0 1 1 0 1 1 0 +; 1 1 0 0 0 1 1 0 1 1 0 1 0 1 1 0 1 0 1 1 +; 0 1 1 0 1 1 0 0 0 1 1 0 1 1 0 1 0 1 1 0 +; 1 1 1 0 0 1 1 0 1 1 0 0 0 1 1 0 1 1 0 1 +; 0 1 1 0 1 1 1 0 0 1 1 0 1 1 1 1 0 1 1 0 +; 1 1 0 1 0 1 1 0 1 1 1 0 0 1 1 0 1 1 1 1 +; 0 1 1 1 0 0 0 0 0 1 1 0 1 1 1 0 0 1 1 0 +; 1 1 1 1 0 1 1 1 0 0 0 0 0 1 1 1 0 0 0 1)) + +; The result: + +;((1 0 0 0 0 1 0 0 1 0 0 1 +; 1 0 0 0 0 0 1 1 1 1 1 0 0 1 0 0 0 1 0 0) +; (0 0 0 1 1 1 0 0 0 0 1 1 +; 1 0 1 1 1 1 0 1 0 0 1 0 0 1 1 0 1 1 1 0) +; (1 0 1 1 1 0 1 0 1 0 1 0 +; 1 1 1 0 0 1 0 0 1 0 1 0 1 0 1 0 0 0 0 1) +; (1 1 1 1 1 0 0 1 0 1 0 1 +; 0 0 0 1 0 0 1 0 1 0 0 1 1 1 1 0 0 1 0 1) +; (1 1 1 0 0 1 0 1 0 1 0 0 0 +; 1 1 0 0 1 1 1 0 0 0 0 1 1 1 1 0 0 0 1)) + +(IN-PACKAGE "ACL2") + +(include-book "parsing") +(include-book "sha-functions") + + +; constants of sha-1 + + +(defun K-1 (i) + (if (and (integerp i) (<= 0 i)) + (cond ((and (<= 0 i) (<= i 19)) + '(0 1 0 1 1 0 1 0 1 0 0 0 + 0 0 1 0 0 1 1 1 1 0 0 1 1 0 0 1 1 0 0 1)) + ((and (<= 20 i) (<= i 39)) + '(0 1 1 0 1 1 1 0 1 1 0 1 + 1 0 0 1 1 1 1 0 1 0 1 1 1 0 1 0 0 0 0 1)) + ((and (<= 40 i) (<= i 59)) + '(1 0 0 0 1 1 1 1 0 0 0 1 + 1 0 1 1 1 0 1 1 1 1 0 0 1 1 0 1 1 1 0 0)) + ((and (<= 60 i) (<= i 79)) + '(1 1 0 0 1 0 1 0 0 1 1 0 + 0 0 1 0 1 1 0 0 0 0 0 1 1 1 0 1 0 1 1 0))) + nil)) + + +(defthm wordp-K-1 +(implies (and (integerp i) (<= 0 i) (<= i 79)) + (wordp (k-1 i) 32))) + + +; initial hash values for sha-1 + +(defun H-1 () + '((0 1 1 0 0 1 1 1 0 1 0 0 + 0 1 0 1 0 0 1 0 0 0 1 1 0 0 0 0 0 0 0 1) + (1 1 1 0 1 1 1 1 1 1 0 0 + 1 1 0 1 1 0 1 0 1 0 1 1 1 0 0 0 1 0 0 1) + (1 0 0 1 1 0 0 0 1 0 1 1 + 1 0 1 0 1 1 0 1 1 1 0 0 1 1 1 1 1 1 1 0) + (0 0 0 1 0 0 0 0 0 0 1 1 + 0 0 1 0 0 1 0 1 0 1 0 0 0 1 1 1 0 1 1 0) + (1 1 0 0 0 0 1 1 1 1 0 1 + 0 0 1 0 1 1 1 0 0 0 0 1 1 1 1 1 0 0 0 0))) + +(defthm wordp-h-1 + (and (wvp (h-1) 32) (equal (len (h-1)) 5 ))) + + +;constant of sha-1 + +(defun mask () + '(0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1)) + +(defthm wordp-mask + (wordp (mask ) 32)) + + +;---sha-1 + +;--- first method + + +(defun temp (j working-variables m-i-ext) + (if (and (wvp working-variables 32) (equal (len working-variables) 5) + (integerp j) (<= 0 j) + (wvp m-i-ext 32) (equal (len m-i-ext) 80)) + (plus 32 (rotl 5 (nth 0 working-variables) 32) + (Ft j (nth 1 working-variables) + (nth 2 working-variables) + (nth 3 working-variables)) + (nth 4 working-variables) + ( K-1 j) + (nth j m-i-ext)) + nil)) + + +(defthm wordp-temp + (implies (and (wvp l 32) (equal (len l) 5) + (integerp j) (<= 0 j) (< j 80) + (wvp m 32) (equal (len m) 80)) + (wordp (temp j l m ) 32)) +:hints +(("goal" + :in-theory (disable k-1 ft rotl binary-plus rotl->rotr nth )))) + + +;prepare the schedule message + +(defun prepare-ac ( j m-i) +(declare (xargs :measure (acl2-count (- 80 j)))) + (if (and (integerp j) (<= 16 j) + (wvp m-i 32)) + (cond ((<= 80 j) m-i) + ((<= j 79) + (prepare-ac (1+ j) + (append m-i + (list (rotl 1 (bv-xor (nth (- j 3) m-i) + (nth (- j 8) m-i) + (nth (- j 14) m-i) + (nth (- j 16) m-i)) 32)))))) + nil)) + +(defun prepare (m-i) + (if (wordp m-i 512) + (prepare-ac 16 (parsing m-i 32)) + nil)) + +(defthm wvp-prepare-ac + (implies (and (integerp j) (<= 16 j) (wvp m 32)) + (wvp (prepare-ac j m) 32)) +:hints +(("goal" + :in-theory (disable rotl binary-bv-xor rotl->rotr)))) + + +(defthm len-prepare-ac + (implies (and (wvp m 32) (integerp j) (<= 16 j) (<= j (len m) )) + (equal (len (prepare-ac j m)) + (if (<= j 80) + (+ (- 80 j) (len m)) + (len m)))) +:hints +(("goal" + :in-theory (disable rotl binary-bv-xor rotl->rotr)))) + + +(defthm wvp-prepare + (implies (wordp m 512) + (wvp (prepare m) 32)) +:hints (("goal" :in-theory (disable prepare-ac )))) + + +(defthm len-prepare + (implies (wordp m 512) + (equal (len (prepare m)) 80)) +:hints (("goal" :in-theory (disable prepare-ac)))) + + +; one step of digest +(defun digest-one-block-ac ( j working-variables m-i-ext) +(declare (xargs :measure (acl2-count (- 80 j)))) + (if (and (wvp working-variables 32) (equal (len working-variables ) 5) + (integerp j) (<= 0 j) + (wvp m-i-ext 32) (equal (len m-i-ext) 80)) + (if (<= 80 j) + working-variables + (digest-one-block-ac (+ 1 j) + (list (temp j working-variables m-i-ext) + (nth 0 working-variables) + (rotl 30 (nth 1 working-variables) 32) + (nth 2 working-variables) + (nth 3 working-variables)) + m-i-ext) ) + nil)) + + +(defun digest-one-block (hash-values m-i-ext) + (if (and (wvp hash-values 32) (equal (len hash-values) 5) + (wvp m-i-ext 32) (equal (len m-i-ext) 80)) + (digest-one-block-ac 0 hash-values m-i-ext) + nil)) + + +(defthm wvp-digest-one-block-ac + (implies (and (wvp l 32) (equal (len l) 5) + (integerp j) (<= 0 j) + (wvp m 32) (equal (len m) 80)) + (wvp (digest-one-block-ac j l m ) 32)) +:hints +(("goal" + :in-theory (disable temp nth rotl rotl->rotr)))) + + +(defthm len-digest-one-block-ac + (implies (and (wvp l 32) (equal (len l) 5) + (integerp j) (<= 0 j) + (wvp m 32) (equal (len m) 80)) + (equal (len (digest-one-block-ac j l m )) 5)) +:hints +(("goal" + :in-theory (disable temp nth rotl rotl->rotr )))) + + +(defthm wvp-digest-one-block + (implies (and (wvp l 32) (equal (len l) 5) + (wvp m 32) (equal (len m) 80)) + (wvp (digest-one-block l m ) 32)) +:hints +(("goal" + :in-theory (disable digest-one-block-ac)))) + + +(defthm len-digest-one-block + (implies (and (wvp l 32) (equal (len l) 5) + (wvp m 32) (equal (len m) 80)) + (equal (len (digest-one-block l m )) 5)) +:hints +(("goal" + :in-theory (disable digest-one-block-ac )))) + + +;intermediate hash +(defun intermediate-hash ( l1 l2) + (if (and (wvp l1 32) (equal (len l1) 5) + (wvp l2 32) (equal (len l2) 5) ) + (list (plus 32 (nth 0 l1) (nth 0 l2) ) + (plus 32 (nth 1 l1) (nth 1 l2) ) + (plus 32 (nth 2 l1) (nth 2 l2) ) + (plus 32 (nth 3 l1) (nth 3 l2) ) + (plus 32 (nth 4 l1) (nth 4 l2) )) + nil)) + + +(defthm wvp-intermediate-hash + (implies (and (wvp l1 32) (equal (len l1) 5) + (wvp l2 32) (equal (len l2) 5) ) + (wvp (intermediate-hash l1 l2 ) 32)) +:hints +(("goal" + :in-theory (disable binary-plus wordp nth )))) + + +(defthm len-intermediate-hash + (implies (and (wvp l1 32) (equal (len l1) 5) + (wvp l2 32) (equal (len l2) 5) ) + (equal (len (intermediate-hash l1 l2 )) 5))) + + +(defun digest ( m hash-values) + (if (and (wvp m 512) (wvp hash-values 32) (equal (len hash-values) 5)) + (if (endp m) hash-values + (digest (cdr m) + (intermediate-hash hash-values + (digest-one-block hash-values (prepare (car m)))))) + nil) ) + + +(defthm wvp-digest + (implies (and (wvp m 512) (wvp hash-values 32) + (equal (len hash-values) 5)) + (wvp (digest m hash-values ) 32) ) +:hints +(("goal" + :in-theory (disable intermediate-hash digest-one-block prepare parsing )))) + + +(defthm len-digest + (implies (and (wvp m 512) (wvp hash-values 32) (not (endp m)) + (equal (len hash-values) 5)) + (equal (len (digest m hash-values )) 5) ) +:hints +(("goal" + :in-theory (disable intermediate-hash digest-one-block prepare )))) + + +(defun sha-1 ( m) + (if (and (bvp m) (< (len m) (expt 2 64))) + (digest (parsing (padding-1-256 m) 512) (h-1)) + nil)) + + +(defthm wvp-sha-1 +(implies (and (bvp m) (< (len m) (expt 2 64))) + (wvp (sha-1 m) 32) ) +:hints(("goal" :in-theory (disable digest parsing padding-1-256)))) + + +(defthm len-sha-1 +(implies (and (bvp m) (< (len m) (expt 2 64))) + (equal (len (sha-1 m)) 5 )) +:hints(("goal" +:use (:instance len-digest (m (parsing (padding-1-256 m) 512)) (hash-values (h-1))) +:in-theory (disable digest parsing padding-1-256 )))) + + +; --- second method of sha-1 (no preparing of the message) + +(defun s (j) + (if (and (integerp j) (<= 0 j)) + (bv-int-big-endian (bv-and (int-bv-big-endian j) (mask))) + nil )) + + +;(defthm integerp-s +; (implies (and (integerp j) (<= 0 j)) +; (integerp (s j))) +;:hints (("goal" :in-theory (disable bv-int-big-endian int-bv-big-endian mask )) +;)) + +(defun temp-1 (j working-variables m-i) + (if (and (wvp working-variables 32) (equal (len working-variables) 5) + (integerp j) (<= 0 j) + (wvp m-i 32) (equal (len m-i) 16)) + (plus 32 (rotl 5 (nth 0 working-variables) 32) + (Ft j (nth 1 working-variables) + (nth 2 working-variables) + (nth 3 working-variables)) + (nth 4 working-variables) + (nth (s j) m-i) + (K-1 j) ) + nil)) + +;(defthm wordp-temp-1 +; (implies (and (wvp l 32) (equal (len l) 5) +; (integerp j) (<= 0 j) (< j 80) +; (wvp m 32) (equal (len m) 16)) +; (wordp (temp-1 j l m ) 32)) +;:hints (("goal" :in-theory (disable k-1 ft rotl binary-plus rotl->rotr nth )) +;)) + +(defun wo (j m-i ) + (if (and (integerp j) (<= 0 j) + (wvp m-i 32)) + (rotl 1 (bv-xor + (nth (bv-int-big-endian (bv-and (int-bv-big-endian (+ 13 (s j))) + (mask))) m-i) + (nth (bv-int-big-endian (bv-and (int-bv-big-endian (+ 8 (s j))) + (mask))) m-i) + (nth (bv-int-big-endian (bv-and (int-bv-big-endian (+ 2 (s j))) + (mask))) m-i) + (nth (bv-int-big-endian (bv-and (int-bv-big-endian j) + (mask))) m-i)) 32) + nil)) + + +(defun digest-one-block-1 ( j working-variables m-i ) +(declare (xargs :measure (acl2-count (- 80 j)))) + (if (and (wvp working-variables 32) (equal (len working-variables) 5) + (integerp j) (<= 0 j) + (wvp m-i 32) (equal (len m-i) 16)) + (if (<= 80 j) + working-variables + (if (>= j 16) + (digest-one-block-1 (+ 1 j) + (list (temp-1 j working-variables (repl (s j) + (wo j m-i) m-i)) + (nth 0 working-variables) + (rotl 30 ( nth 1 working-variables) 32) + (nth 2 working-variables) + (nth 3 working-variables)) + (repl (s j) (wo j m-i) m-i) ) + (digest-one-block-1 (+ 1 j) + (list (temp-1 j working-variables m-i ) + (nth 0 working-variables) + (rotl 30 (nth 1 working-variables) 32) + (nth 2 working-variables) + (nth 3 working-variables)) + m-i ) )) + nil)) + + +(defun digest-1 ( m hash-values) + (if (and (wvp m 512) (wvp hash-values 32) (equal (len hash-values) 5) ) + (if (endp m) hash-values + (digest-1 (cdr m) + (intermediate-hash hash-values + (digest-one-block-1 0 hash-values (parsing (car m) 32))))) + nil) ) + + +(defun sha-1-2 ( m) + (if (and (bvp m) (< (len m) (expt 2 64))) + (digest-1 (parsing (padding-1-256 m) 512) (h-1)) + nil)) diff --git a/books/workshops/2003/toma-borrione/support/sha-256.lisp b/books/workshops/2003/toma-borrione/support/sha-256.lisp new file mode 100644 index 0000000..afbf187 --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/sha-256.lisp @@ -0,0 +1,533 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of SHA-256 +; Message digest functions and theorems +;------------------------------------------ + +(IN-PACKAGE "ACL2") + +(include-book "parsing") +(include-book "sha-functions") + +;I strongly recommend after charging the book to do :comp t in order to accelerate the computation + +; For a message M with length less than (expt 2 64) sha-1 returns a message digest of 256 bits (eight words each of 32 bits). + +;For message "abc" +;ACL2 !>(sha-256 '(0 1 1 0 0 0 0 1 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 )) +;((1 0 1 1 1 0 1 0 0 1 1 1 +; 1 0 0 0 0 0 0 1 0 1 1 0 1 0 1 1 1 1 1 1) +; (1 0 0 0 1 1 1 1 0 0 0 0 +; 0 0 0 1 1 1 0 0 1 1 1 1 1 1 1 0 1 0 1 0) +; (0 1 0 0 0 0 0 1 0 1 0 0 +; 0 0 0 1 0 1 0 0 0 0 0 0 1 1 0 1 1 1 1 0) +; (0 1 0 1 1 1 0 1 1 0 1 0 +; 1 1 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 1) +; (1 0 1 1 0 0 0 0 0 0 0 0 +; 0 0 1 1 0 1 1 0 0 0 0 1 1 0 1 0 0 0 1 1) +; (1 0 0 1 0 1 1 0 0 0 0 1 +; 0 1 1 1 0 1 1 1 1 0 1 0 1 0 0 1 1 1 0 0) +; (1 0 1 1 0 1 0 0 0 0 0 1 +; 0 0 0 0 1 1 1 1 1 1 1 1 0 1 1 0 0 0 0 1) +; (1 1 1 1 0 0 1 0 0 0 0 0 0 +; 0 0 0 0 0 0 1 0 1 0 1 1 0 1 0 1 1 0 1)) + +;For the message "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" (448 bits) +;ACL2 !>(sha-256 '(0 1 1 0 0 0 0 1 +; 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 0 1 1 0 +; 0 1 0 0 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 +; 0 1 1 0 0 1 0 0 0 1 1 0 0 1 0 1 0 1 1 0 +; 0 0 1 1 0 1 1 0 0 1 0 0 0 1 1 0 0 1 0 1 +; 0 1 1 0 0 1 1 0 0 1 1 0 0 1 0 0 0 1 1 0 +; 0 1 0 1 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 1 +; 0 1 1 0 0 1 0 1 0 1 1 0 0 1 1 0 0 1 1 0 +; 0 1 1 1 0 1 1 0 1 0 0 0 0 1 1 0 0 1 1 0 +; 0 1 1 0 0 1 1 1 0 1 1 0 1 0 0 0 0 1 1 0 +; 1 0 0 1 0 1 1 0 0 1 1 1 0 1 1 0 1 0 0 0 +; 0 1 1 0 1 0 0 1 0 1 1 0 1 0 1 0 0 1 1 0 +; 1 0 0 0 0 1 1 0 1 0 0 1 0 1 1 0 1 0 1 0 +; 0 1 1 0 1 0 1 1 0 1 1 0 1 0 0 1 0 1 1 0 +; 1 0 1 0 0 1 1 0 1 0 1 1 0 1 1 0 1 1 0 0 +; 0 1 1 0 1 0 1 0 0 1 1 0 1 0 1 1 0 1 1 0 +; 1 1 0 0 0 1 1 0 1 1 0 1 0 1 1 0 1 0 1 1 +; 0 1 1 0 1 1 0 0 0 1 1 0 1 1 0 1 0 1 1 0 +; 1 1 1 0 0 1 1 0 1 1 0 0 0 1 1 0 1 1 0 1 +; 0 1 1 0 1 1 1 0 0 1 1 0 1 1 1 1 0 1 1 0 +; 1 1 0 1 0 1 1 0 1 1 1 0 0 1 1 0 1 1 1 1 +; 0 1 1 1 0 0 0 0 0 1 1 0 1 1 1 0 0 1 1 0 +; 1 1 1 1 0 1 1 1 0 0 0 0 0 1 1 1 0 0 0 1)) + +; The result: + +;((0 0 1 0 0 1 0 0 1 0 0 0 +; 1 1 0 1 0 1 1 0 1 0 1 0 0 1 1 0 0 0 0 1) +; (1 1 0 1 0 0 1 0 0 0 0 0 +; 0 1 1 0 0 0 1 1 1 0 0 0 1 0 1 1 1 0 0 0) +; (1 1 1 0 0 1 0 1 1 1 0 0 +; 0 0 0 0 0 0 1 0 0 1 1 0 1 0 0 1 0 0 1 1) +; (0 0 0 0 1 1 0 0 0 0 1 1 +; 1 1 1 0 0 1 1 0 0 0 0 0 0 0 1 1 1 0 0 1) +; (1 0 1 0 0 0 1 1 0 0 1 1 +; 1 1 0 0 1 1 1 0 0 1 0 0 0 1 0 1 1 0 0 1) +; (0 1 1 0 0 1 0 0 1 1 1 1 +; 1 1 1 1 0 0 1 0 0 0 0 1 0 1 1 0 0 1 1 1) +; (1 1 1 1 0 1 1 0 1 1 1 0 +; 1 1 0 0 1 1 1 0 1 1 0 1 1 1 0 1 0 1 0 0) +; (0 0 0 1 1 0 0 1 1 1 0 1 1 +; 0 1 1 0 0 0 0 0 1 1 0 1 1 0 0 0 0 0 1)) + +; constants of sha-256 +(defun K-256 (i) + (cond ((equal i 0) + '(0 1 0 0 0 0 1 0 1 0 0 0 + 1 0 1 0 0 0 1 0 1 1 1 1 1 0 0 1 1 0 0 0)) + ((equal i 1) + '(0 1 1 1 0 0 0 1 0 0 1 1 + 0 1 1 1 0 1 0 0 0 1 0 0 1 0 0 1 0 0 0 1)) + ((equal i 2) '(1 0 1 1 0 1 0 1 1 1 0 0 + 0 0 0 0 1 1 1 1 1 0 1 1 1 1 0 0 1 1 1 1)) + ((equal i 3) '(1 1 1 0 1 0 0 1 1 0 1 1 + 0 1 0 1 1 1 0 1 1 0 1 1 1 0 1 0 0 1 0 1)) + ((equal i 4) '(0 0 1 1 1 0 0 1 0 1 0 1 + 0 1 1 0 1 1 0 0 0 0 1 0 0 1 0 1 1 0 1 1)) + ((equal i 5) '(0 1 0 1 1 0 0 1 1 1 1 1 + 0 0 0 1 0 0 0 1 0 0 0 1 1 1 1 1 0 0 0 1)) + ((equal i 6) '(1 0 0 1 0 0 1 0 0 0 1 1 + 1 1 1 1 1 0 0 0 0 0 1 0 1 0 1 0 0 1 0 0)) + ((equal i 7) '(1 0 1 0 1 0 1 1 0 0 0 1 + 1 1 0 0 0 1 0 1 1 1 1 0 1 1 0 1 0 1 0 1)) + ((equal i 8) '(1 1 0 1 + 1 0 0 0 0 0 0 0 0 1 1 1 1 0 1 0 1 0 1 0 + 1 0 0 1 1 0 0 0)) + ((equal i 9) '(0 0 0 1 + 0 0 1 0 1 0 0 0 0 0 1 1 0 1 0 1 1 0 1 1 + 0 0 0 0 0 0 0 1)) + ((equal i 10) '(0 0 1 0 + 0 1 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 1 0 1 + 1 0 1 1 1 1 1 0)) + ((equal i 11) '(0 1 0 1 + 0 1 0 1 0 0 0 0 1 1 0 0 0 1 1 1 1 1 0 1 + 1 1 0 0 0 0 1 1)) + ((equal i 12) '(0 1 1 1 + 0 0 1 0 1 0 1 1 1 1 1 0 0 1 0 1 1 1 0 1 + 0 1 1 1 0 1 0 0)) + ((equal i 13) '(1 0 0 0 + 0 0 0 0 1 1 0 1 1 1 1 0 1 0 1 1 0 0 0 1 + 1 1 1 1 1 1 1 0)) + ((equal i 14) '(1 0 0 1 + 1 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 1 1 0 + 1 0 1 0 0 1 1 1)) + ((equal i 15) '(1 1 0 0 + 0 0 0 1 1 0 0 1 1 0 1 1 1 1 1 1 0 0 0 1 + 0 1 1 1 0 1 0 0)) + ((equal i 16) '(1 1 1 0 + 0 1 0 0 1 0 0 1 1 0 1 1 0 1 1 0 1 0 0 1 + 1 1 0 0 0 0 0 1)) + ((equal i 17) '(1 1 1 0 + 1 1 1 1 1 0 1 1 1 1 1 0 0 1 0 0 0 1 1 1 + 1 0 0 0 0 1 1 0)) + ((equal i 18) '(0 0 0 0 + 1 1 1 1 1 1 0 0 0 0 0 1 1 0 0 1 1 1 0 1 + 1 1 0 0 0 1 1 0)) + ((equal i 19) '(0 0 1 0 + 0 1 0 0 0 0 0 0 1 1 0 0 1 0 1 0 0 0 0 1 + 1 1 0 0 1 1 0 0)) + ((equal i 20) '(0 0 1 0 + 1 1 0 1 1 1 1 0 1 0 0 1 0 0 1 0 1 1 0 0 + 0 1 1 0 1 1 1 1)) + ((equal i 21) '(0 1 0 0 + 1 0 1 0 0 1 1 1 0 1 0 0 1 0 0 0 0 1 0 0 + 1 0 1 0 1 0 1 0)) + ((equal i 22) '(0 1 0 1 + 1 1 0 0 1 0 1 1 0 0 0 0 1 0 1 0 1 0 0 1 + 1 1 0 1 1 1 0 0)) + ((equal i 23) '(0 1 1 1 + 0 1 1 0 1 1 1 1 1 0 0 1 1 0 0 0 1 0 0 0 + 1 1 0 1 1 0 1 0)) + ((equal i 24) '(1 0 0 1 + 1 0 0 0 0 0 1 1 1 1 1 0 0 1 0 1 0 0 0 1 + 0 1 0 1 0 0 1 0)) + ((equal i 25) '(1 0 1 0 + 1 0 0 0 0 0 1 1 0 0 0 1 1 1 0 0 0 1 1 0 + 0 1 1 0 1 1 0 1)) + ((equal i 26) '(1 0 1 1 + 0 0 0 0 0 0 0 0 0 0 1 1 0 0 1 0 0 1 1 1 + 1 1 0 0 1 0 0 0)) + ((equal i 27) '(1 0 1 1 + 1 1 1 1 0 1 0 1 1 0 0 1 0 1 1 1 1 1 1 1 + 1 1 0 0 0 1 1 1)) + ((equal i 28) '(1 1 0 0 + 0 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 0 1 1 + 1 1 1 1 0 0 1 1 )) + ((equal i 29) '(1 1 0 1 + 0 1 0 1 1 0 1 0 0 1 1 1 1 0 0 1 0 0 0 1 + 0 1 0 0 0 1 1 1 )) + ((equal i 30) '(0 0 0 0 + 0 1 1 0 1 1 0 0 1 0 1 0 0 1 1 0 0 0 1 1 + 0 1 0 1 0 0 0 1 )) + ((equal i 31) '(0 0 0 1 + 0 1 0 0 0 0 1 0 1 0 0 1 0 0 1 0 1 0 0 1 + 0 1 1 0 0 1 1 1)) + ((equal i 32) '(0 0 1 0 + 0 1 1 1 1 0 1 1 0 1 1 1 0 0 0 0 1 0 1 0 + 1 0 0 0 0 1 0 1)) + ((equal i 33) '(0 0 1 0 + 1 1 1 0 0 0 0 1 1 0 1 1 0 0 1 0 0 0 0 1 + 0 0 1 1 1 0 0 0 )) + ((equal i 34) '(0 1 0 0 + 1 1 0 1 0 0 1 0 1 1 0 0 0 1 1 0 1 1 0 1 + 1 1 1 1 1 1 0 0)) + ((equal i 35) '(0 1 0 1 + 0 0 1 1 0 0 1 1 1 0 0 0 0 0 0 0 1 1 0 1 + 0 0 0 1 0 0 1 1 )) + ((equal i 36) '(0 1 1 0 0 1 0 1 0 0 0 0 + 1 0 1 0 0 1 1 1 0 0 1 1 0 1 0 1 0 1 0 0)) + ((equal i 37) '(0 1 1 1 + 0 1 1 0 0 1 1 0 1 0 1 0 0 0 0 0 1 0 1 0 + 1 0 1 1 1 0 1 1)) + ((equal i 38) '(1 0 0 0 + 0 0 0 1 1 1 0 0 0 0 1 0 1 1 0 0 1 0 0 1 + 0 0 1 0 1 1 1 0)) + ((equal i 39) '(1 0 0 1 + 0 0 1 0 0 1 1 1 0 0 1 0 0 0 1 0 1 1 0 0 + 1 0 0 0 0 1 0 1)) + ((equal i 40) '(1 0 1 0 + 0 0 1 0 1 0 1 1 1 1 1 1 1 1 1 0 1 0 0 0 + 1 0 1 0 0 0 0 1 )) + ((equal i 41) '(1 0 1 0 + 1 0 0 0 0 0 0 1 1 0 1 0 0 1 1 0 0 1 1 0 + 0 1 0 0 1 0 1 1)) + ((equal i 42) '(1 1 0 0 + 0 0 1 0 0 1 0 0 1 0 1 1 1 0 0 0 1 0 1 1 + 0 1 1 1 0 0 0 0 )) + ((equal i 43) '(1 1 0 0 + 0 1 1 1 0 1 1 0 1 1 0 0 0 1 0 1 0 0 0 1 + 1 0 1 0 0 0 1 1)) + ((equal i 44) '(1 1 0 1 + 0 0 0 1 1 0 0 1 0 0 1 0 1 1 1 0 1 0 0 0 + 0 0 0 1 1 0 0 1 )) + ((equal i 45) '(1 1 0 1 + 0 1 1 0 1 0 0 1 1 0 0 1 0 0 0 0 0 1 1 0 + 0 0 1 0 0 1 0 0 )) + ((equal i 46) '(1 1 1 1 + 0 1 0 0 0 0 0 0 1 1 1 0 0 0 1 1 0 1 0 1 + 1 0 0 0 0 1 0 1 )) + ((equal i 47) '(0 0 0 1 + 0 0 0 0 0 1 1 0 1 0 1 0 1 0 1 0 0 0 0 0 + 0 1 1 1 0 0 0 0)) + ((equal i 48) '(0 0 0 1 + 1 0 0 1 1 0 1 0 0 1 0 0 1 1 0 0 0 0 0 1 + 0 0 0 1 0 1 1 0 )) + ((equal i 49) '(0 0 0 1 + 1 1 1 0 0 0 1 1 0 1 1 1 0 1 1 0 1 1 0 0 + 0 0 0 0 1 0 0 0)) + ((equal i 50) '(0 0 1 0 + 0 1 1 1 0 1 0 0 1 0 0 0 0 1 1 1 0 1 1 1 + 0 1 0 0 1 1 0 0 )) + ((equal i 51) '(0 0 1 1 + 0 1 0 0 1 0 1 1 0 0 0 0 1 0 1 1 1 1 0 0 + 1 0 1 1 0 1 0 1 )) + ((equal i 52) '(0 0 1 1 + 1 0 0 1 0 0 0 1 1 1 0 0 0 0 0 0 1 1 0 0 + 1 0 1 1 0 0 1 1 )) + ((equal i 53) '(0 1 0 0 + 1 1 1 0 1 1 0 1 1 0 0 0 1 0 1 0 1 0 1 0 + 0 1 0 0 1 0 1 0 )) + ((equal i 54) '(0 1 0 1 + 1 0 1 1 1 0 0 1 1 1 0 0 1 1 0 0 1 0 1 0 + 0 1 0 0 1 1 1 1 )) + ((equal i 55) '(0 1 1 0 + 1 0 0 0 0 0 1 0 1 1 1 0 0 1 1 0 1 1 1 1 + 1 1 1 1 0 0 1 1 )) + ((equal i 56) '(0 1 1 1 + 0 1 0 0 1 0 0 0 1 1 1 1 1 0 0 0 0 0 1 0 + 1 1 1 0 1 1 1 0)) + ((equal i 57) '(0 1 1 1 + 1 0 0 0 1 0 1 0 0 1 0 1 0 1 1 0 0 0 1 1 + 0 1 1 0 1 1 1 1 )) + ((equal i 58) '(1 0 0 0 + 0 1 0 0 1 1 0 0 1 0 0 0 0 1 1 1 1 0 0 0 + 0 0 0 1 0 1 0 0 )) + ((equal i 59) '(1 0 0 0 + 1 1 0 0 1 1 0 0 0 1 1 1 0 0 0 0 0 0 1 0 + 0 0 0 0 1 0 0 0 )) + ((equal i 60) '(1 0 0 1 + 0 0 0 0 1 0 1 1 1 1 1 0 1 1 1 1 1 1 1 1 + 1 1 1 1 1 0 1 0 )) + ((equal i 61) '(1 0 1 0 + 0 1 0 0 0 1 0 1 0 0 0 0 0 1 1 0 1 1 0 0 + 1 1 1 0 1 0 1 1 )) + ((equal i 62) '(1 0 1 1 + 1 1 1 0 1 1 1 1 1 0 0 1 1 0 1 0 0 0 1 1 + 1 1 1 1 0 1 1 1 )) + ((equal i 63) '(1 1 0 0 + 0 1 1 0 0 1 1 1 0 0 0 1 0 1 1 1 1 0 0 0 + 1 1 1 1 0 0 1 0)) + (t nil))) + +(defthm wordp-K-256 +(implies (and (integerp i) (<= 0 i) (<= i 63)) + (wordp (k-256 i) 32))) + + +; initial hash values for sha-256 +(defun h-256 () +'((0 1 1 0 1 0 1 0 0 0 0 0 + 1 0 0 1 1 1 1 0 0 1 1 0 0 1 1 0 0 1 1 1) +(1 0 1 1 1 0 1 1 0 1 1 0 + 0 1 1 1 1 0 1 0 1 1 1 0 1 0 0 0 0 1 0 1) +(0 0 1 1 1 1 0 0 0 1 1 0 + 1 1 1 0 1 1 1 1 0 0 1 1 0 1 1 1 0 0 1 0) +(1 0 1 0 0 1 0 1 0 1 0 0 + 1 1 1 1 1 1 1 1 0 1 0 1 0 0 1 1 1 0 1 0) +(0 1 0 1 0 0 0 1 0 0 0 0 + 1 1 1 0 0 1 0 1 0 0 1 0 0 1 1 1 1 1 1 1) +(1 0 0 1 1 0 1 1 0 0 0 0 + 0 1 0 1 0 1 1 0 1 0 0 0 1 0 0 0 1 1 0 0) +(0 0 0 1 1 1 1 1 1 0 0 0 + 0 0 1 1 1 1 0 1 1 0 0 1 1 0 1 0 1 0 1 1) +(0 1 0 1 1 0 1 1 1 1 1 0 + 0 0 0 0 1 1 0 0 1 1 0 1 0 0 0 1 1 0 0 1)) +) + +(defthm wordp-h-256 + (and (wvp (h-256) 32) (equal (len (h-256)) 8 ))) + + +;-----sha-256 + +(defun prepare-256-ac ( j m-i) +(declare (xargs :measure (acl2-count (- 64 j)))) + (if (and (wvp m-i 32) (integerp j) (<= 16 j)) + (cond ((<= 64 j) m-i) + ((<= j 63) + (prepare-256-ac (1+ j) (append m-i + (list (plus 32 (s-1-256 (nth (- j 2) m-i)) + (nth (- j 7) m-i) + (s-0-256 (nth (- j 15) m-i)) + (nth (- j 16) m-i) )))))) + nil)) + + +(defun prepare-256 (m-i) + (if (wordp m-i 512) + (prepare-256-ac 16 (parsing m-i 32)) + nil)) + + +(defthm wvp-prepare-256-ac + (implies (and (integerp j) (<= 16 j) (wvp m 32)) + (wvp (prepare-256-ac j m) 32)) +:hints +(("goal" + :in-theory (disable s-1-256 s-0-256 nth binary-plus )))) + + +(defthm len-prepare-256-ac + (implies (and (wvp m 32) (integerp j) (<= 16 j) (<= j (len m) )) + (equal (len (prepare-256-ac j m)) + (if (<= j 64) + (+ (- 64 j) (len m)) + (len m)))) +:hints +(("goal" + :in-theory (disable s-1-256 s-0-256 nth binary-plus )))) + + +(defthm wvp-prepare-256 + (implies (wordp m 512) + (wvp (prepare-256 m) 32)) +:hints (("goal" :in-theory (disable prepare-256-ac )))) + + +(defthm len-prepare-256 + (implies (wordp m 512) + (equal (len (prepare-256 m)) 64)) +:hints (("goal" :in-theory (disable prepare-256-ac)))) + + +(defun temp-1-256 (j working-variables m-i-ext) + (if (and (wvp working-variables 32) (equal (len working-variables) 8) + (integerp j) (<= 0 j) + (wvp m-i-ext 32) (equal (len m-i-ext) 64)) + (plus 32 (nth 7 working-variables) + (sigma-1-256 (nth 4 working-variables)) + (Ch (nth 4 working-variables) + (nth 5 working-variables) + (nth 6 working-variables )) + (k-256 j) + (nth j m-i-ext) ) + nil)) + +(defthm wordp-temp-1-256 + (implies (and (wvp l 32) (equal (len l) 8) + (integerp j) (<= 0 j) (< j 64) + (wvp m 32) (equal (len m) 64)) + (wordp (temp-1-256 j l m ) 32)) +:hints (("goal" :in-theory (disable sigma-1-256 ch k-256 nth binary-plus )) +)) + +(defun temp-2-256 ( working-variables ) + (if (and (wvp working-variables 32) (equal (len working-variables) 8)) + (plus 32 (sigma-0-256 (nth 0 working-variables)) + (Maj (nth 0 working-variables ) + (nth 1 working-variables) + (nth 2 working-variables)) ) + nil)) + + +(defthm wordp-temp-2-256 + (implies (and (wvp l 32) (equal (len l) 8)) + (wordp (temp-2-256 l ) 32)) +:hints +(("goal" + :in-theory (disable sigma-0-256 maj binary-plus nth )))) + + +(defun digest-one-block-256-ac ( j working-variables m-i-ext) +(declare (xargs :measure (acl2-count (- 64 j)))) + (if (and (wvp working-variables 32) (equal (len working-variables) 8) + (integerp j) (<= 0 j) + (wvp m-i-ext 32) (equal (len m-i-ext) 64)) + (if (<= 64 j) + working-variables + (digest-one-block-256-ac (+ 1 j) + (list (plus 32 (temp-1-256 j working-variables m-i-ext) + (temp-2-256 working-variables )) + (nth 0 working-variables) + (nth 1 working-variables) + (nth 2 working-variables) + (plus 32 (nth 3 working-variables) + (temp-1-256 j working-variables m-i-ext)) + (nth 4 working-variables) + (nth 5 working-variables) + (nth 6 working-variables)) + m-i-ext) ) + nil)) + + +(defun digest-one-block-256 (hash-values m-i-ext) + (if (and (wvp hash-values 32) (equal (len hash-values) 8) + (wvp m-i-ext 32) (equal (len m-i-ext) 64)) + (digest-one-block-256-ac 0 hash-values m-i-ext) + nil)) + + +(defthm wvp-digest-one-block-256-ac + (implies (and (wvp l 32) (equal (len l) 8) + (integerp j) (<= 0 j) + (wvp m 32) (equal (len m) 64)) + (wvp (digest-one-block-256-ac j l m ) 32)) +:hints (("goal" :in-theory (disable temp-1-256 temp-2-256 nth binary-plus)) +)) + +(defthm len-digest-one-block-256-ac + (implies (and (wvp l 32) (equal (len l) 8) + (integerp j) (<= 0 j) + (wvp m 32) (equal (len m) 64)) + (equal (len (digest-one-block-256-ac j l m )) 8)) +:hints (("goal" :in-theory (disable temp-1-256 temp-2-256 nth binary-plus )))) + + + +(defthm wvp-digest-one-block-256 + (implies (and (wvp l 32) (equal (len l) 8) + (wvp m 32) (equal (len m) 64)) + (wvp (digest-one-block-256 l m ) 32)) +:hints +(("goal" + :in-theory (disable digest-one-block-256-ac)))) + + +(defthm len-digest-one-block-256 + (implies (and (wvp l 32) (equal (len l) 8) + (wvp m 32) (equal (len m) 64)) + (equal (len (digest-one-block-256 l m )) 8)) +:hints +(("goal" + :in-theory (disable digest-one-block-256-ac )))) + + +(defun intermediate-hash-256 ( l1 l2) + (if (and (wvp l1 32) (equal (len l1) 8) + (wvp l2 32) (equal (len l2) 8) ) + (list (plus 32 (nth 0 l1) (nth 0 l2)) + (plus 32 (nth 1 l1) (nth 1 l2) ) + (plus 32 (nth 2 l1) (nth 2 l2) ) + (plus 32 (nth 3 l1) (nth 3 l2) ) + (plus 32 (nth 4 l1) (nth 4 l2) ) + (plus 32 (nth 5 l1) (nth 5 l2) ) + (plus 32 (nth 6 l1) (nth 6 l2) ) + (plus 32 (nth 7 l1) (nth 7 l2) ) ) + nil)) + + +(defthm wvp-intermediate-hash-256 + (implies (and (wvp l1 32) (equal (len l1) 8) + (wvp l2 32) (equal (len l2) 8) ) + (wvp (intermediate-hash-256 l1 l2 ) 32)) +:hints +(("goal" + :in-theory (disable binary-plus wordp nth )))) + + +(defthm len-intermediate-hash-256 + (implies (and (wvp l1 32) (equal (len l1) 8) + (wvp l2 32) (equal (len l2) 8) ) + (equal (len (intermediate-hash-256 l1 l2 )) 8))) + + +(defun digest-256 ( m hash-values) + (if (and (wvp m 512) (wvp hash-values 32) (equal (len hash-values) 8)) + (if (endp m) hash-values + (digest-256 (cdr m) + (intermediate-hash-256 hash-values + (digest-one-block-256 hash-values + (prepare-256 (car m) ))))) + nil) ) + + +(defthm wvp-digest-256 + (implies (and (wvp m 512) (wvp hash-values 32) + (equal (len hash-values) 8)) + (wvp (digest-256 m hash-values ) 32) ) +:hints +(("goal" + :in-theory (disable intermediate-hash-256 + digest-one-block-256 prepare-256 )))) + + +(defthm len-digest-256 + (implies (and (wvp m 512) (wvp hash-values 32) (not (endp m)) + (equal (len hash-values) 8)) + (equal (len (digest-256 m hash-values )) 8) ) +:hints +(("goal" + :in-theory (disable intermediate-hash-256 + digest-one-block-256 prepare-256 )))) + +(defun sha-256 ( m) + (if (and (bvp m) (< (len m) (expt 2 64))) + (digest-256 (parsing (padding-1-256 m) 512) (h-256)) + nil)) + + +(defthm wvp-sha-256 +(implies (and (bvp m) (< (len m) (expt 2 64))) + (wvp (sha-256 m) 32) ) +:hints +(("goal" + :in-theory (disable digest-256 parsing padding-1-256)))) + + +(defthm len-sha-256 +(implies (and (bvp m) (< (len m) (expt 2 64))) + (equal (len (sha-256 m)) 8 )) +:hints +(("goal" + :use (:instance len-digest-256 (m (parsing (padding-1-256 m) 512)) + (hash-values (h-256))) + :in-theory (disable digest-256 parsing padding-1-256))))
\ No newline at end of file diff --git a/books/workshops/2003/toma-borrione/support/sha-384-512.lisp b/books/workshops/2003/toma-borrione/support/sha-384-512.lisp new file mode 100644 index 0000000..3a846a1 --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/sha-384-512.lisp @@ -0,0 +1,721 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of SHA-384 and SHA-512 +; Message digest functions and theorems +;------------------------------------------ + +(IN-PACKAGE "ACL2") + +(include-book "parsing") +(include-book "sha-functions") + +;I strongly recommend after charging the book to do :comp t in order to accelerate the computation + +; For a message M with length less than (expt 2 128) sha-512 returns a message digest of 512 bits (eight words each of 64 bits), and sha-384 returns 384 bits of message digest (six words each of 64 bits) . + +;For message "abc" +;ACL2 !>(sha-512 '(0 1 1 0 0 0 0 1 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 )) +;((1 1 0 1 +; 1 1 0 1 1 0 1 0 1 1 1 1 0 0 1 1 0 1 0 1 +; 1 0 1 0 0 0 0 1 1 0 0 1 0 0 1 1 0 1 1 0 +; 0 0 0 1 0 1 1 1 1 0 1 0 1 0 1 1 1 0 1 0) +; (1 1 0 0 +; 1 1 0 0 0 1 0 0 0 0 0 1 0 1 1 1 0 0 1 1 +; 0 1 0 0 1 0 0 1 1 0 1 0 1 1 1 0 0 0 1 0 +; 0 0 0 0 0 1 0 0 0 0 0 1 0 0 1 1 0 0 0 1) +; (0 0 0 1 +; 0 0 1 0 1 1 1 0 0 1 1 0 1 1 1 1 1 0 1 0 +; 0 1 0 0 1 1 1 0 1 0 0 0 1 0 0 1 1 0 1 0 +; 1 0 0 1 0 1 1 1 1 1 1 0 1 0 1 0 0 0 1 0) +; (0 0 0 0 +; 1 0 1 0 1 0 0 1 1 1 1 0 1 1 1 0 1 1 1 0 +; 1 1 1 0 0 1 1 0 0 1 0 0 1 0 1 1 0 1 0 1 +; 0 1 0 1 1 1 0 1 0 0 1 1 1 0 0 1 1 0 1 0) +; (0 0 1 0 +; 0 0 0 1 1 0 0 1 0 0 1 0 1 0 0 1 1 0 0 1 +; 0 0 1 0 1 0 1 0 0 0 1 0 0 1 1 1 0 1 0 0 +; 1 1 1 1 1 1 0 0 0 0 0 1 1 0 1 0 1 0 0 0) +; (0 0 1 1 +; 0 1 1 0 1 0 1 1 1 0 1 0 0 0 1 1 1 1 0 0 +; 0 0 1 0 0 0 1 1 1 0 1 0 0 0 1 1 1 1 1 1 +; 1 1 1 0 1 1 1 0 1 0 1 1 1 0 1 1 1 1 0 1) +; (0 1 0 0 +; 0 1 0 1 0 1 0 0 1 1 0 1 0 1 0 0 0 1 0 0 +; 0 0 1 0 0 0 1 1 0 1 1 0 0 1 0 0 0 0 1 1 +; 1 1 0 0 1 1 1 0 1 0 0 0 0 0 0 0 1 1 1 0) +; (0 0 1 0 1 +; 0 1 0 1 0 0 1 1 0 1 0 1 1 0 0 1 0 0 1 0 +; 1 0 0 1 1 1 1 1 0 1 0 0 1 0 1 0 1 0 0 1 +; 1 0 0 1 0 1 0 0 1 0 0 1 0 0 1 1 1 1 1)) + + + +; constants of sha-512 +(defun K-512 (i) + (cond ((equal i 0) + '(0 1 0 0 0 0 1 0 1 0 0 0 + 1 0 1 0 0 0 1 0 1 1 1 1 1 0 0 1 1 0 0 0 1 1 0 1 0 1 1 1 0 0 1 0 + 1 0 0 0 1 0 1 0 1 1 1 0 0 0 1 0 0 0 1 0)) + ((equal i 1) + '(0 1 1 1 0 0 0 1 0 0 1 1 + 0 1 1 1 0 1 0 0 0 1 0 0 1 0 0 1 0 0 0 1 0 0 1 0 0 0 1 1 1 1 1 0 + 1 1 1 1 0 1 1 0 0 1 0 1 1 1 0 0 1 1 0 1)) + ((equal i 2) '(1 0 1 1 0 1 0 1 1 1 0 0 + 0 0 0 0 1 1 1 1 1 0 1 1 1 1 0 0 1 1 1 1 1 1 1 0 1 1 0 0 0 1 0 0 + 1 1 0 1 0 0 1 1 1 0 1 1 0 0 1 0 1 1 1 1)) + ((equal i 3) '(1 1 1 0 1 0 0 1 1 0 1 1 + 0 1 0 1 1 1 0 1 1 0 1 1 1 0 1 0 0 1 0 1 1 0 0 0 0 0 0 1 1 0 0 0 + 1 0 0 1 1 1 0 1 1 0 1 1 1 0 1 1 1 1 0 0)) + ((equal i 4) '(0 0 1 1 1 0 0 1 0 1 0 1 + 0 1 1 0 1 1 0 0 0 0 1 0 0 1 0 1 1 0 1 1 1 1 1 1 0 0 1 1 0 1 0 0 + 1 0 0 0 1 0 1 1 0 1 0 1 0 0 1 1 1 0 0 0)) + ((equal i 5) '(0 1 0 1 1 0 0 1 1 1 1 1 + 0 0 0 1 0 0 0 1 0 0 0 1 1 1 1 1 0 0 0 1 1 0 1 1 0 1 1 0 0 0 0 0 + 0 1 0 1 1 1 0 1 0 0 0 0 0 0 0 1 1 0 0 1)) + ((equal i 6) '(1 0 0 1 0 0 1 0 0 0 1 1 + 1 1 1 1 1 0 0 0 0 0 1 0 1 0 1 0 0 1 0 0 1 0 1 0 1 1 1 1 0 0 0 1 + 1 0 0 1 0 1 0 0 1 1 1 1 1 0 0 1 1 0 1 1)) + ((equal i 7) '(1 0 1 0 + 1 0 1 1 0 0 0 1 1 1 0 0 0 1 0 1 1 1 1 0 + 1 1 0 1 0 1 0 1 1 1 0 1 1 0 1 0 0 1 1 0 + 1 1 0 1 1 0 0 0 0 0 0 1 0 0 0 1 1 0 0 0)) + ((equal i 8) '(1 1 0 1 + 1 0 0 0 0 0 0 0 0 1 1 1 1 0 1 0 1 0 1 0 + 1 0 0 1 1 0 0 0 1 0 1 0 0 0 1 1 0 0 0 0 + 0 0 1 1 0 0 0 0 0 0 1 0 0 1 0 0 0 0 1 0)) + ((equal i 9) '(0 0 0 1 + 0 0 1 0 1 0 0 0 0 0 1 1 0 1 0 1 1 0 1 1 + 0 0 0 0 0 0 0 1 0 1 0 0 0 1 0 1 0 1 1 1 + 0 0 0 0 0 1 1 0 1 1 1 1 1 0 1 1 1 1 1 0)) + ((equal i 10) '(0 0 1 0 + 0 1 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 1 0 1 + 1 0 1 1 1 1 1 0 0 1 0 0 1 1 1 0 1 1 1 0 + 0 1 0 0 1 0 1 1 0 0 1 0 1 0 0 0 1 1 0 0)) + ((equal i 11) '(0 1 0 1 + 0 1 0 1 0 0 0 0 1 1 0 0 0 1 1 1 1 1 0 1 + 1 1 0 0 0 0 1 1 1 1 0 1 0 1 0 1 1 1 1 1 + 1 1 1 1 1 0 1 1 0 1 0 0 1 1 1 0 0 0 1 0)) + ((equal i 12) '(0 1 1 1 + 0 0 1 0 1 0 1 1 1 1 1 0 0 1 0 1 1 1 0 1 + 0 1 1 1 0 1 0 0 1 1 1 1 0 0 1 0 0 1 1 1 + 1 0 1 1 1 0 0 0 1 0 0 1 0 1 1 0 1 1 1 1)) + ((equal i 13) '(1 0 0 0 + 0 0 0 0 1 1 0 1 1 1 1 0 1 0 1 1 0 0 0 1 + 1 1 1 1 1 1 1 0 0 0 1 1 1 0 1 1 0 0 0 1 + 0 1 1 0 1 0 0 1 0 1 1 0 1 0 1 1 0 0 0 1)) + ((equal i 14) '(1 0 0 1 + 1 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 1 1 0 + 1 0 1 0 0 1 1 1 0 0 1 0 0 1 0 1 1 1 0 0 + 0 1 1 1 0 0 0 1 0 0 1 0 0 0 1 1 0 1 0 1)) + ((equal i 15) '(1 1 0 0 + 0 0 0 1 1 0 0 1 1 0 1 1 1 1 1 1 0 0 0 1 + 0 1 1 1 0 1 0 0 1 1 0 0 1 1 1 1 0 1 1 0 + 1 0 0 1 0 0 1 0 0 1 1 0 1 0 0 1 0 1 0 0)) + ((equal i 16) '(1 1 1 0 + 0 1 0 0 1 0 0 1 1 0 1 1 0 1 1 0 1 0 0 1 + 1 1 0 0 0 0 0 1 1 0 0 1 1 1 1 0 1 1 1 1 + 0 0 0 1 0 1 0 0 1 0 1 0 1 1 0 1 0 0 1 0)) + ((equal i 17) '(1 1 1 0 + 1 1 1 1 1 0 1 1 1 1 1 0 0 1 0 0 0 1 1 1 + 1 0 0 0 0 1 1 0 0 0 1 1 1 0 0 0 0 1 0 0 + 1 1 1 1 0 0 1 0 0 1 0 1 1 1 1 0 0 0 1 1)) + ((equal i 18) '(0 0 0 0 + 1 1 1 1 1 1 0 0 0 0 0 1 1 0 0 1 1 1 0 1 + 1 1 0 0 0 1 1 0 1 0 0 0 1 0 1 1 1 0 0 0 + 1 1 0 0 1 1 0 1 0 1 0 1 1 0 1 1 0 1 0 1)) + ((equal i 19) '(0 0 1 0 + 0 1 0 0 0 0 0 0 1 1 0 0 1 0 1 0 0 0 0 1 + 1 1 0 0 1 1 0 0 0 1 1 1 0 1 1 1 1 0 1 0 + 1 1 0 0 1 0 0 1 1 1 0 0 0 1 1 0 0 1 0 1)) + ((equal i 20) '(0 0 1 0 + 1 1 0 1 1 1 1 0 1 0 0 1 0 0 1 0 1 1 0 0 + 0 1 1 0 1 1 1 1 0 1 0 1 1 0 0 1 0 0 1 0 + 1 0 1 1 0 0 0 0 0 0 1 0 0 1 1 1 0 1 0 1)) + ((equal i 21) '(0 1 0 0 + 1 0 1 0 0 1 1 1 0 1 0 0 1 0 0 0 0 1 0 0 + 1 0 1 0 1 0 1 0 0 1 1 0 1 1 1 0 1 0 1 0 + 0 1 1 0 1 1 1 0 0 1 0 0 1 0 0 0 0 0 1 1)) + ((equal i 22) '(0 1 0 1 + 1 1 0 0 1 0 1 1 0 0 0 0 1 0 1 0 1 0 0 1 + 1 1 0 1 1 1 0 0 1 0 1 1 1 1 0 1 0 1 0 0 + 0 0 0 1 1 1 1 1 1 0 1 1 1 1 0 1 0 1 0 0)) + ((equal i 23) '(0 1 1 1 + 0 1 1 0 1 1 1 1 1 0 0 1 1 0 0 0 1 0 0 0 + 1 1 0 1 1 0 1 0 1 0 0 0 0 0 1 1 0 0 0 1 + 0 0 0 1 0 1 0 1 0 0 1 1 1 0 1 1 0 1 0 1)) + ((equal i 24) '(1 0 0 1 + 1 0 0 0 0 0 1 1 1 1 1 0 0 1 0 1 0 0 0 1 + 0 1 0 1 0 0 1 0 1 1 1 0 1 1 1 0 0 1 1 0 + 0 1 1 0 1 1 0 1 1 1 1 1 1 0 1 0 1 0 1 1)) + ((equal i 25) '(1 0 1 0 + 1 0 0 0 0 0 1 1 0 0 0 1 1 1 0 0 0 1 1 0 + 0 1 1 0 1 1 0 1 0 0 1 0 1 1 0 1 1 0 1 1 + 0 1 0 0 0 0 1 1 0 0 1 0 0 0 0 1 0 0 0 0)) + ((equal i 26) '(1 0 1 1 + 0 0 0 0 0 0 0 0 0 0 1 1 0 0 1 0 0 1 1 1 + 1 1 0 0 1 0 0 0 1 0 0 1 1 0 0 0 1 1 1 1 + 1 0 1 1 0 0 1 0 0 0 0 1 0 0 1 1 1 1 1 1)) + ((equal i 27) '(1 0 1 1 + 1 1 1 1 0 1 0 1 1 0 0 1 0 1 1 1 1 1 1 1 + 1 1 0 0 0 1 1 1 1 0 1 1 1 1 1 0 1 1 1 0 + 1 1 1 1 0 0 0 0 1 1 1 0 1 1 1 0 0 1 0 0)) + ((equal i 28) '(1 1 0 0 + 0 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 0 1 1 + 1 1 1 1 0 0 1 1 0 0 1 1 1 1 0 1 1 0 1 0 + 1 0 0 0 1 0 0 0 1 1 1 1 1 1 0 0 0 0 1 0)) + ((equal i 29) '(1 1 0 1 + 0 1 0 1 1 0 1 0 0 1 1 1 1 0 0 1 0 0 0 1 + 0 1 0 0 0 1 1 1 1 0 0 1 0 0 1 1 0 0 0 0 + 1 0 1 0 1 0 1 0 0 1 1 1 0 0 1 0 0 1 0 1)) + ((equal i 30) '(0 0 0 0 + 0 1 1 0 1 1 0 0 1 0 1 0 0 1 1 0 0 0 1 1 + 0 1 0 1 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 + 0 0 1 1 1 0 0 0 0 0 1 0 0 1 1 0 1 1 1 1)) + ((equal i 31) '(0 0 0 1 + 0 1 0 0 0 0 1 0 1 0 0 1 0 0 1 0 1 0 0 1 + 0 1 1 0 0 1 1 1 0 0 0 0 1 0 1 0 0 0 0 0 + 1 1 1 0 0 1 1 0 1 1 1 0 0 1 1 1 0 0 0 0)) + ((equal i 32) '(0 0 1 0 + 0 1 1 1 1 0 1 1 0 1 1 1 0 0 0 0 1 0 1 0 + 1 0 0 0 0 1 0 1 0 1 0 0 0 1 1 0 1 1 0 1 + 0 0 1 0 0 0 1 0 1 1 1 1 1 1 1 1 1 1 0 0)) + ((equal i 33) '(0 0 1 0 + 1 1 1 0 0 0 0 1 1 0 1 1 0 0 1 0 0 0 0 1 + 0 0 1 1 1 0 0 0 0 1 0 1 1 1 0 0 0 0 1 0 + 0 1 1 0 1 1 0 0 1 0 0 1 0 0 1 0 0 1 1 0)) + ((equal i 34) '(0 1 0 0 + 1 1 0 1 0 0 1 0 1 1 0 0 0 1 1 0 1 1 0 1 + 1 1 1 1 1 1 0 0 0 1 0 1 1 0 1 0 1 1 0 0 + 0 1 0 0 0 0 1 0 1 0 1 0 1 1 1 0 1 1 0 1)) + ((equal i 35) '(0 1 0 1 + 0 0 1 1 0 0 1 1 1 0 0 0 0 0 0 0 1 1 0 1 + 0 0 0 1 0 0 1 1 1 0 0 1 1 1 0 1 1 0 0 1 + 0 1 0 1 1 0 1 1 0 0 1 1 1 1 0 1 1 1 1 1)) + ((equal i 36) '(0 1 1 0 + 0 1 0 1 0 0 0 0 1 0 1 0 0 1 1 1 0 0 1 1 + 0 1 0 1 0 1 0 0 1 0 0 0 1 0 1 1 1 0 1 0 + 1 1 1 1 0 1 1 0 0 0 1 1 1 1 0 1 1 1 1 0)) + ((equal i 37) '(0 1 1 1 + 0 1 1 0 0 1 1 0 1 0 1 0 0 0 0 0 1 0 1 0 + 1 0 1 1 1 0 1 1 0 0 1 1 1 1 0 0 0 1 1 1 + 0 1 1 1 1 0 1 1 0 0 1 0 1 0 1 0 1 0 0 0)) + ((equal i 38) '(1 0 0 0 + 0 0 0 1 1 1 0 0 0 0 1 0 1 1 0 0 1 0 0 1 + 0 0 1 0 1 1 1 0 0 1 0 0 0 1 1 1 1 1 1 0 + 1 1 0 1 1 0 1 0 1 1 1 0 1 1 1 0 0 1 1 0)) + ((equal i 39) '(1 0 0 1 + 0 0 1 0 0 1 1 1 0 0 1 0 0 0 1 0 1 1 0 0 + 1 0 0 0 0 1 0 1 0 0 0 1 0 1 0 0 1 0 0 0 + 0 0 1 0 0 0 1 1 0 1 0 1 0 0 1 1 1 0 1 1)) + ((equal i 40) '(1 0 1 0 + 0 0 1 0 1 0 1 1 1 1 1 1 1 1 1 0 1 0 0 0 + 1 0 1 0 0 0 0 1 0 1 0 0 1 1 0 0 1 1 1 1 + 0 0 0 1 0 0 0 0 0 0 1 1 0 1 1 0 0 1 0 0)) + ((equal i 41) '(1 0 1 0 + 1 0 0 0 0 0 0 1 1 0 1 0 0 1 1 0 0 1 1 0 + 0 1 0 0 1 0 1 1 1 0 1 1 1 1 0 0 0 1 0 0 + 0 0 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1)) + ((equal i 42) '(1 1 0 0 + 0 0 1 0 0 1 0 0 1 0 1 1 1 0 0 0 1 0 1 1 + 0 1 1 1 0 0 0 0 1 1 0 1 0 0 0 0 1 1 1 1 + 1 0 0 0 1 0 0 1 0 1 1 1 1 0 0 1 0 0 0 1)) + ((equal i 43) '(1 1 0 0 + 0 1 1 1 0 1 1 0 1 1 0 0 0 1 0 1 0 0 0 1 + 1 0 1 0 0 0 1 1 0 0 0 0 0 1 1 0 0 1 0 1 + 0 1 0 0 1 0 1 1 1 1 1 0 0 0 1 1 0 0 0 0)) + ((equal i 44) '(1 1 0 1 + 0 0 0 1 1 0 0 1 0 0 1 0 1 1 1 0 1 0 0 0 + 0 0 0 1 1 0 0 1 1 1 0 1 0 1 1 0 1 1 1 0 + 1 1 1 1 0 1 0 1 0 0 1 0 0 0 0 1 1 0 0 0)) + ((equal i 45) '(1 1 0 1 + 0 1 1 0 1 0 0 1 1 0 0 1 0 0 0 0 0 1 1 0 + 0 0 1 0 0 1 0 0 0 1 0 1 0 1 0 1 0 1 1 0 + 0 1 0 1 1 0 1 0 1 0 0 1 0 0 0 1 0 0 0 0)) + ((equal i 46) '(1 1 1 1 + 0 1 0 0 0 0 0 0 1 1 1 0 0 0 1 1 0 1 0 1 + 1 0 0 0 0 1 0 1 0 1 0 1 0 1 1 1 0 1 1 1 + 0 0 0 1 0 0 1 0 0 0 0 0 0 0 1 0 1 0 1 0)) + ((equal i 47) '(0 0 0 1 + 0 0 0 0 0 1 1 0 1 0 1 0 1 0 1 0 0 0 0 0 + 0 1 1 1 0 0 0 0 0 0 1 1 0 0 1 0 1 0 1 1 + 1 0 1 1 1 1 0 1 0 0 0 1 1 0 1 1 1 0 0 0)) + ((equal i 48) '(0 0 0 1 + 1 0 0 1 1 0 1 0 0 1 0 0 1 1 0 0 0 0 0 1 + 0 0 0 1 0 1 1 0 1 0 1 1 1 0 0 0 1 1 0 1 + 0 0 1 0 1 1 0 1 0 0 0 0 1 1 0 0 1 0 0 0)) + ((equal i 49) '(0 0 0 1 + 1 1 1 0 0 0 1 1 0 1 1 1 0 1 1 0 1 1 0 0 + 0 0 0 0 1 0 0 0 0 1 0 1 0 0 0 1 0 1 0 0 + 0 0 0 1 1 0 1 0 1 0 1 1 0 1 0 1 0 0 1 1)) + ((equal i 50) '(0 0 1 0 + 0 1 1 1 0 1 0 0 1 0 0 0 0 1 1 1 0 1 1 1 + 0 1 0 0 1 1 0 0 1 1 0 1 1 1 1 1 1 0 0 0 + 1 1 1 0 1 1 1 0 1 0 1 1 1 0 0 1 1 0 0 1)) + ((equal i 51) '(0 0 1 1 + 0 1 0 0 1 0 1 1 0 0 0 0 1 0 1 1 1 1 0 0 + 1 0 1 1 0 1 0 1 1 1 1 0 0 0 0 1 1 0 0 1 + 1 0 1 1 0 1 0 0 1 0 0 0 1 0 1 0 1 0 0 0)) + ((equal i 52) '(0 0 1 1 + 1 0 0 1 0 0 0 1 1 1 0 0 0 0 0 0 1 1 0 0 + 1 0 1 1 0 0 1 1 1 1 0 0 0 1 0 1 1 1 0 0 + 1 0 0 1 0 1 0 1 1 0 1 0 0 1 1 0 0 0 1 1)) + ((equal i 53) '(0 1 0 0 + 1 1 1 0 1 1 0 1 1 0 0 0 1 0 1 0 1 0 1 0 + 0 1 0 0 1 0 1 0 1 1 1 0 0 0 1 1 0 1 0 0 + 0 0 0 1 1 0 0 0 1 0 1 0 1 1 0 0 1 0 1 1)) + ((equal i 54) '(0 1 0 1 + 1 0 1 1 1 0 0 1 1 1 0 0 1 1 0 0 1 0 1 0 + 0 1 0 0 1 1 1 1 0 1 1 1 0 1 1 1 0 1 1 0 + 0 0 1 1 1 1 1 0 0 0 1 1 0 1 1 1 0 0 1 1)) + ((equal i 55) '(0 1 1 0 + 1 0 0 0 0 0 1 0 1 1 1 0 0 1 1 0 1 1 1 1 + 1 1 1 1 0 0 1 1 1 1 0 1 0 1 1 0 1 0 1 1 + 0 0 1 0 1 0 1 1 1 0 0 0 1 0 1 0 0 0 1 1)) + ((equal i 56) '(0 1 1 1 + 0 1 0 0 1 0 0 0 1 1 1 1 1 0 0 0 0 0 1 0 + 1 1 1 0 1 1 1 0 0 1 0 1 1 1 0 1 1 1 1 0 + 1 1 1 1 1 0 1 1 0 0 1 0 1 1 1 1 1 1 0 0)) + ((equal i 57) '(0 1 1 1 + 1 0 0 0 1 0 1 0 0 1 0 1 0 1 1 0 0 0 1 1 + 0 1 1 0 1 1 1 1 0 1 0 0 0 0 1 1 0 0 0 1 + 0 1 1 1 0 0 1 0 1 1 1 1 0 1 1 0 0 0 0 0)) + ((equal i 58) '(1 0 0 0 + 0 1 0 0 1 1 0 0 1 0 0 0 0 1 1 1 1 0 0 0 + 0 0 0 1 0 1 0 0 1 0 1 0 0 0 0 1 1 1 1 1 + 0 0 0 0 1 0 1 0 1 0 1 1 0 1 1 1 0 0 1 0)) + ((equal i 59) '(1 0 0 0 + 1 1 0 0 1 1 0 0 0 1 1 1 0 0 0 0 0 0 1 0 + 0 0 0 0 1 0 0 0 0 0 0 1 1 0 1 0 0 1 1 0 + 0 1 0 0 0 0 1 1 1 0 0 1 1 1 1 0 1 1 0 0)) + ((equal i 60) '(1 0 0 1 + 0 0 0 0 1 0 1 1 1 1 1 0 1 1 1 1 1 1 1 1 + 1 1 1 1 1 0 1 0 0 0 1 0 0 0 1 1 0 1 1 0 + 0 0 1 1 0 0 0 1 1 1 1 0 0 0 1 0 1 0 0 0)) + ((equal i 61) '(1 0 1 0 + 0 1 0 0 0 1 0 1 0 0 0 0 0 1 1 0 1 1 0 0 + 1 1 1 0 1 0 1 1 1 1 0 1 1 1 1 0 1 0 0 0 + 0 0 1 0 1 0 1 1 1 1 0 1 1 1 1 0 1 0 0 1)) + ((equal i 62) '(1 0 1 1 + 1 1 1 0 1 1 1 1 1 0 0 1 1 0 1 0 0 0 1 1 + 1 1 1 1 0 1 1 1 1 0 1 1 0 0 1 0 1 1 0 0 + 0 1 1 0 0 1 1 1 1 0 0 1 0 0 0 1 0 1 0 1)) + ((equal i 63) '(1 1 0 0 + 0 1 1 0 0 1 1 1 0 0 0 1 0 1 1 1 1 0 0 0 + 1 1 1 1 0 0 1 0 1 1 1 0 0 0 1 1 0 1 1 1 + 0 0 1 0 0 1 0 1 0 0 1 1 0 0 1 0 1 0 1 1)) + ((equal i 64) '(1 1 0 0 + 1 0 1 0 0 0 1 0 0 1 1 1 0 0 1 1 1 1 1 0 + 1 1 0 0 1 1 1 0 1 1 1 0 1 0 1 0 0 0 1 0 + 0 1 1 0 0 1 1 0 0 0 0 1 1 0 0 1 1 1 0 0)) + ((equal i 65) '(1 1 0 1 + 0 0 0 1 1 0 0 0 0 1 1 0 1 0 1 1 1 0 0 0 + 1 1 0 0 0 1 1 1 0 0 1 0 0 0 0 1 1 1 0 0 + 0 0 0 0 1 1 0 0 0 0 1 0 0 0 0 0 0 1 1 1)) + ((equal i 66) '(1 1 1 0 + 1 0 1 0 1 1 0 1 1 0 1 0 0 1 1 1 1 1 0 1 + 1 1 0 1 0 1 1 0 1 1 0 0 1 1 0 1 1 1 1 0 + 0 0 0 0 1 1 1 0 1 0 1 1 0 0 0 1 1 1 1 0)) + ((equal i 67) '(1 1 1 1 + 0 1 0 1 0 1 1 1 1 1 0 1 0 1 0 0 1 1 1 1 + 0 1 1 1 1 1 1 1 1 1 1 0 1 1 1 0 0 1 1 0 + 1 1 1 0 1 1 0 1 0 0 0 1 0 1 1 1 1 0 0 0)) + ((equal i 68) '(0 0 0 0 + 0 1 1 0 1 1 1 1 0 0 0 0 0 1 1 0 0 1 1 1 + 1 0 1 0 1 0 1 0 0 1 1 1 0 0 1 0 0 0 0 1 + 0 1 1 1 0 1 1 0 1 1 1 1 1 0 1 1 1 0 1 0)) + ((equal i 69) '(0 0 0 0 + 1 0 1 0 0 1 1 0 0 0 1 1 0 1 1 1 1 1 0 1 + 1 1 0 0 0 1 0 1 1 0 1 0 0 0 1 0 1 1 0 0 + 1 0 0 0 1 0 0 1 1 0 0 0 1 0 1 0 0 1 1 0)) + ((equal i 70) '(0 0 0 1 + 0 0 0 1 0 0 1 1 1 1 1 1 1 0 0 1 1 0 0 0 + 0 0 0 0 0 1 0 0 1 0 1 1 1 1 1 0 1 1 1 1 + 1 0 0 1 0 0 0 0 1 1 0 1 1 0 1 0 1 1 1 0)) + ((equal i 71) '(0 0 0 1 + 1 0 1 1 0 1 1 1 0 0 0 1 0 0 0 0 1 0 1 1 + 0 0 1 1 0 1 0 1 0 0 0 1 0 0 1 1 0 0 0 1 + 1 1 0 0 0 1 0 0 0 1 1 1 0 0 0 1 1 0 1 1)) + ((equal i 72) '(0 0 1 0 + 1 0 0 0 1 1 0 1 1 0 1 1 0 1 1 1 0 1 1 1 + 1 1 1 1 0 1 0 1 0 0 1 0 0 0 1 1 0 0 0 0 + 0 1 0 0 0 1 1 1 1 1 0 1 1 0 0 0 0 1 0 0)) + ((equal i 73) '(0 0 1 1 + 0 0 1 0 1 1 0 0 1 0 1 0 1 0 1 0 1 0 1 1 + 0 1 1 1 1 0 1 1 0 1 0 0 0 0 0 0 1 1 0 0 + 0 1 1 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 1)) + ((equal i 74) '(0 0 1 1 + 1 1 0 0 1 0 0 1 1 1 1 0 1 0 1 1 1 1 1 0 + 0 0 0 0 1 0 1 0 0 0 0 1 0 1 0 1 1 1 0 0 + 1 0 0 1 1 0 1 1 1 1 1 0 1 0 1 1 1 1 0 0)) + ((equal i 75) '(0 1 0 0 + 0 0 1 1 0 0 0 1 1 1 0 1 0 1 1 0 0 1 1 1 + 1 1 0 0 0 1 0 0 1 0 0 1 1 1 0 0 0 0 0 1 + 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 0 1 1 0 0)) + ((equal i 76) '(0 1 0 0 + 1 1 0 0 1 1 0 0 0 1 0 1 1 1 0 1 0 1 0 0 + 1 0 1 1 1 1 1 0 1 1 0 0 1 0 1 1 0 0 1 1 + 1 1 1 0 0 1 0 0 0 0 1 0 1 0 1 1 0 1 1 0)) + ((equal i 77) '(0 1 0 1 + 1 0 0 1 0 1 1 1 1 1 1 1 0 0 1 0 1 0 0 1 + 1 0 0 1 1 1 0 0 1 1 1 1 1 1 0 0 0 1 1 0 + 0 1 0 1 0 1 1 1 1 1 1 0 0 0 1 0 1 0 1 0)) + ((equal i 78) '(0 1 0 1 + 1 1 1 1 1 1 0 0 1 0 1 1 0 1 1 0 1 1 1 1 + 1 0 1 0 1 0 1 1 0 0 1 1 1 0 1 0 1 1 0 1 + 0 1 1 0 1 1 1 1 1 0 1 0 1 1 1 0 1 1 0 0)) + ((equal i 79) '(0 1 1 0 + 1 1 0 0 0 1 0 0 0 1 0 0 0 0 0 1 1 0 0 1 + 1 0 0 0 1 1 0 0 0 1 0 0 1 0 1 0 0 1 0 0 + 0 1 1 1 0 1 0 1 1 0 0 0 0 0 0 1 0 1 1 1)) + (t nil))) + + +(defthm wordp-K-512 +(implies (and (integerp i) (<= 0 i) (<= i 79)) + (wordp (k-512 i) 64))) + + +; initial hash values for sha-384 +(defun h-384() +'((1 1 0 0 + 1 0 1 1 1 0 1 1 1 0 1 1 1 0 0 1 1 1 0 1 + 0 1 0 1 1 1 0 1 1 1 0 0 0 0 0 1 0 0 0 0 + 0 1 0 1 1 0 0 1 1 1 1 0 1 1 0 1 1 0 0 0) +(0 1 1 0 + 0 0 1 0 1 0 0 1 1 0 1 0 0 0 1 0 1 0 0 1 + 0 0 1 0 1 0 1 0 0 0 1 1 0 1 1 0 0 1 1 1 + 1 1 0 0 1 1 0 1 0 1 0 1 0 0 0 0 0 1 1 1) +(1 0 0 1 + 0 0 0 1 0 1 0 1 1 0 0 1 0 0 0 0 0 0 0 1 + 0 1 0 1 1 0 1 0 0 0 1 1 0 0 0 0 0 1 1 1 + 0 0 0 0 1 1 0 1 1 1 0 1 0 0 0 1 0 1 1 1) +(0 0 0 1 + 0 1 0 1 0 0 1 0 1 1 1 1 1 1 1 0 1 1 0 0 + 1 1 0 1 1 0 0 0 1 1 1 1 0 1 1 1 0 0 0 0 + 1 1 1 0 0 1 0 1 1 0 0 1 0 0 1 1 1 0 0 1) +(0 1 1 0 + 0 1 1 1 0 0 1 1 0 0 1 1 0 0 1 0 0 1 1 0 + 0 1 1 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 + 0 0 0 0 0 0 0 0 1 0 1 1 0 0 1 1 0 0 0 1) +(1 0 0 0 + 1 1 1 0 1 0 1 1 0 1 0 0 0 1 0 0 1 0 1 0 + 1 0 0 0 0 1 1 1 0 1 1 0 1 0 0 0 0 1 0 1 + 1 0 0 0 0 0 0 1 0 1 0 1 0 0 0 1 0 0 0 1) +(1 1 0 1 + 1 0 1 1 0 0 0 0 1 1 0 0 0 0 1 0 1 1 1 0 + 0 0 0 0 1 1 0 1 0 1 1 0 0 1 0 0 1 1 1 1 + 1 0 0 1 1 0 0 0 1 1 1 1 1 0 1 0 0 1 1 1) +(0 1 0 0 + 0 1 1 1 1 0 1 1 0 1 0 1 0 1 0 0 1 0 0 0 + 0 0 0 1 1 1 0 1 1 0 1 1 1 1 1 0 1 1 1 1 + 1 0 1 0 0 1 0 0 1 1 1 1 1 0 1 0 0 1 0 0)) +) + +(defthm wordp-h-384 + (and (wvp (h-384) 64) (equal (len (h-384)) 8 ))) + + +; initial hash values for sha-512 +(defun h-512() +'((0 1 1 0 + 1 0 1 0 0 0 0 0 1 0 0 1 1 1 1 0 0 1 1 0 + 0 1 1 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 + 1 1 0 0 1 1 0 0 1 0 0 1 0 0 0 0 1 0 0 0) +(1 0 1 1 + 1 0 1 1 0 1 1 0 0 1 1 1 1 0 1 0 1 1 1 0 + 1 0 0 0 0 1 0 1 1 0 0 0 0 1 0 0 1 1 0 0 + 1 0 1 0 1 0 1 0 0 1 1 1 0 0 1 1 1 0 1 1) +(0 0 1 1 + 1 1 0 0 0 1 1 0 1 1 1 0 1 1 1 1 0 0 1 1 + 0 1 1 1 0 0 1 0 1 1 1 1 1 1 1 0 1 0 0 1 + 0 1 0 0 1 1 1 1 1 0 0 0 0 0 1 0 1 0 1 1) +(1 0 1 0 + 0 1 0 1 0 1 0 0 1 1 1 1 1 1 1 1 0 1 0 1 + 0 0 1 1 1 0 1 0 0 1 0 1 1 1 1 1 0 0 0 1 + 1 1 0 1 0 0 1 1 0 1 1 0 1 1 1 1 0 0 0 1) +(0 1 0 1 + 0 0 0 1 0 0 0 0 1 1 1 0 0 1 0 1 0 0 1 0 + 0 1 1 1 1 1 1 1 1 0 1 0 1 1 0 1 1 1 1 0 + 0 1 1 0 1 0 0 0 0 0 1 0 1 1 0 1 0 0 0 1) +(1 0 0 1 + 1 0 1 1 0 0 0 0 0 1 0 1 0 1 1 0 1 0 0 0 + 1 0 0 0 1 1 0 0 0 0 1 0 1 0 1 1 0 0 1 1 + 1 1 1 0 0 1 1 0 1 1 0 0 0 0 0 1 1 1 1 1) +(0 0 0 1 + 1 1 1 1 1 0 0 0 0 0 1 1 1 1 0 1 1 0 0 1 + 1 0 1 0 1 0 1 1 1 1 1 1 1 0 1 1 0 1 0 0 + 0 0 0 1 1 0 1 1 1 1 0 1 0 1 1 0 1 0 1 1) +(0 1 0 1 + 1 0 1 1 1 1 1 0 0 0 0 0 1 1 0 0 1 1 0 1 + 0 0 0 1 1 0 0 1 0 0 0 1 0 0 1 1 0 1 1 1 + 1 1 1 0 0 0 1 0 0 0 0 1 0 1 1 1 1 0 0 1)) +) + +(defthm wordp-h-512 + (and (wvp (h-512) 64) (equal (len (h-512)) 8 ))) + + +;----sha-512 + +(defun prepare-512-ac ( j m-i) +(declare (xargs :measure (acl2-count (- 80 j)))) + (if (and (integerp j) (<= 16 j) (wvp m-i 64)) + (cond ((<= 80 j) m-i) + ((<= j 79) + (prepare-512-ac (1+ j) + (append m-i (list (plus 64 (s-1-512 (nth (- j 2) m-i)) + (nth (- j 7) m-i) + (s-0-512 (nth (- j 15) m-i)) + (nth (- j 16) m-i))))))) + nil)) + + +(defun prepare-512 (m-i) + (if (wordp m-i 1024) + (prepare-512-ac 16 (parsing m-i 64)) + nil)) + + +(defthm wvp-prepare-512-ac + (implies (and (integerp j) (<= 16 j) (wvp m 64)) + (wvp (prepare-512-ac j m) 64)) +:hints (("goal" :in-theory (disable s-1-512 s-0-512 nth binary-plus )))) + + +(defthm len-prepare-512-ac + (implies (and (wvp m 64) (integerp j) (<= 16 j) (<= j (len m) )) + (equal (len (prepare-512-ac j m)) + (if (<= j 80) + (+ (- 80 j) (len m)) + (len m)))) +:hints (("goal" :in-theory (disable s-1-512 s-0-512 nth binary-plus )))) + + +(defthm wvp-prepare-512 + (implies (wordp m 1024) + (wvp (prepare-512 m) 64)) +:hints (("goal" :in-theory (disable prepare-512-ac )))) + + +(defthm len-prepare-512 + (implies (wordp m 1024) + (equal (len (prepare-512 m)) 80)) +:hints (("goal" :in-theory (disable prepare-512-ac)))) + + +(defun temp-1-512 (j working-variables m-i-ext) + (if (and (equal (len working-variables) 8) (wvp working-variables 64) + (integerp j) (<= 0 j) + (wvp m-i-ext 64) (equal (len m-i-ext) 80)) + (plus 64 (nth 7 working-variables) + (sigma-1-512 (nth 4 working-variables)) + (Ch (nth 4 working-variables) + (nth 5 working-variables) + (nth 6 working-variables)) + (k-512 j) + (nth j m-i-ext) ) + nil)) + + +(defthm wordp-temp-1-512 + (implies (and (wvp l 64) (equal (len l) 8) + (integerp j) (<= 0 j) (< j 80) + (wvp m 64) (equal (len m) 80)) + (wordp (temp-1-512 j l m ) 64)) +:hints +(("goal" + :in-theory (disable sigma-1-512 ch k-512 nth binary-plus wordp )))) + + +(defun temp-2-512 ( working-variables ) + (if (and (equal (len working-variables) 8) (wvp working-variables 64)) + (plus 64 (sigma-0-512 (nth 0 working-variables)) + (Maj (nth 0 working-variables) + (nth 1 working-variables) + (nth 2 working-variables)) ) + nil)) + + +(defthm wordp-temp-2-512 + (implies (and (wvp l 64) (equal (len l) 8)) + (wordp (temp-2-512 l ) 64)) +:hints (("goal" :in-theory (disable sigma-0-512 maj binary-plus nth )))) + + +(defun digest-one-block-512-ac ( j working-variables m-i-ext) +(declare (xargs :measure (acl2-count (- 80 j)))) + (if (and (equal (len working-variables) 8) (wvp working-variables 64) + (integerp j) (<= 0 j) + (wvp m-i-ext 64) (equal (len m-i-ext) 80)) + (if (<= 80 j) + working-variables + (digest-one-block-512-ac (+ 1 j) + (list (plus 64 (temp-1-512 j working-variables m-i-ext) + (temp-2-512 working-variables )) + (nth 0 working-variables) + (nth 1 working-variables) + (nth 2 working-variables) + (plus 64 (nth 3 working-variables) + (temp-1-512 j working-variables m-i-ext) ) + (nth 4 working-variables) + (nth 5 working-variables) + (nth 6 working-variables)) + m-i-ext) ) + nil)) + + +(defun digest-one-block-512 (hash-values m-i-ext) + (if (and (wvp hash-values 64) (equal (len hash-values) 8) + (wvp m-i-ext 64) (equal (len m-i-ext) 80)) + (digest-one-block-512-ac 0 hash-values m-i-ext) + nil)) + + +(defthm wvp-digest-one-block-512-ac + (implies (and (wvp l 64) (equal (len l) 8) + (integerp j) (<= 0 j) + (wvp m 64) (equal (len m) 80)) + (wvp (digest-one-block-512-ac j l m ) 64)) +:hints (("goal" :in-theory (disable temp-1-512 temp-2-512 nth binary-plus)))) + + +(defthm len-digest-one-block-512-ac + (implies (and (wvp l 64) (equal (len l) 8) + (integerp j) (<= 0 j) + (wvp m 64) (equal (len m) 80)) + (equal (len (digest-one-block-512-ac j l m )) 8)) +:hints (("goal" :in-theory (disable temp-1-512 temp-2-512 nth binary-plus )))) + + +(defthm wvp-digest-one-block-512 + (implies (and (wvp l 64) (equal (len l) 8) + (wvp m 64) (equal (len m) 80)) + (wvp (digest-one-block-512 l m ) 64)) +:hints +(("goal" + :in-theory (disable digest-one-block-512-ac)))) + + +(defthm len-digest-one-block-512 + (implies (and (wvp l 64) (equal (len l) 8) + (wvp m 64) (equal (len m) 80)) + (equal (len (digest-one-block-512 l m )) 8)) +:hints +(("goal" + :in-theory (disable digest-one-block-512-ac )))) + + +(defun intermediate-hash-512 ( l1 l2) + (if (and (wvp l1 64) (equal (len l1) 8) + (wvp l2 64) (equal (len l2) 8) ) + (list (plus 64 (nth 0 l1) (nth 0 l2) ) + (plus 64 (nth 1 l1) (nth 1 l2) ) + (plus 64 (nth 2 l1) (nth 2 l2) ) + (plus 64 (nth 3 l1) (nth 3 l2) ) + (plus 64 (nth 4 l1) (nth 4 l2) ) + (plus 64 (nth 5 l1) (nth 5 l2) ) + (plus 64 (nth 6 l1) (nth 6 l2) ) + (plus 64 (nth 7 l1) (nth 7 l2) )) + nil)) + + +(defthm wvp-intermediate-hash-512 + (implies (and (wvp l1 64) (equal (len l1) 8) + (wvp l2 64) (equal (len l2) 8) ) + (wvp (intermediate-hash-512 l1 l2 ) 64)) +:hints (("goal" :in-theory (disable binary-plus wordp nth )))) + + +(defthm len-intermediate-hash-512 + (implies (and (wvp l1 64) (equal (len l1) 8) + (wvp l2 64) (equal (len l2) 8) ) + (equal (len (intermediate-hash-512 l1 l2 )) 8))) + + +(defun digest-512 ( m hash-values) + (if (and (wvp m 1024) (wvp hash-values 64) (equal (len hash-values) 8) ) + (if (endp m) hash-values + (digest-512 (cdr m) + (intermediate-hash-512 hash-values + (digest-one-block-512 hash-values + (prepare-512 (car m) ))))) + nil) ) + + +(defthm wvp-digest-512 + (implies (and (wvp m 1024) (wvp hash-values 64) + (equal (len hash-values) 8)) + (wvp (digest-512 m hash-values ) 64) ) +:hints +(("goal" + :in-theory (disable intermediate-hash-512 + digest-one-block-512 prepare-512 )))) + + +(defthm len-digest-512 + (implies (and (wvp m 1024) (wvp hash-values 64) (not (endp m)) + (equal (len hash-values) 8)) + (equal (len (digest-512 m hash-values )) 8) ) +:hints +(("goal" + :in-theory (disable intermediate-hash-512 + digest-one-block-512 prepare-512 )))) + + +(defun sha-512 ( m) + (if (and (bvp m) (< (len m) (expt 2 128))) + (digest-512 (parsing (padding-512 m) 1024) (h-512)) + nil)) + + +(defthm wvp-sha-512 +(implies (and (bvp m) (< (len m) (expt 2 128))) + (wvp (sha-512 m) 64) ) +:hints(("goal" :in-theory (disable digest-512 parsing padding-512)))) + + +(defthm len-sha-512 +(implies (and (bvp m) (< (len m) (expt 2 128))) + (equal (len (sha-512 m)) 8 )) +:hints +(("goal" + :use (:instance len-digest-512 (m (parsing (padding-512 m) 1024)) + (hash-values (h-512))) + :in-theory (disable digest-512 parsing padding-512)))) + + +; sha-384 + +(defun sha-384 ( m) + (if (bvp m) + (let ((res (digest-512 (parsing (padding-512 m) 1024) (h-384)))) + (list (nth 0 res) + (nth 1 res) + (nth 2 res) + (nth 3 res) + (nth 4 res) + (nth 5 res) )) + nil)) + + +(defthm wvp-sha-384 +(implies (and (bvp m) (< (len m) (expt 2 128))) + (wvp (sha-384 m) 64) ) +:hints +(("goal" + :in-theory (disable digest-512 parsing padding-512 wordp nth) + :use (:instance len-digest-512 (m (parsing (padding-512 m) 1024)) + (hash-values (h-384)))))) + + +(defthm len-sha-384 +(implies (and (bvp m) (< (len m) (expt 2 128))) + (equal (len (sha-384 m)) 6 )) +:hints +(("goal" + :use (:instance len-digest-512 (m (parsing (padding-512 m) 1024)) + (hash-values (h-384))) + :in-theory (disable digest-512 parsing padding-512))))
\ No newline at end of file diff --git a/books/workshops/2003/toma-borrione/support/sha-functions.lisp b/books/workshops/2003/toma-borrione/support/sha-functions.lisp new file mode 100644 index 0000000..520f444 --- /dev/null +++ b/books/workshops/2003/toma-borrione/support/sha-functions.lisp @@ -0,0 +1,164 @@ +;------------------------------------------ +; +; Author: Diana Toma +; TIMA-VDS, Grenoble, France +; March 2003 +; ACL2 formalization of SHAs +; Logic functions (and theorems) needed for all four SHA +;------------------------------------------ + + + +(IN-PACKAGE "ACL2") + +(include-book "bv-op-defthms") + + +;logic functions for SHAs + +(defun Ch (x y z) + (if (and (bvp x) + (bvp y) + (bvp z)) + (bv-xor (bv-and x y) (bv-and (bv-not x) z)) + nil)) + +(defthm bvp-Ch + (implies (and (bvp x) (bvp y) (bvp z)) + (bvp (Ch x y z)))) + +(defthm wordp-Ch + (implies (and (wordp x w) (wordp y w) (wordp z w)) + (wordp (Ch x y z) w))) + + +(defun Parity (x y z) + (if (and (bvp x) + (bvp y) + (bvp z)) + (bv-xor x y z) + nil)) + +(defthm bvp-Parity + (implies (and (bvp x) (bvp y) (bvp z)) + (bvp (Parity x y z)))) + +(defthm wordp-Parity + (implies (and (wordp x w) (wordp y w) (wordp z w)) + (wordp (Parity x y z) w))) + +(defun Maj (x y z) + (if (and (bvp x) + (bvp y) + (bvp z)) + (bv-xor (bv-and x y) (bv-and x z) (bv-and y z)) + nil)) + +(defthm bvp-Maj + (implies (and (bvp x) (bvp y) (bvp z)) + (bvp (Maj x y z)))) + +(defthm wordp-Maj + (implies (and (wordp x w) (wordp y w) (wordp z w)) + (wordp (Maj x y z) w))) + +(defun Ft (i x y z) + (if (and (integerp i) + (<= 0 i) + (wordp x 32) + (wordp y 32) + (wordp z 32)) + (cond ((and (<= 0 i) (<= i 19)) + (Ch x y z)) + ((or (and (<= 20 i) (<= i 39)) (and (<= 60 i) (<= i 79))) + (Parity x y z)) + ((and (<= 40 i) (<= i 59)) + (Maj x y z))) + nil)) + +(defthm wordp-Ft + (implies (and (integerp i) (<= 0 i) (wordp x 32) (<= 0 i) (< i 80) + (wordp y 32) (wordp z 32)) + (wordp (Ft i x y z) 32)) +:hints (("goal" :in-theory (disable ch parity maj) ))) + +(defun sigma-0-256 (x) + (if (wordp x 32) + (bv-xor (rotr 2 x 32) (rotr 13 x 32) (rotr 22 x 32)) + nil)) + + +(defthm wordp-sigma-0-256 +(implies (wordp x 32) + ( wordp (sigma-0-256 x) 32)) +:hints (("goal" :in-theory (disable binary-bv-xor rotr rotr->rotl )))) + +(defun sigma-1-256 (x) + (if (wordp x 32) + (bv-xor (rotr 6 x 32) (rotr 11 x 32) (rotr 25 x 32)) + nil)) + +(defthm wordp-sigma-1-256 +(implies (wordp x 32) + ( wordp (sigma-1-256 x) 32)) +:hints (("goal" :in-theory (disable binary-bv-xor rotr rotr->rotl )))) + +(defun s-0-256 (x) + (if (wordp x 32) + (bv-xor (rotr 7 x 32) (rotr 18 x 32) (shr 3 x 32)) + nil)) + +(defthm wordp-s-0-256 +(implies (wordp x 32) + ( wordp (s-0-256 x) 32)) +:hints (("goal" :in-theory (disable binary-bv-xor rotr rotr->rotl shr )))) + +(defun s-1-256 (x) + (if (wordp x 32) + (bv-xor (rotr 17 x 32) (rotr 19 x 32) (shr 10 x 32)) + nil)) + +(defthm wordp-s-1-256 +(implies (wordp x 32) + ( wordp (s-1-256 x) 32)) +:hints (("goal" :in-theory (disable binary-bv-xor rotr rotr->rotl shr )))) + +(defun sigma-0-512 (x) + (if (wordp x 64) + (bv-xor (rotr 28 x 64) (rotr 34 x 64) (rotr 39 x 64)) + nil)) + +(defthm wordp-sigma-0-512 +(implies (wordp x 64) + ( wordp (sigma-0-512 x) 64)) +:hints (("goal" :in-theory (disable binary-bv-xor rotr rotr->rotl )))) + +(defun sigma-1-512 (x) + (if (wordp x 64) + (bv-xor (rotr 14 x 64) (rotr 18 x 64) (rotr 41 x 64)) + nil)) + +(defthm wordp-sigma-1-512 +(implies (wordp x 64) + ( wordp (sigma-1-512 x) 64)) +:hints (("goal" :in-theory (disable binary-bv-xor rotr rotr->rotl )))) + +(defun s-0-512 (x) + (if (wordp x 64) + (bv-xor (rotr 1 x 64) (rotr 8 x 64) (shr 7 x 64)) + nil)) + +(defthm wordp-s-0-512 +(implies (wordp x 64) + ( wordp (s-0-512 x) 64)) +:hints (("goal" :in-theory (disable binary-bv-xor rotr rotr->rotl shr )))) + +(defun s-1-512 (x) + (if (wordp x 64) + (bv-xor (rotr 19 x 64) (rotr 61 x 64) (shr 6 x 64)) + nil)) + +(defthm wordp-s-1-512 +(implies (wordp x 64) + ( wordp (s-1-512 x) 64)) +:hints (("goal" :in-theory (disable binary-bv-xor rotr rotr->rotl shr )))) diff --git a/books/workshops/2003/tsong/shim.pdf.gz b/books/workshops/2003/tsong/shim.pdf.gz Binary files differnew file mode 100644 index 0000000..65561ec --- /dev/null +++ b/books/workshops/2003/tsong/shim.pdf.gz diff --git a/books/workshops/2003/tsong/shim.ps.gz b/books/workshops/2003/tsong/shim.ps.gz Binary files differnew file mode 100644 index 0000000..3dd3b9f --- /dev/null +++ b/books/workshops/2003/tsong/shim.ps.gz diff --git a/books/workshops/2003/tsong/support/shim.lisp b/books/workshops/2003/tsong/support/shim.lisp new file mode 100644 index 0000000..e57b8b8 --- /dev/null +++ b/books/workshops/2003/tsong/support/shim.lisp @@ -0,0 +1,1886 @@ +(IN-PACKAGE "ACL2") +(include-book "../../../../data-structures/structures") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; tools function +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun ith(i a) + (declare (xargs :guard (and (integerp i) (> i 0)))) + ( cond ((atom a) nil) + ((zp (- i 1)) (car a)) + ((ith (- i 1) (cdr a))) + ) +) +(defun strlistp (strlist) + ( if (endp strlist) t + (and + (stringp (car strlist)) + (strlistp (cdr strlist)) + ) + ) +) +(defun strmem(str strlist) + (if (strlistp strlist) + ( + if (endp strlist) + nil + (or (string-equal str (car strlist)) (strmem str (cdr strlist))) + ) + nil + ) +) +(defun InPath(pathin pathsrc) +(cond ((endp pathsrc) t) + ((and (endp pathin)(not (endp pathsrc))) nil) + ((not (equal (car pathin)(car pathsrc))) nil) + ((equal (car pathin) (car pathsrc)) (InPath(cdr pathin)(cdr pathsrc))) +) +) + +(defun path-equal (path1 path2) +(cond ((and (endp path1)(endp path2)) t) + ((and (endp path1)(not (endp path2))) nil) + ((and (endp path2)(not (endp path1))) nil) + ((not (equal (car path1)(car path2))) nil) + ((equal (car path1) (car path2)) (path-equal(cdr path1)(cdr path2))) +) +) +(defun path-append (path1 path2) +(append path1 path2) +) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; formalizaion of log data +; +;log record: ((prog ruid pid euid egid) +; (name ouid ogid pmode inodeid) +; (syscall flags) +; (newowner, newmode, newpath, chpid))...... +;pmode: ((r w x)(r w x)(r w x)(dir reg socket pipe)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| +(defun natp(x) + (and (<= 0 x) + (integerp x)) +) +|# + +(defstructure proc-obj + prog + (ruid (:assert (integerp ruid))) + (pid (:assert (integerp pid))) + (euid (:assert (integerp euid))) + (egid (:assert (integerp egid))) +) + +(defstructure rwx-obj + r + w + x +) +(defstructure attr-obj + (dir (:assert (integerp dir))) + (reg (:assert (integerp reg))) + (socket (:assert (integerp socket))) + (pipe (:assert (integerp pipe))) +) +(defstructure pmode-obj + (umode (:assert (and (consp umode)(rwx-obj-p umode)) )) + (gmode (:assert (and (consp gmode)(rwx-obj-p gmode)))) + (amode (:assert (and (consp amode)(rwx-obj-p amode)))) + (attr (:assert (and (consp attr)(attr-obj-p attr)))) +) +(defstructure file-obj + (name (:assert (consp name))) + (ouid (:assert (integerp ouid))) + (ogid (:assert (integerp ogid))) + (pmode (:assert (pmode-obj-p pmode))) + (inodeid (:assert (integerp inodeid))) + ) +(defstructure syscall-obj + callname + flags +) +(defstructure newattr-obj + newowner + newmode + newpath + chpid +) +(defstructure logrec + (pobj (:assert (and (consp pobj)(proc-obj-p pobj)))) + (fobj (:assert (and (consp fobj)(file-obj-p fobj)))) + (callobj (:assert (and (consp callobj)(syscall-obj-p callobj)))) + (newattrobj (:assert (newattr-obj-p newattrobj))) +) + + +(defun logp (log) + (if (endp log) t + (and (logrec-p (car log)) + (consp (car log)) + (logp (cdr log)))) + ) + + +(defun getsyscall (logrec) + (logrec-callobj logrec) + ) + + +(defun getcallname (logrec) + (syscall-obj-callname (logrec-callobj logrec)) + ) + +(defun getcallflag (logrec) + (syscall-obj-flags (logrec-callobj logrec)) + ) + +(defun getproc (logrec) + (logrec-pobj logrec) + ) + + +(defun getprocname (logrec) + ( proc-obj-prog(logrec-pobj logrec)) + ) + +(defun getprocruid (logrec) + (proc-obj-ruid (logrec-pobj logrec)) + ) + +(defun getprocpid (logrec) + (proc-obj-pid (logrec-pobj logrec)) + ) + +(defun getproceuid (logrec) + (proc-obj-euid (logrec-pobj logrec)) + ) + +(defun getprocegid (logrec) + (proc-obj-egid (logrec-pobj logrec))) +; ) ; extra paren removed by Matt K. + + + (defun getfile (logrec) + (logrec-fobj logrec) + ) + + ;(filep '(/home/tsong/file 23 2 ((1 1 0) (1 0 0) (1 0 0)) 23021)) + (defun getfilename ( fileobj) + (file-obj-name fileobj) + ) + (defun getfileouid( fileobj) + (file-obj-ouid fileobj) + ) + (defun getfileogid( fileobj) + (file-obj-ogid fileobj) + ) + (defun getfilemode( fileobj) + (file-obj-pmode fileobj) + ) + (defun getinodeid( fileobj) + (file-obj-inodeid fileobj) + ) + (defun getreg(fileobj) + (attr-obj-reg(pmode-obj-attr(file-obj-pmode fileobj))) + ) + (defun getsocket( fileobj) + (attr-obj-socket(pmode-obj-attr(file-obj-pmode fileobj))) + ) + (defun getpipe( fileobj) + (attr-obj-pipe(pmode-obj-attr(file-obj-pmode fileobj))) + ) + ;(file-obj-pmode '(/home/tsong/file 23 2 ((1 1 0) (1 0 0) (1 0 0)) 23021)) + + + ;(newprop '(0 ((1 1 0) (1 0 0) (1 0 0)) /root/file 4108)) + + ;(logrecp '((ftpd 23 3405 0 0) (/home/tsong/file 23 2 ((1 1 0) (1 0 0) (1 0 0))23021) (open r))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; formalization of system +; +;log: ((prog ruid pid euid egid) (name ouid ogid pmode inodeid)(syscall flags) (newowner, newmode, newpath, chpid))...... +;system:(((pname pdir)...)((callname)..)((dir ouid ogid pmode inodeid)...)((uid uname gid homedir)...)((envname envvalue)...)) +;(((ftp "/bin/ftp")(lpr "/bin/lpr"))((create)(open)(read)(write)(chmod)(chown))(("/bin/ftp" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1001)("/bin/lpr" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1002)("/home/tsong/" 23 2 ((1 1 1)(0 0 1)(0 0 1))))((0 root "/") (23 tsong "/home/tsong")) ((printpool "/temp/print")(printdir "/temp/print"))) +;system: (proclist calllist filelist userlist envlist) +;proclist:((pname pdir)...) +;calllist:((callname)...) +;filelist:((dir ouid ogid pmode inodeid)...) +;pmode: ((r w x)(r w x)(r w x)(dir reg socket pipe)) +;userlist:((uid uname gid homedir)...) +;envlist:((envname envvalue)...) +;(((ftp "/bin/ftp")(lpr "/bin/lpr"))((create)(open)(read)(write)(chmod)(chown))(("/bin/ftp" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1001)("/bin/lpr" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1002)("/home/tsong/" 23 2 ((1 1 1)(0 0 1)(0 0 1))))((0 root "/") (23 tsong "/home/tsong")) ((printpool "/temp/print")(printdir "/temp/print"))) +; +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + (defstructure prog-obj + pname + pdir + ) + (defstructure call-obj + callname + ) + (defstructure user-obj + uid + uname + gid + (homedir (:assert (consp homedir))) + ) + (defstructure env-obj + envname + envvalue + ) + + (defun filelistp (filelist) + (if (endp filelist) t + (and + (and (consp (car filelist))(file-obj-p (car filelist))) + (filelistp (cdr filelist)) + ) + ) + ) + + (defun proglistp (proclist) + (if (endp proclist) t + (and + (and (consp (car proclist))(prog-obj-p (car proclist))) + (proglistp (cdr proclist)) + ) + ) + ) + + (defun calllistp (calllist) + (if (endp calllist) t + (and + (and (consp (car calllist))(call-obj-p (car calllist))) + (calllistp (cdr calllist)) + ) + ) + ) + (defun userlistp (userlist) + (if (endp userlist) t + (and + (and (consp (car userlist))(user-obj-p (car userlist))) + (userlistp (cdr userlist)) + ) + ) + ) + + (defun envlistp (envlist) + (if (endp envlist) t + (and + (and (consp (car envlist))(env-obj-p (car envlist))) + (envlistp (cdr envlist)) + ) + ) + ) + + (defstructure sys + (proglist (:assert (and (not (endp proglist))(proglistp proglist)))) + (calllist (:assert (and (not (endp calllist))(calllistp calllist)))) + (filelist (:assert (and (not (endp filelist))(filelistp filelist)))) + (userlist (:assert (and (not (endp userlist))(userlistp userlist)))) + (envlist (:assert (and (not (endp envlist))(envlistp envlist)))) + ) + + +;(proclistp '((ftp "/bin/ftp")(lpr "/bin/lpr"))) +;(calllistp '((create)(open)(read)(write)(chmod)(chown))) +;(filelistp '(("/bin/ftp" 0 0 ((1 1 1)(0 0 1)(0 0 1)(0 0 0 0)) 1001)("/bin/lpr" 0 0 ((1 1 1)(0 0 1)(0 0 1)(0 0 0 0)) 1002)("/home/tsong/" 23 2 ((1 1 1)(0 0 1)(0 0 1)(0 0 0 0)) 1003))) +;(userlistp '((0 root "/") (23 tsong "/home/tsong"))) +;(envlistp '((printpool "/temp/print")(printdir "/temp/print"))) +;(sys-p '(((ftp "/bin/ftp")(lpr "/bin/lpr"))((create)(open)(read)(write)(chmod)(chown))(("/bin/ftp" 0 0 ((1 1 1)(0 0 1)(0 0 1)(0 0 0 0)) 1001)("/bin/lpr" 0 0 ((1 1 1)(0 0 1)(0 0 1)(0 0 0 0)) 1002)("/home/tsong/" 23 2 ((1 1 1)(0 0 1)(0 0 1)(0 0 0 0)) 1003))((0 root 0 "/") (23 tsong 2 "/home/tsong")) ((printpool "/temp/print")(printdir "/temp/print")))) +;(((ftpd)())()()()()) + (defun getproclist (sys) + (sys-proglist sys) + ) + (defun getcalllist (sys) + (sys-calllist sys) + ) + (defun getfilelist (sys) + (sys-filelist sys) + ) + (defun getuserlist (sys) + (sys-userlist sys) + ) + (defun getenvlist (sys) + (sys-envlist sys) + ) + (defun getenv (envlist envname) + (if (endp envlist) + nil + ( if (equal (env-obj-envname(car envlist)) envname) + (env-obj-envvalue(car envlist)) + (getenv (cdr envlist) envname) + ) + ) + ) + (defun getprinterdir(sys) + (getenv (getenvlist sys ) 'printerdir) + ) + (defun getprinterspool(sys) + (getenv (getenvlist sys ) 'printerspool) + ) + + + (defun homedir (userlist uid) + (if (endp userlist) + nil + ( if (equal (user-obj-uid(car userlist)) uid) + (user-obj-homedir(car userlist)) + (homedir (cdr userlist) uid) + ) + ) + ) + (defun gethomedir (uid sys) + (homedir (sys-userlist sys) uid) + ) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; operation and relationship function of specs +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun operate (oper logrec) + ( if (equal oper 'openrd) (and (equal (getcallname logrec) 'open) (equal (getcallflag logrec) 'rd)) + (if(equal oper 'openrw) (and (equal (getcallname logrec) 'open) (equal (getcallflag logrec) 'rw)) + (if(equal oper 'openwr) (and (equal (getcallname logrec) 'open) (equal (getcallflag logrec) 'wr)) + (if (equal oper 'opencr) (and (equal (getcallname logrec) 'open) (equal (getcallflag logrec) 'cr)) + (if (equal oper 'open) (equal (getcallname logrec) 'open) + (if (equal oper 'unlink) (equal (getcallname logrec) 'unlink) + (if (equal oper 'link) (equal (getcallname logrec) 'link) + (if (equal oper 'chmod) (equal (getcallname logrec) 'chmod) + (if (equal oper 'fchmod) (equal (getcallname logrec) 'fchmod) + (if (equal oper 'chown) (equal (getcallname logrec) 'chown) + (if (equal oper 'fchown) (equal (getcallname logrec) 'fchown) + (if (equal oper 'fork) (equal (getcallname logrec) 'fork) + (if (equal oper 'vfork) (equal (getcallname logrec) 'vfork) + (if (equal oper 'read) (equal (getcallname logrec) 'read) + (if (equal oper 'write) (equal (getcallname logrec) 'write) + (if (equal oper 'socket) (equal (getcallname logrec) 'socket) + (if (equal oper 'connect) (equal (getcallname logrec) 'connect) + (if (equal oper 'exit) (equal (getcallname logrec) 'exit) + (if (equal oper 'setuid) (equal (getcallname logrec) 'setuid) + (if (equal oper 'execvt) (equal (getcallname logrec) 'execvt) + (if (equal oper 'create) (equal (getcallname logrec) 'create) + (if (equal oper 'rename) (equal (getcallname logrec) 'rename) + (if (equal oper 'setresuid) (equal (getcallname logrec) 'setresuid) nil)))))))))))))))))))) + )) + ) +) +;(operate 'opencr '((cst 0 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open cr))) + (defun filter (procname log) + (cond ((endp log) nil) + ((equal procname (getprocname (car log))) (cons (car log) (filter procname (cdr log))) + ) + (t (filter procname (cdr log)) + ) + ) + ) + + + (defun spec-create(filecreated logrec) + (if (and (or(operate 'create logrec)(operate 'opencr logrec)) (not(member (getfilename (logrec-fobj logrec)) filecreated)) ) + (append (list (getfilename (logrec-fobj logrec))) filecreated) + filecreated + ) + ) + + +(defun WorldReadable(fileobj) +(equal (rwx-obj-r (pmode-obj-amode (file-obj-pmode fileobj))) '1) +) +;(WorldReadable '(/home/tsong/file 23 2 ((1 1 0)(1 0 0)(1 0 0)) 534)) + + +(defun CreatedByProcTree(fileobj filelist) +(member(getfilename fileobj) filelist) +) +;(CreatedByProcTree '("/home/tsong/file" 23 2 ((1 1 0)(1 0 0)(1 0 0)) 534) '("/home/tsong/file" (/ etc passwd))) + +(defun CreatedByProc(fileobj filelist) +(member (getfilename fileobj) filelist) +) +;(CreatedByProc '("/home/tsong/file" 23 2 ((1 1 0)(1 0 0)(1 0 0)) 534) '("/home/tsong/file" (/ etc passwd))) + +(defun PathEqual(fileobj path) +(path-equal (getfilename fileobj) path) +) +;(pathequal '("/home/tsong/file" 23 2 ((1 1 0)(1 0 0)(1 0 0)) 534) '"/home/tsong/file") + +(defun InDir(fileobj path) +(inpath(getfilename fileobj) path) + +) +; ) ; extra paren removed by Matt K. +;(InDir '("/home/tsong/file" 23 2 ((1 1 0)(1 0 0)(1 0 0)) 534) '"/home/tsong") + +(defun IsFile(fileobj target) +(path-equal (getfilename fileobj) target) +) +;(IsFile '("/home/tsong/file" 23 2 ((1 1 0)(1 0 0)(1 0 0)) 534) '"/home/tsong/file") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;how to describe regfiel, socket and pipe +(defun IsRegFile(fileobj) + (equal (getreg fileobj) 1) +) + +(defun IsSocket(fileobj) + (> (getsocket fileobj) 0) +) + +(defun GetPort(fileobj) + (getsocket fileobj) +) + +(defun IsPipe(fileobj) + (equal (getpipe fileobj) 1) +) + +(defun CreateBySelf(fileobj uid) +(equal (getfileouid fileobj) uid ) +) + +(defun InDirList(fileobj dirlist) + (if (endp dirlist) + nil + (or (InDir fileobj (car dirlist)) (InDirList fileobj (cdr dirlist))) + ) +) +(defun InPathList(filename dirlist) + (if (endp dirlist) + nil + (or (InPath filename (car dirlist)) (InPathList filename (cdr dirlist))) + ) +) +(defthm InDirList2InPathList + (implies (and (InDirList fileobj dirlist)(file-obj-p fileobj)) + (InPathList (file-obj-name fileobj) dirlist) + ) +) +(defun OwnerofFile(logrec) + (equal (getfileouid (logrec-fobj logrec)) (getprocruid logrec)) +) + +(defun PathMatch(fileobj path) + (InDir fileobj path) +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; two spec samples +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;(spec_ftpd '(((ftp "/bin/ftp")(lpr "/bin/lpr"))((create)(open)(read)(write)(chmod)(chown))(("/bin/ftp" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1001)("/bin/lpr" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1002)("/home/tsong/" 23 2 ((1 1 1)(0 0 1)(0 0 1))))((0 root "/") (23 tsong "/home/tsong")) ((printpool "/temp/print")(printdir "/temp/print"))) '(((ftpd 23 3405 0 0) ("/home/tsong/file" 23 2 ((1 1 0) (1 0 0) (1 0 0)(0 0 0 0))23021) (open r))) nil) +;(spec_ftpd '(((ftp "/bin/ftp")(lpr "/bin/lpr"))((create)(open)(read)(write)(chmod)(chown))(("/bin/ftp" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1001)("/bin/lpr" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1002)("/home/tsong/" 23 2 ((1 1 1)(0 0 1)(0 0 1))))((0 root "/") (23 tsong "/home/tsong")) ((printpool "/temp/print")(printdir "/temp/print"))) nil nil) +;(logp '(((ftpd 23 3405 0 0) ("/home/tsong/file" 23 2 ((1 1 0) (1 0 0) (1 0 0)(0 0 0 0))23021) (open r)))) +;(sys-p '(((ftp "/bin/ftp")(lpr "/bin/lpr"))((create)(open)(read)(write)(chmod)(chown))(("/bin/ftp" 0 0 ((1 1 1)(0 0 1)(0 0 1)(0 0 0 0)) 1001)("/bin/lpr" 0 0 ((1 1 1)(0 0 1)(0 0 1)(0 0 0 0)) 1002)("/home/tsong/" 23 2 ((1 1 1)(0 0 1)(0 0 1)(0 0 0 0)) 1003))((0 root "/") (23 tsong "/home/tsong")) ((printpool "/temp/print")(printdir "/temp/print")))) +; +;(defun spec_lpr_rec (sys logrec filelist) +; (if (or +; (and (consp sys)(consp logrec)(consp filelist) (operate 'openrd logrec) (WorldReadable (logrec-fobj logrec))) +; (and (operate 'openrd logrec) (OwnerofFile logrec)) +; (and (operate 'openrd logrec) (CreatedByProc (logrec-fobj logrec) filelist)) +; (and (operate 'openrd logrec) (IsFile (logrec-fobj logrec) '(/ etc spwd.db))) +; (and (operate 'openwr logrec) (CreatedByProc (logrec-fobj logrec) filelist)) +; (and (operate 'openwr logrec) (pathmatch (logrec-fobj logrec) (path-append (getprinterspool sys) '(* seq)))) +; (and (operate 'opencr logrec) (InDirList (logrec-fobj logrec) (getprinterdir sys) )) +; (and (operate 'unlink logrec) (CreatedByProc (logrec-fobj logrec) filelist)) +; (and (operate 'chmod logrec) (CreatedByProc (logrec-fobj logrec) filelist)) +; (and (operate 'fchmod logrec) (CreatedByProc (logrec-fobj logrec) filelist)) +; (and (operate 'chown logrec) (CreatedByProc (logrec-fobj logrec) filelist)) +; (operate 'fork logrec) +; (operate 'vfork logrec) +; ) +; t +; nil + ; ) +;) + +;(defun spec_lpr (sys log filelist) +; (if (endp log) +; t +; (and ( spec_lpr_rec sys (car log) filelist)(spec_lpr sys (cdr log)(spec-create filelist (car log)))) +; ) +;) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; new version therom +; +;log: ((prog ruid pid euid egid) (name ouid ogid pmode inodeid)(syscall flags) (newowner, newmode, newpath, chpid))...... +;(((ftpd 23 3405 0 0) (/home/tsong/file 23 2 ((1 1 0) (1 0 0) (1 0 0)(0 0 0 0))23021) (open r)))) +;system:(((pname pdir)...)((callname)..)((dir ouid ogid pmode inodeid)...)((uid uname gid homedir)...)((envname envvalue)...)) +;(((ftp "/bin/ftp")(lpr "/bin/lpr"))((create)(open)(read)(write)(chmod)(chown))(("/bin/ftp" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1001)("/bin/lpr" 0 0 ((1 1 1)(0 0 1)(0 0 1)) 1002)("/home/tsong/" 23 2 ((1 1 1)(0 0 1)(0 0 1))))((0 root "/") (23 tsong "/home/tsong")) ((printpool "/temp/print")(printdir "/temp/print"))) +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun access-logrec (logrec) + (if (and (not (equal (getprocruid logrec) 0)) + (equal '(/ etc passwd) (getfilename (logrec-fobj logrec)) ) + (or (equal 'open (getcallname logrec)) + (equal 'chmod (getcallname logrec)) + (equal 'chown (getcallname logrec)) + (equal 'rename (getcallname logrec)) + (equal 'delete (getcallname logrec)) )) + t + nil + ) + ) + +(defun access-passwd (log) + (if (not (logp log)) nil + (if (endp log) nil + (or (access-logrec (car log)) + (access-passwd (cdr log) )) + ) + ) +) +(defun not-access-logrec (logrec) + (if (or (equal (getprocruid logrec) 0) + (not(equal '(/ etc passwd) (getfilename (logrec-fobj logrec)) )) + (and (not (equal 'open (getcallname logrec))) + (not (equal 'chmod (getcallname logrec))) + (not (equal 'chown (getcallname logrec))) + (not (equal 'rename (getcallname logrec))) + (not (equal 'delete (getcallname logrec)) ))) + t + nil + ) + ) + +(defun not-access-passwd (log) + (if (endp log) t + (and (not-access-logrec (car log)) + (not-access-passwd (cdr log) )) + ) +) + +(defthm lemma-access-passwd + (implies (and (logp log)(consp log)) + (equal (not-access-passwd log)(not (access-passwd log))) + ) +) +;(access-passwd2 '(((ftpd 23 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open rd))((ftpd 0 324 0 0) ((/ etc passwd) 0 0 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open rd)) )) +;(access-passwd3 '(((ftpd 23 324 0 0) ((/ etc passwd) 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open rd)))) +;(filter 'ftpd '(((lpr 23 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open rd))((ftpd 0 324 0 0) ((/ etc passwd) 0 0 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open rd)) )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; assumptions +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun checkhomedir-rec (userobj) + (and (not (inpath '(/ etc passwd) (user-obj-homedir userobj)))(consp (user-obj-homedir userobj))) +) + +(defun checkhomedir (userlist) + (if (endp userlist) t + (and + (checkhomedir-rec (car userlist)) + (checkhomedir(cdr userlist)) ) + ) + + +) + +(defun homedirsafe (sys) + (checkhomedir (getuserlist sys)) +) + +;(checkhomedir '((23 tsong 2 "/home/tsong")(24 aaa 2 "/etc"))) + +(defun passwdsaferec (rec) + (not(and (or (WorldReadable(logrec-fobj rec)) (not (equal (getfileouid (logrec-fobj rec)) 0)))(PathEqual (logrec-fobj rec)'(/ etc passwd))) + ) +) + +(defun passwdsafe (log) + (if (endp log) t + (and (passwdsaferec (car log)) (passwdsafe(cdr log))) + ) +) + +;(passwdsafe '(((ftpd 0 3405 0 0) ((/ etc passwd) 0 2 ((1 1 0) (1 0 0) (0 0 0)(0 0 0 0))23021) (open r)))) + +(defun userreccheck (userrec uid) + (equal (user-obj-uid userrec) uid) +) + +(defun userlistcheck (userlist uid) + (if (endp userlist) nil + (or (userreccheck (car userlist) uid) + (userlistcheck (cdr userlist) uid)) + ) +) + +(defun validuserrec (sys rec) + (userlistcheck (getuserlist sys) (getprocruid rec)) + ) + +(defun validuser (sys log) + (if (endp log) t + (and (validuserrec sys (car log)) + (validuser sys (cdr log))) + ) + ) +(defun validenv(sys envname) + (and (not (inpath '(/ etc passwd) (getenv (getenvlist sys ) envname)))(consp (getenv (getenvlist sys ) envname))) +) +(defun validprinterdir(sys) + (and (not (inpathlist '(/ etc passwd) (getenv (getenvlist sys ) 'printerdir)))(consp (getenv (getenvlist sys ) 'printerdir))) +) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; theorem with one spec +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +(defun spec_ftpd_rec (sys logrec filelist) + (if + (or + (and (operate 'openrd logrec) (WorldReadable (logrec-fobj logrec))) + (and (operate 'openrd logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (operate 'openrd logrec) (OwnerofFile logrec)) + (and (operate 'openwr logrec) (PathEqual (logrec-fobj logrec) '"/var/log/wtmp")) + (and (operate 'openwr logrec) (PathEqual (logrec-fobj logrec) '"/var/log/xferlog")) + (and (operate 'openwr logrec) (PathEqual (logrec-fobj logrec) '"/var/log/ftp.pids-all")) + (and (operate 'openrw logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (operate 'open logrec) (PathEqual (logrec-fobj logrec) '"/dev/dull")) + (and (operate 'unlink logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (operate 'read logrec) (and (IsSocket (logrec-fobj logrec))(equal (getport (logrec-fobj logrec)) 21))) + (and (operate 'write logrec) (and (IsSocket (logrec-fobj logrec))(equal (getport(logrec-fobj logrec)) 21))) + (and (operate 'create logrec) (InDir (logrec-fobj logrec) (homedir (sys-userlist sys) (getprocruid logrec)))) + (and (operate 'execve logrec) (or (PathEqual (logrec-fobj logrec) '"/bin/tar" ) (PathEqual (logrec-fobj logrec) '"/bin/compress" )(PathEqual (logrec-fobj logrec) '"/bin/ls" )(PathEqual (logrec-fobj logrec) '"/bin/gzip" ))) + ) + t + nil + ) +) + + +(defun spec_ftpd (sys log filelist) + (if (endp log) + t + (and ( spec_ftpd_rec sys (car log) filelist)(spec_ftpd sys (cdr log)(spec-create filelist (car log)))) + ) +) + +( defthm lemma81 +(implies (and (consp userlist1)(userlistp userlist1)(integerp uid) + (userlistcheck userlist1 uid) + (checkhomedir userlist1) + ) + ( consp(homedir userlist1 uid )) +) +;:hints (("Subgoal 1''" :induct (homedir (sys-userlist sys)uid ))) +) + +( defthm lemma82 +(implies (and (consp userlist1)(userlistp userlist1)(integerp uid) + (userlistcheck userlist1 uid) + (checkhomedir userlist1) + ) + (not (InPath '(/ etc passwd)(homedir userlist1 uid )) ) +) +;:hints (("Subgoal 1''" :induct (homedir (sys-userlist sys)uid ))) +) + +(defthm lemma83 + (implies (and (consp sys)(sys-p sys)) + (and (consp (sys-userlist sys))(userlistp (sys-userlist sys))) + ) +) +(defthm lemma84 + (implies (homedirsafe sys) + (checkhomedir (sys-userlist sys)) + ) +) + +( defthm lemma7 +(implies (and (consp sys)(sys-p sys)(integerp uid) + (userlistcheck (sys-userlist sys) uid) + (homedirsafe sys) + + ) + (not (InPath '(/ etc passwd) (homedir (sys-userlist sys)uid )) ) +) +;:hints (("Goal'" :do-not-induct (homedir (sys-userlist sys)uid ) :use lemma82 )) +) +( defthm lemma71 +(implies + (and + (consp sys) + (sys-p sys) + (integerp uid) + (userlistcheck + (sys-userlist sys) uid) + (homedirsafe sys) + (InPath filename (homedir (sys-userlist sys)uid )) + ) + (not (equal '(/ etc passwd) filename) ) +) +) + +( defthm lemma72 +(implies + (and + (consp sys) + (sys-p sys) + (logrec-p logrec) + (integerp uid) + (userlistcheck + (sys-userlist sys) uid) + (homedirsafe sys) + (InDir (logrec-fobj logrec) (homedir (sys-userlist sys)uid )) + ) + (not (equal '(/ etc passwd) (file-obj-name (logrec-fobj logrec))) ) +) +) +( defthm lemma73 +(implies + (and + (consp sys) + (sys-p sys) + (logp log) + (integerp uid) + (userlistcheck + (sys-userlist sys) uid) + (homedirsafe sys) + (InDir (logrec-fobj (car log)) (homedir (sys-userlist sys)uid )) + ) + (not (equal '(/ etc passwd) (file-obj-name (logrec-fobj (car log)))) ) +) +) +( defthm lemma74 +(implies + (and + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (logp log) + (integerp uid) + (userlistcheck + (sys-userlist sys) uid) + (homedirsafe sys) + (InDir (logrec-fobj (car log)) (homedir (sys-userlist sys)uid )) + ) + (not (member '(/ etc passwd) (spec-create created (car log)))) +) +) +( defthm lemma75 +(implies + (and + (sys-p sys) + (logp log) + (validuserrec sys (car log)) + ) + (userlistcheck (sys-userlist sys) (proc-obj-ruid(logrec-pobj(car log)))) +) +) + +( defthm lemma752 +(implies + (and + (sys-p sys) + (logp log) + (consp log) + (validuser sys log) + ) + (userlistcheck (sys-userlist sys) (proc-obj-ruid(logrec-pobj(car log)))) +) +) + +( defthm lemma762 +(implies + (and + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (logp log) + (integerp uid) + (userlistcheck (sys-userlist sys) uid) + (homedirsafe sys) + (InDir (logrec-fobj (car log)) (homedir (sys-userlist sys)uid )) + ) + (not (member '(/ etc passwd) (spec-create created (car log)))) +) +) + + +( defthm lemma763 +(implies + (and + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (logp log) + (integerp (proc-obj-ruid(logrec-pobj(car log)))) + (userlistcheck (sys-userlist sys) (proc-obj-ruid(logrec-pobj(car log)))) + (homedirsafe sys) + (InDir (logrec-fobj (car log)) (homedir (sys-userlist sys)(proc-obj-ruid(logrec-pobj(car log))) )) + ) + (not (member '(/ etc passwd) (spec-create created (car log)))) +) +;:hints (("Goal" :use ((:instance lemma762 (id (proc-obj-ruid(logrec-pobj(car log)))))))) +) + +(defthm lemm764 + (implies + (and + (consp log) + (logp log) + ) + (integerp (proc-obj-ruid(logrec-pobj(car log)))) + ) +) +(defthm lemm765 + (implies + (and + (consp log) + (validuser sys log) + ) + (userlistcheck (sys-userlist sys) (proc-obj-ruid(logrec-pobj(car log)))) + ) +) + + +( defthm lemma77 +(implies + (and + (consp log) + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (logp log) + (validuser sys log) + (homedirsafe sys) + (InDir (logrec-fobj (car log)) (homedir (sys-userlist sys) (proc-obj-ruid(logrec-pobj(car log))) )) + ) + (not (member '(/ etc passwd) (spec-create created (car log)))) +) +) + + +( defthm lemma79 +(implies + (and + (consp log) + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (logp log) + (validuser sys log) + (homedirsafe sys) + (spec_ftpd_rec sys (car log) created) + ) + (not (member '(/ etc passwd) (spec-create created (car log)))) +) +;:hints (("Goal" :uses lemma78 :uses lemma77)) +) + +(defthm passwd-ftp1-lemma + (implies + (not (member '(/ etc passwd) created)) + (implies + (and + (consp log) + (consp sys) + (logp log) + (consp created) + (sys-p sys) + (passwdsafe log) + (homedirsafe sys) + (validuser sys log) + (spec_ftpd sys log created)) + (not(access-passwd log)) + ) + ) +) + +(defthm passwd-ftp2-lemma + (implies + (and + (not (member '(/ etc passwd) created)) + (consp log) + (consp sys) + (logp log) + (consp created) + (sys-p sys) + (passwdsafe log) + (homedirsafe sys) + (validuser sys log) + (spec_ftpd sys log created)) + (not (access-passwd log) ) + ) + ;:hints (("Goal" :use (passwd-ftp1) )) +) +(defthm passwd-ftp2 + (implies + (and + (not (member '(/ etc passwd) created)) + (consp log) + (consp sys) + (logp log) + (consp created) + (sys-p sys) + (passwdsafe log) + (homedirsafe sys) + (validuser sys log) + (spec_ftpd sys log created)) + (not-access-passwd log) + ) + :hints (("Goal" :use (passwd-ftp2-lemma) )) +) +(defthm passwd-ftp-lemma + (implies + (and + (not (member '(/ etc passwd) created)) + (consp log) + (consp sys) + (logp log) + (sys-p sys) + (passwdsafe log) + (homedirsafe sys) + (validuser sys log) + (spec_ftpd sys log created)) + (not(access-passwd log)) + ) + :hints (("Goal" :use (passwd-ftp2-lemma) )) +) +(defthm passwd-ftp + (implies + (and + (not (member '(/ etc passwd) created)) + (consp log) + (consp sys) + (logp log) + (sys-p sys) + (passwdsafe log) + (homedirsafe sys) + (validuser sys log) + (spec_ftpd sys log created)) + (not-access-passwd log) + ) + :hints (("Goal" :use (passwd-ftp-lemma) )) +) +(defthm passwd-ftp3-lemma + (implies + (and + (not (member '(/ etc passwd) created)) + (consp sys) + (logp log) + (sys-p sys) + (passwdsafe log) + (homedirsafe sys) + (validuser sys log) + (spec_ftpd sys log created)) + (not (access-passwd log) ) + ) + :hints (("Goal" :use (passwd-ftp-lemma) )) +) +(defthm passwd-ftp3 + (implies + (and + (not (member '(/ etc passwd) created)) + (consp sys) + (logp log) + (sys-p sys) + (passwdsafe log) + (homedirsafe sys) + (validuser sys log) + (spec_ftpd sys log created)) + (not-access-passwd log) + ) + :hints (("Goal" :use (lemma-access-passwd passwd-ftp3-lemma) )) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun spec_lpr_rec (sys logrec filelist) + (if (or + (and (consp sys)(consp logrec)(consp filelist) (operate 'openrd logrec) (WorldReadable (logrec-fobj logrec))) + (and (operate 'openrd logrec) (OwnerofFile logrec)) + (and (operate 'openrd logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (operate 'openrd logrec) (IsFile (logrec-fobj logrec) '(/ etc spwd.db))) + (and (operate 'openwr logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (consp sys) (consp logrec)(consp filelist) (operate 'openwr logrec) (pathmatch (logrec-fobj logrec) (path-append (getprinterspool sys) '(* seq)))) +; (and (consp sys)(consp logrec)(consp filelist)(operate 'opencr logrec) (InDirList (logrec-fobj logrec) (getprinterdir sys) )) + (and (operate 'unlink logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (logrec-fobj logrec) filelist)) + (operate 'fork logrec) + (operate 'vfork logrec) + ) + t + nil + ) +) + +(defun spec_lpr (sys log filelist) + (if (endp log) + t + (and ( spec_lpr_rec sys (car log) filelist)(spec_lpr sys (cdr log)(spec-create filelist (car log)))) + ) +) + + +( defthm lemma2001 +(implies (and + (consp sys) + (sys-p sys) + (validenv sys 'printerspool) + ) + ( consp (getprinterspool sys)) +) +) +( defthm lemma2002 +(implies (and + (consp sys) + (sys-p sys) + (validenv sys 'printerspool) + ) + ( not(inpath '(/ etc passwd) (getprinterspool sys))) +) +) + +(defthm lemma2003 + (implies (not (inpath aaa bbb)) + (not (inpath aaa (path-append bbb ccc))) + ) +) +(defthm lemma2004 + (implies (not (inpath aaa bbb)) + (not (inpath aaa (path-append bbb ccc))) + ) +) +(in-theory (disable path-append getprinterspool)) +(defthm lemma2005 + (implies (not (inpath '(/ etc passwd) (getprinterspool sys))) + (not (inpath '(/ etc passwd) (path-append (getprinterspool sys) '(* seq)))) + ) + ; :hints (("Goal" :use (:instance lemma2004(aaa '(/ etc passwd))( bbb (getprinterspool sys))( ccc '(* seq))))) +) +(defthm lemma2006 +(implies (and (consp sys)(sys-p sys) (validenv sys 'printerspool)) + (not(inpath '(/ etc passwd) (path-append (getprinterspool sys) '(* seq)))) + ) + ;:hints (("Goal" :use (lemma2002 lemma2005) )) +) +(defthm lemma2007 + (implies (and (consp sys)(sys-p sys)(logrec-p logrec) (validenv sys 'printerspool) (pathmatch (logrec-fobj logrec) (path-append (getprinterspool sys) '(* seq)))) + (not (equal '(/ etc passwd)(file-obj-name(logrec-fobj logrec)))) + ) + ;:hints (("Goal" :use (lemma2002 lemma2005) )) +) +(defthm lemma2008 + (implies (and (consp sys)(sys-p sys)(logrec-p logrec) (validenv sys 'printerspool) (pathmatch (logrec-fobj logrec) (path-append (getprinterspool sys) '(* seq)))) + (not (access-logrec logrec)) + ) + ;:hints (("Goal" :use (lemma2002 lemma2005) )) +) + + + +( defthm lemma201 +(implies (and + (consp sys) + (sys-p sys) + (validprinterdir sys) + ) + ( consp (getprinterdir sys)) +) +) +( defthm lemma202 +(implies (and + (consp sys) + (sys-p sys) + (validprinterdir sys) + ) + ( not(InPathList '(/ etc passwd) (getprinterdir sys))) +) +) + +( defthm lemma203 +(implies + (and + (logrec-p logrec) + (consp logrec) + ) +(file-obj-p (logrec-fobj logrec)) +) +) + +( defthm lemma204 +(implies + (and + (logrec-p logrec) + (consp logrec) + (consp sys) + (sys-p sys) + (InDirList (logrec-fobj logrec) (getprinterdir sys) ) + ) + (InPathList (file-obj-name(logrec-fobj logrec)) (getprinterdir sys)) +) +;:hints (("Goal" :use ((:instance InDirList2InPathList(fileobj (logrec-fobj logrec)))))) +) + +( defthm lemma205 +(implies + (and + (logrec-p logrec) + (consp logrec) + (consp sys) + (sys-p sys) + (InDirList (logrec-fobj logrec) (getprinterdir sys) ) + (validprinterdir sys) + ) + (and ( not(InPathList '(/ etc passwd) (getprinterdir sys)))(InPathList (file-obj-name(logrec-fobj logrec)) (getprinterdir sys))) +; (not (equal '(/ etc passwd) (file-obj-name(logrec-fobj logrec))) ) +) +) +(defthm lemma206 + (implies + (and ( not(InPathList '(/ etc passwd) (getprinterdir sys)))(InPathList (file-obj-name(logrec-fobj logrec)) (getprinterdir sys))) + (not (equal '(/ etc passwd) (file-obj-name(logrec-fobj logrec))) ) + ) +) + +( defthm lemma207 +(implies + (and + (logrec-p logrec) + (consp logrec) + (consp sys) + (sys-p sys) + (InDirList (logrec-fobj logrec) (getprinterdir sys) ) + (validprinterdir sys) + ) +; (and ( not(InPathList '(/ etc passwd) (getprinterdir sys)))(InPathList (file-obj-name(logrec-fobj logrec)) (getprinterdir sys))) + (not (equal '(/ etc passwd) (file-obj-name(logrec-fobj logrec))) ) +) +:hints (("Goal" :use (lemma205 lemma206))) +) +( defthm lemma208 +(implies + (and + (logp log) + (consp log) + ) + (and + (consp (car log)) + (logrec-p (car log)) + ) +) +) + +( defthm lemma209 +(implies + (and + (logp log) + (consp log) + (consp sys) + (sys-p sys) + (InDirList (logrec-fobj (car log)) (getprinterdir sys) ) + (validprinterdir sys) + ) +; (and ( not(InPathList '(/ etc passwd) (getprinterdir sys)))(InPathList (file-obj-name(logrec-fobj logrec)) (getprinterdir sys))) + (not (equal '(/ etc passwd) (file-obj-name(logrec-fobj (car log)))) ) +) +:hints (("Goal" :use lemma207)) +) + +( defthm lemma210 +(implies + (and + (not (member '(/ etc passwd) created)) + (logp log) + (consp log) + (not (equal '(/ etc passwd) (file-obj-name(logrec-fobj (car log)))) ) + ) + (not (member '(/ etc passwd) (spec-create created (car log)))) +) +) + +( defthm lemma211 +(implies + (and + (logp log) + (consp log) + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (InDirList (logrec-fobj (car log)) (getprinterdir sys) ) + (validprinterdir sys) + ) + (not (equal '(/ etc passwd) (file-obj-name(logrec-fobj (car log)))) ) +) +:hints (("Goal" :use lemma209)) +) + + +( defthm lemma212 +(implies + (and + (logp log) + (consp log) + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (InDirList (logrec-fobj (car log)) (getprinterdir sys) ) + (validprinterdir sys) + ) + (and + (not (member '(/ etc passwd) created)) + (logp log) + (consp log) + ) +) +) + +( defthm lemma213 +(implies + (and + (logp log) + (consp log) + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (InDirList (logrec-fobj (car log)) (getprinterdir sys) ) + (validprinterdir sys) + ) + (and + (not (member '(/ etc passwd) created)) + (logp log) + (consp log) + (not (equal '(/ etc passwd) (file-obj-name(logrec-fobj (car log)))) ) + ) +) +) + +( defthm lemma214 +(implies + (and + (logp log) + (consp log) + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (InDirList (logrec-fobj (car log)) (getprinterdir sys) ) + (validprinterdir sys) + ) + (not (member '(/ etc passwd) (spec-create created (car log)))) +) +:hints (("Goal" :use (lemma213 lemma210))) +) + +(defun aa(log sys created) + (and + (logp log) + (consp log) + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (InDirList (logrec-fobj (car log)) (getprinterdir sys) ) + (validprinterdir sys) + ) +) +(defun bb(log created) + (and + (not (member '(/ etc passwd) created)) + (logp log) + (consp log) + (not (equal '(/ etc passwd) (file-obj-name(logrec-fobj (car log)))) ) + ) +) +(defun cc(log created) +(not (member '(/ etc passwd) (spec-create created (car log)))) +) + +(defthm lemma2152 + (implies (aa log sys created) + (bb log created) + ) +:hints (("Goal" :use lemma213)) +) +(defthm lemma216 + (implies + (bb log created) + (cc log created) + ) +:hints (("Goal" :use lemma210)) +) +(defthm lemma217 + (implies (aa log sys created) + (cc log created) + ) +:hints (("Goal" :use lemma2152)) +) +( defthm lemma218 +(implies + (and + (logp log) + (consp log) + (consp sys) + (sys-p sys) + (not (member '(/ etc passwd) created)) + (InDirList (logrec-fobj (car log)) (getprinterdir sys) ) + (validprinterdir sys) + ) +(not (member '(/ etc passwd) (spec-create created (car log)))) + +) +:hints (("Goal" :use lemma217)) +) + + + +(defthm passwd-lpr + (implies + (and + (not (member '(/ etc passwd) created)) + (consp log) + (consp sys) + (logp log) + (consp created) + (sys-p sys) + (passwdsafe log) + (homedirsafe sys) + (validenv sys 'printerspool) + (validuser sys log) + (spec_lpr sys log created)) + (not (access-passwd log) ) + ) + ;:hints (("Goal" :use (lemma2008) )) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; spec functions of SHIM +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun vaildaccess (sys logrec ) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (OwnerofFile logrec)) + ) + ) + t + nil +) +) +(defun spec_atcst_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (CreatedByProcTree (getfile logrec) filelist)) + (and (operate 'openwr logrec) (CreatedByProcTree (getfile logrec) filelist)) + (and (operate 'openwr logrec) (IsFile (getfile logrec) '"/var/spool/at/.SEQ")) + (and (operate 'opencr logrec) (InDir (getfile logrec) '"/var/spool/at")) + (and (operate 'unlink logrec) (CreatedByProcTree (getfile logrec) filelist)) + (and (operate 'unlink logrec) (InDir (getfile logrec) '"/var/spool/at/spool")) + (and (operate 'chmod logrec) (CreatedByProcTree (getfile logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProcTree (getfile logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProcTree (getfile logrec) filelist)) + (and (operate 'fchown logrec) (CreatedByProcTree (getfile logrec) filelist)) + (operate 'fork logrec) + (operate 'vfork logrec) + )) + t + nil + ) +) +;(spec_atcst_rec '( a b c) '((cst 0 324 0 0) ("/home/tsong/file" 23 2 ((1 1 0)(1 0 0)(1 0 0)(0 0 0 0)) 2345) (open rd)) nil) +;(spec_atcst_rec '( a b c) '((cst 0 324 0 0) ("/home/tsong/file" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open rd)) '("/home/tsong/file")) +;(spec_atcst_rec '( a b c) '((cst 0 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open cr)) nil) +(defun spec_atcst (sys log filelist) + (if (endp log) + t + (and ( spec_atcst_rec sys (car log) filelist)(spec_atcst sys (cdr log)(spec-create filelist (car log)))) + ) +) +;(spec_atcst '(a b c) '(((cst 0 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open cr)) ) nil) +;(spec_atcst '(a b c) '(((cst 0 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open rd)) ) nil) +;(spec_atcst '(a b c) '(((cst 0 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open rd)) ) '("/var/spool/at/myfile")) +;(spec-create nil '((cst 0 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open cr))) +;(spec_atcst '(a b c) '(((cst 0 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open cr)) ((cst 0 324 0 0) ("/var/spool/at/myfile" 23 2 ((1 1 0)(1 0 0)(0 0 0)(0 0 0 0)) 2345) (open rd))) nil) +;create "/var/spool/at/myfile" then read it +(defun spec_chage_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (IsFile (getfile logrec) '"/etc/shadow")) + (and (operate 'openrw logrec) (InDir (getfile logrec) '"/var/run/utmp")) + (and (operate 'openrw logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'link logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchown logrec) (CreatedByProc (getfile logrec) filelist)) + (operate 'read logrec) + (operate 'write logrec) + (operate 'socket logrec) + (operate 'connect logrec) + (operate 'exit logrec) + )) + t + nil + ) +) +(defun spec_chage (sys log filelist) + (if (endp log) + t + (and ( spec_chage_rec sys (car log) filelist)(spec_chage sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_chsh_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (IsFile (getfile logrec) '"/etc/shadow")) + (and (operate 'openrw logrec) (InDir (getfile logrec) '"/var/run/utmp")) + (and (operate 'openrw logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'link logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchown logrec) (CreatedByProc (getfile logrec) filelist)) + (operate 'read logrec) + (operate 'write logrec) + (operate 'socket logrec) + (operate 'connect logrec) + (operate 'exit logrec) + )) + t + nil + ) +) +(defun spec_chsh (sys log filelist) + (if (endp log) + t + (and ( spec_chsh_rec sys (car log) filelist)(spec_chsh sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_chfn_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (IsFile (getfile logrec) '"/etc/shadow")) + (and (operate 'openrw logrec) (InDir (getfile logrec) '"/var/run/utmp")) + (and (operate 'openrw logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'link logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchown logrec) (CreatedByProc (getfile logrec) filelist)) + (operate 'read logrec) + (operate 'write logrec) + (operate 'socket logrec) + (operate 'connect logrec) + (operate 'exit logrec) + )) + t + nil + ) +) + +(defun spec_chfn (sys log filelist) + (if (endp log) + t + (and ( spec_chfn_rec sys (car log) filelist)(spec_chfn sys (cdr log)(spec-create filelist (car log)))) + ) +) + + +(defun spec_crontab_rec (sys logrec filelist) + (let ((cronspooldir '"/var/cron/spool/")( username '"tsong")) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'openrw logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'openrw logrec) (InDir (getfile logrec) (string-append cronspooldir username))) + (and (operate 'opencr logrec) (InDir (getfile logrec) (string-append cronspooldir username))) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchown logrec) (CreatedByProc (getfile logrec) filelist)) + (operate 'fork logrec) + (operate 'vfork logrec) + )) + t + nil + ) + ) + +) +(defun spec_crontab (sys log filelist) + (if (endp log) + t + (and ( spec_crontab_rec sys (car log) filelist)(spec_crontab sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_dumpcst_rec (sys logrec) + + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (operate 'connect logrec) + (operate 'fork logrec) + (operate 'vfork logrec) + )) + t + nil + ) + + +) +(defun spec_dumpcst (sys log ) + (if (endp log) + t + (and ( spec_dumpcst_rec sys (car log) )(spec_dumpcst sys (cdr log) )) + ) +) +;----------------------------------------------- later +;(defun spec_fingerd (sys log) +; (and ( spec_fingerd_rec sys car log)(spec_fingerd sys (cdr log))) +;) +;(defun spec_stateftpd (sys log) +; +; (and ( spec_stateftpd_rec sys car log)(spec_stateftpd sys (cdr log))) +;) + +;-------------------------------------------------- +(defun spec_gpasswd_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (IsFile (getfile logrec) '"/etc/gshadow")) + (and (operate 'openrw logrec) (PathEqual (getfile logrec) '"/var/run/utmp")) + (and (operate 'openwr logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'link logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchown logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'rename logrec) (IsFile (getfile logrec) '"/etc/gshadow")) + (and (operate 'rename logrec) (IsFile (getfile logrec) '"/etc/gpasswd")) + + )) + t + nil + ) +) +(defun spec_gpasswd (sys log filelist) + (if (endp log) + t + (and ( spec_gpasswd_rec sys (car log) filelist)(spec_gpasswd sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_lpd_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (OwnerofFile logrec)) + (and (operate 'openrd logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'openrd logrec) (IsFile (getfile logrec) '"/etc/spwd.db")) + (and (operate 'openwr logrec) (IsFile (getfile logrec) '"/var/spool/lpd/*/.seq")) + (and (operate 'openwr logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'openrw logrec) (InDir (getfile logrec) '"/dev/null")) + (and (operate 'open logrec) (InDirList (getfile logrec) (getprinterdir sys))) + (and (operate 'unlink logrec) (InDirList (getfile logrec) (getprinterdir sys))) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chown logrec) (PathEqual (getfile logrec) '"/dev/printer")) + (and (operate 'fchown logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'rename logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'rename logrec) (InDirList (getfile logrec) (getprinterdir sys))) + (and (operate 'execve logrec) (InDir (getfile logrec) '"/var/spool/lpd")) + (and (operate 'execve logrec) (InDir (getfile logrec) '"/usr/bin")) + (and (operate 'execve logrec) (InDir (getfile logrec) '"/bin")) + (and (operate 'execve logrec) (InDir (getfile logrec) '"/usr/lib/rhs")) + (operate 'fork logrec) + (operate 'vfork logrec) + )) + t + nil + ) +) +;???????????????? +(defun spec_lpd (sys log filelist) + (if (endp log) + t + (and ( spec_lpd_rec sys (car log) filelist)(spec_lpd sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_lpq_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (OwnerofFile logrec)) + (and (operate 'openrd logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'openrd logrec) (IsFile (getfile logrec) '"/etc/spwd.db")) + (and (operate 'openwr logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'openwr logrec) (IsFile (getfile logrec) '"/var/spool/output/lpd/.seq")) + (operate 'opencr logrec) + (operate 'create logrec) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (getfile logrec) filelist)) + (operate 'fork logrec) + (operate 'vfork logrec) + )) + t + nil + ) +) +(defun spec_lpq (sys log filelist) + (if (endp log) + t + (and ( spec_lpq_rec sys (car log) filelist)(spec_lpq sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_lprm_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (OwnerofFile logrec)) + (and (operate 'openrd logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'openrd logrec) (IsFile (getfile logrec) '"/etc/spwd.db")) + (and (operate 'openwr logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'openwr logrec) (IsFile (getfile logrec) '"/var/spool/output/lpd/.seq")) + (operate 'opencr logrec) + (operate 'create logrec) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'fchmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (getfile logrec) filelist)) + (operate 'fork logrec) + (operate 'vfork logrec) + )) + t + nil + ) +) +(defun spec_lprm (sys log filelist) + (if (endp log) + t + (and ( spec_lprm_rec sys (car log) filelist)(spec_lprm sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_mountcst_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openwr logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'openwr logrec) (PathEqual (getfile logrec) '"/etc/mtab")) + (and (operate 'opencr logrec) (PathMatch (getfile logrec) '"/etc/mtab")) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'link logrec) (CreatedByProc (getfile logrec) filelist)) + )) + t + nil + ) +) +(defun spec_mountcst (sys log filelist) + (if (endp log) + t + (and ( spec_mountcst_rec sys (car log) filelist)(spec_mountcst sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_netutil_rec (sys logrec ) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (operate 'connect logrec) + (operate 'setuid logrec) + (operate 'socket logrec) + )) + t + nil + ) +) +(defun spec_netutil (sys log ) + (if (endp log) + t + (and ( spec_netutil_rec sys (car log) )(spec_netutil sys (cdr log))) + ) +) +(defun spec_passwd_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrd logrec) (IsFile (getfile logrec) '"/etc/gshadow")) + (and (operate 'openrw logrec) (PathEqual (getfile logrec) '"/var/run/utmp")) + (and (operate 'openwr logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'link logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chown logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'rename logrec) (IsFile (getfile logrec) '"/etc/gshadow")) + (and (operate 'rename logrec) (IsFile (getfile logrec) '"/etc/gpasswd")) + + )) + t + nil + ) +) +(defun spec_passwd (sys log filelist) + (if (endp log) + t + (and ( spec_passwd_rec sys (car log) filelist)(spec_passwd sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_ping_rec (sys logrec ) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (operate 'connect logrec) + (operate 'setuid logrec) + (operate 'socket logrec) + )) + t + nil + ) +) +(defun spec_ping (sys log ) + (if (endp log) + t + (and ( spec_ping_rec sys (car log) )(spec_ping sys (cdr log))) + ) +) +(defun spec_rcmd_rec (sys logrec filelist) + (if (and (sys-p sys) + (listp filelist) + (or + (vaildaccess sys logrec) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (operate 'bind logrec) + (operate 'setuid logrec) + (operate 'socket logrec) + )) + t + nil + ) +) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;??????????????????????????????? +(defun spec_rcmd (sys log filelist) + (if (endp log) + t + (and ( spec_rcmd_rec sys (car log) filelist)(spec_rcmd sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_restore_rec (sys logrec filelist) + (if (and (sys-p sys) + (listp filelist) + (or + (vaildaccess sys logrec) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (operate 'fork logrec) + (operate 'vfork logrec) + (operate 'connect logrec) + )) + t + nil + ) +) +(defun spec_restore (sys log filelist) + (if (endp log) + t + (and ( spec_restore_rec sys (car log) filelist)(spec_restore sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_rshacst_rec (sys logrec filelist) + (if (and (sys-p sys) + (listp filelist) + (or + (and (operate 'execve logrec)(IsFile (getfile logrec) '"/usr/bin/rlogin")) + (vaildaccess sys logrec) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (operate 'fork logrec) + (operate 'setuid logrec) + (operate 'connect logrec) + )) + t + nil + ) +) +(defun spec_rshacst (sys log filelist) + (if (endp log) + t + (and ( spec_rshacst_rec sys (car log) filelist)(spec_rshacst sys (cdr log)(spec-create filelist (car log)))) + ) +) +;;;what's the use of this spec? +(defun spec_stdunix_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openwr logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + + )) + t + nil + ) +) +(defun spec_stdunix (sys log filelist) + (if (endp log) + t + (and ( spec_stdunix_rec sys (car log) filelist)(spec_stdunix sys (cdr log)(spec-create filelist (car log)))) + ) +) +(defun spec_syslogd_rec (sys logrec filelist) + (if (and (sys-p sys)(or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (and (operate 'openrw logrec) (InDir (getfile logrec) '"/var/log")) + (and (operate 'open logrec) (PathEqual (getfile logrec) '"/var/run/syslogd.pid")) + (and (operate 'openwr logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'chmod logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'unlink logrec) (CreatedByProc (getfile logrec) filelist)) + (and (operate 'link logrec) (CreatedByProc (getfile logrec) filelist)) + (operate 'connect logrec) + (operate 'socket logrec) + )) + t + nil + ) +) +(defun spec_syslogd (sys log filelist) + (if (endp log) + t + (and ( spec_syslogd_rec sys (car log) filelist)(spec_syslogd sys (cdr log)(spec-create filelist (car log)))) + ) +) + +(defun spec_traceroute_rec (sys logrec filelist) + (if (and (sys-p sys)(listp filelist) (or + (and (operate 'openrd logrec) (WorldReadable (getfile logrec))) + (operate 'connect logrec) + (operate 'setuid logrec) + (operate 'socket logrec) + )) + t + nil + ) +) +(defun spec_traceroute (sys log filelist) + (if (endp log) + t + (and ( spec_traceroute_rec sys (car log) filelist)(spec_traceroute sys (cdr log)(spec-create filelist (car log)))) + ) +) diff --git a/books/workshops/2003/whats-new/note-v2-7.txt.gz b/books/workshops/2003/whats-new/note-v2-7.txt.gz Binary files differnew file mode 100644 index 0000000..063ba03 --- /dev/null +++ b/books/workshops/2003/whats-new/note-v2-7.txt.gz diff --git a/books/workshops/2003/whats-new/note-v2-8.txt.gz b/books/workshops/2003/whats-new/note-v2-8.txt.gz Binary files differnew file mode 100644 index 0000000..c736bbf --- /dev/null +++ b/books/workshops/2003/whats-new/note-v2-8.txt.gz diff --git a/books/workshops/2003/whats-new/talk.txt.gz b/books/workshops/2003/whats-new/talk.txt.gz Binary files differnew file mode 100644 index 0000000..e4e007f --- /dev/null +++ b/books/workshops/2003/whats-new/talk.txt.gz |