;;; Functions for checking and defining functions which are simple
;;; and tail-form.

(printf "check-tailform.s Tue Jun  1 10:27:41 1993~%")

;;; Tue Jun  1 10:27:51 1993 fixed mapand-tail-nontail to recognize
;;; that else-line in record-case only has two components

;;; Need to fix .chezrc and check-tailform.s to use
;;; **simple-operations** instead of **trivials**

;;; updated Fri Nov 13 15:25:47 1992 to use simple in place of
;;; trivial, tail-form in place of tail-recursive.

;;; updated Tue Nov  6 13:16:37 1990 to use new versions of problems

;;; redone Tue Nov  7 09:36:56 1989 to use new defn of simple,
;;; map-tail-non-tail to organize tail-form?

;;; ****************************************************************

;;; Simple Expressions

;;; simple? checks an expression to see if it is simple

(define simple?
  (lambda (exp)
    (cond
      ((symbol? exp) true)
      ((number? exp) true)
      ((boolean? exp) #t)
      ((eqv? (car exp) 'quote) true)    ; all quotations are simple
      ((eqv? (car exp) 'lambda)
       (tail-form? (caddr exp))) 
      ((memq (car exp) **trivials**)
       (mapand (map simple? (cdr exp))))
      (else false))))

;; if **trivials** is not yet defined, then define it.

(if (not (top-level-bound? '**trivials**)) (define **trivials** '()))
  
;; We may want to add to this list

(set! **trivials** (append
  '(car cdr cons eqv? symbol? zero? + - * add1 sub1
     < > = eq? or and equal?		; equal? is probably a cheat
     pair? null? not atom? list)
  **trivials**))

;; mapand takes the "and" of its arguments:

(define mapand
  (lambda (l)
    (if (null? l) true
        (and (car l) (mapand (cdr l))))))

;; Now we will define a new special form for defining new simple
;; functions:

; why not (define-simple name body) ??

(extend-syntax (define-simple)
  ((define-simple name (lambda args body))
   (if (simple? 'body)
       (begin
        (if (memq 'name **trivials**) nil
            (set! **trivials** (cons 'name **trivials**)))
        (define name (lambda args body)))
       (error 'define-simple" ~s has non-simple body" 'name))))

; Example:

(define-simple mycadr (lambda (x) (car (cdr x))))

;; ***************************************************************

;; Now we'll do the same for tail-form expressions.  In tail
;; form, every expression appearing in an argument (non-tail) position
;; must be simple; expressions in tail positions need only be tail-form. 

(define constant?
  (lambda (exp)
    (or (symbol? exp)
	(number? exp)
        (boolean? exp)
	(and (pair? exp)
	     (eq? (car exp) 'quote)))))

(define mapand-tail-non-tail
  (lambda (exp const-proc tail-proc non-tail-proc)
    ;; applies tail-proc to each tail position and non-tail-proc to
    ;; each non-tail position; takes the "and" of each
    (if (constant? exp)
      (const-proc exp)
      (record-case exp
	(if (test m n)
	  (and (non-tail-proc test)
	       (tail-proc m)
	       (tail-proc n)))
	(lambda (vars b)
	  (tail-proc b))
	(record-case (arg . alternatives)
	  (and (non-tail-proc arg)
	       (mapand (map (lambda (e) 
                              (if (and (eq? (car e) 'else)
                                       (= (length e) 2))
                                (tail-proc (cadr e))
                                (tail-proc (caddr e))))
			    alternatives))))
	(cond alternatives
	  (mapand (map (lambda (alt)
			 (and (non-tail-proc (car alt))
			      (tail-proc (car alt))
			      (tail-proc (cadr alt))))
		       alternatives)))
	(letrec (defs body)
	  (and (tail-proc body)
	       (mapand (map (lambda (def)
			      (and (symbol? (car def))
				   (non-tail-proc (cadr def))))
			    defs))))
	(let (defs body)
	  (and (tail-proc body)
	       (mapand (map (lambda (def)
			      (and (symbol? (car def))
				   (non-tail-proc (cadr def))))
			    defs))))
	(set! (id body)
	  (and (symbol? id)
	       (non-tail-proc body)))
	(else
	  (let ((rator (car exp)) (rands (cdr exp)))
	    (and (tail-proc rator)
		 (mapand (map non-tail-proc rands)))))
	))))

;; now we define the predicate tail-form? using this mapping
;; function to check each tail- and non-tail-position.

(define tail-form?
  (lambda (exp)
    (let
      ((simple?
	 ;; redefine simple? to complain in case of error 
	 (let
	   ((errstring
	      "Error: Non-simple subexpression ~s~%in argument position of ~s~%"))
	   (lambda (subexp)
	     (if (simple? subexp)
	       #t
	       (begin
		 (printf errstring subexp exp)
		 #f))))))
      (mapand-tail-non-tail exp
	(lambda (exp) #t)		; constants are always tail-form
	tail-form?			; tail positions must be tail-form
	simple?                         ; non-tail positions must be simple 
	))))

(extend-syntax (define-tail-form)
  ((define-tail-form name (lambda args body))
   (if (tail-form? 'body)
       (define name (lambda args body))
       (error 'define-tail-form "~s not tail-form" 'name))))

;; example:

(define-tail-form fact
  (lambda (n k)
    (if (zero? n) (k 1)
        (fact (- n 1) (lambda (v) (k (* n v)))))))

;; now we can write things like (fact 3 (lambda (x) x))

;; **********************************

;; Examples to be modified for machine problem:

(define init-cont
   (lambda (x)
      (printf "The answer is: ~s~%" x)))      

(define remove*
  (lambda (a alst)
    (cond
      ((null? alst) '())
      ((pair? (car alst))
       (cons (remove* a (car alst))
	     (remove* a (cdr alst))))
      ((eq? (car alst) a) (remove* a (cdr alst)))
      (else (cons (car alst) (remove* a (cdr alst)))))))

(define member*
  (lambda (a alst)
    (cond
      ((null? alst) #f)
      ((pair? (car alst))
       (or (member* a (car alst))
	   (member* a (cdr alst))))
      ((eq? (car alst) a) alst)
      (else (member* a (cdr alst))))))

(define remfirst*
  (lambda (a alst)
    (letrec ((loop 
               (lambda (alst)
		 (cond
		   ((null? alst) '())
		   ((not (pair? (car alst)))
		    (if (eq? (car alst) a)
		      (cdr alst)
		      (cons (car alst)
			    (loop (cdr alst)))))
		   ((equal? (loop (car alst)) (car alst))
		    (cons (car alst) (loop (cdr alst))))
		   (else (cons (loop (car alst))
			       (cdr alst)))))))
      (loop alst))))

(define depth
  (lambda (alst)
    (cond
      ((null? alst) 1)
      ((not (pair? (car alst))) (depth (cdr alst)))
      ((< (+ (depth (car alst)) 1) (depth (cdr alst)))
       (depth (cdr alst)))
      (else (+ (depth (car alst)) 1)))))

(define depth-with-let
  (lambda (alst)
    (if (null? alst)
      1
      (let ((drest (depth (cdr alst))))
	(if (pair? (car alst))
	  (let ((dfirst (+ (depth (car alst)) 1)))
	    (if (< dfirst drest) drest dfirst))
	  drest)))))

;;; Don't forget map-cps, fnlr>n, and add>n !!