Thứ Hai, 7 tháng 12, 2015

lời giải 100 bài (tiếp theo)

Bài 63/2001 - Tìm số nhỏ nhất
(Dành cho học sinh Tiểu học)
a. Số đó chia hết cho 9 nên tổng các chữ số của nó phải chia hết cho 9. Ta thấy tổng 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 = 45 chia hết cho 9. Vậy số nhỏ nhất bao gồm tất cả các chữ số 0, 1, 2, ..., 9 mà chia hết cho 9 là: 1023456789.
b. Số này chia hết cho 5 nên tận cùng phải là 0 hoặc 5. Nếu tận cùng là 5 thì số nhỏ nhất sẽ là 1023467895 còn nếu số đó tận cùng là 0 thì số nhỏ nhất sẽ là123457890.
So sánh hai số trên, suy ra số nhỏ nhất phải tìm là: 1023467895
c. Một số chia hết cho 20, do đó phải chia hết cho 10. Suy ra số đó phải là số nhỏ nhất tận cùng là 0. Mặt khác, chữ số hàng chục của số đó phải là một số chẵn.  Vì vậy ta tìm được số phải tìm là 1234567980.

Bài 64/2001 - Đổi ma trận số
(Dành cho học sinh THCS và PTTH)
Program DoiMT;
Uses Crt;
Const nmax=50;
      inp='INPUT.TXT'; {Du lieu duoc nhap vao file input.txt}
Type Mang=array [1..nmax,1..nmax] of real;
Var a,b,c: Mang;
    n,i,j: integer;

Procedure Nhap;
Var i,j: integer;
    f: text;
Begin
  Assign(f,inp); Reset(f);
  Readln(f,n);
  For i:=1 to 2*n do
   begin
     For j:=1 to 2*n do Read(f,c[i,j]);
     Readln(f);
   end;
  Close(f);
End;
Procedure Xuat(a: Mang);
Var i,j: integer;
Begin
  For i:=1 to 2*n do
  begin
   For j:=1 to 2*n do Write(a[i,j]:8:2);
   Writeln;
  end;
End;
BEGIN
 Nhap;
 For i:=1 to n do
  For j:=1 to n do
  begin
    a[i+n,j+n]:=c[i,j];
    a[i,j+n]:=c[i+n,j];
    a[i,j]:=c[i+n,j+n];
    a[i+n,j]:=c[i,j+n];
    b[i,j]:=c[i+n,j];
    b[i,j+n]:=c[i,j];
    b[i+n,j+n]:=c[i,j+n];
    b[i+n,j]:=c[i+n,j+n];
  end;
 ClrScr;
 Xuat(c); {mang ban dau}
 Writeln;
 Xuat(a);
 Writeln;
 Xuat(b);
 Readln;
END.

(Lời giải của bạn Lê Thanh Tùng - Vĩnh Yên - Vĩnh Phúc)

 


Bài 65/2001 - Lưới ô vuông vô hạn

(Dành cho học sinh THCS và PTTH)
Program bai65;
uses crt;
var
   a:array[1..100,1..100] of integer;
   b,i,j,n,m,k:integer;
   f:text;
   t:boolean;
Begin
 clrscr;
 write('Nhap so n: '); readln(n);
 write('Nhap so m: '); readln(m);
 for i:=1 to m do
  for j:=1 to n do a[i,j]:=-1;
 for i:=m downto 1 do
  for j:=1 to n do
    begin
       b:=-1;
       repeat
        inc(b); t:=true;
        for k:=1 to n do if a[i,k]=b then t:=false; {kt hang}
        for k:=1 to m do if a[k,j]=b then t:=false; {kt cot}
       until t;
       a[i,j]:=b;
    end;
  assign(f,'KQ.TXT');
  rewrite(f);
  for i:=1 to m do
   begin
       for j:=1 to n do write(f,a[i,j]:5);
       writeln(f);
   end;
  close(f);
  write('Mo file KQ.TXT de xem ket qua!');
  readln;
