/* Hauptprogramm :
   kleine Buchstaben Variablen grosse Buchstaben Konstanten, besonders :
   E=e P=pi Q=0 J=1  */

lib="rexxmathlib.library"
if ~show('l',lib) then do
   if ~addlib(lib,0,-30) then do
      do
         say "no "||lib
         exit 5
      end
   end
end

call initconst()
call writech(stdout,"Funktion : ")
fkt=compress(readln(stdin))
say "Umgekehrt polnisch Notation :"
rpn=bas2rpn(fkt)
say rpn
if index(rpn,"ERROR")~=0 then exit
say "Konstanten :"
call inputconst(rpn)
say "Vereinfachen :"
rpn=verein(rpn)
say rpn
call writech(stdout,"ableiten nach : ")
var=compress(readln(stdin))
say "Ableitung :"
abl=diff(rpn,var)
say abl
say "Vereinfachen :"
smp=verein(abl)
say smp
say "Endform :"
call rpn2bas(smp)
exit

/****************************************************************************/
/* Wandelt normalen Computer-Mathe-Ausdruck in umgekehrt polnische Notation */
/* keine Funktion benutzt den Stack */
bas2rpn: procedure
fkt=arg(1)
err=check(fkt)
if err~=="OK" then return err
fkt=changefunc(fkt)
fkt=killbrack(fkt)
fkt=priokl(fkt)
fkt=killbrack(fkt)
fkt=basic2rpn(fkt)
return fkt

/* konvertiert Basic-Mathe-Ausdruecke nach umgekehrt polnisch
   ignoriert : Punkt-vor-Strich-Rechnung , d.h. :
   Klammern setzen !   ! REKURSIV ! */
basic2rpn: procedure
str=arg(1)
rpn=""
len=length(str)
do i = 1 to len
   z=substr(str,i,1)
   if z=="(" then do
      klamm=inbrack(str,i)
      b2r=basic2rpn(klamm)
      if i=1 then rpn=rpn||b2r
      else rpn=rpn||b2r||substr(str,i-1,1)
      i=i+length(klamm)+1
   end
   else do
      w=wert(z)
      if w=-2 then do
         rpn=rpn||z
         iterate i
      end
      if i=1 then rpn=z
      else do
         if w=1 then do
            rpn=rpn||z||substr(str,i-1,1)
         end
      end
   end
end
return rpn

/* setzt Prioritaets-Klammern fuer [ / * ^ ] ! REKURSIV ! */
priokl: procedure
string=arg(1)
len=length(string)
ps=""
nowprio=1
do i = 1 to len
   z=substr(string,i,1)
   p=prio(z)
   select
      when p=0 then nop
      when p=4 then do
         str=inbrack(string,i)
         z=priokl(str)
         z="("||z||")"
         i=i+length(str)+1
      end
      otherwise do
         diff=p-nowprio
         if diff~=0 then do
            if diff>0 then do
               zeich=right(ps,1)
               if zeich==")" then do
                  str=inbrack(ps,length(ps))
                  ps=left(ps,length(ps)-length(str)-2)||copies("(",diff)||"("||str||")"
               end
               else do
                  ps=left(ps,length(ps)-1)||copies("(",diff)||zeich
               end
            end
            else do
               ps=ps||copies(")",-diff)
            end
            nowprio=p
         end
      end
   end
   ps=ps||z
end
ps=ps||copies(")",nowprio-1)
return ps

/* wandelt SIN -> ß und ³ nach ^³ */
changefunc: procedure
str=arg(1)
/* trig,exp,log,neg Funktionen umwandeln */
do i = 1 to 10
   fkt=function(i)
   do forever
      pos=index(upper(str),fkt)
      if pos=0 then leave
      len=length(fkt)
      str=delstr(str,pos,len)
      klamm=inbrack(str,pos)
      str=insert(fktchar(i)||")",str,pos+length(klamm)+1,2)
      str=insert("(",str,pos-1,1)
   end
