#lang lazy

(require tests/eli-tester)

;; tests for lazy language constructs

(define (basic-tests)
  (test
   (! ((car (list if)) (< 1 2) 3 (error "poof"))) => 3
   (! ((car (list or)) 3 (error "poof"))) => 3
   (! ((car (list and)) (< 2 1) (error "poof"))) => #f
   (!! (let ([x 0]) (set! x 1) (list x))) => '(1) ; implicit begin forces
   (! (let ([x 0]) (when (zero? x) (error "poof")) 1)) =error> "poof"
   (! (let ([x 0]) (when (zero? x) (set! x (add1 x)) (set! x (add1 x))) x))
   => 2
   (! (let ([x 1]) (unless (zero? x) (set! x (add1 x)) (set! x (add1 x))) x))
   => 3
   (! (let ([x 0]) (cond [(zero? x) (set! x (add1 x)) (set! x (add1 x))]) x))
   => 2
   (! (eq? 1 1)) => #t
   (! (eq? 1 2)) => #f
   (! (eqv? 1.0 1.0)) => #t
   (! (eqv? 1.0 1)) => #f
   (! (= 1.0 1)) => #t
   (! (equal? (list 1.0) (list 1.0))) => #t
   (! (letrec ([zs (cons 0 zs)]) (equal? (list zs zs) (list zs zs)))) => #t
   ))

