Ler4onok
Новичок
|
    
Если можно,то комменты в коде оставить и код выслать на почту по адресу...ler4onok90@rambler.ru.....
procedure Ttrans.MakeWord;
var
pTLM,pTLM2:TListToMake;
p:Tlist;
i:integer;
begin
p:=Mylist;
pTLM:=ListToMake;
while p.sl<>'begin' do p:=p.next;
p:=p.next;
{разбить на слова}
while p.sl<>'end' do
begin
if ListToMake=nil then
begin
new(ptlm);
ptlm.ptr:=1;
ptlm.info[1]:=p.sl;
ListToMake:=ptlm;
end
else
begin
new(ptlm2);
ptlm2.ptr:=1;
ptlm2.info[1]:=p.sl;
ptlm.next:=ptlm2;
ptlm:=ptlm2;
end;
p:=p.next;
while (p.sl<>';') and (p.sl<>'of') do
begin
inc(ptlm.ptr);
ptlm.info[ptlm.ptr]:=p.sl;
p:=p.next;
end;
p:=p.next;
end;
{Разбили на слова}
ptlm.next:=nil;
end;
procedure Ttrans.perevod(w:byte; var st:array of string; var pt:byte);
var
opstek:array[1..50] of string;
ptropstek:byte;
symb:string;
i,j:byte;
str_out:array[1..200] of string;
l:integer;
start,fin:byte;
stek:string;
function prioritet(oper1,oper2:string):boolean;
begin
if oper1='=' then prioritet:=false;
if (oper1='/') then prioritet:=True;
if ((oper1='+') or (oper1='-')) and (oper2='/') then prioritet:=False;
if ((oper1='+') or (oper1='-')) and ((oper2='+') or(oper2='-')) then prioritet:=False;
if (oper1='(') then prioritet:=false;
if (oper1<>')') and (oper2='(') then prioritet:=false;
if (oper1<>'(') and (oper2=')') then prioritet:=true;
if (oper1='-') and ((oper2='+') or (oper2='-')) then prioritet:=true;
end;
begin
l:=0;
ptropstek:=0;
i:=w;
while i<=pt do
begin
if ((st[i-1]='=') or (st[i-1]='(')) and (st='-') then
begin
start:=i; fin:=pt;
stek:=st[start+1];
while start<=fin do
begin
st[fin+1]:=st[fin];
dec(fin);
end;
st[start]:='0';
inc(pt);
end;
inc(i);
end;
l:=0;
ptropstek:=0;
i:=w;
while i<=pt do
begin
symb:=st;
if (symb<>'+') and (symb<>'-') and (symb<>'/') and (symb<>'=') and
(symb<>'(') and (symb<>')') then
begin
inc(l);
str_out[l]:=symb;
end
else
begin
while (ptropstek<>0) and prioritet(opstek[ptropstek],symb) do
begin
inc(l);
str_out[l]:=opstek[ptropstek];
dec(ptropstek);
end;
if (ptropstek=0) or (symb<>')') then
begin
inc(ptropstek);
opstek[ptropstek]:=symb;
end else dec(ptropstek);
end;
inc(i);
end;
while (ptropstek<>0) do
begin
inc(l);
str_out[l]:=opstek[ptropstek];
dec(ptropstek);
end;
for i:=1 to l do st:=str_out;
pt:=l;
end;
procedure Ttrans.MekePostfix;
var
p:TListToMake;
i:integer;
m:integer;
//f:BOOLEAN;
st:array[0..200] of string;
pt,w:byte;
begin
p:=ListToMake;
while p<>nil do
begin
for i:=1 to p.ptr do st:=p.info;
pt:=p.ptr;
w:=1;
//f:=false;
if st[2]='=' then
begin
w:=1;
perevod(w,st,pt);
for i:=1 to pt do p.info:=st;
p.ptr:=pt;
end else
if st[4]='=' then
begin
w:=3;
perevod(w,st,pt);
for i:=1 to pt do p.info[i+2]:=st;
p.ptr:=pt+2;
end;
p:=p.next;
end;
end;
procedure Ttrans.MakeVir(vir:array of string; ptr:byte);
var
a1,a2,op1:string;
i:integer;
start,fin:byte;
function oper(a,op,b:string):integer;
begin
oper:=0;
if op='+' then oper:=(strtoint(a)+strtoint(b)) else
if op='-' then oper:=(strtoint(a)-strtoint(b)) else
if op='/' then oper:=(round(strtoint(a)/strtoint(b)));
end;
begin
if vir[1]=':' then
begin
for i:=3 to ptr-1 do
if (vir<>'+') and (vir<>'/') and
(vir<>'-') and (vir<>'=') then
vir:=inttostr(findIDvl(vir));
for i:=2 to ptr-1 do vir[i-2]:=vir;
ptr:=ptr-2;
end else
for i:=1 to ptr-1 do
if (vir<>'+') and (vir<>'/') and
(vir<>'-') and (vir<>'=') then vir:=inttostr(findIDvl(vir));
ptr:=ptr-1;
//for i:=0 to ptr do form1.Memo2.Lines.Add(vir);
//form1.Memo2.Lines.Add('---------');
{begin_блок выполнения выражения vir}
while true do
begin
i:=2;
repeat
a1:=vir[i-2];
a2:=vir[i-1];
op1:=vir;
//showmessage(a1+a2+op1);
inc(i);
until (op1='+') or (op1='-') or (op1='/') or (op1='=');
if op1<>'=' then
begin
vir[i-3]:=inttostr(oper(a1,op1,a2));
{begin_сдвиг}
start:=i-2;
fin:=ptr;
while start<fin do
begin
vir[start]:=vir[start+2];
inc(start);
end;
ptr:=ptr-2;
{end_сдвиг}
end
else begin
writeID(vir[i-3],strtoint(vir[i-2]));
break;
end;
end;
{end_блок выполнения выражения vir}
end;
procedure Ttrans.RunSt(str:array of string);
var
i:integer;
a:string;
begin
i:=1;
if str[0]='write' then
while str<>')'do begin
if (str<>'(') and (str<>',') then
AboutBox.showmodal1(false,inttostr(findIDvl(str)));
inc(i);
end else
if str[0]='read' then
while str<>')'do begin
if (str<>'(') and (str<>',') then
begin
a:=str;
form1.Hide;
AboutBox.showmodal;
form1.Show;
if prov_digit(perread) then
WriteID(a,strtoint(perread));
end;
inc(i);
end;
end;
procedure Ttrans.Run;
var
p,p1:Tlisttomake;
ch:char;
a:integer;
begin
p:=listtomake;
while p<>nil do
begin
if (p.info[1]='write') or (p.info[1]='read') then runst(p.info) else
if (p.info[1]='case') then
begin
a:=FindIDvl(p.info[2]);
p:=p.next;
while (p.info[1]<>'end_case') and (strtoint(p.info[1])<>a) do
begin
p:=p.next;
end;
if p.info[1]<>'end_case' then MakeVir(p.info,p.ptr);
while p.info[1]<>'end_case' do p:=p.next;
end else MakeVir(p.info,p.ptr);
p:=p.next;
end
end;
procedure Ttrans.interpritate;
var
p:TListToMake;
i:integer;
begin
MakeWord;{Сделать из слов предложения}
MekePostfix;{Сделать постфиксную запись выражений}
aboutbox.ClearAll;
Run;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
road:='';
end;
procedure TForm1.SpeedButton4Click(Sender: TObject);
var
k:integer;
p:tlist;
begin
memo2.Lines.Clear;
pr:=Ttrans.init;
if pr.scaner and pr.parcer then
begin
pr.interpritate;
Memo2.Lines.Add('Упешная интерпритация');
end;
pr.distroy;
end;
procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
road:=OpenDialog1.FileName;
memo1.Lines.LoadFromFile(OpenDialog1.FileName);
end;
end;
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
if savedialog1.Execute then
memo1.Lines.SaveToFile(savedialog1.FileName);
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
WinExec(PChar('Project1.exe'),SW_ShowNormal);
end;
procedure TForm1.SpeedButton5Click(Sender: TObject);
begin
if road<>'' then memo1.Lines.SaveToFile(road)
else
if savedialog1.Execute then
begin
memo1.Lines.SaveToFile(savedialog1.FileName);
road:=savedialog1.FileName;
end;
end;
procedure TForm1.N9Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.N10Click(Sender: TObject);
begin
form2.show;
end;
procedure TForm1.SpeedButton6Click(Sender: TObject);
begin
Aboutbox.ShowModal;
end;
end.
|
Всего сообщений: 7 | Присоединился: январь 2010 | Отправлено: 12 дек. 2010 17:48 | IP
|
|
Ler4onok
Новичок
|
спасибо,уже не надо....
|
Всего сообщений: 7 | Присоединился: январь 2010 | Отправлено: 14 дек. 2010 19:11 | IP
|
|
|
Форум
Делфи