end
/* hoch 1/2 -1 2 3 umwandeln in ^ */
do i = 11 to 14
   fkt=function(i)
   letztes=1
   do forever
      pos=index(str,fkt,letztes)
      if pos=0 then leave
      str=insert("^",str,pos-1,1)
      letztes=pos+2
   end
end
return str

/* loescht alle unnoetigen Klammern aus einem Ausdruck */
killbrack: procedure
str=arg(1)
/* Klammern um gesamten String loeschen */
do while left(str,1)=="("
   klamm=inbrack(str,1)
   if length(klamm)<length(str)-2 then leave
   str=klamm
end
return str

/********************* dauert zu lange : Klammern im String loeschen
start=1
do forever
   pos=index(str,"((",start)+1
   if pos=1 then leave
   pos2=pos+length(inbrack(str,pos))+1
   if substr(str,pos2+1,1)==")" then do
      str=delstr(str,pos2,1)
      str=delstr(str,pos,1)
   end
   else do
      start=pos+1
   end
end
**************************************/

/* gibt eine "Unter"-Klammer vom Ausdruck aus :
   f+g+(g+k+l)-j => g+k+l
   falls an pos ( dann vorwaertsklammer sonst rueckwaerts */
inbrack: procedure
str=arg(1)
pos=arg(2)
zeich=substr(str,pos,1)
if index("()",zeich)=0 then return("")
found=1
nxbr=pos
if zeich=="(" then do
   do forever
      nxop=pos("(",str,nxbr+1)
      nxcl=pos(")",str,nxbr+1)
      if nxop=0 then nxbr=nxcl
                else nxbr=min(nxop,nxcl)
      z=substr(str,nxbr,1)
      if z=="(" then do
         found=found+1
         iterate
      end
      found=found-1
      if found=0 then leave
   end
   brastr=substr(str,pos+1,nxbr-pos-1)
end
else do
   do forever
      nxcl=lastpos(")",str,nxbr-1)
      nxop=lastpos("(",str,nxbr-1)
      if nxcl=0 then nxbr=nxop
                else nxbr=max(nxcl,nxop)
      z=substr(str,nxbr,1)
      if z==")" then do
         found=found+1
         iterate
      end
      found=found-1
      if found=0 then leave
   end
   brastr=substr(str,nxbr+1,pos-nxbr-1)
end
return brastr
exit

/* ERROR - Check */
check: procedure
str=arg(1)
/* Ist hinter jeder Funktion eine Klammer ? */
do i = 1 to 10
   fkt=function(i)
   len=length(fkt)
   lastpos=0
   do forever
      pos=index(upper(str),fkt)
      if pos<=lastpos then leave
      if substr(str,pos+len,1)~=="(" then return "Funktion - ERROR"
      lastpos=pos
   end
end
/* alles raus, was stoert ,d.h. alle Funktionen */
do i=1 while fkt~=""
   fkt=function(i)
   len=length(fkt)
   do forever
      pos=index(upper(str),fkt)
      if pos=0 then leave
      str=delstr(str,pos,len)
      if (i>10)&(pos=0) then return "Funktion - ERROR"
   end
end
/* Kontrolle */
erlaubt="abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ+-*/^()"
wertsumme=0
openbrack=0
len=length(str)
do i = 1 to len
   z=substr(str,i,1)
   if index(erlaubt,z)=0 then return "Falsches Zeichen - ERROR"
   wertsumme=wertsumme+wert(z)
   if (wertsumme<0)|(wertsumme>1) then return "Syntax - ERROR"
   if z=="(" then do
      openbrack=openbrack+1
      if i=len then return "Klammer - ERROR"
      znach=substr(str,i+1,1)
      if (wert(znach)~=1)&(znach~==z) then return "Klammer - ERROR"
   end
   if z==")" then do
      openbrack=openbrack-1
      if i=1 then return "Klammer - ERROR"
      zvor=substr(str,i-1,1)
      if (wert(zvor)~=1)&(zvor~==z) then return "Klammer - ERROR"
   end
   if openbrack<0 then return "Klammer - ERROR"
