;;;============================================================================

;;; File: "test.scm"

;;; Copyright (c) 2021 by Marc Feeley, All Rights Reserved.

;;;============================================================================

;;; SRFI 1, List Library

(import (srfi 1))
(import (_test))

;;;============================================================================

;; The rest of this file is the file 1.scm found at
;;
;; https://github.com/srfi-explorations/srfi-test

;;;============================================================================

;; Copyright 1998, 1999 Olin Shivers
;; Copyright 2012, 2014, 2015 Alex Shinn
;; SPDX-License-Identifier: MIT

(test-begin "srfi-1")

;; srfi-1 examples
;; http://srfi.schemers.org/srfi-1/srfi-1.html
(test-equal '(a) (cons 'a '()))
(test-equal '((a) b c d) (cons '(a) '(b c d)))
(test-equal '("a" b c) (cons "a" '(b c)))
(test-equal '(a . 3) (cons 'a 3))
(test-equal '((a b) . c) (cons '(a b) 'c))
(test-equal '(a 7 c) (list 'a (+ 3 4) 'c))
(test-equal '() (list))
(test-equal '(a b c) (xcons '(b c) 'a))
(test-equal '(1 2 3 . 4) (cons* 1 2 3 4))
(test-equal 1 (cons* 1))
(test-equal '(c c c c) (make-list 4 'c))
(test-equal '(0 1 2 3) (list-tabulate 4 values))
(test-equal '(z q z q z q) (take (circular-list 'z 'q) 6))
(test-equal '(0 1 2 3 4) (iota 5))
;;(test '(0 -0.1 -0.2 -0.3 -0.4)
;;    (let ((res (iota 5 0 -0.1)))
;;      (cons (inexact->exact (car res)) (cdr res))))
(test-equal #t (pair? '(a . b)))
(test-equal #t (pair? '(a b c)))
(test-equal #f (pair? '()))
(test-equal #f (pair? '#(a b)))
(test-equal #f (pair? 7))
(test-equal #f (pair? 'a))
(test-equal #t (list= eq?))
(test-equal #t (list= eq? '(a)))
(test-equal #f (list= = '(1 2) '(1 2 3)))
(test-equal #f (list= = '(1 2 3) '(1 2)))
(test-equal 'a (car '(a b c)))
(test-equal '(b c)   (cdr '(a b c)))
(test-equal '(a) (car '((a) b c d)))
(test-equal '(b c d) (cdr '((a) b c d)))
(test-equal '1 (car '(1 . 2)))
(test-equal '2 (cdr '(1 . 2)))
(test-error (car '()))
(test-error (cdr '()))
(test-equal 1 (first '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 2 (second '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 3 (third '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 4 (fourth '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 5 (fifth '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 6 (sixth '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 7 (seventh '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 8 (eighth '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 9 (ninth '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 10 (tenth '(1 2 3 4 5 6 7 8 9 10)))
(test-equal 'c (list-ref '(a b c d) 2))
(test-equal 'c (third '(a b c d e)))
(test-equal '(a b) (take '(a b c d e)  2))
(test-equal '(c d e) (drop '(a b c d e)  2))
(test-equal '(1 2) (take '(1 2 3 . d) 2))
(test-equal '(3 . d) (drop '(1 2 3 . d) 2))
(test-equal '(1 2 3) (take '(1 2 3 . d) 3))
(test-equal 'd (drop '(1 2 3 . d) 3))
(test-equal '(d e) (take-right '(a b c d e) 2))
(test-equal '(a b c) (drop-right '(a b c d e) 2))
(test-equal '(2 3 . d) (take-right '(1 2 3 . d) 2))
(test-equal '(1) (drop-right '(1 2 3 . d) 2))
(test-equal 'd (take-right '(1 2 3 . d) 0))
(test-equal '(1 2 3) (drop-right '(1 2 3 . d) 0))
(test-assert (member (take! (circular-list 1 3 5) 8)
                     '((1 3) (1 3 5 1 3 5 1 3)) equal?))
(test-equal (list '(a b c) '(d e f g h))
  (call-with-values (lambda () (split-at '(a b c d e f g h) 3))
    list))
(test-equal 'c (last '(a b c)))
(test-equal '(c) (last-pair '(a b c)))
(test-equal '(x y) (append '(x) '(y)))
(test-equal '(a b c d) (append '(a) '(b c d)))
(test-equal '(a (b) (c)) (append '(a (b)) '((c))))
(test-equal '(a b c . d) (append '(a b) '(c . d)))
(test-equal 'a (append '() 'a))
(test-equal '(x y) (append '(x y)))
(test-equal '() (append))
(test-equal '(c b a) (reverse '(a b c)))
(test-equal '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
(test-equal '((one 1 odd) (two 2 even) (three 3 odd))
  (zip '(one two three)
       '(1 2 3)
       '(odd even odd even odd even odd even)))
(test-equal '((1) (2) (3)) (zip '(1 2 3)))
(test-equal '((3 #f) (1 #t) (4 #f) (1 #t))
  (zip '(3 1 4 1) (circular-list #f #t)))
(test-equal (list '(1 2 3) '(one two three))
  (call-with-values (lambda () (unzip2 '((1 one) (2 two) (3 three))))
    list))
(test-equal 3 (count even? '(3 1 4 1 5 9 2 5 6)))
(test-equal 3 (count < '(1 2 4 8) '(2 4 6 8 10 12 14 16)))
(test-equal 2 (count < '(3 1 4 1) (circular-list 1 10)))
(test-equal '(c 3 b 2 a 1) (fold cons* '() '(a b c) '(1 2 3 4 5)))
(test-equal '(a 1 b 2 c 3) (fold-right cons* '() '(a b c) '(1 2 3 4 5)))
(test-equal '((a b c) (b c) (c)) (pair-fold-right cons '() '(a b c)))
(test-equal '((a b c) (1 2 3) (b c) (2 3) (c) (3))
  (pair-fold-right cons* '() '(a b c) '(1 2 3)))
(test-equal '(b e h) (map cadr '((a b) (d e) (g h))))
(test-equal '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
(test-equal '(5 7 9) (map + '(1 2 3) '(4 5 6)))
(test-assert (member (let ((count 0))
                       (map (lambda (ignored) (set! count (+ count 1)) count)
                            '(a b))) '((1 2) (2 1)) equal?))
(test-equal '(4 1 5 1) (map + '(3 1 4 1) (circular-list 1 0)))
(test-equal '#(0 1 4 9 16)
  (let ((v (make-vector 5)))
    (for-each (lambda (i) (vector-set! v i (* i i)))
              '(0 1 2 3 4))
    v))
(test-equal '(1 -1 3 -3 8 -8)
  (append-map (lambda (x) (list x (- x)))
              '(1 3 8)))
(test-equal '(1 -1 3 -3 8 -8)
  (apply append (map (lambda (x) (list x (- x)))
                     '(1 3 8))))
(test-equal '(1 -1 3 -3 8 -8)
  (append-map! (lambda (x) (list x (- x)))
               '(1 3 8)))
(test-equal '(1 -1 3 -3 8 -8)
  (apply append! (map (lambda (x) (list x (- x)))
                      '(1 3 8))))
(test-equal "pair-for-each-1"
  '((a b c) (b c) (c))
  (let ((a '()))
    (pair-for-each (lambda (x) (set! a (cons x a)))
                   '(a b c))
    (reverse a)))
(test-equal '(1 9 49)
  (filter-map (lambda (x) (and (number? x) (* x x))) '(a 1 b 3 c 7)))
(test-equal '(0 8 8 -4) (filter even? '(0 7 8 8 43 -4)))
(test-equal (list '(one four five) '(2 3 6))
  (call-with-values (lambda () (partition symbol? '(one 2 3 four five 6)))
    list))
(test-equal '(7 43) (remove even? '(0 7 8 8 43 -4)))
(test-equal 2 (find even? '(1 2 3)))
(test-equal #t (any  even? '(1 2 3)))
(test-equal #f (find even? '(1 7 3)))
(test-equal #f (any  even? '(1 7 3)))
;;(test-error (find even? '(1 3 . x)))
;;(test-error (any  even? '(1 3 . x)))
;;(test 'error/undefined (find even? '(1 2 . x)))
;;(test 'error/undefined (any  even? '(1 2 . x))) ; success, error or other
(test-equal 6 (find even? (circular-list 1 6 3)))
(test-equal #t (any  even? (circular-list 1 6 3)))
;;(test-error (find even? (circular-list 1 3))) ; divergent
;;(test-error (any even? (circular-list 1 3))) ; divergent
(test-equal 4 (find even? '(3 1 4 1 5 9)))
(test-equal #f (every odd? '(1 2 3)))
(test-equal #t (every < '(1 2 3) '(4 5 6)))
(test-error (every odd? '(1 3 . x)))
(test-equal '(-8 -5 0 0) (find-tail even? '(3 1 37 -8 -5 0 0)))
(test-equal '#f (find-tail even? '(3 1 37 -5)))
(test-equal '(2 18) (take-while even? '(2 18 3 10 22 9)))
(test-equal '(3 10 22 9) (drop-while even? '(2 18 3 10 22 9)))
(test-equal (list '(2 18) '(3 10 22 9))
  (call-with-values (lambda () (span even? '(2 18 3 10 22 9)))
    list))
(test-equal (list '(3 1) '(4 1 5 9))
  (call-with-values (lambda () (break even? '(3 1 4 1 5 9)))
    list))
(test-equal #t (any integer? '(a 3 b 2.7)))
(test-equal #f (any integer? '(a 3.1 b 2.7)))
(test-equal #t (any < '(3 1 4 1 5) '(2 7 1 8 2)))
(test-equal 2 (list-index even? '(3 1 4 1 5 9)))
(test-equal 1 (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
(test-equal #f (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
(test-equal '(a b c) (memq 'a '(a b c)))
(test-equal '(b c) (memq 'b '(a b c)))
(test-equal #f (memq 'a '(b c d)))
(test-equal #f (memq (list 'a) '(b (a) c)))
(test-equal '((a) c) (member (list 'a) '(b (a) c)))
;;(test '*unspecified* (memq 101 '(100 101 102)))
(test-equal '(101 102) (memv 101 '(100 101 102)))
(test-equal '(a b c z) (delete-duplicates '(a b a c a b c z)))
(test-equal '((a . 3) (b . 7) (c . 1))
  (delete-duplicates '((a . 3) (b . 7) (a . 9) (c . 1))
                     (lambda (x y) (eq? (car x) (car y)))))
(let ((e '((a 1) (b 2) (c 3))))
  (test-equal '(a 1) (assq 'a e))
  (test-equal '(b 2) (assq 'b e))
  (test-equal #f (assq 'd e))
  (test-equal #f (assq (list 'a) '(((a)) ((b)) ((c)))))
  (test-equal '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
  ;;(test '*unspecified* (assq 5 '((2 3) (5 7) (11 13))))
  (test-equal '(5 7) (assv 5 '((2 3) (5 7) (11 13)))))
(test-equal #t (lset<= eq? '(a) '(a b a) '(a b c c)))
(test-equal #t (lset<= eq?))
(test-equal #t (lset<= eq? '(a)))
(test-equal #f (lset= eq? '(a) '()))
(test-equal #f (lset= eq? '() '(a)))
(test-equal #t (lset= eq? '(b e a) '(a e b) '(e e b a)))
(test-equal #t (lset= eq?))
(test-equal #t (lset= eq? '(a)))
(test-equal #f (lset= = '(2 1) '(2 1 0)))
(test-equal #t (lset<= = '(2 1) '(2 1 0)))
(test-equal #f (lset<= = '(2 1 0) '(2 1)))
(test-equal '(u o i a b c d c e)
  (lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u))
(test-equal '(u o i a b c d e) (lset-union eq? '(a b c d e) '(a e i o u)))
(test-equal '(x a a c) (lset-union eq? '(a a c) '(x a x)))
(test-equal '() (lset-union eq?))
(test-equal '(a b c) (lset-union eq? '(a b c)))
(test-equal '(a e) (lset-intersection eq? '(a b c d e) '(a e i o u)))
(test-equal '(a x a) (lset-intersection eq? '(a x y a) '(x a x z)))
(test-equal '(a b c) (lset-intersection eq? '(a b c)))
(test-equal '(b c d) (lset-difference eq? '(a b c d e) '(a e i o u)))
(test-equal '(a b c) (lset-difference eq? '(a b c)))
(test-equal #t
  (lset= eq?
         '(d c b i o u)
         (lset-xor eq? '(a b c d e) '(a e i o u))))
(test-equal '() (lset-xor eq?))
(test-equal '(a b c d e) (lset-xor eq? '(a b c d e)))

(test-end "srfi-1")
