Tin học Tây Sơn

ĐỘ LỆCH...

Go down

ĐỘ LỆCH...

Bài gửi by Admin on Tue Nov 13, 2018 3:29 pm

Xét một số N có 4 chữ số và không phải tất cả các chữ số đều giống nhau. Phép tính độ lệch được thực hiện như sau:
·        Tạo số thứ nhất N1 bằng cách xếp các chữ số theo trình tự giảm dần
·        Tạo số thứ hai N2 bằng cách xếp các chữ số theo trình tự tăng dần (nếu có chữ số 0 ở đầu thì N2 sẽ không phải là số có 4 chữ số)
·        Tính hiệu N1-N2 và gán lại cho N
Các bước trên được thực hiện cho đến khi nhận được số N là 6174 hoặc 0
Ví dụ: Nếu N=1023
·        Ở bước 1: N1=3210, N2=123, N=N1-N2=3087
·        Ở bước 2: N1=8730, N2=378, N=N1-N2=8352
·        Ở bước 3: N1=8532, N2=2358, N=N1-N2=6174
Vậy ta cần thực hiện 3 lần biến đổi
Yêu cầu: Hãy xác định số lần biến đổi thực hiện theo yêu cầu trên.
Dữ liệu: số nguyên dương N có 4 chữ số
Kết quả:  số lần biến đổi tương ứng với số N
 
DOL.INPDOL.OUT
53643
avatar
Admin
Admin
Admin

Posts : 658
Reputation : -39
Join date : 16/11/2015
Age : 29

Xem lý lịch thành viên http://tinhocts.forumvi.com

Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by Nguyễn Văn Biên on Wed Nov 14, 2018 9:17 pm

CODE:
program DOL;
var fi,fo:text;
n,n1,n2,i,j,x,dem:integer;
A:array[1..4] of byte;
begin
assign(fi,'DOL.INP'); reset(fi);
read(fi,n); close(fi);
if (n<1000) and (n>9999) then exit;
while (n<>6174) and (n<>0) do
begin
n1:=0; n2:=0;
for i:=1 to 4 do
begin
A[i]:=n mod 10;
n:=n div 10
end;
for i:=1 to 3 do
for j:=i+1 to 4 do
if A[i]<A[j] then
begin
x:=A[i];
A[i]:=A[j];
A[j]:=x
end;
n1:=A[1]; n2:=A[4];
for i:=2 to 4 do
begin
n1:=n1*10;
n1:=n1+A[i]
end;
for i:=3 downto 1 do
begin
n2:=n2*10;
n2:=n2+A[i]
end;
n:=n1-n2; dem:=dem+1
end;
assign(fo,'DOL.OUT'); rewrite(fo);
write(fo,dem); close(fo)
end.
avatar
Nguyễn Văn Biên
S-mod
S-mod

Posts : 186
Reputation : 21
Join date : 18/06/2018
Age : 14
Location : ?

Xem lý lịch thành viên https://bien2004official.blogspot.com

Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by tonguyengiahan237 on Thu Nov 15, 2018 12:04 am

Code:
Program Do_lech;
Uses crt;
Type Mang=array[1..4] of integer;
Var  A:Mang;
    N:integer;
    fi,fo:text;

Procedure  Docdl(Var N:integer;Var fi:text);
Begin
Assign(fi,'DOL.INP');
Reset(fi);
Read(fi,n);
Close(fi);
End;
Procedure DOL(Var A:Mang;Var N:integer;Var fo:text);
Var N1,N2,N3,N4,N5,i,j,tam,Dem:integer;
Begin
Assign(fo,'DOL.OUT');
Rewrite(fo);
Dem:=0;
N1:=N mod 10;
N:=N div 10;
N2:=N mod 10;
N:=N div 10;
N3:=N mod 10;
N:=N div 10;
N4:=N mod 10;
While (N1<>6) and (N2<>1) and (N3<>7) and (N4<>4) and (N5<>0) do
  Begin
  For i:=1 to 4 do
  Begin
  A[i]:=N mod 10;
  N:=N div 10
  end;
     For i:=1 to 3 do
     For j:=i+1 to 4 do
   If A[i]<A[j] then
       begin
       Tam:=A[i];
       A[i]:=A[j];
       A[j]:=Tam;
       end;
