From 44e1f750e1095ee1a4fbfcdea7e81f87934f4214 Mon Sep 17 00:00:00 2001 From: phantomics Date: Sat, 15 Dec 2018 18:05:09 -0800 Subject: [PATCH] fixes & cleanup for release --- README.md | 54 +++++----- aplesque/aplesque.asd | 5 +- aplesque/aplesque.lisp | 227 ++++++++++++++++++----------------------- april.asd | 7 +- spec.lisp | 50 ++++----- utilities.lisp | 77 ++++++-------- vex/vex.asd | 5 +- vex/vex.lisp | 34 +++--- 8 files changed, 208 insertions(+), 251 deletions(-) diff --git a/README.md b/README.md index 2a04084c..89bca065 100644 --- a/README.md +++ b/README.md @@ -16,7 +16,7 @@ But no longer. Lisp is the great connector of the software world, digesting and ## Installation -April depends on Common Lisp, ASDF and Quicklisp. The only Common Lisp implementation tested so far has been Steel Bank Common Lisp (SBCL). +April depends on Common Lisp, ASDF and Quicklisp. It has been tested with Steel Bank Common Lisp (SBCL), Armed Bear Common Lisp (ABCL) and LispWorks. ### Preparing Quicklisp @@ -31,7 +31,7 @@ ln -s ~/mystuff/april To complete the installation, just start a Common Lisp REPL and enter: -``` +```lisp (ql:quickload 'april) ``` @@ -49,7 +49,7 @@ Some APL functions and operators won't be added to April since they don't make s Evaluating an APL expression is as simple as: -``` +```lisp * (april "1+2 3 4") #(3 4 5) @@ -61,7 +61,7 @@ The macro (april) will evaluate any APL string passed to it as the sole argument Setting state properties for the APL instance can be done like this: -``` +```lisp * (april (set (:state :count-from 0)) "⍳9") #(0 1 2 3 4 5 6 7 8) @@ -71,7 +71,7 @@ Instead of an APL string, the first argument to (april) may be a list of specifi For example, you can use this configuration setting to determine whether the APL instance will start counting from 0 or 1. -``` +```lisp * (april (set (:state :count-from 1)) "⍳9") #(1 2 3 4 5 6 7 8 9) @@ -83,7 +83,7 @@ For example, you can use this configuration setting to determine whether the APL More APL expressions: -``` +```lisp * (april "⍳12") #(1 2 3 4 5 6 7 8 9 10 11 12) @@ -117,13 +117,13 @@ More APL expressions: When the (april) macro is called, you may pass it either a single text string: -``` +```lisp * (april "1+1 2 3") ``` Or a parameter object followed by a text string: -``` +```lisp * (april (set (:state :count-from 0)) "⍳9") ``` @@ -133,7 +133,7 @@ This section details the parameters you can pass to April. To run April's test suite, just enter: -``` +```lisp * (april (test)) ``` @@ -141,7 +141,7 @@ To run April's test suite, just enter: (set) is the workhorse of April parameters, allowing you to configure your April instance in many ways. The most common sub-parameter passed via (set) is (:state). To wit: -``` +```lisp * (april (set (:state :count-from 1 :in ((a 1) (b 2)) :out (a c))) @@ -163,26 +163,26 @@ Sets the index from which April counts. Almost always set to 0 or 1. The default Passes variables into the April instance that may be used when evaluating the subsequent expressions. In the example above, the variables "a" and "b" are set in the code, with values 1 and 2 respectively. You can use :in to pass values from Lisp into the April instance. -Please note that April variables follow a stricter naming convention than Lisp variables. When naming the input variables, only alphanumeric characters and dashes may be used. In keeping with APL tradition, the triangle characters ∆ and ⍙ can be used in variable names as well. Punctuation marks like ?, >, . and ! must not be used as they have separate meanings in April. +Please note that April variables follow a stricter naming convention than Lisp variables. When naming the input variables, only alphanumeric characters and dashes may be used. In keeping with APL tradition, the delta/triangle characters ∆ and ⍙ can be used in variable names as well. Punctuation marks like ?, >, . and ! must not be used as they have separate meanings in April. These characters may be used in April variable names: ``` -0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz∆⍙ +0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_∆⍙ ``` These variable names are ok: ``` -a var my-var +a var my_var ``` These are not ok: ``` -true! this->that pass/fail? var.name +true! this->that pass/fail? another-var var.name ``` -Note also that variables are converted from Lisp-style dash-separated format into camel case for use within April code. For example: +You can use dashes in the names of Lisp variables you pass into April, but inside April they will be converted to camel case. For example: -``` +```lisp * (april (set (:state :in ((my-var 2) (other-var 5)))) "myVar×otherVar+5") @@ -201,7 +201,7 @@ my-var-∆ → myVar∆ Lists variables to be output when the code has finished evaluating. By default, the value of the last evaluated expression is passed back after an April evaluation is finished. For example: -``` +```lisp * (april "1+2 2+3 3+4") @@ -211,7 +211,7 @@ Lists variables to be output when the code has finished evaluating. By default, The last value calculated is displayed. The :out sub-parameter allows you to list a set of variables that whose values will be returned once evaluation is complete. For example: -``` +```lisp * (april (set (:state :out (a b c))) "a←9+2 b←5+3 @@ -226,14 +226,14 @@ The last value calculated is displayed. The :out sub-parameter allows you to lis In APL, there's really no such thing as a value outside an array. Every piece of data used within an April instance is an array. When you enter something like 1+1, you're actually adding two arrays containing a single value, 1, and outputting another array containing the value 2. When April returns arrays like this, its default behavior is to disclose them like this: -``` +```lisp * (april "1+1") 2 ``` But if you set the :disclose-output option to nil, you can change this: -``` +```lisp * (april (set (:state :disclose-output nil)) "1+1") #(2) @@ -245,7 +245,7 @@ With :disclose-output set to nil, unitary vectors will be passed directly back w If you want to create a persistent workspace where the functions and variables you've created are stored and can be used in multiple calls to April, use the (:space) parameter. For example: -``` +```lisp * (april (set (:space *space1*)) "a←5+2 ⋄ b←3×9") 27 @@ -267,7 +267,7 @@ You can use the :state-persistent parameter to set state values within the works For example: -``` +```lisp * (april (set (:state-persistent :count-from 0) (:space *space1*)) "⍳7") #(0 1 2 3 4 5 6) @@ -285,7 +285,7 @@ Did you notice that when switching to a different space, in this case *space2*, You can use :state-persistent to set persistent input variables that will stay available for each piece of code you run in your April instance. If these input variables refer to external Lisp variables, changing the external variables will change the values available to April. Like this: -``` +```lisp * (defvar *dynamic-var* 2) *DYNAMIC-VAR* @@ -309,17 +309,17 @@ You can use :state-persistent to set persistent input variables that will stay a If you just want to compile the code you enter into April without running it, use this option. For example: -``` +```lisp * (april (set (:compile-only)) "1+1 2 3") -(PROGN (DISCLOSE (APL-CALL + (SCALAR-FUNCTION +) (AVECTOR 1 2 3) (AVECTOR 1)))) +(DISCLOSE-ATOM (APL-CALL + (SCALAR-FUNCTION +) (AVECTOR 1 2 3) (AVECTOR 1))) ``` ### (restore-defaults) To restore all of April's state variables to the default values, enter: -``` +```lisp * (april (restore-defaults)) ``` @@ -376,7 +376,7 @@ System functions and variables within APL are not implemented, along with APL's If you missed it earlier, you can run tests for the implemented APL functions and operators by entering: -``` +```lisp (april (test)) ``` diff --git a/aplesque/aplesque.asd b/aplesque/aplesque.asd index b3924bfa..801ca42a 100644 --- a/aplesque/aplesque.asd +++ b/aplesque/aplesque.asd @@ -1,11 +1,12 @@ ;;;; aplesque.asd -(asdf:defsystem #:aplesque +(asdf:defsystem "aplesque" :description "A collection of array manipulation functions patterned after functions from the APL language." + :version "1.0.0" :author "Andrew Sengul" :license "Apache-2.0" :serial t - :depends-on (:alexandria :array-operations :parse-number :symbol-munger) + :depends-on ("alexandria" "array-operations" "parse-number" "symbol-munger") :components ((:file "package") (:file "aplesque"))) diff --git a/aplesque/aplesque.lisp b/aplesque/aplesque.lisp index a8bd2929..50ff7a81 100644 --- a/aplesque/aplesque.lisp +++ b/aplesque/aplesque.lisp @@ -121,6 +121,7 @@ (rotate-left (- (length l) n) l)) (defun multidim-slice (array dimensions &key (inverse nil) (fill-with 0)) + "Take a subsection of an array of the same rank and given dimensions as per APL's ↑ function, or invert the function as per APL's ↓ function to take the elements of an array excepting a specific dimensional range." (let* ((adims (dims array)) (output (make-array (mapcar (lambda (outdim indim) (if (not inverse) @@ -128,35 +129,32 @@ dimensions adims) :initial-element fill-with :element-type (type-of array)))) (run-dim array (lambda (element coords) + (declare (ignore element)) (let* ((coord t) (target (loop :for c :from 0 :to (1- (length coords)) :while coord - :do (let ((cx (nth c coords)) (ix (nth c adims)) - (ox (nth c dimensions))) - (setq coord (cond ((and inverse (> 0 ox)) - (if (< cx (+ ix ox)) - cx)) - (inverse (if (> ix (+ cx ox)) - (+ cx ox))) - ((> 0 ox) - (if (>= cx (+ ox ix)) - (- cx (+ ox ix)))) - (t (if (and (< cx ox) - (< cx ix)) - cx))))) - :collect coord))) + :collect (let ((cx (nth c coords)) (ix (nth c adims)) + (ox (nth c dimensions))) + (setq coord (cond ((and inverse (> 0 ox)) + (if (< cx (+ ix ox)) + cx)) + (inverse (if (> ix (+ cx ox)) + (+ cx ox))) + ((> 0 ox) + (if (>= cx (+ ox ix)) + (- cx (+ ox ix)))) + (t (if (and (< cx ox) + (< cx ix)) + cx)))))))) (if coord (setf (apply #'aref (cons output (if inverse coords target))) (apply #'aref (cons array (if inverse target coords)))))))) output)) (defun scan-back (function input &optional output) (if (not input) - output (if (not output) + output (if output (scan-back function (rest input) + (disclose (funcall function (first input) output))) (scan-back function (cddr input) - (disclose (funcall function (second input) - (first input)))) - (scan-back function (rest input) - (disclose (funcall function (first input) - output)))))) + (disclose (funcall function (second input) (first input))))))) (defun make-back-scanner (function) "Build a function to scan across an array, modifying each value as determined by prior values." @@ -171,13 +169,13 @@ (defmacro do-permuted (array axis arank &body body) - `(if (> ,axis (1- arank)) + `(if (> ,axis (1- ,arank)) (error "Invalid axis.") - (progn (if (not (= ,axis (1- arank))) - (setq ,array (aops:permute (rotate-left (1+ axis) (iota arank)) + (progn (if (not (= ,axis (1- ,arank))) + (setq ,array (aops:permute (rotate-left (1+ axis) (iota ,arank)) ,array))) - ,@body (if (not (= ,axis (1- arank))) - (aops:permute (rotate-right (1+ axis) (iota arank)) + ,@body (if (not (= ,axis (1- ,arank))) + (aops:permute (rotate-right (1+ axis) (iota ,arank)) ,array) ,array)))) @@ -219,11 +217,11 @@ (defun laminate (a1 a2 axis) (let* ((permute-dims (alexandria:iota (1+ (rank a1)))) (pa1 (if (not (is-unitary a1)) - (aops:permute (rotate-right axis permute-dims) - (array-promote a1)))) + (aops:permute (rotate-right axis permute-dims) + (array-promote a1)))) (pa2 (if (not (is-unitary a2)) - (aops:permute (rotate-right axis permute-dims) - (array-promote a2))))) + (aops:permute (rotate-right axis permute-dims) + (array-promote a2))))) ;; a 1-element array argument to laminate is scaled to ;; match the other array's dimensions (aops:stack axis (if (is-unitary a1) @@ -539,7 +537,6 @@ (defun interval-index (atomic-vector) "Return a function to find the locations of indices of an array between the indices of a reference array." (lambda (items reference) - ;; TODO: add higher rank and nested functionality (labels ((interval-compare (ref) (lambda (oitem) (let ((match 0)) @@ -550,8 +547,7 @@ ref) match)))) (if (vectorp reference) - (aops:each (interval-compare reference) - items) + (aops:each (interval-compare reference) items) (if (and (<= (rank reference) (rank items)) (let ((rdims (reverse (rest (dims reference)))) (idims (reverse (dims items)))) @@ -587,20 +583,16 @@ (defun find-array (array target) "Find instances of an array within a larger array." (let ((target-head (row-major-aref target 0)) - (target-dims (append (if (< (rank target) - (rank array)) - (loop :for index :from 0 :to (1- (- (rank array) - (rank target))) + (target-dims (append (if (< (rank target) (rank array)) + (loop :for index :from 0 :to (1- (- (rank array) (rank target))) :collect 1)) (dims target))) - (output (make-array (dims array) - :element-type 'bit :initial-element 0)) - (match-coords nil) - (confirmed-matches nil)) - (run-dim array (lambda (element coords) - (if (equal element target-head) - (setq match-coords (cons coords match-coords))))) - (loop :for match :in match-coords + (output (make-array (dims array) :element-type 'bit :initial-element 0))) + (loop :for match :in (let ((match-coords nil)) + (run-dim array (lambda (element coords) + (if (equal element target-head) + (setq match-coords (cons coords match-coords))))) + match-coords) :do (let ((target-index 0) (target-matched t) (target-displaced (make-array (list (array-total-size target)) @@ -610,40 +602,26 @@ (if (and (< target-index (length target-displaced)) (not (equal element (aref target-displaced target-index)))) (setq target-matched nil)) - (incf target-index 1)) + (incf target-index)) :start-at match :limit target-dims) ;; check the target index in case the elements in the searched array ran out (if (and target-matched (= target-index (length target-displaced))) - (setq confirmed-matches (cons match confirmed-matches))))) - (loop :for match :in confirmed-matches - :do (setf (apply #'aref (cons output match)) - 1)) + (incf (apply #'aref (cons output match)))))) output)) -(defun run-dim (array function &key (dimensions nil) (indices nil) (start-at nil) (limit nil) (elision nil)) - "Iterate across a range of elements in an array, with an optional starting point, limits and elision." - (let ((dimensions (if dimensions dimensions (dims array)))) - (flet ((for-element (elix &optional source-index) - (if source-index (setq elix source-index)) - (if (< (length indices) - (1- (length dimensions))) - (run-dim array function :indices (append indices (list elix)) :elision elision - :dimensions dimensions :start-at start-at :limit limit) - (funcall function (apply #'aref (cons array (append indices (list elix)))) - (append indices (list elix)))))) - (let ((elided (nth (length indices) elision)) - (this-start (nth (length indices) start-at))) - (if (and elision elided) - (if (listp elided) - (loop :for elix :from 0 :to (1- (length elided)) - :do (for-element elix (nth elix elided))) - (for-element elided)) - (loop :for elix :from (if this-start this-start 0) - :to (min (if limit (+ (if this-start this-start 0) - -1 (nth (length indices) limit)) - (1- (nth (length indices) dimensions))) - (1- (nth (length indices) dimensions))) - :do (for-element elix))))))) +(defun run-dim (array function &key (start-at nil) (limit nil) (indices nil)) + "Iterate across a range of elements in an array, with an optional starting point and limits for iterating over portions of an array." + (let* ((dimensions (dims array)) + (this-start (nth (length indices) start-at))) + (loop :for elix :from (if this-start this-start 0) + :to (min (if limit (+ (if this-start this-start 0) + -1 (nth (length indices) limit)) + (1- (nth (length indices) dimensions))) + (1- (nth (length indices) dimensions))) + :do (if (< (length indices) (1- (length dimensions))) + (run-dim array function :start-at start-at :limit limit :indices (append indices (list elix))) + (funcall function (apply #'aref (cons array (append indices (list elix)))) + (append indices (list elix))))))) (defun aref-eliding (array aindices &key (fn #'identity) (set nil) (set-coords nil)) ;; (print (list :ar array aindices)) @@ -736,7 +714,7 @@ :displaced-to (aops:each #'dims arrays)))) (loop :for dx :from 0 :to (1- (length (aref mdims 0))) :collect (apply #'max (array-to-list (aops:each (lambda (n) (nth dx n)) - mdims))))))) + mdims))))))) (first-element (apply #'aref (cons arrays (loop :for i :from 0 :to (1- (rank arrays)) :collect 0))))) ;; TODO: the recombine option and some other things are hacks, how better to handle cases @@ -780,59 +758,54 @@ (defun ravel (count-from array &optional axes) "Produce a vector from the elements of a multidimensional array." - (flet ((linsert (newelt lst index) - (if (= 0 index) - (setq lst (cons newelt lst)) - (push newelt (cdr (nthcdr (1- index) lst)))) - lst)) - (if (and (not axes) - (vectorp array)) - array (if axes - (cond ((and (= 1 (length (first axes))) - (not (integerp (aref (first axes) 0)))) - (make-array (if (and (vectorp (aref (first axes) 0)) - (= 0 (length (aref (first axes) 0)))) - (append (dims array) - (list 1)) - (linsert 1 (dims array) - (- (ceiling (aref (first axes) 0)) - count-from))) - :element-type (element-type array) - :displaced-to (copy-array array))) - ((and (< 1 (length (first axes))) - (or (< (aref (first axes) 0) - 0) - (> (aref (first axes) - (1- (length (first axes)))) - (rank array)) - (not (loop :for index :from 1 :to (1- (length (first axes))) - :always (= (aref (first axes) index) - (1+ (aref (first axes) - (1- index)))))))) - (error - "Dimension indices must be consecutive and within the array's number of dimensions.")) - ((< 1 (length (first axes))) - (let* ((axl (mapcar (lambda (item) (- item count-from)) - (array-to-list (first axes)))) - (collapsed (apply #'* (mapcar (lambda (index) (nth index (dims array))) - axl)))) - (labels ((dproc (dms &optional index output) - (let ((index (if index index 0))) - (if (not dms) - (reverse output) - (dproc (if (= index (first axl)) - (nthcdr (length axl) dms) - (rest dms)) - (1+ index) - (cons (if (= index (first axl)) - collapsed (first dms)) - output)))))) - (make-array (dproc (dims array)) - :element-type (element-type array) - :displaced-to (copy-array array)))))) - (make-array (list (array-total-size array)) - :element-type (element-type array) - :displaced-to (copy-array array)))))) + (if (and (not axes) (= 1 (rank array))) + array (if axes (cond ((and (= 1 (length (first axes))) + (not (integerp (aref (first axes) 0)))) + (make-array (if (and (vectorp (aref (first axes) 0)) + (= 0 (length (aref (first axes) 0)))) + (append (dims array) + (list 1)) + (funcall (lambda (lst index) + (if (= 0 index) + (setq lst (cons 1 lst)) + (push 1 (cdr (nthcdr (1- index) lst)))) + lst) + (dims array) + (- (ceiling (aref (first axes) 0)) + count-from))) + :element-type (element-type array) + :displaced-to (copy-array array))) + ((and (< 1 (length (first axes))) + (or (> 0 (aref (first axes) 0)) + (> (aref (first axes) (1- (length (first axes)))) + (rank array)) + (not (loop :for index :from 1 :to (1- (length (first axes))) + :always (= (aref (first axes) index) + (1+ (aref (first axes) (1- index)))))))) + (error (concatenate 'string "Dimension indices must be consecutive and within " + "the array's number of dimensions."))) + ((< 1 (length (first axes))) + (let* ((axl (mapcar (lambda (item) (- item count-from)) + (array-to-list (first axes)))) + (collapsed (apply #'* (mapcar (lambda (index) (nth index (dims array))) + axl)))) + (labels ((dproc (dms &optional index output) + (let ((index (if index index 0))) + (if (not dms) + (reverse output) + (dproc (if (= index (first axl)) + (nthcdr (length axl) dms) + (rest dms)) + (1+ index) + (cons (if (= index (first axl)) + collapsed (first dms)) + output)))))) + (make-array (dproc (dims array)) + :element-type (element-type array) + :displaced-to (copy-array array)))))) + (make-array (list (array-total-size array)) + :element-type (element-type array) + :displaced-to (copy-array array))))) (defun re-enclose (matrix axes) "Convert an array into a set of sub-arrays listed within a larger array. The dimensions of the containing array and the sub-arrays will be some combination of the dimensions of the original array. For example, a 2 x 3 x 4 array may be composed into a 3-element vector containing 2 x 4 dimensional arrays." diff --git a/april.asd b/april.asd index 1ec35f28..a0e1a1d4 100644 --- a/april.asd +++ b/april.asd @@ -1,12 +1,13 @@ ;;;; april.asd -(asdf:defsystem #:april +(asdf:defsystem "april" :description "April is a subset of the APL programming language that compiles to Common Lisp." + :version "1.0.0" :author "Andrew Sengul" :license "Apache-2.0" :serial t - :depends-on (:vex :aplesque :array-operations :alexandria - :cl-ppcre :parse-number :symbol-munger :prove) + :depends-on ("vex" "aplesque" "array-operations" "alexandria" "cl-ppcre" + "parse-number" "symbol-munger" "prove") :components ((:file "package") (:file "utilities") diff --git a/spec.lisp b/spec.lisp index 78ccb124..59d0cffd 100644 --- a/spec.lisp +++ b/spec.lisp @@ -35,7 +35,7 @@ :match-token-character (lambda (char) (or (alphanumericp char) - (member char (list #\. #\∆ #\⍙ #\¯ #\⍺ #\⍵ #\⍬)))) + (member char (list #\. #\_ #\∆ #\⍙ #\¯ #\⍺ #\⍵ #\⍬)))) ;; overloaded numeric characters may be functions or operators or may be part of a numeric token ;; depending on their context :match-overloaded-numeric-character (lambda (char) (char= #\. char)) @@ -56,8 +56,7 @@ (lambda (form) ;; wrap the last element of the compiled output in a disclose form if discloseOutput is set (if (of-state this-idiom :disclose-output) - (append (butlast form) - (list (list 'disclose-atom (first (last form))))) + (append (butlast form) (list (list 'disclose-atom (first (last form))))) form)) :postprocess-value (lambda (item) @@ -236,8 +235,7 @@ (let ((omega (disclose omega))) (if (not (integerp omega)) (error "The argument to ⍳ must be a single integer, i.e. ⍳9.") - (make-array (list omega) - :initial-contents (iota omega :start index-origin))))) + (make-array (list omega) :initial-contents (iota omega :start index-origin))))) (lambda (omega alpha) (index-of omega alpha index-origin))) (tests (is "⍳5" #(1 2 3 4 5)) (is "3⍳1 2 3 4 5" #(2 2 1 2 2)))) @@ -252,13 +250,10 @@ (is "4 5⍴⍳3" #2A((1 2 3 1 2) (3 1 2 3 1) (2 3 1 2 3) (1 2 3 1 2))))) (⌷ (has :title "Index") (dyadic (lambda (omega alpha &optional axes) - ;; (print (list :al alpha)) - (enclose (aref-eliding omega (let ((coords (array-to-list (apply-scalar #'- alpha - index-origin))) + (enclose (aref-eliding omega (let ((coords (array-to-list (apply-scalar #'- alpha index-origin))) (axis (if (first axes) (array-to-list (apply-scalar #'- (first axes) index-origin))))) - ;; (print (list :cc coords)) (if (not axis) coords (loop :for dim :from 0 :to (1- (rank omega)) :collect (if (member dim axis) @@ -434,13 +429,11 @@ (loop :for i :from 0 :to (1- (length omega)) :collect (list (aref omega i)))) (let ((o-dims (dims omega))) - (make-array (list (first o-dims) - (apply #'* (rest o-dims))) + (make-array (list (first o-dims) (apply #'* (rest o-dims))) :element-type (element-type omega) :displaced-to (copy-array omega))))) (lambda (omega alpha &optional axes) - (if (and (vectorp alpha) - (vectorp omega)) + (if (and (vectorp alpha) (vectorp omega)) (if (and axes (< 0 (- (aref (first axes) 0) index-origin))) (error (concatenate 'string "Specified axis is greater than 1, vectors" @@ -451,9 +444,8 @@ (concatenate 'vector alpha omega))) (if (or (not axes) (integerp (aref (first axes) 0))) - (catenate alpha omega (if axes (- (aref (first axes) 0) - index-origin) - 0)))))) + (catenate alpha omega (if (not axes) 0 (- (aref (first axes) 0) + index-origin))))))) (tests (is "⍪'MAKE'" #2A((#\M) (#\A) (#\K) (#\E))) (is "⍪3 4⍴⍳9" #2A((1 2 3 4) (5 6 7 8) (9 1 2 3))) (is "⍪2 3 4⍴⍳24" #2A((1 2 3 4 5 6 7 8 9 10 11 12) @@ -946,17 +938,17 @@ ,(resolve-function :dyadic operand) (let ((items (if alpha (gethash key key-table) (funcall indices-of key keys)))) - (funcall (if (= 1 (length items)) - (lambda (v) (vector (vector v))) - #'identity) + (funcall (if (< 1 (length items)) + #'identity (lambda (v) (vector v))) (make-array (list (length items)) - :initial-contents items))) + :initial-contents + (reverse items)))) key)))) (mix-arrays 0 (apply #'vector item-sets))))))) - (tests (is "fruit←'Apple' 'Orange' 'Apple' 'Pear' 'Orange' 'Peach' - quantities ← 12 3 2 6 8 16 5 ⋄ fruit {⍺ ⍵}⌸ quantities" - #2A(((#\A #\p #\p #\l #\e) (2 12)) ((#\O #\r #\a #\n #\g #\e) (8 3)) - ((#\P #\e #\a #\r) (6)) ((#\P #\e #\a #\c #\h) (16)))) + (tests (is "fruit←'Apple' 'Orange' 'Apple' 'Pear' 'Orange' 'Peach' 'Pear' 'Pear' + quantities ← 12 3 2 6 8 16 7 3 ⋄ fruit {⍺ ⍵}⌸ quantities" + #2A(((#\A #\p #\p #\l #\e) (12 2)) ((#\O #\r #\a #\n #\g #\e) (3 8)) + ((#\P #\e #\a #\r) (6 7 3)) ((#\P #\e #\a #\c #\h) 16))) (is "fruit←'Apple' 'Orange' 'Apple' 'Pear' 'Orange' 'Peach' ⋄ {⍴⍵}⌸ fruit" #2A((2) (2) (1) (1))))) (\. (has :title "Inner/Outer Product") @@ -984,7 +976,7 @@ (a (if (arrayp a) a (vector a)))) (if (is-unitary o) ;; swap arguments in case of a - ;; singleton omega argument + ;; unitary omega argument (let ((placeholder a)) (setq a o o placeholder))) @@ -1004,8 +996,7 @@ ;; to preserve the rank of the result (reduce ,op-left (apply-scalar ,op-right alpha omega))) (array-inner-product alpha omega (lambda (arg1 arg2) - (if (or (arrayp arg1) - (arrayp arg2)) + (if (or (arrayp arg1) (arrayp arg2)) (apply-scalar ,op-right arg1 arg2) (funcall ,op-right arg1 arg2))) ,op-left))))))) @@ -1085,9 +1076,8 @@ (iota arank :start index-origin)))))))) (if alpha (mix-arrays 0 (if romega (if ralpha (each fn romega ralpha) - (each fn romega - (make-array (dims romega) - :initial-element alpha))) + (each fn romega (make-array (dims romega) + :initial-element alpha))) (if ralpha (each fn (make-array (dims ralpha) :initial-element omega) ralpha) diff --git a/utilities.lisp b/utilities.lisp index 9293df6d..cab10985 100644 --- a/utilities.lisp +++ b/utilities.lisp @@ -17,7 +17,7 @@ (arrayp item) (is-unitary item) (not (arrayp (aref item 0)))) - (apply #'aref (cons item (loop :for i :from 0 :to (1- (rank item)) :collect 0))) + (row-major-aref item 0) item)) (defun array-to-nested-vector (array) @@ -46,8 +46,7 @@ (if (not omega) (let ((omega alpha)) (if (arrayp omega) - (labels ((apply-fn (arg) (if (arrayp arg) - (aops:each #'apply-fn arg) + (labels ((apply-fn (arg) (if (arrayp arg) (aops:each #'apply-fn arg) (funcall function arg)))) (aops:each #'apply-fn omega)) (funcall function omega))) @@ -55,39 +54,34 @@ (omega-scalar? (not (arrayp omega))) (alpha-unitary? (or alpha-scalar? (is-unitary alpha))) (omega-unitary? (or omega-scalar? (is-unitary omega)))) - (flet ((disclose-non-vector (input) - (if (not (and (is-unitary input) (arrayp (aref input 0)) - (< 1 (rank (aref input 0))))) - input (disclose input)))) - ;; (print (list :ao alpha omega)) - (cond ((and alpha-scalar? omega-scalar?) - (funcall function alpha omega)) - ((and alpha-scalar? omega-unitary?) - (disclose-atom (aops:each (lambda (a o) (apply-scalar function a o)) - (vector alpha) omega))) - ((and alpha-unitary? omega-scalar?) - (disclose-atom (aops:each (lambda (a o) (apply-scalar function a o)) - alpha (vector omega)))) - ((and alpha-unitary? omega-unitary?) - (aops:each (lambda (a o) (apply-scalar function a o)) - alpha omega)) - ((not (or alpha-unitary? omega-unitary? alpha-scalar? omega-scalar?)) - (if (loop for dimension in (funcall (lambda (a o) (mapcar #'= a o)) - (dims alpha) (dims omega)) - always dimension) - (aops:each (lambda (alpha omega) (apply-scalar function alpha omega)) - alpha omega) - (error "Array size mismatch."))) - (t (labels ((scan-over (element) - (if (arrayp element) - (aops:each #'scan-over element) - (apply (lambda (left right) (apply-scalar function left right)) - (cond (alpha-scalar? (list alpha element)) - (alpha-unitary? (list (disclose alpha) element)) - (omega-scalar? (list element omega)) - (omega-unitary? (list element (disclose omega)))))))) - (aops:each #'scan-over (if (or alpha-scalar? alpha-unitary?) - omega alpha))))))))) + (cond ((and alpha-scalar? omega-scalar?) + (funcall function alpha omega)) + ((and alpha-scalar? omega-unitary?) + (disclose-atom (aops:each (lambda (a o) (apply-scalar function a o)) + (vector alpha) omega))) + ((and alpha-unitary? omega-scalar?) + (disclose-atom (aops:each (lambda (a o) (apply-scalar function a o)) + alpha (vector omega)))) + ((and alpha-unitary? omega-unitary?) + (aops:each (lambda (a o) (apply-scalar function a o)) + alpha omega)) + ((not (or alpha-unitary? omega-unitary? alpha-scalar? omega-scalar?)) + (if (loop for dimension in (funcall (lambda (a o) (mapcar #'= a o)) + (dims alpha) (dims omega)) + always dimension) + (aops:each (lambda (alpha omega) (apply-scalar function alpha omega)) + alpha omega) + (error "Array size mismatch."))) + (t (labels ((scan-over (element) + (if (arrayp element) + (aops:each #'scan-over element) + (apply (lambda (left right) (apply-scalar function left right)) + (cond (alpha-scalar? (list alpha element)) + (alpha-unitary? (list (disclose alpha) element)) + (omega-scalar? (list element omega)) + (omega-unitary? (list element (disclose omega)))))))) + (aops:each #'scan-over (if (or alpha-scalar? alpha-unitary?) + omega alpha)))))))) (defun numeric-string-p (string) "Checks whether the argument is a numeric string." @@ -334,14 +328,8 @@ `(let ((new-array (copy-array omega))) ;; wrap the result in an extra array layer if it is already an enclosed array of rank > 1, ;; this ensures that the returned result will be enclosed - (funcall (lambda (item) ;; (if (or (not (arrayp item)) - ;; (not (= 1 (rank item))) - ;; (not (arrayp (aref item 0))) - ;; (and (= 1 (rank (aref item 0))) - ;; (is-unitary (aref item 0)))) - ;; item (vector item)) - (if (= 1 (array-depth omega)) - item (vector item))) + (funcall (lambda (item) (if (= 1 (array-depth omega)) + item (vector item))) (if (vectorp new-array) (funcall ,for-vector ,wrapped-function new-array) (funcall ,for-array ,wrapped-function new-array @@ -399,4 +387,3 @@ (list :symbolic (first spec-body)))))) ((eq :operators type) `(:operators ,(first spec-body))))))))) - diff --git a/vex/vex.asd b/vex/vex.asd index 7bd01407..e3cb5867 100644 --- a/vex/vex.asd +++ b/vex/vex.asd @@ -1,11 +1,12 @@ ;;;; vex.asd -(asdf:defsystem #:vex +(asdf:defsystem "vex" :description "A set of templates for implementing your own vector programming language that compiles to Common Lisp." + :version "0.8.0" :author "Andrew Sengul" :license "Apache-2.0" :serial t - :depends-on (:alexandria :array-operations :maxpc :cl-ppcre :symbol-munger :prove) + :depends-on ("alexandria" "array-operations" "maxpc" "cl-ppcre" "symbol-munger" "prove") :components ((:file "package") (:file "vex"))) diff --git a/vex/vex.lisp b/vex/vex.lisp index b6012e5f..07ceab18 100644 --- a/vex/vex.lisp +++ b/vex/vex.lisp @@ -404,7 +404,6 @@ (values precedent properties tokens) (composer idiom space tokens processed properties))))) - (defmacro set-composer-patterns (name with &rest params) "Generate part of a Vex grammar from entered specifications." (let* ((with (rest with)) @@ -588,20 +587,25 @@ (gethash :variables meta)) (gensym)) (second var-entry)))))))) - (let ((code `(,@(if (and vars-declared (not internal)) - `(let* ,vars-declared - (declare (ignorable ,@(mapcar #'second var-symbols)))) - '(progn)) - ,@(funcall (if output-vars #'values (of-utilities idiom :postprocess-compiled)) - compiled-expressions) - ,@(if output-vars - (list (cons 'values - (mapcar (lambda (return-var) - (funcall (of-utilities idiom :postprocess-value) - (gethash (intern (lisp->camel-case return-var) - "KEYWORD") - (gethash :variables meta)))) - output-vars))))))) + (let ((code (funcall (lambda (exps) + (if (and vars-declared (not internal)) + `(let* ,vars-declared + (declare (ignorable ,@(mapcar #'second var-symbols))) + ,@exps) + (if (= 1 (length exps)) + (first exps) + `(progn ,@exps)))) + `(,@(funcall (if output-vars #'values (of-utilities idiom :postprocess-compiled)) + compiled-expressions) + ,@(if output-vars + (list (cons 'values + (mapcar (lambda (return-var) + (funcall (of-utilities idiom :postprocess-value) + (gethash (intern (lisp->camel-case + return-var) + "KEYWORD") + (gethash :variables meta)))) + output-vars)))))))) (if (assoc :compile-only options) `(quote ,code) code)))))))