(declare (usual-integrations))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File:         boyer.sch
; Description:  The Boyer benchmark
; Author:       Bob Boyer
; Created:      5-Apr-85
; Modified:     10-Apr-85 14:52:20 (Bob Shaw)
;               22-Jul-87 (Will Clinger)
; Language:     Scheme (but see note)
; Status:       Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Note:  This benchmark uses property lists.  The procedures that must
; be supplied are get and put, where (put x y z) is equivalent to Common
; Lisp's (setf (get x y) z).
; Note:  The Common Lisp version of this benchmark returns the wrong
; answer because it uses the Common Lisp equivalent of memv instead of
; member in the falsep and truep procedures.  (The error arose because
; memv is called member in Common Lisp.  Don't ask what member is called,
; unless you want to learn about keyword arguments.)  This Scheme version
; may run a few percent slower than it would if it were equivalent to
; the Common Lisp version, but it works.

;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Fairly CONS intensive.

(define unify-subst '())
(define temp-temp '())

(define (add-lemma term)
  (cond ((and (pair? term)
              (eq? (car term)
                   (quote _equal))
              (pair? (cadr term)))
         (put (car (cadr term))
              (quote _lemmas)
              (cons term (get (car (cadr term)) (quote _lemmas)))))
        (else (error "ADD-LEMMA did not like term:  " term))))

(define (add-lemma-lst lst)
  (cond ((null? lst)
         '#t)
        (else (add-lemma (car lst))
              (add-lemma-lst (cdr lst)))))

(define (apply-subst alist term)
  (cond ((not (pair? term))
         (cond ((begin (set! temp-temp (assq term alist))
                       temp-temp)
                (cdr temp-temp))
               (else term)))
        (else (cons (car term)
                    (apply-subst-lst alist (cdr term))))))

(define (apply-subst-lst alist lst)
  (cond ((null? lst)
         '())
        (else (cons (apply-subst alist (car lst))
                    (apply-subst-lst alist (cdr lst))))))

(define (falsep x lst)
  (or (equal? x (quote (_f)))
      (member x lst)))

(define (one-way-unify term1 term2)
  (begin (set! unify-subst '())   ;;; JSM: was #f
         (one-way-unify1 term1 term2)))

(define (one-way-unify1 term1 term2)
  (cond ((not (pair? term2))
         (cond ((begin (set! temp-temp (assq term2 unify-subst))
                       temp-temp)
                (equal? term1 (cdr temp-temp)))
               (else (set! unify-subst (cons (cons term2 term1)
                                             unify-subst))
                     '#t)))
        ((not (pair? term1))
         '#f)
        ((eq? (car term1)
              (car term2))
         (one-way-unify1-lst (cdr term1)
                             (cdr term2)))
        (else '#f)))

(define (one-way-unify1-lst lst1 lst2)
  (cond ((null? lst1)
         '#t)
        ((one-way-unify1 (car lst1)
                         (car lst2))
         (one-way-unify1-lst (cdr lst1)
                             (cdr lst2)))
        (else '#f)))

(define (rewrite term)
  (cond ((not (pair? term))
         term)
        (else (rewrite-with-lemmas (cons (car term)
                                         (rewrite-args (cdr term)))
                                   (get (car term)
                                        (quote _lemmas))))))

(define (rewrite-args lst)
  (cond ((null? lst)
         '())
        (else (cons (rewrite (car lst))
                    (rewrite-args (cdr lst))))))

(define (rewrite-with-lemmas term lst)
  (cond ((null? lst)
         term)
        ((one-way-unify term (cadr (car lst)))
         (rewrite (apply-subst unify-subst (caddr (car lst)))))
        (else (rewrite-with-lemmas term (cdr lst)))))

(define (setup)
  (add-lemma-lst
   (quote ((_equal (_compile form)
                  (_reverse (_codegen (_optimize form)
                                    (_nil))))
           (_equal (_eqp x y)
                  (_equal (_fix x)
                         (_fix y)))
           (_equal (_greaterp x y)
                  (_lessp y x))
           (_equal (_lesseqp x y)
                  (_not (_lessp y x)))
           (_equal (_greatereqp x y)
                  (_not (_lessp x y)))
           (_equal (_boolean x)
                  (_or (_equal x (_t))
                      (_equal x (_f))))
           (_equal (_iff x y)
                  (_and (_implies x y)
                       (_implies y x)))
           (_equal (_even1 x)
                  (_if (_zerop x)
                      (_t)
                      (_odd (_1- x))))
           (_equal (_countps- l pred)
                  (_countps-loop l pred (_zero)))
           (_equal (_fact- i)
                  (_fact-loop i 1))
           (_equal (_reverse- x)
                  (_reverse-loop x (_nil)))
           (_equal (_divides x y)
                  (_zerop (_remainder y x)))
           (_equal (_assume-true var alist)
                  (_cons (_cons var (_t))
                        alist))
           (_equal (_assume-false var alist)
                  (_cons (_cons var (_f))
                        alist))
           (_equal (_tautology-checker x)
                  (_tautologyp (_normalize x)
                              (_nil)))
           (_equal (_falsify x)
                  (_falsify1 (_normalize x)
                            (_nil)))
           (_equal (_prime x)
                  (_and (_not (_zerop x))
                       (_not (_equal x (_add1 (_zero))))
                       (_prime1 x (_1- x))))
           (_equal (_and p q)
                  (_if p (_if q (_t)
                              (_f))
                        (_f)))
           (_equal (_or p q)
                  (_if p (_t)
                        (_if q (_t)
                              (_f))
                        (_f)))
           (_equal (_not p)
                  (_if p (_f)
                        (_t)))
           (_equal (_implies p q)
                  (_if p (_if q (_t)
                              (_f))
                        (_t)))
           (_equal (_fix x)
                  (_if (_numberp x)
                      x
                      (_zero)))
           (_equal (_if (_if a b c)
                      d e)
                  (_if a (_if b d e)
                        (_if c d e)))
           (_equal (_zerop x)
                  (_or (_equal x (_zero))
                      (_not (_numberp x))))
           (_equal (_plus (_plus x y)
                        z)
                  (_plus x (_plus y z)))
           (_equal (_equal (_plus a b)
                         (_zero))
                  (_and (_zerop a)
                       (_zerop b)))
           (_equal (_difference x x)
                  (_zero))
           (_equal (_equal (_plus a b)
                         (_plus a c))
                  (_equal (_fix b)
                         (_fix c)))
           (_equal (_equal (_zero)
                         (_difference x y))
                  (_not (_lessp y x)))
           (_equal (_equal x (_difference x y))
                  (_and (_numberp x)
                       (_or (_equal x (_zero))
                           (_zerop y))))
           (_equal (_meaning (_plus-tree (_append x y))
                           a)
                  (_plus (_meaning (_plus-tree x)
                                 a)
                        (_meaning (_plus-tree y)
                                 a)))
           (_equal (_meaning (_plus-tree (_plus-fringe x))
                           a)
                  (_fix (_meaning x a)))
           (_equal (_append (_append x y)
                          z)
                  (_append x (_append y z)))
           (_equal (_reverse (_append a b))
                  (_append (_reverse b)
                          (_reverse a)))
           (_equal (_times x (_plus y z))
                  (_plus (_times x y)
                        (_times x z)))
           (_equal (_times (_times x y)
                         z)
                  (_times x (_times y z)))
           (_equal (_equal (_times x y)
                         (_zero))
                  (_or (_zerop x)
                      (_zerop y)))
           (_equal (_exec (_append x y)
                        pds envrn)
                  (_exec y (_exec x pds envrn)
                          envrn))
           (_equal (_mc-flatten x y)
                  (_append (_flatten x)
                          y))
           (_equal (_member x (_append a b))
                  (_or (_member x a)
                      (_member x b)))
           (_equal (_member x (_reverse y))
                  (_member x y))
           (_equal (_length (_reverse x))
                  (_length x))
           (_equal (_member a (_intersect b c))
                  (_and (_member a b)
                       (_member a c)))
           (_equal (_nth (_zero)
                       i)
                  (_zero))
           (_equal (_exp i (_plus j k))
                  (_times (_exp i j)
                         (_exp i k)))
           (_equal (_exp i (_times j k))
                  (_exp (_exp i j)
                       k))
           (_equal (_reverse-loop x y)
                  (_append (_reverse x)
                          y))
           (_equal (_reverse-loop x (_nil))
                  (_reverse x))
           (_equal (_count-list z (_sort-lp x y))
                  (_plus (_count-list z x)
                        (_count-list z y)))
           (_equal (_equal (_append a b)
                         (_append a c))
                  (_equal b c))
           (_equal (_plus (_remainder x y)
                        (_times y (_quotient x y)))
                  (_fix x))
           (_equal (_power-eval (_big-plus1 l i base)
                              base)
                  (_plus (_power-eval l base)
                        i))
           (_equal (_power-eval (_big-plus x y i base)
                              base)
                  (_plus i (_plus (_power-eval x base)
                                (_power-eval y base))))
           (_equal (_remainder y 1)
                  (_zero))
           (_equal (_lessp (_remainder x y)
                         y)
                  (_not (_zerop y)))
           (_equal (_remainder x x)
                  (_zero))
           (_equal (_lessp (_quotient i j)
                         i)
                  (_and (_not (_zerop i))
                       (_or (_zerop j)
                           (_not (_equal j 1)))))
           (_equal (_lessp (_remainder x y)
                         x)
                  (_and (_not (_zerop y))
                       (_not (_zerop x))
                       (_not (_lessp x y))))
           (_equal (_power-eval (_power-rep i base)
                              base)
                  (_fix i))
           (_equal (_power-eval (_big-plus (_power-rep i base)
                                        (_power-rep j base)
                                        (_zero)
                                        base)
                              base)
                  (_plus i j))
           (_equal (_gcd x y)
                  (_gcd y x))
           (_equal (_nth (_append a b)
                       i)
                  (_append (_nth a i)
                          (_nth b (_difference i (_length a)))))
           (_equal (_difference (_plus x y)
                              x)
                  (_fix y))
           (_equal (_difference (_plus y x)
                              x)
                  (_fix y))
           (_equal (_difference (_plus x y)
                              (_plus x z))
                  (_difference y z))
           (_equal (_times x (_difference c w))
                  (_difference (_times c x)
                              (_times w x)))
           (_equal (_remainder (_times x z)
                             z)
                  (_zero))
           (_equal (_difference (_plus b (_plus a c))
                              a)
                  (_plus b c))
           (_equal (_difference (_add1 (_plus y z))
                              z)
                  (_add1 y))
           (_equal (_lessp (_plus x y)
                         (_plus x z))
                  (_lessp y z))
           (_equal (_lessp (_times x z)
                         (_times y z))
                  (_and (_not (_zerop z))
                       (_lessp x y)))
           (_equal (_lessp y (_plus x y))
                  (_not (_zerop x)))
           (_equal (_gcd (_times x z)
                       (_times y z))
                  (_times z (_gcd x y)))
           (_equal (_value (_normalize x)
                         a)
                  (_value x a))
           (_equal (_equal (_flatten x)
                         (_cons y (_nil)))
                  (_and (_nlistp x)
                       (_equal x y)))
           (_equal (_listp (_gopher x))
                  (_listp x))
           (_equal (_samefringe x y)
                  (_equal (_flatten x)
                         (_flatten y)))
           (_equal (_equal (_greatest-factor x y)
                         (_zero))
                  (_and (_or (_zerop y)
                           (_equal y 1))
                       (_equal x (_zero))))
           (_equal (_equal (_greatest-factor x y)
                         1)
                  (_equal x 1))
           (_equal (_numberp (_greatest-factor x y))
                  (_not (_and (_or (_zerop y)
                                (_equal y 1))
                            (_not (_numberp x)))))
           (_equal (_times-list (_append x y))
                  (_times (_times-list x)
                         (_times-list y)))
           (_equal (_prime-list (_append x y))
                  (_and (_prime-list x)
                       (_prime-list y)))
           (_equal (_equal z (_times w z))
                  (_and (_numberp z)
                       (_or (_equal z (_zero))
                           (_equal w 1))))
           (_equal (_greatereqpr x y)
                  (_not (_lessp x y)))
           (_equal (_equal x (_times x y))
                  (_or (_equal x (_zero))
                      (_and (_numberp x)
                           (_equal y 1))))
           (_equal (_remainder (_times y x)
                             y)
                  (_zero))
           (_equal (_equal (_times a b)
                         1)
                  (_and (_not (_equal a (_zero)))
                       (_not (_equal b (_zero)))
                       (_numberp a)
                       (_numberp b)
                       (_equal (_1- a)
                              (_zero))
                       (_equal (_1- b)
                              (_zero))))
           (_equal (_lessp (_length (_delete x l))
                         (_length l))
                  (_member x l))
           (_equal (_sort2 (_delete x l))
                  (_delete x (_sort2 l)))
           (_equal (_dsort x)
                  (_sort2 x))
           (_equal (_length (_cons x1
                                (_cons x2
                                      (_cons x3 (_cons x4
                                                     (_cons x5
                                                           (_cons x6 x7)))))))
                  (_plus 6 (_length x7)))
           (_equal (_difference (_add1 (_add1 x))
                              2)
                  (_fix x))
           (_equal (_quotient (_plus x (_plus x y))
                            2)
                  (_plus x (_quotient y 2)))
           (_equal (_sigma (_zero)
                         i)
                  (_quotient (_times i (_add1 i))
                            2))
           (_equal (_plus x (_add1 y))
                  (_if (_numberp y)
                      (_add1 (_plus x y))
                      (_add1 x)))
           (_equal (_equal (_difference x y)
                         (_difference z y))
                  (_if (_lessp x y)
                      (_not (_lessp y z))
                      (_if (_lessp z y)
                          (_not (_lessp y x))
                          (_equal (_fix x)
                                 (_fix z)))))
           (_equal (_meaning (_plus-tree (_delete x y))
                           a)
                  (_if (_member x y)
                      (_difference (_meaning (_plus-tree y)
                                           a)
                                  (_meaning x a))
                      (_meaning (_plus-tree y)
                               a)))
           (_equal (_times x (_add1 y))
                  (_if (_numberp y)
                      (_plus x (_times x y))
                      (_fix x)))
           (_equal (_nth (_nil)
                       i)
                  (_if (_zerop i)
                      (_nil)
                      (_zero)))
           (_equal (_last (_append a b))
                  (_if (_listp b)
                      (_last b)
                      (_if (_listp a)
                          (_cons (_car (_last a))
                                b)
                          b)))
           (_equal (_equal (_lessp x y)
                         z)
                  (_if (_lessp x y)
                      (_equal t z)
                      (_equal f z)))
           (_equal (_assignment x (_append a b))
                  (_if (_assignedp x a)
                      (_assignment x a)
                      (_assignment x b)))
           (_equal (_car (_gopher x))
                  (_if (_listp x)
                      (_car (_flatten x))
                      (_zero)))
           (_equal (_flatten (_cdr (_gopher x)))
                  (_if (_listp x)
                      (_cdr (_flatten x))
                      (_cons (_zero)
                            (_nil))))
           (_equal (_quotient (_times y x)
                            y)
                  (_if (_zerop y)
                      (_zero)
                      (_fix x)))
           (_equal (_get j (_set i val mem))
                  (_if (_eqp j i)
                      val
                      (_get j mem)))))))

(define (tautologyp x true-lst false-lst)
  (cond ((truep x true-lst)
         '#t)
        ((falsep x false-lst)
         '#f)
        ((not (pair? x))
         '#f)
        ((eq? (car x)
              (quote _if))
         (cond ((truep (cadr x)
                       true-lst)
                (tautologyp (caddr x)
                            true-lst false-lst))
               ((falsep (cadr x)
                        false-lst)
                (tautologyp (cadddr x)
                            true-lst false-lst))
               (else (and (tautologyp (caddr x)
                                      (cons (cadr x)
                                            true-lst)
                                      false-lst)
                          (tautologyp (cadddr x)
                                      true-lst
                                      (cons (cadr x)
                                            false-lst))))))
        (else '#f)))

(define (tautp x)
  (tautologyp (rewrite x)
              '() '()))  ;;; JSM was two #Fs

(define (test)
  (define ans '#f)
  (define term '#f)
  (set! term
        (apply-subst
         (quote ((x _f (_plus (_plus a b)
                            (_plus c (_zero))))
                 (y _f (_times (_times a b)
                             (_plus c d)))
                 (z _f (_reverse (_append (_append a b)
                                       (_nil))))
                 (u _equal (_plus a b)
                          (_difference x y))
                 (w _lessp (_remainder a b)
                          (_member a (_length b)))))
         (quote (_implies (_and (_implies x y)
                              (_and (_implies y z)
                                   (_and (_implies z u)
                                        (_implies u w))))
                         (_implies x w)))))
  (set! ans (tautp term))
  ans)

(define (trans-of-implies n)
  (list (quote _implies)
        (trans-of-implies1 n)
        (list (quote _implies)
              0 n)))

(define (trans-of-implies1 n)
  (cond ((equal? n 1)
         (list (quote _implies)
               0 1))
        (else (list (quote _and)
                    (list (quote _implies)
                          (- n 1)
                          n)
                    (trans-of-implies1 (- n 1))))))

(define (truep x lst)
  (or (equal? x (quote (_t)))
      (member x lst)))

(setup)

;;; make sure you've run (setup) then call:  (test)

(lambda () (test))
