1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-23 07:19:15 +00:00
emacs/lisp/calc/calc-lang.el

1117 lines
36 KiB
EmacsLisp
Raw Normal View History

;;; calc-lang.el --- calc language functions
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
2003-02-04 13:24:35 +00:00
;; Maintainers: D. Goel <deego@gnufans.org>
2003-01-15 15:16:25 +00:00
;; Colin Walters <walters@debian.org>
2001-11-06 18:59:06 +00:00
;; This file is part of GNU Emacs.
;; 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.
;; 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.
;;; Commentary:
;;; Code:
2001-11-06 18:59:06 +00:00
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
(require 'calc-macs)
(defun calc-Need-calc-lang () nil)
;;; Alternate entry/display languages.
(defun calc-set-language (lang &optional option no-refresh)
(setq math-expr-opers (or (get lang 'math-oper-table) math-standard-opers)
math-expr-function-mapping (get lang 'math-function-table)
math-expr-variable-mapping (get lang 'math-variable-table)
calc-language-input-filter (get lang 'math-input-filter)
calc-language-output-filter (get lang 'math-output-filter)
calc-vector-brackets (or (get lang 'math-vector-brackets) "[]")
calc-complex-format (get lang 'math-complex-format)
calc-radix-formatter (get lang 'math-radix-formatter)
calc-function-open (or (get lang 'math-function-open) "(")
calc-function-close (or (get lang 'math-function-close) ")"))
(if no-refresh
(setq calc-language lang
calc-language-option option)
(calc-change-mode '(calc-language calc-language-option)
(list lang option) t)))
2001-11-06 18:59:06 +00:00
(defun calc-normal-language ()
(interactive)
(calc-wrapper
(calc-set-language nil)
(message "Normal language mode")))
2001-11-06 18:59:06 +00:00
(defun calc-flat-language ()
(interactive)
(calc-wrapper
(calc-set-language 'flat)
(message "Flat language mode (all stack entries shown on one line)")))
2001-11-06 18:59:06 +00:00
(defun calc-big-language ()
(interactive)
(calc-wrapper
(calc-set-language 'big)
(message "\"Big\" language mode")))
2001-11-06 18:59:06 +00:00
(defun calc-unformatted-language ()
(interactive)
(calc-wrapper
(calc-set-language 'unform)
(message "Unformatted language mode")))
2001-11-06 18:59:06 +00:00
(defun calc-c-language ()
(interactive)
(calc-wrapper
(calc-set-language 'c)
(message "`C' language mode")))
2001-11-06 18:59:06 +00:00
(put 'c 'math-oper-table
'( ( "u+" ident -1 1000 )
( "u-" neg -1 1000 )
( "u!" calcFunc-lnot -1 1000 )
( "~" calcFunc-not -1 1000 )
( "*" * 190 191 )
( "/" / 190 191 )
( "%" % 190 191 )
( "+" + 180 181 )
( "-" - 180 181 )
( "<<" calcFunc-lsh 170 171 )
( ">>" calcFunc-rsh 170 171 )
( "<" calcFunc-lt 160 161 )
( ">" calcFunc-gt 160 161 )
( "<=" calcFunc-leq 160 161 )
( ">=" calcFunc-geq 160 161 )
( "==" calcFunc-eq 150 151 )
( "!=" calcFunc-neq 150 151 )
( "&" calcFunc-and 140 141 )
( "^" calcFunc-xor 131 130 )
( "|" calcFunc-or 120 121 )
( "&&" calcFunc-land 110 111 )
( "||" calcFunc-lor 100 101 )
( "?" (math-read-if) 91 90 )
( "!!!" calcFunc-pnot -1 88 )
( "&&&" calcFunc-pand 85 86 )
( "|||" calcFunc-por 75 76 )
( "=" calcFunc-assign 51 50 )
( ":=" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 ))) ; should support full assignments
2001-11-06 18:59:06 +00:00
(put 'c 'math-function-table
'( ( acos . calcFunc-arccos )
( acosh . calcFunc-arccosh )
( asin . calcFunc-arcsin )
( asinh . calcFunc-arcsinh )
( atan . calcFunc-arctan )
( atan2 . calcFunc-arctan2 )
( atanh . calcFunc-arctanh )))
2001-11-06 18:59:06 +00:00
(put 'c 'math-variable-table
'( ( M_PI . var-pi )
( M_E . var-e )))
2001-11-06 18:59:06 +00:00
(put 'c 'math-vector-brackets "{}")
(put 'c 'math-radix-formatter
(function (lambda (r s)
(if (= r 16) (format "0x%s" s)
(if (= r 8) (format "0%s" s)
(format "%d#%s" r s))))))
(defun calc-pascal-language (n)
(interactive "P")
(calc-wrapper
(and n (setq n (prefix-numeric-value n)))
(calc-set-language 'pascal n)
(message (if (and n (/= n 0))
(if (> n 0)
"Pascal language mode (all uppercase)"
"Pascal language mode (all lowercase)")
"Pascal language mode"))))
2001-11-06 18:59:06 +00:00
(put 'pascal 'math-oper-table
'( ( "not" calcFunc-lnot -1 1000 )
( "*" * 190 191 )
( "/" / 190 191 )
( "and" calcFunc-and 190 191 )
( "div" calcFunc-idiv 190 191 )
( "mod" % 190 191 )
( "u+" ident -1 185 )
( "u-" neg -1 185 )
( "+" + 180 181 )
( "-" - 180 181 )
( "or" calcFunc-or 180 181 )
( "xor" calcFunc-xor 180 181 )
( "shl" calcFunc-lsh 180 181 )
( "shr" calcFunc-rsh 180 181 )
( "in" calcFunc-in 160 161 )
( "<" calcFunc-lt 160 161 )
( ">" calcFunc-gt 160 161 )
( "<=" calcFunc-leq 160 161 )
( ">=" calcFunc-geq 160 161 )
( "=" calcFunc-eq 160 161 )
( "<>" calcFunc-neq 160 161 )
( "!!!" calcFunc-pnot -1 85 )
( "&&&" calcFunc-pand 80 81 )
( "|||" calcFunc-por 75 76 )
( ":=" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 )))
2001-11-06 18:59:06 +00:00
(put 'pascal 'math-input-filter 'calc-input-case-filter)
(put 'pascal 'math-output-filter 'calc-output-case-filter)
(put 'pascal 'math-radix-formatter
(function (lambda (r s)
(if (= r 16) (format "$%s" s)
(format "%d#%s" r s)))))
(defun calc-input-case-filter (str)
(cond ((or (null calc-language-option) (= calc-language-option 0))
str)
(t
(downcase str))))
2001-11-06 18:59:06 +00:00
(defun calc-output-case-filter (str)
(cond ((or (null calc-language-option) (= calc-language-option 0))
str)
((> calc-language-option 0)
(upcase str))
(t
(downcase str))))
2001-11-06 18:59:06 +00:00
(defun calc-fortran-language (n)
(interactive "P")
(calc-wrapper
(and n (setq n (prefix-numeric-value n)))
(calc-set-language 'fortran n)
(message (if (and n (/= n 0))
(if (> n 0)
"FORTRAN language mode (all uppercase)"
"FORTRAN language mode (all lowercase)")
"FORTRAN language mode"))))
2001-11-06 18:59:06 +00:00
(put 'fortran 'math-oper-table
'( ( "u/" (math-parse-fortran-vector) -1 1 )
( "/" (math-parse-fortran-vector-end) 1 -1 )
( "**" ^ 201 200 )
( "u+" ident -1 191 )
( "u-" neg -1 191 )
( "*" * 190 191 )
( "/" / 190 191 )
( "+" + 180 181 )
( "-" - 180 181 )
( ".LT." calcFunc-lt 160 161 )
( ".GT." calcFunc-gt 160 161 )
( ".LE." calcFunc-leq 160 161 )
( ".GE." calcFunc-geq 160 161 )
( ".EQ." calcFunc-eq 160 161 )
( ".NE." calcFunc-neq 160 161 )
( ".NOT." calcFunc-lnot -1 121 )
( ".AND." calcFunc-land 110 111 )
( ".OR." calcFunc-lor 100 101 )
( "!!!" calcFunc-pnot -1 85 )
( "&&&" calcFunc-pand 80 81 )
( "|||" calcFunc-por 75 76 )
( "=" calcFunc-assign 51 50 )
( ":=" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 )))
2001-11-06 18:59:06 +00:00
(put 'fortran 'math-vector-brackets "//")
(put 'fortran 'math-function-table
'( ( acos . calcFunc-arccos )
( acosh . calcFunc-arccosh )
( aimag . calcFunc-im )
( aint . calcFunc-ftrunc )
( asin . calcFunc-arcsin )
( asinh . calcFunc-arcsinh )
( atan . calcFunc-arctan )
( atan2 . calcFunc-arctan2 )
( atanh . calcFunc-arctanh )
( conjg . calcFunc-conj )
( log . calcFunc-ln )
( nint . calcFunc-round )
2003-02-04 13:24:35 +00:00
( real . calcFunc-re )))
2001-11-06 18:59:06 +00:00
(put 'fortran 'math-input-filter 'calc-input-case-filter)
(put 'fortran 'math-output-filter 'calc-output-case-filter)
(defvar math-parsing-fortran-vector nil)
2001-11-06 18:59:06 +00:00
(defun math-parse-fortran-vector (op)
(let ((math-parsing-fortran-vector '(end . "\000")))
(prog1
(math-read-brackets t "]")
(setq exp-token (car math-parsing-fortran-vector)
exp-data (cdr math-parsing-fortran-vector)))))
2001-11-06 18:59:06 +00:00
(defun math-parse-fortran-vector-end (x op)
(if math-parsing-fortran-vector
(progn
(setq math-parsing-fortran-vector (cons exp-token exp-data)
exp-token 'end
exp-data "\000")
x)
(throw 'syntax "Unmatched closing `/'")))
2001-11-06 18:59:06 +00:00
(defun math-parse-fortran-subscr (sym args)
(setq sym (math-build-var-name sym))
(while args
(setq sym (list 'calcFunc-subscr sym (car args))
args (cdr args)))
sym)
2001-11-06 18:59:06 +00:00
(defun calc-tex-language (n)
(interactive "P")
(calc-wrapper
(and n (setq n (prefix-numeric-value n)))
(calc-set-language 'tex n)
(message (if (and n (/= n 0))
(if (> n 0)
"TeX language mode with \\hbox{func}(\\hbox{var})"
"TeX language mode with \\func{\\hbox{var}}")
"TeX language mode"))))
2001-11-06 18:59:06 +00:00
(put 'tex 'math-oper-table
'( ( "u+" ident -1 1000 )
( "u-" neg -1 1000 )
( "\\hat" calcFunc-hat -1 950 )
( "\\check" calcFunc-check -1 950 )
( "\\tilde" calcFunc-tilde -1 950 )
( "\\acute" calcFunc-acute -1 950 )
( "\\grave" calcFunc-grave -1 950 )
( "\\dot" calcFunc-dot -1 950 )
( "\\ddot" calcFunc-dotdot -1 950 )
( "\\breve" calcFunc-breve -1 950 )
( "\\bar" calcFunc-bar -1 950 )
( "\\vec" calcFunc-Vec -1 950 )
( "\\underline" calcFunc-under -1 950 )
( "u|" calcFunc-abs -1 0 )
( "|" closing 0 -1 )
( "\\lfloor" calcFunc-floor -1 0 )
( "\\rfloor" closing 0 -1 )
( "\\lceil" calcFunc-ceil -1 0 )
( "\\rceil" closing 0 -1 )
( "\\pm" sdev 300 300 )
( "!" calcFunc-fact 210 -1 )
( "^" ^ 201 200 )
( "_" calcFunc-subscr 201 200 )
( "\\times" * 191 190 )
( "*" * 191 190 )
( "2x" * 191 190 )
( "+" + 180 181 )
( "-" - 180 181 )
( "\\over" / 170 171 )
( "/" / 170 171 )
( "\\choose" calcFunc-choose 170 171 )
( "\\mod" % 170 171 )
( "<" calcFunc-lt 160 161 )
( ">" calcFunc-gt 160 161 )
( "\\leq" calcFunc-leq 160 161 )
( "\\geq" calcFunc-geq 160 161 )
( "=" calcFunc-eq 160 161 )
( "\\neq" calcFunc-neq 160 161 )
( "\\ne" calcFunc-neq 160 161 )
( "\\lnot" calcFunc-lnot -1 121 )
( "\\land" calcFunc-land 110 111 )
( "\\lor" calcFunc-lor 100 101 )
( "?" (math-read-if) 91 90 )
( "!!!" calcFunc-pnot -1 85 )
( "&&&" calcFunc-pand 80 81 )
( "|||" calcFunc-por 75 76 )
( "\\gets" calcFunc-assign 51 50 )
( ":=" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 )
( "\\to" calcFunc-evalto 40 41 )
( "\\to" calcFunc-evalto 40 -1 )
( "=>" calcFunc-evalto 40 41 )
( "=>" calcFunc-evalto 40 -1 )))
2001-11-06 18:59:06 +00:00
(put 'tex 'math-function-table
'( ( \\arccos . calcFunc-arccos )
( \\arcsin . calcFunc-arcsin )
( \\arctan . calcFunc-arctan )
( \\arg . calcFunc-arg )
( \\cos . calcFunc-cos )
( \\cosh . calcFunc-cosh )
( \\det . calcFunc-det )
( \\exp . calcFunc-exp )
( \\gcd . calcFunc-gcd )
( \\ln . calcFunc-ln )
( \\log . calcFunc-log10 )
( \\max . calcFunc-max )
( \\min . calcFunc-min )
( \\tan . calcFunc-tan )
( \\sin . calcFunc-sin )
( \\sinh . calcFunc-sinh )
( \\sqrt . calcFunc-sqrt )
( \\tanh . calcFunc-tanh )
( \\phi . calcFunc-totient )
( \\mu . calcFunc-moebius )))
2001-11-06 18:59:06 +00:00
(put 'tex 'math-variable-table
'( ( \\pi . var-pi )
( \\infty . var-inf )
( \\infty . var-uinf )
( \\phi . var-phi )
( \\gamma . var-gamma )
( \\sum . (math-parse-tex-sum calcFunc-sum) )
( \\prod . (math-parse-tex-sum calcFunc-prod) )))
2001-11-06 18:59:06 +00:00
(put 'tex 'math-complex-format 'i)
(defun math-parse-tex-sum (f val)
(let (low high save)
(or (equal exp-data "_") (throw 'syntax "Expected `_'"))
(math-read-token)
(setq save exp-old-pos)
(setq low (math-read-factor))
(or (eq (car-safe low) 'calcFunc-eq)
(progn
(setq exp-old-pos (1+ save))
(throw 'syntax "Expected equation")))
(or (equal exp-data "^") (throw 'syntax "Expected `^'"))
(math-read-token)
(setq high (math-read-factor))
(list (nth 2 f) (math-read-factor) (nth 1 low) (nth 2 low) high)))
2001-11-06 18:59:06 +00:00
(defun math-tex-input-filter (str) ; allow parsing of 123\,456\,789.
(while (string-match "[0-9]\\\\,[0-9]" str)
(setq str (concat (substring str 0 (1+ (match-beginning 0)))
(substring str (1- (match-end 0))))))
str)
2001-11-06 18:59:06 +00:00
(put 'tex 'math-input-filter 'math-tex-input-filter)
(defun calc-eqn-language (n)
(interactive "P")
(calc-wrapper
(calc-set-language 'eqn)
(message "Eqn language mode")))
2001-11-06 18:59:06 +00:00
(put 'eqn 'math-oper-table
'( ( "u+" ident -1 1000 )
( "u-" neg -1 1000 )
( "prime" (math-parse-eqn-prime) 950 -1 )
( "prime" calcFunc-Prime 950 -1 )
( "dot" calcFunc-dot 950 -1 )
( "dotdot" calcFunc-dotdot 950 -1 )
( "hat" calcFunc-hat 950 -1 )
( "tilde" calcFunc-tilde 950 -1 )
( "vec" calcFunc-Vec 950 -1 )
( "dyad" calcFunc-dyad 950 -1 )
( "bar" calcFunc-bar 950 -1 )
( "under" calcFunc-under 950 -1 )
( "sub" calcFunc-subscr 931 930 )
( "sup" ^ 921 920 )
( "sqrt" calcFunc-sqrt -1 910 )
( "over" / 900 901 )
( "u|" calcFunc-abs -1 0 )
( "|" closing 0 -1 )
( "left floor" calcFunc-floor -1 0 )
( "right floor" closing 0 -1 )
( "left ceil" calcFunc-ceil -1 0 )
( "right ceil" closing 0 -1 )
( "+-" sdev 300 300 )
( "!" calcFunc-fact 210 -1 )
( "times" * 191 190 )
( "*" * 191 190 )
( "2x" * 191 190 )
( "/" / 180 181 )
( "%" % 180 181 )
( "+" + 170 171 )
( "-" - 170 171 )
( "<" calcFunc-lt 160 161 )
( ">" calcFunc-gt 160 161 )
( "<=" calcFunc-leq 160 161 )
( ">=" calcFunc-geq 160 161 )
( "=" calcFunc-eq 160 161 )
( "==" calcFunc-eq 160 161 )
( "!=" calcFunc-neq 160 161 )
( "u!" calcFunc-lnot -1 121 )
( "&&" calcFunc-land 110 111 )
( "||" calcFunc-lor 100 101 )
( "?" (math-read-if) 91 90 )
( "!!!" calcFunc-pnot -1 85 )
( "&&&" calcFunc-pand 80 81 )
( "|||" calcFunc-por 75 76 )
( "<-" calcFunc-assign 51 50 )
( ":=" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 )
( "->" calcFunc-evalto 40 41 )
( "->" calcFunc-evalto 40 -1 )
( "=>" calcFunc-evalto 40 41 )
( "=>" calcFunc-evalto 40 -1 )))
2001-11-06 18:59:06 +00:00
(put 'eqn 'math-function-table
'( ( arc\ cos . calcFunc-arccos )
( arc\ cosh . calcFunc-arccosh )
( arc\ sin . calcFunc-arcsin )
( arc\ sinh . calcFunc-arcsinh )
( arc\ tan . calcFunc-arctan )
( arc\ tanh . calcFunc-arctanh )
( GAMMA . calcFunc-gamma )
( phi . calcFunc-totient )
( mu . calcFunc-moebius )
( matrix . (math-parse-eqn-matrix) )))
2001-11-06 18:59:06 +00:00
(put 'eqn 'math-variable-table
'( ( inf . var-uinf )))
2001-11-06 18:59:06 +00:00
(put 'eqn 'math-complex-format 'i)
(defun math-parse-eqn-matrix (f sym)
(let ((vec nil))
(while (assoc exp-data '(("ccol") ("lcol") ("rcol")))
(math-read-token)
(or (equal exp-data calc-function-open)
(throw 'syntax "Expected `{'"))
(math-read-token)
(setq vec (cons (cons 'vec (math-read-expr-list)) vec))
(or (equal exp-data calc-function-close)
(throw 'syntax "Expected `}'"))
(math-read-token))
(or (equal exp-data calc-function-close)
(throw 'syntax "Expected `}'"))
(math-read-token)
(math-transpose (cons 'vec (nreverse vec)))))
2001-11-06 18:59:06 +00:00
(defun math-parse-eqn-prime (x sym)
(if (eq (car-safe x) 'var)
(if (equal exp-data calc-function-open)
(progn
(math-read-token)
(let ((args (if (or (equal exp-data calc-function-close)
(eq exp-token 'end))
nil
(math-read-expr-list))))
(if (not (or (equal exp-data calc-function-close)
(eq exp-token 'end)))
(throw 'syntax "Expected `)'"))
(math-read-token)
(cons (intern (format "calcFunc-%s'" (nth 1 x))) args)))
(list 'var
(intern (concat (symbol-name (nth 1 x)) "'"))
(intern (concat (symbol-name (nth 2 x)) "'"))))
(list 'calcFunc-Prime x)))
2001-11-06 18:59:06 +00:00
(defun calc-mathematica-language ()
(interactive)
(calc-wrapper
(calc-set-language 'math)
(message "Mathematica language mode")))
2001-11-06 18:59:06 +00:00
(put 'math 'math-oper-table
'( ( "[[" (math-read-math-subscr) 250 -1 )
( "!" calcFunc-fact 210 -1 )
( "!!" calcFunc-dfact 210 -1 )
( "^" ^ 201 200 )
( "u+" ident -1 197 )
( "u-" neg -1 197 )
( "/" / 195 196 )
( "*" * 190 191 )
( "2x" * 190 191 )
( "+" + 180 181 )
( "-" - 180 181 )
( "<" calcFunc-lt 160 161 )
( ">" calcFunc-gt 160 161 )
( "<=" calcFunc-leq 160 161 )
( ">=" calcFunc-geq 160 161 )
( "==" calcFunc-eq 150 151 )
( "!=" calcFunc-neq 150 151 )
( "u!" calcFunc-lnot -1 121 )
( "&&" calcFunc-land 110 111 )
( "||" calcFunc-lor 100 101 )
( "!!!" calcFunc-pnot -1 85 )
( "&&&" calcFunc-pand 80 81 )
( "|||" calcFunc-por 75 76 )
( ":=" calcFunc-assign 51 50 )
( "=" calcFunc-assign 51 50 )
( "->" calcFunc-assign 51 50 )
( ":>" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 )
))
(put 'math 'math-function-table
'( ( Abs . calcFunc-abs )
( ArcCos . calcFunc-arccos )
( ArcCosh . calcFunc-arccosh )
( ArcSin . calcFunc-arcsin )
( ArcSinh . calcFunc-arcsinh )
( ArcTan . calcFunc-arctan )
( ArcTanh . calcFunc-arctanh )
( Arg . calcFunc-arg )
( Binomial . calcFunc-choose )
( Ceiling . calcFunc-ceil )
( Conjugate . calcFunc-conj )
( Cos . calcFunc-cos )
( Cosh . calcFunc-cosh )
( D . calcFunc-deriv )
( Dt . calcFunc-tderiv )
( Det . calcFunc-det )
( Exp . calcFunc-exp )
( EulerPhi . calcFunc-totient )
( Floor . calcFunc-floor )
( Gamma . calcFunc-gamma )
( GCD . calcFunc-gcd )
( If . calcFunc-if )
( Im . calcFunc-im )
( Inverse . calcFunc-inv )
( Integrate . calcFunc-integ )
( Join . calcFunc-vconcat )
( LCM . calcFunc-lcm )
( Log . calcFunc-ln )
( Max . calcFunc-max )
( Min . calcFunc-min )
( Mod . calcFunc-mod )
( MoebiusMu . calcFunc-moebius )
( Random . calcFunc-random )
( Round . calcFunc-round )
( Re . calcFunc-re )
( Sign . calcFunc-sign )
( Sin . calcFunc-sin )
( Sinh . calcFunc-sinh )
( Sqrt . calcFunc-sqrt )
( Tan . calcFunc-tan )
( Tanh . calcFunc-tanh )
( Transpose . calcFunc-trn )
( Length . calcFunc-vlen )
))
(put 'math 'math-variable-table
'( ( I . var-i )
( Pi . var-pi )
( E . var-e )
( GoldenRatio . var-phi )
( EulerGamma . var-gamma )
( Infinity . var-inf )
( ComplexInfinity . var-uinf )
( Indeterminate . var-nan )
))
(put 'math 'math-vector-brackets "{}")
(put 'math 'math-complex-format 'I)
(put 'math 'math-function-open "[")
(put 'math 'math-function-close "]")
(put 'math 'math-radix-formatter
(function (lambda (r s) (format "%d^^%s" r s))))
(defun math-read-math-subscr (x op)
(let ((idx (math-read-expr-level 0)))
(or (and (equal exp-data "]")
(progn
(math-read-token)
(equal exp-data "]")))
(throw 'syntax "Expected ']]'"))
(math-read-token)
(list 'calcFunc-subscr x idx)))
2001-11-06 18:59:06 +00:00
(defun calc-maple-language ()
(interactive)
(calc-wrapper
(calc-set-language 'maple)
(message "Maple language mode")))
2001-11-06 18:59:06 +00:00
(put 'maple 'math-oper-table
'( ( "matrix" ident -1 300 )
( "MATRIX" ident -1 300 )
( "!" calcFunc-fact 210 -1 )
( "^" ^ 201 200 )
( "**" ^ 201 200 )
( "u+" ident -1 197 )
( "u-" neg -1 197 )
( "/" / 191 192 )
( "*" * 191 192 )
( "intersect" calcFunc-vint 191 192 )
( "+" + 180 181 )
( "-" - 180 181 )
( "union" calcFunc-vunion 180 181 )
( "minus" calcFunc-vdiff 180 181 )
( "mod" % 170 170 )
( ".." (math-read-maple-dots) 165 165 )
( "\\dots" (math-read-maple-dots) 165 165 )
( "<" calcFunc-lt 160 160 )
( ">" calcFunc-gt 160 160 )
( "<=" calcFunc-leq 160 160 )
( ">=" calcFunc-geq 160 160 )
( "=" calcFunc-eq 160 160 )
( "<>" calcFunc-neq 160 160 )
( "not" calcFunc-lnot -1 121 )
( "and" calcFunc-land 110 111 )
( "or" calcFunc-lor 100 101 )
( "!!!" calcFunc-pnot -1 85 )
( "&&&" calcFunc-pand 80 81 )
( "|||" calcFunc-por 75 76 )
( ":=" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 )
))
(put 'maple 'math-function-table
'( ( bernoulli . calcFunc-bern )
( binomial . calcFunc-choose )
( diff . calcFunc-deriv )
( GAMMA . calcFunc-gamma )
( ifactor . calcFunc-prfac )
( igcd . calcFunc-gcd )
( ilcm . calcFunc-lcm )
( int . calcFunc-integ )
( modp . % )
( irem . % )
( iquo . calcFunc-idiv )
( isprime . calcFunc-prime )
( length . calcFunc-vlen )
( member . calcFunc-in )
( crossprod . calcFunc-cross )
( inverse . calcFunc-inv )
( trace . calcFunc-tr )
( transpose . calcFunc-trn )
( vectdim . calcFunc-vlen )
))
(put 'maple 'math-variable-table
'( ( I . var-i )
( Pi . var-pi )
( E . var-e )
( infinity . var-inf )
( infinity . var-uinf )
( infinity . var-nan )
))
(put 'maple 'math-complex-format 'I)
(defun math-read-maple-dots (x op)
(list 'intv 3 x (math-read-expr-level (nth 3 op))))
2001-11-06 18:59:06 +00:00
(defun math-read-big-rec (h1 v1 h2 v2 &optional baseline prec short)
(or prec (setq prec 0))
;; Clip whitespace above or below.
(while (and (< v1 v2) (math-read-big-emptyp h1 v1 h2 (1+ v1)))
(setq v1 (1+ v1)))
(while (and (< v1 v2) (math-read-big-emptyp h1 (1- v2) h2 v2))
(setq v2 (1- v2)))
;; If formula is a single line high, normal parser can handle it.
(if (<= v2 (1+ v1))
(if (or (<= v2 v1)
(> h1 (length (setq v2 (nth v1 lines)))))
(math-read-big-error h1 v1)
(setq the-baseline v1
the-h2 h2
v2 (nth v1 lines)
h2 (math-read-expr (substring v2 h1 (min h2 (length v2)))))
(if (eq (car-safe h2) 'error)
(math-read-big-error (+ h1 (nth 1 h2)) v1 (nth 2 h2))
h2))
;; Clip whitespace at left or right.
(while (and (< h1 h2) (math-read-big-emptyp h1 v1 (1+ h1) v2))
(setq h1 (1+ h1)))
(while (and (< h1 h2) (math-read-big-emptyp (1- h2) v1 h2 v2))
(setq h2 (1- h2)))
;; Scan to find widest left-justified "----" in the region.
(let* ((widest nil)
(widest-h2 0)
(lines-v1 (nthcdr v1 lines))
(p lines-v1)
(v v1)
(other-v nil)
other-char line len h)
(while (< v v2)
(setq line (car p)
len (min h2 (length line)))
(and (< h1 len)
(/= (aref line h1) ?\ )
(if (and (= (aref line h1) ?\-)
;; Make sure it's not a minus sign.
(or (and (< (1+ h1) len) (= (aref line (1+ h1)) ?\-))
(/= (math-read-big-char h1 (1- v)) ?\ )
(/= (math-read-big-char h1 (1+ v)) ?\ )))
(progn
(setq h h1)
(while (and (< (setq h (1+ h)) len)
(= (aref line h) ?\-)))
(if (> h widest-h2)
(setq widest v
widest-h2 h)))
(or other-v (setq other-v v other-char (aref line h1)))))
(setq v (1+ v)
p (cdr p)))
(cond ((not (setq v other-v))
(math-read-big-error h1 v1)) ; Should never happen!
;; Quotient.
(widest
(setq h widest-h2
v widest)
(let ((num (math-read-big-rec h1 v1 h v))
(den (math-read-big-rec h1 (1+ v) h v2)))
(setq p (if (and (math-integerp num) (math-integerp den))
(math-make-frac num den)
(list '/ num den)))))
;; Big radical sign.
((= other-char ?\\)
(or (= (math-read-big-char (1+ h1) v) ?\|)
(math-read-big-error (1+ h1) v "Malformed root sign"))
(math-read-big-emptyp h1 v1 (1+ h1) v nil t)
(while (= (math-read-big-char (1+ h1) (setq v (1- v))) ?\|))
(or (= (math-read-big-char (setq h (+ h1 2)) v) ?\_)
(math-read-big-error h v "Malformed root sign"))
(while (= (math-read-big-char (setq h (1+ h)) v) ?\_))
(math-read-big-emptyp h1 v1 (1+ h1) v nil t)
(math-read-big-emptyp h1 (1+ other-v) h v2 nil t)
(setq p (list 'calcFunc-sqrt (math-read-big-rec
(+ h1 2) (1+ v)
h (1+ other-v) baseline))
v the-baseline))
;; Small radical sign.
((and (= other-char ?V)
(= (math-read-big-char (1+ h1) (1- v)) ?\_))
(setq h (1+ h1))
(math-read-big-emptyp h1 v1 h (1- v) nil t)
(math-read-big-emptyp h1 (1+ v) h v2 nil t)
(math-read-big-emptyp h1 v1 (1+ h1) v nil t)
(while (= (math-read-big-char (setq h (1+ h)) (1- v)) ?\_))
(setq p (list 'calcFunc-sqrt (math-read-big-rec
(1+ h1) v h (1+ v) t))
v the-baseline))
;; Binomial coefficient.
((and (= other-char ?\()
(= (math-read-big-char (1+ h1) v) ?\ )
(= (string-match "( *)" (nth v lines) h1) h1))
(setq h (match-end 0))
(math-read-big-emptyp h1 v1 (1+ h1) v nil t)
(math-read-big-emptyp h1 (1+ v) (1+ h1) v2 nil t)
(math-read-big-emptyp (1- h) v1 h v nil t)
(math-read-big-emptyp (1- h) (1+ v) h v2 nil t)
(setq p (list 'calcFunc-choose
(math-read-big-rec (1+ h1) v1 (1- h) v)
(math-read-big-rec (1+ h1) (1+ v)
(1- h) v2))))
;; Minus sign.
((= other-char ?\-)
(setq p (list 'neg (math-read-big-rec (1+ h1) v1 h2 v2 v 250 t))
v the-baseline
h the-h2))
;; Parentheses.
((= other-char ?\()
(math-read-big-emptyp h1 v1 (1+ h1) v nil t)
(math-read-big-emptyp h1 (1+ v) (1+ h1) v2 nil t)
(setq h (math-read-big-balance (1+ h1) v "(" t))
(math-read-big-emptyp (1- h) v1 h v nil t)
(math-read-big-emptyp (1- h) (1+ v) h v2 nil t)
(let ((sep (math-read-big-char (1- h) v))
hmid)
(if (= sep ?\.)
(setq h (1+ h)))
(if (= sep ?\])
(math-read-big-error (1- h) v "Expected `)'"))
(if (= sep ?\))
(setq p (math-read-big-rec (1+ h1) v1 (1- h) v2 v))
(setq hmid (math-read-big-balance h v "(")
p (list p (math-read-big-rec h v1 (1- hmid) v2 v))
h hmid)
(cond ((= sep ?\.)
(setq p (cons 'intv (cons (if (= (math-read-big-char
(1- h) v)
?\))
0 1)
p))))
((= (math-read-big-char (1- h) v) ?\])
(math-read-big-error (1- h) v "Expected `)'"))
((= sep ?\,)
(or (and (math-realp (car p)) (math-realp (nth 1 p)))
(math-read-big-error
h1 v "Complex components must be real"))
(setq p (cons 'cplx p)))
((= sep ?\;)
(or (and (math-realp (car p)) (math-anglep (nth 1 p)))
(math-read-big-error
h1 v "Complex components must be real"))
(setq p (cons 'polar p)))))))
;; Matrix.
((and (= other-char ?\[)
(or (= (math-read-big-char (setq h h1) (1+ v)) ?\[)
(= (math-read-big-char (setq h (1+ h)) v) ?\[)
(and (= (math-read-big-char h v) ?\ )
(= (math-read-big-char (setq h (1+ h)) v) ?\[)))
(= (math-read-big-char h (1+ v)) ?\[))
(math-read-big-emptyp h1 v1 h v nil t)
(let ((vtop v)
(hleft h)
(hright nil))
(setq p nil)
(while (progn
(setq h (math-read-big-balance (1+ hleft) v "["))
(if hright
(or (= h hright)
(math-read-big-error hright v "Expected `]'"))
(setq hright h))
(setq p (cons (math-read-big-rec
hleft v h (1+ v)) p))
(and (memq (math-read-big-char h v) '(?\ ?\,))
(= (math-read-big-char hleft (1+ v)) ?\[)))
(setq v (1+ v)))
(or (= hleft h1)
(progn
(if (= (math-read-big-char h v) ?\ )
(setq h (1+ h)))
(and (= (math-read-big-char h v) ?\])
(setq h (1+ h))))
(math-read-big-error (1- h) v "Expected `]'"))
(if (= (math-read-big-char h vtop) ?\,)
(setq h (1+ h)))
(math-read-big-emptyp h1 (1+ v) (1- h) v2 nil t)
(setq v (+ vtop (/ (- v vtop) 2))
p (cons 'vec (nreverse p)))))
;; Square brackets.
((= other-char ?\[)
(math-read-big-emptyp h1 v1 (1+ h1) v nil t)
(math-read-big-emptyp h1 (1+ v) (1+ h1) v2 nil t)
(setq p nil
h (1+ h1))
(while (progn
(setq widest (math-read-big-balance h v "[" t))
(math-read-big-emptyp (1- h) v1 h v nil t)
(math-read-big-emptyp (1- h) (1+ v) h v2 nil t)
(setq p (cons (math-read-big-rec
h v1 (1- widest) v2 v) p)
h widest)
(= (math-read-big-char (1- h) v) ?\,)))
(setq widest (math-read-big-char (1- h) v))
(if (or (memq widest '(?\; ?\)))
(and (eq widest ?\.) (cdr p)))
(math-read-big-error (1- h) v "Expected `]'"))
(if (= widest ?\.)
(setq h (1+ h)
widest (math-read-big-balance h v "[")
p (nconc p (list (math-read-big-big-rec
h v1 (1- widest) v2 v)))
h widest
p (cons 'intv (cons (if (= (math-read-big-char (1- h) v)
?\])
3 2)
p)))
(setq p (cons 'vec (nreverse p)))))
;; Date form.
((= other-char ?\<)
(setq line (nth v lines))
(string-match ">" line h1)
(setq h (match-end 0))
(math-read-big-emptyp h1 v1 h v nil t)
(math-read-big-emptyp h1 (1+ v) h v2 nil t)
(setq p (math-read-big-rec h1 v h (1+ v) v)))
;; Variable name or function call.
((or (and (>= other-char ?a) (<= other-char ?z))
(and (>= other-char ?A) (<= other-char ?Z)))
(setq line (nth v lines))
(string-match "\\([a-zA-Z'_]+\\) *" line h1)
(setq h (match-end 1)
widest (match-end 0)
p (math-match-substring line 1))
(math-read-big-emptyp h1 v1 h v nil t)
(math-read-big-emptyp h1 (1+ v) h v2 nil t)
(if (= (math-read-big-char widest v) ?\()
(progn
(setq line (if (string-match "-" p)
(intern p)
(intern (concat "calcFunc-" p)))
h (1+ widest)
p nil)
(math-read-big-emptyp widest v1 h v nil t)
(math-read-big-emptyp widest (1+ v) h v2 nil t)
(while (progn
(setq widest (math-read-big-balance h v "(" t))
(math-read-big-emptyp (1- h) v1 h v nil t)
(math-read-big-emptyp (1- h) (1+ v) h v2 nil t)
(setq p (cons (math-read-big-rec
h v1 (1- widest) v2 v) p)
h widest)
(= (math-read-big-char (1- h) v) ?\,)))
(or (= (math-read-big-char (1- h) v) ?\))
(math-read-big-error (1- h) v "Expected `)'"))
(setq p (cons line (nreverse p))))
(setq p (list 'var
(intern (math-remove-dashes p))
(if (string-match "-" p)
(intern p)
(intern (concat "var-" p)))))))
;; Number.
(t
(setq line (nth v lines))
(or (= (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\([0-9]+\\(#\\|\\^\\^\\)[0-9a-zA-Z:]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?" line h1) h1)
(math-read-big-error h v "Expected a number"))
(setq h (match-end 0)
p (math-read-number (math-match-substring line 0)))
(math-read-big-emptyp h1 v1 h v nil t)
(math-read-big-emptyp h1 (1+ v) h v2 nil t)))
;; Now left term is bounded by h1, v1, h, v2; baseline = v.
(if baseline
(or (= v baseline)
(math-read-big-error h1 v "Inconsistent baseline in formula"))
(setq baseline v))
;; Look for superscripts or subscripts.
(setq line (nth baseline lines)
len (min h2 (length line))
widest h)
(while (and (< widest len)
(= (aref line widest) ?\ ))
(setq widest (1+ widest)))
(and (>= widest len) (setq widest h2))
(if (math-read-big-emptyp h v widest v2)
(if (math-read-big-emptyp h v1 widest v)
(setq h widest)
(setq p (list '^ p (math-read-big-rec h v1 widest v))
h widest))
(if (math-read-big-emptyp h v1 widest v)
(setq p (list 'calcFunc-subscr p
(math-read-big-rec h v widest v2))
h widest)))
;; Look for an operator name and grab additional terms.
(while (and (< h len)
(if (setq widest (and (math-read-big-emptyp
h v1 (1+ h) v)
(math-read-big-emptyp
h (1+ v) (1+ h) v2)
(string-match "<=\\|>=\\|\\+/-\\|!=\\|&&\\|||\\|:=\\|=>\\|." line h)
(assoc (math-match-substring line 0)
math-standard-opers)))
(and (>= (nth 2 widest) prec)
(setq h (match-end 0)))
(and (not (eq (string-match ",\\|;\\|\\.\\.\\|)\\|\\]\\|:" line h)
h))
(setq widest '("2x" * 196 195)))))
(cond ((eq (nth 3 widest) -1)
(setq p (list (nth 1 widest) p)))
((equal (car widest) "?")
(let ((y (math-read-big-rec h v1 h2 v2 baseline nil t)))
(or (= (math-read-big-char the-h2 baseline) ?\:)
(math-read-big-error the-h2 baseline "Expected `:'"))
(setq p (list (nth 1 widest) p y
(math-read-big-rec (1+ the-h2) v1 h2 v2
baseline (nth 3 widest) t))
h the-h2)))
(t
(setq p (list (nth 1 widest) p
(math-read-big-rec h v1 h2 v2
baseline (nth 3 widest) t))
h the-h2))))
;; Return all relevant information to caller.
(setq the-baseline baseline
the-h2 h)
(or short (= the-h2 h2)
(math-read-big-error h baseline))
p)))
2001-11-06 18:59:06 +00:00
(defun math-read-big-char (h v)
(or (and (>= h h1)
(< h h2)
(>= v v1)
(< v v2)
(let ((line (nth v lines)))
(and line
(< h (length line))
(aref line h))))
?\ ))
2001-11-06 18:59:06 +00:00
(defun math-read-big-emptyp (eh1 ev1 eh2 ev2 &optional what error)
(and (< ev1 v1) (setq ev1 v1))
(and (< eh1 h1) (setq eh1 h1))
(and (> ev2 v2) (setq ev2 v2))
(and (> eh2 h2) (setq eh2 h2))
(or what (setq what ?\ ))
(let ((p (nthcdr ev1 lines))
h)
(while (and (< ev1 ev2)
(progn
(setq h (min eh2 (length (car p))))
(while (and (>= (setq h (1- h)) eh1)
(= (aref (car p) h) what)))
(and error (>= h eh1)
(math-read-big-error h ev1 (if (stringp error)
error
"Whitespace expected")))
(< h eh1)))
(setq ev1 (1+ ev1)
p (cdr p)))
(>= ev1 ev2)))
2001-11-06 18:59:06 +00:00
(defun math-read-big-error (h v &optional msg)
(let ((pos 0)
(p lines))
(while (> v 0)
(setq pos (+ pos 1 (length (car p)))
p (cdr p)
v (1- v)))
(setq h (+ pos (min h (length (car p))))
err-msg (list 'error h (or msg "Syntax error")))
(throw 'syntax nil)))
2001-11-06 18:59:06 +00:00
(defun math-read-big-balance (h v what &optional commas)
(let* ((line (nth v lines))
(len (min h2 (length line)))
(count 1))
(while (> count 0)
(if (>= h len)
(if what
(math-read-big-error h1 v (format "Unmatched `%s'" what))
(setq count 0))
(if (memq (aref line h) '(?\( ?\[))
(setq count (1+ count))
(if (if (and commas (= count 1))
(or (memq (aref line h) '(?\) ?\] ?\, ?\;))
(and (eq (aref line h) ?\.)
(< (1+ h) len)
(eq (aref line (1+ h)) ?\.)))
(memq (aref line h) '(?\) ?\])))
(setq count (1- count))))
(setq h (1+ h))))
h))
2001-11-06 18:59:06 +00:00
;;; calc-lang.el ends here