guile-ploy/test/test-from.scm

; Tests for (from) and (amend!) from (ploy ploy).
; (c) Daniel Llorens - 2012-2014

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

; further generalization of array-fill! / array-set! / array-copy! / array-amend!.
(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))
; this is the general case. The others are needed b/c ply & array-from pass x not #0(x) for rank-0 arrays.
          (else
           (ply (verb (cut array-amend! <> <>) #f (rank z) '_)
                (apply array-from b i) z)))))

; a variant that doesn't ply the write argument.
(define (subrank-copy! b z . i)
  (let ((li (length i)))
    (if (= (rank b) li)
; this case b/c (array-from) will return x not #0(x).
      (apply array-set! b z i)
      (apply array-amend! b (extend-left z (drop ($ b) li)) i))))

; ----------------
; just rank-1 indices.
; ----------------

(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))

; ----------------
; rank-1 and rank-0 indices.
; ----------------

(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)))

; ----------------
; using shortcuts.
; ----------------

(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)))

; -------------------
; indices with rank>0
; -------------------

(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))

; -------------------
; shortcuts and indices with rank>0. This uses backward != forward.
; -------------------

; see (5-6).
(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)))

; -------------------
; subrank-copy!
; -------------------

(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)))) ; @TODO Unsettled (see 4).
(define A (i. 2 3))
(subrank-copy! A #0(a))
(T-msg "bad subrank-copy! 3" A  #2((a a a) (a a a))) ; @TODO Unsettled (see 3)

(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)))

; -------------------
; fill has rank below shape remainder.
; -------------------

(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)))

; Like (3-0), but extending to expected-z-shape.
(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)))

; -------------------
; regression tests for amend!
; -------------------

; These work.
(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)))

; These go through to prefix-amend!, but still require extend-left.
(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)))