END.
(Lời giải của bạn Nguyễn Trường Đức Trí)

Bài 66/2001 - Bảng số 9 x 9

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

Ta sẽ điền vào các ô ở cột thứ năm các số lớn nhất có thể được. Nếu số lớn nhất trong các cột còn lại (chưa điền vào bảng) là a, thì số lớn nhất có thể điền vào cột thứ năm là a- 4 vì các số phải điền theo thứ tự tăng dần theo hàng mà sau cột thứ 5 còn có 4 cột nữa. Ta thực hiện điền các số giảm dần từ 81 vào nửa phải của bảng trước, sau đó dễ dàng điền vào nửa còn lại với nhiều cách khác nhau:
   
1
2
3
4
77
78
79
80
81
5
6
7
8
72
73
74
75
76
9
10
11
12
67
68
69
70
71
13
14
15
16
62
63
64
65
66
17
18
19
20
57
58
59
60
61
21
22
23
24
52
53
54
55
56
25
26
27
28
47
48
49
50
51
29
30
31
32
42
43
44
45
46
33
34
35
36
37
38
39
40
41
 Program bai66;
 Uses  ctr ;
 Var i,j : integer ;
  Begin
    Clsscr;
    for i:= 1 to do
     begin
        for j:= 1to 4 do write (4*(i-1) + j :3);       
        for j:= 0 to 4 do write (81-4*i-(i-1)+j :3) ;
        Writeln;
     end ;
    Write (‘tong cac so o cot 5: ‘,(37+77)*9div2);
    Readln
 End.   
(Lời giải của bạn  Nguyễn Chí Thức -  Lớp 11A1 - Khối PTCTT - ĐHSPHN - Thôn Đại Đồng - xã Thuỵ Phương - Từ Liêm - Hà Nội)

Bài 67/2001 - Về các phép biến đổi "Nhân 2 trừ 1"

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

Để biến đổi ma trận A thành 0, ta biến đổi từng cột thành 0
Xét một cột bất kì có n số a1, ..., an (ai >= 0)
Đặt X = max(a1, ..., an).
 - Bước 1:
   + Nếu dãy a1, ..., an có một số 0 và một số khác 0, dừng ở đây vì không thể đưa A về 0;   
- Bước 2:
   + Nếu dãy a1, ..., an có ai = 0 (i = 1..n) thì cột này đã được biến đổi xong, qua cột tiếp theo,
   + Nếu không thì ai = 2ai nếu 2ai <= X (nhân hàng có chứa số ai lên 2), tiếp tục thực hiện đến khi không nhân được nữa, qua  bước 3; 
  - Bước 3:
            X:= X-1;
            ai:= ai-1;
Quay lại bước 2.
Đây không phải là lời giải tốt ưu nhưng rất đơn giản, dễ dàng cài đặt (việc viết chương trình tương đối đơn giản)
Nhận xét: Bài này thực sự dễ nếu chỉ dừng lại ở mức tìm thuật toán? Nếu đặt lại điều kiện là có thể nhân hàng, cột cho 2, trừ hàng, cột cho 1, tìm lời giải tối ưu với giới hạn của M, N thì hay hơn nhiều.
(Lời giải của bạn Vũ Lê An - Lớp 11T2 - Lê Khiết - Quảng Ngãi)
Thuật toán của bạn Vũ Lê An rất đúng. Song trên thực tế thuật toán này còn một điểm chưa chuẩn vì nếu các số của mảng số thì nhỏ, số thì lớn thì thuật toán này mất rất nhiều bước. Việc nhân có thể gây ra tràn số.
Ví dụ:
2 3
1      100     1
100   1        100
số bước sẽ rất lớn.
Nhưng thuật toán này trên lý thuyết là giải được. Chương trình theo thuật toán trên.
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q+,R+,S+,T-,V+,X+,Y+}
{$M 16384,0,655360}
program bai67_bien_doi_mang; {Author : Nguyen Van Chung}
uses crt;
const           max             =100;
                fi              ='bai67.inp';
                fo              ='bai67.out';
