; Copyright (c) 2011-2013, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; 
; Author: Juergen Lorenz
;         ju (at) jugilo (dot) de
;
; Last update: Apr 19, 2013
;
;Rationale
;=========
;
;Skiplists are data-types, which can replace balanced search-trees. They
;are invented by Pugh. The idea is as follows:
;
;Contrary to listnodes, which are pairs of an item and a next pointer,
;skipnodes are pairs of an item and a vector of next pointers. The
;length' of these vectors depend on each skipnode itself. They are
;choosen randomly in such a way, that, in the average, the number of
;nodes with at least k links is half the number of links with at least
;k-1 links, for k>1. Following the next pointers at a fixed link-level,
;k say, one skips all nodes with less than k pointers.
;
;Inserting an item into a skiplist now works as follows.
;First one packages the item into a skipnode, where the number of links
;is generated randomly as described above.
;Second, one follows the skiplist along the highest occupied number of
;links as long as the skiplist's nodes point to items less then the item
;of the node to be inserted.
;Third, one steps down one level and continues following the skiplist's
;nodes at this new smaller level.
;Repeating this process until level 0 is reached we eventually find the
;place where our new node is to be inserted.
;
;Some additional remarks are in order.
;
;We described the process with a width of two, i.e. at each level in the
;average one node of the level below is skipped.  A higher value than two
;for the width is possible as well, trading performance against space.
;
;We have to decide, what to do with duplicates. We choose the following
;approach: The skiplist itself stores a list of either one or several numerical
;comparison operators. Only if the last of those operators is the special
;comparison operator dups (which returns constantly 0, i.e. it compares
;nothing) duplicates are allowed. Moreover, we arrage matters in such a
;way, that all nodes of duplicates with the same key have the same
;height, so that a search for the item which was inserted last will be
;found first.