If A[4]<A[1] then N4:=(A[4]+10)-A[1];
If A[4]>=A[1] then N4:=A[4]-A[1];
If A[3]<A[2] then N3:=(A[3]+10)-A[2];
If A[3]>=A[2] then N3:=A[3]-A[2];
If A[4]<A[1] then N3:=N3-1;
If A[2]<A[3] then N2:=(A[2]+10)-A[3];
If A[2]>=A[3] then N2:=A[2]-A[3];
If A[3]<A[2] then N2:=N2-1;
If A[1]<A[4] then N1:=(A[1]+10)-A[4];
If A[1]>=A[4] then N1:=A[1]-A[4];
If A[2]<A[3] then N1:=N1-1;
N5:=N1+N2+N3+N4;
Dem:=Dem+1;
end;
Dem:=Dem+1;
Writeln(fo,Dem);
close(fo)
end;

BEGIN
CLRSCR;
Docdl(N,fi);
DOL(A,N,fo);
READLN;
END.
avatar
tonguyengiahan237
Teen Chính hiệu
Teen Chính hiệu

Posts : 28
Reputation : -2
Join date : 06/11/2018
Age : 14
Location : TT Phú Phong Huyện Tây Sơn Tỉnh Bình Định

Xem lý lịch thành viên

Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by mainhatthong2004 on Thu Nov 15, 2018 4:13 pm

thong:
program bai7;
uses crt;
var fi,fo:text;
a:array[1..100] of integer;
tg,n,i,d,j,n1,n2:integer;
begin
clrscr;
assign(fi,'DOL.inp');
reset(fi);
readln(fi,n);
assign(fo,'DOL.out');
rewrite(fo);
while (n<>0) and (n<>6174) do
begin
n1:=0;
n2:=0;
i:=1;
while n>0 do
begin
a[i]:=n mod 10;
n:=n div 10;
inc(i);
end;
for i:=1 to 3 do
for j:=i+1 to 4 do
if a[i]<a[j] then
begin
tg:=a[i];
a[i]:=a[j];
a[j]:=tg;
end;
n1:=a[1];
n2:=a[4];
for i:=2 to 4 do
n1:=n1*10+a[i];
for i:=3 downto 1 do
n2:=n2*10+a[i];
n:=n1-n2;
inc(d);
end;
write(fo,d);
close(fi);
close(fo);
readln;
end.



avatar
mainhatthong2004
Teen cá tính
Teen cá tính

Posts : 76
Reputation : -25
Join date : 18/06/2018

Xem lý lịch thành viên

Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by nguyen77 on Thu Nov 15, 2018 4:35 pm

Code:

program bai7;
uses crt;
var fi,fo:text;
a:array[1..100] of integer;
tg,n,i,dem,j,n1,n2:integer;
begin
clrscr;
assign(fi,'DOL.inp');
reset(fi);
readln(fi,n);
assign(fo,'DOL.out');
rewrite(fo);
while (n<>0) and (n<>6174) do
        begin
                n1:=0;
                n2:=0;
                i:=1;
                while n>0 do
                        begin
                                a[i]:=n mod 10;
                                n:=n div 10;
                                inc(i);
                        end;
                for i:=1 to 3 do
                for j:=i+1 to 4 do
                        if a[i]<a[j] then
                                begin
                                        tg:=a[i];
                                        a[i]:=a[j];
                                        a[j]:=tg;
                                end;
                n1:=a[1];
                n2:=a[4];
                for i:=2 to 4 do
                        n1:=n1*10+a[i];
                for i:=3 downto 1 do
                        n2:=n2*10+a[i];
                n:=n1-n2;
                inc(dem);
        end;
