;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 2003-2009 Clozure Associates
;;;   This file is part of Clozure CL.  
;;;
;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with Clozure CL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html

(in-package "CCL")


;;; A (partial) implementation of SPLAY-TREEs, which are binary trees
;;; that reorganize themselves so that the most recently accessed keys
;;; cluster near the tree's root.

(defstruct (tree-node
             (:constructor make-tree-node (key value)))
  key
  value
  left                                  ; the child < this key, or NIL
  right                                 ; the child > this key, or NIL
  parent                                ; we're the root if NIL.   
  )

(defmethod print-object ((node tree-node) stream)
  (print-unreadable-object (node stream :type t :identity t)
    (let* ((*print-circle* t))
      (format stream "~s -> ~s" (tree-node-key node) (tree-node-value node)))))


(defun tree-node-is-leaf (n)
  (and (null (tree-node-left n))
       (null (tree-node-right n))))

(defun tree-node-is-root (n)
  (null (tree-node-parent n)))

;;; Is node the left child of its parent ?
(defun tree-node-is-left (n)
  (let* ((parent (tree-node-parent n)))
    (and parent (eq n (tree-node-left parent)))))

(defun tree-node-is-right (n)
  (let* ((parent (tree-node-parent n)))
    (and parent (eq n (tree-node-right parent)))))

(defun tree-node-set-right (node newright)
  (when (setf (tree-node-right node) newright)
    (setf (tree-node-parent newright) node)))

(defun tree-node-set-left (node newleft)
  (when (setf (tree-node-left node) newleft)
    (setf (tree-node-parent newleft) node)))             

(defun tree-node-replace-child (node old new)
  (if (eq old (tree-node-left node))
    (tree-node-set-left node new)
    (tree-node-set-right node new)))

(defstruct (splay-tree (:constructor %make-splay-tree))
  (root nil #|:type (or null splay-tree-node)|#)
  equal                                 ; true if x = y
  less                                  ; true if x < y
  (count 0)
  )

(defmethod print-object ((tree splay-tree) stream)
  (print-unreadable-object (tree stream :type t :identity t)
    (format stream "count = ~d, root = ~s"
	    (splay-tree-count tree)
	    (splay-tree-root tree))))
	    


;;; Returns tree-node or NIL
(defun binary-tree-get (tree key)
  (do* ((equal (splay-tree-equal tree))
        (less (splay-tree-less tree))
        (node (splay-tree-root tree)))
       ((null node))
    (let* ((node-key (tree-node-key node)))
      (if (funcall equal key node-key)
        (return node)
        (if (funcall less key node-key)
          (setq node (tree-node-left node))
          (setq node (tree-node-right node)))))))

;;; No node with matching key exists in the tree
(defun binary-tree-insert (tree node)
  (let* ((root (splay-tree-root tree)))
    (if (null root)
      (setf (splay-tree-root tree) node)
      (do* ((less (splay-tree-less tree))
            (key (tree-node-key node))
            (current root)
            (parent nil))
           ((null current)
            (if (funcall less key (tree-node-key parent))
              (tree-node-set-left parent node)
              (tree-node-set-right parent node)))
        (setq parent current)
        (if (funcall less key (tree-node-key current))
          (setq current (tree-node-left current))
          (setq current (tree-node-right current))))))
  (incf (splay-tree-count tree)))
    
            
;;; Replace the node's parent with the node itself, updating the
;;; affected children so that the binary tree remains properly
;;; ordered.
(defun binary-tree-rotate (tree node)
  (when (and node (not (tree-node-is-root node)))
    (let* ((parent (tree-node-parent node))
           (grandparent (if parent (tree-node-parent parent)))
           (was-left (tree-node-is-left node)))
      (if grandparent
        (tree-node-replace-child grandparent parent node)
        (setf (splay-tree-root tree) node
              (tree-node-parent node) nil))
      (if was-left
        (progn
          (tree-node-set-left parent (tree-node-right node))
          (tree-node-set-right node parent))
        (progn
          (tree-node-set-right parent (tree-node-left node))
          (tree-node-set-left node parent))))))

;;; Keep rotating the node (and maybe its parent) until the node's the
;;; root of tree.
(defun splay-tree-splay (tree node)
  (when node
    (do* ()
         ((tree-node-is-root node))
      (let* ((parent (tree-node-parent node))
             (grandparent (tree-node-parent parent)))
        (cond ((null grandparent)
               (binary-tree-rotate tree node)) ; node is now root
              ((eq (tree-node-is-left node)
                   (tree-node-is-left parent))
               (binary-tree-rotate tree parent)
               (binary-tree-rotate tree node))
              (t
               (binary-tree-rotate tree node)
               (binary-tree-rotate tree node)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The more-or-less public API follows.
;;;
;;; I suppose that we should support DELETE as well, and perhaps
;;; UPDATE (find the node and modify its key in place.)  For now,
;;; SPLAY-TREE-PUT assumes that no node with a matching key exists.
;;; Access to the tree has to be serialized by the caller.

(defun splay-tree-get (tree key &optional default)
  (let* ((node (binary-tree-get tree key)))
    (if node
      (progn
        (splay-tree-splay tree node)
        (tree-node-value node))
      default)))

(defun splay-tree-put (tree key value)
  (let* ((node (make-tree-node key value)))
    (binary-tree-insert tree node)
    (splay-tree-splay tree node)
    value))

;;; Note that the tree wants two comparison functions.  This may
;;; increase the chance that builtin CL functions can be used; a tree
;;; whose keys are real numbers could use #'= and #'<, for instance.
;;; Using two comparison functions is (at best) only slightly better
;;; than insisting that a single comparison function return (values
;;; equal less), or (member -1 0 1), or some other convention.

(defun make-splay-tree (equal less)
  (check-type equal function)
  (check-type less function)
  (%make-splay-tree :equal equal :less less))

;;; Do an inorder traversal of the splay tree, applying function F
;;; to the value of each node.

(defun map-splay-tree (tree f)
  (labels ((map-tree-node (node)
	     (when node
	       (map-tree-node (tree-node-left node))
	       (funcall f (tree-node-value node))
	       (map-tree-node (tree-node-right node)))))
    (map-tree-node (splay-tree-root tree))))

(defun map-splay-tree-keys-and-values (tree f)
  (labels ((map-tree-node (node)
	     (when node
	       (map-tree-node (tree-node-left node))
	       (funcall f (tree-node-key node) (tree-node-value node))
	       (map-tree-node (tree-node-right node)))))
    (map-tree-node (splay-tree-root tree))))