IPB
ЛогинПароль:

> ВНИМАНИЕ!

Прежде чем задать вопрос, смотрите FAQ.
Рекомендуем загрузить DRKB.

Наладить общение поможет, если вы подпишитесь по почте на новые темы в этом форуме.

> Однонаправленный список поисковых деревьев
сообщение
Сообщение #1


Гость






У меня не получается сохранение в файл и загрузка из файла, помогите пожалуйста.

unit Kurs;

interface
type
ItemTree=class
private
name:string[20];
fam:string[20];
left,right:ItemTree;
public
constructor create(el1,el2:string);
function getn:string;
function getf:string;
function getnl:ItemTree;
function getnr:ItemTree;
procedure setinf(el1,el2:string);
end;
Tree=class
private
pRoot,pCurrent,pParent:ItemTree;
public
sr:string;
constructor Create;
function getroot:ItemTree;
function empty:boolean;
function find(el1,el2:string):boolean;
procedure view(pCurrent:ItemTree);
procedure add(el1,el2:string);
procedure del(el1,el2:string);
procedure deltree;
end;
TList=class
private
group:string[4];
next: TList;
ch:Tree;
public
constructor Create(agroup:string);
procedure SetGroup(agroup:string);
function GetGroup:string;
procedure Delete;
function emptych(name,fam:string):boolean;
Procedure Addch(name,fam:string);
Procedure Findch(name,fam:string;var found:boolean);
Procedure Delch(name,fam:string);
Procedure Viewch(var st:string);
end;
MainList=class
private
str:string;
head,cur,node,prev: TList;
public
constructor Create;
function empty:boolean;
procedure Add(agroup:string);
procedure Del(agroup:string;var found:boolean);
Procedure View(var st:string);
Procedure Find(agroup:string;var ind:Tlist);
Procedure ViewAll(var st:string);
Procedure Save(var f:text; put:string);
{Procedure Load(var f:text; put:string);}
end;
implementation
constructor ItemTree.create(el1,el2:string);
begin
name:=el1;
fam:=el2;
left:=nil;
right:=nil;
end;
function ItemTree.getn:string;
begin
getn:=name;
end;
function ItemTree.getf:string;
begin
getf:=fam;
end;
function ItemTree.getnl:ItemTree;
begin
getnl:=left;
end;
function ItemTree.getnr:ItemTree;
begin
getnr:=right;
end;
Procedure ItemTree.setinf(el1,el2:string);
begin
name:=el1;
fam:=el2;
end;
constructor Tree.Create;
begin
pRoot:=nil;
end;
function Tree.getroot:ItemTree;
begin
getroot:=proot;
end;
function Tree.empty:boolean;
begin
if pRoot<>nil then
empty:=false
else
empty:=true;
end;
function Tree.find(el1,el2:string):boolean;
var found:boolean;
begin
pCurrent:=pRoot;
pParent:=nil;
found:=false;
while (pCurrent<>nil)and(not found) do
if el1<pCurrent.getn then
begin
pParent:=pCurrent;
pCurrent:=pCurrent.getnl;
end
else
if el1>pCurrent.getn then
begin
pParent:=pCurrent;
pCurrent:=pCurrent.getnr;
end
else
if pCurrent.getf=el2 then
found:=true;
find:=found;
end;
procedure Tree.view(pCurrent:ItemTree);
begin
if pCurrent<>nil then
begin
view(pCurrent.getnl);
sr:=sr+pCurrent.getn+' '+pCurrent.getf + #13;
view(pCurrent.getnr);
end;
end;
procedure Tree.add(el1,el2:string);
var found:boolean;
begin
pCurrent:=pRoot;
pParent:=nil;
found:=false;
while (pCurrent<>nil)and(not found) do
if el1<pCurrent.name then
begin
pParent:=pCurrent;
pCurrent:=pCurrent.left;
end
else
if el1>pCurrent.name then
begin
pParent:=pCurrent;
pCurrent:=pCurrent.right;
end
else
found:=true;
pCurrent:=ItemTree.create(el1,el2);
if pParent<>nil then
begin
if pParent.getn>el1 then
pParent.left:=pCurrent
else
pParent.right:=pCurrent;
end
else
pRoot:=pCurrent;
end;
procedure Tree.del(el1,el2:string);
var pTemp,pPar:ItemTree;
begin
if pRoot<>nil then
begin
if find(el1,el2) then
begin
if (pCurrent.getnl<>nil)and(pCurrent.getnr<>nil) then
begin
pTemp:=pCurrent.getnr;
pPar:=nil;
while pTemp.getnl<>nil do
begin
pPar:=pTemp;
pTemp:=pTemp.getnl;
end;
Pcurrent.setinf(pTemp.getn,pTemp.getf);
if pPar<>nil then
begin
if pTemp.getnr<>nil then
pPar.left:=pTemp.right
else
pPar.left:=nil;
end
else
pCurrent.right:=pTemp.right;

