(FILECREATED " 7-Oct-85 21:58:47" {QV}<IDL>SOURCES>ARRAY.;14 37321
changes to: (FNS RANK ADJOIN CROSS)
previous date: " 5-Sep-85 19:25:08" {QV}<IDL>SOURCES>ARRAY.;13)
(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ARRAYCOMS)
(RPAQQ ARRAYCOMS [(* User level array manipulation functions.)
(FNS ADJOIN CROSS DEAL ELEMENTTYPE FORMAT GENVEC IDLARRAYP ORDER ORDERROW ORDERROW1 RANK
REDUCE RESHAPE RPLUS RTIMES SEEK SHAPE SHIFT TRANSPOSE)
(PROP ARGNAMES REDUCE SHIFT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA SHIFT REDUCE CROSS ADJOIN])
(* User level array manipulation functions.)
(DEFINEQ
(ADJOIN
[LAMBDA VECTORS (* jop: " 5-Sep-85 19:03")
(* Joins VECTORS together end to end)
(DECLARE (SPECVARS VECTORS))
(UENTRY (QUOTE ADJOIN)
(EAPPLY [FUNCTION (LAMBDA VECTORS
(DPROG ((ADJOIN (bind (ATYPE ←(QUOTE INTEGER))
(ALENGTH ← 0)
declare (ALENGTH IJK)
(ATYPE (MEMQ INTEGER FLOATING))
for I V from 1 to VECTORS
do (if (type? VECTOR (SETQ V (ARG VECTORS I)))
then (add ALENGTH (GETRELT (fetch SHAPE
of V)
1))
(if (EQ (fetch AELTTYPE of V)
(QUOTE FLOATING))
then (SETQQ ATYPE FLOATING))
else (ASSERT (type? (ONEOF SCALAR VSCALARP)
V))
(add ALENGTH 1)
(if [type? FLOATING (if (type? SCALAR V)
then V
else (GETAELT
V
(VSCALARPTR V]
then (SETQQ ATYPE FLOATING)))
finally (RETURN (ALLOC.SARRAY (ROWINTOF ALENGTH)
(QUOTE FULL)
ATYPE))) VECTOR)
(RETURNS VECTOR))
(bind (ALEVEL ← 1)
(NOAVD ← T)
(GSB ←(create GENSTATEBLOCK))
(GSBA ←(SETUP ADJOIN (QUOTE ROWMAJOR)))
declare (ALEVEL IJK)
(NOAVD BOOL (* NIL once ADJOIN's valdim is established)
)
(GSB GENSTATEBLOCK)
(GSBA GENSTATEBLOCK)
for I V from 1 to VECTORS
do (SELTYPEQ (SETQ V (ARG VECTORS I))
[VECTOR (SETUP V (QUOTE ROWMAJOR)
GSB)
[until (fetch DONE of GSB)
do (SETAELT ADJOIN (NEXT GSBA)
(GETAELT V (NEXT GSB]
(if LABPROPFLAG
then (OR (GETDIMLAB ADJOIN 1)
(SETDIMLAB ADJOIN 1
(GETDIMLAB V 1)))
(for VLEVEL (VVD ←(GETVALDIM V))
from 1
to (GETRELT (fetch SHAPE
of V)
1)
declare (VLEVEL IJK)
first (if VVD
then (if NOAVD
then
(SETVALDIM
ADJOIN 1)
(SETQ NOAVD NIL))
)
do (SETLEVLAB ADJOIN 1 ALEVEL
(GETLEVLAB V 1 VLEVEL))
(* The special CODES logic handles a hidden,
vector-wide codebook)
(if VVD
then (SETCODES ADJOIN ALEVEL
(GETCODES
V VLEVEL)))
(add ALEVEL 1))
else (add ALEVEL (GETRELT (fetch SHAPE
of V)
1]
(SCALAR (SETAELT ADJOIN (NEXT GSBA)
V)
(add ALEVEL 1))
(VSCALARP (SETAELT ADJOIN (NEXT GSBA)
(GETAELT V (VSCALARPTR V)))
(add ALEVEL 1))
(SHOULDNT)))
[if LABPROPFLAG
then (SETTITLE ADJOIN (APPLY (FUNCTION MAKETITLE)
(CONS NIL (for I to VECTORS
collect (ARG VECTORS I]
(RETURN ADJOIN))]
(QUOTE (VECTOR ...))
(for I to VECTORS collect (ARG VECTORS I])
(CROSS
[LAMBDA VECTORS (* jop: " 5-Sep-85 19:04")
(* Creates cartesian "cross" product of elements in
VECTORS)
(DECLARE (SPECVARS VECTORS))
(UENTRY (QUOTE CROSS)
(EAPPLY [FUNCTION (LAMBDA VECTORS
(DPROG ((CSHAPE (create ROWINT
NELTS ←(ADD1 VECTORS)) ROWINT)
THEN (CROSS (bind (CTYPE ←(QUOTE INTEGER)) declare (CTYPE (MEMQ INTEGER
FLOATING))
for I V from 1 to VECTORS
do (SELTYPEQ (SETQ V (ARG VECTORS I))
(VECTOR (SETRELT CSHAPE I
(GETRELT (fetch SHAPE
of V)
1))
(if (EQ (fetch AELTTYPE of V)
(QUOTE FLOATING))
then (SETQQ CTYPE FLOATING)))
(SCALAR (SETRELT CSHAPE I 1)
(if (type? FLOATING V)
then (SETQQ CTYPE FLOATING)))
(VSCALARP (SETRELT CSHAPE I 1)
(if (type? FLOATING
(GETAELT V (VSCALARPTR
V)))
then (SETQQ CTYPE FLOATING)))
(SHOULDNT))
finally (SETRELT CSHAPE (ADD1 VECTORS)
VECTORS)
(RETURN (ALLOC.SARRAY CSHAPE (QUOTE FULL)
CTYPE))) SIMARRAY)
(RETURNS SIMARRAY))
(* We generate each of VECTORS only once, cause they may be more complicated objects than the simarray CROSS.
For each element in a vector, we stick it in all its locations in CROSS before moving onto the next element -
The locations are determined by two parameters: the runlength, the number of rows in a row that are to receive the
same value; and the spacing between the runs)
(bind (RUN ← VECTORS)
(NOCVD ← T)
(GSB ←(create GENSTATEBLOCK))
(GSBC ←(SETUP CROSS (QUOTE ROWMAJOR)))
declare (RUN IJK)
(NOCVD BOOL)
(GSB GENSTATEBLOCK)
(GSBC GENSTATEBLOCK)
for I V VAL CODES from VECTORS to 1 by -1
do (* Do them backwards so that RUN is easy to compute)
(SELTYPEQ (SETQ V (ARG VECTORS I))
[VECTOR (SETUP V (QUOTE ROWMAJOR)
GSB)
(until (fetch DONE of GSB)
for START
[SPACE ←(ITIMES RUN
(SUB1 (GETRELT CSHAPE I]
from (SUB1 I) by RUN
declare (START IJK)
(SPACE IJK)
do (SETQ VAL (GETAELT V (NEXT GSB)))
(RESETUP GSBC)
(SKIP GSBC START)
(* The starting location for this vector)
(until (fetch DONE of GSBC)
do (for R from VECTORS to RUN
by VECTORS declare (R IJK)
do (SETAELT CROSS (NEXT GSBC)
VAL)
(SKIP GSBC (SUB1 VECTORS)))
(SKIP GSBC SPACE)))
(SETQ RUN (ITIMES RUN (GETRELT CSHAPE I)))
(if LABPROPFLAG
then (SETDIMLAB CROSS I (GETDIMLAB V 1))
(SETLEVLAB CROSS (ADD1 VECTORS)
I
(GETDIMLAB V 1))
(for LEV from 1
to (GETRELT (fetch SHAPE
of V)
1)
do (SETLEVLAB CROSS I LEV
(GETLEVLAB V 1 LEV)))
(if (EQ (GETVALDIM V)
1)
then
(* Should we check to make sure the codes are the same
for all levels, take the union, or what?)
elseif (SETQ CODES (GROUP.HIDDENCODES
V))
then (if NOCVD
then (SETVALDIM
CROSS
(ADD1 VECTORS))
(SETQ NOCVD NIL))
(SETCODES CROSS I CODES]
[(ONEOF SCALAR VSCALARP)
[SETQ VAL (if (type? SCALAR V)
then V
else (if (AND LABPROPFLAG (SETQ CODES
(GROUP.HIDDENCODES V)))
then (if NOCVD
then
(SETVALDIM
CROSS
(ADD1 VECTORS))
(SETQ NOCVD NIL))
(SETCODES CROSS I CODES))
(GETAELT V (VSCALARPTR V]
(RESETUP GSBC)
(SKIP GSBC (SUB1 I))
(until (fetch DONE of GSBC)
do (SETAELT CROSS (NEXT GSBC)
VAL)
(SKIP GSBC (SUB1 VECTORS]
(SHOULDNT)))
(replace KEEPS of CROSS
with (for I from 1 to VECTORS collect I))
[if LABPROPFLAG
then (SETTITLE CROSS (APPLY (FUNCTION MAKETITLE)
(CONS NIL (for I to VECTORS
collect (ARG VECTORS I]
(RETURN CROSS))]
(QUOTE (VECTOR ...))
(for I to VECTORS collect (ARG VECTORS I])
(DEAL
[ULAMBDA ((N INTEGER (SATISFIES ~(MINUSP N)))
(RETURNS VECTOR))
(* bas: " 8-AUG-79 16:25" posted: " 1-AUG-77 13:44")
(* Returns a random permutation of the integers from 1
to N. Algorithm from Knuth, Vol 2, p 125)
(DPROG ((DEAL (VFROMR (for I K (DROW ←(GENROW 1 N))
declare (DROW ROWINT)
(K INTEGER (SATISFIES (INDEXP DROW K)))
(RETURNS ROWINT)
from N to 2 by -1
do (K←(RAND 1 I))
(DROW$K←(PROG1 DROW$I DROW$I←DROW$K))
finally (RETURN DROW))) SIMARRAY))
(if LABPROPFLAG
then (SETTITLE DEAL (MAKETITLE NIL N)))
(RETURN DEAL))])
(ELEMENTTYPE
[ULAMBDA ((A ARRAY)
(RETURNS (MEMQ INTEGER FLOATING)))
(* bas: " 9-SEP-77 14:36" posted: " 5-AUG-77 09:57")
A:AELTTYPE])
(FORMAT
[ULAMBDA ((A ARRAY)
(RETURNS FORMATCODE))
(* bas: " 9-SEP-77 14:37" posted: " 5-AUG-77 09:58")
A:FORMAT])
(GENVEC
[ULAMBDA ((INITIAL [ONEOF ARITH (VECTOR (SATISFIES (EQ (GETRELT (fetch SHAPE of INITIAL)
1)
2])
(END ARITH)
(RETURNS VECTOR))
(* jop: "12-Nov-84 15:44")
(* Generates sequences of ARITH)
(DPROG ((S NIL ARITH)
(D NIL ARITH)
(N NIL IJK)
(GV NIL SIMARRAY))
(if (type? ARITH INITIAL)
then (SETQ S INITIAL)
(SETQ D (if (GREATERP END S)
then 1
else -1))
else (SETQ S (OR (GETAELT INITIAL (AELTPTR1 INITIAL 1))
(UERROR "NIL in INITIAL")))
(SETQ D (DIFFERENCE (OR (GETAELT INITIAL (AELTPTR1 INITIAL 2))
(UERROR "NIL in INITIAL"))
S)))
[SETQ N (ADD1 (FIX (QUOTIENT (DIFFERENCE END S)
D]
(if (ILESSP N 1)
then (UERROR "Inconsistent increment and bounds"))
[SETQ GV (VFROMR (if (OR (type? FLOATING S)
(type? FLOATING END))
then (bind SF (ROW ←(create ROWFLOAT
NELTS ← N))
(DF ←(FLOAT D)) for I to N
declare (I IJK)
(ROW ROWFLOAT)
first (SETQ SF (FDIFFERENCE (FLOAT S)
DF))
do [SETRELT ROW I (FPLUS SF (FTIMES DF (FLOAT I]
(* Done by multip so as to prevent accumulation of
roundoff error)
finally (RETURN ROW))
else (bind (VAL ← S)
(ROW ←(create ROWINT
NELTS ← N))
for I to N
declare (VAL FIXP)
(I IJK)
(ROW ROWINT)
do (SETRELT ROW I VAL)
(add VAL D)
finally (RETURN ROW]
[if LABPROPFLAG
then (SETTITLE GV (if (type? ARITH INITIAL)
then (CONCAT INITIAL "->" END)
else (CONCAT S "->" END " by " D]
(RETURN GV))])
(IDLARRAYP
[ULAMBDA (A)
(* rmk: "19-JUL-78 10:50" posted: "19-JUL-78 10:52")
(* Predicate for IDLARRAY-hood)
(AND (ARRAYTYPEP A 'ARRAY)
~(VSCALARP A))])
(ORDER
[ULAMBDA ((V (EXPECTS VECTOR))
(CFN (ONEOF NIL FUNCTION) "Illegal comparison function")
(RETURNS VECTOR))
(* rmk: "26-APR-78 11:13" posted: "26-JUL-77 17:56")
(* The user entry for ordering.
NOTE: Values passed to CFN are ephemeral!!)
(DPROG ((OV (VFROMR (ORDERROW (CONV.SIMARRAY V):ELEMENTBLOCK CFN)) VECTOR)
(RETURNS VECTOR))
[if LABPROPFLAG
then (SETTITLE OV (MAKETITLE NIL V (AND CFN < " by " (if (LITATOM CFN)
then CFN
else "user form")
>]
(RETURN OV))])
(ORDERROW
[DLAMBDA ((X ROWSCALAR (USEDIN ORDERROW1))
(C (ONEOF NIL FUNCTION) (USEDIN ORDERROW1) (* comparison fn))
(RETURNS ROWINT))
(* bas: "25-JUL-79 18:30" posted: " 7-SEP-77 18:16")
(* Returns an ordering row for X)
(DPROG ((N (X:NELTS) INTEGER)
THEN (TT (GENROW 1 N) ROWINT (USEDIN ORDERROW1)))
(if ~C
then C←(if (type? ROWINT X)
then (FUNCTION ILESSP)
elseif (type? ROWFLOAT X)
then (FUNCTION LESSP)
else (FUNCTION ULESSP)))
(if N gt 8
then (ORDERROW1 1 N)) (* Insertion sort. The quicksort provided by ORDERROW1
guarantees that we only have to search back a bounded
amount)
[for I U from 2 to N
do (U←X$(TT$I))
(for J V from I-1 by -1 to 1 until (OR (EQP U V←X$(TT$J))
(APPLY* C V U))
do (TT$J←(PROG1 TT$(J+1)
TT$(J+1)←TT$J]
(RETURN TT))])
(ORDERROW1
[DLAMBDA ((L INTEGER)
(R INTEGER (SATISFIES (L lt R))))
(* bas: "25-JUL-79 18:34" posted: " 7-SEP-77 18:16")
(* Does the partitioning for ORDERROW)
(DECL (X ROWSCALAR (BOUNDIN ORDERROW))
(C FUNCTION (BOUNDIN ORDERROW))
(TT ROWINT (BOUNDIN ORDERROW)))
(bind V M J I←L
declare (I INTEGER)
(J INTEGER)
until R-L lt 9
do (M←X$(TT$((L+R)/2)))
(J←R)
(do (until (OR (EQP M V←X$(TT$I))
~(APPLY* C V M))
do
(* Tricky! We check for EQ as the comparison must fail against the item being used to partition the set.
This is no sweat for fns like ILESSP but if (FN X X) we would shift to oblivion otherwise)
(add I 1))
(until (OR (EQP M V←X$(TT$J))
~(APPLY* C M V))
do (* Ditto tricky!)
(add J -1))
(if I lt J
then (TT$I←(PROG1 TT$J TT$J←TT$I))
(add I 1)
(add J -1)
else (RETURN) (* I and J have converged)))
(if J gt L+8
then (ORDERROW1 L J)) (* Recurse if left part longer than 8)
(L←I) (* Tail recursion))])
(RANK
[ULAMBDA ((A (EXPECTS ARRAY))
(RETURNS ARRAY))
(* jop: " 5-Sep-85 17:17" posted: " 1-AUG-77 11:09")
(* Returns a matrix with the same shape as A, but whose
values are their ranks over the set of elements in A)
(DPROG ((AE (fetch ELEMENTBLOCK of (CONV.SIMARRAY A)) ROWSCALAR)
THEN (L (fetch NELTS of AE) INTEGER)
(X (ORDERROW AE) ROWINT)
THEN (RX (create ROWINT
NELTS ← L) ROWSCALAR)
(RANK NIL SIMARRAY)
(SCR NIL SCALAR))
(for I J (NNIL ← 0) to L
do (SETQ SCR (GETRELT AE (GETRELT X I)))
(SETQ J (PLUS [for J from (PLUS I 1)
thereis (OR (GREATERP J L)
(NOT (EQP SCR (GETRELT AE (GETRELT X J]
-1))
(if SCR
then (SETQ SCR (if (GREATERP J I)
then (if (EQ (IREMAINDER (PLUS J I)
2)
0)
then (QUOTIENT (PLUS I J)
2)
else (OR (EQ (fetch RELTTYPE of RX)
(QUOTE FLOATING))
(SETQ RX (FLOATROW RX L)))
(QUOTIENT (PLUS I J)
2.0))
else I)) (* Computing rank for this batch of tied scores)
[OR (EQ NNIL 0)
(SETQ SCR (if (FIXP SCR)
then (DIFFERENCE SCR NNIL)
else (FDIFFERENCE SCR (FLOAT NNIL]
(* Adjusting rank for previously seen NILs)
else (SETQ NNIL (PLUS (DIFFERENCE J I)
1)) (* Set NNIL to size of NIL block)
)
(for K from I to J do (SETRELT RX (GETRELT X K)
SCR))
(SETQ I J))
(SETQ RANK (create SIMARRAY
SHAPE ←(fetch SHAPE of A)
FORMAT ←(fetch FORMAT of A)
ELEMENTBLOCK ← RX))
(if LABPROPFLAG
then (LAB.COPYDIMS A RANK)
(SETTITLE RANK (MAKETITLE NIL A)))
(RETURN RANK))])
(REDUCE
[LAMBDA REDUCENARGS (* DECLARATIONS: (RECORD ARGRECORD
(A F STARTINGVAL)))
(DECLARE (SPECVARS REDUCENARGS)) (* bas: "11-FEB-83 09:53")
(* Applies user binary fn F left associatively to the elements of A. Returns NIL for empty arrays.
A no-spread function so we can distinguish a starting value of NIL from no startingvalue at all.)
(UENTRY (QUOTE REDUCE)
(EAPPLY* [FUNCTION [ULAMBDA ((A ARRAY)
(F FUNCTION)
(STARTINGVAL ANY)
(RETURNS ANY))
(DECL (REDUCENARGS (BOUNDIN REDUCE)))
(if (VSCALARP A)
then (SETQ A (CONV.VECTOR A)))
(if (IEQP 0 (NLOGICALELTS (fetch SHAPE of A)))
then STARTINGVAL
else (bind (GSBA ←(SETUP A (QUOTE ROWMAJOR)))
RESULT declare (GSBA GENSTATEBLOCK)
first [SETQ RESULT (OR STARTINGVAL
(AND (ILESSP REDUCENARGS 3)
(COPYAELT A (NEXT GSBA]
(* STARTINGVAL taken if either it is non-NIL or there
were more than 2 args)
until (fetch DONE of GSBA)
do [SETQ RESULT (APPLY* F RESULT (COPYAELT A (NEXT GSBA]
finally (RETURN RESULT)))]]
(QUOTE (ARRAY))
(AND (IGREATERP REDUCENARGS 0)
(ARG REDUCENARGS 1))
(AND (IGREATERP REDUCENARGS 1)
(ARG REDUCENARGS 2))
(AND (IGREATERP REDUCENARGS 2)
(ARG REDUCENARGS 3])
(RESHAPE
[ULAMBDA ((A (EXPECTS ARRAY (ONEOF SCALAR ARRAY)))
(NEWSHAPE (ONEOF NIL VECTOR))
(NEWFORMAT (ONEOF NIL FORMATCODE))
(RETURNS SIMARRAY))
(* bas: "11-JAN-79 12:04" posted: "20-MAY-78 15:03")
(* Reads an array in rowmajor order and puts it in an
array of shape NEWSHAPE and format NEWFORMAT)
(DPROG ((SROW (if NEWSHAPE
then (CONV.ROWINT NEWSHAPE)
else (ROWINTOF (if (type? ARRAY A)
then (NLOGICALELTS A:SHAPE)
else 1))) ROWINT)
(NEWARRAY NIL SIMARRAY))
(for I from 1 to SROW:NELTS when (MINUSP SROW$I) do (UERROR
"Negative element in NEWSHAPE: "
SROW$I))
(if NEWFORMAT='SYMMETRIC
then (OR (if (IEQP SROW:NELTS 2)
then (IEQP SROW$1 SROW$2))
(UERROR "Shape not consistent with symmetric format"))
else NEWFORMAT←'FULL) (* Coerce NIL to FULL)
[if (type? SCALAR A)
then NEWARRAY←(ALLOC.SARRAY SROW NEWFORMAT A)
elseif (AND (type? SIMARRAY A)
(IEQP (NPHYSICALELTS A:SHAPE A:FORMAT)
(NPHYSICALELTS SROW NEWFORMAT)))
then (if A=(UARG A)
then (NEWARRAY←(create SIMARRAY
SHAPE ← SROW
FORMAT ← NEWFORMAT
ELEMENTBLOCK ← A:ELEMENTBLOCK))
(if LABPROPFLAG
then (SETTITLE NEWARRAY (MAKETITLE 'VALUES A)))
else (NEWARRAY←A) (* A is new, user-invisible)
(NEWARRAY:SHAPE←SROW)
(NEWARRAY:SLOT3←(MAKEOFFSETS SROW)))
elseif (VSCALARP A)
then NEWARRAY←(ALLOC.SARRAY SROW NEWFORMAT (CONV.SCALAR A))
else (NEWARRAY←(ALLOC.SARRAY SROW NEWFORMAT A:AELTTYPE))
(if (IEQP 0 (NLOGICALELTS A:SHAPE))
then (OR (IEQP 0 (NLOGICALELTS SROW))
(UERROR "Cant reshape an empty array to a non-empty one")))
(bind (GSBOLD ←(SETUP A 'ROWMAJOR))
(GSBNEW ←(SETUP NEWARRAY 'ROWMAJOR))
declare (GSBOLD GENSTATEBLOCK)
(GSBNEW GENSTATEBLOCK)
until GSBNEW:DONE
do (SETAELT NEWARRAY (NEXT GSBNEW)
(GETAELT A (NEXT GSBOLD)))
(if GSBOLD:DONE
then (RESETUP GSBOLD)))
(if LABPROPFLAG
then (SETTITLE NEWARRAY (MAKETITLE 'VALUES < " from " A>]
[if (AND LABPROPFLAG NEWSHAPE)
then (for I from 1 to SROW:NELTS do (SETDIMLAB NEWARRAY I (GETLEVLAB NEWSHAPE 1 I]
(RETURN NEWARRAY))])
(RPLUS
[ULAMBDA ((A (EXPECTS ARRAY))
(RETURNS SCALAR))
(* jop: "12-Nov-84 15:46" posted: "20-MAY-78 15:03")
(* Returns sum of all elements, 0 if A is empty, NIL if
any element is NIL.)
(if (VSCALARP A)
then (COPYAELT A (VSCALARPTR A))
else (SELECTQ (fetch AELTTYPE of A)
(INTEGER (bind (TOT ← 0)
(GSBA ←(SETUP A (QUOTE ROWMAJOR)))
declare (GSBA GENSTATEBLOCK)
(TOT FIXP)
until (fetch DONE of GSBA) do (add TOT (OR (GETAELT A (NEXT GSBA))
(RETURN)))
finally (RETURN TOT)))
(FLOATING (bind (TOT ← 0.0)
(GSBA ←(SETUP A (QUOTE ROWMAJOR)))
declare (GSBA GENSTATEBLOCK)
(TOT FLOATING)
until (fetch DONE of GSBA) do (fadd TOT (OR (GETAELT A (NEXT GSBA))
(RETURN)))
finally (RETURN TOT)))
(SHOULDNT)))])
(RTIMES
[ULAMBDA ((A (EXPECTS ARRAY))
(RETURNS SCALAR))
(* jop: "12-Nov-84 15:47")
(* Returns product of all elements, 1 if A is empty,
NIL if any element is NIL.)
(if (VSCALARP A)
then (COPYAELT A (VSCALARPTR A))
else (SELECTQ (fetch AELTTYPE of A)
(INTEGER (bind (GSBA ←(SETUP A (QUOTE ROWMAJOR)))
(PROD ← 1)
declare (GSBA GENSTATEBLOCK)
(PROD FIXP)
until (fetch DONE of GSBA)
do [SETQ PROD (ITIMES PROD (OR (GETAELT A (NEXT GSBA))
(RETURN]
finally (RETURN PROD)))
(FLOATING (bind (GSBA ←(SETUP A (QUOTE ROWMAJOR)))
(PROD ← 1.0)
declare (GSBA GENSTATEBLOCK)
(PROD FLOATING)
until (fetch DONE of GSBA)
do [SETQ PROD (FTIMES PROD (OR (GETAELT A (NEXT GSBA))
(RETURN]
finally (RETURN PROD)))
(SHOULDNT)))])
(SEEK
[ULAMBDA ((SOUGHT (ONEOF FUNCTION SCALAR VECTOR))
(VEC VECTOR)
(RETURNS VECTOR))
(* rmk: "28-FEB-80 21:53" posted: " 2-AUG-77 10:52")
(* Returns a (sorted) vector of indicies I st VEC@I is equal to SOUGHT, member of SOUGHT, or an argument which when
given to SOUGHT returns non NIL. Scalars are treated separately for efficiency.)
(DPROG ((GSBV (SETUP VEC 'ROWMAJOR) GENSTATEBLOCK)
(STYPE (SELTYPEQ SOUGHT
(SCALAR 'SCALAR)
(VECTOR 'VECTOR)
'FUNCTION) (MEMQ FUNCTION SCALAR VECTOR))
THEN (FND (VFROMR (ROWINTOF1 (bind (VSIZE ←(fetch ELTCNT of GSBV))
(GSBS ←(if STYPE='VECTOR
then (SETUP SOUGHT 'DONTCARE)))
declare (VSIZE CARDINAL
(* To convert ELTCNT to index;
not large cause of APPLY* below))
(GSBS (ONEOF NIL GENSTATEBLOCK))
until GSBV:DONE
when (SELECTQ STYPE
[FUNCTION (APPLY* SOUGHT (COPYAELT VEC
(NEXT GSBV]
[SCALAR (UEQP SOUGHT (GETAELT VEC (NEXT GSBV]
(bind (V ←(GETAELT VEC (NEXT GSBV)))
first (RESETUP GSBS) until GSBS:DONE
when (UEQP V (GETAELT SOUGHT (NEXT GSBS)))
do (RETURN T)))
collect VSIZE-GSBV:ELTCNT))) VECTOR)
(RETURNS VECTOR))
(if LABPROPFLAG
then (SETTITLE FND (MAKETITLE NIL VEC < " for " (if (AND STYPE='FUNCTION ~(LITATOM
SOUGHT))
then "user form"
else SOUGHT)
>)))
(RETURN FND))])
(SHAPE
[ULAMBDA ((A (ONEOF SCALAR ARRAY))
(RETURNS VECTOR))
(* bas: " 2-DEC-78 23:01" posted: " 5-AUG-77 09:57")
(DPROG ((S (VFROMR (if (type? SCALAR A)
then (ROWINTOF)
else A:SHAPE)) VECTOR))
[if LABPROPFLAG
then (SETTITLE S (MAKETITLE NIL A))
(SETDIMLAB S 1 'Dimension)
(for I to S:SHAPE$1 do (SETLEVLAB S 1 I (GETDIMLAB A I]
(RETURN S))])
(SHIFT
[LAMBDA SHIFTNARGS (* DECLARATIONS: (RECORD ARGRECORD
(V SHIFT FILL)))
(* jop: "30-Apr-85 14:49")
(* Shifts vector V SHIFT positions to the right (left if SHIFT negative), replacing vacated elements with successive
elements from the opposite end of vector FILL (or V if FILL not given). If FILL exhausts, it is restarted.)
(DECLARE (SPECVARS SHIFTNARGS))
(UENTRY (QUOTE SHIFT)
(EAPPLY* [FUNCTION [ULAMBDA ((V VECTOR)
(SHIFT INTEGER)
(FILL (ONEOF SCALAR VECTOR))
(RETURNS VECTOR))
(if (ILESSP SHIFTNARGS 3)
then (SETQ FILL V))
(if (IEQP SHIFT 0)
then (DPROG ((OUT (PRESERVE V) VECTOR))
(SETTITLE OUT (if (IGREATERP SHIFTNARGS 2)
then (MAKETITLE NIL V SHIFT FILL)
else (MAKETITLE NIL V SHIFT)))
(RETURN OUT))
else
(DPROG ((LEFT (MINUSP SHIFT) BOOL
(* T if shifting to the left))
(DIST (if (MINUSP SHIFT)
then (IMINUS SHIFT)
else SHIFT) IJK
(* How far to go))
(FL (if (type? SCALAR FILL)
then 1
else (GETRELT (fetch SHAPE of FILL)
1)) IJK
(* Length of FILL))
(VL (GETRELT (fetch SHAPE of V)
1) IJK
(* Length of V))
THEN (SH (ALLOC.SARRAY
(ROWINTOF VL)
(QUOTE FULL)
(if (OR (EQ (fetch AELTTYPE of V)
(QUOTE FLOATING))
(AND (type? ARRAY FILL)
(EQ (fetch AELTTYPE of FILL)
(QUOTE FLOATING)))
(type? FLOATING FILL))
then (QUOTE FLOATING)
else (QUOTE INTEGER))) VECTOR)
THEN (GSBS (SETUP SH (QUOTE ROWMAJOR)) GENSTATEBLOCK)
(RETURNS VECTOR))
(* Add the surviving elements of V)
[for I GSBV from (ADD1 DIST) to VL
declare (I IJK)
(GSBV GENSTATEBLOCK)
first (SETQ GSBV (SETUP V (QUOTE ROWMAJOR)))
(* GSB not created if DIST gt VL)
(SKIP (if LEFT
then GSBV
else GSBS)
DIST)
do (SETAELT SH (NEXT GSBS)
(GETAELT V (NEXT GSBV]
(* Then fill the vacated cells)
(if (NOT LEFT)
then (RESETUP GSBS))
(* Go back to the beginning if shifting right, continue
on if going left)
[if (type? SCALAR FILL)
then (for I from 1 to (IMIN DIST VL)
declare (I IJK) do (SETAELT SH (NEXT GSBS)
FILL))
else (bind (GSBF ←(SETUP FILL (QUOTE ROWMAJOR)))
for I from 1 to (IMIN DIST VL)
declare (I IJK)
first [SKIP GSBF
(if LEFT
then (IMAX 0
(IREMAINDER
(IDIFFERENCE DIST VL)
FL))
else (IDIFFERENCE FL
(IREMAINDER DIST
FL]
do (if (fetch DONE of GSBF)
then (RESETUP GSBF))
(SETAELT SH (NEXT GSBS)
(GETAELT FILL (NEXT GSBF]
[if LABPROPFLAG
then (SETTITLE SH (if (IGREATERP SHIFTNARGS 2)
then (MAKETITLE NIL V SHIFT FILL)
else (MAKETITLE NIL V SHIFT]
(RETURN SH)))]]
(QUOTE (VECTOR SCALAR VECTOR))
(AND (IGREATERP SHIFTNARGS 0)
(ARG SHIFTNARGS 1))
(AND (IGREATERP SHIFTNARGS 1)
(ARG SHIFTNARGS 2))
(AND (IGREATERP SHIFTNARGS 2)
(ARG SHIFTNARGS 3])
(TRANSPOSE
[ULAMBDA ((A ARRAY)
(PERM (ONEOF LST VECTOR))
(RETURNS ARRAY))
(* rmk: "14-JAN-79 14:05" posted: "14-JAN-79 14:05")
(* The APL transpose function)
(DPROG ((S (A:SHAPE) ROWINT)
(TA NIL SIMARRAY (* Result hook))
THEN (SN (S:NELTS) INTEGER)
THEN (PV (if PERM
then (MAKEDIMSPEC A PERM)
else (DPROG ((R (create ROWINT
NELTS ← SN) ROWINT)
(RETURNS ROWINT))
(for I to SN do (R$I←SN+1-I))
(RETURN R))) ROWINT)
(MN 0 INTEGER (* dimensionality of result))
(M NIL ROWINT (* shape of result)))
(if PV:NELTS~=SN
then (UERROR "Wrong length dimension specification"))
(for I to SN do (if MN lt PV$I
then MN←PV$I))
(M←(create ROWINT
NELTS ← MN
INIT ← -1))
(for I TVI to SN
do (TVI←PV$I)
(M$TVI←([LAMBDA (X Y)
(if (OR (MINUSP X)
(X gt Y))
then Y
else X]
M$TVI S$I)))
(if (for I to MN thereis (MINUSP M$I))
then (UERROR "Missing dimension in dimension specification"))
(TA←(ALLOC.SARRAY M 'FULL A:AELTTYPE))
(DPROG ((TAE (TA:ELEMENTBLOCK) ROWSCALAR)
(IDX (create ROWINT
NELTS ← SN
INIT ← 1) ROWINT)
(INV (create ROWINT
NELTS ← MN) ROWINT))
(for I to SN do (INV$(PV$I)←I))
[for I to TAE:NELTS
do (TAE$I←(GETAELT A (AELTPTR A IDX)))
(for J V←1 from MN by -1 to 1 while V=1
do (V←(if (IEQP M$J IDX$(INV$J))
then 1
else IDX$(INV$J)+ 1))
(for K to INV$J do (if PV$K=J
then (IDX$K←V])
(if LABPROPFLAG
then (SETTITLE TA (MAKETITLE NIL A (AND PERM < " by " (if (LISTP PERM)
then <'LIST ! PERM>
else PERM)
>)))
(for I AI to MN when AI←(for J to SN
do (if PV$J=I
then (if $$VAL
then (RETURN)
else $$VAL ←J))
(* only dimensions that are not projected together on
one dim of the transposed arrray are given labels)
)
do (LAB.COPYDIM A TA AI I T)))
(RETURN TA))])
)
(PUTPROPS REDUCE ARGNAMES (NIL (A F STARTINGVAL) . REDUCENARGS))
(PUTPROPS SHIFT ARGNAMES (NIL (V SHIFT FILL) . SHIFTNARGS))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA SHIFT REDUCE CROSS ADJOIN)
)
(PUTPROPS ARRAY COPYRIGHT ("Xerox Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (739 36943 (ADJOIN 749 . 4413) (CROSS 4415 . 9905) (DEAL 9907 . 10762) (ELEMENTTYPE
10764 . 10984) (FORMAT 10986 . 11186) (GENVEC 11188 . 13425) (IDLARRAYP 13427 . 13733) (ORDER 13735 .
14505) (ORDERROW 14507 . 15739) (ORDERROW1 15741 . 17243) (RANK 17245 . 19575) (REDUCE 19577 . 21423)
(RESHAPE 21425 . 24285) (RPLUS 24287 . 25414) (RTIMES 25416 . 26567) (SEEK 26569 . 28421) (SHAPE 28423
. 28961) (SHIFT 28963 . 34053) (TRANSPOSE 34055 . 36941)))))
STOP