Skocz do zawartości

Pomoc! Pascal! musze napisac program


mtbmlody

Polecane posty

Witam mam za zadanie napisanie kalkulatora string który np po wpisaniu wyrazenie 12*4/3-2+7*2 poda mi odrazu wynik. Szukalem w necie nic nie znalalzem mam napisane tyle i wisze niewiem co dalej zrobic prosze o pomoc.

 

program Project1;

 

{$APPTYPE CONSOLE}

 

{warunki zmiennych}

var

wyrazenie,wyrazenie1:string;

pamiec0,pamiec1,pamiec2:string;

pamiec1u,pamiec2u,e,i,j,k,b:integer;

 

begin

 

{zerowanie pamieci zmiennych}

pamiec0:='';

pamiec1:='';

pamiec2:='';

 

{podanie wyrazenia matematycznego do obliczenia}

writeln('podaj wyrazenie ');

readln(wyrazenie);

 

{wyszukiwanie pierwszego znaku (znaku mnożenia) }

for i:=1 to length(wyrazenie) do

begin

pamiec0:=pamiec0+wyrazenie;

if wyrazenie='*' then

{natrafienie na znak}

begin

for k:=i+1 to length(wyrazenie) do

{wprowadzenie do pamieci2 liczby po znaku}

begin

if wyrazenie[j]=('+') then break;

if wyrazenie[j]=('-') then break;

if wyrazenie[j]=('*') then break;

if wyrazenie[j]=('/') then break;

pamiec2:=pamiec2+wyrazenie[k];

end;

for j:=i-1 downto 1 do

begin

{wprowadzenie do pamieci1 wyrazenie przed znakiem}

if wyrazenie[j]=('+') then break;

if wyrazenie[j]=('-') then break;

if wyrazenie[j]=('*') then break;

if wyrazenie[j]=('/') then break;

pamiec1:=wyrazenie[j]+pamiec1;

end;

for e:=1 to j do wyrazenie1:=wyrazenie;

 

end;

 

end;

writeln(pamiec0);

writeln(pamiec1);

writeln(pamiec2);

val(pamiec1,pamiec1u,B);

val(pamiec2,pamiec2u,B);

writeln(pamiec1u*pamiec2u);

readln;

 

 

end.

Link do komentarza
Udostępnij na innych stronach

Witam :)

 

Mam dla Ciebie program, który napisałem jakieś dwa latka temu. Jest to prosty kalkulator, właśnie taki, jakiego potrzebujesz :) Niestety, w pierwotnej wersji program napisany został dla aplikacji windows i po przeniesieniu kodu na konsole, okazało się, iż zawiera błąd. Ponieważ cierpię na brak wolnego czasu, nie debugowałem, dopisałem małą łatkę usuwającą ten bug. Pozdrawiam :)

 

ps. posiadam też wersje kalkulatora w C++

 

KOD

program Calc;

 

{$APPTYPE CONSOLE}

 

uses

SysUtils;

 

var

Wyr: String;

x : Integer;

tmp: String;

 

{

* - mnozenie

/ - dzielenie

+ - dodawanie

- - odejmowanie

}

 

function Calc(w: String): String;

var

x : Integer;

l : Integer;

p1: Integer;

p2: Integer;

p3: Integer;

p4: Integer;

t1: Integer;

t2: Integer;

t : Integer;

begin

x :=0;

l :=0;

p1:=0;

p2:=0;

p3:=0;

p4:=0;

t1:=0;

t2:=0;

t :=0;

 

// Mnozenie

 

for x:=Length(w) downto 1 do

begin

if w[x]='*' then

begin

p2:=x-1;

for l:=p2 downto 1 do

begin

if (w[l]='*') or (w[l]='/') or (w[l]='+') or

(w[l]='-') or (l=1) then

begin

if l=1 then p1:=l else p1:=l+1;

break;

end;

end;

t1:=StrToInt(Copy(w,p1,p2-p1+1));

 

p3:=x+1;

for l:=p3+1 to Length(w) do

begin

if (w[l]='*') or (w[l]='/') or (w[l]='+') or

(w[l]='-') or (l=Length(w)) then

begin

if l=Length(w) then p4:=l else p4:=l-1;

