(FILECREATED "30-Sep-85 14:55:26" {ERIS}<LISPCORE>LIBRARY>CMLFLOATARRAY.;5
 58932  

      changes to:  (FNS COMPLEX-TO-BITMAP FLOAT-TO-BITMAP XCOMPLEX-TO-BITMAP) (VARS CMLFLOATARRAYCOMS)

      previous date: "27-Sep-85 01:37:18" {ERIS}<LISPCORE>LIBRARY>CMLFLOATARRAY.;4)


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

(PRETTYCOMPRINT CMLFLOATARRAYCOMS)

(RPAQQ CMLFLOATARRAYCOMS
 ((FILES CMLARRAY) (* * MAPARRAY fns and macros) (FNS MAPARRAY MAPARRAY1 
MAPARRAY2) (MACROS FARRAYP POLYNOM SMALLARRAYP MKARRAY? CFARRAYB CSARRAYB ARRAYBASE) (* * Other array 
functions) (FNS ARRAY-COPY ARRAY-POWER ARRAY-SET MAXARR MINARR MAXABSARR MINABSARR MULARR ADDARR 
WHERE-MINABSARR WHERE-MINARR WHERE-MAXABSARR WHERE-MAXARR SUMARR FABS-LESSP FABS-GREATERP FABSMIN 
FABSMAX MAKE-INDEX \SUM-VECTOR) (MACROS MIN/MAX WMIN/MAX DIVARR SUBARR) (* * FFT stuff) (FNS FFT 
FFT.GET.COLUMN.PILOTBBT FFT.INIT FFT.PERMUTATE FFT.PUT.COLUMN.PILOTBBT FFT.RADARS FFT.TABLE.INIT 
FFTSTEP \FFTSTEP) (RECORDS FFTTABLE FFTSOURCE COMPLEX) (CONSTANTS \FFTTABLESIZE FFTSSIZE PI) (MACROS 
FFT.GET.COLUMN FFT.PUT.COLUMN FFT.STEP FFTGET FFTGETARR FFTPUT FFTPUT? \NLP2) (GLOBALVARS 
FFTREUSETABLE \SLICE1 \SLICE2) (VARS \SUM-VECTOR (FFTREUSETABLE NIL) (\SLICE1 (CFARRAYB FFTSSIZE)) (
\SLICE2 (CFARRAYB FFTSSIZE))) (* * FFTs of real vectors (pack in complex format)) (FNS 2DXFFT \2DXFFT 
FFT.GET.COLUMNX.PILOTBBT FFT.PUT.COLUMNX.PILOTBBT FFT.\DISSEP FFT.\SEP.INIT FFT.\DISSEP.INIT FFT.FR 
FFT.INVFR FFT.SCALE/SIGN FFTTEST) (MACROS FFT.GET.COLUMNX FFT.PUT.COLUMNX FFTX INVFFTX) (* * 
Conversion stuff) (FNS BITMAP-TO-COMPLEX COMPLEX-TO-BITMAP FLOAT-TO-BITMAP BITMAP-TO-FLOAT 
BITMAP-TO-XCOMPLEX XCOMPLEX-TO-BITMAP COMPLEX-TO-FLOAT FLOAT-TO-COMPLEX) (* * 2D versions) (FNS 
2DCTIMES 2DCXTIMES 2DFFT 2DMMUL 2DTRANS 2DTRANS-1) (MACROS 2DFMATP) (* * Misc.) (FNS \RE/IM-PACK 
\RE/IM-UNPACK GET.COLUMN.BBT PUT.COLUMN.BBT ZEROARRAY \NLP2 ARRAYBASE CHIPTEST) (MACROS DIV4 DIV2 MUL2
 MUL4 MUL8) (* * UFNs) (FNS \FLOATBLT) (PROP DOPVAL \FLOATBLT) (PROP DOPVAL \BLKFABSMAX \BLKFABSMIN 
\BLKFMAX \BLKFMIN \FFTSTEP \FLOATTOBYTE) (* * For convenience) (PROP ARGNAMES FFT MAPARRAY 
\BLKEXPONENT \BLKFDIFF \BLKFLOATP2COMP \BLKFPLUS \BLKFTIMES \BLKMAG \BLKPERM \BLKSEP \BLKSMALLP2FLOAT 
\FLOATTOBYTE \BLKFMAX \BLKFMIN \BLKFABSMAX \BLKFABSMIN \IBLT1 \IBLT2) (FNS \BLKEXPONENT \BLKFDIFF 
\BLKFLOATP2COMP \BLKFPLUS \BLKFTIMES \BLKMAG \BLKPERM \BLKSEP \BLKSMALLP2FLOAT \BLKFMAX \BLKFMIN 
\BLKFABSMAX \BLKFABSMIN \FLOATTOBYTE \PILOTBITBLT POLYNOM \POLYNOM) (MACROS \POLYNOM ARRAYHIELT DOUBLE
 QUADRUPLE) (FNS ARRAYBASE) (PROP PUTPROPS FARRAYP) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MAPARRAY)))))
(FILESLOAD CMLARRAY)
(* * MAPARRAY fns and macros)


(DEFINEQ

(MAPARRAY

(LAMBDA ARGS (* JAS "27-Aug-85 12:35") (* * Top level entry to array mapper: recognizes MAPARRAY1 and 
MAPARRAY2 cases. If RESULT is not an array, then create an array with the appropriate dimensions) (LET
 ((RESULT (ARG ARGS 1)) (MAPFN (ARG ARGS 2)) (ARRAY1 (ARG ARGS 3)) (ARRAYARGS (for ARGNO from 3 to 
ARGS collect (ARG ARGS ARGNO)))) (COND ((EQ ARGS 3) (MAPARRAY1 RESULT MAPFN ARRAY1)) ((EQ ARGS 4) (
MAPARRAY2 RESULT MAPFN ARRAY1 (ARG ARGS 4))) (T (LET ((DIM (for A in ARRAYARGS do NIL until (FARRAYP A
) finally (RETURN (FARRAYP A))))) (COND ((NOT (AND DIM (EVERY (for ARRAYARG in ARRAYARGS collect (OR (
NUMBERP ARRAYARG) (FARRAYP ARRAYARG DIM))) (FUNCTION (LAMBDA (X) (NOT (NULL X))))) (FARRAYP (MKARRAY? 
RESULT DIM) DIM))) (ERROR "Illegal arguments to MAPARRAY" ARRAYARGS))) (LET ((ABASES (for ARRAYARG in 
ARRAYARGS collect (OR (NUMBERP ARRAYARG) (ARRAYBASE ARRAYARG)))) (ELEMENTS (ARRAY-TOTAL-SIZE RESULT)) 
(RESULTBASE (ARRAYBASE RESULT))) (for ELEMENT from 0 to (SUB1 ELEMENTS) do (\PUTBASEFLOATP RESULTBASE 
(MUL2 ELEMENT) (APPLY MAPFN (for ARRAYARG in ABASES collect (OR (NUMBERP ARRAYARG) (\GETBASEFLOATP 
ARRAYARG (MUL2 ELEMENT)))))))) RESULT))))))

(MAPARRAY1

(LAMBDA (RESULT MAPFN ARRAY) (* JAS " 5-Sep-85 17:42") (* * Map a function across an array. Recognizes
 the special cases that can run in microcode.) (LET ((ARRAYSIZE (ARRAY-TOTAL-SIZE ARRAY)) (ARRAYBASE (
ARRAYBASE ARRAY)) (DIMS (ARRAY-DIMENSIONS ARRAY))) (SELECTQ MAPFN (EXPONENT (OR (FARRAYP ARRAY) (ERROR
 "ILLEGAL ARGUMENT:" ARRAY)) (MKARRAY? RESULT DIMS (QUOTE (UNSIGNED-BYTE 16))) (COND ((EQUAL DIMS (
SMALLARRAYP RESULT)) (\BLKEXPONENT ARRAYBASE (ARRAYBASE RESULT) ARRAYSIZE)) (T (ERROR 
"ILLEGAL ARGUMENT:" RESULT)))) (MAGNITUDE (LET* ((DIMS (COPY DIMS)) (TAIL (NTH DIMS (ARRAY-RANK ARRAY)
))) (RPLACA TAIL (DIV2 (CAR TAIL))) (OR (EVENP (CAR TAIL)) (ERROR "Array not complex: " ARRAY)) (OR (
FARRAYP ARRAY) (ERROR "ILLEGAL ARGUMENT:" ARRAY)) (MKARRAY? RESULT DIMS) (COND ((EQUAL DIMS (FARRAYP 
RESULT)) (\BLKMAG ARRAYBASE (ARRAYBASE RESULT) (DIV2 ARRAYSIZE))) (T (ERROR "ILLEGAL ARGUMENT:" RESULT
))))) (FLOAT (LET ((DIMS (SMALLARRAYP ARRAY))) (OR DIMS (ERROR "ILLEGAL ARGUMENT:" ARRAY)) (MKARRAY? 
RESULT DIMS) (COND ((EQUAL DIMS (FARRAYP RESULT)) (\BLKSMALLP2FLOAT ARRAYBASE (ARRAYBASE RESULT) 
ARRAYSIZE)) (T (ERROR "ILLEGAL ARGUMENT: " RESULT))))) (COMPLEX (LET* ((DIMS (COPY DIMS)) (TAIL (NTH 
DIMS (ARRAY-RANK ARRAY)))) (RPLACA TAIL (MUL2 (CAR TAIL))) (OR (FARRAYP ARRAY) (ERROR 
"ILLEGAL FLOAT ARRAY: " ARRAY)) (MKARRAY? RESULT DIMS) (COND ((EQ DIMS (FARRAYP RESULT)) (
\BLKFLOATP2COMP ARRAYBASE (ARRAYBASE RESULT) ARRAYSIZE)) (T (ERROR "ILLEGAL FLOAT ARRAY: " RESULT)))))
 (COND ((EQUAL (FARRAYP ARRAY) (FARRAYP (MKARRAY? RESULT DIMS))) (LET ((RB (ARRAYBASE RESULT))) (for 
ELT from 0 to (MUL2 (SUB1 ARRAYSIZE)) by 2 do (\PUTBASEFLOATP RB ELT (APPLY* MAPFN (\GETBASEFLOATP 
ARRAYBASE ELT)))))) (T (ERROR "ILLEGAL ARGUMENTS")))) RESULT)))

(MAPARRAY2

(LAMBDA (RESULT MAPFN ARRAY1 ARRAY2) (* raf "27-Sep-85 01:33") (* * Map a function across two arrays. 
Recognizes the cases that can run in microcode. Check the array arguments. Rebind arguments when 
checked. Numbers are converted to vectors and a result vector is created if NIL.) (SELECTQ MAPFN ((
PERMUTE ELT) (* ARRAY2 should be a (UNSIGNED-BYTE 16) array) (OR (SMALLARRAYP ARRAY2 1) (ERROR 
"Illegal permutation array" ARRAY1)) (OR RESULT (SETQ RESULT (COPYALL ARRAY1))) (\BLKPERM (ARRAYBASE 
ARRAY1) (ARRAYBASE ARRAY2) (ARRAYBASE RESULT) (ARRAY-DIMENSION ARRAY2 0))) (LET* ((DIMS (OR (FARRAYP 
ARRAY1) (FARRAYP ARRAY2))) (SIZE (APPLY (FUNCTION ITIMES) DIMS)) (ARRAY1 (OR (AND DIMS (NUMBERP ARRAY1
) (MAKE-ARRAY DIMS (QUOTE :ELEMENT-TYPE) (QUOTE SINGLE-FLOAT) (QUOTE :INITIAL-ELEMENT) (FLOAT ARRAY1) 
(QUOTE :ALIGNMENT) (IMIN (\NLP2 SIZE) 128))) ARRAY1)) (ARRAY2 (OR (AND DIMS (NUMBERP ARRAY2) (
MAKE-ARRAY DIMS (QUOTE :ELEMENT-TYPE) (QUOTE SINGLE-FLOAT) (QUOTE :INITIAL-ELEMENT) (FLOAT ARRAY2) (
QUOTE :ALIGNMENT) (IMIN (\NLP2 SIZE) 128))) ARRAY2)) (RESULT (AND DIMS (COND ((EQUAL (FARRAYP RESULT) 
DIMS) RESULT) ((NULL RESULT) (MAKE-ARRAY DIMS (QUOTE :ELEMENT-TYPE) (QUOTE SINGLE-FLOAT) (QUOTE 
:ALIGNMENT) (IMIN (\NLP2 SIZE) 128))) (T (ERROR "ILLEGAL RESULT ARRAY: " RESULT)))))) (COND ((AND DIMS
 RESULT (EQUAL (FARRAYP ARRAY1) (FARRAYP ARRAY2))) (LET ((ARRAY1BASE (ARRAYBASE ARRAY1)) (ARRAY2BASE (
ARRAYBASE ARRAY2)) (RESULTBASE (ARRAYBASE RESULT))) (SELECTQ MAPFN (FTIMES (\BLKFTIMES ARRAY1BASE 
ARRAY2BASE RESULTBASE SIZE)) (FPLUS (\BLKFPLUS ARRAY1BASE ARRAY2BASE RESULTBASE SIZE)) (FDIFF (
\BLKFDIFF ARRAY1BASE ARRAY2BASE RESULTBASE SIZE)) (for ELT from 0 to (MUL2 (SUB1 SIZE)) by 2 do (
\PUTBASEFLOATP RESULTBASE ELT (APPLY* MAPFN (\GETBASEFLOATP ARRAY1BASE ELT) (\GETBASEFLOATP ARRAY2BASE
 ELT))))) RESULT)) (T (ERROR "ILLEGAL ARGUMENTS"))))) RESULT))
)
(DECLARE: EVAL@COMPILE 
(PUTPROPS FARRAYP MACRO ((ARR DIM) (AND (TYPENAMEP ARR (QUOTE ARRAY)) (EQ (ARRAY-ELEMENT-TYPE ARR) (
QUOTE SINGLE-FLOAT)) (OR (NULL DIM) (EQ (ARRAY-RANK ARR) DIM) (EQUAL DIM (ARRAY-DIMENSIONS ARR))) (
ARRAY-DIMENSIONS ARR))))
(PUTPROPS POLYNOM DMACRO ((X COEFFS DEGREE) (* execute the POLYEVAL opcode on the value X, the array 
COEFFS with degree DEGREE) (\FLOATBOX ((OPCODES UBFLOAT3 0) (\FLOATUNBOX X) (ARRAYBASE COEFFS) DEGREE)
)))
(PUTPROPS SMALLARRAYP MACRO ((ARR DIM) (AND (TYPENAMEP ARR (QUOTE ARRAY)) (EQUAL (ARRAY-ELEMENT-TYPE 
ARR) (QUOTE (UNSIGNED-BYTE 16))) (OR (NULL DIM) (EQ (ARRAY-RANK ARR) DIM)) (ARRAY-DIMENSIONS ARR))))
(PUTPROPS MKARRAY? MACRO ((ARRAY DIMS TYPE) (OR ARRAY (SETQ ARRAY (MAKE-ARRAY DIMS (QUOTE 
:ELEMENT-TYPE) (OR TYPE (QUOTE FLOAT)) (QUOTE :ALIGNMENT) (IMIN 128 (\NLP2 (APPLY (FUNCTION ITIMES) 
DIMS))))))))
(PUTPROPS CFARRAYB MACRO ((SIZE IE) (ARRAYBASE (MAKE-ARRAY SIZE (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT) (
QUOTE :ALIGNMENT) (IMIN (\NLP2 SIZE) 128) (QUOTE :INITIAL-ELEMENT) (OR IE 0.0)))))
(PUTPROPS CSARRAYB MACRO ((SIZE) (ARRAYBASE (MAKE-ARRAY SIZE (QUOTE :ELEMENT-TYPE) (QUOTE (
UNSIGNED-BYTE 16)) (QUOTE :ALIGNMENT) (IMIN (\NLP2 (DIV2 SIZE)) 128)))))
(PUTPROPS ARRAYBASE MACRO ((X) (COND ((TYPENAMEP X (QUOTE ARRAYP)) (fetch (ARRAYP BASE) of X)) (T (
fetch (ARRAY BASE) of X)))))
)
(* * Other array functions)


