new primal arrays including one-hot vectors

Author: phantomics

README.md

@@ -837,10 +837,10 @@ April makes available the following APL system variables, constants and function
 ⎕IO ⎕CT ⎕PP ⎕DIV ⎕RL ⎕A ⎕D ⎕TS ⎕NS ⎕CS ⎕UCS ⎕FMT
 ```
 
-Additionally, April exposes these system variables and function not found in other APL implementations:
+Additionally, April exposes these system variables and functions not found in other APL implementations:
 
 ```
-⎕OST ⎕DT ⎕XWV ⎕XWF ⎕XWO
+⎕OST ⎕TY ⎕XWV ⎕XWF ⎕XWO
 ```
 
 [Click here to read the names and descriptions of these symbols.](./environmental-symbols.md)
@@ -987,7 +987,7 @@ APL's function editor system and control statements are not implemented; this ty
 
 ## April's Lexicon Compared to Other APLs
 
-APL has multiple implementations, and there are subtle but significant variations between the lexical functions they offer. April's set of functions is closest to those offered by Dyalog APL in its default mode. For instance, in April, dyadic `⊂` implements the partitioned enclose function while dyadic `⊆` implements the partition function, as in Dyalog. In IBM APL2, however, there is no partitioned enclose function and dyadic `⊂` implements the partition function. The same is true in GNU APL, whose design primarily follows APL2.
+APL has multiple implementations and there are subtle but significant variations between the lexical functions they offer. April's set of functions is closest to those offered by Dyalog APL in its default mode. For instance, in April dyadic `⊂` implements the partitioned enclose function while dyadic `⊆` implements the partition function, as in Dyalog. In IBM APL2, however, there is no partitioned enclose function and dyadic `⊂` implements the partition function. The same is true in GNU APL, whose design primarily follows APL2.
 
 The other major lexical difference between APL2-family languages and April is that in April, monadic `⊃` implements the disclose function and monadic `↑` implements the mix function; the converse is true in APL2.
 

demos/fnn/demo.lisp

@@ -481,7 +481,7 @@ To test against only the first N images in the set. In the above case, only the
 (let ((net-shape) (net-state) (image-size 0) (training-data) (training-labels) (test-data) (test-labels)
       ;; tabled vectors representing the target states for the 10 digits
       (segment-dims) (tdata-segment) (tsdata-segment) (ovec-length) (output-holder) (oh-segment)
-      (target-arrays (april "(⊂3⎕DT 10 1↑1)⊖¨⍨-⎕IO-⍨⍳10")))
+      (target-arrays (april "(⊂3⎕TY 10 1↑1)⊖¨⍨-⎕IO-⍨⍳10")))
   (defun load-digit-data ()
     "Load the training dataset of handwritten digit images from MNIST."
     (unless training-data

environmental-symbols.md

@@ -51,7 +51,7 @@ These symbols represent standard functions available within April. Currently, th
 
 |Symbol|Name                       |Description|
 |------|---------------------------|-----------|
-|`⎕DT` |Coerce/Get Type            |Get enumerated type of an array or coerce an array to an enumerated type.|
+|`⎕TY` |Coerce/Get Type            |Get enumerated type of an array or coerce an array to an enumerated type.|
 |`⎕XWV`|External Workspace Value   |Fetch one or more values from another workspace.|
 |`⎕XWF`|External Workspace Function|Fetch one or more functions from another workspace.|
 |`⎕XWO`|External Workspace Operator|Fetch one or more operators from another workspace.|

functions.lisp

@@ -301,7 +301,7 @@
                                (let ((generator (generator-of index)))
                                  (if (not (functionp generator))
                                      generator (funcall generator 0)))))))
-    (if int-index (make-instance 'vapri-integer-progression :number int-index :origin index-origin)
+    (if int-index (make-instance 'vapri-arith-provec :number int-index :origin index-origin)
         (make-instance 'vapri-coordinate-identity :shape index :index-origin index-origin))))
 
 (defun at-index (index-origin axes)

libraries/dfns/array/array.apl

@@ -157,7 +157,7 @@ display ← { ⎕IO←0                            ⍝ Boxed display of array.
   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
+  line←{(49=⎕TY 1⍴⍵)⊃' -'}                   ⍝ underline for atom
 
   { ⎕IO←0                                    ⍝ recursive boxing of arrays:
     0=≡⍵:' '⍪(open ⎕FMT ⍵)⍪line ⍵            ⍝ simple scalar

spec.lisp

@@ -261,7 +261,7 @@
  (symbols (:variable ⎕ to-output ⎕io *index-origin* ⎕pp print-precision ⎕div *division-method*
                      ⎕ost output-stream ⎕ct *comparison-tolerance* ⎕rl *rngs*)
           (:constant ⎕a *alphabet-vector* ⎕d *digit-vector* ⎕ts *apl-timestamp*)
-          (:function ⎕ns make-namespace ⎕cs change-namespace ⎕dt coerce-or-get-type
+          (:function ⎕ns make-namespace ⎕cs change-namespace ⎕ty coerce-or-get-type
                      ⎕ucs scalar-code-char ⎕fmt (format-array-uncollated print-precision)
                      ⎕xwv external-workspace-value ⎕xwf external-workspace-function
                      ⎕xwo external-workspace-operator))
@@ -2141,6 +2141,7 @@
   (for "Inverse circular ops."   "{(5○⍨-⍵)=⍵∘○⍣¯1⊢5} ⍳12" #(1 1 1 1 1 1 1 1 1 1 1 1))
   (for "Inverse indexing." "⍳⍣¯1⊢1 2 3 4 5" 5)
   (for "Inverse where." "(⍸⍣¯1) 4 5 9" #*000110001)
+  (for "Inverse where, right tack-separated." "⍸⍣¯1⊢4 5 9" #*000110001)
   (for "Another inverse where." "(⍸⍣¯1) (1 2) (2 3)" #2A((0 1 0) (0 0 1)))
   (for "Inverse mix."      "↑⍣¯2⊢2 3 4⍴⍳9" #(#(#(1 2 3 4) #(5 6 7 8) #(9 1 2 3))
                                              #(#(4 5 6 7) #(8 9 1 2) #(3 4 5 6))))

utilities.lisp

@@ -1374,7 +1374,7 @@
               (error "Not a valid namespace."))))))
 
 (defun coerce-or-get-type (array &optional type-index)
-  "Create an array with a numerically designated type holding the contents of the given array. Used to implement ⎕DT."
+  "Create an array with a numerically designated type holding the contents of the given array. Used to implement ⎕TY."
   (let ((array (vrender array))
         (types '((0 t) (-1 bit) (1 (unsigned-byte 2)) (2 (unsigned-byte 4))
                  (-3 (unsigned-byte 7)) (3 (unsigned-byte 8)) (-4 (unsigned-byte 15))

varray/base.lisp

@@ -717,6 +717,7 @@
                                               (let ((count (aref counts dx)))
                                                 (unless (zerop count)
                                                   (let ((start-at (aref start-points dx)))
+                                                    ;; (print (list :sa start-points start-at count))
                                                     (lambda ()
                                                       (funcall jit-gen start-at
                                                                count iaddr oaddr)))))))))))
@@ -736,7 +737,7 @@
                                                   ;; (print (list :st start-at count))
                                                   (funcall jit-gen start-at count
                                                            (vader-base varray) output)))))))))
-                              
+                              ;; (when segment-handler (push varray april::*stuff*))
                               ;; (print (list :pro divisions sbesize sbsize))
                               ;; (print (list :out (type-of output) (type-of varray)
                               ;;              divisions division-size sbesize sbsize
@@ -745,7 +746,10 @@
                               ;;                (vacmp-threadable varray))))
                               ;; (print (list :ts to-nest (setf april::ggt varray)))
                               ;; (print (list :jg jit-gen))
-                              (loop :for d :below divisions :for dx :from 0
+                              ;; TODO: segment handler system requires iteration over all threads,
+                              ;; is there a way to consolidate the logic?
+                              (loop :for d :below (if segment-handler wcadj divisions)
+                                    :for dx :from 0
                                     :do (if (or (and (typep varray 'vader-composing)
                                                      (not (vacmp-async varray)))
                                                 ;; don't thread when rendering the output of operators composed
@@ -973,6 +977,7 @@
           (assign-element-type (vader-base varray)))))
 
 (defmethod shape-of :around ((varray varray-derived))
+  "Extend derived arrays' shape-of methods to collect data on array shape over the course of an array transformation."
   (let* ((this-shape (lparallel::force (call-next-method)))
          (metadata (metadata-of varray))
          (shape-meta (getf metadata :shape)))

varray/calculate.lisp

@@ -96,7 +96,7 @@
      (flet ((shape-matches (a)
               (loop :for s1 :in shape :for s2 :in (shape-of a) :always (= s1 s2))))
        (typecase (vader-base varray)
-         (vapri-integer-progression nil)
+         (vapri-arith-provec nil)
          ((or varray sequence)
           (loop :for i :below base-size
                 :do (let ((a (if base-gen (funcall base-gen i)

varray/composed.lisp

@@ -293,7 +293,7 @@
                 :when (and window (= dx axis))
                   :do (setq wsegment (- dim (1- window))))
           (cond
-            ((and scalar-fn (typep (vacmp-omega varray) 'vapri-integer-progression))
+            ((and scalar-fn (typep (vacmp-omega varray) 'vapri-arith-provec))
              (get-reduced (vacmp-omega varray) (vacmp-left varray)))
             ((and (or scalar-fn (and catenate-fn (not window)))
                   (not out-dims) (arrayp (vacmp-omega varray)))

varray/derived.lisp

@@ -364,8 +364,9 @@
   (get-promised
    (varray-shape varray)
    (let ((base (vader-base varray)))
+     (typecase base (vader-identity (setf base (vader-base base))))
      (typecase base
-       (vapri-integer-progression
+       (vapri-arith-provec
         (if (and (= 1 (vapip-repeat base))
                  (= 1 (vapip-factor base))
                  (= (vads-io varray) (vapip-origin base)))
@@ -391,8 +392,9 @@
 (defmethod generator-of ((varray vader-inverse-where) &optional indexers params)
   (declare (ignore indexers))
   (let ((base (vader-base varray)))
+     (typecase base (vader-identity (setf base (vader-base base))))
     (typecase base
-      (vapri-integer-progression 1)
+      (vapri-arith-provec 1)
       (vapri-coordinate-identity 1)
       (vader-where
        (setf (vader-content varray)
@@ -3284,7 +3286,7 @@
 (defmethod inverse-count-to ((varray vader-identity) index-origin)
   (inverse-count-to (vader-base varray) index-origin))
 
-(defmethod inverse-count-to ((varray vapri-integer-progression) index-origin)
+(defmethod inverse-count-to ((varray vapri-arith-provec) index-origin)
   ;; TODO: this does not get invoked by for instance ⍳⍣¯1⊢⍳9 because of the identity varray
   (if (and (= 1 (vapip-repeat varray))
            (= 1 (vapip-factor varray))

varray/effectors-x86-asm.lisp

@@ -536,24 +536,26 @@
          (etag (case encoding (8 :byte) (16 :word) (32 :dword) (64 :qword))))
     (case format
       (:x86-asm
-       (lambda (symbols)
-         (let ((sum 0))
-           (loop :for dx :below (rank-of varray)
-                 :do (incf sum (ash (+ (aref (vasec-span varray) dx)
-                                       (aref (vasec-pad varray) dx))
-                                    (* coordinate-type
-                                       (- (rank-of varray) (1+ dx))))))
-           (destructuring-bind (_ _ _ _ _ _ r8 &rest _) symbols
-             (declare (ignore _))
-             (unless (zerop sum)
-               `((inst add ,etag ,r8 ,sum)))))))
+       ;; current disabled when padding is present
+       (when (loop :for p :across (vasec-pad varray) :always (zerop p))
+         (lambda (symbols)
+           (let ((sum 0))
+             (loop :for dx :below (rank-of varray)
+                   :do (incf sum (ash (+ (aref (vasec-span varray) dx)
+                                         (aref (vasec-pad varray) dx))
+                                      (* coordinate-type
+                                         (- (rank-of varray) (1+ dx))))))
+             (destructuring-bind (_ _ _ _ _ _ r8 &rest _) symbols
+               (declare (ignore _))
+               (unless (zerop sum)
+                 `((inst add ,etag ,r8 ,sum))))))))
       (t (call-next-method)))))
 
 (defmethod effector-of :around ((varray vader-turn) &optional params)
   (let* ((format (getf params :format))
          (ewidth (getf (rest (getf params :gen-meta)) :index-width))
          (cwidth (getf (rest (getf params :gen-meta)) :index-type))
-         (etag (case ewidth (8 :byte) (16 :word) (32 :dword) (64 :qword)))
+         (etag (case ewidth (8 :byte) (16 :word) (32 :dword) (64 :qword))) ; 3 4 4 3 3 3 3 3 3 3
          (axis (max 0 (if (eq :last (vads-axis varray))
                           (1- (rank-of varray))
                           (- (vads-axis varray)
@@ -577,6 +579,7 @@
          (let* ((cindex (- (rank-of varray) (1+ axis)))
                 (adj-degrees (ash (vaturn-degrees varray) (* cwidth cindex)))
                 (adj-dim (ash dimension (* cwidth cindex)))
+                ;; (ltag (when ))
                 (mask (ash (1- (expt 2 cwidth)) (* cwidth cindex)))
                 (ROTATED (gensym)))
            (destructuring-bind (ra rc rd rb r6 r7 r8 r9 r10 r11) symbols

varray/logic.lisp

@@ -22,8 +22,8 @@
                    (make-instance 'vader-enclose :base (funcall function (vader-base (first base))))))))
          ((= 2 (length base))
           (let ((iota-first (and (typep (first base) 'integer)
-                                 (typep (second base) 'vapri-integer-progression)))
-                (iota-second (and (typep (first base) 'vapri-integer-progression)
+                                 (typep (second base) 'vapri-arith-provec)))
+                (iota-second (and (typep (first base) 'vapri-arith-provec)
                                   (typep (second base) 'integer)))
                 (lex-ref (getf params :lexical-reference)))
             (cond ((and lex-ref (or (numberp (first base))
@@ -41,7 +41,7 @@
                         lex-ref (member lex-ref arith-functions :test #'char=)
                         (not (and iota-second (char= #\÷ lex-ref))))
                    (destructuring-bind (iota number) (if iota-second base (reverse base))
-                     (make-instance 'vapri-integer-progression
+                     (make-instance 'vapri-arith-provec
                                     :number (vapip-number iota) :origin (vapip-origin iota)
                                     :offset (if (not (member lex-ref add-sub-functions :test #'char=))
                                                 (vapip-offset iota)
@@ -60,6 +60,25 @@
                                                       (funcall function number (vapip-factor iota)))))
                                     :repeat (vapip-repeat iota))))))))))))
 
+(defun extend-allocator-vader-inverse-where (&key base argument index-origin)
+  "Extend allocation behavior of inverse-where class; allows the use of ⍸⍣¯1 to create one-hot vectors."
+  (declare (ignore argument))
+  (let ((base-shape (shape-of base)))
+    (when (and (not (second base-shape))
+               (first base-shape) (= 1 (first base-shape)))
+      (let ((base-val (funcall (generator-of base) 0)))
+        (when (and (integerp base-val) (plusp base-val))
+          (make-instance 'vapri-onehot-vector :shape (list base-val) :index (- base-val index-origin)))))))
+
+(defun extend-allocator-vader-section (&key base argument inverse axis index-origin)
+  "Extend allocation behavior of section class; allows resizing of one-hot vectors."
+  (declare (ignore axis index-origin))
+  (typecase base
+    (vapri-onehot-vector (when (or (not (listp argument))
+                                   (= 1 (length argument))))
+                           (make-instance 'vapri-onehot-vector :shape (list argument)
+                                          :index (vaohv-index base)))))
+
 (defun extend-allocator-vader-permute (&key base argument index-origin)
   "Extend allocation behavior of permute class; allows simple inversion of permutation without an argument."
   (declare (ignore axis index-origin))
@@ -72,10 +91,10 @@
   "Extend allocation behavior of expand class; allows for 3/⍳3 to produce a repeating integer progression vector instead of a vader-expand instance."
   (declare (ignore axis index-origin inverse))
   (typecase base
-    (vapri-integer-progression
+    (vapri-arith-provec
      (let ((rendered-argument (unless (shape-of argument) (render argument))))
        (when (integerp rendered-argument)
-         (make-instance 'vapri-integer-progression
+         (make-instance 'vapri-arith-provec
                         :number (vapip-number base) :origin (vapip-origin base)
                         :offset (vapip-offset base) :factor (vapip-factor base)
                         :repeat (* rendered-argument (vapip-repeat base))))))))

varray/package.lisp

@@ -4,7 +4,7 @@
 (defpackage #:varray
   (:use #:cl)
   (:export #:varray #:varrayp #:etype-of #:shape-of #:size-of #:rank-of #:generator-of #:assign-rank
-           #:vrender #:vapri-integer-progression #:vapri-coordinate-identity #:vader-calculate
+           #:vrender #:vapri-arith-provec #:vapri-coordinate-identity #:vader-calculate
            #:vader-select #:vader-random #:vader-deal #:vader-without #:vader-umask
            #:vader-index #:vader-shape #:vader-reshape #:vader-depth #:vader-first-dim
            #:vader-compare #:vader-enlist #:vader-membership #:vader-find #:vader-where