Bài 35/2000 - Các phân số được sắp xếp

Bài 37/2000 - Số siêu nguyên tố

Program Bai37;

{SuperPrime};

var a,b: array [1..100] of longint;

      N,i,k,ka,kb,cs: byte;

Function Prime(N: longint): boolean;

Var i: longint;

Begin

      Prime:=false

   Else

      Begin

         While (N mod i <> 0) and (i <= Sqrt(N)) do Inc(i);

         If i > Sqrt(N) then

               Prime:=true   Else Prime:=false;

       End;

End;

    Write ('Nhap N: ');

    Readln (N);

    ka:=1;  a[ka]:=0;

    For i:=1 to N do

         Begin

            Kb:=0;

            For k:=1 to ka do

               For cs:=0 to 9 do

                  If Prime(a[k]*10+cs) then

                      Begin

                         Inc(kb);

                         b[kb]:=a[k]*10+cs;

                      end;

           ka:=kb;

           For k:=1 to ka do

              a[k]:=b[k]; end;

           For k:=1 to ka do

             Write(a[k]:10);

             Writeln;

    Writeln('Co tat ca',ka,'so sieu nguyen to co',N,'chu so.');

    Readln;

END.
Bài 38/2000 - Tam giác số

Uses Crt;

Const inp='INPUT.TXT';

Var N,Smax: integer;

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

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

Procedure Nhap;

Var f: text;

i,j: integer;

Begin

Reset(f);

Readln(f,n);

For i:=1 to N do

begin

For j:=1 to i do Read(f,a[i,j]);

end;

End;

Procedure Thu(S,i,j: integer);

Var k,S_new: integer;

Begin

If i=N then

begin

If S_new>Smax then Smax:=S_new;

else

End;

BEGIN

Smax:=0;

Write('Smax = ',Smax);

Readln;

END.
Dưới đây các bạn có thể tham khảo lời giải của bạn Phạm Đức Thanh dùng phương pháp quy hoạch động trên mảng hai chiều:

Uses crt;

Type mang = array[1..100,1..100] of integer;

Var

i,j,n:integer;

a,b:mang;

Procedure Input;

Begin

clrscr;

reset(f);

readln(f,n);

for j:=1 to n do

begin

for i:=2 to j+1 do

end;

end;

Function Max(m,n:integer):integer;

Begin

if n>m then Max:=n

end;

Procedure MakeArrayOfQHD;

Begin

b[1,2]:=a[1,2];

for i:=3 to n do b[1,i]:=-maxint;

for j:=2 to n do

begin

b[j,i]:=a[j,i]+max(b[j-1,i],b[j-1,i-1]);

end;

end;

Procedure FindMax;

var max:integer;

Begin

for i:=2 to n do

if b[n,i]>max then max:=b[n,i];

writeln('Smax:=',max);

readln;

end;

BEGIN

makearrayofQHD;

FindMax;

END.
Nhận xét: Lời giải dùng thuật toán quy hoạch động của Phạm Đức Thanh tốt hơn rất nhiều so với thuật toán đệ quy quay lui.

{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q+,R+,S-,T-,V+,X+}

{$M 16384,0,655360}

uses crt;

fo = 'output.txt';

new,blank : record x,y : integer end;

var f : text;

begin

assign(f,fo);

write(f,'This puzzle has no final configuration.');

close(f);

halt;

var f : text;

i,j : byte;

begin

rewrite(f);

for i := 1 to 5 do

begin

write(f,a[i,j]);

writeln(f);

end;

end;
procedure swap(px,py : integer);

var coc : char;

begin

new.y := blank.y + py;

if (new.x >5) or (new.y >5) or (new.x <1) or (new.y <1) then

no_no_and_no;

A[new.x,new.y] := A[blank.x,blank.y];

A[blank.x,blank.y] :=coc;

blank := new;

end;
procedure chuyen(ch : char);

begin

'A' : swap( -1,0);

'B' : swap( 1,0);

