Artifact
daa3f9105dda54e05bf8ca7805521df8138b081c:
- File
srfi/s25/list.scm
— part of check-in
[80c8c83034]
at
2016-07-07 18:11:39
on branch trunk
— initial import
(user:
ovenpasta@pizzahack.eu
size: 26086)
;;; An identity matrix.
(define i_4
(let* ((i (make-array
(shape 0 4 0 4)
0))
(d (share-array i
(shape 0 4)
(lambda (k)
(values k k)))))
(do ((k 0 (+ k 1))) ((= k 4))
(array-set! d k 1))
i))
(past "i_4")
(or (array-equal? i_4
(tabulate-array
(shape 0 4 0 4)
(lambda (j k)
(if (= j k) 1 0))))
(error "failed to build i_4"))
(past "i_4 vs tabulate-array")
(or (array-equal? i_4
(array
(shape 0 4 0 4)
1 0 0 0
0 1 0 0
0 0 1 0
0 0 0 1))
(error "failed to array i_4"))
(past "i_4 vs array")
(or (array-equal? (share-array
i_4
(shape 0 4)
(lambda (k)
(values k k)))
(share-array
(array (shape) 1)
(shape 0 4)
(lambda (k)
(values))))
(error "failed to share diagonal of i_4 or cell of 1"))
(past "i_4 diagonal")
(or (array-equal? (share-array
i_4
(shape 0 4)
(lambda (k)
(values (- 3 k) k)))
(share-array
(array (shape) 0)
(shape 0 4)
(lambda (k)
(values))))
(error "failed to share codiagonal of i_4 or cell of 0"))
(past "i_4 codiagonal")
(or (array-equal? (share-array
i_4
(shape 0 2 0 2)
(lambda (j k)
(values (* 3 j) (* 3 k))))
(share-array
i_4
(shape 0 2 0 2)
(lambda (j k)
(values (+ j 1) (+ k 1)))))
(error "failed to share corners or center of i_4"))
(past "i_4 corners and center")
(or (array-equal? i_4 (transpose i_4))
(error "failed to transpose i_4"))
(past "i_4 transpose")
;;; Try a three dimensional transpose. This will also exercise matrix
;;; multiplication.
(define threed123
(array (shape 0 1 0 2 0 3)
'a 'b 'c
'd 'e 'f))
(past "threed123")
(define threed312
(array (shape 0 3 0 1 0 2)
'a 'd
'b 'e
'c 'f))
(past "threed312")
(define rot231 (list 1 2 0))
;; 0 1 0
;; 0 0 1
;; 1 0 0
(or (array-equal? threed123
(apply transpose threed312 rot231))
(error "failed to transpose three dimensions"))
(past "threed123 transpose")
;;; The frivolous board game exercises share of share of share.
;;; A three dimensional chess board with two phases: piece and colour
;;; of piece. Think of pieces in a cube with height, width and depth,
;;; and piece colours in a parallel cube. We put pink jays around and
;;; grey crows inside the board proper. Later we put in a blue rook.
(define board
(tabulate-array
(shape -1 9 -1 9 -1 9 0 2)
(lambda (t u v w)
(case w
((0) (if (and (< -1 u 8)
(< -1 v 8)
(< -1 t 8))
'crow
'jay))
((1) (if (and (< -1 u 8)
(< -1 v 8)
(< -1 t 8))
'grey
'pink))))))
(past "board")
;;; A cylinder with height 4, width 4, depth 6, both phases, centered
;;; inside the board. Top left front corner is at 0 0 0 of cylinder but
;;; 2 2 1 of board.
(define board-cylinder
(share-array
board
(shape 0 4 0 4 0 6 0 2)
(lambda (t u v w)
(values (+ t 2) (+ u 2) (+ v 1) w))))
(past "board-cylinder")
;;; The center cube with side 2 of the cylinder, hence of the board,
;;; with both phases. Top left corner is 0 0 0 of center but 1 1 2
;;; of cylinder and 3 3 3 of board.
(define board-center
(share-array
board-cylinder
(shape 0 2 0 2 0 2 0 2)
(lambda (t u v w)
(values (+ t 1) (+ u 1) (+ v 2) w))))
(past "board-center")
;;; Front face of center cube, in two dimensions plus phase. Top left
;;; corner is 0 0 of face but 0 0 0 of center and 1 1 2 of cylinder
;;; 3 3 3 of board.
(define board-face
(share-array
board-center
(shape 0 2 0 2 0 2)
(lambda (t u w)
(values t u 0 w))))
(past "board-face")
;;; Left side of face in three dimensions plus phase. Top is 0 0 0 of
;;; pillar but 0 0 of face and 0 0 0 of center and 1 1 2 of cylinder
;;; and 3 3 3 of board. Bottom is 1 0 0 of pillar but 1 0 of face and
;;; 1 0 0 of center and 2 1 2 of cylinder and 4 3 3 of board.
(define board-pillar
(share-array
board-face
(shape 0 2 0 1 0 1 0 2)
(lambda (t u v w)
(values t 0 w))))
(past "board-pillar")
;;; Pillar upside down. Now top 0 0 0 is 1 0 of face and 1 0 0 of center
;;; and 2 1 2 of cylinder and 4 3 3 of board.
(define board-reverse-pillar
(share-array
board-pillar
(shape 0 2 0 1 0 1 0 2)
(lambda (t u v w)
(values (- 1 t) u v w))))
(past "board-reverse-pillar")
;;; Bottom of pillar.
(define board-cubicle
(share-array
board-pillar
(shape 0 2)
(lambda (w)
(values 1 0 0 w))))
(past "board-cubicle")
;;; Top of upside down pair.
(define board-reverse-cubicle
(share-array
board-reverse-pillar
(shape 0 2)
(lambda (w)
(values 0 0 0 w))))
(past "board-reverse-cubicle")
;;; Piece phase of cubicle.
(define board-piece
(share-array
board-cubicle
(shape)
(lambda ()
(values 0))))
(past "board-piece")
;;; Colour phase of the other cubicle that is actually the same cubicle.
(define board-colour
(share-array
board-reverse-cubicle
(shape)
(lambda ()
(values 1))))
(past "board-colour")
;;; Put a blue rook at the bottom of the pillar and at the top of the
;;; upside pillar.
(array-set! board-piece 'rook)
(array-set! board-colour 'blue)
(past "array-set! to board-piece and board-colour")
;;; Build the same chess position directly.
(define board-two
(tabulate-array
(shape -1 9 -1 9 -1 9 0 2)
(lambda (t u v w)
(if (and (= t 4) (= u 3) (= v 3))
(case w
((0) 'rook)
((1) 'blue))
(case w
((0) (if (and (< -1 u 8)
(< -1 v 8)
(< -1 t 8))
'crow
'jay))
((1) (if (and (< -1 u 8)
(< -1 v 8)
(< -1 t 8))
'grey
'pink)))))))
(past "board-two")
(or (array-equal? board board-two)
(error "failed in three dimensional chess"))
(past "board vs board-two")
;;; Permute the dimensions of the chess board in two different ways.
;;; The transpose also exercises matrix multiplication.
(define board-three
(share-array
board-two
(shape 0 2 -1 9 -1 9 -1 9)
(lambda (w t u v)
(values t u v w))))
(past "board-three")
(or (array-equal? board-three
(transpose board-two 3 0 1 2))
;; 0 0 0 1
;; 1 0 0 0
;; 0 1 0 0
;; 0 0 1 0
(error "failed to permute chess board dimensions"))
(past "board-three vs transpose of board-two")
(or (array-equal? (share-array
board-two
(shape -1 9 0 2 -1 9 -1 9)
(lambda (t w u v)
(values t u v w)))
(transpose board-two 0 3 1 2))
;; 1 0 0 0
;; 0 0 0 1
;; 0 1 0 0
;; 0 0 1 0
(error "failed to permute chess board dimensions another way"))
(past "board-two versus transpose of board-two")
;;; Just see that empty share does not crash. No index is valid. Just by
;;; the way. There is nothing to be done with it.
(define board-nothing
(share-array
board
(shape 0 3 1 1 0 3)
(lambda (t u v)
(values 0 0 0))))
(or (array-equal? board-nothing (array (array-shape board-nothing)))
(error "board-nothing failed"))
(past "board-nothing")
;;; ---
(or (array-equal? (tabulate-array (shape 4 8 2 5 0 1) *)
(tabulate-array! (shape 4 8 2 5 0 1)
(lambda (v)
(* (vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)))
(vector * * *)))
(error "tabulate-array! with vector failed"))
(past "tabulate-array! with vector")
(or (array-equal? (tabulate-array (shape 4 8 2 5 0 1) *)
(let ((index (share-array (make-array (shape 0 2 0 3))
(shape 0 3)
(lambda (k) (values 1 k)))))
(tabulate-array! (shape 4 8 2 5 0 1)
(lambda (a)
(* (array-ref a 0)
(array-ref a 1)
(array-ref a 2)))
index)))
(error "tabulate-array! with array failed"))
(past "tabulate-array! with array")
;;; Sum of constants
(or (array-equal?
(array-map
+
(share-array (array (shape) 0) (shape 1 2 1 4) (lambda _ (values)))
(share-array (array (shape) 1) (shape 1 2 1 4) (lambda _ (values)))
(share-array (array (shape) 2) (shape 1 2 1 4) (lambda _ (values))))
(array (shape 1 2 1 4) 3 3 3))
(error "failed to map constants to their constant sum"))
(past "array-map sum")
;;; Multiplication table
(define four-by-four
(array (shape 0 4 0 4)
0 0 0 0
0 1 2 3
0 2 4 6
0 3 6 9))
(past "four-by-four")
(or (array-equal? four-by-four (tabulate-array (shape 0 4 0 4) *))
(error "failed to tabulate four by four"))
(past "four-by-four vs tabulate-array")
(or (array-equal?
four-by-four
(let ((table (make-array (shape 0 4 0 4) 19101)))
(array-retabulate! table (array-shape table) *)
table))
(error "failed to retabulate four by four simply"))
(past "four-by-four vs array-retabulate!")
(or (array-equal?
four-by-four
(let ((table (make-array (shape 0 4 0 4) 19101)))
(array-retabulate!
table
(shape 1 2 1 4)
(lambda (v)
(* (vector-ref v 0) (vector-ref v 1)))
(vector - -))
(array-retabulate!
table
(shape 2 4 0 4)
(lambda (a)
(* (array-ref a (vector 0)) (array-ref a (vector 1))))
(make-array (shape 0 2)))
(array-set! table 0 0 0)
(array-set! table (vector 0 1) 0)
(array-set! table (array (shape 0 2) 0 2) 0)
(shape-for-each
(shape 0 1 3 4)
(lambda (v)
(array-set! table v (vector-ref v 0)))
(vector - -))
(let ((arr (share-array
table
(shape 1 2 0 1 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8)
(lambda (r k . _)
(values r k)))))
(array-retabulate! arr (array-shape arr) *))
table))
(error "failed to retabulate four by four in a hard way"))
(past "four-by-four vs array-retabulate! on parts")
;;; An argument was missing in a call in arlib when
;;; shape-for-each was called without an index object.
(or (let ((em '()))
(shape-for-each
(shape 0 2 -2 0 0 1)
(lambda (u v w)
(set! em (cons (list u v w) em))))
(equal? (reverse em) '((0 -2 0) (0 -1 0) (1 -2 0) (1 -1 0))))
(error "shape-for-each without index object"))
(past "shape-for-each without index object")
;;; Exercise share-array/index!
(or (let ((arr (tabulate-array (shape 2 4 3 5 4 7) *)))
(array-equal? (share-array/index!
arr
(array-shape arr)
(lambda (v) v)
(vector * * *))
arr))
(error "share-array/index! with identity and vector failed"))
(past "share-array/index! with identity and vector")
(or (let ((arr (tabulate-array (shape 2 4 3 5 4 7) *))
(ind (share-array (make-array (shape 0 2 0 3))
(shape 0 3)
(lambda (k) (values 1 k)))))
(array-equal? (share-array/index!
arr
(array-shape arr)
(lambda (a) a) ind)
arr))
(error "share-array/index! with identity and array failed"))
(past "share-array/index! with identity and array")
(or (let ((arr (tabulate-array (shape 3 5 4 5 4 7) *))
(in (vector * *))
(out (array (shape 0 3) 4 * *)))
(array-equal? (share-array/index!
arr
(shape 4 5 4 7)
(lambda (in)
(array-set! out 1 (vector-ref in 0))
(array-set! out 2 (vector-ref in 1))
out)
in)
(share-array
arr
(shape 4 5 4 7)
(lambda (j k)
(values 4 j k)))))
(error "share-array/index! with vector in array out failed"))
(past "share-array/index! with vector in array out")
(or (let ((arr (tabulate-array (shape 3 5 4 5 4 7) *))
(in (array (shape 0 2) * *))
(out (vector 4 * *)))
(array-equal? (share-array/index!
arr
(shape 4 5 4 7)
(lambda (in)
(vector-set! out 1 (array-ref in 0))
(vector-set! out 2 (array-ref in 1))
out)
in)
(share-array
arr
(shape 4 5 4 7)
(lambda (j k)
(values 4 j k)))))
(error "share-array/index! with array in vector out failed"))
(past "share-array/index! with array in vector out")
(let ((x (array (shape 2 4 3 5 4 5 5 7 6 8)
10 11 12 13
20 21 22 23
30 31 32 33
40 41 42 43)))
(or (array-equal? (share-array/origin x 3 3 3 3 3)
(array-append 0 (array (shape 3 3
3 5
3 4
3 5
3 5))
x))
(error "share-array/origin against empty array-append failed"))
(or (array-equal? (share-array/origin x 3 3 3 3 3)
(array-append 3 (array (shape 3 5
3 5
3 4
3 3
3 5))
x))
(error "share-array/origin against empty array-append failed")))
(past "share-array/origin against empty array-append")
(let ((a* (make-array (shape 4 6 7 9 100 101) 'a))
(b* (make-array (shape 3 6 7 8 200 201) 'b))
(c* (make-array (shape 0 1 2 4 300 301) 'c)))
(or (array-equal? (array-append 1 (array-append 0 a* c*) b* b* b*)
(apply array (shape 4 7 7 12 100 101)
'(a a b b b
a a b b b
c c b b b)))
(error "array-append failed")))
(past "array-append")
(let ((a* (make-array (shape 4 6 7 9 100 101) 'a))
(b* (make-array (shape 3 6 7 8 200 201) 'b))
(c* (make-array (shape 0 1 2 4 300 301) 'c)))
(or (array-equal? (array-append 1 a* (transpose c* 1 0 2)
(array-append 0 (transpose b* 1 0 2)
(transpose b* 1 0 2)))
(apply array (shape 4 6 7 13 100 101)
'(a a c b b b
a a c b b b)))
(error "array-append with transpose failed")))
(past "array-append with transpose")
;;; Check that share-array/index! agrees with share-array.
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? m (share-array m (shape 1 3 1 3) values))
(error "share-array identity failed"))
(or (array-equal? m (share-array/index!
m (shape 1 3 1 3)
(lambda (x) x)
(vector * *)))
(error "share-array/index! identity with vector failed"))
(or (array-equal? m (share-array/index!
m (shape 1 3 1 3)
(lambda (x) x)
(make-array (shape 0 2))))
(error "share-array/index! identity with actor failed")))
(past "share-array/index! identity")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array
m (shape 1 3)
(lambda (r)
(values r 1)))
(share-array/index!
m (shape 1 3)
(lambda (x)
(vector (vector-ref x 0) 1))
(vector *)))
(error "share-array/index! 1-d column failed")))
(past "share-array/index! 1-d column")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array
m (shape 1 3 1 3)
(lambda (r k)
(values r 1)))
(share-array/index!
m (shape 1 3 1 3)
(lambda (x)
(vector (vector-ref x 0) 1))
(vector * *)))
(error "share-array/index! 2-d column failed")))
(past "share-array/index! 2-d column")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array
m (shape 1 3)
(lambda (k)
(values 1 k)))
(share-array/index!
m (shape 1 3)
(lambda (x)
(vector 1 (vector-ref x 0)))
(vector *)))
(error "share-array/index! 1-d row failed")))
(past "share-array/index! 1-d row")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array
m (shape 1 2 1 3)
(lambda (r k)
(values 1 k)))
(share-array/index!
m (shape 1 2 1 3)
(lambda (x)
(vector 1 (vector-ref x 1)))
(vector * *)))
(error "share-array/index! 2-d row failed")))
(past "share-array/index! 2-d row")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array
m (shape 1 3)
(lambda (r)
(values r r)))
(share-array/index!
m (shape 1 3)
(lambda (x)
(vector (vector-ref x 0) (vector-ref x 0)))
(vector *)))
(error "share-array/index! diagonal failed")))
(past "share-array/index! diagonal")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array
m (shape)
(lambda ()
(values 1 2)))
(share-array/index!
m (shape)
(lambda (x)
(vector 1 2))
(vector)))
(error "share-array/index! 0-d corner failed")))
(past "share-array/index! 0-d corner")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array
m (shape 1 2)
(lambda (_)
(values 1 2)))
(share-array/index!
m (shape 1 2)
(lambda (x)
(vector 1 2))
(vector *)))
(error "share-array/index! 1-d corner failed")))
(past "share-array/index! 1-d corner")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array
m (shape 1 2 1 2)
(lambda (r k)
(values 1 2)))
(share-array/index!
m (shape 1 2 1 2)
(lambda (x)
(vector 1 2))
(vector * *)))
(error "share-array/index! 2-d corner failed")))
(past "share-array/index! 2-d corner")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array/prefix m 1)
(share-array/index!
m (shape 1 3)
(lambda (x)
(vector 1 (vector-ref x 0)))
(vector *)))
(error "share-array/index! with prefix 1 failed")))
(past "share-array/{prefix,index!} 1")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array/prefix m (vector 1))
(share-array/index!
m (shape 1 3)
(lambda (x)
(vector 1 (vector-ref x 0)))
(vector *)))
(error "share-array/prefix with vector failed")))
(past "share-array/prefix with vector")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array/prefix m 2)
(share-array/index!
m (shape 1 3)
(lambda (x)
(vector 2 (vector-ref x 0)))
(vector *)))
(error "share-array/index! with prefix 2 failed")))
(past "share-array/{prefix,index!} 2")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array/prefix m (array (shape 0 1) 2))
(share-array/index!
m (shape 1 3)
(lambda (x)
(vector 2 (vector-ref x 0)))
(vector *)))
(error "share-array/prefix with array failed")))
(past "share-array/prefix with array")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array/prefix m)
(share-array/index!
m (shape 1 3 1 3)
(lambda (x) x)
(vector * *)))
(error "share-array/index! with empty prefix failed")))
(past "share-array/{prefix,index!} e")
(let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd)))
(or (array-equal? (share-array/prefix m 1 2)
(share-array/index!
m (shape)
(lambda (x)
(vector 1 2))
(vector)))
(error "share-array/index! with prefix 1 2 failed")))
(past "share-array/{prefix,index!} 1 2")
;;; Uh oh.
(let* ((hape (tabulate-array
(shape 0 57 0 2)
(lambda (r k)
(case k
((0) r)
((1) (case r
((0) (+ r 2))
((56) (+ r 4))
(else (+ r 1))))))))
(tape (tabulate-array
(shape 0 34 0 2)
(lambda (r k)
(case k
((0) (+ r 23))
((1) (case r
((33) (+ r 27))
(else (+ r 24))))))))
(long (make-vector 57 *))
(shot (make-vector 34 *))
(huge (tabulate-array!
hape
(lambda (ix) (vector-ref '#(a b) (vector-ref ix 0)))
long))
(tiny0 (share-array/index!
huge
tape
(begin
(do ((k 0 (+ k 1)))
((= k 23))
(vector-set! long k k))
(lambda (ix)
(do ((k 23 (+ k 1)))
((= k 57))
(vector-set! long k (vector-ref ix (- k 23))))
long))
shot))
(tiny1 (share-array/index!
huge
tape
(begin
(vector-set! long 0 1)
(do ((k 1 (+ k 1)))
((= k 23))
(vector-set! long k k))
(lambda (ix)
(do ((k 23 (+ k 1)))
((= k 57))
(vector-set! long k (vector-ref ix (- k 23))))
long))
shot)))
(or (and (equal? (array->vector huge) '#(a a a a b b b b))
(equal? (array->vector tiny0) '#(a a a a))
(equal? (array->vector tiny1) '#(b b b b)))
(error "share-array/index! failed huge or tiny contents"))
(or (array-equal? huge
(share-array/index!
(array (shape 4 6) 'a 'b)
hape
(lambda (ix)
(vector-ref '#(#(4) #(5)) (vector-ref ix 0)))
long))
(error "share-array/index! failed huge"))
(or (array-equal? tiny0
(share-array/index!
(array (shape 6 7) 'a)
tape
(lambda (ix) '#(6))
shot))
(error "share-array/index! failed tiny0"))
(or (array-equal? tiny1
(share-array/index!
(array (shape 6 7 8 9) 'b)
tape
(lambda (ix) '#(6 8))
shot))
(error "share-array/index! failed tiny1")))
(past "share-array/index! huge as tiny")