(module %skiplists
  (skiplist skiplist? skiplist-null? skiplist-item? skiplist-found?
            skiplist-dups? skiplist-insert! skiplist-remove!
            skiplist-clear! skiplist-search! skiplist-orders
            skiplist-compare skiplist-width skiplist-height
            skiplist-found skiplist->list skiplist-filter skiplist-map
            skiplist-for-each skiplist-reorder skiplist-restructure
            skiplist-count skiplist-search-level skiplist-min
            skiplist-max dups skiplist-max-height) 

(import scheme
  (only chicken
        define-record-type define-record-printer optional when unless
        define-inline error void fixnum?
        fx+ fx- fx>= fx> fx< fx= fxmin gensym vector-resize getter-with-setter)
  (only data-structures identity list-of?)
  (only extras format random))

(define-syntax do-while
  (syntax-rules ()
    ((_ test? xpr xpr1 ...)
     (let loop ()
       (if test?
         (begin
           xpr xpr1 ...
           (loop)))))))

(define-inline (fx1- n) (fx- n 1))
(define-inline (fx1+ n) (fx+ n 1))

(define (repeat-string str k)
  (let loop ((k k) (result ""))
    (if (fx= k 0)
      result
      (loop (fx1- k) (string-append str result)))))

(define (choose-height width)
  (let loop ((choice (random width)) (k 1))
    (if (fx>= choice 1)
      k
      (loop (random width) (fx1+ k)))))

;; trivial comparison operator to allow duplicates
;; must be the last order in the orders list
(define (dups x y)
  0)
;;;; skipnode ADT (hidden)

(define-record-type skipnode
  (make-skipnode item next)
  skipnode?
  (item skipnode-item)
  (next skipnode-next))

;;; constructor
(define-inline (skipnode item height)
  (make-skipnode item (make-vector height '())))

;; items of the first and last skipnode
(define gstart (gensym 'start))
(define gfinish (gensym 'finish))

(define-inline (skipnode-finish? node)
  (eq? (skipnode-item node) gfinish))

(define-inline (skipnode-start? node)
  (eq? (skipnode-item node) gstart))

(define skipnode-next-ref
  (getter-with-setter
    (lambda (node k)
      (vector-ref (skipnode-next node) k))
    (lambda (node k new)
      (vector-set! (skipnode-next node) k new))))

(define-inline (skipnode-height node)
  (vector-length (skipnode-next node)))

(define-record-printer (skipnode node out)
  (format out "~S#~S"
          (skipnode-item node) (skipnode-height node)))

(define-record-type skiplist
  (make-skiplist width item? orders height count start cursor found level finish)
  skiplist?
  (width skiplist-width)
  (item? skiplist-item?)
  (orders skiplist-orders)
  ;; setters not exported, cursor not exported
  (height skiplist-height skiplist-height-set!)
  (count skiplist-count skiplist-count-set!)
  (start skiplist-start (setter skiplist-start)) ; vector of max-height
  (cursor skiplist-cursor (setter skiplist-cursor)) ; vector of nodes
  (found skiplist-found skiplist-found-set!)
  (level skiplist-search-level skiplist-search-level-set!)
  (finish skiplist-finish (setter skiplist-finish)))

(define-record-printer (skiplist sls out)
  (format out "#,(skiplist[dups: ~s width: ~s height: ~s count: ~s]"
          (skiplist-dups? sls)
          (skiplist-width sls)
          (skiplist-height sls)
          (skiplist-count sls))
  (if (skiplist-null? sls)
    (display ")" out)
    ;(format out " ~s ... ~s)" (skiplist-min sls) (skiplist-max sls))))
    (let ((smin (skiplist-min sls)) (smax (skiplist-max sls)))
      (format out "~? ...~?)~%"
              (repeat-string " ~s" (length smin)) smin
              (repeat-string " ~s" (length smax)) smax))))

;; check constructor arguments (internal)
(define (width-and-max-height? ls)
  (and (list? ls)
       (fx> (length ls) 3)
       (let ((width (car ls))
             (max-height (cadr ls))
             (item? (caddr ls))
             (orders (cdddr ls)))
         (fixnum? width)
         (fx> width 1)
         (fixnum? max-height)
         (fx> max-height 1)
         (procedure? item?)
         ((list-of? procedure?) orders))))

(define (max-height? ls)
  (and (list? ls)
       (fx> (length ls) 2)
       (let ((max-height (car ls))
             (item? (cadr ls))
             (orders (cddr ls)))
         (fixnum? max-height)
         (fx> max-height 1)
         (procedure? item?)
         ((list-of? procedure?) orders))))

;; constructor
(define (skiplist . args)
  (cond
    ;; width and max-height supplied
    ((width-and-max-height? args)
     (let* ((max-height (cadr args))
            (finish (skipnode gfinish max-height))
            (start (make-skipnode gstart (make-vector max-height finish))))
       (make-skiplist (car args) ; width
                      (caddr args) ; item?
                      (cdddr args) ; orders
                      1 ; height
                      0 ; count
                      start
                      (vector start) ; cursor
                      '() ; found
                      0 ; level
                      finish)))
    ;; default value for width
    ((max-height? args)
     (let* ((max-height (car args))
            (finish (skipnode gfinish max-height))
            (start (make-skipnode gstart (make-vector max-height finish))))
       (make-skiplist 2 ; width
                      (cadr args) ; item?
                      (cddr args) ; orders
                      1 ; height
                      0 ; count
                      start
                      (vector start) ; cursor
                      '() ; found
                      0 ; level
                      finish)))
    ;; default values for width and max-height
    ((and (fx> (length args) 1) ((list-of? procedure?) args))
     (let* ((max-height 10)
            (finish (skipnode gfinish max-height))
            (start (make-skipnode gstart (make-vector max-height finish))))
       (make-skiplist 2 ; width
                      (car args) ; item?
                      (cdr args) ; (cons order orders)
                      1 ; height
                      0 ; count
                      start
                      (vector start) ; cursor
                      '() ; found
                      0 ; level
                      finish)))
    (else (error 'skiplist "no constructor arguments" args))))

(define (skiplist-max-height sls)
  (vector-length (skipnode-next (skiplist-start sls))))

(define (skiplist-dups? sls)
  ;; dups as last item in the orders list
  (let ((dups? (memq dups (skiplist-orders sls))))
    (and dups? (null? (cdr dups?)))))

(define (skiplist-null? sls)
  (zero? (skiplist-count sls)))

(define (skiplist-found? sls item)
  (member item (skiplist-found sls)))

;; combine orders
(define (skiplist-compare sls)
  (let loop ((orders (skiplist-orders sls)))
    (unless (null? orders)
      (let ((cmp (car orders)) (rest (cdr orders)))
        (if (null? rest)
          cmp
          (lambda (x y)
            (if (zero? (cmp x y))
              ((loop rest) x y)
              (cmp x y))))))))

;; compare items
(define (skiplist-less? sls item0 item1)
  (cond
    ((eq? item0 gstart) #t)
    ((eq? item0 gfinish) #f)
    ((eq? item1 gstart) #f)
    ((eq? item1 gfinish) #t)
    (else
      (negative?
        ((skiplist-compare sls) item0 item1)))))

(define (skiplist-equal? sls item0 item1)
  (and (not (skiplist-less? sls item0 item1))
       (not (skiplist-less? sls item1 item0))))

(define (cursor-less? sls k item)
  (skiplist-less? sls (skipnode-item (cursor-next sls k)) item))

(define (cursor-equal? sls k item)
  (skiplist-equal? sls (skipnode-item (cursor-next sls k)) item))

;; all operations should happen at the cursor, where it is moved in such
;; a way, that is less than a node but points to a node which is not

(define cursor-ref
  (getter-with-setter
    (lambda (sls k)
      (vector-ref (skiplist-cursor sls) k))
    (lambda (sls k node)
      (vector-set! (skiplist-cursor sls) k node))))

(define cursor-next
  (getter-with-setter
    (lambda (sls k)
      (skipnode-next-ref (cursor-ref sls k) k))
    (lambda (sls k new)
      (set! (skipnode-next-ref (cursor-ref sls k) k) new))))

(define skiplist-start-next
  (getter-with-setter
    (lambda (sls k)
      (skipnode-next-ref (skiplist-start sls) k))
    (lambda (sls k node)
      (set! (skipnode-next-ref (skiplist-start sls) k) node))))

;; cursor movements
(define (cursor-forth! sls k)
  (set! (cursor-ref sls k)
        (cursor-next sls k)))

(define (cursor-moveto! sls k item)
  (do-while (cursor-less? sls k item)
            (cursor-forth! sls k)))

(define (cursor-start! sls k)
  (set! (cursor-ref sls k)
        (skiplist-start-next sls k)))

;;; this is where the work gets done!
(define (skiplist-search! sls item)
  (call-with-current-continuation
    (lambda (out)
      (let ((top (fx1- (skiplist-height sls))))
        ;; save cursors at every level
        (do ((k top (fx1- k)))
          ((negative? k))
          (if (fx= k top)
            ;;; restart cursor at highest level only if cursor not less item
            (if (not (cursor-less? sls k item))
              (set! (cursor-ref sls k) (skiplist-start sls)))
            ;; start at every lower cursor level with the result of the level above
            (set! (cursor-ref sls k) (cursor-ref sls (fx1+ k))))
          ;; advance cursor horizontally
          (cursor-moveto! sls k item)
          (if (cursor-equal? sls k item) ; item found
            (begin
              (skiplist-search-level-set! sls k)
              ;; collect found items
              (let loop ((node (cursor-next sls k)) (found '()))
                (if (not (skiplist-equal? sls (skipnode-item node) item))
                  (skiplist-found-set! sls (reverse found))
                  (loop (skipnode-next-ref node k)
                        (cons (skipnode-item node) found))))
              (out (void)))
            (begin
              (skiplist-found-set! sls '())
              (skiplist-search-level-set! sls k))))))))

(define (skiplist-search-further! sls item)
  ;; save cursors at every level below search level
  (do ((k (fx1- (skiplist-search-level sls)) (fx1- k)))
    ((negative? k))
      ;; restart cursor at every lower cursor level with the result of the level above
    (set! (cursor-ref sls k) (cursor-ref sls (fx1+ k)))
    ;; advance cursor horizontally
    (cursor-moveto! sls k item)))

(define (skiplist-insert! sls item . items)
  (let ((height (fxmin (skiplist-max-height sls)
                       (choose-height (skiplist-width sls)))))
    ;; restructure
    (when (> height (skiplist-height sls))
      (set! (skiplist-cursor sls)
            (vector-resize (skiplist-cursor sls)
                           height
                           (skiplist-start sls)))
      (skiplist-search-level-set! sls height)
      (skiplist-height-set! sls height))
    ;; insert
    (if (skiplist-dups? sls)
      (begin
        ;; prepare upper part of cursor for insertion
        (skiplist-search! sls item) ; ok
        (let* (
          ;; the new node should have the same height as the
          ;; found one so removing all is fast
          (height (if (null? (skiplist-found sls))
                    height
                    (skipnode-height
                      (cursor-next sls (skiplist-search-level sls)))))
          (new (skipnode item height))
          )
          ;; prepare lower part of cursor for insertion
          (skiplist-search-further! sls item)
          (skiplist-count-set! sls (fx1+ (skiplist-count sls)))
          (skiplist-found-set! sls (cons item (skiplist-found sls)))
          (do ((k 0 (fx1+ k)))
            ((fx= k height))
            (set! (skipnode-next-ref new k)
                  (cursor-next sls k))
            (set! (cursor-next sls k) new))))
      (begin
        ;; prepare upper part of cursor
        (skiplist-search! sls item)
        (when (null? (skiplist-found sls))
          ;; prepare lower part of cursor
          (skiplist-search-further! sls item)
          (let ((new (skipnode item height)))
            (skiplist-count-set! sls (fx1+ (skiplist-count sls)))
            (do ((k 0 (fx1+ k)))
              ((fx= k height))
              (set! (skipnode-next-ref new k)
                    (cursor-next sls k))
              (set! (cursor-next sls k) new)))))))
  ;; insert additional items, if there are any
  (do ((items items (cdr items)))
    ((null? items))
    (skiplist-insert! sls (car items))))

(define (skiplist-remove! sls item . items)
  ;; remove one item if found
  (skiplist-search! sls item)
  (if (member item (skiplist-found sls))
    (unless (null? (skiplist-found sls))
      (let ((level (skiplist-search-level sls)))
        ;; advance horizontally until item found
        (do-while
          (not (equal? item
                       (skipnode-item (cursor-next sls level))))
          (cursor-forth! sls level))
        (skiplist-search-further! sls item)
        (when (cursor-equal? sls level item)
          (set! (cursor-next sls level)
                (skipnode-next-ref (cursor-next sls level) level))
          (skiplist-count-set! sls (fx1- (skiplist-count sls)))
          (skiplist-found-set! sls (cdr (skiplist-found sls)))
          (do ((k 0 (fx1+ k)))
            ((fx= k level))
            (when (cursor-equal? sls k item)
              (set! (cursor-next sls k)
                    (skipnode-next-ref (cursor-next sls k) k))))))))
  ;; remove other items, if any
  (do ((items items (cdr items)))
    ((null? items))
    (skiplist-remove! sls (car items))))

(define (skiplist-for-each sls proc)
  (do ((node (skipnode-next-ref (skiplist-start sls) 0)
             (skipnode-next-ref node 0)))
    ((skipnode-finish? node)) ; way out
    (proc (skipnode-item node))))

(define (skiplist-clear! sls)
  (skiplist-height-set! sls 1)
  (do ((k 0 (fx1+ k)))
    ((fx= k (skiplist-max-height sls)))
    (set! (skiplist-start-next sls k) (skiplist-finish sls)))
  (set! (skiplist-cursor sls) (make-vector 1 (skiplist-start sls)))
  (skiplist-count-set! sls 0))

(define (skiplist-map sls proc . args)
  (let (
    (result
      (cond
        ;; old width, max-height, item? and orders
        ((null? args)
         (apply skiplist
                (skiplist-width sls)
                (skiplist-max-height sls)
                (skiplist-item? sls)
                (skiplist-orders sls)))
        ;; old width and max-height,  new item? and orders
        ((and (fx> (length args) 1)
              ((list-of? procedure?) args))
         (apply skiplist
                (skiplist-width sls)
                (skiplist-max-height sls)
                args))))
    )
    (do ((node (skipnode-next-ref (skiplist-start sls) 0)
               (skipnode-next-ref node 0)))
      ((skipnode-finish? node)) ; way out
      (skiplist-insert! result (proc (skipnode-item node))))
    result))

(define (skiplist-restructure sls width max-height)
  (let ((result (apply skiplist
                       width
                       max-height
                       (skiplist-item? sls)
                       (skiplist-orders sls))))
    (do ((node (skipnode-next-ref (skiplist-start sls) 0) (skipnode-next-ref node 0)))
      ((skipnode-finish? node))
      (skiplist-insert! result (skipnode-item node)))
    result))

(define (skiplist-reorder sls order . orders)
  ;(apply skiplist-map sls identity order orders))
  (let ((result (apply skiplist
                       (skiplist-width sls)
                       (skiplist-max-height sls)
                       (skiplist-item?  sls)
                       order orders)))
    (do ((node (skipnode-next-ref (skiplist-start sls) 0) (skipnode-next-ref node 0)))
      ((skipnode-finish? node))
      (skiplist-insert! result (skipnode-item node)))
    result))

(define (skiplist-filter sls ok?)
  (let ((result (apply skiplist
                       (skiplist-width sls)
                       (skiplist-max-height sls)
                       (skiplist-item?  sls)
                       (skiplist-orders sls))))
    (do ((node (skipnode-next-ref (skiplist-start sls) 0)
               (skipnode-next-ref node 0)))
      ((skipnode-finish? node)) ; way out
      (let ((item (skipnode-item node)))
        (if (ok? item) (skiplist-insert! result item))))
    result))

(define (skiplist-min sls)
  (if (skiplist-null? sls)
    '()
    (begin
      (cursor-start! sls 0)
      ;(skipnode-item (cursor-ref sls 0)))
      (skiplist-search! sls (skipnode-item (cursor-ref sls 0)))
      (skiplist-found sls))))
  ;(let ((item (skipnode-item (cursor-ref sls 0))))
  ;  (if (skiplist-dups? sls)
  ;    (begin
  ;      (skiplist-search! sls item)
  ;      (skiplist-found sls))
  ;    item)))

(define (skiplist-max sls)
  ;; skiplist-search! won't work since gfinish is of wrong type;
  ;; moreover it stores the next item in found, wheras max is the
  ;; present item at level 0 after moveto!
  (if (skiplist-null? sls)
    '()
    (begin 
      (let ((top (fx1- (skiplist-height sls))))
        ;; save cursors at every level
        (do ((k top (fx1- k)))
          ((negative? k))
          ;; at highest start where you are, it's always less gfinish
          (if (fx< k top)
            ;; start at every lower cursor level with the result of the level above
            (set! (cursor-ref sls k) (cursor-ref sls (fx1+ k))))
          ;; advance cursor horizontally
          (cursor-moveto! sls k gfinish)))
      ;(skipnode-item (cursor-ref sls 0)))
      (skiplist-search! sls (skipnode-item (cursor-ref sls 0)))
      (skiplist-found sls))))

(define (skiplist->list sls . level)
  (let ((k (optional level 0)))
    (cursor-start! sls k)
    (let loop ((node (cursor-ref sls k)) (result '()))
      (if (skipnode-finish? node)
        (reverse result)
        (loop (skipnode-next-ref node k) (cons (skipnode-item node) result))))))

) ; module %skiplists

(require-library dbc)

(module skiplists *

(import scheme
        dbc
        (only chicken cut
              fixnum? fx>= fx> fx< fx<= fx=)
        ; get-output-string open-output-string)
        (only data-structures list-of? constantly)
        (prefix (except %skiplists dups) %))

(reexport (only %skiplists dups))
; since the adress of dups is checked in skiplist-dups? dups can not be
; wrapped into a contract

(init-dbc)

;;; constructor
(define-with-contract skiplist
  (contract (result)
    ((_ width max-height item? order . orders)
     (and (fixnum? width) (fx> width 1)
          (fixnum? max-height) (fx> max-height 1)
          (procedure? item?) "(item? item)"
          (procedure? order) "(fixnum? (order item? item?))"
          ((list-of? procedure?) orders)
          "like order, last one might be dups")
     (%skiplist? result))
    ((_ max-height item? order . orders)
     (and (fixnum? max-height) (fx> max-height 1)
          (procedure? item?) "(item? item)"
          (procedure? order) "(fixnum? (order item? item?))"
          ((list-of? procedure?) orders)
          "like order, last one might be dups")
     (%skiplist? result))
    ((_ item? order . orders)
     (and (procedure? item?) "(item? item)"
          (procedure? order) "(fixnum? (order item? item?))"
          ((list-of? procedure?) orders)
          "like order, last one might be dups")
     (%skiplist? result)))
  %skiplist)

;;; predicates
(define-with-contract skiplist?
  (contract (result)
    ((_ xpr)
     #t
     (boolean? result)))
  %skiplist?)

;; is skiplist empty?
(define-with-contract skiplist-null?
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     (boolean? result)))
  %skiplist-null?)

;; are duplicates allowed?
(define-with-contract skiplist-dups?
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     (boolean? result)))
  %skiplist-dups?)

;; item type predicate
(define-with-contract skiplist-item?
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     (procedure? result)))
  %skiplist-item?)

;; item found?
(define-with-contract skiplist-found?
  (contract (result)
    ((_ sls item)
     (and (%skiplist? sls) ((%skiplist-item? sls) item))
     (boolean? result)))
  %skiplist-found?)

;;; functions


;; since the adress of dups is checked in skiplist-dups? dups can not be
;; wrapped into a contract, but documentation should be provided.
;; If dups is supplied as last item in list of orders dupliacates are allowed
(push-contract!
  '(dups (procedure (result)
           ((_ x y)
            (and ((skiplist-item? sls) x) ((skiplist-item? sls) y))
            (fx= result 0)))))

;; list of found items, to be called after search!
(define-with-contract skiplist-found
  (contract (result)
    ((_ sls)
     (%skiplist? sls)
     ((list-of? (%skiplist-item? sls)) result)))
  %skiplist-found)

;; smallest items stored in skiplist
(define-with-contract skiplist-min
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     ((list-of? (%skiplist-item? sls)) result)))
  %skiplist-min)

;; biggest items stored in skiplist
(define-with-contract skiplist-max
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     ((list-of? (%skiplist-item? sls)) result)))
  %skiplist-max)


;; maximum heigth of nodes in skiplist
(define-with-contract skiplist-height
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     (and (fixnum? result) (fx> result 0))))
  %skiplist-height)

