Data Sorting

Sorting Method #1: Bubble Sort

Procedure BubbleSort(numbers : Array of Integer; size : Integer);
Var i, j, temp : Integer;


Begin
   For i := size-1 DownTo 1 do
       For j := 2 to i do
           If (numbers[j-1] > numbers[j]) then
                Begin
                     temp := numbers[j-1];
                     numbers[j-1] := numbers[j];
                     numbers[j] := temp;
                End;

End. 

Sorting Method #2: Insertion Sort

Procedure InsertionSort(numbers : Array of Integer; size : Integer);
Var i, j, index : Integer


Begin
For i := 2 to size-1 do
  Begin
   index := numbers[i];
   j := i;
   While ((j > 1) AND (numbers[j-1] > index)) do
    Begin
     numbers[j] := numbers[j-1];
     j := j - 1;
    End;
   numbers[j] := index;
  End;

End.

Sorting Method #3: Quick Sort

Procedure QSort(numbers : Array of Integer;
                left : Integer; right : Integer);
Var pivot, l_ptr, r_ptr : Integer;


Begin
l_ptr := left;
r_ptr := right;
pivot := numbers[left];
While (left < right) do
  Begin
   While ((numbers[right] >= pivot) AND (left < right)) do
    right := right - 1;
   If (left <> right) then
    Begin
     numbers[left] := numbers[right];
     left := left + 1;
    End;
   While ((numbers[left] <= pivot) AND (left < right)) do
    left := left + 1;
   If (left <> right) then
    Begin
     numbers[right] := numbers[left];
     right := right - 1;
    End;
End;
numbers[left] := pivot;
pivot := left;
left := l_ptr;
right := r_ptr;
If (left < pivot) then
  QSort(numbers, left, pivot-1);
If (right > pivot) then
  QSort(numbers, pivot+1, right);
End;

نوشته شده توسط : حسین

سورس های ارسالی

سورس های زیر توسط ahura برای وبلاگ ارسال شده

سورس  هشت وزیر   :     دریافت

سورس تبدیل اعداد رومی به صحیح :     دریافت

سورس رمز گشا         :     دریافت

با تشکر از ahura ی عزیز.

 

{ NOT TESTED }

نوشته شده توسط : حسین

تعویض قطر اصلی و فرعی ماتریس n در n به در خواست دوستان

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.

نوشته شده توسط : حسین

دفترچه تلفن

دانلود سورس :                                  دفترچه تلفن

دانلود فایل اجرایی :                            دفترچه تلفن

 

برای مشاهده سورس به ادامه مطلب بروید

 

ادامه مطلب

نوشته شده توسط : حسین

تعویض قطر اصلی و فرعی ماتریس 5 در 5 به درخواست دوستان

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.

نوشته شده توسط : حسین

سیستم بانکداری با استفاده از رکورد ها

دانلود سورس :                          سیستم بانکداری با استفاده از رکورد ها

دانلود فایل جرایی :                    سیستم بانکداری با استفاده از رکورد ها

{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}

 

برای مشاهده ادامه سورس برنامه به ادامه مطلب بروید......

ادامه مطلب

نوشته شده توسط : حسین

سیستم بانکداری با استفاده از آرایه ها

{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;

برای در یافت ادامه سورس کد به ادامه متن بروید.                                                                                              

ادامه مطلب

نوشته شده توسط : حسین

در یافت یک تاریخ و مشخص نمودن نام آن روز به در خواست توحید

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.

نوشته شده توسط : حسین

سیستم ثبت اطلاعات دانشجویان:ثبت:حذف:مرتب سازی به در خواست دوستان

{Student Information
Programming By Hussein Tajarenezhad
[e-mail]}

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}

برای دریافت ادامه سورس کد ادامه مطلب را ببینید

ادامه مطلب

نوشته شده توسط : حسین

سیستم کتابخانه

uses wincrt;{Programming By Hussein Tajarenezhad([e-mail])}

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([e-mail])}

نوشته شده توسط : حسین

ضرب و جمع دو عدد 20 رقمی به در خواست emad

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 عضوی به در خواست پریسا

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 دانشجو ، چاپ لیست مشروطین ، منظم نمودن اطلاعات قبول شدگان بر اساس فامیلی

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.

نوشته شده توسط : حسین

حل دو معادله دو مجهول به روش کرامر به درخواست توحید

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.

نوشته شده توسط : حسین

دریافت تاریخ به عدد و نمایش آن با حروف به درخواست معین

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.

نوشته شده توسط : حسین