Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Add s101

  • Loading branch information...
commit 6758b3b95e634fea9c6ea5803ff968b9494cf8c5 1 parent 2c3d015
dharmatech authored March 20, 2010
504  s101/random-access-lists.sls
... ...
@@ -0,0 +1,504 @@
  1
+#!r6rs
  2
+;; SRFI 101: Purely Functional Random-Access Pairs and Lists
  3
+;; Copyright (c) David Van Horn 2009.  All Rights Reserved.
  4
+
  5
+;; Permission is hereby granted, free of charge, to any person obtaining
  6
+;; a copy of this software and associated documentation
  7
+;; files (the "Software"), to deal in the Software without restriction,
  8
+;; including without limitation the rights to use, copy, modify, merge,
  9
+;; publish, distribute, sublicense, and/or sell copies of the Software,
  10
+;; and to permit persons to whom the Software is furnished to do so,
  11
+;; subject to the following conditions:
  12
+
  13
+;; The above copyright notice and this permission notice shall be
  14
+;; included in all copies or substantial portions of the Software.
  15
+
  16
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  17
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  18
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  19
+;; NONINFRINGEMENT. REMEMBER, THERE IS NO SCHEME UNDERGROUND. IN NO EVENT
  20
+;; SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
  21
+;; DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
  22
+;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
  23
+;; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  24
+
  25
