Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume24/gnucalc/part12

Lisp/Scheme | 1991-10-29 | 57KB | 1,750 lines

Newsgroups: comp.sources.misc
From: [e-mail] (David Gillespie)
Subject:  v24i060:  gnucalc - GNU Emacs Calculator, v2.00, Part12/56
Message-ID: <[e-mail]>
X-Md4-Signature: 276a2a38d451b3a8a87fc2dace749499
Date: Tue, 29 Oct 1991 23:01:23 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (David Gillespie)
Posting-number: Volume 24, Issue 60
Archive-name: gnucalc/part12
Environment: Emacs
Supersedes: gmcalc: Volume 13, Issue 27-45

---- Cut Here and unpack ----
#!/bin/sh
# this is Part.12 (part 12 of a multipart archive)
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-comp.el continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 12; 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-comp.el'
else
echo 'x - continuing file calc-comp.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-comp.el' &&
X         (setq accum (max accum (math-comp-descent (car c)))))
X       accum))
X    ((memq (car c) '(vcent vleft vright))
X     (let ((accum (- (nth 1 c))))
X       (setq c (cdr c))
X       (while (setq c (cdr c))
X         (setq accum (+ accum (math-comp-height (car c)))))
X       (max (1- accum) 0)))
X    ((eq (car c) 'supscr)
X     (math-comp-descent (nth 1 c)))
X    ((eq (car c) 'subscr)
X     (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
X    ((eq (car c) 'tag)
X     (math-comp-descent (nth 2 c)))
X    (t 0))
)
X
(defun calcFunc-cwidth (a &optional prec)
X  (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
X  (math-comp-width (math-compose-expr a (or prec 0)))
)
X
(defun calcFunc-cheight (a &optional prec)
X  (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
X  (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
X       (memq (length a) '(2 3))
X       (eq (nth 1 a) 0))
X      0
X    (math-comp-height (math-compose-expr a (or prec 0))))
)
X
(defun calcFunc-cascent (a &optional prec)
X  (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
X  (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
X       (memq (length a) '(2 3))
X       (eq (nth 1 a) 0))
X      0
X    (math-comp-ascent (math-compose-expr a (or prec 0))))
)
X
(defun calcFunc-cdescent (a &optional prec)
X  (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
X  (math-comp-descent (math-compose-expr a (or prec 0)))
)
X
X
;;; Convert a simplified composition into string form.
X
(defun math-vert-comp-to-string (c)
X  (if (stringp c)
X      c
X    (math-vert-comp-to-string-step (cdr (cdr c))))
)
X
(defun math-vert-comp-to-string-step (c)
X  (if (cdr c)
X      (concat (car c) "\n" (math-vert-comp-to-string-step (cdr c)))
X    (car c))
)
X
X
;;; Convert a composition to a string in "raw" form (for debugging).
X
(defun math-comp-to-string-raw (c indent)
X  (cond ((or (not (consp c)) (eq (car c) 'set))
X     (prin1-to-string c))
X    ((null (cdr c))
X     (concat "(" (symbol-name (car c)) ")"))
X    (t
X     (let ((next-indent (+ indent 2 (length (symbol-name (car c))))))
X       (concat "("
X           (symbol-name (car c))
X           " "
X           (math-comp-to-string-raw (nth 1 c) next-indent)
X           (math-comp-to-string-raw-step (cdr (cdr c))
X                         next-indent)
X           ")"))))
)
X
(defun math-comp-to-string-raw-step (cl indent)
X  (if cl
X      (concat "\n"
X          (make-string indent 32)
X          (math-comp-to-string-raw (car cl) indent)
X          (math-comp-to-string-raw-step (cdr cl) indent))
X    "")
)
X
X
X
X
SHAR_EOF
echo 'File calc-comp.el is complete' &&
chmod 0644 calc-comp.el ||
echo 'restore of calc-comp.el failed'
Wc_c="`wc -c < 'calc-comp.el'`"
test 54712 -eq "$Wc_c" ||
    echo 'calc-comp.el: original size 54712, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-cplx.el ==============
if test -f 'calc-cplx.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-cplx.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-cplx.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-cplx.el' &&
;; Calculator for GNU Emacs, part II [calc-cplx.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
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-cplx () nil)
X
X
(defun calc-argument (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "arg" 'calcFunc-arg arg))
)
X
(defun calc-re (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "re" 'calcFunc-re arg))
)
X
(defun calc-im (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "im" 'calcFunc-im arg))
)
X
X
(defun calc-polar ()
X  (interactive)
X  (calc-slow-wrapper
X   (let ((arg (calc-top-n 1)))
X     (if (or (calc-is-inverse)
X         (eq (car-safe arg) 'polar))
X     (calc-enter-result 1 "p-r" (list 'calcFunc-rect arg))
X       (calc-enter-result 1 "r-p" (list 'calcFunc-polar arg)))))
)
X
X
X
X
(defun calc-complex-notation ()
X  (interactive)
X  (calc-wrapper
X   (calc-change-mode 'calc-complex-format nil t)
X   (message "Displaying complex numbers in (X,Y) format."))
)
X
(defun calc-i-notation ()
X  (interactive)
X  (calc-wrapper
X   (calc-change-mode 'calc-complex-format 'i t)
X   (message "Displaying complex numbers in X+Yi format."))
)
X
(defun calc-j-notation ()
X  (interactive)
X  (calc-wrapper
X   (calc-change-mode 'calc-complex-format 'j t)
X   (message "Displaying complex numbers in X+Yj format."))
)
X
X
(defun calc-polar-mode (n)
X  (interactive "P")
X  (calc-wrapper
X   (if (if n
X       (> (prefix-numeric-value n) 0)
X     (eq calc-complex-mode 'cplx))
X       (progn
X     (calc-change-mode 'calc-complex-mode 'polar)
X     (message "Preferred complex form is polar."))
X     (calc-change-mode 'calc-complex-mode 'cplx)
X     (message "Preferred complex form is rectangular.")))
)
X
X
;;;; Complex numbers.
X
(defun math-normalize-polar (a)
X  (let ((r (math-normalize (nth 1 a)))
X    (th (math-normalize (nth 2 a))))
X    (cond ((math-zerop r)
X       '(polar 0 0))
X      ((or (math-zerop th))
X       r)
X      ((and (not (eq calc-angle-mode 'rad))
X        (or (equal th '(float 18 1))
X            (equal th 180)))
X       (math-neg r))
X      ((math-negp r)
X       (math-neg (list 'polar (math-neg r) th)))
X      (t
X       (list 'polar r th))))
)
X
X
;;; Coerce A to be complex (rectangular form).  [c N]
(defun math-complex (a)
X  (cond ((eq (car-safe a) 'cplx) a)
X    ((eq (car-safe a) 'polar)
X     (if (math-zerop (nth 1 a))
X         (nth 1 a)
X       (let ((sc (calcFunc-sincos (nth 2 a))))
X         (list 'cplx
X           (math-mul (nth 1 a) (nth 1 sc))
X           (math-mul (nth 1 a) (nth 2 sc))))))
X    (t (list 'cplx a 0)))
)
X
;;; Coerce A to be complex (polar form).  [c N]
(defun math-polar (a)
X  (cond ((eq (car-safe a) 'polar) a)
X    ((math-zerop a) '(polar 0 0))
X    (t
X     (list 'polar
X           (math-abs a)
X           (calcFunc-arg a))))
)
X
;;; Multiply A by the imaginary constant i.  [N N] [Public]
(defun math-imaginary (a)
X  (if (and (or (Math-objvecp a) (math-infinitep a))
X       (not calc-symbolic-mode))
X      (math-mul a
X        (if (or (eq (car-safe a) 'polar)
X            (and (not (eq (car-safe a) 'cplx))
X                 (eq calc-complex-mode 'polar)))
X            (list 'polar 1 (math-quarter-circle nil))
X          '(cplx 0 1)))
X    (math-mul a '(var i var-i)))
)
X
X
X
X
(defun math-want-polar (a b)
X  (cond ((eq (car-safe a) 'polar)
X     (if (eq (car-safe b) 'cplx)
X         (eq calc-complex-mode 'polar)
X       t))
X    ((eq (car-safe a) 'cplx)
X     (if (eq (car-safe b) 'polar)
X         (eq calc-complex-mode 'polar)
X       nil))
X    ((eq (car-safe b) 'polar)
X     t)
X    ((eq (car-safe b) 'cplx)
X     nil)
X    (t (eq calc-complex-mode 'polar)))
)
X
;;; Force A to be in the (-pi,pi] or (-180,180] range.
(defun math-fix-circular (a &optional dir)   ; [R R]
X  (cond ((eq (car-safe a) 'hms)
X     (cond ((and (Math-lessp 180 (nth 1 a)) (not (eq dir 1)))
X        (math-fix-circular (math-add a '(float -36 1)) -1))
X           ((or (Math-lessp -180 (nth 1 a)) (eq dir -1))
X        a)
X           (t
X        (math-fix-circular (math-add a '(float 36 1)) 1))))
X    ((eq calc-angle-mode 'rad)
X     (cond ((and (Math-lessp (math-pi) a) (not (eq dir 1)))
X        (math-fix-circular (math-sub a (math-two-pi)) -1))
X           ((or (Math-lessp (math-neg (math-pi)) a) (eq dir -1))
X        a)
X           (t
X        (math-fix-circular (math-add a (math-two-pi)) 1))))
X    (t
X     (cond ((and (Math-lessp '(float 18 1) a) (not (eq dir 1)))
X        (math-fix-circular (math-add a '(float -36 1)) -1))
X           ((or (Math-lessp '(float -18 1) a) (eq dir -1))
X        a)
X           (t
X        (math-fix-circular (math-add a '(float 36 1)) 1)))))
)
X
X
;;;; Complex numbers.
X
(defun calcFunc-polar (a)   ; [C N] [Public]
X  (cond ((Math-vectorp a)
X     (math-map-vec 'calcFunc-polar a))
X    ((Math-realp a) a)
X    ((Math-numberp a)
X     (math-normalize (math-polar a)))
X    (t (list 'calcFunc-polar a)))
)
X
(defun calcFunc-rect (a)   ; [N N] [Public]
X  (cond ((Math-vectorp a)
X     (math-map-vec 'calcFunc-rect a))
X    ((Math-realp a) a)
X    ((Math-numberp a)
X     (math-normalize (math-complex a)))
X    (t (list 'calcFunc-rect a)))
)
X
;;; Compute the complex conjugate of A.  [O O] [Public]
(defun calcFunc-conj (a)
X  (let (aa bb)
X    (cond ((Math-realp a)
X       a)
X      ((eq (car a) 'cplx)
X       (list 'cplx (nth 1 a) (math-neg (nth 2 a))))
X      ((eq (car a) 'polar)
X       (list 'polar (nth 1 a) (math-neg (nth 2 a))))
X      ((eq (car a) 'vec)
X       (math-map-vec 'calcFunc-conj a))
X      ((eq (car a) 'calcFunc-conj)
X       (nth 1 a))
X      ((math-known-realp a)
X       a)
X      ((and (equal a '(var i var-i))
X        (math-imaginary-i))
X       (math-neg a))
X      ((and (memq (car a) '(+ - * /))
X        (progn
X          (setq aa (calcFunc-conj (nth 1 a))
X            bb (calcFunc-conj (nth 2 a)))
X          (or (not (eq (car-safe aa) 'calcFunc-conj))
X              (not (eq (car-safe bb) 'calcFunc-conj)))))
X       (if (eq (car a) '+)
X           (math-add aa bb)
X         (if (eq (car a) '-)
X         (math-sub aa bb)
X           (if (eq (car a) '*)
X           (math-mul aa bb)
X         (math-div aa bb)))))
X      ((eq (car a) 'neg)
X       (math-neg (calcFunc-conj (nth 1 a))))
X      ((let ((inf (math-infinitep a)))
X         (and inf
X          (math-mul (calcFunc-conj (math-infinite-dir a inf)) inf))))
X      (t (calc-record-why 'numberp a)
X         (list 'calcFunc-conj a))))
)
X
X
;;; Compute the complex argument of A.  [F N] [Public]
(defun calcFunc-arg (a)
X  (cond ((Math-anglep a)
X     (if (math-negp a) (math-half-circle nil) 0))
X    ((eq (car-safe a) 'cplx)
X     (calcFunc-arctan2 (nth 2 a) (nth 1 a)))
X    ((eq (car-safe a) 'polar)
X     (nth 2 a))
X    ((eq (car a) 'vec)
X     (math-map-vec 'calcFunc-arg a))
X    ((and (equal a '(var i var-i))
X          (math-imaginary-i))
X     (math-quarter-circle t))
X    ((and (equal a '(neg (var i var-i)))
X          (math-imaginary-i))
X     (math-neg (math-quarter-circle t)))
X    ((let ((signs (math-possible-signs a)))
X       (or (and (memq signs '(2 4 6)) 0)
X           (and (eq signs 1) (math-half-circle nil)))))
X    ((math-infinitep a)
X     (if (or (equal a '(var uinf var-uinf))
X         (equal a '(var nan var-nan)))
X         '(var nan var-nan)
X       (calcFunc-arg (math-infinite-dir a))))
X    (t (calc-record-why 'numvecp a)
X       (list 'calcFunc-arg a)))
)
X
(defun math-imaginary-i ()
X  (let ((val (calc-var-value 'var-i)))
X    (or (eq (car-safe val) 'special-const)
X    (equal val '(cplx 0 1))
X    (and (eq (car-safe val) 'polar)
X         (eq (nth 1 val) 0)
X         (Math-equal (nth 1 val) (math-quarter-circle nil)))))
)
X
;;; Extract the real or complex part of a complex number.  [R N] [Public]
;;; Also extracts the real part of a modulo form.
(defun calcFunc-re (a)
X  (let (aa bb)
X    (cond ((Math-realp a) a)
X      ((memq (car a) '(mod cplx))
X       (nth 1 a))
X      ((eq (car a) 'polar)
X       (math-mul (nth 1 a) (calcFunc-cos (nth 2 a))))
X      ((eq (car a) 'vec)
X       (math-map-vec 'calcFunc-re a))
X      ((math-known-realp a) a)
X      ((eq (car a) 'calcFunc-conj)
X       (calcFunc-re (nth 1 a)))
X      ((and (equal a '(var i var-i))
X        (math-imaginary-i))
X       0)
X      ((and (memq (car a) '(+ - *))
X        (progn
X          (setq aa (calcFunc-re (nth 1 a))
X            bb (calcFunc-re (nth 2 a)))
X          (or (not (eq (car-safe aa) 'calcFunc-re))
X              (not (eq (car-safe bb) 'calcFunc-re)))))
X       (if (eq (car a) '+)
X           (math-add aa bb)
X         (if (eq (car a) '-)
X         (math-sub aa bb)
X           (math-sub (math-mul aa bb)
X             (math-mul (calcFunc-im (nth 1 a))
X                   (calcFunc-im (nth 2 a)))))))
X      ((and (eq (car a) '/)
X        (math-known-realp (nth 2 a)))
X       (math-div (calcFunc-re (nth 1 a)) (nth 2 a)))
X      ((eq (car a) 'neg)
X       (math-neg (calcFunc-re (nth 1 a))))
X      (t (calc-record-why 'numberp a)
X         (list 'calcFunc-re a))))
)
X
(defun calcFunc-im (a)
X  (let (aa bb)
X    (cond ((Math-realp a)
X       (if (math-floatp a) '(float 0 0) 0))
X      ((eq (car a) 'cplx)
X       (nth 2 a))
X      ((eq (car a) 'polar)
X       (math-mul (nth 1 a) (calcFunc-sin (nth 2 a))))
X      ((eq (car a) 'vec)
X       (math-map-vec 'calcFunc-im a))
X      ((math-known-realp a)
X       0)
X      ((eq (car a) 'calcFunc-conj)
X       (math-neg (calcFunc-im (nth 1 a))))
X      ((and (equal a '(var i var-i))
X        (math-imaginary-i))
X       1)
X      ((and (memq (car a) '(+ - *))
X        (progn
X          (setq aa (calcFunc-im (nth 1 a))
X            bb (calcFunc-im (nth 2 a)))
X          (or (not (eq (car-safe aa) 'calcFunc-im))
X              (not (eq (car-safe bb) 'calcFunc-im)))))
X       (if (eq (car a) '+)
X           (math-add aa bb)
X         (if (eq (car a) '-)
X         (math-sub aa bb)
X           (math-add (math-mul (calcFunc-re (nth 1 a)) bb)
X             (math-mul aa (calcFunc-re (nth 2 a)))))))
X      ((and (eq (car a) '/)
X        (math-known-realp (nth 2 a)))
X       (math-div (calcFunc-im (nth 1 a)) (nth 2 a)))
X      ((eq (car a) 'neg)
X       (math-neg (calcFunc-im (nth 1 a))))
X      (t (calc-record-why 'numberp a)
X         (list 'calcFunc-im a))))
)
X
X
X
SHAR_EOF
chmod 0644 calc-cplx.el ||
echo 'restore of calc-cplx.el failed'
Wc_c="`wc -c < 'calc-cplx.el'`"
test 10186 -eq "$Wc_c" ||
    echo 'calc-cplx.el: original size 10186, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-embed.el ==============
if test -f 'calc-embed.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-embed.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-embed.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-embed.el' &&
;; Calculator for GNU Emacs, part II [calc-embed.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
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-embed () nil)
X
X
(defun calc-show-plain (n)
X  (interactive "P")
X  (calc-wrapper
X   (calc-set-command-flag 'renum-stack)
X   (message (if (calc-change-mode 'calc-show-plain n nil t)
X        "Including \"plain\" formulas in Calc Embedded mode."
X          "Omitting \"plain\" formulas in Calc Embedded mode.")))
)
X
X
X
X
;;; Things to do for Embedded Mode:
;;;
;;;  Detect and strip off unexpected labels during reading.
;;;
;;;  Get calc-grab-region to use math-read-big-expr.
;;;  If calc-show-plain, main body should have only righthand side of => expr.
;;;  Handle tabs that have crept into embedded formulas.
;;;  After "switching to new formula", home cursor to that formula.
;;;  Do something like \evalto ... \to for \gets operators.
;;;
X
X
(defvar calc-embedded-modes nil)
(defvar calc-embedded-globals nil)
(defvar calc-embedded-active nil)
X
(make-variable-buffer-local 'calc-embedded-all-active)
(make-variable-buffer-local 'calc-embedded-some-active)
X
X
(defvar calc-embedded-open-formula "\\`\\|^\n\\|\\$\\$?\\|\\\\\\[\\|^\\\\begin.*\n\\|^@.*\n\\|^\\.EQ.*\n\\|\\\\(\\|^%\n\\|^\\.\\\\\"\n"
X  "*A regular expression for the opening delimiter of a formula used by
calc-embedded.")
X
(defvar calc-embedded-close-formula "\\'\\|\n$\\|\\$\\$?\\|\\\\]\\|^\\\\end.*\n\\|^@.*\n\\|^\\.EN.*\n\\|\\\\)\\|\n%\n\\|^\\.\\\\\"\n"
X  "*A regular expression for the closing delimiter of a formula used by
calc-embedded.")
X
(defvar calc-embedded-open-word "^\\|[^-+0-9.eE]"
X  "*A regular expression for the opening delimiter of a formula used by
calc-embedded-word.")
X
(defvar calc-embedded-close-word "$\\|[^-+0-9.eE]"
X  "*A regular expression for the closing delimiter of a formula used by
calc-embedded-word.")
X
(defvar calc-embedded-open-plain "%%% "
X  "*A string which is the opening delimiter for a \"plain\" formula.
If calc-show-plain mode is enabled, this is inserted at the front of
each formula.")
X
(defvar calc-embedded-close-plain " %%%\n"
X  "*A string which is the closing delimiter for a \"plain\" formula.
See calc-embedded-open-plain.")
X
(defvar calc-embedded-open-new-formula "\n\n"
X  "*A string which is inserted at front of formula by calc-embedded-new-formula.")
X
(defvar calc-embedded-close-new-formula "\n\n"
X  "*A string which is inserted at end of formula by calc-embedded-new-formula.")
X
(defvar calc-embedded-announce-formula "%Embed\n\\(% .*\n\\)*"
X  "*A regular expression which is sure to be followed by a calc-embedded formula." )
X
(defvar calc-embedded-open-mode "% "
X  "*A string which should precede calc-embedded mode annotations.
This is not required to be present for user-written mode annotations.")
X
(defvar calc-embedded-close-mode "\n"
X  "*A string which should follow calc-embedded mode annotations.
This is not required to be present for user-written mode annotations.")
X
X
(defconst calc-embedded-mode-vars '(("precision" . calc-internal-prec)
X                    ("word-size" . calc-word-size)
X                    ("angles" . calc-angle-mode)
X                    ("symbolic" . calc-symbolic-mode)
X                    ("matrix" . calc-matrix-mode)
X                    ("fractions" . calc-prefer-frac)
X                    ("complex" . calc-complex-mode)
X                    ("simplify" . calc-simplify-mode)
X                    ("language" . the-language)
X                    ("plain" . calc-show-plain)
X                    ("break" . calc-line-breaking)
X                    ("justify" . the-display-just)
X                    ("left-label" . calc-left-label)
X                    ("right-label" . calc-right-label)
X                    ("radix" . calc-number-radix)
X                    ("leading-zeros" . calc-leading-zeros)
X                    ("grouping" . calc-group-digits)
X                    ("group-char" . calc-group-char)
X                    ("point-char" . calc-point-char)
X                    ("frac-format" . calc-frac-format)
X                    ("float-format" . calc-float-format)
X                    ("complex-format" . calc-complex-format)
X                    ("hms-format" . calc-hms-format)
X                    ("date-format" . calc-date-format)
X                    ("matrix-justify" . calc-matrix-just)
X                    ("full-vectors" . calc-full-vectors)
X                    ("break-vectors" . calc-break-vectors)
X                    ("vector-commas" . calc-vector-commas)
X                    ("vector-brackets" . calc-vector-brackets)
X                    ("matrix-brackets" . calc-matrix-brackets)
X                    ("strings" . calc-display-strings)
))
X
X
;;; Format of calc-embedded-info vector:
;;;    0   Editing buffer.
;;;    1   Calculator buffer.
;;;    2   Top of current formula (marker).
;;;    3   Bottom of current formula (marker).
;;;    4   Top of current formula's delimiters (marker).
;;;    5   Bottom of current formula's delimiters (marker).
;;;    6   String representation of current formula.
;;;    7   Non-nil if formula is embedded within a single line.
;;;    8   Internal representation of current formula.
;;;    9   Variable assigned by this formula, or nil.
;;;   10   List of variables upon which this formula depends.
;;;   11   Evaluated value of the formula, or nil.
;;;   12   Mode settings for current formula.
;;;   13   Local mode settings for current formula.
;;;   14   Permanent mode settings for current formula.
;;;   15   Global mode settings for editing buffer.
X
X
;;; calc-embedded-active is an a-list keyed on buffers; each cdr is a
;;; sorted list of calc-embedded-infos in that buffer.  We do this
;;; rather than using buffer-local variables because the latter are
;;; thrown away when a buffer changes major modes.
X
X
(defun calc-do-embedded (arg end obeg oend)
X  (if calc-embedded-info
X
X      ;; Turn embedded mode off or switch to a new buffer.
X      (cond ((eq (current-buffer) (aref calc-embedded-info 1))
X         (let ((calcbuf (current-buffer))
X           (buf (aref calc-embedded-info 0)))
X           (calc-embedded-original-buffer t)
X           (calc-embedded nil)
X           (switch-to-buffer calcbuf)))
X
X        ((eq (current-buffer) (aref calc-embedded-info 0))
X         (let* ((info calc-embedded-info)
X            (mode calc-embedded-modes))
X           (save-excursion
X         (set-buffer (aref info 1))
X         (if (and (> (calc-stack-size) 0)
X              (equal (calc-top 1 'full) (aref info 8)))
X             (let ((calc-no-refresh-evaltos t))
X               (if (calc-top 1 'sel)
X               (calc-unselect 1))
X               (calc-embedded-set-modes
X            (aref info 15) (aref info 12) (aref info 14))
X               (let ((calc-embedded-info nil))
X             (calc-wrapper (calc-pop-stack))))
X           (calc-set-mode-line)))
X           (setq calc-embedded-info nil
X             mode-line-buffer-identification (car mode)
X             truncate-lines (nth 2 mode)
X             buffer-read-only nil)
X           (use-local-map (nth 1 mode))
X           (set-buffer-modified-p (buffer-modified-p))
X           (or calc-embedded-quiet
X           (message "Back to %s mode." mode-name))))
X
X        (t
X         (if (buffer-name (aref calc-embedded-info 0))
X         (save-excursion
X           (set-buffer (aref calc-embedded-info 0))
X           (or (y-or-n-p "Cancel Calc Embedded mode in buffer %s? "
X                 (buffer-name))
X               (keyboard-quit))
X           (calc-embedded nil)))
X         (calc-embedded arg end obeg oend)))
X
X    ;; Turn embedded mode on.
X    (calc-plain-buffer-only)
X    (let ((modes (list mode-line-buffer-identification
X               (current-local-map)
X               truncate-lines))
X      top bot outer-top outer-bot
X      info chg ident)
X      (barf-if-buffer-read-only)
X      (or calc-embedded-globals
X      (calc-find-globals))
X      (setq info (calc-embedded-make-info (point) nil t arg end obeg oend))
X      (if (eq (car-safe (aref info 8)) 'error)
X      (progn
X        (goto-char (nth 1 (aref info 8)))
X        (error (nth 2 (aref info 8)))))
X      (let ((mode-line-buffer-identification mode-line-buffer-identification)
X        (calc-embedded-info info)
X        (calc-embedded-no-reselect t))
X    (calc-wrapper
X     (let* ((okay nil)
X        (calc-no-refresh-evaltos t))
X       (setq chg (calc-embedded-set-modes
X              (aref info 15) (aref info 12) (aref info 13)))
X       (if (aref info 8)
X           (calc-push (calc-normalize (aref info 8)))
X         (calc-alg-entry)))
X     (setq calc-undo-list nil
X           calc-redo-list nil
X           ident mode-line-buffer-identification)))
X      (setq calc-embedded-info info
X        calc-embedded-modes modes
X        mode-line-buffer-identification ident
X        truncate-lines t
X        buffer-read-only t)
X      (set-buffer-modified-p (buffer-modified-p))
X      (use-local-map calc-mode-map)
X      (setq calc-no-refresh-evaltos nil)
X      (and chg calc-any-evaltos (calc-wrapper (calc-refresh-evaltos)))
X      (or (eq calc-embedded-quiet t)
X      (message "Embedded Calc mode enabled.  %s to return to normal."
X           (if calc-embedded-quiet
X               "Type `M-# x'"
X             "Give this command again")))))
X  (scroll-down 0)    ; fix a bug which occurs when truncate-lines is changed.
)
(setq calc-embedded-quiet nil)
X
X
(defun calc-embedded-select (arg)
X  (interactive "P")
X  (calc-embedded arg)
X  (and calc-embedded-info
X       (eq (car-safe (aref calc-embedded-info 8)) 'calcFunc-evalto)
X       (calc-select-part 1))
X  (and calc-embedded-info
X       (or (eq (car-safe (aref calc-embedded-info 8)) 'calcFunc-assign)
X       (and (eq (car-safe (aref calc-embedded-info 8)) 'calcFunc-evalto)
X        (eq (car-safe (nth 1 (aref calc-embedded-info 8)))
X            'calcFunc-assign)))
X       (calc-select-part 2))
)
X
X
(defun calc-embedded-update-formula (arg)
X  (interactive "P")
X  (if arg
X      (let ((entry (assq (current-buffer) calc-embedded-active)))
X    (while (setq entry (cdr entry))
X      (and (eq (car-safe (aref (car entry) 8)) 'calcFunc-evalto)
X           (or (not (consp arg))
X           (and (<= (aref (car entry) 2) (region-beginning))
X            (>= (aref (car entry) 3) (region-end))))
X           (save-excursion
X         (calc-embedded-update (car entry) 14 t t)))))
X    (if (and calc-embedded-info
X         (eq (current-buffer) (aref calc-embedded-info 0))
X         (>= (point) (aref calc-embedded-info 4))
X         (<= (point) (aref calc-embedded-info 5)))
X    (calc-evaluate 1)
X      (let* ((opt (point))
X         (info (calc-embedded-make-info (point) nil t))
X         (pt (- opt (aref info 4))))
X    (or (eq (car-safe (aref info 8)) 'error)
X        (progn
X          (save-excursion
X        (calc-embedded-update info 14 'eval t))
X          (goto-char (+ (aref info 4) pt)))))))
)
X
X
(defun calc-embedded-edit (arg)
X  (interactive "P")
X  (let ((info (calc-embedded-make-info (point) nil t arg))
X    str)
X    (if (eq (car-safe (aref info 8)) 'error)
X    (progn
X      (goto-char (nth 1 (aref info 8)))
X      (error (nth 2 (aref info 8)))))
X    (calc-wrapper
X     (setq str (math-showing-full-precision
X        (math-format-nice-expr (aref info 8) (screen-width))))
X     (calc-edit-mode (list 'calc-embedded-finish-edit info))
X     (insert str "\n")))
X  (calc-show-edit-buffer)
)
X
(defun calc-embedded-finish-edit (info)
X  (let ((buf (current-buffer))
X    (str (buffer-substring (point) (point-max)))
X    (start (point))
X    pos)
X    (switch-to-buffer calc-original-buffer)
X    (let ((val (save-excursion
X         (set-buffer (aref info 1))
X         (let ((calc-language nil)
X               (math-expr-opers math-standard-opers))
X           (math-read-expr str)))))
X      (if (eq (car-safe val) 'error)
X      (progn
X        (switch-to-buffer buf)
X        (goto-char (+ start (nth 1 val)))
X        (error (nth 2 val))))
X      (calc-embedded-original-buffer t info)
X      (aset info 8 val)
X      (calc-embedded-update info 14 t t)))
)
X
(defun calc-do-embedded-activate (arg cbuf)
X  (calc-plain-buffer-only)
X  (if arg
X      (calc-embedded-forget))
X  (calc-find-globals)
X  (if (< (prefix-numeric-value arg) 0)
X      (message "Deactivating %s for Calc Embedded mode." (buffer-name))
X    (message "Activating %s for Calc Embedded mode..." (buffer-name))
X    (save-excursion
X      (let* ((active (assq (current-buffer) calc-embedded-active))
X         (info active)
X         (pat " := \\| \\\\gets \\| => \\| \\\\evalto "))
X    (if calc-embedded-announce-formula
X        (setq pat (format "%s\\|\\(%s\\)"
X                  pat calc-embedded-announce-formula)))
X    (while (setq info (cdr info))
X      (or (equal (buffer-substring (aref (car info) 2) (aref (car info) 3))
X             (aref (car info) 6))
X          (setcdr active (delq (car info) (cdr active)))))
X    (goto-char (point-min))
X    (while (re-search-forward pat nil t)
X      (if (looking-at calc-embedded-open-formula)
X          (goto-char (match-end 1)))
X      (setq info (calc-embedded-make-info (point) cbuf nil))
X      (or (eq (car-safe (aref info 8)) 'error)
X          (goto-char (aref info 5))))))
X    (message "Activating %s for Calc Embedded mode...done" (buffer-name)))
X  (calc-embedded-active-state t)
)
X
(defun calc-plain-buffer-only ()
X  (if (memq major-mode '(calc-mode calc-trail-mode calc-edit-mode))
X      (error "This command should be used in a normal editing buffer"))
)
X
(defun calc-embedded-active-state (state)
X  (or (assq 'calc-embedded-all-active minor-mode-alist)
X      (setq minor-mode-alist
X        (cons '(calc-embedded-all-active " Active")
X          (cons '(calc-embedded-some-active " ~Active")
X            minor-mode-alist))))
X  (let ((active (assq (current-buffer) calc-embedded-active)))
X    (or (cdr active)
X    (setq state nil)))
X  (and (eq state 'more) calc-embedded-all-active (setq state t))
X  (setq calc-embedded-all-active (eq state t)
X    calc-embedded-some-active (not (memq state '(nil t))))
X  (set-buffer-modified-p (buffer-modified-p))
)
X
X
(defun calc-embedded-original-buffer (switch &optional info)
X  (or info (setq info calc-embedded-info))
X  (or (buffer-name (aref info 0))
X      (progn
X    (error "Calc embedded mode: Original buffer has been killed")))
X  (if switch
X      (set-buffer (aref info 0)))
)
X
(defun calc-embedded-word ()
X  (interactive)
X  (calc-embedded '(4))
)
X
(defun calc-embedded-mark-formula (&optional body-only)
X  "Put point at the beginning of this Calc formula, mark at the end.
This normally marks the whole formula, including surrounding delimiters.
With any prefix argument, marks only the formula itself."
X  (interactive "P")
X  (and (eq major-mode 'calc-mode)
X       (error "This command should be used in a normal editing buffer"))
X  (let (top bot outer-top outer-bot)
X    (save-excursion
X      (calc-embedded-find-bounds body-only))
X    (push-mark (if body-only bot outer-bot) t)
X    (goto-char (if body-only top outer-top)))
)
X
(defun calc-embedded-find-bounds (&optional plain)
X  ;; (while (and (bolp) (eq (following-char) ?\n))
X  ;;  (forward-char 1))
X  (and (eolp) (bolp) (not (eq (char-after (- (point) 2)) ?\n))
X       (forward-char -1))
X  (let ((home (point)))
X    (or (and (looking-at calc-embedded-open-formula)
X         (not (looking-at calc-embedded-close-formula)))
X    (re-search-backward calc-embedded-open-formula nil t)
X    (error "Can't find start of formula"))
X    (and (eq (preceding-char) ?\$)  ; backward search for \$\$? won't back
X     (eq (following-char) ?\$)  ; up over a second $, so do it by hand.
X     (forward-char -1))
X    (setq outer-top (point))
X    (goto-char (match-end 0))
X    (if (eq (following-char) ?\n)
X    (forward-char 1))
X    (or (bolp)
X    (while (eq (following-char) ?\ )
X      (forward-char 1)))
X    (or (eq plain 'plain)
X    (if (looking-at (regexp-quote calc-embedded-open-plain))
X        (progn
X          (goto-char (match-end 0))
X          (search-forward calc-embedded-close-plain))))
X    (setq top (point))
X    (or (re-search-forward calc-embedded-close-formula nil t)
X    (error "Can't find end of formula"))
X    (if (< (point) home)
X    (error "Not inside a formula"))
X    (and (eq (following-char) ?\n) (not (bolp))
X     (forward-char 1))
X    (setq outer-bot (point))
X    (goto-char (match-beginning 0))
X    (if (eq (preceding-char) ?\n)
X    (backward-char 1))
X    (or (eolp)
X    (while (eq (preceding-char) ?\ )
X      (backward-char 1)))
X    (setq bot (point)))
)
X
(defun calc-embedded-kill-formula ()
X  "Kill the formula surrounding point.
If Calc Embedded mode was active, this deactivates it.
The formula (including its surrounding delimiters) is saved in the kill ring.
The command \\[yank] can retrieve it from there."
X  (interactive)
X  (and calc-embedded-info
X       (calc-embedded nil))
X  (calc-embedded-mark-formula)
X  (kill-region (point) (mark))
X  (pop-mark)
)
X
(defun calc-embedded-copy-formula-as-kill ()
X  "Save the formula surrounding point as if killed, but don't kill it."
X  (interactive)
X  (save-excursion
X    (calc-embedded-mark-formula)
X    (copy-region-as-kill (point) (mark))
X    (pop-mark))
)
X
(defun calc-embedded-duplicate ()
X  (interactive)
X  (let ((already calc-embedded-info)
X    top bot outer-top outer-bot new-top)
X    (if calc-embedded-info
X    (progn
X      (setq top (+ (aref calc-embedded-info 2))
X        bot (+ (aref calc-embedded-info 3))
X        outer-top (+ (aref calc-embedded-info 4))
X        outer-bot (+ (aref calc-embedded-info 5)))
X      (calc-embedded nil))
X      (calc-embedded-find-bounds))
X    (goto-char outer-bot)
X    (insert "\n")
X    (setq new-top (point))
X    (insert-buffer-substring (current-buffer) outer-top outer-bot)
X    (goto-char (+ new-top (- top outer-top)))
X    (let ((calc-embedded-quiet (if already t 'x)))
X      (calc-embedded (+ new-top (- top outer-top))
X             (+ new-top (- bot outer-top))
X             new-top
X             (+ new-top (- outer-bot outer-top)))))
)
X
(defun calc-embedded-next (arg)
X  (interactive "P")
X  (setq arg (prefix-numeric-value arg))
X  (let* ((active (cdr (assq (current-buffer) calc-embedded-active)))
X     (p active)
X     (num (length active)))
X    (or active
X    (error "No active formulas in buffer"))
X    (cond ((= arg 0))
X      ((= arg -1)
X       (if (<= (point) (aref (car active) 3))
X           (goto-char (aref (nth (1- num) active) 2))
X         (while (and (cdr p)
X             (> (point) (aref (nth 1 p) 3)))
X           (setq p (cdr p)))
X         (goto-char (aref (car p) 2))))
X      ((< arg -1)
X       (calc-embedded-next -1)
X       (calc-embedded-next (+ (* num 1000) arg 1)))
X      (t
X       (setq arg (1+ (% (1- arg) num)))
X       (while (and p (>= (point) (aref (car p) 2)))
X         (setq p (cdr p)))
X       (while (> (setq arg (1- arg)) 0)
X         (setq p (if p (cdr p) (cdr active))))
X       (goto-char (aref (car (or p active)) 2)))))
)
X
(defun calc-embedded-previous (arg)
X  (interactive "p")
X  (calc-embedded-next (- (prefix-numeric-value arg)))
)
X
(defun calc-embedded-new-formula ()
X  (interactive)
X  (and (eq major-mode 'calc-mode)
X       (error "This command should be used in a normal editing buffer"))
X  (if calc-embedded-info
X      (calc-embedded nil))
X  (let (top bot outer-top outer-bot)
X    (if (and (eq (preceding-char) ?\n)
X         (string-match "\\`\n" calc-embedded-open-new-formula))
X    (progn
X      (setq outer-top (1- (point)))
X      (forward-char -1)
X      (insert (substring calc-embedded-open-new-formula 1)))
X      (setq outer-top (point))
X      (insert calc-embedded-open-new-formula))
X    (setq top (point))
X    (insert " ")
X    (setq bot (point))
X    (insert calc-embedded-close-new-formula)
X    (if (and (eq (following-char) ?\n)
X         (string-match "\n\\'" calc-embedded-close-new-formula))
X    (delete-char 1))
X    (setq outer-bot (point))
X    (goto-char top)
X    (let ((calc-embedded-quiet 'x))
X      (calc-embedded top bot outer-top outer-bot)))
)
X
(defun calc-embedded-forget ()
X  (interactive)
X  (setq calc-embedded-active (delq (assq (current-buffer) calc-embedded-active)
X                   calc-embedded-active))
X  (calc-embedded-active-state nil)
)
X
X
(defun calc-embedded-set-modes (gmodes modes local-modes &optional temp)
X  (let ((the-language (calc-embedded-language))
X    (the-display-just (calc-embedded-justify))
X    (v gmodes)
X    (changed nil)
X    found value)
X    (while v
X      (or (symbolp (car v))
X      (and (setq found (assq (car (car v)) modes))
X           (not (eq (cdr found) 'default)))
X      (and (setq found (assq (car (car v)) local-modes))
X           (not (eq (cdr found) 'default)))
X      (progn
X        (if (eq (setq value (cdr (car v))) 'default)
X        (setq value (cdr (assq (car (car v)) calc-mode-var-list))))
X        (equal (symbol-value (car (car v))) value))
X      (progn
X        (setq changed t)
X        (if temp (setq prev-modes (cons (cons (car (car v))
X                          (symbol-value (car (car v))))
X                        prev-modes)))
X        (set (car (car v)) value)))
X      (setq v (cdr v)))
X    (setq v modes)
X    (while v
X      (or (and (setq found (assq (car (car v)) local-modes))
X           (not (eq (cdr found) 'default)))
X      (eq (setq value (cdr (car v))) 'default)
X      (equal (symbol-value (car (car v))) value)
X      (progn
X        (setq changed t)
X        (if temp (setq prev-modes (cons (cons (car (car v))
X                          (symbol-value (car (car v))))
X                        prev-modes)))
X        (set (car (car v)) value)))
X      (setq v (cdr v)))
X    (setq v local-modes)
X    (while v
X      (or (eq (setq value (cdr (car v))) 'default)
X      (equal (symbol-value (car (car v))) value)
X      (progn
X        (setq changed t)
X        (if temp (setq prev-modes (cons (cons (car (car v))
X                          (symbol-value (car (car v))))
X                        prev-modes)))
X        (set (car (car v)) value)))
X      (setq v (cdr v)))
X    (and changed (not (eq temp t))
X     (progn
X       (calc-embedded-set-justify the-display-just)
X       (calc-embedded-set-language the-language)))
X    (and changed (not temp)
X     (progn
X       (setq calc-full-float-format (list (if (eq (car calc-float-format)
X                              'fix)
X                          'float
X                        (car calc-float-format))
X                          0))
X       (calc-refresh)))
X    changed)
)
X
(defun calc-embedded-language ()
X  (if calc-language-option
X      (list calc-language calc-language-option)
X    calc-language)
)
X
(defun calc-embedded-set-language (lang)
X  (let ((option nil))
X    (if (consp lang)
X    (setq option (nth 1 lang)
X          lang (car lang)))
X    (or (and (eq lang calc-language)
X         (equal option calc-language-option))
X    (calc-set-language lang option t)))
)
X
(defun calc-embedded-justify ()
X  (if calc-display-origin
X      (list calc-display-just calc-display-origin)
X    calc-display-just)
)
X
(defun calc-embedded-set-justify (just)
X  (if (consp just)
X      (setq calc-display-origin (nth 1 just)
X        calc-display-just (car just))
X    (setq calc-display-just just
X      calc-display-origin nil))
)
X
X
(defun calc-find-globals ()
X  (interactive)
X  (and (eq major-mode 'calc-mode)
X       (error "This command should be used in a normal editing buffer"))
X  (make-local-variable 'calc-embedded-globals)
X  (let ((case-fold-search nil)
X    (modes nil)
X    (save-pt (point))
X    found value)
X    (goto-char (point-min))
X    (while (re-search-forward "\\[calc-global-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)\\]" nil t)
X      (and (setq found (assoc (buffer-substring (match-beginning 1)
X                        (match-end 1))
X                  calc-embedded-mode-vars))
X       (or (assq (cdr found) modes)
X           (setq modes (cons (cons (cdr found)
X                       (car (read-from-string
X                         (buffer-substring
X                          (match-beginning 2)
X                          (match-end 2)))))
X                 modes)))))
X    (setq calc-embedded-globals (cons t modes))
X    (goto-char save-pt))
)
X
(defun calc-embedded-find-modes ()
X  (let ((case-fold-search nil)
X    (save-pt (point))
X    (no-defaults t)
X    (modes nil)
X    (emodes nil)
X    (pmodes nil)
X    found value)
X    (while (and no-defaults (search-backward "[calc-" nil t))
X      (forward-char 6)
X      (or (and (looking-at "mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]")
X           (setq found (assoc (buffer-substring (match-beginning 1)
X                            (match-end 1))
X                  calc-embedded-mode-vars))
X           (or (assq (cdr found) modes)
X           (setq modes (cons (cons (cdr found)
X                       (car (read-from-string
X                         (buffer-substring
X                          (match-beginning 2)
X                          (match-end 2)))))
X                     modes))))
X      (and (looking-at "perm-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]")
X           (setq found (assoc (buffer-substring (match-beginning 1)
X                            (match-end 1))
X                  calc-embedded-mode-vars))
X           (or (assq (cdr found) pmodes)
X           (setq pmodes (cons (cons (cdr found)
X                        (car (read-from-string
X                          (buffer-substring
X                           (match-beginning 2)
X                           (match-end 2)))))
X                      pmodes))))
X      (and (looking-at "edit-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]")
X           (setq found (assoc (buffer-substring (match-beginning 1)
X                            (match-end 1))
X                  calc-embedded-mode-vars))
X           (or (assq (cdr found) emodes)
X           (setq emodes (cons (cons (cdr found)
X                        (car (read-from-string
X                          (buffer-substring
X                           (match-beginning 2)
X                           (match-end 2)))))
X                      emodes))))
X      (and (looking-at "defaults]")
X           (setq no-defaults nil)))
X      (backward-char 6))
X    (goto-char save-pt)
X    (list modes emodes pmodes))
)
X
X
(defun calc-embedded-make-info (point cbuf fresh &optional
X                      top bot outer-top outer-bot)
X  (let* ((bufentry (assq (current-buffer) calc-embedded-active))
X     (found bufentry)
X     (force (and fresh top))
X     (fixed top)
X     (new-info nil)
X     info str)
X    (or found
X    (setq found (list (current-buffer))
X          calc-embedded-active (cons found calc-embedded-active)))
X    (while (and (cdr found)
X        (> point (aref (car (cdr found)) 3)))
X      (setq found (cdr found)))
X    (if (and (cdr found)
X         (>= point (aref (nth 1 found) 2)))
X    (setq info (nth 1 found))
X      (setq info (make-vector 16 nil)
X        new-info t
X        fresh t)
X      (aset info 0 (current-buffer))
X      (aset info 1 (or cbuf (save-excursion
X                  (calc-create-buffer)
X                  (current-buffer)))))
X    (if (and (integerp top) (not bot))  ; started with a user-supplied argument
X    (progn
X      (if (= (setq arg (prefix-numeric-value arg)) 0)
X          (progn
X        (aset info 2 (copy-marker (region-beginning)))
X        (aset info 3 (copy-marker (region-end))))
X        (aset info (if (> arg 0) 2 3) (point-marker))
X        (forward-line arg)
X        (aset info (if (> arg 0) 3 2) (point-marker)))
X      (aset info 4 (copy-marker (aref info 2)))
X      (aset info 5 (copy-marker (aref info 3))))
X      (if (aref info 4)
X      (setq top (aref info 2)
X        fixed top)
X    (if (consp top)
X        (let ((calc-embedded-open-formula calc-embedded-open-word)
X          (calc-embedded-close-formula calc-embedded-close-word))
X          (calc-embedded-find-bounds 'plain))
X      (or top
X          (calc-embedded-find-bounds 'plain)))
X    (aset info 2 (copy-marker (min top bot)))
X    (aset info 3 (copy-marker (max top bot)))
X    (aset info 4 (copy-marker (or outer-top (aref info 2))))
X    (aset info 5 (copy-marker (or outer-bot (aref info 3))))))
X    (goto-char (aref info 2))
X    (if new-info
X    (progn
X      (or (bolp) (aset info 7 t))
X      (goto-char (aref info 3))
X      (or (bolp) (eolp) (aset info 7 t))))
X    (if fresh
X    (let ((modes (calc-embedded-find-modes)))
X      (aset info 12 (car modes))
X      (aset info 13 (nth 1 modes))
X      (aset info 14 (nth 2 modes))))
X    (aset info 15 calc-embedded-globals)
X    (setq str (buffer-substring (aref info 2) (aref info 3)))
X    (if (or force
X        (not (equal str (aref info 6))))
X    (if (and fixed (aref info 6))
X        (progn
X          (aset info 4 nil)
X          (calc-embedded-make-info point cbuf nil)
X          (setq new-info nil))
X      (let* ((open-plain calc-embedded-open-plain)
X         (close-plain calc-embedded-close-plain)
X         (pref-len (length open-plain))
X         (vars-used nil)
X         suff-pos val temp)
X        (save-excursion
X          (set-buffer (aref info 1))
X          (calc-embedded-set-modes (aref info 15)
X                       (aref info 12) (aref info 14))
X          (if (and (> (length str) pref-len)
X               (equal (substring str 0 pref-len) open-plain)
X               (setq suff-pos (string-match (regexp-quote close-plain)
X                            str pref-len)))
X          (setq val (math-read-plain-expr
X                 (substring str pref-len suff-pos)))
X        (if (string-match "[^ \t\n]" str)
X            (setq pref-len 0
X              val (math-read-big-expr str))
X          (setq val nil))))
X        (if (eq (car-safe val) 'error)
X        (setq val (list 'error
X                (+ (aref info 2) pref-len (nth 1 val))
X                (nth 2 val))))
X        (aset info 6 str)
X        (aset info 8 val)
X        (setq temp val)
X        (if (eq (car-safe temp) 'calcFunc-evalto)
X        (setq temp (nth 1 temp))
X          (if (eq (car-safe temp) 'error)
X          (if new-info
X              (setq new-info nil)
X            (setcdr found (delq info (cdr found)))
X            (calc-embedded-active-state 'less))))
X        (aset info 9 (and (eq (car-safe temp) 'calcFunc-assign)
X                  (nth 1 temp)))
X        (if (memq (car-safe val) '(calcFunc-evalto calcFunc-assign))
X        (calc-embedded-find-vars val))
X        (aset info 10 vars-used)
X        (aset info 11 nil))))
X    (if new-info
X    (progn
X      (setcdr found (cons info (cdr found)))
X      (calc-embedded-active-state 'more)))
X    info)
)
X
(defun calc-embedded-find-vars (x)
X  (cond ((Math-primp x)
X     (and (eq (car-safe x) 'var)
X          (not (assoc x vars-used))
X          (setq vars-used (cons (list x) vars-used))))
X    ((eq (car x) 'calcFunc-evalto)
X     (calc-embedded-find-vars (nth 1 x)))
X    ((eq (car x) 'calcFunc-assign)
X     (calc-embedded-find-vars (nth 2 x)))
X    (t
X     (and (eq (car x) 'calcFunc-subscr)
X          (eq (car-safe (nth 1 x)) 'var)
X          (Math-primp (nth 2 x))
X          (not (assoc x vars-used))
X          (setq vars-used (cons (list x) vars-used)))
X     (while (setq x (cdr x))
X       (calc-embedded-find-vars (car x)))))
)
X
X
(defun calc-embedded-evaluate-expr (x)
X  (let ((vars-used (aref calc-embedded-info 10)))
X    (or vars-used (calc-embedded-find-vars x))
X    (if vars-used
X    (let ((active (assq (aref calc-embedded-info 0) calc-embedded-active))
X          (args nil))
X      (save-excursion
X        (calc-embedded-original-buffer t)
X        (or active
X        (progn
X          (calc-embedded-activate)
X          (setq active (assq (aref calc-embedded-info 0)
X                     calc-embedded-active))))
X        (while vars-used
X          (calc-embedded-eval-get-var (car (car vars-used)) active)
X          (setq vars-used (cdr vars-used))))
X      (calc-embedded-subst x))
X      (calc-normalize (math-evaluate-expr-rec x))))
)
X
(defun calc-embedded-subst (x)
X  (if (and (eq (car-safe x) 'calcFunc-evalto) (cdr x))
X      (let ((rhs (calc-embedded-subst (nth 1 x))))
X    (list 'calcFunc-evalto
X          (nth 1 x)
X          (if (eq (car-safe rhs) 'calcFunc-assign) (nth 2 rhs) rhs)))
X    (if (and (eq (car-safe x) 'calcFunc-assign) (= (length x) 3))
X    (list 'calcFunc-assign
X          (nth 1 x)
X          (calc-embedded-subst (nth 2 x)))
X      (calc-normalize (math-evaluate-expr-rec (math-multi-subst-rec x)))))
)
X
(defun calc-embedded-eval-get-var (var base)
X  (let ((entry base)
X    (point (aref calc-embedded-info 2))
X    (last nil)
X    val)
X    (while (and (setq entry (cdr entry))
X        (or (not (equal var (aref (car entry) 9)))
X            (and (> point (aref (car entry) 3))
X             (setq last entry)))))
X    (if last
X    (setq entry last))
X    (if entry
X    (progn
X      (setq entry (car entry))
X      (if (equal (buffer-substring (aref entry 2) (aref entry 3))
X             (aref entry 6))
X          (progn
X        (or (aref entry 11)
X            (save-excursion
X              (calc-embedded-update entry 14 t nil)))
X        (setq val (aref entry 11))
X        (if (eq (car-safe val) 'calcFunc-evalto)
X            (setq val (nth 2 val)))
X        (if (eq (car-safe val) 'calcFunc-assign)
X            (setq val (nth 2 val)))
X        (setq args (cons (cons var val) args)))
X        (calc-embedded-activate)
X        (calc-embedded-eval-get-var var base)))))
)
X
X
(defun calc-embedded-update (info which need-eval need-display
X                  &optional str entry old-val)
X  (let* ((prev-modes nil)
X     (open-plain calc-embedded-open-plain)
X     (close-plain calc-embedded-close-plain)
X     (vars-used nil)
X     (evalled nil)
X     (val (aref info 8))
X     (old-eval (aref info 11)))
X    (or old-val (setq old-val val))
X    (if (eq (car-safe val) 'calcFunc-evalto)
X    (setq need-display t))
X    (unwind-protect
X    (progn
X      (set-buffer (aref info 1))
X      (and which
X           (calc-embedded-set-modes (aref info 15) (aref info 12)
X                    (aref info which)
X                    (if need-display 'full t)))
X      (if (memq (car-safe val) '(calcFunc-evalto calcFunc-assign))
X          (calc-embedded-find-vars val))
X      (if need-eval
X          (let ((calc-embedded-info info))
X        (setq val (math-evaluate-expr val)
X              evalled val)))
X      (if (or (eq need-eval 'eval) (eq (car-safe val) 'calcFunc-evalto))
X          (aset info 8 val))
X      (aset info 9 nil)
X      (aset info 10 vars-used)
X      (aset info 11 nil)
X      (if (or need-display (eq (car-safe val) 'calcFunc-evalto))
X          (let ((extra (if (eq calc-language 'big) 1 0)))
X        (or entry (setq entry (list val 1 nil)))
X        (or str (progn
X              (setq str (let ((calc-line-numbering nil))
X                      (math-format-stack-value entry)))
X              (if (eq calc-language 'big)
X                  (setq str (substring str 0 -1)))))
X        (and calc-show-plain
X             (setq str (concat open-plain
X                       (math-showing-full-precision
X                    (math-format-flat-expr val 0))
X                       close-plain
X                       str)))
X        (save-excursion
X          (calc-embedded-original-buffer t info)
X          (or (equal str (aref info 6))
X              (let ((delta (- (aref info 5) (aref info 3)))
X                (buffer-read-only nil))
X            (goto-char (aref info 2))
X            (delete-region (point) (aref info 3))
X            (and (> (nth 1 entry) (1+ extra))
X                 (aref info 7)
X                 (progn
X                   (aset info 7 nil)
X                   (delete-horizontal-space)
X                   (insert "\n\n")
X                   (delete-horizontal-space)
X                   (backward-char 1)))
X            (insert str)
X            (set-marker (aref info 3) (point))
X            (set-marker (aref info 5) (+ (point) delta))
X            (aset info 6 str))))))
X      (if (eq (car-safe val) 'calcFunc-evalto)
X          (progn
X        (setq evalled (nth 2 val)
X              val (nth 1 val))))
X      (if (eq (car-safe val) 'calcFunc-assign)
X          (progn
X        (aset info 9 (nth 1 val))
X        (aset info 11 (or evalled
X                  (let ((calc-embedded-info info))
X                    (math-evaluate-expr (nth 2 val)))))
X        (or (equal old-eval (aref info 11))
X            (calc-embedded-var-change (nth 1 val) (aref info 0))))
X        (if (eq (car-safe old-val) 'calcFunc-evalto)
X        (setq old-val (nth 1 old-val)))
X        (if (eq (car-safe old-val) 'calcFunc-assign)
X        (calc-embedded-var-change (nth 1 old-val) (aref info 0)))))
X      (set-buffer (aref info 1))
X      (while prev-modes
X    (cond ((eq (car (car prev-modes)) 'the-language)
X           (if need-display
X           (calc-embedded-set-language (cdr (car prev-modes)))))
X          ((eq (car (car prev-modes)) 'the-display-just)
X           (if need-display
X           (calc-embedded-set-justify (cdr (car prev-modes)))))
X          (t
X           (set (car (car prev-modes)) (cdr (car prev-modes)))))
X    (setq prev-modes (cdr prev-modes)))))
)
X
X
X
X
;;; These are hooks called by the main part of Calc.
X
(defun calc-embedded-select-buffer ()
X  (if (eq (current-buffer) (aref calc-embedded-info 0))
X      (let ((info calc-embedded-info)
X        horiz vert)
X    (if (and (or (< (point) (aref info 4))
X             (> (point) (aref info 5)))
X         (not calc-embedded-no-reselect))
X        (let ((calc-embedded-quiet t))
X          (message "(Switching Calc Embedded mode to new formula.)")
X          (calc-embedded nil)
X          (calc-embedded nil)))
X    (setq horiz (max (min (current-column) (- (point) (aref info 2))) 0)
X          vert (if (<= (aref info 2) (point))
X               (- (count-lines (aref info 2) (point))
X              (if (bolp) 0 1))
X             0))
X    (set-buffer (aref info 1))
X    (if calc-show-plain
X        (if (= vert 0)
X        (setq horiz 0)
X          (setq vert (1- vert))))
X    (calc-cursor-stack-index 1)
X    (if calc-line-numbering
X        (setq horiz (+ horiz 4)))
X    (if (> vert 0)
X        (forward-line vert))
X    (forward-char (min horiz
X               (- (point-max) (point)))))
X    (calc-select-buffer))
)
(setq calc-embedded-no-reselect nil)
X
(defun calc-embedded-finish-command ()
X  (let ((buf (current-buffer))
X    horiz vert)
X    (save-excursion
X      (set-buffer (aref calc-embedded-info 1))
X      (if (> (calc-stack-size) 0)
X      (let ((pt (point))
X        (col (current-column))
X        (bol (bolp)))
X        (calc-cursor-stack-index 0)
X        (if (< pt (point))
X        (progn
X          (calc-cursor-stack-index 1)
X          (if (>= pt (point))
X              (progn
X            (setq horiz (- col (if calc-line-numbering 4 0))
X                  vert (- (count-lines (point) pt)
X                      (if bol 0 1)))
X            (if calc-show-plain
X                (setq vert (max 1 (1+ vert))))))))
X        (goto-char pt))))
X    (if horiz
X    (progn
X      (set-buffer (aref calc-embedded-info 0))
X      (goto-char (aref calc-embedded-info 2))
X      (if (> vert 0)
X          (forward-line vert))
X      (forward-char (max horiz 0))
X      (set-buffer buf))))
)
X
(defun calc-embedded-stack-change ()
X  (or calc-executing-macro
X      (save-excursion
X    (set-buffer (aref calc-embedded-info 1))
X    (let* ((info calc-embedded-info)
X           (extra-line (if (eq calc-language 'big) 1 0))
X           (the-point (point))
X           (empty (= (calc-stack-size) 0))
X           (entry (if empty
X              (list '(var empty var-empty) 1 nil)
X            (calc-top 1 'entry)))
X           (old-val (aref info 8))
X           top bot str)
X      (if empty
X          (setq str "empty")
X        (save-excursion
X          (calc-cursor-stack-index 1)
X          (setq top (point))
X          (calc-cursor-stack-index 0)
X          (setq bot (- (point) extra-line))
X          (setq str (buffer-substring top (- bot 1))))
X        (if calc-line-numbering
X        (let ((pos 0))
X          (setq str (substring str 4))
X          (while (setq pos (string-match "\n...." str pos))
X            (setq str (concat (substring str 0 (1+ pos))
X                      (substring str (+ pos 5)))
X              pos (1+ pos))))))
X      (calc-embedded-original-buffer t)
X      (aset info 8 (car entry))
X      (calc-embedded-update info 13 nil t str entry old-val))))
)
X
(defun calc-embedded-mode-line-change ()
X  (let ((str mode-line-buffer-identification))
X    (save-excursion
X      (calc-embedded-original-buffer t)
X      (setq mode-line-buffer-identification str)
X      (set-buffer-modified-p (buffer-modified-p))))
)
X
(defun calc-embedded-modes-change (vars)
X  (if (eq (car vars) 'calc-language) (setq vars '(the-language)))
X  (if (eq (car vars) 'calc-display-just) (setq vars '(the-display-just)))
X  (while (and vars
X          (not (rassq (car vars) calc-embedded-mode-vars)))
X    (setq vars (cdr vars)))
X  (if (and vars calc-mode-save-mode (not (eq calc-mode-save-mode 'save)))
X      (save-excursion
X    (let* ((save-mode calc-mode-save-mode)
X           (header (if (eq save-mode 'local)
X               "calc-mode:"
X             (format "calc-%s-mode:" save-mode)))
X           (the-language (calc-embedded-language))
X           (the-display-just (calc-embedded-justify))
X           (values (mapcar 'symbol-value vars))
X           (num (cond ((eq save-mode 'local) 12)
X              ((eq save-mode 'edit) 13)
X              ((eq save-mode 'perm) 14)
X              (t nil)))
X           base limit mname mlist)
X      (calc-embedded-original-buffer t)
X      (save-excursion
X        (if (eq save-mode 'global)
X        (setq base (point-max)
X              limit (point-min)
X              mlist calc-embedded-globals)
X          (goto-char (aref calc-embedded-info 4))
X          (beginning-of-line)
X          (setq base (point)
X            limit (max (- (point) 1000) (point-min))
X            mlist (and num (aref calc-embedded-info num)))
X          (and (re-search-backward
X            (format "\\(%s\\)[^\001]*\\(%s\\)\\|\\[calc-defaults]"
X                calc-embedded-open-formula
X                calc-embedded-close-formula) limit t)
X           (setq limit (point))))
X        (while vars
X          (goto-char base)
X          (if (setq mname (car (rassq (car vars)
X                      calc-embedded-mode-vars)))
X          (let ((buffer-read-only nil)
X            (found (assq (car vars) mlist)))
X            (if found
X            (setcdr found (car values))
X              (setq mlist (cons (cons (car vars) (car values)) mlist))
X              (if num
X              (aset calc-embedded-info num mlist)
X            (if (eq save-mode 'global)
X                (setq calc-embedded-globals mlist))))
X            (if (re-search-backward
X             (format "\\[%s *%s: *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]"
X                 header mname)
X             limit t)
X            (progn
X              (goto-char (match-beginning 1))
X              (delete-region (point) (match-end 1))
X              (insert (prin1-to-string (car values))))
SHAR_EOF
true || echo 'restore of calc-embed.el failed'
fi
echo 'End of  part 12'
echo 'File calc-embed.el is continued in part 13'
echo 13 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].