(FILECREATED " 4-Sep-85 13:11:54" {QV}<IDL>SOURCES>ARITHMETIC.;9
 6142   

      changes to:  (VARS ARITHMETICCOMS)

      previous date: " 3-Sep-85 17:28:31" {QV}<IDL>SOURCES>ARITHMETIC.;8)


(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT ARITHMETICCOMS)

(RPAQQ ARITHMETICCOMS
 [(* New IDL functions that operate on and produce arithmetic values.)
		       (FNS PLUSP ROUND SAME SCALARP TRANSLATE)
		       (PROP ARGNAMES TRANSLATE)
		       (VARS (E 2.718282)
			     (PI 3.141594))
		       (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
				 (ADDVARS (NLAMA)
					  (NLAML)
					  (LAMA TRANSLATE])



(* New IDL functions that operate on and produce arithmetic values.)


(DEFINEQ

(PLUSP

  [ULAMBDA ((X SCALAR))
                                                             (* rmk: " 6-AUG-78 11:42" posted: " 6-AUG-78 11:43")

                                                             (* T if X is positive.)

    (
AND
 X (GREATERP.LISP X 0))])

(ROUND

  [ULAMBDA ((VAL (EXPECTS SCALAR))
            (INTERVAL (EXPECTS SCALAR))
            (RETURNS SCALAR))
                                                             (* bas: " 9-FEB-83 15:13")

    (
OR
 INTERVAL INTERVAL←1)
    [
AND
 VAL (
TIMES
 INTERVAL (IVALUE (
FIX
 (
FPLUS
 (
FQUOTIENT
 VAL INTERVAL)
						 (if
 (
MINUSP
 VAL)
						     then
 -.5
						   else
 .5]])

(SAME

  [ULAMBDA ((A (EXPECTS SCALAR))
            (B (EXPECTS SCALAR))
            (RETURNS INTEGER))
                                                             (* bas: "21-DEC-78 10:52" posted: "21-DEC-78 10:51")

    (if
 (
EQP
 A B)
	then
 1
      else
 0)])

(SCALARP

  [ULAMBDA (S)
                                                             (* rmk: "19-JUL-78 10:58" posted: "19-JUL-78 11:01")

                                                             (* Predicate for scalar-hood)

    (
AND
 (
OR
 (type?
 SCALAR S)
	     (
VSCALARP
 S))
	 T)])

(TRANSLATE

  [LAMBDA TRANSLATENARGS                                     (* DECLARATIONS: (RECORD ARGRECORD 

							     (S TABLE DEFAULT)))

                                                             (* bas: "11-FEB-83 11:49")


          (* Translates S through TABLE returning translation or DEFAULT if specified otherwise S. A no spread so we can test 

	  for supplied NIL for DEFAULT. TABLE is either m*1, in which case the translation is I such that S=TABLE@{I};

	  m*2, in which case the translation is TABLE@{I,2} where I is the first index such that S=TABLE@{I,1};

	  or m*3, in which case any number between TABLE@{I,1} and TABLE@{I,2} is translated to TABLE@{I,3}.

	  In the 3-column case, NIL only matches NIL-NIL, NIL is -infinity in NIL-X, +infinity in X-NIL.)



    (DECLARE
 (
SPECVARS
 TRANSLATENARGS))
    (UENTRY (
QUOTE
 TRANSLATE)
	    (
OR
 (
IGREATERP
 TRANSLATENARGS 1)
		(UERROR "Missing translation table"))
	    (
EAPPLY*
 [
FUNCTION
 [ULAMBDA ((S SCALAR           (* Value to be translated)
)
                                         (TABLE (ONEOF VECTOR MATRIX) 
                                                             (* Translation table)
)
                                         (DEFAULT SCALAR     (* Value if no match found)
)
                                         (RETURNS SCALAR))
                                 (DECL (TRANSLATENARGS (BOUNDIN TRANSLATE)))
				 (bind
 TELT (I ← 0)
				       (TTYPE ←(if
 (
EQ
 (fetch
 NDIMS of
 TABLE)
						       1)
						   then
 1
						 else
 (
GETRELT
 (fetch
 SHAPE of
 TABLE)
							       2)))
				       [GSB ←(
SETUP
 TABLE (
QUOTE
 ROWMAJOR)
						    (
CONSTANT
 (create
 GENSTATEBLOCK]
				    declare
 (TELT SCALAR)
					    (I INTEGER)
					    (TTYPE INTEGER)
					    (GSB GENSTATEBLOCK)
				    until
 (fetch
 DONE of
 GSB)
				    do

				     (
SETQ
 TELT (
GETAELT
 TABLE (
NEXT
 GSB)))
				     (
SELECTQ

				       TTYPE
				       (1 (add
 I 1)
					  (
AND
 (
UEQP
 S TELT)
					       (
RETURN
 I)))
				       (2 (if
 (
UEQP
 S TELT)
					      then
 (
RETURN
 (
COPYAELT
 TABLE (
NEXT
 GSB)))
					    else
 (
SKIP
 GSB 1)))
				       [3 (if
 S
					      then
 [if
 TELT
						       then
 [if
 (
GREATERP
 TELT S)
								then
 (
SKIP
 GSB 2)
							      elseif
 (
AND
 (
SETQ
 TELT
									    (
GETAELT
 TABLE
										     (
NEXT
 GSB)))
									  (
GREATERP
 S TELT))
								then
 (
SKIP
 GSB 1)
							      else
 (
RETURN
 (
COPYAELT
 TABLE
										     (
NEXT
 GSB]
						     elseif
 (
OR
 [
NULL
 (
SETQ
 TELT (
GETAELT

									  TABLE
									  (
NEXT
 GSB]
								(
GREATERP
 S TELT))
						       then
 (
SKIP
 GSB 1)
						     else
 (
RETURN
 (
COPYAELT
 TABLE (
NEXT
 GSB]
					    elseif
 TELT
					      then
 (
SKIP
 GSB 2)
					    elseif
 (
GETAELT
 TABLE (
NEXT
 GSB))
					      then
 (
SKIP
 GSB 1)
					    else
 (
RETURN
 (
COPYAELT
 TABLE (
NEXT
 GSB]
				       (UERROR "Invalid size translation table"))
				    finally
 (
RETURN
 (
OR
 DEFAULT (
AND
 (
ILESSP
 TRANSLATENARGS 3)
								     S)))
                                                             (* Default is DEFAULT if there is one, else S)

                                                             (* If no translation found)

					    )]]
		     (
QUOTE
 (SCALAR MATRIX SCALAR))
		     (
ARG
 TRANSLATENARGS 1)
		     (
ARG
 TRANSLATENARGS 2)
		     (
AND
 (
IGREATERP
 TRANSLATENARGS 2)
			  (
ARG
 TRANSLATENARGS 3])
)

(PUTPROPS TRANSLATE ARGNAMES
 (NIL (S TABLE DEFAULT) . TRANSLATENARGS))

(RPAQQ E
 2.718282)

(RPAQQ PI
 3.141594)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 TRANSLATE)
)
(PUTPROPS ARITHMETIC COPYRIGHT ("Xerox Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (751 5785 (PLUSP 761 . 1040) (ROUND 1042 . 1456) (SAME 1458 . 1740) (SCALARP 1742 . 2055
) (TRANSLATE 2057 . 5783)))))
STOP