;; width skipped on average at each search level supplied by constructor
(define-with-contract skiplist-width
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     (and (fixnum? result) (fx> result 1))))
  %skiplist-width)

;; maximal height
(define-with-contract skiplist-max-height
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     (and (fixnum? result) (fx> result 1))))
  %skiplist-max-height)

;; number of items stored in skiplist
(define-with-contract skiplist-count
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     (and (fixnum? result) (fx>= result 0))))
  %skiplist-count)

;; list of orders defined in the constructor
(define-with-contract skiplist-orders
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     ((list-of? procedure?) result)))
  %skiplist-orders)

;; combined comparison function
(define-with-contract skiplist-compare
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     (and (procedure? result) "(fixnum? (result x y))")))
  %skiplist-compare)
  
;; down to which level a previous search descended?
(define-with-contract skiplist-search-level
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     (and (fixnum? result) (fx>= result 0)
          (fx< result (skiplist-height sls)))))
  %skiplist-search-level)

;; the list of items stored in each level
(define-with-contract skiplist->list
  (contract (result)
    ((_ sls)
     (%skiplist? sls) 
     ((list-of? (%skiplist-item? sls)) result))
    ((_ sls level)
     (and (%skiplist? sls) (fixnum? level)
          (fx<= 0 level) (fx< level (%skiplist-height sls))) 
     ((list-of? (%skiplist-item? sls)) result)))
  %skiplist->list)

