;
; Verifying the treaps package
;
; Modified for Chicken Scheme and the test package by Ivan Raikov


(require-library srfi-1 srfi-13 treap test)
(import srfi-1 srfi-13 treap test)


(define (++ x) (fx+ 1 x))
(define (-- x) (fx- x 1))

(define min-key -1) 
(define max-key 10)

(define a-key (quotient (+ min-key max-key) 2))
	   
(define treap (make-treap (lambda (x y) (- x y))))
	   
(define ;; a hard-wired association between a key and a value"
  compute-assoc (lambda (key) (cons key (++ key))))
	   

(test-group "--> Sorting of a set of numbers via a treap"
	   
    (test-assert (treap 'empty?) )
    (test-assert (zero? (treap 'size)))
    (test-assert (zero? (treap 'depth)))
	   
    (do ((i min-key (++ i))) ((> i max-key))
      (test-assert (not ((treap 'put!) i (cdr (compute-assoc i))) )))
	   
    (print "treap depth: " (treap 'depth))
    (treap 'debugprint)
	   
    (test (++ (- max-key min-key)) (treap 'size) )
    (test-assert (not (treap 'empty?)))

    (test  (compute-assoc min-key) (treap 'get-min) )
    (test  (compute-assoc max-key) (treap 'get-max) )
    (test  ((treap 'get) min-key)  (treap 'get-min) )
    (test  ((treap 'get) max-key)  (treap 'get-max) )
	   
    (test (compute-assoc (++ min-key)) ((treap 'get) (++ min-key)) )
    (test (compute-assoc (++ min-key)) ((treap 'get) (++ min-key) #f) )
	   
    (test-assert (not ((treap 'get) (-- min-key) #f)))
	   
    (treap 'clear!)
	   
    (test-assert (treap 'empty?) )
    (test-assert (zero? (treap 'size)) )
    (test-assert (zero? (treap 'depth)) )
	   
    (do ((i max-key (-- i))) ((< i min-key))
      (test-assert (not ((treap 'put!) i (cdr (compute-assoc i))))))

    (print "treap depth: " (treap 'depth))
    (treap 'debugprint)

    (test (compute-assoc min-key) (treap 'get-min) )
    (test (compute-assoc min-key) (treap 'delete-min!) )
    (test-assert (not ((treap 'get) min-key #f)) )
    (test  (compute-assoc (++ min-key)) (treap 'get-min) )

    (test (compute-assoc max-key) (treap 'get-max) )
    (test (compute-assoc max-key) (treap 'delete-max!) )

    (test-assert (not ((treap 'get) max-key #f)) )
    (test (treap 'get-max) ((treap 'get) (-- max-key)) )
    (test (treap 'size)  (+ -2 (++ (- max-key min-key))))
	   
    (do ((i (++ min-key) (++ i))) ((> i (-- max-key)))
      (test  (compute-assoc i) ((treap 'get) i #f))
      (test  (compute-assoc i) (treap 'delete-min!) )
      (test-assert (not ((treap 'get) i #f) )))
	   
    (test-assert (treap 'empty?))
    (test-assert (zero? (treap 'size)) )
    (test-assert (zero? (treap 'depth)) )
	   
    
    (do ((i min-key) (j max-key) (direction #t (not direction)))
	((< j i))
      (cond
       (direction
	(test-assert (not ((treap 'put!) i (cdr (compute-assoc i)))))
	(set! i (++ i)))
       (else
	(test-assert (not ((treap 'put!) j (cdr (compute-assoc j)))))
	(set! j (-- j)))))
	   

    (let* ((old-assoc (compute-assoc a-key))
	   (new-assoc (cons a-key #\a)))
       (test old-assoc ((treap 'get) a-key) )
       (test old-assoc ((treap 'put!) a-key (cdr new-assoc)) )
       (test new-assoc ((treap 'get) a-key) )
       (test new-assoc ((treap 'delete!) a-key) )
       (test-assert (not ((treap 'delete!) a-key #f) ))
       (test-assert (not ((treap 'put!) a-key (cdr old-assoc)) ))
       (test old-assoc ((treap 'put!) a-key (cdr old-assoc)) )
       (test old-assoc ((treap 'get) a-key) ))
			
    (test (treap 'size) (++ (- max-key min-key)))

    (print "treap depth: " (treap 'depth))

    (test-assert (not (treap 'empty?)))

    (let ((expected-key min-key))
      ((treap 'for-each-ascending)
       (lambda (association)
	 (test association (compute-assoc expected-key))
	 (set! expected-key (++ expected-key))))
      (test expected-key (++ max-key) ))

    (let ((expected-key max-key))
      ((treap 'for-each-descending)
       (lambda (association)
	 (test association (compute-assoc expected-key))
	 (set! expected-key (-- expected-key))))
      (test expected-key (-- min-key)  )))