;;; -*- Mode: Scheme -*-

;;;; Skip Lists
;;;; (Optimized for MIT Scheme <http://www.gnu.org/software/mit-scheme/>)

;;; This code is written by Taylor R. Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

;;; The skip list is a probabilistic data structure comparable to
;;; balanced binary trees in running time of map and set operations.
;;;
;;; This code depends on SRFIs 9 (DEFINE-RECORD-TYPE), 23 (ERROR), and
;;; 27 (random number generation).  The dependency on SRFI 27 could be
;;; elided with a suitable replacement for the definition of FLIP-COIN,
;;; at the bottom of the file.
;;;
;;; This code is permanently stored at
;;;
;;;   <http://mumble.net/~campbell/scheme/mit-skip-list.scm>;
;;;
;;; it was derived from the portable implementation at
;;;
;;;   <http://mumble.net/~campbell/scheme/skip-list.scm>.

;;;; Documentation

;;;   (MAKE-SKIP-LIST-TYPE <key-selector> <key-comparator>) -> skip-list-type
;;;   (MAKE-SKIP-LIST-SET-TYPE <key-comparator>) -> skip-list-type
;;;   (MAKE-SKIP-LIST-MAP-TYPE <key-comparator>) -> skip-list-type
;;;     Constructors for skip list types.  <Key-selector> must be a
;;;     procedure of one argument, an element appropriate for storage
;;;     in a skip list of this type; it returns the key by which the
;;;     element will be ordered.  <Key-comparator> must be a procedure
;;;     of two arguments, the keys of elements appropriate for storage
;;;     in the skip list, and return a boolean value totally ordering
;;;     the elements.
;;;
;;;     Skip list types contain closures over the given key selectors
;;;     and key comparators, and if these procedures are integrated at
;;;     call sites, the actual generated code can be specialized
;;;     without general procedure calls.  MAKE-SKIP-LIST-SET-TYPE
;;;     supplies a key selector of the identity procedure, for sets;
;;;     MAKE-SKIP-LIST-MAP-TYPE supplies a key selector of CAR, for
;;;     maps whose associations are represented with pairs.
;;;
;;;   (SKIP-LIST-TYPE? <object>) -> boolean
;;;     Disjoint type predicate for skip list types.
;;;
;;;   (SKIP-LIST-TYPE/KEY-SELECTOR <skip-list-type>) -> key-selector
;;;   (SKIP-LIST-TYPE/KEY-COMPARATOR <skip-list-type>) -> key-comparator
;;;     Accessors for the key selector and key comparator procedures of
;;;     skip list types.
;;;
;;;   (MAKE-SKIP-LIST <skip-list-type> [<max-level>]) -> skip-list
;;;     Skip list constructor.  <Skip-list-type> must be a skip list
;;;     type, and <max-level> must be a non-negative integer, which
;;;     indicates to what depth the skip list is allowed to expand.
;;;     The default is 32, which suffices for four billion elements to
;;;     be accessible on average with fewer than 32 key comparisons.
;;;
;;;   (SKIP-LIST? <object>) -> boolean
;;;     Disjoint type predicate for skip lists.
;;;
;;;   (SKIP-LIST/TYPE <skip-list>) -> skip-list-type
;;;     Returns <skip-list>'s type.
;;;
;;;   (SKIP-LIST/COUNT <skip-list>) -> exact, non-negative integer
;;;     Returns the number of elements in <skip-list>.
;;;
;;;   (LIST->SKIP-LIST <list> <skip-list-type>) -> skip-list
;;;   (SKIP-LIST->LIST <skip-list>) -> list
;;;     LIST->SKIP-LIST returns a skip list of the given type
;;;     containing all of the elements in <list>.  SKIP-LIST->LIST
;;;     returns a sorted list (according to <skip-list>'s type's key
;;;     comparator) of all the elements in <skip-list>.

;;;;; Skip List Operations

;;;   (SKIP-LIST/LOOKUP <skip-list> <key> <default>) -> element
;;;     Returns the element in <skip-list> whose key is equivalent to
;;;     <key>, or <default> if there is no such element.  <Default>
;;;     must be supplied because of the common error of accidentally
;;;     preventing sets from containing #F caused by the interface to
;;;     the set; by requiring programmers to write it explicitly, at
;;;     least they are acknowledging that #F means an out-of-band
;;;     token.
;;;
;;;   (SKIP-LIST/CONTAINS-KEY? <skip-list> <key>) -> boolean
;;;     Returns true of <skip-list> contains an element whose key is
;;;     equivalent to <key>, and false if not.
;;;
;;;   (SKIP-LIST/INSERT! <skip-list> <element>)
;;;     Inserts <element> into <skip-list>.  If <skip-list> already
;;;     contains an element with a key equivalent to <element>'s,
;;;     SKIP-LIST/INSERT! replaces that element with <element>.
;;;
;;;   (SKIP-LIST/INTERN! <skip-list> <key> <generator>) -> element
;;;     If <skip-list> contains an element with a key equivalent to
;;;     <key>, SKIP-LIST/INTERN! returns that element.  Otherwise, it
;;;     inserts and returns the element yielded by calling the
;;;     procedure <generator> with one argument, <key>.  It is an error
;;;     if <generator> returns an element that does not have a key
;;;     equivalent to <key>.
;;;
;;;   (SKIP-LIST/DELETE! <skip-list> <key>)
;;;     If <skip-list> contains an element with a key equivalent to
;;;     <key>, SKIP-LIST/DELETE! deletes that element from
;;;     <skip-list>.
;;;
;;;   (SKIP-LIST/MIN <skip-list>) -> element
;;;     Returns the element with the smallest key in <skip-list>.  It
;;;     is an error if <skip-list> is empty.
;;;
;;;   (SKIP-LIST/DELETE-MIN! <skip-list>) -> element
;;;     Returns and deletes from <skip-list> its element with the
;;;     smallest key.  It is an error if <skip-list> is empty.

;;;;; Primitive Skip List Operations

;;; The above operations on skip list are all implemented in terms of
;;; the following general skip list operations:
;;;
;;;   (SKIP-LIST/SEARCH <skip-list> <key> <if-found> <if-not-found>)
;;;     Searches in <skip-list> for an element with a key equivalent to
;;;     <key>.  If such an element is found, SKIP-LIST/SEARCH calls the
;;;     procedure <if-found> in a tail position with the element as its
;;;     sole argument; otherwise, it calls the procedure <if-not-found>
;;;     with zero arguments.  For example, SKIP-LIST/LOOKUP could have
;;;     been defined in terms of SKIP-LIST/SEARCH like so:
;;;
;;;       (define (skip-list/lookup skip-list key default)
;;;         (skip-list/search skip-list key
;;;           (lambda (element) element)
;;;           (lambda () default)))
;;;
;;;   (SKIP-LIST/UPDATE! <skip-list> <key> <if-found> <if-not-found>)
;;;     Searches in <skip-list> for an element with a key equivalent to
;;;     <key>, building up the necessary internal data structures for
;;;     updating the structure of <skip-list>.  If such an element is
;;;     found, then SKIP-LIST/UPDATE! calls the procedure <if-found> in
;;;     a tail position with three arguments:
;;;
;;;        1. The element that was found.
;;;        2. A unary procedure to replace the element with another
;;;           one: (REPLACE <replacement>).  <Replacement> must have a
;;;           key equivalent to <key>; it is an (unchecked) error if
;;;           <replacement> does not.
;;;        3. A nullary procedure to delete the element: (DELETE).
;;;
;;;       If no element with a key equivalent to <key> is found, then
;;;       the procedure <if-not-found> is called with one argument, a
;;;       unary procedure to insert an element with the key in the skip
;;;       list: (INSERT <element>).  It is an (unchecked) error if
;;;       <element> does not have a key equivalent to <key>.
;;;
;;;     For example, SKIP-LIST/INTERN! could have been defined like so:
;;;
;;;       (define (skip-list/intern! skip-list key generator)
;;;         (skip-list/update! skip-list key
;;;           (lambda (element replace delete)
;;;             replace delete          ;ignore
;;;             element)
;;;           (lambda (insert)
;;;             (let ((element (generator key)))
;;;               (insert element)
;;;               element))))
;;;
;;;   (SKIP-LIST/UPDATE-MIN! <skip-list> <if-found> <if-empty>)
;;;     If <skip-list> is non-empty, this is like SKIP-LIST/UPDATE!,
;;;     but for the element with the smallest key in <skip-list>,
;;;     rather than the element corresponding with a given key.  If
;;;     <skip-list> is empty, this calls <if-empty> in a tail position
;;;     with zero arguments.  Example:
;;;
;;;       (define (skip-list/delete-min! skip-list)
;;;         (skip-list/update-min! skip-list
;;;           (lambda (element replace delete)
;;;             replace                 ;ignore
;;;             (delete)
;;;             element)
;;;           (lambda () (error "Empty skip list:" skip-list))))

;;;;; Skip List Map Operations

;;; Skip lists are often useful specialized as maps, where the elements
;;; of the skip list are pairs whose cars are the keys of the map and
;;; whose cdrs are the data of the map.  The MAKE-SKIP-LIST-MAP-TYPE
;;; constructs skip list types that follow this structure, given a key
;;; comparator.  Several operations are provided for this special
;;; case.  Whether mutative operations such as SKIP-LIST/MAP-UPDATE!
;;; replace elements (associations) in the skip list, or alter the cdrs
;;; of existing elements, is unspecified.
;;;
;;;   (SKIP-LIST/MAP-SEARCH <skip-list> <key> <if-found> <if-not-found>)
;;;     Searches in <skip-list> for a datum associated with <key>.  If
;;;     such a datum is found, SKIP-LIST/MAP-SEARCH calls <if-found> in
;;;     a tail position with that datum as a single argument; otherwise,
;;;     SKIP-LIST/MAP-SEARCH calls <if-not-found> in a tail position
;;;     with zero arguments.
;;;
;;;   (SKIP-LIST/MAP-LOOKUP <skip-list> <key> <default>) -> datum
;;;     Returns the datum associated with <key> in <skip-list>, or
;;;     <default> if there is none.
;;;
;;;   (SKIP-LIST/MAP-UPDATE! <skip-list> <key>
;;;       <if-found> <if-not-found>)
;;;     Like SKIP-LIST/UPDATE!, but calls the procedure <if-found> with
;;;     the datum associated with <key> in <skip-list>, rather than the
;;;     element (association) whose key is <key>.
;;;
;;;   (SKIP-LIST/MAP-INSERT! <skip-list> <key> <datum>)
;;;     Inserts an association between <key> and <datum>, i.e. a pair
;;;     (<key> . <datum>), into <skip-list>.
;;;
;;;   (SKIP-LIST/MAP-MODIFY! <skip-list> <key> <default> <modifier>)
;;;     If <skip-list> contains a datum associated with <key>,
;;;     SKIP-LIST/MAP-MODIFY! replaces that datum with the result of
;;;     applying <modifier> to it.  Otherwise, SKIP-LIST/MAP-MODIFY!
;;;     inserts an association whose key is <key> and whose datum is
;;;     the result of applying <modifier> to <default>.
;;;
;;;   (SKIP-LIST/MAP-INTERN! <skip-list> <key> <generator>)
;;;     If <skip-list> contains a datum associated with <key>,
;;;     SKIP-LIST/MAP-INTERN! returns that datum; otherwise, it calls
;;;     the procedure <generator> with zero arguments to generate a new
;;;     datum, inserts an association between <key> and that datum into
;;;     <skip-list>, and returns that datum.
;;;
;;;   (SKIP-LIST/MAP-MIN <skip-list>) -> [key datum]
;;;     Returns two values: the smallest key in <skip-list> and its
;;;     associated datum.  It is an error if <skip-list> is empty.
;;;
;;;   (SKIP-LIST/MAP-DELETE-MIN! <skip-list>) -> [key datum]
;;;     Returns two values -- the smallest key in <skip-list> and its
;;;     associated datum --, and removes the association from
;;;     <skip-list>.  It is an error if <skip-list> is empty.
;;;
;;;   (SKIP-LIST/MAP-UPDATE-MIN! <skip-list> <if-found> <if-not-found>)
;;;     Like SKIP-LIST/UPDATE-MIN!, but passes the smallest key and its
;;;     associated datum, rather than the element whose key is <key>,
;;;     to <if-found>, and the REPLACE procedure takes a datum to
;;;     associate with <key>, not an element whose key is <key>.

;;;;; Built-In Skip List Types

;;; Several skip list types are provided already defined.
;;;
;;;    SKIP-LIST-TYPE:REAL-NUMBER-SET
;;;    SKIP-LIST-TYPE:REAL-NUMBER-MAP
;;;      Arbitrary real numbers -- any object on which the `<'
;;;      procedure is defined, which by the R5RS is any object
;;;      satisfying the REAL? predicate.
;;;
;;;    SKIP-LIST-TYPE:EXACT-INTEGER-SET
;;;    SKIP-LIST-TYPE:EXACT-INTEGER-MAP
;;;      Like above, but restricted to exact integers, for efficiency.
;;;      These exact integers are not limited to a particular range.
;;;
;;;    SKIP-LIST-TYPE:SYMBOL-SET
;;;    SKIP-LIST-TYPE:SYMBOL-MAP
;;;      Symbols, ordered by STRING<? on their names, as obtained using
;;;      SYMBOL->STRING.
;;;
;;;    SKIP-LIST-TYPE:STRING-SET        SKIP-LIST-TYPE:STRING-SET-CI
;;;    SKIP-LIST-TYPE:STRING-MAP        SKIP-LIST-TYPE:STRING-MAP-CI
;;;      Strings, ordered by STRING<? or STRING-CI<?.

(declare (usual-integrations)
         (automagic-integrations)
         ;; I don't think this makes any difference to compiled code,
         ;; but it actually prevents integration declarations from
         ;; working, so we disable it, since integrating ELEMENT->KEY
         ;; and KEY<? in MAKE-SKIP-LIST-TYPE is very important.
         (no-open-block-optimizations)
         (eta-substitution))

;;;; Skip List Structure

;;; - An element is an element of a skip list.
;;; - A key is a part of an element (or possibly the whole thing) by
;;;   which the element is ordered.
;;; - A node is a compound structure containing an element and an
;;;   indexed sequence of forward nodes.  There are several different
;;;   ways to represent this, to finely tune the internal structure of
;;;   skip lists.  Such bumming is probably utterly pointless.

(define-record-type <skip-list-type>
    (%make-skip-list-type key-selector
                          key-comparator
                          operation/search
                          operation/update!
                          operation/lookup
                          operation/contains-key?
                          operation/insert!
                          operation/intern!
                          operation/delete!
                          )
    skip-list-type?
  (key-selector skip-list-type/key-selector)
  (key-comparator skip-list-type/key-comparator)
  (operation/search skip-list-type/operation/search)
  (operation/update! skip-list-type/operation/update!)
  (operation/lookup skip-list-type/operation/lookup)
  (operation/contains-key? skip-list-type/operation/contains-key?)
  (operation/insert! skip-list-type/operation/insert!)
  (operation/intern! skip-list-type/operation/intern!)
  (operation/delete! skip-list-type/operation/delete!)
  )

(define-record-type <skip-list>
    (%make-skip-list type header max-level)
    skip-list?
  (type skip-list/type)
  (header skip-list/header set-skip-list/header!)
  (max-level skip-list/max-level))

(define (make-skip-list type . max-level)
  (%make-skip-list type
                   (empty-header-node)
                   (fix:+ (bottom-level)
                          (if (pair? max-level)
                              (car max-level)
                              (default-max-level)))))

(define-integrable (skip-list/level skip-list)
  (node-level (skip-list/header skip-list)))

(define-integrable (default-max-level) 32)

(define (random-level skip-list)
  (let ((max-level (skip-list/max-level skip-list)))
    (let loop ((level (fix:+ 1 (bottom-level))))
      (if (and (fix:< level max-level)
               (flip-coin))
          (loop (fix:+ level 1))
          level))))

;;;; Skip List Operations

(define-integrable (skip-list/search skip-list key if-found if-not-found)
  ((skip-list-type/operation/search (skip-list/type skip-list))
   skip-list key if-found if-not-found))

(define-integrable (skip-list/update! skip-list key if-found if-not-found)
  ((skip-list-type/operation/update! (skip-list/type skip-list))
   skip-list key if-found if-not-found))

(define-integrable (skip-list/lookup skip-list key default)
  ((skip-list-type/operation/lookup (skip-list/type skip-list))
   skip-list key default))

(define-integrable (skip-list/contains-key? skip-list key)
  ((skip-list-type/operation/contains-key? (skip-list/type skip-list))
   skip-list key))

(define-integrable (skip-list/insert! skip-list element)
  ((skip-list-type/operation/insert! (skip-list/type skip-list))
   skip-list element))

(define-integrable (skip-list/intern! skip-list key generator)
  ((skip-list-type/operation/intern! (skip-list/type skip-list))
   skip-list key generator))

(define-integrable (skip-list/delete! skip-list key)
  ((skip-list-type/operation/delete! (skip-list/type skip-list))
   skip-list key))

(define (skip-list->list skip-list)
  (let ((header (skip-list/header skip-list)))
    (if (bottom-level? (node-level header))
        '()
        (let loop ((node (node-next header)) (elements '()))
          (let ((elements (cons (node-element node) elements))
                (node* (node-next node)))
            (if (node? node*)
                (loop node* elements)
                (reverse elements)))))))

(define (list->skip-list list skip-list-type)
  (let ((skip-list (make-skip-list skip-list-type)))
    (for-each (lambda (element)
                (skip-list/insert! skip-list element))
              list)
    skip-list))

;++ sorted-list->skip-list
;++ skip-list->ascending-list versus skip-list->descending-list?

;;;;; More Operations

(define (skip-list/count skip-list)
  (let ((header (skip-list/header skip-list)))
    (if (bottom-level? (node-level header))
        0
        (let loop ((node (node-next header)) (count 1))
          (let ((node* (node-next node)))
            (if (node? node*)
                (loop node* (fix:+ count 1))
                count))))))

(define (skip-list/min skip-list)
  (let ((header (skip-list/header skip-list)))
    (if (bottom-level? (node-level header))
        (error "Empty skip list has no minimum:" skip-list)
        (node-element (node-next header)))))

(define (skip-list/delete-min! skip-list)
  (let ((header (skip-list/header skip-list)))
    (if (bottom-level? (node-level header))
        (error "Empty skip list has no minimum to delete:" skip-list)
        (let ((node (node-next header)))
          (if (node? (node-next node))
              (move-forward! node (node-level node) header)
              (set-skip-list/header! skip-list (empty-header-node)))
          (node-element node)))))

(define-integrable (skip-list/update-min! skip-list if-found if-empty)
  (let ((header (skip-list/header skip-list)))
    (if (bottom-level? (node-level header))
        (if-empty)
        (let ((node (node-next header)))
          (if-found
           (node-element node)
           (lambda (replacement)        ;replace
             (declare (integrate replacement))
             (set-node-element! node replacement))
           (lambda ()                   ;delete
             (if (node? (node-next node))
                 (move-forward! node (node-level node) header)
                 (set-skip-list/header! skip-list (empty-header-node)))))))))

;;;;; Map Operations

(define-integrable (skip-list/map-search skip-list key if-found if-not-found)
  (skip-list/search skip-list key
    (lambda (element)
      (declare (integrate element))
      (if-found (cdr element)))
    if-not-found))

(define-integrable (skip-list/map-lookup skip-list key default)
  (cdr (skip-list/lookup skip-list key (cons key default))))

(define-integrable (skip-list/map-update! skip-list key if-found if-not-found)
  (skip-list/update! skip-list key
    (lambda (element replace delete)
      (declare (ignore replace) (integrate delete))
      (if-found (cdr element)
                (lambda (replacement)
                  (set-cdr! element replacement))
                delete))
    (lambda (insert)
      (declare (integrate insert))
      (if-not-found (lambda (datum) (insert (cons key datum)))))))

(define-integrable (skip-list/map-modify! skip-list key default modifier)
  (skip-list/map-update! skip-list key
    (lambda (datum replace delete)
      (declare (ignore delete) (integrate datum replace))
      (replace (modifier datum)))
    (lambda (insert)
      (declare (integrate insert))
      (insert (modifier default)))))

(define-integrable (skip-list/map-insert! skip-list key datum)
  (skip-list/insert! skip-list (cons key datum)))

(define-integrable (skip-list/map-intern! skip-list key generator)
  (cdr (skip-list/intern! skip-list key
         (lambda (key)
           (cons key (generator key))))))

(define-integrable (skip-list/map-min skip-list)
  (let ((min (skip-list/min skip-list)))
    (values (car min) (cdr min))))

(define-integrable (skip-list/map-delete-min! skip-list)
  (let ((min (skip-list/delete-min! skip-list)))
    (values (car min) (cdr min))))

(define-integrable (skip-list/map-update-min! skip-list if-found if-empty)
  (skip-list/update-min! skip-list
    (lambda (element replace delete)
      (declare (ignore replace) (integrate delete))
      (if-found (car element)
                (cdr element)
                (lambda (replacement)
                  (set-cdr! element replacement))
                delete))
    if-empty))

;;;; Node Abstraction

;;; We could cache the key associated with each object, but we expect
;;; them to be cheap to compute anyway, and this saves us some
;;; storage.
;;;
;;; Note: the NON-NODE procedure must return the same value each time,
;;; in the sense of EQ?.

(define-integrable (make-header-node level)
  (make-node level 'HEADER-DUMMY))

(define-integrable (empty-header-node)
  (make-header-node (bottom-level)))

;;; This implementation of nodes uses an extra cons cell, but requires
;;; no frobnication of level indices.

;; (define-integrable (bottom-level) 0)
;; (define-integrable (bottom-level? level) (fix:zero? level))
;;
;; (define-integrable (make-node level element)
;;   (cons element (make-vector level (non-node))))
;;
;; (define-integrable (non-node) #f)
;; (define-integrable (node? object) (pair? object))
;; (define-integrable (node-level node) (vector-length (cdr node)))
;; (define-integrable (node-element node) (car node))
;; (define-integrable (set-node-element! node element) (set-car! node element))
;; (define-integrable (node-next node) (node-forward node 0))
;; (define-integrable (node-forward node level) (vector-ref (cdr node) level))
;; (define-integrable (set-node-forward! node level forward)
;;   (vector-set! (cdr node) level forward))
;;
;; (define (move-forward! source send target)
;;   (subvector-move-right! (cdr source) 0 send (cdr target) 0))
;;
;; (define (fill-forward! node start end forward)
;;   (subvector-fill! (cdr node) start end forward))

;;; This implementation of nodes uses one-element longer vectors, and
;;; zero-based level indices, but must adjust the level indices for
;;; any access to the vector.

;; (define-integrable (bottom-level) 0)
;; (define-integrable (bottom-level? level) (fix:zero? level))
;;
;; (define-integrable (make-node level element)
;;   (let ((node (make-vector (fix:+ level 1) (non-node))))
;;     (vector-set! node 0 element)
;;     node))
;;
;; (define-integrable (non-node) #f)
;; (define-integrable (node? object) (vector? object))
;; (define-integrable (node-level node) (fix:- (vector-length node) 1))
;; (define-integrable (node-element node) (vector-ref node 0))
;; (define-integrable (set-node-element! node element)
;;   (vector-set! node 0 element))
;; (define-integrable (node-next node) (vector-ref node 1))
;; (define-integrable (node-forward node level)
;;   (vector-ref node (fix:+ level 1)))
;; (define-integrable (set-node-forward! node level forward)
;;   (vector-set! node (fix:+ level 1) forward))
;;
;; (define-integrable (move-forward! source send target)
;;   (subvector-move-right! source 1 (fix:+ send 1) target 1))
;;
;; (define-integrable (fill-forward! node start end forward)
;;   (subvector-fill! node (fix:+ start 1) (fix:+ end 1) forward))

;;; This implementation uses a one-element longer vector, and
;;; represents levels by one-based indices.  In MIT Scheme this is
;;; about 5% faster than either of the above two.  In most systems this
;;; will use much a little bit less storage than the pair-based one,
;;; proportional to the number of elements in the skip list.

(define-integrable (bottom-level) 1)
(define-integrable (bottom-level? level) (fix:= level 1))

(define-integrable (make-node level element)
  (let ((node (make-vector level (non-node))))
    (vector-set! node 0 element)
    node))

(define-integrable (non-node) #f)
(define-integrable (node? object) (vector? object))
(define-integrable (node-level node) (vector-length node))
(define-integrable (node-element node) (vector-ref node 0))
(define-integrable (set-node-element! node element)
  (vector-set! node 0 element))
(define-integrable (node-next node) (vector-ref node 1))
(define-integrable (node-forward node level) (vector-ref node level))
(define-integrable (set-node-forward! node level forward)
  (vector-set! node level forward))

(define-integrable (move-forward! source send target)
  (do ((si 1 (fix:+ si 1))
       (ti 1 (fix:+ ti 1)))
      ((fix:= si send))
    (vector-set! target ti (vector-ref source si))))

(define-integrable (fill-forward! node start end forward)
  (do ((index start (fix:+ index 1)))
      ((fix:= index end))
    (vector-set! node index forward)))

;;;; Skip List Algorithms

;;; This is where the guts of the algorithms go.  This is all part of
;;; one big procedure so that if we so desire we can copy the body of
;;; MAKE-SKIP-LIST-TYPE at call sites to specialize ELEMENT->KEY and
;;; KEY<?.

(define (make-skip-list-type element->key key<?)

  (declare (integrate-operator element->key key<? search update!))

  (define (search skip-list key if-found if-not-found)
    (declare (integrate if-found if-not-found))
    (let* ((header (skip-list/header skip-list))
           (level (node-level header)))

      ;; There is a moderately clever optimization going on in this
      ;; algorithm to avoid repeated comparisons to the same keys.  If
      ;; the only forward pointer from NODE at LEVEL is NEXT, then we
      ;; have already compared KEY to NEXT's key, so we can continue
      ;; searching down, confident that the desired element will lie
      ;; between NODE and NEXT.  NEXT may also be the non-node.
      (define (search-across level node next)
        (let ((node* (node-forward node level)))
          (if (eq? node* next)
              (search-down level node next)
              (let* ((element* (node-element node*))
                     (key* (element->key element*)))
                (cond ((key<? key key*)
                       (search-down level node node*))
                      ((key<? key* key)
                       (search-across level node* (non-node)))
                      (else
                       (if-found element*)))))))

      (define (search-down level node next)
        (if (bottom-level? level)
            (if-not-found)
            (search-across (fix:- level 1) node next)))

      (search-down level header (non-node))))

  (define (lookup skip-list key default)
    (search skip-list key
      (lambda (element)
        (declare (integrate element))
        element)
      (lambda () default)))

  (define (contains-key? skip-list key)
    (search skip-list key
      (lambda (element)
        (declare (ignore element))
        #t)
      (lambda () #f)))

;;;; MAKE-SKIP-LIST, continued: update, and insertion algorithm

  (define (update! skip-list key if-found if-not-found)
    (declare (integrate if-found if-not-found))
    (let* ((header (skip-list/header skip-list))
           (max-level (node-level header))
           (update (make-vector max-level header)))

      (define (search-across level node next)
        (let ((node* (node-forward node level)))
          (if (eq? node* next)
              (search-down/update level node next)
              (let* ((element* (node-element node*))
                     (key* (element->key element*)))
                (cond ((key<? key key*)
                       (search-down/update level node node*))
                      ((key<? key* key)
                       (search-across level node* (non-node)))
                      (else
                       (if-found
                        element*
                        (lambda (replacement-element)
                          (set-node-element! node* replacement-element))
                        (lambda ()
                          (do-delete skip-list key level node update)))))))))

      (define (search-down/update level node next)
        (vector-set! update level node)
        (search-down level node next))

      (define (search-down level node next)
        (if (bottom-level? level)
            (if-not-found (lambda (element)
                            (do-insert skip-list element node update)))
            (search-across (fix:- level 1) node next)))

      (search-down max-level header (non-node))))

  (define (do-insert skip-list element current-node update)
    (let ((new-level (random-level skip-list))
          (old-level (skip-list/level skip-list)))
      (let ((new-node (make-node new-level element)))
        (define (splice level old-node)
          (set-node-forward! new-node level (node-forward old-node level))
          (set-node-forward! old-node level new-node))
        (let ((limit-from-current (min (bottom-level) new-level))
              (limit-from-update (min old-level new-level)))
          (do ((level (bottom-level) (fix:+ level 1)))
              ((fix:= level limit-from-current))
            (splice level current-node))
          (do ((level limit-from-current (fix:+ level 1)))
              ((fix:= level limit-from-update))
            (splice level (vector-ref update level)))
          (if (fix:> new-level old-level)
              (let ((old-header (skip-list/header skip-list))
                    (new-header (make-header-node new-level)))
                (move-forward! old-header old-level new-header)
                (fill-forward! new-header old-level new-level new-node)
                (set-skip-list/header! skip-list new-header)))))))

;;;; MAKE-SKIP-LIST-TYPE continued: deletion algorithm

  (define (do-delete skip-list key current-level current-node update)
    (let ((max-level (skip-list/level skip-list))
          (delete-node (node-forward current-node current-level)))
      (define (unsplice level node)
        (set-node-forward! node level (node-forward delete-node level)))
      (define (delete-up level)
        (if (fix:< level max-level)
            (let* ((node (vector-ref update level))
                   (node* (node-forward node level)))
              (if (eq? node* delete-node)
                  (begin (unsplice level node)
                         (delete-up (fix:+ level 1)))))))
      (define (delete-across level node)
        (let ((node* (node-forward node level)))
          (if (node? node*)
              (let* ((element* (node-element node*))
                     (key* (element->key element*)))
                (if (key<? key* key)
                    (delete-across level node*)
                    (begin
                      (if (eq? node* delete-node)
                          (unsplice level node))
                      (delete-down level node))))
              (delete-down level node))))
      (define (delete-down level node)
        (let ((level* (fix:- level 1)))
          (if (not (bottom-level? level))
              (delete-across level* node))))
      (delete-up current-level)
      (delete-across current-level current-node)
      (if (fix:= max-level (node-level delete-node))
          (let ((old-header (skip-list/header skip-list)))
            (let loop ((bound max-level))
              (if (bottom-level? bound)
                  (set-skip-list/header! skip-list (empty-header-node))
                  (let* ((level (fix:- bound 1))
                         (node (node-forward old-header level)))
                    (if (node? node)
                        (if (fix:< level max-level)
                            (let ((new-header (make-header-node bound)))
                              (move-forward! old-header bound new-header)
                              (set-skip-list/header! skip-list new-header)))
                        (loop level)))))))))

;;;; MAKE-SKIP-LIST-TYPE continued: update utilities

  (define (insert! skip-list element)
    (update! skip-list (element->key element)
      (lambda (element* replace delete)
        (declare (ignore element* delete) (integrate replace))
        (replace element))
      (lambda (insert)
        (declare (integrate insert))
        (insert element))))

  (define (intern! skip-list key generator)
    (update! skip-list key
      (lambda (element replace delete)
        (declare (ignore replace delete) (integrate element))
        element)
      (lambda (insert)
        (declare (integrate insert))
        (let ((element (generator key)))
          (let ((key* (element->key element)))
            (if (or (key<? key key*) (key<? key* key))
                (error "Interned element has inequal key:" element key key*)))
          (insert element)
          element))))

  (define (delete! skip-list key)
    (update! skip-list key
      (lambda (element replace delete)
        (declare (ignore element replace) (integrate delete))
        (delete))
      (lambda (insert)
        (declare (ignore insert))
        unspecific)))

  (%make-skip-list-type element->key
                        key<?
                        search
                        update!
                        lookup
                        contains-key?
                        insert!
                        intern!
                        delete!))

;;;; Miscellaneous Skip List Types

(define (make-skip-list-set-type key<?)
  (declare (integrate make-skip-list-type key<?))
  (make-skip-list-type (lambda (element)
                         (declare (integrate element))
                         element)
                       key<?))

(define-integrable (make-skip-list-set-type+ key<?)
  (declare (integrate make-skip-list-set-type))
  (make-skip-list-set-type key<?))

(define skip-list-type:real-number-set (make-skip-list-set-type+ <))
(define skip-list-type:exact-integer-set (make-skip-list-set-type+ int:<))
(define skip-list-type:symbol-set (make-skip-list-set-type symbol<?))
(define skip-list-type:string-set (make-skip-list-set-type string<?))
(define skip-list-type:string-set-ci (make-skip-list-set-type string-ci<?))

(define (make-skip-list-map-type key<?)
  (declare (integrate make-skip-list-type key<?))
  (make-skip-list-type car key<?))

(define-integrable (make-skip-list-map-type+ key<?)
  (declare (integrate make-skip-list-map-type))
  (make-skip-list-map-type key<?))

(define skip-list-type:real-number-map (make-skip-list-map-type+ <))
(define skip-list-type:exact-integer-map (make-skip-list-map-type+ int:<))
(define skip-list-type:symbol-map (make-skip-list-map-type symbol<?))
(define skip-list-type:string-map (make-skip-list-map-type string<?))
(define skip-list-type:string-map-ci (make-skip-list-set-type string-ci<?))

;;; Iterator for foof-loop; see
;;; <http://mumble.net/~campbell/scheme/foof-loop.txt>.

(define-syntax in-skip-list
  (syntax-rules ()
    ((IN-SKIP-LIST (element-variable) (skip-list-expression) next . rest)
     (next (((SKIP-LIST) skip-list-expression))       ;Outer bindings
           ((NODE (SKIP-LIST/INITIAL-NODE SKIP-LIST)  ;Loop variables
                  NODE*))
           ()                                         ;Entry bindings
           ((NOT (NODE? NODE)))                       ;Termination conditions
           (((element-variable) (NODE-ELEMENT NODE))  ;Body bindings
            ((NODE*) (NODE-NEXT NODE)))
           ()                                         ;Final bindings
           . rest))))

(define (skip-list/initial-node skip-list)
  (let ((header (skip-list/header skip-list)))
    (if (bottom-level? (node-level header))
        #f
        (node-next header))))

;;;; Testing, Diagnostic, and General Utilities

;;; This is no excuse for a proper test suite.

(define (test-skip-list count)
  (let ((set (make-skip-list skip-list-type:string-set)))
    (do ((i 0 (+ i 1)))
        ((>= i count))
      (let ((s (number->string i)))
        (skip-list/insert! set s)
        (if (not (= i (string->number (skip-list/lookup set s "-1"))))
            (error "Intermediate lossage in insertion:" i))))
    (do ((i 0 (+ i 2)))
        ((>= i count))
      (let ((s (number->string i)))
        (skip-list/delete! set s)
        (if (skip-list/lookup set s #f)
            (error "Intermediate lossage in deletion:" i))))
    (do ((i 0 (+ i 1)))
        ((>= i count))
      (let ((s (number->string i)))
        (if (if (even? i)
                (skip-list/lookup set s #f)
                (not (= i (string->number (skip-list/lookup set s "-1")))))
            (error "Post-lossage:" i))))
    set))

;++ Implement SKIP-LIST-HORIZONTALS.

(define (skip-list/verticals skip-list)
  (define (vertical-elements node)
    (let loop ((level (bottom-level)) (elements '()))
      (if (fix:= level (node-level node))
          elements
          (let ((node* (node-forward node level)))
            (if (node? node*)
                (loop (fix:+ level 1)
                      (cons (node-element node*) elements))
                elements)))))
  (let ((header (skip-list/header skip-list)))
    (if (bottom-level? (node-level header))
        '()
        (let loop ((node header) (verticals '()))
          (let ((node* (node-next node)))
            (if (node? node*)
                (loop node* (cons (vertical-elements node) verticals))
                (reverse verticals)))))))

(define (flip-coin)
  (fix:zero? (random-integer 2)))