مترجم سایت

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

از اینکه به این وبلاگ سر زدید ممنونم

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

از بهترین و پربازدید ترین سایت های داخلی

در کمترین زمان ممکن برسید

پس

.

.

.

.

به لینک زیر بیاید

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

با تشکر

mlrdownload.persianblog.ir

ایرانیان باستان اولین فصل سال را (به ار) یعنی اورنده بهترین ها نامیدند

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

program soal_1;
{$APPTYPE CONSOLE}
var
i,j:integer;
begin
for i:=1 to 5 do
begin
for j:=i downto 1 do
write(j:3);
writeln;
end;
readln;
end.

program soal_2;
{$APPTYPE CONSOLE}
var
s:string;
y,t,i,p,f:integer;
begin
writeln;
write('please enter a number in base 16 := ');
readln(s);
t:=0;
p:=1;
f:=length(s);
for i:=f downto 1 do
begin
case s[i] of
'0':y:=0;
'1':y:=1;
'2':y:=2;
'3':y:=3;
'4':y:=4;
'5':y:=5;
'6':y:=6;
'7':y:=7;
'8':y:=8;
'9':y:=9;
'a':y:=10;
'b':y:=11;
'c':y:=12;
'd':y:=13;
'e':y:=14;
'f':y:=15;
end;
t:=t+p*y;
p:=p*16;
end;
writeln(t);
readln;
end.

program soal_3;
{$APPTYPE CONSOLE}
var
x,p:array[0..100]of integer;
q,n,i,j,c,g:integer;
f:Boolean;
begin
write('please enter a number := ');
readln(n);
for i:=1 to n do
begin
write('x[',i,'] := ');
readln(x[i]);
end;
writeln;
write('please enter another number := ');
readln(q);      //adade entekhabi
f:=false;
for i:=1 to n do
if x[i]=q then       //agar q dar baze vojod dasht
begin
f:=true;
for j:=i to n-1 do
x[j]:=x[j+1];
for c:=1 to n-1 do
write(x[c]:3);
break;
end;   //end of if
writeln;
for i:=1 to n do
if (q>x[i]) and (q<x[i+1]) then      // peida kardane makane q
begin
g:=i+1;           //agar q dar baze vojod nadasht
for c:=g to n do
p[c+1]:=x[c];          //  p = araye komaki baraye ozve jadid
for c:=1 to g-1 do
p[c]:=x[c];
p[g]:=q;
for c:=1 to n+1 do
if f=false then
write(p[c]:3)
end;
for i := 1 to n+1 do
if q>x[n] then
begin
x[n+1]:=q;
write(x[i]:3);
end;
for i:=0 to n do
begin
if f=false then
if q<x[1] then
begin
x[0]:=q;
write(x[i]:3);
end;
end;
readln;
end.

program soal_4;
{$APPTYPE CONSOLE}
type
tell=record
number:integer;
name:string[20];
address:string;
cost:integer;
end;
y=array[1..50]of tell;
procedure sort(var c:y;m:integer);
var
i,j,k,p:integer ;
s,z:string;
begin
for i:=1 to m do
for j:=1 to m-i do
if c[j].number>c[j+1].number then
begin
k:=c[j].number;
c[j].number:=c[j+1].number;
c[j+1].number:=k;
p:=c[j].cost;
c[j].cost:=c[j+1].cost;
c[j+1].cost:=p;
s:=c[j].name;
c[j].name:=c[j+1].name;
c[j+1].name:=s;
z:=c[j].address;
c[j].address:=c[j+1].address;
c[j+1].address:=z;
end;
end;
function warning(c:y;m:integer):y;
var
i:integer;
begin
writeln;
writeln('moshtariane por masraf');
for i:=1 to m do
if c[i].cost>20000 then
begin
writeln(c[i].cost,c[i].name:10,c[i].number:10,c[i].address:10);
writeln('_________________________')
end;
warning:=c;
end;
var
x:y;
n,i:integer;
begin
write('please enter a number := ');
readln(n);
for i:=1 to n do
begin
write('name[',i,'] := ');
readln(x[i].name);
write('number[',i,'] := ');
readln(x[i].number);
write('address[',i,'] := ');
readln(x[i].address);
write('cost[',i,'] := ');
readln(x[i].cost);
writeln('_________________________')
end;
sort(x,n);
writeln('moratab sazi information');
for i:=1 to n do
begin
writeln(x[i].number,x[i].name:10,x[i].address:10,x[i].cost:10);
writeln('_________________________');
end;
writeln;
warning(x,n);
readln;
end.

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

