; Copyright (c) 2011, 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: Aug 2, 2012
;
;Rationale
;=========
;
;Skiplists are data-types, which can replace balanced search-trees. They
;are described by Sedgewick. 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 vary
;between 1 and a predefind integer, max-links. An alternative to
;balancing is achieved by some randomization 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,...,max-links. Following the
;next pointers at a fixed link-level, k say,  one skips all nodes with less
;pointers than k.
;
;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 in some randomized way.
;Second, one follows the skiplist along the highest occupied number of
;links as long as the skiplist's nodes have 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 gap of two, i.e. at each level one node
;of the level below is skipped.  Another value than two for the gap is
;possible as well.
;
;We have to decide, what to do with duplicates. We choose the following
;approach: The skilist itself stores a list of either one or several numerical
;comparison operators. One means, duplicates are not allowed, several means,
;that the nth operator resolves the remaining duplicates the operators
;below n.
;
(require-library records contracts)

(module %skiplists
  (skiplist? make-skiplist make-skiplist-with-gap skip-compare
   make-skiplist-from-list make-skiplist-with-gap-from-list
   skip-search!  skip-insert! skip-remove! skip-list skip-gap skip-count
   skip-remove-all! skip-found? skip-dups? skip-links skip-max-links dups
   skip-restructure skip-for-each skip-orders skip-reorder
   skip-filter)

(import scheme records
  (only chicken
    assert when unless keyword? optional
    getter-with-setter print); get-output-string open-output-string)
  (only data-structures list-of?)
  (only extras random))

;;;; skipnode ADT (hidden)

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

(define make-skipnode
  (record-constructor skipnode-type))

(define skipnode? (record-predicate skipnode-type))