break;

end;

end;

t2:=StrToInt(Copy(w,p3,p4-p3+1));

 

t:=t1*t2;

Delete(w,p1,p4-p1+1);

Insert(IntToStr(t),w,p1);

end;

end;

 

// Dzielenie

 

for x:=Length(w) downto 1 do

begin

if w[x]='/' then

begin

p2:=x-1;

for l:=p2 downto 1 do

begin

if (w[l]='*') or (w[l]='/') or (w[l]='+') or

(w[l]='-') or (l=1) then

begin

if l=1 then p1:=l else p1:=l+1;

break;

end;

end;

t1:=StrToInt(Copy(w,p1,p2-p1+1));

 

p3:=x+1;

for l:=p3+1 to Length(w) do

begin

if (w[l]='*') or (w[l]='/') or (w[l]='+') or

(w[l]='-') or (l=Length(w)) then

begin

if l=Length(w) then p4:=l else p4:=l-1;

break;

end;

end;

t2:=StrToInt(Copy(w,p3,p4-p3+1));

 

t:=t1 div t2;

Delete(w,p1,p4-p1+1);

Insert(IntToStr(t),w,p1);

end;

end;

 

// Dodawanie

 

for x:=Length(w) downto 1 do

begin

if w[x]='+' then

begin

p2:=x-1;

for l:=p2 downto 1 do

begin

if (w[l]='*') or (w[l]='/') or (w[l]='+') or

(w[l]='-') or (l=1) then

begin

if l=1 then p1:=l else p1:=l+1;

break;

end;

end;

t1:=StrToInt(Copy(w,p1,p2-p1+1));

 

p3:=x+1;

for l:=p3+1 to Length(w) do

begin

if (w[l]='*') or (w[l]='/') or (w[l]='+') or

(w[l]='-') or (l=Length(w)) then

begin

if l=Length(w) then p4:=l else p4:=l-1;

break;

end;

end;

t2:=StrToInt(Copy(w,p3,p4-p3+1));

 

t:=t1+t2;

Delete(w,p1,p4-p1+1);

Insert(IntToStr(t),w,p1);

end;

end;

 

// Odejmowanie

 

for x:=Length(w) downto 1 do

begin

if (w[x]='-') and (x>1) then

begin

if w[x-1]='-' then begin p2:=x-2; p3:=x; end else

begin p2:=x-1; p3:=x+1; end;

for l:=p2 downto 1 do

begin

if (w[l]='*') or (w[l]='/') or (w[l]='+') or

(w[l]='-') or (l=1) then

begin

if l=1 then p1:=l else p1:=l+1;

break;

end;

end;

t1:=StrToInt(Copy(w,p1,p2-p1+1));

 

for l:=p3+1 to Length(w) do

begin

if (w[l]='*') or (w[l]='/') or (w[l]='+') or

(w[l]='-') or (l=Length(w)) then

begin

if l=Length(w) then p4:=l else p4:=l-1;

break;

end;

end;

t2:=StrToInt(Copy(w,p3,p4-p3+1));

 

t:=t1-t2;

Delete(w,p1,p4-p1+1);

Insert(IntToStr(t),w,p1);

end;

end;

 

result:=w;

end;

 

begin

write('Podaj wyrazenie: ');

readln(wyr);

 

// petla usuwa spacje z wyrazenia

 

for x:=Length(Wyr) downto 1 do

begin

if (Wyr[x]=chr(32)) then Delete(Wyr,x,1);

end;

 

// latka naprawiajaca blad

 

if (Wyr[Length(Wyr)-1]='*') or (Wyr[Length(Wyr)-1]='/') or

(Wyr[Length(Wyr)-1]='+') or (Wyr[Length(Wyr)-1]='-') then

begin

tmp:=Wyr[Length(Wyr)];

Wyr[Length(Wyr)]:='0';

Insert(tmp,Wyr,Length(Wyr)+1);

end;

 

Wyr:=Calc(Wyr);

writeln('Wynik: '+Wyr);

readln(wyr);

end.

 

Link do komentarza
Udostępnij na innych stronach

Dziękuje Brainer :)

Spoko, nie ma sprawy! :)

 

