(defpackage :bintree
  (:use :cl )
  (:export ))
(in-package :bintree)

(defclass bintree ()
  ((value :initarg :value :accessor node-value)
   (%left :initarg :left :accessor tree-left :initform nil)
   (%right :initarg :right :accessor tree-right :initform nil)))

(define-condition constraint-violated (serious-condition)
  ())

(defmethod (setf tree-left) :before ((new-value bintree) (object bintree))
  (unless (<= (node-value new-value)
              (node-value object))
    (error 'constraint-violated)))

(defmethod (setf tree-left) ((new-value integer) (object bintree))
  (setf (tree-left object) (make-instance 'bintree :value new-value)))

(defmethod (setf tree-right) :before ((new-value bintree) (object bintree))
  (unless (> (node-value new-value)
             (node-value object))
    (error 'constraint-violated)))

(defmethod (setf tree-right) ((new-value integer) (object bintree))
  (setf (tree-right object) (make-instance 'bintree :value new-value)))

(defun insert (tree value)
  (if (<= value (node-value tree))
      (if (null (tree-left tree))
          (setf (tree-left tree) value)
          (insert (tree-left tree) value))
      (if (null (tree-right tree))
          (setf (tree-right tree) value)
          (insert (tree-right tree) value))))

(defun rotate (tree direction)
  (ecase direction
    (:right (let* ((right-child (tree-right tree))
                   (left-of-right (tree-left right-child)))
              (setf (tree-left right-child) tree
                    (tree-right tree) left-of-right)
              right-child))
    (:left (let* ((left-child (tree-left tree))
                  (right-of-left (tree-right left-child)))
             (setf (tree-right left-child) tree
                   (tree-left tree) right-of-left)
             left-child))))

(defun list->tree (list)
  (declare (optimize (debug 3)))
  (destructuring-bind (root . rest) list
    (let ((result (make-instance 'bintree :value root)))
      (mapcar (lambda (v) (insert result v))
              rest)
      result)))

(defmethod print-object ((object bintree) stream)
  (labels ((print-node (node stream)
             (if node
                 (format stream "~a (~a) (~a)"
                         (node-value node)
                         (print-node (tree-left node) nil)
                         (print-node (tree-right node) nil))
                 (format stream "~a" node))))
    (print-unreadable-object (object stream :type t :identity t)
      (format stream "(~a)" (print-node object nil)))))