(FILECREATED "17-Feb-87 12:55:42" {QV}<PEDERSEN>LISP>KOTO>EARRAY-UTIL.;2 10459
changes to: (VARS EARRAY-UTILCOMS)
(FNS ARRAYREAD ARRAYPRINT)
previous date: "16-Jun-86 18:40:16" {QV}<PEDERSEN>LISP>KOTO>EARRAY-UTIL.;1)
(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT EARRAY-UTILCOMS)
(RPAQQ EARRAY-UTILCOMS ((MACROS LISTREF LISTSET LOGICAL-VALUE)
(FNS EARRAY-MAKEHASH PERMUTELIST LISTSET RAND-GAUSS RAND-PERMUTATION LISTREF SCALAR-AND
SCALAR-CEILING SCALAR-CHOOSE SCALAR-EQP SCALAR-EQUAL SCALAR-FACTORIAL SCALAR-FLOOR
SCALAR-NAND SCALAR-NOR SCALAR-NOT SCALAR-NOT-EQP SCALAR-OR SCALAR-RECIPROCAL
SCALAR-ROUND SCALAR-TYPE-OF SCALAR-XOR)
(FNS ARRAYPRINT ARRAYREAD)
(ADDVARS (HPRINTMACROS (ARRAY . ARRAYPRINT)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))))
(DECLARE: EVAL@COMPILE
[PUTPROPS LISTREF MACRO (OPENLAMBDA (LST INDEX)
(CAR (FNTH LST (ADD1 INDEX]
(PUTPROPS LISTSET MACRO (OPENLAMBDA (NEWVALUE LST INDEX)
(RPLACA (FNTH LST (ADD1 INDEX))
NEWVALUE)))
(DEFMACRO LOGICAL-VALUE (T-OR-NIL)
(BQUOTE (if , T-OR-NIL then 1 else 0)))
)
(DEFINEQ
(EARRAY-MAKEHASH
[LAMBDA (SIZE PLIST) (* jop: "13-Jun-86 12:03")
(* *)
(LET ((HARRAY (HASHARRAY SIZE)))
(for PROP on PLIST by (CDDR PROP) as VALUE on (CDR PLIST) by (CDDR VALUE)
do (PUTHASH (CAR PROP)
(CAR VALUE)
HARRAY))
HARRAY])
(PERMUTELIST
[LAMBDA (LST PERMUTATION) (* jop: "17-Mar-86 22:27")
(* * Returns the PERMUTATION of LST)
(if (NOT (EQLENGTH LST (LENGTH PERMUTATION)))
then (HELP "LST and PERMUTATION not of same length"))
(bind (RESULT ← (for I from 1 to (LENGTH LST) collect NIL)) for INDEX in
PERMUTATION
as LSTELT in LST do (LISTSET LSTELT RESULT INDEX) finally (RETURN RESULT])
(LISTSET
[LAMBDA (NEWVALUE LST INDEX) (* jop: " 5-Jun-86 12:41")
(* *)
(RPLACA (FNTH LST (ADD1 INDEX))
NEWVALUE])
(RAND-GAUSS
[LAMBDA (MU SIGMA) (* jop: " 5-Jun-86 12:56")
(* * Gaussian variates ala BOX-MUELLER)
(LET ((FMU (FLOAT (OR MU 0.0)))
(FSIGMA (FLOAT (OR SIGMA 1.0)))
RESULT)
(DECLARE (TYPE FLOATP FMU FSIGMA RESULT))
(if (UFLEQ FSIGMA 0.0)
then (ERROR "SIGMA must be positive" SIGMA))
(SETQ RESULT (FPLUS FMU (FTIMES FSIGMA
(LET [(STORE (QUOTE (NIL]
(if (CAR STORE)
then (PROG1 (CAR STORE)
(RPLACA STORE NIL))
else (LET ((TWOPI (CONSTANT (FTIMES
2.0
\IEEE.SHORT.PI)))
(R1 (RAND 0.0 1.0))
(R2 (RAND 0.0 1.0))
A B)
[SETQ A
(SQRT (FTIMES -2.0
(LOG R1]
(SETQ B (FTIMES TWOPI R2))
(RPLACA STORE
(FTIMES A
(COS B T)))
(FTIMES A (SIN B T])
(RAND-PERMUTATION
[LAMBDA (LST) (* jop: " 5-Jun-86 13:09")
(* * Generate a random permutation of LST)
(bind (NEWLST ← (COPY LST))
I TEMP for J from (SUB1 (LENGTH LST)) to 0 by -1
do [SETQ I (IDL-FLOOR (FTIMES J (RAND 0.0 1.0]
(SETQ TEMP (LISTREF NEWLST I))
(LISTSET (LISTREF NEWLST J)
NEWLST I)
(LISTSET TEMP NEWLST J)
finally (RETURN NEWLST])
(LISTREF
[LAMBDA (LST INDEX) (* jop: " 8-May-86 13:50")
(* *)
(CAR (FNTH LST (ADD1 INDEX])
(SCALAR-AND
[LAMBDA (X Y) (* jop: " 8-Jun-86 17:36")
(* *)
(if (AND (EQ X 1)
(EQ Y 1))
then 1
else 0])
(SCALAR-CEILING
[LAMBDA (X) (* jop: " 5-Jun-86 12:35")
(* *)
(LET ((FX (FLOAT X))
FIXX)
(DECLARE (TYPE FLOATP FX))
(SETQ FIXX (UFIX FX))
(if (UFLESSP (FLOAT FIXX)
FX)
then (ADD1 FIXX)
else FIXX])
(SCALAR-CHOOSE
[LAMBDA (N R) (* jop: " 5-Jun-86 12:29")
(* *)
(if (NOT (AND (IGEQ N 0)
(IGEQ R 0)
(ILEQ R N)))
then (HELP "Invalid args"))
(if (IGREATERP R (RSH N 1))
then (SETQ R (IDIFFERENCE N R)))
(if (EQ N 0)
then 1
elseif (EQ R 0)
then 1
elseif (EQ R 1)
then N
elseif (ILESSP N 8)
then (IQUOTIENT (for I from (ADD1 (IDIFFERENCE N R)) to N product I)
(for I from 1 to R product I))
else (IPLUS (SCALAR-CHOOSE (SUB1 N)
R)
(SCALAR-CHOOSE (SUB1 N)
(SUB1 R])
(SCALAR-EQP
[LAMBDA (X Y) (* jop: "15-Jun-86 15:04")
(* *)
(LOGICAL-VALUE (EQP X Y])
(SCALAR-EQUAL
[LAMBDA (X Y) (* jop: "14-May-86 17:26")
(* *)
(if (EQUALP X Y)
then 1
else 0])
(SCALAR-FACTORIAL
[LAMBDA (N) (* jop: " 5-Jun-86 12:40")
(* *)
(for I from 1 to N product I])
(SCALAR-FLOOR
[LAMBDA (X) (* jop: " 5-Jun-86 12:38")
(* *)
(LET ((FX (FLOAT X))
FIXX)
(DECLARE (TYPE FLOATP FX))
(SETQ FIXX (UFIX FX))
(if (UFGREATERP (FLOAT FIXX)
FX)
then (SUB1 FIXX)
else FIXX])
(SCALAR-NAND
[LAMBDA (X Y) (* jop: " 9-Jun-86 16:57")
(* *)
(if (AND (EQ X 1)
(EQ Y 1))
then 0
else 1])
(SCALAR-NOR
[LAMBDA (X Y) (* jop: " 9-Jun-86 16:56")
(* *)
(if (OR (EQ X 1)
(EQ Y 1))
then 0
else 1])
(SCALAR-NOT
[LAMBDA (LOGICAL-VALUE) (* jop: " 5-Jun-86 12:40")
(* *)
(if (EQ LOGICAL-VALUE 0)
then 1
else 0])
(SCALAR-NOT-EQP
[LAMBDA (X Y) (* jop: "15-Jun-86 15:08")
(* *)
(LOGICAL-VALUE (NOT (EQP X Y])
(SCALAR-OR
[LAMBDA (X Y) (* jop: " 5-Jun-86 12:40")
(* *)
(if (OR (EQ X 1)
(EQ Y 1))
then 1
else 0])
(SCALAR-RECIPROCAL
[LAMBDA (X) (* jop: " 9-Jun-86 21:38")
(* *)
(LET ((FX (FLOAT X))
RESULT)
(DECLARE (TYPE FLOATP FX RESULT))
(SETQ RESULT (FQUOTIENT 1.0 FX])
(SCALAR-ROUND
[LAMBDA (X) (* jop: " 9-Jun-86 21:10")
(* *)
(LET ((FX (FPLUS .5 (FLOAT X)))
FIXX)
(DECLARE (TYPE FLOATP FX))
(SETQ FIXX (UFIX FX))
(if (UFGREATERP (FLOAT FIXX)
FX)
then (SUB1 FIXX)
else FIXX])
(SCALAR-TYPE-OF
[LAMBDA (DATUM) (* jop: "15-Jun-86 17:30")
(* * As in CML TYPE-OF)
(if (NUMBERP DATUM)
then (if (FLOATP DATUM)
then (QUOTE SINGLE-FLOAT)
else (QUOTE FIXNUM))
else T])
(SCALAR-XOR
[LAMBDA (X Y) (* jop: " 9-Jun-86 16:58")
(* *)
(if (EQ X 1)
then (if (EQ Y 1)
then 0
else 1)
else (if (EQ Y 1)
then 1
else 0])
)
(DEFINEQ
(ARRAYPRINT
[LAMBDA (ARRAY STREAM) (* edited: "17-Feb-87 11:57")
(LET* [(SIZE (ARRAY-TOTAL-SIZE ARRAY))
(TYPE (ARRAY-ELEMENT-TYPE ARRAY))
(ELEMENTS (bind (L-ARRAY ←(MAKE-ARRAY SIZE (QUOTE :ELEMENT-TYPE)
TYPE
(QUOTE :DISPLACED-TO)
ARRAY))
for I from 0 to (SUB1 SIZE) collect (AREF L-ARRAY I]
(PRINTOUT STREAM "(ARRAYREAD)(")
(PRINTOUT STREAM "DIMS" , (ARRAY-DIMENSIONS ARRAY)
, "ELEMENTTYPE" , (ARRAY-ELEMENT-TYPE ARRAY)
, "ELEMENTS" , ELEMENTS)
(PRINTOUT STREAM ")")
T])
(ARRAYREAD
[LAMBDA (STREAM) (* edited: "17-Feb-87 12:06")
(LET* ((PROPLST (HREAD STREAM))
(DIMS (LISTGET PROPLST (QUOTE DIMS)))
(ELEMENTTYPE (LISTGET PROPLST (QUOTE ELEMENTTYPE)))
(ELEMENTS (LISTGET PROPLST (QUOTE ELEMENTS)))
(SIZE (bind (TOTAL ← 1) for DIM in DIMS do (SETQ TOTAL (TIMES TOTAL DIM))
finally (RETURN TOTAL)))
(ARRAY (MAKE-ARRAY DIMS (QUOTE :ELEMENT-TYPE)
ELEMENTTYPE)))
(bind (L-ARRAY ←(MAKE-ARRAY SIZE (QUOTE :ELEMENT-TYPE)
ELEMENTTYPE
(QUOTE :DISPLACED-TO)
ARRAY))
for I from 0 to (SUB1 SIZE) as ELEMENT in ELEMENTS
collect (ASET ELEMENT L-ARRAY I))
ARRAY])
)
(ADDTOVAR HPRINTMACROS (ARRAY . ARRAYPRINT))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS EARRAY-UTIL COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1180 8701 (EARRAY-MAKEHASH 1190 . 1582) (PERMUTELIST 1584 . 2119) (LISTSET 2121 . 2314)
(RAND-GAUSS 2316 . 3426) (RAND-PERMUTATION 3428 . 3970) (LISTREF 3972 . 4144) (SCALAR-AND 4146 . 4358
) (SCALAR-CEILING 4360 . 4718) (SCALAR-CHOOSE 4720 . 5511) (SCALAR-EQP 5513 . 5677) (SCALAR-EQUAL 5679
. 5871) (SCALAR-FACTORIAL 5873 . 6060) (SCALAR-FLOOR 6062 . 6424) (SCALAR-NAND 6426 . 6639) (
SCALAR-NOR 6641 . 6851) (SCALAR-NOT 6853 . 7051) (SCALAR-NOT-EQP 7053 . 7230) (SCALAR-OR 7232 . 7441)
(SCALAR-RECIPROCAL 7443 . 7717) (SCALAR-ROUND 7719 . 8096) (SCALAR-TYPE-OF 8098 . 8409) (SCALAR-XOR
8411 . 8699)) (8702 10218 (ARRAYPRINT 8712 . 9382) (ARRAYREAD 9384 . 10216)))))
STOP