Artifact
64a1cd90c0d8cbb6ab04414e5e694dbb9d701bef:
- File
srfi/s25/op-ctor.scm
— part of check-in
[80c8c83034]
at
2016-07-07 18:11:39
on branch trunk
— initial import
(user:
ovenpasta@pizzahack.eu
size: 23366)
(begin
(define array:opt-args '(ctor (4)))
(define (array:optimize f r)
(case r
((0) (let ((n0 (f))) (array:0 n0)))
((1) (let ((n0 (f 0))) (array:1 n0 (- (f 1) n0))))
((2)
(let ((n0 (f 0 0)))
(array:2 n0 (- (f 1 0) n0) (- (f 0 1) n0))))
((3)
(let ((n0 (f 0 0 0)))
(array:3
n0
(- (f 1 0 0) n0)
(- (f 0 1 0) n0)
(- (f 0 0 1) n0))))
(else
(let ((v
(do ((k 0 (+ k 1)) (v '() (cons 0 v)))
((= k r) v))))
(let ((n0 (apply f v)))
(apply
array:n
n0
(array:coefficients f n0 v v)))))))
(define (array:optimize-empty r)
(let ((x (make-vector (+ r 1) 0)))
(vector-set! x r -1)
x))
(define (array:coefficients f n0 vs vp)
(case vp
((()) '())
(else
(set-car! vp 1)
(let ((n (- (apply f vs) n0)))
(set-car! vp 0)
(cons n (array:coefficients f n0 vs (cdr vp)))))))
(define (array:vector-index x ks)
(do ((sum 0 (+ sum (* (vector-ref x k) (car ks))))
(ks ks (cdr ks))
(k 0 (+ k 1)))
((null? ks) (+ sum (vector-ref x k)))))
(define (array:shape-index) '#(2 1 0))
(define (array:empty-shape-index) '#(0 0 -1))
(define (array:shape-vector-index x r k)
(+
(* (vector-ref x 0) r)
(* (vector-ref x 1) k)
(vector-ref x 2)))
(define (array:actor-index x k)
(+ (* (vector-ref x 0) k) (vector-ref x 1)))
(define (array:0 n0) (vector n0))
(define (array:1 n0 n1) (vector n1 n0))
(define (array:2 n0 n1 n2) (vector n1 n2 n0))
(define (array:3 n0 n1 n2 n3) (vector n1 n2 n3 n0))
(define (array:n n0 n1 n2 n3 n4 . ns)
(apply vector n1 n2 n3 n4 (append ns (list n0))))
(define (array:maker r)
(case r
((0) array:0)
((1) array:1)
((2) array:2)
((3) array:3)
(else array:n)))
(define array:indexer/vector
(let ((em
(vector
(lambda (x i) (+ (vector-ref x 0)))
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(vector-ref x 1)))
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(* (vector-ref x 1) (vector-ref i 1))
(vector-ref x 2)))
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(* (vector-ref x 1) (vector-ref i 1))
(* (vector-ref x 2) (vector-ref i 2))
(vector-ref x 3)))
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(* (vector-ref x 1) (vector-ref i 1))
(* (vector-ref x 2) (vector-ref i 2))
(* (vector-ref x 3) (vector-ref i 3))
(vector-ref x 4)))
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(* (vector-ref x 1) (vector-ref i 1))
(* (vector-ref x 2) (vector-ref i 2))
(* (vector-ref x 3) (vector-ref i 3))
(* (vector-ref x 4) (vector-ref i 4))
(vector-ref x 5)))
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(* (vector-ref x 1) (vector-ref i 1))
(* (vector-ref x 2) (vector-ref i 2))
(* (vector-ref x 3) (vector-ref i 3))
(* (vector-ref x 4) (vector-ref i 4))
(* (vector-ref x 5) (vector-ref i 5))
(vector-ref x 6)))
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(* (vector-ref x 1) (vector-ref i 1))
(* (vector-ref x 2) (vector-ref i 2))
(* (vector-ref x 3) (vector-ref i 3))
(* (vector-ref x 4) (vector-ref i 4))
(* (vector-ref x 5) (vector-ref i 5))
(* (vector-ref x 6) (vector-ref i 6))
(vector-ref x 7)))
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(* (vector-ref x 1) (vector-ref i 1))
(* (vector-ref x 2) (vector-ref i 2))
(* (vector-ref x 3) (vector-ref i 3))
(* (vector-ref x 4) (vector-ref i 4))
(* (vector-ref x 5) (vector-ref i 5))
(* (vector-ref x 6) (vector-ref i 6))
(* (vector-ref x 7) (vector-ref i 7))
(vector-ref x 8)))
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(* (vector-ref x 1) (vector-ref i 1))
(* (vector-ref x 2) (vector-ref i 2))
(* (vector-ref x 3) (vector-ref i 3))
(* (vector-ref x 4) (vector-ref i 4))
(* (vector-ref x 5) (vector-ref i 5))
(* (vector-ref x 6) (vector-ref i 6))
(* (vector-ref x 7) (vector-ref i 7))
(* (vector-ref x 8) (vector-ref i 8))
(vector-ref x 9)))))
(it
(lambda (w)
(lambda (x i)
(+
(* (vector-ref x 0) (vector-ref i 0))
(* (vector-ref x 1) (vector-ref i 1))
(* (vector-ref x 2) (vector-ref i 2))
(* (vector-ref x 3) (vector-ref i 3))
(* (vector-ref x 4) (vector-ref i 4))
(* (vector-ref x 5) (vector-ref i 5))
(* (vector-ref x 6) (vector-ref i 6))
(* (vector-ref x 7) (vector-ref i 7))
(* (vector-ref x 8) (vector-ref i 8))
(* (vector-ref x 9) (vector-ref i 9))
(do ((xi
0
(+
(* (vector-ref x u) (vector-ref i u))
xi))
(u (- w 1) (- u 1)))
((< u 10) xi))
(vector-ref x w))))))
(lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
(define array:indexer/array
(let ((em
(vector
(lambda (x v i) (+ (vector-ref x 0)))
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(vector-ref x 1)))
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(*
(vector-ref x 1)
(vector-ref v (array:actor-index i 1)))
(vector-ref x 2)))
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(*
(vector-ref x 1)
(vector-ref v (array:actor-index i 1)))
(*
(vector-ref x 2)
(vector-ref v (array:actor-index i 2)))
(vector-ref x 3)))
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(*
(vector-ref x 1)
(vector-ref v (array:actor-index i 1)))
(*
(vector-ref x 2)
(vector-ref v (array:actor-index i 2)))
(*
(vector-ref x 3)
(vector-ref v (array:actor-index i 3)))
(vector-ref x 4)))
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(*
(vector-ref x 1)
(vector-ref v (array:actor-index i 1)))
(*
(vector-ref x 2)
(vector-ref v (array:actor-index i 2)))
(*
(vector-ref x 3)
(vector-ref v (array:actor-index i 3)))
(*
(vector-ref x 4)
(vector-ref v (array:actor-index i 4)))
(vector-ref x 5)))
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(*
(vector-ref x 1)
(vector-ref v (array:actor-index i 1)))
(*
(vector-ref x 2)
(vector-ref v (array:actor-index i 2)))
(*
(vector-ref x 3)
(vector-ref v (array:actor-index i 3)))
(*
(vector-ref x 4)
(vector-ref v (array:actor-index i 4)))
(*
(vector-ref x 5)
(vector-ref v (array:actor-index i 5)))
(vector-ref x 6)))
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(*
(vector-ref x 1)
(vector-ref v (array:actor-index i 1)))
(*
(vector-ref x 2)
(vector-ref v (array:actor-index i 2)))
(*
(vector-ref x 3)
(vector-ref v (array:actor-index i 3)))
(*
(vector-ref x 4)
(vector-ref v (array:actor-index i 4)))
(*
(vector-ref x 5)
(vector-ref v (array:actor-index i 5)))
(*
(vector-ref x 6)
(vector-ref v (array:actor-index i 6)))
(vector-ref x 7)))
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(*
(vector-ref x 1)
(vector-ref v (array:actor-index i 1)))
(*
(vector-ref x 2)
(vector-ref v (array:actor-index i 2)))
(*
(vector-ref x 3)
(vector-ref v (array:actor-index i 3)))
(*
(vector-ref x 4)
(vector-ref v (array:actor-index i 4)))
(*
(vector-ref x 5)
(vector-ref v (array:actor-index i 5)))
(*
(vector-ref x 6)
(vector-ref v (array:actor-index i 6)))
(*
(vector-ref x 7)
(vector-ref v (array:actor-index i 7)))
(vector-ref x 8)))
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(*
(vector-ref x 1)
(vector-ref v (array:actor-index i 1)))
(*
(vector-ref x 2)
(vector-ref v (array:actor-index i 2)))
(*
(vector-ref x 3)
(vector-ref v (array:actor-index i 3)))
(*
(vector-ref x 4)
(vector-ref v (array:actor-index i 4)))
(*
(vector-ref x 5)
(vector-ref v (array:actor-index i 5)))
(*
(vector-ref x 6)
(vector-ref v (array:actor-index i 6)))
(*
(vector-ref x 7)
(vector-ref v (array:actor-index i 7)))
(*
(vector-ref x 8)
(vector-ref v (array:actor-index i 8)))
(vector-ref x 9)))))
(it
(lambda (w)
(lambda (x v i)
(+
(*
(vector-ref x 0)
(vector-ref v (array:actor-index i 0)))
(*
(vector-ref x 1)
(vector-ref v (array:actor-index i 1)))
(*
(vector-ref x 2)
(vector-ref v (array:actor-index i 2)))
(*
(vector-ref x 3)
(vector-ref v (array:actor-index i 3)))
(*
(vector-ref x 4)
(vector-ref v (array:actor-index i 4)))
(*
(vector-ref x 5)
(vector-ref v (array:actor-index i 5)))
(*
(vector-ref x 6)
(vector-ref v (array:actor-index i 6)))
(*
(vector-ref x 7)
(vector-ref v (array:actor-index i 7)))
(*
(vector-ref x 8)
(vector-ref v (array:actor-index i 8)))
(*
(vector-ref x 9)
(vector-ref v (array:actor-index i 9)))
(do ((xi
0
(+
(*
(vector-ref x u)
(vector-ref
v
(array:actor-index i u)))
xi))
(u (- w 1) (- u 1)))
((< u 10) xi))
(vector-ref x w))))))
(lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
(define array:applier-to-vector
(let ((em
(vector
(lambda (p v) (p))
(lambda (p v) (p (vector-ref v 0)))
(lambda (p v)
(p (vector-ref v 0) (vector-ref v 1)))
(lambda (p v)
(p
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)))
(lambda (p v)
(p
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)))
(lambda (p v)
(p
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)
(vector-ref v 4)))
(lambda (p v)
(p
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)
(vector-ref v 4)
(vector-ref v 5)))
(lambda (p v)
(p
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)
(vector-ref v 4)
(vector-ref v 5)
(vector-ref v 6)))
(lambda (p v)
(p
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)
(vector-ref v 4)
(vector-ref v 5)
(vector-ref v 6)
(vector-ref v 7)))
(lambda (p v)
(p
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)
(vector-ref v 4)
(vector-ref v 5)
(vector-ref v 6)
(vector-ref v 7)
(vector-ref v 8)))))
(it
(lambda (r)
(lambda (p v)
(apply
p
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)
(vector-ref v 4)
(vector-ref v 5)
(vector-ref v 6)
(vector-ref v 7)
(vector-ref v 8)
(vector-ref v 9)
(do ((k r (- k 1))
(r
'()
(cons (vector-ref v (- k 1)) r)))
((= k 10) r)))))))
(lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
(define array:applier-to-actor
(let ((em
(vector
(lambda (p a) (p))
(lambda (p a) (p (array-ref a 0)))
(lambda (p a)
(p (array-ref a 0) (array-ref a 1)))
(lambda (p a)
(p
(array-ref a 0)
(array-ref a 1)
(array-ref a 2)))
(lambda (p a)
(p
(array-ref a 0)
(array-ref a 1)
(array-ref a 2)
(array-ref a 3)))
(lambda (p a)
(p
(array-ref a 0)
(array-ref a 1)
(array-ref a 2)
(array-ref a 3)
(array-ref a 4)))
(lambda (p a)
(p
(array-ref a 0)
(array-ref a 1)
(array-ref a 2)
(array-ref a 3)
(array-ref a 4)
(array-ref a 5)))
(lambda (p a)
(p
(array-ref a 0)
(array-ref a 1)
(array-ref a 2)
(array-ref a 3)
(array-ref a 4)
(array-ref a 5)
(array-ref a 6)))
(lambda (p a)
(p
(array-ref a 0)
(array-ref a 1)
(array-ref a 2)
(array-ref a 3)
(array-ref a 4)
(array-ref a 5)
(array-ref a 6)
(array-ref a 7)))
(lambda (p a)
(p
(array-ref a 0)
(array-ref a 1)
(array-ref a 2)
(array-ref a 3)
(array-ref a 4)
(array-ref a 5)
(array-ref a 6)
(array-ref a 7)
(array-ref a 8)))))
(it
(lambda (r)
(lambda (p a)
(apply
a
(array-ref a 0)
(array-ref a 1)
(array-ref a 2)
(array-ref a 3)
(array-ref a 4)
(array-ref a 5)
(array-ref a 6)
(array-ref a 7)
(array-ref a 8)
(array-ref a 9)
(do ((k r (- k 1))
(r '() (cons (array-ref a (- k 1)) r)))
((= k 10) r)))))))
(lambda (r)
"These are high level, hiding implementation at call site."
(if (< r 10) (vector-ref em r) (it r)))))
(define array:applier-to-backing-vector
(let ((em
(vector
(lambda (p ai av) (p))
(lambda (p ai av)
(p (vector-ref av (array:actor-index ai 0))))
(lambda (p ai av)
(p
(vector-ref av (array:actor-index ai 0))
(vector-ref av (array:actor-index ai 1))))
(lambda (p ai av)
(p
(vector-ref av (array:actor-index ai 0))
(vector-ref av (array:actor-index ai 1))
(vector-ref av (array:actor-index ai 2))))
(lambda (p ai av)
(p
(vector-ref av (array:actor-index ai 0))
(vector-ref av (array:actor-index ai 1))
(vector-ref av (array:actor-index ai 2))
(vector-ref av (array:actor-index ai 3))))
(lambda (p ai av)
(p
(vector-ref av (array:actor-index ai 0))
(vector-ref av (array:actor-index ai 1))
(vector-ref av (array:actor-index ai 2))
(vector-ref av (array:actor-index ai 3))
(vector-ref av (array:actor-index ai 4))))
(lambda (p ai av)
(p
(vector-ref av (array:actor-index ai 0))
(vector-ref av (array:actor-index ai 1))
(vector-ref av (array:actor-index ai 2))
(vector-ref av (array:actor-index ai 3))
(vector-ref av (array:actor-index ai 4))
(vector-ref av (array:actor-index ai 5))))
(lambda (p ai av)
(p
(vector-ref av (array:actor-index ai 0))
(vector-ref av (array:actor-index ai 1))
(vector-ref av (array:actor-index ai 2))
(vector-ref av (array:actor-index ai 3))
(vector-ref av (array:actor-index ai 4))
(vector-ref av (array:actor-index ai 5))
(vector-ref av (array:actor-index ai 6))))
(lambda (p ai av)
(p
(vector-ref av (array:actor-index ai 0))
(vector-ref av (array:actor-index ai 1))
(vector-ref av (array:actor-index ai 2))
(vector-ref av (array:actor-index ai 3))
(vector-ref av (array:actor-index ai 4))
(vector-ref av (array:actor-index ai 5))
(vector-ref av (array:actor-index ai 6))
(vector-ref av (array:actor-index ai 7))))
(lambda (p ai av)
(p
(vector-ref av (array:actor-index ai 0))
(vector-ref av (array:actor-index ai 1))
(vector-ref av (array:actor-index ai 2))
(vector-ref av (array:actor-index ai 3))
(vector-ref av (array:actor-index ai 4))
(vector-ref av (array:actor-index ai 5))
(vector-ref av (array:actor-index ai 6))
(vector-ref av (array:actor-index ai 7))
(vector-ref av (array:actor-index ai 8))))))
(it
(lambda (r)
(lambda (p ai av)
(apply
p
(vector-ref av (array:actor-index ai 0))
(vector-ref av (array:actor-index ai 1))
(vector-ref av (array:actor-index ai 2))
(vector-ref av (array:actor-index ai 3))
(vector-ref av (array:actor-index ai 4))
(vector-ref av (array:actor-index ai 5))
(vector-ref av (array:actor-index ai 6))
(vector-ref av (array:actor-index ai 7))
(vector-ref av (array:actor-index ai 8))
(vector-ref av (array:actor-index ai 9))
(do ((k r (- k 1))
(r
'()
(cons
(vector-ref
av
(array:actor-index ai (- k 1)))
r)))
((= k 10) r)))))))
(lambda (r)
"These are low level, exposing implementation at call site."
(if (< r 10) (vector-ref em r) (it r)))))
(define (array:index/vector r x v)
((array:indexer/vector r) x v))
(define (array:index/array r x av ai)
((array:indexer/array r) x av ai))
(define (array:apply-to-vector r p v)
((array:applier-to-vector r) p v))
(define (array:apply-to-actor r p a)
((array:applier-to-actor r) p a)))