;; filtering
(define-with-contract skiplist-filter
  (contract (result)
    ((_ sls ok?)
     (and (%skiplist? sls) (procedure? ok?) "(boolean? (ok? x))")
     (%skiplist? result)))
  %skiplist-filter)

;; mapping: depending on the mapping function, different order
;; procedures might be necessary
(define-with-contract skiplist-map
  (contract (result)
    ((_ sls fn)
     (and (%skiplist? sls) (procedure? fn) "((skiplist-item? sls) (fn x))")
     (%skiplist? result))
    ((_ sls fn order . orders)
     (and (%skiplist? sls) (procedure? fn)
          (((list-of? procedure?) (cons order orders))))
     (%skiplist? result))
    ((_ sls fn width)
     (and (%skiplist? sls) (fixnum? width) (fx> width 1)
          (procedure? fn) "((skiplist-item? sls) (fn x))")
     (%skiplist? result))
    ((_ sls fn width order . orders)
     (and (%skiplist? sls) (procedure? fn)
          (fixnum? width) (fx> width 1)
          (((list-of? procedure?) (cons order orders))))
     (%skiplist? result)))
  %skiplist-map)

;; changing orders
(define-with-contract skiplist-reorder
  (contract (result)
    ((_ sls order . orders)
     (and (%skiplist? sls) ((list-of? procedure?) (cons order orders))
          "each (fixnum? (order x y))")
     (%skiplist? result)))
  %skiplist-reorder)

