(FILECREATED " 6-Aug-84 02:33:21" {FLOPPY}NEWBOXFTIMES.;1 12198
changes to: (FNS NEW\BOXFPLUSDIF NEW\BOXFTIMES2)
previous date: " 5-Aug-84 02:55:43" {ERIS}<SPEECH>WORK>NEWBOXFTIMES.;13)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT NEWBOXFTIMESCOMS)
(RPAQQ NEWBOXFTIMESCOMS [[DECLARE: EVAL@LOAD DOCOPY FIRST (P (MOVD? '\BOXFTIMES2 'OLD\BOXFTIMES2)
(MOVD? '\BOXFQUOTIENT 'OLD\BOXFQUOTIENT)
(MOVD? '\FDIFFERENCE.UFN (QUOTE
OLD\FDIFFERENCE.UFN))
(MOVD? '\BOXFPLUSDIF 'OLD\BOXFPLUSDIF)
(MOVD? 'SIN 'OLDSIN)
(MOVD? 'COS 'OLDCOS]
(FNS COERCETOFLOATARRAY NEW\BOXFPLUSDIF NEW\BOXFQUOTIENT NEW\BOXFTIMES2
NEW\FDIFFERENCE.UFN GENVEC NEWCOS NEWSIN NUMARRAYTYP)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD 'NEW\BOXFTIMES2 '\BOXFTIMES2)
(MOVD 'NEW\BOXFQUOTIENT '\BOXFQUOTIENT)
(MOVD 'NEW\FDIFFERENCE.UFN (QUOTE
\FDIFFERENCE.UFN))
(MOVD 'NEW\BOXFPLUSDIF '\BOXFPLUSDIF)
(MOVD 'NEWSIN 'SIN)
(MOVD 'NEWCOS 'COS])
(DECLARE: EVAL@LOAD DOCOPY FIRST
(MOVD? '\BOXFTIMES2 'OLD\BOXFTIMES2)
(MOVD? '\BOXFQUOTIENT 'OLD\BOXFQUOTIENT)
(MOVD? '\FDIFFERENCE.UFN 'OLD\FDIFFERENCE.UFN)
(MOVD? '\BOXFPLUSDIF 'OLD\BOXFPLUSDIF)
(MOVD? 'SIN 'OLDSIN)
(MOVD? 'COS 'OLDCOS)
)
(DEFINEQ
(COERCETOFLOATARRAY
[LAMBDA (A) (* rmk: " 2-Aug-84 22:06")
(* Assumes A is an array, not of floatps. If it is some form of integer array, the result will be a float array
with coerced values. Otherwise NIL.)
(SELECTQ (ARRAYTYP A)
((BYTE SMALLPOSP FIXP BIT)
(for I (RESULT ←(ARRAY (ARRAYSIZE A)
(QUOTE FLOATP)
NIL
(ARRAYORIG A)))
from (ARRAYORIG A) to (IPLUS (ARRAYSIZE A)
(SUB1 (ARRAYORIG A)))
do (SETA RESULT I (FLOAT (ELT A I))) finally (RETURN RESULT)))
NIL])
(NEW\BOXFPLUSDIF
[LAMBDA (X Y SUBTRACT) (* edited: " 6-Aug-84 02:11")
(PROG (RESULT SIZE COERCEDX COERCEDY XFLOAT)
(RETURN (COND
([AND (ARRAYP X)
(OR (EQ 'FLOATP (ARRAYTYP X))
(SETQ COERCEDX (COERCETOFLOATARRAY X]
(COND
([AND (ARRAYP Y)
(OR (EQ 'FLOATP (ARRAYTYP Y))
(SETQ COERCEDY (COERCETOFLOATARRAY Y]
(* Both floating point arrays)
(OR (AND (EQ (SETQ SIZE (ARRAYSIZE X))
(ARRAYSIZE Y))
(EQ (ARRAYORIG X)
(ARRAYORIG Y)))
(ERROR "NONCONFORMABLE ARRAYS" (LIST X Y)))
[SETQ RESULT (OR COERCEDX COERCEDY (ARRAY SIZE 'FLOATP NIL (ARRAYORIG
X]
(OR COERCEDX (SETQ COERCEDX X))
(OR COERCEDY (SETQ COERCEDY Y))
(\BLKFPLUS (ARRAYBASE COERCEDX)
(ARRAYBASE COERCEDY)
(ARRAYBASE COERCEDY)
SIZE)
RESULT)
(T (SETQ SIZE (ARRAYSIZE X))
[SETQ RESULT (OR COERCEDX (ARRAY SIZE 'FLOATP NIL (ARRAYORIG X]
(for I (YFLOAT ←(FLOAT Y)) from (ARRAYORIG X)
to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FPLUS (ELT (OR COERCEDX X)
I)
YFLOAT)))
RESULT)))
((AND (ARRAYP Y)
(NUMARRAYTYP Y))
(SETQ XFLOAT (FLOAT X))
(SETQ RESULT (ARRAY (ARRAYSIZE Y)
'FLOATP NIL (ARRAYORIG Y)))
[for I from 1 to (ARRAYSIZE Y) do (SETA RESULT I (FPLUS XFLOAT
(ELT Y I]
RESULT)
(T (OLD\BOXFPLUSDIF X Y])
(NEW\BOXFQUOTIENT
[LAMBDA (X Y BOX) (* rmk: " 3-Aug-84 17:39")
(PROG (RESULT SIZE COERCEDX COERCEDY)
(RETURN (COND
([AND (ARRAYP X)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP X))
(SETQ COERCEDX (COERCETOFLOATARRAY X]
(COND
([AND (ARRAYP Y)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP Y))
(SETQ COERCEDY (COERCETOFLOATARRAY Y]
(* Both floating point arrays)
(OR (AND (EQ (SETQ SIZE (ARRAYSIZE X))
(ARRAYSIZE Y))
(EQ (ARRAYORIG X)
(ARRAYORIG Y)))
(ERROR "NONCONFORMABLE ARRAYS" (LIST X Y)))
[SETQ RESULT (OR COERCEDX COERCEDY (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(OR COERCEDX (SETQ COERCEDX X))
(OR COERCEDY (SETQ COERCEDY Y))
[for I from (ARRAYORIG X) to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FQUOTIENT (ELT COERCEDX I)
(ELT COERCEDY I]
RESULT)
(T (SETQ SIZE (ARRAYSIZE X))
[SETQ RESULT (OR COERCEDX (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(for I (YFLOAT ←(FLOAT Y)) from (ARRAYORIG X)
to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FQUOTIENT (ELT (OR COERCEDX X)
I)
YFLOAT)))
RESULT)))
((AND (ARRAYP Y)
(NUMARRAYTYP Y))
(SETQ RESULT (ARRAY (ARRAYSIZE Y)
(QUOTE FLOATP)
NIL
(ARRAYORIG Y)))
[for I (XFLOAT ←(FLOAT X)) from (ARRAYORIG Y)
to (IPLUS (ARRAYSIZE Y)
(SUB1 (ARRAYORIG Y)))
do (for I from 1 to (ARRAYSIZE Y) do (SETA RESULT I (FQUOTIENT XFLOAT
(ELT Y I]
RESULT)
(T (OLD\BOXFQUOTIENT X Y BOX])
(NEW\BOXFTIMES2
[LAMBDA (X Y BOX) (* hdj " 5-Aug-84 02:52")
(PROG (RESULT SIZE COERCEDX COERCEDY)
(RETURN (COND
([AND (ARRAYP X)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP X))
(SETQ COERCEDX (COERCETOFLOATARRAY X]
(COND
([AND (ARRAYP Y)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP Y))
(SETQ COERCEDY (COERCETOFLOATARRAY Y]
(* Both floating point arrays)
(OR (AND (EQ (SETQ SIZE (ARRAYSIZE X))
(ARRAYSIZE Y))
(EQ (ARRAYORIG X)
(ARRAYORIG Y)))
(ERROR "NONCONFORMABLE ARRAYS" (LIST X Y)))
(\BLKFTIMES (fetch (ARRAYP BASE) of (OR COERCEDX X))
(fetch (ARRAYP BASE) of (OR COERCEDY Y))
[fetch (ARRAYP BASE) of (SETQ RESULT
(OR COERCEDX COERCEDY
(ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
SIZE)
RESULT)
(T (SETQ SIZE (ARRAYSIZE X))
[SETQ RESULT (OR COERCEDX (ARRAY SIZE (QUOTE FLOATP)
(FLOAT Y)
(ARRAYORIG X]
(\BLKFTIMES (fetch (ARRAYP BASE) of X)
(fetch (ARRAYP BASE) of RESULT)
(fetch (ARRAYP BASE) of RESULT)
SIZE)
RESULT)))
((AND (ARRAYP Y)
(NUMARRAYTYP Y))
(SETQ SIZE (ARRAYSIZE Y))
(SETQ RESULT (ARRAY (ARRAYSIZE Y)
(QUOTE FLOATP)
(FLOAT X)
(ARRAYORIG Y)))
(\BLKFTIMES (fetch (ARRAYP BASE) of RESULT)
(fetch (ARRAYP BASE) of Y)
(fetch (ARRAYP BASE) of RESULT)
SIZE)
RESULT)
(T (OLD\BOXFTIMES2 X Y BOX])
(NEW\FDIFFERENCE.UFN
[LAMBDA (X Y) (* rmk: " 3-Aug-84 17:48")
(PROG (RESULT SIZE COERCEDX COERCEDY)
(RETURN (COND
([AND (ARRAYP X)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP X))
(SETQ COERCEDX (COERCETOFLOATARRAY X]
(COND
([AND (ARRAYP Y)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP Y))
(SETQ COERCEDY (COERCETOFLOATARRAY Y]
(* Both floating point arrays)
(OR (AND (EQ (SETQ SIZE (ARRAYSIZE X))
(ARRAYSIZE Y))
(EQ (ARRAYORIG X)
(ARRAYORIG Y)))
(ERROR "NONCONFORMABLE ARRAYS" (LIST X Y)))
[SETQ RESULT (OR COERCEDX COERCEDY (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(OR COERCEDX (SETQ COERCEDX X))
(OR COERCEDY (SETQ COERCEDY Y))
[for I from (ARRAYORIG X) to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FDIFFERENCE (ELT COERCEDX I)
(ELT COERCEDY I]
RESULT)
(T (SETQ SIZE (ARRAYSIZE X))
[SETQ RESULT (OR COERCEDX (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(for I (YFLOAT ←(FLOAT Y)) from (ARRAYORIG X)
to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FDIFFERENCE (ELT (OR COERCEDX X)
I)
YFLOAT)))
RESULT)))
((AND (ARRAYP Y)
(NUMARRAYTYP Y))
(SETQ RESULT (ARRAY (ARRAYSIZE Y)
(QUOTE FLOATP)
NIL
(ARRAYORIG Y)))
[for I (XFLOAT ←(FLOAT X)) from (ARRAYORIG Y)
to (IPLUS (ARRAYSIZE Y)
(SUB1 (ARRAYORIG Y)))
do (for I from 1 to (ARRAYSIZE Y) do (SETA RESULT I (FDIFFERENCE
XFLOAT
(ELT Y I]
RESULT)
(T (OLD\BOXFPLUSDIF X Y T])
(GENVEC
[LAMBDA (INITIAL END BY ORIG) (* rmk: " 3-Aug-84 18:28")
(* Generates sequences of numbers)
(PROG ((N NIL)
(GV NIL))
(COND
((NULL END)
(SETQ END INITIAL)
(SETQ INITIAL 1)))
(OR BY (SETQ BY (if (GREATERP END INITIAL)
then 1
else -1)))
[SETQ N (ADD1 (FIX (QUOTIENT (DIFFERENCE END INITIAL)
BY]
(if (ILESSP N 1)
then (ERROR "Inconsistent increment and bounds"))
[SETQ GV (if (OR (FLOATP INITIAL)
(FLOATP END)
(FLOATP BY))
then (bind SF (ROW ←(ARRAY N (QUOTE FLOATP)
NIL ORIG))
(DBY ←(FLOAT BY)) for I from (OR ORIG 1)
to (COND
(ORIG (SUB1 N))
(T N))
first (SETQ SF (FDIFFERENCE (FLOAT INITIAL)
DBY))
do [SETA ROW I (FPLUS SF (FTIMES DBY (FLOAT I]
(* Done by multip so as to prevent accumulation of
roundoff error)
finally (RETURN ROW))
else (bind (VAL ← INITIAL)
(ROW ←(ARRAY N (QUOTE FIXP)
NIL ORIG))
for I from (OR ORIG 1) to (COND
(ORIG (SUB1 N))
(T N))
do (SETA ROW I VAL)
(add VAL BY)
finally (RETURN ROW]
(RETURN GV])
(NEWCOS
[LAMBDA (X RADIANSFLG) (* rmk: " 3-Aug-84 18:21")
(IF (AND (ARRAYP X)
(NUMARRAYTYP X))
THEN (PROG (RESULT (SIZE (ARRAYSIZE X)))
(SETQ RESULT (ARRAY SIZE (QUOTE FLOATP)))
(for I from (ARRAYORIG X) to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (OLDCOS (ELT X I)
RADIANSFLG)))
(RETURN RESULT))
ELSE (OLDCOS X RADIANSFLG])
(NEWSIN
[LAMBDA (X RADIANSFLG) (* rmk: " 3-Aug-84 18:21")
(IF (AND (ARRAYP X)
(NUMARRAYTYP X))
THEN (PROG (RESULT (SIZE (ARRAYSIZE X)))
(SETQ RESULT (ARRAY SIZE (QUOTE FLOATP)))
(for I from (ARRAYORIG X) to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (OLDSIN (ELT X I)
RADIANSFLG)))
(RETURN RESULT))
ELSE (OLDSIN X RADIANSFLG])
(NUMARRAYTYP
[LAMBDA (A) (* rmk: " 2-Aug-84 22:12")
(* T if A is a numeric array)
(SELECTQ (ARRAYTYP A)
((FLOATP BYTE SMALLPOSP FIXP BIT)
T)
NIL])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD 'NEW\BOXFTIMES2 '\BOXFTIMES2)
(MOVD 'NEW\BOXFQUOTIENT '\BOXFQUOTIENT)
(MOVD 'NEW\FDIFFERENCE.UFN '\FDIFFERENCE.UFN)
(MOVD 'NEW\BOXFPLUSDIF '\BOXFPLUSDIF)
(MOVD 'NEWSIN 'SIN)
(MOVD 'NEWCOS 'COS)
)
(PUTPROPS NEWBOXFTIMES COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1355 11881 (COERCETOFLOATARRAY 1365 . 2003) (NEW\BOXFPLUSDIF 2005 . 3627) (
NEW\BOXFQUOTIENT 3629 . 5488) (NEW\BOXFTIMES2 5490 . 7239) (NEW\FDIFFERENCE.UFN 7241 . 9129) (GENVEC
9131 . 10621) (NEWCOS 10623 . 11103) (NEWSIN 11105 . 11585) (NUMARRAYTYP 11587 . 11879)))))
STOP