(load-from-lib "ch4.ss")
(load-from-lib "trees.ss")

;; (remove-left-most 'b '(a (b c) () (c (b a))))
;;                  ==> (a (c) () (c (b a)))
;; (remove-left-most 'c '(a (b c) () (c (b a))))
;;                   ==> (a (b) () (c (b a)))
;; (remove-left-most 'a '()) ==> ()


;; The following is an initial version, based strictly on the pattern
;; discussed for tree of atomic-item recursion in class.

(DEFINE remove-left-most
  ; TYPE: (-> (atomic-item (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item tr)
  (COND
   ((tree-empty? tr) the-empty-tree)
   ((atomic-item? (tree-first tr))
    (COND
      ((equal? item (tree-first tr))
       (tree-rest tr))
      (ELSE (tree-cons                   ; *
	      (tree-first tr)
	      (remove-left-most item (tree-rest tr))))))
   (ELSE
    (COND
      ((member-all? item (tree-first tr))
       (tree-cons
	 (remove-left-most item (tree-first tr))
	 (tree-rest tr)))
     (ELSE (tree-cons                    ; *
	     (tree-first tr)
	     (remove-left-most item (tree-rest tr)))))))))

;; Note that the 2 ELSE subcases above, marked * are the same.
;; In order to combine them, first bring all the conditions out
;; to the top level, by making the implicit dependencies on
;; evaluation order all explicit.  This gives the following version.

(DEFINE remove-left-most
  ; TYPE: (-> (atomic-item (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item tr)
  (COND
   ((tree-empty? tr) the-empty-tree)
   ((atomic-item? (tree-first tr))
    (COND
      ((and (atomic-item? (tree-first tr))
	    (equal? item (tree-first tr)))
       (tree-rest tr))
      ((and (atomic-item? (tree-first tr))
	    (not (equal? item (tree-first tr))))
       (tree-cons                         ; *
	 (tree-first tr)
	 (remove-left-most item (tree-rest tr))))))
   ((not (atomic-item? (tree-first tr)))
    (COND
      ((and (not (atomic-item? (tree-first tr)))
	    (member-all? item (tree-first tr)))
       (tree-cons
	 (remove-left-most item (tree-first tr))
	 (tree-rest tr)))
      ((and (not (atomic-item? (tree-first tr)))
	    (not (member-all? item (tree-first tr))))
       (tree-cons                          ; *
	 (tree-first tr)
	 (remove-left-most item (tree-rest tr)))))))))

;; Since the outer COND's tests are now redundant, the inner cond tests
;; can be moved to the outer level of the cond.  This gives the following.
;; Incidently, note that this shows the information accumulated in the above
;; versions during evaluation of the COND.

(DEFINE remove-left-most
  ; TYPE: (-> (atomic-item (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item tr)
  (COND
   ((tree-empty? tr) the-empty-tree)
   ((and (atomic-item? (tree-first tr))
	 (equal? item (tree-first tr)))
    (tree-rest tr))
   ((and (atomic-item? (tree-first tr))
	 (not (equal? item (tree-first tr))))
    (tree-cons                           ; *
      (tree-first tr)
      (remove-left-most item (tree-rest tr))))
   ((and (not (atomic-item? (tree-first tr)))
	 (member-all? item (tree-first tr)))
    (tree-cons
      (remove-left-most item (tree-first tr))
      (tree-rest tr)))
   ((and (not (atomic-item? (tree-first tr)))
	 (not (member-all? item (tree-first tr))))
    (tree-cons                           ; *
      (tree-first tr)
      (remove-left-most item (tree-rest tr))))
   )))

;; Now the clauses can be rearranged, since the information that was
;; implicit in the evaluation order is now explicit; that is, it makes no
;; difference in what order the clauses are evaluated (execpt the first).

(DEFINE remove-left-most
  ; TYPE: (-> (atomic-item (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item tr)
  (COND
   ((tree-empty? tr) the-empty-tree)
   ((and (atomic-item? (tree-first tr))
	 (equal? item (tree-first tr)))
    (tree-rest tr))
   ((and (not (atomic-item? (tree-first tr)))
	 (member-all? item (tree-first tr)))
    (tree-cons
      (remove-left-most item (tree-first tr))
      (tree-rest tr)))
   ((and (atomic-item? (tree-first tr))
	 (not (equal? item (tree-first tr))))
    (tree-cons                           ; *
      (tree-first tr)
      (remove-left-most item (tree-rest tr))))
   ((and (not (atomic-item? (tree-first tr)))
	 (not (member-all? item (tree-first tr))))
    (tree-cons                           ; *
      (tree-first tr)
      (remove-left-most item (tree-rest tr))))
   )))

;; Now combine the two * clauses, by combining their tests.

(DEFINE remove-left-most
  ; TYPE: (-> (atomic-item (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item tr)
  (COND
   ((tree-empty? tr) the-empty-tree)
   ((and (atomic-item? (tree-first tr))
	 (equal? item (tree-first tr)))
    (tree-rest tr))
   ((and (not (atomic-item? (tree-first tr)))
	 (member-all? item (tree-first tr)))
    (tree-cons
      (remove-left-most item (tree-first tr))
      (tree-rest tr)))
   ((or (and (atomic-item? (tree-first tr))
	     (not (equal? item (tree-first tr))))
	(and (not (atomic-item? (tree-first tr)))
	     (not (member-all? item (tree-first tr)))))
    (tree-cons                           ; *
      (tree-first tr)
      (remove-left-most item (tree-rest tr))))
   )))

;; The condition guarding the clause * is complex, but since it is now
;; the last condition it simplifies to ELSE!

(DEFINE remove-left-most
  ; TYPE: (-> (atomic-item (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item tr)
  (COND
   ((tree-empty? tr) the-empty-tree)
   ((and (atomic-item? (tree-first tr))
	 (equal? item (tree-first tr)))
    (tree-rest tr))
   ((and (not (atomic-item? (tree-first tr)))
	 (member-all? item (tree-first tr)))
    (tree-cons
      (remove-left-most item (tree-first tr))
      (tree-rest tr)))
   (ELSE
    (tree-cons                           ; *
      (tree-first tr)
      (remove-left-most item (tree-rest tr))))
   )))

;; This is about as far as one can simplify without generalizing the procedure.
;; If one generalizes the procedure, it can be simplified even more
;; by allowing not just atomic-items, but any Scheme datum as an argument.
;; That is, if the type is changed to:
;;      (-> (datum (tree atomic-item)) (tree atomic-item))
;; then one would be forced to test the first item in the tree for equality,
;; regardless of whether it is atomic.  So the 2nd cond test is simplified
;; as follows.  (We change the procedure's name too,
;; as it is no longer doing the same thing).

(DEFINE remove-leftmost
  ; TYPE: (-> (datum (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item tr)
  (COND
   ((tree-empty? tr) '())
   ((equal? item (tree-first tr))     ; simplified
    (tree-rest tr))
   ((and (not (atomic-item? (tree-first tr)))
	 (member-all? item (tree-first tr)))
    (tree-cons
      (remove-leftmost item (tree-first tr))
      (tree-rest tr)))
   (ELSE
    (tree-cons
      (tree-first tr)
      (remove-leftmost item (tree-rest tr))))
   )))

;; Note that the test protecting the 3rd COND clause is a bit strong,
;; since member-all? (program 4.16 in the book) can take as its
;; second argument a tree of atoms.  The simplification to the test
;; in the 3rd COND clause below is justified by the following calculation.
;;
;;    (not (atomic-item? (tree-first tr)))
;;  = <by def of atomic-item?>
;;    (not ((lambda (x) (not (or (pair? x) (null? x)))) (tree-first tr)))
;;  = <since we don't care about the null? by the above discussion>
;;    (not ((lambda (x) (not (pair? x))) (tree-first tr)))
;;  = <by def of application>
;;    (not (not (pair? (tree-first tr))))
;;  = <by def of not>
;;    (pair? (tree-first tr))

(DEFINE remove-leftmost
  ; TYPE: (-> (datum (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item tr)
  (COND
   ((tree-empty? tr) '())
   ((equal? item (tree-first tr))
    (tree-rest tr))
   ((and (pair? (tree-first tr))
	 (member-all? item (tree-first tr)))
    (tree-cons
      (remove-leftmost item (tree-first tr))
      (tree-rest tr)))
   (ELSE
    (tree-cons
      (tree-first tr)
      (remove-leftmost item (tree-rest tr))))
   )))

;; Finally, by replacing the "tree-..." procedures with their definitions,
;; changing the variable tr to ls, and reformatting,
;; one arrives at program 4.17 in the book:

(DEFINE remove-leftmost
  ; TYPE: (-> (datum (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item ls)
  (COND
   ((null? ls) '())
   ((equal? item (car ls)) (cdr ls))
   ((and (pair? (car ls)) (member-all? item (car ls)))
    (cons (remove-leftmost item (car ls)) (cdr ls)))
   (ELSE (cons (car ls) (remove-leftmost item (cdr ls)))))))

;; Compare the above with the final version of remove-left-most with the same
;; superficial changes (replacing the tree-... procedures with their defs,
;; and and changing tr to ls), which follows.

(DEFINE remove-left-most
  ; TYPE: (-> (atomic-item (tree atomic-item)) (tree atomic-item))
 (LAMBDA (item ls)
  (COND
   ((null? ls) '())
   ((and (atomic-item? (car ls)) (equal? item (car ls))) (cdr ls))
   ((and (not (atomic-item? (car ls))) (member-all? item (car ls)))
    (cons (remove-left-most item (car ls)) (cdr ls)))
   (ELSE (cons (car ls) (remove-left-most item (cdr ls)))))))