;; SRFI 101: Purely Functional Random-Access Pairs and Lists
;; Copyright (c) David Van Horn 2009.  All Rights Reserved.

;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. REMEMBER, THERE IS NO SCHEME UNDERGROUND. IN NO
;; EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;; This test suite has been successfully run on Ikarus (0.0.3),
;; Larceny (0.97), and PLT Scheme (4.2.1.7).
;; Move srfi-101.sls and srfi-101-test.sls into (respectively):
;;    ./srfi/%3A101.sls
;;    ./srfi/%3A101/tests.sls
;;
;; To run:
;;    ikarus --r6rs-script srfi/%3A101/tests.sls
;;    larceny -r6rs -path . -program srfi/%3A101/tests.sls
;;    plt-r6rs --install srfi/%3A101.sls srfi/%3A101/tests.sls
;;
;; Note that this will shadow the SRFI collection that ships with PLT
;; Scheme since it installs a new `srfi' collection.

(use functional-lists)

(print "*** Testing \"functional-lists\". No output means OK. ***")

(define (check-expect c e)
  (if (ra:pair? c)
      (begin (assert (ra:pair? e))
             (check-expect (ra:car c)
                           (ra:car e))
             (check-expect (ra:cdr c)
                           (ra:cdr e)))
      (assert (equal? c e))))

(define-syntax check-error
  (syntax-rules ()
    ((_ e)
     (let ((f (ra:cons 0 0)))
       (guard (g ((eq? f g) (assert #f))
                 (else 'OK))
              (begin e
                     (raise f)))))))

(define-syntax guard
  (syntax-rules ()
    ((_ (?var ?clause0 ...) body ...)
      (handle-exceptions ?var
          (cond ?clause0 ...)
        body ...) ) ) )

(define-syntax raise
  (syntax-rules ()
    ((_ ?c) (signal ?c)) ) )

; quote

; Bug in Larceny prevents this from working
; https://trac.ccs.neu.edu/trac/larceny/ticket/656
(check-expect (ra:quote 5) (quote 5))
(check-expect (ra:quote x) (quote x))

(check-expect (let ((f (lambda () '(x))))
                (eq? (f) (f)))
              #t)

#; ;cannot work
(check-expect '(1 2 3) (ra:list 1 2 3))


; pair?
(check-expect (ra:pair? (ra:cons 'a 'b)) #t)
(check-expect (ra:pair? (ra:list 'a 'b 'c)) #t)
(check-expect (ra:pair? '()) #f)
(check-expect (ra:pair? '#(a b)) #f)

; cons
(check-expect (ra:cons 'a '()) (ra:list 'a))
(check-expect (ra:cons (ra:list 'a) (ra:list 'b 'c 'd))
              (ra:list (ra:list 'a) 'b 'c 'd))
(check-expect (ra:cons "a" (ra:list 'b 'c))
              (ra:list "a" 'b 'c))
(check-expect (ra:cons 'a 3)
              (ra:cons 'a 3))
(check-expect (ra:cons (ra:list 'a 'b) 'c)
              (ra:cons (ra:list 'a 'b) 'c))

; car
(check-expect (ra:car (ra:list 'a 'b 'c))
              'a)
(check-expect (ra:car (ra:list (ra:list 'a) 'b 'c 'd))
              (ra:list 'a))
(check-expect (ra:car (ra:cons 1 2)) 1)
(check-error (ra:car '()))

; cdr
(check-expect (ra:cdr (ra:list (ra:list 'a) 'b 'c 'd))
              (ra:list 'b 'c 'd))
(check-expect (ra:cdr (ra:cons 1 2))
              2)
(check-error (ra:cdr '()))

; null?
(check-expect (eq? ra:null? null?) #t)
(check-expect (ra:null? '()) #t)
(check-expect (ra:null? (ra:cons 1 2)) #f)
(check-expect (ra:null? 4) #f)

; list?
(check-expect (ra:list? (ra:list 'a 'b 'c)) #t)
(check-expect (ra:list? '()) #t)
(check-expect (ra:list? (ra:cons 'a 'b)) #f)

; list
(check-expect (ra:list 'a (+ 3 4) 'c)
              (ra:list 'a 7 'c))
(check-expect (ra:list) '())

; length
(check-expect (ra:length (ra:list 'a 'b 'c)) 3)
(check-expect (ra:length (ra:list 'a (ra:list 'b) (ra:list 'c))) 3)
(check-expect (ra:length '()) 0)

; append
(check-expect (ra:append (ra:list 'x) (ra:list 'y)) (ra:list 'x 'y))
(check-expect (ra:append (ra:list 'a) (ra:list 'b 'c 'd)) (ra:list 'a 'b 'c 'd))
(check-expect (ra:append (ra:list 'a (ra:list 'b)) (ra:list (ra:list 'c)))
              (ra:list 'a (ra:list 'b) (ra:list 'c)))
(check-expect (ra:append (ra:list 'a 'b) (ra:cons 'c 'd))
              (ra:cons 'a (ra:cons 'b (ra:cons 'c 'd))))
(check-expect (ra:append '() 'a) 'a)

; reverse
(check-expect (ra:reverse (ra:list 'a 'b 'c))
              (ra:list 'c 'b 'a))
(check-expect (ra:reverse (ra:list 'a (ra:list 'b 'c) 'd (ra:list 'e (ra:list 'f))))
              (ra:list (ra:list 'e (ra:list 'f)) 'd (ra:list 'b 'c) 'a))

; list-tail
(check-expect (ra:list-tail (ra:list 'a 'b 'c 'd) 2)
              (ra:list 'c 'd))

; list-ref
(check-expect (ra:list-ref (ra:list 'a 'b 'c 'd) 2) 'c)

; list-set
(check-expect (ra:list-set (ra:list 'a 'b 'c 'd) 2 'x)
              (ra:list 'a 'b 'x 'd))

; list-ref/update
(let-values (((a b)
              (ra:list-ref/update (ra:list 7 8 9 10) 2 -)))
  (check-expect a 9)
  (check-expect b (ra:list 7 8 -9 10)))

; map
(check-expect (ra:map ra:cadr (ra:list (ra:list 'a 'b) (ra:list 'd 'e) (ra:list 'g 'h)))
              (ra:list 'b 'e 'h))
(check-expect (ra:map (lambda (n) (expt n n))
                   (ra:list 1 2 3 4 5))
              (ra:list 1 4 27 256 3125))
(check-expect (ra:map + (ra:list 1 2 3) (ra:list 4 5 6))
              (ra:list 5 7 9))

; for-each
(check-expect (let ((v (make-vector 5)))
                (ra:for-each (lambda (i)
                            (vector-set! v i (* i i)))
                          (ra:list 0 1 2 3 4))
                v)
              '#(0 1 4 9 16))

; random-access-list->linear-access-list
; linear-access-list->random-access-list
(check-expect (ra:random-access-list->linear-access-list '()) '())
(check-expect (ra:linear-access-list->random-access-list '()) '())

(check-expect (ra:random-access-list->linear-access-list (ra:list 1 2 3))
              (list 1 2 3))

(check-expect (ra:linear-access-list->random-access-list (list 1 2 3))
              (ra:list 1 2 3))