تبلیغات سورس های زیر توسط ahura برای وبلاگ ارسال شده
سورس هشت وزیر : دریافت
سورس تبدیل اعداد رومی به صحیح : دریافت
سورس رمز گشا : دریافت
با تشکر از ahura ی عزیز.
{ NOT TESTED }
نوشته شده توسط : حسین تجره نژاد
تعویض قطر اصلی و فرعی ماتریس n در n به در خواست دوستان
جمعه 20 دی 1387 11:40 ب.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
uses wincrt;
var
a : array[1..100,1..100] of integer;
i,j,temp,n : integer;
begin
writeln('Enter Number For n: ');
readln(n);
for i:= 1 to n do
for j:= 1 to n do
begin
writeln('Enter a[',i,j,']');
readln(a[i,j]);
end;
writeln;
writeln('Matrix :');
for i:= 1 to n do
begin
for j:= 1 to n do
write( a[i,j]:3);
writeln;
end;
j:=n;
for i:=1 to n do
begin
temp := a[i,i];
a[i,i] := a[i,j];
a[i,j] := temp;
dec(j);
end;
writeln;
writeln('Matrix Tavize Ghotre asli Va Farei :');
for i:= 1 to n do
begin
for j:= 1 to n do
write( a[i,j]:3);
writeln;
end;
end.
نوشته شده توسط : حسین تجره نژاد
دفترچه تلفن
جمعه 20 دی 1387 10:10 ب.ظ
نوع مطلب : سورس کدهای پاسکال ،آموزش برنامه نویسی با پاسکال ،
دانلود سورس : دفترچه تلفن
دانلود فایل اجرایی : دفترچه تلفن
برای مشاهده سورس به ادامه مطلب بروید
نوشته شده توسط : حسین تجره نژاد
تعویض قطر اصلی و فرعی ماتریس 5 در 5 به درخواست دوستان
شنبه 14 دی 1387 09:33 ب.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
uses wincrt;
var
a : array[1..5,1..5] of integer;
i,j,temp : integer;
begin
for i:= 1 to 5 do
for j:= 1 to 5 do
begin
writeln('Enter a[',i,j,']');
readln(a[i,j]);
end;
temp:=a[1,1];
a[1,1]:=a[1,5];
a[1,5]:=temp;
temp:=a[2,2];
a[2,2]:=a[2,4];
a[2,4]:=temp;
temp:=a[4,4];
a[4,4]:=a[4,2];
a[4,2]:=temp;
temp:=a[5,5];
a[5,5]:=a[5,1];
a[5,1]:=temp;
for i:= 1 to 5 do
begin
for j:= 1 to 5 do
write( a[i,j]:3);
writeln;
end;
end.
نوشته شده توسط : حسین تجره نژاد
سیستم بانکداری با استفاده از رکورد ها
سه شنبه 10 دی 1387 09:17 ق.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
دانلود سورس : سیستم بانکداری با استفاده از رکورد ها
دانلود فایل جرایی : سیستم بانکداری با استفاده از رکورد ها
{B A N K I N G S Y S T E M (Records)
PROGRAMMING BY :
HUSSEIN TAJARENEZHAD}
uses wincrt;
type
Information = record
firstname,lastname,accounttype : string[20];
customercode,supply : longint;
profit : real;
end;
Customers = array[1..100] of information;
var
info : information;
i,j,sc,m : integer;
custom : customers;
s : integer;
procedure starting;
begin
writeln(' * W E L C O M E T O B A N K I N G S Y S T E M *');
writeln;
Writeln('What You Want To Do?');
writeln;
writeln(' * Add Customer : 01');
writeln(' * Find Customer By Last name : 02');
writeln(' * Find Customer By Customer Code : 03');
writeln(' * View All Customer : 04');
writeln(' * Profit : 05');
writeln(' * Delete Customer : 06');
writeln(' * For Sorting Data By Last Name : 07');
writeln(' * For Sorting Data By Customer Code : 08');
writeln(' * Edit Customer Infomation : 09');
writeln(' * View Profit Rate : 10');
writeln;
writeln('Enter Service Code :');
readln(sc);
clrscr;
end;
procedure scan;
var
n,i,j : integer;
begin
writeln(' * A D D C U S T O M E R S Y S T E M *');
writeln;
while n > 100 do
begin
writeln('Enter Number of Customer you want to add');
readln(n);
m:=m+n;
if n > 100 then
begin
writeln('You can only Enter 100 customer!');
m:=m-n;
end;
for i:= 1 to n do
begin
for j:= 1 to 5 do
begin
case j of
1:
begin
writeln('Select Accunt Type For Below Chart :');
writeln('***********************************');
writeln('* Account Name * Code *');
writeln('***********************************');
writeln('* Long Period 1 Year : 1 *');
writeln('* Long Period 2 Year : 2 *');
writeln('* Long Period 3 Year : 3 *');
writeln('* Long Period 4 Year : 4 *');
writeln('* Long Period 5 Year : 5 *');
writeln('* Short Period : 6 *');
writeln('***********************************');
writeln;
writeln('Enter Type Code :');
readln(custom[i].accounttype);
if custom[i].accounttype='1' then
custom[i].accounttype:='Long Period 1 Year'
else if custom[i].accounttype='2' then
custom[i].accounttype:='Long Period 2 Year'
else if custom[i].accounttype='3' then
custom[i].accounttype:='Long Period 3 Year'
else if custom[i].accounttype='4' then
custom[i].accounttype:='Long Period 4 Year'
else if custom[i].accounttype='5' then
custom[i].accounttype:='Long Period 5 Year'
else if custom[i].accounttype='6' then
custom[i].accounttype:='Short Period'
else
begin
Writeln('For Your Acount Profit Not Calculate');
custom[i].accounttype:='None';
end;
end;
3:
begin
writeln('Enter Last name of Customer :');
readln(custom[i].lastname);
end;
2:
begin
writeln('Enter First name of Customer :');
readln(custom[i].firstname);
end;
4:
begin
writeln('Enter Customer Code :');
readln(custom[i].customercode);
end;
5:
begin
writeln('Enter Customer ',custom[i].customercode,' Supply :');
readln(custom[i].supply);
end;
end;
end;
writeln;
writeln('Entering Data Completed');
writeln;
write('* ',custom[i].firstname,' ',custom[i].lastname,' ',custom[i].accounttype);
writeln(' Accunt Sucssecfuly Created');
writeln;
if i<>n then
writeln('Now Enter Data of Customer ',i+1);
end;
Writeln('Entering Data for ',n,' Customer Completed');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure scan}
end;
procedure searchname;
var
l : string[30];
flag,sni : integer;
begin
writeln(' * S E A R C H I N G S Y S T E M : B Y L A S T N A M E *');
writeln;
writeln('Enter last name which you want to search');
readln(l);
flag:= 0;
sni:=1;
while (sni<100) and (flag=0) do
begin
if l=custom[sni].lastname then
begin
writeln('Data Found!');
writeln;
writeln('*******************************************************************************');
writeln('*');
writeln('* Full name : ',custom[sni].firstname,' ',custom[sni].lastname);
writeln('* Customer Code : ',custom[sni].customercode);
writeln('* Supply : ',custom[sni].supply);
writeln('* Account Type : ',custom[sni].accounttype);
writeln('* Profit : ',custom[sni].profit:8:2);
writeln('*');
writeln('*******************************************************************************');
flag:= 1;
end;
inc(sni);
end;
if flag=0 then
Writeln('Customer Not Found');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure search name}
procedure searchcode;
var
cc : longint;
flag1,sci : integer;
begin
writeln(' * S E A R C H I N G S Y S T E M : B Y C U S T O M E R C O D E *');
writeln;
writeln('Enter Customer Code which you want to search');
readln(cc);
flag1:= 0;
sci:=1;
while (sci<100) and (flag1=0) do
begin
if (cc=custom[sci].customercode) then
begin
writeln('Data Found!');
writeln('*******************************************************************************');
writeln('*');
writeln('* Full name : ',custom[sci].firstname,' ',custom[sci].lastname);
writeln('* Customer Code : ',custom[sci].customercode);
writeln('* Supply : ',custom[sci].supply);
writeln('* Account Type : ',custom[sci].accounttype);
writeln('* Profit : ',custom[sci].profit:8:2);
writeln('*');
writeln('*******************************************************************************');
flag1:= 1;
end;
inc(sci);
end;
if flag1=0 then
Writeln('Customer Not Found');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure search code}
procedure sortname;
var
index : integer;
min : string;
temp : information;
begin
writeln(' * S O R T I N G D A T A S Y S T E M B Y L A S T N A M E *');
writeln;
for i:= 1 to m do
begin
min:= custom[i].lastname;
index:=i;
for j:= i+1 to m do
if custom[j].lastname< min then
begin
min:= custom[j].lastname;
index:=j;
end;
temp:=custom[index];
custom[index]:=custom[i];
custom[i]:=temp;
end;
writeln('Data sorted By Last Name');
writeln('For view sorted data in first page enter show service code');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End Of procedure Sorting Data By Customer Last Name}
procedure sortcode;
var
index : integer;
min : longint;
temp : information;
begin
writeln(' * S O R T I N G D A T A S Y S T E M B Y C U S T O M E R C O D E *');
writeln;
for i:= 1 to m do
begin
min:= custom[i].customercode;
index:=i;
for j:= i+1 to m do
if custom[j].customercode< min then
begin
min:= custom[j].customercode;
index:=j;
end;
temp:=custom[index];
custom[index]:=custom[i];
custom[i]:=temp;
end;
writeln('Data sorted By Customer Code');
writeln('For view sorted data in first page enter show service code');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End Of procedure Sorting Data By Customer Code}
برای مشاهده ادامه سورس برنامه به ادامه مطلب بروید......
نوشته شده توسط : حسین تجره نژاد
سیستم بانکداری با استفاده از آرایه ها
دوشنبه 9 دی 1387 10:13 ق.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
{B A N K I N G S Y S T E M
PROGRAMMING BY :
HUSSEIN TAJARENEZHAD}
uses wincrt;
type
information=array[1..50,1..2] of string[30];{First name,Account Type}
accunt = array[1..50,1..2] of longint;{Customer Code,Supply}
pro = array[1..50] of real;{Profit}
lname = array[1..50] of string[30];{Last Name}
var
info : information;
no : accunt;
fa : lname;
prof : pro;
i,j,sc,m : integer;
procedure starting;
begin
writeln(' * W E L C O M E T O B A N K I N G S Y S T E M *');
writeln;
Writeln(' What You Want To Do?');
writeln;
writeln('* Add Customer : 01');
writeln('* Find Customer By Last name : 02');
writeln('* Find Customer By Customer Code : 03');
writeln('* View All Customer : 04');
writeln('* Profit : 05');
writeln('* Delete Customer : 06');
writeln('* For Sorting Data By Last Name : 07');
writeln('* For Sorting Data By Customer Code : 08');
writeln('* Help : 09');
writeln;
writeln('Enter Service Code :');
readln(sc);
clrscr;
end;
procedure scan;
var
n,i,j : integer;
k : char;
begin
writeln(' * A D D C U S T O M E R S Y S T E M *');
writeln;
while n > 100 do
begin
writeln('Enter Number of Customer you want to add');
readln(n);
m:=m+n;
if n > 100 then
begin
writeln('You can only Enter 100 customer!');
m:=m-n;
end;
for i:= 1 to n do
begin
for j:= 1 to 5 do
begin
case j of
1:
begin
writeln('Select Accunt Type For Below Chart :');
writeln('***********************************');
writeln('* Account Name * Code *');
writeln('***********************************');
writeln('* Long Period 1 Year : 1 *');
writeln('* Long Period 2 Year : 2 *');
writeln('* Long Period 3 Year : 3 *');
writeln('* Long Period 4 Year : 4 *');
writeln('* Long Period 5 Year : 5 *');
writeln('* Short Period : 6 *');
writeln('***********************************');
writeln;
writeln('Enter Type Code :');
readln(info[i,2]);
if info[i,2]='1' then
info[i,2]:='Long Period 1 Year'
else if info[i,2]='2' then
info[i,2]:='Long Period 2 Year'
else if info[i,2]='3' then
info[i,2]:='Long Period 3 Year'
else if info[i,2]='4' then
info[i,2]:='Long Period 4 Year'
else if info[i,2]='5' then
info[i,2]:='Long Period 5 Year'
else if info[i,2]='6' then
info[i,2]:='Short Period'
else
begin
Writeln('For Your Acount Profit Not Calculate');
info[i,2]:='None';
end;
end;
3:
begin
writeln('Enter Last name of Customer :');
readln(fa[i]);
end;
2:
begin
writeln('Enter First name of Customer :');
readln(info[i,1]);
end;
4:
begin
writeln('Enter Customer Code :');
readln(no[i,1]);
end;
5:
begin
writeln('Enter Customer ',no[i,1],' Supply :');
readln(no[i,2]);
end;
end;
end;
writeln;
writeln('Entering Data Compelited');
writeln;
writeln('* ',info[i,1],' ',fa[i],' ',info[i,2],' Accunt Sucssecfuly Created');
writeln;
if i<>n then
writeln('Now Enter Data of Customer ',i+1);
end;
Writeln('Entering Data for ',n,' Customer Compelited');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure scan}
end;
برای در یافت ادامه سورس کد به ادامه متن بروید.
نوشته شده توسط : حسین تجره نژاد
در یافت یک تاریخ و مشخص نمودن نام آن روز به در خواست توحید
شنبه 7 دی 1387 07:45 ب.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
uses wincrt;
var
td : array[1..10] of char;
ld : array[1..12] of char;
ntda : array[1..17] of string[10];
ndt : string[10];
td1,td2,tm1,tm2,ty1,ty2,ty3,ty4,ntd,tm,ty : integer;
ld1,ld2,lm1,lm2,ly1,ly2,ly3,ly4,nld,lm,ly : integer;
i,index,D,R : integer;
ndtd,ndtm,ndty : longint;
ndld,ndlm,ndly : longint;
begin
ntda[1]:='shanbe';
ntda[2]:='1shanbe';
ntda[3]:='2shanbe';
ntda[4]:='3shanbe';
ntda[5]:='4shanbe';
ntda[6]:='5shanbe';
ntda[7]:='jome';
ntda[8]:='shanbe';
ntda[9]:='1shanbe';
ntda[10]:='2shanbe';
ntda[11]:='3shanbe';
ntda[12]:='4shanbe';
ntda[13]:='5shanbe';
ntda[14]:='jome';
writeln('Like below :');
for i:= 1 to 7 do
write(ntda[i]:10);
writeln;
writeln('Enter Name Of Today');
readln(ndt);
writeln('Enter Date of Today');
for i:= 1 to 10 do
read(td[i]);
writeln('Enter date of day which you want to know name :');
i:=1;
for i:= 1 to 12 do
read(ld[i]);
for i:=7 to 14 do
if ntda[i]=ndt then
index:=i;
writeln;
td1:=ord(td[10])-48;
td2:=ord(td[9])-48;
tm1:=ord(td[7])-48;
tm2:=ord(td[6])-48;
ty1:=ord(td[4])-48;
ty2:=ord(td[3])-48;
ty3:=ord(td[2])-48;
ty4:=ord(td[1])-48;
ntd:=td1+(10*td2);
tm:=tm1+(10*tm2);
ty:=ty1+(10*ty2)+(100*ty3)+(1000*ty4);
ld1:=ord(ld[12])-48;
ld2:=ord(ld[11])-48;
lm1:=ord(ld[9])-48;
lm2:=ord(ld[8])-48;
ly1:=ord(ld[6])-48;
ly2:=ord(ld[5])-48;
ly3:=ord(ld[4])-48;
ly4:=ord(ld[3])-48;
nld:=ld1+(10*ld2);
lm:=lm1+(10*lm2);
ly:=ly1+(10*ly2)+(100*ly3)+(1000*ly4);
writeln;
if tm<=6 then
ndtm:=tm*31
else
ndtm:=(6*31)+((tm-6)*30);
ndty:=ty*365+(ty div 4);
ndtd:=ntd+ndtm+ndty;{today date bu day}
if lm<=6 then
ndlm:=lm*31
else
ndlm:=(6*31)+((lm-6)*30);
ndly:=ly*365+(ly div 4);
ndld:=nld+ndlm+ndly;{last date bu day}
d:=ndtd-ndld;
R:=D mod 7;
writeln;
case R of
0: write(ntda[index]);
1: write(ntda[index-1]);
2: write(ntda[index-2]);
3: write(ntda[index-3]);
4: write(ntda[index-4]);
5: write(ntda[index-5]);
6: write(ntda[index-6]);
end;
end.
نوشته شده توسط : حسین تجره نژاد
سیستم ثبت اطلاعات دانشجویان:ثبت:حذف:مرتب سازی به در خواست دوستان
جمعه 6 دی 1387 11:11 ق.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
{Student Information
Programming By Hussein Tajarenezhad
Tajarenezhad@gmail.com}
uses wincrt;
type
StudentInformation = record
firstname,lastname : string[20];
studentno : longint;
average : real;
end;
students = array[1..100] of StudentInformation;
var
stud : students;
sc,m,s,i,j : integer;
procedure starting;
begin
writeln('* W E L C O M E T O S T U D E N T I N F O R M A T I O N *');
writeln;
Writeln('What You Want To Do?');
writeln;
writeln(' * Add Student : 01');
writeln(' * Find Student By Last name : 02');
writeln(' * Find Student By Student.No : 03');
writeln(' * View All Student : 04');
writeln(' * Delete Student : 05');
writeln(' * For Sorting Student By Last Name : 06');
writeln(' * For Sorting Student Student.No : 07');
writeln(' * Edit Student Infomation : 08');
writeln;
writeln('Enter Service Code :');
readln(sc);
clrscr;
end;
procedure scan;
var
n,i,j : integer;
begin
writeln(' * A D D S T U D E N T S Y S T E M *');
writeln;
while n > 100 do
begin
writeln('Enter Number of Student you want to add');
readln(n);
m:=m+n;
if n > 100 then
begin
writeln('You can only Enter 100 Student!');
m:=m-n;
end;
for i:= 1 to n do
begin
for j:= 1 to 4 do
begin
case j of
4:
begin
writeln('Enter Student Average :');
readln(stud[i].average);
end;
2:
begin
writeln('Enter Last name of Student :');
readln(stud[i].lastname);
end;
1:
begin
writeln('Enter First name of Student :');
readln(stud[i].firstname);
end;
3:
begin
writeln('Enter Student.No :');
readln(stud[i].Studentno);
end;
end;
end;
writeln;
writeln('Entering Data Compelited');
writeln;
write('* ',stud[i].firstname,' ',stud[i].lastname,' ',stud[i].studentno);
writeln(' Student Sucssecfuly Added');
writeln;
if i<>n then
writeln('Now Enter Data of Student ',i+1);
end;
Writeln('Entering Data for ',n,' Student Compelited');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;
end;{End of procedure scan}
procedure searchname;
var
l : string[30];
flag,sni : integer;
begin
writeln(' * S E A R C H I N G S Y S T E M : B Y L A S T N A M E *');
writeln;
writeln('Enter last name which you want to search');
readln(l);
flag:= 0;
sni:=1;
while (sni<100) and (flag=0) do
begin
if l=stud[sni].lastname then
begin
writeln('Data Found!');
writeln;
writeln('*******************************************************************************');
writeln('*');
writeln('* Full name : ',stud[sni].firstname,' ',stud[sni].lastname);
writeln('* Student.No : ',stud[sni].studentno);
writeln('* Average : ',stud[sni].average:5:2);
writeln('*');
writeln('*******************************************************************************');
flag:= 1;
end;
inc(sni);
end;
if flag=0 then
Writeln('Student Not Found');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure search name}
برای دریافت ادامه سورس کد ادامه مطلب را ببینید
نوشته شده توسط : حسین تجره نژاد
سیستم کتابخانه
سه شنبه 3 دی 1387 12:36 ب.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
uses wincrt;{Programming By Hussein Tajarenezhad(Tajarenezhad@Gmail.com)}
type
MemberInfo = array[1..100,1..3] of string[30];{First name,Last Name ,Books}
Bookinfo = array[1..500,1..3] of string[20];{Book name ,Author name ,Book code,}
MemberCode = array[1..100] of integer;{Member Code}
var
mi : memberinfo;
bi : bookinfo;
mc : membercode;
sc,i,j,mm,mb : integer;
procedure starting;
begin
writeln(' * L I B R A R Y S Y S T E M *');
writeln;
Writeln(' What You Want To Do?');
writeln;
writeln('* Add Member : 01');
writeln('* Add Book : 02');
writeln('* Find Member : 03');
writeln('* View All Member : 04');
writeln('* View All Book : 05');
writeln('* Find Book : 06');
writeln;
writeln('Enter Service Code :');
readln(sc);
clrscr;
end;
procedure scanmember;
var
n,i,j : integer;
k : char;
begin
writeln(' * A D D M E M B E R S Y S T E M *');
writeln;
while n > 100 do
begin
writeln('Enter Number of Member you want to add');
readln(n);
mm:=mm+n;
if n > 100 then
begin
writeln('You can only Enter 100 Member!');
mm:=mm-n;
end;
for i:= 1 to n do
begin
for j:= 1 to 3 do
begin
case j of
2:
begin
writeln('Enter Last name of Member :');
readln(mi[i,2]);
end;
1:
begin
writeln('Enter First name of Member :');
readln(mi[i,1]);
end;
3:
begin
writeln('Enter Member Code :');
readln(mc[i]);
end;
end;
end;
writeln;
writeln('Entering Data Compelited');
writeln;
writeln('* ',mi[i,1],' ',mi[i,2],' ',' Accunt Sucssecfuly Created');
writeln;
if i<>n then
writeln('Now Enter Data of Member ',i+1);
end;
Writeln('Entering Data for ',n,' Member Completed');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure scanmember}
end;
procedure scanbook;
var
n,i,j : integer;
k : char;
begin
writeln(' * A D D B O O K S Y S T E M *');
writeln;
writeln('Enter Number of Book you want to add');
readln(n);
mb:=mb+n;
if n > 1000 then
begin
writeln('You can only Enter 1000 Book!');
for i:= 1 to n do
begin
for j:= 1 to 3 do
begin
case j of
1:
begin
writeln('Enter Name of Book :');
readln(bi[i,1]);
end;
2:
begin
writeln('Enter Name of Book Author :');
readln(bi[i,2]);
end;
3:
begin
writeln('Enter Book Code :');
readln(bi[i,3]);
end;
end;
end;
writeln;
writeln('Entering Data Compelited');
writeln;
writeln('* ',bi[i,1],' ',bi[i,2],' Book Sucssecfuly Added');
writeln;
if i<>n then
writeln('Now Enter Data of Book ',i+1);
end;
Writeln('Entering Data for ',n,' Book Completed');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure scanbook}
end;
procedure findmember;
var
cc : longint;
flag1,sci : integer;
begin
writeln(' * S E A R C H I N G S Y S T E M : B Y M E M B E R C O D E *');
writeln;
writeln('Enter Member Code which you want to search');
readln(cc);
flag1:= 0;
sci:=1;
while (sci<100) and (flag1=0) do
begin
if (cc=mc[sci]) then
begin
writeln('Data Found!');
writeln('*******************************************************************************');
writeln('*');
writeln('* Full name : ',mi[sci,1],' ',mi[sci,2]);
writeln('* Member Code : ',mc[sci]);
writeln('* ');
writeln('* Book''s : ',mi[sci,3]);
writeln('* ');
writeln('*');
writeln('*******************************************************************************');
flag1:= 1;
end;
inc(sci);
end;
if flag1=0 then
Writeln('Member Not Found');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure search code}
procedure findbook;
var
l : string[30];
flag,sni : integer;
begin
writeln(' * S E A R C H I N G S Y S T E M : B Y B O O K N A M E *');
writeln;
writeln('Enter book name which you want to search');
readln(l);
flag:= 0;
sni:=1;
while (sni<100) and (flag=0) do
begin
if l=bi[sni,1] then
begin
writeln('Data Found!');
writeln;
writeln('*******************************************************************************');
writeln('*');
writeln('* Book name : ',bi[sni,1]);
writeln('* Book Code : ',bi[sni,3]);
writeln('* Author : ',bi[sni,2]);
writeln('* ');
writeln('* ');
writeln('*');
writeln('*******************************************************************************');
flag:= 1;
end;
inc(sni);
end;
if flag=0 then
Writeln('Book Not Found');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure search book name}
procedure showallmember;
begin
writeln(' * V I E W A L L M E M B E R A C C U N T S Y S T E M *');
writeln;
writeln('*******************************************************************************');
writeln('* Full Name * Member Code * Books * *');
writeln('*******************************************************************************');
for i:= 1 to mm do
begin
write(' ',mi[i,1],' ',mi[i,2]);
write(' ':5,mc[i]);
write(' ':5,mi[i,3]);
end;
writeln('*******************************************************************************');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure show member}
procedure showallbook;
begin
writeln(' * V I E W A L L B O O K S Y S T E M *');
writeln;
writeln('*******************************************************************************');
writeln('* Book Name * Author Name * Book Code * *');
writeln('*******************************************************************************');
for i:= 1 to mb do
begin
write(' ',bi[i,1]);
write(' ':5,bi[i,2]);
write(' ':5,bi[i,3]);
end;
writeln('*******************************************************************************');
writeln;
writeln('For Continue Press Enter');
readln;
clrscr;
starting;
end;{End of procedure show book}
procedure afterstarting;
begin
case sc of
01:
scanmember;
02:
scanbook;
03:
findmember;
04:
showallmember;
05:
showallbook;
06:
findbook;
else
begin
writeln('* With Code: ',sc,' We Dont Have Service!!!');
starting;
end;
end;
end;
begin
starting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
afterstarting;
end.
{Programming By Hussein Tajarenezhad(Tajarenezhad@Gmail.com)}
نوشته شده توسط : حسین تجره نژاد
ضرب و جمع دو عدد 20 رقمی به در خواست emad
یکشنبه 1 دی 1387 09:16 ب.ظ
نوع مطلب : سورس کدهای پاسکال ،آموزش برنامه نویسی با پاسکال ،
uses wincrt;
var
s1,s2,sum : string[21];
sum1,s : string[20];
jj,p,i,n1,j,n2,kk,c,k,er : integer;
begin
writeln('Enter S1 :');
readln(s1);
writeln('Enter S2 :');
readln(s2);
c:=0;
for i:=20 downto 1 do
begin
val(s1[i],n1,er);
val(s2[i],n2,er);
k:=n1+n2;
sum[i+1]:=chr(k mod 10 + ord('0'));
c:=k div 10;
end;
sum[1]:=chr(c + ord('0'));
sum[0]:=chr(21);
writeln;
writeln('',s1,' + ',s2,' = ',sum);
for i:= 1 to 50 do
sum1[i]:='0';
sum1[0]:=chr(50);
p:=50;
for i:=20 downto 1 do
begin
val(s1[i],n1,er);
for kk:=1 to 50 do
s[kk]:='0';
s[0]:=chr(50);
c:=0;
jj:=p;
for j:= 20 downto 1 do
begin
val(s1[j],n2,er);
k:=n1*n2;
s[jj]:=chr((k mod 10)+ord('0'));
c:= k div 10;
dec(jj);
end;
s[jj]:=chr(c+ord('0'));
c:=0;
dec(p);
for kk:=50 downto jj+1 do
begin
val(s[kk],n1,er);
k:=n1*n2;
sum1[kk]:=chr(k mod 10+ord('0'));
c:=k div 10;
end;
sum[jj]:=chr(c+ord('0'));
end;
writeln;
writeln(' ',s1,' + ',s2,' = ',sum1);
end.{TEST NOT COMPLETE}
نوشته شده توسط : حسین تجره نژاد
تعیین بشترین تکرار 0 تا 9 در یک آرایه 20 عضوی به در خواست پریسا
پنجشنبه 28 آذر 1387 12:20 ب.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
uses wincrt;
var
a: array[1..20] of integer;
b: array[0..9] of integer;
i,max: integer;
begin
writeln('Enter Numbers');
for i:= 1 to 20 do
begin
writeln('Enter Number ',i);
readln(a[i]);
end;
writeln;
for i:=1 to 20 do
begin
case a[i] of
0: b[0]:=b[0]+1;
1: b[1]:=b[1]+1;
2: b[2]:=b[2]+1;
3: b[3]:=b[3]+1;
4: b[4]:=b[4]+1;
5: b[5]:=b[5]+1;
6: b[6]:=b[6]+1;
7: b[7]:=b[7]+1;
8: b[8]:=b[8]+1;
9: b[9]:=b[9]+1;
end;
end;
max:=b[0];
for i:= 1 to 9 do
if b[i] > max then
max:=b[i];
if max= b[0] then
Writeln('Number with Maximum repeat is ',0)
else if max= b[1] then
Writeln('Number with Maximum repeat is ',1)
else if max= b[2]then
Writeln('Number with Maximum repeat is ',2)
else if max= b[3]then
Writeln('Number with Maximum repeat is ',3)
else if max= b[4]then
Writeln('Number with Maximum repeat is ',4)
else if max= b[5]then
Writeln('Number with Maximum repeat is ',5)
else if max= b[6]then
Writeln('Number with Maximum repeat is ',6)
else if max= b[7]then
Writeln('Number with Maximum repeat is ',7)
else if max= b[8]then
Writeln('Number with Maximum repeat is ',8)
else if max= b[9]then
Writeln('Number with Maximum repeat is ',9);
end.
نوشته شده توسط : حسین تجره نژاد
دریافت اطلاعات 100 دانشجو ، چاپ لیست مشروطین ، منظم نمودن اطلاعات قبول شدگان بر اساس فامیلی
جمعه 22 آذر 1387 11:46 ق.ظ
نوع مطلب : سورس کدهای پاسکال ،
uses wincrt;
var
info : array[1..100,1..2] of string[25];
fa: array[1..100]of string[30];
no : array[1..100,1..6] of integer;
ave: array[1..10] of real;
n,i,j,index,t : integer;
an,min,temp: string[30];
t1 : real;
begin
writeln('Enter Number Of Student Which you want to add,Maximum is 100');
readln(n);
if n>100 then
writeln('Number Is Greater than 100,program will work But in continue you have problem');
writeln('Now Enter Information');
for i:=1 to n do
for j:=1 to 9 do
begin
case j of
1:
begin
writeln('Enter First name of student ',i);
readln(info[i,1]);
end;
2:
begin
writeln('Enter Last name of student ',i);
readln(fa[i]);
end;
3:
begin
writeln('Enter Student No of student ',i);
readln(info[i,2]);
end;
4:
begin
writeln('Enter grade 1 of student ',i);
readln(no[i,1]);
end;
5:
begin
writeln('Enter unit of grad 1 of student ',i);
readln(no[i,2]);
end;
6:
begin
writeln('Enter grade 2 of student ',i);
readln(no[i,3]);
end;
7:
begin
writeln('Enter unit of grad 2 of student ',i);
readln(no[i,4]);
end;
8:
begin
writeln('Enter grade 3 of student ',i);
readln(no[i,5]);
end;
9:
begin
writeln('Enter unit of grad 3 of student ',i);
readln(no[i,6]);
end;
end;
end;
for i:= 1 to n do
for j:= 1 to 6 do
ave[i]:=(((no[i,1]*no[i,2])+(no[i,3]*no[i,4])+(no[i,5]*no[i,6]))/(no[i,2]+no[i,4]+no[i,6]));
writeln('If You Want Liste Mashrootin Write mashroot');
writeln('If You Want Liste Ghaboolin write ghabool');
readln(an);
if an='mashroot' then
begin
writeln('*********** Liste Mashrootin ************');
for i:= 1 to n do
if (ave[i]<10) then
begin
writeln('*');
writeln('* Full name : ',info[i,1],' ',fa[i]);
writeln('* Student No : ',info[i,2]);
writeln('* Average is : ',ave[i]:5:2);
writeln('*');
end;
writeln('*****************************************');
end
else if (an='ghabool') then
begin
for i:= 1 to n do
begin
min:= fa[i];
index:=i;
for j:= i+1 to n do
if fa[j]< min then
begin
min:= fa[j];
index:=j;
end;
fa[index]:=fa[i];
fa[i]:=min;
for j:= 1 to 2 do
begin
temp:=info[i,j];
info[i,j]:=info[index,j];
info[index,j]:=temp;
end;
for j:=1 to 6 do
begin
t:=no[i,j];
no[i,j]:=no[index,j];
no[index,j]:=t;
end;
t1:=ave[i];
ave[i]:=ave[index];
ave[index]:=t1;
end;
writeln('********************************** Liste Ghaboolin ***********************');
writeln('* *');
writeln('*Last name * First name * Student No * grade1 * grade2 * grad3 * average *');
i:=1;
for i:= i to n do
begin
if (ave[i]<10) then
i:=i+1;
writeln('*',fa[i],' * ',info[i,1],' * ',info[i,2],' * ',no[i,1],' * ',no[i,3],' * ',no[i,5],' * ',ave[i]:5:2,'*');
end;
writeln('**************************************************************************');
end;
end.
نوشته شده توسط : حسین تجره نژاد
حل دو معادله دو مجهول به روش کرامر به درخواست توحید
چهارشنبه 20 آذر 1387 10:24 ب.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
Uses wincrt;
var
a,b,c,d,e,f,x,y : real;
begin
writeln('In Style Below :');
writeln('ax + by = e');
writeln('cx + dy = f');
writeln;
writeln('Enter a :');
read(a);
writeln('Enter b :');
read(b);
writeln('Enter e :');
read(e);
writeln('Enter c :');
read(c);
writeln('Enter d :');
read(d);
writeln('Enter f :');
read(f);
x:=((e*d-b*f)/(a*d-b*c));
y:=((a*f-e*c)/(a*d-b*c));
writeln;
writeln('X = ',x:5:2);
writeln('Y = ',y:5:2);
end.
نوشته شده توسط : حسین تجره نژاد
دریافت تاریخ به عدد و نمایش آن با حروف به درخواست معین
سه شنبه 19 آذر 1387 11:56 ق.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
uses wincrt;
var
date : array[1..10] of char;
d1,d2,m1,m2,y1,y2,y3,y4,i,M,D : integer;
begin
writeln('Enter Date in (dd/mm/yyyy) pattern.');
writeln('for exampel (16/09/1387).');
for i:= 1 to 10 do
read(date[i]);
d1 := ord(date[1])-48;
d2 := ord(date[2])-48;
m1 := ord(date[4])-48;
m2 := ord(date[5])-48;
y1 := ord(date[7])-48;
y2 := ord(date[8])-48;
y3 := ord(date[9])-48;
y4 := ord(date[10])-48;
D := d1*10+d2;
M := m1*10+m2;
case D of
1 : write('yek e ');
2 : write('do e ');
3 : write('se e ');
4 : write('chahar e ');
5 : write('panj e ');
6 : write('shesh e ');
7 : write('haft e ');
8 : write('hasht e ');
9 : write('noh e ');
10: write('dah e ');
11: write('yazdah e ');
12: write('davazdah e ');
13: write('sizdah e ');
14: write('chahardah e ');
15: write('panzdah e ');
16: write('shanzdah e ');
17: write('hefdah e ');
18: write('hejdah e ');
19: write('nozdah e ');
20: write('bisto e ');
21: write('bisto yek e ');
22: write('bisto do e ');
23: write('bisto se e ');
24: write('bisto chahar e ');
25: write('bisto panj e ');
26: write('bisto shesh e ');
27: write('bisto haft e ');
28: write('bisto hasht e ');
29: write('bisto noh e ');
30: write('si e ');
31: write('si o yek e ');
end;
case M of
1 : write('Farvardan e ');
2 : write('Ordibehesht e ');
3 : write('Khordad e ');
4 : write('Tir e ');
5 : write('Mordad e ');
6 : write('Shahrivar e ');
7 : write('Mehr e ');
8 : write('Aban e ');
9 : write('Azar e ');
10: write('Dey e ');
11: write('Bahman e ');
12: write('Esfand e ');
end;
write('Hezar o ');
case y2 of
1 : write('sad o ');
2 : write('divist o ');
3 : write('sisad o ');
4 : write('chaharsad o ');
5 : write('pansad o ');
6 : write('sheshsad o ');
7 : write('haftsad o ');
8 : write('hashtsad o ');
9 : write('nohsad o ');
end;
if y3 = 1 then
begin
case (y3*10+y4) of
10: write('dah ');
11: write('yazdah ');
12: write('davazdah ');
13: write('sizdah ');
14: write('chahardah ');
15: write('panzdah ');
16: write('shanzdah ');
17: write('hefdah ');
18: write('hejdah ');
19: write('nozdah ');
end;
end
else
begin
case y3 of
2: write('bist o ');
3: write('si o ');
4: write('chehel o ');
5: write('oanjah o ');
6: write('shast o ');
7: write('haftad o ');
8: write('hashtad o ');
9: write('navad o ');
end;
case y4 of
1 : write('yek ');
2 : write('do ');
3 : write('se ');
4 : write('chahar ');
5 : write('panj ');
6 : write('shesh ');
7 : write('haft ');
8 : write('hasht ');
9 : write('noh ');
end;
end;
end.
نوشته شده توسط : حسین تجره نژاد
دریافت اطلاعات حداکثر 100 کارمند و کسر بیمه و مالیات ونمایش اطلاعات آنها با کد کارمندی به درخواست معین
سه شنبه 19 آذر 1387 11:13 ق.ظ
نوع مطلب : سورس کدهای پاسکال ،سورس کدها و پروژه های درخواستی ،
uses wincrt;
var
info : array[1..100,1..3] of string[30];
no : array[1..100,1..8] of real;
i,j,n,emno : integer;
begin
writeln('Enter Number Of Employee which you want to add,Maximum is 100');
readln(n);
if n>100 then
writeln('Number Is Greater than 100,program will work But in continue you have problem');
for i:= 1 to n do
for j:= 1 to 5 do
begin
case j of
1 :
begin
writeln('Enter First Name OF Employee',' ',i);
readln(info[i,1]);
end;
2 :
begin
writeln('Enter Last Name OF Employee',' ',i);
readln(info[i,2]);
end;
3 :
begin
writeln('Enter Employee Code OF Employee',' ',i);
readln(no[i,1]);
end;
4 :
begin
writeln('Enter Hours work of Employee',' ',i);
readln(no[i,2]);
end;
5 :
begin
writeln('earn per hours of employee',' ',i);
readln(no[i,3]);
end;
end;
no[i,4]:=no[i,2]*no[i,3];{hogoogh}
no[i,5]:=no[i,4]*(10/100);{maliyat}
no[i,6]:=no[i,4]*(7/100);{bimeh}
no[i,7]:=no[i,4]-no[i,5]-no[i,6];{daryafti}
end;
writeln;
writeln('Entering Information Compilited!');
writeln('Now You can Enter Employee Code and recive information');
readln(emno);
for i:= 1 to n do
if emno=no[i,1] then
begin
writeln('Information Of Employee',' ',i);
writeln(' Full name : ',info[i,1],' ',info[i,2]);
writeln(' Employee Code : ',no[i,1]:8:2);
writeln( 'Hours of work : ',no[i,2]:8:2);
writeln(' Earn Per Hours : ',no[i,3]:8:2);
writeln(' Hoghooghe Khales : ',no[i,4]:8:2);
writeln('Kasre Haghe Bimeh : ',no[i,6]:8:2);
writeln(' Kasre Maliyat : ',no[i,5]:8:2);
writeln(' Daryafti : ',no[i,7]:8:2);
end;
i:= i+1;
if i > n then
writeln('There is No Employee With Upper Code');
end.
نوشته شده توسط : حسین تجره نژاد