end
if wertsumme~=1 then return "Syntax - ERROR"
if openbrack~=0 then return "Klammer - ERROR"
return "OK"

/* Zeichen - Prioritaet */
prio: procedure
zeichen=arg(1)
prio=0
if index("+-",zeichen)~=0 then prio=1
if index("*/",zeichen)~=0 then prio=2
if index("^",zeichen)~=0 then prio=3
if index("()",zeichen)~=0 then prio=4
return prio

/* Zeichen - Wert */
wert: procedure
zeichen=arg(1)
wert=1
if index("^*+/-",zeichen)~=0 then wert=-1
if index("()",zeichen)~=0 then wert=0
if index("ßçþ§ÇÞé£ð­½¹²³",zeichen)~=0 then wert=-2
return wert

/* Funktionen die erkannt werden */
function: procedure
nr=arg(1)
select
   when nr=1 then f="ASIN"
   when nr=2 then f="ACOS"
   when nr=3 then f="ATAN"
   when nr=4 then f="SIN"
   when nr=5 then f="COS"
   when nr=6 then f="TAN"
   when nr=7 then f="EXP"
   when nr=8 then f="LN"
   when nr=9 then f="LOG"
   when nr=10 then f="NEG"
   when nr=11 then f="¹"
   when nr=12 then f="²"
   when nr=13 then f="³"
   when nr=14 then f="½"
   otherwise f=""
end
return f

/* UPN-Buchstaben fuer die Funktionen und umgekehrt */
fktchar: procedure
z=arg(1)
if datatype(z)="NUM" then do
   select
      when z=1 then f="§"
      when z=2 then f="Ç"
      when z=3 then f="Þ"
      when z=4 then f="ß"
      when z=5 then f="ç"
      when z=6 then f="þ"
      when z=7 then f="é"
      when z=8 then f="£"
      when z=9 then f="ð"
      when z=10 then f="­"
      when z=11 then f="¹"
      when z=12 then f="²"
      when z=13 then f="³"
      when z=14 then f="½"
      otherwise f=""
   end
end
else do
   select
      when z="§" then f=1
      when z="Ç" then f=2
      when z="Þ" then f=3
      when z="ß" then f=4
      when z="ç" then f=5
      when z="þ" then f=6
      when z="é" then f=7
      when z="£" then f=8
      when z="ð" then f=9
      when z="­" then f=10
      when z="¹" then f=11
      when z="²" then f=12
      when z="³" then f=13
      when z="½" then f=14
      otherwise f=0
   end
end
return f

/****************************************************************************/

/* konvertiert wieder zrueck */
rpn2bas: procedure
ausdr=arg(1)
stack.pos=0
do i = 1 to length(ausdr)
   z=substr(ausdr,i,1)
   w=wert(z)
   select
      when w=1 then do
         if z=upper(z) then z=getconst(z)
         call push(z)
      end
      when w=-1 then do      /* Operation mit zwei Argumenten */
         p=prio(z)
         a1=pull()
         a2=pull()
         if lowprio(a2)<p then a2="("||a2||")"
         if (z="+")|(z="*") then do   /* kommutativ */
            if lowprio(a1)<p then a1="("||a1||")"
         end
         else do
            if lowprio(a1)<=p then a1="("||a1||")"
         end
         call push(a2||z||a1)
      end
      otherwise do            /* Operation mit einem Argument */
         nr=fktchar(z)
         fkt=function(nr)
         a1=pull()
         if nr<11 then do
            call push(fkt||"("||a1||")")
         end
         else do
            if length(a1)~=1 then a1="("||a1||")"
            call push(a1||fkt)
         end
      end
   end
end
ausdr=pull()
say ausdr
return

/* niedrigste Piroritaet im String */
lowprio: procedure
str=arg(1)
lp=9
do i = 1 to length(str)
   z=substr(str,i,1)
   if z="(" then do
      a=inbrack(str,i)
      i=i+length(a)
      iterate i
   end
   p=prio(z)
   if p=0 then iterate
   if p<lp then lp=p