write(fo,dem);
close(fi);
close(fo);
readln;
end.
avatar
nguyen77
Năng động
Năng động

Posts : 68
Reputation : -22
Join date : 18/06/2018

Xem lý lịch thành viên

Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by Tạ Thúy Phượng on Thu Nov 15, 2018 4:46 pm

code:
program DOL;
vaR
fi,fo:text;
n,N1,N2,i,j,tg,dem:integer;
a:array[1..4] of byte;
begin
assign(fi,'DOL.INP');
reset(fi);
read(fi,n);
assign(fo,'DOL.OUT');
rewrite(fo);
dem:=0;
while (n<>0)and(n<>6174) do
begin
N1:=0;
N2:=0;
for i:=1 to 4 do
begin
a[i]:=n mod 10;
n:=n div 10;
end;
for i:=1 to 3 do
for j:=i+1 to 4 do
if a[i]<a[j] then
begin
tg:=a[i];
a[i]:=a[j];
a[j]:=tg;
end;
N1:=a[1];
for i:=2 to 4 do
N1:=N1*10+a[i];
N2:=a[4];
for i:=3 downto 1 do
N2:=N2*10+a[i];
N:=N1-N2;
inc(dem);
end;
write(fo,dem);
close(fi);
close(fo);
readln;
end.
avatar
Tạ Thúy Phượng
Năng động
Năng động

Posts : 63
Reputation : -19
Join date : 18/06/2018
Location : Binh Thuan-Tay Son-Binh Dinh

Xem lý lịch thành viên

Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by quantran on Thu Nov 15, 2018 4:53 pm

code cua em:
program bai;
var
a:array[1..4] of byte;
n,N1,N2:integer;
i,j,tg,d:integer;
fi,fo:text;
//-------------------------------
procedure nhap;
begin
assign(fi,'dol.inp');
reset(fi);
read(fi,n);
close(fi);
end;
//--------------------------------
{tim duoc so lan thuc hien phep doi do lech }
procedure xuli;
begin
nhap;

assign(fo,'DOL.out');
rewrite(fo);
while (n<>6174) and (n<>0) do
begin
N1:=0;
N2:=0;
i:=1;
while n>0 do
begin
a[i]:=n mod 10;
n:=n div 10;
inc(i);
end;
for i:=1 to 3 do
for j:=i+1 to 4 do
if a[i]<a[j] then
begin
tg:=a[i];
a[i]:=a[j];
a[j]:=tg;
end;
N1:=a[1];
N2:=a[4];
for i:=2 to 4 do
begin
N1:=N1*10;
N1:=N1+a[i];
end;
for i:=3 downto 1 do
begin
N2:=N2*10;
N2:=N2+a[i];
end;
n:=N1-N2;
d:=d+1;
end;
write(fo,d);
close(fo);
end;
//----------------------------------------
begin
xuli;
readln;
end.
avatar
quantran
Teen cá tính
Teen cá tính

Posts : 73
Reputation : -20
Join date : 18/06/2018
Age : 14
Location : Binh Thuan-Tay Son-Binh Dinh

Xem lý lịch thành viên

Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by lohan on Fri Nov 16, 2018 3:18 pm

Code:
Program Do_lech;
Uses crt;
Type Mang=array[1..4] of integer;
Var  A:Mang;
    N:integer;
    fi,fo:text;

Procedure  Doc(Var N:integer;Var fi:text);
 Begin
 Assign(fi,'DOL.INP');
 Reset(fi);
 Read(fi,n);
 Close(fi);
 End;
Procedure Tim(Var A:Mang;Var N:integer;Var fo:text);
Var N1,N2,N3,N4,N5,i,j,tam,Dem:integer;
Begin
Assign(fo,'DOL.OUT');
Rewrite(fo);
Dem:=0;
 While (n<>6174) and (n<>0) do
  Begin
  For i:=1 to 4 do
  Begin
  A[i]:=N mod 10;
  N:=N div 10
  end;
      For i:=1 to 3 do
      For j:=i+1 to 4 do
    If A[i]<A[j] then
        begin
        Tam:=A[i];
        A[i]:=A[j];
        A[j]:=Tam;
        end;
