guile-ploy/test/test-slices.scm

; Tests for (ploy slices)
; (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 (srfi srfi-1) (srfi srfi-9) (srfi srfi-26) (ploy basic) (ploy slices)
        (ploy test) (ploy as-array))

; this might need to be elsewhere, but test-reduce.scm doesn't know cant.
(define +/ (verb (cut over (lambda (x y) (ply + x y)) <>) #f '_))
(define +/a (verb (cut folda + 0 <>) #f '_))
(define +/b (verb (cut foldb + 0 <>) #f '_))

;; @TODO An example that is too slow b/c +/ results in many (ply + scalar scalar).
(ply (w/rank +/ 1) (cant (i. 200) 21))
(ply (w/rank +/a 1) (cant (i. 200) 21))
(ply (w/rank +/b 1) (cant (i. 200) 21))

; ------------------------
; index
; ------------------------

(T 0 (index (lambda (v) (= (v-norm v) 1)) #2((1 0 0) (1 2 0) (-.1 0 .3))))
(T 1 (index (lambda (v) (> (v-norm v) 1)) #2((1 0 0) (1 2 0) (-.1 0 .3))))
(T 2 (index (lambda (v) (< (v-norm v) 1)) #2((1 0 0) (1 2 0) (-.1 0 .3))))

(ply (lambda (i) (index (cut = i <>) (i. 10))) #(0 1 2))

; -----------------------------
; max-by min-by sort. sort-by.
; -----------------------------

(assert (= -2 (max-by '(-1 -2 2 1) (lambda (a b) (< (magnitude a) (magnitude b)))))
        "unstable sort")
(assert (= -1 (min-by '(-2 -1 1 2) (lambda (a b) (< (magnitude a) (magnitude b)))))
        "unstable sort")

(T (sort. (i. 3) >) #(2 1 0))
(T (sort. #(2 1 0)) (i. 3))
(T (sort-by. (i. 3 3) #(1 0 2)) #2((3 4 5) (0 1 2) (6 7 8)))
(T (sort-by. (i. 3 3) #(1 0 2) >) #2((6 7 8) (0 1 2) (3 4 5)))
(T (sort-indices-by. #(1 0 0 1 2) #(1.3 1.9 0.3) <)
   (sort-by. #(1 0 0 1 2) (from #(1.3 1.9 0.3) #(1 0 0 1 2)) <)
   #(2 0 0 1 1))
(T (sort-indices-by. #(1 0 0 1 2) #(1.3 1.9 0.3) >)
   (sort-by. #(1 0 0 1 2) (from #(1.3 1.9 0.3) #(1 0 0 1 2)) >)
   #(1 1 0 0 2))

; -----------------------------
; ply with other functions.
; -----------------------------

(define zxy (verb (cut from <> #(2 0 1)) '(3) 1))
(T (ply zxy #2((0 1+1i 1) (1-1i 0 1))) #2((1 0 1+1i) (1 1-1i 0)))
(T (ply zxy #2f64((0 1 2) (1 0 2))) #2f64((2 0 1) (2 1 0)))
(T (ply zxy #2c64((0 1+1i 1) (1-1i 0 1))) #2c64((1 0 1+1i) (1 1-1i 0)))

; -----------------------------
; pile
; -----------------------------

; @TODO type output according to types of a.
(define (pile a)
  "(pile a) Make array whose items are the elements of list a"
  (assert (not (null? a)))
  (let ((rank (rank (car a)))
        (type (array-type* (car a))))
    (if (zero? rank)
        (list->typed-array type 1 a)
        (let ((b (apply make-typed-array type *unspecified* (length a) ($ (car a)))))
          (let loop ((a a) (i 0))
            (cond ((null? a) b)
                  (else
                   (array-copy! (car a) (from b i))
                   (loop (cdr a) (+ 1 i)))))))))

(T (pile '(1 2 3)) #(1 2 3))
(T (pile '(#(1 2) #(3 4) #(5 6))) #2((1 2) (3 4) (5 6)))

; ---------------------------------------------------------------------
; joining arrays.
; ---------------------------------------------------------------------

; @TODO signal arity error proc->verb
; (folda (verb (lambda (n a) (+ n (tally a))) '() '_) a)
(T (raze #(#(1 2 3) #(a b) #(5 6 7 8) #() #(x) #(s t)))
   #(1 2 3 a b 5 6 7 8 x s t))

(T (raze `#(,(i. 3 2) ,(i. 1 2) ,(i. 5 2) ,(i. 0 2)))
   #2((0 1) (2 3) (4 5) (0 1) (0 1) (2 3) (4 5) (6 7) (8 9)))

; -------------------------
; axis operations.
; -------------------------

(T (reverse. (i. 3 2) 0) #2((4 5) (2 3) (0 1)))
(T (reverse. (i. 3 2) 1) #2((1 0) (3 2) (5 4)))

; -----------------------------
; cant
; -----------------------------

(T (cant (i. 9) 3 3)
   #2((0 1 2) (3 4 5) (6 7 8)))

(T (cant (i. 9) 3 2)
   #2((0 1 2) (2 3 4) (4 5 6) (6 7 8)))

(T (cant (i. 9) 3 1)
   #2((0 1 2) (1 2 3) (2 3 4) (3 4 5) (4 5 6) (5 6 7) (6 7 8)))

(T (cant (i. 9) 2 2)
   #2((0 1) (2 3) (4 5) (6 7)))

(T (cant (i. 9) 2 1)
   #2((0 1) (1 2) (2 3) (3 4) (4 5) (5 6) (6 7) (7 8)))

; -----------------------------
; roll
; -----------------------------

(T (ply (w/rank (verb (cut roll 1 <>) #f '_) 1) (i. 5 5))
   #2((4 0 1 2 3) (9 5 6 7 8) (14 10 11 12 13) (19 15 16 17 18) (24 20 21 22 23)))

; -----------------------------
; index-of count. copy. copy-i. drop. remove-i. filter. indices
; -----------------------------

; J dyad (i.). This definition is irregular; not sure if I want to adopt it.
(define (index-of a b)
  (if (> (rank a) (rank b))
      (if (array? b)
          (ply (verb (lambda (a) (index (cut array-equal? <> b) a)) #f (+ 1 (array-rank b))) a)
          (ply (verb (lambda (a) (index (cut equal? <> b) a)) #f 1) a))
      (if (> (rank a) 1)
          (ply (verb (lambda (a b) (index (cut array-equal? <> b) a)) #f '_ (+ -1 (array-rank a))) a b)
          (ply (verb (lambda (a b) (index (cut equal? <> b) a)) #f '_ (+ -1 (array-rank a))) a b))))

; direct cases.
; 3 1 4 1 5 9 i. 5
(T 4 (index-of #(3 1 4 1 5 9) 5))

; (i. 4 3) i. 6 7 8
(T 2 (index-of (i. 4 3) #(6 7 8)))

; reverse cases
; 3 1 4 1 5 9 i. 1 5
(T #(1 4) (index-of #(3 1 4 1 5 9) #(1 5)))

; (i. 3 3) i. (i. 2 3)
(T #(0 1) (index-of (i. 3 3) (i. 2 3)))

; 3 1 4 1 5 9 i. 8 4 _1
(T #(#f 2 #f) (index-of #(3 1 4 1 5 9) #(8 4 -1)))

; cf., although wasteful (way faster to modify (make-array #f 10)
(T (index-of (i. 10) #(3 4 7)) #(3 4 7))
(T (index-of #(3 4 7) (i. 10)) #(#f #f #f 0 1 #f #f 2 #f #f))

(T 0 (count. values #()))
(T 2 (count. values #(#f #f #t #f #t #f)))
(T 3 (count. (lambda (a) (apply < (vector->list a))) #2((0 1) (1 2) (3 2) (1 3) (9 2))))
(T (copy. #(#f #f #t #f #t #f) (i. 6 2))   #2((4 5) (8 9)))
(T (copy-i. #(0 1 0) (i. 6 3))             #2((0 1 2) (3 4 5)))
(T (ply (verb array-cell-ref #f '_ 0) (i. 6 3) #(0 1 0)) #2((0 1 2) (3 4 5) (0 1 2)))
(T (remove-i. #(0 2 4) (i. 6 3)) #2((3 4 5) (9 10 11) (15 16 17)))
(T (drop. (i. 3 3)) #2((3 4 5) (6 7 8)))
(T (drop. (i. 3 3) 2) #2((6 7 8)))

; filter.
(T (filter. (lambda (v) (odd? (array-cell-ref v (- (tally v) 1))))
            (i. 4 3))
   #2((3 4 5) (9 10 11)))
(T (filter. (lambda (v) (negative? (array-cell-ref v (- (tally v) 1))))
            (i. 4 3))
   (make-array 0 0 0)) ; @TODO #2() is buggy in my Guile branch
(T (filter. positive? #(1 2 3 -4 5))
   #(1 2 3 5))

; filter-map.
(T #(-3 -5) (filter-map. (lambda (x) (if (positive? x) (- x) #f)) #(-1 -1 +3 0 -4 5)))

; invert-index
(T (invert-index #(3 7 1)) #(#f 2 #f 0 #f #f #f 1))
(T (invert-index #(1 0 2)) #(1 0 2))
(T (invert-index #(1 2 0)) #(2 0 1))

; @TODO More tests, argument should be verb
(T #(2) (indices (lambda (a b) (positive? (+ a b))) #(1 2 3) #(-2 -2 -2)))

; -----------------------------
; deal @TODO the argument to ply is spurious.
; -----------------------------

(define (deal w y)
  (ply (lambda (w) (array-cell-ref y (random (tally y)))) (reshape 1 w)))
(deal 4 (i. 4))
(define x (deal 1000 (i. 360)))

; -----------------------------
; conversion or casting.
; -----------------------------

(T-eps 0. #c64(1+2i 3+1i 2+3i) (real->c64 #f64(1 2 3 1 2 3)))
(T-eps 0. (complex->f64 #c64(1+2i 3+1i 2+3i)) #f64(1 2 3 1 2 3))

; -----------------------
; array-map-rows-1!
; -----------------------
; deprecated test; array-map-rows-1! isn't used anymore.
; only to check performance of ply against manual looping.

(define-syntax repeat-i
  (syntax-rules ()
    ((_ (i n) e0 ...) (do ((i 0 (+ i 1))) ((= i n)) e0 ...))))

(define (array-map-rows-1! dst f src0)
  "(array-map-rows-1! dst f src) - map over rows of src0 to rows of dst."
  (case (array-rank dst)
    ((2) (repeat-i (i (tally dst))
           (array-copy! (f (array-cell-ref src0 i)) (array-cell-ref dst i))))
    ((1) (array-index-map! dst (lambda (i) (f (array-cell-ref src0 i)))))
    (else (error (format #f "bad rank of destination ~a" (array-rank dst))))))

(define (sphere-points . dims)
  (let ((a (make-random-array dims)))
    (ply / a (ply vnorm. a)))) ; @TODO typical need of fusion

(define r (sphere-points 100 3))

(define r0 (array-copy 'f64 r))
(define r1 (array-copy 'f64 r))
(define r2 (array-copy 'f64 r))
(define r3 (array-copy 'f64 r))
(array-map! r0 (cut * 2 <>) r0)
(array-map-rows-1! r1 (cut array-map #t (cut * <> 2) <>) r1)
(assert (zero? (max (compare-arrays r0 r1))) "bad array-map-rows-1!")

; array-map-rows-1! when the destination has rank 1.

(define r0 #(1.73205080756888 3.46410161513775 5.19615242270663))
(define r1 (array-copy #f64(0 0 0)))
(array-map-rows-1! r1 v-norm #2f64((1 1 1) (2 2 2) (3 3 3)))
(assert (> 5e-15 (max (compare-arrays r0 r1))) "bad array-map-rows-1!")

(define r0 (as-array r #:type 'f64))
(define vr0 (make-typed-array 'f64 0. ($. r0 0)))
(array-map-rows-1! vr0 v-norm r)
(assert (> 6e-15 (max (compare-arrays (reshape 1. (tally r0)) vr0))))

(define r (sphere-points 1000 3))

(define r0 (as-array r #:type 'f64))
(define vr1 (make-typed-array 'f64 0. (tally r0)))
(array-map-rows-1! vr1 v-norm r)
(define vr2 (ply (verb v-norm '() 1) r))

(T-eps 1e-15 (reshape 1. (tally r0)) vr1 vr2)

; -----------------------------
; reductions, @TODO to be filed in (ploy reduce).
; -----------------------------

(T 4 (every. values #(1 2 3 4)))
(T #t (every. positive? #(1 2 3 4)))

(T 1 (any. values #(1 2 3 4)))
(T #t (any. negative? #(1 2 -3 4)))

; @wish ((w/rank (cut every. positive? <>) 1) (i. 10 3))
(T (ply (verb (cut every. positive? <>) '() 1) (i. 10 3))
   #(#f #t #t #t #t #t #t #t #t #t))

(T #t (every. values #(#t #t)))
(T #f (every. values #(#t #f)))
(T #f (every. values #(#f #t)))
(T #t (every. values #(#t)))
(T #f (every. values #(#f)))
(T #t (every. values #()))

; -----------------------------
; tile
; -----------------------------

(T (tile (i. 2 3) 3 1) #2((0 1 2) (3 4 5) (0 1 2) (3 4 5) (0 1 2) (3 4 5)))
(T (tile (i. 2 3) 1 3) #2((0 1 2 0 1 2 0 1 2) (3 4 5 3 4 5 3 4 5)))
(T (tile (i. 2 3) 0 3) #2:0:9())
(T (tile (i. 2 3) 3 0) #2(() () () () () ()))
(T (tile #(#(1 2) #(3)) 3) #(#(1 2) #(3) #(1 2) #(3) #(1 2) #(3)))
(T (tile #2((#(1 2) #(3)) (#(4) #(5 6))) 2 3)
   #2((#(1 2) #(3) #(1 2) #(3) #(1 2) #(3))
      (#(4) #(5 6) #(4) #(5 6) #(4) #(5 6))
      (#(1 2) #(3) #(1 2) #(3) #(1 2) #(3))
      (#(4) #(5 6) #(4) #(5 6) #(4) #(5 6))))

(T (tile (cat 1 (i. 3 1 2 2) (i. 3 1 2 2)) 1 1 1 1)
   (tile (i. 3 1 2 2) 1 2 1 1))

(T (tile (cat 2 (i. 1 3 1 2) (i. 1 3 1 2)) 1 1 1 1)
   (tile (i. 1 3 1 2) 1 1 2 1))

(T (tile (cat 2 (i. 1 3 1 2 2) (i. 1 3 1 2 2)) 1 1 1 1 1)
   (tile (i. 1 3 1 2 2) 1 1 2 1 1))

(T (tile (i. 2 3) 2)
   (tile (i. 2 3) 2 1)
   (cat 0 (i. 2 3) (i. 2 3))
   #2((0 1 2) (3 4 5) (0 1 2) (3 4 5)))

; -----------------------------
; bits
; -----------------------------

(display "\ndone.\n") (force-output)