(FILECREATED "17-Feb-87 13:47:12" {QV}<PEDERSEN>LISP>KOTO>EARRAY-FNS.;2 52150
changes to: (FNS EQUIRANK-ADJOIN)
previous date: "25-Jun-86 12:32:45" {QV}<PEDERSEN>LISP>KOTO>EARRAY-FNS.;1)
(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT EARRAY-FNSCOMS)
(RPAQQ EARRAY-FNSCOMS [(FNS DEGENERATE-ADJOIN DEGENERATE-LAMINATE EARRAY-ADJOIN EARRAY-COMPRESS
EARRAY-EXPAND EARRAY-INNER-PRODUCT EARRAY-MONADIC-APPLY
EARRAY-NADIC-APPLYMACRO EARRAY-OUTER-PRODUCT EARRAY-PUT-TEMP-VECTOR
EARRAY-SCAN EARRAY-SET* EARRAY-SWEEP EARRAY-TAKE EARRAY-TRANSPOSE
EARRAY-BLT EARRAY-DROP EARRAY-DYADIC-APPLY EARRAY-FILL EARRAY-FLOAT-BLT
EARRAY-FLOAT-FILL EARRAY-GENERIC-BLT EARRAY-GENERIC-DYADIC-APPLY
EARRAY-GENERIC-FILL EARRAY-GENERIC-MONADIC-APPLY
EARRAY-GENERIC-NADIC-APPLYMACRO EARRAY-GENERIC-VECTOR-REDUCE
EARRAY-GENERIC-VECTOR-SCAN EARRAY-GENVECTOR EARRAY-GET-TEMP-VECTOR
EARRAY-LAMINATE EARRAY-RAVEL EARRAY-REDUCE EARRAY-REF EARRAY-RESHAPE
EARRAY-REVERSE EARRAY-ROTATE EARRAY-REF* EARRAY-SET EARRAY-SHAPE
EQUIRANK-ADJOIN EQUIRANK-LAMINATE)
(MACROS EARRAY-GENERIC-NADIC-APPLY EARRAY-NADIC-APPLY)
(VARS EARRAY-DYADIC-FNS-LIST EARRAY-MONADIC-FNS-LIST EARRAY-REDUCTION-FNS-LIST
EARRAY-SCAN-FNS-LIST)
(P (SETQ \EARRAY-MONADIC-FNS (EARRAY-MAKEHASH (FIX (TIMES 2.5 (LENGTH EARRAY-MONADIC-FNS-LIST)
))
EARRAY-MONADIC-FNS-LIST))
(SETQ \EARRAY-DYADIC-FNS (EARRAY-MAKEHASH (FIX (TIMES 2.5 (LENGTH EARRAY-DYADIC-FNS-LIST)))
EARRAY-DYADIC-FNS-LIST))
(SETQ \EARRAY-REDUCTION-FNS (EARRAY-MAKEHASH (FIX (TIMES 2.5 (LENGTH
EARRAY-REDUCTION-FNS-LIST)))
EARRAY-REDUCTION-FNS-LIST))
(SETQ \EARRAY-SCAN-FNS (EARRAY-MAKEHASH (FIX (TIMES 2.5 (LENGTH EARRAY-SCAN-FNS-LIST)))
EARRAY-SCAN-FNS-LIST))
(SETQ \EARRAY-TEMP-VECTORS (LIST NIL NIL NIL NIL NIL)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA EARRAY-REF*
EARRAY-SET*])
(DEFINEQ
(DEGENERATE-ADJOIN
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: " 8-Jun-86 19:21")
(* * As in the APL concatenate operator)
(LET ((DIMS1 (EARRAY-DIMENSIONS ARRAY1))
(DIMS2 (EARRAY-DIMENSIONS ARRAY2))
LARGER LARGERDIMS)
(if (IGREATERP (LENGTH DIMS1)
(LENGTH DIMS2))
then (SETQ LARGER ARRAY1)
(SETQ LARGERDIMS DIMS1)
else (SETQ LARGER ARRAY2)
(SETQ LARGERDIMS DIMS2))
[SETQ RESULT (EARRAY-TEST-RESULT RESULT
(OR (for DL in LARGERDIMS as I from 0
collect (if (EQ I AXIS)
then (ADD1 DL)
else DL))
(QUOTE (2)))
(EARRAY-COMMON-TYPE (EARRAY-ELEMENT-TYPE ARRAY2)
(EARRAY-ELEMENT-TYPE ARRAY1]
[EARRAY-BLT ARRAY1 NIL RESULT (ITERATOR-SETUP RESULT
(for DR in (EARRAY-DIMENSIONS RESULT)
as I from 0
collect
(if (EQ I AXIS)
then (if (EQ ARRAY1 LARGER)
then
(for J from 0
upto
(SUB1 DR)
collect J)
else (QUOTE (0)))
else (QUOTE ALL]
[EARRAY-BLT ARRAY2 NIL RESULT
(ITERATOR-SETUP RESULT
(for DR in (EARRAY-DIMENSIONS RESULT) as I
from 0
collect (if (EQ I AXIS)
then (if (EQ ARRAY2 LARGER)
then (for J from 1
upto DR
collect J)
else (LIST (SUB1 DR)))
else (QUOTE ALL]
RESULT])
(DEGENERATE-LAMINATE
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: " 8-Jun-86 19:20")
(* *)
(LET ((DIMS1 (EARRAY-DIMENSIONS ARRAY1))
(DIMS2 (EARRAY-DIMENSIONS ARRAY2))
(EXTRADIM (SCALAR-CEILING AXIS))
LARGERDIMS)
(if (NULL DIMS2)
then (SETQ LARGERDIMS DIMS1)
else (SETQ LARGERDIMS DIMS2))
[SETQ RESULT (EARRAY-TEST-RESULT RESULT [bind (D1 ← LARGERDIMS) for I from 0
upto (ADD1 (LENGTH LARGERDIMS))
collect (if (EQ I EXTRADIM)
then 2
else (PROG1 (CAR D1)
(SETQ D1
(CDR D1]
(EARRAY-COMMON-TYPE (EARRAY-ELEMENT-TYPE ARRAY2)
(EARRAY-ELEMENT-TYPE ARRAY1]
[EARRAY-BLT ARRAY1 NIL RESULT (ITERATOR-SETUP RESULT (for I from 0
upto (EARRAY-RANK RESULT)
collect (if (EQ I EXTRADIM)
then 0
else (QUOTE
ALL]
[EARRAY-BLT ARRAY2 NIL RESULT (ITERATOR-SETUP RESULT (for I from 0
upto (EARRAY-RANK RESULT)
collect (if (EQ I EXTRADIM)
then 1
else (QUOTE
ALL]
RESULT])
(EARRAY-ADJOIN
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: " 9-Jun-86 15:05")
(* * As in the APL concatenate operator)
(LET ((RANK1 (EARRAY-RANK ARRAY1))
(DIMS1 (EARRAY-DIMENSIONS ARRAY1))
(RANK2 (EARRAY-RANK ARRAY2))
(DIMS2 (EARRAY-DIMENSIONS ARRAY2)))
(if (NULL AXIS)
then [SETQ AXIS (IMAX 0 (SUB1 (IMAX RANK1 RANK2]
elseif [NOT (AND (FIXP AXIS)
(IGEQ AXIS 0)
(ILESSP AXIS (IMAX RANK1 RANK2]
then (ERROR "Incorrect AXIS specifier" AXIS))
(if (EQ 0 (IMIN RANK1 RANK2))
then (DEGENERATE-ADJOIN ARRAY1 ARRAY2 AXIS RESULT)
elseif (AND (EQ RANK1 RANK2)
(for D1 in DIMS1 as D2 in DIMS1 as I from 0
unless (EQ I AXIS) always (EQ D1 D2)))
then (EQUIRANK-ADJOIN ARRAY1 ARRAY2 AXIS RESULT)
elseif (AND (EQ 1 (IABS (IDIFFERENCE RANK1 RANK2)))
(bind (SMALLER ← (if (ILESSP RANK1 RANK2)
then DIMS1
else DIMS2))
TEST for GREATER in (if (IGREATERP RANK1 RANK2)
then DIMS1
else DIMS2)
as I from 0 unless (EQ I AXIS)
always (SETQ TEST (EQ GREATER (CAR SMALLER)))
(SETQ SMALLER (CDR SMALLER))
TEST))
then (DEGENERATE-ADJOIN ARRAY1 ARRAY2 AXIS RESULT)
else (ERROR "Non-conformable arguments"])
(EARRAY-COMPRESS
[LAMBDA (COMPRESSION ARRAY AXIS RESULT) (* jop: "23-Jun-86 22:23")
(* * as in the APL compression operator, AXIS is optional, defaults to last dimension)
[SETQ AXIS (OR AXIS (SUB1 (EARRAY-RANK ARRAY]
(LET ((RANK (EARRAY-RANK ARRAY))
(DIMS (EARRAY-DIMENSIONS ARRAY))
(SIZE (EARRAY-DIMENSION ARRAY AXIS)))
(if (EARRAY-SCALARP COMPRESSION)
then (SETQ COMPRESSION (EARRAY-RESHAPE RANK COMPRESSION)))
(if (NOT (AND (EQ (EARRAY-RANK COMPRESSION)
1)
(EQ (EARRAY-TOTAL-SIZE COMPRESSION)
SIZE)))
then (ERROR "Compression vector of incorrect form" COMPRESSION))
(EARRAY-BLT ARRAY [ITERATOR-SETUP ARRAY
(for I from 0 upto RANK as DIM in DIMS
collect (if (EQ I AXIS)
then (for I from 0
upto SIZE
unless
(EQ (AREF COMPRESSION
I)
0)
collect I)
else (QUOTE ALL]
(EARRAY-TEST-RESULT RESULT
(for I from 0 as DIM in DIMS
collect (if (EQ I AXIS)
then (for I from 0 upto SIZE
count (NEQ (AREF
COMPRESSION I)
0))
else DIM))
(EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-EXPAND
[LAMBDA (EXPANSION ARRAY AXIS RESULT) (* jop: " 9-Jun-86 15:06")
(* * as in the APL compression operator, AXIS is optional, defaults to last dimension)
(LET ((RANK (EARRAY-RANK ARRAY))
(DIMS (EARRAY-DIMENSIONS ARRAY)))
(SETQ AXIS (OR AXIS (SUB1 RANK)))
(if [NOT (AND (EQ (EARRAY-RANK EXPANSION)
1)
(EQ (for I from 0 upto (EARRAY-TOTAL-SIZE EXPANSION)
count (NEQ (AREF EXPANSION I)
0))
(EARRAY-DIMENSION ARRAY AXIS]
then (ERROR "Compression vector of incorrect form" EXPANSION))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT (for I from 0 as DIM in DIMS
collect (if (EQ I AXIS)
then (EARRAY-TOTAL-SIZE
EXPANSION)
else DIM))
(EARRAY-ELEMENT-TYPE ARRAY)))
(EARRAY-BLT ARRAY NIL RESULT (ITERATOR-SETUP RESULT
(for I from 0 upto RANK
collect
(if (EQ I AXIS)
then (for I from 0
upto (
EARRAY-TOTAL-SIZE
EXPANSION)
unless
(EQ (AREF EXPANSION
I)
0)
collect I)
else (QUOTE ALL])
(EARRAY-INNER-PRODUCT
[LAMBDA (FN1 FN2 ARRAY1 ARRAY2 RESULT RESULTELTTYPE TEMPRESULTTYPE)
(* jop: "23-Jun-86 22:23")
(* *)
(LET* ((DIMS1 (EARRAY-DIMENSIONS ARRAY1))
(DIMS2 (EARRAY-DIMENSIONS ARRAY2))
(RESULTDIMS (APPEND (LDIFF DIMS1 (LAST DIMS1))
(CDR DIMS2)))
(TEMPRESULT (EARRAY-GET-TEMP-VECTOR (if (EARRAY-SCALARP ARRAY2)
then (CAR (LAST DIMS1))
else (CAR DIMS2))
TEMPRESULTTYPE)))
(if [NOT (OR (NULL DIMS1)
(NULL DIMS2)
(EQ (CAR (LAST DIMS1))
(CAR DIMS2]
then (ERROR "Arrays not conformable"))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE))
[if (EARRAY-SCALARP RESULT)
then (SETQ RESULT (EARRAY-REDUCE FN1 (EARRAY-DYADIC-APPLY FN2 ARRAY1 ARRAY2
TEMPRESULT)))
else (LET ((LINEARIZED-RESULT (EARRAY-LINEARIZE RESULT)))
(if (EARRAY-SCALARP ARRAY1)
then (bind (META-ITERATOR ←(META-ITERATOR-SETUP ARRAY2 0))
(TEMPVECTOR ←(EARRAY-GET-TEMP-VECTOR
(CAR (EARRAY-DIMENSIONS ARRAY2))
(EARRAY-ELEMENT-TYPE ARRAY2)))
for I from 0 upto (EARRAY-TOTAL-SIZE RESULT)
do (EARRAY-BLT ARRAY2 (META-ITERATOR-NEXTITERATOR
META-ITERATOR)
TEMPVECTOR)
(ASET (EARRAY-REDUCE FN1 (EARRAY-DYADIC-APPLY FN2
ARRAY1
TEMPVECTOR
TEMPRESULT))
LINEARIZED-RESULT I)
finally (EARRAY-PUT-TEMP-VECTOR TEMPVECTOR))
elseif (EARRAY-SCALARP ARRAY2)
then (bind [META-ITERATOR ←(META-ITERATOR-SETUP
ARRAY1
(SUB1 (EARRAY-RANK ARRAY1]
(TEMPVECTOR ←(EARRAY-GET-TEMP-VECTOR
(EARRAY-DIMENSION ARRAY1
(SUB1 (EARRAY-RANK
ARRAY1)))
(EARRAY-ELEMENT-TYPE ARRAY1)))
for I from 0 upto (EARRAY-TOTAL-SIZE RESULT)
do (EARRAY-BLT ARRAY1 (META-ITERATOR-NEXTITERATOR
META-ITERATOR)
TEMPVECTOR)
(ASET (EARRAY-REDUCE FN1 (EARRAY-DYADIC-APPLY FN2
TEMPVECTOR
ARRAY2
TEMPRESULT))
LINEARIZED-RESULT I)
finally (EARRAY-PUT-TEMP-VECTOR TEMPVECTOR))
else (bind [META-ITERATOR1 ←(META-ITERATOR-SETUP ARRAY1
(SUB1
(EARRAY-RANK
ARRAY1]
(META-ITERATOR2 ←(META-ITERATOR-SETUP ARRAY2 0))
(TEMPVECTOR1 ←(EARRAY-GET-TEMP-VECTOR
(EARRAY-DIMENSION ARRAY1
(SUB1 (EARRAY-RANK
ARRAY1)))
(EARRAY-ELEMENT-TYPE ARRAY1)))
(TEMPVECTOR2 ←(EARRAY-GET-TEMP-VECTOR (CAR (
EARRAY-DIMENSIONS
ARRAY2))
(
EARRAY-ELEMENT-TYPE
ARRAY2)))
(I ← 0)
ITERATOR1 ITERATOR2 while (SETQ ITERATOR1 (
META-ITERATOR-NEXTITERATOR
META-ITERATOR1))
do (EARRAY-BLT ARRAY1 ITERATOR1 TEMPVECTOR1)
(while (SETQ ITERATOR2 (META-ITERATOR-NEXTITERATOR
META-ITERATOR2))
do (EARRAY-BLT ARRAY2 ITERATOR2 TEMPVECTOR2)
(ASET (EARRAY-REDUCE FN1
(EARRAY-DYADIC-APPLY
FN2 TEMPVECTOR1
TEMPVECTOR2 TEMPRESULT))
LINEARIZED-RESULT I)
(SETQ I (ADD1 I)))
(META-ITERATOR-RESET META-ITERATOR2)
finally (EARRAY-PUT-TEMP-VECTOR TEMPVECTOR1)
(EARRAY-PUT-TEMP-VECTOR TEMPVECTOR2]
(EARRAY-PUT-TEMP-VECTOR TEMPRESULT)
RESULT])
(EARRAY-MONADIC-APPLY
[LAMBDA (FN ARRAY RESULT RESULTELTTYPE) (* jop: "13-Jun-86 11:38")
(* *)
(DECLARE (GLOBALVARS \EARRAY-MONADIC-FNS))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT (EARRAY-DIMENSIONS ARRAY)
RESULTELTTYPE))
(LET ((MONADIC-FN (GETHASH FN \EARRAY-MONADIC-FNS)))
(if MONADIC-FN
then (APPLY* MONADIC-FN FN ARRAY RESULT)
else (EARRAY-GENERIC-MONADIC-APPLY FN ARRAY RESULT])
(EARRAY-NADIC-APPLYMACRO
[LAMBDA (ARGS) (* jop: "23-Jun-86 22:27")
(* *)
(LET ((FN (CAR ARGS))
(ARRAYLIST (CADR ARGS))
(RESULT (CADDR ARGS))
(RESULTELTTYPE (CADDDR ARGS)))
(BQUOTE (LET ([RESULTDIMS (OR ,@(for A in ARRAYLIST collect (BQUOTE
(EARRAY-DIMENSIONS
, A]
(RESULT , RESULT))
(if [NOT (AND ,@(for A in ARRAYLIST
collect (BQUOTE (OR (EARRAY-SCALARP , A)
(EQUAL (
EARRAY-DIMENSIONS
, A)
RESULTDIMS]
then (ERROR "Args not conformable"))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT RESULTDIMS , RESULTELTTYPE))
(EARRAY-GENERIC-NADIC-APPLY , FN ,@ ARRAYLIST RESULT])
(EARRAY-OUTER-PRODUCT
[LAMBDA (FN ARRAY1 ARRAY2 RESULT RESULTELTTYPE) (* jop: "23-Jun-86 22:23")
(* *)
(LET [(RESULTDIMS (APPEND (EARRAY-DIMENSIONS ARRAY1)
(EARRAY-DIMENSIONS ARRAY2]
(SETQ RESULT (EARRAY-TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE))
(if (OR (EARRAY-SCALARP ARRAY1)
(EARRAY-SCALARP ARRAY2))
then (EARRAY-DYADIC-APPLY FN ARRAY1 ARRAY2 RESULT)
else (bind (LINEARIZED-ARRAY1 ←(EARRAY-LINEARIZE ARRAY1))
(RESULT-META-ITERATOR ←(META-ITERATOR-SETUP RESULT (for I
from
(EARRAY-RANK
ARRAY1)
upto
(EARRAY-RANK
RESULT)
collect I)))
(TEMPRESULT ←(EARRAY-GET-TEMP-VECTOR (FNTH (EARRAY-DIMENSIONS RESULT)
(ADD1 (EARRAY-RANK
ARRAY1)))
(EARRAY-ELEMENT-TYPE RESULT)))
for I from 0 upto (EARRAY-TOTAL-SIZE ARRAY1)
do (EARRAY-DYADIC-APPLY FN (AREF LINEARIZED-ARRAY1 I)
ARRAY2 TEMPRESULT)
(EARRAY-BLT TEMPRESULT NIL RESULT (META-ITERATOR-NEXTITERATOR
RESULT-META-ITERATOR))
finally (EARRAY-PUT-TEMP-VECTOR TEMPRESULT))
RESULT])
(EARRAY-PUT-TEMP-VECTOR
[LAMBDA (VECTOR) (* jop: "23-Jun-86 12:16")
(* *)
(DECLARE (GLOBALVARS \EARRAY-TEMP-VECTORS))
(LET [(CANDIDATE (OR (for A on \EARRAY-TEMP-VECTORS thereis (NULL (CAR A)))
(LAST \EARRAY-TEMP-VECTORS]
(RPLACA CANDIDATE VECTOR)
(if (NEQ CANDIDATE \EARRAY-TEMP-VECTORS)
then (RPLACD (NLEFT \EARRAY-TEMP-VECTORS 1 CANDIDATE)
(CDR CANDIDATE))
(RPLACD CANDIDATE \EARRAY-TEMP-VECTORS)
(SETQ \EARRAY-TEMP-VECTORS CANDIDATE])
(EARRAY-SCAN
[LAMBDA (FN ARRAY AXIS RESULT RESULTELTTYPE) (* jop: "23-Jun-86 12:22")
(* *)
(DECLARE (GLOBALVARS \EARRAY-SCAN-FNS))
(if (NULL AXIS)
then (SETQ AXIS (SUB1 (EARRAY-RANK ARRAY)))
elseif [NOT (AND (FIXP AXIS)
(IGEQ AXIS 0)
(ILESSP AXIS (EARRAY-RANK ARRAY]
then (ERROR "Incorrect AXIS specifier" AXIS))
(LET ((RESULTDIMS (EARRAY-DIMENSIONS ARRAY))
(SCAN-FN (GETHASH FN \EARRAY-SCAN-FNS)))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE))
(if (EQ 1 (EARRAY-RANK ARRAY))
then (if (NULL SCAN-FN)
then (EARRAY-GENERIC-VECTOR-SCAN FN ARRAY RESULT)
else (APPLY* SCAN-FN ARRAY RESULT))
else (bind (META-ITERATOR ←(META-ITERATOR-SETUP ARRAY AXIS))
(SOURCEVECTOR ←(EARRAY-GET-TEMP-VECTOR (EARRAY-DIMENSION ARRAY AXIS)
(EARRAY-ELEMENT-TYPE ARRAY)))
(SINKVECTOR ←(EARRAY-GET-TEMP-VECTOR (EARRAY-DIMENSION ARRAY AXIS)
(EARRAY-ELEMENT-TYPE RESULT)))
ITERATOR while (SETQ ITERATOR (META-ITERATOR-NEXTITERATOR
META-ITERATOR))
do (EARRAY-BLT ARRAY ITERATOR SOURCEVECTOR)
(EARRAY-BLT (if (NULL SCAN-FN)
then (EARRAY-GENERIC-VECTOR-SCAN FN SOURCEVECTOR
SINKVECTOR)
else (APPLY* SCAN-FN SOURCEVECTOR SINKVECTOR))
NIL RESULT (ITERATOR-RESET ITERATOR))
finally (EARRAY-PUT-TEMP-VECTOR SOURCEVECTOR)
(EARRAY-PUT-TEMP-VECTOR SINKVECTOR))
RESULT])
(EARRAY-SET*
[LAMBDA ARGS (* jop: " 9-Jun-86 14:24")
(* *)
(if (ILESSP ARGS 2)
then (ERROR "must have at least two args"))
(LET* ((NEWVALUE (ARG ARGS 1))
(ARRAY (ARG ARGS 2))
(RANK (EARRAY-RANK ARRAY)))
(if (EQ RANK 0)
then (ERROR "Cannot assign into a scalar" ARRAY))
(if (NOT (EQ (IDIFFERENCE ARGS 2)
RANK))
then (ERROR "Dimensional mismatch"))
(EARRAY-BLT NEWVALUE NIL ARRAY (ITERATOR-SETUP ARRAY
(for I from 3 to ARGS
collect (EARRAY-ASLIST
(ARG ARGS I])
(EARRAY-SWEEP
[LAMBDA (FN ARRAY1 ARRAY2 AXIS RESULT RESULTELTTYPE) (* jop: "23-Jun-86 22:23")
(* *)
(if (NULL AXIS)
then (SETQ AXIS (SUB1 (EARRAY-RANK ARRAY1)))
elseif [NOT (AND (FIXP AXIS)
(IGEQ AXIS 0)
(ILESSP AXIS (EARRAY-RANK ARRAY1]
then (ERROR "Incorrect AXIS specifier" AXIS))
(if [NOT (OR (EARRAY-SCALARP ARRAY2)
(EQUAL (EARRAY-DIMENSIONS ARRAY2)
(for I from 0 as DIM in (EARRAY-DIMENSIONS ARRAY1)
unless (EQ I AXIS) collect DIM]
then (ERROR "Args not conformable"))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT (EARRAY-DIMENSIONS ARRAY1)
RESULTELTTYPE))
(if (OR (EARRAY-SCALARP ARRAY1)
(EARRAY-SCALARP ARRAY2))
then (EARRAY-DYADIC-APPLY FN ARRAY1 ARRAY2 RESULT)
else (bind (LINEARIZEDARRAY2 ←(EARRAY-LINEARIZE ARRAY2))
(META-ITERATOR ←(META-ITERATOR-SETUP ARRAY1 AXIS))
(SUBARRAY ←(EARRAY-GET-TEMP-VECTOR (EARRAY-DIMENSION ARRAY1 AXIS)
(EARRAY-ELEMENT-TYPE RESULT)))
ITERATOR for I from 0 while (SETQ ITERATOR (META-ITERATOR-NEXTITERATOR
META-ITERATOR))
do (EARRAY-BLT ARRAY1 ITERATOR SUBARRAY)
(EARRAY-BLT (EARRAY-DYADIC-APPLY FN SUBARRAY (AREF LINEARIZEDARRAY2 I)
SUBARRAY)
NIL RESULT (ITERATOR-RESET ITERATOR))
finally (EARRAY-PUT-TEMP-VECTOR SUBARRAY))
RESULT])
(EARRAY-TAKE
[LAMBDA (TAKEVECTOR ARRAY RESULT) (* jop: "23-Jun-86 22:23")
(* *)
(LET ((RANK (EARRAY-RANK ARRAY))
(DIMS (EARRAY-DIMENSIONS ARRAY)))
(if (EARRAY-SCALARP TAKEVECTOR)
then (SETQ TAKEVECTOR (EARRAY-RESHAPE RANK TAKEVECTOR)))
(if (NOT (AND (EQ (EARRAY-RANK TAKEVECTOR)
1)
(EQ (EARRAY-TOTAL-SIZE TAKEVECTOR)
RANK)))
then (ERROR "TAKEVECTOR of incorrect form" TAKEVECTOR))
(EARRAY-BLT ARRAY
[ITERATOR-SETUP ARRAY
(bind V for I from 0 upto RANK as DIM
in DIMS
collect (SETQ V (AREF TAKEVECTOR I))
(if (ILESSP V 0)
then (for J
from (IMAX 0
(IPLUS DIM V))
upto DIM collect J)
elseif (EQ V 0)
then (QUOTE ALL)
else (for J from 0
upto (IMIN DIM V) collect
J]
(EARRAY-TEST-RESULT RESULT (for I from 0 upto RANK
collect (IABS (AREF TAKEVECTOR I)))
(EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-TRANSPOSE
[LAMBDA (ARRAY PERMUTATION RESULT) (* jop: " 9-Jun-86 15:02")
(* * Implements the so called Generic transpose)
(if [AND PERMUTATION (NOT (AND (EQ (EARRAY-RANK PERMUTATION)
1)
(EQ (EARRAY-TOTAL-SIZE PERMUTATION)
(EARRAY-RANK ARRAY]
then (ERROR "PERMUTATION of incorrect form" PERMUTATION))
(LET [(PERMLST (if (NULL PERMUTATION)
then (for I from (SUB1 (EARRAY-RANK ARRAY)) to 0 by -1
collect I)
else (EARRAY-ASLIST PERMUTATION]
(EARRAY-BLT ARRAY (ITERATOR-SETUP ARRAY NIL PERMLST)
(EARRAY-TEST-RESULT RESULT (PERMUTELIST (EARRAY-DIMENSIONS ARRAY)
PERMLST)
(EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-BLT
[LAMBDA (SOURCE SOURCEITERATOR DESTINATION DESTINATIONITERATOR)
(* jop: "23-Jun-86 22:23")
(* *)
(if (EARRAY-SCALARP DESTINATION)
then (ERROR "DESTINATION not an array" DESTINATION))
(if (EARRAY-SCALARP SOURCE)
then (EARRAY-FILL SOURCE DESTINATION DESTINATIONITERATOR)
else (if (AND (EQ (EARRAY-ELEMENT-TYPE SOURCE)
(QUOTE SINGLE-FLOAT))
(EQ (EARRAY-ELEMENT-TYPE DESTINATION)
(QUOTE SINGLE-FLOAT)))
then (EARRAY-FLOAT-BLT SOURCE SOURCEITERATOR DESTINATION DESTINATIONITERATOR)
else (EARRAY-GENERIC-BLT SOURCE SOURCEITERATOR DESTINATION DESTINATIONITERATOR])
(EARRAY-DROP
[LAMBDA (DROPVECTOR ARRAY RESULT) (* jop: "23-Jun-86 22:23")
(* *)
(LET ((RANK (EARRAY-RANK ARRAY))
(DIMS (EARRAY-DIMENSIONS ARRAY)))
(if (EARRAY-SCALARP DROPVECTOR)
then (SETQ DROPVECTOR (EARRAY-RESHAPE RANK DROPVECTOR)))
(if (NOT (AND (EQ (EARRAY-RANK DROPVECTOR)
1)
(EQ (EARRAY-TOTAL-SIZE DROPVECTOR)
RANK)))
then (ERROR "DROPVECTOR of incorrect form" DROPVECTOR))
(EARRAY-BLT ARRAY
[ITERATOR-SETUP ARRAY
(bind V for I from 0 upto RANK as DIM
in DIMS
collect (SETQ V (AREF DROPVECTOR I))
(if (ILESSP V 0)
then (for J from 0
upto (IPLUS DIM V)
collect J)
elseif (EQ V 0)
then (QUOTE ALL)
else (for J from V upto DIM
collect J]
(EARRAY-TEST-RESULT RESULT
[for I from 0 upto RANK as DIM in DIMS
collect (IMAX 0 (IDIFFERENCE
DIM
(IABS (AREF DROPVECTOR I]
(EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-DYADIC-APPLY
[LAMBDA (FN ARRAY1 ARRAY2 RESULT RESULTELTTYPE) (* jop: "13-Jun-86 12:34")
(* *)
(DECLARE (GLOBALVARS \EARRAY-DYADIC-FNS))
(if (NOT (CONFORMABLE-P ARRAY1 ARRAY2))
then (ERROR "Args not conformable"))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT (OR (EARRAY-DIMENSIONS ARRAY1)
(EARRAY-DIMENSIONS ARRAY2))
RESULTELTTYPE))
(LET ((DYADIC-FN (GETHASH FN \EARRAY-DYADIC-FNS)))
(if DYADIC-FN
then (APPLY* DYADIC-FN FN ARRAY1 ARRAY2 RESULT)
else (EARRAY-GENERIC-DYADIC-APPLY FN ARRAY1 ARRAY2 RESULT])
(EARRAY-FILL
[LAMBDA (SCALAR DESTINATION DESTINATIONITERATOR) (* jop: "23-Jun-86 22:23")
(* * It is assumed that ELTS are of the same ELTTYPE as GENARRAY)
(if (EARRAY-SCALARP DESTINATION)
then (ERROR "DESTINATION not an array" DESTINATION))
(if (EQ (EARRAY-ELEMENT-TYPE DESTINATION)
(QUOTE SINGLE-FLOAT))
then (EARRAY-FLOAT-FILL SCALAR DESTINATION DESTINATIONITERATOR)
else (EARRAY-GENERIC-FILL SCALAR DESTINATION DESTINATIONITERATOR])
(EARRAY-FLOAT-BLT
[LAMBDA (SOURCE SOURCEITERATOR DESTINATION DESTINATIONITERATOR)
(* jop: " 9-Jun-86 20:34")
(* *)
(LET ((SOURCEBASE (ARRAYBASE SOURCE))
(DESTINATIONBASE (ARRAYBASE DESTINATION)))
[if (NULL SOURCEITERATOR)
then [if (NULL DESTINATIONITERATOR)
then (bind (TOTAL ←(ARRAY-TOTAL-SIZE DESTINATION))
(CNT ←(ARRAY-TOTAL-SIZE SOURCE))
(OFFSET ← 0) while (IGREATERP TOTAL CNT)
do (BLAS.ARRAYBLT SOURCE 0 1 DESTINATION OFFSET 1 CNT)
(SETQ TOTAL (IDIFFERENCE TOTAL CNT))
(SETQ OFFSET (IPLUS OFFSET CNT))
finally (AND (NEQ TOTAL 0)
(BLAS.ARRAYBLT SOURCE 0 1 DESTINATION OFFSET 1
TOTAL)))
else (bind (I ←(ITERATOR-NEXTINDEX DESTINATIONITERATOR))
(SOURCELIMIT ←(ARRAY-TOTAL-SIZE SOURCE))
(J ← 0) while I
do (if (EQ J SOURCELIMIT)
then (SETQ J 0))
(\PUTBASEFLOATP DESTINATIONBASE (MUL2 I)
(\GETBASEFLOATP SOURCEBASE (MUL2 J)))
(SETQ I (ITERATOR-NEXTINDEX DESTINATIONITERATOR))
(SETQ J (ADD1 J]
else (if (NULL DESTINATIONITERATOR)
then (bind (J ←(ITERATOR-NEXTINDEX SOURCEITERATOR)) for I from 0
upto (ARRAY-TOTAL-SIZE DESTINATION)
do (if (NULL J)
then (ITERATOR-RESET SOURCEITERATOR)
(SETQ J (ITERATOR-NEXTINDEX SOURCEITERATOR)))
(\PUTBASEFLOATP DESTINATIONBASE (MUL2 I)
(\GETBASEFLOATP SOURCEBASE (MUL2 J)))
(SETQ J (ITERATOR-NEXTINDEX SOURCEITERATOR)))
else (bind (I ←(ITERATOR-NEXTINDEX DESTINATIONITERATOR))
(J ←(ITERATOR-NEXTINDEX SOURCEITERATOR)) while I
do (if (NULL J)
then (ITERATOR-RESET SOURCEITERATOR)
(SETQ J (ITERATOR-NEXTINDEX SOURCEITERATOR)))
(\PUTBASEFLOATP DESTINATIONBASE (MUL2 I)
(\GETBASEFLOATP SOURCEBASE (MUL2 J)))
(SETQ I (ITERATOR-NEXTINDEX DESTINATIONITERATOR))
(SETQ J (ITERATOR-NEXTINDEX SOURCEITERATOR]
DESTINATION])
(EARRAY-FLOAT-FILL
[LAMBDA (SCALAR DESTINATION DESTINATIONITERATOR) (* jop: " 9-Jun-86 20:35")
(* *)
(if (NULL DESTINATIONITERATOR)
then (BLAS.ARRAYFILL SCALAR DESTINATION)
else (bind (FSCALAR ←(FLOAT SCALAR))
(DESTINATIONBASE ←(ARRAYBASE DESTINATION))
I declare (TYPE FLOATP FSCALAR) while (SETQ I (ITERATOR-NEXTINDEX
DESTINATIONITERATOR))
do (\PUTBASEFLOATP DESTINATIONBASE (MUL2 I)
FSCALAR)))
DESTINATION])
(EARRAY-GENERIC-BLT
[LAMBDA (SOURCE SOURCEITERATOR DESTINATION DESTINATIONITERATOR)
(* jop: " 8-Jun-86 18:24")
(* *)
(LET ((LINEARIZEDSOURCE (EARRAY-LINEARIZE SOURCE))
(LINEARIZEDDESTINATION (EARRAY-LINEARIZE DESTINATION)))
[if (NULL SOURCEITERATOR)
then [if (NULL DESTINATIONITERATOR)
then (bind (SOURCELIMIT ← (ARRAY-TOTAL-SIZE SOURCE))
(J ← 0) for I from 0 upto (ARRAY-TOTAL-SIZE
DESTINATION)
do (if (EQ J SOURCELIMIT)
then (SETQ J 0))
(ASET (AREF LINEARIZEDSOURCE J)
LINEARIZEDDESTINATION I)
(SETQ J (ADD1 J)))
else (bind (I ← (ITERATOR-NEXTINDEX DESTINATIONITERATOR))
(SOURCELIMIT ← (ARRAY-TOTAL-SIZE SOURCE))
(J ← 0) while I
do (if (EQ J SOURCELIMIT)
then (SETQ J 0))
(ASET (AREF LINEARIZEDSOURCE J)
LINEARIZEDDESTINATION I)
(SETQ I (ITERATOR-NEXTINDEX DESTINATIONITERATOR))
(SETQ J (ADD1 J]
else (if (NULL DESTINATIONITERATOR)
then (bind (J ← (ITERATOR-NEXTINDEX SOURCEITERATOR)) for I
from 0 upto (ARRAY-TOTAL-SIZE DESTINATION)
do (if (NULL J)
then (ITERATOR-RESET SOURCEITERATOR)
(SETQ J (ITERATOR-NEXTINDEX SOURCEITERATOR)))
(ASET (AREF LINEARIZEDSOURCE J)
LINEARIZEDDESTINATION I)
(SETQ J (ITERATOR-NEXTINDEX SOURCEITERATOR)))
else (bind (I ← (ITERATOR-NEXTINDEX DESTINATIONITERATOR))
(J ← (ITERATOR-NEXTINDEX SOURCEITERATOR)) while I
do (if (NULL J)
then (ITERATOR-RESET SOURCEITERATOR)
(SETQ J (ITERATOR-NEXTINDEX SOURCEITERATOR)))
(ASET (AREF LINEARIZEDSOURCE J)
LINEARIZEDDESTINATION I)
(SETQ I (ITERATOR-NEXTINDEX DESTINATIONITERATOR))
(SETQ J (ITERATOR-NEXTINDEX SOURCEITERATOR]
DESTINATION])
(EARRAY-GENERIC-DYADIC-APPLY
[LAMBDA (OP ARRAY1 ARRAY2 RESULT) (* jop: "23-Jun-86 22:23")
(* *)
(if (AND (EARRAY-SCALARP ARRAY1)
(EARRAY-SCALARP ARRAY2))
then (APPLY* OP ARRAY1 ARRAY2)
else (if (EARRAY-SCALARP ARRAY1)
then (bind (LINEARIZEDARRAY ←(EARRAY-LINEARIZE ARRAY2))
(LINEARIZEDRESULT ←(EARRAY-LINEARIZE RESULT)) for I from 0
upto (EARRAY-TOTAL-SIZE RESULT) do (ASET (APPLY* OP ARRAY1
(AREF
LINEARIZEDARRAY I))
LINEARIZEDRESULT I))
elseif (EARRAY-SCALARP ARRAY2)
then (bind (LINEARIZEDARRAY ←(EARRAY-LINEARIZE ARRAY1))
(LINEARIZEDRESULT ←(EARRAY-LINEARIZE RESULT)) for I from 0
upto (EARRAY-TOTAL-SIZE RESULT) do (ASET (APPLY* OP
(AREF
LINEARIZEDARRAY I)
ARRAY2)
LINEARIZEDRESULT I))
else (bind (LINEARIZEDARRAY1 ←(EARRAY-LINEARIZE ARRAY1))
(LINEARIZEDARRAY2 ←(EARRAY-LINEARIZE ARRAY2))
(LINEARIZEDRESULT ←(EARRAY-LINEARIZE RESULT)) for I from 0
upto (EARRAY-TOTAL-SIZE RESULT) do (ASET (APPLY* OP
(AREF
LINEARIZEDARRAY1 I)
(AREF
LINEARIZEDARRAY2 I))
LINEARIZEDRESULT I)))
RESULT])
(EARRAY-GENERIC-FILL
[LAMBDA (SCALAR DESTINATION DESTINATIONITERATOR) (* jop: " 8-Jun-86 18:57")
(* *)
(LET ((LINEARIZEDDESTINATION (EARRAY-LINEARIZE DESTINATION)))
(if (NULL DESTINATIONITERATOR)
then (for I from 0 upto (ARRAY-TOTAL-SIZE DESTINATION)
do (ASET SCALAR LINEARIZEDDESTINATION I))
else (bind I while (SETQ I (ITERATOR-NEXTINDEX DESTINATIONITERATOR))
do (ASET SCALAR LINEARIZEDDESTINATION I)))
DESTINATION])
(EARRAY-GENERIC-MONADIC-APPLY
[LAMBDA (OP ARRAY RESULT) (* jop: "23-Jun-86 22:23")
(* *)
(if (EARRAY-SCALARP ARRAY)
then (APPLY* OP ARRAY)
else (bind (LINEARIZEDARRAY ←(EARRAY-LINEARIZE ARRAY))
(LINEARIZEDRESULT ←(EARRAY-LINEARIZE RESULT)) for I from 0
upto (EARRAY-TOTAL-SIZE RESULT) do (ASET (APPLY* OP (AREF LINEARIZEDARRAY
I))
LINEARIZEDRESULT I))
RESULT])
(EARRAY-GENERIC-NADIC-APPLYMACRO
[LAMBDA (ARGS) (* jop: "23-Jun-86 22:26")
(* *)
(if (ILESSP (LENGTH ARGS)
2)
then (ERROR "must have at least two args"))
(LET [(OP (CAR ARGS))
(RESULT (CAR (LAST ARGS)))
(ARRAYS (for I from 1 to (IDIFFERENCE (LENGTH ARGS)
2)
as ARG in (CDR ARGS) collect ARG))
(GENLIST (for I from 1 to (IDIFFERENCE (LENGTH ARGS)
2)
collect (PACK* (QUOTE GEN)
I]
(BQUOTE (if [AND ,@(for A in ARRAYS collect (BQUOTE (EARRAY-SCALARP , A]
then (APPLY* , OP ,@(for A in ARRAYS collect A))
else (bind ,@[for G in GENLIST as A in ARRAYS
collect (BQUOTE (, G ←(GENERATOR-SETUP , A]
(LINEARIZEDRESULT ←(EARRAY-LINEARIZE , RESULT)) for I
from 0 upto (EARRAY-TOTAL-SIZE , RESULT)
do (ASET [APPLY* , OP ,@(for G in GENLIST
collect (BQUOTE (
GENERATOR-NEXTELT
, G]
LINEARIZEDRESULT I)
finally (RETURN , RESULT])
(EARRAY-GENERIC-VECTOR-REDUCE
[LAMBDA (OP VECTOR) (* jop: "12-Jun-86 22:51")
(* *)
(LET ((SIZE (EARRAY-TOTAL-SIZE VECTOR)))
(if (IGREATERP SIZE 0)
then (bind (RESULT ← (AREF VECTOR 0)) for I from 1 upto SIZE
do (SETQ RESULT (APPLY* OP RESULT (AREF VECTOR I)))
finally (RETURN RESULT])
(EARRAY-GENERIC-VECTOR-SCAN
[LAMBDA (OP VECTOR RESULT) (* jop: "12-Jun-86 22:52")
(* *)
(LET ((SIZE (EARRAY-TOTAL-SIZE VECTOR)))
(if (IGREATERP SIZE 0)
then (ASET (AREF VECTOR 0)
RESULT 0)
(bind (ELT ← (AREF RESULT 0)) for I from 1 upto SIZE
do (SETQ ELT (APPLY* OP ELT (AREF VECTOR I)))
(ASET ELT RESULT I))
RESULT])
(EARRAY-GENVECTOR
[LAMBDA (N START STEPSIZE) (* jop: "23-Jun-86 13:58")
(* *)
(if (NULL N)
then (ERROR "Must supply N"))
(if (NULL START)
then (SETQ START 0))
(if (NULL STEPSIZE)
then (SETQ STEPSIZE 1))
(EARRAY-ASVECTOR (for I from 1 to (FIXR (QUOTIENT (DIFFERENCE N START)
STEPSIZE))
as VALUE from START by STEPSIZE collect VALUE])
(EARRAY-GET-TEMP-VECTOR
[LAMBDA (SIZE ELEMENT-TYPE) (* jop: "23-Jun-86 12:15")
(* *)
(DECLARE (GLOBALVARS \EARRAY-TEMP-VECTORS))
(if (NULL ELEMENT-TYPE)
then (SETQ ELEMENT-TYPE T))
(LET [(CANDIDATE (bind ARRAY for TAIL on \EARRAY-TEMP-VECTORS
thereis (SETQ ARRAY (CAR TAIL))
(AND ARRAY (EQ (ARRAY-TOTAL-SIZE ARRAY)
SIZE)
(EQUAL (ARRAY-ELEMENT-TYPE ARRAY)
ELEMENT-TYPE]
(if (NULL CANDIDATE)
then (MAKE-ARRAY SIZE (QUOTE :ELEMENT-TYPE)
ELEMENT-TYPE)
else (PROG1 (CAR CANDIDATE)
(RPLACA CANDIDATE NIL])
(EARRAY-LAMINATE
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: " 9-Jun-86 15:06")
(* *)
(LET ((RANK1 (EARRAY-RANK ARRAY1))
(DIMS1 (EARRAY-DIMENSIONS ARRAY1))
(RANK2 (EARRAY-RANK ARRAY2))
(DIMS2 (EARRAY-DIMENSIONS ARRAY2)))
(if (NULL AXIS)
then (SETQ AXIS -.5)
elseif [NOT (AND (FLOATP AXIS)
(LESSP AXIS (ADD1 (IMAX RANK1 RANK2]
then (ERROR "Incorrect axis specifier" AXIS))
(if (EQ 0 (IMIN RANK1 RANK2))
then (DEGENERATE-LAMINATE ARRAY1 ARRAY2 AXIS RESULT)
elseif (AND (EQ RANK1 RANK2)
(EQUAL DIMS1 DIMS2))
then (EQUIRANK-LAMINATE ARRAY1 ARRAY2 AXIS RESULT)
else (ERROR "Non-conformable arguments"])
(EARRAY-RAVEL
[LAMBDA (ARRAY RESULT) (* jop: " 9-Jun-86 14:38")
(* *)
(LET ((RESULTDIMS (LIST (EARRAY-TOTAL-SIZE ARRAY)))
(RESULTELTTYPE (EARRAY-ELEMENT-TYPE ARRAY)))
(EARRAY-BLT ARRAY NIL (EARRAY-TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE])
(EARRAY-REDUCE
[LAMBDA (FN ARRAY AXIS RESULT RESULTELTTYPE) (* jop: "23-Jun-86 12:22")
(* *)
(DECLARE (GLOBALVARS \EARRAY-REDUCTION-FNS))
(if (NULL AXIS)
then (SETQ AXIS (SUB1 (EARRAY-RANK ARRAY)))
elseif [NOT (AND (FIXP AXIS)
(IGEQ AXIS 0)
(ILESSP AXIS (EARRAY-RANK ARRAY]
then (ERROR "Incorrect AXIS specifier" AXIS))
(LET ((RESULTDIMS (for DIM in (EARRAY-DIMENSIONS ARRAY) as I from 0
unless (EQ I AXIS) collect DIM))
(REDUCTION-FN (GETHASH FN \EARRAY-REDUCTION-FNS)))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE))
(if (EQ 1 (EARRAY-RANK ARRAY))
then (if (NULL REDUCTION-FN)
then (EARRAY-GENERIC-VECTOR-REDUCE FN ARRAY)
else (APPLY* REDUCTION-FN ARRAY))
else (bind (LINEARIZEDRESULT ←(EARRAY-LINEARIZE RESULT))
(META-ITERATOR ←(META-ITERATOR-SETUP ARRAY AXIS))
(SUBARRAY ←(EARRAY-GET-TEMP-VECTOR (EARRAY-DIMENSION ARRAY AXIS)
(EARRAY-ELEMENT-TYPE ARRAY)))
for I from 0 upto (EARRAY-TOTAL-SIZE RESULT)
do (EARRAY-BLT ARRAY (META-ITERATOR-NEXTITERATOR META-ITERATOR)
SUBARRAY)
(ASET (if (NULL REDUCTION-FN)
then (EARRAY-GENERIC-VECTOR-REDUCE FN SUBARRAY)
else (APPLY* REDUCTION-FN SUBARRAY SUBARRAY))
LINEARIZEDRESULT I)
finally (EARRAY-PUT-TEMP-VECTOR SUBARRAY))
RESULT])
(EARRAY-REF
[LAMBDA (ARRAY SELECTORS RESULT) (* jop: "17-Jun-86 15:09")
(* * SELECTION OPERATOR)
(if (NOT (EQ (EARRAY-RANK SELECTORS)
1))
then (ERROR "Selectors must be a oned-array" SELECTORS))
(if (NOT (EQ (EARRAY-TOTAL-SIZE SELECTORS)
(EARRAY-RANK ARRAY)))
then (ERROR "Dimensional mismatch" SELECTORS))
(LET* [(RANK (EARRAY-RANK ARRAY))
(SELECTORLST (for I from 0 upto RANK collect (AREF SELECTORS I)))
(RESULTDIMS (for SELECTOR in SELECTORLST as DIM in (EARRAY-DIMENSIONS ARRAY)
when (NOT (FIXP SELECTOR)) collect (if (EQ SELECTOR
(QUOTE ALL))
then DIM
else (EARRAY-TOTAL-SIZE
SELECTOR]
(if (NULL RESULTDIMS)
then (if (EQ RANK 0)
then ARRAY
else (APPLY (FUNCTION AREF)
(CONS ARRAY SELECTORLST)))
else (EARRAY-BLT ARRAY (ITERATOR-SETUP ARRAY (for SELECTOR in SELECTORLST
collect (EARRAY-ASLIST SELECTOR)
))
(EARRAY-TEST-RESULT RESULT RESULTDIMS (EARRAY-ELEMENT-TYPE
ARRAY])
(EARRAY-RESHAPE
[LAMBDA (SHAPE ARRAY RESULT) (* jop: " 9-Jun-86 15:05")
(* * SHAPE must be a vector of non-negative integers -- for convenience scalars are treated as vectors of length 1)
(if (NOT (OR (FIXP SHAPE)
(EQ (EARRAY-RANK SHAPE)
1)))
then (ERROR "SHAPE of incorrect form" SHAPE))
(LET [(RESULTDIMS (if (FIXP SHAPE)
then (LIST SHAPE)
else (for I from 0 upto (EARRAY-TOTAL-SIZE SHAPE)
collect (AREF SHAPE I]
(if (NULL RESULTDIMS)
then (EARRAY-MAKESCALAR ARRAY)
else (EARRAY-BLT ARRAY NIL (EARRAY-TEST-RESULT RESULT RESULTDIMS (
EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-REVERSE
[LAMBDA (ARRAY AXIS RESULT) (* jop: " 9-Jun-86 14:55")
(* *)
[if (NULL AXIS)
then (SETQ AXIS (SUB1 (EARRAY-RANK ARRAY]
(LET ((DIMS (EARRAY-DIMENSIONS ARRAY)))
(EARRAY-BLT ARRAY [ITERATOR-SETUP ARRAY (for DIM in DIMS as I from 0
collect (if (EQ I AXIS)
then (for J
from (SUB1 DIM)
to 0 by -1
collect J)
else (QUOTE ALL]
(EARRAY-TEST-RESULT RESULT DIMS (EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-ROTATE
[LAMBDA (SCALAR ARRAY AXIS RESULT) (* jop: " 9-Jun-86 15:06")
(* *)
(if (NOT (FIXP SCALAR))
then (ERROR "Not an integer" SCALAR))
[if (NULL AXIS)
then (SETQ AXIS (SUB1 (EARRAY-RANK ARRAY]
(LET ((DIMS (EARRAY-DIMENSIONS ARRAY)))
(EARRAY-BLT ARRAY [ITERATOR-SETUP
ARRAY
(for DIM in DIMS as I from 0
collect (if (EQ I AXIS)
then [bind (I ← (if (IGREATERP SCALAR 0)
then SCALAR
else (PLUS DIM SCALAR)))
for J from 1 to DIM
collect (PROG1 I (if (EQ I (SUB1 DIM))
then (SETQ I 0)
else (SETQ I
(ADD1 I]
else (QUOTE ALL]
(EARRAY-TEST-RESULT RESULT DIMS (EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-REF*
[LAMBDA ARGS (* jop: "17-Jun-86 15:09")
(* * SELECTION OPERATOR)
(if (ILESSP ARGS 1)
then (ERROR "must have at least one arg"))
(LET* ((ARRAY (ARG ARGS 1))
(RANK (EARRAY-RANK ARRAY))
(LIMIT ARGS)
RESULT RESULTDIMS)
(if (EQ ARGS (IPLUS 2 RANK))
then (SETQ RESULT (ARG ARGS ARGS))
(SETQ LIMIT (SUB1 ARGS))
elseif (NEQ ARGS (ADD1 RANK))
then (ERROR "Dimensional mismatch"))
[SETQ RESULTDIMS (bind SELECTOR for I from 2 to LIMIT as DIM
in (EARRAY-DIMENSIONS ARRAY)
when [NOT (FIXP (SETQ SELECTOR (ARG ARGS I]
collect (if (EQ SELECTOR (QUOTE ALL))
then DIM
else (EARRAY-TOTAL-SIZE SELECTOR]
(if (NULL RESULTDIMS)
then [if (EQ RANK 0)
then ARRAY
else (APPLY (FUNCTION AREF)
(CONS ARRAY (for I from 2 to LIMIT
collect (ARG ARGS I]
else (EARRAY-BLT ARRAY [ITERATOR-SETUP ARRAY (for I from 2 to LIMIT
collect (EARRAY-ASLIST
(ARG ARGS I]
(EARRAY-TEST-RESULT RESULT RESULTDIMS (EARRAY-ELEMENT-TYPE
ARRAY])
(EARRAY-SET
[LAMBDA (NEWVALUE ARRAY SELECTORS) (* jop: " 9-Jun-86 13:46")
(* *)
(LET ((RANK (EARRAY-RANK ARRAY)))
(if (EQ RANK 0)
then (ERROR "Cannot assign into a scalar" ARRAY))
(if (NOT (EQ (EARRAY-RANK SELECTORS)
1))
then (ERROR "Selectors must be a oned-array" SELECTORS))
(if (NOT (EQ (EARRAY-TOTAL-SIZE SELECTORS)
(EARRAY-RANK ARRAY)))
then (ERROR "Dimensional mismatch" SELECTORS))
(EARRAY-BLT NEWVALUE NIL ARRAY (ITERATOR-SETUP ARRAY
(for I from 0 upto RANK
collect (EARRAY-ASLIST
(AREF SELECTORS I])
(EARRAY-SHAPE
[LAMBDA (ARRAY RESULT) (* jop: "22-Jun-86 13:06")
(* *)
(LET [(RESULTDIMS (LIST (EARRAY-RANK ARRAY]
(SETQ RESULT (EARRAY-TEST-RESULT RESULT RESULTDIMS))
(for I from 0 as DIM in (EARRAY-DIMENSIONS ARRAY) do (ASET DIM RESULT I))
RESULT])
(EQUIRANK-ADJOIN
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* edited: "17-Feb-87 13:22")
(* *)
(LET ((DIMS1 (EARRAY-DIMENSIONS ARRAY1))
(DIMS2 (EARRAY-DIMENSIONS ARRAY2)))
[SETQ RESULT (EARRAY-TEST-RESULT RESULT
(for D1 in DIMS1 as D2 in DIMS2 as I
from 0 collect (if (EQ I AXIS)
then (IPLUS D1 D2)
else D1))
(EARRAY-COMMON-TYPE (EARRAY-ELEMENT-TYPE ARRAY1)
(EARRAY-ELEMENT-TYPE ARRAY2]
[EARRAY-BLT ARRAY1 NIL RESULT
(ITERATOR-SETUP RESULT
(for D1 in DIMS1 as I from 0
collect (if (EQ I AXIS)
then (for J from 0 upto D1
collect J)
else (QUOTE ALL]
[EARRAY-BLT ARRAY2 NIL RESULT
(ITERATOR-SETUP RESULT
(for DR in (EARRAY-DIMENSIONS RESULT) as D1
in DIMS1 as I from 0
collect (if (EQ I AXIS)
then (for J from D1 upto DR
collect J)
else (QUOTE ALL]
RESULT])
(EQUIRANK-LAMINATE
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: " 8-Jun-86 19:22")
(* *)
(LET ((EXTRADIM (SCALAR-CEILING AXIS)))
[SETQ RESULT (EARRAY-TEST-RESULT RESULT [bind (D1 ←(EARRAY-DIMENSIONS ARRAY1))
for I from 0 upto (ADD1 (EARRAY-RANK
ARRAY1))
collect (if (EQ I EXTRADIM)
then 2
else (PROG1 (CAR D1)
(SETQ D1
(CDR D1]
(EARRAY-COMMON-TYPE (EARRAY-ELEMENT-TYPE ARRAY1)
(EARRAY-ELEMENT-TYPE ARRAY2]
[EARRAY-BLT ARRAY1 NIL RESULT (ITERATOR-SETUP RESULT (for I from 0
upto (EARRAY-RANK RESULT)
collect (if (EQ I EXTRADIM)
then 0
else (QUOTE
ALL]
[EARRAY-BLT ARRAY2 NIL RESULT (ITERATOR-SETUP RESULT (for I from 0
upto (EARRAY-RANK RESULT)
collect (if (EQ I EXTRADIM)
then 1
else (QUOTE
ALL]
RESULT])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS EARRAY-GENERIC-NADIC-APPLY MACRO (ARGS (EARRAY-GENERIC-NADIC-APPLYMACRO ARGS)))
(PUTPROPS EARRAY-NADIC-APPLY MACRO (ARGS (EARRAY-NADIC-APPLYMACRO ARGS)))
)
(RPAQQ EARRAY-DYADIC-FNS-LIST (DIFFERENCE EARRAY-DIFFERENCE-FN MAX EARRAY-MAX-FN MIN EARRAY-MIN-FN
PLUS EARRAY-PLUS-FN QUOTIENT EARRAY-QUOTIENT-FN REMAINDER
EARRAY-REMAINDER-FN TIMES EARRAY-TIMES-FN CHOOSE
EARRAY-CHOOSE-FN EQP EARRAY-EQP-FN NOT-EQP
EARRAY-NOT-EQP-FN EQUAL EARRAY-EQUAL-FN NOT-EQUAL
EARRAY-NOT-EQUAL-FN GEQ EARRAY-GEQ-FN GREATERP
EARRAY-GREATERP-FN LEQ EARRAY-LEQ-FN LESSP
EARRAY-LESSP-FN AND EARRAY-AND-FN OR EARRAY-OR-FN NAND
EARRAY-NAND-FN NOR EARRAY-NOR-FN XOR EARRAY-XOR-FN))
(RPAQQ EARRAY-MONADIC-FNS-LIST (ABS EARRAY-ABS-FN FIX EARRAY-FIX-FN FLOAT EARRAY-FLOAT-FN
RECIPROCAL EARRAY-RECIPROCAL-FN MINUS EARRAY-MINUS-FN FACTORIAL
EARRAY-FACTORIAL-FN CEILING EARRAY-CEILING-FN FLOOR
EARRAY-FLOOR-FN ROUND EARRAY-ROUND-FN NOT EARRAY-NOT-FN))
(RPAQQ EARRAY-REDUCTION-FNS-LIST (PLUS EARRAY-PLUS-REDUCE-FN MAX EARRAY-MAX-REDUCE-FN MIN
EARRAY-MIN-REDUCE-FN MEAN EARRAY-MEAN MEDIAN EARRAY-MEDIAN
VARIANCE EARRAY-VARIANCE SAMPLE-VARIANCE
EARRAY-SAMPLE-VARIANCE))
(RPAQQ EARRAY-SCAN-FNS-LIST (TIMES EARRAY-TIMES-SCAN-FN PLUS EARRAY-PLUS-SCAN-FN GRADE-UP
EARRAY-GRADE-UP GRADE-DOWN EARRAY-GRADE-DOWN INDEX-GRADE-UP
EARRAY-INDEX-GRADE-UP INDEX-GRADE-DOWN EARRAY-INDEX-GRADE-DOWN))
(SETQ \EARRAY-MONADIC-FNS (EARRAY-MAKEHASH (FIX (TIMES 2.5 (LENGTH EARRAY-MONADIC-FNS-LIST)))
EARRAY-MONADIC-FNS-LIST))
(SETQ \EARRAY-DYADIC-FNS (EARRAY-MAKEHASH (FIX (TIMES 2.5 (LENGTH EARRAY-DYADIC-FNS-LIST)))
EARRAY-DYADIC-FNS-LIST))
(SETQ \EARRAY-REDUCTION-FNS (EARRAY-MAKEHASH (FIX (TIMES 2.5 (LENGTH EARRAY-REDUCTION-FNS-LIST)))
EARRAY-REDUCTION-FNS-LIST))
(SETQ \EARRAY-SCAN-FNS (EARRAY-MAKEHASH (FIX (TIMES 2.5 (LENGTH EARRAY-SCAN-FNS-LIST)))
EARRAY-SCAN-FNS-LIST))
(SETQ \EARRAY-TEMP-VECTORS (LIST NIL NIL NIL NIL NIL))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA EARRAY-REF* EARRAY-SET*)
)
(PUTPROPS EARRAY-FNS COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2207 49691 (DEGENERATE-ADJOIN 2217 . 4041) (DEGENERATE-LAMINATE 4043 . 5434) (
EARRAY-ADJOIN 5436 . 7035) (EARRAY-COMPRESS 7037 . 8546) (EARRAY-EXPAND 8548 . 10000) (
EARRAY-INNER-PRODUCT 10002 . 13994) (EARRAY-MONADIC-APPLY 13996 . 14504) (EARRAY-NADIC-APPLYMACRO
14506 . 15391) (EARRAY-OUTER-PRODUCT 15393 . 16729) (EARRAY-PUT-TEMP-VECTOR 16731 . 17371) (
EARRAY-SCAN 17373 . 19083) (EARRAY-SET* 19085 . 19822) (EARRAY-SWEEP 19824 . 21409) (EARRAY-TAKE 21411
. 22684) (EARRAY-TRANSPOSE 22686 . 23546) (EARRAY-BLT 23548 . 24321) (EARRAY-DROP 24323 . 25624) (
EARRAY-DYADIC-APPLY 25626 . 26298) (EARRAY-FILL 26300 . 26834) (EARRAY-FLOAT-BLT 26836 . 29205) (
EARRAY-FLOAT-FILL 29207 . 29767) (EARRAY-GENERIC-BLT 29769 . 31990) (EARRAY-GENERIC-DYADIC-APPLY 31992
. 33459) (EARRAY-GENERIC-FILL 33461 . 34028) (EARRAY-GENERIC-MONADIC-APPLY 34030 . 34562) (
EARRAY-GENERIC-NADIC-APPLYMACRO 34564 . 35870) (EARRAY-GENERIC-VECTOR-REDUCE 35872 . 36319) (
EARRAY-GENERIC-VECTOR-SCAN 36321 . 36819) (EARRAY-GENVECTOR 36821 . 37338) (EARRAY-GET-TEMP-VECTOR
37340 . 38079) (EARRAY-LAMINATE 38081 . 38927) (EARRAY-RAVEL 38929 . 39272) (EARRAY-REDUCE 39274 .
40917) (EARRAY-REF 40919 . 42237) (EARRAY-RESHAPE 42239 . 43039) (EARRAY-REVERSE 43041 . 43694) (
EARRAY-ROTATE 43696 . 44652) (EARRAY-REF* 44654 . 46088) (EARRAY-SET 46090 . 46863) (EARRAY-SHAPE
46865 . 47250) (EQUIRANK-ADJOIN 47252 . 48482) (EQUIRANK-LAMINATE 48484 . 49689)))))
STOP