var             a               :array[1..max,1..max]of longint;
                m,n             :integer;

procedure docf;
var f     :text;
    i,j   :integer;
 begin
   assign(f,fi);
   reset(f);
   read(f,m,n);
   for i:=1 to m do
    for j:=1 to n do read(f,a[i,j]);
   close(f);
 end;

procedure lam;
var  f           :text;
     i,j,ma,mi,k :longint;
 begin
   assign(f,fo);
   rewrite(f);
   for j:=1 to n do
     begin
       ma:=0;mi:=maxlongint;
       for i:=1 to m do
         begin
           if a[i,j]>ma then ma:=a[i,j];
           if a[i,j]<mi then mi:=a[i,j];
         end;
       if (ma>0)and(mi=0) then
         begin
           rewrite(f);
           writeln(f,'No solution');
           break;
         end;
       repeat
        for i:=1 to m do
         begin
           while a[i,j]*2<=ma do
             begin
               for k:=1 to n do a[i,k]:=a[i,k]*2;
               writeln(f,'nhan 2 dong :',i);
             end;
           a[i,j]:=a[i,j]-1;
         end;
        dec(ma);
        writeln(f,'tru 1 cot :',j);
       until ma=0;
     end;
   close(f);
 end;

BEGIN
  docf;
  lam;
END.

Bài 68/2001 - Hình tròn và bảng vuông
(Dành cho học sinh PTTH)
+ Tính số ô vuông bị cắt bởi hình tròn:
 Nếu trục toạ độ là (0,0) thì tâm vòng tròng có toạ độ (n,n). Xét 1 phần 4 vòng tròn từ 6 giờ đến  giờ ô bị cắt là ô có đỉnh (i,j) nằm ngoài vònh tròn và 1 đến 3 đỉnh (i+1, j), (i, j+1), (i+1, j+1) trong vòng tròn. Do tính đối xứng ta chỉ cần tính số ô của 1 phần 4 vòng tròn rồi nhân với 4. Tuy nhiên nếu nhận xét kĩ hơn ta thấy với n = 2, số ô bị cắt là 12, khi n tăng 1 đơn vị, số ô bị cắt tăng lên 8 ô. Do đó ta có thể tính thẳng số ô bị cắt bằng công thức : Số ô bị cắt =12 + (n-2)*8
+ Tính số ô nằm trong vòng tròn:
Cũng do tính đối xứng ta chỉ cần tính số ô nằm trong 1 phần 4 vòng tròn rồi nhân với 4, ô nằm trong vòng tròn khi tất cả 4 đỉnh nằm trong vòng tròn.
Chương trình Pascal
Uses Ctr;
Const S1 =’INPUT.TXT’;
S2=’OUTPUT.TXT’;
VarF1F2: text;
I,J,N : word;
Dem :longint;
FunctionTrong(X,Y: longint): boolean;
Begin
Trong:= 4*(sqr(X-N)+sqr(Y-N))<=sqr(2*N-1);
End
BEGIN
Clrscr;
Assign(F1,S1);
Reset(F1);
Assign(F2,S2);
Rewrite(F2);
While not eof(F1) do
Begin
Readln(F1,N);
Write(F2,’N=,’=>’,12+((N-2)*8));
Dem:= 0;
For I:= 0 to N-1 do
For J:= 0 to J-1 do
If Trong (I,J) and Trong (I+1,J) and Trong (I,J+1) and Trong (I+1, J+1) then(Dem)
Writeln(F2,’’,Dem*4);
End;
Close(F1);
Close(F2);
End.
(Lời giải của bạn Lâm Tấn Minh Tâm - 12 Tin trường PTTH Chuyên Tiền Giang- Tiền Giang)

