guile-ploy/test/test-as-array.scm

; Test array memory order operations and array conversion.
; (c) Daniel Llorens - 2013

; This library is free software; you can redistribute it and/or modify it under
; the terms of the GNU General Public License as published by the Free
; Software Foundation; either version 3 of the License, or (at your option) any
; later version.

(import (srfi srfi-1) (srfi srfi-26) (ploy as-array) (ploy slices) (ploy test)
        (ploy basic))

; ---------------------------------------------------------------------
; assignable?
; ---------------------------------------------------------------------

(assert (assignable? (i. 3 3 3)))
(assert (assignable? (i. 3 3)))
(assert (assignable? (i. 3)))
(assert (assignable? (i.)))
(assert (assignable? (reverse. (i. 3) 0)))
(assert (assignable? (reverse. (i. 3 3) 0)))
(assert (assignable? (reverse. (i. 3 3) 1)))
(assert (assignable? (reverse. (reverse. (i. 3 3) 0) 1)))
(assert (assignable? (reverse. (reverse. (i. 3 3) 1) 0)))

(assert (assignable? (reshape (i. 3 3) 3 3 1)))

(assert (assignable? (reshape (i. 3 3) 3 3 2)))
(assert (not (assignable? (reshape (i. 3 3) 2 3 3))))
(assert (not (assignable? (reshape 3 4 4 4))))

