home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / optim.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  5.6 KB  |  164 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8.  
  9. (in-package "MAXIMA")
  10. ;    ** (c) Copyright 1982 Massachusetts Institute of Technology **
  11.  
  12. (macsyma-module optim)
  13.  
  14. (DECLARE-TOP (SPECIAL VARS SETQS OPTIMCOUNT XVARS)
  15.      (FIXNUM N (OPT-HASH))
  16.      (ARRAY* (NOTYPE (SUBEXP 1)))
  17.      #-NIL (UNSPECIAL ARGS))
  18.  
  19. ;(ARRAY *SUBEXP* T 64.)
  20. (defvar *subexp* (*array nil t 64.))
  21.  
  22. (DEFMVAR $OPTIMPREFIX '$%)
  23.  
  24. (DEFMVAR $OPTIMWARN T "warns if OPTIMIZE encounters a special form.")
  25.  
  26. ;; $OPTIMIZE takes a Macsyma expression and returns a BLOCK form which is
  27. ;; equivalent, but which uses local variables to store the results of computing
  28. ;; common subexpressions.  These subexpressions are found by hashing them.
  29.  
  30. (DEFMFUN $OPTIMIZE (X0)
  31.   (LET (($OPTIMWARN $OPTIMWARN))
  32.     (PROG (VARS SETQS OPTIMCOUNT XVARS X)
  33.       (SETQ OPTIMCOUNT 0 XVARS (CDR ($LISTOFVARS X0)))
  34.       (FILLARRAY *subexp* '(NIL))
  35.       (SETQ X (COLLAPSE (OPFORMAT (COLLAPSE X0))))
  36.       (IF (ATOM X) (RETURN X))
  37.       (COMEXP X)
  38.       (SETQ X (OPTIM X))
  39.       (RETURN (PROG1 (COND ((NULL VARS) X0)
  40.                (T (IF (OR (NOT (EQ (CAAR X) 'MPROG))
  41.                       (AND ($LISTP (CADR X)) (CDADR X)))
  42.                   (SETQ X (NREVERSE (CONS X SETQS)))
  43.                   (SETQ X ;(NCONC (NREVERSE SETQS) (CDDR X))
  44.                       (NRECONC SETQS (CDDR X))))
  45.                   `((MPROG SIMP) ((MLIST) . ,(NREVERSE VARS)) . ,X)))
  46.              (FILLARRAY *subexp* '(NIL)))))))
  47.  
  48. (DEFUN OPFORMAT (X)
  49.   (COND ((ATOM X) X)
  50.     ((SPECREPP X) (OPFORMAT (SPECDISREP X)))
  51.     ((AND $OPTIMWARN
  52.           (MSPECFUNP (CAAR X))
  53.           (PROG2 (MTELL "OPTIMIZE has met up with a special form - ~
  54.                  answer may be wrong.")
  55.              (SETQ $OPTIMWARN NIL))))
  56.     ((EQ (CAAR X) 'MEXPT) (OPMEXPT X))
  57.     (T (LET ((NEWARGS (MAPCAR #'OPFORMAT (CDR X))))
  58.          (IF (ALIKE NEWARGS (CDR X)) X (CONS (CAR X) NEWARGS))))))
  59.  
  60. (DEFUN OPMEXPT (X)
  61.   (LET ((*BASE (OPFORMAT (CADR X))) (EXP (OPFORMAT (CADDR X))) XNEW NEGEXP)
  62.     (SETQ NEGEXP
  63.       (COND ((AND (NUMBERP EXP) (MINUSP EXP)) (MINUS EXP))
  64.         ((AND (RATNUMP EXP) (MINUSP (CADR EXP)))
  65.          (LIST (CAR EXP) (MINUS (CADR EXP)) (CADDR EXP)))
  66.         ((AND (MTIMESP EXP) (NUMBERP (CADR EXP)) (MINUSP (CADR EXP)))
  67.          (IF (EQUAL (CADR EXP) -1)
  68.              (IF (NULL (CDDDR EXP)) (CADDR EXP)
  69.                         (CONS (CAR EXP) (CDDR EXP)))
  70.              (LIST* (CAR EXP) (MINUS (CADR EXP)) (CDDR EXP))))
  71.         ((AND (MTIMESP EXP) (RATNUMP (CADR EXP)) (MINUSP (CADADR EXP)))
  72.          (LIST* (CAR EXP)
  73.             (LIST (CAADR EXP) (MINUS (CADADR EXP)) (CADDR (CADR EXP)))
  74.             (CDDR EXP)))))
  75.     (SETQ XNEW
  76.       (COND (NEGEXP
  77.          `((MQUOTIENT)
  78.            1
  79.            ,(COND ((EQUAL NEGEXP 1) *BASE)
  80.               (T (SETQ XNEW (LIST (CAR X) *BASE NEGEXP))
  81.                  (IF (AND (RATNUMP NEGEXP) (EQUAL (CADDR NEGEXP) 2))
  82.                  (OPMEXPT XNEW)
  83.                  XNEW)))))
  84.         ((AND (RATNUMP EXP) (EQUAL (CADDR EXP) 2)) 
  85.          (SETQ EXP (CADR EXP))
  86.          (IF (EQUAL EXP 1) `((%SQRT) ,*BASE)
  87.                    `((MEXPT) ((%SQRT) ,*BASE) ,EXP)))
  88.         (T (LIST (CAR X) *BASE EXP))))
  89.     (IF (ALIKE1 X XNEW) X XNEW)))
  90.  
  91. (DEFMFUN $COLLAPSE (X)
  92.   (FILLARRAY *subexp* '(NIL))
  93.   (PROG1 (COLLAPSE X) (FILLARRAY *subexp* '(NIL))))
  94.        
  95. (DEFUN COLLAPSE (X)
  96.   (COND ((ATOM X) X)
  97.     ((SPECREPP X) (COLLAPSE (SPECDISREP X)))
  98.     (T (LET ((N (OPT-HASH (CAAR X))))
  99.          (DO ((L (CDR X) (CDR L)))
  100.          ((NULL L))
  101.          (IF (NOT (EQ (COLLAPSE (CAR L)) (CAR L)))
  102.              (RPLACA L (COLLAPSE (CAR L))))
  103.          (SETQ N (fixnum-remainder (f+ (OPT-HASH (CAR L)) N) 12553.)))
  104.          (SETQ N (LOGAND 63. N))
  105.          (DO ((L (aref *subexp* N) (CDR L)))
  106.          ((NULL L) (STORE (aref *subexp* N) (CONS (LIST X) (aref *subexp* N))) X)
  107.          (IF (ALIKE1 X (CAAR L)) (RETURN (CAAR L))))))))
  108.  
  109. (DEFUN COMEXP (X)
  110.   (IF (NOT (OR (ATOM X) (EQ (CAAR X) 'RAT)))
  111.       (LET ((N (OPT-HASH (CAAR X))))
  112.     (DOLIST (U (CDR X)) (SETQ N (fixnum-remainder (f+ (OPT-HASH U) N) 12553.)))
  113.     (SETQ X (ASSOL X (aref *subexp* (LOGAND 63. N))))
  114.     (COND ((NULL (CDR X)) (RPLACD X 'SEEN) (MAPC #'COMEXP (CDAR X)))
  115.           (T (RPLACD X 'COMEXP))))))
  116.  
  117. (DEFUN OPTIM (X)
  118.   (COND ((ATOM X) X)
  119.     ((AND (MEMQ 'array (CDAR X))
  120.           (NOT (EQ (CAAR X) 'MQAPPLY))
  121.           (NOT (MGET (CAAR X) 'ARRAYFUN-MODE)))
  122.      X)
  123.     ((EQ (CAAR X) 'RAT) X)
  124.     (T (LET ((N (OPT-HASH (CAAR X))) (NX (LIST (CAR X))))
  125.          (DOLIST (U (CDR X))
  126.         (SETQ N (fixnum-remainder (f+ (OPT-HASH U) N) 12553.)
  127.               NX (CONS (OPTIM U) NX)))
  128.          (SETQ X (ASSOL X (aref *subexp* (LOGAND 63. N))) NX (NREVERSE NX))
  129.          (COND ((EQ (CDR X) 'SEEN) NX)
  130.            ((EQ (CDR X) 'COMEXP)
  131.             (RPLACD X (GETOPTIMVAR))
  132.             (SETQ SETQS (CONS `((MSETQ) ,(CDR X) ,NX) SETQS))
  133.             (CDR X))
  134.            (T (CDR X)))))))
  135.  
  136. (DEFUN OPT-HASH (EXP)  ; EXP is in general representation.
  137.   (fixnum-remainder (IF (ATOM EXP)
  138.      (SXHASH EXP)
  139.      (DO ((N (OPT-HASH (CAAR EXP)))
  140.           (ARGS (CDR EXP) (CDR ARGS)))
  141.          ((NULL ARGS) N)
  142.          (SETQ N (fixnum-remainder (f+ (OPT-HASH (CAR ARGS)) N) 12553.))))
  143.      12553.))  ; a prime number < 2^14 ; = PRIME(1500)
  144.  
  145.  
  146. (DEFUN GETOPTIMVAR ()
  147.  (sloop with var
  148.        do
  149.        (INCREMENT OPTIMCOUNT)
  150.        (SETQ VAR
  151.          #-(or NIL cl) (INTERN  (MAKNAM (NCONC (EXPLODEN $OPTIMPREFIX)
  152.                            (MEXPLODEN OPTIMCOUNT))))
  153.          #+cl (MAKE-SYMBOL
  154.            (FORMAT NIL "~A~D"
  155.                $OPTIMPREFIX OPTIMCOUNT))
  156.              #+NIL (SYMBOLCONC $OPTIMPREFIX OPTIMCOUNT))
  157.        while (MEMQ VAR XVARS)
  158.        finally
  159.        (SETQ VARS (CONS VAR VARS))
  160.        (RETURN VAR)))
  161.  
  162.  
  163.  
  164.