program soal_5;
{$APPTYPE CONSOLE}

type
tell=record
number:integer;
name:string[20];
address:string;
cost:integer;
end;
y=array[1..50]of tell;
var
f,g:text;
x:y;
n,i,k,d:integer;
b:array[1..50]of integer;
begin
write('please enter a number := ');
readln(n);
assign(f,'e:\tell.dbf');
rewrite(f);
for i:=1 to n do
begin
write('cost[',i,'] := ');
readln(x[i].cost);
write(f,x[i].cost);
write('name[',i,'] := ');
readln(x[i].name);
write(f,x[i].name:10);
write('number[',i,'] := ');
readln(x[i].number);
write(f,x[i].number:10);
write('address[',i,'] := ');
readln(x[i].address);
write(f,x[i].address:10);
writeln('_________________________');
writeln(f);
end;
close(f);
k:=0;
assign(f,'e:\tell.dbf');
reset(f);
for i:=1 to n do
begin
readln(f,x[i].cost);
if x[i].cost>20000 then
begin
k:=k+1;
b[k]:=i;
end;
end;
close(f);
assign(g,'e:\new.dbf');
rewrite(g);
writeln(g,'moshtariane por masraf');
writeln(g);
for d:=1 to k do
begin
write(g,x[b[d]].name);
write(g,x[b[d]].number:10);
write(g,x[b[d]].address:10);
write(g,x[b[d]].cost:10);
writeln('_________________________');
writeln(g);
end;
close(g);
readln;
end.

program zarbb07;
{$APPTYPE CONSOLE}
var
x,y,t1:string;
i,j,n,m,e,h,q:integer;
a,b:array[1..255]of integer;
z,p:array[0..255]of integer;
t:array[1..255,0..255]of integer;
begin
writeln('please enter first number');
readln(x);
writeln('please enter second number');
readln(y);
n:=length(x);
m:=length(y);
if n>m then
 begin
  t1:=x;
  x:=y;
  y:=t1;
  n:=length(x);
  m:=length(y);
 end
else if m>n then
 begin
  n:=length(x);
  m:=length(y);
 end;
for i:=n downto 1 do
 val(x[i],a[i],e);
for i:=m downto 1 do
 val(y[i],b[i],e);
 z[m]:=0;
for i:=n downto 1 do
  begin
   for j:=m downto 1 do
    begin
     z[j]:=z[j]+a[i]*b[j];
     case z[j] of
     0..9:begin z[j]:=z[j];end;
     10..19:begin z[j]:=z[j]-10; z[j-1]:=1;end;
     20..29:begin z[j]:=z[j]-20; z[j-1]:=2;end;
     30..39:begin z[j]:=z[j]-30; z[j-1]:=3;end;
     40..49:begin z[j]:=z[j]-40; z[j-1]:=4;end;
     50..59:begin z[j]:=z[j]-50; z[j-1]:=5;end;
     60..69:begin z[j]:=z[j]-60; z[j-1]:=6;end;
     70..79:begin z[j]:=z[j]-70; z[j-1]:=7;end;
     80..81:begin z[j]:=z[j]-80; z[j-1]:=8;end;
     end;
    p[j]:=z[j];
    p[0]:=z[j-1];
   if j=1 then
    begin
     for h:=n downto 1 do
      begin
       for q:=m downto 0 do
       t[h,q]:=p[q];
      end;
    end;
   end;
 end;
writeln;
write('x*y:=');
if t[1,1]=0 then
begin
 for h:=1 to n do
 for q:=1 to m do
 write(t[h,q]);
end
else
begin
 for h:=1 to n do
 for q:=1 to m do
 write(t[h,q]);
end;
readln;
end.

ساختار کلی برنامه به صورت زیر است...
1-تعریف
2-به وسیله procedure و functionقسمتهای تکراری را از بین ببریم
3-بدنه

فرم کلی پاسکال:

اسم Program
; تعریف ثابت const
; تعریف نوع type
; تعریف متغیرها

(پارامترها) نام procedure

begin
....

....
end ;
; ( پارامترها ) نام نوع تابع function
begin
....

....
end ;
begin

....

....

end .

انواع متغیرها در پاسکال:
Integer :انواع عددی صحیح شامل اعداد بدون نقطه ممیز است
نوع مقادیری که می پذیرند طول(بایت)
byte 0 تا 255 1
Shortint 128- تا 127 1
integer 32768- تا 32767 2
Word 0 تا 65535 2
Longint 2147483648- تا 2147483647 4

