Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add s101

  • Loading branch information...
commit 6758b3b95e634fea9c6ea5803ff968b9494cf8c5 1 parent 2c3d015
@dharmatech authored
Showing with 701 additions and 0 deletions.
  1. +504 −0 s101/random-access-lists.sls
  2. +197 −0 s101/srfi-101-tests.sps
View
504 s101/random-access-lists.sls
@@ -0,0 +1,504 @@
+#!r6rs
+;; 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.
+
+(library (surfage s101 random-access-lists)
+ (export (rename (ra:quote quote)
+ (ra:pair? pair?)
+ (ra:cons cons)
+ (ra:car car)
+ (ra:cdr cdr)
+ (ra:caar caar)
+ (ra:cadr cadr)
+ (ra:cddr cddr)
+ (ra:cdar cdar)
+ (ra:caaar caaar)
+ (ra:caadr caadr)
+ (ra:caddr caddr)
+ (ra:cadar cadar)
+ (ra:cdaar cdaar)
+ (ra:cdadr cdadr)
+ (ra:cdddr cdddr)
+ (ra:cddar cddar)
+ (ra:caaaar caaaar)
+ (ra:caaadr caaadr)
+ (ra:caaddr caaddr)
+ (ra:caadar caadar)
+ (ra:cadaar cadaar)
+ (ra:cadadr cadadr)
+ (ra:cadddr cadddr)
+ (ra:caddar caddar)
+ (ra:cdaaar cdaaar)
+ (ra:cdaadr cdaadr)
+ (ra:cdaddr cdaddr)
+ (ra:cdadar cdadar)
+ (ra:cddaar cddaar)
+ (ra:cddadr cddadr)
+ (ra:cddddr cddddr)
+ (ra:cdddar cdddar)
+ (ra:null? null?)
+ (ra:list? list?)
+ (ra:list list)
+ (ra:make-list make-list)
+ (ra:length length)
+ (ra:append append)
+ (ra:reverse reverse)
+ (ra:list-tail list-tail)
+ (ra:list-ref list-ref)
+ (ra:list-set list-set)
+ (ra:list-ref/update list-ref/update)
+ (ra:map map)
+ (ra:for-each for-each)
+ (ra:random-access-list->linear-access-list
+ random-access-list->linear-access-list)
+ (ra:linear-access-list->random-access-list
+ linear-access-list->random-access-list)))
+
+ (import (rnrs base)
+ (rnrs lists)
+ (rnrs control)
+ (rnrs hashtables)
+ (rnrs records syntactic)
+ (rnrs arithmetic bitwise))
+
+ (define-record-type kons (fields size tree rest))
+ (define-record-type node (fields val left right))
+
+ ;; Nat -> Nat
+ (define (sub1 n) (- n 1))
+ (define (add1 n) (+ n 1))
+
+ ;; [Tree X] -> X
+ (define (tree-val t)
+ (if (node? t)
+ (node-val t)
+ t))
+
+ ;; [X -> Y] [Tree X] -> [Tree Y]
+ (define (tree-map f t)
+ (if (node? t)
+ (make-node (f (node-val t))
+ (tree-map f (node-left t))
+ (tree-map f (node-right t)))
+ (f t)))
+
+ ;; [X -> Y] [Tree X] -> unspecified
+ (define (tree-for-each f t)
+ (if (node? t)
+ (begin (f (node-val t))
+ (tree-for-each f (node-left t))
+ (tree-for-each f (node-right t)))
+ (f t)))
+
+ ;; [X Y Z ... -> R] [List [Tree X] [Tree Y] [Tree Z] ...] -> [Tree R]
+ (define (tree-map/n f ts)
+ (let recr ((ts ts))
+ (if (and (pair? ts)
+ (node? (car ts)))
+ (make-node (apply f (map node-val ts))
+ (recr (map node-left ts))
+ (recr (map node-right ts)))
+ (apply f ts))))
+
+ ;; [X Y Z ... -> R] [List [Tree X] [Tree Y] [Tree Z] ...] -> unspecified
+ (define (tree-for-each/n f ts)
+ (let recr ((ts ts))
+ (if (and (pair? ts)
+ (node? (car ts)))
+ (begin (apply f (map node-val ts))
+ (recr (map node-left ts))
+ (recr (map node-right ts)))
+ (apply f ts))))
+
+ ;; Nat [Nat -> X] -> [Tree X]
+ ;; like build-list, but for complete binary trees
+ (define (build-tree i f) ;; i = 2^j-1
+ (let rec ((i i) (o 0))
+ (if (= 1 i)
+ (f o)
+ (let ((i/2 (half i)))
+ (make-node (f o)
+ (rec i/2 (add1 o))
+ (rec i/2 (+ 1 o i/2)))))))
+
+ ;; Consumes n = 2^i-1 and produces 2^(i-1)-1.
+ ;; Nat -> Nat
+ (define (half n)
+ (bitwise-arithmetic-shift n -1))
+
+ ;; Nat X -> [Tree X]
+ (define (tr:make-tree i x) ;; i = 2^j-1
+ (let recr ((i i))
+ (if (= 1 i)
+ x
+ (let ((n (recr (half i))))
+ (make-node x n n)))))
+
+ ;; Nat [Tree X] Nat [X -> X] -> X [Tree X]
+ (define (tree-ref/update mid t i f)
+ (cond ((zero? i)
+ (if (node? t)
+ (values (node-val t)
+ (make-node (f (node-val t))
+ (node-left t)
+ (node-right t)))
+ (values t (f t))))
+ ((<= i mid)
+ (let-values (((v* t*) (tree-ref/update (half (sub1 mid))
+ (node-left t)
+ (sub1 i)
+ f)))
+ (values v* (make-node (node-val t) t* (node-right t)))))
+ (else
+ (let-values (((v* t*) (tree-ref/update (half (sub1 mid))
+ (node-right t)
+ (sub1 (- i mid))
+ f)))
+ (values v* (make-node (node-val t) (node-left t) t*))))))
+
+ ;; Special-cased above to avoid logarathmic amount of cons'ing
+ ;; and any multi-values overhead. Operates in constant space.
+ ;; [Tree X] Nat Nat -> X
+ ;; invariant: (= mid (half (sub1 (tree-count t))))
+ (define (tree-ref/a t i mid)
+ (cond ((zero? i) (tree-val t))
+ ((<= i mid)
+ (tree-ref/a (node-left t)
+ (sub1 i)
+ (half (sub1 mid))))
+ (else
+ (tree-ref/a (node-right t)
+ (sub1 (- i mid))
+ (half (sub1 mid))))))
+
+ ;; Nat [Tree X] Nat -> X
+ ;; invariant: (= size (tree-count t))
+ (define (tree-ref size t i)
+ (if (zero? i)
+ (tree-val t)
+ (tree-ref/a t i (half (sub1 size)))))
+
+ ;; Nat [Tree X] Nat [X -> X] -> [Tree X]
+ (define (tree-update size t i f)
+ (let recr ((mid (half (sub1 size))) (t t) (i i))
+ (cond ((zero? i)
+ (if (node? t)
+ (make-node (f (node-val t))
+ (node-left t)
+ (node-right t))
+ (f t)))
+ ((<= i mid)
+ (make-node (node-val t)
+ (recr (half (sub1 mid))
+ (node-left t)
+ (sub1 i))
+ (node-right t)))
+ (else
+ (make-node (node-val t)
+ (node-left t)
+ (recr (half (sub1 mid))
+ (node-right t)
+ (sub1 (- i mid))))))))
+
+ ;; ------------------------
+ ;; Random access lists
+
+ ;; [RaListof X]
+ (define ra:null (quote ()))
+
+ ;; [Any -> Boolean]
+ (define ra:pair? kons?)
+
+ ;; [Any -> Boolean]
+ (define ra:null? null?)
+
+ ;; X [RaListof X] -> [RaListof X] /\
+ ;; X Y -> [RaPair X Y]
+ (define (ra:cons x ls)
+ (if (kons? ls)
+ (let ((s (kons-size ls)))
+ (if (and (kons? (kons-rest ls))
+ (= (kons-size (kons-rest ls))
+ s))
+ (make-kons (+ 1 s s)
+ (make-node x
+ (kons-tree ls)
+ (kons-tree (kons-rest ls)))
+ (kons-rest (kons-rest ls)))
+ (make-kons 1 x ls)))
+ (make-kons 1 x ls)))
+
+
+ ;; [RaPair X Y] -> X Y
+ (define ra:car+cdr
+ (lambda (p)
+ (assert (kons? p))
+ (if (node? (kons-tree p))
+ (let ((s* (half (kons-size p))))
+ (values (tree-val (kons-tree p))
+ (make-kons s*
+ (node-left (kons-tree p))
+ (make-kons s*
+ (node-right (kons-tree p))
+ (kons-rest p)))))
+ (values (kons-tree p) (kons-rest p)))))
+
+ ;; [RaPair X Y] -> X
+ (define (ra:car p)
+ (call-with-values (lambda () (ra:car+cdr p))
+ (lambda (car cdr) car)))
+
+ ;; [RaPair X Y] -> Y
+ (define (ra:cdr p)
+ (call-with-values (lambda () (ra:car+cdr p))
+ (lambda (car cdr) cdr)))
+
+ ;; [RaListof X] Nat [X -> X] -> X [RaListof X]
+ (define (ra:list-ref/update ls i f)
+ ;(assert (< i (ra:length ls)))
+ (let recr ((xs ls) (j i))
+ (if (< j (kons-size xs))
+ (let-values (((v* t*)
+ (tree-ref/update (half (sub1 (kons-size xs)))
+ (kons-tree xs) j f)))
+ (values v* (make-kons (kons-size xs)
+ t*
+ (kons-rest xs))))
+ (let-values (((v* r*)
+ (recr (kons-rest xs)
+ (- j (kons-size xs)))))
+ (values v* (make-kons (kons-size xs)
+ (kons-tree xs)
+ r*))))))
+
+ ;; [RaListof X] Nat [X -> X] -> [RaListof X]
+ (define (ra:list-update ls i f)
+ ;(assert (< i (ra:length ls)))
+ (let recr ((xs ls) (j i))
+ (let ((s (kons-size xs)))
+ (if (< j s)
+ (make-kons s (tree-update s (kons-tree xs) j f) (kons-rest xs))
+ (make-kons s (kons-tree xs) (recr (kons-rest xs) (- j s)))))))
+
+ ;; [RaListof X] Nat X -> (values X [RaListof X])
+ (define (ra:list-ref/set ls i v)
+ (ra:list-ref/update ls i (lambda (_) v)))
+
+ ;; X ... -> [RaListof X]
+ (define (ra:list . xs)
+ (fold-right ra:cons ra:null xs))
+
+ ;; Nat X -> [RaListof X]
+ (define ra:make-list
+ (case-lambda
+ ((k) (ra:make-list k 0))
+ ((k obj)
+ (let loop ((n k) (a ra:null))
+ (cond ((zero? n) a)
+ (else
+ (let ((t (largest-skew-binary n)))
+ (loop (- n t)
+ (make-kons t (tr:make-tree t obj) a)))))))))
+
+ ;; A Skew is a Nat 2^k-1 with k > 0.
+
+ ;; Skew -> Skew
+ (define (skew-succ t) (add1 (bitwise-arithmetic-shift t 1)))
+
+ ;; Computes the largest skew binary term t <= n.
+ ;; Nat -> Skew
+ (define (largest-skew-binary n)
+ (if (= 1 n)
+ 1
+ (let* ((t (largest-skew-binary (half n)))
+ (s (skew-succ t)))
+ (if (> s n) t s))))
+
+ ;; [Any -> Boolean]
+ ;; Is x a PROPER list?
+ (define (ra:list? x)
+ (or (ra:null? x)
+ (and (kons? x)
+ (ra:list? (kons-rest x)))))
+
+ (define ra:caar (lambda (ls) (ra:car (ra:car ls))))
+ (define ra:cadr (lambda (ls) (ra:car (ra:cdr ls))))
+ (define ra:cddr (lambda (ls) (ra:cdr (ra:cdr ls))))
+ (define ra:cdar (lambda (ls) (ra:cdr (ra:car ls))))
+
+ (define ra:caaar (lambda (ls) (ra:car (ra:car (ra:car ls)))))
+ (define ra:caadr (lambda (ls) (ra:car (ra:car (ra:cdr ls)))))
+ (define ra:caddr (lambda (ls) (ra:car (ra:cdr (ra:cdr ls)))))
+ (define ra:cadar (lambda (ls) (ra:car (ra:cdr (ra:car ls)))))
+ (define ra:cdaar (lambda (ls) (ra:cdr (ra:car (ra:car ls)))))
+ (define ra:cdadr (lambda (ls) (ra:cdr (ra:car (ra:cdr ls)))))
+ (define ra:cdddr (lambda (ls) (ra:cdr (ra:cdr (ra:cdr ls)))))
+ (define ra:cddar (lambda (ls) (ra:cdr (ra:cdr (ra:car ls)))))
+
+ (define ra:caaaar (lambda (ls) (ra:car (ra:car (ra:car (ra:car ls))))))
+ (define ra:caaadr (lambda (ls) (ra:car (ra:car (ra:car (ra:cdr ls))))))
+ (define ra:caaddr (lambda (ls) (ra:car (ra:car (ra:cdr (ra:cdr ls))))))
+ (define ra:caadar (lambda (ls) (ra:car (ra:car (ra:cdr (ra:car ls))))))
+ (define ra:cadaar (lambda (ls) (ra:car (ra:cdr (ra:car (ra:car ls))))))
+ (define ra:cadadr (lambda (ls) (ra:car (ra:cdr (ra:car (ra:cdr ls))))))
+ (define ra:cadddr (lambda (ls) (ra:car (ra:cdr (ra:cdr (ra:cdr ls))))))
+ (define ra:caddar (lambda (ls) (ra:car (ra:cdr (ra:cdr (ra:car ls))))))
+ (define ra:cdaaar (lambda (ls) (ra:cdr (ra:car (ra:car (ra:car ls))))))
+ (define ra:cdaadr (lambda (ls) (ra:cdr (ra:car (ra:car (ra:cdr ls))))))
+ (define ra:cdaddr (lambda (ls) (ra:cdr (ra:car (ra:cdr (ra:cdr ls))))))
+ (define ra:cdadar (lambda (ls) (ra:cdr (ra:car (ra:cdr (ra:car ls))))))
+ (define ra:cddaar (lambda (ls) (ra:cdr (ra:cdr (ra:car (ra:car ls))))))
+ (define ra:cddadr (lambda (ls) (ra:cdr (ra:cdr (ra:car (ra:cdr ls))))))
+ (define ra:cddddr (lambda (ls) (ra:cdr (ra:cdr (ra:cdr (ra:cdr ls))))))
+ (define ra:cdddar (lambda (ls) (ra:cdr (ra:cdr (ra:cdr (ra:car ls))))))
+
+ ;; [RaList X] -> Nat
+ (define (ra:length ls)
+ (assert (ra:list? ls))
+ (let recr ((ls ls))
+ (if (kons? ls)
+ (+ (kons-size ls) (recr (kons-rest ls)))
+ 0)))
+
+ (define (make-foldl empty? first rest)
+ (letrec ((f (lambda (cons empty ls)
+ (if (empty? ls)
+ empty
+ (f cons
+ (cons (first ls) empty)
+ (rest ls))))))
+ f))
+
+ (define (make-foldr empty? first rest)
+ (letrec ((f (lambda (cons empty ls)
+ (if (empty? ls)
+ empty
+ (cons (first ls)
+ (f cons empty (rest ls)))))))
+ f))
+
+ ;; [X Y -> Y] Y [RaListof X] -> Y
+ (define ra:foldl/1 (make-foldl ra:null? ra:car ra:cdr))
+ (define ra:foldr/1 (make-foldr ra:null? ra:car ra:cdr))
+
+ ;; [RaListof X] ... -> [RaListof X]
+ (define (ra:append . lss)
+ (cond ((null? lss) ra:null)
+ (else (let recr ((lss lss))
+ (cond ((null? (cdr lss)) (car lss))
+ (else (ra:foldr/1 ra:cons
+ (recr (cdr lss))
+ (car lss))))))))
+
+ ;; [RaListof X] -> [RaListof X]
+ (define (ra:reverse ls)
+ (ra:foldl/1 ra:cons ra:null ls))
+
+ ;; [RaListof X] Nat -> [RaListof X]
+ (define (ra:list-tail ls i)
+ (let loop ((xs ls) (j i))
+ (cond ((zero? j) xs)
+ (else (loop (ra:cdr xs) (sub1 j))))))
+
+ ;; [RaListof X] Nat -> X
+ ;; Special-cased above to avoid logarathmic amount of cons'ing
+ ;; and any multi-values overhead. Operates in constant space.
+ (define (ra:list-ref ls i)
+ ;(assert (< i (ra:length ls)))
+ (let loop ((xs ls) (j i))
+ (if (< j (kons-size xs))
+ (tree-ref (kons-size xs) (kons-tree xs) j)
+ (loop (kons-rest xs) (- j (kons-size xs))))))
+
+ ;; [RaListof X] Nat X -> [RaListof X]
+ (define (ra:list-set ls i v)
+ (let-values (((_ l*) (ra:list-ref/set ls i v))) l*))
+
+ ;; [X ... -> y] [RaListof X] ... -> [RaListof Y]
+ ;; Takes advantage of the fact that map produces a list of equal size.
+ (define ra:map
+ (case-lambda
+ ((f ls)
+ (let recr ((ls ls))
+ (if (kons? ls)
+ (make-kons (kons-size ls)
+ (tree-map f (kons-tree ls))
+ (recr (kons-rest ls)))
+ ra:null)))
+ ((f . lss)
+ ;(check-nary-loop-args 'ra:map (lambda (x) x) f lss)
+ (let recr ((lss lss))
+ (cond ((ra:null? (car lss)) ra:null)
+ (else
+ ;; IMPROVE ME: make one pass over lss.
+ (make-kons (kons-size (car lss))
+ (tree-map/n f (map kons-tree lss))
+ (recr (map kons-rest lss)))))))))
+
+
+ ;; [X ... -> Y] [RaListof X] ... -> unspecified
+ (define ra:for-each
+ (case-lambda
+ ((f ls)
+ (when (kons? ls)
+ (tree-for-each f (kons-tree ls))
+ (ra:for-each f (kons-rest ls))))
+ ((f . lss)
+ ;(check-nary-loop-args 'ra:map (lambda (x) x) f lss)
+ (let recr ((lss lss))
+ (when (ra:pair? (car lss))
+ (tree-map/n f (map kons-tree lss))
+ (recr (map kons-rest lss)))))))
+
+ ;; [RaListof X] -> [Listof X]
+ (define (ra:random-access-list->linear-access-list x)
+ (ra:foldr/1 cons '() x))
+
+ ;; [Listof X] -> [RaListof X]
+ (define (ra:linear-access-list->random-access-list x)
+ (fold-right ra:cons '() x))
+
+ ;; This code based on code written by Abdulaziz Ghuloum
+ ;; http://ikarus-scheme.org/pipermail/ikarus-users/2009-September/000595.html
+ (define get-cached
+ (let ((h (make-eq-hashtable)))
+ (lambda (x)
+ (define (f x)
+ (cond
+ ((pair? x) (ra:cons (f (car x)) (f (cdr x))))
+ ((vector? x) (vector-map f x))
+ (else x)))
+ (cond
+ ((not (or (pair? x) (vector? x))) x)
+ ((hashtable-ref h x #f))
+ (else
+ (let ((v (f x)))
+ (hashtable-set! h x v)
+ v))))))
+
+ (define-syntax ra:quote
+ (syntax-rules ()
+ ((ra:quote datum) (get-cached 'datum))))
+
+
+ ) ; (srfi :101 random-access-lists)
View
197 s101/srfi-101-tests.sps
@@ -0,0 +1,197 @@
+#!r6rs
+;; 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).
+
+;; To run:
+;; cp srfi-101.sls srfi/%3A101.sls
+;; ikarus --r6rs-script srfi-101-tests.sls
+;; larceny -r6rs -path . -program srfi-101-tests.sls
+;; plt-r6rs ++path . srfi-101-tests.sls
+
+(import (except (rnrs base)
+ quote pair? cons car cdr
+ caar cadr cddr cdar
+ caaar caadr caddr cadar
+ cdaar cdadr cdddr cddar
+ caaaar caaadr caaddr caadar
+ cadaar cadadr cadddr caddar
+ cdaaar cdaadr cdaddr cdadar
+ cddaar cddadr cddddr cdddar
+ null? list? list length
+ append reverse list-tail
+ list-ref map for-each)
+ (prefix (rnrs base) r6:)
+ (rnrs exceptions)
+ (surfage s101 random-access-lists))
+
+(define (check-expect c e)
+ (if (pair? c)
+ (begin (assert (pair? e))
+ (check-expect (car c)
+ (car e))
+ (check-expect (cdr c)
+ (cdr e)))
+ (assert (equal? c e))))
+
+(define-syntax check-error
+ (syntax-rules ()
+ ((_ e)
+ (let ((f (cons 0 0)))
+ (guard (g ((eq? f g) (assert #f))
+ (else 'OK))
+ (begin e
+ (raise f)))))))
+
+; quote
+
+; Bug in Larceny prevents this from working
+; https://trac.ccs.neu.edu/trac/larceny/ticket/656
+;(check-expect (quote 5) (r6:quote 5))
+;(check-expect (quote x) (r6:quote x))
+
+(check-expect (let ((f (lambda () '(x))))
+ (eq? (f) (f)))
+ #t)
+
+(check-expect '(1 2 3) (list 1 2 3))
+
+; pair?
+(check-expect (pair? (cons 'a 'b)) #t)
+(check-expect (pair? (list 'a 'b 'c)) #t)
+(check-expect (pair? '()) #f)
+(check-expect (pair? '#(a b)) #f)
+
+; cons
+(check-expect (cons 'a '()) (list 'a))
+(check-expect (cons (list 'a) (list 'b 'c 'd))
+ (list (list 'a) 'b 'c 'd))
+(check-expect (cons "a" (list 'b 'c))
+ (list "a" 'b 'c))
+(check-expect (cons 'a 3)
+ (cons 'a 3))
+(check-expect (cons (list 'a 'b) 'c)
+ (cons (list 'a 'b) 'c))
+
+; car
+(check-expect (car (list 'a 'b 'c))
+ 'a)
+(check-expect (car (list (list 'a) 'b 'c 'd))
+ (list 'a))
+(check-expect (car (cons 1 2)) 1)
+(check-error (car '()))
+
+; cdr
+(check-expect (cdr (list (list 'a) 'b 'c 'd))
+ (list 'b 'c 'd))
+(check-expect (cdr (cons 1 2))
+ 2)
+(check-error (cdr '()))
+
+; null?
+(check-expect (eq? null? r6:null?) #t)
+(check-expect (null? '()) #t)
+(check-expect (null? (cons 1 2)) #f)
+(check-expect (null? 4) #f)
+
+; list?
+(check-expect (list? (list 'a 'b 'c)) #t)
+(check-expect (list? '()) #t)
+(check-expect (list? (cons 'a 'b)) #f)
+
+; list
+(check-expect (list 'a (+ 3 4) 'c)
+ (list 'a 7 'c))
+(check-expect (list) '())
+
+; make-list
+(check-expect (length (make-list 5)) 5)
+(check-expect (make-list 5 0)
+ (list 0 0 0 0 0))
+
+; length
+(check-expect (length (list 'a 'b 'c)) 3)
+(check-expect (length (list 'a (list 'b) (list 'c))) 3)
+(check-expect (length '()) 0)
+
+; append
+(check-expect (append (list 'x) (list 'y)) (list 'x 'y))
+(check-expect (append (list 'a) (list 'b 'c 'd)) (list 'a 'b 'c 'd))
+(check-expect (append (list 'a (list 'b)) (list (list 'c)))
+ (list 'a (list 'b) (list 'c)))
+(check-expect (append (list 'a 'b) (cons 'c 'd))
+ (cons 'a (cons 'b (cons 'c 'd))))
+(check-expect (append '() 'a) 'a)
+
+; reverse
+(check-expect (reverse (list 'a 'b 'c))
+ (list 'c 'b 'a))
+(check-expect (reverse (list 'a (list 'b 'c) 'd (list 'e (list 'f))))
+ (list (list 'e (list 'f)) 'd (list 'b 'c) 'a))
+
+; list-tail
+(check-expect (list-tail (list 'a 'b 'c 'd) 2)
+ (list 'c 'd))
+
+; list-ref
+(check-expect (list-ref (list 'a 'b 'c 'd) 2) 'c)
+
+; list-set
+(check-expect (list-set (list 'a 'b 'c 'd) 2 'x)
+ (list 'a 'b 'x 'd))
+
+; list-ref/update
+(let-values (((a b)
+ (list-ref/update (list 7 8 9 10) 2 -)))
+ (check-expect a 9)
+ (check-expect b (list 7 8 -9 10)))
+
+; map
+(check-expect (map cadr (list (list 'a 'b) (list 'd 'e) (list 'g 'h)))
+ (list 'b 'e 'h))
+(check-expect (map (lambda (n) (expt n n))
+ (list 1 2 3 4 5))
+ (list 1 4 27 256 3125))
+(check-expect (map + (list 1 2 3) (list 4 5 6))
+ (list 5 7 9))
+
+; for-each
+(check-expect (let ((v (make-vector 5)))
+ (for-each (lambda (i)
+ (vector-set! v i (* i i)))
+ (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 (random-access-list->linear-access-list '()) '())
+(check-expect (linear-access-list->random-access-list '()) '())
+
+(check-expect (random-access-list->linear-access-list (list 1 2 3))
+ (r6:list 1 2 3))
+
+(check-expect (linear-access-list->random-access-list (r6:list 1 2 3))
+ (list 1 2 3))
Please sign in to comment.
Something went wrong with that request. Please try again.