work to lazify /\

phantomics · phantomics · commit e6e1e61254b5 · 2022-05-01T09:23:42.000-07:00
diff --git a/aplesque/forms.lisp b/aplesque/forms.lisp
@@ -81,31 +81,29 @@
           (odiv-size (reduce #'* (if dims (loop :for d :in dims :for dx :from 0
                                                 :when (> dx axis) :collect d :when (= dx axis)
                                                   :collect (aref c-degrees (1- (length degrees))))
-                                     ;; (loop :for d :across c-degrees :for dx :from 0
-                                     ;;       :collect (abs d))
-                                     ))))
+                                     (loop :for d :across c-degrees :for dx :from 0
+                                           :collect (abs d))))))
       ;; (print (list :eee dims idiv-size odiv-size c-degrees))
       (lambda (i)
         ;; in compress-mode: degrees must = length of axis,
         ;; zeroes are omitted from output, negatives add zeroes
         ;; otherwise: zeroes pass through, negatives add zeroes, degrees>0 must = length of axis
-        ;; (print (list :ll i))
+        ;; (print (list :ll i odiv-size section-size))
         ;; (setq dims (list 3))
         ;; (setq odiv-size 6)
-        (if t ; dims
-            (multiple-value-bind (oseg remainder) (floor i odiv-size)
-              (multiple-value-bind (oseg-index element-index) (floor remainder section-size)
-                ;; dimension index
-                (let ((dx (loop :for d :across c-degrees :for di :from 0
-                                :when (> d oseg-index) :return di)))
-                  ;; (print (list :dd dx oseg oseg-index section-size odiv-size))
-                  (if (< 0 (aref degrees dx))
-                      (+ element-index (* oseg idiv-size)
-                         (* section-size (if (not positive-indices)
-                                             dx (or (loop :for p :across positive-indices
-                                                          :for px :from 0 :when (= p dx)
-                                                          :return px)
-                                                    1)))))))))))))
+        (multiple-value-bind (oseg remainder) (floor i (max 1 odiv-size))
+          (multiple-value-bind (oseg-index element-index) (floor remainder section-size)
+            ;; dimension index
+            (let ((dx (loop :for d :across c-degrees :for di :from 0
+                            :when (> d oseg-index) :return di)))
+              ;; (print (list :dd dx oseg oseg-index section-size odiv-size))
+              (if (< 0 (aref degrees dx))
+                  (+ element-index (* oseg idiv-size)
+                     (* section-size (if (not positive-indices)
+                                         dx (or (loop :for p :across positive-indices
+                                                      :for px :from 0 :when (= p dx)
+                                                      :return px)
+                                                1))))))))))))
 
 (defun indexer-turn (axis idims &optional degrees)
   "Return indices of an array rotated as with the [⌽ rotate] or [⊖ rotate first] functions."
diff --git a/libraries/dfns/array/array.apl b/libraries/dfns/array/array.apl
@@ -154,7 +154,7 @@ display ← { ⎕IO←0                            ⍝ Boxed display of array.
   deco←{⍺←type open ⍵ ⋄ ⍺,axes ⍵}            ⍝ type and axes vector
   axes←{(-2⌈⍴⍴⍵)↑1+×⍴⍵}                      ⍝ array axis types
   open←{(1⌈⍴⍵)⍴⍵}                            ⍝ exposure of null axes
-  trim←{(~1 1⍷∧⌿⍵=' ')/⎕←⍵}                    ⍝ removal of extra blank cols
+  trim←{(~1 1⍷∧⌿⍵=' ')/⍵}                    ⍝ removal of extra blank cols
   char←{⍬≡⍴⍵:'─' ⋄ (⊃⍵∊'¯',⎕D)⊃'#~'}∘⍕       ⍝ simple scalar type
   type←{{(1=⍴⍵)⊃'+'⍵}∪,char¨⍵}               ⍝ simple array type
   line←{(49=⎕DT 1⍴⍵)⊃' -'}                   ⍝ underline for atom
diff --git a/spec.lisp b/spec.lisp
@@ -991,14 +991,13 @@
             (is "2 1 1 2 3 3 2⍉3 2 3 4 2 4 3⍴⍳1728"
                 #3A(((1 16) (602 617) (1203 1218)) ((385 400) (986 1001) (1587 1602))))))
   (/ (has :title "Replicate")
-     (dyadic (expand-array nil t index-origin axes)
-             ;; (funcall (lambda (n io &optional axes)
-             ;;            (lambda (omega alpha)
-             ;;              (make-instance 'vader-expand :base omega :argument alpha :index-origin io
-             ;;                                           :inverse t :axis (or (first axes) :last))))
-             ;;          nil index-origin axes)
-             )
-     (meta (primary :axes axes :implicit-args (index-origin))
+     (dyadic ;; (expand-array nil t index-origin axes)
+             (funcall (lambda (n io &optional axes)
+                        (lambda (omega alpha)
+                          (make-instance 'vader-expand :base omega :argument alpha :index-origin io
+                                                       :inverse t :axis (or (first axes) :last))))
+                      nil index-origin axes))
+     (meta (primary :axes axes :implicit-args (index-origin) :virtual-support t)
            (dyadic :on-axis :last
                    :inverse (λωαχ (if (is-unitary omega)
                                       ;; TODO: this inverse functionality is probably not complete
@@ -1040,8 +1039,13 @@
             (is "⍴2 3/[2]0 2 0⍴0" #(0 5 0))
             (is "⍴0/2 3 4⍴⍳9" #(2 3 0))))
   (⌿ (has :title "Replicate First")
-     (dyadic (expand-array t t index-origin axes))
-     (meta (primary :axes axes :implicit-args (index-origin))
+     (dyadic ;; (expand-array t t index-origin axes)
+             (funcall (lambda (n io &optional axes)
+                        (lambda (omega alpha)
+                          (make-instance 'vader-expand :base omega :argument alpha :index-origin io
+                                                       :inverse t :axis (or (first axes) io))))
+                      nil index-origin axes))
+     (meta (primary :axes axes :implicit-args (index-origin) :virtual-support t)
            (dyadic :on-axis :first
                    :inverse (λωαχ (if (is-unitary omega)
                                       ;; TODO: this inverse functionality is probably not complete
@@ -1059,14 +1063,13 @@
                                             (1 0 0 3 3 3 0 0 0 0 5 5 5 5 5)
                                             (1 0 0 3 3 3 0 0 0 0 5 5 5 5 5)))))
   (\\ (has :title "Expand")
-      (dyadic (expand-array nil nil index-origin axes)
-              ;; (funcall (lambda (n io &optional axes)
-              ;;           (lambda (omega alpha)
-              ;;             (make-instance 'vader-expand :base omega :argument alpha :index-origin io
-              ;;                                          :axis (or (first axes) :last))))
-              ;;          nil index-origin axes)
-              )
-      (meta (primary :axes axes :implicit-args (index-origin))
+      (dyadic ;; (expand-array nil nil index-origin axes)
+              (funcall (lambda (n io &optional axes)
+                        (lambda (omega alpha)
+                          (make-instance 'vader-expand :base omega :argument alpha :index-origin io
+                                                       :axis (or (first axes) :last))))
+                       nil index-origin axes))
+      (meta (primary :axes axes :implicit-args (index-origin) :virtual-support t)
             (dyadic :on-axis :last))
       (tests (is "4\\2" #(2 2 2 2))
              (is "3\\7" #(7 7 7))
@@ -1092,8 +1095,13 @@
              (is "⍴0 0 0\\0 0⍴0" #(0 3))
              (is "0 0 0 0\\3 0⍴0" #2A((0 0 0 0) (0 0 0 0) (0 0 0 0)))))
   (⍀ (has :title "Expand First")
-     (dyadic (expand-array t nil index-origin axes))
-     (meta (primary :axes axes :implicit-args (index-origin))
+     (dyadic ;; (expand-array t nil index-origin axes)
+             (funcall (lambda (n io &optional axes)
+                        (lambda (omega alpha)
+                          (make-instance 'vader-expand :base omega :argument alpha :index-origin io
+                                                       :axis (or (first axes) io))))
+                       nil index-origin axes))
+     (meta (primary :axes axes :implicit-args (index-origin) :virtual-support t)
            (dyadic :on-axis :first))
      (tests (is "2⍀5" #(5 5))
             (is "2⍀1" #*11)
diff --git a/varray/#varray.asd# b/varray/#varray.asd#
@@ -0,0 +1,11 @@
+x;;;; varray.asd
+
+(asdf:defsystem #:varray
+  :description "Describe varray here"
+  :author "Your Name <your.name@example.com>"
+  :license  "Specify license here"
+  :version "0.0.1"
+  :serial t
+  :depends-on ("aplesque")
+  :components ((:file "package")
+               (:file "varray")))
diff --git a/varray/.#varray.asd b/varray/.#varray.asd
@@ -0,0 +1 @@
+sloane@osidarta.7229:1649572098
diff --git a/varray/varray.lisp b/varray/varray.lisp
@@ -34,8 +34,10 @@
   "The prototype representation of an item is returned by the (apl-array-prototype) function."
   (if (and (arrayp item)
            (array-displacement item)
+           (vectorp (array-displacement item))
            (listp (aref (array-displacement item) 0))
            (member :empty-array-prototype (aref (array-displacement item) 0)))
+      ;; if an empty array prototype has been stored, retrieve it
       (getf (aref (array-displacement item) 0) :empty-array-prototype)
       (apl-array-prototype item)))
 
@@ -89,13 +91,18 @@
   (if (= 0 (array-rank array))
       array (if (= 0 (array-total-size array))
                 (prototype-of array)
-                (lambda (index) (row-major-aref array index)))))
+                (lambda (index)
+                  (row-major-aref array index)))))
 
 (defmethod render ((item t))
   item)
 
 (defmethod render ((varray varray))
+  ;; (print :abc)
+  ;; (print (list :ss (shape-of varray)
+  ;;              (prototype-of varray)))
   (let ((output-shape (shape-of varray))
+        (prototype (prototype-of varray))
         (indexer (indexer-of varray)))
     (if output-shape
         (if (zerop (reduce #'* output-shape))
@@ -108,10 +115,13 @@
                                  (make-array (shape-of varray) :element-type (assign-element-type
                                                                               this-prototype)))))
                 output))
-            (let ((output (make-array (shape-of varray) :element-type (etype-of varray))))
+            (let ((output (make-array (shape-of varray) :element-type (etype-of varray)
+                                      )))
+              ;; (print (list :out output (etype-of varray)))
               (dotimes (i (array-total-size output))
                 (let ((indexed (funcall indexer i)))
-                  (if indexed (setf (row-major-aref output i) indexed))))
+                  (if indexed (setf (row-major-aref output i) indexed)
+                      (setf (row-major-aref output i) prototype))))
               output))
         (funcall indexer 1))))
 
@@ -137,7 +147,8 @@
 ;; the default shape of a derived array is the same as its base array
 (defmethod prototype-of ((varray varray-derived))
   (if (varrayp (vader-base varray))
-      (apl-array-prototype (funcall (indexer-of (vader-base varray)) 0))
+      ;; (apl-array-prototype (funcall (indexer-of (vader-base varray)) 0))
+      (prototype-of (vader-base varray))
       (prototype-of (vader-base varray))))
 
 (defmethod shape-of ((varray varray-derived))
@@ -240,6 +251,7 @@
   nil (:documentation "A reshaped array as from the [⍴ reshape] function."))
 
 (defmethod prototype-of ((varray vader-reshape))
+  (shape-of (vader-base varray)) ;; must get shape so that base array can be rendered
   (let ((indexer (indexer-of (vader-base varray))))
     ;; TODO: remove-disclose when [⍴ shape] is virtually implemented
     (aplesque::make-empty-array (disclose (if (not (functionp indexer))
@@ -251,7 +263,7 @@
   (get-or-assign-shape
    varray (let ((arg (setf (vads-argument varray)
                            (render (vads-argument varray)))))
-            (if (vectorp arg)
+            (if (typep arg 'sequence)
                 (coerce arg 'list)
                 (list arg)))))
 
@@ -361,12 +373,16 @@
 (defclass vader-expand (varray-derived vad-on-axis vad-with-io vad-with-argument vad-invertable)
   nil (:documentation "An expanded (as from [\ expand]) or compressed (as from [/ compress]) array."))
 
-(defmethod prototype-of ((varray vader-expand))
-  (let ((indexer (indexer-of (vader-base varray))))
-    ;; TODO: remove-disclose when [⍴ shape] is virtually implemented
-    (aplesque::make-empty-array (disclose (if (not (functionp indexer))
-                                              indexer ;; ←← remove
-                                              (funcall (indexer-of (vader-base varray)) 0))))))
+;; (defmethod prototype-of ((varray vader-expand))
+;;   (call-next-method)
+;;   ;; (prototype-of (vader-base varray))
+;;   ;; (let ((indexer (indexer-of (vader-base varray))))
+;;   ;;   (print (list :vb (vader-base varray)))
+;;   ;;   ;; TODO: remove-disclose when [⍴ shape] is virtually implemented
+;;   ;;   (aplesque::make-empty-array (disclose (if (not (functionp indexer))
+;;   ;;                                             indexer ;; ←← remove
+;;   ;;                                             (funcall (indexer-of (vader-base varray)) 0)))))
+;;   )
 
 (defmethod shape-of ((varray vader-expand))
   "The shape of an expanded or compressed array."
@@ -377,18 +393,25 @@
           (degrees (setf (vads-argument varray)
                          (funcall (lambda (i)
                                     (if (arrayp i)
-                                        i (vector i)))
+                                        (if (< 0 (array-rank i))
+                                            i (vector (aref i)))
+                                        (vector i)))
                                   (render (vads-argument varray)))))
           (base-shape (copy-list (shape-of (vader-base varray))))
           (base-rank (length base-shape))
           (is-inverse (vads-inverse varray))
           (axis (setf (vads-axis varray)
-                      (max 0 (- (if (eq :last (vads-axis varray))
-                                    base-rank (vads-axis varray))
-                                (vads-io varray))))))
+                      (max 0 (if (eq :last (vads-axis varray))
+                                 (1- base-rank)
+                                 (- (vads-axis varray)
+                                    (vads-io varray)))))))
 
      ;; (print (list :br degrees-count is-inverse base-shape base-rank axis (vads-axis varray)
      ;;              (vader-base varray)))
+
+     ;; (print (list :va (vads-argument varray)))
+     
+     ;; (print (list :deg degrees))
      
      (cond ((and base-shape (zerop (reduce #'* base-shape)))
             ;; (print :ee)
@@ -434,7 +457,6 @@
             (append (butlast base-shape) (list 0)))
            ((and (not base-shape)
                  (not (arrayp degrees)))
-            ;; (print :gg)
             (setf (vads-argument varray) (list (abs degrees))))
            ((and is-inverse base-shape degrees-count (< 1 degrees-count)
                  (nth axis base-shape)
@@ -474,11 +496,18 @@
                       :collect (if (/= index axis) dim (* 1 ex-dim)))))))))
 
 (defmethod indexer-of ((varray vader-expand))
-  (let ((base-indexer (indexer-of (vader-base varray)))
-        (indexer (indexer-expand (coerce (vads-argument varray) 'vector)
-                                 (shape-of (vader-base varray))
-                                 (vads-axis varray)
-                                 (vads-inverse varray))))
+  ;; (Print (list :eeo (vads-argument varray)
+  ;;              (vader-base varray)
+  ;;              (shape-of (vader-base varray))
+  ;;              (vads-axis varray)
+  ;;              (vads-inverse varray)))
+  ;; (print (vads-argument varray))
+  (let* ((arg-vector (coerce (vads-argument varray) 'vector))
+         (base-indexer (indexer-of (vader-base varray)))
+         (indexer (if (< 0 (length arg-vector))
+                      (indexer-expand arg-vector (shape-of (vader-base varray))
+                                      (vads-axis varray)
+                                      (vads-inverse varray)))))
     ;; (PRINT (LIST :ss (shape-of varray)))
     (lambda (index)
       ;; (print (list :iin base-indexer (funcall indexer index) indexer))
@@ -488,8 +517,6 @@
           (let ((indexed (funcall indexer index)))
             (if indexed (funcall base-indexer indexed)))))))
 
-;; (defclass vader-meta-scalar-pass (varray-derived) nil)
-
 (defclass vader-turn (varray-derived vad-on-axis vad-with-io vad-with-argument)
   nil (:documentation "A rotated array as from the [⌽ rotate] function."))
 