اعداد اعشاری:
انواع عددی اعشاری شامل اعدادی با نقطه ممیز است

نوع مقادیری که میپذیرند ارقام با معنی طول(بایت)
single 1.5e-45 تا3.4e38 7 تا 8 4
real 2.9e-39 تا 1.7e38 11 تا 12 6
Double 5.0e-324تا 1.7e308 15 تا 16 8
extended 1.9e-4951تا 1.1e493 19 تا 20 10

از این به بعد به حل مسائل مربوطه می پردازیم

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

var

a,b,c : integer;

x1,x2,delta : real;

begin

writeln('please enter 3 number : ');

readln(a,b,c);

delta := (b*b)-(4*a*c);

if delta > 0 then // 2 real root

begin

x1:=(-b+sqrt(delta))/(2*a);

x2:=(-b-sqrt(delta))/(2*a);

writeln('x1 : ', x1:2:3 , ' , ' , 'x2 : ' , x2:2:3);

//writeln('x2 : ',x2);

end

else if delta = 0 then // 2 equal root

begin

x1:=(-b)/(2*a);

writeln('x1=x2 : ', x1:2:3);

end

else // no real root

begin

writeln('don''t have any real root');

end;

readln;

end.

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

var

i,n,m,c:integer;

begin

writeln('please enter one number:') ;

readln(n);

c:=n div 2;

m:=0;

for i:=1 to c do

begin

if n mod i=0 then

m:=m+1;

end;

if m=1 then writeln('adad aval ast')

else writeln('adad aval nist');

readln;

end.

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

var

i,n,m:integer;

begin

writeln('please enter one number:') ;

readln(n);

m:=0;

for i:=1 to n div 2do

begin

if n mod i=0 then

begin

m:=m+i;

end;

end;

if n=m then writeln('adad kamel ast')

else writeln('adad kamel nist');

readln;

end.

برنامه ای بنویسید که مقلوب عدد مورد نظر را بدست بیاورد.

var

n:integer;

begin

readln(n);

while n>0 do

begin

write(n mod 10);

n:=n div 10

end;

readln;

end.

برنامه ای که عددی رو که شامل صفر میشه دریافت میکنه وصفر اون رو حذف میکنه.

var

n,r,m,p:integer;

begin

p:=1;

readln(n);

m:=0;

while n>0 do

begin

r:=n mod 10;

n:=n div 10;

if r>0 then

begin

p:=p*10;

m:=m+p*r;

end;

end;

write(m div 10);

readln;

end.

برنامه زیر سری فیبوناچی رو قبل از عدد مورد نظر نمایش میده.

var

a,b,c,n:integer;

begin

readln(n);

a:=1;

b:=1;

writeln(a);

writeln(b);

repeat

c:=a+b;

a:=b;

b:=c;

writeln(c);

until c>n;

readln;

end.

برنامه ای که تعداد اعداد زوج و فرد سری فیبوناچی رو قبل از عدد مورد نظر چاپ میکنه.

var

m,n,a,b,c:integer;

begin

a:=0;

b:=1;

writeln('enter m,n');

readln(m,n);

writeln('even num');

repeat

c:=a+b;

if (c>=m) and (c<=n) and (c mod 2=0) then writeln(c);

a:=b;

b:=c;

until c>n;

writeln('odd num');

a:=0;

b:=1;

repeat

c:=a+b;

if (c>=m) and (c<=n) and (c mod 2<>0) then writeln(c);

a:=b;

b:=c;

until c>n;

readln;

end.

محاسبه معادله x^n/n!

var

x,n,i,j,t,f:integer;

begin

i:=1;

j:=1;

t:=1;

f:=1;

writeln('please enter x,n');

readln(x,n);

while i<=n do

begin

t:=t*x;

i:=i+1;

end;

while j<=n do

begin

f:=f*j;

j:=j+1;

end;

writeln('x^n/n!:=',t/f:3:2);

readln;

end.

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

var

k:byte;f:boolean;

a:array[1..50]of integer;

i,j,n:integer;

begin

write('enter a number');

readln(n);

a[1]:=2;

a[2]:=3;

f:=true;

k:=2;

for i:=4 to n do

begin

for j:=2 to(i div 2)do

if(i mod j)=0 then

f:=false;

if f then

begin

k:=k+1;

a[k]:=i;

end;

f:=true;

end;

writeln('the prime numbers before n:');

