;This is a functional interface to Oleg Kiselyov's treap data-structure,
;packaged by Ivan Raikov as a Chicken egg. It's meant as an exercise for
;using methods as implemented in my own multi-methods library. But for
;copyright reasons, I'll implement a simplified version of the method
;macro here again, which only checks preconditions.
;
(require-library lolevel treap)

(module treaps
  (treaps
    make-treap treap? treap-empty? treap-key? treap-value?
    treap-get treap-get-min treap-delete-min! treap-get-max
    treap-delete-max! treap-size treap-depth treap-clear!
    treap-put! treap-delete!  treap-for-each-ascending
    treap-for-each-descending treap-debugprint treap-compare)

(import scheme
        ;(only chicken condition-case receive define-record-type
        ;      define-record-printer error)
        chicken
        (only lolevel extend-procedure procedure-data)
        (only data-structures conjoin list-of?)
        (prefix treap %))

;;; (method [variadic?] (proc-name proc) (name pred . preds) ...)
;;; -------------------------------------------------------------
;;; proc is the actual procedure which is ultimately called, proc-name
;;; its name (a symbol), name a symbol describing the predicate (conjoin
;;; pred . preds) which do the argument checks.
(define-syntax method
  (syntax-rules ()
    ((_ (proc-name proc)
        (pred-name pred . preds)
        ...)
     (method #f
             (proc-name proc)
             (pred-name pred . preds)
             ...))
    ((_ var?
        (proc-name proc)
        (pred-name pred . preds)
        ...)
     (let ((proc-list
             (list (extend-procedure proc proc-name)
                   (extend-procedure (conjoin pred . preds) pred-name)
                   ...)))
       (lambda  args
         (apply method-check-args-and-call proc-list var? args))))))

(define (method-check-args-and-call proc-list variadic? . args)
  (let ((proc (car proc-list))
        (preds (cdr proc-list))
        (split (lambda (lst n)
                 (let loop ((tail lst) (head '()) (n n))
                   (if (or (null? tail) (zero? n))
                     (values tail (reverse head))
                     (loop (cdr tail) (cons (car tail) head) (- n 1)))))))
    (if (null? preds)
      ;; thunk
      (apply proc args)
      (receive (tail-args head-args) (split args (- (length preds) 1))
        (let loop ((head-args head-args) (preds preds))
          (cond
            ((null? head-args)
             (cond
               ((and variadic? ((car preds) tail-args))
                (apply proc args))
               (((car preds) (car tail-args))
                (apply proc args))
               (else
                 (error (procedure-data proc)
                        "precondition violated"
                        (procedure-data (car preds))
                        (if variadic? tail-args (car tail-args))))))
            (((car preds) (car head-args)) 
             (loop (cdr head-args) (cdr preds)))
            (else
              (error (procedure-data proc)
                     "precondition violated"
                     (procedure-data (car preds))
                     (car head-args)))))))))

;; internal
(define-record-type treap
  (create-treap state compare value?)
  treap?
  (state treap-state)
  (compare treap-compare)
  (value? treap-value?))

(define-record-printer (treap trp out)
  (display "#,(treap compare: " out)
  (display (treap-compare trp) out)
  (display " value-type: " out)
  (display (treap-value? trp) out)
  (display " size: " out)
  (display (treap-size trp) out)
  (display " min: " out)
  (write (treap-get-min trp) out)
  (display " max: " out)
  (write (treap-get-max trp) out)
  (display ")" out)
  (newline out))

(define (any? xpr) #t)

(define (at-most-singleton? xpr)
  (and (list? xpr)
       (or (null? xpr) (null? (cdr xpr)))))

(define (treap-of-positive-size? xpr)
 (and (treap? xpr) (positive? (treap-size xpr))))

;; constructor
(define make-treap
  (method ('make-treap
           (lambda (compare value?)
             (create-treap (%make-treap compare) compare value?)))
          ('procedure?compare procedure?)
          ('procedure?value? procedure?)))

(define treap-empty?
  (method ('treap-empty?
           (lambda (trp) ((treap-state trp) 'empty?)))
          ('treap?trp treap?)))

(define treap-key?
  (method ('treap-key?
           (lambda (trp)
             (lambda (xpr)
               (condition-case (integer? ((treap-compare trp) xpr xpr))
                 ((exn arity) #f)
                 ((exn type) #f)))))
          ('treap?trp treap?)))

(define treap-size
  (method ('treap-size
           (lambda (trp) ((treap-state trp) 'size)))
          ('treap?trp treap?)))

(define treap-put!
  (method ('treap-put!
           (lambda (trp key val)
             (((treap-state trp) 'put!) key val)))
          ('treap?trp treap?)
          ('treap-key?key
           (lambda (xpr)
             (lambda (trp) ((treap-key? trp) xpr))))
          ('treap-value?val
           (lambda (xpr)
             (lambda (trp) ((treap-value?  trp) xpr))))))

(define treap-get
  (method #t
          ('treap-get
           (lambda (trp key . default)
             (apply ((treap-state trp) 'get) key default)))
          ('treap?trp treap?)
          ('treap-key?key
           (lambda (xpr)
             (lambda (trp) ((treap-key? trp) xpr))))
          ('null-or-singleton-of-any?default
           (conjoin at-most-singleton?  (list-of?  any?)))))

(define treap-get-min
  (method ('treap-get-min
           (lambda (trp)
             ((treap-state trp) 'get-min)))
          ('treap-of-positive-size?trp
           treap-of-positive-size?)))

(define treap-get-max
  (method ('treap-get-min
           (lambda (trp)
             ((treap-state trp) 'get-max)))
          ('treap-of-positive-size?trp
           treap-of-positive-size?)))

(define treap-delete-min!
  (method ('treap-delete-min!
           (lambda (trp)
             ((treap-state trp) 'delete-min!)))
          ('treap-of-positive-size?trp
           treap-of-positive-size?)))

(define treap-delete-max!
  (method ('treap-delete-max!
           (lambda (trp)
             ((treap-state trp) 'delete-max!)))
          ('treap-of-positive-size?trp
           treap-of-positive-size?)))

(define treap-depth
  (method ('treap-depth
           (lambda (trp)
             ((treap-state trp) 'depth)))
          ('treap?trp treap?)))

(define treap-clear!
  (method ('treap-clear!
           (lambda (trp)
             ((treap-state trp) 'clear!)))
          ('treap?trp treap?)))

(define treap-delete!
  (method #t
          ('treap-delete!
           (lambda (trp key . default)
             (apply ((treap-state trp) 'delete!) key default)))
          ('treap-of-positive-size?trp
           treap-of-positive-size?)
          ('treap-key?key
           (lambda (xpr)
             (lambda (trp) ((treap-key? trp) xpr))))
          ('null-or-singleton-of-any?default
           (conjoin at-most-singleton?  (list-of?  any?)))))

(define treap-for-each-ascending
  (method ('treap-for-each-ascending
           (lambda (trp proc)
             (((treap-state trp) 'for-each-ascending) proc)))
          ('treap?trp treap?)
          ('procedure?proc procedure?)))

(define treap-for-each-descending
  (method ('treap-for-each-descending
           (lambda (trp proc)
             (((treap-state trp) 'for-each-descending) proc)))
          ('treap?trp treap?)
          ('procedure?proc procedure?)))

(define treap-debugprint
  (method ('treap-debugprint
           (lambda (trp)
             ((treap-state trp) 'debugprint)))
          ('treap?trp treap?)))

(define (treaps . args)
  (let ((lst '(make-treap treap? treap-empty? treap-key? treap-value? treap-compare
                          treap-get treap-get-min treap-delete-min! treap-get-max
                          treap-delete-max! treap-size treap-depth treap-clear!
                          treap-put! treap-delete!  treap-for-each-ascending
                          treap-for-each-descending treap-debugprint)))
    (if (null? args)
      lst
      (case (car args)
        ((make-treap)
         '(procedure? (result)
            ((_ compare value?)
             (and (procedure? compare) (procedure? value?))
             (and (treap? result)
"constructor: creates an empty treap, comparing keys with compare and values of type value?"))))
        ((treap?)
         '(procedure (result)
            ((_ xpr)
             #t
             (boolean? result))))
        ((treap-empty?)
         '(procedure (result)
            ((_ trp)
             (treap? trp)
             (boolean? result))))
        ((treap-key?)
         '(procedure (result)
            ((_ trp)
             (treap? trp)
             (and (procedure? result)
                  "predicate checking if its argument is a valid key"))))
        ((treap-value?)
         '(procedure (result)
            ((_ trp)
             (treap? trp)
             (and (procedure? result)
                  "predicate checking if its argument is a valid value"))))
        ((treap-compare)
         '(procedure (result)
            ((_ trp)
             (treap? trp)
             (and (procedure? result)
                  "comparison operator as used in the constuctor"))))
        ((treap-get)
         '(procedure (result)
            ((_ trp key [default])
             (and (treap? trp) ((treap-key? trp) key) (any? default))
             "key-value pair if found, else default")))
        ((treap-get-min)
         '(procedure (result)
            ((_ trp)
             (treap-of-positive-size? trp)
             "key-value pair with minimal key")))
        ((treap-get-max)
         '(procedure (result)
            ((_ trp)
             (treap-of-positive-size? trp)
             "key-value pair with maximal key")))
        ((treap-delete-min!)
         '(procedure (result)
            ((_ trp)
             (treap-of-positive-size? trp)
"delete key-value pair with minimal size, returning the deleted pair")))
        ((treap-delete-max!)
         '(procedure (result)
            ((_ trp)
             (treap-of-positive-size? trp)
"delete key-value pair with maximal size, returning the deleted pair")))
        ((treap-size)
         '(procedure (result)
            ((_ trp)
             (treap? trp)
             "returns the number of key-value pairs")))
        ((treap-depth)
         '(procedure (result)
            ((_ trp)
             (treap? trp)
"returns the depth of the treap traversing it completely")))
        ((treap-clear!)
         '(procedure (result)
            ((_ trp)
             (treap? trp)
             "makes the treap empty removing all key-value pairs")))
        ((treap-put!)
         '(procedure (result)
            ((_ trp key val)
             (and (treap? trp)
                  ((treap-key? trp) key)
                  ((treap-value? trp) val))
"inserts a new key-value pair returning #f or updates the value of an existing key returning the old pair")))
        ((treap-delete!)
         '(procedure (result)
            ((_ trp key [default])
             (and (treap? trp) ((treap-key? trp) key) (any? default))
"removes the key-value pair corresponding to key or evaluates default")))
        ((treap-for-each-ascending)
         '(procedure (result)
            ((_ trp proc)
             (and (treap? trp) (procedure? proc))
"applies proc to each key-value pair traversing trp in ascending order")))
        ((treap-for-each-descending)
         '(procedure (result)
            ((_ trp proc)
             (and (treap? trp) (procedure? proc))
"applies proc to each key-value pair traversing trp in descending order")))
        ((treap-debugprint)
         '(procedure (result)
            ((_ trp)
             (treap? trp)
             "prints whole treap with debug information")))
        (else lst)))))

) ;module treaps