Skip to content

Commit 232fa94

Browse files
phantomicsphantomics
committed
lazify ⍤
1 parent 56c9851 commit 232fa94

File tree

3 files changed

+116
-123
lines changed

3 files changed

+116
-123
lines changed

‎functions.lisp

+114-114
Original file line numberDiff line numberDiff line change
@@ -1323,16 +1323,101 @@
13231323
(if fn-right omega right)
13241324
(if fn-left omega left))))))))
13251325

1326+
(defun operate-at-rank (rank function)
1327+
"Generate a function applying a function to sub-arrays of the arguments. Used to implement [⍤ rank]."
1328+
(lambda (omega &optional alpha environment blank)
1329+
(declare (ignore environment blank))
1330+
(let* ((rank (render-varrays rank))
1331+
(odims (shape-of omega)) (adims (shape-of alpha))
1332+
(orank (varray::rank-of omega)) (arank (varray::rank-of alpha))
1333+
(fn-meta (funcall function :get-metadata nil))
1334+
;; if alpha is nil the monadic metadata will be fetched, otherwise the dyadic data will be
1335+
(rank (if (not (arrayp rank))
1336+
(if (> 0 rank) ;; handle a negative rank as for ,⍤¯1⊢2 3 4⍴⍳24
1337+
(make-array 3 :initial-contents (list (max 0 (+ rank orank))
1338+
(max 0 (+ rank (if alpha arank orank)))
1339+
(max 0 (+ rank orank))))
1340+
(make-array 3 :initial-element rank))
1341+
(if (= 1 (size rank))
1342+
(make-array 3 :initial-element (row-major-aref rank 0))
1343+
(if (= 2 (size rank))
1344+
(make-array 3 :initial-contents (list (aref rank 1)
1345+
(aref rank 0) (aref rank 1)))
1346+
(if (= 3 (size rank))
1347+
rank (when (or (< 1 (rank rank)) (< 3 (size rank)))
1348+
(error "Right operand of [⍤ rank] must be a scalar integer or ~a"
1349+
"integer vector no more than 3 elements long.")))))))
1350+
(ocrank (aref rank 2))
1351+
(acrank (aref rank 1))
1352+
(omrank (aref rank 0))
1353+
(orankdelta (- orank (if alpha ocrank omrank)))
1354+
(odivs (when (<= 0 orankdelta) (make-array (subseq odims 0 orankdelta))))
1355+
(odiv-dims (when odivs (subseq odims orankdelta)))
1356+
(odiv-size (when odivs (reduce #'* odiv-dims)))
1357+
(arankdelta (- arank acrank))
1358+
(adivs (when (and alpha (<= 0 arankdelta))
1359+
(make-array (subseq adims 0 arankdelta))))
1360+
(adiv-dims (when adivs (subseq adims arankdelta)))
1361+
(adiv-size (when alpha (reduce #'* adiv-dims))))
1362+
(when (and alpha (eq :monadic (getf fn-meta :valence)))
1363+
(error "Function composed with [⍤ rank] may not have a left argument."))
1364+
(when (and (not alpha) (eq :dyadic (getf fn-meta :valence)))
1365+
(error "Function composed with [⍤ rank] must have a left argument."))
1366+
(if (eq omega :get-metadata)
1367+
(append fn-meta (list :composed-by #\⍤))
1368+
(if (and (getf fn-meta :on-axis)
1369+
(= 1 (if alpha ocrank omrank)))
1370+
;; if the composed function is directly equivalent to a function that operates
1371+
;; across an axis, as ⊖⍤1 and ⌽⍤1 are to ⌽, just reassign the axis
1372+
(apply (if (eq :last (getf fn-meta :on-axis))
1373+
function (funcall function :reassign-axes (list orank)))
1374+
omega (when alpha (list alpha)))
1375+
(flet ((generate-divs (div-array ref-array div-dims div-size)
1376+
(let ((ref-indexer (indexer-of ref-array)))
1377+
(dotimes (i (size div-array))
1378+
(setf (row-major-aref div-array i)
1379+
(if (zerop (rank div-array)) ref-array
1380+
(if (not div-dims) (funcall ref-indexer i)
1381+
(make-instance 'varray::vader-subarray-displaced
1382+
:shape div-dims :index i
1383+
:base ref-array))))))))
1384+
(when odivs (generate-divs odivs omega odiv-dims odiv-size))
1385+
(if alpha (progn (when adivs (generate-divs adivs alpha adiv-dims adiv-size))
1386+
(if (not (or odivs adivs))
1387+
;; if alpha and omega are scalar, just call the function on them
1388+
(funcall function omega alpha)
1389+
(let ((output (make-array (dims (or odivs adivs)))))
1390+
(dotimes (i (size output))
1391+
(let ((this-odiv (if (not odivs)
1392+
omega (if (zerop (rank odivs))
1393+
(aref odivs)
1394+
(row-major-aref odivs i))))
1395+
(this-adiv (if (not adivs)
1396+
alpha (if (zerop (rank adivs))
1397+
(aref adivs)
1398+
(row-major-aref adivs i)))))
1399+
(setf (row-major-aref output i)
1400+
(funcall function this-odiv this-adiv))))
1401+
(make-instance 'vader-mix :base output :subrendering t
1402+
:axis (max (rank odivs) (rank adivs))))))
1403+
(if (not odivs) ;; as above for an omega value alone
1404+
(funcall function omega)
1405+
(let ((output (make-array (dims odivs))))
1406+
(dotimes (i (size output))
1407+
(setf (row-major-aref output i)
1408+
(funcall function (row-major-aref odivs i))))
1409+
(make-instance 'vader-mix :base output :subrendering t
1410+
:axis (rank output)))))))))))
1411+
13261412
;; (defun operate-at-rank (rank function)
13271413
;; "Generate a function applying a function to sub-arrays of the arguments. Used to implement [⍤ rank]."
13281414
;; (lambda (omega &optional alpha environment blank)
13291415
;; (declare (ignore environment blank))
1330-
;; ;; (setq omega (render-varrays omega)
1331-
;; ;; alpha (render-varrays alpha))
1332-
;; (let* ((rank (render-varrays rank))
1333-
;; (odims (shape-of omega)) (adims (shape-of alpha))
1334-
;; (orank (varray::rank-of omega)) (arank (varray::rank-of alpha))
1335-
;; (fn-meta (funcall function :get-metadata nil))
1416+
;; (setq omega (render-varrays omega)
1417+
;; alpha (render-varrays alpha))
1418+
;; (let* ((odims (dims omega)) (adims (dims alpha))
1419+
;; (orank (rank omega)) (arank (rank alpha))
1420+
;; (fn-meta (funcall function :get-metadata alpha))
13361421
;; ;; if alpha is nil the monadic metadata will be fetched, otherwise the dyadic data will be
13371422
;; (rank (if (not (arrayp rank))
13381423
;; (if (> 0 rank) ;; handle a negative rank as for ,⍤¯1⊢2 3 4⍴⍳24
@@ -1345,62 +1430,59 @@
13451430
;; (if (= 2 (size rank))
13461431
;; (make-array 3 :initial-contents (list (aref rank 1) (aref rank 0) (aref rank 1)))
13471432
;; (if (= 3 (size rank))
1348-
;; rank (when (or (< 1 (rank rank)) (< 3 (size rank)))
1349-
;; (error "Right operand of [⍤ rank] must be a scalar integer or ~a"
1350-
;; "integer vector no more than 3 elements long.")))))))
1433+
;; rank (if (or (< 1 (rank rank)) (< 3 (size rank)))
1434+
;; (error "Right operand of [⍤ rank] must be a scalar integer or ~a"
1435+
;; "integer vector no more than 3 elements long.")))))))
13511436
;; (ocrank (aref rank 2))
13521437
;; (acrank (aref rank 1))
13531438
;; (omrank (aref rank 0))
13541439
;; (orankdelta (- orank (if alpha ocrank omrank)))
1355-
;; (odivs (when (<= 0 orankdelta) (make-array (subseq odims 0 orankdelta))))
1356-
;; (odiv-dims (when odivs (subseq odims orankdelta)))
1357-
;; (odiv-size (when odivs (reduce #'* odiv-dims)))
1440+
;; (odivs (if (<= 0 orankdelta) (make-array (subseq odims 0 orankdelta))))
1441+
;; (odiv-dims (if odivs (subseq odims orankdelta)))
1442+
;; (odiv-size (if odivs (reduce #'* odiv-dims)))
13581443
;; (arankdelta (- arank acrank))
1359-
;; (adivs (when (and alpha (<= 0 arankdelta))
1360-
;; (make-array (subseq adims 0 arankdelta))))
1361-
;; (adiv-dims (when adivs (subseq adims arankdelta)))
1362-
;; (adiv-size (when alpha (reduce #'* adiv-dims))))
1363-
;; (when (and alpha (eq :monadic (getf fn-meta :valence)))
1364-
;; (error "Function composed with [⍤ rank] may not have a left argument."))
1365-
;; (when (and (not alpha) (eq :dyadic (getf fn-meta :valence)))
1366-
;; (error "Function composed with [⍤ rank] must have a left argument."))
1444+
;; (adivs (if (and alpha (<= 0 arankdelta))
1445+
;; (make-array (subseq adims 0 arankdelta))))
1446+
;; (adiv-dims (if adivs (subseq adims arankdelta)))
1447+
;; (adiv-size (if alpha (reduce #'* adiv-dims))))
1448+
;; (if (and alpha (eq :monadic (getf fn-meta :valence)))
1449+
;; (error "Function composed with [⍤ rank] may not have a left argument."))
1450+
;; (if (and (not alpha) (eq :dyadic (getf fn-meta :valence)))
1451+
;; (error "Function composed with [⍤ rank] must have a left argument."))
13671452
;; (if (eq omega :get-metadata)
13681453
;; (append fn-meta (list :composed-by #\⍤))
13691454
;; (if (and (getf fn-meta :on-axis)
13701455
;; (= 1 (if alpha ocrank omrank)))
13711456
;; ;; if the composed function is directly equivalent to a function that operates
13721457
;; ;; across an axis, as ⊖⍤1 and ⌽⍤1 are to ⌽, just reassign the axis
13731458
;; (apply (if (eq :last (getf fn-meta :on-axis))
1374-
;; function (funcall function :reassign-axes (list orank)))
1375-
;; omega (when alpha (list alpha)))
1459+
;; function (funcall function :reassign-axes (list (rank omega))))
1460+
;; omega (if alpha (list alpha)))
13761461
;; (flet ((generate-divs (div-array ref-array div-dims div-size)
13771462
;; (xdotimes div-array (i (size div-array))
13781463
;; (setf (row-major-aref div-array i)
13791464
;; (if (zerop (rank div-array)) ref-array
13801465
;; (if (not div-dims) (row-major-aref ref-array i)
13811466
;; (make-array div-dims :element-type (element-type ref-array)
13821467
;; :displaced-to ref-array
1383-
;; :displaced-index-offset (* i div-size))
1384-
;; (make-instance 'varray::vader-subarray-displaced
1385-
;; :shape div-dims :index i :base ref-array)
1386-
;; ))))))
1387-
;; (when odivs (generate-divs odivs omega odiv-dims odiv-size))
1388-
;; (if alpha (progn (when adivs (generate-divs adivs alpha adiv-dims adiv-size))
1468+
;; :displaced-index-offset (* i div-size))))))))
1469+
;; (if odivs (generate-divs odivs omega odiv-dims odiv-size))
1470+
;; (if alpha (progn (if adivs (generate-divs adivs alpha adiv-dims adiv-size))
13891471
;; (if (not (or odivs adivs))
13901472
;; ;; if alpha and omega are scalar, just call the function on them
13911473
;; (funcall function omega alpha)
13921474
;; (let ((output (make-array (dims (or odivs adivs)))))
1475+
;; (print (list :od odivs adivs))
13931476
;; (xdotimes output (i (size output))
13941477
;; (let ((this-odiv (if (not odivs)
13951478
;; omega (if (zerop (rank odivs))
1396-
;; (aref odivs)
1397-
;; (row-major-aref odivs i))))
1479+
;; (aref odivs) (row-major-aref odivs i))))
13981480
;; (this-adiv (if (not adivs)
13991481
;; alpha (if (zerop (rank adivs))
1400-
;; (aref adivs)
1401-
;; (row-major-aref adivs i)))))
1482+
;; (aref adivs) (row-major-aref adivs i)))))
14021483
;; (setf (row-major-aref output i)
14031484
;; (disclose (render-varrays (funcall function this-odiv this-adiv))))))
1485+
;; (print (list :ou output))
14041486
;; (mix-arrays (max (rank odivs) (rank adivs))
14051487
;; output))))
14061488
;; (if (not odivs) ;; as above for an omega value alone
@@ -1411,88 +1493,6 @@
14111493
;; (render-varrays (funcall function (row-major-aref odivs i)))))
14121494
;; (mix-arrays (rank output) output))))))))))
14131495

1414-
(defun operate-at-rank (rank function)
1415-
"Generate a function applying a function to sub-arrays of the arguments. Used to implement [⍤ rank]."
1416-
(lambda (omega &optional alpha environment blank)
1417-
(declare (ignore environment blank))
1418-
(setq omega (render-varrays omega)
1419-
alpha (render-varrays alpha))
1420-
(let* ((odims (dims omega)) (adims (dims alpha))
1421-
(orank (rank omega)) (arank (rank alpha))
1422-
(fn-meta (funcall function :get-metadata alpha))
1423-
;; if alpha is nil the monadic metadata will be fetched, otherwise the dyadic data will be
1424-
(rank (if (not (arrayp rank))
1425-
(if (> 0 rank) ;; handle a negative rank as for ,⍤¯1⊢2 3 4⍴⍳24
1426-
(make-array 3 :initial-contents (list (max 0 (+ rank orank))
1427-
(max 0 (+ rank (if alpha arank orank)))
1428-
(max 0 (+ rank orank))))
1429-
(make-array 3 :initial-element rank))
1430-
(if (= 1 (size rank))
1431-
(make-array 3 :initial-element (row-major-aref rank 0))
1432-
(if (= 2 (size rank))
1433-
(make-array 3 :initial-contents (list (aref rank 1) (aref rank 0) (aref rank 1)))
1434-
(if (= 3 (size rank))
1435-
rank (if (or (< 1 (rank rank)) (< 3 (size rank)))
1436-
(error "Right operand of [⍤ rank] must be a scalar integer or ~a"
1437-
"integer vector no more than 3 elements long.")))))))
1438-
(ocrank (aref rank 2))
1439-
(acrank (aref rank 1))
1440-
(omrank (aref rank 0))
1441-
(orankdelta (- orank (if alpha ocrank omrank)))
1442-
(odivs (if (<= 0 orankdelta) (make-array (subseq odims 0 orankdelta))))
1443-
(odiv-dims (if odivs (subseq odims orankdelta)))
1444-
(odiv-size (if odivs (reduce #'* odiv-dims)))
1445-
(arankdelta (- arank acrank))
1446-
(adivs (if (and alpha (<= 0 arankdelta))
1447-
(make-array (subseq adims 0 arankdelta))))
1448-
(adiv-dims (if adivs (subseq adims arankdelta)))
1449-
(adiv-size (if alpha (reduce #'* adiv-dims))))
1450-
(if (and alpha (eq :monadic (getf fn-meta :valence)))
1451-
(error "Function composed with [⍤ rank] may not have a left argument."))
1452-
(if (and (not alpha) (eq :dyadic (getf fn-meta :valence)))
1453-
(error "Function composed with [⍤ rank] must have a left argument."))
1454-
(if (eq omega :get-metadata)
1455-
(append fn-meta (list :composed-by #\⍤))
1456-
(if (and (getf fn-meta :on-axis)
1457-
(= 1 (if alpha ocrank omrank)))
1458-
;; if the composed function is directly equivalent to a function that operates
1459-
;; across an axis, as ⊖⍤1 and ⌽⍤1 are to ⌽, just reassign the axis
1460-
(apply (if (eq :last (getf fn-meta :on-axis))
1461-
function (funcall function :reassign-axes (list (rank omega))))
1462-
omega (if alpha (list alpha)))
1463-
(flet ((generate-divs (div-array ref-array div-dims div-size)
1464-
(xdotimes div-array (i (size div-array))
1465-
(setf (row-major-aref div-array i)
1466-
(if (zerop (rank div-array)) ref-array
1467-
(if (not div-dims) (row-major-aref ref-array i)
1468-
(make-array div-dims :element-type (element-type ref-array)
1469-
:displaced-to ref-array
1470-
:displaced-index-offset (* i div-size))))))))
1471-
(if odivs (generate-divs odivs omega odiv-dims odiv-size))
1472-
(if alpha (progn (if adivs (generate-divs adivs alpha adiv-dims adiv-size))
1473-
(if (not (or odivs adivs))
1474-
;; if alpha and omega are scalar, just call the function on them
1475-
(funcall function omega alpha)
1476-
(let ((output (make-array (dims (or odivs adivs)))))
1477-
(xdotimes output (i (size output))
1478-
(let ((this-odiv (if (not odivs)
1479-
omega (if (zerop (rank odivs))
1480-
(aref odivs) (row-major-aref odivs i))))
1481-
(this-adiv (if (not adivs)
1482-
alpha (if (zerop (rank adivs))
1483-
(aref adivs) (row-major-aref adivs i)))))
1484-
(setf (row-major-aref output i)
1485-
(disclose (render-varrays (funcall function this-odiv this-adiv))))))
1486-
(mix-arrays (max (rank odivs) (rank adivs))
1487-
output))))
1488-
(if (not odivs) ;; as above for an omega value alone
1489-
(funcall function omega)
1490-
(let ((output (make-array (dims odivs))))
1491-
(xdotimes output (i (size output) :synchronous-if (not (side-effect-free function)))
1492-
(setf (row-major-aref output i)
1493-
(render-varrays (funcall function (row-major-aref odivs i)))))
1494-
(mix-arrays (rank output) output))))))))))
1495-
14961496
(defun operate-atop (right-fn left-fn)
14971497
"Generate a function applying two functions to a value in succession. Used to implement [⍤ atop]."
14981498
(lambda (omega &optional alpha environment blank)

0 commit comments

Comments
 (0)