Bài 1:
program daonguoc;
uses crt;
var x,y,du:longint;
begin
write('Nhap X=');
readln(x);
if x>0 then
begin
y:=0;
while x<>0 do
begin
du:=x mod 10;
y:=10*y+du;
x:=x div 10;
end;
write('Y=',y);
end
else write('So nay khong hop le');
readln;
end.Bài 2:
program toigian;
uses crt;
var tu_so,mau_so:string;
code,tu,mau,mau1,tu1:longint;
procedure toi_gian(var a,b:longint);
begin
while a<>b do
if a>b then
a:=a-b
else
b:=b-a;
end;
begin
writeln('Nhap vao 1 chuoi phan so:');
write('Tu so:');
readln(tu_so);
write('Mau_so:');
readln(mau_so);
val(tu_so,tu,code);
val(mau_so,mau,code);
if mau<>0 then
begin
mau1:=mau;
tu1:=tu;
toi_gian(mau,tu);
write('Phan so toi gian:',tu1 div tu,'/',mau1 div tu);
end
else
write('Khong hop le');
readln;
end.Bài 3:
program tong_chu_so;
uses crt;
var F,k,r,tong,n:qword;
{-------Ham dem so chu so cua n-------}
function T(n:qword):qword;
var dem:qword;
begin
if n=1 then T:=1
else
begin
dem:=1;
while (n div 10<>0) do
begin
dem:=dem+1;
n:=n div 10;
end;
T:=dem;
end;
end;
{----Tinh tong cac chu so cua n----}
function S(n:qword):qword;
var s1:qword;
begin
s1:=0;
while n div 10 <> 0 do
begin
s1:=s1+n mod 10;
n:=n div 10;
end;
S:=s1+n;
end;
{--------Main--------}
Begin
clrscr;
write('Nhap n=');
readln(n);
if n>0 then
begin
write('So chu so cua ',n,' la:',T(n));
writeln;
write('Tong cac chu so cua ',n,' la:',S(n));
writeln;
K:=1; {tim k lon nhat sao cho F(k)<n}
Tong:=1; {tinh luon tong cac chu so}
F:=1; {So chu so da tinh vao tong}
While F<n do
Begin
k:=k+1;
F:=F+T(k);
tong:=tong+S(k);
End;
{vong lap dung khi F>=n,tuc la gap k ma tong cac chu so cho den k la >=n}
If F=n then write(tong)
Else
Begin
While F>n do
Begin
r:=k mod 10;
tong:=tong-r;
k:=k div 10;
F:=F-1;
end;
Write(tong);
End;
end
else write('Khong hop le');
readln;
End.Bài 4:
Program hinhvuong;
Uses crt;
var fi:text;
m,n,max:byte;
f:array[0..255] of byte;
a:array[1..500,1..500] of byte;
{-------Doc dl-------}
Procedure docdl;
var i,j:byte;
begin
assign(fi,'hinhvuong.inp');
reset(fi);
readln(fi,m,n);
writeln(m,' ',n);
for i:=1 to m do
begin
for j:=1 to n do
read(fi,a[i,j]);
readln(fi);
end;
for i:=1 to m do
begin
for j:=1 to n do
write(a[i,j],' ');
writeln;
end;
close(fi);
end;
{--------Xu ly------}
procedure xuly;
var i,j:byte;
begin
for i:=1 to m do
for j:=1 to n do
if (a[i,j]=a[i,j+1]) and (a[i,j]=a[i+1,j+1])and(a[i,j]=a[i+1,j]) then
f[a[i,j]]:=f[a[i,j]]+1;
max:=f[1];
for i:=1 to 255 do
if max<f[i] then
max:=f[i];
write('Max=',max);
end;
{-------Main--------}
Begin
clrscr;
docdl;
xuly;
readln;
End.