'R' : swap( 0, 1);

'L' : swap( 0,-1);

end;

var f : text;

i,j : byte;

s : string[5];

ch : char;

begin

reset(f);

for i :=1 to 5 do

begin

if length(s) = 4 then s := s+ #32;

for j := 1 to 5 do

begin

if A[i,j] = #32 then

begin

blank.x := i;

end;

end;

begin

if ch = '0' then exit;

chuyen(ch);

end;

end;
BEGIN

clrscr;

docf;

END.
Bài 40/2000 - Máy định vị Radio

Uses crt;

Const nmax = 30;

Output = 'P27.out';

Input = 'P27.inp';

Type

str20 = string[20];

Toado : Array[1..nmax,1..2] of real;

TenDen,TenDen1,TenDen2 : Array[1..nmax] of str20;

n,j,i,k:integer;

Td1,Td2:array[1..2] of integer;

goc,g1,g2,v,l:array[1..2] of real;

t1,t2:array[1..2] of integer;

xd,yd,x,y, x1,x2,y1,y2:array[1..2] of real;

f:text;

Function tg(x: real): real;

if cos(x)<>0 then tg:=sin(x)/cos(x);

End;

Procedure DocDen(var s:str20);

Begin

read(f,d);

Until (d<>' ');

s:='';

begin

Read(f,d);

End;

End;

Var i:integer;

Begin

i:=1;

XdToado:=i;

End;
Procedure InputDen;

Var i:integer;

Begin

Assign(f,input);

Readln(f,n);

For i:=1 to n do

Begin

Readln(f,Toado[i,1],Toado[i,2]);

End;

End;

Begin

For i:=1 to k do

Begin

Readln(f, goc[i],v[i]);

Docden(tenden1[i]);

Td1[i]:=Xdtoado(tenden1[i]);

Readln(f,g1[i]);

Read(f,t2[i]);

Docden(tenden2[i]);

Td2[i]:=Xdtoado(tenden2[i]);

Readln(f,g2[i]);

End;

Close(f);

Procedure Doi;

Begin

For j:=1 to k do

goc[j]:=goc[j]*pi/180;

g1[j]:=g1[j]*pi/180;

g2[j]:=g2[j]*pi/180;

l[j]:=(t2[j]-t1[j])*v[j];

End;

Procedure TinhToan;

Begin

Assign(f,output);Rewrite(f);

Begin

y1[j]:=Toado[td1[j],2];

x2[j]:=Toado[td2[j],1];

y2[j]:=Toado[td2[j],2];

xd[j]:=x1[j]+l[j]*sin(goc[j]);

yd[j]:=y1[j]+l[j]*cos(goc[j]);

If (cos(goc[j]+g2[j])=0) or (cos(goc[j]+g1[j])=0) then

Writeln(f,'Scenario ',j,': Position cannot be determined')

else

Begin

x[j]:= x2[j] - (y2[j] - y[j])*tg(goc[j] + g2[j]);

Writeln(f,'Scenario ',j,': Positino is (', x[j]:6:2, y[j]:6:2,')') ;

end;

End;

InputDen;

Inputkichban;

Doi;

Close(f);

END.
Bài 41/2000 - Cờ Othello

Program bai41; {Co Othello}

Uses Crt ;

Const Inp = 'othello.Inp' ;

Out = 'othello.out' ;

nmax = 50;

huongi:array[1..8] of integer = (-1,-1,-1,0,0,1,1,1);

huongj:array[1..8] of integer = (-1,0,1,-1,1,-1,0,1);

Type

Mang1 = Array [1..nmax] of string[3] ;

Var f: text;

a: mang2; l:mang1;

c: char; n, k, code:integer;

di:array[1..8,1..8] of boolean;

x0,y0:array[1..nmax] of integer;

{=================================================}

Procedure nhap;

Var i,j : Byte ;

Begin

Reset(f) ;

for i:=1 to 8 do

begin

Readln(f) ;

end;

Readln(f,c) ;