Bài 69/2001 - Bội số của 36
(Dành cho học sinh Tiểu học)
Một số đồng thời chia hết cho 4 và 9 thì sẽ chia hết cho 36 (vì 4 và 9 nguyên tố cùng nhau: (4, 9) = 1).
Ta thấy, tổng của tất cả các số từ 1 đến 9 = 1 + 2 + ... + 9 = 45 chia hết cho 9.
Một số chia hết cho 4 khi và chỉ khi hai chữ số cuối cùng của nó chia hết cho 4. Mà ta cần tìm số nhỏ nhất chia hết cho 36, do đó số đó phải là số nhỏ nhất có đầy đủ các chữ số từ 1 đến 9 và hai số cuối cùng của nó phải là một số chia hết cho 4. Vậy số phải tìm là: 123457896

Bài 70/2001 - Mã hoá theo khoá
(Dành cho học sinh THCS và THPT)
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q+,R+,S+,T-,V+,X+}
{$M 16384,0,655360}
uses crt;
   Const  MaxVal=256;
   Var
       n:Integer; S,KQ:String;
       a:array[0..MaxVal] of Integer;
Procedure InPut;
   Var i:Integer;
Begin
   CLrscr;
   Write('Nhap N=');Readln(n);
   For i:=1 to n do
     Begin  Write('a[',i,']=');Readln(a[i]); End;
   Write('Nhap Xau:');Readln(S);
End;
Procedure Main;
   Var  i,j:Integer;
Begin
 if (Length(S) Mod n) <>0 then
  For i:=1 to n-(Length(S) Mod n) do S:=S+' ';
 KQ:='';
 For i:=0 to (Length(S) Div n)-1 do
  For j:=(n*i)+1 to n*(i+1) do
    KQ:=KQ+S[a[j-(n*i)]+(n*i)];
 Writeln('Xau Ma Hoa: ',KQ);
End;
Begin
    InPut;
    Main;
    Readln;
End.
(Lời giải của bạn Nguyễn Cao Thắng - Lớp 12A2 chuyên Vĩnh Phúc - tỉnh Vĩnh Phúc)

Bài 71/2001 - Thực hiện phép nhân
Program Thuc_hien_phep_nhan;
Uses Crt;
Type   so = 0..9;
Var    a,b,c,d: string;
       can,i: byte;
Procedure Nhap;
Begin
  Clrscr;
  Write('Nhap so a : '); Readln(a);
  Write('Nhap so b : '); Readln(b);
  Writeln('Phep nhan a va b : ');
  can:=length(a)+length(b)+1;
  Writeln(a:can);
  Writeln('X');
  Writeln(b:can);
  For i:=1 to can do Write('-');
  Writeln;
End;
Procedure Nhan(a: string; k: so);
Var nho: so;
    x,i: byte;
Begin
  nho:=0;
  c:='';
  For i:=length(a) downto 1 do
    Begin
      x:=(ord(a[i])-48)*k+nho;
      nho:=x div 10;
      c:=chr((x mod 10)+48)+c;
    End;
  If nho>0 then c:=chr(nho+48)+c;
  Writeln(c:can);
  can:=can-1;
End;
Procedure Cong(var c,d: string; z:byte);
Var nho: so;
    x,i: byte;
Begin
  for i:=1 to length(b)-z do c:=c+'0';
  If length(c) > length(d) then
    For i:=1 to length(c)-length(d) do d:='0'+d
  Else
    For i:=1 to length(d)-length(c) do c:='0'+c;
  nho:=0;
  For i:=length(d) downto 1 do
    Begin
      x:=ord(d[i])+ord(c[i])-96+nho;
      d[i]:=chr((x mod 10)+48);
      nho:=x div 10;
    End;
  If nho>0 then d:='1'+d;
End;
Begin
  Nhap;
  d:='';
  For i:=length(b) downto 1 do
    Begin
      Nhan(a,ord(b[i])-48);
      Cong(c,d,i);
    End;
  can:=length(a)+length(b)+1;
  For i:=1 to can do Write('-');
  Writeln;
  Writeln(d:can);
  Readln;
End.
(Lời giải của bạn Đặng Trung Thành - PTTH Nguyễn Du - Buôn Mê Thuột)

Bài 72/2001 - Biến đổi trên lưới số
const Inp ='bai72.inp';
      Out ='bai72.out' ;
      maxn=100;
