;;; 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")