(( بـــــــــرنـــــامــــه جــــــــــــــــــدیــــــــــــد))

سلام 

(( اگر می خواهی در برابر قاضی نایستی، قانونمند زندگی کن. ))
امیدوارم حالتون خوب باشه بنا به درخواست متعدد شما ما تصمیم گرفتیم که برنامه دفترچه تلفن را در وبلاگ قرار دهیم تقدیم به همه آنهایی که این برنامه را می خواهند در ضمن مممکن است که ارخین برنامه است که به زبان پاسکال در  سایت میزایم چون دیگه ما که پاسکال پاس کردیم بعد از این انشا الله برنامه های به زبان C و در سهایی از قبیل ساختمان داده و اسمبلی و..... رو تو وبلاگ بزاریم البته اطلاعات کامل به تون میدیم.

---

برنامه دفترچه تلفن سورس برنامه زیر را در یک فایل متنی کپی کنید خودش درست میشه بعد پسوند اونو به PAS تبدیل کنید.البته این برنامه فارسی بود و اسامی را فارسی مرتب میکرد اما به دلیل اینکه وقتی فارسی باشه باید نرم افزار سایه رو داشته باشید که دوستان خواسته بودند که انگلیسی شو تو وبلاگ بزاریم ما هم هم کارو انجام دادیم اما هر کس فارسی ساز سایه داره و برنامه فارسی رو میخو.اهد بگه تابراش بفرستیم.
این برنامه توسط گروه دانشجوییBDSM  نوشته شده است.(لطفا انتقادات و پیشنهادات  خود را به ما بگویید)

{Babak Javadi * Davod Ghanbari * Saied Anghoti * Mohammad Hosein Ghorbanian}

