share/contrib/maximaMathML/CtMathML.lisp

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;  Purpose:  Generate MathML Content code from MAXIMA
   4 ;;;  File: CtMathML.lsp
   5 ;;;  Author: Paul S. Wang
   6 ;;;  Date: March 1999
   7 ;;;          (c) copyright 1999  Kent State University
   8 ;;;                    all rights reserved.
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10 ;;
  11 ;; Usage:     compile this file with UNIX command
  12 ;;                %mc CtMathML.lsp
  13 ;;             which produces CtMathML.o
  14 ;;
  15 ;;            load/and link into MAXIMA by MAXIMA top-level command
  16 ;;                loadfile("loadmathml.lsp");
  17 ;;
  18 ;;            Once loaded,  use the command ctmathml(expr [,file])
  19 ;;
  20 ;; Author: Paul S. Wang
  21 ;; Date: 4/99
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23
  24 (in-package :maxima)
  25 (macsyma-module mathml)
  26 (declaim (special lop rop ccol *row *indent* mPrport))
  27
  28
  29 (defmfun $ctmathml (&rest margs)
  30          (prog (ccol *row* *indent* filename
  31                  mexpress mPrport x y lop rop)
  32            (setq lop 'mparen rop 'mparen)
  33            (setq mexpress (car margs))
  34            (setq ccol 1 *indent* 0 *row* t)
  35            (cond
  36              ((null mexpress) (princ " NO EXPRESSION GIVEN ")
  37               (return nil))
  38              ((null (cdr margs)) (setq filename nil) (setq mPrport t))
  39              ((null (cddr margs))
  40               (setq mPrport
  41                     (if (stringp (cadr margs))
  42                       (progn
  43                         (setq filename (cadr margs))
  44                         (open (cadr margs)
  45                             :direction :output
  46                             :if-exists :append
  47                             :if-does-not-exist :create))
  48                       ;; otherwise, assume (cadr margs) is a stream.
  49                       (cadr margs))))
  50              (t (princ " wrong No. of Arguments given ")))
  51            (when (symbolp (setq x mexpress))
  52              (setq x ($verbify x))
  53              (cond
  54                ((setq y (mget x 'mexprer))
  55                 (setq mexpress
  56                       (list '(mdefine) (cons (list x) (cdadr y))
  57                             (caddr y))))
  58                ((setq y (mget x 'mmacro))
  59                 (setq mexpress
  60                       (list '(mdefmacro) (cons (list x) (cdadr y))
  61                             (caddr y))))
  62                ((setq y (mget x 'aexpr))
  63                 (setq mexpress
  64                       (list '(mdefine)
  65                             (cons (list x 'array)
  66                                   (cdadr y))
  67                             (caddr y)))))
  68            ) ;; end of when
  69            (when (and (consp mexpress) (consp (car mexpress))
  70                       (eq 'mlabel (caar mexpress)))
  71                 (setq mexpress (cadr mexpress))
  72            )
  73            (tprinc "<math  xmlns='http://www.w3.org/1998/Math/MathML'>")
  74            (ctmathml (nformat mexpress))  ;;; call engine
  75            (tprinc "</math>")
  76            (when filename (terpri mPrport) (close mPrport))
  77            (return 'done)))
  78
  79 (defun masymbol(op l)
  80 (let ((ans (assoc op  l)))
  81       (if ans (cdr ans) nil)
  82 ))
  83
  84 (defun mpsymbol(op l)
  85    (cond  ((null l) nil)
  86           ((eq op (cdar l)) (caar l))
  87           (t (mpsymbol op (cdr l)))
  88   )
  89 )
  90
  91 (defun ctmathml(exp)
  92   (cond ((atom exp) (a2ml exp))     ;; atoms
  93         ((fractionp exp) nil)       ;; fractional number
  94         ((get (caar exp) 'ct-proc)
  95              (funcall (get (caar exp) 'ct-proc) (caar exp)  (cdr exp)))
  96         ((get (caar exp) 'ctfun)    ;; known function
  97             (op2ml (caar exp) (cdr exp)))
  98         ((member 'array (car exp) :test #'eq)
  99                     (ctarray exp))
 100         ((cpxp exp) nil)      ;; complex number
 101         (t (op2ml (caar exp) (cdr exp)))
 102   )
 103 )
 104
 105 (defun op2ml(op args)
 106 (let ((sym (get op 'ctfun)))
 107   (cond (sym (row-begin "<apply>")
 108              (tprinc "<")(tprinc sym)(tprinc ">")
 109         )
 110         (t (row-begin "<apply>")
 111            (tprinc "<fn>")(tprinc (stripdollar op))
 112            (tprinc "</fn>")
 113         )
 114   )
 115   (mapc (function ctmathml) args)
 116   (row-end "</apply>")
 117 ))
 118
 119 (defun ctarray(a)  ;; subscripted var
 120   (tprinc "<ci>") (row-begin "")(mPr-array a)
 121   (row-end "")
 122   (tprinc "</ci>")
 123 )
 124
 125 (defun a2ml(a)    ;; treat atoms
 126 (prog(val)
 127   (cond ((numberp a)
 128          (tprinc "<cn")
 129          (cond ((or (fixnump a) (bignump a))
 130                 (tprinc " type=\"integer\">"))
 131                ((or (floatp a) (bigfloatp a))
 132                 (tprinc " type=\"float\">"))
 133                 (t (tprinc ">"))
 134          )
 135          (tprinc (princ-to-string a))
 136          (tprinc "</cn>")
 137         )
 138         ((setq val (safe-get a 'chchr))
 139          (cond ((member val '("&pi;" "&gamma;" "&ii;" "&ee;") :test #'equal)
 140                   (tprinc "<cn type=\"constant\">") )
 141                (t (tprinc "<cn>") )
 142          )
 143          (tprinc val) (tprinc "</cn>")
 144         )
 145         (t
 146           (let ((my-atom (if (symbolp a) (print-invert-case (stripdollar a)) a)))
 147             (tprinc "<ci>")
 148             (tprinc (coerce (mapcar #'handle_rsw (rm '// (exploden my-atom))) 'string))
 149             (tprinc "</ci>"))))))
 150
 151 (defun cpxp(a)
 152 (if (among '$%i a)
 153  (let ( (r($realpart a)) (i ($imagpart a)) )
 154   (cond ((and (numberp r) (numberp i))
 155          (tprinc "<cn type=\"complex\">")
 156          (tprinc r) (tprinc "<sep/>")
 157          (tprinc i) (tprinc "</cn>")
 158          t)
 159         (t nil)
 160   )
 161  )
 162 ))
 163
 164 (defun fractionp(a)
 165   (cond ((and (eq (caar a) 'rat)
 166               (integerp (cadr a))
 167               (integerp (caddr a))
 168          )
 169          (tprinc "<cn type=\"rational\">")
 170          (tprinc (cadr a)) (tprinc "<sep/>")
 171          (tprinc (caddr a)) (tprinc "</cn>")
 172          t)
 173         (t nil)
 174   )
 175 )
 176
 177 (defun ctlist(op args)
 178    (tprinc "<list>")
 179    (mapc (function ctmathml) args)
 180    (tprinc "</list>")
 181 )
 182
 183 (defun ctset(op args)
 184   (tprinc "<set>")
 185   (mapc (function ctmathml) args)
 186   (tprinc "</set>"))
 187
 188 (defun matrixrow(args)
 189    (setq args (cdr args))
 190    (row-begin "<matrixrow>")
 191    (mapc (function ctmathml) args)
 192    (row-end "</matrixrow>")
 193 )
 194
 195 (defun ctmatrix(op args)
 196    (row-begin "<matrix>")
 197    (mapc (function matrixrow) args)
 198    (row-end "</matrix>")
 199 )
 200
 201 (defun ctvector(op args)
 202    (tprinc "<vector>")
 203    (mapc (function ctmathml) args)
 204    (tprinc "</vector>")
 205 )
 206
 207 (defun relation(op args)
 208 (let ((sym (get op 'ctfun)))
 209    (row-begin "<reln>") (tprinc "<")(tprinc sym)(tprinc ">")
 210    (mapc (function ctmathml) args)
 211    (row-end "</reln>")
 212 ))
 213
 214 (defun sumprod(op args)
 215    (cond ((equal (length args) 4)
 216           (let ((sym (get op 'ctfun))
 217                 (exp (car args)) (var (cadr args))
 218                 (ll (caddr args)) (ul (cadddr args)))
 219                (row-begin "<apply>")
 220                (tprinc "<")(tprinc sym)(tprinc ">")
 221                (tprinc "<bvar>")(ctmathml var)(tprinc "</bvar>")
 222                (setq ll (nformat (meval
 223                  (list '($substitute) '((mminus) $inf) '$minf ll))))
 224                (tprinc "<lowlimit>")(ctmathml ll)(tprinc "</lowlimit>")
 225                (myterpri)
 226                (setq ul (nformat (meval
 227                  (list '($substitute) '((mminus) $inf) '$minf ul))))
 228                (tprinc "<uplimit>")(ctmathml ul)(tprinc "</uplimit>")
 229                (ctmathml exp)
 230                (row-end "</apply>")
 231           ))
 232           (t (tprinc "sumprod: Wrong args")))
 233 )
 234
 235 (defun ctlimit(op args)
 236 (let ((sym (get op 'ctfun)) (f (car args))
 237       (v (cadr args)) (p (caddr args)))
 238      (setq args (cdddr args))
 239      (row-begin "<apply>")
 240      (tprinc "<")(tprinc sym)(tprinc ">")
 241      (tprinc "<bvar>")(ctmathml v)(tprinc "</bvar>")
 242      (setq p (nformat (meval
 243        (list '($substitute) '((mminus) $inf) '$minf p))))
 244      (tprinc "<lowlimit>")(ctmathml p)(tprinc "</lowlimit>")
 245      (myterpri)
 246      (cond (args (row-begin "<condition>")
 247                  (cond ((eq (car args) '$plus)
 248                         (relation 'mgreaterp (list v 0)))
 249                        (t (relation 'mgreaterp (list v 0)))
 250                  )
 251                  (row-end "</condition>")
 252      ))
 253      (ctmathml f)(row-end "</apply>")
 254 ))
 255
 256 (defun ctdiff(op args)
 257 (let ((sym (get op 'ctfun)) (f (car args)))
 258    (setq args (cdr args))
 259    (row-begin "<apply>")
 260    (tprinc "<")(tprinc sym)(tprinc ">")
 261    (ctmathml f)
 262    (cond ((equal (length args)  1)
 263           (tprinc "<bvar>")(ctmathml (car args))
 264           (tprinc "</bvar>")
 265          )
 266          (t (do ((vl args (cddr vl)))
 267                 ((null vl) nil)
 268                 (diffvar (car vl) (cadr vl))
 269          ))
 270    )
 271    (row-end "</apply>")
 272 ))
 273
 274 (defun diffvar(v d)
 275   (tprinc "<bvar>")(ctmathml v)
 276   (tprinc "<degree>") (ctmathml d)
 277   (tprinc "</degree>")
 278   (tprinc "</bvar>")
 279   (myterpri)
 280 )
 281
 282 (defun ctintegrate(op args)
 283    (cond ((equal (length args)  4)
 284           (sumprod op args))
 285          (t (let ((sym (get op 'ctfun))
 286                   (exp (car args)) (var (cadr args)))
 287                (row-begin "<apply>")
 288                (tprinc "<")(tprinc sym)(tprinc ">")
 289                (tprinc "<bvar>")(ctmathml var)(tprinc "</bvar>")
 290                (ctmathml exp)
 291                (row-end "</apply>")
 292             ))
 293 ))
 294
 295
 296 (defun lamd(vars def)
 297   (row-begin "<lambda>")
 298   (do ((l vars (cdr l)))
 299       ((null l) nil)
 300       (tprinc "<bvar>")(ctmathml (car l)) (tprinc "</bvar>")
 301   )
 302   (ctmathml def)
 303   (row-end "</lambda>")
 304 )
 305
 306 (defun def-fun (op args)
 307 (let ((fn (car args)) (def (cadr args)))
 308     (row-begin "<declare type=\"fn\">")
 309     (ctmathml (caar fn))
 310     (lamd (cdr fn) def)
 311     (row-end "</declare>")
 312 ))
 313
 314 ;;;;;;;;;;; tables ;;;;;;;;;;;;
 315 (setup '(%sin  (ctfun "sin/")))
 316 (setup '(%cos  (ctfun "cos/")))
 317 (setup '(%tan  (ctfun "tan/")))
 318 (setup '(%cot  (ctfun "cot/")))
 319 (setup '(%sec  (ctfun "sec/")))
 320 (setup '(%csc  (ctfun "csc/")))
 321
 322 (setup '(%asin  (ctfun "arcsin/")))
 323 (setup '(%acos  (ctfun "arccos/")))
 324 (setup '(%atan  (ctfun "arctan/")))
 325 (setup '(%acot  (ctfun "acot/")))
 326 (setup '(%asec  (ctfun "asec/")))
 327 (setup '(%acsc  (ctfun "acsc/")))
 328 (setup '(%sinh  (ctfun "sinh/")))
 329 (setup '(%cosh  (ctfun "cosh/")))
 330 (setup '(%tanh  (ctfun "tanh/")))
 331 (setup '(%coth  (ctfun "coth/")))
 332 (setup '(%sech  (ctfun "sec/")))
 333 (setup '(%csch  (ctfun "csch/")))
 334
 335
 336 (setup '(%asinh  (ctfun "asinh/")))
 337 (setup '(%acosh  (ctfun "acosh/")))
 338 (setup '(%atanh  (ctfun "atanh/")))
 339 (setup '(%acoth  (ctfun "acoth/")))
 340 (setup '(%asech  (ctfun "asec/")))
 341 (setup '(%acsch  (ctfun "acsch/")))
 342
 343 (setup '(%ln  (ctfun "ln/")))
 344 (setup '(%log  (ctfun "log/")))
 345
 346 (setup '($sin  (ctfun "sin/")))
 347 (setup '($cos  (ctfun "cos/")))
 348 (setup '($tan  (ctfun "tan/")))
 349 (setup '($cot  (ctfun "cot/")))
 350 (setup '($sec  (ctfun "sec/")))
 351 (setup '($csc  (ctfun "csc/")))
 352
 353 (setup '($asin  (ctfun "arcsin/")))
 354 (setup '($acos  (ctfun "arccos/")))
 355 (setup '($atan  (ctfun "arctan/")))
 356 (setup '($acot  (ctfun "acot/")))
 357 (setup '($asec  (ctfun "asec/")))
 358 (setup '($acsc  (ctfun "acsc/")))
 359
 360 (setup '($sinh  (ctfun "sinh/")))
 361 (setup '($cosh  (ctfun "cosh/")))
 362 (setup '($tanh  (ctfun "tanh/")))
 363 (setup '($coth  (ctfun "coth/")))
 364 (setup '($sech  (ctfun "sec/")))
 365 (setup '($csch  (ctfun "csch/")))
 366
 367 (setup '($asinh  (ctfun "asinh/")))
 368 (setup '($acosh  (ctfun "acosh/")))
 369 (setup '($atanh  (ctfun "atanh/")))
 370 (setup '($acoth  (ctfun "acoth/")))
 371 (setup '($asech  (ctfun "asec/")))
 372 (setup '($acsch  (ctfun "acsch/")))
 373 (setup '($ln  (ctfun "ln/")))
 374 (setup '($log  (ctfun "log/")))
 375
 376
 377 ;;;;; containers
 378 (setup '(mlist (ct-proc ctlist)))
 379 (setup '($set (ct-proc ctset)))
 380 (setup '($matrix (ct-proc  ctmatrix)))
 381 (setup '($vector (ct-proc  ctvector)))
 382
 383 ;;;;;;; Operators and functions
 384 (setup '(mand  (ctfun "and/")))
 385 (setup '(mor  (ctfun "or/")))
 386 (setup '(mnot  (ctfun "not/")))
 387 (setup '($xor  (ctfun "xor/")))
 388
 389 (setup '(mplus  (ctfun "plus/")))
 390 (setup '($plus (ctfun "plus/")))
 391 (setup '(mminus  (ctfun "minus/")))
 392 (setup '($minus (ctfun "minus/")))
 393 (setup '(mdif  (ctfun "minus/")))
 394 (setup '($remainder  (ctfun "rem/")))
 395 (setup '($max  (ctfun "max/")))
 396 (setup '($min  (ctfun "min/")))
 397 (setup '(mfactorial  (ctfun "factorial/")))
 398 (setup '(mabs (ctfun "abs/")))
 399 (setup '(%abs (ct-proc abs)))
 400 (setup '($conjugate (ctfun "conjugate/")))
 401 (setup '(mnctimes  (ctfun "times type=\"noncommutative\"/")))
 402 (setup '(mtimes  (ctfun "times/")))
 403 (setup '(mexpt (ctfun "power/")))
 404 ;;(setup '(mdottimes (ctfun "&CenterDot;")))
 405 (setup '(mquotient (ctfun "divide/")))
 406 (setup '(rat (ct-proc rat)))
 407 (setup '($sqrt (ctfun "root/")))
 408 (setup '(%sqrt (ctfun "root/")))
 409
 410 (setup '(mquote  (ctfun "quote/")))
 411
 412
 413 (setup '(mgreaterp  (ct-proc relation) (ctfun "gt/")))
 414 (setup '(mgeqp (ct-proc relation)  (ctfun "geq/")))
 415 (setup '(mequal (ct-proc relation)  (ctfun "eq/")))
 416 (setup '(mnotequal (ct-proc relation)  (ctfun "neq/")))
 417 (setup '(mleqp (ct-proc relation)  (ctfun "leq/")))
 418 (setup '(mlessp (ct-proc relation)  (ctfun "lt/")))
 419
 420 (setup '(mdefine (ct-proc def-fun)))
 421
 422 ;;(setup '(msetq  (ctfun "&Assign;")))
 423 ;;(setup '(mset  (ctfun "&Assign;")))  ;;; This is not math
 424 ;;(setup '(marrow  (ctfun "&RightArrow;")))
 425 ;;(setup '(mrarrow  (ctfun "&RightArrow;")))
 426 ;;(setup '(%at (ct-proc mPr-at)))
 427 ;;(setup '($at (ct-proc mPr-at)))
 428 ;;(setup '($det (ct-proc mPr-det)))
 429 ;;(setup '(%determinant (ct-proc det)))
 430 ;;(setup '($binomial (ct-proc binomial)))
 431 ;;(setup '(%binomial (ct-proc binomial)))
 432
 433 (setup '(%sum (ct-proc sumprod)(ctfun "sum/")))
 434 (setup '($sum (ct-proc sumprod)(ctfun "sum/")))
 435 (setup '($product (ct-proc sumprod)(ctfun "product/")))
 436 (setup '(%product (ct-proc sumprod)(ctfun "product/")))
 437 (setup '($integrate (ct-proc ctintegrate)(ctfun "int/")))
 438 (setup '(%integrate (ct-proc ctintegrate)(ctfun "int/")))
 439 (setup '($diff (ct-proc ctdiff)(ctfun "diff/")))
 440 (setup '(%derivative (ct-proc ctdiff)(ctfun "diff/")))
 441 (setup '($limit (ct-proc ctlimit)(ctfun "limit/")))
 442 (setup '(%limit (ct-proc ctlimit)(ctfun "limit/")))
 443
 444 ;;(setup '(mprog (ctfun "block")))
 445 ;;(setup '($block (ctfun "block")))
 446 ;;(setup '($$boldif (ctfun "if/")))
 447 ;;(setup '($$boldthen (ctfun "then/")))
 448 ;;(setup '($$boldelse (ctfun "else/")))