/usr/share/maxima/5.32.1/src/optim.lisp is in maxima-src 5.32.1-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The data in this file contains enhancments. ;;;;;
;;; ;;;;;
;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
;;; All rights reserved ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :maxima)
;; ** (c) Copyright 1982 Massachusetts Institute of Technology **
(macsyma-module optim)
(declare-top (unspecial args))
(defvar *subexp* (make-array 64 :initial-element nil))
(defmvar $optimprefix '$%)
(defmvar $optimwarn t "warns if `optimize' encounters a special form.")
;; $OPTIMIZE takes a Macsyma expression and returns a BLOCK form which is
;; equivalent, but which uses local variables to store the results of computing
;; common subexpressions. These subexpressions are found by hashing them.
(defmfun $optimize (x0)
(let (($optimwarn $optimwarn)
*setqs*
vars
(*optimcount* 0)
(*xvars* (cdr ($listofvars x0))))
(declare (special *optimcount* *xvars* *setqs* vars))
(fill *subexp* nil)
(prog ((x (collapse (opformat (collapse x0)))))
(when (atom x) (return x))
(comexp x)
(setq x (optim x))
(return (prog1 (cond ((null vars) x0)
(t (if (or (not (eq (caar x) 'mprog))
(and ($listp (cadr x)) (cdadr x)))
(setq x (nreverse (cons x *setqs*)))
(setq x (nreconc *setqs* (cddr x))))
`((mprog simp) ((mlist) ,@(nreverse vars)) ,@x)))
(fill *subexp* nil))))))
(defun opformat (x)
(cond ((atom x) x)
((specrepp x) (opformat (specdisrep x)))
((and $optimwarn
(mspecfunp (caar x))
(prog2 (mtell (intl:gettext "optimize: encountered a special form; result may be wrong."))
(setq $optimwarn nil))))
((eq (caar x) 'mexpt) (opmexpt x))
(t (let ((newargs (mapcar #'opformat (cdr x))))
(if (alike newargs (cdr x)) x (cons (car x) newargs))))))
(defun opmexpt (x)
(let ((*base (opformat (cadr x))) (exp (opformat (caddr x))) xnew negexp)
(setq negexp
(cond ((and (realp exp) (minusp exp)) (- exp))
((and (ratnump exp) (minusp (cadr exp)))
(list (car exp) (- (cadr exp)) (caddr exp)))
((and (mtimesp exp) (realp (cadr exp)) (minusp (cadr exp)))
(if (equal (cadr exp) -1)
(if (null (cdddr exp)) (caddr exp)
(cons (car exp) (cddr exp)))
(list* (car exp) (- (cadr exp)) (cddr exp))))
((and (mtimesp exp) (ratnump (cadr exp)) (minusp (cadadr exp)))
(list* (car exp)
(list (caadr exp) (- (cadadr exp)) (caddr (cadr exp)))
(cddr exp)))))
(setq xnew
(cond (negexp
`((mquotient)
1
,(cond ((equal negexp 1) *base)
(t (setq xnew (list (car x) *base negexp))
(if (and (ratnump negexp) (equal (caddr negexp) 2))
(opmexpt xnew)
xnew)))))
((and (ratnump exp) (equal (caddr exp) 2))
(setq exp (cadr exp))
(if (equal exp 1) `((%sqrt) ,*base)
`((mexpt) ((%sqrt) ,*base) ,exp)))
(t (list (car x) *base exp))))
(if (alike1 x xnew) x xnew)))
(defmfun $collapse (x)
(fill *subexp* nil)
(prog1 (collapse x) (fill *subexp* nil)))
(defun collapse (x)
(cond ((atom x) x)
((specrepp x) (collapse (specdisrep x)))
(t (let ((n (opt-hash (caar x))))
(do ((l (cdr x) (cdr l)))
((null l))
(if (not (eq (collapse (car l)) (car l)))
(rplaca l (collapse (car l))))
(setq n (rem (+ (opt-hash (car l)) n) 12553.)))
(setq n (logand 63 n))
(do ((l (aref *subexp* n) (cdr l)))
((null l) (setf (aref *subexp* n) (cons (list x) (aref *subexp* n))) x)
(if (alike1 x (caar l)) (return (caar l))))))))
(defun comexp (x)
(if (not (or (atom x) (eq (caar x) 'rat)))
(let ((n (opt-hash (caar x))))
(dolist (u (cdr x)) (setq n (rem (+ (opt-hash u) n) 12553.)))
(setq x (assol x (aref *subexp* (logand 63. n))))
(cond ((null (cdr x)) (rplacd x 'seen) (mapc #'comexp (cdar x)))
(t (rplacd x 'comexp))))))
(defun optim (x)
(declare (special *setqs*))
(cond ((atom x) x)
((and (member 'array (cdar x) :test #'eq)
(not (eq (caar x) 'mqapply))
(not (mget (caar x) 'arrayfun-mode)))
x)
((eq (caar x) 'rat) x)
(t (let ((n (opt-hash (caar x))) (nx (list (car x))))
(dolist (u (cdr x))
(setq n (rem (+ (opt-hash u) n) 12553.)
nx (cons (optim u) nx)))
(setq x (assol x (aref *subexp* (logand 63. n))) nx (nreverse nx))
(cond ((eq (cdr x) 'seen) nx)
((eq (cdr x) 'comexp)
(rplacd x (getoptimvar))
(push `((msetq) ,(cdr x) ,nx) *setqs*)
(cdr x))
(t (cdr x)))))))
(defun opt-hash (exp) ; EXP is in general representation.
(rem (if (atom exp)
(sxhash exp)
(do ((n (opt-hash (caar exp)))
(args (cdr exp) (cdr args)))
((null args) n)
(setq n (rem (+ (opt-hash (car args)) n) 12553.))))
12553.)) ; a prime number < 2^14 ; = PRIME(1500)
(defun getoptimvar ()
(declare (special *optimcount* *xvars* vars))
(loop with var
do
(incf *optimcount*)
(setq var (make-symbol (format nil "~A~D" $optimprefix *optimcount*)))
while (member var *xvars* :test #'eq)
finally
(push var vars)
(return var)))
|