for j:=1 to k do

writeln(a[j]);

readln;

end.

جایگزین کردن صفر به جای اعداد اول در یک ارایه

var

i,j,m,n:integer;

a:array[1..50]of integer;

flag:boolean;

begin

writeln('enter number element of array:');

readln(n);

writeln('enter elements of array');

for i:=1 to n do

readln(a[i]);

for i:=1 to n do

begin

m:=(a[i] div 2);

flag:=true;

for j:=2 to m do

if(a[i] mod j)=0 then flag:=false;

if flag and not(a[i]=1) then a[i]:=0;

end;

writeln('output');

for i:=1 to n do

writeln(a[i]);

readln;

end.

محاسبه مجموع هر سطر

var

s:real;

a:array[1..3,1..3]of integer;

i,j:byte;

begin

writeln('please enter element of matrix 3*3');

for i:=1 to 3 do

for j:=1 to 3 do

begin

write('a[',i,j,']:=');

readln(a[i,j]);

end;

writeln;

for i:=1 to 3 do

begin

for j:=1 to 3 do

begin

write(a[i,j]:3);

s:=s+a[i,j];

end;

writeln(s:8:2);

s:=0;

end;

readln;

end.

ادامه در صفحه بعد....

    var m, n : integer;
{****************************}
  function gcd(m, n : integer) : integer;
  begin
      if (n <= m) and (m mod n = 0) then
          gcd := n
      else if m < n then
          gcd := gcd(n, m)
      else
          gcd := gcd(n, m mod n)
  end;
{****************************}
begin{test}
   write('Enter two positive integer :');
   readln(m, n);
   write('thier greatest common divisor is:', gcd(m,n));
   readln
end.

   const n = 5;
   type arr = array[1..n] of integer;
   var  x : arr;
        i : integer;
{************************}
   function sum(var x : arr; n : integer) : integer;
   begin
      if n = 1 then
         sum := x[1]
       else
         sum := x[n] + sum(x, n-1)
   end;
{************************}
begin{test}

   write('Enter ', n, ' number:');
   for i := 1 to n do
       read(x[i]);
   write('Sum of array elements is:',sum(x, n));
   readln;
   readln;
end.

  label 100 ;
  const
       n = 5;
  var
    x , sum , i : integer ;
begin
      write('Enter five integer number :');
      i := 1;
      sum := 0 ;
100 : begin
        read(x);
        sum := sum + x * x ;
        i := i + 1;
        if i <= 5 then
           goto 100
      end;
      write('Sum of square is :',sum);
      readln;
      readln;
end.

const
     n1 = 8;
     n2 = 5;
type
     ar1 = array[1..n1] of integer;
     ar2 = array[1..n2] of integer;
     ar3 = array[1..n1 + n2] of integer;
var
   i : integer;
   a : ar1;
   b : ar2;
   c : ar3;
{***************}
procedure mergArr(a : ar1; n1 : integer; b : ar2; n2 : integer; var c : ar3; n3 : integer);
var
   i, j, k : integer;
begin
   i := 1;
   j := 1;
   if ((n1 + n2) <> n3) then
   begin
      write('Size of n3 is incorrect.');
      readln;
      exit;
   end;
   k := 1;
   while (i <= n1) and (j <= n2) do
   begin
      if a[i] < b[j] then
      begin
  c[k] := a[i];
         i := i + 1;
      end
      else
      begin
  c[k] := b[j];
         j := j + 1;
      end;
      k := k + 1;
   end;{while}
   while i <= n1 do
   begin
      c[k] := a[i];
      k := k + 1;
      i := i + 1;
   end;
   while j <= n2 do
   begin
      c[k] := b[j];
      k := k + 1;
      j := j + 1;
   end;
end;
{***********************}
begin
for i:=1 to 8 do
readln(a[i]);
for i:=1 to 5 do
readln(b[i]);
   mergArr(a, n1, b, n2, c, n1 + n2);
   for i := 1 to n1 + n2 do
       write(c[i] : 3);
   readln;
end.

type letter = 'A'..'Z' ;
        arr = array[letter] of integer ;
   var
       str : string ;
       ch  : char;
       count : arr;
       i : integer ;
begin
    for ch  := 'A' to 'Z' do
         count[ch] := 0 ;

    write('Enter a string :');
    readln(str);
    for i := 1 to length(str) do
    begin
        ch := upcase(str[i]) ;
        if (ch >='A') and (ch <= 'Z') then
            count[ch] := count[ch] + 1 ;
    end;
    writeln;
    writeln('Character' , '   Count ');
    for ch  := 'A' to 'Z' do
        if count[ch] <> 0 then
         writeln(ch :4  , count[ch] : 12) ;
    readln;