end
return lp

/************* S T A C K - O P E R A T I O N E N ************/

/* push to stack */
push:
wert=arg(1)
positionstack=stack.pos+1
stack.pos=positionstack
stack.positionstack=wert
return

/* pull from stack */
pull:
if stack.pos=0 then do
   say "Stack empty !"
   exit
end
positionstack=stack.pos
stack.pos=positionstack-1
return stack.positionstack

/******************* D I F F E R E N Z I E R E N ***********************

Differenzieren (Ableiten)
leitet ausdruck nach variablen ab !REKURSIV! */
diff: procedure
ausdr=arg(1)
var=arg(2)
if (length(var)~=1)|(var=upper(var)) then do
   say var "ist keine Variable !"
   exit
end
if ausdr==var then return "J"
if index(ausdr,var)=0 then return "Q"
z=right(ausdr,1)
rest=left(ausdr,length(ausdr)-1)
if wert(z)=-2 then do
   df=diff(rest,var)
   select
      when z="ß" then df=df||rest||"ç*"
      when z="ç" then df=df||rest||"ß*­"
      when z="þ" then df=df||rest||"ç²¹*"
      when z="§" then df=df||"J"||rest||"²-"||"½/"
      when z="Ç" then df=df||"J"||rest||"²-"||"½/­"
      when z="Þ" then df=df||"J"||rest||"²+/"
      when z="é" then df=df||rest||"é*"
      when z="£" then df=df||rest||"/"
      when z="ð" then df=df||rest||"¹"||setconst(10)||"£/*"
      when z="­" then df=df||"­"
      when z="¹" then df=df||rest||"²/­"
      when z="²" then df=df||rest||"*"||setconst(2)||"*"
      when z="³" then df=df||rest||"²*"||setconst(3)||"*"
      when z="½" then df=df||rest||"½/"||setconst(2)||"/"
      otherwise nop
   end
end
else do
   tp=termpos(rest)
   term1=left(rest,tp)
   term2=right(rest,length(rest)-tp)
   dt1=diff(term1,var)
   dt2=diff(term2,var)
   select
      when z="+" then df=dt1||dt2||"+"
      when z="-" then df=dt1||dt2||"-"
      when z="*" then df=dt1||term2||"*"||dt2||term1||"*+"
      when z="/" then df=dt1||term2||"*"||dt2||term1||"*-"||term2||"²/"
      when z="^" then df=dt1||term1||"/"||term2||"*"||term1||"£"||dt2||"*+"||ausdr||"*"
      otherwise nop
   end
end
return df

/****************  V E R E I N F A C H E N *******************/

verein: procedure
str=arg(1)
do until str==alt
   alt=str
   str=trivial(str)
   str=pullneg(str)
   str=simp(str)
end
return str

/* NEG() und x¹ (am ersten Term) so weit wie moeglich rausziehen
   !REKURSIV!    am zweiten Term erledigt das schon trivial */
pullneg: procedure
pn=arg(1)
if (index(pn,"­")=0)&(index(pn,"¹")=0) then return pn
z=right(pn,1)
rest=left(pn,length(pn)-1)
if wert(z)=-2 then do
   argu=pullneg(rest)
   pn=argu||z
   if (z=="­")&(right(argu,1)="-") then pn=changeterm(argu)
   if (z=="¹")&(right(argu,1)="/") then pn=changeterm(argu)
end
if wert(z)=-1 then do
   tp=termpos(rest)
   term1=left(rest,tp)
   term2=right(rest,length(rest)-tp)
   pn1=pullneg(term1)
   pn2=pullneg(term2)
   pn=pn1||pn2||z
   pnn=left(pn1,length(pn1)-1)
   if right(pn1,1)=="­" then do
   select
      when z="+" then pn=pn2||pnn||"-"
      when z="-" then pn=pnn||pn2||"+­"
      when z="*" then pn=pnn||pn2||"*­"
      when z="/" then pn=pnn||pn2||"/­"
      otherwise nop
   end
   end
   if right(pn1,1)=="¹" then do
   select
      when z="*" then pn=pn2||pnn||"/"
      when z="/" then pn=pnn||pn2||"*¹"
      when z="^" then pn=pnn||pn2||"^¹"
      otherwise nop
   end
   end