N1:=A[1]; N2:=A[4];
For i:=2 to 4 do
begin
N1:=N1*10;
N1:=N1+A[i]
end;
For i:=3 downto 1 do
Begin
N2:=N2*10;
N2:=N2+A[i]
end;
N:=N1-N2; dem:=dem+1;
end;
Writeln(fo,Dem);
close(fo)
end;

BEGIN
CLRSCR;
Doc(N,fi);
Tim(A,N,fo);
READLN;
END.
avatar
lohan
Teen Chính hiệu
Teen Chính hiệu

Posts : 20
Reputation : -3
Join date : 06/11/2018
Age : 14

Xem lý lịch thành viên

Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by huynhtanluc on Fri Nov 16, 2018 7:09 pm

Code:
Program dolech;
uses crt;
type mang=array[1..4] of byte;
var n,n1,n2:integer;i,j,tg,d:integer;
    t1,t2:text;a:mang;

        Procedure doc;
        var i:integer;
        begin
        assign(t1,'dol.inp');
        reset(t1);
        read(t1,n);
        close(t1);
        end;

        Procedure inra;
        begin
        assign(t2,'dol.out');
        rewrite(t2);
        while (n<>0) and (n<>6174) do
        begin
        n1:=0;n2:=0;i:=1;
        while n>0 do
        begin
        a[i]:=n mod 10;
        n:=n div 10;
        inc(i);
        end;
        for i:=1 to 3 do
        for j:=i+1 to 4 do
        if a[i]<a[j] then
        begin
        tg:=a[j];
        a[j]:=a[i];
        a[i]:=tg;
        end;
        n1:=a[1];n2:=a[4];
        for i:=2 to 4 do
        n1:=n1*10+a[i];
        for i:=3 downto 1 do
        n2:=n2*10+a[i];
        n:=n1-n2;
        inc(d);
        end;
        writeln(t2,d);
        close(t2);
        end;

Begin
        clrscr;
        doc;
        inra;
        readln;
End.
avatar
huynhtanluc
Năng động
Năng động

Posts : 61
Reputation : -14
Join date : 18/06/2018

Xem lý lịch thành viên

Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by Khách viếng thăm on Fri Nov 16, 2018 9:06 pm

code:
Program dolech;
uses crt;
type mang=array[1..4] of byte;
var N,N1,N2:integer;i,j,tg,d:integer;
fi,fo:text;
a:mang;

Procedure nhap;
var i:integer;
begin
assign(fi,'dol.inp');
reset(fi);
read(fi,n);
close(fi);
end;

Procedure solan;
begin
assign(fo,'dol.out');
rewrite(fo);
while (N<>0) and (N<>6174) do
begin
N1:=0;N2:=0;i:=1;
while N>0 do
begin
a[i]:=n mod 10;
N:=N div 10;
inc(i);
end;
for i:=1 to 3 do
for j:=i+1 to 4 do
if a[i]<a[j] then
begin
tg:=a[j];
a[j]:=a[i];
a[i]:=tg;
end;
N1:=a[1];N2:=a[4];
for i:=2 to 4 do
N1:=N1*10+a[i];
for i:=3 downto 1 do
N2:=N2*10+a[i];
N:=N1-N2;
inc(d);
end;
writeln(fo,d);
close(fo);
end;

Begin
clrscr;
nhap;
solan;
readln;
End.

Khách viếng thăm
Khách viếng thăm


Về Đầu Trang Go down

Re: ĐỘ LỆCH...

Bài gửi by Sponsored content


Sponsored content


Về Đầu Trang Go down

Về Đầu Trang


 
Permissions in this forum:
Bạn không có quyền trả lời bài viết