Var dem, n, i, j, d:integer; f:text;
    a:array[0..maxn+1,0..maxn+1] of Boolean;
Procedure Init;
Var t:integer;
Begin
  Fillchar(a, Sizeof(a), true);
  Assign(f, inp); reset(f);
  dem:=0;
  Readln(f, n);
  for i:= 1 to n do
   for j:=1 to n do
   begin
      read(f, t);
      If t=1 then a[i,j]:=true else begin a[i,j]:=false;inc(dem); end;
      If j=n then readln(f);
   end;
Close(f);
End;
Procedure Solve1;
Begin
  for i:=1 to n do
  for j:=1 to n do
  begin
    If not a[i,j] then
    begin
       a[i,j]:= not (a[i,j-1] xor a[i,j+1] xor a[i-1,j] xor a[i+1,j]);
       If a[i,j] then begin dec(dem);writeln(f,i,' ',j) end
    end;
  end;
End;
Procedure Solve2;
Begin
  for i:=1 to n do
   for j:=1 to n do
   If not a[i,j] then
   begin
     If i >1 then
     begin
        a[i-1,j]:=false;
        inc(dem);
        writeln(f, i-1, ' ', j);
     end
     else 
       If i <n then
       begin
         a[i+1,j]:=false;
         inc(dem);
         writeln(f, i+1, ' ', j);
       end
       else
         If j >1 then
         begin
            a[i,j-1]:=false;
            inc(dem);
            writeln(f, i, ' ', j-1);
         end
           else 
          begin a[i,j+1]:=false; inc(dem); writeln(f, i, ' ', j+1) end;
 exit;
 end;
End;
BEGIN
  Init;
  Assign(f,out); rewrite(f);
  While dem >0 do
  begin
     writeln(dem); d:=dem; solve1;
     If (d=dem) and (dem >0) then solve2;
  end; Close(f);
END.
(Lời giải của bạn Nguyễn Chí Thức - khối PTCTT - ĐHSP - Hà Nội)

Bài 73/2001 - Bài toán chuỗi số

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

Hai số cuối là 59 và 65.
Giải thích: Chuỗi số được tạo ra từ việc cộng các số nguyên tố (ở hàng trên) với các số không phải là nguyên tố (hàng dưới), cụ thể như sau:

 

 

Bài 74/2001 -  Hai hàng số kỳ ảo

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

Tổng các số từ 1 đến 2n: 1 + 2 + … + 2n = (2n*(2n+1))/2 = n*(2n+1).
Do đó, để hai hàng có tổng bằng nhau thì tổng của mỗi hàng phải là: (n*(2n+1))/2, như vậy n phải là số chẵn thì mới tồn tại hai hàng số kì ảo.
Tổng của n cột bằng nhau nên tổng của mỗi cột sẽ là: 2n+1.
ứng với một số A[i] (A[i] = 1, 2, …, 2n) chỉ tồn tại duy nhất một số B[i] = 2n -(A[i] -1) sao cho: A[i] + B[i] = 2n + 1;
Toàn bộ chương trình lời giải:
Program bai74;
uses crt;
var n:byte;
    a:array[1..100]of 0..1;
    th:array[0..50]of byte;
    ok:boolean;
    s:integer;
Procedure xet;
var i,j,tong:integer;
    duoc:boolean;
Begin
tong:=0;
for j:=1 to n do tong:=tong+th[j];
if tong=s div 2 then
begin
  duoc:=true;
  for j:=1 to n-1 do
   for i:=j+1 to n do
    if th[j]+th[i]=(s div n) then duoc:=false;
  if duoc then
   begin
       for i:=1 to n do write(th[i]:3);
       writeln;
       for i:=1 to n do write(((s div n)-th[i]):3);
       ok:=true;
   end;
 end;
end;
Procedure try(i:byte);
 var j:byte;
Begin
 if i>n then xet
 else if not ok then
        for j:=th[i-1]+1 to 2*n do
         begin
             th[i]:=j;
             try(i+1);
          end;
