source: project/release/5/slib-arraymap/trunk/slib-arraymap.scm @ 38545

Last change on this file since 38545 was 38545, checked in by Kon Lovett, 6 months ago

*-test runner, style

File size: 1.6 KB
Line 
1;;; slib-arraymap.scm  -*- Scheme -*-
2
3(module slib-arraymap
4
5(;export
6  array-map!
7  array-map
8  array-for-each
9  array-indexes
10  array-index-for-each
11  array-index-map!
12  array:copy!
13  array-copy
14  array-fold)
15
16(import scheme)
17(import (chicken module))
18(import (only (chicken base) include identity sub1 add1 cut))
19(import (chicken type))
20(import (only (srfi 1) last-pair))
21(import (srfi 63))
22
23;; Types
24
25(define-type array-strict (struct array))                            ;SRFI 63
26(define-type array (or string vector array-strict))
27
28(: array-map! (array (#!rest -> *) #!rest array -> void))
29(: array-map (array (#!rest -> *) #!rest array -> array))
30(: array-for-each ((#!rest -> void) #!rest array -> void))
31(: array-indexes (array -> array))
32(: array-index-for-each (array (#!rest -> void) -> void))
33(: array-index-map! (array (#!rest -> *) -> void))
34(: array:copy! (array array -> void))
35(: array-copy (array -> array))
36
37(include "arraymap")
38
39(define (array-copy src)
40  (let ((dst (apply make-array src (array-dimensions src))))
41    (array:copy! dst src)
42    dst ) )
43
44(define (array-fold proc seed . ras)
45  (let rafo ((rdims (array-dimensions (car ras))) (inds '()))
46    (if (null? (cdr rdims))
47      (let* (
48        (sdni (reverse (cons #f inds)))
49        (lastpair (last-pair sdni)) )
50        (do ((i 0 (add1 i)))
51            ((> i (sub1 (car rdims))))
52          (set-car! lastpair i)
53          (set! seed (apply proc seed (map (cut apply array-ref <> sdni) ras))) ) )
54      (let (
55        (crdims (cdr rdims))
56        (ll (sub1 (car rdims))) )
57        (do ((i 0 (add1 i)))
58            ((> i ll))
59          (rafo crdims (cons i inds)) ) ) ) )
60  seed )
61
62) ;module slib-arraymap
Note: See TracBrowser for help on using the repository browser.