@Topic Tu masz ten kodzik, o którym pisałem wcześniej. Sorka za fatalne formatowanie - Ci z Eksperta wcale nie stosują się do reguł Borlanda. :P

CODEunit BinMath;

 

interface

uses Classes;

 

type TFunkcjaObliczen0arg = function : Double;

type TFunkcjaObliczen1arg = function(A : Double) : Double;

type TFunkcjaObliczen2arg = function(A,B : Double) : Double;

type TFunkcjaObliczen3arg = function(A,B,C : Double) : Double;

type TFunkcjaObliczen4arg = function(A,B,C,D : Double) : Double;

 

 

type TStosDane = class

private

Nazwa : String;

Priorytet : Integer;

public

constructor Create(S : String; I : Integer);

end;

 

type TStos = class

private

FLista : TList;

public

constructor Create;

destructor Destroy; override;

 

procedure Dodaj(S : String; Priorytet : Integer = 0);

function Zdejmij : String;

 

function Istnieje : Boolean;

 

function AktualnyPriorytet : Integer;

procedure Wyczysc;

end;

 

type TZmienneDane = class

private

Nazwa : String;

Wartosc : Double;

public

constructor Create(N : String;W : Double);

end;

 

type TFunkcjeDane = class

private

Nazwa : String;

Priorytet : Integer;

Adres : Pointer;

Argumentow : Integer;

public

constructor Create(N : String; P : Integer; D : Pointer; A : Integer);

end;

 

type TObliczenia = class

private

FListaFunkcji : TList; //lista funkcji

FZmienne : TList; //lista zmiennych

FStosONP : TStos; //stos do konwersji na ONP

FStosWynik : TStos; //stos do obliczenia wyniku

FWyrazenie : String; //wprowadzone wyrażenie

FONP : String; //wyrażenie zamienione na ONP

 

FKodError : Integer; //kod błędu

 

procedure GenerujONP; //generowanie ONP

 

public

procedure Wyrazenie(S : String); //wprowadzenie wyrażenia

function Wynik : Double; //odczytanie wyniku

 

function ONP : String; //odczytanie wyrażenia ONP

function Blad : Integer; //odczytanie kodu błędu

function BladOpis :String; //opis występującego błędu

 

//zarządzanie obsługiwanymi funkcjami

procedure FunkcjeRejestruj(Nazwa : String; Priorytet : Integer; Arg : Integer; Adres : Pointer);

function FunkcjeID(Nazwa : String) : Integer;

function FunkcjeInfo(Id : Integer) : TFunkcjeDane;

procedure FunkcjeWyczysc;

 

//obsługa zmiennych

procedure ZmienneDodaj(N : String; W : Double);

procedure ZmienneWyczysc;

 

//konstruktor i destruktor

constructor Create;

destructor Destroy; override;

end;

 

 

implementation

uses SysUtils,Math;

 

const

MY_PI=3.14159265358979323846;

MY_E=2.7182818285;

 

//sprawdzenie, czy podany ciąg jest liczbą

function CzyLiczba(S : String) : Boolean;

var Blad: Integer;

Wart: Double;

begin

Val(S, Wart, Blad);

Result := (Blad = 0);

end;

 

//zamiana napisu na liczbę typu DOUBLE, z podmianą kropki na przecinek

function STF(A : String) : Double;

var i : Integer;

begin

for i:=1 to Length(A) do if A='.' then A:=',';

Result:=StrToFloat(A);

end;

 

//zamiana liczby DOUBLE na napis, z podmianą przecinka na kropkę

function FTS(A : Double) : String;

var i : Integer;

begin

Result:=FloatToStr(A);

for i:=1 to length(Result) do if Result=',' then Result:='.';

end;

 

function BIN_DODAWANIE(A,B : Double) : Double;

begin

Result:=A+B;

end;

 

function BIN_ODEJMOWANIE(A,B : Double) : Double;

begin

Result:=A-B;

end;

 

function BIN_MNOZENIE(A,B : Double) : Double;

begin

Result:=A*B;

end;

 

function BIN_DZIELENIE(A,B : Double) : Double;

begin

Result:=A/B;

end;

 

function BIN_SILNIA(A : Double) : Double;

