(use extras)

(format (current-error-port) "Some Test Cases And A Benchmark
 * partition/cps: an implementation taking a continuation to deliver it's result values
 * partition.1:   an implementation of SRFI-1 \"partition\" almost literal from SRFI-1
                  (here to make sure both are compiled with the same flags)
 * partition.2:   an implementation of SRFI-1 \"partition\" using partition/cps
 * partition.2.2: an implementation of SRFI-1 \"partition\" using a slightly modified version
 * partition.1.b: SRFI-1 \"partition\" using an ad-hoc alternative of
                  values/call-with-values in portable Scheme
 * partition.1.c: SRFI-1 \"partition\" using a second ad-hoc alternative of
                  values/call-with-values in portable Scheme
 * partition-iterative: another alternative in procedural style
")

(define (partition/cps return pred lis)
  (let recur ((lis lis) (return return))
    (if (null? lis) (return lis lis)
	(let ((elt (car lis))
	      (tail (cdr lis)))
	  (let ((cont (lambda (in out)
			(if (pred elt)
			    (return (if (pair? out) (cons elt in) lis) out)
			    (return in (if (pair? in) (cons elt out) lis))))))
	    (recur tail cont))))))


(define (partition/cps.2 return pred lis)
  (let recur ((lis lis) (return return))
    (if (null? lis) (return lis lis)
	(recur (cdr lis)
	       (lambda (in out)
		 (let ((elt (car lis)))
		   (if (pred elt)
		       (return (if (pair? out) (cons elt in) lis) out)
		       (return in (if (pair? in) (cons elt out) lis)))))))))

(define (partition.2 pred lst)
  (partition/cps values pred lst))

(define (partition.2.2 pred lst)
  (partition/cps.2 values pred lst))

(define (partition.1 pred lis)
  (let recur ((lis lis))
    (if (null? lis) (values lis lis)
	(let ((elt (car lis))
	      (tail (cdr lis)))
	  (receive (in out) (recur tail)
	    (if (pred elt)
		(values (if (pair? out) (cons elt in) lis) out)
		(values in (if (pair? in) (cons elt out) lis))))))))

(define (adhoc-values . list) (lambda (receiver) (apply receiver list)))
(define (adhoc-call-with-values thunk receiver) ((thunk) receiver))

(define (partition.1.b pred lis)
  (let recur ((lis lis))
    (if (null? lis) (adhoc-values lis lis)
	(let ((elt (car lis))
	      (tail (cdr lis)))
	  (adhoc-call-with-values
	   (lambda () (recur tail))
	   (lambda (in out)
	     (if (pred elt)
		 (adhoc-values (if (pair? out) (cons elt in) lis) out)
		 (adhoc-values in (if (pair? in) (cons elt out) lis)))))))))


(define (adhoc-values.2 . list) (lambda () list))
(define (adhoc-call-with-values.2 thunk receiver) (apply receiver ((thunk))))

(define (partition.1.c pred lis)
  (let recur ((lis lis))
    (if (null? lis) (adhoc-values.2 lis lis)
	(let ((elt (car lis))
	      (tail (cdr lis)))
	  (adhoc-call-with-values.2
	   (lambda () (recur tail))
	   (lambda (in out)
	     (if (pred elt)
		 (adhoc-values.2 (if (pair? out) (cons elt in) lis) out)
		 (adhoc-values.2 in (if (pair? in) (cons elt out) lis)))))))))

;; In constract to the SRFI-1 implementation, this one does not share
;; a common tail.
(define (partition-iterative pred lst)
  (let ((t (cons #f '()))
	(f (cons #f '())))
    (let ((tl t) (fl f))
      (do ((lst lst (cdr lst)))
	  ((null? lst) (values (cdr t) (cdr f)))
	(let ((elt (car lst)))
	  (if (pred elt)
	      (let ((p (cons elt (cdr tl))))
		(set-cdr! tl p)
		(set! tl p))
	      (let ((p (cons elt (cdr fl))))
		(set-cdr! fl p)
		(set! fl p))))))))

(format (current-error-port) "partition/cps values + vector\n~a\n"
 (let ((lst '(1 2 3 4 5)))
   (call-with-values (lambda () (partition/cps values odd? lst)) vector)))

(format (current-error-port) "partition/cps vector\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (partition/cps vector odd? lst)))

(format (current-error-port) "partition/cps.2 vector\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (partition/cps.2 vector odd? lst)))

(format (current-error-port) "partition/cps list\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (partition/cps list odd? lst)))

(format (current-error-port) "partition/cps.2 list\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (partition/cps.2 list odd? lst)))

(format (current-error-port) "\npartition.2 received by vector\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (call-with-values (lambda () (partition.2 odd? lst)) vector)))

(format (current-error-port) "\npartition.2.2 received by vector\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (call-with-values (lambda () (partition.2.2 odd? lst)) vector)))

(format (current-error-port) "\npartition.1 received by vector\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (call-with-values (lambda () (partition.1 odd? lst)) vector)))

(format (current-error-port) "\npartition.1.b received by vector\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (adhoc-call-with-values (lambda () (partition.1.b odd? lst)) vector)))

(format (current-error-port) "\npartition.1.c received by vector\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (adhoc-call-with-values.2 (lambda () (partition.1.c odd? lst)) vector)))

(format (current-error-port) "\npartition-iterative received by vector\n~s\n"
 (let ((lst '(1 2 3 4 5)))
   (call-with-values (lambda () (partition-iterative odd? lst)) vector)))

(define (noita count)
  (let* ((start 0) (step 1) (last-val (+ start (* (- count 1) step))))
    (do ((count count (- count 1))
	 (val last-val (- val step))
	 (ans '() (cons val ans)))
	((<= count 0)  ans))))

(define test-input
  (noita 10000000))

(define test-runs 3)

(format (current-error-port) "Timing partition.1 ~a times\n" test-runs)
(do ((i 0 (+ i 1)))
    ((= i test-runs) #t)
  (time (call-with-values (lambda () (partition.1 odd? test-input)) vector)))

(format (current-error-port) "Timing partition.1.b ~a times\n" test-runs)
(do ((i 0 (+ i 1)))
    ((= i test-runs) #t)
  (time (adhoc-call-with-values (lambda () (partition.1.b odd? test-input)) vector)))

(format (current-error-port) "Timing partition.1.c ~a times\n" test-runs)
(do ((i 0 (+ i 1)))
    ((= i test-runs) #t)
  (time (adhoc-call-with-values.2 (lambda () (partition.1.c odd? test-input)) vector)))

(format (current-error-port) "Timing partition.2 ~a times\n" test-runs)
(do ((i 0 (+ i 1)))
    ((= i test-runs) #t)
  (time (call-with-values (lambda () (partition.2 odd? test-input)) vector)))

(format (current-error-port) "Timing partition.2.2 ~a times\n" test-runs)
(do ((i 0 (+ i 1)))
    ((= i test-runs) #t)
  (time (call-with-values (lambda () (partition.2.2 odd? test-input)) vector)))

(format (current-error-port) "Timing partition-iterative ~a times\n" test-runs)
(do ((i 0 (+ i 1)))
    ((= i test-runs) #t)
  (time (call-with-values (lambda () (partition-iterative odd? test-input)) vector)))

(newline)
(exit 0)