while not eof(f) do

begin

inc(i);

end;

End ;

Procedure kiemtra(i,j:integer);

Var m:integer;

Begin

'B': If a[i,j] = 'B' then

Begin

m:= 1;

if (a[i+huongi[m],j+huongj[m]] = 'W')

and(i+huongi[m]>0)and(j+huongj[m]>0)

and(i+2*huongi[m]>0)and(j+2*huongj[m]>0)

and(i+huongi[m]<9)and(j+huongj[m]<9)

and(i+2*huongi[m]<9)and(j+2*huongj[m]<9)

and(A [i+2*huongi[m],j+2*huongj[m]] = '-')

then

m:=m+1;

End;

Begin

repeat

and(i+huongi[m]>0)and(j+huongj[m]>0)

and(i+2*huongi[m]>0)and(j+2*huongj[m]>0)

and(i+huongi[m]<9)and(j+huongj[m]<9)

and(i+2*huongi[m]<9)and(j+2*huongj[m]<9)

and(a[i+2*huongi[m],j+2*huongj[m]] = '-')

then

di[i+2*huongi[m],j+2*huongj[m]] := True;

until m>8;

end;

End;{of Case}

{================================================}

Procedure lietke;

Var

t: Boolean;

Begin

t:= false;

for j:= 1 to 8 do

di[i,j]:=false;

for i:=1 to 8 do

for j:= 1 to 8 do kiemtra(i,j);

for i:= 1 to 8 do

for j:= 1 to 8 do

If di[i,j] then

Begin

t:= True;

End;

Writeln(f);

End;

{======================================}

Var m:integer;

Begin

Case c of

begin

repeat

and(a[x0-huongi[m],y0-huongj[m]] = 'W')

then

begin

a[x0-huongi[m],y0-huongj[m]] := 'B';

end;
m:=m+1;

until m>8;

end;

'W': if a[x0,y0] ='-'then

m:= 1;

If (a[x0-2*huongi[m],y0-2*huongj[m]] = 'W')

and(a[x0-huongi[m],y0-huongj[m]] = 'B')

then

a[x0,y0]:='W';

a[x0-huongi[m],y0-huongj[m]] := 'W';

end;

until m>8;

end;

end;

{=============================================}

Procedure Thuchien(k:integer);

Var

code,m: Integer;

Begin
for i:= 1 to 8 do

for j:= 1 to 8 do

begin

if a[i,j]='W'then yy1:=yy1+1;

end;

for i:= 1 to 8 do

for j:= 1 to 8 do kiemtra(i,j);

If not di[x0[k],y0[k]] then

begin

Case c Of

'B':c:= 'W';

End;

for i:= 1 to 8 do

If not di[x0[k],y0[k]] then

Case c Of

'W':c:= 'W';

'B':c:= 'B';

End;

latco(x0[k],y0[k]);

for i:= 1 to 8 do

for j:= 1 to 8 do

begin

if a[i,j]='W'then yy:=yy+1;

end;

if (xx<>xx1)and(yy<>yy1) then

Case c Of

'W':c:= 'B';

'B':c:= 'W';

End;

{=============================================}

Procedure ketthuc;

Var

Begin

begin

Writeln(f);

end;

End;

Begin

nhap;

Rewrite(f);

for k:=1 to n do

Case l[k][1] of

'L': Lietke;

'M':begin

Val(l[k][2],x0[k],code);

Val(l[k][3],y0[k],code);

Thuchien(k);

end;

End;

End.
Bài 42/2000 - Một chút về tư duy số học

(Dành cho học sinh Tiểu học)

Giả sử A là số phải tìm, khi đó A phải có dạng:

A = 2k₁ + 1 = 3k₂ +2 = ... = 10k₉ + 9 (k₁, k₂, ..., k₉ - là các số tự nhiên).

Khi đó A + 1 = 2(k₁ + 1) = 3(k₂ +1 ) = ... = 10(k₉+ 1).