pTemp.Destroy;
end
else
if pParent<>nil then
begin
if pCurrent.left<>nil then
begin
if pParent.left=pCurrent then
begin
pParent.left:=pCurrent.left;
pCurrent.Destroy;
end
else
begin
pParent.right:=pCurrent.left;
pCurrent.Destroy;
end;
end
else
if pParent.left=pCurrent then
begin
pParent.left:=pCurrent.right;
pCurrent.Destroy;
end
else
begin
pParent.right:=pCurrent.right;
pCurrent.Destroy;
end;
end
else
if pCurrent.left<>nil then
begin
pRoot:=pCurrent.left;
pCurrent.Destroy;
end
else
begin
pRoot:=pCurrent.right;
pCurrent.Destroy;
end;
end;
end;
end;
procedure Tree.deltree;
begin
pRoot:=nil;
end;
constructor Tlist.Create(agroup:string);
begin
group:=agroup;
ch:=Tree.Create;
end;
procedure Tlist.SetGroup(agroup:string);
begin
group:=agroup;
end;
function Tlist.GetGroup;
begin
getgroup:=group;
end;
procedure Tlist.Delete;
begin
ch.deltree;
end;
function Tlist.emptych(name,fam:string):boolean;
begin
emptych:=ch.empty;
end;
constructor MainList.Create;
begin
Head:=Tlist.Create('head');
head.next:=nil;

end;
function MainList.empty;
begin
if head.next = nil then
empty:=true
else
empty:=false;
end;
procedure MainList.Add(agroup:string);
begin
node:=Tlist.Create(agroup);
cur:=head;
if head.next=nil then
begin
node.next:=nil;
head.next :=node;
end
else
begin
repeat
begin
prev:=cur;
cur:=cur.next;
end;
until (node.group < cur.group)or(cur.next = nil);
If (cur.next=nil) and (node.group>cur.group)then
begin
node.next:=cur.next;
cur.next:=node;
end
else
begin
node.next:=cur;
prev.next:=node;
end;
end;
end;
procedure MainList.Del(agroup:string;var found:boolean);
begin
cur:=head.next;
found:=FALSE;
while (cur <> nil) and (not found) do
begin
if (cur.GetGroup = agroup)then
found:=TRUE
else
begin
prev:=cur ;
cur:=cur.next;
end;
end;
if found then
begin
prev.next:=cur.next;
end;
cur.delete;
cur.Destroy;
end;

Procedure MainList.View(var st:string);
begin
st:='';
cur:=head.next;
while cur <> nil do
begin
st:=st+cur.group+#13;
cur:=cur.next;
end;
end;
Procedure MainList.Find(agroup:string;var ind:Tlist);
var found:boolean;
begin
found:=false;
cur:=head.next;
while (cur <> nil) and (not found) do
begin
if (cur.GetGroup = agroup) then
found:=TRUE; prev:=cur;
cur:=cur.next;
end;
if found then
ind:=prev
else
ind:=nil;

end;
Procedure TList.Addch(name,fam:string);
begin
ch.add(name,fam);
end;
Procedure Tlist.Delch(name,fam:string);
begin
ch.del(name,fam);
end;
Procedure Tlist.Findch(name,fam:string;var found:boolean);
begin
found:=ch.find(name,fam);
end;
Procedure TList.Viewch(var st:string);
begin
ch.sr:='';
ch.view(ch.getroot);
st:=ch.sr;
end;
Procedure MainList.ViewAll(var st:string);
begin
st:='';
cur:=head.next;
while (cur <> nil) do
begin
cur.ch.sr:='';
cur.ch.view(cur.ch.getroot);
st:=st+cur.group+':'+#13+cur.ch.sr+#13;
cur:=cur.next;
end;
end;


Procedure MainList.save(var f:text; put:string);
var tmp: string;
current, root1 :ItemTree;
begin
assign(f,put);
rewrite(f);
cur:=head.next;
while (cur<>nil) do
begin
tmp:=cur.group;
writeln(f,tmp);
if (cur.ch.getroot)<>nil then
begin
root1:=nil;
repeat
begin
current:=cur.ch.getroot;
while current<>root1 do
{current:=current.next;}
tmp:=current.fam;
writeln(f,tmp);
tmp:=current.name;
writeln(f,tmp);
root1:=current;
end;
until root1=cur.ch.getroot;
end;
writeln(f,'');
cur:=cur.next;
end;
close(f);
end;

{Procedure MainList.Load(var f:text; put:string);
var tmp, a, b: string;
node: Tlist;
begin
assign(f,put);
reset(f);
while not eof(f) do
begin
readln(f,tmp);
add(tmp,node);
readln(f,tmp);
if tmp<>'' then
begin
repeat
begin
a:=tmp;
readln(f,tmp);
b:=tmp;
node.addch(a,b);
readln(f,tmp);
end;
until tmp='';
end;
end;
close(f);
end;}
end.


Загрузку вообще дельфа не съедает, поэтому я закомментировал этот участок, а сохранение вообще ничего не сохраняет. И еще, если мелкие недочеты, то укажите на них пожалуйста
 К началу страницы 
+ Ответить 
 
 Ответить  Открыть новую тему 
Ответов
сообщение
Сообщение #2


Гость






Да ты что? Качать 160К при средней скорости отдачи в 0.7К ??? Не буду... Надо - клади сюда...

Только НЕ ПРИСОЕДИНЯЙ в проекте EXE, иначе тема будет закрыта, предупреждаю сразу!!!
 К началу страницы 
+ Ответить 

Сообщений в этой теме


 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 28.03.2024 17:42
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name