end.

  const n = 5;
  type arr = array[1..n] of integer;
  var  i : integer;
       x, y : arr;
{********************}
  function com(var x, y : arr; n : integer) : boolean;
  begin
      if n = 1 then
         com := (x[1] = y[1])
      else if x[n] <> y[n] then
         com := false
      else
         com := com(x, y, n-1)
  end;{find}
{********************}
begin{test}
  write('Enter ',n, ' number for x:');
  for i := 1 to n do
     read(x[i]);

  write('Enter ',n, ' number for y:');
  for i := 1 to n do
     read(y[i]);
  if com(x, y, n) then
     write(' arrays x , y are equal.')
  else
     write(' arrays x , y are not equal.');
  readln;
  readln;
end.

 var a, b, c, x1, x2 : real;
      result : byte;
  {*************}
   procedure root(a, b, c : real; var x1, x2 : real; var result : byte);
     var delta : real;
   begin
     delta := b * b - 4 * a * c;
     if delta < 0 then
        result := 0
     else if (a = 0) and (b = 0) then
        result := 0
     else if (a = 0) and (b <> 0) then
     begin
        result := 1;
        x1 := -c / b;
     end
     else if (a <> 0) and (delta = 0) then
     begin
        result := 2;
        x1 := -b / 2 * a;
        x2 := x1;
     end
     else if (a <> 0) and (delta <> 0) then
     begin
         result := 3;
         x1 := (-b + sqrt(delta)) / (2 * a);
         x2 := (-b - sqrt(delta)) / (2 * a);
     end;
   end;{root}
  {*************}
begin

  write('Enter a, b, c:');
  read(a, b, c);
  result := 5;
  root(a, b, c, x1, x2, result);
  writeln;
  case result of
    0 : writeln('Euation has not real answers.');
    1 : writeln('Equation has one answer : x1 =',x1:5:2);
    2 : writeln('Equation has two equal answers : x1=x2=',x1 :5 :2);
    3 : writeln('Equation has two answers:x1=',x1:5:2, ',x2=',x2:5:2);
  end;{case}
  readln;
  readln;
end.

      const n = 8;
type
     ar = array[0..n - 1] of integer;
var
   i : integer;
   a : ar;
{*******************}
procedure split(var a : ar; first : integer; last : integer; var pos : integer);
var
    t, left, right, pivot : integer;
begin
    left := first;
    right := last;
    pivot := a[first];
   while left < right do
   begin
     {search from right for element <= pivot}
     while a[right] > pivot do
 right := right - 1;
     {search from right for element <= pivot}
     while (left < right) and (a[left] <= pivot) do
 left := left + 1;
     {interchange element if searches havn't met}
     if left < right then
     begin
       t := a[left];
       a[left] := a[right];
       a[right] := t;
      end;
   end; {end of while}
   {end of searches. place pivot in correct position}
   pos := right;
   a[first] := a[pos];
   a[pos] := pivot;
end;
{***************}
procedure quicksort(var a : ar; first : integer; last : integer);
var
   pos : integer;  {final position of pivot}
begin
   if first < last  then
   begin
       {split into two sublists}
       split(a, first, last, pos);
       {sort left sublist}
       quicksort(a, first, pos - 1);
       {sort right sublidt}
       quicksort(a, pos + 1, last);
   end;
   {else list has 0 or 1 element}
   {and requires no sorting}
end;
{*******************************}
begin
for i:=0 to 8 do
readln(a[i]);
     quicksort(a, 0, n - 1);
   for i := 0 to n - 1 do
       write(a[i] : 3);
   readln;
end.

program test;
{$APPTYPE CONSOLE}
var
a,b:integer;
procedure swap(x,y:integer);
var
t:integer;
begin
t:=x;
x:=y;
y:=t;
writeln('num1=',x,'       num2=',y)
end;
begin
writeln('please enter two number');
readln(a,b);
swap(a,b);
readln;
end.

program moraba;
{$APPTYPE CONSOLE}
var
n:integer;
procedure mor(var a:integer);
var
i:integer;
begin
for i:=1 to a do
 begin
  a:=i*i;
  writeln(a);
 end;//end of procedure
end;
begin
writeln('please enter a number to do');
readln(n);
mor(n);
readln;
end.