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

Last change on this file since 38719 was 38719, checked in by Kon Lovett, 4 months ago

add common slib-compat

File size: 1.7 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))
19(import (chicken type))
20(import (srfi 63))
21
22;;;
23
24(include "slib-compat")
25
26;; Types
27
28(define-type array-strict (struct array))                            ;SRFI 63
29(define-type array (or string vector array-strict))
30
31(: array-map! (array (#!rest -> *) #!rest array -> void))
32(: array-map (array (#!rest -> *) #!rest array -> array))
33(: array-for-each ((#!rest -> void) #!rest array -> void))
34(: array-indexes (array -> array))
35(: array-index-for-each (array (#!rest -> void) -> void))
36(: array-index-map! (array (#!rest -> *) -> void))
37(: array:copy! (array array -> void))
38(: array-copy (array -> array))
39
40(include "arraymap")
41
42(define (array-copy src)
43  (let ((dst (apply make-array src (array-dimensions src))))
44    (array:copy! dst src)
45    dst ) )
46
47(define (array-fold proc seed . ras)
48  (import (only (chicken base) sub1 add1 cut))
49  (let rafo ((rdims (array-dimensions (car ras))) (inds '()))
50    (if (null? (cdr rdims))
51      (let* (
52        (sdni (reverse (cons #f inds)))
53        (lastpair (last-pair sdni)) )
54        (do ((i 0 (add1 i)))
55            ((> i (sub1 (car rdims))))
56          (set-car! lastpair i)
57          (set! seed (apply proc seed (map (cut apply array-ref <> sdni) ras))) ) )
58      (let (
59        (crdims (cdr rdims))
60        (ll (sub1 (car rdims))) )
61        (do ((i 0 (add1 i)))
62            ((> i ll))
63          (rafo crdims (cons i inds)) ) ) ) )
64  seed )
65
66) ;module slib-arraymap
Note: See TracBrowser for help on using the repository browser.