Umiestnenie súboru www.TrSek.com/cover/koupy/solver.pas{ SOLVER.PAS Copyright (c) Petr Koupy }
{ }
{ Interpreter vyrazu a iteracni reseni rovnic. }
{ }
{ Vyèíslování aritmetických výrazù, øe¹ení rovnic s jednou neznámou,}
{ vyu¾ití elementárních matematických funkcí, pamì» mezivýsledkù. }
{ Je mo¾né nastavit poèet desetinných míst a prohledávaný rozsah }
{ promìnné pøi øe¹ení rovnice. Pro øe¹ení rovnic jsou implementovány}
{ rùzné numerické metody, které se li¹í svojí èasovou slo¾itostí. }
{ Pro snadnìj¹í pou¾ívání je v menu obsa¾ena nápovìda. Program není }
{ zcela dokonèen a vlastní implementace nìkterých elementárních }
{ funkcí není dostateènì pøesná. Pøedev¹ím pøi pou¾ití vnoøených }
{ goniometrických funkcí je tøeba brát výsledky hodnì s rezervou. }
{ Program vznikl v rámci pøípravy na maturitu. }
{ }
{ Datum:01.05.2007 http://www.trsek.com }
program solver;
uses crt, math, dos;
const maxzasobnik=50; {maximalni pocet prvku ulozenych v zasobniku}
type zasobnik1=record {ciselny zasobnik bude datoveho typu zaznam a obsahuje:}
obsah:array[1..maxzasobnik] of real; {- jednotlive prvky typu real}
pozice:word; {- pozici posledniho prvku}
end;
zasobnik2=record {operatorovy zasobnik bude datoveho typu zaznam a obsahuje:}
obsah:array[1..maxzasobnik] of integer; {- jednotlive prvky typu integer}
pozice:word; {- pozici posledniho prvku}
end;
var vstup:string; {hlavni program - retezec od uzivatele}
chyba:integer; {globalni promenna pro chybove hlaseni}
promenne:array['A'..'Z'] of real; {pole promennych, do kterych bude mozne ukladat mezivypocty}
pruseciky:array[1..50] of real;
pocetkorenu:integer;
preteceni:boolean;
i:char; {pomocna promenna pro cyklus}
x:real; {vysledek celeho zpracovani}
volba:byte; {promenna pro vyber uzivatele}
{zacatek - chybove hlaseni}
function ChyboveHlaseni(ch:integer):string; {prevadi chybovy kod na srozumitelny textovy retezec}
var retezec:string; {promenna na docasne ulozeni daneho chyboveho hlaseni}
begin
case ch of
2: retezec:='Deleni nulou';
3: retezec:='Chybny parametr';
4: retezec:='Chybny operator';
5: retezec:='Chybne cislo';
6: retezec:='Chybna promenna';
7: retezec:='Nedefinovano v R'
end;
ChyboveHlaseni:=retezec; {prirazeni retezce funkci}
end;
procedure Selhani(s:integer); {pri selhani ruzneho druhu se hodnota chyboveho hlaseni priradi promenne}
begin
chyba:=s; {prirazeni chyboveho hlaseni globalni promenne}
end;
{konec - chybove hlaseni}
{zacatek - zasobniky}
procedure Inicializovat1(var z:zasobnik1); {vymazani zasobniku pred zpracovanim}
begin
z.pozice:=0; {at je uvnitr cokoliv, pozice posledniho prvku jde na nulu}
end;
procedure Inicializovat2(var z:zasobnik2); {vymazani zasobniku pred zpracovanim}
begin
z.pozice:=0; {at je uvnitr cokoliv, pozice posledniho prvku jde na nulu}
end;
procedure Vlozit1(var z:zasobnik1;prvek:real); {vlozeni prvku na posledni misto zasobniku}
begin
if z.pozice<maxzasobnik then {pokud neni zasobnik plny, muze se vkladat}
begin
inc(z.pozice); {zasobnik bude vzapeti o jeden prvek plnejsi}
z.obsah[z.pozice]:=prvek; {fyzicke vlozeni prvku do zasobniku}
end;
end;
procedure Vlozit2(var z:zasobnik2;prvek:integer); {vlozeni prvku na posledni misto zasobniku}
begin
if z.pozice<maxzasobnik then {pokud neni zasobnik plny, muze se vkladat}
begin
inc(z.pozice); {zasobnik bude vzapeti o jeden prvek plnejsi}
z.obsah[z.pozice]:=prvek; {fyzicke vlozeni prvku do zasobniku}
end;
end;
function Vyjmout1(var z:zasobnik1):real; {vraci hodnotu posledniho prvku zasobniku a zaroven posledni prvek vyjme}
begin
if z.pozice>0 then {pokud zasobnik neni prazdny, muze se vyjimat}
begin
Vyjmout1:=z.obsah[z.pozice]; {prirazeni hodnoty posledniho prvku funkci}
dec(z.pozice); {zasobnik se vyjmutim zmensuje o jeden prvek}
end;
end;
function Vyjmout2(var z:zasobnik2):integer; {vraci hodnotu posledniho prvku zasobniku a zaroven posledni prvek vyjme}
begin
if z.pozice>0 then {pokud zasobnik neni prazdny, muze se vyjimat}
begin
Vyjmout2:=z.obsah[z.pozice]; {prirazeni hodnoty posledniho prvku funkci}
dec(z.pozice); {zasobnik se vyjmutim zmensuje o jeden prvek}
end;
end;
function Nacist1(var z:zasobnik1):real; {vraci hodnotu posledniho prvku zasobniku}
begin
if z.pozice>0 then {pokud zasobnik neni prazdny, muze se nacitat}
begin
Nacist1:=z.obsah[z.pozice]; {prirazeni hodnoty posledniho prvku funkci}
end;
end;
function Nacist2(var z:zasobnik2):integer; {vraci hodnotu posledniho prvku zasobniku}
begin
if z.pozice>0 then {pokud zasobnik neni prazdny, muze se nacitat}
begin
Nacist2:=z.obsah[z.pozice]; {prirazeni hodnoty posledniho prvku funkci}
end;
end;
function Prazdny1(z:zasobnik1):boolean; {zjisteni prazdnosti zasobniku}
begin
if z.pozice=0 then Prazdny1:=true {prirazeni logicke hodnoty funkci}
else Prazdny1:=false;
end;
function Prazdny2(z:zasobnik2):boolean; {zjisteni prazdnosti zasobniku}
begin
if z.pozice=0 then Prazdny2:=true {prirazeni logicke hodnoty funkci}
else Prazdny2:=false;
end;
function Plny1(z:zasobnik1):boolean; {zjisteni plnosti zasobniku}
begin
if z.pozice=maxzasobnik then Plny1:=true {prirazeni logicke hodnoty funkci}
else Plny1:=false;
end;
function Plny2(z:zasobnik2):boolean; {zjisteni plnosti zasobniku}
begin
if z.pozice=maxzasobnik then Plny2:=true {prirazeni logicke hodnoty funkci}
else Plny2:=false;
end;
{konec - zasobniky}
{zacatek - zpracovani retezce}
procedure OdstranitMezery(var retezec:string); {odstraneni uvodnich mezer ze vstupniho vyrazu}
begin
while retezec[1]=' ' do retezec:=copy(retezec,2,255); {dokud jsou na zacatku mezery, retezec se sam do sebe kopiruje vzdy od druheho mista az do konce}
end;
function VelkeZnaky(var retezec:string):string; {vsechny znaky ve vstupnim retezci prevede na jejich velke varianty}
var opakovani:integer; {promenna pro cyklus rizeny promennou}
begin
for opakovani:=1 to length(retezec) do retezec[opakovani]:=upcase(retezec[opakovani]); {vsechny znaky postupne prevest na velke varianty}
VelkeZnaky:=retezec; {prirazeni prevedeneho retezce funkci}
end;
function ZacinaPodretezcem(podretezec:string; var retezec:string):boolean; {testuje, jestli retezec zacina podretezcem, a zaroven podretezec vyjme pryc}
begin
if VelkeZnaky(podretezec)=copy(VelkeZnaky(retezec),1,length(podretezec)) then {pokud se podretezec na zacatku retezce nachazi, tak pokracuje - ke zvetsovani dochazi kvuli vyhodnoceni funkci}
begin
retezec:=copy(retezec,length(podretezec)+1,255); {vyjmuti podretezce tim, ze se zbytek retezce sam do sebe zkopiruje od konce podretezce}
ZacinaPodretezcem:=true; {prirazeni logicke hodnoty funkci}
end
else ZacinaPodretezcem:=false; {prirazeni logicke hodnoty funkci}
end;
{konec - zpracovani retezce}
{zacatek - slozitejsi matematicke operace}
function Umocneni(a,b:real):real; {spocita a^b}
var opakovani:integer; {pomocna promenna pro cyklus}
vysledek:real; {promenna na ulozeni mezivysledku postupneho nasobeni zakladem mocniny}
begin
vysledek:=1; {pojistka, kdyby se exponent rovnal nule}
if int(b)=b then {pokud je exponent cele cislo, bude jiny postup pri umocnovani}
begin
for opakovani:=1 to abs(trunc(b)) do vysledek:=vysledek*a; {pocet nasobeni se rovna absolutni hodnote z exponentu}
if b<0 then vysledek:=1/vysledek; {pokud byl exponent zaporny, je nutne vratit prevracenou hodnotu vysledku}
end
else
begin
if a>0 then vysledek:=exp(ln(a)*b) else {pokud je zaklad mocniny kladny, muze se ihned spocitat vysledek}
begin
if a<0 then {pokud je zaklad mocniny zaporny, je nutne rozhodnout o 2 vecech:}
begin {1) jestli je exponent tvaru 1/x --- 2) jestli je prevracena hodnota exponentu licha --- pokud jsou tyto podminky splneni, lze odmocnit zaporne cislo, jinak je vracena chyba}
if ((abs(round(1/b)-(1/b))<0.00000001) and ((round(1/b) mod 2)<>0)) then vysledek:=-1*exp(ln(abs(a))*b) else begin Selhani(7); exit; end;
end;
end;
end;
Umocneni:=vysledek; {prirazeni vysledku funkci}
end;
{konec - slozitejsi matematicke operace}
{zacatek - interpretace vyrazu}
function Priorita(p:integer):integer; {vraci prioritu pocetni operace - kazda operace je zastoupena dvojcifernym cislem, kde prvni cifra znamena prioritu a druha cifra odlisuje operace stejne priority od sebe}
begin
Priorita:=p div 10; {prirazeni priority funkci}
end;
procedure Operace(var z:zasobnik1;o:integer); {se dvema prvky zasobniku provede operaci}
var a,b:real; {promenne, do kterych se docasne ulozi dva posledni prvky zasobniku}
begin
a:=Vyjmout1(z); {vyjmuti posledniho prvku ze zasobniku do promenne a}
b:=Vyjmout1(z); {vyjmuti nove vznikleho posledniho prvku ze zasobniku do promenne b}
case o of {v zavislosti na operaci se na konec zasobniku vlozi:}
10: Vlozit1(z,b+a); {soucet} {to co bylo v zasobniku vice nahore (tedy a), je ve skutecnem vyrazu vice vpravo, takze proto jsou promenne prohozene}
11: Vlozit1(z,b-a); {rozdil}
20: Vlozit1(z,b*a); {nasobeni}
21: if a<>0 then Vlozit1(z,trunc(b) div trunc(a)) else Selhani(2); {celociselne deleni - osetreno deleni nulou - chyba 2 zastavi uplne cele zpracovani, kaskadovite dojde k preruseni vsech urovni algoritmu}
22: if a<>0 then Vlozit1(z,trunc(b) mod trunc(a)) else Selhani(2); {zbytek po celociselnem deleni}
23: if a<>0 then Vlozit1(z,b/a) else Selhani(2); {plnohodnotne deleni realnych cisel}
30: Vlozit1(z,Umocneni(b,a)) {umocneni}
end;
end;
function Vyhodnoceni(retezec:string):real; forward; {telo funkce viz dale, dopredna deklarace funkci kvuli vzajemne rekurzi funkci Zavorky a Vyhodnoceni pres funkci Cislo}
function Zavorky(var retezec:string):string; {nalezne v retezci nejvyssi uroven zavorek a jejich obsah vraci jako svoji hodnotu}
var pruchod,pocet:integer; {pruchod bude postupne nabyvat hodnot od jedne do delky retezce, pocet bude vyhodnocovat pocet oteviracich a uzaviracich zavorek}
podretezec:string; {ponese obsah hledanych zavorek}
begin
if retezec[1]<>'(' then {jestli testovany retezec vubec nezacina zavorkou, nema cenu dale pokracovat v testu}
begin
Zavorky:=''; {funkce v tomto pripade vraci prazdnou promennou}
exit; {ukonceni funkce}
end;
pruchod:=1; {nastaveni pruchodove promenne na zacatek retezce}
pocet:=0; {vynulovani zavorkove promenne}
repeat
begin
if retezec[pruchod]='(' then inc(pocet); {pokud je nalezena oteviraci zavorka, dojde k navyseni zavorkove promenne}
if retezec[pruchod]=')' then {pokud je nalezena uzaviraci zavorka, pokracuje se dale}
begin
dec(pocet); {snizeni zavorkove promenne}
if pocet<0 then begin Selhani(1); exit; end; {pokud zavorkova promenna klesne pod nulu, znamena to, ze v retezci bylo vice uzaviracich nez oteviracich zavorek - funkce je ukoncena s chybovym hlasenim}
if pocet=0 then break; {jakmile pocet zase klesne na nulu, znamena to ze v promenne pruchod je umistena pozice uzaviraci zavorky nejvyssi urovne - cyklus je prerusen}
end;
inc(pruchod); {posunuti v retezci o jednu pozici}
end;
until pruchod=length(retezec); {v pripade ze se neskonci drive, tak se cyklus opakuje az se projde cely retezec - znamena to vsak, ze se nerovnal pocet oteviracich a uzaviracich zavorek}
if pocet<>0 then begin Selhani(1); exit; end; {pokud je zavorkova promenna vyssi nez nula, znamena to, ze v retezci bylo vice oteviracich nez uzaviracich zavorek - funkce je ukoncena s chybovym hlasenim}
podretezec:=copy(retezec,2,pruchod-2); {do podretezce se zkopiruje obsah nalezene zavorky - bez hranicnich zavorek}
retezec:=copy(retezec,pruchod+1,255); {retezec ze sebe vyjme obsah zavorek vcetne zavorek samotnych}
if podretezec='' then podretezec:='0'; {pokud je na vstupu nahodou zadano (), tedy prazdna zavorka, neni to povazovano za chybu, ale obsahu zavorky se priradi hodnota nula}
Zavorky:=podretezec; {zaverecne prirazeni obsahu zavorky funkci}
end;
function Promenna(retezec:string):char; {vraci zastupny znak promenne nebo mezeru, pokud se o promennou nejedna - na vstupu teto funkce je retezec, ktery se nachazi pred znakem '=' - tento retezec by mel byt jednoznakovy, pokud neni, bude vracena mezera}
var znak:char; {reprezentace promenne}
begin
OdstranitMezery(retezec); {odstraneni pripadnych mezer ze zacatku vstupniho retezce}
znak:=upcase(retezec[1]); {prvni znak ze vstupniho retezce se prevede na svoji velkou variantu}
if (znak<'A') or (znak>'Z') then {pokud neni ordinalni hodnota daneho znaku ve vymezene hodnote, nebude se jednat o promennou}
begin
Promenna:=' '; {prirazeni mezery cele funkci, znamena to negativni reakci na overeni promenne}
exit; {ukonceni overeni}
end;
retezec:=copy(retezec,2,255); {vyjmuti prvniho znaku ze vstupniho retezce}
OdstranitMezery(retezec); {opet se odstrani mozne mezery}
if retezec<>'' then {pokud se v overovanem retezci stale neco nachazi, urcite nejde o promennou}
begin
Promenna:=' '; {prirazeni mezery cele funkci, znamena to negativni reakci na overeni promenne}
exit; {ukonceni overeni}
end;
Promenna:=znak; {zaverecne prirazeni znaku funkci}
end;
function Cislo(var retezec:string):real; {vyjme ze vstupniho retezce neprerusenou sadu cislic a tyto vycisli jako hodnotu, pokud jsou nalezeny zavorky, jejich obsah je rekurzivne zpracovan funkci Vyhodnoceni a nakonec je tedy stejne vraceno cislo}
const nekonecno:real=1E35; {pomocna konstanta pro vypocet tangens}
var hodnota:string; {podretezec, do ktereho se postupne nacitaji cisla od zacatku vstupniho retezce az po libovolny operator}
obsahzavorky:string; {promenna bude obsahovat obsah zavorky, ktera je nalezena funkci Zavorky}
testpromenne:string; {bude obsahovat retezec, ktery je treba otestovat, zda se nejedna o promennou}
opakovani:integer; {pomocna promenna pro cyklus}
vyslednahodnota:real; {promenna pro vyslednou transformaci podretezce na hodnotu}
znamenko:integer; {pokud vstupni retezec bude zacinat zapornym znamenkem, tato promenna o tom ponese informaci}
begin
OdstranitMezery(retezec); {pokud jsou na zacatku vstupniho retezce mezery, dojde k jejich odstraneni}
znamenko:=1; {defaultne je nastaveno, ze retezec zacina kladne}
if retezec='' then {pokud v retezci byly jen mezery a retezec je tim padem nyni zcela prazdny, funkce konci selhanim a dale nepokracuje - tento typ selhani nastava i pri uplnem zpracovani retezce a ukoncuje vyhodnocovaci cyklus}
begin
Selhani(1); {cislo selhani bude ulozeno do globalni promenne chyba}
exit; {predcasne ukonceni cele funkce Cislo}
end;
if retezec[1]='-' then {v pripade, ze hned prvni prvek vstupniho vyrazu je zaporny operator, dojde pred dalsim zpracovanim k uprave}
begin
znamenko:=-1; {ulozi se informace o zapornosti, nakonec se tim bude vysledek nasobit}
retezec:=copy(retezec,2,255); {retezec se sam do sebe zkopiruje od druheho mista do konce - nyni je zbaven operatoru na zacatku a muze byt dale zpracovan}
end;
obsahzavorky:=Zavorky(retezec); {funkce Cislo je pripravena izolovat ze vstupniho retezce pouze ciselnou hodnotu a predpoklada, ze na prvnim nebo druhem miste retezce cisla opravdu jsou - proto se musi prednostne zjistit, jestli retezec nahodou nezacina zavorkovou strukturou - pokud ano, tak se obsah zavorky nejvyssi urovne nacte do teto promenne}
if obsahzavorky<>'' then {pokud funkce Zavorky vrati nejaky obsah zavorek, je nutne tento obsah zpracovat}
begin {zde je dobre se zamyslet, jak se navzajem funkce rekurzivne volaji v pripade, ze jsou nalezeny zavorky}
vyslednahodnota:=Vyhodnoceni(obsahzavorky); {funkce Vyhodnoceni vrati ciselnou hodnotu odpovidajici vyrazu v zavorce - tato hodnota je prirazena vysledku}
Cislo:=vyslednahodnota*znamenko; {funkci Cislo je prirazen vysledek, ktery se vynasobi znamenkem, coz zaruci spravnou hodnotu}
exit; {cela funce Cisla je v tuto chvili zastavena, protoze pres toto rozhodovani se dostane pouze tehdy, kdyz se zpracovani nachazi na nejnizsi urovni zavorek - lze tedy normalne nacist cislo}
end;
{zacatek - zpracovani funkci} {pokud se funkce Cislo postupne rekurzivnim volanim dostane az na nejnizsi uroven zavorek, je mozne ze narazi misto cisel na nejakou funkci se svym parametrem, ktery je v zavorce - v takovem pripade se algoritmus presmeruje do zpracovani dane funkce, opet bude nutne vyhodnotit parametr v zavorce pomoci funkci Zavorka a Vyhodnoceni, ktere se zase mohou rekurzivne volat...}
{signum}
if ZacinaPodretezcem('SGN',retezec) then {vyhodnoti zda posloupnost znaku odpovida dane funkci}
begin
obsahzavorky:=Zavorky(retezec); {nacteni parametru, ktery je v zavorce}
if chyba>0 then exit; {pokud funkce Zavorky nahlasi chybu, cela funkce Cislo je prerusena}
if obsahzavorky='' then begin Selhani(3); exit; end; {pokud je parametr prazdny, dojde k selhani a cela funkce Cislo je prerusena}
vyslednahodnota:=Vyhodnoceni(obsahzavorky); {zjisteni hodnoty parametru}
{nasledujici cast je pro kazdou funkci charakteristicka}
if vyslednahodnota>0 then vyslednahodnota:=1;
if vyslednahodnota<0 then vyslednahodnota:=-1;
{dale je zase spolecne zpracovani}
Cislo:=vyslednahodnota*znamenko; {korekce vysledne hodnoty podle znamenka v pameti}
exit; {ukonceni funkce Cisla}
end;
{absolutni hodnota}
if ZacinaPodretezcem('ABS',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
if vyslednahodnota<0 then vyslednahodnota:=-vyslednahodnota;
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{druha mocnina}
if ZacinaPodretezcem('SQR',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
vyslednahodnota:=sqr(vyslednahodnota);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{druha odmocnina}
if ZacinaPodretezcem('SQRT',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
if vyslednahodnota<0 then begin Selhani(7); exit; end;
vyslednahodnota:=sqrt(vyslednahodnota);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{logaritmus naturalis}
if ZacinaPodretezcem('LN',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
if vyslednahodnota<=0 then begin Selhani(7); exit; end;
vyslednahodnota:=ln(vyslednahodnota);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{logaritmus o zakladu 10}
if ZacinaPodretezcem('LOG',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
if vyslednahodnota<=0 then begin Selhani(7); exit; end;
vyslednahodnota:=ln(vyslednahodnota)/ln(10);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{Ludolfovo cislo}
if ZacinaPodretezcem('PI',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky<>'' then begin Selhani(3); exit; end;
vyslednahodnota:=Pi;
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{Eulerovo cislo}
if ZacinaPodretezcem('EXP',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky<>'' then begin Selhani(3); exit; end;
vyslednahodnota:=exp(1);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{sinus}
if ZacinaPodretezcem('SIN',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
vyslednahodnota:=sin(vyslednahodnota);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{cosinus}
if ZacinaPodretezcem('COS',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
vyslednahodnota:=cos(vyslednahodnota);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{tangens}
if ZacinaPodretezcem('TAN',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
if cos(vyslednahodnota)=0 then begin Selhani(7); exit; end;
if abs(cos(vyslednahodnota))<1E-35 then vyslednahodnota:=nekonecno else vyslednahodnota:=sin(vyslednahodnota)/cos(vyslednahodnota);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{arcus sinus}
if ZacinaPodretezcem('ARCSIN',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
if ((vyslednahodnota<=-1) or (vyslednahodnota>=1)) then begin Selhani(7); exit; end;
vyslednahodnota:=arcsin(vyslednahodnota);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{arcus cosinus}
if ZacinaPodretezcem('ARCCOS',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
if ((vyslednahodnota<=-1) or (vyslednahodnota>=1)) then begin Selhani(7); exit; end;
vyslednahodnota:=arccos(vyslednahodnota);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{arcus tangens}
if ZacinaPodretezcem('ARCTAN',retezec) then
begin
obsahzavorky:=Zavorky(retezec);
if chyba>0 then exit;
if obsahzavorky='' then begin Selhani(3); exit; end;
vyslednahodnota:=Vyhodnoceni(obsahzavorky);
vyslednahodnota:=arctan(vyslednahodnota);
Cislo:=vyslednahodnota*znamenko;
exit;
end;
{konec - zpracovani funkci}
hodnota:=''; {vycisteni promenne, do ktere se budou nacitat cisla}
for opakovani:=1 to length(retezec) do {od zacatku do konce vstupniho retezce se proveruje, zda jsou dane prvky cisla}
begin
if {(retezec[opakovani]>='0') and (retezec[opakovani]<='9')} (retezec[opakovani] in ['0'..'9','.']) then hodnota:=hodnota+retezec[opakovani] {jestli jsou prvky cisla, budou se postupne pridavat do podretezce}
else break; {jakmile se narazi na prvni prvek, ktery neni cislem, cyklus se zastavi a v promenne opakovani zustane ulozeno misto prvniho neciselneho prvku}
end;
retezec:=copy(retezec,opakovani,255); {retezec se sam do sebe zkopiruje od prvniho neciselneho prvku az do konce}
if hodnota='' then {pokud v celem vstupnim retezci nebylo ani jedno cislo, je treba overit zda se nejedna o promennou - pokud se nejedna ani o promennou, funkce konci selhanim a dale nepokracuje}
begin
testpromenne:=copy(retezec,1,1); {prvni znak retezce se izoluje}
retezec:=copy(retezec,2,255); {retezec se o vyjmuty znak zkrati}
if Promenna(testpromenne)<>' ' then {pokud test promenne konci pozitivne, je treba danou promennou nacist}
begin
Cislo:=promenne[Promenna(testpromenne)]*znamenko; {funkci Cislo je prirazena hodnota dane promenne z pole promennych, samozrejmosti je nasobeni znamenkem}
exit; {funkci Cislo byla prirazena hodnota, neni tedy nutne dale pokracovat}
end;
Selhani(5); {pokud se o promennou nejednalo, kod selhani bude ulozen do globalni promenne chyba}
exit; {predcasne ukonceni cele funkce Cislo}
end;
val(hodnota,vyslednahodnota,opakovani); {vznikly retezec slozeny s cisel (muze zacinat zapornym operatorem) bude nyni preveden na cislo, pokud by doslo k chybe (coz ale kvuli predchozim podminkam nemuze) bylo by misto v retezci, ktere nelze vycislit ulozeno do promenne opakovani}
Cislo:=vyslednahodnota*znamenko; {zaverecne prirazeni vysledne hodnoty funkci - znamenko hodnotu opravi tak, aby odpovidala puvodnimu vyrazu}
end;
function TypOperatoru(var retezec:string):integer; {volanim procedury ZacinaPodretezcem porovnava postupne vsechny definovane operatory se zacatkem vstupniho retezce - pokud nektery nalezne, procedura ZacinaPodretezcem jej ze vstupniho retezce vyjme a umozni, aby funkci Operator bylo prirazeno prislusne identifikacni cislo obsahujici informaci o priorite}
begin
OdstranitMezery(retezec); {pokud jsou na zacatku vstupniho retezce mezery, dojde k jejich odstraneni}
{pokud budou nektere opratory slozeny z vice znaku, musi byt umisteny na zacatku seznamu!!!}
{jakmile se jeden oparator nalezne, prubeh funkce je prerusen}
if ZacinaPodretezcem('DIV',retezec)=true then begin TypOperatoru:=21; exit; end;
if ZacinaPodretezcem('MOD',retezec)=true then begin TypOperatoru:=22; exit; end;
if ZacinaPodretezcem('=',retezec)=true then begin TypOperatoru:=0; exit; end;
if ZacinaPodretezcem('+',retezec)=true then begin TypOperatoru:=10; exit; end;
if ZacinaPodretezcem('-',retezec)=true then begin TypOperatoru:=11; exit; end;
if ZacinaPodretezcem('*',retezec)=true then begin TypOperatoru:=20; exit; end;
if ZacinaPodretezcem('/',retezec)=true then begin TypOperatoru:=23; exit; end;
if ZacinaPodretezcem('^',retezec)=true then begin TypOperatoru:=30; exit; end;
Selhani(4); {pokud neni zadny definovany operator nalezen, funkce konci selhanim}
end;
function Vyhodnoceni(retezec:string):real; {pri vyuziti vsech vyse zminenych procedur a funkci urci vyslednou hodnotu vyrazu zadaneho uzivatelem}
var cisla:zasobnik1; {zasobnik pro cisla}
operatory:zasobnik2; {zasobnik pro operatory}
c:real; {promenna, do ktere se ze zasobniku pro cisla budou nacitat prvky}
o:integer; {promenna, do ktere se ze zasobniku pro operatory budou nacitat prvky}
pozice:integer; {pomocna promenna pro nalezeni pozice znaku '='}
znak:char; {bude docasne nest identitu pripadne promenne ve vyhodnocovanem retezci}
cast1,cast2:string; {promenne pro rozsekani retezce na cast pred a po znaku '='}
begin
{zacatek overeni, zda je zpracovavany vyraz prirazenim do promenne nebo je pozadovan primo vysledek}
pozice:=pos('=',retezec); {pokus o nalezeni znaku '=' ve vstupnim retezci - jeho pozice je ulozena do promenne}
if pozice>0 then {pokud obsahuje '=', jde zrejme o prirazeni}
begin
cast1:=copy(retezec,1,pozice-1); {do cast1 se ulozi znaky pred '='}
cast2:=copy(retezec,pozice+1,255); {do cast2 se ulozi znaky za '='}
znak:=Promenna(cast1); {znaky pred '=' jsou otestovany, zda se nejedna o promennou}
if znak=' ' then {pokud je test kontroly promenne negativni, je podano chybove hlaseni}
begin
chyba:=6; {kod chyby}
exit; {predcasne ukonceni celeho zpracovani}
end;
promenne[znak]:=Vyhodnoceni(cast2); {pokud se overeni povedlo, rekurzivne se vyhodnoti cast za '=' a vysledek se priradi do pole promennych na pozadovane misto}
Vyhodnoceni:=promenne[znak]; {cela funkce Vyhodnoceni vrati hodnotu prave vypoctene promenne}
exit; {pokud se jednalo o prirazeni promenne, dalsi vypocet neni potreba, takze proces je prerusen}
end;
{konec overeni}
retezec:=retezec+'='; {mechanismus pozaduje aby byl v retezci cely pocet usporadanych dvojic [cislo,operator]}
Inicializovat1(cisla); {vynulovani prislusneho zasobniku}
Inicializovat2(operatory); {vynulovani prislusneho zasobniku}
Selhani(0); {prozatim je vse v poradku}
while chyba=0 do
begin
c:=Cislo(retezec); {ze vstupniho retezce se nacte cislo}
if chyba<>0 then break; {pokud procedura Cislo nahlasi chybu, cely vyhodnocovaci proces je ukoncen - tato chyba je nahlasena take pri uplnem zpracovani retezce a slouzi jako ukonceni celeho algoritmu}
o:=TypOperatoru(retezec); {ze vstupniho retezce se nacte operator}
if chyba<>0 then break;
Vlozit1(cisla,c); {do ciselneho zasobniku je vlozeno nactene cislo}
if Prazdny2(operatory)=false then {pokud jiz v operatorovem zasobniku cekaji operatori, musi se nejdriv pred vlozenim noveho zpracovat podle priority}
begin
while Priorita(Nacist2(operatory))>=Priorita(o) do {dokud je priorita posledniho operatoru z operatoroveho zasobniku vetsi nebo rovna priorite soucasne nacteneho operatoru ze vstupniho retezce, tak se prednostne provadeji operace s operatori zasobniku}
begin
Operace(cisla,Vyjmout2(operatory)); {provede se operace se dvema nejvyssimi cisli v cislovem zasobniku, ktera je definovana operatorem z operatoroveho zasobniku}
if Prazdny2(operatory)=true then break; {pokud je operatorovy zasobnik zcela vycerpan, cyklus je prerusen}
end;
end;
Vlozit2(operatory,o); {po tom, co se bud provedli vsechny vice prioritni operace nebo byl operatorovy zasobnik vycerpan, lze jiz vlozit soucasne nacteny operator do operatoroveho zasobniku}
end;
Vyhodnoceni:=Vyjmout1(cisla); {po probehnuti vsech operaci je v ciselnem uz pouze vysledek celeho vyrazu - lze jej tedy priradit funkci}
if chyba=1 then Selhani(0); {ukonceni retezce prazdnotou ve skutecnosti neni chyba}
if chyba>1 then Vyhodnoceni:=0; {pokud je nahlasena jina chyba vysledek je urcite spatne a proto se resetuje}
end;
function Vyraz(retezec:string;var hlaseni:integer):real; {pomocna funkce kvuli lepsimu pouziti funkce Vyhodnoceni v programu}
begin
Vyraz:=Vyhodnoceni(retezec); {prirazeni vysledek celeho procesu funkci}
hlaseni:=chyba; {kod chyby je ulozen do vystupni promenne}
end;
{konec - interpretace vyrazu}
{zacatek - reseni rovnice}
procedure Bisekce(retezec:string;krok,leva,prava:real);
var stred,delka:real;
l,r:real;
hodnota1,hodnota2:real;
help1,help2:integer;
begin
l:=leva;
r:=prava;
repeat
delka:=abs(r-l);
stred:=(l+r)/2;
repeat
promenne['X']:=stred;
hodnota1:=Vyraz(retezec,help1);
if help1>2 then stred:=stred+krok;
until help1<2;
repeat
promenne['X']:=l;
hodnota2:=Vyraz(retezec,help2);
if help2>2 then stred:=l+krok;
until help2<2;
if (hodnota1*hodnota2)<0 then r:=stred
else l:=stred;
until ((delka<krok) or (abs(hodnota1)<krok));
pocetkorenu:=pocetkorenu+1;
if pocetkorenu>50 then begin preteceni:=true; delline; GotoXY(WhereX,WhereY-1); exit; end;
pruseciky[pocetkorenu]:=stred;
end;
procedure RegulaFalsi(retezec:string;krok,leva,prava:real);
var prusecik,delka:real;
l,r:real;
hodnota1,hodnota2:real;
help1,help2:integer;
begin
l:=leva;
r:=prava;
repeat
delka:=abs(r-l);
repeat
promenne['X']:=l;
hodnota1:=Vyraz(retezec,help1);
if help1>2 then l:=l+krok;
until help1<2;
repeat
promenne['X']:=r;
hodnota2:=Vyraz(retezec,help2);
if help2>2 then r:=r-krok;
until help2<2;
if hodnota1-hodnota2<>0 then prusecik:=l-hodnota1*((r-l)/(hodnota2-hodnota1))
else prusecik:=l-hodnota1*((r-l)/(0.00000001));
repeat
promenne['X']:=prusecik;
hodnota2:=Vyraz(retezec,help2);
if help2>2 then prusecik:=prusecik+krok;
until help2<2;
if (hodnota2*hodnota1)<0 then r:=prusecik
else l:=prusecik;
until ((delka<krok) or (abs(hodnota1)<krok));
pocetkorenu:=pocetkorenu+1;
if pocetkorenu>50 then begin preteceni:=true; delline; GotoXY(WhereX,WhereY-1); exit; end;
pruseciky[pocetkorenu]:=prusecik;
end;
procedure Newton(retezec:string;krok,leva,prava:real);
var stary,novy:real;
l,r:real;
hodnota1,hodnota2:real;
help1,help2:integer;
begin
l:=leva;
r:=prava;
stary:=(l+r)/2;
repeat
repeat
promenne['X']:=stary-krok;
hodnota1:=Vyraz(retezec,help1);
if help1>2 then stary:=stary-krok;
until help1<2;
repeat
promenne['X']:=stary+krok;
hodnota2:=Vyraz(retezec,help2);
if help2>2 then stary:=stary+krok;
until help2<2;
if hodnota1-hodnota2<>0 then novy:=(stary-krok)-hodnota1*(((stary+krok)-(stary-krok))/(hodnota2-hodnota1))
else novy:=(stary-krok)-hodnota1*(((stary+krok)-(stary-krok))/(0.00000001));
stary:=novy;
repeat
promenne['X']:=novy;
hodnota2:=Vyraz(retezec,help2);
if help2>2 then novy:=novy+krok;
until help2<2;
until abs(hodnota2)<krok;
pocetkorenu:=pocetkorenu+1;
if pocetkorenu>50 then begin preteceni:=true; delline; GotoXY(WhereX,WhereY-1); exit; end;
pruseciky[pocetkorenu]:=novy;
end;
procedure Jednoducha(retezec:string;krok,leva,prava:real;rezim:byte);
var l,r:real;
hodnota1,hodnota2:real;
help1,help2:integer;
nacitani:string;
s1,s2,v1,v2,m1,m2,h1,h2:word;
begin
l:=leva;
if rezim=1 then r:=leva+krok
else r:=leva+0.1;
writeln;
nacitani:='.';
textcolor(10);
gettime(h1,m1,v1,s1);
repeat
promenne['X']:=l;
hodnota1:=Vyraz(retezec,help1);
promenne['X']:=r;
hodnota2:=Vyraz(retezec,help2);
if (((hodnota1*hodnota2)<=0) and (help1<2) and (help2<2)) then
begin
if rezim=1 then
begin
pocetkorenu:=pocetkorenu+1;
if pocetkorenu>50 then begin preteceni:=true; delline; GotoXY(WhereX,WhereY-1); exit; end;
pruseciky[pocetkorenu]:=(l+r)/2;
end
else
begin
case rezim of
2: Bisekce(retezec,krok,l,r);
3: RegulaFalsi(retezec,krok,l,r);
4: Newton(retezec,krok,l,r)
end;
if pocetkorenu>50 then begin exit; end;
end;
end;
gettime(h2,m2,v2,s2);
if ((nacitani='.') and (((h2*60*60*100+m2*60*100+v2*100+s2)-(h1*60*60*100+m1*60*100+v1*100+s1))=100)) then begin GotoXY(WhereX-9,WhereY); clreol; nacitani:='..'; write('Pocitam ',nacitani); gettime(h1,m1,v1,s1); end;
if ((nacitani='..') and (((h2*60*60*100+m2*60*100+v2*100+s2)-(h1*60*60*100+m1*60*100+v1*100+s1))=100)) then begin GotoXY(WhereX-10,WhereY); clreol; nacitani:='...'; write('Pocitam ',nacitani); gettime(h1,m1,v1,s1); end;
if ((nacitani='...') and (((h2*60*60*100+m2*60*100+v2*100+s2)-(h1*60*60*100+m1*60*100+v1*100+s1))=100)) then begin GotoXY(WhereX-11,WhereY); clreol; nacitani:='.'; write('Pocitam ',nacitani); gettime(h1,m1,v1,s1); end;
l:=r;
if rezim=1 then r:=r+krok
else r:=r+0.1;
until r>=prava;
delline;
GotoXY(WhereX,WhereY-1);
end;
{konec - reseni rovnice}
{zacatek - interface}
procedure Kalkulator;
var mista:integer;
nacteni:string;
neplatnost:integer;
begin
mista:=3;
writeln;
textcolor(15);
write('Pocet desetinnych mist vysledku (default=3): ');
textcolor(11);
readln(nacteni);
if nacteni<>'' then val(nacteni,mista,neplatnost);
if neplatnost>0 then mista:=3;
repeat
writeln;
textcolor(15);
write('Zadej vyraz: ');
textcolor(14);
readln(vstup);
if vstup='' then break;
x:=Vyraz(vstup,chyba);
if chyba=0 then writeln(vstup,'=',x:5:mista)
else begin textcolor(12); writeln ('Chyba: ',ChyboveHlaseni(chyba)); end;
until false;
end;
procedure Koreny;
var mista:integer;
nacteni:string;
neplatnost:integer;
q:integer;
kontrola:boolean;
presnost,levamez,pravamez:real;
begin
mista:=3;
writeln;
textcolor(15);
write('Pocet desetinnych mist vysledku (default=3): ');
textcolor(11);
readln(nacteni);
if nacteni<>'' then val(nacteni,mista,neplatnost);
if neplatnost>0 then mista:=3;
repeat
writeln;
pocetkorenu:=0;
preteceni:=false;
repeat
kontrola:=true;
textcolor(15);
write('Zadej rovnici: ');
textcolor(14);
write('0=');
readln(vstup);
promenne['Z']:=1;
x:=Vyraz(vstup,chyba);
if ((chyba>=3) and (chyba<=6)) then kontrola:=false;
for q:=1 to length(vstup) do
begin
if vstup[q]='=' then kontrola:=false;
end;
if vstup='' then kontrola:=true;
if kontrola=false then begin textcolor(12); writeln ('Chyba: Spatne zadana rovnice'); writeln; end;
until kontrola=true;
if vstup='' then break;
textcolor(15);
presnost:=0;
writeln;
write('Zadej presnost (default=0.001): ');
textcolor(11);
readln(nacteni);
if nacteni<>'' then val(nacteni,presnost,neplatnost);
if presnost=0 then neplatnost:=1;
if neplatnost>0 then presnost:=0.001;
writeln;
textcolor(15);
write('Zadej levou mez (default=-10): ');
textcolor(11);
readln(nacteni);
if nacteni<>'' then val(nacteni,levamez,neplatnost);
if neplatnost>0 then levamez:=-10;
repeat
writeln;
textcolor(15);
write('Zadej pravou mez (default=10): ');
textcolor(11);
readln(nacteni);
if nacteni<>'' then val(nacteni,pravamez,neplatnost);
if neplatnost>0 then pravamez:=10;
if pravamez<(levamez+presnost) then begin textcolor(12); writeln ('Chyba: Spatne zadane meze'); textcolor(15); end;
until pravamez>=(levamez+presnost);
repeat
begin
writeln;
textcolor(15);
writeln('Jakou numerickou metodu chcete pouzit?');
writeln('(1) Jednoduche projiti intervalu');
writeln('(2) Bisekce (puleni intervalu)');
writeln('(3) Regula falsi (metoda secen)');
writeln('(4) Newton (metoda tecen)');
write('Volba: ');
textcolor(11);
readln(volba);
end;
until ((volba>=1) and (volba<=4));
case volba of
1: Jednoducha(vstup,presnost,levamez,pravamez,1);
2: Jednoducha(vstup,presnost,levamez,pravamez,2);
3: Jednoducha(vstup,presnost,levamez,pravamez,3);
4: Jednoducha(vstup,presnost,levamez,pravamez,4)
end;
writeln;
textcolor(15);
if preteceni=true then writeln('Rovnice ma nekonecne mnoho reseni (nebo vice nez 50)') else
begin
if pocetkorenu=0 then writeln('Rovnice nema reseni v R') else
begin
textcolor(14);
for q:=1 to pocetkorenu do writeln('X',q,'=',pruseciky[q]:5:mista);
end;
end;
until false;
end;
procedure Napoveda;
begin
textcolor(10);
writeln; writeln('-=NAPOVEDA=-');
writeln; writeln('1) Operatory');
writeln('+ priklad: a+b akce: soucet'); writeln('- priklad: a-b akce: rozdil');
writeln('* priklad: a*b akce: soucin'); writeln('/ priklad: a/b akce: podil');
writeln('div priklad: a div b akce: celociselne deleni'); writeln('mod priklad: a mod b akce: zbytek celociselneho deleni cisel');
writeln('^ priklad: a^b akce: umocneni'); writeln('= priklad: a=5 akce: prirazeni hodnoty do promenne');
writeln; writeln('2) Funkce');
writeln('- kazda funkce ma v zavorce svuj parametr - napr.: sqrt(2)');
writeln('sgn akce: signum'); writeln('abs akce: absolutni hodnota');
writeln('sqr akce: druha mocnina'); writeln('sqrt akce: druha odmocnina');
writeln('ln akce: prirozeny logaritmus'); writeln('log akce: logaritmus o zakladu 10');
writeln('sin akce: sinus, parametr zadavat v radianech'); writeln('cos akce: cosinus, parametr zadavat v radianech'); writeln('tan akce: tangens, parametr zadavat v radianech');
writeln('arcsin akce: arcus sinus'); writeln('arccos akce: arcus cosinus'); writeln('arctan akce: arcus tangens');
writeln; writeln('3) Konstanty');
writeln('exp akce: Eulerovo cislo'); writeln('pi akce: Ludolfovo cislo');
writeln; writeln('4) Promenne');
writeln('- pismena A az Z jsou vyhrazena jako pametove promenne');
writeln('- zapis prirazeni do promenne: a=vyraz');
writeln; writeln('5) Syntax');
writeln('- povolene znaky: promenne, operatory, funkce, cisla, desetinna tecka, zavorky');
writeln('- funkce musi mit svuj parametr v zavorce');
writeln('- v rezimu reseni rovnic se za promennou povazuje znak "x"');
writeln('- prazdny vstup vyrazu nebo rovnice vrati program do hlavni nabidky');
end;
{konec - interface}
{zacatek - vlastni program}
begin
for i:='A' to 'Z' do promenne[i]:=0; {vynulovani pole promennych}
clrscr;
writeln('SOLVER - interpreter vyrazu a iteracni reseni rovnic');
writeln('Copyright (c) 2007 Petr Koupy');
repeat
repeat
begin
writeln;
textcolor(7);
writeln('Co chcete provest?');
writeln('(1) Zapnout kalkulator');
writeln('(2) Nalezt koreny rovnice');
writeln('(3) Zobrazit pamet');
writeln('(4) Vynulovat pamet');
writeln('(5) Zobrazit napovedu');
writeln('(6) Ukoncit program');
write('Volba: ');
textcolor(11);
readln(volba);
end;
until ((volba>=1) and (volba<=6));
case volba of
1: Kalkulator;
2: Koreny;
3: begin writeln; textcolor(14); for i:='A' to 'Z' do writeln(i,'=',promenne[i]:5:3); textcolor(7); end;
4: begin for i:='A' to 'Z' do promenne[i]:=0; writeln; textcolor(15); writeln('Pamet vynulovana...'); textcolor(7); end;
5: Napoveda;
6: break
end;
until false;
end.