Kỳ thi lập đội tuyển học sinh giỏi quốc gia năm học 2013-2014 môn : tin học 12

SỞ GIÁO DỤC & ĐÀO TẠO KỲ THI LẬP ĐỘI TUYỂN HSG QUỐC GIA 
 NĂM HỌC 2013-2014
 ĐẮK LẮK	 MÔN : TIN HỌC 12 - THPT	

ĐÁP ÁN VÀ HƯỚNG DẪN CHẤM VÒNG 2

I. Phần chương trình nguồn

Bài 1:
 program biendoixau;
{$B-,Q+,R+} {$M 65500,0,655360}
const
 maxN = 20;
 fi = 'BAI1.INP' ; fo = 'BAI1.OUT';
 bd: array[1..9] of string[2]= ('aa','ab','ac','ba','bb',
 'bc','ca','cb','cc');
type
 sN= string[maxN]; s9= string[9];
 mang= array[1..maxN] of byte;
var
 a, vt: mang; m,n: byte;
 u: sN; x: s9; w: char; f: text;
procedure khoitao;
var i:byte;
begin
 assign(f,fi); reset(f);
 readln(f,n);
 u:= ''; x:= ''; m:= n-1;
 for i:=1 to n do
 begin
 readln(f,w); u:=u+w;
 end;
 for i:=1 to 9 do
 begin
 readln(f,w); x:=x+w;
 end;
 read(f,w); close(f);
end;
procedure check;
var
 t,i,kt: byte; s:sN;
begin
 s:= u;
 for i:=1 to m do
 begin
 t:= pos(bd[a[i]],s);
 if t = 0 then exit;
 vt[i]:= t; delete(s,t,2);
 insert(x[a[i]],s,t);
 end;
 if pos(w,s) > 0 then
 begin
 writeln(f,m);
 for i:= 1 to m do
 writeln(f,a[i],' ',vt[i], ' ',vt[i]+1);
 close(f);halt;
 end;
end;
procedure tim(i:byte);
var j:byte;
begin
 if i>m then check
 else for j:=1 to 9 do
 begin
 a[i]:= j; tim(i+1);
 end;
end;
procedure xuly;
begin
 assign(f,fo); rewrite(f);
 tim(1); write(f,0); close(f);
end;
BEGIN
 khoitao; xuly;
END.

BÀI 2:
program doico;
const
 tfi = 'BAI2.INP';
 tfo = 'BAI2.OUT';
 maxN = 1000;

var
 fi, fo : text;
 N : integer;
 dd,x,a,b,csA,csB : array[1..maxN] of integer;
 DiemMax : integer;

procedure Docdl;
var i: integer;
begin
 assign(fi,tfi); reset(fi);
 readln(fi,N);
 for i:=1 to N do read(fi,a[i],b[i]);
 close(fi);
end;

procedure Doi(var u,v: integer);
var w: integer;
begin
 w:=u;
 u:=v;
 v:=w;
end;

procedure SortA(k,l: integer);
var i,j,mid: integer;
begin
 mid:=a[(k+l) div 2];
 i:=k; j:=l;
 repeat
 while a[i]<mid do inc(i);
 while a[j]>mid do dec(j);
 if i<=j then
 begin
 Doi(a[i],a[j]);
 Doi(csA[i],csA[j]);
 inc(i);
 dec(j);
 end;
 until i>j;
 if j>k then SortA(k,j);
 if i<l then SortA(i,l);
end;

procedure SapxepA;
var i: integer;
begin
 for i:=1 to N do csA[i]:=i;
 SortA(1,N);
end;

procedure SortB(k,l: integer);
var i,j,mid: integer;
begin
 mid:=b[(k+l) div 2];
 i:=k;
 j:=l;
 repeat
 while b[i]>mid do inc(i);
 while b[j]<mid do dec(j);
 if i<=j then
 begin
 Doi(b[i],b[j]);
 Doi(csB[i],csB[j]);
 inc(i);
 dec(j);
 end;
 until i>j;
 if j>k then SortB(k,j);
 if i<l then SortB(i,l);
end;

procedure SapXepB;
var i: integer;
begin
 for i:=1 to N do csB[i]:=i;
 SortB(1,n);
end;

function TimA(r: integer): integer;
var i: integer;
begin
 for i:=n downto 1 do
 if (dd[csA[i]]=0) and (a[i]<r) then
 begin
 TimA:=i;
 exit;
 end;
 for i:=n downto 1 do
 if (dd[csA[i]]=0) and (a[i]=r) then
 begin
 TimA:=i;
 exit;
 end;
 TimA:=0;
end;

procedure Ghep;
var j,limit,i,k: integer;
begin
 fillchar(dd,sizeof(dd),0);
 fillchar(x,sizeof(x),0);
 i:=1;
 DiemMax:=0;
 limit:=n;
 repeat
 k:=TimA(b[i]);
 if k>0 then
 begin
 x[csA[k]]:=csB[i];
 dd[csA[k]]:=1;
 if b[i]>a[k] then inc(DiemMax,2) else inc(DiemMax,1);
 limit:=k-1;
 inc(i);
 end;
 until k=0;
 for j:=i to N do
 begin
 repeat inc(k) until dd[k]=0;
 x[k]:=csB[j];
 end;
end;

procedure inkq;
var i: integer;
begin
 assign(fo,tfo); rewrite(fo);
 writeln(fo,diemMax);
 for i:=1 to N do writeln(fo,x[i]);
 close(fo);
end;

BEGIN
 Docdl;
 SapXepA;
 SapXepB;
 Ghep;
 Inkq;
END.
II. Hướng dẫn chấm.
Bài 1: 5 Test, mỗi test đúng cho 2 điểm
Bài 2: 5 Test, mỗi test đúng cho 2 điểm
Chú ý: Kết quả có thể có nhiều phương án khác nhau do đó yêu cầu giám khảo xem xét kỹ khi chấm bài.


---- Hết ----