Vậy A+1 phải là BSCNN (bội số chung nhỏ nhất) của (2, 3, ..., 10) = 2520.

Do đó số phải tìm là A = 2519.

(Dành cho học sinh Tiểu học)

Ta có các nhận xét sau:

+ Kim phút chạy nhanh gấp 12 lần kim giờ. Giả sử gọi v là vận tốc chạy của kim giờ, khi đó vận tốc của kim phút là 12v.

+ Mỗi giờ kim phút chạy một vòng và gặp kim giờ một lần. Như vậy trong 24 giờ, kim giờ và kim phút sẽ gặp nhau 24 lần. Tất nhiên những lần gặp nhau trong 12 giờ đầu cũng như các lần gặp nhau trong 12 giờ sau. Và các lần gặp nhau lúc 0 giờ, 12 giờ và 24 giờ là trùng nhau và gặp nhau vào chính xác các giờ đó.

Do đó, ở đây ta chỉ xét trong chu kì một vòng của kim giờ (tức là từ 0 giờ đến 12 giờ).

Giả sử kim giờ và kim phút gặp nhau lúc h giờ (h = 0, 1, 2, 3, ..., 10, 11) và s phút. Và giả sử xét quãng đường được đo theo đơn vị là phút. Do thời gian chạy là như nhau nên ta có:



60h = 11s s = .

Thay lần lượt h = 0, 1, 2, 3, ..., 10, 11 vào ta sẽ tính được s.

Với h = 0, s = 0 Kim giờ và kim phút gặp nhau đúng vào lúc 0 giờ.

h = 1, s = = Kim giờ và kim phút gặp nhau lúc 1 giờ phút.

h = 2, s = Kim giờ và kim phút gặp nhau lúc 2 giờ phút.

....

h = 11, s = 60; 11 giờ 60 phút = 12 giờ Kim giờ và kim phút gặp nhau đúng vào lúc 12 giờ.

(Dành cho học sinh THCS)

Program mang;

uses crt;

const n=9;

var a:array[1..n,1..n] of integer;

i,j,k:integer; t:boolean;

Begin

for j:=1 to n do

Begin

a[1,j]:=j;

end;

repeat

for j:=i to n do

begin

t:= false;

if t then

begin

if a[j-1,i]+2 > n*2 then a[j,i]:=2 else a[j,i]:=a[j-1,i]+2;

end

begin

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

end;

end;

for i:=1 to n do

begin

for j:=1 to n do write(a[i,j]:4);

end;

end.
Bài 45/2000 - Các vòng tròn Olympic

(Dành cho học sinh THCS và PTTH)

{$Q-}

Program Vong_Tron;

Uses Crt,Dos;

Const Max = 39;

Fileout = 'VTron.out';

Dvt : array [1 .. 5,0 .. 8] of byte = ((8,1,2,3 ,4 ,5 ,6 ,7,8),

(6,2,3,4 ,9 ,10,11,0,0),

(6,4,5,6 ,11,12,13,0,0),

(4,6,7,13,14,0 ,0 ,0,0),

(4,1,2,9 ,15,0 ,0 ,0,0));

D0 : array [1 .. 5] of byte = (8,11,13,14,15);

Type Limt = 0 .. Max;

Mang = array [Limt] of byte;

Var A,B : Mang;

dm : longint;

fout : text;

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

Procedure Time;

Var h,k,i,j : word;

Begin

writeln(h,' : ',k,' : ',i,'.',j);

End;

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

Var i,j : byte;

Begin

Inc(dm);

writeln(fout);

End;

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

Var s,i0 : shortint;

Begin

s := 0;

if Dvt[j0,i0] <= count then Inc(s,A[Dvt[j0,i0]]);

GT := s;

End;

Procedure Try(s0,count,k0 : shortint);

Var i0 : shortint;

Begin

For i0 := 1 to Max-s0 do if B[i0] = 0 then

Begin

B[i0] := 1;

if (count = D0[k0]) and (s0 + i0 = Max) then