var X,W,I : Integer;

begin

X:=Round(A);

W:=1;

for i:=1 to X do W:=W*i;

Result:=W;

end;

 

function BIN_SIN(A : Double) : Double;

begin

Result:=Sin(A);

end;

 

function BIN_COS(A : Double) : Double;

begin

Result:=Cos(A);

end;

 

function BIN_COSH(A : Double) : Double;

begin

Result:=CosH(A);

end;

 

function BIN_SINH(A : Double) : Double;

begin

Result:=SinH(A);

end;

 

function BIN_TGH(A : Double) : Double;

begin

Result:=TanH(A);

end;

 

function BIN_CTGH(A : Double) : Double;

begin

Result:=CotH(A);

end;

 

function BIN_ACOS(A : Double) : Double;

begin

Result:=ArcCos(A);

end;

 

function BIN_ASIN(A : Double) : Double;

begin

Result:=ArcSin(A);

end;

 

function BIN_ATG(A : Double) : Double;

begin

Result:=ArcTan(A);

end;

 

function BIN_ACTG(A : Double) : Double;

begin

Result:=(MY_PI/2)-ArcTan(A);

end;

 

function BIN_TG(A : Double) : Double;

begin

Result:=Tan(A);

end;

 

function BIN_CTG(A : Double) : Double;

begin

Result:=CoTan(A) ;

end;

 

function BIN_KOMBINACJE(K,N : Double) : Double;

begin

Result:=BIN_SILNIA(N) / ( BIN_SILNIA(N-K)*BIN_SILNIA(K) );

end;

 

function BIN_ZMIENZNAK(A : Double) : Double;

begin

Result:=-A;

end;

 

function BIN_STALAPI : Double;

begin

Result:=MY_PI;

end;

 

function BIN_STALAE : Double;

begin

Result:=MY_E;

end;

 

function BIN_SECANT(A : Double) : Double;

begin

Result:=Secant(A);

end;

 

function BIN_COSECANT(A : Double) : Double;

begin

Result:=CoSecant(A);

end;

 

function BIN_RADTODEG(A : Double) : Double;

begin

Result:=RadToDeg(A);

end;

 

function BIN_DEGTORAD(A : Double) : Double;

begin

Result:=DegToRad(A);

end;

 

function BIN_GRADTODEG(A : Double) : Double;

begin

Result:=GradToDeg(A);

end;

 

function BIN_DEGTOGRAD(A : Double) : Double;

begin

Result:=DegToGrad(A);

end;

 

function BIN_RADTOGRAD(A : Double) : Double;

begin

Result:=RadToGrad(A);

end;

 

function BIN_GRADTORAD(A : Double) : Double;

begin

Result:=GradToRad(A);

end;

 

function BIN_LOG2(A : Double) : Double;

begin

Result:=Log2(A);

end;

 

function BIN_LOG10(A : Double) : Double;

begin

Result:=Log10(A);

end;

 

function BIN_LOG(A,B : Double) : Double;

begin

Result:=LogN(A,B);

end;

 

function BIN_LOGE(A : Double) : Double;

begin

Result:=BIN_LOG10(A)/BIN_LOG10(MY_E);

end;

 

function BIN_POW(A,B : Double) : Double;

begin

Result:=Power(A,B);

end;

 

function BIN_ABS(A : Double) : Double;

begin

Result:=Abs(A);

end;

 

function BIN_SQRT(A : Double) : Double;

begin

Result:=Sqrt(A);

end;

 

function BIN_SQR(A : Double) : Double;

begin

Result:=Sqr(A);

end;

 

//============================== STOS ==========================================

 

constructor TStosDane.Create(S : String; I : Integer);

begin

inherited Create;

Nazwa:=S;

Priorytet:=I;

end;

 

constructor TStos.Create;

begin

inherited;

FLista:=TList.Create;

end;

 

destructor TStos.Destroy;

begin

Wyczysc;

FLista.Free;

inherited;

end;

 

procedure TStos.Dodaj(S : String; Priorytet : Integer = 0);

begin

FLista.Add(TStosDane.Create(S,Priorytet));

end;

 

function TStos.Zdejmij : String;

begin

if FLista.Count>0 then

begin

