giles
d570da1dea
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
1065 lines
29 KiB
Plaintext
1065 lines
29 KiB
Plaintext
; APL Runtime — array model + scalar primitives
|
||
;
|
||
; Array = SX dict {:shape (d1 d2 ...) :ravel (v1 v2 ...)}
|
||
; Scalar: rank 0, shape (), one element in ravel
|
||
; Vector: rank 1, shape (n), n elements in ravel
|
||
; Matrix: rank 2, shape (r c), r*c elements in ravel
|
||
|
||
; ============================================================
|
||
; Array constructors
|
||
; ============================================================
|
||
|
||
(define make-array (fn (shape ravel) {:ravel ravel :shape shape}))
|
||
|
||
(define apl-scalar (fn (v) {:ravel (list v) :shape (list)}))
|
||
|
||
(define apl-vector (fn (elems) {:ravel elems :shape (list (len elems))}))
|
||
|
||
; enclose — wrap any value in a rank-0 box
|
||
(define enclose (fn (v) (apl-scalar v)))
|
||
|
||
; disclose — unwrap rank-0 box, returning the first element
|
||
(define disclose (fn (arr) (first (get arr :ravel))))
|
||
|
||
; ============================================================
|
||
; Array accessors
|
||
; ============================================================
|
||
|
||
(define array-rank (fn (arr) (len (get arr :shape))))
|
||
|
||
(define scalar? (fn (arr) (= (len (get arr :shape)) 0)))
|
||
|
||
(define array-ref (fn (arr i) (nth (get arr :ravel) i)))
|
||
|
||
; ============================================================
|
||
; System variables
|
||
; ============================================================
|
||
|
||
(define apl-io 1)
|
||
|
||
; ============================================================
|
||
; Broadcast engine
|
||
; ============================================================
|
||
|
||
(define
|
||
broadcast-monadic
|
||
(fn (f arr) (make-array (get arr :shape) (map f (get arr :ravel)))))
|
||
|
||
(define
|
||
broadcast-dyadic
|
||
(fn
|
||
(f a b)
|
||
(cond
|
||
((and (scalar? a) (scalar? b))
|
||
(apl-scalar (f (first (get a :ravel)) (first (get b :ravel)))))
|
||
((scalar? a)
|
||
(let
|
||
((sv (first (get a :ravel))))
|
||
(make-array
|
||
(get b :shape)
|
||
(map (fn (x) (f sv x)) (get b :ravel)))))
|
||
((scalar? b)
|
||
(let
|
||
((sv (first (get b :ravel))))
|
||
(make-array
|
||
(get a :shape)
|
||
(map (fn (x) (f x sv)) (get a :ravel)))))
|
||
(else
|
||
(if
|
||
(equal? (get a :shape) (get b :shape))
|
||
(make-array (get a :shape) (map f (get a :ravel) (get b :ravel)))
|
||
(error "length error: shape mismatch"))))))
|
||
|
||
; ============================================================
|
||
; Arithmetic primitives
|
||
; ============================================================
|
||
|
||
; Monadic + : identity
|
||
(define apl-plus-m (fn (a) (broadcast-monadic (fn (x) x) a)))
|
||
|
||
; Dyadic +
|
||
(define apl-add (fn (a b) (broadcast-dyadic (fn (x y) (+ x y)) a b)))
|
||
|
||
; Monadic - : negate
|
||
(define apl-neg-m (fn (a) (broadcast-monadic (fn (x) (- 0 x)) a)))
|
||
|
||
; Dyadic -
|
||
(define apl-sub (fn (a b) (broadcast-dyadic (fn (x y) (- x y)) a b)))
|
||
|
||
; Monadic × : signum
|
||
(define
|
||
apl-signum
|
||
(fn
|
||
(a)
|
||
(broadcast-monadic
|
||
(fn (x) (cond ((> x 0) 1) ((< x 0) -1) (else 0)))
|
||
a)))
|
||
|
||
; Dyadic ×
|
||
(define apl-mul (fn (a b) (broadcast-dyadic (fn (x y) (* x y)) a b)))
|
||
|
||
; Monadic ÷ : reciprocal
|
||
(define apl-recip (fn (a) (broadcast-monadic (fn (x) (/ 1 x)) a)))
|
||
|
||
; Dyadic ÷
|
||
(define apl-div (fn (a b) (broadcast-dyadic (fn (x y) (/ x y)) a b)))
|
||
|
||
; Monadic ⌈ : ceiling
|
||
(define apl-ceil (fn (a) (broadcast-monadic (fn (x) (ceil x)) a)))
|
||
|
||
; Dyadic ⌈ : max
|
||
(define
|
||
apl-max
|
||
(fn (a b) (broadcast-dyadic (fn (x y) (if (>= x y) x y)) a b)))
|
||
|
||
; Monadic ⌊ : floor
|
||
(define apl-floor (fn (a) (broadcast-monadic (fn (x) (floor x)) a)))
|
||
|
||
; Dyadic ⌊ : min
|
||
(define
|
||
apl-min
|
||
(fn (a b) (broadcast-dyadic (fn (x y) (if (<= x y) x y)) a b)))
|
||
|
||
; Monadic * : e^x
|
||
(define apl-exp (fn (a) (broadcast-monadic (fn (x) (exp x)) a)))
|
||
|
||
; Dyadic * : power
|
||
(define apl-pow (fn (a b) (broadcast-dyadic (fn (x y) (pow x y)) a b)))
|
||
|
||
; Monadic ⍟ : natural log
|
||
(define apl-ln (fn (a) (broadcast-monadic (fn (x) (log x)) a)))
|
||
|
||
; Dyadic ⍟ : log base (a⍟b = log base a of b)
|
||
(define
|
||
apl-log
|
||
(fn (a b) (broadcast-dyadic (fn (x y) (/ (log y) (log x))) a b)))
|
||
|
||
; Monadic | : absolute value
|
||
(define
|
||
apl-abs
|
||
(fn (a) (broadcast-monadic (fn (x) (if (< x 0) (- 0 x) x)) a)))
|
||
|
||
; Dyadic | : modulo (a|b = b mod a)
|
||
(define
|
||
apl-mod
|
||
(fn
|
||
(a b)
|
||
(broadcast-dyadic
|
||
(fn (x y) (if (= x 0) y (- y (* x (floor (/ y x))))))
|
||
a
|
||
b)))
|
||
|
||
; Monadic ! : factorial
|
||
(define
|
||
apl-fact
|
||
(fn
|
||
(a)
|
||
(broadcast-monadic
|
||
(fn
|
||
(n)
|
||
(let
|
||
((loop nil))
|
||
(begin
|
||
(set!
|
||
loop
|
||
(fn (i acc) (if (> i n) acc (loop (+ i 1) (* acc i)))))
|
||
(loop 1 1))))
|
||
a)))
|
||
|
||
; Dyadic ! : binomial coefficient n!k (a=n, b=k => a choose b)
|
||
(define
|
||
apl-binomial
|
||
(fn
|
||
(a b)
|
||
(broadcast-dyadic
|
||
(fn
|
||
(n k)
|
||
(let
|
||
((loop nil))
|
||
(begin
|
||
(set!
|
||
loop
|
||
(fn
|
||
(i num den)
|
||
(if
|
||
(> i k)
|
||
(/ num den)
|
||
(loop (+ i 1) (* num (- (+ n 1) i)) (* den i)))))
|
||
(loop 1 1 1))))
|
||
a
|
||
b)))
|
||
|
||
; Monadic ○ : pi times x
|
||
(define
|
||
apl-pi-times
|
||
(fn (a) (broadcast-monadic (fn (x) (* 3.14159 x)) a)))
|
||
|
||
; Dyadic ○ : trig functions (a○b, a=code, b=value)
|
||
(define
|
||
apl-trig
|
||
(fn
|
||
(a b)
|
||
(broadcast-dyadic
|
||
(fn
|
||
(n x)
|
||
(cond
|
||
((= n 0) (pow (- 1 (* x x)) 0.5))
|
||
((= n 1) (sin x))
|
||
((= n 2) (cos x))
|
||
((= n 3) (tan x))
|
||
((= n -1) (asin x))
|
||
((= n -2) (acos x))
|
||
((= n -3) (atan x))
|
||
(else (error "circle: unsupported trig code"))))
|
||
a
|
||
b)))
|
||
|
||
; ============================================================
|
||
; Comparison primitives (return 0 or 1)
|
||
; ============================================================
|
||
|
||
(define
|
||
apl-lt
|
||
(fn (a b) (broadcast-dyadic (fn (x y) (if (< x y) 1 0)) a b)))
|
||
|
||
(define
|
||
apl-le
|
||
(fn (a b) (broadcast-dyadic (fn (x y) (if (<= x y) 1 0)) a b)))
|
||
|
||
(define
|
||
apl-eq
|
||
(fn (a b) (broadcast-dyadic (fn (x y) (if (= x y) 1 0)) a b)))
|
||
|
||
(define
|
||
apl-ge
|
||
(fn (a b) (broadcast-dyadic (fn (x y) (if (>= x y) 1 0)) a b)))
|
||
|
||
(define
|
||
apl-gt
|
||
(fn (a b) (broadcast-dyadic (fn (x y) (if (> x y) 1 0)) a b)))
|
||
|
||
(define
|
||
apl-ne
|
||
(fn (a b) (broadcast-dyadic (fn (x y) (if (= x y) 0 1)) a b)))
|
||
|
||
; ============================================================
|
||
; Logical primitives
|
||
; ============================================================
|
||
|
||
; Monadic ~ : logical not
|
||
(define
|
||
apl-not
|
||
(fn (a) (broadcast-monadic (fn (x) (if (= x 0) 1 0)) a)))
|
||
|
||
; Dyadic ∧ : logical and
|
||
(define
|
||
apl-and
|
||
(fn
|
||
(a b)
|
||
(broadcast-dyadic
|
||
(fn (x y) (if (and (not (= x 0)) (not (= y 0))) 1 0))
|
||
a
|
||
b)))
|
||
|
||
; Dyadic ∨ : logical or
|
||
(define
|
||
apl-or
|
||
(fn
|
||
(a b)
|
||
(broadcast-dyadic
|
||
(fn (x y) (if (or (not (= x 0)) (not (= y 0))) 1 0))
|
||
a
|
||
b)))
|
||
|
||
; Dyadic ⍱ : logical nor
|
||
(define
|
||
apl-nor
|
||
(fn
|
||
(a b)
|
||
(broadcast-dyadic
|
||
(fn (x y) (if (or (not (= x 0)) (not (= y 0))) 0 1))
|
||
a
|
||
b)))
|
||
|
||
; Dyadic ⍲ : logical nand
|
||
(define
|
||
apl-nand
|
||
(fn
|
||
(a b)
|
||
(broadcast-dyadic
|
||
(fn (x y) (if (and (not (= x 0)) (not (= y 0))) 0 1))
|
||
a
|
||
b)))
|
||
|
||
; ============================================================
|
||
; Shape primitives
|
||
; ============================================================
|
||
|
||
; Monadic ⍴ : shape — returns shape as a vector array
|
||
(define apl-shape (fn (arr) (apl-vector (get arr :shape))))
|
||
|
||
; Monadic , : ravel — returns a rank-1 vector of all elements
|
||
(define apl-ravel (fn (arr) (apl-vector (get arr :ravel))))
|
||
|
||
; Monadic ≢ : tally — first dimension (1 for scalar)
|
||
(define
|
||
apl-tally
|
||
(fn
|
||
(arr)
|
||
(if
|
||
(scalar? arr)
|
||
(apl-scalar 1)
|
||
(apl-scalar (first (get arr :shape))))))
|
||
|
||
; Monadic ≡ : depth
|
||
; simple number/string value → 0
|
||
; array containing only non-arrays → 0
|
||
; array containing arrays → 1 + max depth of elements
|
||
(define
|
||
apl-depth
|
||
(fn
|
||
(arr)
|
||
(define item-depth nil)
|
||
(set!
|
||
item-depth
|
||
(fn
|
||
(v)
|
||
(if
|
||
(and
|
||
(dict? v)
|
||
(not (= nil (get v :shape nil)))
|
||
(not (= nil (get v :ravel nil))))
|
||
(+ 1 (first (get (apl-depth v) :ravel)))
|
||
0)))
|
||
(let
|
||
((depths (map item-depth (get arr :ravel))))
|
||
(apl-scalar (reduce (fn (a b) (if (> a b) a b)) 0 depths)))))
|
||
|
||
; Monadic ⍳ : iota — vector 1..n (with ⎕IO=1)
|
||
(define
|
||
apl-iota
|
||
(fn
|
||
(n-arr)
|
||
(let
|
||
((n (first (get n-arr :ravel))) (build nil))
|
||
(begin
|
||
(set!
|
||
build
|
||
(fn (i acc) (if (< i 1) acc (build (- i 1) (cons i acc)))))
|
||
(apl-vector (build n (list)))))))
|
||
|
||
(define
|
||
apl-strides
|
||
(fn
|
||
(shape)
|
||
(map
|
||
(fn (i) (reduce * 1 (drop shape (+ i 1))))
|
||
(range 0 (len shape)))))
|
||
|
||
(define
|
||
apl-flat->multi
|
||
(fn
|
||
(flat shape strides)
|
||
(map
|
||
(fn (i) (mod (floor (/ flat (nth strides i))) (nth shape i)))
|
||
(range 0 (len shape)))))
|
||
|
||
(define
|
||
apl-multi->flat
|
||
(fn (coords strides) (reduce + 0 (map * coords strides))))
|
||
|
||
(define
|
||
apl-reshape
|
||
(fn
|
||
(shape-arr data-arr)
|
||
(let
|
||
((new-shape (if (scalar? shape-arr) (list (disclose shape-arr)) (get shape-arr :ravel)))
|
||
(src-ravel
|
||
(if
|
||
(scalar? data-arr)
|
||
(list (disclose data-arr))
|
||
(get data-arr :ravel))))
|
||
(let
|
||
((new-size (reduce * 1 new-shape)) (src-len (len src-ravel)))
|
||
(let
|
||
((new-ravel (if (= new-size 0) (list) (if (= src-len 0) (map (fn (i) 0) (range 0 new-size)) (map (fn (i) (nth src-ravel (mod i src-len))) (range 0 new-size))))))
|
||
(make-array new-shape new-ravel))))))
|
||
|
||
(define
|
||
apl-transpose
|
||
(fn
|
||
(arr)
|
||
(let
|
||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||
(if
|
||
(< (len shape) 2)
|
||
arr
|
||
(let
|
||
((new-shape (reverse shape)) (strides (apl-strides shape)))
|
||
(let
|
||
((new-strides (apl-strides new-shape)) (new-size (len ravel)))
|
||
(make-array
|
||
new-shape
|
||
(map
|
||
(fn
|
||
(new-flat)
|
||
(let
|
||
((new-coords (apl-flat->multi new-flat new-shape new-strides)))
|
||
(nth
|
||
ravel
|
||
(apl-multi->flat (reverse new-coords) strides))))
|
||
(range 0 new-size)))))))))
|
||
|
||
(define
|
||
apl-transpose-dyadic
|
||
(fn
|
||
(perm-arr data-arr)
|
||
(let
|
||
((perm (map (fn (p) (- p apl-io)) (get perm-arr :ravel)))
|
||
(shape (get data-arr :shape))
|
||
(ravel (get data-arr :ravel)))
|
||
(let
|
||
((new-shape (map (fn (k) (nth shape k)) perm))
|
||
(strides (apl-strides shape)))
|
||
(let
|
||
((inv-perm (map (fn (j) (index-of perm j)) (range 0 (len perm))))
|
||
(new-strides (apl-strides new-shape))
|
||
(new-size (len ravel)))
|
||
(make-array
|
||
new-shape
|
||
(map
|
||
(fn
|
||
(new-flat)
|
||
(let
|
||
((new-coords (apl-flat->multi new-flat new-shape new-strides)))
|
||
(let
|
||
((old-coords (map (fn (i) (nth new-coords (nth inv-perm i))) (range 0 (len shape)))))
|
||
(nth ravel (apl-multi->flat old-coords strides)))))
|
||
(range 0 new-size))))))))
|
||
|
||
(define apl-safe-mod (fn (a m) (mod (+ (mod a m) m) m)))
|
||
|
||
(define
|
||
apl-take
|
||
(fn
|
||
(n-arr data-arr)
|
||
(let
|
||
((old-shape (get data-arr :shape))
|
||
(old-ravel (get data-arr :ravel))
|
||
(ns
|
||
(if (scalar? n-arr) (list (disclose n-arr)) (get n-arr :ravel))))
|
||
(let
|
||
((new-shape (map abs ns)) (old-strides (apl-strides old-shape)))
|
||
(let
|
||
((new-size (reduce * 1 new-shape))
|
||
(new-strides (apl-strides new-shape)))
|
||
(make-array
|
||
new-shape
|
||
(map
|
||
(fn
|
||
(new-flat)
|
||
(let
|
||
((new-coords (apl-flat->multi new-flat new-shape new-strides)))
|
||
(let
|
||
((old-coords (map (fn (i) (let ((ni (nth ns i)) (nc (nth new-coords i)) (od (nth old-shape i))) (if (>= ni 0) nc (+ (- od (- ni)) nc)))) (range 0 (len ns)))))
|
||
(if
|
||
(every?
|
||
(fn
|
||
(i)
|
||
(and
|
||
(>= (nth old-coords i) 0)
|
||
(< (nth old-coords i) (nth old-shape i))))
|
||
(range 0 (len old-coords)))
|
||
(nth old-ravel (apl-multi->flat old-coords old-strides))
|
||
0))))
|
||
(range 0 new-size))))))))
|
||
|
||
(define
|
||
apl-drop
|
||
(fn
|
||
(n-arr data-arr)
|
||
(let
|
||
((old-shape (get data-arr :shape))
|
||
(old-ravel (get data-arr :ravel))
|
||
(ns
|
||
(if (scalar? n-arr) (list (disclose n-arr)) (get n-arr :ravel))))
|
||
(let
|
||
((new-shape (map (fn (i) (let ((ni (nth ns i)) (od (nth old-shape i))) (let ((d (if (>= ni 0) (- od ni) (+ od ni)))) (if (> d 0) d 0)))) (range 0 (len ns))))
|
||
(offsets
|
||
(map
|
||
(fn (i) (let ((ni (nth ns i))) (if (>= ni 0) ni 0)))
|
||
(range 0 (len ns))))
|
||
(old-strides (apl-strides old-shape)))
|
||
(let
|
||
((new-size (reduce * 1 new-shape))
|
||
(new-strides (apl-strides new-shape)))
|
||
(make-array
|
||
new-shape
|
||
(map
|
||
(fn
|
||
(new-flat)
|
||
(let
|
||
((new-coords (apl-flat->multi new-flat new-shape new-strides)))
|
||
(let
|
||
((old-coords (map (fn (i) (+ (nth new-coords i) (nth offsets i))) (range 0 (len ns)))))
|
||
(nth old-ravel (apl-multi->flat old-coords old-strides)))))
|
||
(range 0 new-size))))))))
|
||
|
||
(define
|
||
apl-reverse
|
||
(fn
|
||
(arr)
|
||
(let
|
||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||
(if
|
||
(= (len shape) 0)
|
||
arr
|
||
(let
|
||
((last-dim (last shape)) (n (len ravel)))
|
||
(make-array
|
||
shape
|
||
(map
|
||
(fn
|
||
(flat)
|
||
(let
|
||
((c-last (mod flat last-dim)))
|
||
(nth ravel (+ flat (- last-dim 1) (* -2 c-last)))))
|
||
(range 0 n))))))))
|
||
|
||
(define
|
||
apl-reverse-first
|
||
(fn
|
||
(arr)
|
||
(let
|
||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||
(if
|
||
(= (len shape) 0)
|
||
arr
|
||
(let
|
||
((first-dim (first shape))
|
||
(first-stride (reduce * 1 (rest shape)))
|
||
(n (len ravel)))
|
||
(make-array
|
||
shape
|
||
(map
|
||
(fn
|
||
(flat)
|
||
(let
|
||
((row (floor (/ flat first-stride))))
|
||
(let
|
||
((old-row (- first-dim 1 row)))
|
||
(nth
|
||
ravel
|
||
(+ (* old-row first-stride) (mod flat first-stride))))))
|
||
(range 0 n))))))))
|
||
|
||
(define
|
||
apl-rotate-first
|
||
(fn
|
||
(n-arr data-arr)
|
||
(let
|
||
((shape (get data-arr :shape))
|
||
(ravel (get data-arr :ravel))
|
||
(rot (disclose n-arr)))
|
||
(if
|
||
(= (len shape) 0)
|
||
data-arr
|
||
(let
|
||
((first-dim (first shape))
|
||
(first-stride (reduce * 1 (rest shape)))
|
||
(n (len ravel)))
|
||
(make-array
|
||
shape
|
||
(map
|
||
(fn
|
||
(flat)
|
||
(let
|
||
((row (floor (/ flat first-stride))))
|
||
(let
|
||
((old-row (apl-safe-mod (+ row rot) first-dim)))
|
||
(nth
|
||
ravel
|
||
(+ (* old-row first-stride) (mod flat first-stride))))))
|
||
(range 0 n))))))))
|
||
|
||
(define
|
||
apl-rotate
|
||
(fn
|
||
(n-arr data-arr)
|
||
(let
|
||
((shape (get data-arr :shape))
|
||
(ravel (get data-arr :ravel))
|
||
(rot (disclose n-arr)))
|
||
(if
|
||
(= (len shape) 0)
|
||
data-arr
|
||
(let
|
||
((last-dim (last shape)) (n (len ravel)))
|
||
(make-array
|
||
shape
|
||
(map
|
||
(fn
|
||
(flat)
|
||
(let
|
||
((c-last (mod flat last-dim)))
|
||
(let
|
||
((old-c-last (apl-safe-mod (+ c-last rot) last-dim)))
|
||
(nth ravel (+ flat (- old-c-last c-last))))))
|
||
(range 0 n))))))))
|
||
|
||
(define
|
||
apl-catenate
|
||
(fn
|
||
(a b)
|
||
(let
|
||
((a-s (if (scalar? a) (list 1) (get a :shape)))
|
||
(b-s (if (scalar? b) (list 1) (get b :shape)))
|
||
(a-r (get a :ravel))
|
||
(b-r (get b :ravel)))
|
||
(let
|
||
((a-last (last a-s)) (prefix (take a-s (- (len a-s) 1))))
|
||
(let
|
||
((new-shape (append prefix (list (+ a-last (last b-s)))))
|
||
(a-strides (apl-strides a-s))
|
||
(b-strides (apl-strides b-s)))
|
||
(let
|
||
((new-size (reduce * 1 new-shape))
|
||
(new-strides (apl-strides new-shape)))
|
||
(make-array
|
||
new-shape
|
||
(map
|
||
(fn
|
||
(new-flat)
|
||
(let
|
||
((new-coords (apl-flat->multi new-flat new-shape new-strides)))
|
||
(let
|
||
((last-c (last new-coords))
|
||
(prefix-c (take new-coords (- (len new-coords) 1))))
|
||
(if
|
||
(< last-c a-last)
|
||
(nth
|
||
a-r
|
||
(apl-multi->flat
|
||
(append prefix-c (list last-c))
|
||
a-strides))
|
||
(nth
|
||
b-r
|
||
(apl-multi->flat
|
||
(append prefix-c (list (- last-c a-last)))
|
||
b-strides))))))
|
||
(range 0 new-size)))))))))
|
||
|
||
(define
|
||
apl-catenate-first
|
||
(fn
|
||
(a b)
|
||
(let
|
||
((a-s (if (scalar? a) (list 1) (get a :shape)))
|
||
(b-s (if (scalar? b) (list 1) (get b :shape)))
|
||
(a-r (get a :ravel))
|
||
(b-r (get b :ravel)))
|
||
(make-array
|
||
(cons (+ (first a-s) (first b-s)) (rest a-s))
|
||
(append a-r b-r)))))
|
||
|
||
(define
|
||
apl-squad
|
||
(fn
|
||
(idx-arr data-arr)
|
||
(let
|
||
((shape (get data-arr :shape))
|
||
(ravel (get data-arr :ravel))
|
||
(strides (apl-strides (get data-arr :shape))))
|
||
(let
|
||
((idxs (if (scalar? idx-arr) (list (disclose idx-arr)) (get idx-arr :ravel))))
|
||
(let
|
||
((k (len idxs)) (rank (len shape)))
|
||
(let
|
||
((adj (map (fn (i) (- i apl-io)) idxs)))
|
||
(if
|
||
(= k rank)
|
||
(apl-scalar (nth ravel (apl-multi->flat adj strides)))
|
||
(let
|
||
((remaining-shape (drop shape k))
|
||
(start (apl-multi->flat adj (take strides k)))
|
||
(slice-size (reduce * 1 (drop shape k))))
|
||
(make-array
|
||
remaining-shape
|
||
(map
|
||
(fn (j) (nth ravel (+ start j)))
|
||
(range 0 slice-size)))))))))))
|
||
|
||
(define
|
||
apl-grade
|
||
(fn
|
||
(arr ascending)
|
||
(let
|
||
((ravel (get arr :ravel)) (n (len (get arr :ravel))))
|
||
(let
|
||
((pairs (map (fn (i) (list (nth ravel i) (+ i apl-io))) (range 0 n))))
|
||
(define ins nil)
|
||
(set!
|
||
ins
|
||
(fn
|
||
(x sorted)
|
||
(if
|
||
(= (len sorted) 0)
|
||
(list x)
|
||
(let
|
||
((xv (first x))
|
||
(xi (nth x 1))
|
||
(hd (first sorted))
|
||
(sv (first hd))
|
||
(si (nth hd 1)))
|
||
(if
|
||
(if
|
||
ascending
|
||
(or (< xv sv) (and (= xv sv) (< xi si)))
|
||
(or (> xv sv) (and (= xv sv) (< xi si))))
|
||
(cons x sorted)
|
||
(cons hd (ins x (rest sorted))))))))
|
||
(define isort nil)
|
||
(set!
|
||
isort
|
||
(fn
|
||
(lst)
|
||
(if
|
||
(= (len lst) 0)
|
||
(list)
|
||
(ins (first lst) (isort (rest lst))))))
|
||
(make-array (list n) (map (fn (p) (nth p 1)) (isort pairs)))))))
|
||
|
||
(define apl-grade-up (fn (arr) (apl-grade arr true)))
|
||
|
||
(define apl-grade-down (fn (arr) (apl-grade arr false)))
|
||
|
||
(define apl-enclose (fn (arr) (apl-scalar arr)))
|
||
|
||
(define
|
||
apl-disclose
|
||
(fn
|
||
(arr)
|
||
(let
|
||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||
(if
|
||
(= (len shape) 0)
|
||
(let
|
||
((inner (first ravel)))
|
||
(if (= (type-of inner) "dict") inner (apl-scalar inner)))
|
||
(if
|
||
(= (len shape) 1)
|
||
(apl-scalar (first ravel))
|
||
(let
|
||
((inner-shape (rest shape))
|
||
(inner-size (reduce * 1 (rest shape))))
|
||
(make-array inner-shape (take ravel inner-size))))))))
|
||
|
||
(define
|
||
apl-member
|
||
(fn
|
||
(a b)
|
||
(let
|
||
((a-ravel (if (scalar? a) (list (disclose a)) (get a :ravel)))
|
||
(b-ravel (if (scalar? b) (list (disclose b)) (get b :ravel)))
|
||
(a-shape (get a :shape)))
|
||
(make-array
|
||
a-shape
|
||
(map (fn (x) (if (index-of b-ravel x) 1 0)) a-ravel)))))
|
||
|
||
(define
|
||
apl-index-of
|
||
(fn
|
||
(v w)
|
||
(let
|
||
((v-ravel (if (scalar? v) (list (disclose v)) (get v :ravel)))
|
||
(w-ravel (if (scalar? w) (list (disclose w)) (get w :ravel)))
|
||
(w-shape (get w :shape))
|
||
(n (len (if (scalar? v) (list (disclose v)) (get v :ravel)))))
|
||
(make-array
|
||
w-shape
|
||
(map
|
||
(fn
|
||
(x)
|
||
(let
|
||
((i (index-of v-ravel x)))
|
||
(if i (+ i apl-io) (+ n apl-io))))
|
||
w-ravel)))))
|
||
|
||
(define
|
||
apl-without
|
||
(fn
|
||
(a b)
|
||
(let
|
||
((a-ravel (if (scalar? a) (list (disclose a)) (get a :ravel)))
|
||
(b-ravel (if (scalar? b) (list (disclose b)) (get b :ravel))))
|
||
(let
|
||
((result (filter (fn (x) (not (index-of b-ravel x))) a-ravel)))
|
||
(make-array (list (len result)) result)))))
|
||
|
||
(define
|
||
apl-reduce
|
||
(fn
|
||
(f arr)
|
||
(let
|
||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||
(if
|
||
(= (len shape) 0)
|
||
arr
|
||
(if
|
||
(= (len shape) 1)
|
||
(let
|
||
((n (first shape)))
|
||
(if
|
||
(= n 0)
|
||
(apl-scalar 0)
|
||
(apl-scalar
|
||
(reduce
|
||
(fn (a b) (disclose (f (apl-scalar a) (apl-scalar b))))
|
||
(first ravel)
|
||
(rest ravel)))))
|
||
(let
|
||
((last-dim (last shape))
|
||
(pre-shape (take shape (- (len shape) 1)))
|
||
(pre-size (reduce * 1 (take shape (- (len shape) 1)))))
|
||
(make-array
|
||
pre-shape
|
||
(map
|
||
(fn
|
||
(i)
|
||
(let
|
||
((start (* i last-dim))
|
||
(elems
|
||
(map
|
||
(fn (j) (nth ravel (+ start j)))
|
||
(range 0 last-dim))))
|
||
(if
|
||
(= last-dim 0)
|
||
0
|
||
(reduce
|
||
(fn
|
||
(a b)
|
||
(disclose (f (apl-scalar a) (apl-scalar b))))
|
||
(first elems)
|
||
(rest elems)))))
|
||
(range 0 pre-size)))))))))
|
||
|
||
(define
|
||
apl-reduce-first
|
||
(fn
|
||
(f arr)
|
||
(let
|
||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||
(if
|
||
(< (len shape) 2)
|
||
(apl-reduce f arr)
|
||
(let
|
||
((first-dim (first shape))
|
||
(inner-shape (rest shape))
|
||
(inner-size (reduce * 1 (rest shape))))
|
||
(if
|
||
(= first-dim 0)
|
||
(make-array inner-shape (map (fn (i) 0) (range 0 inner-size)))
|
||
(make-array
|
||
inner-shape
|
||
(map
|
||
(fn
|
||
(j)
|
||
(let
|
||
((col (map (fn (i) (nth ravel (+ j (* i inner-size)))) (range 0 first-dim))))
|
||
(reduce
|
||
(fn
|
||
(a b)
|
||
(disclose (f (apl-scalar a) (apl-scalar b))))
|
||
(first col)
|
||
(rest col))))
|
||
(range 0 inner-size)))))))))
|
||
|
||
(define
|
||
apl-scan
|
||
(fn
|
||
(f arr)
|
||
(let
|
||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||
(if
|
||
(= (len shape) 0)
|
||
arr
|
||
(if
|
||
(= (len shape) 1)
|
||
(let
|
||
((n (first shape)))
|
||
(make-array
|
||
shape
|
||
(map
|
||
(fn
|
||
(i)
|
||
(let
|
||
((slice (take ravel (+ i 1))))
|
||
(reduce
|
||
(fn
|
||
(a b)
|
||
(disclose (f (apl-scalar a) (apl-scalar b))))
|
||
(first slice)
|
||
(rest slice))))
|
||
(range 0 n))))
|
||
(let
|
||
((last-dim (last shape))
|
||
(pre-size (reduce * 1 (take shape (- (len shape) 1)))))
|
||
(make-array
|
||
shape
|
||
(flatten
|
||
(map
|
||
(fn
|
||
(i)
|
||
(let
|
||
((start (* i last-dim))
|
||
(row
|
||
(map
|
||
(fn (j) (nth ravel (+ start j)))
|
||
(range 0 last-dim))))
|
||
(map
|
||
(fn
|
||
(k)
|
||
(let
|
||
((slice (take row (+ k 1))))
|
||
(reduce
|
||
(fn
|
||
(a b)
|
||
(disclose (f (apl-scalar a) (apl-scalar b))))
|
||
(first slice)
|
||
(rest slice))))
|
||
(range 0 last-dim))))
|
||
(range 0 pre-size))))))))))
|
||
|
||
(define
|
||
apl-scan-first
|
||
(fn
|
||
(f arr)
|
||
(let
|
||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||
(if
|
||
(< (len shape) 2)
|
||
(apl-scan f arr)
|
||
(let
|
||
((first-dim (first shape))
|
||
(inner-size (reduce * 1 (rest shape))))
|
||
(make-array
|
||
shape
|
||
(flatten
|
||
(map
|
||
(fn
|
||
(i)
|
||
(map
|
||
(fn
|
||
(j)
|
||
(let
|
||
((col (map (fn (k) (nth ravel (+ j (* k inner-size)))) (range 0 (+ i 1)))))
|
||
(reduce
|
||
(fn
|
||
(a b)
|
||
(disclose (f (apl-scalar a) (apl-scalar b))))
|
||
(first col)
|
||
(rest col))))
|
||
(range 0 inner-size)))
|
||
(range 0 first-dim)))))))))
|
||
|
||
(define
|
||
apl-each
|
||
(fn
|
||
(f arr)
|
||
(let
|
||
((shape (get arr :shape)) (ravel (get arr :ravel)))
|
||
(make-array
|
||
shape
|
||
(map (fn (x) (disclose (f (apl-scalar x)))) ravel)))))
|
||
|
||
(define
|
||
apl-each-dyadic
|
||
(fn
|
||
(f a b)
|
||
(cond
|
||
((and (scalar? a) (scalar? b)) (apl-scalar (disclose (f a b))))
|
||
((scalar? a)
|
||
(make-array
|
||
(get b :shape)
|
||
(map (fn (x) (disclose (f a (apl-scalar x)))) (get b :ravel))))
|
||
((scalar? b)
|
||
(make-array
|
||
(get a :shape)
|
||
(map (fn (x) (disclose (f (apl-scalar x) b))) (get a :ravel))))
|
||
(else
|
||
(if
|
||
(equal? (get a :shape) (get b :shape))
|
||
(make-array
|
||
(get a :shape)
|
||
(map
|
||
(fn (x y) (disclose (f (apl-scalar x) (apl-scalar y))))
|
||
(get a :ravel)
|
||
(get b :ravel)))
|
||
(error "length error: shape mismatch"))))))
|
||
|
||
(define
|
||
apl-outer
|
||
(fn
|
||
(f a b)
|
||
(let
|
||
((a-shape (get a :shape))
|
||
(b-shape (get b :shape))
|
||
(a-ravel (get a :ravel))
|
||
(b-ravel (get b :ravel)))
|
||
(make-array
|
||
(append a-shape b-shape)
|
||
(flatten
|
||
(map
|
||
(fn
|
||
(x)
|
||
(map
|
||
(fn (y) (disclose (f (apl-scalar x) (apl-scalar y))))
|
||
b-ravel))
|
||
a-ravel))))))
|
||
|
||
(define
|
||
apl-inner
|
||
(fn
|
||
(f g a b)
|
||
(let
|
||
((a-shape (get a :shape))
|
||
(b-shape (get b :shape))
|
||
(a-ravel (get a :ravel))
|
||
(b-ravel (get b :ravel)))
|
||
(let
|
||
((a-rank (len a-shape)) (b-rank (len b-shape)))
|
||
(if
|
||
(and (= a-rank 0) (= b-rank 0))
|
||
(apl-scalar (disclose (g a b)))
|
||
(let
|
||
((inner-dim (last a-shape))
|
||
(a-pre (take a-shape (- a-rank 1)))
|
||
(b-post (rest b-shape)))
|
||
(let
|
||
((a-pre-size (reduce * 1 a-pre))
|
||
(b-post-size (reduce * 1 b-post))
|
||
(new-shape (append a-pre b-post)))
|
||
(make-array
|
||
new-shape
|
||
(flatten
|
||
(map
|
||
(fn
|
||
(i)
|
||
(map
|
||
(fn
|
||
(j)
|
||
(let
|
||
((pairs (map (fn (k) (disclose (g (apl-scalar (nth a-ravel (+ (* i inner-dim) k))) (apl-scalar (nth b-ravel (+ (* k b-post-size) j)))))) (range 0 inner-dim))))
|
||
(reduce
|
||
(fn
|
||
(x y)
|
||
(disclose (f (apl-scalar x) (apl-scalar y))))
|
||
(first pairs)
|
||
(rest pairs))))
|
||
(range 0 b-post-size)))
|
||
(range 0 a-pre-size)))))))))))
|
||
|
||
(define apl-commute (fn (f x) (f x x)))
|
||
|
||
(define apl-commute-dyadic (fn (f x y) (f y x)))
|