(define (list-tests)
  (test
   (! (car 0)) =error> "car: contract violation\n  expected: pair?"
   (! (cdr 0)) =error> "cdr: contract violation\n  expected: pair?"
   (! (car (cons 1 (/ 1 0)))) => 1
   (! (cdr (cons (/ 1 0) 1))) => 1
   (! (list-ref (list (/ 1 0) 1 (/ 1 0)) 1)) => 1
   (! (list-ref (cons 1 (/ 1 0)) 0)) => 1 ; doesn't force list structure
   (! (list-tail (cons (/ 1 0) 0) 1)) => 0
   (! (length (list (/ 1 0) (/ 1 0) (/ 1 0)))) => 3
   (! (let ([l (list (/ 1 0) (/ 1 0))]) (length (append l l l)))) => 6
   (!! (member 1 (cons 0 (cons 1 2)))) => '(1 . 2)
   (!! (memq   1 (cons 0 (cons 1 2)))) => '(1 . 2)
   (!! (memv   1 (cons 0 (cons 1 2)))) => '(1 . 2)
   (! (second (map car (list 1 2 3)))) =error> "contract violation"
   (! (second (map car (list 1 '(2) 3)))) => 2
   ))

(define (take-tests)
  (define test-lst1 '(1 2 3))
  (test
   (! (take "nonnum" test-lst1))
   =error>
   #rx"take: expects type <non-negative exact integer> as 1st argument, given: \"nonnum\"; other arguments were: .*\\((list )?1 2 3\\)"
   (! (take -1 test-lst1))
   =error> "take: expects type <non-negative exact integer> as 1st argument"
   (! (take -1 "nonlist"))
   =error> "take: expects type <non-negative exact integer> as 1st argument"
   (! (take 0 "nonlist")) => '()
   (! (take 1 "nonlist")) =error> "take: not a proper list: \"nonlist\""
   (! (take 0 null)) => '()
   (! (take 0 test-lst1)) => '()
   (!! (take 1 test-lst1)) => '(1)
   (!! (take 2 test-lst1)) => '(1 2)
   (!! (take 3 (take 4 test-lst1))) => '(1 2 3) ; doesn't force the error
   (! (fourth (take 4 test-lst1)))              ; this one does
   =error> "take: index 4 too large for input list"
   (! (list-ref (take (~ 1) (list 2)) 0)) => 2
   (! (take 0 (error))) => '() ; doesn't even force the list structure
   (!! (take 1 (cons 0 (error "poof")))) => '(0)
   ))

(define (misc-tests)
  (define-struct a (b c))
  (define-struct d (e f))
  (test
   (! (a-b (make-a 1 2))) => 1
   (! (a-c (make-a 1 2))) => 2
   (! (a-b (a 1 2))) => 1
   (! (a-c (a 1 2))) => 2
   (! (a? (a 1 2))) => true
   (! (a? (d 1 2))) => false
   ))

; Lazy Racket examples from Premiers cours de programmation avec Scheme (Roy)
(define (pcps-tests)
  ;; Definitions --------------------------------------------------------------
  (define (f x y) x)
  (define (fac n)
    (if (= n 0) 1 (* n (fac (- n 1)))))
  (define (new-if test p q)
    (cond (test p)
          (else q)))
  (define fibs (cons 0 (cons 1 (map + fibs (cdr fibs)))))
  #;(define ($list-ref L k)
    (let loop ((k (force k)) (L (force L)))
      (if (= k 0)
          (car L)
          (loop (- k 1) (cdr (force L))))))
  (define L2 (cons 2 (map add1 L2)))
  (define (rayer n L)     ; L prive des multiples de n
    (filter (lambda (x) (not (= 0 (modulo x n)))) L))
  (define (crible L)
    (cons (car L) (crible (rayer (car L) (cdr L)))))
  (define PREMS (crible L2)) ; primes
  (define ZERO (cons 0 ZERO))     ; le flot infini <0,0,0,0,...>
  (define (poly->serie L)         ; L = coeffs en puissances croissantes
    (define (copy L)
      (if (null? L)
          ZERO                    ; padding à droite par des 0
          (cons (car L) (copy (cdr L)))))
    (copy L))
  (define (int-serie S)           ; integration terme a terme
    (define (aux S i)
      (cons (/ (car S) i) (aux (cdr S) (+ i 1))))
    (aux S 1))
  (define EXPO (cons 1 (int-serie EXPO)))
  (define SIN (cons 0 (int-serie COS)))
  (define COS (cons 1 (map - (int-serie SIN))))
  (define (ints-from n)
    (cons n (ints-from (+ n 1))))
  (define NAT (ints-from 0))
  (define UN (cons 1 UN))
  (define nats (cons 0 (map + nats UN)))
  (define QUATRE (filter (lambda (x) (zero? (modulo x 4))) NAT))
  (define (melanger F1 F2)     ; F1 et F2 infinis strictement croissants
    (cond ((< (car F1) (car F2)) (cons (car F1) (melanger (cdr F1) F2)))
          ((> (car F1) (car F2)) (cons (car F2) (melanger F1 (cdr F2))))
          (else (cons (car F1) (melanger (cdr F1) (cdr F2))))))
  (define (zoom x F)
    (cons (* (car F) x) (zoom x (cdr F))))
  (define PAIR (zoom 2 NAT))
  (define (hamming)
    (define h (cons 1 (melanger (zoom 2 h) (melanger (zoom 3 h) (zoom 5 h)))))
    h)
  (define h (hamming))
  (define FACT (cons 1 (map * FACT (cdr NAT))))
  (define (entrelacer s1 s2)
    (cons (car s1) (entrelacer s2 (cdr s1))))
  (define F (entrelacer NAT F))
  ;; Tests --------------------------------------------------------------------
  (test
   (!! (fac 5)) => 120
   (!! (new-if (= 1 2) (/ 1 0) 3)) => 3
   (!! (take 20 PREMS)) =>
   '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71)
   (!! (list-ref PREMS 999)) => 7919
   (!! (apply + (take 100 PREMS))) => 24133
   (!! (take 10 (poly->serie '(1 2 3)))) => '(1 2 3 0 0 0 0 0 0 0)
   (!! (take 10 EXPO)) => 
   '(1 1 1/2 1/6 1/24 1/120 1/720 1/5040 1/40320 1/362880)
   (!! (take 8 SIN)) => '(0 1 0 -1/6 0 1/120 0 -1/5040)
   (!! (take 8 COS)) => '(1 0 -1/2 0 1/24 0 -1/720 0)
   (!! (take 10 (ints-from 5))) => '(5 6 7 8 9 10 11 12 13 14)
   (!! (take 10 NAT)) => '(0 1 2 3 4 5 6 7 8 9)
   (!! (take 10 UN)) => '(1 1 1 1 1 1 1 1 1 1)
   (!! (take 10 nats)) => '(0 1 2 3 4 5 6 7 8 9)
   (!! (take 10 QUATRE)) => '(0 4 8 12 16 20 24 28 32 36)
   (!! (take 10 (melanger NAT QUATRE))) => '(0 1 2 3 4 5 6 7 8 9)
   (!! (take 10 PAIR)) => '(0 2 4 6 8 10 12 14 16 18)
   (!! (take 30 h)) => 
   '(1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30 32 36 40 45 48 50 54 60 64 72 75 80)
   (!! (list-ref h 10000)) => 288555831593533440
   (!! (take 10 FACT)) => '(1 1 2 6 24 120 720 5040 40320 362880)
   (!! (take 10 (entrelacer NAT PAIR))) => '(0 0 1 2 2 4 3 6 4 8)
   (!! (take 10 F)) => '(0 0 1 0 2 1 3 0 4 2)))

(define (strictness-tests)
  (test
   (! (and (/ 1 0))) =error> "/: division by zero"
   (! (and #f (/ 1 0))) => #f
   (! (and #t (/ 1 0))) =error> "/: division by zero"
   (! (cdr (append (list (/ 1 0)) '()))) => '()
   (! (cdr (append '() (list (/ 1 0))))) => '()
   (! (append (/ 1 0) '())) =error> "/: division by zero"
   (! (append (/ 1 0) '() '())) =error> "/: division by zero"
   (! (append (/ 1 0) '(1))) =error> "/: division by zero"
   (! (append '() (/ 1 0))) =error> "/: division by zero"
   (! (car (append '(1) (/ 1 0)))) => 1
   (! (cdr (append '(1) (/ 1 0)))) =error> "/: division by zero"
   (! (car (append '(1) 1 (/ 1 0)))) => 1
   (! (foldr (/ 1 0) 0 '())) =error> "/: division by zero"
   (! (foldr 1 (/ 1 0) '())) =error> "/: division by zero"
   (! (foldr 1 2 (/ 1 0))) =error> "/: division by zero"
   (! (foldr (/ 1 0) 1 '(1))) =error> "/: division by zero"
   (! (foldr 1 (/ 1 0) '(1))) =error> "/: division by zero"
   (! (foldl (/ 1 0) 0 '())) =error> "/: division by zero"
   (! (foldl 1 (/ 1 0) '())) =error> "/: division by zero"
   (! (foldl 1 2 (/ 1 0))) =error> "/: division by zero"
   (! (foldl (/ 1 0) 1 '(1))) =error> "/: division by zero"
   (! (foldl 1 (/ 1 0) '(1))) =error> "/: division by zero"
   (! (filter (/ 1 0) '())) =error> "/: division by zero"
   (! (filter 1 (/ 1 0))) =error> "/: division by zero"
   (! (filter (/ 1 0) '(1))) =error> "/: division by zero"
   (! (map (/ 1 0) '())) =error> "/: division by zero"
   (! (map (/ 1 0) '(1))) =error> "/: division by zero"
   (! (map 1 (/ 1 0))) =error> "/: division by zero"
   (! (if (/ 1 0) 1 2)) =error> "/: division by zero"
   (! (if #t 1 (/ 1 0))) => 1
   (! (if #f (/ 1 0) 1)) => 1
   (! (andmap (/ 1 0) '())) =error> "/: division by zero"
   (! (andmap (/ 1 0) '(1))) =error> "/: division by zero"
   (! (andmap 1 (/ 1 0))) =error> "/: division by zero"
   ))

(provide lang-tests)
(module+ main (lang-tests))
(define (lang-tests)
  (! (begin (basic-tests)
            (list-tests)
            (take-tests)
            (misc-tests)
            (pcps-tests)
            (strictness-tests))))