End;
Procedure xuli;
var i:byte;
Begin
 th[0]:=0;
 ok:=false;
 s:=n*(2*n)+1;
 try(1);
 if ok=false then write('Khong the sap xep');
End;
BEGIN
 clrscr;
 write('Nhap n:');readln(n);
 if n mod 2 =1 then writeln('Khong the sap xep')
 else xuli;
 readln;
END.

(Lời giải của bạn Hoàng Phương Nhi  - PTTH chuyên Lý Tự Trọng - Cần Thơ)


Nhận xét: Cách làm của bạn Hoàng Phương Nhi  - PTTH chuyên Lý Tự Trọng - Cần Thơ dùng thuật toán duyệt nên chạy không được lớn. Với N = 20 thì chương trình chạy rất lâu, nếu N lớn hơn nữa thì không thể ra được kết quả. Bạn có thể cải tiến chương trình này bằng cách kiểm tra các điều kiện ngay trong quá trình duyệt để giảm bớt thời gian duyệt.
Cách làm khác dùng thuật toán chia kẹo chạy rất nhanh với N<35.
Tổng các số từ 1 đến 2n: 1 + 2 + .. + 2n = (2n*(2n+1))/2 = n*(2n+1).
Do đó, để hai hàng có tổng bằng nhau thì tổng của mỗi hàng phải là: (n*(2n+1))/2, như vậy n phải là số chẵn thì mới tồn tại hai hàng số kì ảo.
Tổng của n cột bằng nhau nên tổng của mỗi cột sẽ là: 2n+1.
ứng với một số A[i] (A[i] = 1, 2,.., 2n) chỉ tồn tại duy nhất một số B[i] = 2n -(A[i] -1) sao cho: A[i] + B[i] = 2n + 1
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q+,R+,S+,T-,V+,X+,Y+}
{$M 16384,0,655360}
uses crt;

const     max  =35;
             fi    = 'bai74.inp';
             fo   = 'bai74.out';

var          d   : array[0..max*(2*max+1) div 2] of byte;
             tr   : array[1..max,0..max*(2*max+1) div 2]of byte;
             kq  : array[1..max]of integer;
             n,sum  : integer;
             ok   : boolean;

procedure docf;
var  f    :text;
 begin
   ok:=false;
   assign(f,fi);
   reset(f);
   read(f,n);
   close(f);
 end;

procedure lam;
var i,j   :integer;
 begin
   sum:=n*(2*n+1) div 2;
   fillchar(d,sizeof(d),0);
   fillchar(tr,sizeof(tr),0);
   d[0]:=1;
   for i:=1 to n do
     begin
       for j:=sum-i downto 0 do
        if d[j]=1 then
          begin
            d[j+i]:=2;
            tr[i,j+i]:=1;
          end;

       for j:=sum-(2*n+1-i) downto 0 do
        if d[j]=1 then
          begin
            d[j+2*n+1-i]:=2;
            tr[i,j+2*n+1-i]:=2;
          end;
       for j:=0 to sum do
        if d[j]>0 then dec(d[j]);
     end;
   ok:=(d[sum]=1);
 end;

procedure ghif;
var  f    :text;
     i,j  :integer;
 begin
    assign(f,fo);
    rewrite(f);
    if ok=false then write(f,'No solution')
     else
       begin
         i:=sum;j:=n;
         while i>0 do
           begin
             if tr[j,i]=1 then kq[j]:=j else kq[j]:=2*n+1-j;
             i:=i-kq[j];
             dec(j);
           end;
         for j:=1 to n do write(f,kq[j]:6);
         writeln(f);
         for j:=1 to n do write(f,(2*n+1-kq[j]):6);
       end;
    close(f);
 end;

BEGIN
   docf;
   if n mod 2=0 then lam;
   ghif;
END.

Bài 75/2001 - Trò chơi Tích - Tắc vuông

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

