{ 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.pozice0 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 ((delka50 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 ((delka50 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)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. {konec - vlastni program}