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

(define apl-compose (fn (f g x) (f (g x))))

(define apl-compose-dyadic (fn (f g x y) (f x (g y))))

(define
  apl-power
  (fn (f n x) (reduce (fn (acc i) (f acc)) x (range 0 n))))

(define
  apl-power-fixed
  (fn
    (f x)
    (let
      ((next (f x)))
      (if
        (and
          (equal? (get next :shape) (get x :shape))
          (equal? (get next :ravel) (get x :ravel)))
        x
        (apl-power-fixed f next)))))

(define
  apl-rank
  (fn
    (f k arr)
    (let
      ((shape (get arr :shape)) (ravel (get arr :ravel)))
      (let
        ((rank (len shape)))
        (if
          (>= k rank)
          (f arr)
          (let
            ((frame-shape (take shape (- rank k)))
              (cell-shape (drop shape (- rank k))))
            (let
              ((frame-size (reduce * 1 frame-shape))
                (cell-size (reduce * 1 cell-shape)))
              (let
                ((cells (map (fn (i) (let ((start (* i cell-size))) (make-array cell-shape (map (fn (j) (nth ravel (+ start j))) (range 0 cell-size))))) (range 0 frame-size))))
                (let
                  ((results (map (fn (c) (f c)) cells)))
                  (make-array
                    (append frame-shape (get (first results) :shape))
                    (flatten (map (fn (r) (get r :ravel)) results))))))))))))

(define
  apl-at-replace
  (fn
    (vals idxs arr)
    (let
      ((vals-ravel (get vals :ravel))
        (idxs-ravel (get idxs :ravel))
        (arr-ravel (get arr :ravel))
        (arr-shape (get arr :shape))
        (vals-scalar? (= (len (get vals :shape)) 0)))
      (make-array
        arr-shape
        (map
          (fn
            (i)
            (let
              ((pos (index-of idxs-ravel (+ i apl-io))))
              (if
                pos
                (if vals-scalar? (first vals-ravel) (nth vals-ravel pos))
                (nth arr-ravel i))))
          (range 0 (len arr-ravel)))))))

(define
  apl-at-apply
  (fn
    (f idxs arr)
    (let
      ((idxs-ravel (get idxs :ravel))
        (arr-ravel (get arr :ravel))
        (arr-shape (get arr :shape)))
      (make-array
        arr-shape
        (map
          (fn
            (i)
            (let
              ((pos (index-of idxs-ravel (+ i apl-io))))
              (if
                pos
                (disclose (f (apl-scalar (nth arr-ravel i))))
                (nth arr-ravel i))))
          (range 0 (len arr-ravel)))))))