(* Thuat toan:
Chia ban co lam 4 huong: Dong , Tay , Nam , Bac. Ta co cach di sau:
i)  Luon di theo o lien canh voi o truoc
ii)  Di theo huong khong bi chan. Vi du: o buoc 1 neu bi chan o huong Dong
thi di theo huong nguoc lai la huong Tay. Di theo huong Tay den khi huong Tay bi chan thi di theo huong Bac hoac Nam.
Trong khi di ta luon de y 2 dieu kien sau:
1. Neu co 3 o da lap thanh 3 dinh cua 1 hinh vuong ma o thu 4 chua bi di
thi ta se di o thu 4 va gianh duoc thang loi.
2. Neu co 2k+1(k>=1) o lien canh lien tiep thi kiem tra co the gianh thang
loi bang nuoc do^i khong? Nuoc do^i la nuoc ta danh vao 1 o nhung co the co duoc 2 hinh vuong. vi du: co 3 o (1,1);(1,2);(1,3) thi ta co the danh nuoc doi bang cach danh vao o (2,2) nhu vay ta co kha nang hinh thanh 2 o vuong. Nhung sau 1 nuoc di doi thi chi duy nhat chan duoc 1 o vuong, ta co the danh nuoc tiep theo de hinh thanh o vuong con lai va gianh duoc thang loi.
  Bang cach danh nhu vay ban co the chien thang trong vong toi da la 10 nuoc.*)
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R+,S+,T-,V+,X+}
{$M 16384,0,655360}
CONST Min=-50;
      Max=50;
TYPE Ma=Array[Min..Max,Min..Max] of char;
     diem= Record
            hg,cot:Integer;
           End;
     Qu=Array[1..Max] of diem;
VAR dmay,dng,dc1,dc2:diem;
    hgdi:Integer; (*1:B ; 2:D ; -1:N ; -2:T*)
    fin,ok:Boolean;
    A:Ma;
    Q,Qc:Qu;
    dlt,dq,cq:Integer;
Procedure HienA(hgd,hgc,cotd,cotc:Integer);
Var i,j:Integer;
 Begin
      For i:=hgd to hgc do
       Begin
            For j:=cotd to cotc do Write(A[i,j],' ');
            Writeln;
       End;
 End;
Procedure finish(d:diem);
 Begin
  A[d.hg,d.cot]:='x';
  HienA(-10,10,-10,10);
  Writeln('Ban da thua! An ENTER de ket thuc chuong trinh');
  Readln;
  Halt;
 End;
Procedure Init;
 Begin
  Fillchar(A,sizeof(A),'.');
  fin:=false;
   Writeln('Gia thiet bang o vuong co: 101 hang (-50 -> 50)');
   Writeln('                           101 cot  (-50 -> 50)');
   Writeln('Gia thiet may luon di nuoc dau tien tai o co toa do (0:0)');
  dmay.hg:=0; dmay.cot:=0; A[dmay.hg,dmay.cot]:='X';
  HienA(-10,10,-10,10);
  dlt:=1;
 End;
Procedure Sinh(d1:diem; Var d2:diem; hgdi,k:integer);
Var h,c:Integer;
 Begin
  h:=d1.hg; c:=d1.cot;
  Case hgdi of
   1: Dec(h,k);
   2: Inc(c,k);
  -1: Inc(h,k);
  -2: Dec(c,k);
  End;
  d2.hg:=h; d2.cot:=c;
 End;
Function kt(Var d1,d2:diem):boolean;
Var g1,g,g2:diem;
    k,p:integer;
 Begin
  kt:=true;
  k:=(dlt-1) div 2;
  p:=2 div abs(hgdi);
  sinh(dmay,g1,-hgdi,k);
  sinh(dmay,g2,-hgdi,2*k);
  sinh(g1,g,p,k);
  sinh(dmay,d1,p,k);
  sinh(g2,d2,p,k);
  If (A[d1.hg,d1.cot]='.')and(A[g.hg,g.cot]='.')and(A[d2.hg,d2.cot]='.')then
    begin A[g.hg,g.cot]:='x'; HienA(-10,10,-10,10); exit; end;
  sinh(g1,g,-p,k);
  sinh(dmay,d1,-p,k);
  sinh(g2,d2,-p,k);
  If (A[d1.hg,d1.cot]='.')and(A[g.hg,g.cot]='.')and(A[d2.hg,d2.cot]='.')then
    begin A[g.hg,g.cot]:='x'; HienA(-10,10,-10,10); exit; end;
  kt:=false;
 End;
