Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-06 20:56:38 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Add array-fold-{left|right}

Browse source 
My tests pass, and I believe that your tests pass.
This commit is contained in:
Bradley Lucier 2024-05-28 04:09:35 -04:00
parent 78a990c73b
commit 1dd84df451
3 changed files with 78 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
lib/srfi/231.sld
View file

@ -45,8 +45,8 @@
array-safe? array-packed? specialized-array-share array-safe? array-packed? specialized-array-share
array-copy array-curry array-extract array-tile array-translate array-copy array-curry array-extract array-tile array-translate
array-permute array-reverse array-sample array-permute array-reverse array-sample
array-outer-product array-map array-for-each array-foldl array-outer-product array-map array-for-each array-fold-left
array-foldr array-reduce array-any array-every array-fold-right array-reduce array-any array-every
array-inner-product array-stack array-append array-block array-inner-product array-stack array-append array-block
array->list list->array array->vector vector->array array->list list->array array->vector vector->array
array->list* list*->array array->vector* vector*->array array->list* list*->array array->vector* vector*->array

42
lib/srfi/231/test.sld
View file

@ -204,7 +204,7 @@
(error "array-display can't handle > 2 dimensions: " A)))) (error "array-display can't handle > 2 dimensions: " A))))
(define (myindexer= indexer1 indexer2 interval) (define (myindexer= indexer1 indexer2 interval)
(array-foldl (lambda (x y) (and x y)) (array-fold-left (lambda (x y) (and x y))
#t #t
(make-array interval (make-array interval
(lambda args (lambda args
@ -221,7 +221,7 @@
(define (myarray= array1 array2) (define (myarray= array1 array2)
(and (interval= (array-domain array1) (and (interval= (array-domain array1)
(array-domain array2)) (array-domain array2))
(array-foldl (lambda (vs result) (array-fold-left (lambda (vs result)
(and (equal? (car vs) (and (equal? (car vs)
(cadr vs)) (cadr vs))
result)) result))
@ -677,7 +677,7 @@
;;(define test-pgm (read-pgm "girl.pgm")) ;;(define test-pgm (read-pgm "girl.pgm"))
(define (array-dot-product a b) (define (array-dot-product a b)
(array-foldl (lambda (x y) (array-fold-left (lambda (x y)
(+ x y)) (+ x y))
0 0
(array-map (array-map
@ -708,7 +708,7 @@
(make-array (make-array
result-domain result-domain
(lambda (i j) (lambda (i j)
(array-foldl (array-fold-left
(lambda (p q) (lambda (p q)
(+ p q)) (+ p q))
0 0
@ -737,9 +737,9 @@
(max 0 (min (exact (round pixel)) max-grey))) (max 0 (min (exact (round pixel)) max-grey)))
(define (array-sum a) (define (array-sum a)
(array-foldl + 0 a)) (array-fold-left + 0 a))
(define (array-max a) (define (array-max a)
(array-foldl max -inf.0 a)) (array-fold-left max -inf.0 a))
(define (max-norm a) (define (max-norm a)
(array-max (array-map abs a))) (array-max (array-map abs a)))
@ -1921,10 +1921,10 @@
;; (test-assert (indices-in-proper-order (reverse arguments-2))) ;; (test-assert (indices-in-proper-order (reverse arguments-2)))
;; )) ;; ))
(test-error (array-foldl 1 1 1)) (test-error (array-fold-left 1 1 1))
(test-error (array-foldl list 1 1)) (test-error (array-fold-left list 1 1))
(test-error (array-foldr 1 1 1)) (test-error (array-fold-right 1 1 1))
(test-error (array-foldr list 1 1)) (test-error (array-fold-right list 1 1))
(test-error (array-for-each 1 #f)) (test-error (array-for-each 1 #f))
(test-error (array-for-each list 1 (make-array (make-interval '#(3) '#(4)) (test-error (array-for-each list 1 (make-array (make-interval '#(3) '#(4))
list))) list)))
@ -2112,10 +2112,10 @@
0 1) 0 1)
(matrix 1 0 (matrix 1 0
i 1)))))) i 1))))))
(test (array-foldr x2x2-multiply (matrix 1 0 0 1) A) (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A)
(array-reduce x2x2-multiply A)) (array-reduce x2x2-multiply A))
(test-not (equal? (array-reduce x2x2-multiply A) (test-not (equal? (array-reduce x2x2-multiply A)
(array-foldl x2x2-multiply (matrix 1 0 0 1) A)))) (array-fold-left x2x2-multiply (matrix 1 0 0 1) A))))
(let ((A_2 (make-array (make-interval '#(1 1) '#(3 7)) (let ((A_2 (make-array (make-interval '#(1 1) '#(3 7))
(lambda (i j) (lambda (i j)
@ -2124,10 +2124,10 @@
j 1) j 1)
(matrix 1 j (matrix 1 j
i -1)))))) i -1))))))
(test (array-foldr x2x2-multiply (matrix 1 0 0 1) A_2) (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A_2)
(array-reduce x2x2-multiply A_2)) (array-reduce x2x2-multiply A_2))
(test-not (equal? (array-reduce x2x2-multiply A_2) (test-not (equal? (array-reduce x2x2-multiply A_2)
(array-foldl x2x2-multiply (matrix 1 0 0 1) A_2))) (array-fold-left x2x2-multiply (matrix 1 0 0 1) A_2)))
(test-not (equal? (array-reduce x2x2-multiply A_2) (test-not (equal? (array-reduce x2x2-multiply A_2)
(array-reduce x2x2-multiply (array-rotate A_2 1))))) (array-reduce x2x2-multiply (array-rotate A_2 1)))))
@ -2138,10 +2138,10 @@
j k) j k)
(matrix k j (matrix k j
i -1)))))) i -1))))))
(test (array-foldr x2x2-multiply (matrix 1 0 0 1) A_3) (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A_3)
(array-reduce x2x2-multiply A_3)) (array-reduce x2x2-multiply A_3))
(test-not (equal? (array-reduce x2x2-multiply A_3) (test-not (equal? (array-reduce x2x2-multiply A_3)
(array-foldl x2x2-multiply (matrix 1 0 0 1) A_3))) (array-fold-left x2x2-multiply (matrix 1 0 0 1) A_3)))
(test-not (equal? (array-reduce x2x2-multiply A_3) (test-not (equal? (array-reduce x2x2-multiply A_3)
(array-reduce x2x2-multiply (array-rotate A_3 1))))) (array-reduce x2x2-multiply (array-rotate A_3 1)))))
@ -2152,10 +2152,10 @@
j k) j k)
(matrix l k (matrix l k
i j)))))) i j))))))
(test (array-foldr x2x2-multiply (matrix 1 0 0 1) A_4) (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A_4)
(array-reduce x2x2-multiply A_4)) (array-reduce x2x2-multiply A_4))
(test-not (equal? (array-reduce x2x2-multiply A_4) (test-not (equal? (array-reduce x2x2-multiply A_4)
(array-foldl x2x2-multiply (matrix 1 0 0 1) A_4))) (array-fold-left x2x2-multiply (matrix 1 0 0 1) A_4)))
(test-not (equal? (array-reduce x2x2-multiply A_4) (test-not (equal? (array-reduce x2x2-multiply A_4)
(array-reduce x2x2-multiply (array-rotate A_4 1))))) (array-reduce x2x2-multiply (array-rotate A_4 1)))))
@ -2166,10 +2166,10 @@
j k) j k)
(matrix (- l m) k (matrix (- l m) k
i j)))))) i j))))))
(test (array-foldr x2x2-multiply (matrix 1 0 0 1) A_5) (test (array-fold-right x2x2-multiply (matrix 1 0 0 1) A_5)
(array-reduce x2x2-multiply A_5)) (array-reduce x2x2-multiply A_5))
(test-not (equal? (array-reduce x2x2-multiply A_5) (test-not (equal? (array-reduce x2x2-multiply A_5)
(array-foldl x2x2-multiply (matrix 1 0 0 1) A_5))) (array-fold-left x2x2-multiply (matrix 1 0 0 1) A_5)))
(test-not (equal? (array-reduce x2x2-multiply A_5) (test-not (equal? (array-reduce x2x2-multiply A_5)
(array-reduce x2x2-multiply (array-rotate A_5 1))))) (array-reduce x2x2-multiply (array-rotate A_5 1)))))
@ -3897,7 +3897,7 @@
;; (pgm-pixels test-pgm) ;; (pgm-pixels test-pgm)
;; edge-filter)))) ;; edge-filter))))
;; (max-pixel ;; (max-pixel
;; (array-foldl max 0 edge-array)) ;; (array-fold-left max 0 edge-array))
;; (normalizer ;; (normalizer
;; (inexact (/ greys max-pixel)))) ;; (inexact (/ greys max-pixel))))
;; (write-pgm ;; (write-pgm

34
lib/srfi/231/transforms.scm
View file

@ -388,6 +388,40 @@
(define (array-foldr kons knil array) (define (array-foldr kons knil array)
(fold-right kons knil (array->list array))) (fold-right kons knil (array->list array)))
(define (array-fold-left operator identity array . arrays)
(assert (and (procedure? operator)
(array? array)
(every array? arrays)
(every (lambda (a) (interval= (array-domain array) a)) arrays)))
(if (null? array)
(interval-fold-left (array-getter array)
(lambda (accumulator array-element)
(operator accumulator array-element))
identity
(array-domain array))
(interval-fold-left (array-getter (apply array-map list array arrays))
(lambda (accumulator array-elements)
(apply operator accumulator array-elements))
identity
(array-domain array))))
(define (array-fold-right operator identity array . arrays)
(assert (and (procedure? operator)
(array? array)
(every array? arrays)
(every (lambda (a) (interval= (array-domain array) a)) arrays)))
(if (null? arrays)
(interval-fold-right (array-getter array)
(lambda (array-element accumulator)
(operator array-element accumulator))
identity
(array-domain array))
(interval-fold-right (array-getter (apply array-map list array arrays))
(lambda (array-elements accumulator)
(apply operator (append array-elements (list accumulator))))
identity
(array-domain array))))
(define (array-reduce op array) (define (array-reduce op array)
(let* ((domain (array-domain array)) (let* ((domain (array-domain array))
(init-index (interval-lower-bounds->list domain)) (init-index (interval-lower-bounds->list domain))