تابع کسینوس
function cosinos(a:real):real;
var
s,d,f:real;
i,k,j,h,p:integer;
begin
for h:=0 to 360 do
for p:=0 to 360 do
if(360*h+p*1)=a then
a:=a-(360*h);
if (a<=360)and(a>180)then a:=360-a
else a:=a;
a:=(pi*a)/180; //bar hasbe radian
s:=1;
f:=1;
k:=1;
d:=1;
begin
for i:=1 to 5 do
begin
f:=-(a*a)*f;
for j:=2 to 2*i do //mohasebe tavan
begin
k:=k*j;
end;
d:=(f/k);
k:=1;
if (d<0.00001)and (d>=0) then break;
s:=s+d;
end; //end of for
writeln;
writeln;
cosinos:=s;
end;
var
x,r:real;
begin
writeln('please enter a degree');
readln(x); //bar hasbe daraje
r:=cosinos(x);
writeln('cos x:=',r:6:3);
readln;
end.
تابع سینوس
function sinos(a:real):real;
var
s,d,f:real;
i,k,j,h,p:integer;
begin
for h:=0 to 360 do
for p:=0 to 360 do
if(360*h+p*1)=a then
a:=a-(360*h);
if (a<=360)and(a>180)then a:=360-a
else a:=a;
a:=(pi*a)/180; //bar hasbe radian
s:=a;
f:=a;
k:=1;
for i:=1 to 10 do
begin
f:=-(a*a)*f; //mohasebe tavan
for j:=2 to (3*i)-i+1 do //mohasebe factoriel
k:=k*j;
d:=(f/k);
k:=1;
s:=s+d;
if (d<0.0001)and (d>=0) then break;
end; //end of for
writeln;
writeln;
sinos:=s;
end;
var
x,r:real;
begin
writeln('please enter a degree');
readln(x); //bar hasbe daraje
r:=sinos(x);
writeln('sin x:=',r:6:3);
readln;
end.
مبناي 2 يک عدد
var
a:array[1..20]of integer;
i,n:integer;
begin
writeln('please enter a number');
readln(n);
i:=1;
while n>0 do
begin
a[i]:=n mod 2;
i:=i+1;
n:=n div 2;
end;
if n<=0 then
begin
i:=i-1;
while i>0 do
begin
write(a[i]);
i:=i-1;
end;
end;
readln;
end.
ضرب دو ماتريس
var
a,b,c:array[1..20,1..20]of integer;
i,j,m,n,h,l,s:integer;
begin
writeln('please enter m,n,l:');{m*n,,,n*l}
readln(m,n,l);
for i:=1 to m do
for j:=1 to n do
begin
writeln('a[',i,j,']:=' );
readln(a[i,j]);
end;
for i:=1 to n do
for j:=1 to l do
begin
writeln('b[',i,j,']:=' );
readln(b[i,j]);
end;
for i:=1 to m do
for j:=1 to l do
begin
h:=1;
s:=0;
while h<=n do
begin
c[i,j]:=a[i,h]*b[h,j];
s:=c[i,j]+s;
c[i,j]:=s;
h:=h+1;
end;
end;
for i:=1 to m do
for j:=1 to l do
writeln('c[',i,j,']:',c[i,j]);
readln;
end.
جايگزيني عدد صفر به جاي اعدادي که مربع کامل هستند.
var
x:array[1..10,1..10]of integer;
i,j,n:integer;
begin
writeln('please enter one number');
readln(n);
for i:=1 to n do
for j:=1 to n do
begin
write('x[',i,j,']:=');
readln(x[i,j]);
end;
for i:=1 to n do
for j:=1 to n do
if frac(sqrt(x[i,j]))=0 then
x[i,j]:=0;
for i:=1 to n do
begin
for j:=1 to n do
write(x[i,j]:3);
writeln;
end;
readln;
end.
جمع سطر و ستون وچاپ ان به همراه ماتريس ورودي.
var
m:array[1..5,1..5]of integer;
row,col:array[1..5]of integer;
i,j:integer;
begin
writeln('please enter elements of array');
for i:=1 to 5 do
begin
writeln('enter row:',i);
for j:=1 to 5 do
readln(m[i,j]);
end;
for i:=1 to 5 do
for j:=1 to 5 do
begin
row[i]:=row[i]+m[i,j];
col[i]:=col[i]+m[j,i];
end;
for i:=1 to 5 do
begin
for j:=1 to 5 do
write(m[i,j]:5);
write(row[i]:5);
writeln;
end;
for i:=1 to 5 do
write(col[i]:5);
readln;
end.
ترانهاده يک ماتريس
var
a:array[1..3,1..3]of integer;
i,j:integer;
t:integer;
begin
for i:=1 to 3 do
for j:=1 to 3 do
begin
writeln('a[',i,j,']');
readln(a[i,j]);
end;
for i:=1 to 3 do
for j:=1 to 3 do
if j>i then
begin
t:=a[i,j];
a[i,j]:=a[j,i];
a[j,i]:=t;
end;
writeln;
for i:=1 to 3 do
begin
for j:=1 to 3 do
write(a[i,j]:4);
writeln;
end;
readln;
end.
ضرب 2 ماتريس(با کمي تغيير نسبت به راه حل قبلي).
var
a : array [1..3] of integer;
b : array [1..3] of integer;
c : array [1..9] of integer;
i,j,co: integer;
begin
for i:= 1 to 3 do
begin
writeln('a[',i,']:=' );
readln(a[i]);
write('b[',i,']:=' );
readln(b[i]);
end ;
for i:=1 to 3 do
for j:=1 to 3 do
begin
co:=co+1 ;
c[co]:=a[i]*b[j];
end ;
for i:=1 to 9 do
begin
writeln(c[i]);
end;
readln;
end.
مرتب سازي خطي
var
x:array[1..100]of integer;
i,a,n:integer;
f:boolean;
begin
f:=false;
writeln('pleae enter a number');
readln(n);
writeln('please enter ',n,' number');
for i:=1 to n do
readln(x[i]);
writeln('please choose one of the number''s');
readln(a);
for i:=1 to 3 do
if a=x[i]then
f:=true;
if f=true then writeln('found')
else write('not found');
readln;
end.
مرتب سازي انتخابي
var
x:array[1..100]of integer;
i,j,n,min,f:integer;
begin
write('enter n:=');
readln(n);
writeln('please enter ',n,' number');
for i:=1 to n do
readln(x[i]);
for i:=1 to n-1 do
begin
min:=x[i];
f:=i;
for j:=i+1 to n do
if x[j] begin
min:=x[j];
f:=j;
end;
x[f]:=x[i];
x[i]:=min;
end;
for i:=1 to n do
write(':',x[i]);
readln;
end.
اميدوارم تا اينجاي کار مشکلي براتون پيش نيومده باشه.
برنامه اي که دو کلمه ميگيرد و بعد از کاراکتر '='در عبارت اول کلمه دوم را قرار مي دهد.
var
n,m:string;
j:integer;
Begin
writeln('please enter two word');
readln(n);
readln(m);
j:=pos('=',n);
delete(n,j+1,length(n)-j);
insert(m,n,j+1);
writeln(n);
readln;
end.
مرتب سازي حبابي
var
x:array[1..10]of integer;
i,a,j:integer;
begin
writeln('please enter 5 number');
for i:=1 to 5 do
readln(x[i]);
for i:=1 to 5 do
for j:=1 to 5-i do
if x[j]>x[j+1]then
begin
a:=x[j];
x[j]:=x[j+1];
x[j+1]:=a;
end;
for i:=1 to 5 do
write(x[i]:3);
readln;
end.
تبديل کلمه is به are
var
a,b,c:string;
i:integer;
begin
a:='pascal is book';
b:='is';
c:='are';
i:=pos(b,a);
while i>0 do
begin
delete(a,i,2);
insert(c,a,i);
i:=pos(b,a);
end;
write(a);
readln;
end.
تشخيص متقارن بودن يک کلمه يا عدد مثل عدد 123321 يا 13431
var
n:string;
i,k:integer;
begin
k:=1;
writeln('please enter a string');
readln(n);
for i:=1 to(length(n)div 2)do
begin
if n[i]<>n[length(n)-i+1]then
k:=0;
end;
if k=1 then writeln('ok')
else write('no');
readln;
end.
10 عدد رندوم بين 10 تا 30
var
i,a:integer;
begin
for i:=1 to 10 do
begin
randomize;
a:=random(21)+10;
writeln(a);
end;
readln;
end.
نکته:در اين برنامه عدد 21 در واقع تفاضل بين دو عدد انتخابي است.
برنامه اي بنويسيد که تعداد کلمات يک جمله را حساب کند.
Readln(st);
S:=0;
St:=st+' '
While pos(' ',st) <> 0 do
Begin
S;=s+1;
Delete(st,1,pos(' ',st));
While st[1]=' 'do
Delet (st,1,1);
End;
End.
يه برنامه جالب با استفاده از تابع chr
var
y:char;
begin
y:=chr(3);
writeln(y:20,y,y:4,y:1);
writeln(y:18,y:5,y:5);
writeln(y:17,y:12);
writeln(y:17,y:12);
writeln(y:17,y:12);
writeln(y:18,y:10);
writeln(y:19,y:8);
writeln(y:20,y:6);
writeln(y:21,y:4);
writeln(y:22,y:2);
writeln(y:23);
readln;
end.
|
