(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