(FILECREATED "28-Jun-86 15:47:05" {QV}<PEDERSEN>LISP>IDLARRAYFNS.;17 51706
changes to: (FNS AT MONADIC-APPLY DYADIC-APPLY REDUCE SCAN SWEEP PLUS-SWEEP TIMES-SWEEP
QUOTIENT-SWEEP DIFFERENCE-SWEEP ELEMENT-OF FACTORIAL LAMINATE REGRESS)
(VARS IDLARRAYFNSCOMS)
previous date: "25-Jun-86 14:53:00" {QV}<PEDERSEN>LISP>IDLARRAYFNS.;15)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT IDLARRAYFNSCOMS)
(RPAQQ IDLARRAYFNSCOMS [(* File created by Coms Manager.)
(FNS CEILING COMPRESS DIFFERENCE-SWEEP DROP DYADIC-APPLY ELEMENT-OF EXPAND FACTORIAL FLOOR
GENVECTOR ADJOIN ASLIST ASSIGN ASSIGN* DEAL ASVECTOR ASVECTOR* AT AT* IDL-ABS IDL-AND
IDL-ANTILOG IDL-CHOOSE IDL-COPY IDL-COS IDL-DIFFERENCE IDL-EQP IDL-EQUAL IDL-EXPT
IDL-GEQ IDL-GREATERP IDL-LEQ IDL-LESSP IDL-LOG IDL-MAX IDL-MIN IDL-MINUS IDL-NAND
IDL-NOR IDL-NOT IDL-NOT-EQP IDL-NOT-EQUAL IDL-OR IDL-PLUS IDL-QUOTIENT IDL-RAND IDL-SIN
IDL-SQRT IDL-TAN IDL-TIMES IDL-XOR INDEX-OF INNERPRODUCT INV-T-DIST LAMINATE MAX-REDUCE
MEAN MEDIAN MIN-REDUCE MONADIC-APPLY NORMALS ORDER PLUS-REDUCE PLUS-SCAN PLUS-SWEEP
QUOTIENT-SWEEP RAVEL REDUCE REGRESS RESHAPE RESIDUE REVERSAL ROLL ROTATE SAMPLE-VARIANCE
SCAN SHAPE SWEEP T-DIST TAKE TIMES-SWEEP TRANSPOSE VARIANCE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA AT* ASVECTOR*
ASSIGN*])
(* File created by Coms Manager.)
(DEFINEQ
(CEILING
[LAMBDA (ARRAY RESULT) (* jop: "25-Jun-86 00:44")
(* *)
(MONADIC-APPLY (QUOTE CEILING)
ARRAY RESULT (QUOTE NUMERIC)
(QUOTE INTEGER])
(COMPRESS
[LAMBDA (COMPRESSION IDLARRAY AXIS RESULT) (* jop: "23-Jun-86 23:39")
(* * as in the APL compression operator, AXIS is optional, defaults to last dimension)
[if (NULL AXIS)
then (SETQ AXIS (SUB1 (IDLARRAY-RANK IDLARRAY]
(LET ((SIZE (IDLARRAY-DIMENSION IDLARRAY AXIS))
(RESULTELTTYPE (IDLARRAY-ELTTYPE IDLARRAY)))
(if [NOT (AND (IDLARRAY-ELTTYPEP COMPRESSION (QUOTE LOGICAL))
(OR (SCALARP COMPRESSION)
(AND (EQ (IDLARRAY-RANK COMPRESSION)
1)
(EQ (IDLARRAY-TOTALSIZE COMPRESSION)
SIZE]
then (HELP "Compression vector of incorrect form" COMPRESSION))
(if (AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
RESULTELTTYPE)))
then (ERROR "Result of incorrect type" RESULT))
(SETQ RESULT (IDLARRAY-CREATE (EARRAY-COMPRESS (IDLARRAY-CMLARRAY COMPRESSION)
(IDLARRAY-CMLARRAY IDLARRAY)
AXIS
(IDLARRAY-CMLARRAY RESULT))
RESULTELTTYPE NIL NIL RESULT))
(AND (IDLARRAY-HAS-DIMLABELS-P IDLARRAY)
(IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS IDLARRAY)))
[for DIM from 0 upto (IDLARRAY-RANK IDLARRAY) when (IDLARRAY-HAS-LEVELLABELS-P
IDLARRAY DIM)
do (if (AND (EQ DIM AXIS)
(NEQ COMPRESSION 1))
then [AND (NEQ COMPRESSION 0)
(bind (RESULTLEVEL ← 0)
LEVELLABEL for I from 0 upto SIZE
when (EQ (IDLARRAY-REF COMPRESSION I)
1)
do (SETQ LEVELLABEL (IDLARRAY-GETLEVELLABEL IDLARRAY DIM
I))
(if (LITATOM LEVELLABEL)
then (IDLARRAY-SETLEVELLABEL RESULT DIM
RESULTLEVEL
LEVELLABEL))
(SETQ RESULTLEVEL (ADD1 RESULTLEVEL]
else (IDLARRAY-SETLEVELLABELS RESULT DIM (IDLARRAY-LEVELLABELS IDLARRAY DIM]
RESULT])
(DIFFERENCE-SWEEP
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: "28-Jun-86 13:37")
(* *)
(SWEEP (QUOTE DIFFERENCE)
ARRAY1 ARRAY2 AXIS RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(DROP
[LAMBDA (DROPVECTOR IDLARRAY RESULT) (* jop: "23-Jun-86 23:48")
(* *)
(LET ((RANK (IDLARRAY-RANK IDLARRAY))
(RESULTELTTYPE (IDLARRAY-ELTTYPE IDLARRAY)))
(if [NOT (AND (IDLARRAY-ELTTYPEP DROPVECTOR (QUOTE INTEGER))
(OR (SCALARP DROPVECTOR)
(AND (EQ (IDLARRAY-RANK DROPVECTOR)
1)
(EQ (IDLARRAY-TOTALSIZE DROPVECTOR)
RANK]
then (HELP "Dropvector vector of incorrect form" DROPVECTOR))
(if (AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
RESULTELTTYPE)))
then (ERROR "Result of incorrect type" RESULT))
(SETQ RESULT (IDLARRAY-CREATE (EARRAY-DROP (IDLARRAY-CMLARRAY DROPVECTOR)
(IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-CMLARRAY RESULT))
RESULTELTTYPE NIL NIL RESULT))
(AND (IDLARRAY-HAS-DIMLABELS-P IDLARRAY)
(IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS IDLARRAY)))
[bind V for I from 0 upto RANK as DIM in (IDLARRAY-DIMS IDLARRAY)
when (IDLARRAY-HAS-LEVELLABELS-P IDLARRAY I)
do (SETQ V (IDLARRAY-REF DROPVECTOR I))
(if (ILESSP V 0)
then [IDLARRAY-SETLEVELLABELS RESULT I (IDLARRAY-LEVELLABELS
IDLARRAY I 0 (SUB1 (IPLUS DIM V]
else (IDLARRAY-SETLEVELLABELS RESULT I (IDLARRAY-LEVELLABELS IDLARRAY I V]
RESULT])
(DYADIC-APPLY
[LAMBDA (FN ARRAY1 ARRAY2 RESULT LEFTELTTYPE RIGHTELTTYPE RESULTELTTYPE)
(* jop: "28-Jun-86 12:57")
(* *)
(if (AND LEFTELTTYPE (NOT (IDLARRAY-ELTTYPEP ARRAY1 LEFTELTTYPE)))
then (HELP "Left array not of type" LEFTELTTYPE))
(if (AND RIGHTELTTYPE (NOT (IDLARRAY-ELTTYPEP ARRAY2 RIGHTELTTYPE)))
then (HELP "Right array not of type" RIGHTELTTYPE))
[if (NULL RESULTELTTYPE)
then (SETQ RESULTELTTYPE (IDLARRAY-COMMON-TYPE (IDLARRAY-ELTTYPE ARRAY1)
(IDLARRAY-ELTTYPE ARRAY2]
(LET ((DIMS1 (IDLARRAY-DIMS ARRAY1))
(DIMS2 (IDLARRAY-DIMS ARRAY2)))
(if (AND DIMS1 DIMS2 (NOT (EQUAL DIMS1 DIMS2)))
then (HELP "Nonconformable args"))
(if (OR DIMS1 DIMS2)
then (SETQ RESULT (TEST-RESULT RESULT (OR DIMS1 DIMS2)
RESULTELTTYPE))
(EARRAY-DYADIC-APPLY FN (IDLARRAY-CMLARRAY ARRAY1)
(IDLARRAY-CMLARRAY ARRAY2)
(IDLARRAY-CMLARRAY RESULT))
(if (NULL DIMS1)
then (COPYLABELS ARRAY2 RESULT)
elseif (NULL DIMS2)
then (COPYLABELS ARRAY1 RESULT))
RESULT
else (EARRAY-DYADIC-APPLY FN ARRAY1 ARRAY2])
(ELEMENT-OF
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "28-Jun-86 13:15")
(* *)
(SETQ RESULT (TEST-RESULT RESULT (IDLARRAY-DIMS ARRAY1)
(QUOTE LOGICAL)))
(EARRAY-MEMBER (IDLARRAY-CMLARRAY ARRAY1)
(IDLARRAY-CMLARRAY ARRAY2)
(IDLARRAY-CMLARRAY RESULT))
(COPYLABELS ARRAY1 RESULT)
RESULT])
(EXPAND
[LAMBDA (EXPANSION IDLARRAY AXIS RESULT) (* jop: "23-Jun-86 23:39")
(* * as in the APL compression operator, AXIS is optional, defaults to last dimension)
[if (NULL AXIS)
then (SETQ AXIS (SUB1 (IDLARRAY-RANK IDLARRAY]
(if (NOT (AND (IDLARRAY-ELTTYPEP EXPANSION (QUOTE LOGICAL))
(EQ (IDLARRAY-RANK EXPANSION)
1)))
then (HELP "Expansion vector of incorrect form" EXPANSION))
(if [AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
(IDLARRAY-ELTTYPE IDLARRAY]
then (ERROR "Result of incorrect type" RESULT))
(SETQ RESULT (IDLARRAY-CREATE (EARRAY-EXPAND (IDLARRAY-CMLARRAY EXPANSION)
(IDLARRAY-CMLARRAY IDLARRAY)
AXIS
(IDLARRAY-CMLARRAY RESULT))
(IDLARRAY-ELTTYPE IDLARRAY)
NIL NIL RESULT))
(AND (IDLARRAY-HAS-DIMLABELS-P IDLARRAY)
(IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS IDLARRAY)))
[for DIM from 0 upto (IDLARRAY-RANK IDLARRAY) when (IDLARRAY-HAS-LEVELLABELS-P
IDLARRAY DIM)
do (if (EQ DIM AXIS)
then (bind (LEVEL ← 0)
LEVELLABEL for I from 0 upto (IDLARRAY-TOTALSIZE EXPANSION)
when (EQ (IDLARRAY-REF EXPANSION I)
1)
do (SETQ LEVELLABEL (IDLARRAY-GETLEVELLABEL IDLARRAY DIM LEVEL))
(if (LITATOM LEVELLABEL)
then (IDLARRAY-SETLEVELLABEL RESULT DIM I LEVELLABEL))
(SETQ LEVEL (ADD1 LEVEL)))
else (IDLARRAY-SETLEVELLABELS RESULT DIM (IDLARRAY-LEVELLABELS IDLARRAY DIM]
RESULT])
(FACTORIAL
[LAMBDA (ARRAY RESULT) (* jop: "28-Jun-86 13:16")
(* *)
(MONADIC-APPLY (QUOTE FACTORIAL)
ARRAY RESULT (QUOTE COUNT)
(QUOTE COUNT])
(FLOOR
[LAMBDA (ARRAY RESULT) (* jop: "25-Jun-86 00:44")
(* *)
(MONADIC-APPLY (QUOTE FLOOR)
ARRAY RESULT (QUOTE NUMERIC)
(QUOTE INTEGER])
(GENVECTOR
[LAMBDA (N START STEPSIZE) (* jop: "25-Jun-86 09:57")
(* *)
(if (NULL N)
then (HELP "Must supply N"))
(if (NULL START)
then (SETQ START 0))
(if (NULL STEPSIZE)
then (SETQ STEPSIZE 1))
(ASVECTOR (for I from 1 to N as VALUE from START by STEPSIZE collect VALUE])
(ADJOIN
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: "23-Jun-86 23:37")
(* * As in the APL concatenate operator)
(LET* ((RANK1 (IDLARRAY-RANK ARRAY1))
(RANK2 (IDLARRAY-RANK ARRAY2))
(RESULTELTTYPE (IDLARRAY-COMMON-TYPE (IDLARRAY-ELTTYPE ARRAY1)
(IDLARRAY-ELTTYPE ARRAY2)))
(RESULTRANK (IMAX 1 RANK1 RANK2)))
[if (NULL AXIS)
then (SETQ AXIS (IMAX 0 (SUB1 (IMAX RANK1 RANK2]
(if (AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
RESULTELTTYPE)))
then (ERROR "Result of incorrect type" RESULT))
(SETQ RESULT (IDLARRAY-CREATE (EARRAY-ADJOIN (IDLARRAY-CMLARRAY ARRAY1)
(IDLARRAY-CMLARRAY ARRAY2)
AXIS
(IDLARRAY-CMLARRAY RESULT))
RESULTELTTYPE NIL NIL RESULT))
[if (ILESSP RANK1 RANK2)
then (* ARRAY2 dominates)
(AND (IDLARRAY-HAS-DIMLABELS-P ARRAY2)
(IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS ARRAY2)))
(for DIM from 0 upto RESULTRANK when (IDLARRAY-HAS-LEVELLABELS-P
ARRAY2 DIM)
do (IDLARRAY-SETLEVELLABELS RESULT DIM (IDLARRAY-LEVELLABELS ARRAY2 DIM)
(AND (EQ DIM AXIS)
1)))
elseif (ILESSP RANK2 RANK1)
then (* ARRAY1 dominates)
(AND (IDLARRAY-HAS-DIMLABELS-P ARRAY1)
(IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS ARRAY1)))
(for DIM from 0 upto RESULTRANK when (IDLARRAY-HAS-LEVELLABELS-P
ARRAY1 DIM)
do (IDLARRAY-SETLEVELLABELS RESULT DIM (IDLARRAY-LEVELLABELS ARRAY1 DIM)
))
else (* Must be equirank)
[if (IDLARRAY-HAS-DIMLABELS-P ARRAY1)
then (if (IDLARRAY-HAS-DIMLABELS-P ARRAY2)
then (for DIM from 0 as L1 in (IDLARRAY-DIMLABELS
ARRAY1)
as L2 in (IDLARRAY-DIMLABELS ARRAY2)
do (if (LITATOM L1)
then (AND (OR (NOT (LITATOM L2))
(AND (LITATOM L2)
(EQ L1 L2)))
(IDLARRAY-SETDIMLABEL RESULT DIM
L1))
elseif (LITATOM L2)
then (IDLARRAY-SETDIMLABEL RESULT DIM L2)))
else (IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS ARRAY1)))
else (if (IDLARRAY-HAS-DIMLABELS-P ARRAY2)
then (IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS ARRAY2]
(for DIM from 0 upto RESULTRANK
do (if (IDLARRAY-HAS-LEVELLABELS-P ARRAY1 DIM)
then (if (IDLARRAY-HAS-LEVELLABELS-P ARRAY2 DIM)
then
[if (EQ DIM AXIS)
then (IDLARRAY-SETLEVELLABELS RESULT DIM
(
IDLARRAY-LEVELLABELS
ARRAY1 DIM))
(IDLARRAY-SETLEVELLABELS RESULT DIM
(
IDLARRAY-LEVELLABELS
ARRAY2 DIM)
(IDLARRAY-DIMENSION
ARRAY1 DIM))
else (for LEVEL from 0 as L1
in (IDLARRAY-LEVELLABELS ARRAY1 DIM)
as L2 in (IDLARRAY-LEVELLABELS ARRAY2
DIM)
do (if (LITATOM L1)
then
(AND (OR (NOT (LITATOM
L2))
(AND (LITATOM
L2)
(EQ L1 L2)))
(IDLARRAY-SETLEVELLABEL
RESULT DIM LEVEL L1))
elseif (LITATOM L2)
then (IDLARRAY-SETLEVELLABEL
RESULT DIM LEVEL L2]
else (IDLARRAY-SETLEVELLABELS RESULT DIM
(IDLARRAY-LEVELLABELS
ARRAY1 DIM)))
else (if (IDLARRAY-HAS-LEVELLABELS-P ARRAY2 DIM)
then (IDLARRAY-SETLEVELLABELS RESULT DIM
(IDLARRAY-LEVELLABELS
ARRAY2 DIM)
(AND (EQ DIM AXIS)
(IDLARRAY-DIMENSION
ARRAY1 DIM]
RESULT])
(ASLIST
[LAMBDA (IDLARRAY) (* jop: "23-Jun-86 23:17")
(* *)
(SELECTQ (IDLARRAY-RANK IDLARRAY)
(0 IDLARRAY)
(1 (for I from 0 upto (IDLARRAY-TOTALSIZE IDLARRAY) collect (IDLARRAY-REF
IDLARRAY I)))
(bind (LINARRAY ←(RAVEL IDLARRAY)) for I from 0 upto (IDLARRAY-TOTALSIZE
IDLARRAY)
collect (IDLARRAY-REF LINARRAY I])
(ASSIGN
[LAMBDA (NEWVALUE IDLARRAY SELECTORS) (* jop: "23-Jun-86 22:15")
(* * SELECTION OPERATOR)
(if (NOT (EQ (IDLARRAY-RANK SELECTORS)
1))
then (ERROR "Selectors must be a oned-array" SELECTORS))
(if (NOT (EQ (IDLARRAY-TOTALSIZE SELECTORS)
(IDLARRAY-RANK IDLARRAY)))
then (ERROR "Dimensional mismatch" SELECTORS))
(if (NOT (IDLARRAY-SUBTYPEP (IDLARRAY-ELTTYPE NEWVALUE)
(IDLARRAY-ELTTYPE IDLARRAY)))
then (ERROR "Type mismatch"))
[EARRAY-SET (IDLARRAY-CMLARRAY NEWVALUE)
(IDLARRAY-CMLARRAY IDLARRAY)
(EARRAY-ASVECTOR (for I from 0 upto (IDLARRAY-TOTALSIZE SELECTORS)
collect (IDLARRAY-CMLARRAY (IDLARRAY-REF SELECTORS I]
NEWVALUE])
(ASSIGN*
[LAMBDA ARGS (* jop: "24-Jun-86 23:23")
(* *)
(if (ILESSP ARGS 2)
then (ERROR "Must have at least one arg"))
(ASSIGN (ARG ARGS 1)
(ARG ARGS 2)
(ASVECTOR (for I from 3 to ARGS collect (ARG ARGS I])
(DEAL
[LAMBDA (VECTOR NUMITEMS RESULT) (* jop: "25-Jun-86 14:50")
(* *)
(if [AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
(IDLARRAY-ELTTYPE IDLARRAY]
then (ERROR "Result of incorrect type" RESULT))
(IDLARRAY-CREATE (EARRAY-DEAL (IDLARRAY-CMLARRAY VECTOR)
NUMITEMS
(IDLARRAY-CMLARRAY RESULT))
(IDLARRAY-ELTTYPE VECTOR)
NIL NIL RESULT])
(ASVECTOR
[LAMBDA (LST) (* jop: "23-Jun-86 22:29")
(* *)
(DECLARE (GLOBALVARS IDLARRAY-TYPE-TREE))
(LET* ([ELTTYPE (if (for L in LST thereis (NOT (SCALARP L)))
then (QUOTE ANY)
else (bind (LASTTYPE ←(IDLARRAY-ELTTYPE (CAR LST))) for L
in (CDR LST) until (EQ (SETQ LASTTYPE (
IDLARRAY-COMMON-TYPE
LASTTYPE
(IDLARRAY-ELTTYPE L)))
(QUOTE ANY))
finally (RETURN LASTTYPE]
(IDLARRAY (MAKE-IDLARRAY (LENGTH LST)
ELTTYPE)))
(for I from 0 as L in LST do (IDLARRAY-SET L IDLARRAY I))
IDLARRAY])
(ASVECTOR*
[LAMBDA ARGS (* jop: "23-Jun-86 22:29")
(* *)
(DECLARE (GLOBALVARS IDLARRAY-TYPE-TREE))
(LET* ([ELTTYPE (if [for I from 1 to ARGS thereis (NOT (SCALARP (ARG ARGS I]
then (QUOTE ANY)
else (bind [LASTTYPE ←(if (EQ ARGS 0)
then (QUOTE ANY)
else (IDLARRAY-ELTTYPE (ARG ARGS 1]
for I from 2 to ARGS
until (EQ [SETQ LASTTYPE (IDLARRAY-COMMON-TYPE
LASTTYPE
(IDLARRAY-ELTTYPE (ARG ARGS I]
(QUOTE ANY))
finally (RETURN LASTTYPE]
(IDLARRAY (MAKE-IDLARRAY ARGS ELTTYPE)))
(for I from 0 upto ARGS do (IDLARRAY-SET (ARG ARGS (ADD1 I))
IDLARRAY I))
IDLARRAY])
(AT
[LAMBDA (IDLARRAY SELECTORS RESULT) (* jop: "28-Jun-86 15:44")
(* * SELECTION OPERATOR)
(if (NOT (EQ (IDLARRAY-RANK SELECTORS)
1))
then (ERROR "Selectors must be a oned-array" SELECTORS))
(if (NOT (EQ (IDLARRAY-TOTALSIZE SELECTORS)
(IDLARRAY-RANK IDLARRAY)))
then (ERROR "Dimensional mismatch" SELECTORS))
(LET ((RANK (IDLARRAY-RANK IDLARRAY))
(RESULTELTTYPE (IDLARRAY-ELTTYPE IDLARRAY)))
(if (AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
RESULTELTTYPE)))
then (ERROR "Result of incorrect type" RESULT))
(SETQ RESULT (IDLARRAY-CREATE
(EARRAY-REF (IDLARRAY-CMLARRAY IDLARRAY)
[EARRAY-ASVECTOR (bind SELECTOR for I from 0 upto (
IDLARRAY-TOTALSIZE
SELECTORS)
collect (SETQ SELECTOR (IDLARRAY-REF SELECTORS
I))
(if (SCALARP SELECTOR)
then (if (EQ SELECTOR
(QUOTE ALL))
then (QUOTE ALL)
else (IDLARRAY-LEVELINDEX
IDLARRAY I SELECTOR))
else
(EARRAY-ASVECTOR
(for J from 0
upto (IDLARRAY-TOTALSIZE
SELECTOR)
collect (IDLARRAY-LEVELINDEX
IDLARRAY I
(IDLARRAY-REF
SELECTOR J]
(IDLARRAY-CMLARRAY RESULT))
RESULTELTTYPE NIL NIL RESULT))
[AND (IDLARRAY-HAS-DIMLABELS-P IDLARRAY)
(bind (RESULTDIM ← 0)
SELECTOR DIMLABEL for DIM from 0 upto RANK
when (OR [NOT (SCALARP (SETQ SELECTOR (IDLARRAY-REF SELECTORS DIM]
(EQ SELECTOR (QUOTE ALL)))
do (SETQ DIMLABEL (IDLARRAY-GETDIMLABEL IDLARRAY DIM))
(if (LITATOM DIMLABEL)
then (IDLARRAY-SETDIMLABEL RESULT RESULTDIM DIMLABEL))
(SETQ RESULTDIM (ADD1 RESULTDIM]
(bind (RESULTDIM ← 0)
SELECTOR for DIM from 0 upto RANK
when (OR [NOT (SCALARP (SETQ SELECTOR (IDLARRAY-REF SELECTORS DIM]
(EQ SELECTOR (QUOTE ALL)))
do [if (IDLARRAY-HAS-LEVELLABELS-P IDLARRAY DIM)
then (if (EQ SELECTOR (QUOTE ALL))
then (IDLARRAY-SETLEVELLABELS RESULT RESULTDIM (
IDLARRAY-LEVELLABELS IDLARRAY
DIM))
else (bind LEVELLABEL for I from 0 upto (IDLARRAY-TOTALSIZE
SELECTOR)
when [LITATOM (SETQ LEVELLABEL (IDLARRAY-LEVELLABEL
IDLARRAY DIM (IDLARRAY-REF SELECTOR I]
do (IDLARRAY-SETLEVELLABEL RESULT RESULTDIM I LEVELLABEL]
(SETQ RESULTDIM (ADD1 RESULTDIM)))
RESULT])
(AT*
[LAMBDA ARGS (* jop: "24-Jun-86 23:21")
(* *)
(if (ILESSP ARGS 1)
then (ERROR "Must have at least one arg"))
(AT (ARG ARGS 1)
(ASVECTOR (for I from 2 to ARGS collect (ARG ARGS I])
(IDL-ABS
[LAMBDA (ARRAY RESULT) (* jop: "25-Jun-86 01:07")
(* *)
(MONADIC-APPLY (QUOTE ABS)
ARRAY RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE ARRAY])
(IDL-AND
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:15")
(* *)
(DYADIC-APPLY (QUOTE AND)
ARRAY1 ARRAY2 RESULT (QUOTE LOGICAL)
(QUOTE LOGICAL)
(QUOTE LOGICAL])
(IDL-ANTILOG
[LAMBDA (ARRAY RESULT) (* jop: "25-Jun-86 01:21")
(* *)
(MONADIC-APPLY (QUOTE ANTILOG)
ARRAY RESULT (QUOTE NUMERIC)
(QUOTE FLOAT])
(IDL-CHOOSE
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:23")
(* *)
(DYADIC-APPLY (QUOTE CHOOSE)
ARRAY1 ARRAY2 RESULT (QUOTE COUNT)
(QUOTE COUNT)
(QUOTE COUNT])
(IDL-COPY
[LAMBDA (ARRAY RESULT) (* jop: "25-Jun-86 09:43")
(* *)
(RESHAPE (SHAPE ARRAY)
ARRAY RESULT])
(IDL-COS
[LAMBDA (ARRAY RADIANSFLG RESULT) (* jop: "25-Jun-86 09:13")
(* *)
(DYADIC-APPLY (QUOTE COS)
ARRAY RADIANSFLG RESULT (QUOTE NUMERIC)
NIL
(QUOTE FLOAT])
(IDL-DIFFERENCE
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 00:33")
(* *)
(DYADIC-APPLY (QUOTE DIFFERENCE)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(IDL-EQP
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:08")
(* *)
(DYADIC-APPLY (QUOTE EQP)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(QUOTE LOGICAL])
(IDL-EQUAL
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:09")
(* *)
(DYADIC-APPLY (QUOTE EQUAL)
ARRAY1 ARRAY2 RESULT NIL NIL (QUOTE LOGICAL])
(IDL-EXPT
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:20")
(* *)
(DYADIC-APPLY (QUOTE EXPT)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(IDL-GEQ
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:11")
(* *)
(DYADIC-APPLY (QUOTE GEQ)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(QUOTE LOGICAL])
(IDL-GREATERP
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:10")
(* *)
(DYADIC-APPLY (QUOTE GREATERP)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(QUOTE LOGICAL])
(IDL-LEQ
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:11")
(* *)
(DYADIC-APPLY (QUOTE LEQ)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(QUOTE LOGICAL])
(IDL-LESSP
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:11")
(* *)
(DYADIC-APPLY (QUOTE LESSP)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(QUOTE LOGICAL])
(IDL-LOG
[LAMBDA (ARRAY RESULT) (* jop: "25-Jun-86 01:22")
(* *)
(MONADIC-APPLY (QUOTE LOG)
ARRAY RESULT (QUOTE NUMERIC)
(QUOTE FLOAT])
(IDL-MAX
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 00:37")
(* *)
(DYADIC-APPLY (QUOTE MAX)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(IDL-MIN
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 00:37")
(* *)
(DYADIC-APPLY (QUOTE MIN)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(IDL-MINUS
[LAMBDA (ARRAY RESULT) (* jop: "25-Jun-86 00:46")
(* *)
(MONADIC-APPLY (QUOTE MINUS)
ARRAY RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE ARRAY])
(IDL-NAND
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:16")
(* *)
(DYADIC-APPLY (QUOTE NAND)
ARRAY1 ARRAY2 RESULT (QUOTE LOGICAL)
(QUOTE LOGICAL)
(QUOTE LOGICAL])
(IDL-NOR
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:16")
(* *)
(DYADIC-APPLY (QUOTE NOR)
ARRAY1 ARRAY2 RESULT (QUOTE LOGICAL)
(QUOTE LOGICAL)
(QUOTE LOGICAL])
(IDL-NOT
[LAMBDA (ARRAY RESULT) (* jop: "25-Jun-86 01:17")
(* *)
(MONADIC-APPLY (QUOTE NOT)
ARRAY RESULT (QUOTE LOGICAL)
(QUOTE LOGICAL])
(IDL-NOT-EQP
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:12")
(* *)
(DYADIC-APPLY (QUOTE NOT-EQP)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(QUOTE LOGICAL])
(IDL-NOT-EQUAL
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:12")
(* *)
(DYADIC-APPLY (QUOTE NOT-EQUAL)
ARRAY1 ARRAY2 RESULT NIL NIL (QUOTE LOGICAL])
(IDL-OR
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:15")
(* *)
(DYADIC-APPLY (QUOTE OR)
ARRAY1 ARRAY2 RESULT (QUOTE LOGICAL)
(QUOTE LOGICAL)
(QUOTE LOGICAL])
(IDL-PLUS
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 00:31")
(* *)
(DYADIC-APPLY (QUOTE PLUS)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(IDL-QUOTIENT
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 00:35")
(* *)
(DYADIC-APPLY (QUOTE QUOTIENT)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(IDL-RAND
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 09:18")
(* *)
(DYADIC-APPLY (QUOTE RAND)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(IDL-SIN
[LAMBDA (ARRAY RADIANSFLG RESULT) (* jop: "25-Jun-86 09:13")
(* *)
(DYADIC-APPLY (QUOTE SIN)
ARRAY RADIANSFLG RESULT (QUOTE NUMERIC)
NIL
(QUOTE FLOAT])
(IDL-SQRT
[LAMBDA (ARRAY RESULT) (* jop: "25-Jun-86 01:22")
(* *)
(MONADIC-APPLY (QUOTE SQRT)
ARRAY RESULT (QUOTE NUMERIC)
(QUOTE FLOAT])
(IDL-TAN
[LAMBDA (ARRAY RADIANSFLG RESULT) (* jop: "25-Jun-86 09:13")
(* *)
(DYADIC-APPLY (QUOTE TAN)
ARRAY RADIANSFLG RESULT (QUOTE NUMERIC)
NIL
(QUOTE FLOAT])
(IDL-TIMES
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 00:34")
(* *)
(DYADIC-APPLY (QUOTE TIMES)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(IDL-XOR
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 01:16")
(* *)
(DYADIC-APPLY (QUOTE XOR)
ARRAY1 ARRAY2 RESULT (QUOTE LOGICAL)
(QUOTE LOGICAL)
(QUOTE LOGICAL])
(INDEX-OF
[LAMBDA (ARRAY VECTOR RESULT) (* jop: "24-Jun-86 22:38")
(* *)
(SETQ RESULT (TEST-RESULT RESULT (IDLARRAY-DIMS ARRAY)
(QUOTE COUNT)))
(EARRAY-INDEXOF (IDLARRAY-CMLARRAY ARRAY)
(IDLARRAY-CMLARRAY VECTOR)
(IDLARRAY-CMLARRAY RESULT))
(if (IDLARRAY-HAS-DIMLABELS-P ARRAY)
then (IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS ARRAY)))
(for I from 0 upto (IDLARRAY-RANK ARRAY) when (IDLARRAY-HAS-LEVELLABELS-P ARRAY I)
do (IDLARRAY-SETLEVELLABELS RESULT I (IDLARRAY-LEVELLABELS ARRAY I)))
RESULT])
(INNERPRODUCT
[LAMBDA (FN1 FN2 ARRAY1 ARRAY2 RESULT ARRAY1ELTTYPE ARRAY2ELTTYPE RESULTELTTYPE1 RESULTELTTYPE2)
(* jop: "25-Jun-86 00:18")
(* *)
(if (AND ARRAY1ELTTYPE (NOT (IDLARRAY-ELTTYPEP ARRAY1 ARRAY1ELTTYPE)))
then (HELP "Array1 not of type" ARRAY1ELTTYPE))
(if (AND ARRAY2ELTTYPE (NOT (IDLARRAY-ELTTYPEP ARRAY2 ARRAY2ELTTYPE)))
then (HELP "Array2 not of type" ARRAY2ELTTYPE))
[if (NULL RESULTELTTYPE2)
then (SETQ RESULTELTTYPE2 (IDLARRAY-COMMON-TYPE (IDLARRAY-ELTTYPE ARRAY1)
(IDLARRAY-ELTTYPE ARRAY2]
(if (NULL RESULTELTTYPE1)
then (SETQ RESULTELTTYPE1 RESULTELTTYPE2))
(LET* [(DIMS1 (IDLARRAY-DIMS ARRAY1))
(DIMS2 (IDLARRAY-DIMS ARRAY2))
(RESULTDIMS (APPEND (LDIFF DIMS1 (LAST DIMS1))
(CDR DIMS2]
(if [NOT (OR (NULL DIMS1)
(NULL DIMS2)
(EQ (CAR (LAST DIMS1))
(CAR DIMS2]
then (HELP "Arrays not conformable"))
(if RESULTDIMS
then (SETQ RESULT (TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE1))
(EARRAY-INNER-PRODUCT FN1 FN2 (IDLARRAY-CMLARRAY ARRAY1)
(IDLARRAY-CMLARRAY ARRAY2)
(IDLARRAY-CMLARRAY RESULT))
RESULT
else (EARRAY-INNER-PRODUCT FN1 FN2 (IDLARRAY-CMLARRAY ARRAY1)
(IDLARRAY-CMLARRAY ARRAY2])
(INV-T-DIST
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 09:53")
(* *)
(DYADIC-APPLY (QUOTE INV-T-CDF)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(QUOTE FLOAT])
(LAMINATE
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: "28-Jun-86 13:24")
(* *)
(LET [(RANK1 (IDLARRAY-RANK ARRAY1))
(RANK2 (IDLARRAY-RANK ARRAY2))
(RESULTELTTYPE (IDLARRAY-COMMON-TYPE (IDLARRAY-ELTTYPE ARRAY1)
(IDLARRAY-ELTTYPE ARRAY2]
(if (NULL AXIS)
then (SETQ AXIS -.5)
elseif [NOT (AND (FLOATP AXIS)
(LESSP AXIS (ADD1 (IMAX RANK1 RANK2]
then (HELP "Incorrect axis specifier" AXIS))
(if (AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
RESULTELTTYPE)))
then (ERROR "Result of incorrect type" RESULT))
(SETQ RESULT (IDLARRAY-CREATE (EARRAY-LAMINATE (IDLARRAY-CMLARRAY ARRAY1)
(IDLARRAY-CMLARRAY ARRAY2)
AXIS
(IDLARRAY-CMLARRAY RESULT))
RESULTELTTYPE NIL NIL RESULT))
RESULT])
(MAX-REDUCE
[LAMBDA (ARRAY AXIS RESULT) (* jop: "25-Jun-86 01:04")
(* *)
(REDUCE (QUOTE MAX)
ARRAY AXIS RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE ARRAY])
(MEAN
[LAMBDA (IDLARRAY AXIS RESULT) (* jop: "25-Jun-86 00:26")
(* *)
(REDUCE (QUOTE MEAN)
IDLARRAY AXIS RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE IDLARRAY])
(MEDIAN
[LAMBDA (IDLARRAY AXIS RESULT) (* jop: "25-Jun-86 00:26")
(* *)
(REDUCE (QUOTE MEDIAN)
IDLARRAY AXIS RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE IDLARRAY])
(MIN-REDUCE
[LAMBDA (ARRAY AXIS RESULT) (* jop: "25-Jun-86 01:04")
(* *)
(REDUCE (QUOTE MIN)
ARRAY AXIS RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE ARRAY])
(MONADIC-APPLY
[LAMBDA (FN IDLARRAY RESULT ARRAYELTTYPE RESULTELTTYPE) (* jop: "28-Jun-86 12:51")
(* *)
(if (AND ARRAYELTTYPE (NOT (IDLARRAY-ELTTYPEP IDLARRAY ARRAYELTTYPE)))
then (HELP "Array not of type" ARRAYELTTYPE))
(if (NULL RESULTELTTYPE)
then (SETQ RESULTELTTYPE (IDLARRAY-ELTTYPE IDLARRAY)))
(LET ((RESULTDIMS (IDLARRAY-DIMS IDLARRAY)))
(if RESULTDIMS
then (SETQ RESULT (TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE))
(EARRAY-MONADIC-APPLY FN (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-CMLARRAY RESULT))
(COPYLABELS IDLARRAY RESULT)
RESULT
else (EARRAY-MONADIC-APPLY FN IDLARRAY])
(NORMALS
[LAMBDA (N MU SIGMA) (* jop: "24-Jun-86 23:05")
(* *)
(if (NULL MU)
then (SETQ MU 0.0))
(if (NULL SIGMA)
then (SETQ SIGMA 1.0))
(IDLARRAY-CREATE (EARRAY-RAND-GAUSS (EARRAY-RESHAPE N MU)
SIGMA)
(QUOTE FLOAT])
(ORDER
[LAMBDA (VECTOR COMPAREFN RESULT) (* jop: "24-Jun-86 23:17")
(* *)
(if (NOT (EQ (IDLARRAY-RANK VECTOR)
1))
then (ERROR "Array not of rank 1" VECTOR))
(if (NULL COMPAREFN)
then (SETQ COMPAREFN (QUOTE LESSP)))
(SETQ RESULT (TEST-RESULT RESULT (IDLARRAY-DIMS VECTOR)
(QUOTE COUNT)))
(EARRAY-INDEX-SORT (IDLARRAY-CMLARRAY VECTOR)
COMPAREFN
(IDLARRAY-CMLARRAY RESULT))
(if (IDLARRAY-HAS-DIMLABELS-P VECTOR)
then (IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS VECTOR)))
(if (IDLARRAY-HAS-LEVELLABELS-P VECTOR 0)
then (IDLARRAY-SETLEVELLABELS RESULT 0 (IDLARRAY-LEVELLABELS VECTOR 0)))
RESULT])
(PLUS-REDUCE
[LAMBDA (ARRAY AXIS RESULT) (* jop: "25-Jun-86 01:03")
(* *)
(REDUCE (QUOTE PLUS)
ARRAY AXIS RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE ARRAY])
(PLUS-SCAN
[LAMBDA (ARRAY AXIS RESULT) (* jop: "25-Jun-86 01:06")
(* *)
(SCAN (QUOTE PLUS)
ARRAY AXIS RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE ARRAY])
(PLUS-SWEEP
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: "28-Jun-86 13:37")
(* *)
(SWEEP (QUOTE PLUS)
ARRAY1 ARRAY2 AXIS RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(QUOTIENT-SWEEP
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: "28-Jun-86 13:37")
(* *)
(SWEEP (QUOTE QUOTIENT)
ARRAY1 ARRAY2 AXIS RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(RAVEL
[LAMBDA (IDLARRAY RESULT) (* jop: "22-Jun-86 13:37")
(* *)
(if [AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
(IDLARRAY-ELTTYPE IDLARRAY]
then (ERROR "Result of incorrect type" RESULT))
(IDLARRAY-CREATE (EARRAY-RAVEL (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-CMLARRAY RESULT))
(IDLARRAY-ELTTYPE IDLARRAY)
NIL NIL RESULT])
(REDUCE
[LAMBDA (FN IDLARRAY AXIS RESULT ARRAYELTTYPE RESULTELTTYPE)
(* jop: "28-Jun-86 13:03")
(* *)
(if (NULL AXIS)
then (SETQ AXIS (SUB1 (IDLARRAY-RANK IDLARRAY)))
elseif [NOT (AND (FIXP AXIS)
(IGEQ AXIS 0)
(ILESSP AXIS (IDLARRAY-RANK IDLARRAY]
then (HELP "Incorrect AXIS specifier" AXIS))
(if (AND ARRAYELTTYPE (NOT (IDLARRAY-ELTTYPEP IDLARRAY ARRAYELTTYPE)))
then (HELP "Array not of type" ARRAYELTTYPE))
(if (NULL RESULTELTTYPE)
then (SETQ RESULTELTTYPE (IDLARRAY-ELTTYPE IDLARRAY)))
(LET ((RESULTDIMS (for DIM in (IDLARRAY-DIMS IDLARRAY) as I from 0
unless (EQ I AXIS) collect DIM)))
(if RESULTDIMS
then (SETQ RESULT (TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE))
(EARRAY-REDUCE FN (IDLARRAY-CMLARRAY IDLARRAY)
AXIS
(IDLARRAY-CMLARRAY RESULT))
[if (IDLARRAY-HAS-DIMLABELS-P IDLARRAY)
then (bind (J ← 0)
DIMLABEL for I from 0 upto (IDLARRAY-RANK IDLARRAY)
do (SETQ DIMLABEL (IDLARRAY-GETDIMLABEL IDLARRAY I))
(if (NEQ I AXIS)
then (if (LITATOM DIMLABEL)
then (IDLARRAY-SETDIMLABEL RESULT J
DIMLABEL))
(SETQ J (ADD1 J]
[bind (J ← 0)
LEVELLABEL for I from 0 upto (IDLARRAY-RANK IDLARRAY)
do (if (NEQ I AXIS)
then (if (IDLARRAY-HAS-LEVELLABELS-P IDLARRAY I)
then (IDLARRAY-SETLEVELLABELS RESULT J
(IDLARRAY-LEVELLABELS
IDLARRAY I)))
(SETQ J (ADD1 J]
RESULT
else (EARRAY-REDUCE FN (IDLARRAY-CMLARRAY IDLARRAY)
AXIS])
(REGRESS
[LAMBDA (YVECTOR XMATRIX RESULT) (* jop: "28-Jun-86 13:30")
(* *)
(if [AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
(QUOTE FLOAT]
then (ERROR "Result of incorrect type" RESULT))
(SETQ RESULT (IDLARRAY-CREATE (EARRAY-MATRIX-REGRESS (IDLARRAY-CMLARRAY YVECTOR)
(IDLARRAY-CMLARRAY XMATRIX)
(IDLARRAY-CMLARRAY RESULT))
(QUOTE FLOAT)
NIL NIL RESULT])
(RESHAPE
[LAMBDA (SHAPE IDLARRAY RESULT) (* jop: "22-Jun-86 13:24")
(* * SHAPE must be a vector of non-negative integers -- for convenience scalars are treated as vectors of length 1)
(if [AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
(IDLARRAY-ELTTYPE IDLARRAY]
then (ERROR "Result of incorrect type" RESULT))
(IDLARRAY-CREATE (EARRAY-RESHAPE (IDLARRAY-CMLARRAY SHAPE)
(IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-CMLARRAY RESULT))
(IDLARRAY-ELTTYPE IDLARRAY)
NIL NIL RESULT])
(RESIDUE
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 00:39")
(* *)
(DYADIC-APPLY (QUOTE REMAINDER)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(REVERSAL
[LAMBDA (IDLARRAY AXIS RESULT) (* jop: "24-Jun-86 22:42")
(* *)
[if (NULL AXIS)
then (SETQ AXIS (SUB1 (IDLARRAY-RANK IDLARRAY]
(if [AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
(IDLARRAY-ELTTYPE IDLARRAY]
then (ERROR "Result of incorrect type" RESULT))
(IDLARRAY-CREATE (EARRAY-REVERSE (IDLARRAY-CMLARRAY IDLARRAY)
AXIS
(IDLARRAY-CMLARRAY RESULT))
(IDLARRAY-ELTTYPE IDLARRAY)
NIL NIL RESULT])
(ROLL
[LAMBDA (IDLARRAY RESULT) (* jop: "24-Jun-86 22:48")
(* *)
(if (NOT (EQ (IDLARRAY-ELTTYPE IDLARRAY)
(QUOTE COUNT)))
then (ERROR "IDLARRAY must be of type COUNT"))
(if [AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
(QUOTE COUNT]
then (ERROR "Result of incorrect type" RESULT))
(IDLARRAY-CREATE (EARRAY-RAND 0 (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-CMLARRAY RESULT))
(IDLARRAY-ELTTYPE IDLARRAY)
NIL NIL RESULT])
(ROTATE
[LAMBDA (SCALAR IDLARRAY AXIS RESULT) (* jop: "24-Jun-86 22:09")
(* *)
(if (NOT (FIXP SCALAR))
then (HELP "Not an integer" SCALAR))
[if (NULL AXIS)
then (SETQ AXIS (SUB1 (IDLARRAY-RANK IDLARRAY]
(if [AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
(IDLARRAY-ELTTYPE IDLARRAY]
then (ERROR "Result of incorrect type" RESULT))
(IDLARRAY-CREATE (EARRAY-ROTATE SCALAR (IDLARRAY-CMLARRAY IDLARRAY)
AXIS
(IDLARRAY-CMLARRAY RESULT))
(IDLARRAY-ELTTYPE IDLARRAY)
NIL NIL RESULT])
(SAMPLE-VARIANCE
[LAMBDA (IDLARRAY AXIS RESULT) (* jop: "25-Jun-86 00:27")
(* *)
(REDUCE (QUOTE SAMPLE-VARIANCE)
IDLARRAY AXIS RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE IDLARRAY])
(SCAN
[LAMBDA (FN IDLARRAY AXIS RESULT ARRAYELTTYPE RESULTELTTYPE)
(* jop: "28-Jun-86 13:03")
(* *)
(if (NULL AXIS)
then (SETQ AXIS (SUB1 (IDLARRAY-RANK IDLARRAY)))
elseif [NOT (AND (FIXP AXIS)
(IGEQ AXIS 0)
(ILESSP AXIS (IDLARRAY-RANK IDLARRAY]
then (HELP "Incorrect AXIS specifier" AXIS))
(if (AND ARRAYELTTYPE (NOT (IDLARRAY-ELTTYPEP IDLARRAY ARRAYELTTYPE)))
then (HELP "Array not of type" ARRAYELTTYPE))
(if (NULL RESULTELTTYPE)
then (SETQ RESULTELTTYPE (IDLARRAY-ELTTYPE IDLARRAY)))
(LET ((RESULTDIMS (IDLARRAY-DIMS IDLARRAY)))
(SETQ RESULT (TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE))
(EARRAY-SCAN FN (IDLARRAY-CMLARRAY IDLARRAY)
AXIS
(IDLARRAY-CMLARRAY RESULT))
(COPYLABELS IDLARRAY RESULT)
RESULT])
(SHAPE
[LAMBDA (IDLARRAY RESULT) (* jop: "22-Jun-86 13:09")
(* *)
(LET ((RANK (IDLARRAY-RANK IDLARRAY)))
(SETQ RESULT (TEST-RESULT RESULT (LIST RANK)
(QUOTE COUNT)))
(EARRAY-SHAPE (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-CMLARRAY RESULT))
(if (IDLARRAY-HAS-DIMLABELS-P IDLARRAY)
then (bind LABEL for I from 0 upto RANK when (LITATOM (SETQ LABEL
(
IDLARRAY-GETDIMLABEL
IDLARRAY I)))
do (IDLARRAY-SETLEVELLABEL RESULT 0 I LABEL)))
RESULT])
(SWEEP
[LAMBDA (FN ARRAY1 ARRAY2 AXIS RESULT ARRAY1TYPE ARRAY2TYPE RESULTELTTYPE)
(* jop: "28-Jun-86 13:10")
(* *)
(if (NULL AXIS)
then (SETQ AXIS (SUB1 (IDLARRAY-RANK ARRAY1)))
elseif [NOT (AND (FIXP AXIS)
(IGEQ AXIS 0)
(ILESSP AXIS (IDLARRAY-RANK ARRAY1]
then (HELP "Incorrect AXIS specifier" AXIS))
(if (AND ARRAY1TYPE (NOT (IDLARRAY-ELTTYPEP ARRAY1 ARRAY1TYPE)))
then (HELP "Array1 not of type" ARRAY1TYPE))
(if (AND ARRAY2TYPE (NOT (IDLARRAY-ELTTYPEP ARRAY2 ARRAY2TYPE)))
then (HELP "Array2 not of type" ARRAY2TYPE))
(if (NULL RESULTELTTYPE)
then (SETQ RESULTELTTYPE (IDLARRAY-ELTTYPE ARRAY1)))
(if [NOT (OR (SCALARP ARRAY2)
(EQUAL (IDLARRAY-DIMS ARRAY2)
(for I from 0 as DIM in (IDLARRAY-DIMS ARRAY1)
unless (EQ I AXIS) collect DIM]
then (ERROR "Args not conformable"))
(LET ((RESULTDIMS (IDLARRAY-DIMS ARRAY1)))
(if RESULTDIMS
then (SETQ RESULT (TEST-RESULT RESULT RESULTDIMS RESULTELTTYPE))
(EARRAY-SWEEP FN (IDLARRAY-CMLARRAY ARRAY1)
(IDLARRAY-CMLARRAY ARRAY2)
AXIS
(IDLARRAY-CMLARRAY RESULT))
(COPYLABELS ARRAY1 RESULT)
RESULT
else (EARRAY-SWEEP FN (IDLARRAY-CMLARRAY ARRAY1)
(IDLARRAY-CMLARRAY ARRAY2)
AXIS])
(T-DIST
[LAMBDA (ARRAY1 ARRAY2 RESULT) (* jop: "25-Jun-86 09:17")
(* *)
(DYADIC-APPLY (QUOTE T-CDF)
ARRAY1 ARRAY2 RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(QUOTE FLOAT])
(TAKE
[LAMBDA (TAKEVECTOR IDLARRAY RESULT) (* jop: "23-Jun-86 23:49")
(* *)
(LET ((RANK (IDLARRAY-RANK IDLARRAY))
(RESULTELTTYPE (IDLARRAY-ELTTYPE IDLARRAY)))
(if [NOT (AND (IDLARRAY-ELTTYPEP TAKEVECTOR (QUOTE INTEGER))
(OR (SCALARP TAKEVECTOR)
(AND (EQ (IDLARRAY-RANK TAKEVECTOR)
1)
(EQ (IDLARRAY-TOTALSIZE TAKEVECTOR)
RANK]
then (HELP "Takevector vector of incorrect form" TAKEVECTOR))
(if (AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
RESULTELTTYPE)))
then (ERROR "Result of incorrect type" RESULT))
(SETQ RESULT (IDLARRAY-CREATE (EARRAY-TAKE (IDLARRAY-CMLARRAY TAKEVECTOR)
(IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-CMLARRAY RESULT))
RESULTELTTYPE NIL NIL RESULT))
(AND (IDLARRAY-HAS-DIMLABELS-P IDLARRAY)
(IDLARRAY-SETDIMLABELS RESULT (IDLARRAY-DIMLABELS IDLARRAY)))
[bind V for I from 0 upto RANK as DIM in (IDLARRAY-DIMS IDLARRAY)
when (IDLARRAY-HAS-LEVELLABELS-P IDLARRAY I)
do (SETQ V (IDLARRAY-REF TAKEVECTOR I))
(if (ILESSP V 0)
then (IDLARRAY-SETLEVELLABELS RESULT I (IDLARRAY-LEVELLABELS IDLARRAY I
(IPLUS
DIM V)))
else (IDLARRAY-SETLEVELLABELS RESULT I (IDLARRAY-LEVELLABELS
IDLARRAY I 0 (SUB1 (IMIN V DIM]
RESULT])
(TIMES-SWEEP
[LAMBDA (ARRAY1 ARRAY2 AXIS RESULT) (* jop: "28-Jun-86 13:37")
(* *)
(SWEEP (QUOTE DIFFERENCE)
ARRAY1 ARRAY2 AXIS RESULT (QUOTE NUMERIC)
(QUOTE NUMERIC)
(IDLARRAY-NUMERIC-RESULT ARRAY1 ARRAY2])
(TRANSPOSE
[LAMBDA (IDLARRAY PERMUTATION RESULT) (* jop: "24-Jun-86 22:24")
(* * Implements the so called Generic transpose)
(if (NULL PERMUTATION)
then (SETQ PERMUTATION (ASVECTOR (for I from (SUB1 (IDLARRAY-RANK IDLARRAY))
to 0 by -1 collect I)))
elseif [AND PERMUTATION (NOT (AND (IDLARRAY-ELTTYPEP PERMUTATION (QUOTE COUNT))
(EQ (IDLARRAY-RANK PERMUTATION)
1)
(EQ (IDLARRAY-TOTALSIZE PERMUTATION)
(IDLARRAY-RANK IDLARRAY]
then (HELP "PERMUTATION of incorrect form" PERMUTATION))
(LET ((RANK (IDLARRAY-RANK IDLARRAY))
(RESULTELTTYPE (IDLARRAY-ELTTYPE IDLARRAY)))
(if (AND RESULT (NOT (EQ (IDLARRAY-ELTTYPE RESULT)
RESULTELTTYPE)))
then (ERROR "Result of incorrect type" RESULT))
(SETQ RESULT (IDLARRAY-CREATE (EARRAY-TRANSPOSE (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-CMLARRAY PERMUTATION)
(IDLARRAY-CMLARRAY RESULT))
RESULTELTTYPE NIL NIL RESULT))
[if (IDLARRAY-HAS-DIMLABELS-P IDLARRAY)
then (for I from 0 upto RANK do (IDLARRAY-SETDIMLABEL RESULT
(IDLARRAY-REF
PERMUTATION I)
(IDLARRAY-GETDIMLABEL
IDLARRAY I]
(for I from 0 upto RANK when (IDLARRAY-HAS-LEVELLABELS-P IDLARRAY I)
do (IDLARRAY-SETLEVELLABELS RESULT (IDLARRAY-REF PERMUTATION I)
(IDLARRAY-LEVELLABELS IDLARRAY I)))
RESULT])
(VARIANCE
[LAMBDA (IDLARRAY AXIS RESULT) (* jop: "25-Jun-86 00:27")
(* *)
(REDUCE (QUOTE VARIANCE)
IDLARRAY AXIS RESULT (QUOTE NUMERIC)
(IDLARRAY-ELTTYPE IDLARRAY])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA AT* ASVECTOR* ASSIGN*)
)
(PUTPROPS IDLARRAYFNS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1538 51471 (CEILING 1548 . 1788) (COMPRESS 1790 . 3917) (DIFFERENCE-SWEEP 3919 . 4222)
(DROP 4224 . 5778) (DYADIC-APPLY 5780 . 7165) (ELEMENT-OF 7167 . 7576) (EXPAND 7578 . 9367) (FACTORIAL
9369 . 9609) (FLOOR 9611 . 9847) (GENVECTOR 9849 . 10278) (ADJOIN 10280 . 14689) (ASLIST 14691 .
15193) (ASSIGN 15195 . 16064) (ASSIGN* 16066 . 16419) (DEAL 16421 . 16919) (ASVECTOR 16921 . 17717) (
ASVECTOR* 17719 . 18620) (AT 18622 . 21585) (AT* 21587 . 21904) (IDL-ABS 21906 . 22151) (IDL-AND 22153
. 22422) (IDL-ANTILOG 22424 . 22666) (IDL-CHOOSE 22668 . 22933) (IDL-COPY 22935 . 23123) (IDL-COS
23125 . 23377) (IDL-DIFFERENCE 23379 . 23682) (IDL-EQP 23684 . 23953) (IDL-EQUAL 23955 . 24184) (
IDL-EXPT 24186 . 24477) (IDL-GEQ 24479 . 24748) (IDL-GREATERP 24750 . 25029) (IDL-LEQ 25031 . 25300) (
IDL-LESSP 25302 . 25575) (IDL-LOG 25577 . 25811) (IDL-MAX 25813 . 26102) (IDL-MIN 26104 . 26393) (
IDL-MINUS 26395 . 26648) (IDL-NAND 26650 . 26917) (IDL-NOR 26919 . 27188) (IDL-NOT 27190 . 27426) (
IDL-NOT-EQP 27428 . 27701) (IDL-NOT-EQUAL 27703 . 27936) (IDL-OR 27938 . 28205) (IDL-PLUS 28207 .
28498) (IDL-QUOTIENT 28500 . 28799) (IDL-RAND 28801 . 29092) (IDL-SIN 29094 . 29346) (IDL-SQRT 29348
. 29584) (IDL-TAN 29586 . 29838) (IDL-TIMES 29840 . 30133) (IDL-XOR 30135 . 30400) (INDEX-OF 30402 .
31101) (INNERPRODUCT 31103 . 32659) (INV-T-DIST 32661 . 32933) (LAMINATE 32935 . 33915) (MAX-REDUCE
33917 . 34163) (MEAN 34165 . 34410) (MEDIAN 34412 . 34661) (MIN-REDUCE 34663 . 34909) (MONADIC-APPLY
34911 . 35673) (NORMALS 35675 . 36036) (ORDER 36038 . 36860) (PLUS-REDUCE 36862 . 37110) (PLUS-SCAN
37112 . 37352) (PLUS-SWEEP 37354 . 37645) (QUOTIENT-SWEEP 37647 . 37946) (RAVEL 37948 . 38432) (REDUCE
38434 . 40418) (REGRESS 40420 . 40954) (RESHAPE 40956 . 41587) (RESIDUE 41589 . 41884) (REVERSAL
41886 . 42473) (ROLL 42475 . 43090) (ROTATE 43092 . 43767) (SAMPLE-VARIANCE 43769 . 44036) (SCAN 44038
. 45046) (SHAPE 45048 . 45739) (SWEEP 45741 . 47337) (T-DIST 47339 . 47603) (TAKE 47605 . 49204) (
TIMES-SWEEP 49206 . 49504) (TRANSPOSE 49506 . 51214) (VARIANCE 51216 . 51469)))))
STOP