Begin

if k0 = 5 then Output else Try(gt(k0 + 1,count),count + 1,k0 + 1);

B[i0] := 0;

End;

End;

Procedure Process;

Begin

clrscr;

Assign(fout,fileout);rewrite(fout);

Fillchar(A,sizeof(A),0);

B:= A; dm := 0;

Try(0,1,1);

writeln(fout,'So cach : ',dm);

close(fout); Time;

End;

BEGIN

END.

{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R+,S+,T-,V+,X+,Y+}

{$M 16384,0,655360}

(*Du lieu vao: file 'inp.txt' voi cac tu khac nhau, moi tu ghi o mot dong;

Du lieu ra: file 'out.txt' *)

PROGRAM Sinh_hoan_vi;

USES Crt;

CONST

INP = 'inp.txt';

OUT = 'out.txt';

TYPE

VAR

f,g :text;

n :longint; { so luong tu}

time:longint ;

Begin

Assign(g,out);

Reset(f);

Rewrite(g);

Readln(f,n);

End;
PROCEDURE DocDay(var s:str);

Begin

Fillchar(s,sizeof(s),chr(0));

begin

read(f,s[ord(s[0])]);

end;

End;
PROCEDURE VietDay(s:str);

Begin

End;
PROCEDURE Sap_xep(l,r:word);{ giai thuat Quicksort}

Var i,j :word;

tg,tam :char;

Begin

i:=l;j:=r;

Repeat

While ord(s[j]) > ord(tg) do dec(j);

If i<=j then

begin

s[i]:=s[j];

s[j]:=tam;

inc(i);

end;

If j>l then Sap_xep(l,j);

If i

End;
PROCEDURE Sinh_hv(s:str);

Var vti,vtj,i,j:word;

stop :boolean;

tam :char;

Begin

VietDay(s);

Repeat

Stop:=true;

If s[i] > s[i-1] then

begin

vti:=i-1;

For j:=ord(s[0]) downto vti+1 do

begin

If (ord(s[j])>ord(s[vti])) then

vtj:=j;

end;

tam:=s[vtj];

s[vtj]:=s[vti];

s[vti]:=tam;

For j:=1 to ((ord(s[0]) - (vti+1))+1) div 2 do

begin

s[vti+j]:=s[ord(s[0])-j+1];

s[ord(s[0])-j+1]:=tam;

end;

VietDay(s);

break;

end;

End;
PROCEDURE Xu_ly;

Var i:longint;

Begin

begin

readln(f);

Sap_xep(1,ord(s[0]));

Sinh_hv(s);

Writeln(g);

end;

Close(g);

End;
BEGIN

Nhap_dl;

END.

i:integer;

Clrscr;

s[2000]:=1;

i:=1;

repeat

s[i]:=s[s[i]];

i:=s[i];

until

s[i]=i;

readln;

(Lời giải của bạn: Hà Huy Luân)

x:=1+2*(N-topow(N));

(Lời giải của bạn: Nguyễn Quang Trung - Lớp 12A Trường HERMANN GMEINER, Đà Lạt, Lâm Đồng)

(* Thuat Giai Xu ly Bit *)

Max = 2000;

A: array[0..(MAX div 8)] of byte;

so: word;

FUNCTION Laybit(i:word):byte;

Var k:word;

Begin

k:=i div 8;

i:=i mod 8;

Laybit:=(a[k] shr (7-i)) and 1;

k:=i div 8;

i:=i mod 8;

a[k]:=a[k] and (not (1 shl (7-i)));

Tim:=j+1;

j:=1;dem:=0;

Fillchar(a,sizeof(a),255);

Tatbit(0);

j:=tim(j);

Tatbit(j);

inc(dem);

j:=tim(j);

Until dem=max-1;

For i:=0 to (max div 8) do

If a[i]<>0 then break;

so:=i * (1 shl 3);

so:=i;

Writeln(' Press Enter to Stop.....');

readln;

End;
BEGIN

