(DefFlavor Binary-Tree
	   (label
	    (weight 0)
	    (left-child nil)
	    (right-child nil)
	    (chain nil))
	   ()
  :settable-instance-variables
  :gettable-instance-variables)

(DeFun Binary-Tree-P (tree)
    (typep tree '(or Binary-Tree null)))

(DeFun Left (tree)
  (send tree :left-child))

(DeFun Right (tree)
  (send tree :right-child))

(DefMacro Left (tree)
  `(send ,tree :left-child))

(DefMacro Right (tree)
  `(send ,tree :right-child))

(DeFun New-Tree(label &key left right)
  (setq left (coerce-tree left))
  (setq right (coerce-tree right))
  (make-instance 'binary-tree :label label :left-child left :right-child right))

(DeFun Coerce-Tree(thing)
  (typecase thing
    (null nil)
    (binary-tree thing)				;ok, it's already a binary tree
    (t
     (make-instance 'binary-tree :label thing))	;thing is the label
    ))

;;;
;;; DFS -- Depth-First-Search routines
;;;

(DefMacro DFS-Body (tree &body body)
  `(or
     (send tree :eval-inside-yourself '(,body))
     (send (send tree :left-child) :eval-inside-yourself '(,body))
     (send (send tree :right-child) :eval-inside-yourself '(,body))))

(DefMacro DFS(tree method &rest args)
  `(when ,tree
     (let*(
	   (tree ,tree)
	   (method ,method)
	   (left  (left tree))
	   (right (right tree))
	   )
       (cond
	 ((null tree) nil)
	 ((send tree  method ,@args))
	 ((dfs  left  method ,@args))
	 ((dfs  right method ,@args))))))

;;;
;;; Alpha -- comparison routines, here because the system versions are munged.
;;;
 
(DEFUN ALPHALESSP (X Y)
  "T if printed representation of X is less than that of Y.
Characters and numbers come before symbols//strings, before random objects, before lists.
Characters and numbers are compared using CHAR<; symbols//strings with STRING-LESSP;
random objecs by printing them(!); lists are compared recursively."
  (IF (INTEGERP X) (SETQ X (INT-CHAR X)))	;correction
  (IF (INTEGERP Y) (SETQ Y (INT-CHAR Y)))	;correction
  (COND ((CHARACTERP X)
	 (OR (NOT (CHARACTERP Y))
	     (CHAR< X Y)))
	((CHARACTERP Y) NIL)
	((OR (SYMBOLP X) (STRINGP X))
	 (OR (NOT (OR (SYMBOLP Y) (STRINGP Y)))
	     (STRING-LESSP X Y)))
	((OR (SYMBOLP Y) (STRINGP Y)) NIL)
	((ATOM X) (OR (CONSP Y)
		      (STRING-LESSP (FORMAT NIL "~S" X) (FORMAT NIL "~S" Y))))
	((ATOM Y) NIL)
	(T (DO ((X1 X (CDR X1)) (Y1 Y (CDR Y1)))
	       ((NULL Y1))
	     (OR X1 (RETURN T))
	     (AND (ALPHALESSP (CAR X1) (CAR Y1)) (RETURN T))
	     (AND (ALPHALESSP (CAR Y1) (CAR X1)) (RETURN NIL))))))

(DEFUN ALPHAEQUAL (X Y)
  "T if X and Y print the same, or nearly so.
Exceptions: numbers and characters are compared using =
and a symbol and its pname compare as equal."
  (IF (INTEGERP X) (SETQ X (INT-CHAR X)))
  (IF (INTEGERP Y) (SETQ Y (INT-CHAR Y)))
  (TYPECASE X
    (CHARACTER
     (AND (CHARACTERP Y)
	  (= X Y)))
    ((OR SYMBOL STRING)
     (AND (OR (SYMBOLP Y) (STRINGP Y))
	  (STRING-EQUAL X Y)))
    (ATOM
     (AND (ATOM Y)
	  (STRING-EQUAL (FORMAT NIL "~S" X) (FORMAT NIL "~S" Y))))
    (T (DO ((X1 X (CDR X1)) (Y1 Y (CDR Y1)))
	   ((NULL X1) (NULL Y1))
	 (OR Y1 (RETURN NIL))
	 (OR (ALPHAEQUAL (CAR X1) (CAR Y1)) (RETURN NIL))))))

(DeFun AlphaGreaterP (a b)		;Assumes AlphaLessp returned NIL
  (not (AlphaEqual a b)))

;;;
;;; Tree (node label) comparison.
;;;

(DeFun Label-Compare (X Y)

  "Label-Compare: (X Y)
   Compares node, tree, or label values X and Y and returns one of
   EQUAL, LESS, or GREATER to indicate the relation between them.
   This routine refuses to be confused -- it's a winner.
   Examples:
	(label-compare 3 3.0) 	=> EQUAL
	(label-compare 'a 'b) 	=> LESS
	(label-compare /"a/" /"A/")	=> GREATER"

  (cond
    ((eql X Y) 'EQUAL)			;Quick compare for some objects
    (t
     (multiple-value-bind
       (less-fn greater-fn)
	 (cond
	   ((typep X 'binary-tree)
	    (return-from label-compare
	      (label-compare (send X :label) Y)))
	   ((typep Y 'binary-tree)
	    (return-from label-compare
	      (label-compare X (send Y :label))))
	   ((equal (type-of X) (type-of Y))
	    (typecase X
	      (number
	       (values #'lessp #'greaterp))
	      (character
	       (values #'char-lessp #'char-greaterp))
	      (string
	       (values #'string< #'string>))
	      (symbol
	       (values #'string-lessp #'string-greaterp))
	      (t
	       (values #'alphalessp #'alphagreaterp))))
	   ((and
	      (typep X '(or string symbol))
	      (typep Y '(or string symbol)))
	    (values #'string-lessp #'string-greaterp))
	   ((equalp X Y) (return-from label-compare 'EQUAL))
 	   (t
	    (values #'alphalessp #'alphagreaterp)))
       (cond
	 ((funcall less-fn X Y)    'LESS)
	 ((funcall greater-fn X Y) 'GREATER)
	 (t 'EQUAL))))))

(DefMacro Label< (x y)
  `(equal (Label-Compare ,x ,y) 'LESS))

(DefMacro Label= (x y)
  `(equal (Label-Compare ,x ,y) 'EQUAL))

(DefMacro Label> (x y)
  `(equal (Label-Compare ,x ,y) 'GREATER))

;;;
;;; Now we start to do binary tree stuff, for real.
;;;

(DefMethod (Binary-Tree :Insert) (node)		

  "(send <tree> :insert <node>) --
Insert <node> into <tree> appropriately.
  If <node> is not a binary tree, it becomes one with old <node> value
  as the label value.
  Value returned is <node>."

  (when node
    (let*(
	  (tree self)
	  (node (coerce-tree node))
	  (compared (Label-Compare node tree))
	  )
      (case compared
	(EQUAL tree)
	(LESS
	 (if (null (left tree))
	     (setf (left tree) node)
	   (send (left tree) :Insert node)))
	(GREATER
	 (if (null (right tree))
	     (setf (right tree) node)
	   (send (right tree) :Insert node)))))))


(DefMethod (Binary-Tree :Count-Children) ()
  (let*(
       (left (send self :left-child))
       (nleft (if left (add1 (send left :number-of-children)) 0))
       (right (send self :right-child))
       (nright (if right (add1 (send right :number-of-children)) 0))
      )
    (cond
      ((null self) 0)
      (t (plus nleft nright)))))

(DefMethod (Binary-Tree calc-weight) () )

(DefMethod (Binary-Tree :match-node) (label)
  (if (equal label (send self :label)) self)) 

(Defun test ()
  (let(
       (tree (make-instance 'binary-tree))
      )
    (binary-tree-p tree)))