end
return pn

/* einfaches ersetzen */
trivial: procedure
str=arg(1)
str=replace(str,"­ß","ß­")
str=replace(str,"­þ","þ­")
str=replace(str,"­§","§­")
str=replace(str,"­Þ","Þ­")
str=replace(str,"­¹","¹­")
str=replace(str,"­³","³­")
str=replace(str,"­ç","ç")
str=replace(str,"­²","²")

str=replace(str,"¹*","/")
str=replace(str,"¹/","*")
str=replace(str,"­+","-")
str=replace(str,"­-","+")
str=replace(str,"­*","*­")
str=replace(str,"­/","/­")
str=replace(str,"­^","^¹")

str=replace(str,"ߧ","")
str=replace(str,"§ß","")
str=replace(str,"çÇ","")
str=replace(str,"Çç","")
str=replace(str,"þÞ","")
str=replace(str,"Þþ","")
str=replace(str,"é£","")
str=replace(str,"£é","")
str=replace(str,"²½","")
str=replace(str,"½²","")
str=replace(str,"¹¹","")
str=replace(str,"­­","")

return str

/* Killt Nullen und Einsen , wo sie nicht hingehoeren.
drej mo null is null bliev null !REKURSIV! */
simp: procedure
ausdr=arg(1)
len=length(ausdr)
if len=1 then return ausdr
z=right(ausdr,1)
rest=left(ausdr,len-1)
if wert(z)=-2 then do
   slrest=simp(rest)
   sl=slrest||z
   select
      when z="ß" then do
         if (slrest="Q")|(slrest="P") then sl="Q"
      end
      when z="ç" then do
         if slrest="Q" then sl="J"
      end
      when z="þ" then do
         if (slrest="Q")|(slrest="P") then sl="Q"
      end
      when z="§" then do
         if slrest="Q" then sl="Q"
      end
      when z="Ç" then do
         if slrest="J" then sl="Q"
      end
      when z="Þ" then do
         if slrest="Q" then sl"Q"
      end
      when z="é" then do
         if slrest="J" then sl="E"
         if slrest="Q" then sl="J"
      end
      when z="£" then do
         if slrest="J" then sl="Q"
         if slrest="E" then sl="J"
      end
      when z="ð" then do
         if slrest="J" then sl="Q"
      end
      when z="­" then do
         if slrest="Q" then sl="Q"
      end
      when z="¹" then do
         if slrest="J" then sl="J"
      end
      when z="²" then do
         if slrest="Q" then sl="Q"
         if slrest="J" then sl="J"
      end
      when z="³" then do
         if slrest="Q" then sl="Q"
         if slrest="J" then sl="J"
      end
      when z="½" then do
         if slrest="Q" then sl="Q"
         if slrest="J" then sl="J"
      end
      otherwise nop
   end
end
else do
   tp=termpos(rest)
   term1=left(rest,tp)
   term2=right(rest,length(rest)-tp)
   sl1=simp(term1)
   sl2=simp(term2)
   sl=sl1||sl2||z
   select
      when z="+" then do
         if sl1="Q" then sl=sl2
         if sl2="Q" then sl=sl1
      end
      when z="-" then do
         if sl1="Q" then sl=sl2||"­"
         if sl2="Q" then sl=sl1
         if sl1=sl2 then sl="Q"
      end
      when z="*" then do
         if (sl1="Q")|(sl2="Q") then sl="Q"
         if sl1="J" then sl=sl2
         if sl2="J" then sl=sl1
         if sl1=sl2 then sl=sl1||"²"
      end
      when z="/" then do
         if sl1="Q" then sl="Q"
         if sl1="J" then sl=sl2||"¹"
         if sl2="J" then sl=sl1
         if sl1=sl2 then sl="J"
      end
      when z="^" then do
         if sl1="Q" then sl="Q"
         if sl2="Q" then sl="J"
         if sl1="J" then sl="J"
         if sl2="J" then sl=sl1
       end
      otherwise nop
   end
