;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; ;-*-
;;;  Touched: Tue Nov 26 20:47:07 2002 <madhu@unm.cs>
;;;  Time-stamp: <2007-06-16 12:58:22 madhu>
;;;  Bugs-To: <enometh@net.meer>
;;;
;;; (C) Copyright 2002, 2006 Madhu. All rights Reserved.
;;; $Id: treap.lisp,v 1.5 2006/05/28 16:09:31 madhu Exp madhu $
;;;
(cl:defpackage  "TREAP"
  (:use "CL")
  (:shadow "<")				; XXX
  (:export "BASIC-TREAP-NODE-MIXIN"
	   "ROOT"
	   "STORE"
	   "RETRACT"
	   "FIND-KEY"
	   "KEY"
	   "FIND-SMALLEST"
	   "FIND-LARGEST"
	   ;;
	   "MAP-TREAP"
	   "MAP-TREAP>"
	   "MAP-TREAP<"
	   "MAP-TREAP<>"
	   "MAP-TREAP<=>"
	   ;;
	   "FIND-KEY<"
	   "FIND-KEY>"
	   "FIND-KEY<="
	   "FIND-KEY>="
	   ;;
	   "TREAP"
	   "TREAP-NODE"
	   "VALUE"
	   ;;
	   "MAKE-TREAP"
	   "GETTREAP"
	   "SETTREAP"
	   "REMTREAP"
	   "MAPTREAP"
	   ;;
	   "TREAP-LENGTH"
	   "TREAP-FIND-BOUNDS"
	   "TREAP-FIND-BOUNDS<=>"

	   ;;
	   "TREAP-SET-MINMAX"
	   "MAPTREAP-BOUNDED"
	   ))
(cl:in-package "TREAP")

(defvar *predicate-for-comparing-treap-nodes*) ; unbound!

(defmacro TREAP::< (arg1 arg2)
  `(if (boundp '*predicate-for-comparing-treap-nodes*)
       (funcall *predicate-for-comparing-treap-nodes* ,arg1 ,arg2)
       (CL:< ,arg1 ,arg2)))

;; compiling with the :no-predicates feature will turn off support for
;; *predicate-for-comparing-treap-nodes*.

#+no-predicates
(defmacro TREAP::< (&rest args) `(CL:< ,@args))

;;
;; other compile-time features: no-minmax-support, persistent-treap
;;