(DEFINEQ

(ARRAY-COPY

(LAMBDA (ARR1 ARR2) (* JAS " 2-Sep-85 17:54") (COND ((AND (FARRAYP ARR1) (EQUAL (ARRAY-DIMENSIONS ARR1
) (FARRAYP ARR2))) (LET ((TS (MUL2 (ARRAY-TOTAL-SIZE ARR1))) (BA1 (ARRAYBASE ARR1)) (BA2 (ARRAYBASE 
ARR2)) SSIZE) (while (GREATERP TS 0) do (SETQ SSIZE (IMIN 1024 TS)) (\BLT BA2 BA1 SSIZE) (SETQ BA1 (
\ADDBASE BA1 SSIZE)) (SETQ BA2 (\ADDBASE BA2 SSIZE)) (SETQ TS (IDIFFERENCE TS SSIZE))) ARR2)) (T (
ERROR "Illegal arguments")))))

(ARRAY-POWER

(LAMBDA (INARR OUTARR N TMPARR) (* JAS " 2-Sep-85 17:55") (LET ((TMP (COND (TMPARR (ARRAY-COPY INARR 
TMPARR)) (T (COPYALL INARR)))) (OUTARR (OR OUTARR (COPYALL INARR)))) (ARRAY-SET OUTARR 1.0) (while (
GREATERP N 0) do (COND ((ODDP N) (MAPARRAY OUTARR (FUNCTION FTIMES) TMP OUTARR))) (SETQ N (DIV2 N)) (
MAPARRAY TMP (FUNCTION FTIMES) TMP TMP)) OUTARR)))

(ARRAY-SET

(LAMBDA (ARR VALUE) (* JAS " 2-Sep-85 17:41") (COND ((NOT (FARRAYP ARR)) (ERROR 
"Illegal array argument" ARR))) (LET ((BA (ARRAYBASE ARR)) (WS (MUL2 (SUB1 (ARRAY-TOTAL-SIZE ARR))))) 
(\PUTBASEFLOATP BA WS VALUE) (\BLT BA (\ADDBASE BA 2) WS) ARR)))

(MAXARR

(LAMBDA (ARR COMPLEXFLG IMFLG) (* JAS "19-Jul-85 14:42") (MIN/MAX \BLKFMAX FMAX MIN.FLOAT ARR 
COMPLEXFLG IMFLG)))

(MINARR

(LAMBDA (ARR COMPLEXFLG IMFLG) (* JAS "19-Jul-85 14:42") (MIN/MAX \BLKFMIN FMIN MAX.FLOAT ARR 
COMPLEXFLG IMFLG)))

(MAXABSARR

(LAMBDA (ARR COMPLEXFLG IMFLG) (* JAS " 6-Sep-85 16:32") (MIN/MAX \BLKFABSMAX FABSMAX 0.0 ARR 
COMPLEXFLG IMFLG)))

(MINABSARR

(LAMBDA (ARR COMPLEXFLG IMFLG) (* JAS " 2-Sep-85 20:45") (MIN/MAX \BLKFABSMIN FABSMIN MAX.FLOAT ARR 
COMPLEXFLG IMFLG)))

(MULARR

(LAMBDA (ARR X COMPLEXFLG IMFLG) (* JAS "10-Sep-85 16:55") (COND ((FARRAYP ARR) (LET ((CNT (
ARRAY-TOTAL-SIZE ARR)) (SLICE FFTSSIZE) (XV \SLICE1) (BA (ARRAYBASE ARR)) TCNT) (COND (COMPLEXFLG (if 
IMFLG then (for I from 0 to (SUB1 (DIV2 (IMIN CNT SLICE))) do (\PUTBASEFLOATP XV (MUL4 I) 1.0) (
\PUTBASEFLOATP XV (PLUS 2 (MUL4 I)) X)) else (for I from 0 to (SUB1 (DIV2 (IMIN CNT SLICE))) do (
\PUTBASEFLOATP XV (MUL4 I) X) (\PUTBASEFLOATP XV (PLUS 2 (MUL4 I)) 1.0)))) (T (for I from 0 to (SUB1 (
IMIN CNT SLICE)) do (\PUTBASEFLOATP XV (MUL2 I) X)))) (while (GREATERP CNT 0) do (SETQ TCNT (IMIN 
SLICE CNT)) (\BLKFTIMES BA XV BA TCNT) (SETQ BA (\ADDBASE BA (MUL2 TCNT))) (SETQ CNT (IDIFFERENCE CNT 
TCNT))) ARR)) (T (ERROR "Illegal array: " ARR)))))

(ADDARR

(LAMBDA (ARR X COMPLEXFLG IMFLG) (* JAS "10-Sep-85 16:53") (COND ((FARRAYP ARR) (LET ((CNT (
ARRAY-TOTAL-SIZE ARR)) (SLICE FFTSSIZE) (XV \SLICE1) (BA (ARRAYBASE ARR)) TCNT) (COND (COMPLEXFLG (if 
IMFLG then (for I from 0 to (SUB1 (DIV2 (IMIN SLICE CNT))) do (\PUTBASEFLOATP XV (MUL4 I) 0.0) (
\PUTBASEFLOATP XV (PLUS 2 (MUL4 I)) X)) else (for I from 0 to (SUB1 (DIV2 (IMIN SLICE CNT))) do (
\PUTBASEFLOATP XV (MUL4 I) X) (\PUTBASEFLOATP XV (PLUS 2 (MUL4 I)) 0.0)))) (T (for I from 0 to (SUB1 (
IMIN SLICE CNT)) do (\PUTBASEFLOATP XV (MUL2 I) X)))) (while (GREATERP CNT 0) do (SETQ TCNT (IMIN 
SLICE CNT)) (\BLKFPLUS BA XV BA TCNT) (SETQ BA (\ADDBASE BA (MUL2 TCNT))) (SETQ CNT (IDIFFERENCE CNT 
TCNT))) ARR)) (T (ERROR "Illegal array: " ARR)))))

(WHERE-MINABSARR

(LAMBDA (ARRAY COMPFLG IMFLG) (* JAS " 2-Sep-85 20:41") (MAKE-INDEX (ARRAY-DIMENSIONS ARRAY) (WMIN/MAX
 (\ADDBASE (ARRAYBASE ARRAY) (if (AND COMPFLG IMFLG) then 2 else 0)) (if COMPFLG then (DIV2 (
ARRAY-TOTAL-SIZE ARRAY)) else (ARRAY-TOTAL-SIZE ARRAY)) COMPFLG \BLKFABSMIN FABS-LESSP MAX.FLOAT) 
COMPFLG IMFLG)))

(WHERE-MINARR

(LAMBDA (ARRAY COMPFLG IMFLG) (* JAS " 2-Sep-85 20:07") (MAKE-INDEX (ARRAY-DIMENSIONS ARRAY) (WMIN/MAX
 (\ADDBASE (ARRAYBASE ARRAY) (if (AND COMPFLG IMFLG) then 2 else 0)) (if COMPFLG then (DIV2 (
ARRAY-TOTAL-SIZE ARRAY)) else (ARRAY-TOTAL-SIZE ARRAY)) COMPFLG \BLKFMIN LESSP MAX.FLOAT) COMPFLG 
IMFLG)))

(WHERE-MAXABSARR

(LAMBDA (ARRAY COMPFLG IMFLG) (* JAS " 2-Sep-85 20:50") (MAKE-INDEX (ARRAY-DIMENSIONS ARRAY) (WMIN/MAX
 (\ADDBASE (ARRAYBASE ARRAY) (if (AND COMPFLG IMFLG) then 2 else 0)) (if COMPFLG then (DIV2 (
ARRAY-TOTAL-SIZE ARRAY)) else (ARRAY-TOTAL-SIZE ARRAY)) COMPFLG \BLKFABSMAX FABS-GREATERP MIN.FLOAT) 
COMPFLG IMFLG)))

(WHERE-MAXARR

(LAMBDA (ARRAY COMPFLG IMFLG) (* JAS " 2-Sep-85 20:49") (MAKE-INDEX (ARRAY-DIMENSIONS ARRAY) (WMIN/MAX
 (\ADDBASE (ARRAYBASE ARRAY) (if (AND COMPFLG IMFLG) then 2 else 0)) (if COMPFLG then (DIV2 (
ARRAY-TOTAL-SIZE ARRAY)) else (ARRAY-TOTAL-SIZE ARRAY)) COMPFLG \BLKFMAX GREATERP MIN.FLOAT) COMPFLG 
IMFLG)))

(SUMARR

(LAMBDA (ARRAY COMPLEXFLG IMFLG) (* JAS " 3-Sep-85 09:53") (COND ((FARRAYP ARRAY) (\SUM-VECTOR (
ARRAYBASE ARRAY) (ARRAY-TOTAL-SIZE ARRAY) COMPLEXFLG IMFLG)) (T (ERROR "Illegal array arguments")))))

(FABS-LESSP

(LAMBDA (X Y) (* JAS " 2-Sep-85 20:41") (LESSP (FABS X) (FABS Y))))

(FABS-GREATERP

(LAMBDA (X Y) (* JAS " 2-Sep-85 20:50") (GREATERP (FABS X) (FABS Y))))

(FABSMIN

(LAMBDA (X Y) (* JAS " 2-Sep-85 20:45") (FMIN (FABS X) (FABS Y))))

(FABSMAX

(LAMBDA (X Y) (* JAS " 2-Sep-85 20:52") (FMAX (FABS X) (FABS Y))))

(MAKE-INDEX

(LAMBDA (DIMS IDX COMPLEXFLG IMFLG) (* JAS " 2-Sep-85 20:29") (SETQ IDX (if COMPLEXFLG then (if IMFLG 
then (ADD1 (MUL2 IDX)) else (MUL2 IDX)) else IDX)) (if (EQ 1 (LENGTH DIMS)) then (LIST IDX) else (LET 
((REST-SIZE (APPLY (FUNCTION ITIMES) (CDR DIMS)))) (CONS (IQUOTIENT IDX REST-SIZE) (MAKE-INDEX (CDR 
DIMS) (IREMAINDER IDX REST-SIZE)))))))

(\SUM-VECTOR

(LAMBDA (BASE CNT COMPLEXFLG IMFLG) (* JAS "10-Sep-85 11:09") (if COMPLEXFLG then (LET ((S 0.0) (SLICE
 FFTSSIZE) (TMPX \SLICE1) (TMPY \SLICE2) (BASE (if IMFLG then (\ADDBASE BASE 2) else BASE)) (CNT (DIV2
 CNT)) TSIZE) (while (GREATERP CNT 0) do (SETQ TSIZE (IMIN CNT SLICE)) (\RE/IM-UNPACK BASE TMPX TMPY 
TSIZE) (SETQ S (FPLUS S (\POLYNOM 1.0 TMPX (SUB1 TSIZE)))) (SETQ CNT (IDIFFERENCE CNT TSIZE)) (SETQ 
BASE (\ADDBASE BASE (MUL4 TSIZE)))) S) else (\POLYNOM 1.0 BASE (SUB1 CNT)))))
)
(DECLARE: EVAL@COMPILE 
(PUTPROPS MIN/MAX MACRO ((OPC CMP INITV ARR COMPLEXFLG IMFLG) (PROGN (COND ((NOT (FARRAYP ARR)) (ERROR
 "Illegal array: " ARR))) (LET ((SLICE FFTSSIZE) (CNT (ARRAY-TOTAL-SIZE ARR)) (BA (\ADDBASE (ARRAYBASE
 ARR) (COND (IMFLG 2) (T 0)))) (MX INITV) IDX TCNT) (COND (COMPLEXFLG (LET ((RE \SLICE1) (IM \SLICE2) 
(CNT (DIV2 CNT))) (while (GREATERP CNT 0) do (SETQ TCNT (IMIN CNT SLICE)) (\RE/IM-UNPACK BA RE IM TCNT
) (SETQ IDX (OPC RE 0 TCNT)) (SETQ MX (CMP MX (\GETBASEFLOATP RE (MUL2 IDX)))) (SETQ BA (\ADDBASE BA (
MUL2 TCNT))) (SETQ CNT (IDIFFERENCE CNT TCNT))))) (T (while (GREATERP CNT 0) do (SETQ TCNT (IMIN CNT 
SLICE)) (SETQ IDX (OPC BA 0 TCNT)) (SETQ MX (CMP MX (\GETBASEFLOATP BA (MUL2 IDX)))) (SETQ BA (
\ADDBASE BA (MUL2 TCNT))) (SETQ CNT (IDIFFERENCE CNT TCNT))))) MX))))
(PUTPROPS WMIN/MAX MACRO ((BA XSIZE COMPFLG \BLKFx CMPx x.FLOAT) (LET ((SLICE FFTSSIZE) (IDXBASE 0) (
CIDX 0) (BASE BA) (SIZE XSIZE) (MIN.FOUND x.FLOAT) SSIZE XV IDX) (if COMPFLG then (LET ((X \SLICE1) (Y
 \SLICE2)) (while (GREATERP SIZE 0) do (SETQ SSIZE (IMIN SIZE SLICE)) (\RE/IM-UNPACK BASE X Y SSIZE) (
SETQ IDX (\BLKFx X 0 SSIZE)) (if (CMPx (SETQ XV (\GETBASEFLOATP X (MUL2 IDX))) MIN.FOUND) then (SETQ 
CIDX (IPLUS IDX IDXBASE)) (SETQ MIN.FOUND XV)) (SETQ IDXBASE (IPLUS IDXBASE SSIZE)) (SETQ BASE (
\ADDBASE BASE (MUL4 SSIZE))) (SETQ SIZE (IDIFFERENCE SIZE SSIZE)))) else (while (GREATERP SIZE 0) do (
SETQ SSIZE (IMIN SIZE 8192)) (SETQ IDX (\BLKFx BASE 0 SSIZE)) (* PROG1 (SETQ IDX (\BLKFx BASE 0 SSIZE)
) (SETQ A (ADD1 A))) (if (CMPx (SETQ XV (\GETBASEFLOATP BASE (MUL2 IDX))) MIN.FOUND) then (SETQ CIDX (
IPLUS IDX IDXBASE)) (SETQ MIN.FOUND XV)) (SETQ IDXBASE (IPLUS IDXBASE SSIZE)) (SETQ BASE (\ADDBASE 
BASE (MUL2 SSIZE))) (SETQ SIZE (IDIFFERENCE SIZE SSIZE)))) CIDX)))
(PUTPROPS DIVARR MACRO ((ARR X COMPLEXFLG IMFLG) (MULARR ARR (FQUOTIENT 1.0 X) COMPLEXFLG IMFLG)))
(PUTPROPS SUBARR MACRO ((ARR X COMPLEXFLG IMFLG) (ADDARR ARR (FMINUS X) COMPLEXFLG IMFLG)))
)
(* * FFT stuff)


