(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "22-Apr-87 09:55:51" {ERIS}<LISPCORE>LIBRARY>MATMULT.;24 29646
changes to%: (FUNCTIONS %%MATMULT-N33)
previous date%: "15-Apr-87 16:49:42" {ERIS}<LISPCORE>LIBRARY>MATMULT.;23)
(* "
Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT MATMULTCOMS)
(RPAQQ MATMULTCOMS
(
(* ;;; "User entry points")
(DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES FLOAT-ARRAY-SUPPORT))
(FUNCTIONS %%MATMULT-N33 %%MATMULT-N44 DEGREES-TO-RADIANS IDENTITY-3-BY-3 IDENTITY-4-BY-4
MAKE-HOMOGENEOUS-3-BY-3 MAKE-HOMOGENEOUS-3-VECTOR MAKE-HOMOGENEOUS-4-BY-4
MAKE-HOMOGENEOUS-4-VECTOR MAKE-HOMOGENEOUS-N-BY-3 MAKE-HOMOGENEOUS-N-BY-4 MATMULT-133
MATMULT-144 MATMULT-331 MATMULT-333 MATMULT-441 MATMULT-444 MATMULT-N33 MATMULT-N44
PERSPECTIVE-4-BY-4 PROJECT-AND-FIX-3-VECTOR PROJECT-AND-FIX-4-VECTOR
PROJECT-AND-FIX-N-BY-3 PROJECT-AND-FIX-N-BY-4 ROTATE-3-BY-3 ROTATE-4-BY-4-ABOUT-X
ROTATE-4-BY-4-ABOUT-Y ROTATE-4-BY-4-ABOUT-Z SCALE-3-BY-3 SCALE-4-BY-4 TRANSLATE-3-BY-3
TRANSLATE-4-BY-4)
(* ;;; "Compiler options")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
(PROP FILETYPE MATMULT)))
(* ;;; "User entry points")
(DECLARE%: DONTCOPY DOEVAL@COMPILE
(FILESLOAD FLOAT-ARRAY-SUPPORT)
)
(DEFMACRO %%MATMULT-N33 (N A-BASE B-BASE RESULT-BASE) `(CL:DO ((I 0 (CL:1+ I))
(SOURCE-BASE ,A-BASE (\ADDBASE
SOURCE-BASE
6))
(DEST-BASE ,RESULT-BASE
(\ADDBASE DEST-BASE 6))
(MATRIX-BASE ,B-BASE))
((EQ I ,N))
(%%MATMULT-133 SOURCE-BASE MATRIX-BASE
DEST-BASE)))
(DEFMACRO %%MATMULT-N44 (N A-BASE B-BASE RESULT-BASE) `(CL:DO ((I 0 (CL:1+ I))
(SOURCE-BASE ,A-BASE (\ADDBASE
SOURCE-BASE
8))
(DEST-BASE ,RESULT-BASE
(\ADDBASE DEST-BASE 8))
(MATRIX-BASE ,B-BASE))
((EQ I ,N))
(%%MATMULT-144 SOURCE-BASE MATRIX-BASE
DEST-BASE)))
(CL:DEFUN DEGREES-TO-RADIANS (DEGREES) (CL:* (FLOAT DEGREES)
(CONSTANT (/ CL:PI 180.0))))
(CL:DEFUN IDENTITY-3-BY-3 (&OPTIONAL RESULT) (LET [(MATRIX (%%INSURE-ARRAY RESULT (3 3]
(FILL-ARRAY MATRIX 0.0)
(CL:DOTIMES (I 3)
(ASET 1.0 MATRIX I I))
MATRIX))
(CL:DEFUN IDENTITY-4-BY-4 (&OPTIONAL RESULT) (LET [(MATRIX (%%INSURE-ARRAY RESULT (4 4]
(FILL-ARRAY MATRIX 0.0)
(CL:DOTIMES (I 4)
(ASET 1.0 MATRIX I I))
MATRIX))
(CL:DEFUN MAKE-HOMOGENEOUS-3-BY-3 (&KEY A00 A01 A10 A11 A20 A21)
(LET [(MATRIX (CL:MAKE-ARRAY '(3 3) :ELEMENT-TYPE 'CL:SINGLE-FLOAT]
(CL:IF A00 (ASET (FLOAT A00)
MATRIX 0 0))
(CL:IF A01 (ASET (FLOAT A01)
MATRIX 0 1))
(CL:IF A10 (ASET (FLOAT A10)
MATRIX 1 0))
(CL:IF A11 (ASET (FLOAT A11)
MATRIX 1 1))
(CL:IF A20 (ASET (FLOAT A20)
MATRIX 2 0))
(CL:IF A21 (ASET (FLOAT A21)
MATRIX 2 1))
(ASET 1.0 MATRIX 2 2)
MATRIX))
(CL:DEFUN MAKE-HOMOGENEOUS-3-VECTOR (&OPTIONAL X Y) (LET [(V (MAKE-VECTOR 3 :ELEMENT-TYPE
'CL:SINGLE-FLOAT]
(CL:IF X (ASET (FLOAT X)
V 0))
(CL:IF Y (ASET (FLOAT Y)
V 1))
(ASET 1.0 V 2)
V))
(CL:DEFUN MAKE-HOMOGENEOUS-4-BY-4 (&KEY A00 A01 A02 A03 A10 A11 A12 A13 A20 A21 A22 A23 A30 A31 A32)
(LET [(MATRIX (CL:MAKE-ARRAY '(4 4) :ELEMENT-TYPE 'CL:SINGLE-FLOAT]
(CL:IF A00 (ASET (FLOAT A00)
MATRIX 0 0))
(CL:IF A01 (ASET (FLOAT A01)
MATRIX 0 1))
(CL:IF A02 (ASET (FLOAT A02)
MATRIX 0 2))
(CL:IF A03 (ASET (FLOAT A03)
MATRIX 0 3))
(CL:IF A10 (ASET (FLOAT A10)
MATRIX 1 0))
(CL:IF A11 (ASET (FLOAT A11)
MATRIX 1 1))
(CL:IF A12 (ASET (FLOAT A12)
MATRIX 1 2))
(CL:IF A13 (ASET (FLOAT A13)
MATRIX 1 3))
(CL:IF A20 (ASET (FLOAT A20)
MATRIX 2 0))
(CL:IF A21 (ASET (FLOAT A21)
MATRIX 2 1))
(CL:IF A22 (ASET (FLOAT A22)
MATRIX 2 2))
(CL:IF A23 (ASET (FLOAT A23)
MATRIX 2 3))
(CL:IF A30 (ASET (FLOAT A30)
MATRIX 3 0))
(CL:IF A31 (ASET (FLOAT A31)
MATRIX 3 1))
(CL:IF A32 (ASET (FLOAT A32)
MATRIX 3 2))
(ASET 1.0 MATRIX 3 3)
MATRIX))
(CL:DEFUN MAKE-HOMOGENEOUS-4-VECTOR (&OPTIONAL X Y Z) (LET [(V (MAKE-VECTOR 4 :ELEMENT-TYPE
'CL:SINGLE-FLOAT]
(CL:IF X (ASET (FLOAT X)
V 0))
(CL:IF Y (ASET (FLOAT Y)
V 1))
(CL:IF Z (ASET (FLOAT Z)
V 2))
(ASET 1.0 V 3)
V))
(CL:DEFUN MAKE-HOMOGENEOUS-N-BY-3 (N &KEY INITIAL-ELEMENT) (LET [(MATRIX (CL:MAKE-ARRAY (LIST N 3)
:ELEMENT-TYPE
'CL:SINGLE-FLOAT]
(CL:IF INITIAL-ELEMENT
(FILL-ARRAY MATRIX
(FLOAT INITIAL-ELEMENT)
))
(CL:DOTIMES (I N)
(ASET 1.0 MATRIX I 2))
MATRIX))
(CL:DEFUN MAKE-HOMOGENEOUS-N-BY-4 (N &KEY INITIAL-ELEMENT) (LET [(MATRIX (CL:MAKE-ARRAY (LIST N 4)
:ELEMENT-TYPE
'CL:SINGLE-FLOAT]
(CL:IF INITIAL-ELEMENT
(FILL-ARRAY MATRIX
(FLOAT INITIAL-ELEMENT)
))
(CL:DOTIMES (I N)
(ASET 1.0 MATRIX I 3))
MATRIX))
(CL:DEFUN MATMULT-133 (VECTOR MATRIX &OPTIONAL RESULT) (%%TEST-ARRAY VECTOR (3))
(%%TEST-ARRAY MATRIX (3 3))
(SETQ RESULT (%%INSURE-ARRAY RESULT (3)))
(CL:IF (EQ VECTOR RESULT)
(CL:ERROR
"Results undefined if VECTOR reused"
))
(%%MATMULT-133 (%%GET-FLOAT-ARRAY-BASE VECTOR)
(%%GET-FLOAT-ARRAY-BASE MATRIX)
(%%GET-FLOAT-ARRAY-BASE RESULT))
RESULT)
(CL:DEFUN MATMULT-144 (VECTOR MATRIX &OPTIONAL RESULT) (%%TEST-ARRAY VECTOR (4))
(%%TEST-ARRAY MATRIX (4 4))
(SETQ RESULT (%%INSURE-ARRAY RESULT (4)))
(CL:IF (EQ VECTOR RESULT)
(CL:ERROR
"Results undefined if VECTOR reused"
))
(%%MATMULT-144 (%%GET-FLOAT-ARRAY-BASE VECTOR)
(%%GET-FLOAT-ARRAY-BASE MATRIX)
(%%GET-FLOAT-ARRAY-BASE RESULT))
RESULT)
(CL:DEFUN MATMULT-331 (MATRIX VECTOR &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX (3 3))
(%%TEST-ARRAY VECTOR (3))
(SETQ RESULT (%%INSURE-ARRAY RESULT (3)))
(CL:IF (EQ MATRIX RESULT)
(CL:ERROR
"Results undefined if MATRIX reused"
))
(%%MATMULT-331 (%%GET-FLOAT-ARRAY-BASE MATRIX)
(%%GET-FLOAT-ARRAY-BASE VECTOR)
(%%GET-FLOAT-ARRAY-BASE RESULT))
RESULT)
(CL:DEFUN MATMULT-333 (MATRIX-1 MATRIX-2 &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX-1 (3 3))
(%%TEST-ARRAY MATRIX-2 (3 3))
(SETQ RESULT (%%INSURE-ARRAY RESULT
(3 3)))
(CL:IF (EQ MATRIX-1 RESULT)
(CL:ERROR
"Results undefined if MATRIX-1 reused"
))
(%%MATMULT-333 (%%GET-FLOAT-ARRAY-BASE
MATRIX-1)
(%%GET-FLOAT-ARRAY-BASE MATRIX-2)
(%%GET-FLOAT-ARRAY-BASE RESULT))
RESULT)
(CL:DEFUN MATMULT-441 (MATRIX VECTOR &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX (4 4))
(%%TEST-ARRAY VECTOR (4))
(SETQ RESULT (%%INSURE-ARRAY RESULT (4)))
(CL:IF (EQ MATRIX RESULT)
(CL:ERROR
"Results undefined if MATRIX reused"
))
(%%MATMULT-441 (%%GET-FLOAT-ARRAY-BASE MATRIX)
(%%GET-FLOAT-ARRAY-BASE VECTOR)
(%%GET-FLOAT-ARRAY-BASE RESULT))
RESULT)
(CL:DEFUN MATMULT-444 (MATRIX-1 MATRIX-2 &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX-1 (4 4))
(%%TEST-ARRAY MATRIX-2 (4 4))
(SETQ RESULT (%%INSURE-ARRAY RESULT
(4 4)))
(CL:IF (EQ MATRIX-1 RESULT)
(CL:ERROR
"Results undefined if MATRIX-1 reused"
))
(%%MATMULT-444 (%%GET-FLOAT-ARRAY-BASE
MATRIX-1)
(%%GET-FLOAT-ARRAY-BASE MATRIX-2)
(%%GET-FLOAT-ARRAY-BASE RESULT))
RESULT)
(CL:DEFUN MATMULT-N33 (MATRIX-1 MATRIX-2 &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX-1 (CL:* 3))
(%%TEST-ARRAY MATRIX-2 (3 3))
(SETQ RESULT (%%INSURE-ARRAY RESULT
(CL:* 3)
(CL:ARRAY-DIMENSIONS
MATRIX-1)))
(CL:IF (EQ MATRIX-1 RESULT)
(CL:ERROR
"Results undefined if MATRIX-1 reused"
))
(LET ((N (CL:ARRAY-DIMENSION MATRIX-1 0)))
(CL:IF (NOT (EQ N (CL:ARRAY-DIMENSION
RESULT 0)))
(CL:ERROR
"Dimensional mismatch")
)
(%%MATMULT-N33 N (
%%GET-FLOAT-ARRAY-BASE
MATRIX-1)
(%%GET-FLOAT-ARRAY-BASE
MATRIX-2)
(%%GET-FLOAT-ARRAY-BASE RESULT
))
RESULT))
(CL:DEFUN MATMULT-N44 (MATRIX-1 MATRIX-2 &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX-1 (CL:* 4))
(%%TEST-ARRAY MATRIX-2 (4 4))
(SETQ RESULT (%%INSURE-ARRAY RESULT
(CL:* 4)
(CL:ARRAY-DIMENSIONS
MATRIX-1)))
(CL:IF (EQ MATRIX-1 RESULT)
(CL:ERROR
"Results undefined if MATRIX-1 reused"
))
(LET ((N (CL:ARRAY-DIMENSION MATRIX-1 0)))
(CL:IF (NOT (EQ N (CL:ARRAY-DIMENSION
RESULT 0)))
(CL:ERROR
"Dimensional mismatch")
)
(%%MATMULT-N44 N (
%%GET-FLOAT-ARRAY-BASE
MATRIX-1)
(%%GET-FLOAT-ARRAY-BASE
MATRIX-2)
(%%GET-FLOAT-ARRAY-BASE RESULT
))
RESULT))
(CL:DEFUN PERSPECTIVE-4-BY-4 (PX PY PZ &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT)))
(ASET (FLOAT PX)
MATRIX 0 3)
(ASET (FLOAT PY)
MATRIX 1 3)
(ASET (FLOAT PZ)
MATRIX 2 3)
MATRIX))
(CL:DEFUN PROJECT-AND-FIX-3-VECTOR (3-VECTOR &OPTIONAL 2-VECTOR)
(%%TEST-ARRAY 3-VECTOR (3))
(COND
[(NULL 2-VECTOR)
(SETQ 2-VECTOR (CL:MAKE-ARRAY '(2]
([NOT (TYPEP 2-VECTOR '(CL:ARRAY CL:* (2]
(CL:ERROR "Not a 2 vector: ~s" 2-VECTOR)))
(LET ((3-VECTOR-BASE (%%GET-FLOAT-ARRAY-BASE 3-VECTOR)))
(CL:DOTIMES (J 2)
(ASET (UFIX (\GETBASEFLOATP 3-VECTOR-BASE (LLSH J 1)))
2-VECTOR J))
2-VECTOR))
(CL:DEFUN PROJECT-AND-FIX-4-VECTOR (4-VECTOR &OPTIONAL 2-VECTOR)
(%%TEST-ARRAY 4-VECTOR (4))
(COND
[(NULL 2-VECTOR)
(SETQ 2-VECTOR (CL:MAKE-ARRAY '(2]
([NOT (TYPEP 2-VECTOR '(CL:ARRAY CL:* (2]
(CL:ERROR "Not a 2 vector: ~s" 2-VECTOR)))
(LET* ((4-VECTOR-BASE (%%GET-FLOAT-ARRAY-BASE 4-VECTOR))
(DIVISOR (\GETBASEFLOATP 4-VECTOR-BASE 6)))
(DECLARE (TYPE FLOATP DIVISOR))
(CL:IF (UFEQP DIVISOR 1.0)
(CL:DOTIMES (J 2)
(ASET (UFIX (\GETBASEFLOATP 4-VECTOR-BASE (LLSH J 1)))
2-VECTOR J))
(CL:DOTIMES (J 2)
(ASET (UFIX (FQUOTIENT (\GETBASEFLOATP 4-VECTOR-BASE (LLSH J 1))
DIVISOR))
2-VECTOR J)))
2-VECTOR))
(CL:DEFUN PROJECT-AND-FIX-N-BY-3 (N-3-MATRIX &OPTIONAL N-2-MATRIX)
(%%TEST-ARRAY N-3-MATRIX (CL:* 3))
(COND
[(NULL N-2-MATRIX)
(SETQ N-2-MATRIX (CL:MAKE-ARRAY (LIST (CL:ARRAY-DIMENSION N-3-MATRIX 0)
2]
([NOT (TYPEP N-2-MATRIX '(CL:ARRAY CL:* (CL:* 2]
(CL:ERROR "Not an N by 2 array: ~s" N-2-MATRIX)))
(LET ((N (CL:ARRAY-DIMENSION N-3-MATRIX 0)))
(CL:IF (NOT (EQ N (CL:ARRAY-DIMENSION N-2-MATRIX 0)))
(CL:ERROR "Dimensional mismatch"))
(CL:DO ((I 0 (CL:1+ I))
(N-3-BASE (%%GET-FLOAT-ARRAY-BASE N-3-MATRIX)
(\ADDBASE N-3-BASE 6)))
((EQ I N))
(CL:DOTIMES (J 2)
(ASET (UFIX (\GETBASEFLOATP N-3-BASE (LLSH J 1)))
N-2-MATRIX I J)))
N-2-MATRIX))
(CL:DEFUN PROJECT-AND-FIX-N-BY-4 (N-4-MATRIX &OPTIONAL N-2-MATRIX)
(%%TEST-ARRAY N-4-MATRIX (CL:* 4))
(COND
[(NULL N-2-MATRIX)
(SETQ N-2-MATRIX (CL:MAKE-ARRAY (LIST (CL:ARRAY-DIMENSION N-4-MATRIX 0)
2]
([NOT (TYPEP N-2-MATRIX '(CL:ARRAY CL:* (CL:* 2]
(CL:ERROR "Not an N by 2 array: ~s" N-2-MATRIX)))
(LET ((N (CL:ARRAY-DIMENSION N-4-MATRIX 0)))
(CL:IF (NOT (EQ N (CL:ARRAY-DIMENSION N-2-MATRIX 0)))
(CL:ERROR "Dimensional mismatch"))
[CL:DO ((I 0 (CL:1+ I))
(N-4-BASE (%%GET-FLOAT-ARRAY-BASE N-4-MATRIX)
(\ADDBASE N-4-BASE 8)))
((EQ I N))
(LET ((DIVISOR (\GETBASEFLOATP N-4-BASE 6)))
(DECLARE (TYPE FLOATP DIVISOR))
(CL:IF (UFEQP DIVISOR 1.0)
(CL:DOTIMES (J 2)
(ASET (UFIX (\GETBASEFLOATP N-4-BASE (LLSH J 1)))
N-2-MATRIX I J))
(CL:DOTIMES (J 2)
(ASET (UFIX (FQUOTIENT (\GETBASEFLOATP N-4-BASE (LLSH J 1))
DIVISOR))
N-2-MATRIX I J]
N-2-MATRIX))
(CL:DEFUN ROTATE-3-BY-3 (RADIANS &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-3-BY-3 RESULT))
(COSPHI (CL:COS RADIANS))
(SINPHI (CL:SIN RADIANS)))
(ASET COSPHI MATRIX 0 0)
(ASET (- SINPHI)
MATRIX 0 1)
(ASET SINPHI MATRIX 1 0)
(ASET COSPHI MATRIX 1 1)
MATRIX))
(CL:DEFUN ROTATE-4-BY-4-ABOUT-X (RADIANS &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT))
(COSPHI (CL:COS RADIANS))
(SINPHI (CL:SIN RADIANS)))
(ASET COSPHI MATRIX 1 1)
(ASET (- SINPHI)
MATRIX 1 2)
(ASET SINPHI MATRIX 2 1)
(ASET COSPHI MATRIX 2 2)
MATRIX))
(CL:DEFUN ROTATE-4-BY-4-ABOUT-Y (RADIANS &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT))
(COSPHI (CL:COS RADIANS))
(SINPHI (CL:SIN RADIANS)))
(ASET COSPHI MATRIX 0 0)
(ASET (- SINPHI)
MATRIX 2 0)
(ASET SINPHI MATRIX 0 2)
(ASET COSPHI MATRIX 2 2)
MATRIX))
(CL:DEFUN ROTATE-4-BY-4-ABOUT-Z (RADIANS &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT))
(COSPHI (CL:COS RADIANS))
(SINPHI (CL:SIN RADIANS)))
(ASET COSPHI MATRIX 0 0)
(ASET (- SINPHI)
MATRIX 0 1)
(ASET SINPHI MATRIX 1 0)
(ASET COSPHI MATRIX 1 1)
MATRIX))
(CL:DEFUN SCALE-3-BY-3 (SX SY &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-3-BY-3 RESULT)))
(ASET (FLOAT SX)
MATRIX 0 0)
(ASET (FLOAT SY)
MATRIX 1 1)
MATRIX))
(CL:DEFUN SCALE-4-BY-4 (SX SY SZ &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT)))
(ASET (FLOAT SX)
MATRIX 0 0)
(ASET (FLOAT SY)
MATRIX 1 1)
(ASET (FLOAT SZ)
MATRIX 2 2)
MATRIX))
(CL:DEFUN TRANSLATE-3-BY-3 (TX TY &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-3-BY-3 RESULT)))
(ASET (FLOAT TX)
MATRIX 2 0)
(ASET (FLOAT TY)
MATRIX 2 1)
MATRIX))
(CL:DEFUN TRANSLATE-4-BY-4 (TX TY TZ &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT)))
(ASET (FLOAT TX)
MATRIX 3 0)
(ASET (FLOAT TY)
MATRIX 3 1)
(ASET (FLOAT TZ)
MATRIX 3 2)
MATRIX))
(* ;;; "Compiler options")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS MATMULT FILETYPE CL:COMPILE-FILE)
(PUTPROPS MATMULT COPYRIGHT ("Xerox Corporation" 1985 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL)))
STOP