(FILECREATED " 5-Aug-85 23:28:39" {ERIS}<LISPCORE>ARRAY>CMLFLOATARRAY.;3 48808
changes to: (VARS FFTREUSETABLE CMLFLOATARRAYCOMS)
(FNS FFT.\SEPARATE.INIT FFT.\SEPARATE MAPARRAY1 2DFFT MAPARRAY2 2DTRANS-1 2DTRANS
MAPARRAY 2DMMUL \BLKEXPONENT \BLKFLOATP2COMP \BLKMAG \BLKPERM \BLKSEP
\BLKSMALLP2FLOAT \PILOTBITBLT PUT.COLUMN.BBT GET.COLUMN.BBT MMUL ARRAYBASE
DUMMYX)
(MACROS MKARRAY? SMALLARRAYP FARRAYP)
(PROPS (FFT ARGNAMES)
(FARRAYP PUTPROPS)
(MAPARRAY ARGNAMES))
previous date: "29-Jul-85 12:47:01" {ERIS}<JANDERSSON>CMLFFT>CMLFLOATARRAY.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLFLOATARRAYCOMS)
(RPAQQ CMLFLOATARRAYCOMS [(* * MAPARRAY fns and macros)
(FNS MAPARRAY MAPARRAY1 MAPARRAY2 EXPANDMAPARRAY EXPANDMAPARRAY1 EXPANDMAPARRAY2
RATIONALIZEMAPARRAY1 RATIONALIZEMAPARRAY2)
(MACROS FARRAYP MAPARRAY MAPARRAY1 MAPARRAY2 SMALLARRAYP MKARRAY?)
(* * FFT stuff)
(FNS FFT FFT.GET.COLUMN.PILOTBBT FFT.INIT FFT.PERMUTATE FFT.PUT.COLUMN.PILOTBBT FFT.RADARS
FFT.TABLE.INIT FFTSTEP \FFTSTEP FFT.\SEPARATE.INIT FFT.\SEPARATE)
(PROP DOPVAL \FFTSTEP)
(RECORDS FFTTABLE FFTSOURCE COMPLEX)
(CONSTANTS \FFTTABLESIZE FFTSSIZE PI)
(MACROS FFT.GET.COLUMN FFT.PUT.COLUMN FFT.STEP FFTGET FFTGETARR FFTPUT FFTPUT?)
(GLOBALVARS FFTREUSETABLE)
(VARS FFTREUSETABLE)
(P (SETQ FFTREUSETABLE NIL))
(* * 2D versions)
(FNS 2DCTIMES 2DFFT 2DMMUL 2DTRANS 2DTRANS-1)
(MACROS 2DFMATP)
(* * Misc.)
(FNS \RE/IM-PACK \RE/IM-UNPACK GET.COLUMN.BBT PUT.COLUMN.BBT)
(MACROS ARRAYBASE CFARRAYB DIV4 DIV2 MUL2 MUL4 MUL8)
(* * UFNs)
(FNS \FLOATBLT)
(PROP DOPVAL \FLOATBLT)
(* * For convenience)
(PROP ARGNAMES FFT MAPARRAY MAPELT \BLKEXPONENT \BLKFDIFF \BLKFLOATP2COMP \BLKFPLUS
\BLKFTIMES \BLKMAG \BLKPERM \BLKSEP \BLKSMALLP2FLOAT \IBLT1 \IBLT2)
(FNS \BLKEXPONENT \BLKFDIFF \BLKFLOATP2COMP \BLKFPLUS \BLKFTIMES \BLKMAG \BLKPERM \BLKSEP
\BLKSMALLP2FLOAT \PILOTBITBLT)
(MACROS ARRAYHIELT DOUBLE QUADRUPLE)
(FNS ARRAYBASE)
(PROP PUTPROPS FARRAYP)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA MAPARRAY])
(* * MAPARRAY fns and macros)
(DEFINEQ
(MAPARRAY
[LAMBDA ARGS (* JAS "30-Jul-85 13:59")
(* * Top level entry to array mapper: recognizes MAPELT1 and MAPELT2 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)))
(SELECTQ ARGS
(3 (MAPARRAY1 RESULT MAPFN ARRAY1))
(4 (MAPARRAY2 RESULT MAPFN ARRAY1 (ARG ARGS 4)))
(LET* [[RESULT (OR RESULT (AND (FARRAYP ARRAY1)
(COPYALL ARRAY1]
(DIMS (CONS (FARRAYP RESULT)
(for ARGNO from 3 to ARGS collect (FARRAYP (ARG ARGS ARGNO]
(COND
([NOT (EVERY DIMS (FUNCTION (LAMBDA (X XL)
(AND (CAR XL)
(OR (NULL (CDR XL))
(EQUAL X (CAR XL]
(ERROR "ARRAY DIMENSIONS DIFFER")))
[LET ([IBASES (for ARGNO from 3 to ARGS collect (ARRAYBASE (ARG ARGS ARGNO]
(INPUTS (IDIFFERENCE ARGS 2))
(ELEMENTS (ARRAY-TOTAL-SIZE ARRAY1))
(RESULTBASE (ARRAYBASE RESULT)))
(for ELEMENT from 0 to (SUB1 ELEMENTS)
do (\PUTBASEFLOATP RESULTBASE (MUL2 ELEMENT)
(APPLY MAPFN
(for OPERAND from 1 to INPUTS as ARRAY
in IBASES collect (\GETBASEFLOATP
ARRAY
(MUL2 ELEMENT]
RESULT])
(MAPARRAY1
[LAMBDA (RESULT MAPFN ARRAY) (* JAS "31-Jul-85 16:49")
(* * 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]
[COMPLEXIFYFLOAT (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]
[SEPARATE (OR (FARRAYP ARRAY)
(ERROR "ILLEGAL FLOAT ARRAY: " ARRAY))
(MKARRAY? RESULT DIMS)
(COND
((EQUAL DIMS (FARRAYP RESULT))
(\BLKSEP ARRAYBASE (\ADDBASE ARRAYBASE (MUL2 (IDIFFERENCE
(ARRAYSIZE ARRAY)
2)))
(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) (* JAS "30-Jul-85 17:31")
(* * 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))
(\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)))
ARRAY1))
(ARRAY2 (OR (AND DIMS (NUMBERP ARRAY2)
(MAKE-ARRAY DIMS (QUOTE ELEMENT-TYPE)
(QUOTE SINGLE-FLOAT)
(QUOTE INITIAL-ELEMENT)
(FLOAT ARRAY2)))
ARRAY2))
(RESULT (AND DIMS (COND
((EQUAL (FARRAYP RESULT)
DIMS)
RESULT)
((NULL RESULT)
(MAKE-ARRAY DIMS (QUOTE ELEMENT-TYPE)
(QUOTE SINGLE-FLOAT)))
(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"])
(EXPANDMAPARRAY
[LAMBDA (ARGS) (* JAS "29-Jul-85 12:16")
(* * Expands the MAPARRAY macro. Recognizes when you want MAPARRAY1 and when you want MAPARRAY2)
(* * Args looks like "(RESULT MAPFN ARRAY1 {ARRAY2})")
(LET ((ARRAY2 (CADDDR ARGS)))
(if ARRAY2
then (EXPANDMAPARRAY2 ARGS)
else (EXPANDMAPARRAY1 ARGS])
(EXPANDMAPARRAY1
[LAMBDA (ARGS) (* JAS "29-Jul-85 12:22")
(* * Expands the MAPELT macro. Recognizes when MAPFN equals EXPONENT, MAGNITUDE, FLOATSMALLP, COMPLEXIFYFLOATP, or
SEPARATE, and expands into a call on the appropriate opcodes.)
(LET ((RESULT (CAR ARGS))
(MAPFN (CADR ARGS))
(ARRAY (CADDR ARGS)))
(if (OR (EQ (CAR MAPFN)
(QUOTE QUOTE))
(EQ (CAR MAPFN)
(QUOTE FUNCTION)))
then (SELECTQ (CADR MAPFN)
(EXPONENT (RATIONALIZEMAPARRAY1 RESULT (QUOTE \BLKEXPONENT)
ARRAY))
(MAGNITUDE (RATIONALIZEMAPARRAY1 RESULT (QUOTE \BLKMAG)
ARRAY))
(FLOATSMALLP (RATIONALIZEMAPARRAY1 RESULT (QUOTE \BLKSMALLP2FLOAT)
ARRAY))
(COMPLEXIFYFLOATP (RATIONALIZEMAPARRAY1 RESULT (QUOTE \BLKFLOATP2COMP)
ARRAY))
(QUOTE IGNOREMACRO))
else (QUOTE IGNOREMACRO])
(EXPANDMAPARRAY2
[LAMBDA (ARGS) (* JAS "29-Jul-85 12:23")
(* * Expands the MAPELT2 macro. Recognizes when MAPFN equals FTIMES, PERMUTE, ELT, FPLUS, FDIFF, or SEP, and expands
into a call on the appropriate opcodes.)
(LET ((RESULT (CAR ARGS))
(MAPFN (CADR ARGS))
(ARRAY1 (CADDR ARGS))
(ARRAY2 (CADDDR ARGS)))
(if (OR (EQ (CAR MAPFN)
(QUOTE QUOTE))
(EQ (CAR MAPFN)
(QUOTE FUNCTION)))
then (SELECTQ (CADR MAPFN)
(FTIMES (RATIONALIZEMAPARRAY2 RESULT (QUOTE \BLKFTIMES)
ARRAY1 ARRAY2))
((PERMUTE ELT)
(RATIONALIZEMAPARRAY2 RESULT (QUOTE \BLKPERM)
ARRAY1 ARRAY2))
(FPLUS (RATIONALIZEMAPARRAY2 RESULT (QUOTE \BLKFPLUS)
ARRAY1 ARRAY2))
(FDIFF (RATIONALIZEMAPARRAY2 RESULT (QUOTE \BLKFDIFF)
ARRAY1 ARRAY2))
(QUOTE IGNOREMACRO))
else (QUOTE IGNOREMACRO])
(RATIONALIZEMAPARRAY1
[LAMBDA (ACTUALRESULT ACTUALMAPFN ACTUALARRAY) (* JAS "29-Jul-85 12:26")
(BQUOTE (LET* [(SIZE (ARRAY-DIMENSIONS , ACTUALARRAY))
(RESULT (OR (TYPENAMEP , ACTUALRESULT (QUOTE ARRAY))
(MAKE-ARRAY SIZE (QUOTE ELEMENT-TYPE)
(QUOTE FLOAT]
(, ACTUALMAPFN (ARRAYBASE , ACTUALARRAY)
(ARRAYBASE RESULT)
SIZE)
RESULT])
(RATIONALIZEMAPARRAY2
[LAMBDA (ACTUALRESULT ACTUALMAPFN ACTUALARRAY1 ACTUALARRAY2)
(* JAS "29-Jul-85 12:28")
(BQUOTE (LET* [(SIZE (ARRAY-DIMENSIONS , ACTUALARRAY1))
(RESULT (OR (TYPENAMEP , ACTUALRESULT (QUOTE ARRAY))
(MAKE-ARRAY SIZE (QUOTE ELEMENT-TYPE)
(QUOTE FLOAT]
(, ACTUALMAPFN (ARRAYBASE , ACTUALARRAY1)
(ARRAYBASE , ACTUALARRAY2)
(ARRAYBASE RESULT)
SIZE)
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))
(ARRAY-DIMENSIONS ARR]
(PUTPROPS MAPARRAY MACRO (ARGS (EXPANDMAPARRAY ARGS)))
(PUTPROPS MAPARRAY1 MACRO (ARGS (EXPANDMAPARRAY1 ARGS)))
(PUTPROPS MAPARRAY2 MACRO (ARGS (EXPANDMAPARRAY2 ARGS)))
[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 (APPLY (QUOTE ITIMES)
DIMS]
)
(* * FFT stuff)
(DEFINEQ
(FFT
[LAMBDA (V START LEN INVFLG \BASEPTR) (* JAS "24-Jul-85 16:49")
(* 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)))
((TYPENAMEP V (QUOTE ARRAYP))
(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 "26-Jul-85 09:24")
(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 "14-Jul-85 23:24")
(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) (* hdj " 2-Jan-85 15:55")
(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 "26-Jul-85 09:42")
(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])
(FFT.\SEPARATE.INIT
[LAMBDA (N) (* JAS " 5-Aug-85 23:18")
(DECLARE (GLOBALVARS FFTREUSETABLE))
(* Generate permuation templates for the block permutation operator. The unpermuatated format is #
(SUMeven X SUModd X DIFFeven X DIFFodd X { ReX ImX ReY ImY }), where {} is repeated N-1 times.
We want to have a permutation template. # (SUMeven 0 SUModd 0 DIFFeven 0 DIFFodd 0 { ReX ImX ReY ImY }) to #
(SUMeven DIFFeven { ReX } 0 0 { ImX } SUModd DIFFodd { ReY } 0 0 { ImY }).)
(LET ([TB (MAKE-ARRAY (MUL4 (IPLUS 2 N))
(QUOTE ELEMENT-TYPE)
(QUOTE (UNSIGNED-BYTE 16]
[TC (MAKE-ARRAY (MUL4 (IPLUS 2 N))
(QUOTE ELEMENT-TYPE)
(QUOTE (UNSIGNED-BYTE 16]
[TD (MAKE-ARRAY (MUL4 (IPLUS 2 N))
(QUOTE ELEMENT-TYPE)
(QUOTE (UNSIGNED-BYTE 16]
(OFFS 0)
(NTS4 N)
[L1 (LIST (ITIMES 3 (DIV2 N))
(ADD1 (ITIMES 3 (DIV2 N)))
N
(ADD1 N)
0 1 (DIV2 N)
(ADD1 (DIV2 N]
(L2 (QUOTE (6 7 4 5 0 1 2 3)))
GPOS OFFS)
[for X from 0 to 3
do (SETQ GPOS (ITIMES X (IPLUS 2 NTS4)))
(SETQ OFFS (MUL2 X))
(for I from 0 to (DIV2 NTS4)
do (ASET OFFS TB GPOS)
(ASET (ADD1 OFFS)
TB
(ADD1 GPOS))
(SETQ GPOS (IPLUS GPOS 2))
(SETQ OFFS (IPLUS OFFS 8]
(FFTPUT (QUOTE \SEPARATE)
(ARRAYBASE TB)
N)
[for I from 0 to (SUB1 (DIV2 NTS4))
do (for J from 0 to 7 as P in L1 do (ASET (IPLUS (MUL2 I)
P)
TC
(IPLUS (LLSH I 3)
J]
(FFTPUT (QUOTE \DISEP)
(ARRAYBASE TC)
N)
[for I from 0 to (SUB1 (DIV2 N))
do (for J from 0 to 7 as P in L2 do (ASET (IPLUS (LLSH I 3)
P)
TD
(IPLUS (LLSH I 3)
J]
(FFTPUT (QUOTE \PERMSEP)
(ARRAYBASE TD)
N)
TD])
(FFT.\SEPARATE
[LAMBDA (BA N PB0 PB1) (* JAS " 5-Aug-85 22:40")
(LET ((FFSBP (\ADDBASE BA 4))
[FLSBP (\ADDBASE BA (MUL2 (IDIFFERENCE N 2]
[SFSBP (\ADDBASE BA (MUL2 (IPLUS N 2]
[SLSBP (\ADDBASE BA (MUL4 (IDIFFERENCE N 1]
(DB1 PB)
(DB2 (\ADDBASE PB0 (MUL2 N)))
(SUMeven (\GETBASEFLOATP BA 0))
(SUModd (\GETBASEFLOATP BA 2))
(DIFFeven (\GETBASEFLOATP BA (MUL4 N)))
[DIFFodd (\GETBASEFLOATP BA (MUL4 (SUB1 N]
(SEPPRM (FFTGET (QUOTE \SEPARATE)
N))
(DISPRM (FFTGET (QUOTE \DISEP)
N))
(PERPRM (FFTGET (QUOTE \PERMSEP)
N)))
(OR (AND SEPPRM DISPRM PERPRM)
(FFT.\SEPARATE.INIT N))
(* BA is a base address pointing to N complex numbers in the format # (SUMeven SUModd ..... DIFFeven DIFFodd .....).
That is the result of applying a FFT to a X+iY sum there X and Y are real numbers. PB is also an address pointing to
a N+2 sized block of memory (64 bits slots) there the result is stored.)
(\PUTBASEFLOATP DB1 0 SUMeven)
(\PUTBASEFLOATP DB1 2 0.0)
(\PUTBASEFLOATP DB1 4 SUModd)
(\PUTBASEFLOATP DB1 6 0.0)
(\BLKSEP FLSBP FFSBP (\ADDBASE DB1 8))
(\PUTBASEFLOATP DB2 0 DIFFeven)
(\PUTBASEFLOATP DB2 2 0.0)
(\PUTBASEFLOATP DB2 4 DIFFodd)
(\PUTBASEFLOATP DB2 6 0.0)
(\BLKSEP SLSBP SFSBP (\ADDBASE DB2 8))
(* Ok, now reorganize the elements in real and imaginary parts like # (ReX0 ReX1 ... ReXn ImX0 ...
ImXn ReY0 ... ReYn ImY0 ... ImYn))
(\BLKPERM PB0 SEPPRM PB1 (MUL4 N])
)
(PUTPROPS \FFTSTEP DOPVAL (2 FFTSTEP))
[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)
(OR (FFTGET (QUOTE ARR)
(QUOTE ALL))
(FFTPUT (QUOTE ARR)
XPR
(QUOTE ALL]
[PUTPROPS FFTPUT MACRO ((V VAL P)
(CDAR (PUTHASH P (CONS (CONS V VAL)
(GETHASH P FFTREUSETABLE))
(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]
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS FFTREUSETABLE)
)
(RPAQQ FFTREUSETABLE {HARRAYP}#372,74542)
(SETQ FFTREUSETABLE NIL)
(* * 2D versions)
(DEFINEQ
(2DCTIMES
[LAMBDA (M1 M2 M3) (* JAS "28-Jul-85 14:31")
(* 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)))
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 TOTSIZE (IDIFFERENCE TOTSIZE TS)))
M3])
(2DFFT
[LAMBDA (MAT INVFLG) (* JAS "31-Jul-85 11:26")
(* 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 (ARRAYBASE (ARRAY (MUL2 RAWS)
(QUOTE FLOATP)
0 0 (IMIN 128 (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 "30-Jul-85 16:13")
[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)
(SETQ SUM 0.0)
[for K from 0 to (SUB1 CNT)
do (SETQ SUM (FPLUS SUM (\GETBASEFLOATP TMPB (MUL2 K]
(\PUTBASEFLOATP ZB 0 SUM)
(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 "27-Jul-85 20:13")
(LET ((SIZW (MUL4 CNT))
(SIZF (MUL2 CNT))
(SHFFLE (FFTGET (QUOTE PACK)
CNT))
(TMP (FFTGET (QUOTE TMP)
CNT))
I2 I4)
(COND
((NULL SHFFLE)
[SETQ SHFFLE (ARRAYBASE (ARRAY SIZW (QUOTE SMALLP)
0 0 (MIN 128 SIZW]
[SETQ TMP (ARRAYBASE (ARRAY SIZF (QUOTE FLOATP)
0 0 (MIN 128 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 "28-Jul-85 14:36")
(LET ((BRS (FFTGET (QUOTE RESEP)
CNT))
(BIS (FFTGET (QUOTE IMSEP)
CNT))
(SIZW (MUL4 CNT))
(SIZF (MUL2 CNT))
I4 I2)
(COND
((NULL BRS)
[SETQ BRS (ARRAYBASE (ARRAY SIZF (QUOTE SMALLP)
0 0 (IMIN 128 CNT]
[SETQ BIS (ARRAYBASE (ARRAY SIZF (QUOTE SMALLP)
0 0 (IMIN 128 CNT]
(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])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS ARRAYBASE MACRO ((X)
(COND ((TYPENAMEP X (QUOTE ARRAYP))
(fetch (ARRAYP BASE)
of X))
(T (fetch (ARRAY BASE)
of X]
[PUTPROPS CFARRAYB MACRO ((SIZE)
(ARRAYBASE (ARRAY SIZE (QUOTE FLOATP)
0.0 0 (IMIN SIZE 128]
(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))
(* * For convenience)
(PUTPROPS FFT ARGNAMES (ARRAY STARTPOSITION LENGTH INVERSEFLAG \BASPTR))
(PUTPROPS MAPARRAY ARGNAMES (Result Mapfn Array1 Array2 ... ArrayN))
(PUTPROPS MAPELT ARGNAMES "RESULT MAPFN ARRAY1")
(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 \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])
(\PILOTBITBLT
[LAMBDA (A B)
(\PILOTBITBLT A B])
)
(DECLARE: EVAL@COMPILE
[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 (2244 12584 (MAPARRAY 2254 . 3786) (MAPARRAY1 3788 . 6672) (MAPARRAY2 6674 . 9035) (
EXPANDMAPARRAY 9037 . 9478) (EXPANDMAPARRAY1 9480 . 10521) (EXPANDMAPARRAY2 10523 . 11575) (
RATIONALIZEMAPARRAY1 11577 . 12027) (RATIONALIZEMAPARRAY2 12029 . 12582)) (13471 27886 (FFT 13481 .
16891) (FFT.GET.COLUMN.PILOTBBT 16893 . 17120) (FFT.INIT 17122 . 18660) (FFT.PERMUTATE 18662 . 19453)
(FFT.PUT.COLUMN.PILOTBBT 19455 . 19686) (FFT.RADARS 19688 . 20709) (FFT.TABLE.INIT 20711 . 22389) (
FFTSTEP 22391 . 22615) (\FFTSTEP 22617 . 23912) (FFT.\SEPARATE.INIT 23914 . 26128) (FFT.\SEPARATE
26130 . 27884)) (32395 40882 (2DCTIMES 32405 . 34242) (2DFFT 34244 . 36525) (2DMMUL 36527 . 37941) (
2DTRANS 37943 . 39961) (2DTRANS-1 39963 . 40880)) (41103 44243 (\RE/IM-PACK 41113 . 42218) (
\RE/IM-UNPACK 42220 . 43219) (GET.COLUMN.BBT 43221 . 43730) (PUT.COLUMN.BBT 43732 . 44241)) (44753
46265 (\FLOATBLT 44763 . 46263)) (47392 48072 (\BLKEXPONENT 47402 . 47467) (\BLKFDIFF 47469 . 47532) (
\BLKFLOATP2COMP 47534 . 47605) (\BLKFPLUS 47607 . 47670) (\BLKFTIMES 47672 . 47737) (\BLKMAG 47739 .
47804) (\BLKPERM 47806 . 47867) (\BLKSEP 47869 . 47932) (\BLKSMALLP2FLOAT 47934 . 48007) (\PILOTBITBLT
48009 . 48070)) (48285 48543 (ARRAYBASE 48295 . 48541)))))
STOP