(DEFINEQ

(FFT

(LAMBDA (V START LEN INVFLG \BASEPTR) (* JAS " 5-Sep-85 18:38") (* Perform FFT, the microcoded 
routines works on "base pointers" so we have to translate all arrays to those kind of animals. We are 
a bit inefficient here since it would be possible to use the same two buffers all the time, we use a 
third here. But the time spent in moving the data around two times extra is properbly very small. 
START is not the origin of the array. It is the start position of the first complex in the array. I.e.
 if start is 2 then then first four number is skipped) (LET (PASSES BSHUFFLE BFFTBUF1 BFFTBUF2 BV 
\FFTTABLE FFTTABLES SIB) (* We make the START and LEN arguments optional. START is defaulted to zero 
and LEN to the number of complex numbers in the array. Check the argument. V has to be a one 
dimmensional array (Cmlarry) or an interlisp array type.) (OR START (SETQ START 0)) (COND ((NULL 
\BASEPTR) (COND ((TYPENAMEP V (QUOTE ARRAY)) (OR (EQ 1 (ARRAY-RANK V)) (ERROR 
"FFT only takes one dimensional arrays" V)) (OR LEN (SETQ LEN (DIFFERENCE (DIV2 (ARRAY-DIMENSION V 0))
 START))) (AND (GREATERP LEN (DIFFERENCE (DIV2 (ARRAY-DIMENSION V 0)) START)) (ERROR "Array to small" 
V)) (OR (EQ (ARRAY-ELEMENT-TYPE V) (QUOTE SINGLE-FLOAT)) (ERROR "Array must be of type FLOAT" V))) ((
ARRAYP V) (OR LEN (SETQ LEN (DIFFERENCE (DIV2 (ARRAYSIZE V)) START))) (AND (GREATERP LEN (DIFFERENCE (
DIV2 (ARRAYSIZE V)) START)) (ERROR "Array to small" V)) (OR (EQ (ARRAYTYP V) (QUOTE FLOATP)) (ERROR 
"Array must be of type FLOATP" V)))))) (OR (POWEROFTWOP LEN) (ERROR "Length has to be a power of two" 
LEN)) (SETQ PASSES (SUB1 (INTEGERLENGTH LEN))) (SETQ SIB (LLSH LEN 2)) (FFT.INIT PASSES START) (SETQ 
BSHUFFLE (ARRAYBASE (FFTGET (QUOTE SHUFFLE) PASSES))) (SETQ BFFTBUF1 (ARRAYBASE (FFTGET (QUOTE FFTBUF1
) PASSES))) (SETQ BFFTBUF2 (ARRAYBASE (FFTGET (QUOTE FFTBUF2) PASSES))) (SETQ BV (\ADDBASE (COND (
\BASEPTR) (T (ARRAYBASE V))) (LLSH START 2))) (\BLT BFFTBUF2 BV SIB) (\BLKPERM BFFTBUF2 BSHUFFLE 
BFFTBUF1 SIB) (SETQ FFTTABLES (FFTGET (COND (INVFLG (QUOTE INVFFTTABLE)) (T (QUOTE FFTTABLE))) PASSES)
) (SETQ \FFTTABLE (create FFTTABLE)) (for I from 1 to PASSES do (FFT.STEP (ELT FFTTABLES I))) (COND ((
AND (EVENP PASSES) (NULL INVFLG)) (\BLT BV BFFTBUF1 SIB)) ((AND (EVENP PASSES) INVFLG) (\BLKFTIMES 
BFFTBUF1 (ARRAYBASE (FFTGET (QUOTE INVSCALE) PASSES)) BV (IPLUS LEN LEN))) ((NULL INVFLG) (\BLT BV 
BFFTBUF2 SIB)) (T (\BLKFTIMES BFFTBUF2 (ARRAYBASE (FFTGET (QUOTE INVSCALE) PASSES)) BV (IPLUS LEN LEN)
))) V)))

(FFT.GET.COLUMN.PILOTBBT

(LAMBDA (CNT) (* JAS "27-Jul-85 20:37") (create PILOTBBT PBTDESTBIT ← 0 PBTDESTBPL ← 64 PBTWIDTH ← 64 
PBTDISJOINT ← T)))

(FFT.INIT

(LAMBDA (PASSES) (* JAS " 5-Sep-85 17:34") (PROG (ARRAYLENGTH HALFARRAYLENGTH DBLE TMP1 TMP2) (SETQ 
ARRAYLENGTH (LLSH 1 PASSES)) (SETQ HALFARRAYLENGTH (LRSH ARRAYLENGTH 1)) (SETQ DBLE (LLSH ARRAYLENGTH 
1)) (* We will try to reuse the FFT template. All variables associated with a special value of PASSES 
are stored on an a-list in the hash array FFTREUSETABLE. Entries on the a-list: SHUFFLE, FFTBUF1, 
FFTBUF2 and FFTTABLE) (COND ((NULL (FFTGET (QUOTE INVSCALE) PASSES)) (FFTPUT? (QUOTE SHUFFLE) (
FFT.PERMUTATE ARRAYLENGTH) PASSES) (FFTPUT? (QUOTE FFTBUF1) (SETQ TMP1 (ARRAY DBLE (QUOTE FLOATP) 0.0 
0 (MIN 128 DBLE))) PASSES) (FFTPUT? (QUOTE FFTBUF2) (SETQ TMP2 (ARRAY DBLE (QUOTE FLOATP) 0.0 0 (MIN 
128 DBLE))) PASSES) (FFTPUT? (QUOTE FFTTABLE) (FFT.TABLE.INIT (ARRAYBASE TMP1) (ARRAYBASE TMP2) PASSES
) PASSES) (FFTPUT? (QUOTE INVFFTTABLE) (FFT.TABLE.INIT (ARRAYBASE TMP1) (ARRAYBASE TMP2) PASSES T) 
PASSES) (FFTPUT? (QUOTE INVSCALE) (ARRAY DBLE (QUOTE FLOATP) (FQUOTIENT 1.0 ARRAYLENGTH) 0 (MIN 
ARRAYLENGTH 128)) PASSES))))))

(FFT.PERMUTATE

(LAMBDA (ARRAYLENGTH) (* JAS " 5-Sep-85 17:35") (PROG (FOURDBLE PERM FDPERM TMP TMP1) (SETQ FOURDBLE (
LLSH ARRAYLENGTH 2)) (SETQ PERM (FFT.RADARS ARRAYLENGTH)) (SETQ FDPERM (ARRAY FOURDBLE (QUOTE WORD) 0 
0 (MIN 128 (LRSH FOURDBLE 1)))) (for I from 0 to (SUB1 ARRAYLENGTH) do (SETA FDPERM (SETQ TMP1 (LLSH I
 2)) (SETQ TMP (LLSH (ELT PERM I) 2))) (SETA FDPERM (IPLUS 1 TMP1) (IPLUS 1 TMP)) (SETA FDPERM (IPLUS 
2 TMP1) (IPLUS 2 TMP)) (SETA FDPERM (IPLUS 3 TMP1) (IPLUS 3 TMP))) (RETURN FDPERM))))

(FFT.PUT.COLUMN.PILOTBBT

(LAMBDA (CNT) (* JAS "27-Jul-85 21:13") (create PILOTBBT PBTSOURCEBIT ← 0 PBTSOURCEBPL ← 64 PBTWIDTH ←
 64 PBTDISJOINT ← T)))

(FFT.RADARS

(LAMBDA (ARRAYLENGTH) (* JAS " 5-Sep-85 17:42") (PROG ((HALFARRAYLENGTH (LRSH ARRAYLENGTH 1)) (PERM (
ARRAY ARRAYLENGTH (QUOTE WORD) 0 0)) I J K TEMP) (for I from 0 to (SUB1 ARRAYLENGTH) do (SETA PERM I I
)) (SETQ J 1) (* Interchange elements) (SETQ I 1) (* in bit-reversed order) (repeatwhile (ILESSP I 
ARRAYLENGTH) do (COND ((ILESSP I J) (SETQ TEMP (ELT PERM (SUB1 I))) (SETA PERM (SUB1 I) (ELT PERM (
SUB1 J))) (SETA PERM (SUB1 J) TEMP))) (SETQ K HALFARRAYLENGTH) (while (ILESSP K J) do (SETQ J (
IDIFFERENCE J K)) (SETQ K (IQUOTIENT K 2))) (SETQ J (IPLUS J K)) (SETQ I (ADD1 I))) (RETURN PERM))))

(FFT.TABLE.INIT

(LAMBDA (FFTBUF1 FFTBUF2 PASSES INVFLG) (* JAS " 5-Sep-85 17:31") (PROG ((\FFTTABLES (ARRAY (OR 16 
PASSES) (QUOTE POINTER) NIL NIL 16)) M N N2 LEXP LE1 NV2 UR UI WR WI ASOURCE ADEST) (SETQ N (EXPT 2 
PASSES)) (SETQ N2 (TIMES N 2)) (SETQ NV2 (IQUOTIENT N 2)) (SETQ M PASSES) (* Compute M = log (N)) (for
 PASS from 1 to M do (* Loop thru stages) (SETQ LEXP (EXPT 2 PASS)) (SETQ LE1 (IQUOTIENT LEXP 2)) (
SETQ UR 1.0) (SETQ UI 0.0) (SETQ WR (COS (FQUOTIENT PI LE1) T)) (SETQ WI (FMINUS (SIN (FQUOTIENT PI 
LE1) T))) (AND INVFLG (SETQ WI (FMINUS WI))) (COND ((ODDP PASS) (SETQ ASOURCE FFTBUF1) (SETQ ADEST 
FFTBUF2)) (T (SETQ ASOURCE FFTBUF2) (SETQ ADEST FFTBUF1))) (SETA \FFTTABLES PASS (create FFTTABLE 
TWIDDLE ← (FMINUS WR) ITWIDDLE ← WI SOURCE ← ASOURCE ABDEST ← ADEST CDDEST ← (\ADDBASE ADEST N2) (* 
midpoint of dest array) TCNT ← (ITIMES 4 (IQUOTIENT NV2 LE1)) HCNT ← (ITIMES 4 (SUB1 LE1) (IQUOTIENT 
NV2 LE1)) LCNT ← (ITIMES 4 (SUB1 (IQUOTIENT NV2 LE1))) DELTA ← WR IDELTA ← (FMINUS WI)))) (RETURN 
\FFTTABLES))))

(FFTSTEP

(LAMBDA (FFTTABLE) (* hdj "23-Jul-84 23:50") (\BLT \FFTTABLE FFTTABLE \FFTTABLESIZE) (\FFTSTEP 
\FFTTABLE (fetch (FFTTABLE LCNT) of FFTTABLE))))

(\FFTSTEP

(LAMBDA (TABLE COUNTLO) (* hdj "25-Sep-84 19:15") (PROG (X Y) (with FFTTABLE TABLE (do (with FFTSOURCE
 (\ADDBASE SOURCE (ITIMES 2 (IPLUS HCNT COUNTLO))) (SETQ X (FDIFFERENCE (FTIMES C TWIDDLE) (FTIMES D 
ITWIDDLE))) (SETQ Y (FPLUS (FTIMES C ITWIDDLE) (FTIMES D TWIDDLE))) (SETCOMPLEX (\ADDBASE ABDEST (
IPLUS HCNT COUNTLO)) (FPLUS A X) (FPLUS B Y)) (SETCOMPLEX (\ADDBASE CDDEST (IPLUS HCNT COUNTLO)) (
FDIFFERENCE A X) (FDIFFERENCE B Y)) (COND ((IGREATERP COUNTLO 0) (add COUNTLO -4)) ((ILEQ HCNT 0) (* 
return from iteration) (OR (EQ HCNT 0) (SHOULDNT)) (RETURN)) (T (SETQ HCNT (IDIFFERENCE HCNT TCNT)) (
SETQ COUNTLO (IDIFFERENCE TCNT 4)) (SETQ X (FDIFFERENCE (FTIMES TWIDDLE DELTA) (FTIMES ITWIDDLE IDELTA
))) (SETQ ITWIDDLE (FPLUS (FTIMES ITWIDDLE DELTA) (FTIMES TWIDDLE IDELTA))) (SETQ TWIDDLE X)))))) (
RETURN 0))))
)
[DECLARE: EVAL@COMPILE 

(DATATYPE FFTTABLE
 ((TWIDDLE FLOATP) (ITWIDDLE FLOATP (* imaginary part of TWIDDLE)) (SOURCE XPOINTER 
(* virtual address of source array base)) (ABDEST XPOINTER (* virtual address of destination array 
base)) (CDDEST XPOINTER (* midpoint in destination array)) (TCNT WORD (* count of butterfiles with 
same twiddle x4)) (HCNT WORD (* (mod cnt tcnt) high portion of count of butterflies remaining x4)) (
NIL 2 FLOATP (* must have floating complex zero here)) (DELTA FLOATP (* packed complex root of unity 
to change twiddle)) (IDELTA FLOATP (* imaginary part of DELTA)) (LCNT WORD (* (remainder cnt tcnt) low
 portion of count of butterflies remaining x4)) (PAD 11 WORD (* padding so that FFTTABLE will never 
cross page boundary.))))

(BLOCKRECORD FFTSOURCE
 ((A FLOATP) (B FLOATP) (C FLOATP) (D FLOATP)))

(BLOCKRECORD COMPLEX
 ((REAL FLOATP) (IMAG FLOATP)))
]
(/DECLAREDATATYPE (QUOTE FFTTABLE) (QUOTE (FLOATP FLOATP XPOINTER XPOINTER XPOINTER WORD WORD FLOATP 
FLOATP FLOATP FLOATP WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE ((FFTTABLE 0
 FLOATP) (FFTTABLE 2 FLOATP) (FFTTABLE 4 XPOINTER) (FFTTABLE 6 XPOINTER) (FFTTABLE 8 XPOINTER) (
FFTTABLE 10 (BITS . 15)) (FFTTABLE 11 (BITS . 15)) (FFTTABLE 12 FLOATP) (FFTTABLE 14 FLOATP) (FFTTABLE
 16 FLOATP) (FFTTABLE 18 FLOATP) (FFTTABLE 20 (BITS . 15)) (FFTTABLE 21 (BITS . 15)) (FFTTABLE 22 (
BITS . 15)) (FFTTABLE 23 (BITS . 15)) (FFTTABLE 24 (BITS . 15)) (FFTTABLE 25 (BITS . 15)) (FFTTABLE 26
 (BITS . 15)) (FFTTABLE 27 (BITS . 15)) (FFTTABLE 28 (BITS . 15)) (FFTTABLE 29 (BITS . 15)) (FFTTABLE 
30 (BITS . 15)) (FFTTABLE 31 (BITS . 15)))) (QUOTE 32))
(DECLARE: EVAL@COMPILE 

(RPAQQ \FFTTABLESIZE
 32)

(RPAQQ FFTSSIZE
 2048)

(RPAQQ PI
 3.141593)

(CONSTANTS \FFTTABLESIZE FFTSSIZE PI)
)
(DECLARE: EVAL@COMPILE 
(PUTPROPS FFT.GET.COLUMN MACRO ((BSOURCE BDEST RAWS COLS COLUMN# P) (* JAS "27-Jul-85 21:39") (PROGN (
replace (PILOTBBT PBTSOURCE) of P with BSOURCE) (replace (PILOTBBT PBTDEST) of P with BDEST) (replace 
(PILOTBBT PBTSOURCEBPL) of P with (ITIMES 64 COLS)) (replace (PILOTBBT PBTSOURCEBIT) of P with (ITIMES
 64 COLUMN#)) (replace (PILOTBBT PBTHEIGHT) of P with RAWS) (\PILOTBITBLT P 0))))
(PUTPROPS FFT.PUT.COLUMN MACRO ((BSOURCE BDEST RAWS COLS COLUMN# P) (* JAS "27-Jul-85 21:46") (PROGN (
replace (PILOTBBT PBTSOURCE) of P with BSOURCE) (replace (PILOTBBT PBTDEST) of P with BDEST) (replace 
(PILOTBBT PBTDESTBPL) of P with (ITIMES 64 COLS)) (replace (PILOTBBT PBTDESTBIT) of P with (ITIMES 64 
COLUMN#)) (replace (PILOTBBT PBTHEIGHT) of P with RAWS) (\PILOTBITBLT P 0))))
(PROGN (PUTPROPS FFT.STEP DMACRO ((TABLE) (\BLT \FFTTABLE TABLE \FFTTABLESIZE) (\FFTSTEP \FFTTABLE (
fetch (FFTTABLE LCNT) of TABLE)))) (PUTPROPS FFT.STEP MACRO ((TABLE) (\BLT \FFTTABLE TABLE 
\FFTTABLESIZE) (\FFTSTEP \FFTTABLE (fetch (FFTTABLE LCNT) of TABLE)))))
(PUTPROPS FFTGET MACRO ((V P) (CDR (FASSOC V (GETHASH P (OR FFTREUSETABLE (SETQ FFTREUSETABLE (HARRAY 
10))))))))
(PUTPROPS FFTGETARR MACRO ((ARR XPR PROP) (OR (FFTGET (QUOTE ARR) (OR PROP (QUOTE ALL))) (FFTPUT (
QUOTE ARR) XPR (OR PROP (QUOTE ALL))))))
(PUTPROPS FFTPUT MACRO ((V VAL P) (CDAR (PUTHASH P (CONS (CONS V VAL) (GETHASH P FFTREUSETABLE)) (LIST
 (OR FFTREUSETABLE (SETQ FFTREUSETABLE (HARRAY 10))))))))
(PUTPROPS FFTPUT? MACRO ((V VAL P) (LET ((AL (GETHASH P FFTREUSETABLE)) PAIR) (COND ((SETQ PAIR (
FASSOC V AL)) (RPLACD PAIR VAL)) (T (PUTHASH P (CONS (CONS V VAL) AL) (OR FFTREUSETABLE (SETQ 
FFTREUSETABLE (HARRAY 10)))))))))
(PUTPROPS \NLP2 MACRO (LAMBDA (N) (EXPT 2 (SUB1 (INTEGERLENGTH N)))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS FFTREUSETABLE \SLICE1 \SLICE2)
)

(RPAQQ \SUM-VECTOR
 {}#43,56400)

(RPAQQ FFTREUSETABLE
 NIL)

(RPAQ \SLICE1
 (CFARRAYB FFTSSIZE))

(RPAQ \SLICE2
 (CFARRAYB FFTSSIZE))
(* * FFTs of real vectors (pack in complex format))


(DEFINEQ

(2DXFFT

(LAMBDA (MAT INVFLG) (* JAS " 5-Sep-85 17:32") (* 2DXFFT is a special version of 2DFFT which could be 
used when wants to do FFTs on several real vectors. To make it less costly one could pack two real 
items in one complex, like X+iY. This makes it possible to make two FFT with the cost of one. This 
forces us to do a lot of moving around and some packing/unpacking) (DECLARE (LOCALVARS . T)) (COND ((
FARRAYP MAT 2) (LET ((RAWS (ARRAY-DIMENSION MAT 0)) (COLS (DIV2 (ARRAY-DIMENSION MAT 1))) (WSSIZE (
MUL2 (IMAX (MUL2 (ARRAY-DIMENSION MAT 0)) (ARRAY-DIMENSION MAT 1))))) (LET ((MB (ARRAYBASE MAT)) (TBM 
(CFARRAYB WSSIZE)) (WS1 (CFARRAYB WSSIZE)) (WS2 (CFARRAYB WSSIZE)) (BBTGET (OR (FFTGET (QUOTE 
GETCOLUMNXBBT) (QUOTE ALL)) (FFTPUT (QUOTE GETCOLUMNXBBT) (FFT.GET.COLUMNX.PILOTBBT) (QUOTE ALL)))) (
BBTPUT (OR (FFTGET (QUOTE PUTCOLUMNXBBT) (QUOTE ALL)) (FFTPUT (QUOTE PUTCOLUMNXBBT) (
FFT.PUT.COLUMNX.PILOTBBT) (QUOTE ALL))))) (* We have to do some argument checking since this routine 
could crash the machine if called with wrong arguments) (OR (AND (POWEROFTWOP RAWS) (POWEROFTWOP COLS)
) (ERROR "Illegal argument to 2DXFFT" MAT)) (* All arguments correct, temporaries set up) (\2DXFFT MB 
RAWS COLS TBM WS1 WS2 BBTGET BBTPUT INVFLG)))) (T (ERROR "Illegal argument" MAT)))))

(\2DXFFT

(LAMBDA (MB RAWS COLS TBM WS1 WS2 GBBT PBBT INVFLG) (* JAS " 5-Sep-85 18:39") (* \2DXFFT is a function
 which performs FFT assuming that the array M (pointed at by MB) concists of two real number X and Y 
stored as X+iY) (LET ((SCL (OR (FFTGET (QUOTE SCALE/SIGN) RAWS) (FFTPUT (QUOTE SCALE/SIGN) (
FFT.SCALE/SIGN RAWS) RAWS))) (RAWSM1 (SUB1 RAWS)) (COLSM1 (SUB1 COLS)) (R-RWL (MUL4 COLS)) (R-MIDDLE (
MUL2 COLS)) (R-EOM (MUL4 (SUB1 COLS))) (C-RWL (MUL4 (MUL2 RAWS))) (C-MIDDLE (MUL2 (MUL2 RAWS))) (C-EOM
 (MUL4 (SUB1 (MUL2 RAWS)))) (2RAWS (MUL2 RAWS)) (MBR MB) (COLSD2 (DIV2 COLS))) (COND ((NULL INVFLG) (
for I from 0 to RAWSM1 do (FFTX MBR SCL COLS WS1 R-EOM R-MIDDLE) (SETQ MBR (\ADDBASE MBR R-RWL))) (
FFT.GET.COLUMNX MB WS1 RAWS COLSD2 0 GBBT) (FFT.FR WS1 RAWS WS2) (FFT.FR (\ADDBASE WS1 4) RAWS WS2) (
FFT.PUT.COLUMNX WS1 MB RAWS COLSD2 0 PBBT) (for I from 1 to (SUB1 COLSD2) do (FFT.GET.COLUMNX MB WS2 
RAWS COLSD2 I GBBT) (FFT NIL 0 2RAWS INVFLG WS2) (FFT.PUT.COLUMNX WS2 MB RAWS COLSD2 I PBBT))) (T (
FFT.GET.COLUMNX MB TBM RAWS COLSD2 0 GBBT) (FFT.INVFR TBM RAWS WS2) (FFT.INVFR (\ADDBASE TBM 4) RAWS 
WS2) (FFT.PUT.COLUMNX TBM MB RAWS COLSD2 0 PBBT) (for I from 1 to (SUB1 COLSD2) do (FFT.GET.COLUMNX MB
 TBM RAWS COLSD2 I GBBT) (FFT NIL 0 2RAWS INVFLG TBM) (FFT.PUT.COLUMNX TBM MB RAWS COLSD2 I PBBT)) (
for I from 0 to RAWSM1 do (INVFFTX MBR COLS WS1 WS2) (SETQ MBR (\ADDBASE MBR R-RWL))))))))

(FFT.GET.COLUMNX.PILOTBBT

(LAMBDA (CNT) (* JAS "10-Aug-85 14:40") (create PILOTBBT PBTDESTBIT ← 0 PBTDESTBPL ← 128 PBTWIDTH ← 
128 PBTDISJOINT ← T)))

(FFT.PUT.COLUMNX.PILOTBBT

(LAMBDA (CNT) (* JAS "10-Aug-85 14:42") (create PILOTBBT PBTSOURCEBIT ← 0 PBTSOURCEBPL ← 128 PBTWIDTH 
← 128 PBTDISJOINT ← T)))

(FFT.\DISSEP

(LAMBDA (N B BT1 BT2 SCL) (* JAS " 5-Sep-85 17:29") (* BIN: # (SUMX SYMY DIFFX DIFFY { (N/2-1) REX IMX
 REY IMY }) %. BOUT # (SUMX SYMY { (N/2-1) REX+IMY REY-IMX } DIFFX DIFFY { (N/2-1) IMY-REX IMX+REY }))
 (LET ((ND2-1 (SUB1 (DIV2 N)))) (LET ((DISSEP (OR (FFTGET (QUOTE \DISSEP) ND2-1) (FFT.\DISSEP.INIT 
ND2-1))) (SEP (OR (FFTGET (QUOTE \SEP) ND2-1) (FFT.\SEP.INIT ND2-1))) (ReX BT1) (ImX (\ADDBASE BT1 (
MUL2 ND2-1))) (ReY (\ADDBASE BT1 (MUL4 ND2-1))) (ImY (\ADDBASE BT1 (ITIMES 6 ND2-1))) (DIFFX (
\GETBASEFLOATP B 4)) (DIFFY (\GETBASEFLOATP B 6))) (\BLKPERM (\ADDBASE B 8) DISSEP BT1 (MUL8 ND2-1)) (
\BLKFDIFF ReX ImY BT2 ND2-1) (\BLKFPLUS ReY ImX (\ADDBASE BT2 (MUL2 ND2-1)) ND2-1) (\BLKFPLUS ReX ImY 
(\ADDBASE BT2 (MUL4 ND2-1)) ND2-1) (\BLKFDIFF ReY ImX (\ADDBASE BT2 (ITIMES 6 ND2-1)) ND2-1) (\BLKPERM
 BT2 SEP (\ADDBASE B 4) (IPLUS 4 (MUL8 ND2-1))) (\PUTBASEFLOATP B (MUL2 N) DIFFX) (\PUTBASEFLOATP B (
MUL2 (ADD1 N)) DIFFY) (AND SCL (\BLKFTIMES B SCL B (MUL2 N)))))))

(FFT.\SEP.INIT

(LAMBDA (N) (* raf "27-Sep-85 01:34") (DECLARE (GLOBALVARS FFTREUSETABLE)) (LET ((CPOS 0) (V (
MAKE-ARRAY (IPLUS 4 (MUL8 (ADD1 N))) (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 16)) (QUOTE 
:ALIGNMENT) (IMIN (\NLP2 (MUL4 (ADD1 N))) 128))) (L (LIST (QUOTE (0 2)) (QUOTE (1 2)) (LIST (IPLUS -2 
(MUL4 N)) -2) (LIST (SUB1 (MUL4 N)) -2))) PUTPOS STEP) (for OBJ in L do (SETQ PUTPOS (CAR OBJ)) (SETQ 
STEP (CADR OBJ)) (for J from 1 to N do (ASET CPOS V (MUL2 PUTPOS)) (ASET (ADD1 CPOS) V (ADD1 (MUL2 
PUTPOS))) (SETQ CPOS (IPLUS 2 CPOS)) (SETQ PUTPOS (IPLUS STEP PUTPOS)))) (\BLT (\ADDBASE (ARRAYBASE V)
 (IPLUS 4 (MUL4 N))) (\ADDBASE (ARRAYBASE V) (MUL4 N)) (MUL4 N)) (FFTPUT (QUOTE \SEP) (ARRAYBASE V) N)
)))

(FFT.\DISSEP.INIT

(LAMBDA (N) (* raf "27-Sep-85 01:34") (DECLARE (GLOBALVARS FFTREUSETABLE)) (* Pack Real and imaginary 
parts so it is possible to unpackit with the \BLKSEP operation) (LET ((GL (LIST)) (CPOS 0) (V (
MAKE-ARRAY (MUL8 (ADD1 N)) (QUOTE :ELEMENT-TYPE) (QUOTE (UNSIGNED-BYTE 16)) (QUOTE :ALIGNMENT) (IMIN (
\NLP2 (MUL4 (ADD1 N))) 128))) PUTPOS) (for UPOBJ in (QUOTE (0 2 4 6)) do (SETQ PUTPOS UPOBJ) (for I 
from 1 to N do (ASET PUTPOS V CPOS) (ASET (ADD1 PUTPOS) V (ADD1 CPOS)) (SETQ PUTPOS (IPLUS PUTPOS 8)) 
(SETQ CPOS (IPLUS CPOS 2)))) (FFTPUT (QUOTE \DISSEP) (ARRAYBASE V) N))))

(FFT.FR

(LAMBDA (BPTR N TMP) (* JAS "12-Aug-85 13:39") (* Two vectors u and v are packed as # (u0 u1 v0 v1 u2 
u3 ... uN-1 uN vN-1 vN) %. These vectors are complex and should be expanded to { ui , 0 }, i.e. zero 
complex half. Then we put the result back in the array. As the result is symetric we don't have to 
store the hole result, we only store one half. As this is not enough we have to take care of the 0:th 
and N/2:th number, these are real numbers and we pack them as (u0, uN/2)) (LET ((TMPCOPY TMP) (
BPTRCOPY BPTR) (LSTV (\ADDBASE TMP (MUL4 N))) (SECOND (\ADDBASE BPTR 2))) (\ZEROWORDS TMP (\ADDBASE 
TMP (SUB1 (MUL8 N)))) (for I from 0 to (SUB1 N) do (\BLT TMP BPTR 2) (SETQ TMP (\ADDBASE TMP 4)) (\BLT
 TMP (\ADDBASE BPTR 2) 2) (SETQ BPTR (\ADDBASE BPTR 8)) (SETQ TMP (\ADDBASE TMP 4))) (FFT NIL 0 (MUL2 
N) NIL TMPCOPY) (for I from 0 to (SUB1 N) do (\BLT BPTRCOPY TMPCOPY 4) (SETQ TMPCOPY (\ADDBASE TMPCOPY
 4)) (SETQ BPTRCOPY (\ADDBASE BPTRCOPY 8))) (\PUTBASEFLOATP SECOND 0 (\GETBASEFLOATP LSTV 0)))))

(FFT.INVFR

(LAMBDA (BPTR N TMP) (* JAS "13-Aug-85 12:55") (* This function is intendeed to be the direct inverse 
of the FFT.FR function) (LET ((TMPH (\ADDBASE TMP (MUL4 N))) (DIFF (\GETBASEFLOATP BPTR 2)) (LSTPTR (
\ADDBASE BPTR (MUL8 N)))) (\PUTBASEFLOATP TMPH 0 DIFF) (\PUTBASEFLOATP TMPH 2 0.0) (for I from 0 to (
IDIFFERENCE N 2) do (SETQ LSTPTR (\ADDBASE LSTPTR -8)) (SETQ TMPH (\ADDBASE TMPH 4)) (\PUTBASEFLOATP 
TMPH 0 (\GETBASEFLOATP LSTPTR 0)) (\PUTBASEFLOATP TMPH 2 (FMINUS (\GETBASEFLOATP LSTPTR 2)))) (for I 
from 0 to (SUB1 N) do (\BLT (\ADDBASE TMP (MUL4 I)) (\ADDBASE BPTR (MUL8 I)) 4)) (\PUTBASEFLOATP TMP 2
 0.0) (FFT NIL 0 (MUL2 N) T TMP) (for I from 0 to (SUB1 N) do (\BLT BPTR TMP 2) (SETQ TMP (\ADDBASE 
TMP 4)) (SETQ BPTR (\ADDBASE BPTR 2)) (\BLT BPTR TMP 2) (SETQ TMP (\ADDBASE TMP 4)) (SETQ BPTR (
\ADDBASE BPTR 6))))))

(FFT.SCALE/SIGN

(LAMBDA (R/4) (* JAS "12-Aug-85 19:01") (LET ((V (CFARRAYB (MUL4 R/4))) (R (MUL4 R/4))) (
\PUTBASEFLOATP V (MUL2 (SUB1 R)) -.5) (\PUTBASEFLOATP V (MUL2 (IDIFFERENCE R 2)) .5) (\BLT V (\ADDBASE
 V 4) (MUL2 (IDIFFERENCE R 2))) (\PUTBASEFLOATP V 2 .5) (\PUTBASEFLOATP V 6 .5) V)))

(FFTTEST

(LAMBDA (N M F1) (* raf "27-Sep-85 01:34") (LET ((A1 (MAKE-ARRAY (LIST N M) (QUOTE :ELEMENT-TYPE) (
QUOTE FLOAT) (QUOTE :ALIGNMENT) (IMIN (ITIMES N M) 128))) (A3 (MAKE-ARRAY (LIST (DIV2 N) M) (QUOTE 
:ELEMENT-TYPE) (QUOTE FLOAT) (QUOTE :ALIGNMENT) (IMIN (ITIMES N M) 128)))) (for I from 0 to (SUB1 N) 
do (for J from 0 to (IDIFFERENCE M 2) by 2 do (ASET (FLOAT (APPLY* F1 I J)) A1 I J))) (for I from 0 to
 (SUB1 (DIV2 N)) do (for J from 0 to (SUB1 (DIV2 M)) do (ASET (AREF A1 (MUL2 I) (MUL2 J)) A3 I (MUL2 J
)) (ASET (AREF A1 (ADD1 (MUL2 I)) (MUL2 J)) A3 I (ADD1 (MUL2 J))))) (* 2DFFT A1) (* 2DXFFT A3) (LIST 
A1 A3))))
)
(DECLARE: EVAL@COMPILE 
(PUTPROPS FFT.GET.COLUMNX MACRO ((BSOURCE BDEST RAWS COLS COLUMN# P) (* JAS "27-Jul-85 21:39") (PROGN 
(replace (PILOTBBT PBTSOURCE) of P with BSOURCE) (replace (PILOTBBT PBTDEST) of P with BDEST) (replace
 (PILOTBBT PBTSOURCEBPL) of P with (LLSH COLS 7)) (replace (PILOTBBT PBTSOURCEBIT) of P with (LLSH 
COLUMN# 7)) (replace (PILOTBBT PBTHEIGHT) of P with RAWS) (\PILOTBITBLT P 0))))
(PUTPROPS FFT.PUT.COLUMNX MACRO ((BSOURCE BDEST RAWS COLS COLUMN# P) (* JAS "27-Jul-85 21:46") (PROGN 
(replace (PILOTBBT PBTSOURCE) of P with BSOURCE) (replace (PILOTBBT PBTDEST) of P with BDEST) (replace
 (PILOTBBT PBTDESTBPL) of P with (LLSH COLS 7)) (replace (PILOTBBT PBTDESTBIT) of P with (LLSH COLUMN#
 7)) (replace (PILOTBBT PBTHEIGHT) of P with RAWS) (\PILOTBITBLT P 0))))
(PUTPROPS FFTX MACRO ((MB SCALE/SIGN COLS WS1 EOM MIDDLE) (FFT NIL 0 COLS NIL MB) (\BLKSEP (\ADDBASE 
MB EOM) (\ADDBASE MB 4) (\ADDBASE WS1 8) (SUB1 (DIV2 COLS))) (\BLKFPLUS MB MB WS1 2) (\BLKFPLUS (
\ADDBASE MB MIDDLE) (\ADDBASE MB MIDDLE) (\ADDBASE WS1 4) 2) (\BLKFTIMES WS1 SCALE/SIGN MB (MUL2 COLS)
) (* \BLT MB WS1 RWL)))
(PUTPROPS INVFFTX MACRO ((MB COLS WS1 WS2 SCL) (FFT.\DISSEP COLS MB WS1 WS2 SCL) (FFT NIL 0 COLS T MB)
))
)
(* * Conversion stuff)


(DEFINEQ

(BITMAP-TO-COMPLEX

(LAMBDA (BM ARRAY) (* JAS " 5-Sep-85 17:28") (LET ((H (BITMAPHEIGHT BM)) (W (BITMAPWIDTH BM)) (BPP (
fetch (BITMAP BITMAPBITSPERPIXEL) of BM))) (COND ((NOT (MEMB BPP (QUOTE (1 4 8)))) (ERROR 
"ILLEGAL BIT PER PIXEL: " BPP)) ((NOT (ZEROP (LOGAND (ITIMES BPP W) 15))) (ERROR 
"ILLEGAL BITMAPSIZE: " W))) (MKARRAY? ARRAY (LIST H (MUL2 W))) (LET ((DIMS (LIST H (MUL2 W))) (BBT (
create PILOTBBT PBTSOURCEBPL ← BPP PBTSOURCEBIT ← 0 PBTDESTBPL ← 16 PBTDESTBIT ← (IDIFFERENCE 16 BPP) 
PBTWIDTH ← BPP PBTHEIGHT ← W PBTDISJOINT ← T)) (BA (ARRAYBASE ARRAY)) (RWL (MUL4 W)) (BPL (LRSH (
ITIMES W BPP) 4)) (BMB (fetch (BITMAP BITMAPBASE) of BM))) (OR (EQUAL DIMS (FARRAYP ARRAY)) (ERROR 
"ILLEGAL ARRAY ARGUMENT: " ARRAY)) (\ZEROWORDS BA (\ADDBASE BA (SUB1 (ITIMES 4 H W)))) (for I from 0 
to (SUB1 H) do (replace (PILOTBBT PBTDEST) of BBT with BA) (replace (PILOTBBT PBTSOURCE) of BBT with 
BMB) (\PILOTBITBLT BBT 0) (\BLKSMALLP2FLOAT BA BA W) (\BLKFLOATP2COMP BA BA W) (SETQ BA (\ADDBASE BA 
RWL)) (SETQ BMB (\ADDBASE BMB BPL))))) ARRAY))

(COMPLEX-TO-BITMAP

(LAMBDA (ARRAY BM IMFLG) (* raf "30-Sep-85 14:38") (COND ((NOT (FARRAYP ARRAY 2)) (ERROR 
"Illegal array: " ARRAY))) (LET ((DIMS (ARRAY-DIMENSIONS ARRAY)) (H (ARRAY-DIMENSION ARRAY 0)) (W2 (
ARRAY-DIMENSION ARRAY 1)) (W (DIV2 (ARRAY-DIMENSION ARRAY 1)))) (OR BM (SETQ BM (BITMAPCREATE H W 8)))
 (COND ((NOT (AND (EQ H (BITMAPHEIGHT BM)) (EQ W (BITMAPWIDTH BM)) (EQ 8 (fetch (BITMAP 
BITMAPBITSPERPIXEL) of BM)))) (ERROR "Illegal size of bitmap: " BM)) ((NOT (EVENP W)) (ERROR 
"Complex array width must be divisible by 4 for bitmap conversion" W))) (LET ((BA (\ADDBASE (ARRAYBASE
 ARRAY) (COND (IMFLG 2) (T 0)))) (DATA (CFARRAYB W)) (UNUSED (CFARRAYB W)) (BARW (MUL2 W2)) (BMB (
fetch (BITMAP BITMAPBASE) of BM)) (BMRW (DIV2 W))) (for I from 0 to (SUB1 H) do (\RE/IM-UNPACK BA DATA
 UNUSED W) (\FLOATTOBYTE DATA BMB W) (SETQ BA (\ADDBASE BA BARW)) (SETQ BMB (\ADDBASE BMB BMRW))) BM))
))

(FLOAT-TO-BITMAP

(LAMBDA (ARRAY BM) (* raf "30-Sep-85 14:44") (COND ((NOT (FARRAYP ARRAY 2)) (ERROR "ILLEGAL ARRAY: " 
ARRAY))) (LET ((DIMS (ARRAY-DIMENSIONS ARRAY)) (H (ARRAY-DIMENSION ARRAY 0)) (W (ARRAY-DIMENSION ARRAY
 1))) (OR BM (SETQ BM (BITMAPCREATE H W 8))) (COND ((NOT (AND (EQ (BITMAPHEIGHT BM) H) (EQ (
BITMAPWIDTH BM) W))) (ERROR "Illegal size of bitmap: " BM)) ((NOT (EVENP W)) (ERROR 
"Array width must be even for bitmap conversion" W))) (LET ((BA (ARRAYBASE ARRAY)) (BARW (MUL2 W)) (
BMB (fetch (BITMAP BITMAPBASE) of BM)) (BMRW (DIV2 W))) (for I from 0 to (SUB1 H) do (\FLOATTOBYTE BA 
BMB W) (SETQ BA (\ADDBASE BA BARW)) (SETQ BMB (\ADDBASE BMB BMRW))) BM))))

(BITMAP-TO-FLOAT

(LAMBDA (BM ARRAY) (* JAS " 5-Sep-85 17:26") (LET ((H (BITMAPHEIGHT BM)) (W (BITMAPWIDTH BM)) (BPP (
fetch (BITMAP BITMAPBITSPERPIXEL) of BM))) (COND ((NOT (MEMB BPP (QUOTE (1 4 8)))) (ERROR 
"Illegal bit per pixel: " BPP)) ((NOT (ZEROP (LOGAND (ITIMES BPP W) 15))) (ERROR 
"Illegal bitmapsize: " W))) (MKARRAY? ARRAY (LIST H W)) (LET ((DIMS (LIST H W)) (BBT (create PILOTBBT 
PBTSOURCEBPL ← BPP PBTSOURCEBIT ← 0 PBTDESTBPL ← 16 PBTDESTBIT ← (IDIFFERENCE 16 BPP) PBTWIDTH ← BPP 
PBTHEIGHT ← W PBTDISJOINT ← T)) (BA (ARRAYBASE ARRAY)) (RWL (MUL2 W)) (BPL (LRSH (ITIMES W BPP) 4)) (
BMB (fetch (BITMAP BITMAPBASE) of BM))) (OR (EQUAL DIMS (FARRAYP ARRAY)) (ERROR 
"Illegal array argument: " ARRAY)) (\ZEROWORDS BA (\ADDBASE BA (SUB1 (ITIMES 4 H W)))) (for I from 0 
to (SUB1 H) do (replace (PILOTBBT PBTDEST) of BBT with BA) (replace (PILOTBBT PBTSOURCE) of BBT with 
BMB) (\PILOTBITBLT BBT 0) (\BLKSMALLP2FLOAT BA BA W) (SETQ BA (\ADDBASE BA RWL)) (SETQ BMB (\ADDBASE 
BMB BPL))))) ARRAY))

(BITMAP-TO-XCOMPLEX

(LAMBDA (BM ARRAY) (* JAS " 5-Sep-85 17:27") (LET ((H (BITMAPHEIGHT BM)) (W (BITMAPWIDTH BM)) (BPP (
fetch (BITMAP BITMAPBITSPERPIXEL) of BM))) (COND ((NOT (MEMB BPP (QUOTE (1 4 8)))) (ERROR 
"Illegal bit per pixel: " BPP)) ((NOT (ZEROP (LOGAND (ITIMES BPP W) 15))) (ERROR 
"Illegal bitmapwidth: " W))) (MKARRAY? ARRAY (LIST (DIV2 H) (MUL2 W))) (LET ((DIMS (LIST (DIV2 H) (
MUL2 W))) (BBT (create PILOTBBT PBTSOURCEBPL ← BPP PBTSOURCEBIT ← 0 PBTDESTBPL ← 16 PBTDESTBIT ← (
IDIFFERENCE 16 BPP) PBTWIDTH ← BPP PBTHEIGHT ← W PBTDISJOINT ← T)) (BA (ARRAYBASE ARRAY)) (IX (
CSARRAYB W)) (X (CFARRAYB W)) (IY (CSARRAYB W)) (Y (CFARRAYB W)) (RWL (MUL4 W)) (BPL (LRSH (ITIMES W 
BPP) 4)) (BMB (fetch (BITMAP BITMAPBASE) of BM))) (OR (EQUAL DIMS (FARRAYP ARRAY)) (ERROR 
"Illegal array argument: " ARRAY)) (for I from 0 to (SUB1 (DIV2 H)) do (replace (PILOTBBT PBTDEST) of 
BBT with IX) (replace (PILOTBBT PBTSOURCE) of BBT with BMB) (SETQ BMB (\ADDBASE BMB BPL)) (
\PILOTBITBLT BBT 0) (\BLKSMALLP2FLOAT IX X W) (replace (PILOTBBT PBTDEST) of BBT with IY) (replace (
PILOTBBT PBTSOURCE) of BBT with BMB) (SETQ BMB (\ADDBASE BMB BPL)) (\PILOTBITBLT BBT 0) (
\BLKSMALLP2FLOAT IY Y W) (\RE/IM-PACK X Y BA W) (SETQ BA (\ADDBASE BA RWL))))) ARRAY))

(XCOMPLEX-TO-BITMAP

(LAMBDA (ARRAY BM) (* raf "30-Sep-85 14:38") (COND ((NOT (FARRAYP ARRAY 2)) (ERROR "ILLEGAL ARRAY: " 
ARRAY))) (LET ((DIMS (ARRAY-DIMENSIONS ARRAY)) (HD2 (ARRAY-DIMENSION ARRAY 0)) (W2 (ARRAY-DIMENSION 
ARRAY 1)) (H (MUL2 (ARRAY-DIMENSION ARRAY 0))) (W (DIV2 (ARRAY-DIMENSION ARRAY 1)))) (OR BM (SETQ BM (
BITMAPCREATE H W 8))) (COND ((NOT (AND (EQ (BITMAPHEIGHT BM) H) (EQ (BITMAPWIDTH BM) W) (EQ (fetch (
BITMAP BITMAPBITSPERPIXEL) of BM) 8))) (ERROR "Illegal size or bits per pixel bitmap: " BM)) ((NOT (
EVENP W)) (ERROR "Complex array width must be divisible by 4 for bitmap conversion" W))) (LET ((BA (
ARRAYBASE ARRAY)) (DATAX (CFARRAYB W)) (DATAY (CFARRAYB W)) (BARW (MUL2 W2)) (BMB (fetch (BITMAP 
BITMAPBASE) of BM)) (BMRW (DIV2 W))) (for I from 0 to (SUB1 HD2) do (\RE/IM-UNPACK BA DATAX DATAY W) (
\FLOATTOBYTE DATAX BMB W) (SETQ BMB (\ADDBASE BMB BMRW)) (\FLOATTOBYTE DATAY BMB W) (SETQ BMB (
\ADDBASE BMB BMRW)) (SETQ BA (\ADDBASE BA BARW))) BM))))

(COMPLEX-TO-FLOAT

(LAMBDA (CARR FARR IMFLG) (* JAS " 2-Sep-85 18:17") (COND ((NOT (FARRAYP CARR 2)) (ERROR 
"Illegal array: " CARR))) (LET ((DIMS (ARRAY-DIMENSIONS CARR)) (H (ARRAY-DIMENSION CARR 0)) (W2 (
ARRAY-DIMENSION CARR 1)) (W (DIV2 (ARRAY-DIMENSION CARR 1)))) (MKARRAY? FARR (LIST H W)) (COND ((NOT (
FARRAYP FARR (LIST H W))) (ERROR "Illegal result dimensions" FARR))) (LET ((BA (\ADDBASE (ARRAYBASE 
CARR) (COND (IMFLG 2) (T 0)))) (BFA (ARRAYBASE FARR)) (UNUSED (CFARRAYB W)) (BARW (MUL2 W2))) (for I 
from 0 to (SUB1 H) do (\RE/IM-UNPACK BA BFA UNUSED W) (SETQ BA (\ADDBASE BA BARW)) (SETQ BFA (\ADDBASE
 BFA W2))) FARR))))

(FLOAT-TO-COMPLEX

(LAMBDA (RE IM CARR) (* JAS " 2-Sep-85 18:15") (COND ((NOT (AND (FARRAYP RE 2) (EQUAL (
ARRAY-DIMENSIONS RE) (FARRAYP IM)))) (ERROR "Illegal array arguments"))) (LET ((H (ARRAY-DIMENSION RE 
0)) (W (ARRAY-DIMENSION RE 1)) (W2 (MUL2 (ARRAY-DIMENSION RE 1)))) (MKARRAY? CARR (LIST H W2)) (COND (
(NOT (FARRAYP CARR (LIST H W2))) (ERROR "Illegal result dimensions" CARR))) (LET ((BA (ARRAYBASE CARR)
) (X (ARRAYBASE RE)) (Y (ARRAYBASE IM)) (BARW (MUL2 W2))) (for I from 0 to (SUB1 H) do (\RE/IM-PACK X 
Y BA W) (SETQ BA (\ADDBASE BA BARW)) (SETQ X (\ADDBASE X W2)) (SETQ Y (\ADDBASE Y W2))) CARR))))
)
(* * 2D versions)


(DEFINEQ

(2DCTIMES

(LAMBDA (M1 M2 M3) (* kbr: "15-Aug-85 21:55") (* We use the fact that the raws are stored sequencally.
 I.e. we treat the array as one long vector. We iterate over the vector in slices (slice length 
depends on the constant FFTSSIZE) %. In each slice we separate the real and imaginary half and perform
 (xr*yr-xi*yi) and (xr*yi-yr*xi)) (DECLARE (LOCALVARS . T)) (LET ((DM1 (2DFMATP M1)) (DM2 (2DFMATP M2)
) (DM3 (2DFMATP (OR M3 M1))) (M3 (OR M3 M1))) (COND ((NOT DM1) (ERROR "Illegal array: " M1)) ((NOT DM2
) (ERROR "Illegal array: " M2)) ((NOT DM3) (ERROR "Illegal array: " M3)) ((NOT (AND (EQUAL DM1 DM2) (
EQUAL DM2 DM3))) (ERROR "All arrays have to have the same sizes"))) (LET ((TOTSIZE (DIV2 (
ARRAY-TOTAL-SIZE M1))) (BM1 (ARRAYBASE M1)) (BM2 (ARRAYBASE M2)) (BM3 (ARRAYBASE M3)) (XR (FFTGETARR 
XR (CFARRAYB FFTSSIZE))) (XI (FFTGETARR XI (CFARRAYB FFTSSIZE))) (YR (FFTGETARR YR (CFARRAYB FFTSSIZE)
)) (YI (FFTGETARR YI (CFARRAYB FFTSSIZE))) (ZR (FFTGETARR ZR (CFARRAYB FFTSSIZE))) (ZI (FFTGETARR ZI (
CFARRAYB FFTSSIZE))) (BASESTEP (MUL4 FFTSSIZE)) TS) (while (GREATERP TOTSIZE 0) do (SETQ TS (IMIN 
TOTSIZE FFTSSIZE)) (\RE/IM-UNPACK BM1 XR XI TS) (\RE/IM-UNPACK BM2 YR YI TS) (\BLKFTIMES XR YR ZR TS) 
(\BLKFTIMES XR YI ZI TS) (\BLKFTIMES XI YI XR TS) (\BLKFDIFF ZR XR ZR TS) (\BLKFTIMES XI YR XI TS) (
\BLKFPLUS XI ZI ZI TS) (\RE/IM-PACK ZR ZI BM3 TS) (SETQ BM1 (\ADDBASE BM1 BASESTEP)) (SETQ BM2 (
\ADDBASE BM2 BASESTEP)) (SETQ BM3 (\ADDBASE BM3 BASESTEP)) (SETQ TOTSIZE (IDIFFERENCE TOTSIZE TS))) M3
))))

(2DCXTIMES

(LAMBDA (M1 M2 M3) (* JAS "27-Aug-85 15:17") (* We use the fact that the raws are stored sequencally. 
I.e. we treat the array as one long vector. We iterate over the vector in slices (slice length depends
 on the constant FFTSSIZE) %. In each slice we separate the real and imaginary half and perform (
xr*yr-xi*yi) and (xr*yi-yr*xi)) (DECLARE (LOCALVARS . T)) (LET ((DM1 (2DFMATP M1)) (DM2 (2DFMATP M2)) 
(DM3 (2DFMATP (OR M3 M1))) (M3 (OR M3 M1))) (COND ((NOT DM1) (ERROR "Illegal array: " M1)) ((NOT DM2) 
(ERROR "Illegal array: " M2)) ((NOT DM3) (ERROR "Illegal array: " M3)) ((NOT (AND (EQUAL DM1 DM2) (
EQUAL DM2 DM3))) (ERROR "All arrays have to have the same sizes"))) (LET ((TMP1 (CFARRAYB 4)) (TMP2 (
CFARRAYB 4))) (\BLT TMP1 (ARRAYBASE M1) 8) (\BLT TMP2 (ARRAYBASE M2) 8) (2DCTIMES M1 M2 M3) (
\BLKFTIMES TMP1 TMP2 (ARRAYBASE M3) 4)))))

(2DFFT

(LAMBDA (MAT INVFLG) (* JAS " 5-Sep-85 17:23") (* 2DFFT is performed by taking one dimesional FFTs on 
each raw of M thereafter take one dimensional FFTs on each column. 2DFFT only works on Cmlarrays. M is
 considered to be a complex array. I.e. every two following floating point numbers are considered to 
be a complex number. A complex number is 64 bits, a FLOAT 32 bits) (DECLARE (LOCALVARS . T)) (COND ((
AND (TYPENAMEP MAT (QUOTE ARRAY)) (EQ 2 (ARRAY-RANK MAT))) (LET ((RAWS (ARRAY-DIMENSION MAT 0)) (COLS 
(DIV2 (ARRAY-DIMENSION MAT 1)))) (LET ((MB (ARRAYBASE MAT)) (MBR (ARRAYBASE MAT)) (RWL (MUL4 COLS)) (
BTMPA (CFARRAYB (MUL2 RAWS))) (RAWSM1 (SUB1 RAWS)) (BBTGET (OR (FFTGET (QUOTE GETCOLUMNBBT) (QUOTE ALL
)) (FFTPUT (QUOTE GETCOLUMNBBT) (FFT.GET.COLUMN.PILOTBBT) (QUOTE ALL)))) (BBTPUT (OR (FFTGET (QUOTE 
PUTCOLUMNBBT) (QUOTE ALL)) (FFTPUT (QUOTE PUTCOLUMNBBT) (FFT.PUT.COLUMN.PILOTBBT) (QUOTE ALL))))) (* 
We have to do some argument checking since this routine could crash the machine if called with wrong 
arguments) (OR (AND (EQ (QUOTE SINGLE-FLOAT) (ARRAY-ELEMENT-TYPE MAT)) (POWEROFTWOP RAWS) (POWEROFTWOP
 COLS)) (ERROR "Illegal argument to 2DFFT" MAT)) (* We start with FFTs on each raw) (for I from 0 to 
RAWSM1 do (FFT NIL 0 COLS INVFLG MBR) (SETQ MBR (\ADDBASE MBR RWL))) (* Ok, extract on column and take
 FFT on it and put it back in the array) (for I from 0 to (SUB1 COLS) do (FFT.GET.COLUMN MB BTMPA RAWS
 COLS I BBTGET) (FFT NIL 0 COLS INVFLG BTMPA) (FFT.PUT.COLUMN BTMPA MB RAWS COLS I BBTPUT))))) (T (
ERROR "Illegal argument" MAT)))))

(2DMMUL

(LAMBDA (X Y Z) (* JAS " 3-Sep-85 11:08") (LET ((XDIM (FARRAYP X 2)) (YDIM (FARRAYP Y 2))) (COND ((AND
 XDIM YDIM (EQ (CADR XDIM) (CAR YDIM))) (LET ((ZDIM (LIST (CAR XDIM) (CADR YDIM)))) (MKARRAY? Z ZDIM) 
(COND ((NOT (EQUAL (FARRAYP Z) ZDIM)) (ERROR "ILLEGAL ARGUMENTS"))) (LET ((XB (ARRAYBASE X)) (YB (
ARRAYBASE Y)) (ZB (ARRAYBASE Z)) (XRLW (MUL2 (CADR XDIM))) (CNT (CAR YDIM)) (RAWS (CAR ZDIM)) (COLS (
CADR ZDIM)) (TMPB (CFARRAYB (CAR YDIM)))) (LET ((GBBT (GET.COLUMN.BBT YB TMPB (CAR YDIM) (CADR YDIM) 
32)) SUM) (for I from 0 to (SUB1 RAWS) do (for J from 0 to (SUB1 COLS) do (replace (PILOTBBT 
PBTSOURCEBIT) of GBBT with (ITIMES 32 J)) (\PILOTBITBLT GBBT 0) (\BLKFTIMES TMPB XB TMPB CNT) (
\PUTBASEFLOATP ZB 0 (\POLYNOM 1.0 TMPB (SUB1 CNT))) (SETQ ZB (\ADDBASE ZB 2))) (SETQ XB (\ADDBASE XB 
XRLW))))))) (T (ERROR "ILLEGAL ARGUMENTS")))) Z))

(2DTRANS

(LAMBDA (S D) (* JAS "30-Jul-85 18:04") (PROG ((SD (FARRAYP S 2))) (COND ((NULL SD) (ERROR 
"ILLEGAL ARRAY: " S)) ((NEQ (CAR SD) (CADR SD)) (RETURN (2DTRANS-1 S D)))) (MKARRAY? D (REVERSE SD)) (
COND ((NOT (EQUAL (REVERSE SD) (FARRAYP D))) (ERROR "ILLEGAL ARRAY: " D))) (LET ((SB (ARRAYBASE S)) (
DB (ARRAYBASE D)) (RWL (MUL2 (ARRAY-DIMENSION S 0))) (S1RAWS (SUB1 (CAR SD))) (S1COLS (SUB1 (CADR SD))
) (HEIGHT (CAR SD)) (BPL (ITIMES 32 (CAR SD))) BBT I32) (SETQ BBT (GET.COLUMN.BBT SB DB (ADD1 S1RAWS) 
(ADD1 S1COLS) 32)) (for I from 0 to S1COLS do (replace (PILOTBBT PBTSOURCE) of BBT with SB) (replace (
PILOTBBT PBTSOURCEBPL) of BBT with BPL) (replace (PILOTBBT PBTSOURCEBIT) of BBT with (SETQ I32 (LLSH I
 5))) (replace (PILOTBBT PBTHEIGHT) of BBT with HEIGHT) (replace (PILOTBBT PBTDESTBPL) of BBT with 32)
 (replace (PILOTBBT PBTDESTBIT) of BBT with 0) (replace (PILOTBBT PBTDEST) of BBT with (\ADDBASE DB (
MUL2 I))) (\PILOTBITBLT BBT 0) (replace (PILOTBBT PBTSOURCE) of BBT with (\ADDBASE SB (MUL2 I))) (
replace (PILOTBBT PBTSOURCEBPL) of BBT with 32) (replace (PILOTBBT PBTSOURCEBIT) of BBT with 0) (
replace (PILOTBBT PBTDEST) of BBT with DB) (replace (PILOTBBT PBTDESTBIT) of BBT with I32) (replace (
PILOTBBT PBTDESTBPL) of BBT with BPL) (\PILOTBITBLT BBT 0) (SETQ SB (\ADDBASE SB RWL)) (SETQ DB (
\ADDBASE DB RWL)) (SETQ HEIGHT (SUB1 HEIGHT)))) (RETURN D))))

(2DTRANS-1

(LAMBDA (S D) (* JAS "30-Jul-85 18:14") (LET ((SD (FARRAYP S 2))) (MKARRAY? D (REVERSE SD)) (COND ((EQ
 D S) (ERROR "ARRAYS MUST BE DIFFERENT" S))) (COND ((NOT (EQUAL (REVERSE SD) (FARRAYP D))) (ERROR 
"ILLEGAL ARRAY: " D))) (LET ((SB (ARRAYBASE S)) (DB (ARRAYBASE D)) (RWL (MUL2 (ARRAY-DIMENSION S 0))) 
(S1COLS (SUB1 (CADR SD))) GBBT) (SETQ GBBT (GET.COLUMN.BBT SB DB (CAR SD) (CADR SD) 32)) (for I from 0
 to S1COLS do (replace (PILOTBBT PBTSOURCEBIT) of GBBT with (ITIMES I 32)) (replace (PILOTBBT PBTDEST)
 of GBBT with DB) (\PILOTBITBLT GBBT 0) (SETQ DB (\ADDBASE DB RWL)))) D)))
)
(DECLARE: EVAL@COMPILE 
(PUTPROPS 2DFMATP MACRO ((M) (AND (TYPENAMEP M (QUOTE ARRAY)) (EQ (ARRAY-RANK M) 2) (EQ (
ARRAY-ELEMENT-TYPE M) (QUOTE SINGLE-FLOAT)) (ARRAY-DIMENSIONS M))))
)
(* * Misc.)


(DEFINEQ

(\RE/IM-PACK

(LAMBDA (BR BI BA CNT) (* JAS " 6-Sep-85 16:40") (LET ((SIZW (MUL4 CNT)) (SIZF (MUL2 CNT)) (SHFFLE (
FFTGET (QUOTE PACK) CNT)) (TMP (FFTGET (QUOTE TMP) CNT)) I2 I4) (COND ((NULL SHFFLE) (SETQ SHFFLE (
CSARRAYB SIZW)) (SETQ TMP (CFARRAYB SIZF)) (for I from 0 to (SUB1 CNT) do (SETQ I4 (LLSH I 2)) (SETQ 
I2 (LLSH I 1)) (\PUTBASE SHFFLE I4 I2) (\PUTBASE SHFFLE (ADD1 I4) (ADD1 I2)) (\PUTBASE SHFFLE (IPLUS 
I4 2) (IPLUS I2 SIZF)) (\PUTBASE SHFFLE (IPLUS I4 3) (IPLUS I2 SIZF 1))) (FFTPUT (QUOTE PACK) SHFFLE 
CNT) (FFTPUT (QUOTE TMP) TMP CNT))) (\BLT TMP BR SIZF) (\BLT (\ADDBASE TMP SIZF) BI SIZF) (\BLKPERM 
TMP SHFFLE BA SIZW))))

(\RE/IM-UNPACK

(LAMBDA (BA BR BI CNT) (* JAS " 6-Sep-85 16:39") (LET ((BRS (FFTGET (QUOTE RESEP) CNT)) (BIS (FFTGET (
QUOTE IMSEP) CNT)) (SIZW (MUL4 CNT)) (SIZF (MUL2 CNT)) I4 I2) (COND ((NULL BRS) (SETQ BRS (CSARRAYB 
SIZF)) (SETQ BIS (CSARRAYB SIZF)) (for I from 0 to (SUB1 CNT) do (\PUTBASE BRS (SETQ I2 (IPLUS I I)) (
SETQ I4 (IPLUS I2 I2))) (\PUTBASE BRS (ADD1 I2) (IPLUS I4 1)) (\PUTBASE BIS I2 (IPLUS I4 2)) (\PUTBASE
 BIS (ADD1 I2) (IPLUS I4 3))) (FFTPUT (QUOTE RESEP) BRS CNT) (FFTPUT (QUOTE IMSEP) BIS CNT))) (
\BLKPERM BA BRS BR SIZF) (\BLKPERM BA BIS BI SIZF))))

(GET.COLUMN.BBT

(LAMBDA (BSOURCE BDEST RAWS COLS BPE) (* JAS "30-Jul-85 15:37") (OR BPE (SETQ BPE 32)) (LET ((P (
create PILOTBBT PBTSOURCEBPL ← (ITIMES BPE COLS) PBTSOURCEBIT ← 0 PBTDESTBIT ← 0 PBTDESTBPL ← BPE 
PBTWIDTH ← BPE PBTHEIGHT ← RAWS PBTDISJOINT ← T))) (replace (PILOTBBT PBTSOURCE) of P with BSOURCE) (
replace (PILOTBBT PBTDEST) of P with BDEST) P)))

(PUT.COLUMN.BBT

(LAMBDA (BSOURCE BDEST RAWS COLS BPE) (* JAS "30-Jul-85 15:37") (OR BPE (SETQ BPE 32)) (LET ((P (
create PILOTBBT PBTSOURCEBPL ← BPE PBTSOURCEBIT ← 0 PBTDESTBIT ← 0 PBTDESTBPL ← (ITIMES BPE COLS) 
PBTWIDTH ← BPE PBTHEIGHT ← RAWS PBTDISJOINT ← T))) (replace (PILOTBBT PBTSOURCE) of P with BSOURCE) (
replace (PILOTBBT PBTDEST) of P with BDEST) P)))

(ZEROARRAY

(LAMBDA (ARR) (AND (FARRAYP ARR) (\ZEROWORDS (ARRAYBASE ARR) (\ADDBASE (ARRAYBASE ARR) (SUB1 (MUL2 (
ARRAY-TOTAL-SIZE ARR))))))))

(\NLP2

(LAMBDA (N) (* JAS "11-Sep-85 10:49") (EXPT 2 (SUB1 (INTEGERLENGTH N)))))

(ARRAYBASE

(LAMBDA (ARRAY) (* JAS "29-Jul-85 14:45") (COND ((ARRAYP ARRAY) (fetch (ARRAYP BASE) of ARRAY)) (T (
fetch (ARRAY BASE) of ARRAY)))))

(CHIPTEST

(LAMBDA NIL (LET ((X 1.0E-34) (Y .00005) A B) (SETQ A (ARRAY 10 (QUOTE FLOATP) X 0 8)) (SETQ B (ARRAY 
10 (QUOTE FLOATP) Y 0 8)) (\BLKFTIMES (\GETBASEPTR A 0) (\GETBASEPTR B 0) (\GETBASEPTR A 0) 10) (if (
GREATERP (ELT A 0) 1.0) then (PRINTOUT NIL .TAB0 0 "Chip is not ok" T) else (PRINTOUT NIL .TAB0 0 
"Chip is ok")))))
)
(DECLARE: EVAL@COMPILE 
(PUTPROPS DIV4 MACRO ((X) (LRSH X 2)))
(PUTPROPS DIV2 MACRO ((X) (LRSH X 1)))
(PUTPROPS MUL2 MACRO ((X) (IPLUS X X)))
(PUTPROPS MUL4 MACRO ((X) (LLSH X 2)))
(PUTPROPS MUL8 MACRO ((X) (LLSH X 3)))
)
(* * UFNs)


(DEFINEQ

(\FLOATBLT

(LAMBDA (SOURCE1 SOURCE2 DEST N OPERATION) (* lmm "27-Mar-85 08:12") (for I from 0 to (PLUS N N) by 2 
do (\PUTBASEFLOATP DEST I (SELECTQ OPERATION (0 (FLOATWRAP (\GETBASEFLOATP SOURCE1 I))) (1 (
FLOATUNWRAP (\GETBASEFLOATP SOURCE1 I))) (2 (FLOAT (\GETBASEFIXP SOURCE1 I))) (3 (\PUTBASEFIXP DEST I 
(FIX (\GETBASEFLOATP SOURCE1 I))) (GO $$ITERATE)) (4 (FPLUS (\GETBASEFLOATP SOURCE1 I) (\GETBASEFLOATP
 SOURCE2 I))) (5 (FDIFFERENCE (\GETBASEFLOATP SOURCE1 I) (\GETBASEFLOATP SOURCE2 I))) (6 (FDIFFERENCE 
(\GETBASEFLOATP SOURCE2 I) (\GETBASEFLOATP SOURCE1 I))) (7 (FPLUS (ABS (\GETBASEFLOATP SOURCE1 I)) (
ABS (\GETBASEFLOATP SOURCE2 I)))) (8 (ABS (FDIFFERENCE (\GETBASEFLOATP SOURCE1 I) (\GETBASEFLOATP 
SOURCE2 I)))) (9 (ABS (FPLUS (\GETBASEFLOATP SOURCE1 I) (\GETBASEFLOATP SOURCE2 I)))) (16 (FTIMES (
\GETBASEFLOATP SOURCE1 I) (\GETBASEFLOATP SOURCE2 I))) (SHOULDNT))))))
)

(PUTPROPS \FLOATBLT DOPVAL
 (5 FLOATBLT))

(PUTPROPS \BLKFABSMAX DOPVAL
 (3 MISC3 6))

(PUTPROPS \BLKFABSMIN DOPVAL
 (3 MISC3 7))

(PUTPROPS \BLKFMAX DOPVAL
 (3 MISC3 4))

(PUTPROPS \BLKFMIN DOPVAL
 (3 MISC3 5))

(PUTPROPS \FFTSTEP DOPVAL
 (2 FFTSTEP))

(PUTPROPS \FLOATTOBYTE DOPVAL
 (3 MISC3 8))
(* * For convenience)



(PUTPROPS FFT ARGNAMES
 (ARRAY STARTPOSITION LENGTH INVERSEFLAG \BASPTR))

(PUTPROPS MAPARRAY ARGNAMES
 (Result Mapfn Array1 Array2 ... ArrayN))

(PUTPROPS \BLKEXPONENT ARGNAMES
 (source destination kount))

(PUTPROPS \BLKFDIFF ARGNAMES
 (source1 source2 dest kount))

(PUTPROPS \BLKFLOATP2COMP ARGNAMES
 (source destination kount))

(PUTPROPS \BLKFPLUS ARGNAMES
 (source1 source2 dest kount))

(PUTPROPS \BLKFTIMES ARGNAMES
 (source1 source2 dest kount))

(PUTPROPS \BLKMAG ARGNAMES
 (complexArray magnitudeArray kount))

(PUTPROPS \BLKPERM ARGNAMES
 (orig permutations destination kount))

(PUTPROPS \BLKSEP ARGNAMES
 (source1 source2 dest kount))

(PUTPROPS \BLKSMALLP2FLOAT ARGNAMES
 (source destination kount))

(PUTPROPS \FLOATTOBYTE ARGNAMES
 (Source Dest CNT))

(PUTPROPS \BLKFMAX ARGNAMES
 (Base Zero Cnt))

(PUTPROPS \BLKFMIN ARGNAMES
 (Source Zero Cnt))

(PUTPROPS \BLKFABSMAX ARGNAMES
 (Base Zero Cnt))

(PUTPROPS \BLKFABSMIN ARGNAMES
 (Base Zero Cnt))

(PUTPROPS \IBLT1 ARGNAMES
 (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth 
Kount))

(PUTPROPS \IBLT2 ARGNAMES
 (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth 
Kount))
(DEFINEQ

(\BLKEXPONENT

(LAMBDA (S D C) (\BLKEXPONENT S D C)))

(\BLKFDIFF

(LAMBDA (A B C S) (\BLKFDIFF A B C S)))

(\BLKFLOATP2COMP

(LAMBDA (S D C) (\BLKFLOATP2COMP S D C)))

(\BLKFPLUS

(LAMBDA (A B C S) (\BLKFPLUS A B C S)))

(\BLKFTIMES

(LAMBDA (A B C D) (\BLKFTIMES A B C D)))

(\BLKMAG

(LAMBDA (CA SQRMA C) (\BLKMAG CA SQRMA C)))

(\BLKPERM

(LAMBDA (A B C D) (\BLKPERM A B C D)))

(\BLKSEP

(LAMBDA (S1 S2 D C) (\BLKSEP S1 S2 D C)))

(\BLKSMALLP2FLOAT

(LAMBDA (S D C) (\BLKSMALLP2FLOAT S D C)))

(\BLKFMAX

(LAMBDA (Source ZERO CNT) (\BLKFMAX Source ZERO CNT)))

(\BLKFMIN

(LAMBDA (Source ZERO CNT) (\BLKFMIN Source ZERO CNT)))

(\BLKFABSMAX

(LAMBDA (Source ZERO CNT) (\BLKFABSMAX Source ZERO CNT)))

(\BLKFABSMIN

(LAMBDA (Source ZERO CNT) (\BLKFABSMIN Source ZERO CNT)))

(\FLOATTOBYTE

(LAMBDA (Source Dest CNT) (* JAS " 2-Sep-85 13:49") (\FLOATTOBYTE Source Dest CNT)))

(\PILOTBITBLT

(LAMBDA (A B) (\PILOTBITBLT A B)))

(POLYNOM

(LAMBDA (X COEFF DEGREE) (* JAS " 3-Sep-85 08:58") (POLYNOM X COEFF DEGREE)))

(\POLYNOM

(LAMBDA (X BASE SIZE) (* JAS " 3-Sep-85 08:58") (\POLYNOM X BASE SIZE)))
)
(DECLARE: EVAL@COMPILE 
(PUTPROPS \POLYNOM DMACRO ((X BASE SIZE) (* execute the POLYEVAL opcode on the value X, the array 
COEFFS with degree DEGREE) (\FLOATBOX ((OPCODES UBFLOAT3 0) (\FLOATUNBOX X) BASE SIZE))))
(PUTPROPS ARRAYHIELT MACRO ((ARRAY) (IPLUS (ARRAYSIZE ARRAY) (SUB1 (ARRAYORIG ARRAY)))))
(PUTPROPS DOUBLE MACRO ((A) (LLSH A 1)))
(PUTPROPS QUADRUPLE MACRO ((A) (LLSH A 2)))
)
(DEFINEQ

(ARRAYBASE

(LAMBDA (ARRAY) (* JAS "29-Jul-85 14:45") (COND ((ARRAYP ARRAY) (fetch (ARRAYP BASE) of ARRAY)) (T (
fetch (ARRAY BASE) of ARRAY)))))
)

(PUTPROPS FARRAYP PUTPROPS
 FARRAYP)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 MAPARRAY)
)
(PUTPROPS CMLFLOATARRAY COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2775 7623 (MAPARRAY 2785 . 3966) (MAPARRAY1 3968 . 5737) (MAPARRAY2 5739 . 7621)) (9006
 14892 (ARRAY-COPY 9016 . 9466) (ARRAY-POWER 9468 . 9840) (ARRAY-SET 9842 . 10105) (MAXARR 10107 . 
10233) (MINARR 10235 . 10361) (MAXABSARR 10363 . 10492) (MINABSARR 10494 . 10629) (MULARR 10631 . 
11389) (ADDARR 11391 . 12148) (WHERE-MINABSARR 12150 . 12483) (WHERE-MINARR 12485 . 12807) (
WHERE-MAXABSARR 12809 . 13145) (WHERE-MAXARR 13147 . 13472) (SUMARR 13474 . 13684) (FABS-LESSP 13686
 . 13769) (FABS-GREATERP 13771 . 13860) (FABSMIN 13862 . 13941) (FABSMAX 13943 . 14022) (MAKE-INDEX 
14024 . 14385) (\SUM-VECTOR 14387 . 14890)) (16898 23965 (FFT 16908 . 19426) (FFT.GET.COLUMN.PILOTBBT 
19428 . 19578) (FFT.INIT 19580 . 20631) (FFT.PERMUTATE 20633 . 21149) (FFT.PUT.COLUMN.PILOTBBT 21151
 . 21305) (FFT.RADARS 21307 . 21924) (FFT.TABLE.INIT 21926 . 22966) (FFTSTEP 22968 . 23125) (\FFTSTEP 
23127 . 23963)) (27845 36018 (2DXFFT 27855 . 29150) (\2DXFFT 29152 . 30571) (FFT.GET.COLUMNX.PILOTBBT 
30573 . 30726) (FFT.PUT.COLUMNX.PILOTBBT 30728 . 30885) (FFT.\DISSEP 30887 . 31882) (FFT.\SEP.INIT 
31884 . 32607) (FFT.\DISSEP.INIT 32609 . 33209) (FFT.FR 33211 . 34233) (FFT.INVFR 34235 . 35083) (
FFT.SCALE/SIGN 35085 . 35382) (FFTTEST 35384 . 36016)) (37275 44453 (BITMAP-TO-COMPLEX 37285 . 38336) 
(COMPLEX-TO-BITMAP 38338 . 39248) (FLOAT-TO-BITMAP 39250 . 39932) (BITMAP-TO-FLOAT 39934 . 40943) (
BITMAP-TO-XCOMPLEX 40945 . 42203) (XCOMPLEX-TO-BITMAP 42205 . 43191) (COMPLEX-TO-FLOAT 43193 . 43831) 
(FLOAT-TO-COMPLEX 43833 . 44451)) (44478 51319 (2DCTIMES 44488 . 46019) (2DCXTIMES 46021 . 46884) (
2DFFT 46886 . 48464) (2DMMUL 48466 . 49328) (2DTRANS 49330 . 50715) (2DTRANS-1 50717 . 51317)) (51522 
54218 (\RE/IM-PACK 51532 . 52179) (\RE/IM-UNPACK 52181 . 52759) (GET.COLUMN.BBT 52761 . 53128) (
PUT.COLUMN.BBT 53130 . 53497) (ZEROARRAY 53499 . 53643) (\NLP2 53645 . 53729) (ARRAYBASE 53731 . 53879
) (CHIPTEST 53881 . 54216)) (54458 55360 (\FLOATBLT 54468 . 55358)) (56951 58117 (\BLKEXPONENT 56961
 . 57017) (\BLKFDIFF 57019 . 57073) (\BLKFLOATP2COMP 57075 . 57137) (\BLKFPLUS 57139 . 57193) (
\BLKFTIMES 57195 . 57251) (\BLKMAG 57253 . 57309) (\BLKPERM 57311 . 57363) (\BLKSEP 57365 . 57419) (
\BLKSMALLP2FLOAT 57421 . 57485) (\BLKFMAX 57487 . 57555) (\BLKFMIN 57557 . 57625) (\BLKFABSMAX 57627
 . 57701) (\BLKFABSMIN 57703 . 57777) (\FLOATTOBYTE 57779 . 57881) (\PILOTBITBLT 57883 . 57935) (
POLYNOM 57937 . 58027) (\POLYNOM 58029 . 58115)) (58507 58667 (ARRAYBASE 58517 . 58665)))))
STOP