(use foof-loop
     test
     (srfi 1 13 40 45 60))

(define-syntax test-values
  (syntax-rules ()
    ((_ expect expr)
     (test-values #f expect expr))
    ((_ name expect expr)
     (test name
           (receive x expect x)
           (receive x expr x)))))

(define-syntax debug
  (syntax-rules ()
    ((_ x ...)
     (print `((x ,x) ...)))))

(let ((count-matching-items
       (lambda (list predicate)
         (loop ((for item (in-list list))
                (with count 0
                      (if (predicate item)
                          (+ count 1)
                          count)))
               => count))))
  (test "count-matching-items"
        3
        (count-matching-items '(1 2 3 a b c) number?)))

(let ((find-matching-item
       (lambda (list if-absent predicate)
         (loop continue ((for item (in-list list)))
               => (if-absent)
               (if (predicate item)
                   item
                   (continue))))))
  (test "find-matching-item"
        #f
        (find-matching-item '(a b c) (lambda () #f) number?)))

(let ((map
       (lambda (procedure list)
         (loop recur ((for element (in-list list)))
               => '()
               (cons (procedure element) (recur))))))

  (test "map"
        '(1 4 27 256 3125)
        (map (lambda (n) (expt n n)) '(1 2 3 4 5))))

(let ((write-list-newline
       (lambda (list)
         (loop ((for element (in-list list)))
               (write element)
               (newline)))))
  (test "write-list-newline"
        "1\n2\n3\n"
        (with-output-to-string (lambda () (write-list-newline '(1 2 3))))))

(let ((partition
       (lambda (predicate list)
         (loop continue ((for element (in-list list))
                         (with satisfied '())
                         (with unsatisfied '()))
               => (values (reverse satisfied)
                          (reverse unsatisfied))
               (if (predicate element)
                   (continue (=> satisfied (cons element satisfied)))
                   (continue (=> unsatisfied (cons element unsatisfied))))))))

(test-values "partition"
             (values '(one four five) '(2 3 6))
             (partition symbol? '(one 2 3 four five 6))))

(let ((reverse!
       (lambda (list)
         (loop ((for element pair (in-list list))
                (with tail '() pair))
               => tail
               (set-cdr! pair tail)))))
  (test "reverse!"
        '((e (f)) d (b c) a)
        (reverse! '(a (b c) d (e (f))))))

(let ((reverse-map!
       (lambda (procedure list)
         (loop ((for element pair (in-list list))
                (with tail '() pair))
               => tail
               (set-car! pair (procedure element))
               (set-cdr! pair tail)))))
  (test "reverse-map!"
        '(3125 256 27 4 1)
        (reverse-map! (lambda (n) (expt n n)) '(1 2 3 4 5))))

(let ((flatten-begins
       (lambda (list)
         (loop continue ((for element pair (in-list list))
                         (with subforms '()))
               => (reverse subforms)
               (if (and (pair? element)
                        (eq? 'begin (car element)))
                   (continue (=> pair (append (cdr element) (cdr pair))))
                   (continue (=> subforms (cons element subforms))))))))
  (test "flatten-begins"
        '(begin (1 2 3) (a b c) (i ii iii))
        (flatten-begins '(begin (1 2 3)
                                (begin (a b c)
                                       (begin (i ii iii)))))))


;;; locally defective srfi-27; not tested
#;
(let ((shuffle-vector!
       (lambda (vector)
         (loop ((for element i (in-vector vector)))
               (let ((j (random-integer (+ i 1))))
                 (vector-set! vector i (vector-ref vector j))
                 (vector-set! vector j element)))))
      (vector (vector 1 2 3)))
  (test "shuffle-vector!"
        #f
        (shuffle-vector! vector)))

(let ((list-tabulate
       (lambda (length procedure)
         (loop ((for index (up-from 0 (to length)))
                (with list '() (cons (procedure index) list)))
               => (reverse list)))))
  (test "list-tabulate"
        '(0 1 2 3)
        (list-tabulate 4 values)))

(let ((even-integers
       (lambda (N)
         (loop ((for integer (up-from 0 (to N) (by 2)))
                (with evens '() (cons integer evens)))
               => (reverse evens)))))
  (test "even-integers to N"
        '(0 2 4 6 8)
        (even-integers 10)))

(let ((unsafe-length
       (lambda (list)
         (loop ((for element (in-list list))
                (for length (up-from 0)))
               => length))))
  (test "unsafe-length"
        3
        (unsafe-length '(1 2 3))))

(let ((map
       (lambda (procedure list)
         (loop ((for element (in-list list))
                (for result (listing (procedure element))))
               => result))))
  (test "map-with-listing"
        '(1 4 27 256 3125)
        (map (lambda (n) (expt n n)) '(1 2 3 4 5))))

(let ((filter
       (lambda (predicate list)
         (loop ((for element (in-list list))
                (for result
                     (listing element
                              (if (predicate element)))))
               => result))))
  (test "filter"
        '(0 8 8 -4)
        (filter even? '(0 7 8 8 43 -4))))

(let ((filter-map
       (lambda (procedure list)
         (loop ((for element (in-list list))
                (for result
                     (listing (procedure list) => (lambda (x) x))))
               => result))))
  (test "filter-map"
        '(1 9 49)
        (filter-map (lambda (x)
                      (and (number? x)
                           (* x x)))
                    '(a 1 b 3 c 7))))

(test "listing-into!"
      '(initial 0 4 16 36 64)
      (let ((x (cons 'initial '())))
        (loop ((for i (up-from 0 (to 10)))
               (for result (listing-into! x (* i i) (if (even? i))))))
        x))

(let ((read-non-empty-lines
       (lambda (input-port)
         (loop ((for line (in-port input-port read-line))
                (until (string-null? line))
                (for lines (listing line)))
               => lines))))
  (test "read-non-empty-lines"
        '("1" "2" "3")
        (with-input-from-file "read.txt"
          (lambda () (read-non-empty-lines (current-input-port))))))

(test "loop name"
      "(0 () i (i j k p q r))\n(1 (0) k (k p q r))\n(2 (1 0) q (q r))\n"
      (with-output-to-string
        (lambda ()
          (loop continue ((with a 0)
                          (with b '()
                                (cons a b))
                          (for c d (in-list '(i j k p q r))))
                (write (list a b c d))
                (newline)
                (continue (+ a 1)
                          (=> d (cddr d)))))))

(test "alternate `with' like named-let"
      "0123456789"
      (with-output-to-string
        (lambda ()
          (loop next ((x 0))
                (if (< x 10)
                    (begin (write x) (next (+ x 1))))))))

(test "alternate `with' like `do'"
      "0123456789"
      (with-output-to-string
        (lambda ()
          (loop ((x 0 (+ x 1))
                 (until (>= x 10)))
                (write x)))))

;;; appears to require srfi-40 (not srfi-41, "streams")
#;
(test
 "lazy-loop"
 (stream 1 3 5)
 (let ((stream-filter
        (lambda (predicate stream)
          (lazy-loop filter ((for element (in-stream stream)))
                     => stream-nil
                     (if (predicate element)
                         (stream-cons element (filter))
                         (filter))))))
   (stream-filter odd? (stream 0 1 2 3 4 5))))

#;
 (test
 "lazy-loop"
 (stream 1 3 5)
 (let ((stream-filter
        (lambda (predicate stream)
          (lazy (loop filter ((for element (in-stream stream)))
                      => stream-nil
                      (if (predicate element)
                          (stream-cons element (lazy (filter)))
                          (lazy (filter))))))))
   (stream-filter odd? (stream 0 1 2 3 4 5))))

(test "pairs of lists"
      "(a a)\n(b b)\n(c c)\n"
      (with-output-to-string
        (lambda ()
          (loop ((for a (in-list '(a b c)))
                 (for b (in-list '(p q r))))
                (write (list a b))
                (newline)))))

(test "list plus iterator"
      12
      (loop ((for x (in-list '(1 2 3)))
             (with y 0 (+ y (* x 2))))
            => y))

(let ((pair-fold
       (lambda (kons knil list)
         (loop ((for elt pair (in-list list))
                (with knil knil (kons pair knil)))
               => knil))))
  (test "pair-fold"
        '(3 2 1)
        (pair-fold (lambda (pair tail)
                      (set-cdr! pair tail)
                       pair)
                    '()
                     (list 1 2 3))))

(test "transpose-matrix"
      '((c f) (b e) (a d))
      (loop ((for columns (in-lists '((a b c) (d e f))))
             (with rows '() (cons columns rows)))
            => rows))

(let ((every?
       (lambda (predicate list . lists)
         (loop proceed ((for elts (in-lists (cons list lists))))
               (and (apply predicate elts)
                    (proceed))))))
  (test "every?"
        #f
        (every? odd? '(1 2 3))))

(let ((any
       (lambda (predicate list . lists)
         (loop proceed ((for elts (in-lists (cons list lists))))
               (or (apply predicate elts)
                   (proceed))))))
  (test-assert "any-integer?"
               (any integer? '(a 3 b 2.7)))
  (test-assert "any-<"
               (any < '(3 1 4 1 5)
                    '(2 7 1 8 2))))

(let ((fold
       (lambda (kons knil list . lists)
         (loop ((with knil knil (apply kons arguments))
                (for arguments 
                     (in-lists (cons list lists)
                               (cons knil '()))))
               => knil))))
  (test "fold"
        3
        (fold + 0 '(0 1 2))))

(test "pairs of vectors"
      "(foo 0 #\\f 5)\n(bar 1 #\\e 4)\n(baz 2 #\\d 3)\n"
      (with-output-to-string
        (lambda ()
          (loop ((for a i (in-vector '#(foo bar baz)))
                 (for b j (in-string-reverse "abcdefghi" 6 3)))
                => (list i j)
                (write (list a i b j))
                (newline))))) 

(let ((vector-index
       (lambda (vector predicate)
         (loop proceed ((for elt index (in-vector vector)))
               (if (predicate elt)
                   index
                   (proceed))))))
  (test "vector-index"
        2
        (vector-index '#(3 1 4 1 5 9) even?)))

(let ((string-copy!
       (lambda (target tstart source sstart send)
         (loop ((for char (in-string source sstart send))
                (with index tstart (+ index 1)))
               (string-set! target index char)))))
  (test "string-copy!"
        "eta subst"
        (string-copy "Beta substitution" 1 10)))

(test "sample squared-plus-ones from vector"
      "(a 0)\n(b 1)\n(d 3)\n(h 7)\n(p 15)\n"
      (with-output-to-string
        (lambda ()
          (loop proceed 
                ((for v i
                      (in-vector
                       '#(a b c d e f g h i j k l m n o p q r s t u v w x y z))))
                (write (list v i))
                (newline)
                (proceed (=> i (+ 1 (* i 2))))))))

(let ((read-line
       (lambda (input-port)
         (let ((initial (peek-char input-port)))
           (if (eof-object? initial)
               initial
               (loop ((for char (in-port input-port))
                      (until (char=? char #\newline))
                      (with chars '() (cons char chars)))
                     => (list->string (reverse chars))))))))
  (test "read-line"
        "1"
        (with-input-from-file "read.txt"
          (lambda () (read-line (current-input-port))))))

(let ((read-all
       (lambda (input-port)
         (loop ((for datum (in-port input-port read))
                (with data '() (cons datum data)))
               => (reverse data)))))
  (test "read-all"
        '(1 2 3 4 5)
        (with-input-from-file "read.txt"
          (lambda () (read-all (current-input-port))))))

(let ((read-lines-from-file
       (lambda (pathname)
         (loop ((for line (in-file pathname read-line))
                (with lines '() (cons line lines)))
               => (reverse lines)))))
  (test "read-lines-from-file"
        '("1" "2" "3" "" "4" "5")
        (read-lines-from-file "read.txt")))

(let ((iota
       (lambda (count start step)
         (loop ((for n (up-from 0 (to count)))
                (for result (listing (+ start (* n step)))))
               => result))))
  (test "iota"
        '(0 1 2 3 4)
        (iota 5 0 1)))

(let ((sieve
       (lambda (n)
         (let ((table (list->integer (make-list (- n 2) #t))))
           (define (prime? k) (bit-set? (- k 2) table))
           (define (not-prime! k) (set! table (copy-bit (- k 2) table #f)))
           (define (purge-multiples i)
             (loop ((for j (up-from (* i i)
                                    (to n)
                                    (by i))))
                   (not-prime! j)))
           (loop proceed ((for i (up-from 2 (to n)))
                          (with primes '()))
                 => (reverse primes)
                 (if (prime? i)
                     (begin (purge-multiples i)
                            (proceed (=> primes (cons i primes))))
                     (proceed)))))))
  (test "sieve"
        #f
        (sieve 5)))

(let ((vector-quick-sort!
       (lambda (elt< vector start end)
         (loop sort ((start start) (end end))
               (if (< 1 (- end start))
                   (let ((pivot (select-pivot vector start end)))
                     (loop continue ((i start) (j end))
                           (let ((i (loop scan ((for i (up-from i)))
                                          (if (elt< (vector-ref vector i) pivot)
                                              (scan)
                                              i)))
                                 (j (loop scan ((for j (down-from j)))
                                          (if (elt< pivot (vector-ref vector j))
                                              (scan)
                                              j))))
                             (if (< i j)
                                 (begin (vector-exchange! vector i j)
                                        (continue (+ i 1) j))
                                 (begin (sort (=> end i))
                                        (sort (=> start (+ j 1)))))))))))))
  (test "vector-quick-sort!"
        '#(1 2 3)
        (vector-quick-sort! < (vector 3 2 1) 0 2)))

(let ((list-tabulate
       (lambda (length procedure)
         (loop ((for i (up-from 0 (to length)))
                (for list (listing (procedure i))))
               => list))))
  (test "list-tabulate with appending"
        '(0 1 2 3)
        (list-tabulate 4 values)))

(let ((take
       (lambda (list count)
         (loop ((for i (up-from 0 (to count)))
                (for elt (in-list list))
                (for prefix (listing elt)))
               => prefix))))
  (test "take"
        '(a b)
        (take '(a b c d e) 2)))

(let ((append-reverse
       (lambda (list tail)
         (loop ((for elt (in-list list))
                (for result (listing-reverse (initial tail) list)))
               => result))))
  (test "append-reverse"
        '((x) y)
        (append-reverse '(x) '(y))))

(let ((unzip5
       (lambda (list)
         (loop ((for component (in-list list))
                (for result1 (listing (first component)))
                (for result2 (listing (second component)))
                (for result3 (listing (third component)))
                (for result4 (listing (fourth component)))
                (for result5 (listing (fifth component))))
               => (values result1 result2 result3 result4 result5)))))
  (test-values "unzip5"
               (values '(1 2 3 4 5)
                       '(one two three four five))
               (unzip5 '((1 one) (2 two) (3 three) (4 four) (5 five)))))

(let ((concatenate
       (lambda (lists)
         (loop ((for list (in-list lists))
                (for result (appending list)))
               => list))))
  (test "concatenate"
        '(1 2 3 4)
        (concatenate '((1 2) (3 4)))))

(let ((count
       (lambda (predicate list)
         (loop ((for elt (in-list list))
                (for count (summing 1 (if (predicate elt)))))
               => count))))
  (test "count"
        3
        (count even? '(3 1 4 1 5 9 2 5 6))))