Result:=TStosDane(FLista.Last).Nazwa;

TStosDane(FLista.Last).Free;

FLista.Delete(FLista.Count-1);

end else Result:='';

end;

 

function TStos.Istnieje : Boolean;

begin

Result:=FLista.Count>0;

end;

 

function TStos.AktualnyPriorytet : Integer;

begin

if FLista.Count>0 then Result:=TStosDane(FLista.Last).Priorytet

else Result:=0;

end;

procedure TStos.Wyczysc;

var i : Integer;

begin

for i:=0 to FLista.Count-1 do TStosDane(FLista.Items).Free;

FLista.Clear;

end;

 

//================ F U N K C J E i Z M I E N N E ============================

 

constructor TZmienneDane.Create(N : String;W : Double);

begin

Nazwa:=N;

Wartosc:=W;

end;

 

constructor TFunkcjeDane.Create(N : String;P : Integer;D : Pointer;A : Integer);

begin

Nazwa:=N;

Priorytet:=P;

Adres:=D;

Argumentow:=A;

end;

 

//====================== O B L I C Z E N I A ===================================

 

constructor TObliczenia.Create;

begin

inherited;

 

//tworzymy niezbędne obiekty

FZmienne:=TList.Create;

FListaFunkcji:=TList.Create;

FStosONP:=TStos.Create;

FStosWynik:=TStos.Create;

 

//zerujemy znacznik błędu

FKodError:=0;

 

//dodajemy obsługę wbudowanych funkcji

//jako parametry funkcji RejestrujFunkcje podajemy NAZWĘ funkcji, jej

//PRIORYTET, liczbę ARGUMENTÓW i ADRES

 

//adres funkcji uzyskamy poprzedzając jej nazwę symbolem @

 

//im wyższy priorytet, tym szybciej dana operacja jest dokonywana

//w naszym przypadku:

// ZMIANA ZNAKU - priorytet 20

// RÓZNE FUNKCJE (sin, cos...) - priorytet 15

// MNOZENIE I DZIELENIE - priorytet 10

// DODAWANIE I ODEJMOWANIE - priorytet 5

 

FunkcjeRejestruj('pi',30,0,@BIN_STALAPI);

FunkcjeRejestruj('e',30,0,@BIN_STALAE);

FunkcjeRejestruj('zmienznak',20,1,@BIN_ZMIENZNAK);

FunkcjeRejestruj('+',5,2,@BIN_DODAWANIE);

FunkcjeRejestruj('-',5,2,@BIN_ODEJMOWANIE);

FunkcjeRejestruj('*',10,2,@BIN_MNOZENIE);

FunkcjeRejestruj('/',10,2,@BIN_DZIELENIE);

FunkcjeRejestruj('abs',15,1,@BIN_ABS);

FunkcjeRejestruj('!',15,1,@BIN_SILNIA);

FunkcjeRejestruj('sin',15,1,@BIN_SIN);

FunkcjeRejestruj('cos',15,1,@BIN_COS);

FunkcjeRejestruj('tan',15,1,@BIN_TG);

FunkcjeRejestruj('tg',15,1,@BIN_TG);

FunkcjeRejestruj('cotan',15,1,@BIN_CTG);

FunkcjeRejestruj('cot',15,1,@BIN_CTG);

FunkcjeRejestruj('ctg',15,1,@BIN_CTG);

FunkcjeRejestruj('sinh',15,1,@BIN_SINH);

FunkcjeRejestruj('cosh',15,1,@BIN_COSH);

FunkcjeRejestruj('tanh',15,1,@BIN_TGH);

FunkcjeRejestruj('tgh',15,1,@BIN_TGH);

FunkcjeRejestruj('cotanh',15,1,@BIN_CTGH);

FunkcjeRejestruj('coth',15,1,@BIN_CTGH);

FunkcjeRejestruj('ctgh',15,1,@BIN_CTGH);

FunkcjeRejestruj('secant',15,1,@BIN_SECANT);

FunkcjeRejestruj('sec',15,1,@BIN_SECANT);

FunkcjeRejestruj('cosecant',15,1,@BIN_COSECANT);

FunkcjeRejestruj('csc',15,1,@BIN_COSECANT);