(define skipnode-item
  (record-accessor skipnode-type 'item))

(define skip-next
  (record-accessor skipnode-type 'next))

(define (skipnode-links node)
  (if (null? node)
    0
    (vector-length (skip-next node))))

(define skipnode-next
  (getter-with-setter
    (lambda (node k)
      (if (>= k (skipnode-links node))
        '()
        (vector-ref (skip-next node) k)))
    (lambda (node k new)
      (if (>= k (skipnode-links node))
        (set! node new)
        (vector-set! (skip-next node) k new)))))

;;; insert node after cursor, which is another node
(define (skipnode-insert! cursor newnode)
  (let down ((k (- (skipnode-links newnode) 1)))
    (unless (negative? k)
      (let ((node (skipnode-next cursor k)))
        (set! (skipnode-next newnode k) (skipnode-next node k))
        (set! (skipnode-next node k) newnode)
        (down (- k 1))))))

;;; delete node after cursor, which is another node
(define (skipnode-remove! cursor links)
  (let down ((k (- links 1)))
    (unless (negative? k)
      (let ((node (skipnode-next cursor k)))
        (set! (skipnode-next node k) (skipnode-next (skipnode-next node k) k))
        (down (- k 1))))))

;;;; skiplist ADT

(define skip-type
  (make-record-type 'skiplist
    '(orders gap links count cursor start)))

(define skiplist?  (record-predicate skip-type))

(define skip-maker
  (record-constructor skip-type))

(define skip-orders (record-accessor skip-type 'orders))

(define skip-gap (record-accessor skip-type 'gap))

(define skip-count
  (getter-with-setter (record-accessor skip-type 'count)
                      (record-modifier skip-type 'count)))

(define skip-links
  (getter-with-setter (record-accessor skip-type 'links)
                      (record-modifier skip-type 'links)))

(define (skip-cursor skp)
  (make-skipnode cursor: ((record-accessor skip-type 'cursor) skp)))

(define (skip-start skp)
  (make-skipnode start: ((record-accessor skip-type 'start) skp)))

(define (make-skiplist max-links . orders)
  (apply make-skiplist-with-gap max-links 2 orders))

(define (make-skiplist-with-gap max-links gap . orders)
  (skip-maker orders gap 1 0
              (make-vector max-links '())
              (make-vector max-links '())))

(define (make-skiplist-from-list lst max-links . orders)
  (apply make-skiplist-with-gap-from-list lst max-links 2 orders))

(define (make-skiplist-with-gap-from-list lst max-links gap . orders)
  (let ((skp (apply make-skiplist-with-gap max-links gap orders)))
    (let loop ((lst lst))
      (unless (null? lst)
        (skip-insert! skp (car lst))
        (loop (cdr lst))))
    skp))

(define (skip-restructure skp max-links gap)
  (let (
    (result (apply make-skiplist-with-gap max-links gap (skip-orders skp)))
    )
    (let loop ((node (skipnode-next (skip-start skp) 0)))
      (unless (null? node)
        (skip-insert! result (skipnode-item node))
        (loop (skipnode-next node 0))))
    result))

(define (skip-reorder skp . orders)
  (let ((result (apply make-skiplist-with-gap
                    (skip-max-links skp)
                    (skip-gap skp)
                    orders)))
    (let loop ((node (skipnode-next (skip-start skp) 0)))
      (unless (null? node)
        (skip-insert! result (skipnode-item node))
        (loop (skipnode-next node 0))))
    result))

(define (skip-for-each skp proc)
  (let loop ((node (skipnode-next (skip-start skp) 0)))
    (unless (null? node)
      (proc (skipnode-item node))
      (loop (skipnode-next node 0)))))

(define (skip-filter skp ok?)
  (let ((result (apply make-skiplist-with-gap
                       (skip-max-links skp)
                       (skip-gap skp)
                       (skip-orders skp))))
    (let loop ((node (skipnode-next (skip-start skp) 0)))
      (unless (null? node)
        (let ((item (skipnode-item node)))
          (if (ok? item) (skip-insert! result item)))
        (loop (skipnode-next node 0))))
    result))

(define (skip-list skp . ks)
  (let ((k ;(if (null? ks) 0 (car ks))))
           (optional ks 0)))
    (let loop ((node (skipnode-next (skip-start skp) k)) (lst '()))
      (if (null? node)
        (reverse lst)
        (loop (skipnode-next node k) (cons (skipnode-item node) lst))))))

(define (skip-max-links skp)
  (skipnode-links (skip-start skp)))

(define (skip-dups? skp)
  ;; more than one initial comparison operator
  (not (null? (cdr (skip-orders skp)))))

(define (skip-compare skp)
  (let loop ((orders (skip-orders skp)))
    (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))))))))

(define (skip-search! skp item . flags)
  (let ((lazy? (optional flags #t)) (cursor (skip-cursor skp)))
    ; the lazy? argument is set to #f in skip-insert! to cope
    ; with lists which are alreade sorted
    (let down (
      (k (- (skip-links skp) 1))
      ;(node (skip-start skp))
      (node (if (and lazy? (skip-lazy? skp item))
              cursor
              (skip-start skp)))
      )
      (unless (negative? k)
        (let forward ((node node))
          (let ((next (skipnode-next node k)))
            (if (skip-in? skp item next)
              (forward next)
              (begin
                (set! (skipnode-next cursor k) node)
                (down (- k 1) node)))))))))

(define (skip-found? skp item)
  (let ((node (skipnode-next (skip-cursor skp) 0)))
    (and (not (null? node))
         (not (null? (skipnode-next node 0)))
         (zero? ((skip-compare skp) item (skipnode-item (skipnode-next node 0)))))))

(define (skip-lazy? skp item)
  (let ((node (skipnode-next (skip-cursor skp) 0)))
    (and (not (null? node))
         (not (keyword? (skipnode-item node)))
         (positive? ((skip-compare skp) item (skipnode-item node))))))

(define (skip-in? skp item node)
  (and (not (null? node))
       (not (keyword? (skipnode-item node)))
       (> ((skip-compare skp) item (skipnode-item node)) 0)))

(define (skip-insert! skp item)
  (skip-search! skp item #f)
  (unless (and (not (skip-dups? skp)) (skip-found? skp item))
    (let ((newlinks (skip-rand skp)) (links (skip-links skp)))
      (if (> newlinks links)
        (set! (skip-links skp) newlinks))
      (skipnode-insert! (skip-cursor skp)
                        (make-skipnode item (make-vector newlinks '())))
      (set! (skip-count skp) (+ (skip-count skp) 1)))))

(define (skip-remove! skp item)
  (skip-search! skp item)
  (when (skip-found? skp item)
    (skipnode-remove! (skip-cursor skp) (skip-links skp))
    (set! (skip-count skp) (- (skip-count skp) 1))))

(define (skip-remove-all! skp item)
  (skip-search! skp item)
  (let loop ((found (skip-found? skp item)))
    (when found
      (skipnode-remove! (skip-cursor skp) (skip-links skp))
      (set! (skip-count skp) (- (skip-count skp) 1))
      (loop (skip-found? skp item)))))

;;; to skip gap nodes at a time in the 2nd level (link index 1), one
;;; out of every gap nodes must have at least 2 links. Iterating we
;;; want one out of every gap^i nodes to have at least i+1 links.
(define (skip-rand skp)
  (let ((max-links (skip-max-links skp)))
    (if (= max-links 1)
      1 ; normal list, no randomization
      (let* (
        (gap (skip-gap skp))
        (M (expt gap max-links))
        (choice  (+ (random M) 1)) ; 0<=(random M)<M
        )                          ; 1<=choice<=M
        (assert (exact? M) "too many links in skip-rand" max-links)
        (let loop ((links 1) (barrier (quotient M gap)))
          (if (>= choice barrier)
            links
            (loop (+ links 1) (quotient barrier gap))))))))

(define (dups x y)
  0)

) ; module %skiplists

(module skiplists
  (skiplists skiplist? make-skiplist make-skiplist-with-gap skip-compare
             make-skiplist-from-list make-skiplist-with-gap-from-list
             skip-search!  skip-insert! skip-remove! skip-list skip-gap skip-count
             skip-remove-all! skip-found? skip-dups? skip-links skip-max-links dups
             skip-restructure skip-for-each skip-orders skip-reorder
             skip-filter)

(import scheme
  (prefix %skiplists %)
  (only contracts doclist doclist->dispatcher contract define-with-contract)
  (only chicken unless get-output-string open-output-string)
  (only data-structures list-of?))

;; initialize documentation
(doclist '())

;;;; skiplist ADT

(define-with-contract (skiplist? xpr)
  "type predicate"
  (%skiplist? xpr))

(define-with-contract (skip-orders skp)
  "list of numerical comparison operators"
  (domain (%skiplist? skp))
  (range ((list-of? procedure?) result))
  (%skip-orders skp))

(define-with-contract (skip-gap skp)
  "gap of skiplist"
  (domain (%skiplist? skp))
  (range (integer? result) (> result 1))
  (%skip-gap skp))

(define-with-contract (skip-count skp)
  "number of nodes stored in skiplist"
  (domain (%skiplist? skp))
  (range (integer? result) (>= result 0))
  (%skip-count skp))

(define-with-contract (skip-links skp)
  "maximal number of occupied links"
  (domain (%skiplist? skp))
  (range (integer? result) (>= (%skip-max-links skp) result 1))
  (%skip-links skp))

(define-with-contract (make-skiplist max-links . orders)
  "skiplist constructor"
  (domain (integer? max-links) (positive? max-links)
          ((list-of? procedure?) orders)
          (not (null? orders))
          "numerical valued comparison procedures")
  (range (%skiplist? result))
  (apply %make-skiplist-with-gap max-links 2 orders))

(define-with-contract (make-skiplist-with-gap max-links gap . orders)
  "skiplist constructor with gap different from 2"
  (domain (integer? max-links) (positive? max-links)
          (integer? gap) (> gap 1)
          ((list-of? procedure?) orders)
          (not (null? orders))
          "numerical valued comparison procedures")
  (range (%skiplist? result))
  (apply %make-skiplist-with-gap max-links gap orders))
  
(define-with-contract (make-skiplist-from-list lst max-links . orders)
  "construct a skiplist from an ordinary list"
  (domain (list? lst)
          "list items must be comparable by operators in orders"
          (integer? max-links) (positive? max-links)
          ((list-of? procedure?) orders)
          (not (null? orders))
          "numerical valued comparison procedures")
  (range (%skiplist? result))
  (apply %make-skiplist-with-gap-from-list lst max-links 2 orders))

(define-with-contract
  (make-skiplist-with-gap-from-list lst max-links gap . orders)
  "construct a skiplist with gap different from 2 from an ordinary list"
  (domain (list? lst)
          "list items must be comparable by operators in orders"
          (integer? max-links) (positive? max-links)
          (integer? gap) (> gap 1)
          ((list-of? procedure?) orders)
          (not (null? orders))
          "numerical valued comparison procedures")
  (range (%skiplist? result))
  (apply %make-skiplist-with-gap-from-list lst max-links gap orders))

(define-with-contract (skip-restructure skp max-links gap)
  "restructure skiplist by changing max-links and gap"
  (domain (integer? max-links) (positive? max-links)
          (integer? gap) (> gap 1))
  (range (%skiplist? result)
         (= (%skip-max-links result) max-links)
         (= (%skip-gap result) gap))
  (%skip-restructure skp max-links gap))

(define-with-contract (skip-reorder skp . orders)
  "reorder skiplist by changing the order of comparison operators"
  (domain (%skiplist? skp)
          ((list-of? procedure?) orders)
          (set-in? orders (%skip-orders skp))
          (set-in? (%skip-orders skp) orders))
  (range (%skiplist? result)
         (= (%skip-count result) (%skip-count skp)))
  (apply %skip-reorder skp orders))

(define (set-in? lst1 lst2)
  (let loop ((lst lst1))
    (cond
      ((null? lst) #t)
      ((not (memq (car lst) lst2)) #f)
      (else (loop (cdr lst))))))

(define-with-contract (skip-for-each skp proc)
  "apply proc to each item of skiplist"
  (domain (%skiplist? skp)
          (procedure? proc))
  (%skip-for-each skp proc))

(define-with-contract (skip-filter skp ok?)
  "filter a skiplist according to predicate ok?"
  (domain (%skiplist? skp)
          (procedure? ok?)
          "one argument predicate")
  (range (%skiplist? result))
  (%skip-filter skp ok?))

(define-with-contract (skip-list skp . ks)
  "map skiplist to an ordinary list (at link level k, if provided)"
  (domain (%skiplist? skp) ((list-of? (lambda (k)
                                       (and (integer? k)
                                            (>= k 0)
                                            (< k (%skip-max-links skp)))))
                           ks))
  (range (list? result))
  (apply %skip-list skp ks))

(define-with-contract (skip-max-links skp)
  "maximal number of links"
  (domain (%skiplist? skp))
  (range (integer? result) (positive? result))
  (%skip-max-links skp))

(define-with-contract (skip-dups? skp)
  "check if duplicates are allowed"
  (domain (%skiplist? skp))
  (%skip-dups? skp))

(define-with-contract (skip-compare skp)
  "combined numerical comparison procedure"
  (domain (%skiplist? skp))
  (range (procedure? result))
  (%skip-compare skp))

(define-with-contract (skip-search! skp item)
  "move cursor to a place, where one can look for item"
  (domain (%skiplist? skp))
  (effect (count (%skip-count skp) count =)
          (links (%skip-links skp) links =))
  (%skip-search! skp item))
  
(define-with-contract (skip-found? skp item)
  "check, if last skip-search! was successfull"
  (domain (%skiplist? skp))
  (range (boolean? result))
  (%skip-found? skp item))

(define-with-contract (skip-insert! skp . items)
  "insert new nodes with items into skiplist"
  (domain (%skiplist? skp))
  (effect (count (%skip-count skp) (+ count (length items))
                 (if (skip-dups? skp) = >=)))
  (let loop ((items items))
    (unless (null? items)
      (%skip-insert! skp (car items))
      (loop (cdr items)))))

(define-with-contract (skip-remove! skp . items)
  "remove nodes (one per found item) with items from skiplist"
  (domain (%skiplist? skp))
  (effect (count (%skip-count skp) (- count (length items)) <=))
  (let loop ((items items))
    (unless (null? items)
    (%skip-remove! skp (car items))
    (loop (cdr items)))))
  
(define-with-contract (skip-remove-all! skp . items)
  "remove nodes (all per found item) with items from skiplist"
  (domain (%skiplist? skp))
  (effect (count (%skip-count skp) count >=))
  (let loop ((items items))
    (unless (null? items)
    (%skip-remove-all! skp (car items))
    (loop (cdr items)))))
  
(define-with-contract (dups x y)
  "trivial numerical comparison operator to allow for duplicates"
  0)

;; save documentation
(define skiplists (doclist->dispatcher (doclist)))

) ; module skiplists