(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")

(FILECREATED "19-Oct-86 14:28:50" {QV}<PEDERSEN>LISP>TEST-MATMULT.;2
 10286  

      changes to%:  (FUNCTIONS DRAW-3D-PLOT MATMULT-444* TWO-NORM TEST-MATMULT-444 DRAW-SPIRAL 
                           DRAW-TRIANGLE REDRAW-TRIANGLE)
                    (VARS TEST-MATMULTCOMS)

      previous date%: "17-Oct-86 10:44:23" {QV}<PEDERSEN>LISP>TEST-MATMULT.;1)


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

(PRETTYCOMPRINT TEST-MATMULTCOMS)

(RPAQQ TEST-MATMULTCOMS
 ((FUNCTIONS DRAW-3D-PLOT DRAW-SPIRAL DRAW-TRIANGLE MATMULT-444* 
                                REDRAW-TRIANGLE TEST-MATMULT-444 TWO-NORM)
                         (PROP FILETYPE TEST-MATMULT)))
(CL:DEFUN DRAW-3D-PLOT
 (&OPTIONAL (WINDOW (CREATEW))) (LET* ((XMID (RSH (WINDOWPROP WINDOW
                                                                               'WIDTH)
                                                                        1))
                                                             (YMID (RSH (WINDOWPROP WINDOW
                                                                               'HEIGHT)
                                                                        1))
                                                             (WMAX (MIN XMID YMID))
                                                             (POINTS (MAKE-HOMOGENEOUS-N-BY-4 40))
                                                             (SCRATCH1 (MAKE-HOMOGENEOUS-N-BY-4
                                                                        40))
                                                             (SCRATCH2 (MAKE-HOMOGENEOUS-N-BY-4
                                                                        40))
                                                             (PPOINTS (CL:MAKE-ARRAY
                                                                       '(40 2)))
                                                             (OLDPPOINTS (CL:MAKE-ARRAY
                                                                          '(40 2) :INITIAL-ELEMENT 0)
                                                                    )
                                                             (T1 (TRANSLATE-4-BY-4 (- WMAX)
                                                                        (- WMAX)
                                                                        (- WMAX)))
                                                             (T2 (TRANSLATE-4-BY-4 WMAX WMAX WMAX))
                                                             (R (ROTATE-4-BY-4-ABOUT-X (
                                                                                   DEGREES-TO-RADIANS
                                                                                        5)))
                                                             (TRANS (IDENTITY-4-BY-4))
                                                             (NEWTRANS (IDENTITY-4-BY-4)))
                                                            (CL:DOTIMES
                                                             (I 40)
                                                             (CL:DO ((J 0 (CL:1+ J))
                                                                     (RANGE (LLSH WMAX 1)))
                                                                    ((EQL J 3))
                                                                    (ASET (FLOAT (RAND 0 RANGE))
                                                                          POINTS I J)))
                                                            (CL:LOOP (MATMULT-444 TRANS R NEWTRANS)
                                                                   (MATMULT-N44 POINTS T1 SCRATCH1)
                                                                   (MATMULT-N44 SCRATCH1 TRANS 
                                                                          SCRATCH2)
                                                                   (MATMULT-N44 SCRATCH2 T2 SCRATCH1)
                                                                   (PROJECT-AND-FIX-N-BY-4 SCRATCH1 
                                                                          PPOINTS)
                                                                   (CL:DOTIMES (I 40)
                                                                          (BITMAPBIT WINDOW
                                                                                 (CL:AREF OLDPPOINTS 
                                                                                        I 0)
                                                                                 (CL:AREF OLDPPOINTS 
                                                                                        I 1)
                                                                                 0)
                                                                          (BITMAPBIT WINDOW
                                                                                 (CL:AREF PPOINTS I 0
                                                                                        )
                                                                                 (CL:AREF PPOINTS I 1
                                                                                        )
                                                                                 1))
                                                                   (CL:ROTATEF PPOINTS OLDPPOINTS)
                                                                   (CL:ROTATEF TRANS NEWTRANS))))

(CL:DEFUN DRAW-SPIRAL
 (&OPTIONAL (WINDOW (CREATEW))) (LET ((XMID (RSH (WINDOWPROP WINDOW 'WIDTH)
                                                                      1))
                                                           (YMID (RSH (WINDOWPROP WINDOW 'HEIGHT)
                                                                      1))
                                                           (POINT1 (MAKE-HOMOGENEOUS-3-VECTOR 1.0 1.0
                                                                          ))
                                                           (POINT2 (MAKE-HOMOGENEOUS-3-VECTOR 1.0 1.0
                                                                          ))
                                                           (PPOINT (CL:MAKE-ARRAY 2))
                                                           (M (MATMULT-333 (SCALE-3-BY-3 1.001 1.001)
                                                                     (ROTATE-3-BY-3 (
                                                                                   DEGREES-TO-RADIANS
                                                                                     1)))))
                                                          (CL:DOTIMES
                                                           (I (/ (CL:LOG (MAX XMID YMID)
                                                                        1.001)
                                                                 360))
                                                           (CL:DOTIMES (J 360)
                                                                  (MOVETO XMID YMID WINDOW)
                                                                  (MATMULT-133 POINT1 M POINT2)
                                                                  (PROJECT-AND-FIX-3-VECTOR POINT2 
                                                                         PPOINT)
                                                                  (RELDRAWTO (CL:AREF PPOINT 0)
                                                                         (CL:AREF PPOINT 1)
                                                                         1 NIL WINDOW)
                                                                  (CL:ROTATEF POINT1 POINT2)))))

(CL:DEFUN DRAW-TRIANGLE
 (POINTS WINDOW) (MOVETO (CL:AREF POINTS 0 0)
                                               (CL:AREF POINTS 0 1)
                                               WINDOW)
                                        (DRAWTO (CL:AREF POINTS 1 0)
                                               (CL:AREF POINTS 1 1)
                                               NIL NIL WINDOW)
                                        (DRAWTO (CL:AREF POINTS 2 0)
                                               (CL:AREF POINTS 2 1)
                                               NIL NIL WINDOW)
                                        (DRAWTO (CL:AREF POINTS 0 0)
                                               (CL:AREF POINTS 0 1)
                                               NIL NIL WINDOW))

(CL:DEFUN MATMULT-444*
 (MATRIX-1 MATRIX-2 RESULT) (%%TEST-ARRAY MATRIX-1 (4 4))
                                                  (%%TEST-ARRAY MATRIX-2 (4 4))
                                                  (SETQ RESULT (%%INSURE-ARRAY RESULT (4 4)))
                                                  (\MATMULT444 (%%GET-FLOAT-ARRAY-BASE MATRIX-1)
                                                         (%%GET-FLOAT-ARRAY-BASE MATRIX-2)
                                                         (%%GET-FLOAT-ARRAY-BASE RESULT))
                                                  RESULT)

(CL:DEFUN REDRAW-TRIANGLE
 (FPOINTS M W) (DRAW-TRIANGLE (PROJECT-AND-FIX-N-BY-3 (MATMULT-N33 FPOINTS M
                                                                                      ))
                                               W))

(CL:DEFUN TEST-MATMULT-444
 (A R FN) (CL:DOTIMES (I 10)
                                           (CL:FUNCALL FN A R A))
                                    A)

(CL:DEFUN TWO-NORM
 (A I) (CL:DO ((J 0 (CL:1+ J))
                                 (TOTAL 0.0))
                                ((EQL J 4)
                                 TOTAL)
                                (SETQ TOTAL (+ TOTAL (CL:* (CL:AREF A I J)
                                                           (CL:AREF A I J))))))


(PUTPROPS TEST-MATMULT FILETYPE
 CL:COMPILE-FILE)
(PUTPROPS TEST-MATMULT COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP