===========================================================

===============================================

============================

=============

====

=

سلام

خوب بلاخره پرونده برنامه های پاسکال رو می بندیم و می ریم سراغ ++c

اگه کسی سوالی از پاسکال داشت تو قسمت نظرات همین پست بنویسه بهش جواب داده میشه

می تونید کل پرو‌ژه های پاسکال رو از اینک پایین در دریافت کنید.

موفق باشید

سجاد گرامی

http://ifile.it/3bq2807

http://sharedzilla.com/en/get?id=207510

=

======

=============

======================

================================

===========================================

========================================================

=============================================================

سلام

اینم  حسن ختام پروژه های پاسکال.

موفق باشید.

program magic_matrix ;
 uses crt;
 const con3t = 20 ;
 var i,tul:integer;
     odd:boolean;
     a:array[1..con3t , 1..con3t] of integer;

{--------- www.ukcs86.zet.ir -----------}

procedure  clear_matrix;
 var i,j :integer;
  begin
    for i:=1to con3t do
      for j:=1 to con3t do
        a[i,j]:=0;
  end; { of procedure clear_matrix }

{--------- www.ukcs86.zet.ir -----------}

procedure   show_magix_matrix (tul:integer);
 var p,w:integer;
  begin
    for p:=1 to tul do
      begin
         for w := 1 to tul do
            write(a[p,w]:5);
         writeln;
      end;
  end; { of procedure show_magix_matrix }

{--------- www.ukcs86.zet.ir -----------}

procedure do_magic(tul:integer) ;
 var x,y:integer;
  begin{of procedure do_magic}
    x:=1; y:=(tul div 2 )+1;  a[x,y]:=1;
    for i:=2 to (tul*tul) do
      begin
        x:=x-1; y:=y-1;
        if x=0 then x:=tul;
        if y=0 then y:=tul;

        if a[x,y]=0 then  a[x,y]:=i
        else
          begin
            x:=x+2; y:=y+1;
            if x>tul then x:=x-tul;
            if y>tul then y:=y-tul;
            a[x,y]:=i;
          end;{else}
      end;{of for1}
  end;{of procedure do_magic}

{--------- www.ukcs86.zet.ir -----------}

begin
  clear_matrix;
  clrscr;
  write('pleaze enter an odd number : ');
  readln(tul);
  if (tul mod 2) =0 then
     begin
        odd := false;
        writeln('sorry you sould enter a odd number');
     end
  else
      odd:=true;
  if odd then
    do_magic(tul);

  show_magix_matrix(tul);
readln;
end.{-------- source by sajjadG -----------}

------------------------------------------------------------------------------------------------

program eight_gueens;
{uses crt;}
const max=8;   {this is number max queen } { max = 8 ---> 8 vazir }
type  sahovincia = array [1..max,1..max] of boolean ;
var i,j:integer ;
sah : sahovincia;
t:boolean;

{------------------------- function queen - ok ----------------------}

function queen_ok(i,j:integer):boolean;
var
    x :integer;
    t :boolean;
 begin
     t:=false;
     for x:=1 to max do
        t:= t or sah[i,x] or sah[x,j]; {ha}
        {in shart khali budane khanehaye ofoghi va amudi
        ra chek mikonad }

     for x:=1 to max do
        begin  {this 2 line is for cheks row(satr) and column(soton) and ...(orib ya kaj) }
           if (i+j-x>=1) and(i+j-x<=max) then
               t:= (  t or sah[x,i+j-x]  );{agar sah dorost nabud t false meghdare t ke false ast ra migirad}
           if (x-(i-j)>=1) and (x-(i-j)<=max)then
               t:= (  t or sah [x,x-(i-j)]  );
        end;
    queen_ok:=not t ;
 end;

{---------- my check function -----------}

function check(i,k:integer):boolean;
var x:integer;
begin
  x:=0;
   check:=true;
   if not ((k=1) and (i=k) )then
   begin
      if (k>1) then
        for x:=k downto 2 do
           begin
              if sah[i-1,k-1] then
                 check:=false;
              if sah[i+1,k-1] then
                 check:=false;
           end;
      if k<max then
        for x:=k to max do
          begin
             if sah[i-1,k+1] then
                 check:=false;
             if sah[i+1,k+1] then
                 check:=false;
          end;
     for x:=1 to max do
         begin
            if sah[x,k] then
              check:=false;
            if sah[i,x] then
              check:=false;
         end;
     if k=i then
       check:=false;
  end;
end;{of procedure}

{----------------------- function place queen ---------------------- }

function place_queen(i:integer):boolean;
 var
     k :integer ;
     t :boolean ;
 begin
     if i > max then
         place_queen :=true
     else
         begin
             k:=1 ;{baraye while}
             t:=false ;

          {---------raveshe khodesh-----------}

             while (k<=max) and not t do
                 begin
                   if queen_ok(i,k) then
                       begin
                          sah[i,k]:= true ;
                          t:= place_queen(i+1); {back tracking}
                          if not t then
                             sah[i,k]:=false ;
                       end; {of if}
                   k:=k+1;
                 end;{of while}

         (*    for k:=1 to max do
                 begin
                   if queen_ok(i,k) then
                       begin
                          sah[i,k]:= true ;
                          t:= place_queen(i+1); {back tracking}
                          if not t then
                             sah[i,k]:=false ;
                       end; {of if}
                 end;
           *)
            place_queen:=t; {meghdar dahi be tabe}
         end;{of else begin}
 end;

{-------clear matrix-------------}

procedure clear_matrix;
var i:integer;
begin
    for i:= 1 to max do
       for j:=1 to max  do
         sah[i,j]:=false; { input false in all cell array }
end;{of proc clear_matrix}

{----------show queen place-------------}

procedure show_queens ;
var i: integer;
begin
       for i:=1 to max do
         begin
              for j:=1 to max do
                  if sah[i,j] then
                      writeln ('[ ',i,',',j,' ]');
                  write;
          end;
end;{of proc show_queen}

{----------write_matrix--------------}

procedure write_matrix ;
var i:integer;
begin
   for i:=1 to max do
      begin
          for j:=1 to max do
            if sah[i,j]= false then
               write ('0':4)
            else
               write ('':4);
          writeln;
      end;
end;{of proc write_matrix}

{-------------------  main program --------------------}

begin
    (*  textcolor(4);         { for color font }
      textbackground(1);    { for color back ground } *)

  {clrscr ;    { for clear screen in run program }
  clear_matrix;
  t:=place_queen(1);
  writeln ;
  show_queens;
  write_matrix;
  readln;
end.

-----------------------------------------------------------------------------------------

program snake_game_with_comments_by_sajjadG; (* email address: sajjadgerami2003@yahoo.com *)
                {www.ukcs86.zet.ir}
uses crt,graph;

const passo=19;

var coor:array[1..800,1..2]of integer; { for snake length}
    n:array[1..13]of char; { for logo procedure}
    cont,driver,mode,i,j,x,y,xc,yc,totale,ultx,ulty,point,primato,vel  :  integer;
    direzione,key : char ;
    oldscore,score,s  : string;
    c_error,barkhord_ba_khod,mangia  : boolean;

procedure kadr;
  begin
    rectangle(8,8,(passo*30)-8,(passo*24)-8);
    outtextxy(580,80,'Score:')
  end;
  {------------------------------}
procedure segment(x,y:integer);
 var dd:integer;
  begin
    randomize;
    dd:=random(15);
    setcolor(dd);{range dore snake}
    rectangle(x-9,y-9,x+9,y+9); {9 size morabahaye snake ast}
    setfillstyle(12,white);
    bar(x-8,y-8,x+8,y+8);
    setcolor(white);
  end;
  {------------------------------}
procedure clear_s(x,y:integer);
  begin
    setfillstyle(1,black);
    bar(x-9,y-9,x+9,y+9);
    setfillstyle(1,white)
  end;
  {------------------------------}
procedure gerdi(x,y:integer);
  begin
    x:=x*passo;
    y:=y*passo;
    circle(x,y,8);
    setfillstyle(1,blue);{taghire rage snake hengame barkhord}
  end;
  {------------------------------}
procedure end_sound;
 var i:integer;
  begin
    for i:=1 to 30000 do
      sound(100);
      nosound;
  end;
  {------------------------------}
procedure score_sound;
 var i:integer;
  begin
    for i:=1 to 5000 do
      sound(1100);
      nosound;
  end;
  {------------------------------}
function punti(x:integer):string;
 var
  s:string[10];
begin
  str(x,s);{ in tabe integer(x) ra be string(s) tabdil mikonad}
  punti:=s;
end;
  {---------------base procedure-----------------}
procedure base_procedure;
  begin
    kadr;
    point:=0;
    oldscore:=punti(point);
    score:=oldscore;
    x:=passo*15;
    y:=passo*23;
    direzione:='6';
    key:='6';
    totale:=8;
    barkhord_ba_khod:=false;
    mangia:=false;
    coor[1,1]:=x;
    coor[1,2]:=y;
    c_error:=false;
    for i:=2 to totale do
        begin
           coor[i,1]:=coor[i-1,1]-passo;
           coor[i,2]:=y
        end;
    xc:=15;   yc:=12; {x va y e dayere-circle}
    gerdi(xc,yc); {dayereye hadaf} {tavajoh konid ke gerdi ghable halghast}
    repeat
            setcolor(black);  { baraye chape score }
            outtextxy(580,100,oldscore);
            setcolor(white);
            outtextxy(580,100,score);
            for i:=1 to totale do
                 segment(coor[i,1],coor[i,2]);
            delay(170);
            clear_s(coor[totale,1],coor[totale,2]);
            {clear_s baraye pak kardane rade snake}
            delay(70);
            if (x=xc*passo) and (y=yc*passo) then { sharte barkhorde snake}
               mangia:=true;                      {ba dayereye hadaf }
            if mangia then
                  begin
                       point:=point+9; { adding score}
                       score:=punti(point); {negahdarie score jadid}
                       oldscore:=punti(point-9);{negahdarie score ghadimi}
                       totale:=totale+1; {add shodan segmenthaye mar}
                       coor[totale,1]:=ultx;
                       coor[totale,2]:=ulty;
                       score_sound;
                       repeat
                           c_error:=false;
                           xc:=random(29)+1;{ mokhtasate x gerdie jadid}
                           yc:=random(23)+1; { mokhtasate y gerdie jadid}
                           for i:=1 to totale do
                             if (coor[i,1]=xc*passo)and(coor[i,2]=yc*passo)then
                             { in shart chek mikonad ke aya gerdi roye mar ast ya na}
                                   c_error:=true;
                       until not c_error;
                       gerdi(xc,yc);
                       mangia:=false; {mangia sharte barkhord ast}
                  end;
            if keypressed then key:=readkey;
            case key of
                  '8':if direzione<>'2' then direzione:='8';
                  '2':if direzione<>'8' then direzione:='2';
                  '6':if direzione<>'4' then direzione:='6';
                  '4':if direzione<>'6' then direzione:='4'
            end;
            case direzione of
                     '8': y:=y-passo;
                     '2': y:=y+passo;
                     '6': x:=x+passo;
                     '4': x:=x-passo
            end;
            ultx:=coor[totale,1];
            ulty:=coor[totale,2];
            for i:=totale downto 2 do
                begin {enteghale segmenthaye ghabli be jolo i}
                   coor[i,1]:=coor[i-1,1];
                   coor[i,2]:=coor[i-1,2];
                end;
            coor[1,1]:=x; {mokhtasate sare snake}
            coor[1,2]:=y;
            for i:=2 to totale do { sharte barkhord ba khodesh}
                if (coor[i,1]=x) and (coor[i,2]=y) then
                    barkhord_ba_khod:=true
    until (x-passo<0)or(y-passo<0)or(x+passo=passo*31)or(y+passo=passo*25)or barkhord_ba_khod;
    end_sound;
  end;

    {-----------main program--------------}
begin (*main program.*)
    initgraph (driver,mode,'c:\progra~1\tp\bgi');
    setbkcolor(9);
    repeat
      cleardevice;{manade clear screen dar unit crt mibashad}
      base_procedure;
      cleardevice;
      outtextxy(280,240,'Score :  ');
      outtextxy(350,240,punti(point));
      readln;
      outtextxy(265,270,'New game?(Y/N)');
      key:=readkey
    until (key='n') or (key='N');
    closegraph;
end.{www.ukcs86.zet.ir}

----------------------------------------------------------------------------------------------

program snake_game_with_comments_by_sajjadG; (* email address: sajjadgerami2003@yahoo.com *)
                {www.ukcs86.zet.ir}
uses crt,graph;

const passo=19;

var coor:array[1..800,1..2]of integer; { for snake length}
    n:array[1..13]of char; { for logo procedure}
    cont,driver,mode,i,j,x,y,xc,yc,totale,ultx,ulty,point,primato,vel  :  integer;
    direzione,key : char ;
    oldscore,score,s  : string;
    c_error,barkhord_ba_khod,mangia  : boolean;

procedure kadr;
  begin
    rectangle(8,8,(passo*30)-8,(passo*24)-8);
    outtextxy(580,80,'Score:')
  end;
  {------------------------------}
procedure segment(x,y:integer);
 var dd:integer;
  begin
    randomize;
    dd:=random(15);
    setcolor(dd);{range dore snake}
    rectangle(x-9,y-9,x+9,y+9); {9 size morabahaye snake ast}
    setfillstyle(12,white);
    bar(x-8,y-8,x+8,y+8);
    setcolor(white);
  end;
  {------------------------------}
procedure clear_s(x,y:integer);
  begin
    setfillstyle(1,black);
    bar(x-9,y-9,x+9,y+9);
    setfillstyle(1,white)
  end;
  {------------------------------}
procedure gerdi(x,y:integer);
  begin
    x:=x*passo;
    y:=y*passo;
    circle(x,y,8);
    setfillstyle(1,blue);{taghire rage snake hengame barkhord}
  end;
  {------------------------------}
procedure end_sound;
 var i:integer;
  begin
    for i:=1 to 30000 do
      sound(100);
      nosound;
  end;
  {------------------------------}
procedure score_sound;
 var i:integer;
  begin
    for i:=1 to 5000 do
      sound(1100);
      nosound;
  end;
  {------------------------------}
function punti(x:integer):string;
 var
  s:string[10];
begin
  str(x,s);{ in tabe integer(x) ra be string(s) tabdil mikonad}
  punti:=s;
end;
  {---------------base procedure-----------------}
procedure base_procedure;
  begin
    kadr;
    point:=0;
    oldscore:=punti(point);
    score:=oldscore;
    x:=passo*15;
    y:=passo*23;
    direzione:='6';
    key:='6';
    totale:=8;
    barkhord_ba_khod:=false;
    mangia:=false;
    coor[1,1]:=x;
    coor[1,2]:=y;
    c_error:=false;
    for i:=2 to totale do
        begin
           coor[i,1]:=coor[i-1,1]-passo;
           coor[i,2]:=y
        end;
    xc:=15;   yc:=12; {x va y e dayere-circle}
    gerdi(xc,yc); {dayereye hadaf} {tavajoh konid ke gerdi ghable halghast}
    repeat
            setcolor(black);  { baraye chape score }
            outtextxy(580,100,oldscore);
            setcolor(white);
            outtextxy(580,100,score);
            for i:=1 to totale do
                 segment(coor[i,1],coor[i,2]);
            delay(170);
            clear_s(coor[totale,1],coor[totale,2]);
            {clear_s baraye pak kardane rade snake}
            delay(70);
            if (x=xc*passo) and (y=yc*passo) then { sharte barkhorde snake}
               mangia:=true;                      {ba dayereye hadaf }
            if mangia then
                  begin
                       point:=point+9; { adding score}
                       score:=punti(point); {negahdarie score jadid}
                       oldscore:=punti(point-9);{negahdarie score ghadimi}
                       totale:=totale+1; {add shodan segmenthaye mar}
                       coor[totale,1]:=ultx;
                       coor[totale,2]:=ulty;
                       score_sound;
                       repeat
                           c_error:=false;
                           xc:=random(29)+1;{ mokhtasate x gerdie jadid}
                           yc:=random(23)+1; { mokhtasate y gerdie jadid}
                           for i:=1 to totale do
                             if (coor[i,1]=xc*passo)and(coor[i,2]=yc*passo)then
                             { in shart chek mikonad ke aya gerdi roye mar ast ya na}
                                   c_error:=true;
                       until not c_error;
                       gerdi(xc,yc);
                       mangia:=false; {mangia sharte barkhord ast}
                  end;
            if keypressed then key:=readkey;
            case key of
                  '8':if direzione<>'2' then direzione:='8';
                  '2':if direzione<>'8' then direzione:='2';
                  '6':if direzione<>'4' then direzione:='6';
                  '4':if direzione<>'6' then direzione:='4'
            end;
            case direzione of
                     '8': y:=y-passo;
                     '2': y:=y+passo;
                     '6': x:=x+passo;
                     '4': x:=x-passo
            end;
            ultx:=coor[totale,1];
            ulty:=coor[totale,2];
            for i:=totale downto 2 do
                begin {enteghale segmenthaye ghabli be jolo i}
                   coor[i,1]:=coor[i-1,1];
                   coor[i,2]:=coor[i-1,2];
                end;
            coor[1,1]:=x; {mokhtasate sare snake}
            coor[1,2]:=y;
            for i:=2 to totale do { sharte barkhord ba khodesh}
                if (coor[i,1]=x) and (coor[i,2]=y) then
                    barkhord_ba_khod:=true
    until (x-passo<0)or(y-passo<0)or(x+passo=passo*31)or(y+passo=passo*25)or barkhord_ba_khod;
    end_sound;
  end;

    {-----------main program--------------}
begin (*main program.*)
    initgraph (driver,mode,'c:\progra~1\tp\bgi');
    setbkcolor(9);
    repeat
      cleardevice;{manade clear screen dar unit crt mibashad}
      base_procedure;
      cleardevice;
      outtextxy(280,240,'Score :  ');
      outtextxy(350,240,punti(point));
      readln;
      outtextxy(265,270,'New game?(Y/N)');
      key:=readkey
    until (key='n') or (key='N');
    closegraph;
end.{www.ukcs86.zet.ir}

------------------------------------------------------------------------------------------

program matrix ;
{uses crt;}
const max = 8 ;
type
  a = array[1..max , 1..max] of boolean ;
var
   t:integer;
   c_array:a;
   b: array[1..max] of integer;
   s:string;
   city1,city2:integer;
   n,z:integer;

{---------show matrix------------}

procedure show_m (n:integer);
var j,i,k,c:integer;
begin
   for i:=1 to n do
      for j:=1 to n do
        if (i<>j) and (i<j) then
            writeln('[' , i , ',' ,j, ']=' , c_array[i,j]);
end;

{---------true point------------}

procedure true_p(n:integer) ;
var i,j:integer;
begin
  for i:=1 to n do
   for j :=1 to n do
    begin
     if i=j then
      c_array[i,j]:=false;
    end;
end;{of true_p procedure}

{-----------clear matrix----------------}

procedure clear_m ;
var i,j :integer;
begin
   for i:=1 to max do
    for j:=1 to max do
      c_array[i,j]:=false;
end;

{---------------------------------}

procedure show_matrix(n:integer);
var i,j :integer;
begin
  for i:= 1 to n do
    begin
       for j:= 1 to n do
           write(c_array[i,j]:10);
       writeln;
    end;

end;

{------------way-----------------}

procedure way (n:integer);
var c,i,k,j:integer;
begin
 i:=1;
        repeat
         k:=1;
         for c:=i to n-1 do
           begin
             write('Is there any way between city',i,' and city',i+k,' (y/n):');
             repeat
               readln(s);{??? ba read kar nemikonad ???}
             until (s='y') or (s='n') ;
             if s='y' then
                begin
                   c_array[i,i+k] := true;
                   c_array[i+k,i] := true;
                end;
            k:=k+1;
           end;
          i:=i+1
       until i > n ;
end;

{------------------------------------}

function not_in(w:integer):boolean;
var i : integer;
begin
    not_in:=true;
    for i:= 1 to n do
        if b[i]=w then
           not_in:=false;
end;

{------------------------------------}

function way_ok(i,j:integer):boolean;
begin
   if c_array[i,j] then
      way_ok:=true
    else
      way_ok:=false;
end;

{------------------f------------------}

PROCEDURE f (y,t:integer);
var ii,jj:integer;
begin
   if y = city2 then
     begin
        for ii :=1 to t do
           if b[ii]<>0 then
             write(b[ii],',');
        writeln;
     end
   else
   begin
       for jj:=1 to n do
         if not_in(jj) then
            begin
               if way_ok(y,jj) then
{                  t:=t+1;}
                  b[t+1]:=jj;
                  f(jj,t+1);
            end;
   end;
 b[t]:=0;
end;

  {-----------------------------------}

procedure get_cities ;
var i,j:integer;
begin
  clear_m;
  write('how many city we have : ');
  readln(n);

 { true_p(n);}
  way(n);
{  show_m(n);  }
end;

{--------------proc1--------------------}

 function proc1 (n:integer):boolean;
{ var zz:integer;}
 begin
  for z:=1 to n  do
   if z<>city1 then
     begin
       if z=city2 then  proc1:=true
       else
          begin {else}
          if proc1(n+1) then
             write(city2);
          end; {else}
     end;
 end;
(*--------------------------------------------------------*)

begin {of main body}
{  clrscr;}
  get_cities;
  write('enter 2 city : ');
  readln(city1,city2);
  b[1]:=city1;
  t:=1;
  f(city1,1);
{  show_matrix(n);     }
  readln;
end. {of main body}
(*------------------------------------*)

---------------------------------------------------------------------------------------------

سلام

این برنامه یه پولیو از ورودی میگیره و میگه چن تا سکه ۱۰ تومنی ۵ تومنی ۲ تومنی و ۱ تومنی میشه

البته میگه طرف پولداره یا نه

program coin ;{--- www.ukcs86.zet.ir ---}
uses crt;
var n,s,c10,c5,c2,c1:integer;
     {--- www.ukcs86.zet.ir ---}
procedure go (n :integer);
begin
  s:= n mod 10 ; {if number is less than 10 this line become useful}
  if n div 10 >0 then
    begin
      c10:= n div 10 ;
      s:=n mod 10 ;
    end;
  if s div 5 >0 then
    begin
      c5:= s div 5 ;
      s:=s mod 5 ;
    end;
  if s div 2 > 0 then
    begin
      c2:= s div 2 ;
      s:=s mod 2 ;
    end;
  c1:= s div 1 ;
end; {of procedure}
     {--- www.ukcs86.zet.ir ---}
procedure show ;
begin
   writeln(n,' money is : ');
   writeln(c10,' of 10 coin');
   writeln(c5,' of 5 coin');
   writeln(c2,' of 2 coin');
   writeln(c1,' of 1 coin');
end;
     {--- www.ukcs86.zet.ir ---}
procedure rich ;
begin
  if c10>100 then
    writeln('you"ve got a lot of money man. you"r rich')
  else if c10<1 then
    writeln('hey man you"re so poor. do somthing. come on')
  else writeln('humm enought money. you should try harder. Got that?');
end;
begin
  clrscr;
  write('please enter your money : ');
  readln(n);
  go(n);
  show;
  rich;
  readln;
end.  {--- codes by sajjadG ---}
(* you can cwrite this program without procedures but it help
   you to get used to them and it's come useful then *)

موفق باشین.

سلام
امروز روز امتحانه بعید میدونم کسی بیاد تو وبلاگ ولی بازم یه برنامه ی جدید داریم
این برنامه یه مبنا رو از ورودی میگیره و بعدش تا زمانی که کاربر عددی خارج از محدوده ی مبنا وارد نکنه از کاربر عدد میگیره
(تمرین 20 صفحه ی 222 کتاب پاسکال خانم بهادری)

program base22 ;  {---- www.ukcs86.zet.ir ----}
uses crt; {use wincrt in windows mode}
var base:integer;
    num :char;
   {---- www.ukcs86.zet.ir ----}
procedure get_base (var base:integer);
begin
   repeat
     writeln('please enter the correct base less than 16 and more than 1 : ');
     readln(base);
   until (base>1) and (base<17)    ;
end;{of procedure}
   {---- www.ukcs86.zet.ir ----}
procedure get_num ;
begin
  write('enter a number : ');
  readln(num);
end;
   {---- www.ukcs86.zet.ir ----}
function in_range :boolean;
begin
  if base < 11 then
    begin
      if ( ord(num)-47 >base) or (ord(num)< 48) then
        in_range:=false;
    end
  else
   if base = 11 then
     if (ord(num)<48) or( ord(num)>97)    then
       in_range:=false;

   if base = 12 then
     if (ord(num)<48) or( ord(num)>98)    then
       in_range:=false;

   if base = 13 then
     if (ord(num)<48) or( ord(num)>99)    then
       in_range:=false;

   if base = 14 then
     if (ord(num)<48) or( ord(num)>100)    then
       in_range:=false;

   if base = 15 then
     if (ord(num)<48) or( ord(num)>101)    then
       in_range:=false;

   if base = 16 then
     if (ord(num)<48) or( ord(num)>102)    then
       in_range:=false;
{writeln(ord(num), ' ' ,ord(base));}
end;{of function}
   {---- www.ukcs86.zet.ir ----}
begin
 clrscr;
  get_base(base);
  repeat
     get_num;
  until  not in_range ;
  writeln(num,' is an out of range number .');
  readln;
end.{---- codes by sajjadG ----}

موفق باشید.

سلام

این برنامه رو آقا وحید خواستن ما هم براشون نوشتیم.امیدوارم که براتون جالب باشه.

program odd_finder_by_sajjadG ;{www.ukcs86.zet.ir}
var i,n1,n2,temp : integer;
function is_odd(i:integer):boolean;
  begin
    if odd(i) then
      is_odd:=true
    else
      is_odd:=false;
  end;
begin{www.ukcs86.zet.ir}
  write('enter 2 number please : ');
  readln(n1,n2);
  if n1<n2 then
    begin
      temp:=n1;
      n1:=n2;
      n2:=temp;
    end;
  for i:= n2 to n1-1 do
       if is_odd(i) then
         writeln(i);
  readln;
end. {www.ukcs86.zet.ir}

موفق باشید.

سلام

بلاخره نوشتم . امیدوارم دیر نشده باشه

program base16 ;{www.ukcs86.zet.ir}
uses wincrt;
const base =2;
var a:array[1..50] of char ;
i,j,n:integer;
ch:char;
{-----------function--www.ukcs86.zet.ir----}

procedure proc2 (s:integer);
  var num,num1,num2,counter,num3 : integer;
begin {www.ukcs86.blogpars.com}
 counter:=1;
 num1:=0; num2:=0; num3:=0;
 num:=s; {writeln('num = ',num);}
 repeat
     num1:=num div base ;
     num2:=num mod base ;
     num3:=(num3) +(num2 * counter);
     counter:=counter*10;
     num:=num1;
  until   num1+base <= base;
  case s of
    1    : write('000');
    2,3  : write('00');
    4,5,6,7 :write('0');
  end;
 write(num3);
end;

{------------procedure---www.ukcs86.zet.ir----}
procedure proc ;
 var g,f:integer;
 begin
 write('your number in base 2 is : ');
  for g:=1 to j do
   begin
      f:= ord(a[g]) - 48 ;
      case a[g] of
        '1'..'9': proc2(f);
        'a'  : proc2(10);
        'b'  : proc2(11);
        'c'  : proc2(12);
        'd'  : proc2(13);
        'e'  : proc2(14);
        'f'  : proc2(15);
      end; {of case}
   end;{of for}
 end;{of function}
{--------------main prog-------------------}
begin {of main program}
  i:=1;J:=0;  ch:='a';
  writeln('enter a number in base 16 and put z in end of that : ');
  while ch<>'z' do
    begin
       read(ch);
       if ch<>'0' then
         begin
            a[i]:=ch;
            i:=i+1;
            j:=J+1;
         end;
    end;
proc;
writeln;
writeln('your not sure ?!? but I am (sajjadG)');
end.{www.ukcs86.zet.ir}

اگه تلاش کنید ساده ترم میشه نوشت

موفق باشین.از امتحانم نترسین ساده اس پروژه اینو جبران میکنه.

سلام

برنامه ی پایین کد اصلی کلید های کیبرد رو نشون میده

 این procedure-function همیشه هم بدرد نمی خورن مثلآ تو برنامه ی زیر کارو طولانی تر کردن ولی باید یادشون بگیریم چون تو برنامه های بزرگتر خیلی مفیدن. این برنامه رو اول بدون procedure-function نوشتم بعد واسه تمرین باprocedure-function هم نوشتم . هر ۲ تاش یه کارو انجام میدن .

program code_finder;{www.ukcs86.zet.ir}
uses crt;{www.ukcs86.zet.ir}
var i, j:integer;
    c,c2:char;

{-----------procedure exitkey------------}
procedure exitkey ;
var  c:char;
  begin {of proc exitkey}
    clrscr;{www.ukcs86.zet.ir}
    write('enter a key : ');
    readln(c2);
    writeln('enter ',c2,' key again to exit');
  end; {of proc exitkey}

 {------------function proc---------------}
function proc (var c:char; i:integer):integer;
 begin {of function proc}
    i:=ord(c);
    proc:=i;{www.ukcs86.zet.ir}
 end; {of function proc}

 {----------procedure writecode------------}
procedure writecode ;
  begin
    writeln('code of ' ,c,' is : ',proc(c,i));
  end;
{----------------main program--------------}
begin {of main program}
  exitkey;
  c:= readkey;
  while c<>c2 do
    begin{www.ukcs86.zet.ir}
      c:= readkey;
      writecode;
    end;
end. {of main program}

{---------------------------------------------}

 {*other source without procedure & function*}

{begin
   clrscr;
   write('enter a key : ');
   readln(c2);
   writeln('enter ',c2,' key again to exit');
   c:= readkey;
   while c<>c2 do
     begin (*www.ukcs86.zet.ir*)
       c:= readkey;
       i:=ord(c);
       writeln('code of ' ,c,' is : ',i);
     end;
end.}{www.ukcs86.zet.ir}

از برنامه نویسی لذت ببرین.

سلام

اینم یه تیکه برنامه که کمک می کنه بازیه مارو بهتر بفهمین.(procedure segmento) رو ببینید متوجه میشید.

program graph_test_by_sajjadG{www.ukcs86.zet.ir} ;
uses graph;
var a,b :integer;

begin {www.ukcs86.zet.ir}
  initgraph(a,b,'c:bgi');
 {pusheye BGI ra be drive C copy konid}
      {www.ukcs86.zet.ir}
  rectangle(10,10,40,40);
  setfillstyle(1,1);
  bar(11,11,39,39);
      {www.ukcs86.zet.ir}
  rectangle(45,45,90,90);
  setfillstyle(2,2);
  bar(47,47,88,88);
      {www.ukcs86.zet.ir}
  rectangle(100,100,200,200);
  setfillstyle(8,7);
  bar(102,102,198,198);
      {www.ukcs86.zet.ir}
  rectangle(220,220,250,250);
  setfillstyle(10,10);
  bar(222,222,248,248);
      {www.ukcs86.zet.ir}
  rectangle(300,300,450,450);
  setfillstyle(7,11);
  bar(301,301,448,448);
      {www.ukcs86.zet.ir}
  readln;
  closegraph;
end.  www.ukcs86.zet.ir

موفق باشید.

سلام

بازی بازم تغییر کرد ولی خیلی نه.  اگه ریز بین باشین تفاوت هارو احساس میکنید.

program snake_game_with_comments_by_sajjadG; (* email address: sajjadgerami2003@yahoo.com *)
                {www.ukcs86.zet.ir}
uses crt,graph;

const passo=19;

var coor:array[1..800,1..2]of integer; { for snake length}
    n:array[1..13]of char; { for logo procedure}
    cont,driver,mode,i,j,x,y,xc,yc,totale,ultx,ulty,punteggio,primato,vel  :  integer;
    a,direzione,risp,tasto  : char ;
    oldscore,score,s  : string;
    occupato,infrociamento,mangia  : boolean;

  procedure logo ;
  var  n:array[1..13]of char;
   begin
      initgraph (driver,mode,'c:\progra~1\tp\bgi');
      cleardevice;
    (*-----------top texts---------------*)
      setbkcolor(red);
      setcolor(10);
      settextstyle(4,0,100);
      outtextxy(170,-3,'salam');
      settextstyle(1,0,3);
      setcolor(11);
      outtextxy(140,140,'programer');
      setcolor(3);
      settextstyle(2,0,4);
      outtextxy(300,370,'Keys:');
      outtextxy(280,390,'Numpad 8-up');
      outtextxy(280,400,'Numpad 2-down');
      outtextxy(280,410,'Numpad 4-left');
      outtextxy(280,420,'Numpad 6-right');
      outtextxy(250,455,'press a key to start the game');
  (*----------snake pic----------------*)

      rectangle(10,250,230,440);
      bar(20,290,210,300);
      bar(20,290,30,400);
      bar(20,400,60,410);
      bar(220,290,210,340);
      setcolor(white);
      circle(100,407,5);

  (*-----------sound------------------*)
      delay(50);
      sound(100);
      delay(500);
      sound(200);
      delay(300);
      sound(300);
      delay(500);
      sound(200);
      delay(300);
      sound(600);
      delay(600);
      nosound;
      delay(500);
  (*------------------------------*)
      n[1]:='s';
      n[2]:='a';
      n[3]:='j';
      n[4]:='j';
      n[5]:='a';
      n[6]:='d';
      n[7]:=' ' ;
      n[8]:='g';
      n[9]:='e';
      n[10]:='r';
      n[11]:='a';
      n[12]:='m';
      n[13]:='i';
      s:='sajjad gerami';
      repeat
         if not keypressed then
           begin
             for i:=1 to 13 do
                begin
                   for x:=637 downto 265+i*8  do
                       begin
                           if not keypressed then
                             begin
                                settextstyle(2,0,6);
                                outtextxy(x,140,n[i]);
                                delay(1);
                                setcolor(black);
                                outtextxy(x,140,n[i]);
                                setcolor(white);
                             end;
                       end;
                   if not keypressed then
                       outtextxy(265+i*8 ,170,n[i])
                end;
      if not keypressed then
                delay(500);
             if not keypressed then
               begin
                 for j:=333 downto 2 do
                   begin
                      if not keypressed then
                         begin
                           outtextxy(j,170,s);
                           setcolor(red);
                           outtextxy(j,170,s);
                           setcolor(yellow);
                         end;
                   end;
               end;
           end;
       delay(00);
      until keypressed;

   end;

procedure kadr;
  begin
    rectangle(8,8,(passo*30)-8,(passo*24)-8);
    outtextxy(580,80,'Score:')
  end;
  {------------------------------}
procedure segmento(x,y:integer);
 var dd:integer;
  begin
    randomize;
    dd:=random(15);
    setcolor(dd);{range dore snake}
    rectangle(x-9,y-9,x+9,y+9);
    setfillstyle(12,white);
    bar(x-8,y-8,x+8,y+8);
    setcolor(white)
  end;
  {------------------------------}
procedure cancsegm(x,y:integer);
  begin
    setfillstyle(1,black);
    bar(x-9,y-9,x+9,y+9);
    setfillstyle(1,white)
  end;
  {------------------------------}
procedure gerdi(x,y:integer);
  begin
    x:=x*passo;
    y:=y*passo;
    setfillstyle(1,blue);{taghire rage snake hengame barkhord}
    circle(x,y,8);

  end;
  {------------------------------}
procedure end_sound;
 var i:integer;
  begin
    for i:=1 to 30000 do
      sound(100);
      nosound;
  end;
  {------------------------------}
procedure score_sound;
 var i:integer;
  begin
    for i:=1 to 5000 do
      sound(1100);
      nosound;
  end;
  {------------------------------}
function punti(x:integer):string;
 var
  s:string[10];
begin
  str(x,s);{ in tabe integer ra be string tabdil mikonad}
  punti:=s;
end;
  {---------------base procedure-----------------}
procedure base_procedure;
  begin
    cleardevice;
    kadr;
    punteggio:=0;
    oldscore:=punti(punteggio);
    score:=oldscore;
    x:=passo*15;
 y:=passo*23;
    direzione:='6';
    tasto:='6';
    totale:=8;
    infrociamento:=false;
    mangia:=false;
    coor[1,1]:=x;
 coor[1,2]:=y;
    occupato:=false;
    for i:=2 to totale do
        begin
           coor[i,1]:=coor[i-1,1]-passo;
     coor[i,2]:=y
        end;
    xc:=15;yc:=12;
    gerdi(xc,yc);
    repeat
            setcolor(black);
            outtextxy(580,100,oldscore);
            setcolor(white);
            outtextxy(580,100,score);
            for i:=1 to totale do
                 segmento(coor[i,1],coor[i,2]);
            delay(170);
            cancsegm(coor[totale,1],coor[totale,2]);
            delay(70);
            if (x=xc*passo) and (y=yc*passo) then { sharte barkhord}
     mangia:=true;

            if mangia then
                  begin
                       punteggio:=punteggio+9; { adding score}
                       score:=punti(punteggio);
                       oldscore:=punti(punteggio-9);
                       totale:=totale+1; {add shodan mar}
                       coor[totale,1]:=ultx;
        coor[totale,2]:=ulty;
                       score_sound;
                       repeat
                           occupato:=false;
                           xc:=random(29)+1;{ mokhtasate x gerdie jadid}
         yc:=random(23)+1; { mokhtasate y gerdie jadid}
                           for i:=1 to totale do
{ in shart chek mikonad ke aya gerdi roye mar ast ya na}if (coor[i,1]=xc*passo)and(coor[i,2]=yc*passo)then
                                   occupato:=true;
                       until not occupato;
                       gerdi(xc,yc);
                       mangia:=false;
                  end;
            if keypressed then tasto:=readkey;
            case tasto of
                  '8':if direzione<>'5' then direzione:='8';
                  '2':if direzione<>'8' then direzione:='5';
                  '6':if direzione<>'4' then direzione:='6';
                  '4':if direzione<>'6' then direzione:='4'
            end;
            case direzione of
                     '8': y:=y-passo;
                     '5': y:=y+passo;
                     '6': x:=x+passo;
                     '4': x:=x-passo
            end;
            ultx:=coor[totale,1];
   ulty:=coor[totale,2];
            for i:=totale downto 2 do
                begin
                   coor[i,1]:=coor[i-1,1];
                   coor[i,2]:=coor[i-1,2];
                end;
            coor[1,1]:=x;
   coor[1,2]:=y;
            for i:=2 to totale do
               begin
                   if (coor[i,1]=x) and (coor[i,2]=y) then
                      infrociamento:=true
               end;
    until (x-passo<0)or(y-passo<0)or(x+passo=passo*31)or(y+passo=passo*25)or infrociamento;
    end_sound;
  end;

    {-----------main program--------------}
begin (*main program.*)
 logo;
    textcolor(black);
    setbkcolor(9);
    repeat
      base_procedure;
      cleardevice;
      outtextxy(280,240,'Score :  ');
      outtextxy(350,240,punti(punteggio));
      readln;
      outtextxy(265,270,'New game?(Y/N)');
      risp:=readkey
    until (risp='n') or (risp='N')
end.{www.ukcs86.zet.ir}

موفق باشید.

سلام

اینم بازی مار با آخرین تغییرات تا این لحظه قشنگتر شده سرعتشم رفته بالا

program snake_game_with_comments_by_sajjadG; (* email address: sajjadgerami2003@yahoo.com *)
                {www.ukcs86.zet.ir}
uses crt,graph;

const passo=19;

var coor:array[1..800,1..2]of integer; { for snake length}
    n:array[1..13]of char; { for logo procedure}
    cont,driver,mode,i,j,x,y,xc,yc,totale,ultx,ulty,punteggio,primato,vel  :  integer;
    a,direzione,risp,tasto  : char ;
    oldscore,score,s  : string;
    occupato,infrociamento,mangia  : boolean;

  procedure logo ;
  var  n:array[1..13]of char;
   begin
      initgraph (driver,mode,'c:\bgi');
      cleardevice;
    (*-----------top texts---------------*)
      setbkcolor(red);
      setcolor(10);
      settextstyle(4,0,100);
      outtextxy(170,-3,'salam');
      settextstyle(1,0,3);
      setcolor(11);
      outtextxy(140,140,'programer');
      setcolor(3);
      settextstyle(2,0,4);
      outtextxy(300,370,'Keys:');
      outtextxy(280,390,'Numpad 8-up');
      outtextxy(280,400,'Numpad 2-down');
      outtextxy(280,410,'Numpad 4-left');
      outtextxy(280,420,'Numpad 6-right');
      outtextxy(250,455,'press s to start the game');
  (*----------snake pic----------------*)

      rectangle(10,250,230,440);
      bar(20,290,210,300);
      bar(20,290,30,400);
      bar(20,400,60,410);
      bar(220,290,210,340);
      setcolor(white);
      circle(100,407,5);

  (*-----------sound------------------*)
      delay(50);
      sound(100);
      delay(500);
      sound(200);
      delay(300);
      sound(300);
      delay(500);
      sound(200);
      delay(300);
      sound(600);
      delay(600);
      nosound;
      delay(500);
  (*------------------------------*)
      n[1]:='s';
      n[2]:='a';
      n[3]:='j';
      n[4]:='j';
      n[5]:='a';
      n[6]:='d';
      n[7]:=' ' ;
      n[8]:='g';
      n[9]:='e';
      n[10]:='r';
      n[11]:='a';
      n[12]:='m';
      n[13]:='i';
      s:='sajjad gerami';
      repeat
         if not keypressed then
           begin
             for i:=1 to 13 do
                begin
                   for x:=637 downto 265+i*8  do
                       begin
                           if not keypressed then
                             begin
                                settextstyle(2,0,6);
                                outtextxy(x,140,n[i]);
                                delay(1);
                                setcolor(black);
                                outtextxy(x,140,n[i]);
                                setcolor(white);
                             end;
                       end;
                   if not keypressed then
                       outtextxy(265+i*8 ,170,n[i])
                end;
      if not keypressed then
                delay(500);
             if not keypressed then
               begin
                 for j:=333 downto 2 do
                   begin
                      if not keypressed then
                         begin
                           outtextxy(j,170,s);
                           setcolor(red);
                           outtextxy(j,170,s);
                           setcolor(yellow);
                         end;
                   end;
               end;
           end;
       delay(00);
      until keypressed;

   end;

procedure kadr;
  begin
    rectangle(8,8,(passo*30)-8,(passo*24)-8);
    outtextxy(580,80,'Score:')
  end;
  {------------------------------}
procedure segmento(x,y:integer);
 var dd:integer;
  begin
    randomize;
    dd:=random(15);
    setcolor(dd);
    rectangle(x-9,y-9,x+9,y+9);
    setfillstyle(12,white);
    bar(x-8,y-8,x+8,y+8);
    setcolor(white)
  end;
  {------------------------------}
procedure cancsegm(x,y:integer);
  begin
    setfillstyle(1,black);
    bar(x-9,y-9,x+9,y+9);
    setfillstyle(1,white)
  end;
  {------------------------------}
procedure gerdi(x,y:integer);
  begin
    x:=x*passo;
    y:=y*passo;
    circle(x,y,9)
  end;
  {------------------------------}
procedure end_sound;
 var i:integer;
  begin
    for i:=1 to 30000 do
      sound(100);
      nosound;
  end;
  {------------------------------}
procedure score_sound;
 var i:integer;
  begin
    for i:=1 to 5000 do
      sound(1100);
      nosound;
  end;
  {------------------------------}
function punti(x:integer):string;
 var
  s:string[10];
begin
  str(x,s);{ in tabe integer ra be string tabdil mikonad}
  punti:=s;
end;
  {---------------base procedure-----------------}
procedure base_procedure;
  begin
    cleardevice;
    kadr;
    punteggio:=0;
    oldscore:=punti(punteggio);
    score:=oldscore;
    x:=passo*15;
 y:=passo*23;
    direzione:='6';
    tasto:='6';
    totale:=8;
    infrociamento:=false;
    mangia:=false;
    coor[1,1]:=x;
 coor[1,2]:=y;
    occupato:=false;
    for i:=2 to totale do
        begin
           coor[i,1]:=coor[i-1,1]-passo;
     coor[i,2]:=y
        end;
    xc:=15;yc:=12;
    gerdi(xc,yc);
    repeat
            setcolor(black);
            outtextxy(580,100,oldscore);
            setcolor(white);
            outtextxy(580,100,score);
            for i:=1 to totale do
                 segmento(coor[i,1],coor[i,2]);
            delay(170);
            cancsegm(coor[totale,1],coor[totale,2]);
            delay(70);
            if (x=xc*passo) and (y=yc*passo) then { sharte barkhord}
     mangia:=true;

            if mangia then
                  begin
                       punteggio:=punteggio+9; { adding score}
                       score:=punti(punteggio);
                       oldscore:=punti(punteggio-9);
                       totale:=totale+1; {add shodan mar}
                       coor[totale,1]:=ultx;
        coor[totale,2]:=ulty;
                       score_sound;
                       repeat
                           occupato:=false;
                           xc:=random(29)+1;{ mokhtasate x gerdie jadid}
         yc:=random(23)+1; { mokhtasate y gerdie jadid}
                           for i:=1 to totale do
{ in shart chek mikonad ke aya gerdi roye mar ast ya na}if (coor[i,1]=xc*passo)and(coor[i,2]=yc*passo)then
                                   occupato:=true;
                       until not occupato;
                       gerdi(xc,yc);
                       mangia:=false;
                  end;
            if keypressed then tasto:=readkey;
            case tasto of
                  '8':if direzione<>'5' then direzione:='8';
                  '2':if direzione<>'8' then direzione:='5';
                  '6':if direzione<>'4' then direzione:='6';
                  '4':if direzione<>'6' then direzione:='4'
            end;
            case direzione of
                     '8': y:=y-passo;
                     '5': y:=y+passo;
                     '6': x:=x+passo;
                     '4': x:=x-passo
            end;
            ultx:=coor[totale,1];
   ulty:=coor[totale,2];
            for i:=totale downto 2 do
                begin
                   coor[i,1]:=coor[i-1,1];
                   coor[i,2]:=coor[i-1,2];
                end;
            coor[1,1]:=x;
   coor[1,2]:=y;
            for i:=2 to totale do
               begin
                   if (coor[i,1]=x) and (coor[i,2]=y) then
                      infrociamento:=true
               end;
    until (x-passo<0)or(y-passo<0)or(x+passo=passo*31)or(y+passo=passo*25)or infrociamento;
    end_sound;
  end;

    {-----------main program--------------}
begin (*main program.*)
 logo;
    textcolor(black);
    repeat
      base_procedure;
      cleardevice;
      outtextxy(280,240,'Score :  ');
      outtextxy(350,240,punti(punteggio));
      readln;
      outtextxy(265,270,'New game?(Y/N)');
      risp:=readkey
    until (risp='n') or (risp='N')
end.{www.ukcs86.zet.ir}

منتظر بعدیم باشین.

سلام

برای بازی سنیک (snake)یه لوگو ساختم که گفتم شاید سرسش برای ساختن لوگوی خودتون بهتون ایده بده .احتمالآ بازیو هم مینویسم پس این مثل یه مقدمس منتظر بعدیشم باشین .اگه بخاین خوب برنامه رو بفهمین بهتره قسمت به قسمت و کم کم اونو تحلیل کنید.

program snake_game_sajjadG ;{www.ukcs86.zet.ir}
uses dos,crt,graph ;
var
  i,j,x,y,driver,mode:integer;
  ch:char;
  b:boolean;
  s:string;
  h,m,s1,s2 :word;

(*-----------begin of logo procedure-----------------------*)
  procedure logo ;
  var  n:array[1..13]of char;
   begin{www.ukcs86.zet.ir}
    (*-----------top texts---------------*)
      setbkcolor(red);
      setcolor(10);
      settextstyle(4,0,100);
      outtextxy(170,-3,'salam');
      settextstyle(1,0,3);
      setcolor(11);
      outtextxy(140,140,'programer');
      setcolor(3);
      settextstyle(2,0,4);
      outtextxy(300,370,'Keys:');
      outtextxy(280,390,'Numpad 8-up');
      outtextxy(280,400,'Numpad 2-down');
      outtextxy(280,410,'Numpad 4-left');
      outtextxy(280,420,'Numpad 6-right');
      outtextxy(250,455,'press a key to start the game');

   (*----------snake pic----------------*)
      rectangle(10,250,230,440);
      bar(20,290,210,300);
      bar(20,290,30,400);
      bar(20,400,60,410);
      bar(220,290,210,340);
      setcolor(white);
      circle(100,407,5);

   (*----------time&date---------------*)

   { gettime(h,m,s1,s2);
          moveto(200,200);
           write(h,m,s1,s2);}

   (*-----------sound------------------*)
         delay(50);
           sound(100);
           delay(500);
            sound(200);
             delay(300);
            sound(300);
             delay(500);
           sound(200);
           delay(300);
            sound(600);
            delay(600);
            nosound;
            delay(500); 
    (*------------------------------*)
      n[1]:='s';
      n[2]:='a';
      n[3]:='j';
      n[4]:='j';
      n[5]:='a';
      n[6]:='d';
      n[7]:=' ' ;
      n[8]:='g';
      n[9]:='e';
      n[10]:='r';
      n[11]:='a';
      n[12]:='m';
      n[13]:='i';
      s:='sajjad gerami';
      repeat
         if not keypressed then
           begin
             for i:=1 to 13 do
                begin
                   for x:=637 downto 265+i*8  do
                       begin
                           if not keypressed then
                             begin
                                settextstyle(2,0,6);
                                outtextxy(x,140,n[i]);
                                delay(1);
                                setcolor(black);
                                outtextxy(x,140,n[i]);
                                setcolor(white);
                             end;
                       end;
                   if not keypressed then
                       outtextxy(265+i*8 ,170,n[i])
                end;
          if not keypressed then
                delay(500);
             if not keypressed then
               begin
                 for j:=333 downto 2 do
                   begin
                      if not keypressed then
                         begin
                           outtextxy(j,170,s);
                           setcolor(red);
                           outtextxy(j,170,s);
                           setcolor(yellow);
                         end;
                   end;
               end;
          end;
       delay(00);{www.ukcs86.zet.ir}
      until keypressed;
 end;

(*-----------end of logo procedure-----------------------*)

  {www.ukcs86.zet.ir}
begin{main prog}
 initgraph (driver,mode,'c:\bgi');
 cleardevice;
 logo;

 readln;
 closegraph;
{www.ukcs86.zet.ir}

end.{main prog}{www.ukcs86.zet.ir}

با نظر دادنتون به پیشرفت وبلاگ کمک کنید.

موفق باشین.

سلام

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

program test ;{www.ukcs86.zet.ir} 

 uses wincrt;
 var
   d , m , y   : integer ;
   b : boolean ;
begin {of main program }
    repeat    
      b := true;
      write(' please enter todays date:' ) ;
      read( d, m,y ) ;
      if(m>6)and (d=31)then
          b:=false;
    until ( m > 0) and ( m<13 ) and ( d>0 ) and ( d<32 ) and (b <>false ) ;
  if d=31 then
        begin{www.ukcs86.zet.ir} 
          d:=1 ;
          b:=false;
          m :=m+1 ;
        end;
     {d := d +1 ; }
 if (d=30) and (m >6) and (m<12) then
        begin
          d:=1;
          m := m+1 ;
          b:=false;
        end;
  if (m=12) and (d>28) then
    begin
          d:= 1 ;
          m:= 1;  
          b:=false;
          y:= y +1 ;
    end;
  if(d <30 ) and b=true then
       d:=d+1;
 write ('todays date is : ');
  write(d,' ',m,' ',y   );
 end.{www.ukcs86.zet.ir} 

موفق باشید.

سلام

امروز با جمعی از همکلاسی ها رفتیم سایت کامپیوتر و یه برنامه ی ساده رو با روشهای مختلف نوشتیم

برنامه تعدادی عدد رو به انتخاب کاربر میگیره اگه زوج بود توان دوش و اگه فرد بود دو برابرشو چاپ میکنه.

{-------for----- email address: sajjadgerami2003@yahoo.com  --------}

{program practice1;
uses wincrt ;
var
  i,n,number :integer;
begin
  write ('how many number you wanna enter : ');
  readln(n);
  for i:= 1 to n do
    begin
      readln(number);
      if number mod 2 = 0 then
         writeln(number*number)
      else
         writeln(number*2);
    end;
end.}

{------while--------www.ukcs86.zet.ir---------}

{program practic2 ;
uses wincrt;
var number,n , count :integer;
begin
   count:=0;
   read(n);
   while n > count do
    begin
      readln(number);
      if number mod 2 = 0 then
         writeln(number*number)
      else
         writeln(number*2);
      count:=count+1;
    end;
end.}

{-----function-----------www.ukcs86.zet.ir----}

(*
program practice3;
uses wincrt;
var
   i,N, number:integer;
function f (n:integer):integer;
   begin
     for i:=1 to n do
      begin
        if number mod 2=0 then
           f := number *number
        else
           f := number*2;
      end;
   end;

begin {of main program}
  read(n);
  for i:=1 to n do
   begin
     readln(number);
     writeln(f(number));
   end;
end. *)

{-------function------www.ukcs86.zet.ir------}

{*program practice4;
uses wincrt;
TYPE
   AA = array[1..200] of integer;
var
   a:aa;
   b:aa;
   i,N, number:integer;
function f (a:aa):integer;
   begin
     for i:=1 to n do
      begin
        if a[i] mod 2=0 then
           b[i] := a[i] *a[i]
        else
           b[i] := a[i]*2;
      end;
   end;

begin {of main program
  read(n);
  for i:=1 to n do
    begin
      read(number);
      A[I]:=number;
    end;
  f(a);
  for i := 1 to n do
     writeln(b[i]);
end. *)

(*------procedure---------www.ukcs86.zet.ir-----*)

{program practice5;
uses crt;
TYPE
   AA = array[1..200] of integer;
var
   a:aa;
   b:aa;
   i,N, number:integer;
procedure f (a:aa);
   begin
     for i:=1 to n do
      begin
        if a[i] mod 2=0 then
           b[i] := a[i] *a[i]
        else
           b[i] := a[i]*2;
      end;
   end;
begin {of main program
  read(n);
  for i:=1 to n do
    begin
      read(number);
      A[I]:=number;
    end;
  f(a);
  for i := 1 to n do
     writeln(b[i]);
end.}

{-----procedure-------www.ukcs86.zet.ir--------}

program practice6;
uses crt;
TYPE
   AA = array[1..200] of integer;
var
   a:aa;
   b:aa;
   i,N, number:integer;
   procedure f (a:aa);
   begin
     for i:=1 to n do
      begin
        if a[i] mod 2=0 then
           b[i] := a[i] *a[i]
        else
           b[i] := a[i]*2;
      end;
   end;
  procedure ne ;
  begin
    read(n);
     for i:=1 to n do
      begin
       read(number);
       A[I]:=number;
      end;
  end;
 procedure s ;
    begin
     for i := 1 to n do
       writeln(b[i]);
    end;
begin {of main program}
  ne;
  f(a);
  s;
end. }

امیدوارم که با تحلیل این سرس مشکلاتون حل بشه

موفق باشید.

سلام

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

سلام

این یه سرس از بازیه ماره که بدون پردازه ها و توابع نوشته شده.

این سرس به دلیل استفاده از یونیت گراف در پاسکال ویندوز کار نمیکند.

uses crt,graph;
var a,b,bb,x,y,i,jx,jy:integer;
    xx,yy:array[1..1000] of integer;
    c:char;
    n:boolean;
begin
     initgraph(a,b,'c:\bgi');
     randomize;
     a:=1;
     i:=1;
     n:=false;
     x:=100;
     y:=240;
     rectangle(0,0,639,479);

     repeat
        jx:=random(640);
        jy:=random(480);
        if getpixel(jx,jy)=0 then
          begin
            for i:=-3 to 3 do
              begin
                 putpixel(jx+i, jy, 14);
                 putpixel(jx,jy+i,14);
              end;
              a:=1;
          end
        else
        a:=0;
     until a=1;
      i:=1;
     repeat
        a:=a+1;
        if a=150*i+1 then a:=1;
        if n=false then x:=x+1;
        if ord(c)=72 then y:=y-1;
        if ord(c)=75 then x:=x-1;
        if ord(c)=77 then x:=x+1;
        if ord(c)=80 then y:=y+1;
        if getpixel(x,y)=15 then c:='x';
        if getpixel(x,y)=14 then
           begin
              for b:=y-10 to y+10 do
                 begin
                    for bb:=x-10 to x+10 do
                    if getpixel(bb,b)=14 then putpixel(bb,b,0);
                 end;
              repeat
                 jx:=random(640);
                 jy:=random(480);
                 if getpixel(jx,jy)=0 then
                    begin
                        for b:=-3 to 3 do
                           begin
                               putpixel(jx+b, jy, 14);
                               putpixel(jx,jy+b,14);
                           end;
                           b:=1;
                     end
                 else  b:=0;
              until b=1;
              i:=i+1;
           end;
        putpixel(x,y,15);
        delay(15);
        putpixel(xx[a],yy[a],0);
        xx[a]:=x;
        yy[a]:=y;
        if keypressed then n:=true;
        if keypressed then c:=readkey;
     until (c='x') or (i=10);
     if c='x' then
     begin
           settextstyle(1,0,8);
           setcolor(9);
           outtextxy(150,200,'THE END...');
        end;
     if i=10 then
     begin
           setcolor(10);
           settextstyle(3,0,8);
           outtextxy(150,200,'CONGRATS!');
        end;
     delay(500);
     readkey;

     closegraph;
end.
                                                               

این برنامه حدود ۷۰ خط میباشد

موفق باشید.
                                                               

سلام

فکر نمیکنم با یونیت graph زیاد کار کرده باشین. این برنامه به صورت فشرده کار با تعدادی از توابع این یونیت رو نشون میده.

تذکر مهم : این برنامه فقط روی پاسکال طرح داس اجرا میشه اونم اگه یونیت گراف داشته باشه.

program graph;{www.ukcs86.zet.ir}
uses crt, graph ;
var driver,mode:integer;
    x,y:integer;
begin
 initgraph (driver ,mode ,'c:\bgi');
 setbkcolor(12);
 setcolor(7);
 moveto(150,150);
 x:=getx;
 y:=gety;
 for x:=1 to getmaxx do
 putpixel(x,x,14);
 for y:= getmaxx to 1 do
 begin
   putpixel(x,x,14);
   writeln(x);
 end;{www.ukcs86.zet.ir}
 setcolor(14);
 rectangle(200,200,300,300);
 writeln(x,y);
 setcolor(1);
 line (200,200,250,150);
 line(300,200,250,150);
 circle(250,250,20);
 arc(200,200,150,300,50);
 ellipse(400,400,0,360,60,30);
 setfillstyle(xhatchfill,15);
fillellipse(500,150,50,90);

 readln(x);
 closegraph;
end.{www.ukcs86.zet.ir}

اگه بخاین با این یونیت آشنا بشین این سرسو حتمآ تحلیل کنید .

موفق باشین.

سلام

برنامه ی max heap رو بهینش کردین؟ سرسش این پایین هست اگه شما بتونید این سرس رو خوب تحلیل کنید میتونید به خودتون امیدوار باشین.

program max_heap ;   {www.ukcs86.zet.ir}
uses wincrt;
var
   n1,temp,j,i,n2:integer;
   b:boolean;
   a:array [1..50] of integer;
begin
 write('how many number you wanna enter : ');

 readln(n1);
  for i:=1 to n1 do
     begin
        readln(n2);
        a[i] := n2;
     end;
 {--------www.ukcs86.zet.ir--------------------------------- }
  b:=true;
  for i:= 1 to n1 do
   if b<> false then
   begin
     j:=i*2; temp:=(i*2)+1;

      if (a[i] < a[j]) or (a[i] < a[temp] )then
          b:=false
      else
        begin
          b:=true;
        end;
    end;

  if  b=true then writeln(' hey the number was max heap ')
    else if b=false  then          
         writeln('number was not max heap');

  {-------www.ukcs86.zet.ir----------------------------------}

 if b=true then
   begin
      i:=0; j:=0 ; temp:=0;
      write('enter a number to add to the number plz : ' );
      readln (n2);
      a[n1+1]:=n2;
                       for i:=1 to n1+1 do
                           writeln(a[i]);
                           writeln;

   {-------- raveshe ostad --------------------------}
    {  for i:=n1+1 downto 2 do
         begin
           j:=i div 2;
           if a[i] > a[j] then
             begin
                 temp:= a[i];
                 a[i] := a[j];
                 a[j] := temp ;
             end;
         end;    }
   {----------------- raveshe man ---------------------}
      i:= n1 +1 ;
      a[i] :=n2;
      repeat       
         j:=i div 2;
         if a[i] > a[j] then
              begin
                 temp:= a[i];
                 a[i] := a[j];
                 a[j] := temp ;
                 i:=i div 2;                   
              end;
      until j=1 ;
      
      for i:=1 to n1+1 do
        writeln(a[i]);
   end;

    
end.www.ukcs86.zet.ir

توجه کنید که این برنامه در حالت عادی فقط قسمتهای آبی کار میکنه و قسمت قرمز روشیه که استاد سر کلاس گفت .  روش استاد (قرمز) بهینه نیست ولی روش آبی که با حلقه ی repeat نوشته شده  بهینه شده

موفق باشین.

سلام

این برنامه هم برای آشنا شدن شما با کار با فایل هاست . خروجی این برنامه میتونه به عنوان برنامه ی ۱۲.کار با فایل استفاده بشه.

*در این برنامه از goto استفاده کردم که کار اشتباهی است و موجب کاهش خوانایی برنامه میشود*

ولی دونستنش خالی از لطف نیست

program filetrain ;{www.ukcs86.zet.ir}
uses wincrt;
label 200;
var
 name : string;
 ave:real;
 stno :integer;
 first:text     ;
begin {www.ukcs86.zet.ir}
  assign(first,'c:file۲.txt');
  rewrite(first);
  repeat
  200 :  write('enter first');
   readln(name);
    if length(name) >0 then
     begin
       write('enter average ,stno ');
       readln(ave,stno);
       writeln(first,ave:5:2,'',stno,'',name);
     end
    else goto 200;
  until length(name)=0 ;
  close(first);
end.{www.ukcs86.zet.ir}

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

موفق باشین.

سلام

این برنامه تعداد تکرار حروف a تا z  و علامت سوالو و ... رو میشمارد.

program xcounter ;{www.ukcs86.zet.ir}
var ch:char;
    inf:text;
    count1,count2,count3:integer;
begin
count1:=0;count2:=0;count3:=0;
assign (inf,'c:f.txt');
reset(inf);
while ch<>'`'  do
  begin{www.ukcs86.zet.ir}
    read(inf,ch);
    if (ch='0') or (ch='!') or (ch='?') then
      count1:= count1+1;
    if ch in ['a'..'z'] then
      count2:=count2+1;
    if (ch='') or (ch in ['0','!','?']) then
      count3:=count3+1;
  end;
 writeln(count1:3 , count2:3 , count3:3);
end.{www.ukcs86.zet.ir}

موفق باشید.

سلام

این برنامه یه سری علامت و بلنک و ... رو میشماره به سرسش توجه کنید.

program xcounter ;{www.ukcs86.zet.ir}
var ch:char;
    inf:text;
    count1,count2,count3:integer;
begin
count1:=0;count2:=0;count3:=0;
assign (inf,'c:f.txt');
reset(inf);
while ch<>'`'  do
  begin{www.ukcs86.zet.ir}
    read(inf,ch);
    if (ch='0') or (ch='!') or (ch='?') then
      count1:= count1+1;
    if ch in ['a'..'z'] then
      count2:=count2+1;
    if (ch='') or (ch in ['0','!','?']) then
      count3:=count3+1;
  end;
 writeln(count1:3 , count2:3 , count3:3);
end.{www.ukcs86.zet.ir}

این برنامه توسط استاد از کتاب خانم بهادری حل شده.

سلامت باشین.

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

assign(file1,'c:directory');

file1 متغیری از نوع text
و بین کوتیشن هم آدرس محلی فایل وجود دارد یا باید بوجود آید را تایپ کنید

دستوری که فایل را برای استفاده باز می کند reset میباشد
این دستور فایل را باز کرده و ما میتوانیم از اطلاعات قبلی آن استفاده کنیم
استفاده از این دستور وجود فایل در مسیر مورد نظر را ایجاب میکند
ازین دستور برای خواندن از فایل استفاده میشود

reset(file1);

دستور rewriteنیتز اندکی شبیه reset است با این تفاوت که این دستور فایل را ایجاد میکند
بنابراین برای استفاده از این دستور لازم نیست فایل موجود باشد . اگر هم فایل در مسیر مورد نظر باشد این دستور محتویات درون آن را پاک میکند

rewrite(file1);

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

append(file1);

برای اضافه کردن اطلاعت به آخر فایل متنی است

read(file1,ch);

 دستور خواندن از فایل است(load)
chمتغیری از نوع کاراکتر است

write (file1,sth1,'sth',...);

دستور نوشتن درون فایل (save)
sth1 اطلاعاتی است که باید در فایل ذخیره شوند

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

 close(file1);

 فایل را میبندیم.

موفق باشید.

با سلام

این برنامه نحوه ی کار با تابع length رو نشون میده . نکته ای که باید بهش توجه کنید اینه که این تابعع طول رشته رو میگیره و برای string کار میکنه نه برای integer و...

uses wincrt;{www.ukcs86.zet.ir}
var s:string;
    i:integer;
begin
   readln(s);
   i:=length(s);
   writeln(i);
end.{www.ukcs86.zet.ir}

موفق باشید.

سلام

داشتم تو سایتا میگشتم که یه مطلبه جالب در مورد DVD دیدم گفتم بزارمش تو وبلاگ خالی از لطف نیست . امیدوارم براتون مفید باشه.

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

موفق باشید.

سلام دوستان
اگه بخاین برنامه ی فال حافظ رو بنویسین ۵۰ بیت از شعرای حافظ رو لازم دارین.همش این پایین هست کپیش کنین.
برنامه ی فال حافظ هم این پایینه :

program faal_e_hafez ;{www.ukcs86.zet.ir}
uses wincrt;
var a:array[1..50] of string[150];
    f:text;
    i:integer;
    s1,s2:string;
begin{www.ukcs86.zet.ir}
assign(f,'c:h.txt');
reset(f);
write('enter your name : ');
readln (s1);
while not eof(f) do
  while not eoln(f) do
    for i:=1 to 50 do
      begin
        readln(f,s2);
        a[i]:=s2 ;
      end;
randomize;
i:=random(50)+1;
writeln(s1,' your faal is : ');
writeln(a[i]);
gotoxy(2,10);
write('you may see some ... instead of some words ');
writeln('it is because pascal isnt compatible with farsi language.');
write('you can see the poem in the file and this -',i,'- is the line number.');
close(f);
end{www.ukcs86.zet.ir}.

این برنامه پایین هم شعر هاس که باید کپی کنین تو notepad و با اسم h.txt (به خط 8 توجه کنید) در درایو c ذخیرش کنید.

نديدم خوشتر از شعر تو حافظ * به قرآنى كه اندر سينه داري
اگر آن ترک شيرازي بدست‌آرد دل مارا * به خال هندويش بخشم سمرقند و بخارا را
گر از اين مـنزل ويران بـه سوي خانـه روم * دگر آن جا کـه روم عاقـل و فرزانـه روم
زين سـفر گر به سلامت به وطـن بازرسـم * نذر کردم کـه هـم از راه بـه ميخانـه روم
تا بگويم که چه کشفم شد از اين سير و سلوک * بـه در صومـعـه با بربـط و پيمانـه روم
آشـنايان ره عـشـق گرم خون بـخورند * ناکـسـم گر بـه شکايت سوي بيگانه روم
بـعد از اين دست من و زلف چو زنـجير نـگار* *چـند و چـند از پي کام دل ديوانـه روم
گر بـبينـم خـم ابروي چو مـحرابـش باز * سـجده شـکر کـنـم و از پي شکرانه روم
خرم آن دم کـه چو حافـظ بـه تولاي وزير * سرخوش از ميکده با دوست به کاشانـه روم
اگرچه باده فرح‌بخش و باد گل‌بيزست * به بانگ چنگ مخور مى، كه محتسب تيز است
در آستين مرقع پياله پنهان کن * که همچو چشم صراحي، زمانه خونريز است
به آب ديده بشوييم خرقه‌ها از مي * که موسم ورع و روزگار پرهيز است
گفتم غم تو دارم، گفتا غمت سرآيد * گفتم که ماه من شو، گفتا اگر برآيد
گفتم ز مهرورزان رسم وفا بياموز * گفتا ز خوبرويان اين کار کمتر آيد
گفتم که برخيالت راه نظر ببندم * گفتا که شبروست او، از راه ديگر آيد
گفتم که بوي زلفت گمراه عالـمم کرد * گفتا اگر بداني هم‌اوت آيد
گفتم خوشا هوايي کز باد صبح خيزد * گفتا خنک نسيمي کز کوي دلبر آيد
گفتم که نوش لعلت ما را به آرزو کشت * گفتا تو بندگي کن، کو بنده‌پرور آمد
گفتم دل رحيمت کي عزم صلح دارد * گفتا مگوي با تا وقت آن درآيد
گفتم زمان ع ديدي که چون سرآمد؟ * گفتا خموش حافظ کاين قصه هم سرآيد
دلبرم شاهد و طفل است و به بازي روزي * بكشد زارم و در شرع نباشد گنهش
چارده ساله بتي چابک و شيرين دارم * که به جان حلقه بگوش است مه چارده اش
بوي شير از لب همچون شکرش مي آيد * گرچه خون ميچکد از شيوه چشم سيهش
گر چنين جلوه كند مغبچه‌ى باده‌فروش * خاكروب در ميخانه كنم مژگان را
گل بى‌رخ يار خوش نباشد * بى‌باده بهار خوش نباشد
طرف چمن و طواف بستان * بى‌لاله‌عذار خوش نباشد
رقصيدن سرو و حالت گل * بى صوت هزار خوش نباشد
با يار شكرلب گل‌اندام * بى‌بوس و كنار خوش نباشد
هر نقش كه دست عقل بندد * جز نقش نگار خوش نباشد
جان نقد محقر است حافظ * از بهر نثار خوش نباشد
مژده‌ى وصل تو كو كز سر جان برخيزم * طاير قدسم و از دام جهان برخيزم
به ولاى تو كه گر بنده‌ى خويشم خوانى * از سر خواجگى كون و مكان برخيزم
يارب از ابر هدايت برسان بارانى * پيشتر زانكه چو گردى ز ميان برخيزم
بر سر تربت من با مى و مطرب بنشين * تا ببويت ز لحد رقص‌كنان برخيزم
گرچه پيرم، تو شبى تنگ درآغوشم كش * تا سحرگه ز كنار تو جوان برخيزم
خيز و بالا بنما اى بت شيرين‌حركات * كز سر جان و جهان دست‌فشان برخيزم
روز مرگم نفسى مهلت ديدار بده * تا چو حافظ ز سر جان و جهان برخيزم
سينه از آتش دل در غم جانانه بسوخت * آتشي بود در اين خانه که کاشانه بسوخت
تنم از واسطه دوري دلبر بگداخت * جانم از آتش مهر رخ جانانه بسوخت
سوز دل بين که ز بس آتش اشکم دل شمع * دوش بر من ز سر مهر چو پروانه بسوخت
آشنايي نه غريب است که دلسوز من است * چون من از خويش برفتم دل بيگانه بسوخت
خرقه زهد مرا آب خرابات ببرد * خانه عقل مرا آتش ميخانه بسوخت
چون پياله دلم از توبه که کردم بشکست * همچو لاله جگرم بي مي و خمخانه بسوخت
ماجرا کم کن و بازآ که مرا مردم چشم * خرقه از سر به درآورد و به شکرانه بسوخت
ترک افسانه بگو حافظ و مي نوش دمي * که نخفتيم شب و شمع به افسانه بسوخت
خلوت گزيده را به تماشا چه حاجت است * چون کوي دوست هست به صحرا چه حاجت است
جانا به حاجتي که تو را هست با خدا * کخر دمي بپرس که ما را چه حاجت است
اي پادشاه حسن خدا را بسوختيم * آخر سال کن که گدا را چه حاجت است
ارباب حاجتيم و زبان سال نيست * در حضرت کريم تمنا چه حاجت است
محتاج قصه نيست گرت قصد خون ماست * چون رخت از آن توست به يغما چه حاجت است

اگه شعرای دیگه ای میخاین روی ادامه ی مطلب کلیک کنید.

نظر دادن رو فراموش نکنید

موفق باشید.

سلام

برنامه ای بود که استاد گفت بلنکارو حذف میکرد اونو من تایپ کردم اررور میداد اجرا نمیشد. یکمی تغییرش دادم حالا کار میکنه .البنه یه روش راحترم به ذهنم رسید اونو هم نوشتم . امیدوارم استفاده کنید.

این برنامه ی استاد :

program blank_remover;{www.ukcs86.zet.ir}
uses wincrt;
const blank=' ';
var f:text ;
    letter:char;
begin{www.ukcs86.zet.ir}
 assign (f,'c:file.txt');
 reset(f);
 while not eof(f) do
    begin     
       read(f,letter);
        if (letter=blank) then
         begin
           repeat
             read(f,letter);
           until (letter<>blank);
          write(letter);
         end;
      write(letter);        
    end;
 close(f);
end.{www.ukcs86.zet.ir}

اینم مال من :

program blank_remover2;{www.ukcs86.zet.ir}
uses wincrt;
const blank=' ';
var f:text ;
    letter:char;
begin {www.ukcs86.zet.ir}
 assign (f,'c:file.txt');
 reset(f);
 while not eof(f) do
   begin
    read(f,letter);
     if letter <> blank then
       write(letter)
   end;
 close(f);
end.{www.ukcs86.zet.ir}

سلام علیکم

امیدوارم خوب باشین. امروز سعی کردم با فایلا تو پاسکال کار کنم . یکم حالمو گرفت . ارور میداد!

این برنامه برنامه ی جالبیه اگه اینو تحلیل کنید خیلی از مشکلات کار با فایل ها حل میشه.

اگه مشکلی داشتین بگین شاید تونستیم کمکی کنیم.

program file ;{www.ukcs86.zet.ir}
uses wincrt;
var name : string ;
    ave :real ;
    first:text;
    stno,i,count:integer;
    sum,mean:real;
begin
 i:=3;
 count:=0;
 assign(first,'c:file2.txt');
 reset(first);
 writeln('stno','ave':10,'name':20);
  writeln('------------------------------');
 while not eof(first) do
   begin
     readln(first,ave,stno,name);
     gotoxy(1,i);
     write(stno);
     gotoxy(10,i);
     writeln(ave:5:2);
     gotoxy(30,i);
     writeln(name);
     i:=i+1;{www.ukcs86.zet.ir}
     sum:=sum+ave;
     count:=count+1;
   end;
    writeln('----------------------------------') ;
   close(first);
   mean:=sum / count;
   writeln('average of grades is ',mean:5:2);
   write('press enter key to continue...');
   readln;

end.{www.ukcs86.zet.ir}

برنامه رو از کتاب آقای قمی گرفتم.

توجه کنید که باید فایلی رو که در خط 11 آدرس دادیمو باید در درایو c بسازیم.('c:file2.txt')

نمونه ی فایل مورد نظر :

12.2 125 ali
17.50 145 reza
14.50 135 ahmad

موفق باشید.

سلام این برنامه ی کوچیک طول رشته رو بدست میاره . این برنامه برای آشنایی با کار lenght خوبه.

 امیدوارم به دردتون بخوره.

program lenght;
var
 S: String;
begin
 Readln (S);
 Writeln('"', S, '"');
 Writeln('length = ', Length(S));
end.

موفق باشین.

سلام

این برنامه عدد رو وارون میکنه . اگه به سرسش توجه کنین ما از برنامه ۵ که قبلآ نوشتیم(به آرشیو مراجعه کنید) و تعداد ارقام رو بدست می اورد در این برنامه استفاده کردیم.این نشون میده که برنامه های بزرگ از جمع چند برنامه ی کوچیک ساخته میشن.ما خوشحال میشیم برنامه ی شما رو ببینیم.

program number_inverse;{www.ukcs86.blogpars.com}
uses
  WinCrt;
 var num2,num1,num3,i,j:integer;
     counter:integer;
begin           {www.ukcs86.blogpars.com}
 write('enter a number : '); j:=1;
 readln(num2);
 num1:=num2;
 counter:=1;
 if num2>=10 then
  begin
    repeat
      counter :=counter+1;
      num2:= num2 div 10 ;
    until (num2 <10) ;
  end;
{ writeln(counter); }
  for i:= 1 to(counter-1)do j:=j *10 ;
 {writeln(j);}i:=0;
for i:= counter downto 1 do
   begin
     num2:=(num1 mod 10)*(j);
     j:=j div 10;
     num1:=num1 div 10;
     num3:=num3+num2;
   end;
writeln('the inverse of the number is : ',num3);
end.
 {www.ukcs86.blogpars.com}

موفق باشین.

سلام

این برنامه یه عدد از شما میگیره و اونو به مبنایه ۸ میبره . شما با یه کم تلاش میتونید این برنامه رو به مبناهایه دیگه هم تآمیم بدین. اگه نوشتین برایه ما بفرستینش تا با نام خودتون ثبتش کنیم.

program Division;{www.ukcs86.blogpars.com}
uses WinCrt;
 var num,num1,num2,counter,num3 : integer;
begin {www.ukcs86.blogpars.com}
 counter:=1;
 num1:=9; num2:=0; num3:=0;
 write('enter a number : ');
 readln(num);
{ while  num1 +8>  8 do
   begin
     num1:=num div 8 ;
     num2:=num mod 8 ;
     num3:=(num3) +(num2 * counter);
     counter:=counter*10;
     num:=num1;
   end;     }
 repeat
     num1:=num div 8 ;
     num2:=num mod 8 ;
     num3:=(num3) +(num2 * counter);
     counter:=counter*10;
     num:=num1;
  until   num1+8<=8; 
 writeln(num3);       
end.
 {www.ukcs86.blogpars.com}
 {in barname ba do halgheye while va repeat neveshte
  shode ast ke har 2 ham arzand va natayeje yeksani
  midahand shoma mitavanid har 2 ra test konid.   }

این برنامه و بعضی دیگه از برنامه ها با روشای مختلفی نوشته شده و شما میتونید اونا رو تو سرس برنامه ببینید. مثلآ این برنامه با ۲ حلقه ی while و repeat نوشته شده که فقط یکیش کار میکنه و هر دوتاش کار مشابهی میکنن . اگه شما این برنامه رو با روشه دیگه ای نوشتین ممنون میشیم اگه اونو برای ما بفرستین.

درود و سلام بر شما

برنامه ذیل مقسوم علیه های یک عدد را نمایش میده .

program Divisor ;{www.ukcs86.blogpars.com}
uses
  WinCrt;
 var num,i : integer;
     counter:integer;
begin {www.ukcs86.blogpars.com}
 write('enter a number : ');
 readln(num);
 for i := (num div 2)+1 downto 1 do
  begin
    if (num mod i)=0 then write(i,',');
  end;
end.
 {www.ukcs86.blogpars.com}

اگه مشکلی بود بگین.

موفق و پیروز باشین.