;; changing width
(define-with-contract skiplist-restructure
  (contract (result)
    ((_ sls width max-height)
     (and (%skiplist? sls) (fixnum? width) (fx> width 1)
          (fixnum? max-height) (fx> max-height 1))
     (%skiplist? result)))
  %skiplist-restructure)

;;; commands

;; for-each
(define-with-contract skiplist-for-each
  (command-contract ((old new (constantly #t)))
    ((_ sls proc)
     (and (%skiplist? sls) (procedure? proc))
     new))
  %skiplist-for-each)

;; searching for an item changes cursor transparently
(define-with-contract skiplist-search!
  (command-contract (
    (oldlevel newlevel (lambda (sls item)
                         (%skiplist-search-level sls)))
    (oldfound newfound (lambda (sls item)
                         (%skiplist-found sls)))
    )
    ((_ sls item)
     (and (%skiplist? sls) ((%skiplist-item? sls) item))
     (and (fx>= newlevel 0) (fx< newlevel (%skiplist-height sls))
          ((list-of? (%skiplist-item? sls)) newfound)
          ((list-of? zero?) (map (lambda (x) ((%skiplist-compare sls) item x))
                                 newfound)))))
  %skiplist-search!)

(define-with-contract skiplist-insert!
  (command-contract (
    (oldcount newcount (lambda (sls . items) (%skiplist-count sls)))
    ;; it suffices to check first item, since routine is recursive
    (oldfound newfound (lambda (sls . items)
                         (%skiplist-search! sls (car items))
                         (%skiplist-found sls)))
    )
    ((_ sls item . items)
     (and (%skiplist? sls)
          ((list-of? (%skiplist-item? sls))
           (cons item items)))
     (and (fx>= newcount oldcount)
          (member item newfound))))
  %skiplist-insert!)

;; remove special item found with item
(define-with-contract skiplist-remove!
  (command-contract (
    (oldcount newcount (lambda (sls . items) (%skiplist-count sls)))
    )
    ((_ sls item . items)
     (and (%skiplist? sls)
          ((list-of? (%skiplist-item? sls))
           (cons item items)))
     (fx<= newcount oldcount)))
  %skiplist-remove!)

;; reset skiplist
(define-with-contract skiplist-clear!
  (command-contract (
    (oldcount newcount %skiplist-count)
    (oldheight newheight %skiplist-height)
    )
    ((_ sls)
     (%skiplist? sls)
     (and (fx= 0 newcount) (fx= 1 newheight))))
  %skiplist-clear!)

(exit-dbc-with skiplists)
) ; module skiplists