home *** CD-ROM | disk | FTP | other *** search
Text File | 1991-10-29 | 55.3 KB | 1,728 lines |
- Newsgroups: comp.sources.misc
- From: daveg@synaptics.com (David Gillespie)
- Subject: v24i059: gnucalc - GNU Emacs Calculator, v2.00, Part11/56
- Message-ID: <1991Oct29.230052.20207@sparky.imd.sterling.com>
- X-Md4-Signature: 8f16bacf000fd51d6517bfc244c8f8fa
- Date: Tue, 29 Oct 1991 23:00:52 GMT
- Approved: kent@sparky.imd.sterling.com
-
- Submitted-by: daveg@synaptics.com (David Gillespie)
- Posting-number: Volume 24, Issue 59
- Archive-name: gnucalc/part11
- Environment: Emacs
- Supersedes: gmcalc: Volume 13, Issue 27-45
-
- ---- Cut Here and unpack ----
- #!/bin/sh
- # this is Part.11 (part 11 of a multipart archive)
- # do not concatenate these parts, unpack them in order with /bin/sh
- # file calc-comb.el continued
- #
- if test ! -r _shar_seq_.tmp; then
- echo 'Please unpack part 1 first!'
- exit 1
- fi
- (read Scheck
- if test "$Scheck" != 11; then
- echo Please unpack part "$Scheck" next!
- exit 1
- else
- exit 0
- fi
- ) < _shar_seq_.tmp || exit 1
- if test ! -f _shar_wnt_.tmp; then
- echo 'x - still skipping calc-comb.el'
- else
- echo 'x - continuing file calc-comb.el'
- sed 's/^X//' << 'SHAR_EOF' >> 'calc-comb.el' &&
- X 3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907
- X 3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013
- X 4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129
- X 4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243
- X 4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363
- X 4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493
- X 4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621
- X 4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729
- X 4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871
- X 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973
- X 4987 4993 4999 5003])
- X
- X
- X
- X
- SHAR_EOF
- echo 'File calc-comb.el is complete' &&
- chmod 0644 calc-comb.el ||
- echo 'restore of calc-comb.el failed'
- Wc_c="`wc -c < 'calc-comb.el'`"
- test 33469 -eq "$Wc_c" ||
- echo 'calc-comb.el: original size 33469, current size' "$Wc_c"
- rm -f _shar_wnt_.tmp
- fi
- # ============= calc-comp.el ==============
- if test -f 'calc-comp.el' -a X"$1" != X"-c"; then
- echo 'x - skipping calc-comp.el (File already exists)'
- rm -f _shar_wnt_.tmp
- else
- > _shar_wnt_.tmp
- echo 'x - extracting calc-comp.el (Text)'
- sed 's/^X//' << 'SHAR_EOF' > 'calc-comp.el' &&
- ;; Calculator for GNU Emacs, part II [calc-comp.el]
- ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
- ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
- X
- ;; This file is part of GNU Emacs.
- X
- ;; GNU Emacs is distributed in the hope that it will be useful,
- ;; but WITHOUT ANY WARRANTY. No author or distributor
- ;; accepts responsibility to anyone for the consequences of using it
- ;; or for whether it serves any particular purpose or works at all,
- ;; unless he says so in writing. Refer to the GNU Emacs General Public
- ;; License for full details.
- X
- ;; Everyone is granted permission to copy, modify and redistribute
- ;; GNU Emacs, but only under the conditions described in the
- ;; GNU Emacs General Public License. A copy of this license is
- ;; supposed to have been given to you along with GNU Emacs so you
- ;; can know your rights and responsibilities. It should be in a
- ;; file named COPYING. Among other things, the copyright notice
- ;; and this notice must be preserved on all copies.
- X
- X
- X
- ;; This file is autoloaded from calc-ext.el.
- (require 'calc-ext)
- X
- (require 'calc-macs)
- X
- (defun calc-Need-calc-comp () nil)
- X
- X
- ;;; A "composition" has one of the following forms:
- ;;;
- ;;; "string" A literal string
- ;;;
- ;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions
- ;;;
- ;;; (set LEVEL OFF) Set left margin + offset for line-break level
- ;;; (break LEVEL) A potential line-break point
- ;;;
- ;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps
- ;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps
- ;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps
- ;;; N specifies baseline of the stack, 0=top line.
- ;;;
- ;;; (supscr C1 C2) Composition C1 with superscript C2
- ;;; (subscr C1 C2) Composition C1 with subscript C2
- ;;; (rule X) Horizontal line of X, full width of enclosing comp
- ;;;
- ;;; (tag X C) Composition C corresponds to sub-expression X
- X
- (defun math-compose-expr (a prec)
- X (let ((math-compose-level (1+ math-compose-level)))
- X (cond
- X ((or (and (eq a math-comp-selected) a)
- X (and math-comp-tagged
- X (not (eq math-comp-tagged a))))
- X (let ((math-comp-selected nil))
- X (and math-comp-tagged (setq math-comp-tagged a))
- X (list 'tag a (math-compose-expr a prec))))
- X ((math-scalarp a)
- X (if (or (eq (car-safe a) 'frac)
- X (and (nth 1 calc-frac-format) (Math-integerp a)))
- X (if (memq calc-language '(tex eqn math))
- X (let ((aa (math-adjust-fraction a))
- X (calc-frac-format nil))
- X (math-compose-expr (list '/ (nth 1 aa) (nth 2 aa)) prec))
- X (if (and (eq calc-language 'big)
- X (= (length (car calc-frac-format)) 1))
- X (let* ((aa (math-adjust-fraction a))
- X (calc-frac-format nil)
- X (math-radix-explicit-format nil)
- X (c (list 'horiz
- X (if (math-negp (nth 1 aa))
- X "- " "")
- X (list 'vcent 1
- X (math-format-number
- X (math-abs (nth 1 aa)))
- X '(rule ?-)
- X (math-format-number (nth 2 aa))))))
- X (if (= calc-number-radix 10)
- X c
- X (list 'horiz "(" c
- X (list 'subscr ")"
- X (int-to-string calc-number-radix)))))
- X (math-format-number a)))
- X (if (not (eq calc-language 'big))
- X (math-format-number a prec)
- X (if (memq (car-safe a) '(cplx polar))
- X (if (math-zerop (nth 2 a))
- X (math-compose-expr (nth 1 a) prec)
- X (list 'horiz "("
- X (math-compose-expr (nth 1 a) 0)
- X (if (eq (car a) 'cplx) ", " "; ")
- X (math-compose-expr (nth 2 a) 0) ")"))
- X (if (or (= calc-number-radix 10)
- X (not (Math-realp a))
- X (and calc-group-digits
- X (not (assoc calc-group-char '((",") (" "))))))
- X (math-format-number a prec)
- X (let ((s (math-format-number a prec))
- X (c nil))
- X (while (string-match (if (> calc-number-radix 14)
- X "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
- X "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
- X s)
- X (setq c (nconc c (list (substring s 0 (match-beginning 0))
- X (list 'subscr
- X (math-match-substring s 2)
- X (math-match-substring s 1))))
- X s (substring s (match-end 0))))
- X (if (string-match
- X "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s)
- X (setq s (list 'horiz
- X (substring s 0 (match-beginning 0)) " "
- X (list 'supscr
- X (math-match-substring s 1)
- X (math-match-substring s 2))
- X (math-match-substring s 3))))
- X (if c (cons 'horiz (nconc c (list s))) s)))))))
- X ((not (consp a)) (concat "'" (prin1-to-string a)))
- X ((and (get (car a) 'math-compose-forms)
- X (not (eq calc-language 'unform))
- X (let ((comps (get (car a) 'math-compose-forms))
- X temp temp2)
- X (or (and (setq temp (assq calc-language comps))
- X (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
- X (setq temp (apply (cdr temp2) (cdr a)))
- X (math-compose-expr temp prec))
- X (and (setq temp2 (assq nil (cdr temp)))
- X (funcall (cdr temp2) a))))
- X (and (setq temp (assq nil comps))
- X (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
- X (setq temp (apply (cdr temp2) (cdr a)))
- X (math-compose-expr temp prec))
- X (and (setq temp2 (assq nil (cdr temp)))
- X (funcall (cdr temp2) a))))))))
- X ((eq (car a) 'vec)
- X (let* ((left-bracket (if calc-vector-brackets
- X (substring calc-vector-brackets 0 1) ""))
- X (right-bracket (if calc-vector-brackets
- X (substring calc-vector-brackets 1 2) ""))
- X (inner-brackets (memq 'R calc-matrix-brackets))
- X (outer-brackets (memq 'O calc-matrix-brackets))
- X (row-commas (memq 'C calc-matrix-brackets))
- X (comma-spc (or calc-vector-commas " "))
- X (comma (or calc-vector-commas ""))
- X (vector-prec (if (or (and calc-vector-commas (nth 2 a))
- X (memq 'P calc-matrix-brackets)) 0 1000))
- X (just (cond ((eq calc-matrix-just 'right) 'vright)
- X ((eq calc-matrix-just 'center) 'vcent)
- X (t 'vleft)))
- X (break calc-break-vectors))
- X (if (and (memq calc-language '(nil big))
- X (not calc-break-vectors)
- X (math-matrixp a) (not (math-matrixp (nth 1 a)))
- X (or calc-full-vectors
- X (and (< (length a) 7) (< (length (nth 1 a)) 7))
- X (progn (setq break t) nil)))
- X (if (progn
- X (setq vector-prec (if (or (and calc-vector-commas
- X (nth 2 (nth 1 a)))
- X (memq 'P calc-matrix-brackets))
- X 0 1000))
- X (= (length a) 2))
- X (list 'horiz
- X (concat left-bracket left-bracket " ")
- X (math-compose-vector (cdr (nth 1 a)) (concat comma " ")
- X vector-prec)
- X (concat " " right-bracket right-bracket))
- X (let* ((rows (1- (length a)))
- X (cols (1- (length (nth 1 a))))
- X (base (/ (1- rows) 2))
- X (calc-language 'flat))
- X (append '(horiz)
- X (list (append '(vleft)
- X (list base)
- X (list (concat (and outer-brackets
- X (concat left-bracket
- X " "))
- X (and inner-brackets
- X (concat left-bracket
- X " "))))
- X (make-list (1- rows)
- X (concat (and outer-brackets
- X " ")
- X (and inner-brackets
- X (concat
- X left-bracket
- X " "))))))
- X (math-compose-matrix (cdr a) 1 cols base)
- X (list (append '(vleft)
- X (list base)
- X (make-list (1- rows)
- X (if inner-brackets
- X (concat " "
- X right-bracket
- X (and row-commas
- X comma))
- X (if (and outer-brackets
- X row-commas)
- X ";" "")))
- X (list (concat
- X (and inner-brackets
- X (concat " "
- X right-bracket))
- X (and outer-brackets
- X (concat
- X " "
- X right-bracket)))))))))
- X (if (and calc-display-strings
- X (cdr a)
- X (math-vector-is-string a))
- X (math-vector-to-string a t)
- X (if (and break (cdr a)
- X (not (eq calc-language 'flat)))
- X (let* ((full (or calc-full-vectors (< (length a) 7)))
- X (rows (if full (1- (length a)) 5))
- X (base (/ (1- rows) 2))
- X (just 'vleft)
- X (calc-break-vectors nil))
- X (list 'horiz
- X (cons 'vleft (cons base
- X (math-compose-rows
- X (cdr a)
- X (if full rows 3) t)))))
- X (if (or calc-full-vectors (< (length a) 7))
- X (if (and (eq calc-language 'tex)
- X (math-matrixp a))
- X (append '(horiz "\\matrix{ ")
- X (math-compose-tex-matrix (cdr a))
- X '(" }"))
- X (if (and (eq calc-language 'eqn)
- X (math-matrixp a))
- X (append '(horiz "matrix { ")
- X (math-compose-eqn-matrix
- X (cdr (math-transpose a)))
- X '("}"))
- X (if (and (eq calc-language 'maple)
- X (math-matrixp a))
- X (list 'horiz
- X "matrix("
- X left-bracket
- X (math-compose-vector (cdr a) (concat comma " ")
- X vector-prec)
- X right-bracket
- X ")")
- X (list 'horiz
- X left-bracket
- X (math-compose-vector (cdr a) (concat comma " ")
- X vector-prec)
- X right-bracket))))
- X (list 'horiz
- X left-bracket
- X (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
- X (concat comma " ") vector-prec)
- X comma (if (eq calc-language 'tex) " \\ldots" " ...")
- X comma " "
- X (list 'break math-compose-level)
- X (math-compose-expr (nth (1- (length a)) a)
- X (if (equal comma "") 1000 0))
- X right-bracket)))))))
- X ((eq (car a) 'incomplete)
- X (if (cdr (cdr a))
- X (cond ((eq (nth 1 a) 'vec)
- X (list 'horiz "["
- X (math-compose-vector (cdr (cdr a)) ", " 0)
- X " ..."))
- X ((eq (nth 1 a) 'cplx)
- X (list 'horiz "("
- X (math-compose-vector (cdr (cdr a)) ", " 0)
- X ", ..."))
- X ((eq (nth 1 a) 'polar)
- X (list 'horiz "("
- X (math-compose-vector (cdr (cdr a)) "; " 0)
- X "; ..."))
- X ((eq (nth 1 a) 'intv)
- X (list 'horiz
- X (if (memq (nth 2 a) '(0 1)) "(" "[")
- X (math-compose-vector (cdr (cdr (cdr a))) " .. " 0)
- X " .. ..."))
- X (t (format "%s" a)))
- X (cond ((eq (nth 1 a) 'vec) "[ ...")
- X ((eq (nth 1 a) 'intv)
- X (if (memq (nth 2 a) '(0 1)) "( ..." "[ ..."))
- X (t "( ..."))))
- X ((eq (car a) 'var)
- X (let ((v (rassq (nth 2 a) math-expr-variable-mapping)))
- X (if v
- X (symbol-name (car v))
- X (if (and (eq calc-language 'tex)
- X calc-language-option
- X (not (= calc-language-option 0))
- X (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
- X (symbol-name (nth 1 a))))
- X (format "\\hbox{%s}" (symbol-name (nth 1 a)))
- X (if (and math-compose-hash-args
- X (let ((p calc-arg-values))
- X (setq v 1)
- X (while (and p (not (equal (car p) a)))
- X (setq p (and (eq math-compose-hash-args t) (cdr p))
- X v (1+ v)))
- X p))
- X (if (eq math-compose-hash-args 1)
- X "#"
- X (format "#%d" v))
- X (if (memq calc-language '(c fortran pascal maple))
- X (math-to-underscores (symbol-name (nth 1 a)))
- X (if (and (eq calc-language 'eqn)
- X (string-match ".'\\'" (symbol-name (nth 2 a))))
- X (math-compose-expr
- X (list 'calcFunc-Prime
- X (list
- X 'var
- X (intern (substring (symbol-name (nth 1 a)) 0 -1))
- X (intern (substring (symbol-name (nth 2 a)) 0 -1))))
- X prec)
- X (symbol-name (nth 1 a)))))))))
- X ((eq (car a) 'intv)
- X (list 'horiz
- X (if (eq calc-language 'maple) ""
- X (if (memq (nth 1 a) '(0 1)) "(" "["))
- X (math-compose-expr (nth 2 a) 0)
- X (if (eq calc-language 'tex) " \\ldots "
- X (if (eq calc-language 'eqn) " ... " " .. "))
- X (math-compose-expr (nth 3 a) 0)
- X (if (eq calc-language 'maple) ""
- X (if (memq (nth 1 a) '(0 2)) ")" "]"))))
- X ((eq (car a) 'date)
- X (if (eq (car calc-date-format) 'X)
- X (math-format-date a)
- X (concat "<" (math-format-date a) ">")))
- X ((and (eq (car a) 'calcFunc-subscr) (cdr (cdr a))
- X (memq calc-language '(c pascal fortran maple)))
- X (list 'horiz
- X (math-compose-expr (nth 1 a) 1000)
- X (if (eq calc-language 'fortran) "(" "[")
- X (math-compose-vector (cdr (cdr a)) ", " 0)
- X (if (eq calc-language 'fortran) ")" "]")))
- X ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
- X (eq calc-language 'big))
- X (let* ((a1 (math-compose-expr (nth 1 a) 1000))
- X (calc-language 'flat)
- X (a2 (math-compose-expr (nth 2 a) 0)))
- X (if (or (eq (car-safe a1) 'subscr)
- X (and (eq (car-safe a1) 'tag)
- X (eq (car-safe (nth 2 a1)) 'subscr)))
- X (list 'subscr
- X (nth 1 a1)
- X (list 'horiz
- X (nth 2 a1)
- X ", "
- X a2))
- X (list 'subscr a1 a2))))
- X ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
- X (eq calc-language 'math))
- X (list 'horiz
- X (math-compose-expr (nth 1 a) 1000)
- X "[["
- X (math-compose-expr (nth 2 a) 0)
- X "]]"))
- X ((and (eq (car a) 'calcFunc-sqrt)
- X (eq calc-language 'tex))
- X (list 'horiz
- X "\\sqrt{"
- X (math-compose-expr (nth 1 a) 0)
- X "}"))
- X ((and nil (eq (car a) 'calcFunc-sqrt)
- X (eq calc-language 'eqn))
- X (list 'horiz
- X "sqrt {"
- X (math-compose-expr (nth 1 a) -1)
- X "}"))
- X ((and (eq (car a) '^)
- X (eq calc-language 'big))
- X (list 'supscr
- X (if (or (math-looks-negp (nth 1 a))
- X (memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt))
- X (and (eq (car-safe (nth 1 a)) 'cplx)
- X (math-negp (nth 1 (nth 1 a)))
- X (eq (nth 2 (nth 1 a)) 0)))
- X (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
- X (math-compose-expr (nth 1 a) 201))
- X (let ((calc-language 'flat))
- X (math-compose-expr (nth 2 a) 0))))
- X ((and (eq (car a) '/)
- X (eq calc-language 'big))
- X (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac))
- X 'flat 'big)))
- X (math-compose-expr (nth 1 a) 0)))
- X (a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac))
- X 'flat 'big)))
- X (math-compose-expr (nth 2 a) 0))))
- X (list 'vcent
- X (math-comp-height a1)
- X a1 '(rule ?-) a2)))
- X ((and (memq (car a) '(calcFunc-sum calcFunc-prod))
- X (eq calc-language 'tex)
- X (= (length a) 5))
- X (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod")
- X "_{" (math-compose-expr (nth 2 a) 0)
- X "=" (math-compose-expr (nth 3 a) 0)
- X "}^{" (math-compose-expr (nth 4 a) 0)
- X "}{" (math-compose-expr (nth 1 a) 0) "}"))
- X ((and (eq (car a) 'calcFunc-lambda)
- X (> (length a) 2)
- X (memq calc-language '(nil flat big)))
- X (let ((p (cdr a))
- X (ap calc-arg-values)
- X (math-compose-hash-args (if (= (length a) 3) 1 t)))
- X (while (and (cdr p) (equal (car p) (car ap)))
- X (setq p (cdr p) ap (cdr ap)))
- X (append '(horiz "<")
- X (if (cdr p)
- X (list (math-compose-vector
- X (nreverse (cdr (reverse (cdr a)))) ", " 0)
- X " : ")
- X nil)
- X (list (math-compose-expr (nth (1- (length a)) a) 0)
- X ">"))))
- X ((and (eq (car a) 'calcFunc-string)
- X (= (length a) 2)
- X (math-vectorp (nth 1 a))
- X (math-vector-is-string (nth 1 a)))
- X (if (eq calc-language 'unform)
- X (concat "string(" (math-vector-to-string (nth 1 a) t) ")")
- X (math-vector-to-string (nth 1 a) nil)))
- X ((and (eq (car a) 'calcFunc-bstring)
- X (= (length a) 2)
- X (math-vectorp (nth 1 a))
- X (math-vector-is-string (nth 1 a)))
- X (if (eq calc-language 'unform)
- X (concat "bstring(" (math-vector-to-string (nth 1 a) t) ")")
- X (let ((c nil)
- X (s (math-vector-to-string (nth 1 a) nil))
- X p)
- X (while (string-match "[^ ] +[^ ]" s)
- X (setq p (1- (match-end 0))
- X c (cons (list 'break math-compose-level)
- X (cons (substring s 0 p)
- X c))
- X s (substring s p)))
- X (setq c (nreverse (cons s c)))
- X (or (= prec -123)
- X (setq c (cons (list 'set math-compose-level 2) c)))
- X (cons 'horiz c))))
- X ((and (eq (car a) 'calcFunc-cprec)
- X (not (eq calc-language 'unform))
- X (= (length a) 3)
- X (integerp (nth 2 a)))
- X (let ((c (math-compose-expr (nth 1 a) -1)))
- X (if (> prec (nth 2 a))
- X (if (eq calc-language 'tex)
- X (list 'horiz "\\left( " c " \\right)")
- X (if (eq calc-language 'eqn)
- X (list 'horiz "{left ( " c " right )}")
- X (list 'horiz "(" c ")")))
- X c)))
- X ((and (eq (car a) 'calcFunc-choriz)
- X (not (eq calc-language 'unform))
- X (memq (length a) '(2 3 4))
- X (math-vectorp (nth 1 a))
- X (if (integerp (nth 2 a))
- X (or (null (nth 3 a))
- X (and (math-vectorp (nth 3 a))
- X (math-vector-is-string (nth 3 a))))
- X (or (null (nth 2 a))
- X (and (math-vectorp (nth 2 a))
- X (math-vector-is-string (nth 2 a))))))
- X (let* ((cprec (and (integerp (nth 2 a)) (nth 2 a)))
- X (sep (nth (if cprec 3 2) a))
- X (bprec nil))
- X (if sep
- X (math-compose-vector (cdr (nth 1 a))
- X (math-vector-to-string sep nil)
- X (or cprec prec))
- X (cons 'horiz (mapcar (function
- X (lambda (x)
- X (if (eq (car-safe x) 'calcFunc-bstring)
- X (prog1
- X (math-compose-expr
- X x (or bprec cprec prec))
- X (setq bprec -123))
- X (math-compose-expr x (or cprec prec)))))
- X (cdr (nth 1 a)))))))
- X ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert))
- X (not (eq calc-language 'unform))
- X (memq (length a) '(2 3))
- X (math-vectorp (nth 1 a))
- X (or (null (nth 2 a))
- X (integerp (nth 2 a))))
- X (let* ((base 0)
- X (v 0)
- X (prec (or (nth 2 a) prec))
- X (c (mapcar (function
- X (lambda (x)
- X (let ((b nil) (cc nil) a d)
- X (if (and (memq (car-safe x) '(calcFunc-cbase
- X calcFunc-ctbase
- X calcFunc-cbbase))
- X (memq (length x) '(1 2)))
- X (setq b (car x)
- X x (nth 1 x)))
- X (if (and (eq (car-safe x) 'calcFunc-crule)
- X (memq (length x) '(1 2))
- X (or (null (nth 1 x))
- X (and (math-vectorp (nth 1 x))
- X (= (length (nth 1 x)) 2)
- X (math-vector-is-string
- X (nth 1 x)))
- X (and (natnump (nth 1 x))
- X (<= (nth 1 x) 255))))
- X (setq cc (list
- X 'rule
- X (if (math-vectorp (nth 1 x))
- X (aref (math-vector-to-string
- X (nth 1 x) nil) 0)
- X (or (nth 1 x) ?-))))
- X (or (and (memq (car-safe x) '(calcFunc-cvspace
- X calcFunc-ctspace
- X calcFunc-cbspace))
- X (memq (length x) '(2 3))
- X (eq (nth 1 x) 0))
- X (null x)
- X (setq cc (math-compose-expr x prec))))
- X (setq a (if cc (math-comp-ascent cc) 0)
- X d (if cc (math-comp-descent cc) 0))
- X (if (eq b 'calcFunc-cbase)
- X (setq base (+ v a -1))
- X (if (eq b 'calcFunc-ctbase)
- X (setq base v)
- X (if (eq b 'calcFunc-cbbase)
- X (setq base (+ v a d -1)))))
- X (setq v (+ v a d))
- X cc)))
- X (cdr (nth 1 a)))))
- X (setq c (delq nil c))
- X (if c
- X (cons (if (eq (car a) 'calcFunc-cvert) 'vcent
- X (if (eq (car a) 'calcFunc-clvert) 'vleft 'vright))
- X (cons base c))
- X " ")))
- X ((and (memq (car a) '(calcFunc-csup calcFunc-csub))
- X (not (eq calc-language 'unform))
- X (memq (length a) '(3 4))
- X (or (null (nth 3 a))
- X (integerp (nth 3 a))))
- X (list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr)
- X (math-compose-expr (nth 1 a) (or (nth 3 a) 0))
- X (math-compose-expr (nth 2 a) 0)))
- X ((and (eq (car a) 'calcFunc-cflat)
- X (not (eq calc-language 'unform))
- X (memq (length a) '(2 3))
- X (or (null (nth 2 a))
- X (integerp (nth 2 a))))
- X (let ((calc-language (if (memq calc-language '(nil big))
- X 'flat calc-language)))
- X (math-compose-expr (nth 1 a) (or (nth 2 a) 0))))
- X ((and (eq (car a) 'calcFunc-cspace)
- X (memq (length a) '(2 3))
- X (natnump (nth 1 a)))
- X (if (nth 2 a)
- X (cons 'horiz (make-list (nth 1 a)
- X (if (and (math-vectorp (nth 2 a))
- X (math-vector-is-string (nth 2 a)))
- X (math-vector-to-string (nth 2 a) nil)
- X (math-compose-expr (nth 2 a) 0))))
- X (make-string (nth 1 a) ?\ )))
- X ((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
- X (memq (length a) '(2 3))
- X (natnump (nth 1 a)))
- X (if (= (nth 1 a) 0)
- X ""
- X (let* ((c (if (nth 2 a)
- X (if (and (math-vectorp (nth 2 a))
- X (math-vector-is-string (nth 2 a)))
- X (math-vector-to-string (nth 2 a) nil)
- X (math-compose-expr (nth 2 a) 0))
- X " "))
- X (ca (math-comp-ascent c))
- X (cd (math-comp-descent c)))
- X (cons 'vleft
- X (cons (if (eq (car a) 'calcFunc-ctspace)
- X (1- ca)
- X (if (eq (car a) 'calcFunc-cbspace)
- X (+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca))
- X (/ (1- (* (nth 1 a) (+ ca cd))) 2)))
- X (make-list (nth 1 a) c))))))
- X ((and (eq (car a) 'calcFunc-evalto)
- X (setq calc-any-evaltos t)
- X (memq calc-language '(tex eqn))
- X (= math-compose-level (if math-comp-tagged 2 1))
- X (= (length a) 3))
- X (list 'horiz
- X (if (eq calc-language 'tex) "\\evalto " "evalto ")
- X (math-compose-expr (nth 1 a) 0)
- X (if (eq calc-language 'tex) " \\to " " -> ")
- X (math-compose-expr (nth 2 a) 0)))
- X (t
- X (let ((op (and (not (eq calc-language 'unform))
- X (if (and (eq (car a) 'calcFunc-if) (= (length a) 4))
- X (assoc "?" math-expr-opers)
- X (math-assq2 (car a) math-expr-opers)))))
- X (cond ((and op
- X (or (= (length a) 3) (eq (car a) 'calcFunc-if))
- X (/= (nth 3 op) -1))
- X (cond
- X ((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op))))
- X (if (and (eq calc-language 'tex)
- X (not (math-tex-expr-is-flat a)))
- X (if (eq (car-safe a) '/)
- X (list 'horiz "{" (math-compose-expr a -1) "}")
- X (list 'horiz "\\left( "
- X (math-compose-expr a -1)
- X " \\right)"))
- X (if (eq calc-language 'eqn)
- X (if (or (eq (car-safe a) '/)
- X (= (/ prec 100) 9))
- X (list 'horiz "{" (math-compose-expr a -1) "}")
- X (if (math-tex-expr-is-flat a)
- X (list 'horiz "( " (math-compose-expr a -1) " )")
- X (list 'horiz "{left ( "
- X (math-compose-expr a -1)
- X " right )}")))
- X (list 'horiz "(" (math-compose-expr a 0) ")"))))
- X ((and (eq calc-language 'tex)
- X (memq (car a) '(/ calcFunc-choose calcFunc-evalto))
- X (>= prec 0))
- X (list 'horiz "{" (math-compose-expr a -1) "}"))
- X ((eq (car a) 'calcFunc-if)
- X (list 'horiz
- X (math-compose-expr (nth 1 a) (nth 2 op))
- X " ? "
- X (math-compose-expr (nth 2 a) 0)
- X " : "
- X (math-compose-expr (nth 3 a) (nth 3 op))))
- X (t
- X (let* ((math-comp-tagged (and math-comp-tagged
- X (not (math-primp a))
- X math-comp-tagged))
- X (setlev (if (= prec (min (nth 2 op) (nth 3 op)))
- X (progn
- X (setq math-compose-level
- X (1- math-compose-level))
- X nil)
- X math-compose-level))
- X (lhs (math-compose-expr (nth 1 a) (nth 2 op)))
- X (rhs (math-compose-expr (nth 2 a) (nth 3 op))))
- X (and (equal (car op) "^")
- X (eq (math-comp-first-char lhs) ?-)
- X (setq lhs (list 'horiz "(" lhs ")")))
- X (and (eq calc-language 'tex)
- X (or (equal (car op) "^") (equal (car op) "_"))
- X (not (and (stringp rhs) (= (length rhs) 1)))
- X (setq rhs (list 'horiz "{" rhs "}")))
- X (or (and (eq (car a) '*)
- X (or (null calc-language)
- X (assoc "2x" math-expr-opers))
- X (let* ((prevt (math-prod-last-term (nth 1 a)))
- X (nextt (math-prod-first-term (nth 2 a)))
- X (prevc (or (math-comp-last-char lhs)
- X (and (memq (car-safe prevt)
- X '(^ calcFunc-subscr
- X calcFunc-sqrt
- X frac))
- X (eq calc-language 'big)
- X ?0)))
- X (nextc (or (math-comp-first-char rhs)
- X (and (memq (car-safe nextt)
- X '(calcFunc-sqrt
- X calcFunc-sum
- X calcFunc-prod
- X calcFunc-integ))
- X (eq calc-language 'big)
- X ?0))))
- X (and prevc nextc
- X (or (and (>= nextc ?a) (<= nextc ?z))
- X (and (>= nextc ?A) (<= nextc ?Z))
- X (and (>= nextc ?0) (<= nextc ?9))
- X (memq nextc '(?. ?_ ?#
- X ?\( ?\[ ?\{))
- X (and (eq nextc ?\\)
- X (not (string-match
- X "\\`\\\\left("
- X (math-comp-first-string
- X rhs)))))
- X (not (and (eq (car-safe prevt) 'var)
- X (eq nextc ?\()))
- X (list 'horiz
- X (list 'set setlev 1)
- X lhs
- X (list 'break math-compose-level)
- X " "
- X rhs))))
- X (list 'horiz
- X (list 'set setlev 1)
- X lhs
- X (list 'break math-compose-level)
- X (if (or (equal (car op) "^")
- X (equal (car op) "_")
- X (equal (car op) "**")
- X (and (equal (car op) "*")
- X (math-comp-last-char lhs)
- X (math-comp-first-char rhs)))
- X (car op)
- X (if (and (eq calc-language 'big)
- X (equal (car op) "=>"))
- X " => "
- X (concat " " (car op) " ")))
- X rhs))))))
- X ((and op (= (length a) 2) (= (nth 3 op) -1))
- X (cond
- X ((or (> prec (or (nth 4 op) (nth 2 op)))
- X (and (not (eq (assoc (car op) math-expr-opers) op))
- X (> prec 0))) ; don't write x% + y
- X (if (and (eq calc-language 'tex)
- X (not (math-tex-expr-is-flat a)))
- X (list 'horiz "\\left( "
- X (math-compose-expr a -1)
- X " \\right)")
- X (if (eq calc-language 'eqn)
- X (if (= (/ prec 100) 9)
- X (list 'horiz "{" (math-compose-expr a -1) "}")
- X (if (math-tex-expr-is-flat a)
- X (list 'horiz "{( " (math-compose-expr a -1) " )}")
- X (list 'horiz "{left ( "
- X (math-compose-expr a -1)
- X " right )}")))
- X (list 'horiz "(" (math-compose-expr a 0) ")"))))
- X (t
- X (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
- X (list 'horiz
- X lhs
- X (if (or (> (length (car op)) 1)
- X (not (math-comp-is-flat lhs)))
- X (concat " " (car op))
- X (car op)))))))
- X ((and op (= (length a) 2) (= (nth 2 op) -1))
- X (cond
- X ((eq (nth 3 op) 0)
- X (let ((lr (and (eq calc-language 'tex)
- X (not (math-tex-expr-is-flat (nth 1 a))))))
- X (list 'horiz
- X (if lr "\\left" "")
- X (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op))
- X (substring (car op) 1)
- X (car op))
- X (if (or lr (> (length (car op)) 2)) " " "")
- X (math-compose-expr (nth 1 a) -1)
- X (if (or lr (> (length (car op)) 2)) " " "")
- X (if lr "\\right" "")
- X (car (nth 1 (memq op math-expr-opers))))))
- X ((> prec (or (nth 4 op) (nth 3 op)))
- X (if (and (eq calc-language 'tex)
- X (not (math-tex-expr-is-flat a)))
- X (list 'horiz "\\left( "
- X (math-compose-expr a -1)
- X " \\right)")
- X (if (eq calc-language 'eqn)
- X (if (= (/ prec 100) 9)
- X (list 'horiz "{" (math-compose-expr a -1) "}")
- X (if (math-tex-expr-is-flat a)
- X (list 'horiz "{( " (math-compose-expr a -1) " )}")
- X (list 'horiz "{left ( "
- X (math-compose-expr a -1)
- X " right )}")))
- X (list 'horiz "(" (math-compose-expr a 0) ")"))))
- X (t
- X (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
- X (list 'horiz
- X (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
- X (car op))
- X (substring (car op) 1)
- X (car op))))
- X (if (or (> (length ops) 1)
- X (not (math-comp-is-flat rhs)))
- X (concat ops " ")
- X ops))
- X rhs)))))
- X ((and (eq calc-language 'big)
- X (setq op (get (car a) 'math-compose-big))
- X (funcall op a prec)))
- X ((and (setq op (assq calc-language
- X '( ( nil . math-compose-normal )
- X ( flat . math-compose-normal )
- X ( big . math-compose-normal )
- X ( c . math-compose-c )
- X ( pascal . math-compose-pascal )
- X ( fortran . math-compose-fortran )
- X ( tex . math-compose-tex )
- X ( eqn . math-compose-eqn )
- X ( math . math-compose-math )
- X ( maple . math-compose-maple ))))
- X (setq op (get (car a) (cdr op)))
- X (funcall op a prec)))
- X (t
- X (let* ((func (car a))
- X (func2 (assq func '(( mod . calcFunc-makemod )
- X ( sdev . calcFunc-sdev )
- X ( + . calcFunc-add )
- X ( - . calcFunc-sub )
- X ( * . calcFunc-mul )
- X ( / . calcFunc-div )
- X ( % . calcFunc-mod )
- X ( ^ . calcFunc-pow )
- X ( neg . calcFunc-neg )
- X ( | . calcFunc-vconcat ))))
- X left right args)
- X (if func2
- X (setq func (cdr func2)))
- X (if (setq func2 (rassq func math-expr-function-mapping))
- X (setq func (car func2)))
- X (setq func (math-remove-dashes
- X (if (string-match
- X "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
- X (symbol-name func))
- X (math-match-substring (symbol-name func) 1)
- X (symbol-name func))))
- X (if (and (eq calc-language 'tex)
- X calc-language-option
- X (not (= calc-language-option 0))
- X (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func))
- X (if (< (prefix-numeric-value calc-language-option) 0)
- X (setq func (format "\\%s" func))
- X (setq func (format "\\hbox{%s}" func))))
- X (if (and (eq calc-language 'eqn)
- X (string-match "[^']'+\\'" func))
- X (let ((n (- (length func) (match-beginning 0) 1)))
- X (setq func (substring func 0 (- n)))
- X (while (>= (setq n (1- n)) 0)
- X (setq func (concat func " prime")))))
- X (cond ((and (eq calc-language 'tex)
- X (or (> (length a) 2)
- X (not (math-tex-expr-is-flat (nth 1 a)))))
- X (setq left "\\left( "
- X right " \\right)"))
- X ((and (eq calc-language 'eqn)
- X (or (> (length a) 2)
- X (not (math-tex-expr-is-flat (nth 1 a)))))
- X (setq left "{left ( "
- X right " right )}"))
- X ((and (or (and (eq calc-language 'tex)
- X (eq (aref func 0) ?\\))
- X (and (eq calc-language 'eqn)
- X (memq (car a) math-eqn-special-funcs)))
- X (not (string-match "\\hbox{" func))
- X (= (length a) 2)
- X (or (Math-realp (nth 1 a))
- X (memq (car (nth 1 a)) '(var *))))
- X (setq left (if (eq calc-language 'eqn) "~{" "{")
- X right "}"))
- X ((eq calc-language 'eqn)
- X (setq left " ( "
- X right " )"))
- X (t (setq left calc-function-open
- X right calc-function-close)))
- X (list 'horiz func left
- X (math-compose-vector (cdr a)
- X (if (eq calc-language 'eqn)
- X " , " ", ")
- X 0)
- X right))))))))
- )
- X
- (defconst math-eqn-special-funcs
- X '( calcFunc-log
- X calcFunc-ln calcFunc-exp
- X calcFunc-sin calcFunc-cos calcFunc-tan
- X calcFunc-sinh calcFunc-cosh calcFunc-tanh
- X calcFunc-arcsin calcFunc-arccos calcFunc-arctan
- X calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
- ))
- X
- X
- (defun math-prod-first-term (x)
- X (while (eq (car-safe x) '*)
- X (setq x (nth 1 x)))
- X x
- )
- X
- (defun math-prod-last-term (x)
- X (while (eq (car-safe x) '*)
- X (setq x (nth 2 x)))
- X x
- )
- X
- (defun math-compose-vector (a sep prec)
- X (if a
- X (cons 'horiz
- X (cons (list 'set math-compose-level)
- X (let ((c (list (math-compose-expr (car a) prec))))
- X (while (setq a (cdr a))
- X (setq c (cons (if (eq (car-safe (car a))
- X 'calcFunc-bstring)
- X (let ((math-compose-level
- X (1- math-compose-level)))
- X (math-compose-expr (car a) -123))
- X (math-compose-expr (car a) prec))
- X (cons (list 'break math-compose-level)
- X (cons sep c)))))
- X (nreverse c))))
- X "")
- )
- X
- (defun math-compose-matrix (a col cols base)
- X (math-compose-matrix-step a col)
- )
- X
- (defun math-compose-matrix-step (a col)
- X (if (= col cols)
- X (list (cons just
- X (cons base
- X (mapcar (function (lambda (r)
- X (math-compose-expr
- X (nth col r)
- X vector-prec)))
- X a))))
- X (cons (cons just
- X (cons base
- X (mapcar (function
- X (lambda (r) (list 'horiz
- X (math-compose-expr
- X (nth col r)
- X vector-prec)
- X (concat comma-spc " "))))
- X a)))
- X (math-compose-matrix-step a (1+ col))))
- )
- X
- (defun math-compose-rows (a count first)
- X (if (cdr a)
- X (if (<= count 0)
- X (if (< count 0)
- X (math-compose-rows (cdr a) -1 nil)
- X (cons (concat (if (eq calc-language 'tex) " \\ldots" " ...")
- X comma)
- X (math-compose-rows (cdr a) -1 nil)))
- X (cons (list 'horiz
- X (if first (concat left-bracket " ") " ")
- X (math-compose-expr (car a) vector-prec)
- X comma)
- X (math-compose-rows (cdr a) (1- count) nil)))
- X (list (list 'horiz
- X (if first (concat left-bracket " ") " ")
- X (math-compose-expr (car a) vector-prec)
- X (concat " " right-bracket))))
- )
- X
- (defun math-compose-tex-matrix (a)
- X (if (cdr a)
- X (cons (math-compose-vector (cdr (car a)) " & " 0)
- X (cons " \\\\ "
- X (math-compose-tex-matrix (cdr a))))
- X (list (math-compose-vector (cdr (car a)) " & " 0)))
- )
- X
- (defun math-compose-eqn-matrix (a)
- X (if a
- X (cons
- X (cond ((eq calc-matrix-just 'right) "rcol ")
- X ((eq calc-matrix-just 'center) "ccol ")
- X (t "lcol "))
- X (cons
- X (list 'break math-compose-level)
- X (cons
- X "{ "
- X (cons
- X (let ((math-compose-level (1+ math-compose-level)))
- X (math-compose-vector (cdr (car a)) " above " 1000))
- X (cons
- X " } "
- X (math-compose-eqn-matrix (cdr a)))))))
- X nil)
- )
- X
- (defun math-vector-is-string (a)
- X (while (and (setq a (cdr a))
- X (or (and (natnump (car a))
- X (<= (car a) 255))
- X (and (eq (car-safe (car a)) 'cplx)
- X (natnump (nth 1 (car a)))
- X (eq (nth 2 (car a)) 0)
- X (<= (nth 1 (car a)) 255)))))
- X (null a)
- )
- X
- (defun math-vector-to-string (a &optional quoted)
- X (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
- X (cdr a))))
- X (if (string-match "[\000-\037\177\\\"]" a)
- X (let ((p 0)
- X (pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]"))
- X (codes (if quoted math-vector-to-string-chars '((?\^? . "^?"))))
- X (fmt (if quoted "\\^%c" "^%c"))
- X new)
- X (while (setq p (string-match pat a p))
- X (if (setq new (assq (aref a p) codes))
- X (setq a (concat (substring a 0 p)
- X (cdr new)
- X (substring a (1+ p)))
- X p (+ p (length (cdr new))))
- X (setq a (concat (substring a 0 p)
- X (format fmt (+ (aref a p) 64))
- X (substring a (1+ p)))
- X p (+ p 2))))))
- X (if quoted
- X (concat "\"" a "\"")
- X a)
- )
- (defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
- X ( ?\\ . "\\\\" )
- X ( ?\a . "\\a" )
- X ( ?\b . "\\b" )
- X ( ?\e . "\\e" )
- X ( ?\f . "\\f" )
- X ( ?\n . "\\n" )
- X ( ?\r . "\\r" )
- X ( ?\t . "\\t" )
- X ( ?\^? . "\\^?" )
- ))
- X
- (defun math-to-underscores (x)
- X (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
- X (math-to-underscores
- X (concat (math-match-substring x 1) "_" (math-match-substring x 2)))
- X x)
- )
- X
- (defun math-tex-expr-is-flat (a)
- X (or (Math-integerp a)
- X (memq (car a) '(float var))
- X (and (memq (car a) '(+ - * neg))
- X (progn
- X (while (and (setq a (cdr a))
- X (math-tex-expr-is-flat (car a))))
- X (null a)))
- X (and (memq (car a) '(^ calcFunc-subscr))
- X (math-tex-expr-is-flat (nth 1 a))))
- )
- X
- (put 'calcFunc-log 'math-compose-big 'math-compose-log)
- (defun math-compose-log (a prec)
- X (and (= (length a) 3)
- X (list 'horiz
- X (list 'subscr "log"
- X (let ((calc-language 'flat))
- X (math-compose-expr (nth 2 a) 1000)))
- X "("
- X (math-compose-expr (nth 1 a) 1000)
- X ")"))
- )
- X
- (put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
- (defun math-compose-log10 (a prec)
- X (and (= (length a) 2)
- X (list 'horiz
- X (list 'subscr "log" "10")
- X "("
- X (math-compose-expr (nth 1 a) 1000)
- X ")"))
- )
- X
- (put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
- (put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
- (defun math-compose-deriv (a prec)
- X (and (= (length a) 3)
- X (math-compose-expr (list '/
- X (list 'calcFunc-choriz
- X (list 'vec
- X '(calcFunc-string (vec ?d))
- X (nth 1 a)))
- X (list 'calcFunc-choriz
- X (list 'vec
- X '(calcFunc-string (vec ?d))
- X (nth 2 a))))
- X prec))
- )
- X
- (put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
- (defun math-compose-sqrt (a prec)
- X (and (= (length a) 2)
- X (let* ((c (math-compose-expr (nth 1 a) 0))
- X (a (math-comp-ascent c))
- X (d (math-comp-descent c))
- X (h (+ a d))
- X (w (math-comp-width c)))
- X (list 'vleft
- X a
- X (concat (if (= h 1) " " " ")
- X (make-string (+ w 2) ?\_))
- X (list 'horiz
- X (if (= h 1)
- X "V"
- X (append (list 'vleft (1- a))
- X (make-list (1- h) " |")
- X '("\\|")))
- X " "
- X c))))
- )
- X
- (put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
- (defun math-compose-choose (a prec)
- X (let ((a1 (math-compose-expr (nth 1 a) 0))
- X (a2 (math-compose-expr (nth 2 a) 0)))
- X (list 'horiz
- X "("
- X (list 'vcent
- X (math-comp-height a1)
- X a1 " " a2)
- X ")"))
- )
- X
- (put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
- (defun math-compose-integ (a prec)
- X (and (memq (length a) '(3 5))
- X (eq (car-safe (nth 2 a)) 'var)
- X (let* ((parens (and (>= prec 196) (/= prec 1000)))
- X (var (math-compose-expr (nth 2 a) 0))
- X (over (and (eq (car-safe (nth 2 a)) 'var)
- X (or (and (eq (car-safe (nth 1 a)) '/)
- X (math-numberp (nth 1 (nth 1 a))))
- X (and (eq (car-safe (nth 1 a)) '^)
- X (math-looks-negp (nth 2 (nth 1 a)))))))
- X (expr (math-compose-expr (if over
- X (math-mul (nth 1 a)
- X (math-build-var-name
- X (format
- X "d%s"
- X (nth 1 (nth 2 a)))))
- X (nth 1 a)) 185))
- X (calc-language 'flat)
- X (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- X (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))))
- X (list 'horiz
- X (if parens "(" "")
- X (append (list 'vcent (if high 3 2))
- X (and high (list (list 'horiz " " high)))
- X '(" /"
- X " | "
- X " | "
- X " | "
- X "/ ")
- X (and low (list (list 'horiz low " "))))
- X expr
- X (if over
- X ""
- X (list 'horiz " d" var))
- X (if parens ")" ""))))
- )
- X
- (put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
- (defun math-compose-sum (a prec)
- X (and (memq (length a) '(3 5 6))
- X (let* ((expr (math-compose-expr (nth 1 a) 185))
- X (calc-language 'flat)
- X (var (math-compose-expr (nth 2 a) 0))
- X (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- X (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
- X (list 'horiz
- X (if (memq prec '(180 201)) "(" "")
- X (append (list 'vcent (if high 3 2))
- X (and high (list high))
- X '("---- "
- X "\\ "
- X " > "
- X "/ "
- X "---- ")
- X (if low
- X (list (list 'horiz var " = " low))
- X (list var)))
- X (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
- X " " "")
- X expr
- X (if (memq prec '(180 201)) ")" ""))))
- )
- X
- (put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
- (defun math-compose-prod (a prec)
- X (and (memq (length a) '(3 5 6))
- X (let* ((expr (math-compose-expr (nth 1 a) 198))
- X (calc-language 'flat)
- X (var (math-compose-expr (nth 2 a) 0))
- X (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- X (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
- X (list 'horiz
- X (if (memq prec '(196 201)) "(" "")
- X (append (list 'vcent (if high 3 2))
- X (and high (list high))
- X '("----- "
- X " | | "
- X " | | "
- X " | | ")
- X (if low
- X (list (list 'horiz var " = " low))
- X (list var)))
- X (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
- X " " "")
- X expr
- X (if (memq prec '(196 201)) ")" ""))))
- )
- X
- X
- (defun math-stack-value-offset-fancy ()
- X (let ((cwid (+ (math-comp-width c))))
- X (cond ((eq calc-display-just 'right)
- X (if calc-display-origin
- X (setq wid (max calc-display-origin 5))
- X (if (integerp calc-line-breaking)
- X (setq wid calc-line-breaking)))
- X (setq off (- wid cwid
- X (max (- (length calc-right-label)
- X (if (and (integerp calc-line-breaking)
- X calc-display-origin)
- X (max (- calc-line-breaking
- X calc-display-origin)
- X 0)
- X 0))
- X 0))))
- X (t
- X (if calc-display-origin
- X (progn
- X (setq off (- calc-display-origin (/ cwid 2)))
- X (if (integerp calc-line-breaking)
- X (setq off (min off (- calc-line-breaking cwid
- X (length calc-right-label)))))
- X (if (>= off 0)
- X (setq wid (max wid (+ off cwid)))))
- X (if (integerp calc-line-breaking)
- X (setq wid calc-line-breaking))
- X (setq off (/ (- wid cwid) 2)))))
- X (and (integerp calc-line-breaking)
- X (or (< off 0)
- X (and calc-display-origin
- X (> calc-line-breaking calc-display-origin)))
- X (setq wid calc-line-breaking)))
- )
- X
- X
- X
- ;;; Convert a composition to string form, with embedded \n's if necessary.
- X
- (defun math-composition-to-string (c &optional width)
- X (or width (setq width (calc-window-width)))
- X (if calc-display-raw
- X (math-comp-to-string-raw c 0)
- X (if (math-comp-is-flat c)
- X (math-comp-to-string-flat c width)
- X (math-vert-comp-to-string
- X (math-comp-simplify c width))))
- )
- X
- (defun math-comp-is-flat (c) ; check if c's height is 1.
- X (cond ((not (consp c)) t)
- X ((memq (car c) '(set break)) t)
- X ((eq (car c) 'horiz)
- X (while (and (setq c (cdr c))
- X (math-comp-is-flat (car c))))
- X (null c))
- X ((memq (car c) '(vleft vcent vright))
- X (and (= (length c) 3)
- X (= (nth 1 c) 0)
- X (math-comp-is-flat (nth 2 c))))
- X ((eq (car c) 'tag)
- X (math-comp-is-flat (nth 2 c)))
- X (t nil))
- )
- X
- X
- ;;; Convert a one-line composition to a string. Break into multiple
- ;;; lines if necessary, choosing break points according to the structure
- ;;; of the formula.
- X
- (defun math-comp-to-string-flat (c full-width)
- X (if math-comp-sel-hpos
- X (let ((comp-pos 0))
- X (math-comp-sel-flat-term c))
- X (let ((comp-buf "")
- X (comp-word "")
- X (comp-pos 0)
- X (comp-margin 0)
- X (comp-highlight (and math-comp-selected calc-show-selections))
- X (comp-level -1))
- X (math-comp-to-string-flat-term '(set -1 0))
- X (math-comp-to-string-flat-term c)
- X (math-comp-to-string-flat-term '(break -1))
- X (let ((str (aref math-comp-buf-string 0))
- X (prefix ""))
- X (and (> (length str) 0) (= (aref str 0) ? )
- X (> (length comp-buf) 0)
- X (let ((k (length comp-buf)))
- X (while (not (= (aref comp-buf (setq k (1- k))) ?\n)))
- X (aset comp-buf k ? )
- X (if (and (< (1+ k) (length comp-buf))
- X (= (aref comp-buf (1+ k)) ? ))
- X (progn
- X (aset comp-buf (1+ k) ?\n)
- X (setq prefix " "))
- X (setq prefix "\n"))))
- X (concat comp-buf prefix str))))
- )
- (setq math-comp-buf-string (make-vector 10 ""))
- (setq math-comp-buf-margin (make-vector 10 0))
- (setq math-comp-buf-level (make-vector 10 0))
- X
- (defun math-comp-to-string-flat-term (c)
- X (cond ((not (consp c))
- X (if comp-highlight
- X (setq c (math-comp-highlight-string c)))
- X (setq comp-word (if (= (length comp-word) 0) c (concat comp-word c))
- X comp-pos (+ comp-pos (length c))))
- X
- X ((eq (car c) 'horiz)
- X (while (setq c (cdr c))
- X (math-comp-to-string-flat-term (car c))))
- X
- X ((eq (car c) 'set)
- X (if (nth 1 c)
- X (progn
- X (setq comp-level (1+ comp-level))
- X (if (>= comp-level (length math-comp-buf-string))
- X (setq math-comp-buf-string (vconcat math-comp-buf-string
- X math-comp-buf-string)
- X math-comp-buf-margin (vconcat math-comp-buf-margin
- X math-comp-buf-margin)
- X math-comp-buf-level (vconcat math-comp-buf-level
- X math-comp-buf-level)))
- X (aset math-comp-buf-string comp-level "")
- X (aset math-comp-buf-margin comp-level (+ comp-pos
- X (or (nth 2 c) 0)))
- X (aset math-comp-buf-level comp-level (nth 1 c)))))
- X
- X ((eq (car c) 'break)
- X (if (not calc-line-breaking)
- X (setq comp-buf (concat comp-buf comp-word)
- X comp-word "")
- X (let ((i 0) str)
- X (if (and (> comp-pos full-width)
- X (progn
- X (while (progn
- X (setq str (aref math-comp-buf-string i))
- X (and (= (length str) 0) (< i comp-level)))
- X (setq i (1+ i)))
- X (or (> (length str) 0) (> (length comp-buf) 0))))
- X (let ((prefix "") mrg wid)
- X (setq mrg (aref math-comp-buf-margin i))
- X (if (> mrg 12) ; indenting too far, go back to far left
- X (let ((j i) (new (if calc-line-numbering 5 1)))
- X (while (<= j comp-level)
- X (aset math-comp-buf-margin j
- X (+ (aref math-comp-buf-margin j) (- new mrg)))
- X (setq j (1+ j)))
- X (setq mrg new)))
- X (setq wid (+ (length str) comp-margin))
- X (and (> (length str) 0) (= (aref str 0) ? )
- X (> (length comp-buf) 0)
- X (let ((k (length comp-buf)))
- X (while (not (= (aref comp-buf (setq k (1- k))) ?\n)))
- X (aset comp-buf k ? )
- X (if (and (< (1+ k) (length comp-buf))
- X (= (aref comp-buf (1+ k)) ? ))
- X (progn
- X (aset comp-buf (1+ k) ?\n)
- X (setq prefix " "))
- X (setq prefix "\n"))))
- X (setq comp-buf (concat comp-buf prefix str "\n"
- X (make-string mrg ? ))
- X comp-pos (+ comp-pos (- mrg wid))
- X comp-margin mrg)
- X (aset math-comp-buf-string i "")
- X (while (<= (setq i (1+ i)) comp-level)
- X (if (> (aref math-comp-buf-margin i) wid)
- X (aset math-comp-buf-margin i
- X (+ (aref math-comp-buf-margin i)
- X (- mrg wid))))))))
- X (if (and (= (nth 1 c) (aref math-comp-buf-level comp-level))
- X (< comp-pos (+ (aref math-comp-buf-margin comp-level) 2)))
- X () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
- X (let ((str (aref math-comp-buf-string comp-level)))
- X (setq str (if (= (length str) 0)
- X comp-word
- X (concat str comp-word))
- X comp-word "")
- X (while (< (nth 1 c) (aref math-comp-buf-level comp-level))
- X (setq comp-level (1- comp-level))
- X (or (= (length (aref math-comp-buf-string comp-level)) 0)
- X (setq str (concat (aref math-comp-buf-string comp-level)
- X str))))
- X (aset math-comp-buf-string comp-level str)))))
- X
- X ((eq (car c) 'tag)
- X (cond ((eq (nth 1 c) math-comp-selected)
- X (let ((comp-highlight (not calc-show-selections)))
- X (math-comp-to-string-flat-term (nth 2 c))))
- X ((eq (nth 1 c) t)
- X (let ((comp-highlight nil))
- X (math-comp-to-string-flat-term (nth 2 c))))
- X (t (math-comp-to-string-flat-term (nth 2 c)))))
- X
- X (t (math-comp-to-string-flat-term (nth 2 c))))
- )
- X
- (defun math-comp-highlight-string (s)
- X (setq s (copy-sequence s))
- X (let ((i (length s)))
- X (while (>= (setq i (1- i)) 0)
- X (or (memq (aref s i) '(32 ?\n))
- X (aset s i (if calc-show-selections ?\. ?\#)))))
- X s
- )
- X
- (defun math-comp-sel-flat-term (c)
- X (cond ((not (consp c))
- X (setq comp-pos (+ comp-pos (length c))))
- X ((memq (car c) '(set break)))
- X ((eq (car c) 'horiz)
- X (while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000))
- X (math-comp-sel-flat-term (car c))))
- X ((eq (car c) 'tag)
- X (if (<= comp-pos math-comp-sel-cpos)
- X (progn
- X (math-comp-sel-flat-term (nth 2 c))
- X (if (> comp-pos math-comp-sel-cpos)
- X (setq math-comp-sel-tag c
- X math-comp-sel-cpos 1000000)))
- X (math-comp-sel-flat-term (nth 2 c))))
- X (t (math-comp-sel-flat-term (nth 2 c))))
- )
- X
- X
- ;;; Simplify a composition to a canonical form consisting of
- ;;; (vleft n "string" "string" "string" ...)
- ;;; where 0 <= n < number-of-strings.
- X
- (defun math-comp-simplify (c full-width)
- X (let ((comp-buf (list ""))
- X (comp-base 0)
- X (comp-height 1)
- X (comp-hpos 0)
- X (comp-vpos 0)
- X (comp-highlight (and math-comp-selected calc-show-selections))
- X (comp-tag nil))
- X (math-comp-simplify-term c)
- X (cons 'vleft (cons comp-base comp-buf)))
- )
- X
- (defun math-comp-add-string (s h v)
- X (and (> (length s) 0)
- X (let ((vv (+ v comp-base)))
- X (if math-comp-sel-hpos
- X (math-comp-add-string-sel h vv (length s) 1)
- X (if (< vv 0)
- X (setq comp-buf (nconc (make-list (- vv) "") comp-buf)
- X comp-base (- v)
- X comp-height (- comp-height vv)
- X vv 0)
- X (if (>= vv comp-height)
- X (setq comp-buf (nconc comp-buf
- X (make-list (1+ (- vv comp-height)) ""))
- X comp-height (1+ vv))))
- X (let ((str (nthcdr vv comp-buf)))
- X (setcar str (concat (car str)
- X (make-string (- h (length (car str))) 32)
- X (if comp-highlight
- X (math-comp-highlight-string s)
- X s)))))))
- )
- X
- (defun math-comp-add-string-sel (x y w h)
- X (if (and (<= y math-comp-sel-vpos)
- X (> (+ y h) math-comp-sel-vpos)
- X (<= x math-comp-sel-hpos)
- X (> (+ x w) math-comp-sel-hpos))
- X (setq math-comp-sel-tag comp-tag
- X math-comp-sel-vpos 10000))
- )
- X
- (defun math-comp-simplify-term (c)
- X (cond ((stringp c)
- X (math-comp-add-string c comp-hpos comp-vpos)
- X (setq comp-hpos (+ comp-hpos (length c))))
- X ((memq (car c) '(set break))
- X nil)
- X ((eq (car c) 'horiz)
- X (while (setq c (cdr c))
- X (math-comp-simplify-term (car c))))
- X ((memq (car c) '(vleft vcent vright))
- X (let* ((comp-vpos (+ (- comp-vpos (nth 1 c))
- X (1- (math-comp-ascent (nth 2 c)))))
- X (widths (mapcar 'math-comp-width (cdr (cdr c))))
- X (maxwid (apply 'max widths))
- X (bias (cond ((eq (car c) 'vleft) 0)
- X ((eq (car c) 'vcent) 1)
- X (t 2))))
- X (setq c (cdr c))
- X (while (setq c (cdr c))
- X (if (eq (car-safe (car c)) 'rule)
- X (math-comp-add-string (make-string maxwid (nth 1 (car c)))
- X comp-hpos comp-vpos)
- X (let ((comp-hpos (+ comp-hpos (/ (* bias (- maxwid
- X (car widths)))
- X 2))))
- X (math-comp-simplify-term (car c))))
- X (and (cdr c)
- X (setq comp-vpos (+ comp-vpos
- X (+ (math-comp-descent (car c))
- X (math-comp-ascent (nth 1 c))))
- X widths (cdr widths))))
- X (setq comp-hpos (+ comp-hpos maxwid))))
- X ((eq (car c) 'supscr)
- X (let* ((asc (or 1 (math-comp-ascent (nth 1 c))))
- X (desc (math-comp-descent (nth 2 c)))
- X (oldh (prog1
- X comp-hpos
- X (math-comp-simplify-term (nth 1 c))))
- X (comp-vpos (- comp-vpos (+ asc desc))))
- X (math-comp-simplify-term (nth 2 c))
- X (if math-comp-sel-hpos
- X (math-comp-add-string-sel oldh
- X (- comp-vpos
- X -1
- X (math-comp-ascent (nth 2 c)))
- X (- comp-hpos oldh)
- X (math-comp-height c)))))
- X ((eq (car c) 'subscr)
- X (let* ((asc (math-comp-ascent (nth 2 c)))
- X (desc (math-comp-descent (nth 1 c)))
- X (oldv comp-vpos)
- X (oldh (prog1
- X comp-hpos
- X (math-comp-simplify-term (nth 1 c))))
- X (comp-vpos (+ comp-vpos (+ asc desc))))
- X (math-comp-simplify-term (nth 2 c))
- X (if math-comp-sel-hpos
- X (math-comp-add-string-sel oldh oldv
- X (- comp-hpos oldh)
- X (math-comp-height c)))))
- X ((eq (car c) 'tag)
- X (cond ((eq (nth 1 c) math-comp-selected)
- X (let ((comp-highlight (not calc-show-selections)))
- X (math-comp-simplify-term (nth 2 c))))
- X ((eq (nth 1 c) t)
- X (let ((comp-highlight nil))
- X (math-comp-simplify-term (nth 2 c))))
- X (t (let ((comp-tag c))
- X (math-comp-simplify-term (nth 2 c)))))))
- )
- X
- X
- ;;; Measuring a composition.
- X
- (defun math-comp-first-char (c)
- X (cond ((stringp c)
- X (and (> (length c) 0)
- X (elt c 0)))
- X ((memq (car c) '(horiz subscr supscr))
- X (while (and (setq c (cdr c))
- X (math-comp-is-null (car c))))
- X (and c (math-comp-first-char (car c))))
- X ((eq (car c) 'tag)
- X (math-comp-first-char (nth 2 c))))
- )
- X
- (defun math-comp-first-string (c)
- X (cond ((stringp c)
- X (and (> (length c) 0)
- X c))
- X ((eq (car c) 'horiz)
- X (while (and (setq c (cdr c))
- X (math-comp-is-null (car c))))
- X (and c (math-comp-first-string (car c))))
- X ((eq (car c) 'tag)
- X (math-comp-first-string (nth 2 c))))
- )
- X
- (defun math-comp-last-char (c)
- X (cond ((stringp c)
- X (and (> (length c) 0)
- X (elt c (1- (length c)))))
- X ((eq (car c) 'horiz)
- X (let ((c (reverse (cdr c))))
- X (while (and c (math-comp-is-null (car c)))
- X (setq c (cdr c)))
- X (and c (math-comp-last-char (car c)))))
- X ((eq (car c) 'tag)
- X (math-comp-last-char (nth 2 c))))
- )
- X
- (defun math-comp-is-null (c)
- X (cond ((stringp c) (= (length c) 0))
- X ((memq (car c) '(horiz subscr supscr))
- X (while (and (setq c (cdr c))
- X (math-comp-is-null (car c))))
- X (null c))
- X ((eq (car c) 'tag)
- X (math-comp-is-null (nth 2 c)))
- X ((memq (car c) '(set break)) t))
- )
- X
- (defun math-comp-width (c)
- X (cond ((not (consp c)) (length c))
- X ((memq (car c) '(horiz subscr supscr))
- X (let ((accum 0))
- X (while (setq c (cdr c))
- X (setq accum (+ accum (math-comp-width (car c)))))
- X accum))
- X ((memq (car c) '(vcent vleft vright))
- X (setq c (cdr c))
- X (let ((accum 0))
- X (while (setq c (cdr c))
- X (setq accum (max accum (math-comp-width (car c)))))
- X accum))
- X ((eq (car c) 'tag)
- X (math-comp-width (nth 2 c)))
- X (t 0))
- )
- X
- (defun math-comp-height (c)
- X (if (stringp c)
- X 1
- X (+ (math-comp-ascent c) (math-comp-descent c)))
- )
- X
- (defun math-comp-ascent (c)
- X (cond ((not (consp c)) 1)
- X ((eq (car c) 'horiz)
- X (let ((accum 0))
- X (while (setq c (cdr c))
- X (setq accum (max accum (math-comp-ascent (car c)))))
- X accum))
- X ((memq (car c) '(vcent vleft vright))
- X (if (> (nth 1 c) 0) (1+ (nth 1 c)) 1))
- X ((eq (car c) 'supscr)
- X (max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c)))))
- X ((eq (car c) 'subscr)
- X (math-comp-ascent (nth 1 c)))
- X ((eq (car c) 'tag)
- X (math-comp-ascent (nth 2 c)))
- X (t 1))
- )
- X
- (defun math-comp-descent (c)
- X (cond ((not (consp c)) 0)
- X ((eq (car c) 'horiz)
- X (let ((accum 0))
- X (while (setq c (cdr c))
- SHAR_EOF
- true || echo 'restore of calc-comp.el failed'
- fi
- echo 'End of part 11'
- echo 'File calc-comp.el is continued in part 12'
- echo 12 > _shar_seq_.tmp
- exit 0
- exit 0 # Just in case...
- --
- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
- Sterling Software, IMD UUCP: uunet!sparky!kent
- Phone: (402) 291-8300 FAX: (402) 291-4362
- Please send comp.sources.misc-related mail to kent@uunet.uu.net.
-