#lang s-exp "../../lang/base.rkt"

(require "testing.rkt")
(require (for-syntax racket/base))


(test (list 1 2 3 4) foldl cons '() (list 4 3 2 1))
(test (list 1 2 3 4) foldr cons '() (list 1 2 3 4))
(test (list (list 5 6) (list 3 4) (list 1 2))
      foldl (lambda (x y sofar) (cons (list x y) sofar))
      '()
      (list 1 3 5)
      (list 2 4 6))
(test (list (list 1 2) (list 3 4) (list 5 6))
      foldr (lambda (x y sofar) (cons (list x y) sofar))
      '()
      (list 1 3 5)
      (list 2 4 6))

(arity-test foldl 3 -1)
(arity-test foldr 3 -1)

(err/rt-test (foldl 'list 0 10))
(err/rt-test (foldl list 0 10))
(err/rt-test (foldl add1 0 '()))
(err/rt-test (foldl cons 0 '() '()))
(err/rt-test (foldl list 0 '() 10))
(err/rt-test (foldl list 0 '() '() 10))
(err/rt-test (let/cc k (foldl k 0 '(1 2) '(1 2 3))))
(err/rt-test (let/cc k (foldl k 0 '(1 2) '(1 2) '(1 2 3))))
(err/rt-test (foldr 'list 0 10))
(err/rt-test (foldr list 0 10))
(err/rt-test (foldr add1 0 '()))
(err/rt-test (foldr cons 0 '() '()))
(err/rt-test (foldr list 0 '() 10))
(err/rt-test (foldr list 0 '() '() 10))
(err/rt-test (let/cc k (foldr k 0 '(1 2) '(1 2 3))))
(err/rt-test (let/cc k (foldr k 0 '(1 2) '(1 2) '(1 2 3))))

(test '(0 1 2) memf add1 '(0 1 2))
(test '(2 (c 17)) memf number? '((a 1) (0 x) (1 w) 2 (c 17)))
(test '("ok" (2 .7) c) memf string? '((a 0) (0 a) (1 w) "ok" (2 .7) c))
(err/rt-test (memf cons '((1) (2) (3))))
(err/rt-test (memf string? '((1) (2) (3) . 4)) exn:application:mismatch?)

#| dyoo: missing assf 
(err/rt-test (assf add1 '(0 1 2)) exn:application:mismatch?)
(test '(0 x) assf number? '((a 1) (0 x) (1 w) (2 r) (c 17)))
(test '("ok" . 10) assf string? '((a 0) (0 a) (1 w) ("ok" . 10) (2 .7) c))
(err/rt-test (assf cons '((1) (2) (3))))
(err/rt-test (assf string? '((1) (2) (3) . 4)) exn:application:mismatch?)

|#


#| dyoo: missing last
;; ---------- last, last-pair ----------
(let ()
  (test 3        last '(1 2 3))
  (test '(3)     last-pair '(1 2 3))
  (err/rt-test  (last '(1 2 3 . 4)))
  (test '(3 . 4) last-pair '(1 2 3 . 4))
  (err/rt-test  (last '()))
  (err/rt-test  (last 1))
  (err/rt-test  (last-pair '()))
  (err/rt-test  (last-pair 1)))
|#


;; ---------- sort ----------
(test '("a" "b" "c" "c" "d" "e" "f")
      sort
      '("d" "f" "e" "c" "a" "c" "b")
      string<?)
(let ()
  (define (car< x y) (< (car x) (car y)))
  (define (random-list n range)
    (let loop ([n n] [r '()])
      (if (zero? n) r (loop (sub1 n) (cons (list (random range)) r)))))
  (define (sort* lst)
    (let ([s1 (sort lst car<)]
          [s2 (sort lst < #:key car)]
          [s3 (sort lst < #:key car #:cache-keys? #t)])
      (test #t andmap eq? s1 s2)
      (test #t andmap eq? s1 s3)
      s1))
  (define (test-sort len times)
    (or (zero? times)
        (and (let* ([rand (random-list len (if (even? times) 1000000 10))]
                    [orig< (lambda (x y) (memq y (cdr (memq x rand))))]
                    [sorted (sort* rand)]
                    [l1 (reverse (cdr (reverse sorted)))]
                    [l2 (cdr sorted)])
               (and (= (length sorted) (length rand))
                    (andmap (lambda (x1 x2)
                              (and (not (car< x2 x1)) ; sorted?
                                   (or (car< x1 x2) (orig< x1 x2)))) ; stable?
                            l1 l2)))
             (test-sort len (sub1 times)))))
  (test #t test-sort    1  10)
  (test #t test-sort    2  20)
  (test #t test-sort    3  60)
  (test #t test-sort    4 100)
  (test #t test-sort    5 100)
  (test #t test-sort   10 100)
  (test #t test-sort  100 100)
  (test #t test-sort 1000 100)
  ;; test stability
  (test '((1) (2) (3 a) (3 b) (3 c)) sort* '((3 a) (1) (3 b) (2) (3 c)))
  ;; test short lists (+ stable)
  (test '() sort* '())
  (test '((1 1)) sort* '((1 1)))
  (test '((1 2) (1 1)) sort* '((1 2) (1 1)))
  (test '((1) (2)) sort* '((2) (1)))
  (for-each (lambda (l) (test '((0 3) (1 1) (1 2)) sort* l))
            '(((1 1) (1 2) (0 3))
              ((1 1) (0 3) (1 2))
              ((0 3) (1 1) (1 2))))
  (for-each (lambda (l) (test '((0 2) (0 3) (1 1)) sort* l))
            '(((1 1) (0 2) (0 3))
              ((0 2) (1 1) (0 3))
              ((0 2) (0 3) (1 1))))
  ;; exhaustive tests for 2 and 3 item lists
  (for-each (lambda (l) (test '((1 x) (2 y)) sort* l))
            '(((1 x) (2 y))
              ((2 y) (1 x))))
  (for-each (lambda (l) (test '((1 x) (2 y) (3 z)) sort* l))
            '(((1 x) (2 y) (3 z))
              ((2 y) (1 x) (3 z))
              ((2 y) (3 z) (1 x))
              ((3 z) (2 y) (1 x))
              ((3 z) (1 x) (2 y))
              ((1 x) (3 z) (2 y)))))
;; test #:key and #:cache-keys?
(let ()
  (define l '((0) (9) (1) (8) (2) (7) (3) (6) (4) (5)))
  (define sorted '((0) (1) (2) (3) (4) (5) (6) (7) (8) (9)))
  (test sorted sort l < #:key car)
  (let ([c1 0] [c2 0] [touched '()])
    (test sorted
          sort l (lambda (x y) (set! c1 (add1 c1)) (< x y))
                 #:key (lambda (x)
                         (set! c2 (add1 c2))
                         (set! touched (cons x touched))
                         (car x)))
    ;; test that the number of key uses is half the number of comparisons
    (test #t = (* 2 c1) c2)
    ;; and that this is larger than the number of items in the list
    (test #t < (length l) c2)
    ;; and that every item was touched
    ;; dyoo: missing remove*
    #;(test null remove* touched l))
  (let ([c 0] [touched '()])
    ;; now cache the keys
    (test sorted
          sort l <
               #:key (lambda (x)
                       (set! c (add1 c))
                       (set! touched (cons x touched))
                       (car x))
               #:cache-keys? #t)
    ;; test that the number of key uses is the same as the list length
    (test #t = c (length l))
    ;; and that every item was touched
    ;; dyoo: missing remove*
    #;(test null remove* touched l))
  (let* ([c 0] [getkey (lambda (x) (set! c (add1 c)) x)])
    ;; either way, we never use the key proc on no arguments
    (test '() sort '() < #:key getkey #:cache-keys? #f)
    (test '() sort '() < #:key getkey #:cache-keys? #t)
    (test #t = c 0)
    ;; we also don't use it for 1-arg lists
    (test '(1) sort '(1) < #:key getkey #:cache-keys? #f)
    (test #t = c 0)
    ;; but we do use it once if caching happens (it's a consistent interface)
    (test '(1) sort '(1) < #:key getkey #:cache-keys? #t)
    (test #t = c 1)
    ;; check a few other short lists
    (test '(1 2) sort '(2 1) < #:key getkey #:cache-keys? #t)
    (test '(1 2 3) sort '(2 3 1) < #:key getkey #:cache-keys? #t)
    (test '(1 2 3 4) sort '(4 2 3 1) < #:key getkey #:cache-keys? #t)
    (test #t = c 10)))

;; ---------- make-list ----------
;; dyoo: missing make-list
#;(let ()
  (test '()    make-list 0 'x)
  (test '(x)   make-list 1 'x)
  (test '(x x) make-list 2 'x)
  (err/rt-test (make-list -3 'x)))

;; ---------- take/drop[-right] ----------
#|
(let ()
  (define-syntax vals-list
    (syntax-rules ()
      [(_ expr)
       (call-with-values (lambda () expr) list)]))
  ;; dyoo: missing split-at

  (define (split-at*       l n) (vals-list (split-at       l n)))
  (define (split-at-right* l n) (vals-list (split-at-right l n)))
  (define funs (list take drop take-right drop-right
                     split-at* split-at-right*))
  (define tests
    ;; -----args------ --take--- --drop--- --take-r--- --drop-r-
    '([((a b c d) 2)   (a b)     (c d)     (c d)       (a b)    ]
      [((a b c d) 0)   ()        (a b c d) ()          (a b c d)]
      [((a b c d) 4)   (a b c d) ()        (a b c d)   ()       ]
      [((a b c . d) 1) (a)       (b c . d) (c . d)     (a b)    ]
      [((a b c . d) 3) (a b c)   d         (a b c . d) ()       ]
      [(99 0)          ()        99        99          ()       ]))
  (for ([t tests]
        #:when #t
        [expect `(,@(cdr t)
                  ,(list (list-ref t 1) (list-ref t 2))
                  ,(list (list-ref t 4) (list-ref t 3)))]
        [fun funs])
    (apply test expect fun (car t)))
  (for ([fun funs])
    (arity-test fun 2 2)
    (err/rt-test (fun 1 1) exn:application:mismatch?)
    (err/rt-test (fun '(1 2 3) 2.0))
    (err/rt-test (fun '(1) '(1)))
    (err/rt-test (fun '(1) -1))
    (err/rt-test (fun '(1) 2) exn:application:mismatch?)
    (err/rt-test (fun '(1 2 . 3) 3) exn:application:mismatch?)))
|#


;; dyoo: missing append*
#|
;; ---------- append* ----------
(let ()
  (test '()        append* '())
  (test '()        append* '(()))
  (test '()        append* '(() ()))
  (test '(0 1 2 3) append* '((0 1 2 3)))
  (test '(0 1 2 3) append* '(0 1 2 3) '())
  (test '(0 1 2 3) append* '(0 1 2 3) '(()))
  (test '(0 1 2 3) append* '(0 1 2 3) '(() ()))
  (test '(0 1 2 3) append* '(0 1) '((2) (3)))
  (test '(0 1 0 2 0 3) append* (map (lambda (x) (list 0 x)) '(1 2 3)))
  (test '(1 2 3 4 5 6 7 8 9) append* '(1 2 3) '(4 5) '((6 7 8) (9))))
|#


;; ---------- flatten ----------
;; dyoo: missing for*/list
#|
(let ()
  (define (all-sexps n)
    (if (zero? n)
      '(x ())
      (let ([r (all-sexps (sub1 n))])
        (append r (for*/list ([x r] [y r]) (cons x y))))))
  (define sexps (all-sexps 3)) ; can use 4 on fast machines
  (define (flat? x) (and (list? x) (andmap (lambda (x) (eq? 'x x)) x)))
  (for ([x sexps]) (test #t flat? (flatten x))))
|#

;; ---------- add-between ----------
;; dyoo: missing add-between
#|
(let ()
  (test '()          add-between '() 1)
  (test '(9)         add-between '(9) 1)
  (test '(9 1 8 1 7) add-between '(9 8 7) 1)
  (test '(9 (1) 8)   add-between '(9 8) '(1)))
|#
;; ---------- remove-duplicates ----------
#| dyoo: missing remove-duplicates
(let ()
  (define rd remove-duplicates)
  ;; basic 'naive tests
  (test '() rd '())
  (test '(a) rd '(a a a a))
  (test '(a b) rd '(a b))
  (test '(a b) rd '(a b a b a b))
  (test '(a b) rd '(a a a b b b))
  (test '(a b) rd '(a b b a)) ; keeps first occurrences
  (test '("a" "b") rd '("a" "A" "b" "B" "a") #:key string-downcase)
  (let ([long (for/list ([i (in-range 300)]) i)])
    (test long rd long)
    (test long rd (append long long))
    (test long rd (append long (reverse long))) ; keeps first
    (test long rd (append* (map (lambda (x) (list x x)) long)))
    (test long rd (append long (map (lambda (x) (- x)) long)) #:key abs)
    (test long rd (append long (map (lambda (x) (- x)) long)) = #:key abs)))
|#

#|
;; dyoo: missing filter-not
;; ---------- filter and filter-not ----------
(let ()
  (define f filter)
  (define fn filter-not)

  (test '()              f  number? '())
  (test '()              fn number? '())
  (test '(1 2 3)         f  number? '(1 a 2 b 3 c d))
  (test '(a b c d)       fn number? '(1 a 2 b 3 c d))
  (test '()              f  string? '(1 a 2 b 3 c d))
  (test '(1 a 2 b 3 c d) fn string? '(1 a 2 b 3 c d))
  (err/rt-test (f string? '(1 2 3 . 4)) exn:application:mismatch?)
  (err/rt-test (fn string? '(1 2 3 . 4)) exn:application:mismatch?)
  (err/rt-test (f  2 '(1 2 3)))
  (err/rt-test (fn 2 '(1 2 3)))
  (err/rt-test (f cons '(1 2 3)))
  (err/rt-test (fn cons '(1 2 3)))
  (arity-test f  2 2)
  (arity-test fn 2 2))
|#

#| dyoo: missin gpartition
;; ---------- partition ----------
(let ()
  (define (p pred l) (call-with-values (lambda () (partition pred l)) list))
  (test '(() ()) p (lambda (_) #t) '())
  (test '(() ()) p (lambda (_) #f) '())
  (test '((1 2 3 4) ()) p (lambda (_) #t) '(1 2 3 4))
  (test '(() (1 2 3 4)) p (lambda (_) #f) '(1 2 3 4))
  (test '((2 4) (1 3)) p even? '(1 2 3 4))
  (test '((1 3) (2 4)) p odd? '(1 2 3 4)))
|#

#| dyoo: missing filter-map
;; ---------- filter-map ----------
(let ()
  (define fm filter-map)
  (test '() fm values '())
  (test '(1 2 3) fm values '(1 2 3))
  (test '() fm values '(#f #f #f))
  (test '(1 2 3) fm values '(#f 1 #f 2 #f 3 #f))
  (test '(4 8 12) fm (lambda (x) (and (even? x) (* x 2))) '(1 2 3 4 5 6)))
|#


#| dyoo: missing count
;; ---------- count ----------

(let ()
  (test 0 count even? '())
  (test 4 count even? '(0 2 4 6))
  (test 0 count even? '(1 3 5 7))
  (test 2 count even? '(1 2 3 4))
  (test 2 count < '(1 2 3 4) '(4 3 2 1)))
|#

#| dyoo: missing append-map
;; ---------- append-map ----------
(let ()
  (define am append-map)
  (test '() am list '())
  (test '(1 2 3) am list '(1 2 3))
  (test '(1 1 2 2 3 3) am (lambda (x) (list x x)) '(1 2 3)))
|#


#| dyoo: missing regexps
;; ---------- argmin & argmax ----------

(let ()

  (define ((check-regs . regexps) exn)
    (and (exn:fail? exn)
         (andmap (λ (reg) (regexp-match reg (exn-message exn)))
                 regexps)))

  (test 'argmin object-name argmin)
  (test 1 argmin (lambda (x) 0) (list 1))
  (test 1 argmin (lambda (x) x) (list 1 2 3))
  (test 1 argmin (lambda (x) 1) (list 1 2 3))

  (test 3
        'argmin-makes-right-number-of-calls
        (let ([c 0])
          (argmin (lambda (x) (set! c (+ c 1)) 0)
                  (list 1 2 3))
          c))

  (test '(1 banana) argmin car '((3 pears) (1 banana) (2 apples)))

  (err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"procedure"))
  (err/rt-test (argmin (lambda (x) x) 3) (check-regs #rx"argmin" #rx"list"))
  (err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
  (err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))

  (err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
  (err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx"non-empty list"))

  (test 'argmax object-name argmax)
  (test 1 argmax (lambda (x) 0) (list 1))
  (test 3 argmax (lambda (x) x) (list 1 2 3))
  (test 1 argmax (lambda (x) 1) (list 1 2 3))

  (test 3
        'argmax-makes-right-number-of-calls
        (let ([c 0])
          (argmax (lambda (x) (set! c (+ c 1)) 0)
                  (list 1 2 3))
          c))

  (test '(3 pears) argmax car '((3 pears) (1 banana) (2 apples)))

  (err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"procedure"))
  (err/rt-test (argmax (lambda (x) x) 3) (check-regs #rx"argmax" #rx"list"))
  (err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
  (err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))

  (err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
  (err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx"non-empty list")))

|#

;; ---------- check no collisions with srfi/1 ----------
#;(test (void)
      eval '(module foo scheme/base (require scheme/base srfi/1/list))
           (make-base-namespace))

(report-errs)

"list.rkt end"