;;;; list-utils-test.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(import
  (scheme base)
  (chicken base)
  test
  (only (chicken format) format) (test-utils gloss))
(import
  (chicken fixnum)
  (only (srfi 1) every list-copy))

;;;

(test-begin "List Utils")

;;

(import (list-utils basic))

(test-group  "Basic"
  (test-group  "Length"
    (test-assert (length=0? '()))
    (test-assert (not (length=0? '(1))))
    (test-assert (length=1? '(1)))
    (test-assert (not (length=1? '())))
    (test-assert (not (length=1? '(1 2))))
    (test-assert (length=2? '(1 2)))
    (test-assert (not (length=2? '())))
    (test-assert (not (length=2? '(1))))
    (test-assert (not (length=2? '(1 2 3))))
    (test-assert (length>1? '(1 2)))
    (test-assert (not (length>1? '())))
    (test-assert (not (length>1? '(1))))
  )

  (test-group  "Null Stuff"
    (test '(1) (ensure-list '(1)))
    (test '(1) (ensure-list 1))

    (test '(1) (not-null? '(1)))
    (test-assert (not (not-null? '())))
  )

  (test-group  "pair-ref"
    (test '(b c) (pair-ref '(a b c) 1))
    (test '() (pair-ref '(a b c) 3))
  )

  (test-group  "list-set!"
    (let ((ls (list 1 2 3)))
      (list-set! ls 1 'foo)
      (test "list-set!" 'foo (list-ref ls 1)) )
  )

  (test-group  "Extended list-copy (w/ st ed)"
    (test '(a b c) (list-copy* '(a b c)))
    (test '(b c) (list-copy* '(a b c) 1))
    (test '(b c z) (list-copy* '(a b c) 1 4 'z))
    (test '() (list-copy* '(a b c) 3 3 'z))
    (test '(z) (list-copy* '(a b c) 3 4 'z))
    (test-error (list-copy* '(a b c) 4 4 'z))
    (test-error (list-copy* '(a b c) -1 4 'z))
    (test-error (list-copy* '(a b c) 4 1 'z))
  )

  (test-group  "make-list/as"
    (define falses (make-list/as #f))
    (test #f (falses))
    (test '(#f #f #f) (falses 3))
    (test '(#f #f #f) (falses '(1 2 3)))
  )
)
;;

(import (list-utils operations))

(test-group  "operations"
  (test-group  "chain-unfold"
    (test '(1 2 3) (chain-unfold (cut fx+ <> 1) 1 3))
  )

  (test-group  "Unique"
    (test '((a b c d e) (a d)) (receive (list-unique/duplicates '(a a b c d d e))))
    (test '(a b c d e) (list-unique '(a a b c d d e)))
  )

  (test-group  "Skip+"
    (test '(() -1) (receive (skip+ '() -1)))
    (test '(() 0) (receive (skip+ '() 0)))
    (test '(() 1) (receive (skip+ '() 1)))
    (test '((1) -1) (receive (skip+ '(1) -1)))
    (test '((1) 0) (receive (skip+ '(1) 0)))
    (test '(() 0) (receive (skip+ '(1) 1)))
    (test '(() 1) (receive (skip+ '(1) 2)))
    (test '((1 2) -1) (receive (skip+ '(1 2) -1)))
    (test '((1 2) 0) (receive (skip+ '(1 2) 0)))
    (test '((2) 0) (receive (skip+ '(1 2) 1)))
    (test '(() 0) (receive (skip+ '(1 2) 2)))
  )

  (test-group  "Split-at+"
    (test '(() ()) (receive (split-at+ '() -1 #f)))   ;should be same
    (test '(() ()) (receive (split-at+ '() -1)))
    (test '(() ()) (receive (split-at+ '() 0)))
    (test '(() ()) (receive (split-at+ '() 1)))
    (test '(() ()) (receive (split-at+ '() -1 '())))
    (test '(() ()) (receive (split-at+ '() 0 '())))
    (test '(() ()) (receive (split-at+ '() 1 '())))
    (test '(() ()) (receive (split-at+ '() -1 '(1))))
    (test '(() ()) (receive (split-at+ '() 0 '(1))))
    (test '(() ()) (receive (split-at+ '() 1 '(1))))
    (test '(() (1)) (receive (split-at+ '(1) -1)))
    (test '(() (1)) (receive (split-at+ '(1) 0)))
    (test '((1) ()) (receive (split-at+ '(1) 1)))
    (test '(() ()) (receive (split-at+ '(1) 2)))
    (test '(() (1)) (receive (split-at+ '(1) -1 '())))
    (test '(() (1)) (receive (split-at+ '(1) 0 '())))
    (test '((1) ()) (receive (split-at+ '(1) 1 '())))
    (test '((1) ()) (receive (split-at+ '(1) 2 '())))
    (test '(() (1)) (receive (split-at+ '(1) -1 '(2))))
    (test '(() (1)) (receive (split-at+ '(1) 0 '(2))))
    (test '((1) ()) (receive (split-at+ '(1) 1 '(2))))
    (test '((1 2) ()) (receive (split-at+ '(1) 2 '(2))))
  )

  (test-group  "Section"
    ;(section LIST SIZE [STEP [PADS]])
    ;Needs more tests

    (test-error "size <= 0" (section '(1 2) -1 1 #f))
    (test-error "size <= 0" (section '(1 2) 0 1 #f))
    (test-error "step <= 0" (section '(1 2) 1 -1 #f))
    (test-error "step <= 0" (section '(1 2) 1 0 #f))

    (test "null primary" '() (section '() 1 1 #f))
    (test "size > length primary & no pad" '() (section '(1) 2 2 #f))

    (test '((1) (2)) (section '(1 2) 1 1 #f))
    (test '((1 2)) (section '(1 2) 2 2 #f))
    (test "size > length primary & clip" '((1 2)) (section '(1 2) 3 3 '()))
    (test "size > length primary & pad" '((1 2 3)) (section '(1 2) 3 3 '(3 4 5)))

    (test "size > step" '((1 2) (2 3)) (section '(1 2 3) 2 1))
    (test "size < step" '((1) (3)) (section '(1 2 3) 1 2))

    (test '((1 2) (2 3)) (section '(1 2 3) 2 1 '(a b c)))
    (test '((1 2 a)) (section '(1 2) 3 3 '(a b c)))
    (test '((1 2) (3 a)) (section '(1 2 3) 2 2 '(a b c)))
    (test '((1 2) (3)) (section '(1 2 3) 2 2))
  )

  (test-group  "Shift Set"
    (let ((lst (the (or list false) '(1 2))))
      (test 1 (shift!/set lst))
      (test '(2) (identity lst))
      (test 2 (shift!/set lst))
      (test '() (identity lst))
      (test-assert (not (shift!/set lst)))
      (test '() (identity lst))
    )
  )

  (test-group  "fold-right*"
    (define LIS '(0 1 2 3 4 5 6 7 8 9))

    (test '(5 5)
          (receive (fold-right* (lambda (obj s1 s2)
                                  (values (if (even? obj) (add1 s1)
                                              s1)
                                          (if (odd? obj) (add1 s2)
                                              s2)))
                                  LIS 0 0)))
  )

  (test-group  "tree-fold"
    (define TREE '(((a) (b) (c)) (((d)))))

    (test 4 (tree-fold (lambda (obj acc) (add1 acc)) 0 TREE))
  )

  (test-group  "Flatten"
    (define tls '((a) b ((((c) d) e) f) g))
    (define tls-dup (list-copy tls))
    (define tls-flt '(a b c d e f g))

    (test "flattens" tls-flt (list-flatten tls))
    (test "not in-place" tls-dup (identity tls)) ;due to test pattern

    (test-group  "ensure same, unless hilly"
      (test (ensure-list '()) (ensure-flat-list '()))
      (test (ensure-list 1) (ensure-flat-list 1))
      (test (ensure-list '(1)) (ensure-flat-list '(1)))
      (test "flattens" tls-flt (ensure-flat-list tls))
    )
  )

  #;
  (test-group  "experimental"
    (test '((d) (c d) (b c d) (a b c d))
          (pair-map identity #;values '(a b c d)))
    (test '(((d) (4)) ((c d) (3 4)) ((b c d) (2 3 4)) ((a b c d) (1 2 3 4)))
         ;'(((d) (4)) (((c d) (3 4)) (((b c d) (2 3 4)) (((a b c d) (1 2 3 4)) ()))))
          (pair-map values '(a b c d) '(1 2 3 4)))
  )
)

;;

(import (list-utils alist))

(test-group  "Alist"
  (define alst1 '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6) (d 7)))
  (define alst2 '((a . 1) (b . 2) (b . 3) (c . 4) (b . 5) (a . 6) (d . 7)))

  (test-group  "Alist Zip"
    (test '((a b) ((1) (2))) (receive (unzip-alist '((a 1) (b 2)))))
    (test '((a . 1) (b . 2)) (zip-alist '(a b) '(1 2)))
    (test '((a 1) (b 2)) (zip-alist '(a b) '((1) (2))))
    (test '((a . 1) (b . 2)) (zip-alist '(a b) '(1 2)))
  )

  (test-group  "Plist <-> Alist"
    (test '(a (1) b (2) b (3) c (4) b (5) a (6) d (7)) (alist->plist alst1))
    (test '(a 1 b 2 b 3 c 4 b 5 a 6 d 7) (alist->plist alst2))
    (test alst1 (plist->alist '(a (1) b (2) b (3) c (4) b (5) a (6) d (7))))
    (test alst2 (plist->alist '(a 1 b 2 b 3 c 4 b 5 a 6 d 7)))
  )

  (test-group  "Alist Delete"
    (test '((a 1) (c 4) (b 5) (a 6) (d 7)) (alist-delete-duplicates 'b alst1 eq? 2))
    (test '((a 1) (c 4) (a 6) (d 7)) (alist-delete-duplicates 'b alst1 eq?))
    (test '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6)) (alist-delete-duplicates 'd alst1 eq?))
    (test '((a 1) (b 2) (b 3) (b 5) (a 6) (d 7)) (alist-delete-duplicates 'c alst1 eq?))
    (test '((b 2) (b 3) (c 4) (b 5) (a 6) (d 7)) (alist-delete-duplicates 'a alst1 eq? 1))

    (test '((a 1) (c 4) (b 5) (a 6) (d 7)) (alist-delete-duplicates! 'b alst1 eq? 2))
    (test '((a 1) (c 4) (a 6) (d 7)) (alist-delete-duplicates! 'b alst1 eq?))
    (test '((a 1) (c 4) (a 6)) (alist-delete-duplicates! 'd alst1 eq?))
    (test '((a 1) (a 6)) (alist-delete-duplicates! 'c alst1 eq?))
    (test '((a 6)) (alist-delete-duplicates! 'a alst1 eq? 1))
  )
)

;;

(import (list-utils sample))

(test-group "Sample"
  (define RS '(0 1 2 3 4 5 6 7 8 9))

  (let ((rs (list-randoms 10)))
    (test-assert (list? rs))
    (test 10 (length rs))
    (test-assert (every integer? rs)) )

  (let ((ss (list-random-sample RS 5)))
    (gloss "rnds" ss)
    (test-assert (list? ss))
    (test 5 (length ss))
    (test-assert (every integer? ss)) )

  (test '(0 2 4 6 8) (list-cyclic-sample RS 2))
)

;;

(import (list-utils comma))

(test-group  "Comma"
  (test "1, 2, 3" (list-comma-join 1 2 3))
  (test '("1" "2" "3") (comma-string->list "1, 2, 3"))
)

;;;

(test-end "List Utils")

(test-exit)