FunkcjeRejestruj('arcsin',15,1,@BIN_ASIN);

FunkcjeRejestruj('arccos',15,1,@BIN_ACOS);

FunkcjeRejestruj('arctan',15,1,@BIN_ATG);

FunkcjeRejestruj('arctg',15,1,@BIN_ATG);

FunkcjeRejestruj('arccotan',15,1,@BIN_ACTG);

FunkcjeRejestruj('arcctg',15,1,@BIN_ACTG);

FunkcjeRejestruj('radtodeg',15,1,@BIN_RADTODEG);

FunkcjeRejestruj('degtorad',15,1,@BIN_DEGTORAD);

FunkcjeRejestruj('gradtodeg',15,1,@BIN_GRADTODEG);

FunkcjeRejestruj('degtograd',15,1,@BIN_DEGTOGRAD);

FunkcjeRejestruj('radtograd',15,1,@BIN_RADTOGRAD);

FunkcjeRejestruj('gradtorad',15,1,@BIN_GRADTORAD);

FunkcjeRejestruj('loge',15,1,@BIN_LOGE);

FunkcjeRejestruj('ln',15,1,@BIN_LOGE);

FunkcjeRejestruj('log2',15,1,@BIN_LOG2);

FunkcjeRejestruj('log10',15,1,@BIN_LOG10);

FunkcjeRejestruj('log',15,2,@BIN_LOG);

FunkcjeRejestruj('power',15,2,@BIN_POW);

FunkcjeRejestruj('^',15,2,@BIN_POW);

FunkcjeRejestruj('combination',15,2,@BIN_KOMBINACJE);

FunkcjeRejestruj('sqr',15,1,@BIN_SQR);

FunkcjeRejestruj('sqrt',15,1,@BIN_SQRT);

end;

 

destructor TObliczenia.Destroy;

begin

//zwalniamy pamięć

FunkcjeWyczysc;

ZmienneWyczysc;

 

FZmienne.Free;

FListaFunkcji.Free;

 

FStosONP.Free;

FStosWynik.Free;

inherited;

end;

procedure TObliczenia.ZmienneDodaj(N : String; W : Double);

var i : Integer;

begin

 

//jak nie podano nazwy - błąd

if (N='') then

begin

FKodError:=6;

Exit;

end;

 

//zamieniamy wielkość liter w nazwie na małe

N:=lowercase(N);

 

//sprawdzamy, czy w nazwie zmiennej są tylko dozwolone znaki (a..z i _)

for i:=1 to length(N) do

if not (N in ['a'..'z','_']) then

begin

FKodError:=6;

Exit;

end;

 

//nazwa jest poprawna, więc...

 

//szukamy zmiennej w bazie. Może już jest, wtedy tylko ją uaktualnimy.

for i:=0 to FZmienne.Count-1 do

if TZmienneDane(FZmienne.Items).Nazwa=N then

begin

TZmienneDane(FZmienne.Items).Wartosc:=W;

exit;

end;

 

//to nowa zmienna, dodajemy

FZmienne.Add(TZmienneDane.Create(N,W))

end;

 

procedure TObliczenia.ZmienneWyczysc;

var i : Integer;

begin

for i:=0 to FZmienne.Count-1 do TZmienneDane(FZmienne.Items).Free;

FZmienne.Clear;

end;

 

procedure TObliczenia.FunkcjeRejestruj(Nazwa : String; Priorytet : Integer; Arg : Integer; Adres : Pointer);

begin

FListaFunkcji.Add(TFunkcjeDane.Create(Nazwa,Priorytet,Adres,Arg));

end;

 

procedure TObliczenia.FunkcjeWyczysc;

var i : Integer;

begin

for i:=0 to FListaFunkcji.Count-1 do

TFunkcjeDane(FListaFunkcji.Items).Free;

FListaFunkcji.Clear;

end;

 

function TObliczenia.FunkcjeID(Nazwa : String) : Integer;

var i : Integer;

begin

Result:=-1;

Nazwa:=lowercase(Nazwa);

for i:=0 to FListaFunkcji.Count-1 do

if TFunkcjeDane(FListaFunkcji.Items).Nazwa=Nazwa then

