From: Olof-Joachim Frahm <olof@macrolet.net>
Date: Thu, 11 Jul 2013 21:02:22 +0000 (+0200)
Subject: Add initial support for SEQUENCE integration.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7f66452f5c49aef4ad5e38a61c887874f7668d4f;p=trees.git

Add initial support for SEQUENCE integration.

Also simplification of the existing MAKE-ITERATOR.
---

diff --git a/iterator.lisp b/iterator.lisp
index 3cdaa1c..e8c7ea9 100644
--- a/iterator.lisp
+++ b/iterator.lisp
@@ -1,7 +1,7 @@
 (in-package :trees)
 
-(defun extreme-node-with-path (root direction &optional path)
-  (do ((node root (funcall direction node))
+(defun extreme-node-with-path (root leftp &optional path)
+  (do ((node root (if leftp (left node) (right node)))
        (parent nil node))
       ((null node) (values parent path))
     (push node path)))
@@ -12,28 +12,24 @@
                        (stack nil stackp))
   (declare (type binary-tree tree))
   (let ((modcount (modcount tree)))
-    (multiple-value-bind (extremum examine)
-                  (if forwardp
-                      (values #'left #'right)
-                      (values #'right #'left))
-      (multiple-value-bind (current stack)
-          (if (and currentp stackp)
-              (values current stack)
-              (extreme-node-with-path (root tree) extremum))
-        #'(lambda ()
-            (cond
-              ((/= modcount (modcount tree))
-               (error "~A modified during iteration" tree))
-              ((null current)
-               (values nil nil))
-              (t
-               (let* ((next current)
-                      (top (pop stack))
-                      (node (funcall examine top)))
-                 (cond
-                   ((null node)
-                    (setf current (first stack)))
-                   (t
-                    (setf (values current stack)
-                          (extreme-node-with-path node extremum stack))))
-                 (values next t)))))))))
+    (multiple-value-bind (current stack)
+        (if (and currentp stackp)
+            (values current stack)
+            (extreme-node-with-path (root tree) forwardp))
+      (lambda ()
+        (cond
+          ((/= modcount (modcount tree))
+           (error "~A modified during iteration" tree))
+          ((null current)
+           (values nil nil))
+          (t
+           (let* ((next current)
+                  (top (pop stack))
+                  (node (if forwardp (right top) (left top))))
+             (cond
+               ((null node)
+                (setf current (first stack)))
+               (t
+                (setf (values current stack)
+                      (extreme-node-with-path node forwardp stack))))
+             (values next t))))))))
diff --git a/sequence.lisp b/sequence.lisp
new file mode 100644
index 0000000..1d7b2db
--- /dev/null
+++ b/sequence.lisp
@@ -0,0 +1,35 @@
+(in-package :trees)
+
+(defmethod sequence:length ((binary-tree binary-tree))
+  (size binary-tree))
+
+(defmethod sequence:make-simple-sequence-iterator ((binary-tree binary-tree)
+                                                   &key from-end (start 0) end)
+  (when (or (not (zerop start)) end)
+    (error "~A and ~A are unsupported for ~A" 'start 'end 'binary-tree))
+  (multiple-value-bind (current stack)
+      (extreme-node-with-path (root binary-tree) (not from-end))
+    (declare (ignore current))
+    (values stack NIL from-end)))
+
+(defmethod sequence:iterator-step ((binary-tree binary-tree) iterator from-end)
+  (let* ((current (car iterator))
+         (stack (cdr iterator))
+         (node (if from-end (left current) (right current))))
+    (cond
+      ((null node)
+       stack)
+      (t
+       (multiple-value-bind (current stack)
+           (extreme-node-with-path node (not from-end) stack)
+         (declare (ignore current))
+         stack)))))
+
+(defmethod sequence:iterator-endp ((binary-tree binary-tree) iterator limit from-end)
+  (declare (ignore limit from-end))
+  (null iterator))
+
+(defmethod sequence:iterator-element ((binary-tree binary-tree) iterator)
+  (datum (car iterator)))
+
+;; (defmethod sequence:iterator-index ((binary-tree binary-tree) iterator))
diff --git a/trees.asd b/trees.asd
index b8b3a47..8f13810 100644
--- a/trees.asd
+++ b/trees.asd
@@ -19,6 +19,7 @@
                (:file "avl-trees" :depends-on ("types" "binary-trees"))
                (:file "aa-trees" :depends-on ("types" "binary-trees"))
                (:file "iterator" :depends-on ("types" "binary-trees"))
+               (:file "sequence" :depends-on ("iterator"))
                (:file "utils" :depends-on ("binary-trees"))
                (:static-file "LICENSE")
                (:static-file "README")
diff --git a/types.lisp b/types.lisp
index d2235d1..83f9821 100644
--- a/types.lisp
+++ b/types.lisp
@@ -47,6 +47,52 @@
 
 ;;; trees
 
+#+sbcl
+(defclass binary-tree (sequence standard-object)
+  ((test :initform #1=(error "missing arg")
+         :initarg :test
+         :type 'function
+         :reader test)
+   (key :initform #1#
+        :initarg :key
+        :type 'function
+        :reader key)
+   (pred :initform #1#
+         :initarg :pred
+         :type 'function
+         :reader pred)
+   (size :initform 0
+         :initarg :size
+         :type 'fixnum
+         :accessor size)
+   (root :initform nil
+         :initarg :root
+         :type '(or null tree-node)
+         :accessor root)
+   (modcount :initform 0
+             :initarg :modcount
+             :type 'fixnum
+             :accessor modcount)
+   (nodegen :initform #1#
+            :initarg :nodegen
+            :type 'function
+            :reader nodegen)
+   (rebalance/insert :initform nil
+                     :initarg :rebalance/insert
+                     :type '(or null function)
+                     :reader rebalance/insert)
+   (rebalance/delete :initform nil
+                     :initarg :rebalance/delete
+                     :type '(or null function)
+                     :reader rebalance/delete)))
+
+#+sbcl
+(defun %make-binary-tree (pred key test nodegen rebalance/insert rebalance/delete)
+  (make-instance 'binary-tree :pred pred :key key :test test :nodegen nodegen
+                              :rebalance/insert rebalance/insert
+                              :rebalance/delete rebalance/delete))
+
+#-sbcl
 (defstruct (binary-tree
              (:conc-name)
              (:constructor %make-binary-tree (pred key test