Clrscr;

(Lời giải của bạn: Nguyễn Việt Bằng - Lớp 10 Tin - Phổ thông Năng Khiếu - ĐHQG.TPHCM)

(Dành cho học sinh THPT)

Program bai48;

Var x:array[0..10000] of word;

d,a:array[1..1000] of byte;

n,p,s,gtmax:word;

fi,fo:text;

ok:boolean;

Var h,i,j,t:word;

Begin

h:=a[(l+k)div 2];i:=l;j:=k;

While a[i]>h do inc(i);

While a[j]

If i<=j then

Begin

t:=a[i];a[i]:=a[j];a[j]:=t;

End;

if i

if j>l then Q_sort(l,j);

End;
Procedure phan(var ok:boolean);

Var i,p1,j:word;

Begin

For i:=1 to n do

If (d[i]=0) then

For j:=p downto a[i] do

If (x[j]=0) and(x[j-a[i]]<>0) then

Begin

if j=p then

Begin

j:=a[i];

End;

ok:=(x[p]<>0);

if ok then

Begin

Repeat

p1:=p1-a[x[p1]];

Until p1=0;

End;

Var i:word;

Begin

Fillchar(d,sizeof(d),0);

phan(ok);

Until not ok;

ok:=true;

for i:= n downto 1 do

if d[i]=0 then

Begin

ok:=false;

End;

Begin

Begin

if ok then

Begin

writeln(fo,p);

End;

If not ok then

Writeln(fo,s);

End;
Procedure Start;

Var i:word;

Begin

assign(fo,'output.txt');rewrite(fo);

While not seekeof(fi) do

Begin

if n<>0 then

Begin

gtmax:=0;s:=0;

Begin

s:=s+a[i];

if a[i]> gtmax then

gtmax:=a[i];

End;

Q_sort(1,n);

End;

Close(fi);Close(fo);

End;
Begin

Start;

5 2 1 5 2 1 5 2 1

4

1 2 3 4

(Lời giải của bạn Tăng Hải Anh - Hải Dương - TP. Hải Phòng)

Theo giả thiết khi chia A và lập phương của A cho một số lẻ bất kỳ thì nhận được số dư như nhau, tức là: A³ (mod N) = A (mod N), ở đây N số lẻ bất kỳ, chọn N lẻ sao cho N > A³ thì ta phải có A³= A suy ra A=1.

Vậy chỉ có số 1 thoả mãn điều kiện của bài toán.
Bài 50/2001 - Bài toán đổi màu bi

(Dành cho học sinh THCS và PTTH)

Program ba_bi;

Uses crt;

var v,x,d:integer;

BEGIN

Clrscr;

readln(v,x,d);

if ((v-x)mod 3 =0)and((x+d)*(v+d)<>0) then

while (v+x)<>0 do

begin

d:=d-1+3*((3*v*x)div(3*v*x-1));

v:=v+2-3*((3*v)div(3*v-1));

writeln('>> ',v,' ',x,' ',d);

end

readln;

(Lời giải của bạn:Nguyễn Quang Trung)

(Dành cho học sinh THCS và PTTH)

program thaythetu;

var

n:byte;

var

s:string;

f:text;

begin

reset(f);

n:=0;

while not eof(f) do

readln(f,s);

inc(n);

while (s<>'')and(s[1]=' ') do

if i>0 then

begin

i:=pos(' ',s);

while (i<=length(s))and(s[i]=' ') do

i:=i+1;

source[n]:=copy(s,i,length(s)-i+1);

end;

var

s:string;

i,k:byte;

begin

reset(f);

assign(g,'kq.out');

rewrite(g);

while not eof(f) do

begin

for k:=1 to n do

for i:=1 to length(s)-length(des[k])+1 do

if des[k]=copy(s,i,length(des[k])) then

begin

delete(s,i,length(des[k]));

i:=i+length(source[k]);

end;

writeln(g,s);

close(f);

close(g);

end;
begin

init;

replace;