-;; Calculator for GNU Emacs, part II [calc-comp.el]
-;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
-;; Written by Dave Gillespie, daveg@synaptics.com.
+;;; calccomp.el --- composition functions for Calc
+
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
+
+;; Author: David Gillespie <daveg@synaptics.com>
+;; Maintainers: D. Goel <deego@gnufans.org>
+;; Colin Walters <walters@debian.org>
;; This file is part of GNU Emacs.
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
+;;; Commentary:
+;;; Code:
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
(defun calc-Need-calc-comp () nil)
+(defconst math-eqn-special-funcs
+ '( calcFunc-log
+ calcFunc-ln calcFunc-exp
+ calcFunc-sin calcFunc-cos calcFunc-tan
+ calcFunc-sinh calcFunc-cosh calcFunc-tanh
+ calcFunc-arcsin calcFunc-arccos calcFunc-arctan
+ calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh))
;;; A "composition" has one of the following forms:
;;;
(if (eq calc-language 'eqn)
" , " ", ")
0)
- right))))))))
-)
-
-(defconst math-eqn-special-funcs
- '( calcFunc-log
- calcFunc-ln calcFunc-exp
- calcFunc-sin calcFunc-cos calcFunc-tan
- calcFunc-sinh calcFunc-cosh calcFunc-tanh
- calcFunc-arcsin calcFunc-arccos calcFunc-arctan
- calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
-))
+ right)))))))))
(defun math-prod-first-term (x)
(while (eq (car-safe x) '*)
(setq x (nth 1 x)))
- x
-)
+ x)
(defun math-prod-last-term (x)
(while (eq (car-safe x) '*)
(setq x (nth 2 x)))
- x
-)
+ x)
(defun math-compose-vector (a sep prec)
(if a
(cons (list 'break math-compose-level)
(cons sep c)))))
(nreverse c))))
- "")
-)
+ ""))
(defun math-vector-no-parens (a)
(or (cdr (cdr a))
- (not (eq (car-safe (nth 1 a)) '*)))
-)
+ (not (eq (car-safe (nth 1 a)) '*))))
(defun math-compose-matrix (a col cols base)
(let ((col 0)
(concat comma-spc " ")))))
a)))
res)))
- (nreverse res))
-)
+ (nreverse res)))
(defun math-compose-rows (a count first)
(if (cdr a)
(list (list 'horiz
(if first (concat left-bracket " ") " ")
(math-compose-expr (car a) vector-prec)
- (concat " " right-bracket))))
-)
+ (concat " " right-bracket)))))
(defun math-compose-tex-matrix (a)
(if (cdr a)
(cons (math-compose-vector (cdr (car a)) " & " 0)
(cons " \\\\ "
(math-compose-tex-matrix (cdr a))))
- (list (math-compose-vector (cdr (car a)) " & " 0)))
-)
+ (list (math-compose-vector (cdr (car a)) " & " 0))))
(defun math-compose-eqn-matrix (a)
(if a
(cons
" } "
(math-compose-eqn-matrix (cdr a)))))))
- nil)
-)
+ nil))
(defun math-vector-is-string (a)
(while (and (setq a (cdr a))
(natnump (nth 1 (car a)))
(eq (nth 2 (car a)) 0)
(<= (nth 1 (car a)) 255)))))
- (null a)
-)
+ (null a))
+
+(defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
+ ( ?\\ . "\\\\" )
+ ( ?\a . "\\a" )
+ ( ?\b . "\\b" )
+ ( ?\e . "\\e" )
+ ( ?\f . "\\f" )
+ ( ?\n . "\\n" )
+ ( ?\r . "\\r" )
+ ( ?\t . "\\t" )
+ ( ?\^? . "\\^?" )))
(defun math-vector-to-string (a &optional quoted)
(setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
p (+ p 2))))))
(if quoted
(concat "\"" a "\"")
- a)
-)
-(defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
- ( ?\\ . "\\\\" )
- ( ?\a . "\\a" )
- ( ?\b . "\\b" )
- ( ?\e . "\\e" )
- ( ?\f . "\\f" )
- ( ?\n . "\\n" )
- ( ?\r . "\\r" )
- ( ?\t . "\\t" )
- ( ?\^? . "\\^?" )
-))
+ a))
+
(defun math-to-underscores (x)
(if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
(math-to-underscores
(concat (math-match-substring x 1) "_" (math-match-substring x 2)))
- x)
-)
+ x))
(defun math-tex-expr-is-flat (a)
(or (Math-integerp a)
(math-tex-expr-is-flat (car a))))
(null a)))
(and (memq (car a) '(^ calcFunc-subscr))
- (math-tex-expr-is-flat (nth 1 a))))
-)
+ (math-tex-expr-is-flat (nth 1 a)))))
(put 'calcFunc-log 'math-compose-big 'math-compose-log)
(defun math-compose-log (a prec)
(math-compose-expr (nth 2 a) 1000)))
"("
(math-compose-expr (nth 1 a) 1000)
- ")"))
-)
+ ")")))
(put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
(defun math-compose-log10 (a prec)
(list 'subscr "log" "10")
"("
(math-compose-expr (nth 1 a) 1000)
- ")"))
-)
+ ")")))
(put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
(put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
(defun math-compose-deriv (a prec)
- (and (= (length a) 3)
- (math-compose-expr (list '/
- (list 'calcFunc-choriz
- (list 'vec
- '(calcFunc-string (vec ?d))
- (nth 1 a)))
- (list 'calcFunc-choriz
- (list 'vec
- '(calcFunc-string (vec ?d))
- (nth 2 a))))
- prec))
-)
+ (when (= (length a) 3)
+ (math-compose-expr (list '/
+ (list 'calcFunc-choriz
+ (list 'vec
+ '(calcFunc-string (vec ?d))
+ (nth 1 a)))
+ (list 'calcFunc-choriz
+ (list 'vec
+ '(calcFunc-string (vec ?d))
+ (nth 2 a))))
+ prec)))
(put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
(defun math-compose-sqrt (a prec)
- (and (= (length a) 2)
- (let* ((c (math-compose-expr (nth 1 a) 0))
- (a (math-comp-ascent c))
- (d (math-comp-descent c))
- (h (+ a d))
- (w (math-comp-width c)))
- (list 'vleft
- a
- (concat (if (= h 1) " " " ")
- (make-string (+ w 2) ?\_))
- (list 'horiz
- (if (= h 1)
- "V"
- (append (list 'vleft (1- a))
- (make-list (1- h) " |")
- '("\\|")))
- " "
- c))))
-)
+ (when (= (length a) 2)
+ (let* ((c (math-compose-expr (nth 1 a) 0))
+ (a (math-comp-ascent c))
+ (d (math-comp-descent c))
+ (h (+ a d))
+ (w (math-comp-width c)))
+ (list 'vleft
+ a
+ (concat (if (= h 1) " " " ")
+ (make-string (+ w 2) ?\_))
+ (list 'horiz
+ (if (= h 1)
+ "V"
+ (append (list 'vleft (1- a))
+ (make-list (1- h) " |")
+ '("\\|")))
+ " "
+ c)))))
(put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
(defun math-compose-choose (a prec)
(list 'vcent
(math-comp-height a1)
a1 " " a2)
- ")"))
-)
+ ")")))
(put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
(defun math-compose-integ (a prec)
(if over
""
(list 'horiz " d" var))
- (if parens ")" ""))))
-)
+ (if parens ")" "")))))
(put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
(defun math-compose-sum (a prec)
(if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
" " "")
expr
- (if (memq prec '(180 201)) ")" ""))))
-)
+ (if (memq prec '(180 201)) ")" "")))))
(put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
(defun math-compose-prod (a prec)
(if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
" " "")
expr
- (if (memq prec '(196 201)) ")" ""))))
-)
+ (if (memq prec '(196 201)) ")" "")))))
(defun math-stack-value-offset-fancy ()
(or (< off 0)
(and calc-display-origin
(> calc-line-breaking calc-display-origin)))
- (setq wid calc-line-breaking)))
-)
+ (setq wid calc-line-breaking))))
(if (math-comp-is-flat c)
(math-comp-to-string-flat c width)
(math-vert-comp-to-string
- (math-comp-simplify c width))))
-)
+ (math-comp-simplify c width)))))
+(defvar math-comp-buf-string (make-vector 10 ""))
+(defvar math-comp-buf-margin (make-vector 10 0))
+(defvar math-comp-buf-level (make-vector 10 0))
(defun math-comp-is-flat (c) ; check if c's height is 1.
(cond ((not (consp c)) t)
((memq (car c) '(set break)) t)
(math-comp-is-flat (nth 2 c))))
((eq (car c) 'tag)
(math-comp-is-flat (nth 2 c)))
- (t nil))
-)
+ (t nil)))
;;; Convert a one-line composition to a string. Break into multiple
(aset comp-buf (1+ k) ?\n)
(setq prefix " "))
(setq prefix "\n"))))
- (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))
+ (concat comp-buf prefix str)))))
(defun math-comp-to-string-flat-term (c)
(cond ((not (consp c))
(math-comp-to-string-flat-term (nth 2 c))))
(t (math-comp-to-string-flat-term (nth 2 c)))))
- (t (math-comp-to-string-flat-term (nth 2 c))))
-)
+ (t (math-comp-to-string-flat-term (nth 2 c)))))
(defun math-comp-highlight-string (s)
(setq s (copy-sequence s))
(while (>= (setq i (1- i)) 0)
(or (memq (aref s i) '(32 ?\n))
(aset s i (if calc-show-selections ?\. ?\#)))))
- s
-)
+ s)
(defun math-comp-sel-flat-term (c)
(cond ((not (consp c))
(setq math-comp-sel-tag c
math-comp-sel-cpos 1000000)))
(math-comp-sel-flat-term (nth 2 c))))
- (t (math-comp-sel-flat-term (nth 2 c))))
-)
+ (t (math-comp-sel-flat-term (nth 2 c)))))
;;; Simplify a composition to a canonical form consisting of
(comp-highlight (and math-comp-selected calc-show-selections))
(comp-tag nil))
(math-comp-simplify-term c)
- (cons 'vleft (cons comp-base comp-buf)))
-)
+ (cons 'vleft (cons comp-base comp-buf))))
(defun math-comp-add-string (s h v)
(and (> (length s) 0)
(make-string (- h (length (car str))) 32)
(if comp-highlight
(math-comp-highlight-string s)
- s)))))))
-)
+ s))))))))
(defun math-comp-add-string-sel (x y w h)
(if (and (<= y math-comp-sel-vpos)
(<= x math-comp-sel-hpos)
(> (+ x w) math-comp-sel-hpos))
(setq math-comp-sel-tag comp-tag
- math-comp-sel-vpos 10000))
-)
+ math-comp-sel-vpos 10000)))
(defun math-comp-simplify-term (c)
(cond ((stringp c)
(let ((comp-highlight nil))
(math-comp-simplify-term (nth 2 c))))
(t (let ((comp-tag c))
- (math-comp-simplify-term (nth 2 c)))))))
-)
+ (math-comp-simplify-term (nth 2 c))))))))
;;; Measuring a composition.
(math-comp-is-null (car c))))
(and c (math-comp-first-char (car c))))
((eq (car c) 'tag)
- (math-comp-first-char (nth 2 c))))
-)
+ (math-comp-first-char (nth 2 c)))))
(defun math-comp-first-string (c)
(cond ((stringp c)
(math-comp-is-null (car c))))
(and c (math-comp-first-string (car c))))
((eq (car c) 'tag)
- (math-comp-first-string (nth 2 c))))
-)
+ (math-comp-first-string (nth 2 c)))))
(defun math-comp-last-char (c)
(cond ((stringp c)
(setq c (cdr c)))
(and c (math-comp-last-char (car c)))))
((eq (car c) 'tag)
- (math-comp-last-char (nth 2 c))))
-)
+ (math-comp-last-char (nth 2 c)))))
(defun math-comp-is-null (c)
(cond ((stringp c) (= (length c) 0))
(null c))
((eq (car c) 'tag)
(math-comp-is-null (nth 2 c)))
- ((memq (car c) '(set break)) t))
-)
+ ((memq (car c) '(set break)) t)))
(defun math-comp-width (c)
(cond ((not (consp c)) (length c))
accum))
((eq (car c) 'tag)
(math-comp-width (nth 2 c)))
- (t 0))
-)
+ (t 0)))
(defun math-comp-height (c)
(if (stringp c)
1
- (+ (math-comp-ascent c) (math-comp-descent c)))
-)
+ (+ (math-comp-ascent c) (math-comp-descent c))))
(defun math-comp-ascent (c)
(cond ((not (consp c)) 1)
(math-comp-ascent (nth 1 c)))
((eq (car c) 'tag)
(math-comp-ascent (nth 2 c)))
- (t 1))
-)
+ (t 1)))
(defun math-comp-descent (c)
(cond ((not (consp c)) 0)
(+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
((eq (car c) 'tag)
(math-comp-descent (nth 2 c)))
- (t 0))
-)
+ (t 0)))
(defun calcFunc-cwidth (a &optional prec)
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
- (math-comp-width (math-compose-expr a (or prec 0)))
-)
+ (math-comp-width (math-compose-expr a (or prec 0))))
(defun calcFunc-cheight (a &optional prec)
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
(memq (length a) '(2 3))
(eq (nth 1 a) 0))
0
- (math-comp-height (math-compose-expr a (or prec 0))))
-)
+ (math-comp-height (math-compose-expr a (or prec 0)))))
(defun calcFunc-cascent (a &optional prec)
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
(memq (length a) '(2 3))
(eq (nth 1 a) 0))
0
- (math-comp-ascent (math-compose-expr a (or prec 0))))
-)
+ (math-comp-ascent (math-compose-expr a (or prec 0)))))
(defun calcFunc-cdescent (a &optional prec)
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
- (math-comp-descent (math-compose-expr a (or prec 0)))
-)
+ (math-comp-descent (math-compose-expr a (or prec 0))))
;;; Convert a simplified composition into string form.
(defun math-vert-comp-to-string (c)
(if (stringp c)
c
- (math-vert-comp-to-string-step (cdr (cdr c))))
-)
+ (math-vert-comp-to-string-step (cdr (cdr c)))))
(defun math-vert-comp-to-string-step (c)
(if (cdr c)
(concat (car c) "\n" (math-vert-comp-to-string-step (cdr c)))
- (car c))
-)
+ (car c)))
;;; Convert a composition to a string in "raw" form (for debugging).
(math-comp-to-string-raw (nth 1 c) next-indent)
(math-comp-to-string-raw-step (cdr (cdr c))
next-indent)
- ")"))))
-)
+ ")")))))
(defun math-comp-to-string-raw-step (cl indent)
(if cl
(make-string indent 32)
(math-comp-to-string-raw (car cl) indent)
(math-comp-to-string-raw-step (cdr cl) indent))
- "")
-)
-
-
-
+ ""))
+;;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
+;;; calccomp.el ends here
HCoop / bpt / emacs.git / blobdiff