(FILECREATED "24-Oct-85 16:16:19" {ERIS}<LISPCORE>LIBRARY>CMLFLOATARRAY.;8 62734
changes to: (FNS MAPARRAY2)
previous date: " 8-Oct-85 16:13:53" {ERIS}<LISPCORE>LIBRARY>CMLFLOATARRAY.;7)
(* 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)
(* * Other array functions)
(FNS ARRAY-COPY ARRAY-POWER ARRAY-SET ARRAYBASE 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 (ARRAYBASE (MAKE-ARRAY FFTSSIZE (QUOTE :ELEMENT-TYPE)
(QUOTE FLOAT)
(QUOTE :ALIGNMENT)
(IMIN (\NLP2 FFTSSIZE)
128)
(QUOTE :INITIAL-ELEMENT)
0.0)))
(\SLICE2 (ARRAYBASE (MAKE-ARRAY FFTSSIZE (QUOTE :ELEMENT-TYPE)
(QUOTE FLOAT)
(QUOTE :ALIGNMENT)
(IMIN (\NLP2 FFTSSIZE)
128)
(QUOTE :INITIAL-ELEMENT)
0.0]
(* * 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 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)
(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 (* raf " 7-Oct-85 12:32") (* * 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) (\CML.GET.ARRAY.BASE ARRAYARG)))) (ELEMENTS (ARRAY-TOTAL-SIZE
RESULT)) (RESULTBASE (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:32") (* * Map a function across an array. Recognizes
the special cases that can run in microcode.) (LET ((ARRAYSIZE (ARRAY-TOTAL-SIZE ARRAY)) (ARRAYBASE (
\CML.GET.ARRAY.BASE 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 (\CML.GET.ARRAY.BASE 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 (\CML.GET.ARRAY.BASE 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 (\CML.GET.ARRAY.BASE 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 (\CML.GET.ARRAY.BASE RESULT) ARRAYSIZE)) (
T (ERROR "ILLEGAL FLOAT ARRAY: " RESULT))))) (COND ((EQUAL (FARRAYP ARRAY) (FARRAYP (MKARRAY? RESULT
DIMS))) (LET ((RB (\CML.GET.ARRAY.BASE 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 "24-Oct-85 16:15")
(* * 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 (\CML.GET.ARRAY.BASE ARRAY1)
(\CML.GET.ARRAY.BASE ARRAY2)
(\CML.GET.ARRAY.BASE 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 (\CML.GET.ARRAY.BASE ARRAY1))
(ARRAY2BASE (\CML.GET.ARRAY.BASE ARRAY2))
(RESULTBASE (\CML.GET.ARRAY.BASE 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)
(\CML.GET.ARRAY.BASE 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)
(\CML.GET.ARRAY.BASE (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)
(\CML.GET.ARRAY.BASE (MAKE-ARRAY SIZE (QUOTE :ELEMENT-TYPE)
(QUOTE (UNSIGNED-BYTE 16))
(QUOTE :ALIGNMENT)
(IMIN (\NLP2 (DIV2 SIZE))
128]
)
(* * Other array functions)
(DEFINEQ
(ARRAY-COPY
(LAMBDA (ARR1 ARR2) (* raf " 7-Oct-85 12:30") (COND ((AND (FARRAYP ARR1) (EQUAL (ARRAY-DIMENSIONS ARR1
) (FARRAYP ARR2))) (LET ((TS (MUL2 (ARRAY-TOTAL-SIZE ARR1))) (BA1 (\CML.GET.ARRAY.BASE ARR1)) (BA2 (
\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (COND ((NOT (FARRAYP ARR)) (ERROR
"Illegal array argument" ARR))) (LET ((BA (\CML.GET.ARRAY.BASE ARR)) (WS (MUL2 (SUB1 (ARRAY-TOTAL-SIZE
ARR))))) (\PUTBASEFLOATP BA WS VALUE) (\BLT BA (\ADDBASE BA 2) WS) ARR)))
(ARRAYBASE
(LAMBDA (A) (* raf " 8-Oct-85 16:05") (\CML.GET.ARRAY.BASE A)))
(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) (* raf " 7-Oct-85 12:30") (COND ((FARRAYP ARR) (LET ((CNT (
ARRAY-TOTAL-SIZE ARR)) (SLICE FFTSSIZE) (XV \SLICE1) (BA (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (COND ((FARRAYP ARR) (LET ((CNT (
ARRAY-TOTAL-SIZE ARR)) (SLICE FFTSSIZE) (XV \SLICE1) (BA (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (MAKE-INDEX (ARRAY-DIMENSIONS ARRAY) (WMIN/MAX
(\ADDBASE (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (MAKE-INDEX (ARRAY-DIMENSIONS ARRAY) (WMIN/MAX
(\ADDBASE (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (MAKE-INDEX (ARRAY-DIMENSIONS ARRAY) (WMIN/MAX
(\ADDBASE (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (MAKE-INDEX (ARRAY-DIMENSIONS ARRAY) (WMIN/MAX
(\ADDBASE (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (COND ((FARRAYP ARRAY) (\SUM-VECTOR (
\CML.GET.ARRAY.BASE 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 (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (* 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 (\CML.GET.ARRAY.BASE (FFTGET (QUOTE SHUFFLE) PASSES))) (SETQ BFFTBUF1 (\CML.GET.ARRAY.BASE (
FFTGET (QUOTE FFTBUF1) PASSES))) (SETQ BFFTBUF2 (\CML.GET.ARRAY.BASE (FFTGET (QUOTE FFTBUF2) PASSES)))
(SETQ BV (\ADDBASE (COND (\BASEPTR) (T (\CML.GET.ARRAY.BASE 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 (\CML.GET.ARRAY.BASE (FFTGET (QUOTE INVSCALE)
PASSES)) BV (IPLUS LEN LEN))) ((NULL INVFLG) (\BLT BV BFFTBUF2 SIB)) (T (\BLKFTIMES BFFTBUF2 (
\CML.GET.ARRAY.BASE (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) (* raf " 7-Oct-85 12:30") (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 (\CML.GET.ARRAY.BASE TMP1) (
\CML.GET.ARRAY.BASE TMP2) PASSES) PASSES) (FFTPUT? (QUOTE INVFFTTABLE) (FFT.TABLE.INIT (
\CML.GET.ARRAY.BASE TMP1) (\CML.GET.ARRAY.BASE 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 (ARRAYBASE (MAKE-ARRAY FFTSSIZE (QUOTE :ELEMENT-TYPE)
(QUOTE FLOAT)
(QUOTE :ALIGNMENT)
(IMIN (\NLP2 FFTSSIZE)
128)
(QUOTE :INITIAL-ELEMENT)
0.0)))
(RPAQ \SLICE2 (ARRAYBASE (MAKE-ARRAY FFTSSIZE (QUOTE :ELEMENT-TYPE)
(QUOTE FLOAT)
(QUOTE :ALIGNMENT)
(IMIN (\NLP2 FFTSSIZE)
128)
(QUOTE :INITIAL-ELEMENT)
0.0)))
(* * FFTs of real vectors (pack in complex format))
(DEFINEQ
(2DXFFT
(LAMBDA (MAT INVFLG) (* raf " 7-Oct-85 12:30") (* 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 (\CML.GET.ARRAY.BASE
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 " 7-Oct-85 12:30") (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 (
\CML.GET.ARRAY.BASE V) (IPLUS 4 (MUL4 N))) (\ADDBASE (\CML.GET.ARRAY.BASE V) (MUL4 N)) (MUL4 N)) (
FFTPUT (QUOTE \SEP) (\CML.GET.ARRAY.BASE V) N))))
(FFT.\DISSEP.INIT
(LAMBDA (N) (* raf " 7-Oct-85 12:30") (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) (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (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 (\CML.GET.ARRAY.BASE 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 " 7-Oct-85 12:30") (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 (
\CML.GET.ARRAY.BASE 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 " 7-Oct-85 12:30") (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 (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (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 (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (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 (\CML.GET.ARRAY.BASE 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 " 7-Oct-85 12:30") (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 (
\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (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 (
\CML.GET.ARRAY.BASE CARR) (COND (IMFLG 2) (T 0)))) (BFA (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (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 (
\CML.GET.ARRAY.BASE CARR)) (X (\CML.GET.ARRAY.BASE RE)) (Y (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:30") (* 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 (\CML.GET.ARRAY.BASE M1)) (BM2 (\CML.GET.ARRAY.BASE M2)) (BM3 (
\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:29") (* 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 (\CML.GET.ARRAY.BASE M1) 8) (\BLT TMP2 (\CML.GET.ARRAY.BASE M2) 8) (2DCTIMES
M1 M2 M3) (\BLKFTIMES TMP1 TMP2 (\CML.GET.ARRAY.BASE M3) 4)))))
(2DFFT
(LAMBDA (MAT INVFLG) (* raf " 7-Oct-85 12:29") (* 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 (\CML.GET.ARRAY.BASE MAT)) (MBR (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:29") (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 (\CML.GET.ARRAY.BASE X))
(YB (\CML.GET.ARRAY.BASE Y)) (ZB (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:29") (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 (
\CML.GET.ARRAY.BASE S)) (DB (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:29") (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 (\CML.GET.ARRAY.BASE S)) (DB (\CML.GET.ARRAY.BASE 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) (* raf " 7-Oct-85 12:29") (AND (FARRAYP ARR) (\ZEROWORDS (\CML.GET.ARRAY.BASE ARR) (
\ADDBASE (\CML.GET.ARRAY.BASE ARR) (SUB1 (MUL2 (ARRAY-TOTAL-SIZE ARR))))))))
(\NLP2
(LAMBDA (N) (* JAS "11-Sep-85 10:49") (EXPT 2 (SUB1 (INTEGERLENGTH N)))))
(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)))
)
(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 (3177 9002 (MAPARRAY 3187 . 4388) (MAPARRAY1 4390 . 6220) (MAPARRAY2 6222 . 9000)) (
10490 16557 (ARRAY-COPY 10500 . 10970) (ARRAY-POWER 10972 . 11344) (ARRAY-SET 11346 . 11619) (
ARRAYBASE 11621 . 11699) (MAXARR 11701 . 11827) (MINARR 11829 . 11955) (MAXABSARR 11957 . 12086) (
MINABSARR 12088 . 12223) (MULARR 12225 . 12993) (ADDARR 12995 . 13762) (WHERE-MINABSARR 13764 . 14107)
(WHERE-MINARR 14109 . 14441) (WHERE-MAXABSARR 14443 . 14789) (WHERE-MAXARR 14791 . 15126) (SUMARR
15128 . 15349) (FABS-LESSP 15351 . 15434) (FABS-GREATERP 15436 . 15525) (FABSMIN 15527 . 15606) (
FABSMAX 15608 . 15687) (MAKE-INDEX 15689 . 16050) (\SUM-VECTOR 16052 . 16555)) (19081 26248 (FFT 19091
. 21669) (FFT.GET.COLUMN.PILOTBBT 21671 . 21821) (FFT.INIT 21823 . 22914) (FFT.PERMUTATE 22916 .
23432) (FFT.PUT.COLUMN.PILOTBBT 23434 . 23588) (FFT.RADARS 23590 . 24207) (FFT.TABLE.INIT 24209 .
25249) (FFTSTEP 25251 . 25408) (\FFTSTEP 25410 . 26246)) (31345 39568 (2DXFFT 31355 . 32660) (\2DXFFT
32662 . 34081) (FFT.GET.COLUMNX.PILOTBBT 34083 . 34236) (FFT.PUT.COLUMNX.PILOTBBT 34238 . 34395) (
FFT.\DISSEP 34397 . 35392) (FFT.\SEP.INIT 35394 . 36147) (FFT.\DISSEP.INIT 36149 . 36759) (FFT.FR
36761 . 37783) (FFT.INVFR 37785 . 38633) (FFT.SCALE/SIGN 38635 . 38932) (FFTTEST 38934 . 39566)) (
40999 48288 (BITMAP-TO-COMPLEX 41009 . 42070) (COMPLEX-TO-BITMAP 42072 . 42992) (FLOAT-TO-BITMAP 42994
. 43686) (BITMAP-TO-FLOAT 43688 . 44707) (BITMAP-TO-XCOMPLEX 44709 . 45977) (XCOMPLEX-TO-BITMAP 45979
. 46975) (COMPLEX-TO-FLOAT 46977 . 47635) (FLOAT-TO-COMPLEX 47637 . 48286)) (48313 55304 (2DCTIMES
48323 . 49883) (2DCXTIMES 49885 . 50778) (2DFFT 50780 . 52378) (2DMMUL 52380 . 53272) (2DTRANS 53274
. 54680) (2DTRANS-1 54682 . 55302)) (55525 58117 (\RE/IM-PACK 55535 . 56182) (\RE/IM-UNPACK 56184 .
56762) (GET.COLUMN.BBT 56764 . 57131) (PUT.COLUMN.BBT 57133 . 57500) (ZEROARRAY 57502 . 57692) (\NLP2
57694 . 57778) (CHIPTEST 57780 . 58115)) (58377 59279 (\FLOATBLT 58387 . 59277)) (60880 62046 (
\BLKEXPONENT 60890 . 60946) (\BLKFDIFF 60948 . 61002) (\BLKFLOATP2COMP 61004 . 61066) (\BLKFPLUS 61068
. 61122) (\BLKFTIMES 61124 . 61180) (\BLKMAG 61182 . 61238) (\BLKPERM 61240 . 61292) (\BLKSEP 61294
. 61348) (\BLKSMALLP2FLOAT 61350 . 61414) (\BLKFMAX 61416 . 61484) (\BLKFMIN 61486 . 61554) (
\BLKFABSMAX 61556 . 61630) (\BLKFABSMIN 61632 . 61706) (\FLOATTOBYTE 61708 . 61810) (\PILOTBITBLT
61812 . 61864) (POLYNOM 61866 . 61956) (\POLYNOM 61958 . 62044)))))
STOP