+(library (surfage s101 random-access-lists)
  26
+  (export (rename (ra:quote quote)
  27
+                  (ra:pair? pair?) 
  28
+                  (ra:cons cons)
  29
+                  (ra:car car) 
  30
+                  (ra:cdr cdr)
  31
+                  (ra:caar caar) 
  32
+                  (ra:cadr cadr)
  33
+                  (ra:cddr cddr)
  34
+                  (ra:cdar cdar)
  35
+                  (ra:caaar caaar)
  36
+                  (ra:caadr caadr)
  37
+                  (ra:caddr caddr)
  38
+                  (ra:cadar cadar)
  39
+                  (ra:cdaar cdaar)
  40
+                  (ra:cdadr cdadr)
  41
+                  (ra:cdddr cdddr)
  42
+                  (ra:cddar cddar)
  43
+                  (ra:caaaar caaaar)
  44
+                  (ra:caaadr caaadr)
  45
+                  (ra:caaddr caaddr)
  46
+                  (ra:caadar caadar)
  47
+                  (ra:cadaar cadaar)
  48
+                  (ra:cadadr cadadr)
  49
+                  (ra:cadddr cadddr)
  50
+                  (ra:caddar caddar)
  51
+                  (ra:cdaaar cdaaar)
  52
+                  (ra:cdaadr cdaadr)
  53
+                  (ra:cdaddr cdaddr)
  54
+                  (ra:cdadar cdadar)
  55
+                  (ra:cddaar cddaar)
  56
+                  (ra:cddadr cddadr)
  57
+                  (ra:cddddr cddddr)
  58
+                  (ra:cdddar cdddar)
  59
+                  (ra:null? null?)
  60
+                  (ra:list? list?)
  61
+                  (ra:list list)
  62
+                  (ra:make-list make-list)
  63
+                  (ra:length length)
  64
+                  (ra:append append)
  65
+                  (ra:reverse reverse)
  66
+                  (ra:list-tail list-tail)
  67
+                  (ra:list-ref list-ref)
  68
+                  (ra:list-set list-set)
  69
+                  (ra:list-ref/update list-ref/update)
  70
+                  (ra:map map)
  71
+                  (ra:for-each for-each)
  72
+                  (ra:random-access-list->linear-access-list
  73
+                   random-access-list->linear-access-list)
  74
+                  (ra:linear-access-list->random-access-list
  75
+                   linear-access-list->random-access-list)))
  76
+  
  77
+  (import (rnrs base)
  78
+          (rnrs lists)
  79
+          (rnrs control)
  80
+          (rnrs hashtables)
  81
+          (rnrs records syntactic)
  82
+          (rnrs arithmetic bitwise))          
  83
+  
  84
+  (define-record-type kons (fields size tree rest))
  85
+  (define-record-type node (fields val left right)) 
  86
+
  87
+  ;; Nat -> Nat
  88
+  (define (sub1 n) (- n 1))
  89
+  (define (add1 n) (+ n 1))
  90
+    
  91
+  ;; [Tree X] -> X
  92
+  (define (tree-val t)
  93
+    (if (node? t) 
  94
+        (node-val t)
  95
+        t))
  96
+  
  97
+  ;; [X -> Y] [Tree X] -> [Tree Y]
  98
+  (define (tree-map f t)
  99
+    (if (node? t)
  100
+        (make-node (f (node-val t))
  101
+                   (tree-map f (node-left t))
  102
+                   (tree-map f (node-right t)))
  103
+        (f t)))
  104
+
  105
+  ;; [X -> Y] [Tree X] -> unspecified
  106
+  (define (tree-for-each f t)
  107
+    (if (node? t)
  108
+        (begin (f (node-val t))
  109
+               (tree-for-each f (node-left t))
  110
+               (tree-for-each f (node-right t)))
  111
+        (f t)))
  112
+
  113
+  ;; [X Y Z ... -> R] [List [Tree X] [Tree Y] [Tree Z] ...] -> [Tree R]
  114
+  (define (tree-map/n f ts)
  115
+    (let recr ((ts ts))
  116
+      (if (and (pair? ts)
  117
+               (node? (car ts)))
  118
+          (make-node (apply f (map node-val ts))
  119
+                     (recr (map node-left ts))
  120
+                     (recr (map node-right ts)))
  121
+          (apply f ts))))
  122
+  
  123
+  ;; [X Y Z ... -> R] [List [Tree X] [Tree Y] [Tree Z] ...] -> unspecified
  124
+  (define (tree-for-each/n f ts)
  125
+    (let recr ((ts ts))
  126
+      (if (and (pair? ts)
  127
+               (node? (car ts)))
  128
+          (begin (apply f (map node-val ts))
  129
+                 (recr (map node-left ts))
  130
+                 (recr (map node-right ts)))
  131
+          (apply f ts))))
  132
+  
  133
+  ;; Nat [Nat -> X] -> [Tree X]
  134
+  ;; like build-list, but for complete binary trees
  135
+  (define (build-tree i f) ;; i = 2^j-1
  136
+    (let rec ((i i) (o 0))
  137
+      (if (= 1 i) 
  138
+          (f o)
  139
+          (let ((i/2 (half i)))
  140
+            (make-node (f o)
  141
+                       (rec i/2 (add1 o))
  142
+                       (rec i/2 (+ 1 o i/2)))))))
  143
+  
  144
+  ;; Consumes n = 2^i-1 and produces 2^(i-1)-1.
  145
+  ;; Nat -> Nat
  146
+  (define (half n)
  147
+    (bitwise-arithmetic-shift n -1))
  148
+
  149
+  ;; Nat X -> [Tree X]
  150
+  (define (tr:make-tree i x) ;; i = 2^j-1
  151
+    (let recr ((i i))
  152
+      (if (= 1 i) 
  153
+          x
  154
+          (let ((n (recr (half i))))
  155
+            (make-node x n n)))))
  156
+  
  157
+  ;; Nat [Tree X] Nat [X -> X] -> X [Tree X]
  158
+  (define (tree-ref/update mid t i f)
  159
+    (cond ((zero? i)
  160
+           (if (node? t) 
  161
+               (values (node-val t)
  162
+                       (make-node (f (node-val t))
  163
+                                  (node-left t)
  164
+                                  (node-right t)))
  165
+               (values t (f t))))
  166
+          ((<= i mid)
  167
+           (let-values (((v* t*) (tree-ref/update (half (sub1 mid)) 
  168
+                                                  (node-left t) 
  169
+                                                  (sub1 i) 
  170
+                                                  f)))
  171
+             (values v* (make-node (node-val t) t* (node-right t)))))
  172
+          (else           
  173
+           (let-values (((v* t*) (tree-ref/update (half (sub1 mid)) 
  174
+                                                  (node-right t) 
  175
+                                                  (sub1 (- i mid)) 
  176
+                                                  f)))
  177
+             (values v* (make-node (node-val t) (node-left t) t*))))))
  178
+  
  179
+  ;; Special-cased above to avoid logarathmic amount of cons'ing
  180
+  ;; and any multi-values overhead.  Operates in constant space.
  181
+  ;; [Tree X] Nat Nat -> X
  182
+  ;; invariant: (= mid (half (sub1 (tree-count t))))
  183
+  (define (tree-ref/a t i mid) 
  184
+    (cond ((zero? i) (tree-val t))
  185
+          ((<= i mid) 
  186
+           (tree-ref/a (node-left t) 
  187
+                       (sub1 i) 
  188
+                       (half (sub1 mid))))
  189
+          (else 
  190
+           (tree-ref/a (node-right t) 
  191
+                       (sub1 (- i mid)) 
  192
+                       (half (sub1 mid))))))
  193
+  
  194
+  ;; Nat [Tree X] Nat -> X
  195
+  ;; invariant: (= size (tree-count t))
  196
+  (define (tree-ref size t i)
  197
+    (if (zero? i)
  198
+        (tree-val t)
  199
+        (tree-ref/a t i (half (sub1 size)))))
  200
+  
  201
+  ;; Nat [Tree X] Nat [X -> X] -> [Tree X]
  202
+  (define (tree-update size t i f)
  203
+    (let recr ((mid (half (sub1 size))) (t t) (i i))
  204
+      (cond ((zero? i)
  205
+             (if (node? t)
  206
+                 (make-node (f (node-val t))
  207
+                            (node-left t)
  208
+                            (node-right t))
  209
+                 (f t)))
  210
+            ((<= i mid)
  211
+             (make-node (node-val t) 
  212
+                        (recr (half (sub1 mid))
  213
+                              (node-left t) 
  214
+                              (sub1 i)) 
  215
+                        (node-right t)))
  216
+            (else
  217
+             (make-node (node-val t) 
  218
+                        (node-left t) 
  219
+                        (recr (half (sub1 mid))
  220
+                              (node-right t) 
  221
+                              (sub1 (- i mid))))))))
  222
+
  223
+  ;; ------------------------
  224
+  ;; Random access lists
  225
+  
  226
+  ;; [RaListof X]
  227
+  (define ra:null (quote ()))
  228
+
  229
+  ;; [Any -> Boolean]
  230
+  (define ra:pair? kons?)
  231
+  
  232
+  ;; [Any -> Boolean]
  233
+  (define ra:null? null?)
  234
+  
  235
+  ;; X [RaListof X] -> [RaListof X]  /\
  236
+  ;; X Y -> [RaPair X Y]
  237
+  (define (ra:cons x ls)
  238
+    (if (kons? ls)
  239
+        (let ((s (kons-size ls)))
  240
+          (if (and (kons? (kons-rest ls))
  241
+                   (= (kons-size (kons-rest ls))
  242
+                      s))
  243
+              (make-kons (+ 1 s s) 
  244
+                         (make-node x 
  245
+                                    (kons-tree ls)
  246
+                                    (kons-tree (kons-rest ls)))
  247
+                         (kons-rest (kons-rest ls)))
  248
+              (make-kons 1 x ls)))
  249
+        (make-kons 1 x ls)))
  250
+
  251
+  
  252
+  ;; [RaPair X Y] -> X Y
  253
+  (define ra:car+cdr 
  254
+    (lambda (p)
  255
+      (assert (kons? p))
  256
+      (if (node? (kons-tree p))
  257
+          (let ((s* (half (kons-size p))))
  258
+            (values (tree-val (kons-tree p))
  259
+                    (make-kons s* 
  260
+                               (node-left (kons-tree p))
  261
+                               (make-kons s*
  262
+                                          (node-right (kons-tree p))
  263
+                                          (kons-rest p)))))
  264
+          (values (kons-tree p) (kons-rest p)))))
  265
+  
  266
+  ;; [RaPair X Y] -> X
  267
+  (define (ra:car p)
  268
+    (call-with-values (lambda () (ra:car+cdr p))
  269
+                      (lambda (car cdr) car)))
  270
+  
  271
+  ;; [RaPair X Y] -> Y
  272
+  (define (ra:cdr p)
  273
+    (call-with-values (lambda () (ra:car+cdr p))
  274
+                      (lambda (car cdr) cdr)))
  275
+  
  276
+  ;; [RaListof X] Nat [X -> X] -> X [RaListof X]
  277
+  (define (ra:list-ref/update ls i f)
  278
+    ;(assert (< i (ra:length ls)))
  279
+    (let recr ((xs ls) (j i))
  280
+      (if (< j (kons-size xs))
  281
+          (let-values (((v* t*) 
  282
+                        (tree-ref/update (half (sub1 (kons-size xs))) 
  283
+                                         (kons-tree xs) j f)))
  284
+            (values v* (make-kons (kons-size xs) 
  285
+                                  t* 
  286
+                                  (kons-rest xs))))
  287
+          (let-values (((v* r*) 
  288
+                        (recr (kons-rest xs) 
  289
+                              (- j (kons-size xs)))))
  290
+            (values v* (make-kons (kons-size xs) 
  291
+                                  (kons-tree xs) 
  292
+                                  r*))))))
  293
+  
  294
+  ;; [RaListof X] Nat [X -> X] -> [RaListof X]
  295
+  (define (ra:list-update ls i f)
  296
+    ;(assert (< i (ra:length ls)))
  297
+    (let recr ((xs ls) (j i))
  298
+      (let ((s (kons-size xs)))
  299
+        (if (< j s) 
  300
+            (make-kons s (tree-update s (kons-tree xs) j f) (kons-rest xs))
  301
+            (make-kons s (kons-tree xs) (recr (kons-rest xs) (- j s)))))))
  302
+
  303
+  ;; [RaListof X] Nat X -> (values X [RaListof X])
  304
+  (define (ra:list-ref/set ls i v)
  305
+    (ra:list-ref/update ls i (lambda (_) v)))
  306
+
  307
+  ;; X ... -> [RaListof X]
  308
+  (define (ra:list . xs)
  309
+    (fold-right ra:cons ra:null xs))
  310
+
  311
+  ;; Nat X -> [RaListof X]
  312
+  (define ra:make-list
  313
+    (case-lambda
  314
+     ((k) (ra:make-list k 0))
  315
+     ((k obj)
  316
+      (let loop ((n k) (a ra:null))
  317
+        (cond ((zero? n) a)
  318
+              (else 
  319
+               (let ((t (largest-skew-binary n)))
  320
+                 (loop (- n t)
  321
+                       (make-kons t (tr:make-tree t obj) a)))))))))
  322
+
  323
+  ;; A Skew is a Nat 2^k-1 with k > 0.
  324
+  
  325
+  ;; Skew -> Skew
  326
+  (define (skew-succ t) (add1 (bitwise-arithmetic-shift t 1)))
  327
+  
  328
+  ;; Computes the largest skew binary term t <= n.
  329
+  ;; Nat -> Skew
  330
+  (define (largest-skew-binary n)
  331
+    (if (= 1 n) 
  332
+        1
  333
+        (let* ((t (largest-skew-binary (half n)))
  334
+               (s (skew-succ t)))
  335
+          (if (> s n) t s))))  
  336
+
  337
+  ;; [Any -> Boolean]
  338
+  ;; Is x a PROPER list?
  339
+  (define (ra:list? x)
  340
+    (or (ra:null? x)
  341
+        (and (kons? x)
  342
+             (ra:list? (kons-rest x)))))
  343
+  
  344
+  (define ra:caar (lambda (ls) (ra:car (ra:car ls))))
  345
+  (define ra:cadr (lambda (ls) (ra:car (ra:cdr ls))))
  346
+  (define ra:cddr (lambda (ls) (ra:cdr (ra:cdr ls))))
  347
+  (define ra:cdar (lambda (ls) (ra:cdr (ra:car ls))))
  348
+    
  349
+  (define ra:caaar (lambda (ls) (ra:car (ra:car (ra:car ls)))))
  350
+  (define ra:caadr (lambda (ls) (ra:car (ra:car (ra:cdr ls)))))
  351
+  (define ra:caddr (lambda (ls) (ra:car (ra:cdr (ra:cdr ls)))))
  352
+  (define ra:cadar (lambda (ls) (ra:car (ra:cdr (ra:car ls)))))
  353
+  (define ra:cdaar (lambda (ls) (ra:cdr (ra:car (ra:car ls)))))
  354
+  (define ra:cdadr (lambda (ls) (ra:cdr (ra:car (ra:cdr ls)))))
  355
+  (define ra:cdddr (lambda (ls) (ra:cdr (ra:cdr (ra:cdr ls)))))
  356
+  (define ra:cddar (lambda (ls) (ra:cdr (ra:cdr (ra:car ls)))))
  357
+  
  358
+  (define ra:caaaar (lambda (ls) (ra:car (ra:car (ra:car (ra:car ls))))))
  359
+  (define ra:caaadr (lambda (ls) (ra:car (ra:car (ra:car (ra:cdr ls))))))
  360
+  (define ra:caaddr (lambda (ls) (ra:car (ra:car (ra:cdr (ra:cdr ls))))))
  361
+  (define ra:caadar (lambda (ls) (ra:car (ra:car (ra:cdr (ra:car ls))))))
  362
+  (define ra:cadaar (lambda (ls) (ra:car (ra:cdr (ra:car (ra:car ls))))))
  363
+  (define ra:cadadr (lambda (ls) (ra:car (ra:cdr (ra:car (ra:cdr ls))))))
  364
+  (define ra:cadddr (lambda (ls) (ra:car (ra:cdr (ra:cdr (ra:cdr ls))))))
  365
+  (define ra:caddar (lambda (ls) (ra:car (ra:cdr (ra:cdr (ra:car ls))))))
  366
+  (define ra:cdaaar (lambda (ls) (ra:cdr (ra:car (ra:car (ra:car ls))))))
  367
+  (define ra:cdaadr (lambda (ls) (ra:cdr (ra:car (ra:car (ra:cdr ls))))))
  368
+  (define ra:cdaddr (lambda (ls) (ra:cdr (ra:car (ra:cdr (ra:cdr ls))))))
  369
+  (define ra:cdadar (lambda (ls) (ra:cdr (ra:car (ra:cdr (ra:car ls))))))
  370
+  (define ra:cddaar (lambda (ls) (ra:cdr (ra:cdr (ra:car (ra:car ls))))))
  371
+  (define ra:cddadr (lambda (ls) (ra:cdr (ra:cdr (ra:car (ra:cdr ls))))))
  372
+  (define ra:cddddr (lambda (ls) (ra:cdr (ra:cdr (ra:cdr (ra:cdr ls))))))
  373
+  (define ra:cdddar (lambda (ls) (ra:cdr (ra:cdr (ra:cdr (ra:car ls))))))
  374
+  
  375
+  ;; [RaList X] -> Nat
  376
+  (define (ra:length ls)
  377
+    (assert (ra:list? ls))
  378
+    (let recr ((ls ls))
  379
+      (if (kons? ls)
  380
+          (+ (kons-size ls) (recr (kons-rest ls)))
  381
+          0)))
  382
+
  383
+  (define (make-foldl empty? first rest)
  384
+    (letrec ((f (lambda (cons empty ls)
  385
+                  (if (empty? ls) 
  386
+                      empty
  387
+                      (f cons
  388
+                         (cons (first ls) empty) 
  389
+                         (rest ls))))))
  390
+      f))
  391
+  
  392
+  (define (make-foldr empty? first rest)
  393
+    (letrec ((f (lambda (cons empty ls)
  394
+                  (if (empty? ls) 
  395
+                      empty
  396
+                      (cons (first ls)
  397
+                            (f cons empty (rest ls)))))))
  398
+      f))
  399
+
  400
+  ;; [X Y -> Y] Y [RaListof X] -> Y
  401
+  (define ra:foldl/1 (make-foldl ra:null? ra:car ra:cdr))
  402
+  (define ra:foldr/1 (make-foldr ra:null? ra:car ra:cdr))
  403
+
  404
+  ;; [RaListof X] ... -> [RaListof X]
  405
+  (define (ra:append . lss)
  406
+    (cond ((null? lss) ra:null)
  407
+          (else (let recr ((lss lss))
  408
+                  (cond ((null? (cdr lss)) (car lss))
  409
+                        (else (ra:foldr/1 ra:cons
  410
+                                          (recr (cdr lss))
  411
+                                          (car lss))))))))
  412
+  
  413
+  ;; [RaListof X] -> [RaListof X]
  414
+  (define (ra:reverse ls)
  415
+    (ra:foldl/1 ra:cons ra:null ls))
  416
+  
  417
+  ;; [RaListof X] Nat -> [RaListof X]
  418
+  (define (ra:list-tail ls i)
  419
+    (let loop ((xs ls) (j i))
  420
+      (cond ((zero? j) xs)
  421
+            (else (loop (ra:cdr xs) (sub1 j))))))
  422
+  
  423
+  ;; [RaListof X] Nat -> X
  424
+  ;; Special-cased above to avoid logarathmic amount of cons'ing
  425
+  ;; and any multi-values overhead.  Operates in constant space.
  426
+  (define (ra:list-ref ls i)
  427
+    ;(assert (< i (ra:length ls)))
  428
+    (let loop ((xs ls) (j i))
  429
+      (if (< j (kons-size xs))
  430
+          (tree-ref (kons-size xs) (kons-tree xs) j)
  431
+          (loop (kons-rest xs) (- j (kons-size xs))))))
  432
+  
  433
+  ;; [RaListof X] Nat X -> [RaListof X]
  434
+  (define (ra:list-set ls i v)
  435
+    (let-values (((_ l*) (ra:list-ref/set ls i v))) l*))
  436
+  
  437
+  ;; [X ... -> y] [RaListof X] ... -> [RaListof Y]
  438
+  ;; Takes advantage of the fact that map produces a list of equal size.
  439
+  (define ra:map
  440
+    (case-lambda 
  441
+      ((f ls)
  442
+       (let recr ((ls ls))
  443
+         (if (kons? ls)
  444
+             (make-kons (kons-size ls) 
  445
+                        (tree-map f (kons-tree ls)) 
  446
+                        (recr (kons-rest ls)))
  447
+             ra:null)))
  448
+      ((f . lss)
  449
+       ;(check-nary-loop-args 'ra:map (lambda (x) x) f lss)
  450
+       (let recr ((lss lss))
  451
+         (cond ((ra:null? (car lss)) ra:null)
  452
+               (else
  453
+                ;; IMPROVE ME: make one pass over lss.
  454
+                (make-kons (kons-size (car lss))
  455
+                           (tree-map/n f (map kons-tree lss))
  456
+                           (recr (map kons-rest lss)))))))))
  457
+
  458
+
  459
+  ;; [X ... -> Y] [RaListof X] ... -> unspecified
  460
+  (define ra:for-each
  461
+    (case-lambda 
  462
+      ((f ls)
  463
+       (when (kons? ls)
  464
+         (tree-for-each f (kons-tree ls))
  465
+         (ra:for-each f (kons-rest ls))))
  466
+      ((f . lss)
  467
+       ;(check-nary-loop-args 'ra:map (lambda (x) x) f lss)
  468
+       (let recr ((lss lss))
  469
+         (when (ra:pair? (car lss))
  470
+           (tree-map/n f (map kons-tree lss))
  471
+           (recr (map kons-rest lss)))))))
  472
+
  473
+  ;; [RaListof X] -> [Listof X]
  474
+  (define (ra:random-access-list->linear-access-list x)
  475
+    (ra:foldr/1 cons '() x))
  476
+
  477
+  ;; [Listof X] -> [RaListof X]
  478
+  (define (ra:linear-access-list->random-access-list x)
  479
+    (fold-right ra:cons '() x))
  480
+
  481
+  ;; This code based on code written by Abdulaziz Ghuloum
  482
+  ;; http://ikarus-scheme.org/pipermail/ikarus-users/2009-September/000595.html
  483
+  (define get-cached
  484
+    (let ((h (make-eq-hashtable)))
  485
+      (lambda (x)
  486
+        (define (f x)
  487
+          (cond
  488
+           ((pair? x) (ra:cons (f (car x)) (f (cdr x))))
  489
+           ((vector? x) (vector-map f x))
  490
+           (else x)))
  491
+        (cond
  492
+         ((not (or (pair? x) (vector? x))) x)
  493
+         ((hashtable-ref h x #f))
  494
+         (else
  495
+          (let ((v (f x)))
  496
+            (hashtable-set! h x v)
  497
+            v))))))
  498
+
  499
+  (define-syntax ra:quote
  500
+    (syntax-rules ()
  501
+      ((ra:quote datum) (get-cached 'datum)))) 
  502
+
  503
+      
  504
+  ) ; (srfi :101 random-access-lists)
197  s101/srfi-101-tests.sps
... ...
@@ -0,0 +1,197 @@
  1
+#!r6rs
  2
+;; SRFI 101: Purely Functional Random-Access Pairs and Lists
  3
+;; Copyright (c) David Van Horn 2009.  All Rights Reserved.
  4
+
  5
+;; Permission is hereby granted, free of charge, to any person obtaining
  6
+;; a copy of this software and associated documentation
  7
+;; files (the "Software"), to deal in the Software without restriction,
  8
+;; including without limitation the rights to use, copy, modify, merge,
  9
+;; publish, distribute, sublicense, and/or sell copies of the Software,
  10
+;; and to permit persons to whom the Software is furnished to do so,
  11
+;; subject to the following conditions:
  12
+
  13
+;; The above copyright notice and this permission notice shall be
  14
+;; included in all copies or substantial portions of the Software.
  15
+
  16
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  17
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  18
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  19
+;; NONINFRINGEMENT. REMEMBER, THERE IS NO SCHEME UNDERGROUND. IN NO EVENT
  20
+;; SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
  21
+;; DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
  22
+;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
  23
+;; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  24
+
  25
+;; This test suite has been successfully run on Ikarus (0.0.3),
  26
+;; Larceny (0.97), and PLT Scheme (4.2.1.7).
  27
+
  28
+;; To run:
  29
+;;    cp srfi-101.sls srfi/%3A101.sls
  30
+;;    ikarus --r6rs-script srfi-101-tests.sls
  31
+;;    larceny -r6rs -path . -program srfi-101-tests.sls
  32
+;;    plt-r6rs ++path . srfi-101-tests.sls
  33
+
  34
+(import (except (rnrs base)
  35
+                quote pair? cons car cdr 
  36
+                caar cadr cddr cdar
  37
+                caaar caadr caddr cadar
  38
+                cdaar cdadr cdddr cddar
  39
+                caaaar caaadr caaddr caadar
  40
+                cadaar cadadr cadddr caddar
  41
+                cdaaar cdaadr cdaddr cdadar
  42
+                cddaar cddadr cddddr cdddar
  43
+                null? list? list length 
  44
+                append reverse list-tail
  45
+                list-ref map for-each)
  46
+        (prefix (rnrs base) r6:)
  47
+        (rnrs exceptions)
  48
+        (surfage s101 random-access-lists))
  49
+
  50
+(define (check-expect c e)
  51
+  (if (pair? c)
  52
+      (begin (assert (pair? e))
  53
+             (check-expect (car c)
  54
+                           (car e))
  55
+             (check-expect (cdr c)
  56
+                           (cdr e)))
  57
+      (assert (equal? c e))))
  58
+
  59
+(define-syntax check-error
  60
+  (syntax-rules ()
  61
+    ((_ e)
  62
+     (let ((f (cons 0 0)))
  63
+       (guard (g ((eq? f g) (assert #f))
  64
+                 (else 'OK))
  65
+              (begin e
  66
+                     (raise f)))))))
  67
+
  68
+; quote  
  69
+
  70
+; Bug in Larceny prevents this from working
  71
+; https://trac.ccs.neu.edu/trac/larceny/ticket/656
  72
+;(check-expect (quote 5) (r6:quote 5))
  73
+;(check-expect (quote x) (r6:quote x))
  74
+
  75
+(check-expect (let ((f (lambda () '(x))))
  76
+                (eq? (f) (f)))
  77
+              #t)
  78
+
  79
+(check-expect '(1 2 3) (list 1 2 3))
  80
+
  81
+; pair?
  82
+(check-expect (pair? (cons 'a 'b)) #t)
  83
+(check-expect (pair? (list 'a 'b 'c)) #t)
  84
+(check-expect (pair? '()) #f)
  85
+(check-expect (pair? '#(a b)) #f)
  86
+
  87
+; cons
  88
+(check-expect (cons 'a '()) (list 'a))
  89
+(check-expect (cons (list 'a) (list 'b 'c 'd))
  90
+              (list (list 'a) 'b 'c 'd))
  91
+(check-expect (cons "a" (list 'b 'c))
  92
+              (list "a" 'b 'c))
  93
+(check-expect (cons 'a 3)
  94
+              (cons 'a 3))
  95
+(check-expect (cons (list 'a 'b) 'c)
  96
+              (cons (list 'a 'b) 'c))
  97
+
  98
+; car
  99
+(check-expect (car (list 'a 'b 'c))
  100
+              'a)
  101
+(check-expect (car (list (list 'a) 'b 'c 'd))
  102
+              (list 'a))
  103
+(check-expect (car (cons 1 2)) 1)
  104
+(check-error (car '()))
  105
+
  106
+; cdr
  107
+(check-expect (cdr (list (list 'a) 'b 'c 'd))
  108
+              (list 'b 'c 'd))
  109
+(check-expect (cdr (cons 1 2))
  110
+              2)
  111
+(check-error (cdr '()))
  112
+
  113
+; null?
  114
+(check-expect (eq? null? r6:null?) #t)
  115
+(check-expect (null? '()) #t)
  116
+(check-expect (null? (cons 1 2)) #f)
  117
+(check-expect (null? 4) #f)
  118
+
  119
+; list?
  120
+(check-expect (list? (list 'a 'b 'c)) #t)
  121
+(check-expect (list? '()) #t)
  122
+(check-expect (list? (cons 'a 'b)) #f)
  123
+
  124
+; list
  125
+(check-expect (list 'a (+ 3 4) 'c)
  126
+              (list 'a 7 'c))
  127
+(check-expect (list) '())
  128
+
  129
+; make-list
  130
+(check-expect (length (make-list 5)) 5)
  131
+(check-expect (make-list 5 0)
  132
+              (list 0 0 0 0 0))
  133
+
  134
+; length
  135
+(check-expect (length (list 'a 'b 'c)) 3)
  136
+(check-expect (length (list 'a (list 'b) (list 'c))) 3)
  137
+(check-expect (length '()) 0)
  138
+
  139
+; append
  140
+(check-expect (append (list 'x) (list 'y)) (list 'x 'y))
  141
+(check-expect (append (list 'a) (list 'b 'c 'd)) (list 'a 'b 'c 'd))
  142
+(check-expect (append (list 'a (list 'b)) (list (list 'c))) 
  143
+              (list 'a (list 'b) (list 'c)))
  144
+(check-expect (append (list 'a 'b) (cons 'c 'd)) 
  145
+              (cons 'a (cons 'b (cons 'c 'd))))
  146
+(check-expect (append '() 'a) 'a)
  147
+
  148
+; reverse
  149
+(check-expect (reverse (list 'a 'b 'c))
  150
+              (list 'c 'b 'a))
  151
+(check-expect (reverse (list 'a (list 'b 'c) 'd (list 'e (list 'f))))
  152
+              (list (list 'e (list 'f)) 'd (list 'b 'c) 'a))
  153
+
  154
+; list-tail
  155
+(check-expect (list-tail (list 'a 'b 'c 'd) 2)
  156
+              (list 'c 'd))
  157
+
  158
+; list-ref
  159
+(check-expect (list-ref (list 'a 'b 'c 'd) 2) 'c)
  160
+
  161
+; list-set
  162
+(check-expect (list-set (list 'a 'b 'c 'd) 2 'x)
  163
+              (list 'a 'b 'x 'd))
  164
+
  165
+; list-ref/update
  166
+(let-values (((a b) 
  167
+              (list-ref/update (list 7 8 9 10) 2 -)))
  168
+  (check-expect a 9)
  169
+  (check-expect b (list 7 8 -9 10)))
  170
+
  171
+; map
  172
+(check-expect (map cadr (list (list 'a 'b) (list 'd 'e) (list 'g 'h)))
  173
+              (list 'b 'e 'h))
  174
+(check-expect (map (lambda (n) (expt n n))
  175
+                   (list 1 2 3 4 5))
  176
+              (list 1 4 27 256 3125))
  177
+(check-expect (map + (list 1 2 3) (list 4 5 6))
  178
+              (list 5 7 9))
  179
+
  180
+; for-each
  181
+(check-expect (let ((v (make-vector 5)))
  182
+                (for-each (lambda (i)
  183
+                            (vector-set! v i (* i i)))
  184
+                          (list 0 1 2 3 4))
  185
+                v)
  186
+              '#(0 1 4 9 16))
  187
+
  188
+; random-access-list->linear-access-list
  189
+; linear-access-list->random-access-list
  190
+(check-expect (random-access-list->linear-access-list '()) '())
  191
+(check-expect (linear-access-list->random-access-list '()) '())
  192
+
  193
+(check-expect (random-access-list->linear-access-list (list 1 2 3))
  194
+              (r6:list 1 2 3))
  195
+
  196
+(check-expect (linear-access-list->random-access-list (r6:list 1 2 3))
  197
+              (list 1 2 3))

0 notes on commit 6758b3b

Please sign in to comment.
Something went wrong with that request. Please try again.