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

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

add types for -copy & -fold

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
39(: array-copy (array -> array))
40(: array-fold (procedure * #!rest array -> *))
41
42(include "arraymap")
43
44(define (array-copy src)
45  (let ((dst (apply make-array src (array-dimensions src))))
46    (array:copy! dst src)
47    dst ) )
48
49(define (array-fold proc seed . ras)
50  (let rafo ((rdims (array-dimensions (car ras))) (inds '()))
51    (if (null? (cdr rdims))
52      (let* (
53        (sdni (reverse (cons #f inds)))
54        (lastpair (last-pair sdni)) )
55        (do ((i 0 (+ 1 i)))
56            ((> i (+ -1 (car rdims))))
57          (set-car! lastpair i)
58          (set! seed (apply proc seed (map (lambda (x) (apply array-ref x sdni)) ras))) ) )
59      (let (
60        (crdims (cdr rdims))
61        (ll (+ -1 (car rdims))) )
62        (do ((i 0 (+ 1 i)))
63            ((> i ll))
64          (rafo crdims (cons i inds)) ) ) ) )
65  seed )
66
67) ;module slib-arraymap
Note: See TracBrowser for help on using the repository browser.