Procedure Ngdi;
 Begin
  Repeat
   Write('Nhap toa do diem (hang,cot): '); Readln(dng.hg,dng.cot);
  Until (dng.hg>=Min)and(dng.hg<=Max)and(dng.cot>=Min)and(dng.cot<=Max)and(A[dng.hg,dng.cot]='.');
   A[dng.hg,dng.cot]:='1'; HienA(-10,10,-10,10);
 End;
Function Hgchan:Integer;
Var Hgc:Integer;
Begin
If dmay.cot<dng.cot then
Begin
Hgc:=2;
If Hgc=hgdi then Begin Hgchan:=Hgc; Exit; End;
End;
If dmay.cot>dng.cot then
Begin
Hgc:=-2;
If Hgc=hgdi then Begin Hgchan:=Hgc; Exit; End;
End;
If dmay.hg<dng.hg then
Begin
Hgc:=-1;
If Hgc=hgdi then Begin Hgchan:=Hgc; Exit; End;
End;
If dmay.hg>dng.hg then
Begin
Hgc:=1;
If Hgc=hgdi then Begin Hgchan:=Hgc; Exit; End;
End;
Hgchan:=Hgc;
End;
Procedure Nap(Var Q:Qu; d1:diem; hgdi,k:Integer);
Var h,c:Integer;
    d2:diem;
 Begin
  Sinh(d1,Q[cq],hgdi,k);
 End;
Procedure Maydi;
 Begin
  Inc(dq);
  if not ok then
   Begin
    If Q[dq].hg<dmay.hg then hgdi:=1
    Else If Q[dq].hg>dmay.hg then hgdi:=-1
         Else If Q[dq].cot<dmay.cot then hgdi:=-2
              Else If Q[dq].cot>dmay.cot then hgdi:=2;
   End;
  dmay:=Q[dq];
  A[q[dq].hg,q[dq].cot]:='x';
  HienA(-10,10,-10,10)
 End;
Procedure Process;
Var Hgc,p,i,ntt:Integer;
 Begin
  ok:=true; ntt:=0;
  Ngdi;
  Hgc:=Hgchan; Hgdi:=-Hgc;
  Inc(cq); Nap(Q,dmay,hgdi,1); Maydi; Inc(dlt);
   Repeat
         Ngdi; Hgc:=Hgchan;
         If ntt=1 then
          If A[dc1.hg,dc1.cot]='.' then finish(dc1)
          Else finish(dc2);
         If ntt=0 then If (dlt>=3) and (kt(dc1,dc2)) then ntt:=1;
         If (Hgc=Hgdi) then
           If ok then
            Begin
                 p:=2 div abs(Hgc);
                 For i:=1 to dlt-1 do
                     Begin
                          Inc(cq); Nap(Q,dmay,p,i); Nap(Qc,Q[cq],-hgdi,i);
                          Inc(cq); Nap(Q,dmay,-p,i);Nap(Qc,Q[cq],-hgdi,i);
                     End;
                 ok:=false;
                 dlt:=1;
            End
           Else
            Begin
             hgdi:=-hgdi; Inc(cq); Nap(Q,dmay,hgdi,dlt);
            End;
         If ntt=0 then
          Begin
           If dq=cq then Begin Inc(cq); Nap(Q,dmay,hgdi,1); End;
           If A[Qc[dq].hg,Qc[dq].cot]='.' then finish(Qc[dq]);
           Maydi; Inc(dlt);
          End;
   Until fin;
 End;
BEGIN
 Init;
 Process;

END.

Không có nhận xét nào:

Đăng nhận xét