(FILECREATED "21-Nov-84 16:20:20" {ERIS}<LISP>HARMONY>LIBRARY>FLOATARRAY.;1 26056
changes to: (FNS TURNONFLOATARRAYUFNS)
previous date: "14-Nov-84 18:20:28" {ERIS}<LISPCORE>LIBRARY>FLOATARRAY.;1)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FLOATARRAYCOMS)
(RPAQQ FLOATARRAYCOMS [(* * MAPELT fns and macros)
(FNS MAPELT MAPELT1 MAPELT2 EXPANDMAPELT EXPANDMAPELT1 EXPANDMAPELT2
RATIONALIZEMAPELT1 RATIONALIZEMAPELT2)
(MACROS MAPELT MAPELT1 MAPELT2)
(* * FFT stuff)
(FNS FFTSTEP \FFTSTEP)
(PROP DOPVAL \FFTSTEP)
(RECORDS FFTTABLE FFTSOURCE COMPLEX)
(CONSTANTS \FFTTABLESIZE)
(* * UFNs)
(FNS \FLOATBLT \NEWMISC3.UFN \NEWMISC4.UFN \NEWMISC5.UFN \NEWMISC8.UFN)
(PROP DOPVAL \FLOATBLT)
(* * sub-UFNs of \NEWMISC3.UFN)
(FNS BLKEXPONENT BLKFLOATP2COMP BLKMAG BLKSMALLP2FLOAT)
(* * sub-UFNs of \NEWMISC4.UFN)
(FNS BLKSEP BLKPERM BLKFDIFF BLKFPLUS BLKFTIMES)
(* * sub-UFNs of \NEWMISC8.UFN)
(FNS IBLT1 IBLT2)
(* * install the new UFNs)
(FNS TURNONFLOATARRAYUFNS)
(* * For convenience)
(PROP ARGNAMES MAPELT \BLKEXPONENT \BLKFDIFF \BLKFLOATP2COMP \BLKFPLUS
\BLKFTIMES \BLKMAG \BLKPERM \BLKSEP \BLKSMALLP2FLOAT \IBLT1 \IBLT2)
(MACROS ARRAYHIELT DOUBLE QUADRUPLE)
(FNS ARRAYBASE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA MAPELT])
(* * MAPELT fns and macros)
(DEFINEQ
(MAPELT
[LAMBDA ARGS (* hdj "13-Nov-84 14:25")
(* * Top level entry to array mapper: recognizes MAPELT1 and MAPELT2 cases.)
(* * if RESULT is not an array, ARRAY1 had better be)
(LET ((RESULT (ARG ARGS 1))
(MAPFN (ARG ARGS 2))
(ARRAY1 (ARG ARGS 3)))
(SELECTQ ARGS
(3 (MAPELT1 RESULT MAPFN ARRAY1))
(4 (MAPELT2 RESULT MAPFN ARRAY1 (ARG ARGS 4)))
(LET* ([INPUTARRAYBASES (for ARGUMENT from 3 to ARGS collect (ARRAYBASE (ARG ARGS
ARGUMENT]
(NUMINPUTARRAYS (LENGTH INPUTARRAYBASES))
(ELEMENTS (ARRAYSIZE ARRAY1))
[GOODRESULT (OR (ARRAYP RESULT)
(ARRAY (ARRAYSIZE ARRAY1)
(QUOTE FLOATP)
0.0
(ARRAYORIG ARRAY1]
(RESULTBASE (ARRAYBASE GOODRESULT)))
[for ELEMENT from 0 to ELEMENTS
do (\PUTBASEFLOATP RESULTBASE (DOUBLE ELEMENT)
(APPLY MAPFN
(for OPERAND from 1 to NUMINPUTARRAYS as ARRAY
in INPUTARRAYBASES collect (\GETBASEFLOATP
ARRAY
(DOUBLE ELEMENT]
GOODRESULT])
(MAPELT1
[LAMBDA (RESULT MAPFN ARRAY) (* hdj "28-Sep-84 12:44")
(* * Map a function across an array. Recognizes the special cases that can run in microcode.)
(LET [(GOODRESULT (OR RESULT (ARRAY (ARRAYSIZE ARRAY)
(QUOTE FLOATP)
0.0
(ARRAYORIG ARRAY]
(LET ((ARRAYSIZE (ARRAYSIZE ARRAY))
(ARRAYBASE (ARRAYBASE ARRAY))
(RESULTBASE (ARRAYBASE GOODRESULT)))
[SELECTQ MAPFN
(EXPONENT (\BLKEXPONENT ARRAYBASE RESULTBASE ARRAYSIZE))
(MAGNITUDE (\BLKMAG ARRAYBASE RESULTBASE (HALF ARRAYSIZE)))
(FLOAT (\BLKSMALLP2FLOAT ARRAYBASE RESULTBASE ARRAYSIZE))
(COMPLEXIFYFLOATP (\BLKFLOATP2COMP ARRAYBASE RESULTBASE ARRAYSIZE))
(SEPARATE (\BLKSEP ARRAYBASE (\ADDBASE ARRAYBASE (DOUBLE (IDIFFERENCE
(ARRAYSIZE ARRAY)
2)))
RESULTBASE ARRAYSIZE))
(for ELT from 0 to (DOUBLE (SUB1 ARRAYSIZE)) by 2
do (\PUTBASEFLOATP RESULTBASE ELT (APPLY* MAPFN (\GETBASEFLOATP ARRAYBASE
ELT]
GOODRESULT])
(MAPELT2
[LAMBDA (RESULT MAPFN ARRAY1 ARRAY2) (* hdj "28-Sep-84 13:31")
(* * Map a function across two arrays. Recognizes the cases that can run in microcode.)
(PROG (ARRAY1SIZE ARRAY1BASE ARRAY2SIZE ARRAY2BASE RESULTBASE)
(* if ARRAY1 is really an array, leave it alone. Otherwise it is a constant; create an array that has each elt equal
to that constant)
[SETQ ARRAY1 (OR (ARRAYP ARRAY1)
(if (ARRAYP ARRAY2)
then (ARRAY (ARRAYSIZE ARRAY2)
(QUOTE FLOATP)
ARRAY1
(ARRAYORIG ARRAY2))
else (HELP "Neither ARRAY1 nor ARRAY2 is an array"]
(* * same, but for ARRAY2)
[SETQ ARRAY2 (OR (ARRAYP ARRAY2)
(if (ARRAYP ARRAY1)
then (ARRAY (ARRAYSIZE ARRAY1)
(QUOTE FLOATP)
ARRAY1
(ARRAYORIG ARRAY1))
else (HELP "Neither ARRAY1 nor ARRAY2 is an array"]
[SETQ RESULT (OR (ARRAYP RESULT)
(ARRAY (ARRAYSIZE ARRAY1)
(QUOTE FLOATP)
0.0
(ARRAYORIG ARRAY1]
(SETQ ARRAY1SIZE (ARRAYSIZE ARRAY1))
(SETQ ARRAY1BASE (ARRAYBASE ARRAY1))
(SETQ ARRAY2SIZE (ARRAYSIZE ARRAY2))
(SETQ ARRAY2BASE (ARRAYBASE ARRAY2))
(SETQ RESULTBASE (ARRAYBASE RESULT))
[SELECTQ MAPFN
(FTIMES (\BLKFTIMES ARRAY1BASE ARRAY2BASE RESULTBASE ARRAY1SIZE))
((PERMUTE ELT)
(\BLKPERM ARRAY1BASE ARRAY2BASE RESULTBASE ARRAY1SIZE))
(FPLUS (\BLKFPLUS ARRAY1BASE ARRAY2BASE RESULTBASE ARRAY1SIZE))
(FDIFF (\BLKFDIFF ARRAY1BASE ARRAY2BASE RESULTBASE ARRAY1SIZE))
(for ELT from 0 to (DOUBLE (SUB1 ARRAY1SIZE)) by 2
do (\PUTBASEFLOATP RESULTBASE ELT (APPLY* MAPFN (\GETBASEFLOATP ARRAY1BASE ELT)
(\GETBASEFLOATP ARRAY2BASE ELT]
(RETURN RESULT])
(EXPANDMAPELT
[LAMBDA (ARGS) (* hdj "28-Sep-84 12:12")
(* * Expands the MAPELT macro. Recognizes when you want MAPELT1 and when you want MAPELT2)
(* * Args looks like "(RESULT MAPFN ARRAY1 {ARRAY2})")
(LET ((ARRAY2 (CADDDR ARGS)))
(if ARRAY2
then (EXPANDMAPELT2 ARGS)
else (EXPANDMAPELT1 ARGS])
(EXPANDMAPELT1
[LAMBDA (ARGS) (* hdj "26-Sep-84 18:50")
(* * Expands the MAPELT macro. Recognizes when MAPFN equals EXPONENT, MAGNITUDE, FLOATSMALLP, COMPLEXIFYFLOATP, or
SEPARATE, and expands into a call on the appropriate opcodes.)
(PROG ((RESULT (CAR ARGS))
(MAPFN (CADR ARGS))
(ARRAY (CADDR ARGS)))
(RETURN (if (OR (EQ (CAR MAPFN)
(QUOTE QUOTE))
(EQ (CAR MAPFN)
(QUOTE FUNCTION)))
then (SELECTQ (CADR MAPFN)
(EXPONENT (RATIONALIZEMAPELT1 RESULT (QUOTE \BLKEXPONENT)
ARRAY))
(MAGNITUDE (RATIONALIZEMAPELT1 RESULT (QUOTE \BLKMAG)
ARRAY))
(FLOATSMALLP (RATIONALIZEMAPELT1 RESULT (QUOTE \BLKSMALLP2FLOAT)
ARRAY))
(COMPLEXIFYFLOATP (RATIONALIZEMAPELT1 RESULT (QUOTE
\BLKFLOATP2COMP)
ARRAY))
[SEPARATE (BQUOTE (PROG ((SIZE (ARRAYSIZE , ARRAY))
RESULT)
[SETQ RESULT
(OR (ARRAYP RESULT)
(ARRAY SIZE (QUOTE FLOATP)
0.0
(ARRAYORIG , ARRAY]
(\BLKSEP (ARRAYBASE , ARRAY)
(\ADDBASE (ARRAYBASE , ARRAY)
(DOUBLE (IDIFFERENCE
SIZE 2)))
(ARRAYBASE , RESULT)
SIZE)
(RETURN RESULT]
(QUOTE IGNOREMACRO))
else (QUOTE IGNOREMACRO])
(EXPANDMAPELT2
[LAMBDA (ARGS) (* hdj "28-Sep-84 11:57")
(* * 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 (RATIONALIZEMAPELT2 RESULT (QUOTE \BLKFTIMES)
ARRAY1 ARRAY2))
((PERMUTE ELT)
(RATIONALIZEMAPELT2 RESULT (QUOTE \BLKPERM)
ARRAY1 ARRAY2))
(FPLUS (RATIONALIZEMAPELT2 RESULT (QUOTE \BLKFPLUS)
ARRAY1 ARRAY2))
(FDIFF (RATIONALIZEMAPELT2 RESULT (QUOTE \BLKFDIFF)
ARRAY1 ARRAY2))
(QUOTE IGNOREMACRO))
else (QUOTE IGNOREMACRO])
(RATIONALIZEMAPELT1
[LAMBDA (ACTUALRESULT ACTUALMAPFN ACTUALARRAY) (* hdj "28-Sep-84 11:48")
(BQUOTE (LET* [(SIZE (ARRAYSIZE , ACTUALARRAY))
(RESULT (OR (ARRAYP , ACTUALRESULT)
(ARRAY SIZE (QUOTE FLOATP)
0.0
(ARRAYORIG , ACTUALARRAY]
(, ACTUALMAPFN (ARRAYBASE , ACTUALARRAY)
(ARRAYBASE RESULT)
SIZE)
RESULT])
(RATIONALIZEMAPELT2
[LAMBDA (ACTUALRESULT ACTUALMAPFN ACTUALARRAY1 ACTUALARRAY2)
(* hdj "12-Nov-84 17:14")
(BQUOTE (LET* [(SIZE (ARRAYSIZE , ACTUALARRAY1))
(RESULT (OR (ARRAYP , ACTUALRESULT)
(ARRAY SIZE (QUOTE FLOATP)
0.0
(ARRAYORIG , ACTUALARRAY1]
(, ACTUALMAPFN (ARRAYBASE , ACTUALARRAY1)
(ARRAYBASE , ACTUALARRAY2)
(ARRAYBASE RESULT)
SIZE)
RESULT])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS MAPELT MACRO (ARGS (EXPANDMAPELT ARGS)))
(PUTPROPS MAPELT1 MACRO (ARGS (EXPANDMAPELT1 ARGS)))
(PUTPROPS MAPELT2 DMACRO (ARGS (EXPANDMAPELT2 ARGS)))
)
(* * FFT stuff)
(DEFINEQ
(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])
)
(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)))
(DECLARE: EVAL@COMPILE
(RPAQQ \FFTTABLESIZE 32)
(CONSTANTS \FFTTABLESIZE)
)
(* * UFNs)
(DEFINEQ
(\FLOATBLT
[LAMBDA (SOURCE1 SOURCE2 DEST OPERATION N) (* edited: " 7-OCT-83 17:00")
(for I from 0 to (PLUS N N) by 2 do (\PUTBASEFLOATP DEST I
(SELECTQ N
(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])
(\NEWMISC3.UFN
[LAMBDA (ARG1 ARG2 ARG3 ALPHA) (* hdj "19-Sep-84 14:09")
(SELECTQ ALPHA
(0 (BLKEXPONENT ARG1 ARG2 ARG3))
(1 (BLKMAG ARG1 ARG2 ARG3))
(2 (BLKSMALLP2FLOAT ARG1 ARG2 ARG3))
(3 (BLKFLOATP2COMP ARG1 ARG2 ARG3))
(RAID "Illegal op to \MISC3.UFN --" ALPHA])
(\NEWMISC4.UFN
[LAMBDA (ARG1 ARG2 ARG3 ARG4 ALPHA) (* hdj "19-Sep-84 13:55")
(SELECTQ ALPHA
(0 (BLKFTIMES ARG1 ARG2 ARG3 ARG4))
(1 (BLKPERM ARG1 ARG2 ARG3 ARG4))
(2 (BLKFPLUS ARG1 ARG2 ARG3 ARG4))
(3 (BLKFDIFF ARG1 ARG2 ARG3 ARG4))
(4 (BLKSEP ARG1 ARG2 ARG3 ARG4))
(RAID "Illegal op to \MISC4.UFN -- " ALPHA])
(\NEWMISC5.UFN
[LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ALPHA) (* hdj "19-Sep-84 14:10")
(SELECTQ ALPHA
((0 THRU N)
(\FLOATBLT ARG1 ARG2 ARG3 ARG4 ARG5 ALPHA))
(RAID "illegal op to \MISC5.UFN -- ALPHA"])
(\NEWMISC8.UFN
[LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ALPHA) (* hdj "20-Sep-84 10:59")
(SELECTQ ALPHA
(0 (IBLT1 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8))
(1 (IBLT2 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8))
(RAID "Illegal op to \MISC8.UFN --" ALPHA])
)
(PUTPROPS \FLOATBLT DOPVAL (5 FLOATBLT))
(* * sub-UFNs of \NEWMISC3.UFN)
(DEFINEQ
(BLKEXPONENT
[LAMBDA (source destination kount) (* edited: "24-Jun-84 23:44")
(* * extract the exponent of each element of source, stick it in destination)
(* \CHECKARRAYINDEX destination
(SUB1 kount))
(for X from 0 to (SUB1 kount) do (\PUTBASE destination X (fetch (FLOATP EXPONENT)
of (\GETBASEFLOATP source
(LLSH X 1])
(BLKFLOATP2COMP
[LAMBDA (source destination kount) (* hdj "21-Jun-84 19:03")
(* * moves the contents of a Real array into a Complex array; sets imaginary part to 0)
(* \CHECKARRAYINDEX destination
(SUB1 kount))
(for sourceElt from 0 to (SUB1 kount) do (SETCOMPLEX (\ADDBASE destination (LLSH sourceElt 2))
(\GETBASEFLOATP source (LLSH sourceElt 1))
0.0])
(BLKMAG
[LAMBDA (complexArray magnitudeArray kount) (* hdj "21-Jun-84 18:53")
(* \CHECKARRAYINDEX magnitudeArray
(SUB1 kount))
(for magnitude from 0 to (SUB1 kount) bind complexcount real imag
do (SETQ complexcount (LLSH magnitude 2))
(SETQ real (\GETBASEFLOATP complexArray complexcount))
(SETQ imag (\GETBASEFLOATP complexArray (IPLUS complexcount 2)))
(\PUTBASEFLOATP magnitudeArray (LLSH magnitude 1)
(FPLUS (FTIMES real real)
(FTIMES imag imag])
(BLKSMALLP2FLOAT
[LAMBDA (source destination kkount) (* edited: "22-Jun-84 04:21")
(* * convert an array of SMALLPs to FLOATPs)
(* \CHECKARRAYINDEX destination
(SUB1 kount))
(for NN from 0 to (SUB1 kkount) do (\PUTBASEFLOATP destination (LLSH NN 1)
(FLOAT (\GETBASE source NN])
)
(* * sub-UFNs of \NEWMISC4.UFN)
(DEFINEQ
(BLKSEP
[LAMBDA (SOURCE1 SOURCE2 DEST KOUNT) (* hdj "12-Nov-84 16:02")
(* *)
(for ALPHAINDEX from 0 to (DOUBLE (SUB1 KOUNT)) by 8 bind BETAINDEX GAMMAINDEX DELTAINDEX
do (SETQ BETAINDEX (IDIFFERENCE KOUNT ALPHAINDEX))
(SETQ GAMMAINDEX (IPLUS ALPHAINDEX 2))
(SETQ DELTAINDEX (IPLUS BETAINDEX 2))
(\PUTBASEFLOATP DEST ALPHAINDEX (FPLUS (\GETBASEFLOATP SOURCE1 ALPHAINDEX)
(\GETBASEFLOATP SOURCE2 BETAINDEX)))
(\PUTBASEFLOATP DEST (IPLUS ALPHAINDEX 2)
(FDIFFERENCE (\GETBASEFLOATP SOURCE1 GAMMAINDEX)
(\GETBASEFLOATP SOURCE2 DELTAINDEX)))
(\PUTBASEFLOATP DEST (IPLUS ALPHAINDEX 4)
(FPLUS (\GETBASEFLOATP SOURCE1 GAMMAINDEX)
(\GETBASEFLOATP SOURCE2 DELTAINDEX)))
(\PUTBASEFLOATP DEST (IPLUS ALPHAINDEX 6)
(FDIFFERENCE (\GETBASEFLOATP SOURCE1 ALPHAINDEX)
(\GETBASEFLOATP SOURCE2 BETAINDEX])
(BLKPERM
[LAMBDA (orig permutations destination kount) (* hdj "21-Jun-84 19:26")
(* * destination (x) ← orig (perm (x)))
(* * args are arrays of smallps (words))
(* * must fold initial into offset for compatibility with microcode)
(* \CHECKARRAYINDEX destination
(SUB1 kount))
(for X from 0 to (SUB1 kount) do (\PUTBASE destination X (\GETBASE orig (\GETBASE permutations X])
(BLKFDIFF
[LAMBDA (SOURCE1 SOURCE2 DEST KOUNT) (* hdj "20-Sep-84 12:35")
(for INDEX from 0 to (DOUBLE (SUB1 KOUNT)) by 2 do (\PUTBASEFLOATP DEST INDEX
(FDIFFERENCE (\GETBASEFLOATP
SOURCE1 INDEX)
(\GETBASEFLOATP
SOURCE2 INDEX])
(BLKFPLUS
[LAMBDA (SOURCE1 SOURCE2 DEST KOUNT) (* hdj "20-Sep-84 12:36")
(for INDEX from 0 to (DOUBLE (SUB1 KOUNT)) by 2 do (\PUTBASEFLOATP DEST INDEX
(FPLUS (\GETBASEFLOATP SOURCE1
INDEX)
(\GETBASEFLOATP SOURCE2
INDEX])
(BLKFTIMES
[LAMBDA (SOURCE1 SOURCE2 DEST KOUNT) (* hdj "21-Jun-84 19:11")
(* \CHECKARRAYINDEX DEST (SUB1 KOUNT))
(for INDEX from 0 to (LLSH (SUB1 KOUNT)
1)
by 2 do (\PUTBASEFLOATP DEST INDEX (FTIMES (\GETBASEFLOATP SOURCE1 INDEX)
(\GETBASEFLOATP SOURCE2 INDEX])
)
(* * sub-UFNs of \NEWMISC8.UFN)
(DEFINEQ
(IBLT1
[LAMBDA (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth Kount)
(* hdj " 2-Jul-84 17:52")
(* * ValueArray -
an array of 128 elements, 8 bits each)
(* * TextureArray -
an array of 256 elements, each a texture)
(* * XCoord -
bit offset from left of destination bitmap)
(* * BitmapAddr -
destination)
(* * BitmapWidth -
width of dest bitmap in words)
(* * ValHeight -
height of bar)
(* * ValWidth -
width of bar)
(* * Kount -
how many elements of ValueArray to graph)
(PROG (TEXTURE (BITMAPOFFSET BitmapAddr))
(for val from (SUB1 Kount) to 0 by -1
do (SETQ TEXTURE (\GETBASE TextureArray (\GETBASE ValueArray val)))
(for X from 1 to ValHeight
do (\PUTBASEBITS BITMAPOFFSET XCoord ValWidth TEXTURE)
(SETQ BITMAPOFFSET (\ADDBASE BITMAPOFFSET BitmapWidth])
(IBLT2
[LAMBDA (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth Kount)
(* hdj "20-Sep-84 12:20")
(* * Steps by 2, as opposed to IBLT1, which steps by 1)
(* * ValueArray -
an array of 128 elements, 8 bits each)
(* * TextureArray -
an array of 256 elements, each a texture)
(* * XCoord -
bit offset from left of destination bitmap)
(* * BitmapAddr -
destination)
(* * BitmapWidth -
width of dest bitmap in words)
(* * ValHeight -
height of bar)
(* * ValWidth -
width of bar)
(* * Kount -
how many elements of ValueArray to graph)
(PROG (TEXTURE (BITMAPOFFSET BitmapAddr))
(for val from (SUB1 Kount) to 0 by -2
do (SETQ TEXTURE (\GETBASE TextureArray (\GETBASE ValueArray val)))
(for X from 1 to ValHeight
do (\PUTBASEBITS BITMAPOFFSET XCoord ValWidth TEXTURE)
(SETQ BITMAPOFFSET (\ADDBASE BITMAPOFFSET BitmapWidth])
)
(* * install the new UFNs)
(DEFINEQ
(TURNONFLOATARRAYUFNS
[LAMBDA NIL (* hdj "21-Nov-84 15:53")
(* * Installs the real UFNs for \MISC3.UFN, \MISC4.UFN, \MISC5.UFN, and \MISC8.UFN)
(MOVD (QUOTE \NEWMISC3.UFN)
(QUOTE \MISC3.UFN))
(MOVD (QUOTE \NEWMISC4.UFN)
(QUOTE \MISC4.UFN))
(MOVD (QUOTE \NEWMISC5.UFN)
(QUOTE \MISC5.UFN))
(MOVD (QUOTE \NEWMISC8.UFN)
(QUOTE \MISC8.UFN])
)
(* * For convenience)
(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))
(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) (* hdj "14-Nov-84 18:16")
(FETCH (ARRAYP BASE) OF ARRAY])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA MAPELT)
)
(PUTPROPS FLOATARRAY COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1613 10076 (MAPELT 1623 . 2876) (MAPELT1 2878 . 4041) (MAPELT2 4043 . 6099) (
EXPANDMAPELT 6101 . 6523) (EXPANDMAPELT1 6525 . 8097) (EXPANDMAPELT2 8099 . 9147) (RATIONALIZEMAPELT1
9149 . 9568) (RATIONALIZEMAPELT2 9570 . 10074)) (10306 11839 (FFTSTEP 10316 . 10540) (\FFTSTEP 10542
. 11837)) (13563 16415 (\FLOATBLT 13573 . 15069) (\NEWMISC3.UFN 15071 . 15431) (\NEWMISC4.UFN 15433
. 15839) (\NEWMISC5.UFN 15841 . 16101) (\NEWMISC8.UFN 16103 . 16413)) (16500 18706 (BLKEXPONENT 16510
. 17032) (BLKFLOATP2COMP 17034 . 17580) (BLKMAG 17582 . 18241) (BLKSMALLP2FLOAT 18243 . 18704)) (
18745 21523 (BLKSEP 18755 . 19795) (BLKPERM 19797 . 20363) (BLKFDIFF 20365 . 20728) (BLKFPLUS 20730 .
21088) (BLKFTIMES 21090 . 21521)) (21562 23945 (IBLT1 21572 . 22720) (IBLT2 22722 . 23943)) (23979
24476 (TURNONFLOATARRAYUFNS 23989 . 24474)) (25668 25837 (ARRAYBASE 25678 . 25835)))))
STOP