123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213 |
- (import (ploy ploy) (ploy slices) (ploy basic) (srfi srfi-9) (ice-9 match)
- (srfi srfi-1) (srfi srfi-11) (ploy test) (srfi srfi-26) (srfi srfi-8))
- (define (complement-list k l)
- (let loop ((i 0) (l l) (r '()))
- (cond ((= i k) r)
- ((null? l) (append! r (iota (- k i) i)))
- ((< i (car l)) (loop (+ (car l) 1) (cdr l) (append! r (iota (- (car l) i) i))))
- ((= i (car l)) (loop (+ i 1) (cdr l) r))
- (else (error "bad arguments")))))
- (define (subrank-copy*! b z . i)
- (let ((li (length i)))
- (cond ((= (rank b) li)
- (apply array-set! b z i))
- ((zero? (rank z))
- (array-fill! (apply array-from b i) z))
- (else
- (ply (verb (cut array-amend! <> <>) #f (rank z) '_)
- (apply array-from b i) z)))))
- (define (subrank-copy! b z . i)
- (let ((li (length i)))
- (if (= (rank b) li)
- (apply array-set! b z i)
- (apply array-amend! b (extend-left z (drop ($ b) li)) i))))
- (define A (i. 4))
- (amend! A #(a b c d))
- (T-msg "bad amend! 0-0" A #(a b c d))
- (define A (i. 4))
- (amend! A #(a b c) #(3 0 2))
- (T-msg "bad amend! 0-1" A #(b 1 c a))
- (define A (i. 2 2))
- (amend! A #2((a b) (c d)))
- (T-msg "bad amend! 0-2" A #2((a b) (c d)))
- (define A (i. 4 4))
- (amend! A #2((a b) (c d)) #(0 1) #(0 1))
- (T-msg "bad amend! 0-3" A #2((a b 2 3) (c d 6 7) (8 9 10 11) (12 13 14 15)))
- (define A (i. 4 4))
- (amend! A #2((a b) (c d)) #(1 3) #(0 2))
- (T-msg "bad amend! 0-4" A #2((0 1 2 3) (a 5 b 7) (8 9 10 11) (c 13 d 15)))
- (define A (i. 2 2 2))
- (amend! A #3(((a b) (c d)) ((e f) (g h))) #(1 0) #(1 0) #(1 0))
- (T-msg "bad amend! 0-5" A (reverse. (reverse. (reverse. #3(((a b) (c d)) ((e f) (g h))) 0) 1) 2))
- (define A (i. 4 4))
- (amend! A #(a b c d) #(3 2 0 1) 1)
- (T-msg "bad amend! 1-0" A #2((0 c 2 3) (4 d 6 7) (8 b 10 11) (12 a 14 15)))
- (define A (i. 2 2))
- (amend! A #2((a)) #(0) #(1))
- (T-msg "bad amend! 1-1" A #2((0 a) (2 3)))
- (define A (i. 2 2))
- (amend! A #(a) 0 #(1))
- (T-msg "bad amend! 1-2" A #2((0 a) (2 3)))
- (define A (i. 2 2))
- (amend! A #(a) #(0) 1)
- (T-msg "bad amend! 1-3" A #2((0 a) (2 3)))
- (define A (i. 2 2))
- (amend! A 'a 0 1)
- (T-msg "bad amend! 1-4" A #2((0 a) (2 3)))
- (define A (i. 2 2))
- (amend! A #0(a) 0 1)
- (T-msg "bad amend! 1-5" A #2((0 a) (2 3)))
- (define A (i. 2 2))
- (amend! A #2((a b)) #(0) #t)
- (T-msg "bad amend! 2-0" A #2((a b) (2 3)))
- (define A (i. 2 2))
- (amend! A #2((a) (b)) #t #(0))
- (T-msg "bad amend! 2-1" A #2((a 1) (b 3)))
- (define A (i. 2 2))
- (amend! A #(a b) 0 #t)
- (T-msg "bad amend! 2-2" A #2((a b) (2 3)))
- (define A (i. 2 2))
- (amend! A #(a b) #t 0)
- (T-msg "bad amend! 2-3" A #2((a 1) (b 3)))
- (define A (i. 4))
- (from A #2((3 1) (2 0)))
- (amend! A #2((a b) (c d)) #2((3 1) (2 0)))
- (T-msg "bad amend! 3-0" A #(d b c a))
- (define A (i. 1 4))
- (from A #t #2((3 1) (2 0)))
- (amend! A #3(((a b) (c d))) #t #2((3 1) (2 0)))
- (T-msg "bad amend! 4-0" A #2((d b c a)))
- (define A (i. 2 3))
- (subrank-copy! A #(a b c))
- (T-msg "bad subrank-copy! 0" A #2((a b c) (a b c)))
- (define A (i. 2 3))
- (subrank-copy! A 'a)
- (T-msg "bad subrank-copy! 1" A #2((a a a) (a a a)))
- (define A (i. 2 3))
- (subrank-copy*! A #0(a))
- (T-msg "bad subrank-copy! 2" A #2((#0(a) #0(a) #0(a)) (#0(a) #0(a) #0(a))))
- (define A (i. 2 3))
- (subrank-copy! A #0(a))
- (T-msg "bad subrank-copy! 3" A #2((a a a) (a a a)))
- (define A (i. 2 3))
- (subrank-copy! A #(a b c) 1)
- (T-msg "bad subrank-copy! 4" A #2((0 1 2) (a b c)))
- (define A (i. 2 3))
- (subrank-copy! A 'a 1)
- (T-msg "bad subrank-copy! 5" A #2((0 1 2) (a a a)))
- (define A (i. 2 3))
- (subrank-copy! A 'a 1 1)
- (T-msg "bad subrank-copy! 6" A #2((0 1 2) (3 a 5)))
- (define A (i. 2 3))
- (subrank-copy! A #(a b) 1 1)
- (T-msg "bad subrank-copy! 7" A #2((0 1 2) (3 #(a b) 5)))
- (define A (i. 4))
- (amend! A 'a)
- (T-msg "bad amend! 5-0" A #(a a a a))
- (define A (i. 4 4))
- (amend! A 'a)
- (T-msg "bad amend! 5-1" A (reshape 'a 4 4))
- (define A (i. 4 4))
- (amend! A #(a b c d))
- (T-msg "bad amend! 5-2" A (reshape #(a b c d) 4 4))
- (define A (i. 4 4))
- (amend! A #2((a b c) (d e f) (g h i) (j k l)) #t (J 3))
- (T-msg "bad amend! 5-3" A #2((a b c 3) (d e f 7) (g h i 11) (j k l 15)))
- (define A (i. 4 4))
- (amend! A #(a b c) #t (J 3))
- (T-msg "bad amend! 5-4" A #2((a b c 3) (a b c 7) (a b c 11) (a b c 15)))
- (define A (i. 1 4))
- (from A #t #2((3 1) (2 0)))
- (amend! A #2((a b) (c d)) #t #2((3 1) (2 0)))
- (T-msg "bad amend! 5-6" A #2((d b c a)))
- (T #(a b) (amend! (make-array 0 2) #(a b) #(0 1)))
- (T #(a b) (amend! (make-array 0 2) #(a b)))
- (T #(a a) (amend! (make-array 0 2) 'a))
- (T #2((a b) (a b)) (amend! (make-array 0 2 2) #(a b)))
- (T #2((a b) (a b)) (amend! (make-array 0 2 2) #(a b) #(0 1)))
- (T #(a a) (amend! (make-array 0 2) 'a #(0 1)))
- (T #(9 9 9) (amend! (make-array 9 3) 'a #()))
- (T #2((a 0) (a 0)) (amend! (make-array 0 2 2) 'a #(0 1) #(0)))
|