begin GetToken; d:= CalcPrimary; if d = 0 then writeln('Деление на нуль!') else lft:= lft div d
end
end
until not (current in ['*','/']) or (d=0);
CalcTerm:= lft end; (* CalcTerm *)
function CalcExpr: integer; var lft: integer; begin lft:= CalcTerm;
while current in ['+','-'] do begin
case current of
'+': begin GetToken; lft:= lft + CalcTerm end;
'-': begin GetToken; lft:= lft - CalcTerm end end
end;
CalcExpr:= lft end; (* CalcExpr *)
procedure BTInit(var bt: BTree); begin
bt:= nil
end; (* BTInit *)
procedure BTTraversal(bt: BTree; order: BTOrder; f: BTree; r: boolean); var
c: BTree;
pp, pp1: boolean;
begin if bt<>nil then case order of
_Pre_: begin write(bt^.info,' ');
BTTraversal(bt^.left,order,bt,false);
BTTraversal(bt^.right,order,bt,true) end;
_In_: begin if f<>nil then begin pp:= (f^.info[1] in ['*','/']) and (bt^.info[1] in ['+','-']); pp1:= ((f^.info[1] = '-') and (bt^.info[1] in ['+','-'])) or
((f^.info[1] = '/') and (bt^.info[1] in ['*','/'])) end else begin pp:= false; pp1:= false
end; if pp or (pp1 and r) then write('(');
BTTraversal(bt^.left,order,bt,false); write(bt^.info,' ');
BTTraversal(bt^.right,order,bt,true); if pp or (pp1 and r) then write(')')
end;
_Post_: begin
BTTraversal(bt^.left,order,bt,false); BTTraversal(bt^.right,order,bt,true); write(bt^.info,' ')
end
end
end; (* BTTraversal *)
procedure BTWide(var bt: BTree; lev: integer; rgt: boolean); var c: BTree; i: integer;
begin llink[lev]:= (bt^.left<>nil); cont[lev]:= true; if lev>0 then begin if rgt then begin if llink[lev-1] then write(gr[4],gr[1]) (* *)
else write(gr[1],gr[1]) (* *)
end else begin write(' ': FLEN); for i:= 0 to lev-2 do begin if cont[i] and llink[i] then
write(gr[2]) (* *)
else
write(' ');
write(' ': FLEN + 1)
end; write(gr[5],gr[1]) (* *) end
end; write(bt^.info); if (lev>0) and not rgt then
cont[lev-1]:= false;
if (bt^.right<>nil) or (bt^.left<>nil) then
for i:= length(bt^.info) + 1 to FLEN do
write(gr[1]); (* *)
if bt^.right<>nil then begin
if lev<MAXNEST then
BTWide(bt^.right.lev+1.true) else writeln('...')
end else begin
if bt^.left<>nil then
writeln(gr[6]) (* *)
else writeln
end; if bt^.left<>nil then begin
if lev<MAXNEST then
BTWide(bt^.left,lev+1,false) else writeln('...')
end
end; (* BTWide *)
procedure BTDispose(var bt: BTree); begin
if bt<>nil then begin
BTDispose(bt^.left); BTDispose(bt^.right); dispose(bt)
end
end; (* BTDispose *)
function BTLeaf: BTree; var _bt: BTree; begin
new(_bt); _bt^.left:= nil; _bt^.right:= nil; if current in [NAME,NUMBER] then _bt^.info:= cValue else
_bt^.info:= current;
BTLeaf:= bt end; (* BTLeaf *)
function BTPrimary: BTree; var _bt,_bt1,my_bt: BTree; begin
my_bt:= nil; case current of
NUMBER: begin my_bt:= BTLeaf; GetToken end; NAME: begin
_bt:= BTLeaf; GetToken; if current = '=' then begin
_bt1:= BTLeaf;
_bt1^.left:= _bt;
GetToken; _bt1^.right:= BTExpr; my_bt:= _bt1 end else
my_bt:= _bt
end;
'-': begin (* Унарный минус *)
_bt:= BTLeaf; GetToken; _bt^.right:= BTPrimary; my_bt:= _bt
end;
'(': begin
GetToken; _bt:= BTExpr; if current<>')' then begin
writeln('Непарные скобки!'); pos:= len + 1; current:= FINISH; my_bt:= _bt
end else begin GetToken; my_bt:= _bt
end
end
end;
BTPrimary:= my_bt end; (* BTPrimary *)
function BTTerm: BTree; var lft,_bt: BTree; begin
lft:= BTPrimary; while current in ['*','/'] do begin _bt:= BTLeaf;
_bt^.left:= lft;
GetToken;
_bt^.right:= BTPrimary; lft:= _bt
end;
BTTerm:= lft end; (* BTTerm *)
function BTExpr: BTree; var lft,_bt: BTree; c: boolean;
begin lft:= BTTerm; while current in ['+','-'] do begin
_bt:= BTLeaf;
_bt^.left:= lft;
GetToken;
_bt^.right:= BTTerm; lft:= _bt
end;
BTExpr:= lft end; (* BTExpr *)
procedure HTInit; var i: integer; begin for i:=1 to HSIZE do begin
HashTable[i].h_name:= '';
HashTable[i].h_next:= nil end
end; (* HTInit *)
function HTLookUp(var hi: integer; var hp: h_pointer; ins: boolean): HPlace; var hh: integer; p: h_pointer; i: integer; hpp: HPlace;
begin hh:= 0; for i:=0 to length(cValue) do hh:= hh + ord(cValue[i]);
hi:= (hh mod HSize) + 1; if HashTable[hi].h_name = cValue then hpp:= _I_
else begin if HashTable[hi].h_name = '' then begin if ins then begin
HashTable[hi].h_name := cValue; hpp:= _I_
end else hpp:= _N_
end else begin hp:= HashTable[hi].h_next; p:= nil; while (hp<>nil) and (hp^.h_name<>cValue) do begin p:= hp; hp:= hp^.h_next
end; if hp = nil then begin if ins then begin new(hp); hp^.h_name:= cValue; hp^.h_next:= nil; if p = nil then
HashTable[hi].h_next:= hp else p^.h_next:= hp;
hpp:= _X_ end else hpp:= _N_
end else hpp:= _X_
end
end;
HTLookUp:= hpp end; (* HTLookUp *)
procedure HTDisplayVars; var i: integer; p: h_pointer; b: boolean;
begin b:= false; for i:=1 to HSIZE do if HashTable[i].h_name<>'' then begin if not b then begin b:= true; writeln('Формат: значение хэш-функции: имя_переменной = значение'); writeln('')
end; writeln(i:2,': ',HashTable[i].h_name,' = ',HashTable[i].h_value:1); p:= HashTable[i].h_next; while p<>nil do begin writeln(' ',p^.h_name,' = ',p^.h_value:1); p:= p^.h_next end
end
end; (* HTDisplayVars *)
begin (* Main Program *)
BTInit(BinaryTree); E:= '0'; len:= length(E); nValue:= 0; HTInit; repeat begin writeln('1. Ввести 2. Дерево 3. Префиксная форма 4. Инфиксная 5. Постфиксная'); write('6. Переменные 0. Выход> '); readln(i); case i of
1: begin write('Выражение> '); readln(E); len:= length(E); pos:= 1; GetToken; nValue:= CalcExpr; writeln('Значение выражения: ',nValue:1)
end;
2: begin writeln(E,' = ',nValue:1); pos:= 1;
BTDispose(BinaryTree);
GetToken;
BinaryTree:= BTExpr;
BTWide(BinaryTree,0,false) end;
3: begin BTTraversal(BinaryTree,_Pre_,nil,false); writeln end;
4: begin BTTraversal(BinaryTree,_In_,nil,false); writeln end;
5: begin BTTraversal(BinaryTree,_Post_,nil,false); writeln end;
6: HTDisplayVars end
end until i=0
end.
{ Разбор выражения в инфиксной записи }
{ Преобразование в постфиксную форму }
{ Сошников Д.В., 1998 }
program postfx;
{$В-} var stack: array[1..100] of char; sptr: integer; procedure init; begin sptr:=0 end; function empty:boolean; begin empty:=sptr=0 end; function look:char; begin if sptr>0 then look:=stack[sptr] end;
function pop:char; begin if sptr>0 then begin pop:=stack[sptr]; dec(sptr) end;
end;
procedure push(c:char); begin inc(sptr); stack[sptr]:=c; end;
var c,z: char; i : integer;
function prcd(c1,c2: char):integer; begin prcd:=0; if (c1 in ['*','/']) and (c2 in ['+','-']) then prcd:=1; if (c1 in ['+','-']) and (c2 in ['*','/']) then prcd:=-1; if (c1 in ['+','-']) and (c2 in ['+','-']) then prcd:=0; if (c1 in ['*','/']) and (c2 in ['*','/']) then prcd:=0; if (c2='(') or (c1='(') then prcd:=1; if c1=')' then prcd:=-1;
end;
begin init; while not(eoln) do begin read(c);
if с in ['0'..'9'] then write(c) else begin if (c in ['+','-','*','/']) and (empty or (prcd(c,look)>0)) then push(c) else begin while (not empty) and (prcd(c,look)<=0) do begin z:= pop; if z<>'(' then write(z);
end; if c<>')' then push(c);
end;
end;
end; while not empty do begin
if look<>'(' then write(pop);
end; writeln;
end.
[48], с. 18-20, [40], гл. 9. 3.6.1 Поиск в глубину
|
{ Поиск путей в графе |
} |
|
{ Алгоритм поиска в глубину |
} |
|
{ Сошников Д.В., 1998 |
} |
program searchDepth(input, output);
{ поиск в глубину }
type IStack = ^IStackItem;
IStackItem = record x: integer; p: IStack end; type Graph = array [1..5,1..5] of boolean;
function inStack(a: integer; L: IStack):boolean; begin
inStack:=false; while L<>nil do begin if L^.x=a then begin inStack:=true; exit;
end;
L:=L^.p; end;
end;
procedure push(a: integer; var L: IStack); var p: IStack; begin
new(p); p^.x:=a; p^.p:=L;
L:=p; end;
procedure pop(var L: IStack); var p: IStack; begin
p:=L; L:=L^.p; dispose(p);
end;
procedure print(L: IStack); begin while L<>nil do begin
write(L^.x); if L^.p<>nil then write(' <- ');
L:=L^.p; end; writeln;
end;
procedure search(xf,xt: integer; var G: Graph); var L: IStack;
procedure search1; var i,k: integer; begin
k:=L^.x; if k=xt then print(L) else for i:=1 to 5 do
if G[k,i] and not(inStack(i,L) then begin
push(i.L); search1; pop(L);
end;
end;
begin L:=nil; push(xf,L); search1; end;
var G: Graph; i,j: integer;
begin
for i:=1 to 5 do for j:=1 to 5 do G[i,j]:= false;
G[1,2]:=true; G[1,3]:=true;
G[2,4]:=true;
G[3,2]:=true; G[3,5]:=true; G[4,3]:=true; G[4,5]:=true; search(1,5,G);
end.
[61], с. хх-хх, [62], с. zz-uu.
program searchWidth(input, output);
type PObject = ^TObject;
TObject = object constructor Init; procedure print; virtual; {abstract;} destructor Done; virtual; function clone: PObject; virtual;
end;
constructor TObject.Init; begin end;
destructor TObject.Done; begin end;
procedure TObject.Print;
begin writeln('Abstract method called') end;
function TObject.clone: PObject; begin clone:=nil;
end;
type PObjContainer = ^TObjContainer;
TObjContainer = record x: PObject; ptr: PObjContainer;
end;
type TInt = object(TObject)
x : integer; constructor Init(z: integer); function getValue: integer; procedure setValue(z:integer); procedure print; virtual; function clone: PObject; virtual;
end; type PInt = ^TInt;
constructor TInt.Init(z: integer); begin x:=z;
end;
function TInt.clone: PObject; begin clone:= new(PInt,Init(getValue)); end;
function TInt.getValue: integer; begin getValue:=x;
end;
procedure TInt.setValue(z: integer); begin x:=z;
end;
procedure TInt.print; begin write(x,' ');
end;
type TStack = object(TObject)
ptr : PObjContainer; constructor Init; procedure push (z: PObject); virtual; function pop: PObject; virtual; function look: PObject; virtual; function empty: boolean; virtual; procedure print; virtual; function clone: PObject; virtual; destructor Done; virtual;
end; type PStack = ^TStack;
constructor TStack.Init; begin ptr:= nil;
end;
function TStack.empty: boolean; begin empty:=ptr=nil;
end;
destructor TStack.Done; var p: PObjContainer; begin while ptr<>nil do begin
p:=ptr; ptr:=ptr^.ptr; p^.x^.Done; dispose(p);
end;
end; function TStack.clone: PObject; var P: PStack; t,s,u: PObjContainer;
begin P:=new(PStack,Init); t:=ptr; while t<>nil do begin
new(s); s^.ptr:=nil; s^.x:=t^.x^.clone; if P^.ptr=nil then P^.ptr:=s else u^.ptr:=s; u:=s; t:=t^.ptr;
end;
Clone:=P end;
procedure TStack.Push(z: PObject); var p: PObjContainer; begin
new(p); p^.x:=z; p^.ptr:=ptr; ptr:=p;
end;
function TStack.look: PObject; begin look:=ptr^.x;
end;
function TStack.pop: PObject; var p: PObjContainer; begin pop:=ptr^.x; p:=ptr; ptr:=ptr^.ptr; dispose(p);
end;
procedure TStack.Print; var p: PObjContainer; begin
p:=ptr; while (p<>nil) do begin
p^.x^.print; p:=p^.ptr;
end; writeln; end;
type TQueue = object(TStack)
function pop: PObject; virtual; function look: PObject; virtual;
end; type PQueue = ^TQueue;
function TQueue.look : PObject; var p: PObjContainer; begin
p:=ptr; if p=nil then look:=nil else begin
while p^.ptr<>nil do p:=p^.ptr; look:= p^.x;
end;
end;
function TQueue.pop : PObject; var p,q: PObjContainer; begin
p:=ptr; if p=nil then pop:=nil else begin
q:=ptr; while p^.ptr<>nil do begin
p:=p^.ptr; if q<>p then q:=q^.ptr;
end; pop:=p^.x; if q=p then ptr:=nil else q^.ptr:=nil; dispose(p);
end;
end; type Graph = array [1..5,1..5] of boolean;
procedure search(xf,xt: integer; var G: Graph); var Q: TQueue; P,S: PStack; i,j: integer;
begin
P:= new(PStack,Init);
P^.push(new(Pint,Init(xf)));
Q.Init;
Q.push(P);
while not Q.empty do begin
P:=PStack(Q.pop); i:=PInt(P^.look)^.getValue; for j:=1 to 5 do if G[i,j] then begin if j=xt then begin
Уважаемый посетитель!
Чтобы распечатать файл, скачайте его (в формате Word).
Ссылка на скачивание - внизу страницы.