begin

Result:=i;

Break;

end;

end;

 

function TObliczenia.FunkcjeInfo(Id : Integer) : TFunkcjeDane;

begin

if (Id>=0) and (Id

Result:=TFunkcjeDane(FListaFunkcji.Items[id]) else Result:=nil;

end;

 

//zwrócenie kodu błędu

function TObliczenia.Blad :Integer;

begin

Result:=FKodError;

end;

 

//zwrócenie opisu błędu

function TObliczenia.BladOpis :String;

begin

case FKodError of

0 : Result:='';

5 : Result:='Nieprawidłowy zakres zmiennej.';

6 : Result:='Nieprawidłowa nazwa zmiennej.';

8 : Result:='Nie znaleziono takiej zmiennej.';

else Result:='Nieznany błąd.';

end;

end;

 

//zwraca kod ONP dla wyrażenia

function TObliczenia.ONP : String;

begin

Result:=FONP;

end;

 

procedure TObliczenia.Wyrazenie(S : String);

begin

FWyrazenie:=lowercase(trim(S));

FKodError:=0;

GenerujONP;

end;

 

procedure TObliczenia.GenerujONP;

var Start,i : Integer;

Token : String;

Poprzedni : String;

Priorytet,ID : Integer;

begin

Poprzedni:=''; //poprzedni Token

FONP:=''; //początkowa treść kodu ONP

 

FStosONP.Wyczysc; //czyścimy stos ONP

 

 

Start:=1;

while start

begin

 

//pobierzmy pojedynczy token (ciąg znaków, liczbę, operator itp)

for i:=Start to Length(FWyrazenie) do if not (FWyrazenie in ['a'..'z','0'..'9','.','_']) then Break;

if i=Start then Inc(i);

Token:=Copy(FWyrazenie,Start,i-Start);

Start:=i;

 

//użytkownik może używać dowolnych nawiasów, dla nas one wszystkie to jedno: ( i )

if (Token='[') or (Token={') then Token:='(';

if (Token=]') or (Token='}') then Token:=')';

 

//mamy token - operacje na tokenie...

 

 

//jeśli symbolem jest "-" - może to oznaczać bądź to ODJĄĆ, bądź też

//ZMIENZNAK. Kiedy więc poprzedni Token był pusty (początek wyrażenia)

//lub poprzedni Token to "(" - czyli początek wyrażenia w nawiasie,

//jest to ZMIENZNAK!

if (Token='-') and

( (Poprzedni='') or (Poprzedni='(') ) then Token:='zmienznak';

 

 

//jeśli nasz Token to LICZBA, doklejamy ją do wyniku ONP

If CzyLiczba(Token) then FONP:=FONP+Token+' '

else if Token='(' then

begin

//otwieramy nawias

FStosONP.Dodaj('(',0); //dodajemy na stos z priorytetem 0 (zarezerwowany)

 

end else if Token=')' then

begin

//koniec nawiasu

 

//zdejmujemy najpierw ze stosu wszystko do czasu napotkania elementu

//o priorytecie 0, czyli początku nawiasu

while (FStosONP.Istnieje) and (FStosONP.AktualnyPriorytet0) do

FONP:=FONP+FStosONP.Zdejmij+' ';

 

//sam nawias także zdejmijmy

FStosONP.Zdejmij;

 

end else if FunkcjeID(Token)=-1 then

begin

//to nie żadna funkcja (pewnie zmienna), doklejmy do ONP

//nie doklejamy jednak znaku przecinka, który oddziela argumenty

if Token',' then FONP:=FONP+Token+' '

end else

begin

//to funkcja - pobierzmy jej numer

Id:=FunkcjeID(Token);

 

//najpierw zdejmujemy ze stosu wszystko o WYŻSZYCH PRIORYTETACH

Priorytet:=FunkcjeInfo(Id).Priorytet;

while (FStosONP.Istnieje) and (FStosONP.AktualnyPriorytet>=Priorytet) do

FONP:=FONP+FStosONP.Zdejmij+' ';

 

//i teraz na stos naszą funkcję

FStosONP.Dodaj(Token,Priorytet);

end;

 

//zapamiętujemy token jako "Poprzedni"

Poprzedni:=Token;

end;

 

//wszystko co zostało na stosie zdejmujemy

while (FStosONP.Istnieje) do

FONP:=FONP+FStosONP.Zdejmij+' ';

 

end;

 

function TObliczenia.Wynik : Double;

var Start, i,k,id : Integer;

Token : String;

A,B,C,D : String;

Adres : Pointer;

W : Double;

begin

//jak nie mamy ONP - koniec

if FONP='' then

begin

Result:=0;

exit;

end;

 

//czyścimy stos wyniku i dodajemy jako wynik 0

//priorytet nie jest istotny - więc go nie podajemy

FStosWynik.Wyczysc;

FStosWynik.Dodaj('0');

 

//zerujemy kod błędu

FKodError:=0;

 

Start:=1;

while start

begin

 

//pobierzmy pojedynczy token (ciąg znaków, liczbę, operator itp)

for i:=Start to Length(FONP) do if (FONP in [' ']) then Break;

if i=Start then Inc(i);

Token:=Copy(FONP,Start,i-Start);

Start:=i;

 

//wytnijmy białe znaki z końców tego tokena

Token:=trim(Token);

if Token='' then Continue;

 

//jeśli to liczba - to na stos

If CzyLiczba(Token) then FStosWynik.Dodaj(Token)

else if FunkcjeID(Token)=-1 then

begin

//jeśli to nie funkcja, to pewnie zmienna...

k:=0;

for i:=0 to FZmienne.Count-1 do

if TZmienneDane(FZmienne.Items).Nazwa=Token then

begin

k:=1;

break;

end;

if k=1 then FStosWynik.Dodaj(FTS(TZmienneDane(FZmienne.Items).Wartosc)) else FKodError:=8;

end else

begin

//to funkcja, więc pobierzmy jej numer i adres

Id:=FunkcjeID(Token);

Adres:=FunkcjeInfo(Id).Adres;

 

//a teraz w zależności od ilości argumentów...

case FunkcjeInfo(ID).Argumentow of

0: begin

try

W:=TFunkcjaObliczen0arg(Adres);

FStosWynik.Dodaj(FTS(W),0);

except

FKodError:=5;

end;

end;

1: begin

try

A:=FStosWynik.Zdejmij;

W:=TFunkcjaObliczen1arg(Adres)(STF(A));

FStosWynik.Dodaj(FTS(W),0);

except

FKodError:=5;

end;

end;

2: begin

try

B:=FStosWynik.Zdejmij;

if FStosWynik.Istnieje then A:=FStosWynik.Zdejmij else A:='0';

W:=TFunkcjaObliczen2arg(Adres)(STF(A),STF(B));

FStosWynik.Dodaj(FTS(W),0);

except

FKodError:=5;

end;

end;

3: begin

try

C:=FStosWynik.Zdejmij;

if FStosWynik.Istnieje then B:=FStosWynik.Zdejmij else B:='0';

if FStosWynik.Istnieje then A:=FStosWynik.Zdejmij else A:='0';

W:=TFunkcjaObliczen3arg(Adres)(STF(A),STF(B),STF?);

FStosWynik.Dodaj(FTS(W),0);

except

FKodError:=5;

end;

end;

4: begin

try

D:=FStosWynik.Zdejmij;

if FStosWynik.Istnieje then C:=FStosWynik.Zdejmij else C:='0';

if FStosWynik.Istnieje then B:=FStosWynik.Zdejmij else B:='0';

if FStosWynik.Istnieje then A:=FStosWynik.Zdejmij else A:='0';

 

W:=TFunkcjaObliczen4arg(Adres)(STF(A),STF(B),STF?,STF(D));

FStosWynik.Dodaj(FTS(W),0);

except

FKodError:=5;

end;

 

end;

end;

 

end;

 

end;

 

if FKodError=0 then Result:=STF(FStosWynik.Zdejmij)

else Result:=0;

 

end;

end.

 

Mam nadzieję, że pomoże! :)

Link do komentarza
Udostępnij na innych stronach

  • 2 weeks later...

Zarchiwizowany

Ten temat jest archiwizowany i nie można dodawać nowych odpowiedzi.

×
×
  • Utwórz nowe...