(assert (not (assignable? (reshape 0 3))))
(assert (assignable? (reshape 0 1)))
(assert (assignable? (reshape 0 0)))
(assert (assignable? (as-array (reshape 0 3) #:order 'c)))

(assert (not (assignable? (cant (i. 10) 3 1))))
(assert (not (assignable? (cant (i. 10) 3 2))))
(assert (assignable? (cant (i. 10) 3 3)))

; ---------------------------------------------------------------------
; as-array
; ---------------------------------------------------------------------

(define (array->nested-vector A)
  (case (rank A)
    ((0) A)
    ((1) A)
    (else (array->nested-vector (explode 1 A)))))

(define* (test-as-array-with-options #:key (post-test (lambda x #t)) (order #f))
  (let* ((test (lambda* (ref A msg #:key rank)
                 (assert (equal? ($ ref) (arraylike-dimensions A #:rank rank))
                   (format #f "~a, rank ~a: arraylike-dimensions" msg rank))
                 (let ((B (as-array A #:order order #:rank rank)))
                   (assert (equal? ref B) msg)
                   (assert (or (and rank (zero? rank)) (post-test B))
                     (format #f "~a, rank ~a: post-test failed" msg rank))))))

; common cases.

    (for-each
     (lambda (A msg)
       (let ((a (array->list A)))
         (test A a "list")
         (for-each (lambda (i) (test (list->array i a) a msg #:rank i))
                   (iota (rank A) 1))))
     (list (i. 2) (i. 2 3) (i. 2 3 4))
     (list "list" "list-list" "list-list-list"))

    (for-each
     (lambda (A msg)
       (let ((a (array->nested-vector A))
             (B (array-copy A)))
         (test A a "vector")
         (for-each (lambda (i) (test (ply (verb array->nested-vector '() (- i)) A) a msg #:rank i))
                   (iota (rank A) 1))
         (assert (array-equal? A B))))
     (list (i. 2) (i. 2 3) (i. 2 3 4))
     (list "vector" "vector-vector" "vector-vector-vector"))

    (test (i. 2 3) (array->list (explode 1 (i. 2 3))) "list-vector")
    (test (explode 1 (i. 2 3)) (array->list (explode 1 (i. 2 3))) "list-vector" #:rank 1)

    (test (i. 2 3) (list->array 1 (array->list (i. 2 3))) "vector-list")
    (test (list->array 1 (array->list (i. 2 3))) (list->array 1 (array->list (i. 2 3))) "vector-list" #:rank 1)

    (test (i. 2 3 4) (ply array->list (explode 1 (explode 1 (i. 2 3 4)))) "vector-list-vector")
    (test (i. 2 3 4) (array->list (explode 1 (list->array 2 (array->list (i. 2 3 4))))) "list-vector-list")

    (test (i. 2 3 4) (explode 2 (i. 2 3 4)) "vector-array2")
    (test (i. 2 3 4) (explode 1 (i. 2 3 4)) "array2-vector")
    (test (i. 2 3 4) (array->list (explode 2 (i. 2 3 4))) "list-array2")
    (test (i. 2 3 4) (ply array->list (explode 1 (i. 2 3 4))) "array2-list")

; corner cases.

    (test #() '() "empty list")
    (test #() #() "empty vector")
    (test (make-array 0 0 0) (make-array 0 0 0) "empty 0 0 2-array")
    (test (make-array 0 1 0) (make-array 0 1 0) "empty 1 0 2-array")
    (test (make-array 0 0 1) (make-array 0 0 1) "empty 0 1 2-array")

; make-shared-array to output of size 0 doesn't have the same shared-array-root as the original array. I'd say this is a bug in shared-array-root.
; atoms of empty arrays are assumed to be scalars.

    (test #() (from (explode 2 (i. 2 3 4)) (J 0)) "empty view of nonempty array")

; on non-empty arrays, we can tell the rank of the atom.

    (test (from (i. 2 3 4) (J 1)) (from (explode 2 (i. 2 3 4)) (J 1)) "empty view of nonempty array")
    ))

(test-as-array-with-options)
(test-as-array-with-options #:order 'fortran #:post-test fortran-order?)
(test-as-array-with-options #:order 'c #:post-test c-order?)

; very typical cases.

(let ((as-f64 (cut as-array <> #:type 'f64)))
  (T #2f64((1 2 3))
     (as-f64 #(#(1 2 3)))
     (as-f64 #2f64((1 2 3)))
     (as-f64 '((1 2 3)))
     (as-f64 #((1 2 3)))
     (as-f64 '(#(1 2 3)))
     (as-f64 #(#f64(1 2 3)))
     (as-f64 '(#f64(1 2 3)))))

; pass through cases.

(define (test-pass-through msg pass? A . args)
  (assert (eqv? pass? (eq? (shared-array-root A) (shared-array-root (apply as-array A args))))
    (format #f "~a: expected ~a" msg (if pass? "success" "failure"))))

(test-pass-through "c-order passthrough" #t (i. 2 3))

(test-pass-through "c-order passthrough" #f (i. 2 3) #:type 'f64)
(test-pass-through "c-order passthrough" #t (as-array (i. 2 3) #:type 'f64) #:type 'f64)

(test-pass-through "c-order passthrough" #t (i. 2 3) #:order 'c)
(test-pass-through "c-order passthrough" #t (transpose-array (i. 2 3) 1 0) #:order 'fortran)
(test-pass-through "c-order passthrough" #t (i. 2 3))
(test-pass-through "c-order passthrough" #t (transpose-array (i. 2 3) 1 0))
(test-pass-through "c-order passthrough" #f (i. 2 3) #:order 'fortran)
(test-pass-through "c-order passthrough" #f (transpose-array (i. 2 3) 1 0) #:order 'c)
(test-pass-through "c-order passthrough" #f (i. 2 3) #:order 'c #:unique? #t)
(test-pass-through "c-order passthrough" #f (transpose-array (i. 2 3) 1 0) #:order 'fortran #:unique? #t)
(test-pass-through "c-order passthrough" #f (i. 2 3) #:unique? #t)
(test-pass-through "c-order passthrough" #f (transpose-array (i. 2 3) 1 0) #:unique? #t)

; @TODO Check ra-large.H:is_c_order() against these.
;; (c:is_c_order? (as-array (i. 2 3) #:order 'fortran))
;; (c:is_c_order? (as-array (i. 2 3) #:order 'c))

; FIXED array contents should be redefined to return memory also with fortran-order array, or renamed.
(array-contents (as-array (i. 2 3 4) #:order 'c))
; #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
(array-contents (as-array (i. 2 3 4) #:order 'fortran))
; #f