(FILECREATED " 6-Jun-86 11:50:46" {QV}<PEDERSEN>LISP>IDLARRAYUTIL.;1
 6248   

      changes to:  (VARS IDLARRAYUTILCOMS)
		   (FNS IDL-AND IDL-CEILING IDL-CHOOSE IDL-EQUAL IDL-FACTORIAL IDL-FLOOR IDL-NOT 
			IDL-OR LISTREF LISTSET PERMUTELIST TEST-RESULT RAND-NORMAL RAND-PERMUTATION)
)


(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT IDLARRAYUTILCOMS)

(RPAQQ IDLARRAYUTILCOMS
 ((* File created by Coms Manager.)
	(FNS IDL-AND IDL-CEILING IDL-CHOOSE IDL-EQUAL IDL-FACTORIAL IDL-FLOOR IDL-NOT IDL-OR LISTREF 
	     PERMUTELIST LISTSET RAND-NORMAL RAND-PERMUTATION TEST-RESULT)))



(* File created by Coms Manager.)


(DEFINEQ

(IDL-AND

  [LAMBDA (X Y)                                              (* jop: " 5-Jun-86 12:39")

    (if
 (
AND
 (
EQ
 X 1)
		 (
EQ
 Y 1))
	then
 1
      else
 0])

(IDL-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])

(IDL-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
 (IDL-CHOOSE
 (
SUB1
 N)
				    R)
		      (IDL-CHOOSE
 (
SUB1
 N)
				    (
SUB1
 R])

(IDL-EQUAL

  [LAMBDA (X Y)                                              (* jop: "14-May-86 17:26")


          (* *)



    (if
 (
EQUALP
 X Y)
	then
 1
      else
 0])

(IDL-FACTORIAL

  [LAMBDA (N)                                                (* jop: " 5-Jun-86 12:40")


          (* *)



    (for
 I from
 1 to
 N product
 I])

(IDL-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])

(IDL-NOT

  [LAMBDA (LOGICAL-VALUE)                                    (* jop: " 5-Jun-86 12:40")


          (* *)



    (if
 (
EQ
 LOGICAL-VALUE 0)
	then
 1
      else
 0])

(IDL-OR

  [LAMBDA (X Y)                                              (* jop: " 5-Jun-86 12:40")


          (* *)



    (if
 (
OR
 (
EQ
 X 1)
		(
EQ
 Y 1))
	then
 1
      else
 0])

(LISTREF

  [LAMBDA (LST INDEX)                                        (* jop: " 8-May-86 13:50")


          (* *)



    (
CAR
 (
FNTH
 LST (
ADD1
 INDEX])

(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-NORMAL

  [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])

(TEST-RESULT

  [LAMBDA (RESULTARRAY RESULTDIMS RESULTELTTYPE)             (* jop: "11-May-86 13:39")


          (* *)



    (if
 (
NULL
 RESULTARRAY)
	then
 (
MAKE-IDLARRAY
 RESULTDIMS (
QUOTE
 :ELTTYPE)
				RESULTELTTYPE)
      elseif
 (
NOT
 (
AND
 (
IDLARRAY-ELTTYPEP
 RESULTARRAY RESULTELTTYPE)
			     (
EQUAL
 (
IDLARRAY-DIMS
 RESULTARRAY)
				      RESULTDIMS)))
	then
 (
HELP
 "Invalid RESULT" RESULTARRAY])
)
(PUTPROPS IDLARRAYUTIL COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (667 6165 (IDL-AND 677 . 863) (IDL-CEILING 865 . 1220) (IDL-CHOOSE 1222 . 1998) (
IDL-EQUAL 2000 . 2189) (IDL-FACTORIAL 2191 . 2375) (IDL-FLOOR 2377 . 2736) (IDL-NOT 2738 . 2933) (
IDL-OR 2935 . 3141) (LISTREF 3143 . 3315) (PERMUTELIST 3317 . 3852) (LISTSET 3854 . 4047) (RAND-NORMAL
 4049 . 5160) (RAND-PERMUTATION 5162 . 5704) (TEST-RESULT 5706 . 6163)))))
STOP