end
return sl

/* Zwei Terme tauschen (z.B. beim Kommutativgesetz) */
changeterm: procedure
ausdr=arg(1)
z=right(ausdr,1)
if wert(z)~=-1 then do
   say "Keine zweiargumentige Fkt!"
   exit
end
rest=left(ausdr,length(ausdr)-1)
tp=termpos(rest)
term1=left(rest,tp)
term2=right(rest,length(rest)-tp)
return term2||term1||z

/* Wo trennen sich die Terme ? (bei zweiargumentigen Operationen) */
termpos: procedure
str=arg(1)
wertsumme=0
do i = length(str) to 1 by -1
   w=wert(substr(str,i,1))
   if w=-2 then w=0
   wertsumme=wertsumme+w
   if wertsumme=1 then leave
end
return i-1

/************** K O N S T A N T E N - P R O Z E D U R E N ****************/

/* eine Konstante setzen. Uebernimmt Wert und gibt Konstante zurueck 
   z.b. 43 --> W */
setconst: procedure
wert=arg(1)
call readconst()
firstunused="nix"
do i = 65 to 90
   char=d2c(i)
   if const.char=wert then return char    /* Wert schon vergeben */
   if (const.char="#")&(firstunused="nix") then firstunused=char
end
if firstunused="nix" then do
   say "Konstanten alle belegt !"
   exit
end
const.firstunused=wert
call writeconst()
return firstunused

/* den Wert einer Konstanten ermitteln und uebergeben
   z.b. W --> 43 */
getconst: procedure
char=arg(1)
if (length(char)~=1)|(char~=upper(char)) then do
   say char "ist keine Konstante !"
   exit
end
call readconst()
return const.char

/* Konstanten auf Defaultwerte setzen (unbenutzt = #) */
initconst: procedure
call open(tmp,"t:Konstanten.tmp","Write")
do i = 1 to 4
   call writeln(tmp,"#")      /* A-D */
end
call writeln(tmp,exp(1))      /* E */
do i = 1 to 4
   call writeln(tmp,"#")      /* F-I */
end
call writeln(tmp,1)           /* J */
do i = 1 to 5
   call writeln(tmp,"#")      /* K-O */
end
call writeln(tmp,atan(1)*4)   /* P */
call writeln(tmp,0)           /* Q */
do i = 1 to 9
   call writeln(tmp,"#")      /* R-Z */
end
call close(tmp)
return

/* Konstanten, die vorkommen, vom Benutzer erfragen */
inputconst: procedure
ausdr=arg(1)
call readconst()
do i = 65 to 90
   char=d2c(i)
   if (const.char="#")&(index(ausdr,char)~=0) then do forever
      call writech(stdout,char||"=")
      const.char=readln(stdin)
      if datatype(const.char)=="NUM" then break  /* we want a value */
   end
end
call writeconst()
return

/* Konstanten lesen */
readconst:
call open(tmp,"t:Konstanten.tmp","Read")
do qwak = 65 to 90
   jout=d2c(qwak)
   const.jout=readln(tmp)
end
call close(tmp)
return

/* Konstanten schreiben */
writeconst:
call open(tmp,"t:Konstanten.tmp","Write")
do qwak = 65 to 90
   jout=d2c(qwak)
   call writeln(tmp,const.jout)
end
call close(tmp)
return

/**** R E P L A C E *** ("what" by "by" in "str") */
replace: procedure
str=arg(1)
what=arg(2)
by=arg(3)
if index(by,what)~=0 then do
   say "PENG!"
   exit
end
do forever
   pos=index(str,what)
   if pos=0 then leave
   str=delstr(str,pos,length(what))
   str=insert(by,str,pos-1,length(by))
end
return str