program Phon_Book;
uses crt; 
type tree =^rec;
rec = record
left:tree;
family2:string;
family:string;
name:string;
addres:string[255];
num:longint;
right : tree;
end;
recp=^recpp;
recpp=record
chr:char;
link:recp;
end;
tfile = file of rec;
var root,p,q, s :tree;
choice, find : byte;
name:string;
fp:tfile;rec1:rec;
i,j:integer;
function menu:byte;
var chioce :byte;
begin
textbackground(0);
clrscr;
textcolor(12);
writeln('Enter Information................................................1'); writeln;
writeln('Print Information................................................2'); writeln;
writeln('Search...........................................................3'); writeln;
writeln('Save To File.....................................................4'); writeln;
writeln('Load Information.................................................5'); writeln;
writeln('Exit.............................................................6'); writeln;
writeln;
write('Enter Number:');
readln(choice);
menu := choice;
end;
{*****************************}
procedure bdsm2;
var
i,d,q,w,u : integer;
begin
clrscr;
textcolor(26);
textbackground(0);
gotoxy(5,4);
for i:=1 to 9 do
write(#219);
gotoxy(5,12);
for i:=1 to 9 do
write(#219);
gotoxy(5,20);
for i:=1 to 9 do
write(#219);
d:=4;
for i:=1 to 17 do
begin
gotoxy(5,d);
write(#219);
d:=d+1;
end;
d:=4;
q:=14;
for i:=1 to 3 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q+1;
end;
d:=12;
q:=14;
for i:=1 to 3 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q+1;
end;
d:=18;
q:=16;
for i:=1 to 3 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q-1;
end;
d:=10;
q:=16;
for i:=1 to 2 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q-1;
end;
d:=7;
q:=16;
for i:=1 to 3 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
end;
d:=15;
q:=16;
for i:=1 to 3 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
end;
{*********************END B*********************}
d:=4;
for i:=1 to 17 do
begin
gotoxy(22,d);
write(#219);
d:=d+1;
end;
gotoxy(22,4);
for i:=1 to 7 do
write(#219);
gotoxy(22,20);
for i:=1 to 7 do
write(#219);
d:=16;
q:=32;
for i:=1 to 4 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q-1;
end;
d:=4;q:=29;
for i:=1 to 4 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q+1;
end;
d:=8;
for i:=1 to 8 do
begin
gotoxy(33,d);
write(#219);
d:=d+1;
end;
{********************END D****************}
gotoxy(39,4);
for i:=1 to 8 do
write(#219);
gotoxy(39,12);
for i:=1 to 8 do
write(#219);
gotoxy(39,20);
for i:=1 to 8 do
write(#219);
d:=5;
for i:=1 to 7 do
begin
gotoxy(38,d);
write(#219);
d:=d+1;
end;
d:=5;
q:=47;
for i:=1 to 3 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q-1;
end;
d:=17;
q:=40;
for i:=1 to 3 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q-1;
end;
d:=13;
for i:=1 to 7 do
begin
gotoxy(47,d);
write(#219);
d:=d+1;
end;
{********************END S*****************}
d:=4;
for i:=1 to 17 do
begin
gotoxy(52,d);
write(#219);
d:=d+1;
end;
d:=4;
q:=53;
for i:=1 to 9 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q+1;
end;
d:=4;
q:=69;
for i:=1 to 9 do
begin
gotoxy(q,d);
write(#219);
d:=d+1;
q:=q-1;
end;
d:=4;
for i:=1 to 17 do
begin
gotoxy(70,d);
write(#219);
d:=d+1;
end;
textcolor(14);
gotoxy(25,23);
writeln('Email: [e-mail]');
Delay(500);
gotoxy(26,24);
write('WebSite: WWW.BDSM.BLOGSKY.COM');
w:=1000;q:=5000;
for i:=1 to 60 do begin
sound(w);
Delay(10);
sound(q);
Delay(30);
nosound;
w:=w+100;q:=q-100; end;
readkey;
end;
procedure bdsm;
begin
textcolor(25);
gotoxy(25,23);
writeln('Email: [e-mail]');
gotoxy(26,24);
write('WebSite: WWW.BDSM.BLOGSKY.COM');
end;
{******************************************************************}
{__________Start Program
________________________________________}
{******************************************************************}
procedure stack(var p:tree);
var top,oldtop:recp;
str:string;
begin
j:=length(p^.family);
new(top);
top^.link:=nil;
top^.chr:=p^.family[j];
j:=j-1;
for i:=j to 1 do
begin
oldtop:=top;
new(top);
top^.chr:=p^.family[i];
top^.link:=oldtop;
end;
i:=1;
while top<>nil do
begin
str[i]:=top^.chr;
oldtop:=top;
top:=top^.link;
dispose(oldtop);
i:=i+1;
end;p^.family2:=str;
end;
{********************************************}
procedure insrt(var root : tree ;p : tree);
begin
q := root;
while q <> nil do
begin
if p^.family2 > q^.family2 then
begin
if q^.right = nil then
begin
q^.right := p;
break;
end
else q:= q^.right;
end
else
begin
if q^.left = nil then
begin
q^.left :=p;
break
end
else q :=q^.left;
end;
end;{while};
end;{insrt}
{********************************************}
procedure enter(var root : tree);
begin
clrscr;
bdsm;
textcolor(2);
new(p);
gotoxy(73,3);writeln (':Name');
for i:=1 to 80 do write(#205);
gotoxy(70,1);writeln(' :Family ');
for i:=1 to 80 do write(#205);
gotoxy(66,5);writeln ( ':Phon Number');
for i:=1 to 80 do write(#205);
gotoxy(71,7); writeln(':Adress');
for i:=1 to 80 do write(#205);
gotoxy(3,1);readln(p^.family);
gotoxy(3,3); readln(p^.name);
gotoxy(3,5);readln(p^.num);
gotoxy(3,7);readln(p^.addres);
p^.right := nil;
p^.left := nil;
stack(p);
if root = nil then root:=p
else insrt(root, p)
end;
{********************************************}
procedure head(title : string);
var i : byte;
begin
clrscr;
textcolor(2);
writeln(title :40);
write('Name' :10 , 'Family' :20);
writeln('Adress':25,'Phon Number':20);
write(' ');
for i:=1 to 72 do write(#220);
writeln;
end;
{********************************************}
procedure report(var s:tree);
begin
if s<>nil then
begin
report(s^.left);
textcolor(2);
writeln(s^.name:10,s^.family:18,s^.addres:27,s^.num:18);
for i:=1 to 80 do write(#196);
report(s^.right);
end;
end;
{********************************************}
procedure search(s:tree;name:string;find:byte);
begin
clrscr;
if s<> nil then
begin
search(s^.left,name,find);
if s^.family=name then
begin
textcolor(2);
head('<<<< Search >>>>');
writeln(s^.name:10,s^.family:18,s^.addres:27,s^.num:18);
bdsm;
readkey;
find:=1;
exit;
end;
search(s^.right,name,find);
end;
end;
{*****************************************}
procedure save(s:tree);
begin
assign(fp,'tree.dat');
rewrite(fp);
if s<>nil then
begin
save(s^.left);
rec1:=s^;
write(fp,rec1);
save(s^.right);
end;
close(fp);
end;
{***************************************}
procedure load(var root:tree);
begin
assign(fp,'tree.dat');
reset(fp);
while not eof(fp) do
begin
new(p);
read(fp,rec1);
p^:=rec1;
p^.left:=nil;
p^.right:=nil;
stack(p);
if root = nil then root:=p
else insrt(root,p);
end;
close(fp);
end;
{*****************************************************}
begin
bdsm2;
root:=nil;
repeat
clrscr;
find:=0;
choice:=menu;
case choice of
1:enter(root);
2:begin
if root=nil then
begin
clrscr;
textcolor(2);
writeln(' Not Cerating List..........');
readln;
end
else
begin
textcolor(2);
head (' <<>');
report(root);
bdsm;
readkey;
end;
end;
3:begin
clrscr;
write('Enter Family For Search:');
gotoxy(25,1);readln(name);
search(root,name,find);
if find=0 then
begin
write('Not Found........');
end;
end;
4:begin
if root=nil then
begin
writeln(' Not Cerating List..........');
bdsm;
readkey;
end
else
begin
clrscr;
save(root);
writeln(' Save ');
bdsm;
readkey;
end;
end;
5:begin
if root<>nil then
begin
write('List In Memory');
readkey;
end
else
begin
load(root);
clrscr;
writeln('Information Load To Memory');
bdsm;
readkey;
end;
end;
end;
until choice=6;
end.