grg/grgprin.sl

%==========================================================================%
%   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 ===========================================%