share/contrib/maximaMathML/mathml-maxima.lisp

   1 ;;;;;;;;;;;;;;;;; File:  mathml-maxima.lsp  ;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Purpose:   Enabling maxima to receive mathml contentent-coded input
   3 ;;
   4 ;; Usage:     compile this file with UNIX command
   5 ;;                %mc maxima-mp.lsp
   6 ;;             which produces mathml-maxima.o
   7 ;;
   8 ;;            load into MAXIMA by MAXIMA top-level command
   9 ;;                loadfile("mathml-maxima.lsp");
  10 ;;
  11 ;; Author: Paul S. Wang
  12 ;; Date: 3/06/2000
  13 ;
  14 ; Authors:  Paul S. Wang, Kent State University
  15 ; This work was supported by NSF/USA.
  16 ; Permission to use this work for any purpose is granted provided that
  17 ; the copyright notice, author and support credits above are retained.
  18 ;
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20
  21 (in-package :maxima)
  22
  23 (declaim (special *tag* *special-proc* *parse-stream* *in* parse-tyipeek))
  24
  25 (defvar *in* *parse-stream*  "input stream to read")
  26
  27 (setq parse-tyipeek nil) ;; look-ahead in nparse.lisp
  28
  29 (defvar *tag* nil "tag of element returned by ml2ma")
  30
  31
  32 ;;;;; mltoma is the top-level mathml input function
  33
  34 (defun $mathml()
  35   (meval (mltoma *parse-stream*)))
  36
  37 (defun mltoma(&optional *in*)
  38 (prog(ans)
  39    (if (null *in*) (setq *in* t))
  40    (setq g (get-tag))
  41    (if (not (eq g 'math)) (return nil))
  42    (setq ans (ml2ma))
  43    (setq g (get-tag)) ;; this should be </math>
  44    (return ans)))
  45
  46 (defun ml2ma ()
  47   (multiple-value-bind (tag attributes) (get-tag)
  48     (setq *tag* tag)
  49     (cond
  50       ((eq tag 'ci) (ml-ci attributes))
  51       ((eq tag 'cn) (ml-cn attributes))
  52       ((eq tag 'apply) (ml-apply))
  53       ((member tag '(bvar lowlimit uplimit) :test #'eq)
  54        (setq ans (ml2ma)) (get-tag) ans)
  55       ((eq tag '/apply) nil)
  56       (t (merror "unknown or invalid mathml tag: ~A" tag)))))
  57
  58 (defun ml-apply()
  59   (prog(op *special-proc* ans)
  60      (setq op (get-op))
  61      (cond ((null op)
  62             (if *special-proc* (return (apply *special-proc* nil))
  63                 (merror "internal error: null mct-proc"))
  64             ))
  65      (do ((operand (ml2ma) (ml2ma))) ;; returns nil after seeing </apply>
  66          ((null operand) (setq ans (cons op (nreverse ans)))) ;; done
  67        (setq ans (cons operand ans))
  68        )
  69      (return ans)))
  70
  71 ;; <apply>
  72 ;; <diff/> <apply> <fn>G</fn><ci>X</ci> </apply>
  73 ;; <bvar><ci>X</ci><degree><cn type="integer">2</cn></degree></bvar>
  74 ;; </apply>
  75 ;;(($DIFF) (($F) $X) $X 2)
  76
  77 (defun mctdiff()
  78   (let ((fn (ml2ma)) (var-deg (diff-bvar)))
  79        (get-tag) ;; lose </apply>
  80        (cons (list '$diff) (cons fn var-deg))))
  81
  82 (defun mctintegrate()
  83   (prog(var nt ll up grand)
  84      (setq var (get-bvar))
  85      (setq nt (ml2ma))
  86      (cond ((eq *tag* 'lowlimit)
  87             (setq ll nt)
  88             (setq up (ml2ma))
  89             (cond ((eq *tag* 'uplimit)
  90                    (setq grand (ml2ma))
  91                    (get-tag) ;; lose </apply> for <int\>
  92                    (return (list '($integrate) grand var ll up)))
  93                   (t (merror "definite intergral error"))
  94                   ))
  95            )
  96      ;; indefinte integral
  97      (setq grand nt)
  98      (get-tag) ;; lose </apply>
  99      (return (list '($integrate) grand var))))
 100
 101 (defun get-bvar()
 102 (prog(tag v)
 103      (setq tag (get-tag))
 104      (if (not (eq tag 'bvar)) (merror "Expecting bvar but got ~A" tag))
 105      (setq v (ml2ma))
 106      (get-tag) ;; lose </bvar>
 107      (return v)
 108 ))
 109
 110 (defun diff-bvar()
 111 (prog(tag v d)
 112      (setq tag (get-tag))
 113      (if (not (eq tag 'bvar)) (merror "Expecting bvar but got ~A" tag))
 114      (setq v (ml2ma))
 115      (setq tag (get-tag))
 116      (if (not (eq tag 'degree)) (merror "Expecting degree but got ~A" tag))
 117      (setq d (ml2ma))
 118      (get-tag)(get-tag) ;; skip closing tags
 119      (return (list v d))
 120 ))
 121
 122 (defun ml-cn (attributes)
 123 (prog(type number)
 124    (setq type (find-attribute "type" attributes))  ;; always has type
 125    (cond
 126      ((or (equal type "integer") (equal type "float"))
 127       (setq number (get-number)))
 128      ((equal type "constant")
 129       (setq number (coerce (get-token) 'string))
 130       (setq number (mathml-constant-to-maxima-constant number)))
 131      (t
 132        ;; Dunno what we could do here to handle an arbitrary type.
 133        ;; For now, just raise an error.
 134        (merror "Unrecognized type ``%a'' in <cn> tag.~%" type)))
 135    (get-token) ;; skip to >
 136    (return number)))
 137
 138 (defun ml-ci (attributes)
 139 (prog(parse-tyipeek a *parse-stream* type)
 140    (setq type (find-attribute "type" attributes)) ;; may or may not have type
 141    (cond
 142      ((equal type "constant") ;; math constants
 143       (setq a (coerce (get-token) 'string))
 144       (setq a (mathml-constant-to-maxima-constant a)))
 145      (t
 146        ;; normal identifier
 147        (setq a (read-from-string (concatenate 'string "$" (get-token))))))
 148   (get-token) ;; skip to >
 149   (return a)))
 150
 151 (defun mathml-constant-to-maxima-constant (name-string)
 152   (cond
 153     ((equal name-string "&pi;") '$%pi)
 154     ((equal name-string "&ee;") '$%e)
 155     ((equal name-string "&ii;") '$%i)
 156     ((equal name-string "&gamma;") '$%gamma)
 157     (t
 158       (let
 159         ((bare-name (string-left-trim "&" (string-right-trim ";" name-string))))
 160         (read-from-string (concatenate 'string "$" bare-name))))))
 161
 162 (defun get-number()
 163   (let ((s (get-str #\<)))
 164     (if s (read-from-string s))))
 165
 166 ;; returns next non-white non #\> char (or -1?)
 167 (defun next-char ()
 168 (do (c) (nil)      ; Gobble whitespace
 169     (if (member (setq c (tyi *in* -1))
 170            '(#\> #\tab #\space #\linefeed #\return #\page))
 171         nil
 172         (return c)
 173     )
 174 ))
 175
 176 (defun get-tag(&optional (endc #\>))
 177 (prog(tag c)
 178    (setq c (next-char))
 179    (if (not (char= c #\<)) (return nil))
 180    (return (get-atag endc))
 181 ))
 182
 183 (defun get-atag(&optional endc)
 184 (prog(str)
 185     (setq str (get-str endc))
 186     (if (null str) (return nil))
 187     (return
 188       (let*
 189         ((tag+attributes
 190            (split-string str '(#\tab #\space #\linefeed #\return #\page)))
 191          (tag (car tag+attributes))
 192          (attributes (mapcar #'split-attribute (cdr tag+attributes))))
 193         (values (read-from-string tag) attributes)))))
 194
 195 ;; Split "FOO=\"BAR\"" into ("FOO" . "BAR")
 196 (defun split-attribute (attr-string)
 197   (let ((i (position #\= attr-string)))
 198     (if (null i)
 199       (list attr-string)
 200       (let
 201         ((name (subseq attr-string 0 i))
 202          (value (dequotify (subseq attr-string (+ i 1)))))
 203         `(,name . ,value)))))
 204
 205 ;; Remove first character and last characters if the first character
 206 ;; is a single or double quote and last character is the same as the first.
 207 ;; (Do not call STRING-TRIM, because might strip off multiple characters.)
 208
 209 (defun dequotify (s)
 210   (if (or (null s) (< (length s) 2))
 211     s
 212     (let
 213       ((first-char (aref s 0))
 214        (last-char (aref s (1- (length s)))))
 215       (if
 216         (and
 217           (or (eql first-char #\") (eql first-char #\'))
 218           (eql last-char first-char))
 219         (subseq (subseq s 1) 0 (- (length s) 2))
 220         s))))
 221
 222 (defun find-attribute (attr attrs-list)
 223   (cdr (assoc attr attrs-list :test #'equal)))
 224
 225 (defun get-str(&optional endc)
 226 (prog(str)
 227    (setq str (get-token endc))
 228    (if str
 229       (return (coerce str 'string))
 230       (return nil)
 231    )
 232 ))
 233
 234 ;; returns list of chars for next token
 235 (defun get-token (&optional endc)
 236   ; Read at least one char ...
 237   (do ((c (tyi *in* -1) (tyi *in* -1))
 238        (l () (cons c l)))
 239     ((or
 240        (equal c -1)
 241        (and endc (char= c endc))
 242        (and (not endc) (member c '(#\< #\> #\tab #\space #\linefeed #\return #\page))))
 243      (nreverse (or l (ncons (tyi *in* -1)))))))
 244
 245 (defun get-op ()
 246 (prog(op mop opa)
 247     (setq op (get-tag))
 248     (cond ((eq op 'fn)
 249              (setq op (get-str))
 250              (cond ((null op)
 251                 (merror "get-op: invalid null function")
 252              ))
 253              (setq opa (read-from-string op))
 254              (setq opa (get opa 'mmfun))
 255              (get-token)
 256              (if opa (return (list opa)))
 257              (return (list (read-from-string
 258                   (concatenate 'string "$" op))))
 259           )
 260           ((setq proc (get op 'mct-proc))
 261              (setq *special-proc* proc)
 262              (return nil)
 263           )
 264     )
 265     (setq mop (get op 'mmfun))
 266     (if mop (return (list mop))
 267             (return (list op))   ;; should not reach here
 268     )
 269 ))
 270
 271 ;;;(defmacro upcase (operator)
 272 ;;;`(setq operator (intern (string-upcase (string ,operator)))))
 273
 274 (defun set-table (arg)
 275 (prog(a b)
 276   (cond ((equal (length arg) 2)
 277           (setq a (cadadr arg))
 278           (setq b (caadr arg))
 279           (if (stringp a) (setq a (read-from-string a)))
 280           (setf (get a b) (car arg))
 281         )
 282         ((equal (length arg) 3)
 283           (setq arg (cdr arg))
 284           (setq b (car arg) a (cadr arg))
 285           (setq a (cadr a))
 286           (if (stringp a) (setq a (read-from-string a)))
 287           (setf (get a (car b)) (cadr b))
 288         )
 289   )
 290 ))
 291
 292 ;;;;;;;;;;; tables ;;;;;;;;;;;;
 293 ;;(set-table '(%sin  (mmfun "sin/")))
 294 ;;(set-table '(%cos  (mmfun "cos/")))
 295 ;;(set-table '(%tan  (mmfun "tan/")))
 296 ;;(set-table '(%cot  (mmfun "cot/")))
 297 ;;(set-table '(%sec  (mmfun "sec/")))
 298 ;;(set-table '(%csc  (mmfun "csc/")))
 299
 300 ;;(set-table '(%asin  (mmfun "arcsin/")))
 301 ;;(set-table '(%acos  (mmfun "arccos/")))
 302 ;;(set-table '(%atan  (mmfun "arctan/")))
 303 ;;(set-table '(%acot  (mmfun "acot/")))
 304 ;;(set-table '(%asec  (mmfun "asec/")))
 305 ;;(set-table '(%acsc  (mmfun "acsc/")))
 306 ;;(set-table '(%sinh  (mmfun "sinh/")))
 307 ;;(set-table '(%cosh  (mmfun "cosh/")))
 308 ;;(set-table '(%tanh  (mmfun "tanh/")))
 309 ;;(set-table '(%coth  (mmfun "coth/")))
 310 ;;(set-table '(%sech  (mmfun "sec/")))
 311 ;;(set-table '(%csch  (mmfun "csch/")))
 312
 313
 314 ;;(set-table '(%asinh  (mmfun "asinh/")))
 315 ;;(set-table '(%acosh  (mmfun "acosh/")))
 316 ;;(set-table '(%atanh  (mmfun "atanh/")))
 317 ;;(set-table '(%acoth  (mmfun "acoth/")))
 318 ;;(set-table '(%asech  (mmfun "asec/")))
 319 ;;(set-table '(%acsch  (mmfun "acsch/")))
 320
 321 (set-table '(%ln  (mmfun "ln/")))
 322 (set-table '(%log  (mmfun "log/")))
 323
 324 (set-table '($sin  (mmfun "sin/")))
 325 (set-table '($cos  (mmfun "cos/")))
 326 (set-table '($tan  (mmfun "tan/")))
 327 (set-table '($cot  (mmfun "cot/")))
 328 (set-table '($sec  (mmfun "sec/")))
 329 (set-table '($csc  (mmfun "csc/")))
 330
 331 (set-table '($asin  (mmfun "arcsin/")))
 332 (set-table '($acos  (mmfun "arccos/")))
 333 (set-table '($atan  (mmfun "arctan/")))
 334 (set-table '($acot  (mmfun "acot/")))
 335 (set-table '($asec  (mmfun "asec/")))
 336 (set-table '($acsc  (mmfun "acsc/")))
 337
 338 (set-table '($sinh  (mmfun "sinh/")))
 339 (set-table '($cosh  (mmfun "cosh/")))
 340 (set-table '($tanh  (mmfun "tanh/")))
 341 (set-table '($coth  (mmfun "coth/")))
 342 (set-table '($sech  (mmfun "sec/")))
 343 (set-table '($csch  (mmfun "csch/")))
 344
 345 (set-table '($asinh  (mmfun "asinh/")))
 346 (set-table '($acosh  (mmfun "acosh/")))
 347 (set-table '($atanh  (mmfun "atanh/")))
 348 (set-table '($acoth  (mmfun "acoth/")))
 349 (set-table '($asech  (mmfun "asec/")))
 350 (set-table '($acsch  (mmfun "acsch/")))
 351 (set-table '($ln  (mmfun "ln/")))
 352 (set-table '($log  (mmfun "log/")))
 353
 354
 355 ;;;;; containers
 356 ;;(set-table '(mlist (mct-proc mctlist)))
 357 ;;(set-table '($matrix (mct-proc  mctmatrix)))
 358 ;;(set-table '($vector (mct-proc  mctvector)))
 359
 360 ;;;;;;; Operators and functions
 361 (set-table '(mand  (mmfun "and/")))
 362 (set-table '(mor  (mmfun "or/")))
 363 (set-table '(mnot  (mmfun "not/")))
 364 (set-table '($xor  (mmfun "xor/")))
 365
 366 (set-table '(mplus  (mmfun "plus/")))
 367 (set-table '(mminus  (mmfun "minus/")))
 368 ;;(set-table '($minus (mmfun "minus/")))
 369 ;;(set-table '(mdif  (mmfun "minus/")))
 370 (set-table '($remainder  (mmfun "rem/")))
 371 (set-table '($max  (mmfun "max/")))
 372 (set-table '($min  (mmfun "min/")))
 373 (set-table '(mfactorial  (mmfun "factorial/")))
 374 (set-table '(mabs (mmfun "abs/")))
 375 (set-table '(%abs (mct-proc abs)))
 376 ;;(set-table '(mnctimes  (mmfun "times/ type=\"noncommutative\"")))
 377 (set-table '(mtimes  (mmfun "times/")))
 378 (set-table '(mexpt (mmfun "power/")))
 379 (set-table '(mquotient (mmfun "quotient/")))
 380 (set-table '(%sqrt (mmfun "sqrt/")))
 381 (set-table '(mquote  (mmfun "quote/")))
 382
 383 (set-table '(mgreaterp  (mct-proc relation) (mmfun "gt/")))
 384 (set-table '(mgeqp (mct-proc relation)  (mmfun "geq/")))
 385 (set-table '(mequal (mct-proc relation)  (mmfun "eq/")))
 386 (set-table '(mnotequal (mct-proc relation)  (mmfun "neq/")))
 387 (set-table '(mleqp (mct-proc relation)  (mmfun "leq/")))
 388 (set-table '(mlessp (mct-proc relation)  (mmfun "lt/")))
 389
 390 (set-table '(mdefine (mct-proc def-fun)))
 391
 392 (set-table '(msetq  (mmfun "&Assign;")))
 393 ;;(set-table '(mset  (mmfun "&Assign;")))  ;;; This is not math
 394 ;;(set-table '(marrow  (mmfun "&RightArrow;")))
 395 ;;(set-table '(mrarrow  (mmfun "&RightArrow;")))
 396 ;;(set-table '(%at (mct-proc mPr-at)))
 397 ;;(set-table '($at (mct-proc mPr-at)))
 398 ;;(set-table '($det (mct-proc mPr-det)))
 399 ;;(set-table '(%determinant (mct-proc det)))
 400 ;;(set-table '($binomial (mct-proc binomial)))
 401 ;;(set-table '(%binomial (mct-proc binomial)))
 402
 403 (set-table '(%sum (mct-proc sumprod)(mmfun "sum/")))
 404 ;;(set-table '($sum (mct-proc sumprod)(mmfun "sum/")))
 405 ;;(set-table '($product (mct-proc sumprod)(mmfun "product/")))
 406 (set-table '(%product (mct-proc sumprod)(mmfun "product/")))
 407 ;;(set-table '($integrate (mct-proc mctintegrate)(mmfun "int/")))
 408 (set-table '(%integrate (mct-proc mctintegrate)(mmfun "int/")))
 409 (set-table '($diff (mct-proc mctdiff)(mmfun "diff/")))
 410 ;;(set-table '(%derivative (mct-proc mctdiff)(mmfun "diff/")))
 411 (set-table '($limit (mct-proc mctlimit)(mmfun "limit/")))
 412 ;;(set-table '(%limit (mct-proc mctlimit)(mmfun "limit/")))
 413
 414 ;;(set-table '(mprog (mmfun "block")))
 415 ;;(set-table '($block (mmfun "block")))
 416 ;;(set-table '($$boldif (mmfun "if/")))
 417 ;;(set-table '($$boldthen (mmfun "then/")))
 418 ;;(set-table '($$boldelse (mmfun "else/")))
 419