123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922 |
- %==========================================================================%
- % GRGprin.sl Output Routines %
- %==========================================================================%
- % GRG 3.2 Standard Lisp Source Code (C) 1988-96 Vadim V. Zhytnikov %
- %==========================================================================%
- % This file is distributed without any warranty. You may modify it but you %
- % are not allowed to remove author's name and/or distribute modified file. %
- %==========================================================================%
- %----- REDUCE algebraic expression printing -----------------------------
- % Algebraic Expressions Printing ...
- (de algpri!> (w)
- (cond ((getd 'assgnpri) (assgnpri w nil nil))
- (t (varpri w nil nil))))
- % TERPRI for algebraic expressions ...
- (de algterpri!> nil
- (cond ((getd 'assgnpri) (assgnpri "" nil t))
- (t (varpri "" nil t))))
- % Plain print list without spaces and () ...
- (de algrpril!> (lst) (mapc lst 'algrpri!>))
- % Print list without () with Special treatment
- % of strings and spaces ...
- (de algprinwb!> (lst)
- (foreach!> x on lst do
- (prog2
- (cond
- ((stringp(car x)) (progn (algpri!> '!" )
- (algpri!> (car x) )
- (algpri!> '!" )))
- ((atom(car x)) (algpri!> (car x) ))
- (t(progn
- (algpri!> '!( )
- (algprinwb!>(car x))
- (algpri!> '!) ) )))
- (cond((and x (cdr x) (atom(cadr x))
- (not(or (flagp (cadr x) '!+nonsp)
- (flagp (car x) '!+nonsp))))
- (algpri!> " " ))))))
- %----- Print Functions with Linelength check ---------------------------
- (de gterpri!> nil
- (progn
- (cond(![line!] (gterpri0!> ![line!])))
- (terpri)
- (setq ![gpfirst!] nil)
- (setq ![line!] nil)
- (setq ![lline!] 0) ))
- (de gterpri0!> (lst)
- (cond
- ((null(cdr lst)) (prin2(car lst)))
- (t (prog2 (gterpri0!>(cdr lst)) (prin2(car lst))))))
- (de gprinreset!> nil
- (progn (setq ![lline!] 0)
- (setq ![line!] nil)
- (setq ![gpfirst!] t)
- (setq ![gptab!] 0) ))
- (de gprin!> (w)
- (cond
- ((pairp w) (progn (gprin!> "(") (mapcar w 'gprin!>) (gprin!> ")")))
- (t(prog (wc wl)
- (setq wl (difference (linelength nil) spare!*))
- (setq wc (length(explode2 w)))
- (cond
- ((lessp (plus2 ![lline!] wc) wl) (progn
- (cond
- ((and(null ![line!])(not ![gpfirst!])) (progn
- (spaces ![gptab!])
- (setq ![lline!] ![gptab!]))))
- (cond % We skip '! in the beginning of line (but not " ") ...
- ((not(and (null ![line!]) (seprp w))) (prog2
- (setq ![line!] (cons w ![line!]))
- (setq ![lline!] (plus2 ![lline!] wc)) )))))
- (t(progn
- (gterpri!>)
- (cond((not(seprp w))(progn
- (spaces ![gptab!])
- (setq ![lline!] (plus2 ![gptab!] wc))
- (setq ![line!] (ncons w))))))))))))
- % Print list without () by GPRIN> with Special treatment
- % of strings and spaces ...
- (de gprinwb!> (lst) (gprinwb0!> lst 0))
- (de gprinwb0!> (lst wl)
- (foreach!> x on lst do
- (prog2
- (cond
- ((stringp(car x)) (progn
- (gprin!> '!")
- (gprin!>(car x))
- (gprin!> '!") ))
- ((atom(car x)) (gprin!>(car x)))
- (t(progn
- (gprin!> '!( )
- (gprinwb0!> (car x) (add1 wl))
- (gprin!> '!) ) )))
- (cond ((and x (cdr x) (atom(cadr x))
- (not(or (flagp (cadr x) '!+nonsp)
- (flagp (car x) '!+nonsp))))
- (gprin!> '! )))
- (cond ((and (eq (car x) '!,) (zerop wl)) (gprin!> '! )))
- )))
- % Prints simply spaced list of atoms without ()
- (de gprils!> (lst)
- (while!> lst
- (gprin!>(car lst)) (gprin!> '! )
- (setq lst (cdr lst))))
- % Prints simply spaced list of atoms without ()
- % and without last trailing space
- (de gprils0!> (lst)
- (while!> lst
- (gprin!> (car lst))
- (cond ((cdr lst) (gprin!> '! )))
- (setq lst (cdr lst))))
- (de gprils0dot!> (lst)
- (while!> lst
- (gprin!> (cond ((cdr lst) (car lst))
- (t (incom!> (append (explode2(car lst)) '(!! !.))))))
- (cond ((cdr lst) (gprin!> '! )))
- (setq lst (cdr lst))))
- (de gpris!> nil (gprin!> '! ))
- % Prints concatenated list of atoms
- (de gpril!> (lst)
- (while!> lst
- (gprin!>(car lst))
- (setq lst (cdr lst))))
- % Function Print
- (de gfnpri!> (lst)
- (progn (gprin!> (car lst))
- (cond ((get (car lst) 'generic!_function) (gprin!> "*")))
- (gprin!> "(")
- (gfnpri0!> (cdr lst))
- (gprin!> ")") ))
- (de gfnpri0!> (lst)
- (cond((null(cdr lst)) (gprin!>(car lst)))
- (t(progn (gprin!>(car lst))(gprin!> ",")(gfnpri0!>(cdr lst))))))
- %---------- Output Switches Management ---------------------------------
- % Fancy/LaTeX (FT) switcses: FANCY LATEX
- % Output (O) switches: GRG REDUCE MAPLE MATH MACSYMA
- % FT mode is defined by *FANCY=T (FANCYON>)
- % latex mode is defined by *latex=T
- % This detects O output mode ...
- (de ifmodo!> nil (or !*grg !*reduce !*maple !*math !*macsyma))
- % This detects existence of fancy mode in REDUCE
- (de fancyexist!> nil (flagp 'fancy 'switch))
- (de fancyloaded!> nil (getd 'fmp!-switch))
- (de fancyon!> nil
- (and (or(fluidp '!*fancy)(globalp '!*fancy)) (eval '!*fancy)))
- (de tunefancy!> (bool)
- (cond(bool(progn
- (cond((or (fluidp '!*fancy!-lower) (globalp '!*fancy!-lower))
- (set '!*fancy!-lower nil))
- (t(msg!> 9100)))
- (cond ((not ![fldtuned!]) (fldtune!>)))
- (onoff2!> 'latex nil)
- (set 'fancy!-switch!-on!* (int2id 16))
- (set 'fancy!-switch!-off!* (int2id 17))
- (onfancydefs!>)
- (offothero!> nil)))
- (t(offallo!>))))
- (de tunetex!> (bool)
- (prog nil
- (cond ((not(fancyexist!>)) (loadpack!> '(fmprint) nil)))
- (cond ((not(fancyexist!>))
- (progn (msg!> 9101)
- (msg!> 91011)
- (msg!> 91012)
- (msg!> 91013)
- (msg!> 91014)
- (setq !*latex nil)
- (return nil))))
- (cond(bool(progn
- (on fancy)
- (cond((or (fluidp '!*fancy!-lower) (globalp '!*fancy!-lower))
- (set '!*fancy!-lower nil))
- (t (progn (msg!> 9100)
- (msg!> 91011)
- (msg!> 91012)
- (msg!> 91013)
- (msg!> 91014) )))
- (cond ((not ![fldtuned!]) (fldtune!>)))
- (set 'fancy!-switch!-on!* '!$)
- (set 'fancy!-switch!-off!* '!$)
- (ontexdefs!>)
- (offothero!> nil)))
- (t(progn
- (offothero!> nil)
- (set 'fancy!-switch!-on!* (int2id 16))
- (set 'fancy!-switch!-off!* (int2id 17))
- (onfancydefs!>) )))))
- (de fldtune!> nil
- (progn
- (setq ![fldtuned!] t)
- (copyd 'oldfld!> 'fancy!-lower!-digits)
- (remd 'fancy!-lower!-digits)
- (copyd 'fancy!-lower!-digits 'fancylowerdigits!>)
- ))
- (de fancylowerdigits!> (u)
- (prog (w wa wn wz wr)
- (setq w (reverse u))
- % Last symbol is ~ ?
- (cond ((eq (car w) '!~) (setq wz t) (setq w (cdr w))))
- % Selecting digits ...
- lab1
- (cond ((or (null w) (not(digit(car w)))) (go lab2)))
- (setq wn (cons (car w) wn))
- (setq w (cdr w))
- (go lab1)
- lab2
- % Atom itself
- (setq w (reverse w))
- (setq wa (intern(compress w)))
- % Symbol is special
- (cond
- ((setq wa (get wa 'fancy!-special!-symbol))
- (cond
- ((stringp wa) (setq w (explode2 wa)))
- (t (setq w (append '(!\ !s !y !m !b !{)
- (append (explode2 wa) '(!}))))))))
- (cond
- (!*latex % latex mode: usinge \dot{}
- (cond
- (wz (setq w (append '( !\ !d !o !t !{ ) (append w '( !} ))))))
- (cond
- (wn (setq wr (append w (append '( !_ !{ ) (append wn '( !} ))))))
- (t (setq wr w))))
- (t(cond % FANCY mode: using ' for conjugation
- ((and wz wn)
- (setq wr (append w (append '( !' !_ !{ ) (append wn '( !} ))))))
- (wz (setq wr (append w '( !' ))))
- (wn (setq wr (append w (append '( !_ !{ ) (append wn '( !} ))))))
- (t (setq wr w)))))
- (return wr)))
- (de tunedfindexed!> (bool)
- (cond ((or (globalp 'fancy!_print!_df) (fluidp 'fancy!_print!_df))
- (cond (bool (set 'fancy!_print!_df 'indexed))
- (t (set 'fancy!_print!_df 'partial))))))
- (de tunegrg!> (bool)
- (cond(bool(progn
- (offft!>)
- (offothero!> 'grg)))
- (t(offallo!>))))
- (de tunereduce!> (bool)
- (cond(bool(progn
- (offft!>)
- (offothero!> 'reduce)))
- (t(offallo!>))))
- (de tunemaple!> (bool)
- (cond(bool(progn
- (offft!>)
- (offothero!> 'maple)))
- (t(offallo!>))))
- (de tunemath!> (bool)
- (cond(bool(progn
- (offft!>)
- (offothero!> 'math)))
- (t(offallo!>))))
- (de tunemacsyma!> (bool)
- (cond(bool(progn
- (offft!>)
- (offothero!> 'macsyma)))
- (t(offallo!>))))
- % Offs All O-switches exept WSS ...
- (de offothero!> (wss)
- (proc (w)
- (setq w ![flaglo!])
- (while!> w
- (cond((not(eq (car w) wss))
- (onoff2!> (car w) nil)))
- (setq w (cdr w)))))
- % Offs FT-switces ...
- (de offft!> nil
- (progn
- (cond(!*latex (onoff2!> 'latex nil)))
- (cond((fancyon!>)(off fancy)))))
- % Offs all FT and O-switches ...
- (de offallo!> nil
- (prog2 (offft!>) (offothero!> nil)))
- (de ontexdefs!> nil
- (progn
- (put '!#!#lr 'fancy!-special!-symbol "{}")
- (put '!#!#e 'fancy!-special!-symbol "e")
- (put '!#!#b 'fancy!-special!-symbol "b")
- (put '!#!#p 'fancy!-special!-symbol "\partial")
- (flag '(!#!#e !#!#p) 'print!-indexed)
- (put 'e 'fancy!-special!-symbol "e")
- (put 'i 'fancy!-special!-symbol "i")
- (put '!a!l!p!h!a 'fancy!-special!-symbol "\alpha")
- (remprop '!A!L!P!H!A 'fancy!-special!-symbol)
- (put '!b!e!t!a 'fancy!-special!-symbol "\beta")
- (remprop '!B!E!T!A 'fancy!-special!-symbol)
- (put '!g!a!m!m!a 'fancy!-special!-symbol "\gamma")
- (put '!G!A!M!M!A 'fancy!-special!-symbol "\Gamma")
- (put '!G!a!m!m!a 'fancy!-special!-symbol "\Gamma")
- (put '!d!e!l!t!a 'fancy!-special!-symbol "\delta")
- (put '!D!E!L!T!A 'fancy!-special!-symbol "\Delta")
- (put '!D!e!l!t!a 'fancy!-special!-symbol "\Delta")
- (put '!e!p!s!i!l!o!n 'fancy!-special!-symbol "\epsilon")
- (remprop '!E!P!S!I!L!O!N 'fancy!-special!-symbol)
- (put '!z!e!t!a 'fancy!-special!-symbol "\zeta")
- (remprop '!Z!E!T!A 'fancy!-special!-symbol)
- (put '!e!t!a 'fancy!-special!-symbol "\eta")
- (remprop '!E!T!A 'fancy!-special!-symbol)
- (put '!t!h!e!t!a 'fancy!-special!-symbol "\theta")
- (put '!T!H!E!T!A 'fancy!-special!-symbol "\Theta")
- (put '!T!h!e!t!a 'fancy!-special!-symbol "\Theta")
- (put '!i!o!t!a 'fancy!-special!-symbol "\iota")
- (remprop '!I!O!T!A 'fancy!-special!-symbol)
- (put '!k!a!p!p!a 'fancy!-special!-symbol "\kappa")
- (remprop '!K!A!P!P!A 'fancy!-special!-symbol)
- (put '!l!a!m!b!d!a 'fancy!-special!-symbol "\lambda")
- (put '!L!A!M!B!D!A 'fancy!-special!-symbol "\Lambda")
- (put '!L!a!m!b!d!a 'fancy!-special!-symbol "\Lambda")
- (put '!m!u 'fancy!-special!-symbol "\mu")
- (remprop '!M!U 'fancy!-special!-symbol)
- (put '!n!u 'fancy!-special!-symbol "\nu")
- (remprop '!N!U 'fancy!-special!-symbol)
- (put '!x!i 'fancy!-special!-symbol "\xi")
- (put '!X!I 'fancy!-special!-symbol "\Xi")
- (put '!X!i 'fancy!-special!-symbol "\Xi")
- (put '!p!i 'fancy!-special!-symbol "\pi")
- (put '!P!I 'fancy!-special!-symbol "\pi")
- (put '!P!i 'fancy!-special!-symbol "\Pi")
- (put '!r!h!o 'fancy!-special!-symbol "\rho")
- (remprop '!R!H!O 'fancy!-special!-symbol)
- (put '!s!i!g!m!a 'fancy!-special!-symbol "\sigma")
- (put '!S!I!G!M!A 'fancy!-special!-symbol "\Sigma")
- (put '!S!i!g!m!a 'fancy!-special!-symbol "\Sigma")
- (put '!t!a!u 'fancy!-special!-symbol "\tau")
- (remprop '!T!A!U 'fancy!-special!-symbol)
- (put '!u!p!s!i!l!o!n 'fancy!-special!-symbol "\upsilon")
- (put '!U!P!S!I!L!O!N 'fancy!-special!-symbol "\Upsilon")
- (put '!U!p!s!i!l!o!n 'fancy!-special!-symbol "\Upsilon")
- (put '!p!h!i 'fancy!-special!-symbol "\phi")
- (put '!P!H!I 'fancy!-special!-symbol "\Phi")
- (put '!P!h!i 'fancy!-special!-symbol "\Phi")
- (put '!c!h!i 'fancy!-special!-symbol "\chi")
- (remprop '!C!H!I 'fancy!-special!-symbol)
- (put '!p!s!i 'fancy!-special!-symbol "\psi")
- (put '!P!S!I 'fancy!-special!-symbol "\Psi")
- (put '!P!s!i 'fancy!-special!-symbol "\Psi")
- (put '!o!m!e!g!a 'fancy!-special!-symbol "\omega")
- (put '!O!M!E!G!A 'fancy!-special!-symbol "\Omega")
- (put '!O!m!e!g!a 'fancy!-special!-symbol "\Omega")
- (put 'infinity 'fancy!-special!-symbol "\infty")
- (put 'partial!-df 'fancy!-special!-symbol "\partial")
- (remflag '(!D!E!L!T!A !d!e!l!t!a) 'PRINT!-INDEXED)
- (put 'sin 'fancy!-functionsymbol "\sin")
- (put 'sinh 'fancy!-functionsymbol "\sinh")
- (put 'asin 'fancy!-functionsymbol "\arcsin")
- (put 'asinh 'fancy!-functionsymbol "arcsinh")
- (put 'cos 'fancy!-functionsymbol "\cos")
- (put 'cosh 'fancy!-functionsymbol "\cosh")
- (put 'acos 'fancy!-functionsymbol "\arccos")
- (put 'acosh 'fancy!-functionsymbol "arccosh")
- (put 'tan 'fancy!-functionsymbol "\tan")
- (put 'tanh 'fancy!-functionsymbol "\tanh")
- (put 'atan 'fancy!-functionsymbol "\arctan")
- (put 'atanh 'fancy!-functionsymbol "arctanh")
- (put 'cot 'fancy!-functionsymbol "\cot")
- (put 'coth 'fancy!-functionsymbol "\coth")
- (put 'acot 'fancy!-functionsymbol "arccot")
- (put 'acoth 'fancy!-functionsymbol "arccoth")
- (put 'sec 'fancy!-functionsymbol "\sec")
- (put 'sech 'fancy!-functionsymbol "sech")
- (put 'asec 'fancy!-functionsymbol "arcsec")
- (put 'asech 'fancy!-functionsymbol "arcsech")
- (put 'csc 'fancy!-functionsymbol "\csc")
- (put 'csch 'fancy!-functionsymbol "csch")
- (put 'acsc 'fancy!-functionsymbol "arccsc")
- (put 'acsch 'fancy!-functionsymbol "arccsch")
- (put 'ln 'fancy!-functionsymbol "\ln")
- (put 'log 'fancy!-functionsymbol "\log")
- ))
- (DE ONFANCYDEFS!> NIL
- (PROGN
- (put '!#!#lr 'fancy!-special!-symbol "{}")
- (put '!#!#e 'fancy!-special!-symbol "e")
- (put '!#!#b 'fancy!-special!-symbol "b")
- (put '!#!#p 'fancy!-special!-symbol 182)
- (flag '(!#!#e !#!#p) 'print!-indexed)
- (put 'e 'fancy!-special!-symbol "e")
- (put 'i 'fancy!-special!-symbol "i")
- (put '!a!l!p!h!a 'fancy!-special!-symbol "\alpha")
- (remprop '!A!L!P!H!A 'fancy!-special!-symbol)
- (put '!b!e!t!a 'fancy!-special!-symbol "\beta")
- (remprop '!B!E!T!A 'fancy!-special!-symbol)
- (put '!g!a!m!m!a 'fancy!-special!-symbol "\gamma")
- (put '!G!A!M!M!A 'fancy!-special!-symbol 71)
- (put '!G!a!m!m!a 'fancy!-special!-symbol 71)
- (put '!d!e!l!t!a 'fancy!-special!-symbol "\delta")
- (put '!D!E!L!T!A 'fancy!-special!-symbol 68)
- (put '!D!e!l!t!a 'fancy!-special!-symbol 68)
- (put '!e!p!s!i!l!o!n 'fancy!-special!-symbol "\epsilon")
- (remprop '!E!P!S!I!L!O!N 'fancy!-special!-symbol)
- (put '!z!e!t!a 'fancy!-special!-symbol "\zeta")
- (remprop '!Z!E!T!A 'fancy!-special!-symbol)
- (put '!e!t!a 'fancy!-special!-symbol "\eta")
- (remprop '!E!T!A 'fancy!-special!-symbol)
- (put '!t!h!e!t!a 'fancy!-special!-symbol "\theta")
- (put '!T!H!E!T!A 'fancy!-special!-symbol 81)
- (put '!T!h!e!t!a 'fancy!-special!-symbol 81)
- (put '!i!o!t!a 'fancy!-special!-symbol "\iota")
- (remprop '!I!O!T!A 'fancy!-special!-symbol)
- (put '!k!a!p!p!a 'fancy!-special!-symbol "\kappa")
- (remprop '!K!A!P!P!A 'fancy!-special!-symbol)
- (put '!l!a!m!b!d!a 'fancy!-special!-symbol "\lambda")
- (put '!L!A!M!B!D!A 'fancy!-special!-symbol 76)
- (put '!L!a!m!b!d!a 'fancy!-special!-symbol 76)
- (put '!m!u 'fancy!-special!-symbol "\mu")
- (remprop '!M!U 'fancy!-special!-symbol)
- (put '!n!u 'fancy!-special!-symbol "\nu")
- (remprop '!N!U 'fancy!-special!-symbol)
- (put '!x!i 'fancy!-special!-symbol "\xi")
- (put '!X!I 'fancy!-special!-symbol 88)
- (put '!X!i 'fancy!-special!-symbol 88)
- (put '!p!i 'fancy!-special!-symbol "\pi")
- (put '!P!I 'fancy!-special!-symbol "\pi")
- (put '!P!i 'fancy!-special!-symbol 80)
- (put '!r!h!o 'fancy!-special!-symbol "\rho")
- (remprop '!R!H!O 'fancy!-special!-symbol)
- (put '!s!i!g!m!a 'fancy!-special!-symbol "\sigma")
- (put '!S!I!G!M!A 'fancy!-special!-symbol 83)
- (put '!S!i!g!m!a 'fancy!-special!-symbol 83)
- (put '!t!a!u 'fancy!-special!-symbol "\tau")
- (remprop '!T!A!U 'fancy!-special!-symbol)
- (put '!u!p!s!i!l!o!n 'fancy!-special!-symbol "\upsilon")
- (put '!U!P!S!I!L!O!N 'fancy!-special!-symbol 161)
- (put '!U!p!s!i!l!o!n 'fancy!-special!-symbol 161)
- (put '!p!h!i 'fancy!-special!-symbol "\phi")
- (put '!P!H!I 'fancy!-special!-symbol 70)
- (put '!P!h!i 'fancy!-special!-symbol 70)
- (put '!c!h!i 'fancy!-special!-symbol "\chi")
- (remprop '!C!H!I 'fancy!-special!-symbol)
- (put '!p!s!i 'fancy!-special!-symbol "\psi")
- (put '!P!S!I 'fancy!-special!-symbol 89)
- (put '!P!s!i 'fancy!-special!-symbol 89)
- (put '!o!m!e!g!a 'fancy!-special!-symbol "\omega")
- (put '!O!M!E!G!A 'fancy!-special!-symbol 87)
- (put '!O!m!e!g!a 'fancy!-special!-symbol 87)
- (put 'infinity 'fancy!-special!-symbol "\infty")
- (put 'partial!-df 'fancy!-special!-symbol 182)
- (remflag '(!D!E!L!T!A !d!e!l!t!a) 'PRINT!-INDEXED)
- (put 'sin 'fancy!-functionsymbol "sin")
- (put 'sinh 'fancy!-functionsymbol "sinh")
- (put 'asin 'fancy!-functionsymbol "asin")
- (put 'asinh 'fancy!-functionsymbol "asinh")
- (put 'cos 'fancy!-functionsymbol "cos")
- (put 'cosh 'fancy!-functionsymbol "cosh")
- (put 'acos 'fancy!-functionsymbol "acos")
- (put 'acosh 'fancy!-functionsymbol "acosh")
- (put 'tan 'fancy!-functionsymbol "tan")
- (put 'tanh 'fancy!-functionsymbol "tanh")
- (put 'atan 'fancy!-functionsymbol "atan")
- (put 'atanh 'fancy!-functionsymbol "atanh")
- (put 'cot 'fancy!-functionsymbol "cot")
- (put 'coth 'fancy!-functionsymbol "coth")
- (put 'acot 'fancy!-functionsymbol "acot")
- (put 'acoth 'fancy!-functionsymbol "acoth")
- (put 'sec 'fancy!-functionsymbol "sec")
- (put 'sech 'fancy!-functionsymbol "sech")
- (put 'asec 'fancy!-functionsymbol "asec")
- (put 'asech 'fancy!-functionsymbol "asech")
- (put 'csc 'fancy!-functionsymbol "csc")
- (put 'csch 'fancy!-functionsymbol "csch")
- (put 'acsc 'fancy!-functionsymbol "acsc")
- (put 'acsch 'fancy!-functionsymbol "acsch")
- (put 'ln 'fancy!-functionsymbol "ln")
- (put 'log 'fancy!-functionsymbol "log")
- ))
- %------- Print functions for GRG REDUCE MAPLE ... ------------------------
- (de ooprin!> (lst)
- (cond ((atom lst) (ooatom!> lst))
- ((eq (car lst) 'plus) (oonop!> lst "+"))
- ((eq (car lst) 'minus) (oominus!> lst))
- ((eq (car lst) 'difference) (oo2op!> lst "-"))
- ((eq (car lst) 'times) (oonop!> lst "*"))
- ((eq (car lst) 'quotient) (oo2op!> lst "/"))
- ((eq (car lst) 'expt) (oo2op!> lst '!^ ))
- (t (oofun!> lst))
- ))
- (de oominus!> (lst)
- (progn (gprin!> "(")
- (gprin!> "-")
- (ooprin!> (cadr lst))
- (gprin!> ")") ))
- (de oo2op!> (lst w)
- (progn (gprin!> "(")
- (ooprin!> (cadr lst))
- (gprin!> w)
- (ooprin!> (caddr lst))
- (gprin!> ")") ))
- (de oonop!> (lst w)
- (proc nil
- (gprin!> "(")
- (setq lst (cdr lst))
- (ooprin!> (car lst))
- (setq lst (cdr lst))
- (while!> lst
- (gprin!> w)
- (ooprin!> (car lst))
- (setq lst (cdr lst)))
- (gprin!> ")")))
- (de ooatom!> (w)
- (cond ((null w) (gprin!> 0))
- ((eq w 'e) (ooae!>))
- ((eq w 'i) (ooai!>))
- ((eq w 'pi) (ooapi!>))
- ((eq w 'infinity) (ooainf!>))
- ((and (not !*grg) (get w '!=depend))
- (oofun0!>(get w '!=depend)))
- (t (gprin!> w))))
- (de ooae!> nil
- (gprin!> (cond
- (!*macsyma '!%!e )
- ((or !*math !*maple) '!E )
- (t 'e ))))
- (de ooai!> nil
- (gprin!> (cond
- (!*macsyma '!%!i )
- ((or !*math !*maple) '!I )
- (t 'i ))))
- (de ooapi!> nil
- (gprin!> (cond
- (!*macsyma '!%!p!i )
- ((or !*maple !*math) '!P!i )
- (t 'pi ))))
- (de ooainf!> nil
- (gprin!> (cond
- (!*maple '!i!n!f!i!n!i!t!y )
- (!*math '!I!n!f!i!n!i!t!y )
- (t 'infinity ))))
- (de oolb!> nil (gprin!> (cond (!*math "[") (t "("))))
- (de oorb!> nil (gprin!> (cond (!*math "]") (t ")"))))
- (de oofun!> (w)
- (cond
- ((or !*grg !*reduce) (oofun0!> w))
- ((eq (car w) 'df) (oodf!> w))
- ((eq (car w) 'int) (ooint!> w))
- ((eq (car w) 'prod) (oops!> w t))
- ((eq (car w) 'sum) (oops!> w nil))
- ((eq (car w) 'ln) (ooln!> w))
- ((eq (car w) 'log) (oolog!> w))
- ((eq (car w) 'sqrt) (oosqrt!> w))
- ((flagp (car w) '!+trig) (ootrig!> w))
- (t (oofun0!> w))))
- (de oofun0!> (lst)
- (prog2
- (gprin!> (car lst))
- (ooargs!> (cdr lst))))
- (de ooargs!> (lst)
- (proc nil
- (oolb!>)
- (ooprin!> (car lst))
- (setq lst (cdr lst))
- (while!> lst
- (gprin!> ",")
- (ooprin!> (car lst))
- (setq lst (cdr lst)))
- (oorb!>)))
- (de oodf!> (lst)
- (cond((or !*reduce !*grg) (oofun0!> lst))
- (t(prog2
- (gprin!> (cond ((or !*maple !*macsyma) '!d!i!f!f )
- (!*math '!D )
- (t 'df )))
- (ooargsdf!>(cdr lst))))))
- (de ooargsdf!> (lst)
- (proc (w wc)
- (oolb!>)
- (ooprin!> (car lst))
- (setq lst (cdr lst))
- (while!> lst
- (gprin!> ",")
- (setq wc (car lst))
- (cond
- ((numberp wc)
- (for!> ww (2 1 wc) do
- (prog2 (ooprin!> w)
- (cond((not(eqn ww wc))(gprin!> ","))))))
- (t(ooprin!> wc)))
- (setq w wc)
- (setq lst (cdr lst)))
- (oorb!>)))
- (de ooint!> (lst)
- (prog2
- (gprin!> (cond ((or !*maple !*macsyma) '!i!n!t!e!g!r!a!t!e )
- (!*math '!I!n!t!e!g!r!a!t!e )
- (t 'int )))
- (ooargs!>(cdr lst))))
- (de oosqrt!> (lst)
- (prog2
- (gprin!> (cond ((or !*maple !*macsyma) '!s!q!r!t )
- (!*math '!S!q!r!t )
- (T 'sqrt )))
- (ooargs!>(cdr lst))))
- (de ooln!> (lst)
- (prog2
- (gprin!> (cond (!*maple '!l!n )
- (!*macsyma '!l!o!g )
- (!*math '!L!o!g )
- (t 'ln )))
- (ooargs!>(cdr lst))))
- (de oolog!> (lst)
- (prog2
- (gprin!> (cond (!*maple '!l!o!g )
- (!*macsyma '!l!o!g )
- (!*math '!L!o!g )
- (t 'log )))
- (ooargs!>(cdr lst))))
- (de oops!> (lst bool)
- (prog nil
- (gprin!>
- (cond (bool (cond ((or !*maple !*macsyma) '!p!r!o!d )
- (!*math '!P!r!o!d )
- (t 'prod )))
- (t (cond ((or !*maple !*macsyma) '!s!u!m )
- (!*math '!S!u!m )
- (t 'sum ))) ))
- (cond((not(or !*math !*maple))
- (prog2 (ooargs!>(cdr lst)) (return nil))))
- (oolb!>)
- (ooprin!> (cadr lst))
- (setq lst (cddr lst))
- (gprin!> ",")
- (cond(!*math (gprin!> "{")))
- (ooprin!> (car lst))
- (gprin!> (cond (!*math ",")
- (!*maple "=")))
- (ooprin!> (cadr lst))
- (gprin!> (cond (!*math ",")
- (!*maple "..")))
- (ooprin!> (caddr lst))
- (cond(!*math (gprin!> "}")))
- (oorb!>)))
- (de ootrig!> (lst)
- (prog (w wa)
- (setq w (explode2(car lst)))
- (cond((eq (car w) 'a) (prog2
- (setq wa t)
- (setq w (cdr w)))))
- (cond(wa
- (setq wa (cond (!*maple '( !a !r !c ))
- (!*math '( !A !r !c ))
- (t '( A ))))))
- (cond
- (!*maple (setq w (mapcar w 'tolc!>)))
- (!*math (setq w (cons (touc!> (car w)) (mapcar (cdr w) 'tolc!>)))))
- (setq w (compress(append wa w)))
- (oofun0!>(cons w (cdr lst)))))
- (de ooend!> nil
- (cond ((not !*math) (gprin!> ";"))))
- (de ooends!> nil
- (cond((not !*math)
- (gprin!>
- (cond ((or !*reduce !*macsyma) "$")
- (!*maple ":")
- (t ";"))))))
- (de ooelem!> (wi wl)
- (proc nil
- (gprin!> wi)
- (cond((null wl) (return nil)))
- (gprin!> (cond((or !*math !*macsyma) "[")(t "(")))
- (while!> wl
- (gprin!> (car wl))
- (cond((cdr wl)(gprin!> ",")))
- (setq wl (cdr wl)))
- (gprin!> (cond((or !*math !*macsyma) "]")(t ")")))
- ))
- %---------- For Write ----------------------------------------------------
- (de wriassign!> (we)
- (cond ((fancyon!>) (algpri!> (cond (we ":\,") (t "\,=\,")) ))
- ((ifmodo!>)
- (gprin!>
- (cond (!*macsyma " : " )
- ((or !*maple !*reduce) " := ")
- (t " = " ))))
- (t (algpri!> (cond (we " : ") (t " = ")) ))))
- (de wriequal!> nil
- (cond ((fancyon!>) (algpri!> "\,=\," ))
- ((ifmodo!>)
- (gprin!>
- (cond (!*math " == ")
- (t " = " ))))
- (t (algpri!> " = " ))))
- %---------- Equations Printing ------------------------------------------
- (de eqpri!> (wl wr wt)
- (progn
- (cond ((zerop wt) (alpri!> wl)) (t (dfpri!> wl wt)))
- (wriequal!>)
- (cond ((zerop wt) (alpri!> wr)) (t (dfpri!> wr wt)))
- ))
- %---------- Algebraic Expressions Printing -----------------------------
- (de alpri!> (lst)
- (cond ((ifmodo!>) (ooprin!> lst))
- (t (algpri!> (cond (!*wrs (aeval lst)) (t lst)) ))))
- %---------- Form Printing ----------------------------------------------
- (de dfpri!> (lst type)
- (cond ((ifmodo!>) (dfpri1!> lst type))
- (t (dfpri0!> lst type))))
- (de dfpri0!> (lst type)
- (cond((null lst) (algpri!> 0 )) % 0
- (t(prog (wx)
- (setq type (lessp type 0))
- (cond(!*wrs(setq lst(aevalform!> lst))))
- (cond((null lst)(algpri!> 0 ))(t
- (foreach!> x in lst do % for all terms ...
- (progn
- (cond((eqn(car x)-1) (primi!>)) % - d x
- ((not(eq x(car lst))) (pripl!>))) % ... + ...
- (cond((not(or(eqn(car x)-1)(eqn(car x)1))) % d x
- (cond((or(idp(car x))
- (and(numberp(car x))(not(lessp(car x)0)))
- (and !*wrs
- !*exp (not(getd 'taysimpexpt))
- (not(numberp(car x))) % not -n
- (eqn(cdr(cadar x)) 1) % den = 1
- (null(cdar(cadar x)) ) % not a + b
- (eqn(cdaar(cadar x)) 1) % not n * a
- (eqn(cdaaar(cadar x)) 1) % not a ** b
- )) % a d x
- (algpri!> (car x) ))
- (t
- % (algpri!> (list2 '! (car x)) )
- (progn
- (algpri!> "(" )
- (algpri!> (car x) )
- (algpri!> ")" ) )
- )) )) % (...) d x
- (setq wx (cddr x)) % wx - d x list
- (prixvost!> wx type) ))))))))
- (de primi!> nil
- (algpri!>
- (cond (!*latex "-")
- (t " -")) ))
- (de pripl!> nil
- (algpri!>
- (cond (!*latex "+")
- (t " + ")) ))
- (de prixvost!> (wx type)
- (proc (w wc)
- (setq wc 0)
- (while!> wx
- (cond((caar wx) (prog2
- (printdx0!> wc type)
- (cond((cdr wx) (priex!>))) )))
- (setq wc (add1 wc))
- (setq wx (cdr wx)))))
- (de priex!> nil
- (algpri!>
- (cond (!*latex "\,\wedge")
- ((fancyon!>) "\,\symb{217}")
- (t " /\"))
- ))
- (de printdx0!> (wc type)
- (cond
- (![modp!] %%% Anholonomic mode: b or e
- (cond
- ((fancyon!>) (prog2 % latex or fancy ...
- (algpri!> "\," )
- (cond (type (algpri!> (list '!#!#e wc) )) % e_i
- (t (algpri!> (list 'expt '!#!#b wc) ))))) % b^i
- (t (prog2 % plain grg ...
- (algpri!> " " )
- (algpri!>
- (compress (cons (bore!> type) (explode2 wc))) % bi or ei
- )))))
- (t(cond %%% Holonomic mode: @ x or d x ...
- ((fancyon!>) % latex or fancy ...
- (cond (type % \partial_x
- (algpri!> (list '!#!#p (getel1!> ![cord!] wc)) ))
- (t (prog2 % d x
- (algpri!> "\,d\," )
- (algpri!> (getel1!> ![cord!] wc) )))))
- (t (prog2 % plain grg ...
- (algpri!> (cond(type " @ ")(t " d ")) )
- (algpri!> (getel1!> ![cord!] wc) )))))))
- (de bore!> (type) (cond (type '!e) (t '!b)))
- (de dfpri1!> (lst type)
- (cond((null lst) (gprin!> 0)) % 0
- (t(proc (w wf wx wc)
- (setq type (lessp type 0))
- (while!> lst
- (setq w (car lst))
- (cond (wf (gprin!> "+"))
- (t (setq wf t)))
- (cond((not(equal (car w) 1)) (prog2
- (cond
- ((and (numberp(car w)) (lessp (car w) 0))
- (ooprin!> (list2 'minus (minus(car w)))))
- (t (ooprin!> (car w))))
- (gprin!> "*"))))
- (setq w (cddr w)) % d x list
- (setq wc 0)
- (setq wx nil)
- (while!> w
- (cond((caar w)
- (setq wx (cons (prepdx1!> wc type) wx))))
- (setq wc (add1 wc))
- (setq w (cdr w)))
- (cond(!*grg (oogrgdx!> (reverse wx) type))
- (t (oofun0!> (cons (cond (type '!pd) (t '!dx))
- (reverse wx)))))
- (setq lst (cdr lst)))))))
- (de oogrgdx!> (wx type)
- (loop!>
- (cond((not ![modp!])(prog2
- (cond (type (gprin!> '!@))
- (t (gprin!> '!d)))
- (gprin!> '! ))))
- (gprin!> (car wx))
- (setq wx (cdr wx))
- (exitif (null wx))
- (gprin!> '!/!\)))
- (de prepdx1!> (wc type)
- (cond
- (![modp!] (compress (cons (bore!> type)
- (explode2 wc))))
- (t (getel1!> ![cord!] wc))))
- %-------- Some General Print Functions -----------------------------------
- (de grgterpri!> nil
- (cond((ifmodo!>) (gterpri!>))
- (t (algterpri!>))))
- (de grgend!> nil
- (cond((ifmodo!>) (ooend!>))))
- (de grgends!> nil
- (cond((ifmodo!>) (ooends!>))))
- %============ End of GRGprin.sl ===========================================%
|