(defclass basic-treap-node-mixin ()
  ((key
    :initarg :key
    :accessor key)
   (priority
    :initform (random 1.0)
    :accessor priority)
   (up
    :initform nil
    :accessor up)
   (left
    :initform nil
    :accessor left)
   (right
    :initform nil
    :accessor right))
  #+persistent-treap
  (:metaclass db-impl:persistent-metaclass)
  (:documentation
   "
;; This obligatory Treap class implements a mostly O(log n) ordering of
;; `Key's based on radnomized search trees [Seidel R, Aargon CR
;; Algorithmica 16(4/5) 1996]
;;
;; SYNOPSIS:
;;
;; Mix BASIC-TREAP-NODE-MIXIN into any object and your objects can be nodes
;; of a treap. `Key' must have the #'< operator defined.
;;
;; If the special variable *PREDICATE-FOR-COMPARING-TREAP-NODES* is
;; unbound, the nodes will be implicitly compared by #'CL:< (the
;; default.) Otherwise the function it is bound to is used.
;;
;;  EXAMPLES:
;;
;;(defclass foo (treap:basic-treap-node-mixin) ())
;;(setq foo-obj (make-instance 'foo :key 100))
;;(setq root foo-obj)
;;(treap:key root)
;;(setq root (treap:store root (make-instance 'foo :key 200)))
;;(setq foo-obj (treap:find-key root 100))
;;(setq smallest (treap:find-smallest foo-obj))
;;(setq largest  (treap:find-largest foo-obj))
;;(setq root (treap:root foo-obj))
;;(setq root (treap:retract smallest))
"))


;;; ----------------------------------------------------------------------
;;;
;;;
(defmethod $role-in-parent ((node basic-treap-node-mixin))
  "Return :left :right or nil if NODE is a left child, right child, or root."
  (let ((parent (up node)))
    (when parent
      (assert (or (eq (left parent) node) (eq (right parent) node)))
      (if (eq (left parent) node) :left :right))))

(defmethod $rotate-left ((node basic-treap-node-mixin))
  "Rotate tree rooted at NODE to the left."
  (let ((parent (up node))
	(role ($role-in-parent node))
	(temp (right node)))
    (when (left temp) (setf (up (left temp)) node))
    (setf (right node) (left temp)
	  (left temp) node
	  (up node) temp
	  (up temp) parent)
    (case role
      (:left (setf (left parent) temp))
      (:right (setf (right parent) temp)))
    temp))

(defmethod $rotate-right ((node basic-treap-node-mixin))
  "Rotate tree rooted at NODE to the right."
  (let ((parent (up node))
	(role ($role-in-parent node))
	(temp (left node)))
    (when (right temp) (setf (up (right temp)) node))
    (setf (left node) (right temp)
	  (right temp) node
	  (up node) temp
	  (up temp) parent)
    (case role
      (:left (setf (left parent) temp))
      (:right (setf (right parent) temp)))
    temp))

(defmethod $replace ((tree basic-treap-node-mixin) (node basic-treap-node-mixin))
  "Splice NODE into TREE's place in the treap. remove TREE."
  (setf (left node) (left tree)
	(right node) (right tree)
	(priority node) (priority tree)
	(up node) (up tree))
  (let ((role ($role-in-parent tree)))
    (when (left tree) (setf (up (left tree)) node))
    (when (right tree) (setf (up (right tree)) node))
    (case role
      (:left (setf (left (up tree)) node))
      (:right (setf (right (up tree)) node))))
  (setf (left tree) nil
	(right tree) nil
	(up tree) nil)
  node)

(defmethod $store ((tree basic-treap-node-mixin) (node basic-treap-node-mixin))
  (cond ((< (key node) (key tree))
	 (if (left tree)
	     (setf (left tree) ($store (left tree) node))
	     (setf (up node) tree
		   (left tree) node))
	 (if (> (priority tree) (priority (left tree)))
	     ($rotate-right tree)
	     tree))
	((< (key tree) (key node))
	 (if (right tree)
	     (setf (right tree) ($store (right tree) node))
	     (setf (up node) tree
		   (right tree) node))
	 (if (> (priority tree) (priority (right tree)))
	     ($rotate-left tree)
	     tree))
	(t ($replace tree node))))

(defmethod $reparent-and-remove ((tree basic-treap-node-mixin) node)
  "Adjust TREE's parent to be NODE's parent instead. remove TREE."
  (when node
    (let ((parent (up tree))
	  (role ($role-in-parent tree)))
      (setf (up node) parent)
      (case role
	(:left (setf (left parent) node))
	(:right (setf (right parent) node)))))
  (setf (left tree) nil
	(right tree) nil
	(up tree) nil)
  node)

(defmethod $delete-root ((tree basic-treap-node-mixin))
  (cond ((null (left tree)) ($reparent-and-remove tree (right tree)))
	((null (right tree)) ($reparent-and-remove tree (left tree)))
	((< (priority (left tree)) (priority (right tree)))
	 (let ((temp ($rotate-right tree)))
	   (setf (right temp) ($delete-root tree))
	   temp))
	(t (let ((temp ($rotate-left tree)))
	     (setf (left temp) ($delete-root tree))
	     temp))))

(defmethod $retract ((tree basic-treap-node-mixin) (node basic-treap-node-mixin))
  "Remove NODE from the treap rooted at TREE."
  (cond ((< (key node) (key tree))
	 (setf (left tree) (if (left tree)
			       ($retract (left tree) node)
			       nil))
	 tree)
	((< (key tree) (key node))
	 (setf (right tree) (if (right tree)
				($retract (right tree) node)
				nil))
	 tree)
	(t ($delete-root tree))))


;;; ----------------------------------------------------------------------
;;;
;;; PUBLIC
;;;
(defmethod root ((tree basic-treap-node-mixin))
  "Return the root node of the treap that contains node TREE."
  (if (up tree)
      (root (up tree))
      tree))

(defmethod find-key ((tree basic-treap-node-mixin) key)
  "Return the node with KEY in the treap that contains node TREE."
  (loop for p = (root tree)
	then (if (< key (key p)) (left p) (right p))
	while (and p (or (< key (key p)) (< (key p) key)))
	finally (return p)))

(defmethod store ((tree basic-treap-node-mixin) (node basic-treap-node-mixin))
  "Store NODE in the treap that contains node TREE. Returns the updated root
node of the treap."
  (let ((root (root tree)))
    (root ($store root node))))

(defmethod retract ((tree basic-treap-node-mixin))
  "Remove node TREE from the treap it is. Return the new root or NIL."
  (let* ((root (root tree))
	 (ret ($retract root tree)))
    (when ret (root ret))))

(defmethod find-smallest ((tree basic-treap-node-mixin))
  "Return the node with the smallest key in the treap that contains node
TREE."
  (loop for p = (root tree) then (left p)
	while (left p)
	finally (return p)))

(defmethod find-largest ((tree basic-treap-node-mixin))
  "Return the node with the largest key in the treap that contains node TREE."
  (loop for p = (root tree) then (right p)
	while (right p)
	finally (return p)))


;;; ----------------------------------------------------------------------
;;;
;;;  Traverse treap in order
;;;

(defun map-treap (tree fn &optional (depth 0))
  (when (left tree)
    (map-treap (left tree) fn (+ depth 2)))
  (funcall fn tree)
  (when (right tree)
    (map-treap (right tree) fn (+ depth 1))))


;;; ----------------------------------------------------------------------
;;;
;;; PUBLIC HASHTABLE INTERFACE
;;;

#-no-minmax-support
(defclass minmax-node-mixin ()
  ((min :accessor min$)
   (max :accessor max$)))

(defclass treap-node (basic-treap-node-mixin #-no-minmax-support minmax-node-mixin)
  ((value))
  #+persistent-treap
  (:metaclass db-impl:persistent-metaclass))

(defclass treap ()
  ((root :initform nil :reader root)
   #-no-predicates
   (predicate-for-comparing-treap-nodes	; unbound OK!
    :initarg :predicate-for-comparison))
  #+persistent-treap
  (:metaclass db-impl:persistent-metaclass))

;;; misnamed
;;; NOTE: Doesnt take a predicate for argument!
(defmacro with-predicate-for-comparing-treap-nodes ((treap) &body body)
  (let ((treap-var (gensym "TREAP-")))
    `(let ((,treap-var ,treap))
       (if (slot-boundp ,treap-var 'predicate-for-comparing-treap-nodes)
	   (let ((*predicate-for-comparing-treap-nodes*
		  (slot-value ,treap-var
			      'predicate-for-comparing-treap-nodes)))
	     ,@body)
	   (progn ,@body)))))

#+no-predicates
(defmacro with-predicate-for-comparing-treap-nodes ((treap) &body body)
  `(progn ,@body))

(defun make-treap (&key #-no-predicates predicate)
  #-no-predicates
  (apply #'make-instance 'treap
	 #-no-predicates (if predicate
			     (list :predicate-for-comparison predicate))))

(defun gettreap (key treap &optional default)
  (check-type treap treap)
  (with-predicate-for-comparing-treap-nodes (treap)
    (with-slots (root) treap
      (when root
	(let ((node (find-key root key)))
	  (if node (slot-value node 'value) default))))))

(defun settreap (key treap value)
  (check-type treap treap)
  (with-predicate-for-comparing-treap-nodes (treap)
    (with-slots (root) treap
      (cond (root
	     (let ((node (find-key root key)))
	       (cond (node (setf (slot-value node 'value) value))
		     (t (let ((new-node (make-instance 'treap-node :key key)))
			  (setf (slot-value new-node 'value) value)
			  (setq root (store root new-node)))))))
	    (t (setq root (make-instance 'treap-node :key key))
	       (setf (slot-value root 'value) value))))))

#+nil
(defsetf gettreap (key treap) (value)
  `(settreap ,key ,treap ,value))

(define-setf-expander gettreap (key treap &optional default)
  (let ((key-var (gensym))
	(treap-var (gensym))
	(default-var (gensym))
	(new-value-var (gensym)))
    (values
     `(,key-var ,treap-var ,@(if default `(,default-var)))
     `(,key ,treap ,@(if default `(,default)))
     `(,new-value-var)
     `(settreap ,key-var ,treap-var ,new-value-var)
     `(gettreap ,key-var ,treap-var ,@(if default `(,default-var))))))

(defun remtreap (key treap)
  (with-predicate-for-comparing-treap-nodes (treap)
    (with-slots (root) treap
      (when root
	(let ((node (find-key root key)))
	  (when node
	    (setq root (retract node))
	    node))))))

(defun maptreap (fn treap )
  (with-predicate-for-comparing-treap-nodes (treap)
    (with-slots (root) treap
      (map-treap root (lambda (x)
			(funcall fn
				 (slot-value x 'key)
				 (slot-value x 'value)))))))

;; Eg:
;;
(defmethod treap-length ((treap treap))
  (let* ((length 0) (tree (slot-value treap 'root)))
    (with-predicate-for-comparing-treap-nodes (treap)
      (map-treap tree (lambda (node)
			(declare (ignore node))
			(incf length)))
      length)))

#||
;;; TESTS
(defmethod $check-node ((node basic-treap-node-mixin))
  (with-slots (left right up) node
    (when left (assert (eq (up left) node)))
    (when right (assert (eq (up right) node)))
    (when up (assert (or (eq (left up) node) (eq (right up) node)))))
  nil)
(defmethod print-object ((node basic-treap-node-mixin) stream)
  (print-unreadable-object (node stream)
      (call-next-method)
    (with-slots (left right up) node
      (format stream "[~a L=~A R=~A U=~A]"
	      (key node)
	      (if left (key left) nil)
	      (if right (key right) nil)
	      (if up (key up) nil)))))
(defun debug-print (tree &optional (level 1) (stream *standard-output*))
  (when (left tree)
    (debug-print (left tree) (+ level 2) stream))
  (format stream "~&~vt~A (~A) = ~A~&"
	  level
	  (key tree)
	  (priority tree)
	  tree)
  (when (right tree)
    (debug-print (right tree) (+ level 1) stream)))
(defvar *root* nil)
(map-treap *root* '$check-node)
(defun make-test-node ()
  (let ((node (make-instance 'basic-treap-node-mixin :key (random 100))))
    (if *root*
	(setq *root* (store *root* node))
	(setq *root* node))))
(loop initially (setq *root* nil)
      for i below 50
      for added = (make-test-node) do
      (format *standard-output* "ADDED ~A~&" added)
      (when *root* (debug-print *root*))
      (format *standard-output*
	      "---------------------------------------------------~&"))
(setq *root* (retract *root*))
;;; JUNK AT EOF:
(treap-length *root*)
(debug-print *root*)
(setq $a (make-instance 'treap))
(setf (gettreap 10 $a) "foo")
(setf (gettreap 320 $a) "foobar")
(setf (gettreap 420 $a) "barbar")
(gettreap 420 $a)
(remtreap 420 $a)
(remtreap 320 $a)
(remtreap 10 $a)
(debug-print (slot-value $a 'root))
(retract (remtreap 10 $a))
(debug-print (slot-value $a 'root))
(root (slot-value $a 'root))
(setq $a (make-instance 'treap :predicate-for-comparison #'>))
(with-predicate-for-comparing-treap-nodes ($a)
  (< 54 545))
(defun extract-nodes (tree &optional &aux cons)
  (when tree
    (list (key tree)
	  (extract-nodes (left tree))
	  (extract-nodes (right tree)))))
(defun extract-edges (tree &optional (depth 0))
  (let (result)
    (when (left tree)
      (setq result (extract-edges (left tree) (+ depth 2)))
      (push (cons (key tree) (key (left tree))) result))
    (when (right tree)
      (setq result (nconc result (extract-edges (right tree) (+ depth 1))))
      (push (cons (key tree) (key (right tree))) result))
    result))
(treap-length $a)
(extract-edges (slot-value $a 'root))
(remtreap 420 $a)
(multiple-value-setq ($cons $table)
  (extract-nodes (slot-value $a 'root)))
;; TODO: support get rid ofchecktypes by doing dispatch, write
;; remove-smallest remove-largest, and :documentation slots
||#


;;; ----------------------------------------------------------------------
;;;
;;; MAPPERS I
;;;
(defun map-treap< (tree fn &optional (depth 0))
  "Maps fn on all nodes of the treap that are less than node TREE."
  (when (left tree)
    (map-treap (left tree) fn (+ depth 2))))

(defun map-treap> (tree fn &optional (depth 0))
  "Maps FN on all nodes of the treap that are greater than node TREE."
  (when (right tree)
    (map-treap (right tree) fn (+ depth 1))))

(defun map-treap<> (tree fn &optional (depth 0) lo hi)
  "Traverse whole treap TREE but funcall FN only on those nodes
whose key lies between LO and HI. (inclusive.)"
  (declare (special *foo*)) (if (boundp '*foo*) (incf *foo*))
  (labels ((hip (tree) (if (< (key tree) hi) t (not (< hi (key tree)))))
	   (lop (tree) (if (< lo (key tree)) t (not (< (key tree) lo))))
	   (descend-p (tree)
	     (cond ((and hi lo) (and (hip tree) (lop tree)))
		   (hi (hip tree))
		   (lo (lop tree))
		   (t t))))
    (when (left tree)
      (map-treap<> (left tree) fn (+ depth 2) lo hi))
    (when (descend-p tree)
      (funcall fn tree))
    (when (right tree)
      (map-treap<> (right tree) fn (+ depth 1) lo hi))))

(defun map-treap<=> (tree fn &optional (depth 0) lo hi)
  "traverse whole treap TREE but funcall FN only on those nodes
whose key lies between LO and HI (not inclusive.)"
  (declare (special *foo*)) (if (boundp '*foo*) (incf *foo*))
  (when (left tree)
    (map-treap<=> (left tree) fn (+ depth 2) lo hi))
  (when (cond ((and hi lo) (CL:< lo (KEY tree) hi))
	      (hi (< (key tree) hi))
	      (lo (< lo (key tree)))
	      (t t))
    (funcall fn tree))
  (when (right tree)
    (map-treap<=> (right tree) fn (+ depth 1) lo hi)))


;;; ----------------------------------------------------------------------
;;;
;;; madhu 070615
;;; GIVEN: NEEDLE. WANT: tight (LO, HI) such that: LO <= NEEDLE <= HI.
;;;
;;;    KEY
;;;  MIN MAX
;;; L       R
;;;
;;; L: {X: MIN <= X < KEY}
;;; R: {X: KEY < X <= MAX}

(defmethod find-key<= ((tree basic-treap-node-mixin) needle &optional (depth 0))
  "Return largest KEY <= NEEDLE"
  (declare (special *bar*)) (if (boundp '*bar*) (incf *bar*))
  (let ((key (key tree)))
    (if (< key needle)
	(if (right tree)
	    (or (find-key<= (right tree) needle (+ depth 2)) key)
	    key)
	(if (< needle key)
	    (if (left tree)
		(find-key<= (left tree) needle (+ depth 1))
		nil)
	    key))))

(defmethod find-key>= ((tree basic-treap-node-mixin) needle &optional (depth 0))
  "Return smallest KEY >= NEEDLE"
  (declare (special *bar*)) (if (boundp '*bar*) (incf *bar*))
  (let ((key (key tree)))
    (if (< key needle)
	(if (right tree)
	    (find-key>= (right tree) needle (+ depth 2))
	    nil)
	(if (< needle key)
	    (if (left tree)
		(or (find-key>= (left tree) needle (+ depth 1)) key)
		key)
	    key))))

(defmethod find-key< ((tree basic-treap-node-mixin) needle &optional (depth 0))
  "Return largest KEY < NEEDLE"
  (declare (special *bar*)) (if (boundp '*bar*) (incf *bar*))
  (let ((key (key tree)))
    (if (< key needle)
	(if (right tree)
	    (or (find-key< (right tree) needle (+ depth 2)) key)
	    key)
	(if (left tree)
	    (find-key< (left tree) needle (+ depth 1))
	    nil))))

(defmethod find-key> ((tree basic-treap-node-mixin) needle &optional (depth 0))
  "Return smallest KEY > NEEDLE"
  (declare (special *bar*)) (if (boundp '*bar*) (incf *bar*))
  (let ((key (key tree)))
    (if (< key needle)
	(if (right tree)
	    (find-key> (right tree) needle (+ depth 2))
	    nil)
	(if (< needle key)
	    (if (left tree)
		(or (find-key> (left tree) needle (+ depth 1)) key)
		key)
	    (if (left tree)
		(find-key> (left tree) needle (+ depth 1))
		nil)))))

(defmethod treap-find-bounds ((treap treap) needle)
  "Given NEEDLE return LO and HI keys in treap such that LO < NEEDLE < HI."
  (let ((tree (slot-value treap 'root)))
    (list (find-key< tree needle)
	  (find-key> tree needle))))

(defmethod treap-find-bounds<=> ((treap treap) needle)
  "Given NEEDLE return LO and HI keys in treap such that LO <= NEEDLE <= HI."
  (let ((tree (slot-value treap 'root)))
    (list (find-key<= tree needle)
	  (find-key>= tree needle))))


;;; ----------------------------------------------------------------------
;;;
;;; MAP WITH MINMAX SUPPORT, madhu 060528
;;;

#-no-minmax-support
(defmethod set-minmax ((tree minmax-node-mixin) &optional (depth 0))
  (setf (min$ tree) (key tree))
  (setf (max$ tree) (key tree))
  (if (left tree)
      (multiple-value-bind (lmin lmax) (set-minmax (left tree) (+ depth 2))
	(if (< lmin (min$ tree)) (setf (min$ tree) lmin))
	(if (< (max$ tree) lmax) (setf (max$ tree) lmax))))
  (If (right tree)
      (multiple-value-bind (rmin rmax) (set-minmax (right tree) (1+ depth))
	(if (< rmin (min$ tree)) (setf (min$ tree) rmin))
	(if (< (max$ tree) rmax) (setf (max$ tree) rmax))))
  (values (min$ tree) (max$ tree)))

#-no-minmax-support
(defun treap-set-minmax (treap)
  (check-type treap treap)
  (set-minmax (slot-value treap 'root)))

;;; GIVEN: (LO,HI) WANT: {X: LO < X < HI}
;;;
;;;    KEY
;;;  MIN MAX
;;; L       R
;;;
;;; L: {X: MIN <= X < KEY}, empty if KEY <= LO or HI < MIN
;;; R: {X: KEY < X <= MAX}, empty if HI <= KEY or MAX < LO
;;;
;;; Descend node only if not empty

#-no-minmax-support
(defmethod map-treap-bounded ((tree minmax-node-mixin) fn &optional (depth 0) lo hi)
  (declare (special *foo*)) (if (boundp '*foo*) (incf *foo*))
  (let ((min (min$ tree)) (max (max$ tree)) (key (key tree)))
    (unless (or (if hi (or (< hi min) (not (< min hi))))
		(if lo (or (< max lo) (not (< lo max)))))
      (when (left tree)
	(unless (or (if lo (or (< key lo) (not (< lo key))))
		    (if hi (< hi (min$ tree))))
	  (map-treap-bounded (left tree) fn (+ depth 2) lo hi)))
      (when (and (if lo  (< lo key) t) (if hi (< key hi) t))
	(funcall fn tree))
      (when (right tree)
	(unless (or (if hi (or (< hi key) (not (< key hi))))
		    (if lo (< max lo)))
	  (map-treap-bounded (right tree) fn (+ depth 1) lo hi))))))

#-no-minmax-support
(defun maptreap-bounded (treap fn &optional lo hi)
  "Maps FN on elements of the set X : LO < X < HI and X in a
treap-node. call TREAP-SET-MINMAX before calling this. LO or HI can be
NIL indicating `unbound in that direction.'"
  (check-type treap treap)
  (map-treap-bounded (slot-value treap 'root) fn 0 lo hi))

#||
(setq $a (make-instance 'treap))
(setq $l (loop for r in '(5 10 25 18 19 13 42 666 1024 343)
	       ;; for i below 100 for r = (random 200)
	       do (setf (gettreap r $a) (format nil "~R" r))
	       collect r))
(treap-length $a)
(defun foo-1 (treap lo hi)
  (let ((tree (slot-value treap 'root)) x (*foo* 0))
    (declare (special *foo*))
    (map-treap<=> tree (lambda (a) (push (key a)  x)) 0 lo hi)
    (values (sort x #'cl:<) *foo*)))
(defun foo (treap lo hi)
  (let (x (*foo* 0))
    (declare (special *foo*))
    (maptreap-bounded treap (lambda (a) (push (key a) x)) lo hi)
    (values (sort x #'cl:<) *foo*)))
(treap-set-minmax $a)
(foo $a 2 25) ;;=> (5 10 13 18 19), 6
(foo-1 $a 2 25) ;;=> (5 10 13 18 19), 10
(setf (gettreap 2048 $a) (format nil "~R" 2048))
(treap-set-minmax $a)
(foo $a 1046 2049)
(setq $r (slot-value $a 'root))
(set-minmax $r)
(max$ $r)
(min$ $r)
(key $r)
(let (x)
  (setq *foo* 0)
  (map-treap-bounded $r (lambda (a) (push (key a) x)) 0 10 42)
  (values (sort x #'cl:<) *foo*))
(key (right $r))
(loop for i below 10
      for r = (random 200)
      do (setf (gettreap r $a) (format nil "~R" r))
      finally (setq $r (slot-value $a 'root))
      (set-minmax $r))
(setq $questions '((9 181) (10 26) (10 45) (34 98) (160 180)))
(setq $answers1 (loop for (lo hi) in $questions
		      collect (foo-1 $a lo hi)))
(setq $answers2 (loop for (lo hi) in $questions
		      collect (foo $a lo hi)))
(equalp $answers2 $answers1)
;;;
(min$ (left (slot-value $a 'root)))))
(find-key< (slot-value $a 'root) 25)
(find-key> (slot-value $a 'root) 25)

(trace :methods 'find-key<=))
(treap-set-minmax $a)
(let (x)
  (maptreap (lambda (k v) (push k x)) $a) x)
(treap-find-bounds $a 25)

;;;
;;;
(defun graph-treap (tree file)
  (if (typep tree 'treap) (setq tree (root tree)))
  (with-open-file (stream file :direction :output :if-exists :supersede)
    (psgraph:psgraph stream
		     tree
		     (lambda (x &aux left right)
		       (when x
			 (if (setq left (left x))
			     (if (setq right (right x))
				 (list left right)
				 (list left))
			     (if (setq right (right x))
				 (list right)))))
		     (lambda (x)
		       (when x
			 (list (format nil "~A" (key x))))))))
(graph-treap $r "home:treap-tree.ps")
(user:lc "home:cl/db")
(delete-file "/tmp/foo.db")		; start
(db-impl:open-store "/tmp/foo.db")	; new
(setq $x (make-instance 'treap:treap))
(setf (treap:gettreap 0989088989998 $x) :foo)
(setf (treap:gettreap 666 $x) :foo)
(setq db-impl::*store-controller*	; second time around
      (db-impl::make-store-controller :pathname "/tmp/foo.db"))

(list (db-impl:read-one "/tmp/foo.db") $x)
(delete-file "/tmp/foo.db")
(db-impl::dump-one $a "/tmp/foo.db")
(db-impl::dump-one $r "/tmp/foo.db")
(setq $b (db-impl:read-one "/tmp/foo.db"))
(eq $a $b)
(db-impl:add-to-root 'foo $a)
(db-impl:save-store)
(print db-impl::*store-controller*)

(setq $b (make-treap :predicate #'>))
(loop for x in '(1 2 3 4 5 10 20 45 76)
      do (setf (gettreap x $b) x))
(let (x) (maptreap (lambda (k v) (push k x)) $b) x)
||#